File Coverage

blib/lib/FFI/Platypus/Legacy/Raw.pm
Criterion Covered Total %
statement 53 57 92.9
branch 8 10 80.0
condition n/a
subroutine 18 19 94.7
pod 8 8 100.0
total 87 94 92.5


line stmt bran cond sub pod time code
1             package FFI::Platypus::Legacy::Raw;
2              
3 7     7   1515582 use strict;
  7         59  
  7         207  
4 7     7   40 use warnings;
  7         15  
  7         175  
5 7     7   643 use FFI::Platypus;
  7         6538  
  7         180  
6 7     7   2987 use FFI::Platypus::Legacy::Raw::Platypus;
  7         19  
  7         422  
7 7     7   3158 use FFI::Platypus::Legacy::Raw::Callback;
  7         26  
  7         262  
8 7     7   3603 use FFI::Platypus::Legacy::Raw::Ptr;
  7         20  
  7         218  
9 7     7   3030 use FFI::Platypus::Legacy::Raw::MemPtr;
  7         20  
  7         390  
10             use overload
11 7         75 '&{}' => \&coderef,
12 7     7   54 'bool' => \&_bool;
  7         15  
13              
14             # ABSTRACT: Perl bindings to the portable FFI library (libffi)
15             our $VERSION = '0.04'; # VERSION
16              
17             sub _bool {
18 3     3   279 my $ffi = shift;
19 3         12 return $ffi;
20             }
21              
22              
23             sub _new
24             {
25 57     57   162 my($class, $ffi, $id, $ret_type, @types) = @_;
26 57         186 my $f = $ffi->function($id => \@types => $ret_type);
27 56         6330 bless [$f], $class;
28             }
29              
30             sub new
31             {
32 57     57 1 60446 my($class, $library, $function, @types) = @_;
33 57 100       226 my $self = $class->_new(
34             defined $library ? _ffi $library : _ffi_libc,
35             $function,
36             @types
37             );
38 56         313 $self->[1] = $function;
39 56         157 $self;
40             }
41              
42              
43             sub new_from_ptr
44             {
45 0     0 1 0 my($class, $ptr, @types) = @_;
46 0         0 $class->_new(
47             _ffi_package,
48             $ptr,
49             @types,
50             );
51            
52             }
53              
54              
55             sub call
56             {
57 97     97 1 6169 my $self = shift;
58 97         630 $self->[0]->call(@_);
59             }
60              
61              
62             sub coderef
63             {
64 33     33 1 3903 my $self = shift;
65 33     34   159 return sub { $self->call(@_) };
  34         668  
66             }
67              
68              
69 1     1 1 8 sub memptr { FFI::Platypus::Legacy::Raw::MemPtr->new(@_) }
70              
71              
72 7     7 1 2126 sub callback { FFI::Platypus::Legacy::Raw::Callback->new(@_) }
73              
74              
75             sub void () { 'v' }
76              
77              
78             sub int () { 'i' }
79              
80              
81             sub uint () { 'I' }
82              
83              
84             sub short () { 'z' }
85              
86              
87             sub ushort () { 'Z' }
88              
89              
90             sub long () { 'l' }
91              
92              
93             sub ulong () { 'L' }
94              
95              
96             sub int64 () { 'x' }
97              
98              
99             sub uint64 () { 'X' }
100              
101              
102             sub char () { 'c' }
103              
104              
105             sub uchar () { 'C' }
106              
107              
108             sub float () { 'f' }
109              
110              
111             sub double () { 'd' }
112              
113              
114             sub str () { 's' }
115              
116              
117             sub ptr () { 'p' }
118              
119              
120             sub attach
121             {
122 3     3 1 829 my($self, $perl_name, $proto) = @_;
123              
124 3 100       10 unless(defined $perl_name)
125             {
126 2         5 $perl_name = $self->[1];
127 2 50       5 unless(defined $perl_name)
128             {
129 0         0 require Carp;
130 0         0 Carp::croak("Cannot determine function name from a pointer");
131             }
132             }
133              
134             # some of this logic is unfortunately replicated
135             # in FFI-Platypus :/
136 3 50       14 if($perl_name !~ /::/)
137             {
138 3         7 my $caller = caller;
139 3         10 $perl_name = join '::', $caller, $perl_name;
140             }
141            
142 3         13 $self->[0]->attach($perl_name, $proto);
143             }
144              
145              
146             sub platypus
147             {
148 2     2 1 1734 my(undef, $library) = @_;
149 2 100       8 unless(defined $library)
150             {
151 1         9 require Carp;
152 1         180 Carp::croak("cannot get platypus instance for undef lib");
153             }
154 1         5 _ffi $library;
155             }
156              
157              
158             1;
159              
160             __END__