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

package FFI::Platypus::Legacy::Raw::Callback;

use strict;
use warnings;
use FFI::Platypus::Memory qw( strdup free );
use FFI::Platypus::Legacy::Raw::Platypus;

# ABSTRACT: FFI::Platypus::Legacy::Raw function pointer type
our $VERSION = '0.04'; # VERSION


sub new
{
  my($class, $coderef, $ret_type, @arg_types) = @_;

  my $self;

  if($ret_type eq 's')
  {
    $ret_type = 'opaque';
    my $original = $coderef;
    $coderef = sub {
      free $self->{strptr} if $self->{strptr};
      delete $self->{strptr};
      my $string = $original->(@_);
      return undef unless defined $string;
      $self->{strptr} = strdup($string);
    };
  }

  if($ret_type eq 'p')
  {
    $ret_type = 'opaque';
    my $original = $coderef;
    $coderef = sub {
      my $ptr = $original->(@_);
      return undef unless defined $ptr;
      if(ref $ptr)
      {
        if(eval { $ptr->isa('FFI::Platypus::Legacy::Raw::Ptr') })
        { $ptr = $$ptr }
        elsif(eval { $ptr->isa('FFI::Platypus::Legacy::Raw::Callback') })
        { $ptr = $ptr->{ptr} }
      }
      $ptr;
    };
  }

  my $closure = _ffi_package->closure($coderef);
  my $closure_type = '(' . join(',', @arg_types) . ")->$ret_type";

  $self = bless {
    coderef => $coderef,
    closure => $closure,
    ptr     => _ffi_package->cast($closure_type => 'opaque', $closure),
  }, $class;
}

sub DESTROY
{
  my($self) = @_;
  free $self->{strptr} if $self->{strptr};
  delete $self->{strptr};
}


1;

__END__