FFI::Platypus::Type::LPCWSTR

package FFI::Platypus::Type::LPCWSTR;

use strict;
use warnings;

use Config                qw( %Config );
use Encode                qw( decode encode );
use FFI::Platypus::Buffer qw( scalar_to_pointer );

use constant PTR_SIZE => $Config{ptrsize};

use constant PTR_PACK_FORMAT =>
     PTR_SIZE == 8 ? 'Q'
   : PTR_SIZE == 4 ? 'L'
   : die("Unrecognized ptrsize\n");

my @stack;  # To keep buffer alive.

sub strlenW {
   my ($ptr) = @_;

   # typedef uint16_t WCHAR;
   # typedef const WCHAR *LPCWSTR;
   #
   # size_t len = 0;
   # for (; *ptr; ++ptr)
   #    ++len;

   my $len = 0;
   for (; unpack('S', unpack('P2', pack(PTR_PACK_FORMAT, $ptr))); $ptr += 2) {
      ++$len;
   }

   return $len;
}

sub perl_to_native {
   if (defined($_[0])) {
      my $buf = encode('UTF-16le', $_[0]."\0");
      push @stack, \$buf;
      return scalar_to_pointer($buf);
   } else {
      push @stack, undef;
   }
}

sub perl_to_native_post {
   pop @stack;
}

sub native_to_perl {
   return undef if !defined($_[0]);
   return decode('UTF-16le', unpack('P'.strlenW($_[0]), pack(PTR_PACK_FORMAT, $_[0])));
}

sub ffi_custom_type_api_1 {
   return {
      native_type         => 'opaque',
      perl_to_native      => \&perl_to_native,
      perl_to_native_post => \&perl_to_native_post,
      native_to_perl      => \&native_to_perl,
   }
}

1;