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

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

use strict;
use warnings;
use FFI::Platypus;
use FFI::Platypus::Legacy::Raw::Platypus;
use FFI::Platypus::Legacy::Raw::Callback;
use FFI::Platypus::Legacy::Raw::Ptr;
use FFI::Platypus::Legacy::Raw::MemPtr;
use overload
  '&{}'  => \&coderef,
  'bool' => \&_bool;

# ABSTRACT: Perl bindings to the portable FFI library (libffi)
our $VERSION = '0.04'; # VERSION

sub _bool {
  my $ffi = shift;
  return $ffi;
}


sub _new
{
  my($class, $ffi, $id, $ret_type, @types) = @_;
  my $f = $ffi->function($id => \@types => $ret_type);
  bless [$f], $class;
}

sub new
{
  my($class, $library, $function, @types) = @_;
  my $self = $class->_new(
    defined $library ? _ffi $library : _ffi_libc,
    $function,
    @types
  );
  $self->[1] = $function;
  $self;
}


sub new_from_ptr
{
  my($class, $ptr, @types) = @_;
  $class->_new(
    _ffi_package,
    $ptr,
    @types,
  );

}


sub call
{
  my $self = shift;
  $self->[0]->call(@_);
}


sub coderef
{
  my $self = shift;
  return sub { $self->call(@_) };
}


sub memptr { FFI::Platypus::Legacy::Raw::MemPtr->new(@_) }


sub callback { FFI::Platypus::Legacy::Raw::Callback->new(@_) }


sub void ()  { 'v' }


sub int ()   { 'i' }


sub uint ()   { 'I' }


sub short ()   { 'z' }


sub ushort ()   { 'Z' }


sub long ()   { 'l' }


sub ulong ()   { 'L' }


sub int64 ()   { 'x' }


sub uint64 ()   { 'X' }


sub char ()  { 'c' }


sub uchar ()  { 'C' }


sub float () { 'f' }


sub double () { 'd' }


sub str ()   { 's' }


sub ptr ()   { 'p' }


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

  unless(defined $perl_name)
  {
    $perl_name = $self->[1];
    unless(defined $perl_name)
    {
      require Carp;
      Carp::croak("Cannot determine function name from a pointer");
    }
  }

  # some of this logic is unfortunately replicated
  # in FFI-Platypus :/
  if($perl_name !~ /::/)
  {
    my $caller = caller;
    $perl_name = join '::', $caller, $perl_name;
  }

  $self->[0]->attach($perl_name, $proto);
}


sub platypus
{
  my(undef, $library) = @_;
  unless(defined $library)
  {
    require Carp;
    Carp::croak("cannot get platypus instance for undef lib");
  }
  _ffi $library;
}


1;

__END__