File Coverage

blib/lib/FFI/Platypus/Legacy/Raw/Callback.pm
Criterion Covered Total %
statement 40 42 95.2
branch 14 18 77.7
condition n/a
subroutine 8 8 100.0
pod 1 1 100.0
total 63 69 91.3


line stmt bran cond sub pod time code
1             package FFI::Platypus::Legacy::Raw::Callback;
2              
3 7     7   52 use strict;
  7         21  
  7         203  
4 7     7   37 use warnings;
  7         15  
  7         211  
5 7     7   3141 use FFI::Platypus::Memory qw( strdup free );
  7         178333  
  7         621  
6 7     7   74 use FFI::Platypus::Legacy::Raw::Platypus;
  7         18  
  7         2698  
7              
8             # ABSTRACT: FFI::Platypus::Legacy::Raw function pointer type
9             our $VERSION = '0.06'; # VERSION
10              
11              
12             sub new
13             {
14 7     7 1 21 my($class, $coderef, $ret_type, @arg_types) = @_;
15              
16 7         12 my $self;
17              
18 7 100       20 if($ret_type eq 's')
19             {
20 1         2 $ret_type = 'opaque';
21 1         2 my $original = $coderef;
22             $coderef = sub {
23 2 100   2   11 free $self->{strptr} if $self->{strptr};
24 2         4 delete $self->{strptr};
25 2         5 my $string = $original->(@_);
26 2 100       11 return undef unless defined $string;
27 1         11 $self->{strptr} = strdup($string);
28 1         15 };
29             }
30              
31 7 100       18 if($ret_type eq 'p')
32             {
33 3         24 $ret_type = 'opaque';
34 3         6 my $original = $coderef;
35             $coderef = sub {
36 3     3   9 my $ptr = $original->(@_);
37 3 100       16 return undef unless defined $ptr;
38 2 100       6 if(ref $ptr)
39             {
40 1 50       2 if(eval { $ptr->isa('FFI::Platypus::Legacy::Raw::Ptr') })
  1 0       9  
41 1         5 { $ptr = $$ptr }
42 0         0 elsif(eval { $ptr->isa('FFI::Platypus::Legacy::Raw::Callback') })
43 0         0 { $ptr = $ptr->{ptr} }
44             }
45 2         8 $ptr;
46 3         13 };
47             }
48              
49 7         22 my $closure = _ffi_package->closure($coderef);
50 7         145 my $closure_type = '(' . join(',', @arg_types) . ")->$ret_type";
51              
52 7         20 $self = bless {
53             coderef => $coderef,
54             closure => $closure,
55             ptr => _ffi_package->cast($closure_type => 'opaque', $closure),
56             }, $class;
57             }
58              
59             sub DESTROY
60             {
61 6     6   396 my($self) = @_;
62 6 50       14 free $self->{strptr} if $self->{strptr};
63 6         52 delete $self->{strptr};
64             }
65              
66              
67             1;
68              
69             __END__