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


line stmt bran cond sub pod time code
1             package FFI::Platypus::Type::StringArray;
2              
3 1     1   6 use strict;
  1         2  
  1         30  
4 1     1   5 use warnings;
  1         3  
  1         22  
5 1     1   27 use 5.008004;
  1         4  
6 1     1   5 use FFI::Platypus;
  1         2  
  1         123  
7              
8             # ABSTRACT: Platypus custom type for arrays of strings
9             our $VERSION = '2.08'; # VERSION
10              
11              
12             use constant _incantation =>
13 1 50 33     111 $^O eq 'MSWin32' && do { require Config; $Config::Config{archname} =~ /MSWin32-x64/ }
14             ? 'Q'
15 1     1   7 : 'L!';
  1         1  
16 1     1   6 use constant _size_of_pointer => FFI::Platypus->new( api => 2 )->sizeof('opaque');
  1         2  
  1         5  
17 1     1   6 use constant _pointer_buffer => "P" . _size_of_pointer;
  1         2  
  1         615  
18              
19             my @stack;
20              
21             sub perl_to_native
22             {
23             # this is the variable length version
24             # and is actually simpler than the
25             # fixed length version
26 4     4 0 9 my $count = scalar @{ $_[0] };
  4         9  
27 4         12 my $pointers = pack(('P' x $count)._incantation, @{ $_[0] }, 0);
  4         16  
28 4         12 my $array_pointer = unpack _incantation, pack 'P', $pointers;
29 4         10 push @stack, [ \$_[0], \$pointers ];
30 4         18 $array_pointer;
31             }
32              
33             sub perl_to_native_post
34             {
35 16     16 0 28 pop @stack;
36 16         116 ();
37             }
38              
39             sub native_to_perl
40             {
41 4 100   4 0 16 return unless defined $_[0];
42 3         5 my @list;
43 3         5 my $i=0;
44 3         5 while(1)
45             {
46 7         25 my $pointer_pointer = unpack(
47             _incantation,
48             unpack(
49             _pointer_buffer,
50             pack(
51             _incantation, $_[0]+_size_of_pointer*$i
52             )
53             )
54             );
55 7 100       18 last unless $pointer_pointer;
56 4         11 push @list, unpack('p', pack(_incantation, $pointer_pointer));
57 4         7 $i++;
58             }
59 3         19 \@list;
60             }
61              
62             sub ffi_custom_type_api_1
63             {
64             # arg0 = class
65             # arg1 = FFI::Platypus instance
66             # arg2 = array size
67             # arg3 = default value
68 5     5 0 13 my(undef, undef, $count, $default) = @_;
69              
70 5         18 my $config = {
71             native_type => 'opaque',
72             perl_to_native => \&perl_to_native,
73             perl_to_native_post => \&perl_to_native_post,
74             native_to_perl => \&native_to_perl,
75             };
76              
77 5 100       16 if(defined $count)
78             {
79 4         5 my $end = $count-1;
80              
81             $config->{perl_to_native} = sub {
82 12     12   57 my $incantation = '';
83              
84             my @list = ((map {
85             defined $_
86 48         70 ? do { $incantation .= 'P'; $_ }
  48         94  
87             : defined $default
88 6         9 ? do { $incantation .= 'P'; $default }
  6         16  
89 60 100       101 : do { $incantation .= _incantation; 0 };
  6 100       9  
  6         10  
90 12         32 } @{ $_[0] }[0..$end]), 0);
  12         27  
91              
92 12         24 $incantation .= _incantation;
93              
94 12         51 my $pointers = pack $incantation, @list;
95 12         35 my $array_pointer = unpack _incantation, pack 'P', $pointers;
96 12         31 push @stack, [ \@list, $pointers ];
97 12         78 $array_pointer;
98 4         20 };
99              
100 4         8 my $pointer_buffer = "P@{[ FFI::Platypus->new( api => 2 )->sizeof('opaque') * $count ]}";
  4         11  
101 4         15 my $incantation_count = _incantation.$count;
102              
103             $config->{native_to_perl} = sub {
104 4 100   4   15 return unless defined $_[0];
105 3         32 my @pointer_pointer = unpack($incantation_count, unpack($pointer_buffer, pack(_incantation, $_[0])));
106 6 100       9 [map { $_ ? unpack('p', pack(_incantation, $_)) : $default } @pointer_pointer];
  9         52  
107 4         23 };
108              
109             }
110              
111 5         15 $config;
112             }
113              
114             1;
115              
116             __END__