File Coverage

blib/lib/FFI/Platypus/Type/StringArray.pm

Criterion	Covered	Total	%
statement	67	67	100.0
branch	15	16	93.7
condition	1	3	33.3
subroutine	13	13	100.0
pod	0	4	0.0
total	96	103	93.2

package FFI::Platypus::Type::StringArray;

use strict;
use warnings;
use 5.008004;
use FFI::Platypus;

# ABSTRACT: Platypus custom type for arrays of strings
our $VERSION = '2.06_01'; # TRIAL VERSION


use constant _incantation =>
  $^O eq 'MSWin32' && do { require Config; $Config::Config{archname} =~ /MSWin32-x64/ }
  ? 'Q'
  : 'L!';
use constant _size_of_pointer => FFI::Platypus->new( api => 2 )->sizeof('opaque');
use constant _pointer_buffer => "P" . _size_of_pointer;

my @stack;

sub perl_to_native
{
  # this is the variable length version
  # and is actually simpler than the
  # fixed length version
  my $count = scalar @{ $_[0] };
  my $pointers = pack(('P' x $count)._incantation, @{ $_[0] }, 0);
  my $array_pointer = unpack _incantation, pack 'P', $pointers;
  push @stack, [ \$_[0], \$pointers ];
  $array_pointer;
}

sub perl_to_native_post
{
  pop @stack;
  ();
}

sub native_to_perl
{
  return unless defined $_[0];
  my @list;
  my $i=0;
  while(1)
  {
    my $pointer_pointer = unpack(
      _incantation,
      unpack(
        _pointer_buffer,
        pack(
          _incantation, $_[0]+_size_of_pointer*$i
        )
      )
    );
    last unless $pointer_pointer;
    push @list, unpack('p', pack(_incantation, $pointer_pointer));
    $i++;
  }
  \@list;
}

sub ffi_custom_type_api_1
{
  # arg0 = class
  # arg1 = FFI::Platypus instance
  # arg2 = array size
  # arg3 = default value
  my(undef, undef, $count, $default) = @_;

  my $config = {
    native_type => 'opaque',
    perl_to_native => \&perl_to_native,
    perl_to_native_post => \&perl_to_native_post,
    native_to_perl => \&native_to_perl,
  };

  if(defined $count)
  {
    my $end = $count-1;

    $config->{perl_to_native} = sub {
      my $incantation = '';

      my @list = ((map {
        defined $_
          ? do { $incantation .= 'P'; $_ }
          : defined $default
            ? do { $incantation .= 'P'; $default }
            : do { $incantation .= _incantation; 0 };
      } @{ $_[0] }[0..$end]), 0);

      $incantation .= _incantation;

      my $pointers = pack $incantation, @list;
      my $array_pointer = unpack _incantation, pack 'P', $pointers;
      push @stack, [ \@list, $pointers ];
      $array_pointer;
    };

    my $pointer_buffer = "P@{[ FFI::Platypus->new( api => 2 )->sizeof('opaque') * $count ]}";
    my $incantation_count = _incantation.$count;

    $config->{native_to_perl} = sub {
      return unless defined $_[0];
      my @pointer_pointer = unpack($incantation_count, unpack($pointer_buffer, pack(_incantation, $_[0])));
      [map { $_ ? unpack('p', pack(_incantation, $_)) : $default } @pointer_pointer];
    };

  }

  $config;
}

1;

__END__