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   48 use strict;
  7         15  
  7         200  
4 7     7   38 use warnings;
  7         15  
  7         205  
5 7     7   3097 use FFI::Platypus::Memory qw( strdup free );
  7         176931  
  7         671  
6 7     7   80 use FFI::Platypus::Legacy::Raw::Platypus;
  7         17  
  7         2814  
7              
8             # ABSTRACT: FFI::Platypus::Legacy::Raw function pointer type
9             our $VERSION = '0.04'; # VERSION
10              
11              
12             sub new
13             {
14 7     7 1 18 my($class, $coderef, $ret_type, @arg_types) = @_;
15              
16 7         13 my $self;
17              
18 7 100       22 if($ret_type eq 's')
19             {
20 1         3 $ret_type = 'opaque';
21 1         2 my $original = $coderef;
22             $coderef = sub {
23 2 100   2   12 free $self->{strptr} if $self->{strptr};
24 2         5 delete $self->{strptr};
25 2         5 my $string = $original->(@_);
26 2 100       13 return undef unless defined $string;
27 1         13 $self->{strptr} = strdup($string);
28 1         16 };
29             }
30              
31 7 100       18 if($ret_type eq 'p')
32             {
33 3         26 $ret_type = 'opaque';
34 3         7 my $original = $coderef;
35             $coderef = sub {
36 3     3   8 my $ptr = $original->(@_);
37 3 100       17 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         6 { $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         14 };
47             }
48              
49 7         20 my $closure = _ffi_package->closure($coderef);
50 7         202 my $closure_type = '(' . join(',', @arg_types) . ")->$ret_type";
51              
52 7         23 $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   394 my($self) = @_;
62 6 50       14 free $self->{strptr} if $self->{strptr};
63 6         51 delete $self->{strptr};
64             }
65              
66              
67             1;
68              
69             __END__