File Coverage

blib/lib/FFI/Platypus/Function.pm

Criterion	Covered	Total	%
statement	74	74	100.0
branch	6	6	100.0
condition			n/a
subroutine	19	19	100.0
pod			n/a
total	99	99	100.0

package FFI::Platypus::Function;

use strict;
use warnings;
use 5.008004;
use FFI::Platypus;

# ABSTRACT: An FFI function object
our $VERSION = '2.06_01'; # TRIAL VERSION


use overload '&{}' => sub {
  my $ffi = shift;
  sub { $ffi->call(@_) };
}, 'bool' => sub {
  my $ffi = shift;
  return $ffi;
}, fallback => 1;

package FFI::Platypus::Function::Function;

use parent qw( FFI::Platypus::Function );

sub attach
{
  my($self, $perl_name, $proto) = @_;

  my $frame = -1;
  my($caller, $filename, $line);

  do {
    ($caller, $filename, $line) = caller(++$frame);
  } while( $caller =~ /^FFI::Platypus(|::Function|::Function::Wrapper|::Declare)$/ );

  $perl_name = join '::', $caller, $perl_name
    unless $perl_name =~ /::/;

  $self->_attach($perl_name, "$filename:$line", $proto);
  $self;
}

sub sub_ref
{
  my($self) = @_;

  my $frame = -1;
  my($caller, $filename, $line);

  do {
    ($caller, $filename, $line) = caller(++$frame);
  } while( $caller =~ /^FFI::Platypus(|::Function|::Function::Wrapper|::Declare)$/ );

  $self->_sub_ref("$filename:$line");
}

package FFI::Platypus::Function::Wrapper;

use parent qw( FFI::Platypus::Function );

sub new
{
  my($class, $function, $wrapper) = @_;
  bless [ $function, $wrapper ], $class;
}

sub call
{
  my($function, $wrapper) = @{ shift() };
  @_ = ($function, @_);
  goto &$wrapper;
}

sub attach
{
  my($self, $perl_name, $proto) = @_;
  my($function, $wrapper) = @{ $self };

  unless($perl_name =~ /::/)
  {
    my $caller;
    my $frame = -1;
    do { $caller = caller(++$frame) } while( $caller =~ /^FFI::Platypus(|::Declare)$/ );
    $perl_name = join '::', $caller, $perl_name
  }

  my $xsub = $function->sub_ref;

  {
    my $code = sub {
      unshift @_, $xsub;
      goto &$wrapper;
    };
    if(defined $proto)
    {
      _set_prototype($proto, $code);
    }
    no strict 'refs';
    *{$perl_name} = $code;
  }

  $self;
}

sub sub_ref
{
  my($self) = @_;
  my($function, $wrapper) = @{ $self };
  my $xsub = $function->sub_ref;

  return sub {
    unshift @_, $xsub;
    goto &$wrapper;
  };
}

1;

__END__