File Coverage

blib/lib/FFI/Platypus/Type/WideString.pm
Criterion Covered Total %
statement 87 91 95.6
branch 24 32 75.0
condition 3 4 75.0
subroutine 15 15 100.0
pod 0 1 0.0
total 129 143 90.2


line stmt bran cond sub pod time code
1             package FFI::Platypus::Type::WideString;
2              
3 2     2   974 use strict;
  2         4  
  2         50  
4 2     2   10 use warnings;
  2         3  
  2         42  
5 2     2   28 use 5.008004;
  2         6  
6 2     2   636 use FFI::Platypus;
  2         4  
  2         74  
7 2     2   416 use FFI::Platypus::Memory qw( memcpy );
  2         5  
  2         148  
8 2     2   757 use FFI::Platypus::Buffer qw( buffer_to_scalar scalar_to_pointer scalar_to_buffer );
  2         4  
  2         109  
9 2     2   11 use Encode qw( decode encode find_encoding );
  2         2  
  2         84  
10 2     2   9 use Carp ();
  2         3  
  2         1553  
11              
12             # ABSTRACT: Platypus custom type for Unicode "wide" strings
13             our $VERSION = '2.07'; # VERSION
14              
15              
16             my @stack; # To keep buffer alive.
17              
18             sub _compute_wide_string_encoding
19             {
20 6     6   96 foreach my $need (qw( wcslen wcsnlen ))
21             {
22 12 50       73 die "This type plugin needs $need from libc, and cannot find it"
23             unless FFI::Platypus::Memory->can("_$need");
24             }
25              
26 6         25 my $ffi = FFI::Platypus->new( api => 2, lib => [undef] );
27              
28 6         13 my $size = eval { $ffi->sizeof('wchar_t') };
  6         18  
29 6 50       15 die 'no wchar_t' if $@;
30              
31 6         37 my %orders = (
32             join('', 1..$size) => 'BE',
33             join('', reverse 1..$size) => 'LE',
34             );
35              
36 6         14 my $byteorder = join '', @{ $ffi->cast( "wchar_t*", "uint8[$size]", \hex(join '', map { "0$_" } 1..$size) ) };
  6         17  
  24         64  
37              
38 6         15 my $encoding;
39              
40 6 50       18 if($size == 2)
    50          
41             {
42 0         0 $encoding = 'UTF-16';
43             }
44             elsif($size == 4)
45             {
46 6         10 $encoding = 'UTF-32';
47             }
48             else
49             {
50 0         0 die "not sure what encoding to use for size $size";
51             }
52              
53 6 50       12 if(defined $orders{$byteorder})
54             {
55 6         13 $encoding .= $orders{$byteorder};
56             }
57             else
58             {
59 0         0 die "odd byteorder $byteorder not (yet) supported";
60             }
61              
62 6 50       23 die "Perl doesn't recognize $encoding as an encoding"
63             unless find_encoding($encoding);
64              
65 6         4599 return ($encoding, $size);
66             }
67              
68             sub ffi_custom_type_api_1
69             {
70 4     4 0 12 my %args = @_;
71              
72             # TODO: it wold be nice to allow arbitrary encodings, but we are
73             # relying on a couple of wcs* functions to compute the string, so
74             # we will leave that for future development.
75 4         12 my($encoding, $width) = __PACKAGE__->_compute_wide_string_encoding();
76              
77             # it is hard to come up with a default size for write buffers
78             # but 2048 is a multiple of 1024 that is large enough to fit
79             # any Windows PATH (260*4)+2 = 1042
80             #
81             # (assuming all characters in the PATH are in the BMP, which is
82             # admitedly unlikely, possilby impossible (?) and and a null
83             # termination of two bytes).
84             #
85             # it is arbitrary and based on a platform specific windows
86             # thing, but windows is where wide strings are most likely
87             # to be found, so seems good as anything.
88 4   50     21 my $size = $args{size} || 2048;
89 4   100     12 my $access = $args{access} || 'read';
90              
91 4         11 my %ct = (
92             native_type => 'opaque',
93             );
94              
95             $ct{native_to_perl} = sub {
96 8 100   8   24 return undef unless defined $_[0];
97 7         61 return decode($encoding,
98             buffer_to_scalar(
99             $_[0],
100             FFI::Platypus::Memory::_wcslen($_[0])*$width,
101             )
102             );
103 4         17 };
104              
105 4 100       18 if($access eq 'read')
    50          
106             {
107             $ct{perl_to_native} = sub {
108 28 100   28   1011 if(defined $_[0])
109             {
110 27         107 my $buf = encode($encoding, $_[0]."\0");
111 27         982 push @stack, \$buf;
112 27         55 return scalar_to_pointer $buf;
113             }
114             else
115             {
116 1         3 push @stack, undef;
117 1         4 return undef;
118             }
119 2         9 };
120              
121             $ct{perl_to_native_post} = sub {
122 28     28   47 pop @stack;
123 28         94 return;
124 2         8 };
125              
126             }
127             elsif($access eq 'write')
128             {
129 2         5 my @stack;
130              
131             $ct{perl_to_native} = sub {
132 17     17   4969 my $ref = shift;
133 17 100       48 if(ref($ref) eq 'ARRAY')
    100          
134             {
135 8 100       12 ${ $ref->[0] } = "\0" x $size unless defined ${ $ref->[0] };
  4         7  
  8         33  
136 8         9 my $ptr = scalar_to_pointer ${ $ref->[0] };
  8         21  
137 8 50       18 if(defined $ref->[0])
138             {
139 8         20 my $init = encode($encoding, $ref->[1]);
140 8         290 my($sptr, $ssize) = scalar_to_buffer($init);
141 8         32 memcpy($ptr, $sptr, $ssize);
142             }
143 8         11 push @stack, \${ $ref->[0] };
  8         16  
144 8         26 return $ptr;
145             }
146             elsif(ref($ref) eq 'SCALAR')
147             {
148 8         12 push @stack, $ref;
149 8 100       36 $$ref = "\0" x $size unless defined $$ref;
150 8         20 return scalar_to_pointer $$ref;
151             }
152             else
153             {
154 1         2 push @stack, $ref;
155 1         5 return undef;
156             }
157 2         10 };
158              
159             $ct{perl_to_native_post} = sub {
160 17     17   23 my $ref = pop @stack;
161 17 100       37 return unless defined $ref;
162 16         25 my $len = length $$ref;
163 16         51 $len = FFI::Platypus::Memory::_wcsnlen($$ref, $len);
164 16         47 $$ref = decode($encoding, substr($$ref, 0, $len*$width));
165 2         9 };
166              
167             }
168             else
169             {
170 0         0 Carp::croak("Unknown access type $access");
171             }
172              
173 4         13 return \%ct;
174             }
175              
176             1;
177              
178             __END__