File Coverage

blib/lib/FFI/Platypus/Type/StringPointer.pm
Criterion Covered Total %
statement 40 40 100.0
branch 11 12 91.6
condition 1 3 33.3
subroutine 11 11 100.0
pod 0 4 0.0
total 63 70 90.0


line stmt bran cond sub pod time code
1             package FFI::Platypus::Type::StringPointer;
2              
3 1     1   7 use strict;
  1         2  
  1         30  
4 1     1   6 use warnings;
  1         2  
  1         22  
5 1     1   15 use 5.008004;
  1         4  
6 1     1   5 use FFI::Platypus;
  1         2  
  1         23  
7 1     1   5 use Scalar::Util qw( readonly );
  1         2  
  1         151  
8              
9             # ABSTRACT: Convert a pointer to a string and back
10             our $VERSION = '2.06_01'; # TRIAL VERSION
11              
12              
13             use constant _incantation =>
14 1 50 33     121 $^O eq 'MSWin32' && do { require Config; $Config::Config{archname} =~ /MSWin32-x64/ }
15             ? 'Q'
16 1     1   8 : 'L!';
  1         2  
17 1     1   7 use constant _pointer_buffer => "P" . FFI::Platypus->new( api => 2 )->sizeof('opaque');
  1         2  
  1         5  
18              
19             my @stack;
20              
21             sub perl_to_native
22             {
23 5 100   5 0 8606 if(defined $_[0])
24             {
25 4         6 my $packed = pack 'P', ${$_[0]};
  4         15  
26 4         9 my $pointer_pointer = pack 'P', $packed;
27 4         14 my $unpacked = unpack _incantation, $pointer_pointer;
28 4         10 push @stack, [ \$packed, \$pointer_pointer ];
29 4         25 return $unpacked;
30             }
31             else
32             {
33 1         13 push @stack, [];
34 1         7 return undef;
35             }
36             }
37              
38             sub perl_to_native_post
39             {
40 5     5 0 10 my($packed) = @{ pop @stack };
  5         10  
41 5 100       19 return unless defined $packed;
42 4 100       6 unless(readonly(${$_[0]}))
  4         39  
43             {
44 2         8 ${$_[0]} = unpack 'p', $$packed;
  2         8  
45             }
46             }
47              
48             sub native_to_perl
49             {
50 3 100   3 0 1706 return unless defined $_[0];
51 2         12 my $pointer_pointer = unpack(_incantation, unpack(_pointer_buffer, pack(_incantation, $_[0])));
52 2 100       20 $pointer_pointer ? \unpack('p', pack(_incantation, $pointer_pointer)) : \undef;
53             }
54              
55             sub ffi_custom_type_api_1
56             {
57             return {
58 1     1 0 6 native_type => 'opaque',
59             perl_to_native => \&perl_to_native,
60             perl_to_native_post => \&perl_to_native_post,
61             native_to_perl => \&native_to_perl,
62             }
63             }
64              
65             1;
66              
67             __END__