File Coverage

blib/lib/FFI/Util.pm
Criterion Covered Total %
statement 41 57 71.9
branch 2 10 20.0
condition 1 3 33.3
subroutine 14 15 93.3
pod 3 3 100.0
total 61 88 69.3


line stmt bran cond sub pod time code
1             package FFI::Util;
2              
3 5     5   232827 use strict;
  5         30  
  5         105  
4 5     5   18 use warnings;
  5         7  
  5         88  
5 5     5   17 use constant;
  5         5  
  5         112  
6 5     5   100 use 5.008001;
  5         23  
7 5     5   21 use Config;
  5         23  
  5         169  
8 5     5   2907 use FFI::Platypus;
  5         27694  
  5         146  
9 5     5   1880 use FFI::Platypus::Buffer ();
  5         4213  
  5         101  
10 5     5   24 use Scalar::Util qw( refaddr );
  5         7  
  5         442  
11             use Exporter::Tidy
12 5         8 deref => do {
13 5         17 our @types = qw( ptr str int uint short ushort char uchar float double int64 uint64 long ulong );
14 5         9 [map { ("deref_$_\_get","deref_$_\_set") } (@types, qw( size_t time_t dev_t gid_t uid_t ))];
  95         191  
15             },
16             buffer => [qw( scalar_to_buffer buffer_to_scalar )],
17             types => [qw( _size_t _time_t _dev_t _gid_t _uid_t )],
18             locate_module_share_lib => [qw( locate_module_share_lib )],
19 5     5   4240 ;
  5         55  
20              
21             # ABSTRACT: Some useful pointer utilities when writing FFI modules (Deprecated)
22             our $VERSION = '0.17'; # VERSION
23              
24              
25              
26             sub locate_module_share_lib (;$$)
27             {
28 0     0 1 0 require FFI::Platypus::ConfigData;
29 0         0 my($module, $modlibname) = @_;
30 0 0       0 ($module, $modlibname) = caller() unless defined $modlibname;
31 0         0 my @modparts = split(/::/,$module);
32 0         0 my $modfname = $modparts[-1];
33 0         0 my $modpname = join('/',@modparts);
34 0         0 my $c = @modparts;
35 0         0 $modlibname =~ s,[\\/][^\\/]+$,, while $c--; # Q&D basename
36 0         0 foreach my $dlext (@{ FFI::Platypus::ConfigData->config('config_dlext') })
  0         0  
37             {
38 0         0 my $file = "$modlibname/auto/$modpname/$modfname.$dlext";
39 0 0       0 unless(-e $file)
40             {
41 0         0 $modlibname =~ s,[\\/][^\\/]+$,,;
42 0         0 $file = "$modlibname/arch/auto/$modpname/$modfname.$dlext";
43             }
44 0 0       0 return $file if -e $file;
45             }
46 0         0 ();
47             };
48              
49             our $ffi = FFI::Platypus->new;
50             $ffi->package;
51             $ffi->attach( [lookup_type => '_lookup_type'] => ['string'] => 'string');
52              
53             # nicked this from FFI/Raw.pm
54             sub _ffi_void () { ord 'v' }
55             sub _ffi_int () { ord 'i' }
56             sub _ffi_uint () { ord 'I' }
57             sub _ffi_short () { ord 'z' }
58             sub _ffi_ushort () { ord 'Z' }
59             sub _ffi_long () { ord 'l' }
60             sub _ffi_ulong () { ord 'L' }
61             sub _ffi_int64 () { ord 'x' }
62             sub _ffi_uint64 () { ord 'X' }
63             sub _ffi_char () { ord 'c' }
64             sub _ffi_uchar () { ord 'C' }
65             sub _ffi_float () { ord 'f' }
66             sub _ffi_double () { ord 'd' }
67             sub _ffi_str () { ord 's' }
68             sub _ffi_ptr () { ord 'p' }
69              
70             foreach my $type (qw( size_t time_t dev_t gid_t uid_t ))
71             {
72             my $real_type = _lookup_type($type);
73             if($real_type)
74             {
75             constant->import("_$type" => eval "_ffi_$real_type\()");
76             }
77             }
78              
79             $ffi->type( void => 'raw_void' );
80             $ffi->type( string => 'raw_str' );
81             $ffi->type( int => 'raw_int' );
82             $ffi->type( 'unsigned int' => 'raw_uint' );
83             $ffi->type( short => 'raw_short' );
84             $ffi->type( 'unsigned short' => 'raw_ushort' );
85             $ffi->type( long => 'raw_long' );
86             $ffi->type( 'unsigned long' => 'raw_ulong' );
87             $ffi->type( 'uint64' => 'raw_uint64' );
88             $ffi->type( 'sint64' => 'raw_int64' );
89             $ffi->type( 'signed char' => 'raw_char' );
90             $ffi->type( 'unsigned char' => 'raw_uchar' );
91             $ffi->type( 'float' => 'raw_float' );
92             $ffi->type( 'double' => 'raw_double' );
93              
94             $ffi->custom_type(raw_ptr => {
95             perl_to_native => sub { ref($_[0]) ? ${$_[0]} : $_[0] },
96             native_to_perl => sub { $_[0] },
97             });
98              
99             for (qw( ptr str int uint short ushort long ulong char uchar float double int64 uint64 ))
100             {
101             $ffi->attach( "deref_${_}_get" => ['raw_ptr'] => "raw_$_" => '$' );
102             $ffi->attach( "deref_${_}_set" => ['raw_ptr',"raw_$_"] => 'void' => '$$' );
103             }
104              
105             foreach my $type (our @types)
106             {
107             my $code_type = eval qq{ _ffi_$type };
108             foreach my $otype (qw( size_t time_t dev_t gid_t uid_t ))
109             {
110             if((_lookup_type($otype)||'') eq $type)
111             {
112 5     5   3682 no strict 'refs';
  5         12  
  5         528  
113             *{"deref_$otype\_get"} = \&{"deref_$type\_get"};
114             *{"deref_$otype\_set"} = \&{"deref_$type\_set"};
115             }
116             }
117             }
118              
119              
120             use constant _incantation =>
121 5 50 33     387 $^O eq 'MSWin32' && $Config{archname} =~ /MSWin32-x64/
122             ? 'Q'
123 5     5   27 : 'L!';
  5         7  
124              
125              
126             sub scalar_to_buffer ($)
127             {
128 5     5 1 26 (unpack(_incantation, pack 'P', $_[0]), do { use bytes; length $_[0] });
  5     2   73  
  5         24  
  2         4407  
  2         6  
129             }
130              
131              
132             sub buffer_to_scalar ($$)
133             {
134 2 50   2 1 1421 unpack 'P'.$_[1], pack _incantation, defined $_[0] ? $_[0] : 0;
135             }
136              
137             1;
138              
139             __END__