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   1139 use strict;
  2         5  
  2         60  
4 2     2   10 use warnings;
  2         4  
  2         45  
5 2     2   32 use 5.008004;
  2         7  
6 2     2   742 use FFI::Platypus;
  2         5  
  2         58  
7 2     2   456 use FFI::Platypus::Memory qw( memcpy );
  2         40  
  2         131  
8 2     2   908 use FFI::Platypus::Buffer qw( buffer_to_scalar scalar_to_pointer scalar_to_buffer );
  2         5  
  2         131  
9 2     2   13 use Encode qw( decode encode find_encoding );
  2         4  
  2         118  
10 2     2   11 use Carp ();
  2         3  
  2         1998  
11              
12             # ABSTRACT: Platypus custom type for Unicode "wide" strings
13             our $VERSION = '2.08'; # VERSION
14              
15              
16             my @stack; # To keep buffer alive.
17              
18             sub _compute_wide_string_encoding
19             {
20 6     6   127 foreach my $need (qw( wcslen wcsnlen ))
21             {
22 12 50       91 die "This type plugin needs $need from libc, and cannot find it"
23             unless FFI::Platypus::Memory->can("_$need");
24             }
25              
26 6         30 my $ffi = FFI::Platypus->new( api => 2, lib => [undef] );
27              
28 6         16 my $size = eval { $ffi->sizeof('wchar_t') };
  6         23  
29 6 50       19 die 'no wchar_t' if $@;
30              
31 6         50 my %orders = (
32             join('', 1..$size) => 'BE',
33             join('', reverse 1..$size) => 'LE',
34             );
35              
36 6         17 my $byteorder = join '', @{ $ffi->cast( "wchar_t*", "uint8[$size]", \hex(join '', map { "0$_" } 1..$size) ) };
  6         23  
  24         87  
37              
38 6         19 my $encoding;
39              
40 6 50       38 if($size == 2)
    50          
41             {
42 0         0 $encoding = 'UTF-16';
43             }
44             elsif($size == 4)
45             {
46 6         13 $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       17 if(defined $orders{$byteorder})
54             {
55 6         15 $encoding .= $orders{$byteorder};
56             }
57             else
58             {
59 0         0 die "odd byteorder $byteorder not (yet) supported";
60             }
61              
62 6 50       26 die "Perl doesn't recognize $encoding as an encoding"
63             unless find_encoding($encoding);
64              
65 6         5970 return ($encoding, $size);
66             }
67              
68             sub ffi_custom_type_api_1
69             {
70 4     4 0 17 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         17 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     27 my $size = $args{size} || 2048;
89 4   100     16 my $access = $args{access} || 'read';
90              
91 4         14 my %ct = (
92             native_type => 'opaque',
93             );
94              
95             $ct{native_to_perl} = sub {
96 8 100   8   29 return undef unless defined $_[0];
97 7         73 return decode($encoding,
98             buffer_to_scalar(
99             $_[0],
100             FFI::Platypus::Memory::_wcslen($_[0])*$width,
101             )
102             );
103 4         28 };
104              
105 4 100       22 if($access eq 'read')
    50          
106             {
107             $ct{perl_to_native} = sub {
108 28 100   28   1216 if(defined $_[0])
109             {
110 27         103 my $buf = encode($encoding, $_[0]."\0");
111 27         1153 push @stack, \$buf;
112 27         67 return scalar_to_pointer $buf;
113             }
114             else
115             {
116 1         3 push @stack, undef;
117 1         6 return undef;
118             }
119 2         21 };
120              
121             $ct{perl_to_native_post} = sub {
122 28     28   54 pop @stack;
123 28         125 return;
124 2         11 };
125              
126             }
127             elsif($access eq 'write')
128             {
129 2         16 my @stack;
130              
131             $ct{perl_to_native} = sub {
132 17     17   6203 my $ref = shift;
133 17 100       61 if(ref($ref) eq 'ARRAY')
    100          
134             {
135 8 100       17 ${ $ref->[0] } = "\0" x $size unless defined ${ $ref->[0] };
  4         9  
  8         39  
136 8         14 my $ptr = scalar_to_pointer ${ $ref->[0] };
  8         23  
137 8 50       25 if(defined $ref->[0])
138             {
139 8         21 my $init = encode($encoding, $ref->[1]);
140 8         382 my($sptr, $ssize) = scalar_to_buffer($init);
141 8         43 memcpy($ptr, $sptr, $ssize);
142             }
143 8         14 push @stack, \${ $ref->[0] };
  8         20  
144 8         28 return $ptr;
145             }
146             elsif(ref($ref) eq 'SCALAR')
147             {
148 8         14 push @stack, $ref;
149 8 100       55 $$ref = "\0" x $size unless defined $$ref;
150 8         23 return scalar_to_pointer $$ref;
151             }
152             else
153             {
154 1         6 push @stack, $ref;
155 1         6 return undef;
156             }
157 2         14 };
158              
159             $ct{perl_to_native_post} = sub {
160 17     17   32 my $ref = pop @stack;
161 17 100       46 return unless defined $ref;
162 16         24 my $len = length $$ref;
163 16         64 $len = FFI::Platypus::Memory::_wcsnlen($$ref, $len);
164 16         55 $$ref = decode($encoding, substr($$ref, 0, $len*$width));
165 2         10 };
166              
167             }
168             else
169             {
170 0         0 Carp::croak("Unknown access type $access");
171             }
172              
173 4         16 return \%ct;
174             }
175              
176             1;
177              
178             __END__