File Coverage

blib/lib/FFI/Platypus.pm

Criterion	Covered	Total	%
statement	247	253	97.6
branch	135	160	84.3
condition	53	78	67.9
subroutine	40	40	100.0
pod	28	28	100.0
total	503	559	89.9

package FFI::Platypus;

use strict;
use warnings;
use 5.008004;
use Carp qw( croak );
use FFI::Platypus::Function;
use FFI::Platypus::Type;

# ABSTRACT: Write Perl bindings to non-Perl libraries with FFI. No XS required.
our $VERSION = '2.06_01'; # TRIAL VERSION

# Platypus-Man,
# Platypus-Man,
# Does Whatever A Platypus Can
# Is Mildly Venomous
# Hangs Out In Rivers By Caves
# Look Out!
# Here Comes The Platypus-Man

# From the original FFI::Platypus prototype:
#  Kinda like gluing a duckbill to an adorable mammal


our @CARP_NOT = qw( FFI::Platypus::Declare FFI::Platypus::Record );

require XSLoader;
XSLoader::load(
  'FFI::Platypus', $FFI::Platypus::VERSION || 0
);


sub new
{
  my($class, %args) = @_;
  my @lib;
  if(exists $args{lib})
  {
    if(!ref($args{lib}))
    {
      push @lib, $args{lib};
    }
    elsif(ref($args{lib}) eq 'ARRAY')
    {
      push @lib, @{$args{lib}};
    }
    else
    {
      croak "lib argument must be a scalar or array reference";
    }
  }

  my $api          = $args{api} || 0;
  my $experimental = $args{experimental} || 0;

  if($experimental == 1)
  {
    Carp::croak("Please do not use the experimental version of api = 1, instead require FFI::Platypus 1.00 or better");
  }
  elsif($experimental == 2)
  {
    Carp::croak("Please do not use the experimental version of api = 2, instead require FFI::Platypus 2.00 or better");
  }

  if(defined $api && $api > 2 && $experimental != $api)
  {
    Carp::cluck("Enabling development API version $api prior to FFI::Platypus $api.00");
  }

  my $tp;

  if($api == 0)
  {
    $tp = 'Version0';
  }
  elsif($api == 1)
  {
    $tp = 'Version1';
  }
  elsif($api == 2)
  {
    $tp = 'Version2';
  }
  else
  {
    Carp::croak("API version $api not (yet) implemented");
  }

  require "FFI/Platypus/TypeParser/$tp.pm";
  $tp = "FFI::Platypus::TypeParser::$tp";

  my $self = bless {
    lib              => \@lib,
    lang             => '',
    handles          => {},
    abi              => -1,
    api              => $api,
    tp               => $tp->new,
    fini             => [],
    ignore_not_found => defined $args{ignore_not_found} ? $args{ignore_not_found} : 0,
  }, $class;

  $self->lang($args{lang} || 'C');

  $self;
}

sub _lang_class ($)
{
  my($lang) = @_;
  my $class = $lang =~ m/^=(.*)$/ ? $1 : "FFI::Platypus::Lang::$lang";
  unless($class->can('native_type_map'))
  {
    my $pm = "$class.pm";
    $pm =~ s/::/\//g;
    require $pm;
  }
  croak "$class does not provide native_type_map method"
    unless $class->can("native_type_map");
  $class;
}


sub lib
{
  my($self, @new) = @_;

  if(@new)
  {
    push @{ $self->{lib} }, map { ref $_ eq 'CODE' ? $_->() : $_ } @new;
    delete $self->{mangler};
  }

  @{ $self->{lib} };
}


sub ignore_not_found
{
  my($self, $value) = @_;

  if(defined $value)
  {
    $self->{ignore_not_found} = $value;
  }

  $self->{ignore_not_found};
}


sub lang
{
  my($self, $value) = @_;

  if(defined $value && $value ne $self->{lang})
  {
    $self->{lang} = $value;
    my $class = _lang_class($self->{lang});
    $self->abi($class->abi) if $class->can('abi');

    {
      my %type_map;
      my $map = $class->native_type_map(
        $self->{api} > 0
          ? (api => $self->{api})
          : ()
      );
      foreach my $key (keys %$map)
      {
        my $value = $map->{$key};
        next unless $self->{tp}->have_type($value);
        $type_map{$key} = $value;
      }
      $type_map{$_} = $_ for grep { $self->{tp}->have_type($_) }
        qw( void sint8 uint8 sint16 uint16 sint32 uint32 sint64 uint64 float double string opaque
            longdouble complex_float complex_double );
      $type_map{pointer} = 'opaque' if $self->{tp}->isa('FFI::Platypus::TypeParser::Version0');
      $self->{tp}->type_map(\%type_map);
    }

    $class->load_custom_types($self) if $class->can('load_custom_types');
  }

  $self->{lang};
}


sub api { shift->{api} }


sub type
{
  my($self, $name, $alias) = @_;
  croak "usage: \$ffi->type(name => alias) (alias is optional)" unless defined $self && defined $name;

  $self->{tp}->check_alias($alias) if defined $alias;
  my $type = $self->{tp}->parse($name);
  $self->{tp}->set_alias($alias, $type) if defined $alias;

  $self;
}


sub custom_type
{
  my($self, $alias, $cb) = @_;

  my $argument_count = $cb->{argument_count} || 1;

  croak "argument_count must be >= 1"
    unless $argument_count >= 1;

  croak "Usage: \$ffi->custom_type(\$alias, { ... })"
    unless defined $alias && ref($cb) eq 'HASH';

  croak "must define at least one of native_to_perl, perl_to_native, or perl_to_native_post"
    unless defined $cb->{native_to_perl} || defined $cb->{perl_to_native} || defined $cb->{perl_to_native_post};

  $self->{tp}->check_alias($alias);

  my $type = $self->{tp}->create_type_custom(
    $cb->{native_type},
    $cb->{perl_to_native},
    $cb->{native_to_perl},
    $cb->{perl_to_native_post},
    $argument_count,
  );

  $self->{tp}->set_alias($alias, $type);

  $self;
}


sub load_custom_type
{
  my($self, $name, $alias, @type_args) = @_;

  croak "usage: \$ffi->load_custom_type(\$name, \$alias, ...)"
    unless defined $name && defined $alias;

  $name = "FFI::Platypus::Type$name" if $name =~ /^::/;
  $name = "FFI::Platypus::Type::$name" unless $name =~ /::/;

  unless($name->can("ffi_custom_type_api_1"))
  {
    my $pm = "$name.pm";
    $pm =~ s/::/\//g;
    eval { require $pm };
    warn $@ if $@;
  }

  unless($name->can("ffi_custom_type_api_1"))
  {
    croak "$name does not appear to conform to the custom type API";
  }

  my $cb = $name->ffi_custom_type_api_1($self, @type_args);
  $self->custom_type($alias => $cb);

  $self;
}


sub types
{
  my($self) = @_;
  $self = $self->new unless ref $self && eval { $self->isa('FFI::Platypus') };
  sort $self->{tp}->list_types;
}


sub type_meta
{
  my($self, $name) = @_;
  $self = $self->new unless ref $self && eval { $self->isa('FFI::Platypus') };
  $self->{tp}->parse($name)->meta;
}


sub mangler
{
  my($self, $sub) = @_;
  $self->{mangler} = $self->{mymangler} = $sub;
}


sub function
{
  my $wrapper;
  $wrapper = pop if ref $_[-1] eq 'CODE';

  croak "usage \$ffi->function( \$name, \\\@arguments, [\\\@var_args], [\$return_type])" unless @_ >= 3 && @_ <= 6;

  my $self = shift;
  my $name = shift;
  my $fixed_args = shift;
  my $var_args;
  $var_args = shift if defined $_[0] && ref($_[0]) eq 'ARRAY';
  my $ret = shift;
  $ret = 'void' unless defined $ret;

  # special case: treat a single void argument type as an empty list of
  # arguments, a la olde timey C compilers.
  if( (!defined $var_args) && @$fixed_args == 1 && $fixed_args->[0] eq 'void' )
  {
    $fixed_args = [];
  }

  my $fixed_arg_count = defined $var_args ? scalar(@$fixed_args) : -1;

  my @args = map { $self->{tp}->parse($_) || croak "unknown type: $_" } @$fixed_args;
  if($var_args)
  {
    push @args, map {
      my $type = $self->{tp}->parse($_);
      # https://github.com/PerlFFI/FFI-Platypus/issues/323
      $type->type_code == 67 ? $self->{tp}->parse('double') : $type
    } @$var_args;
  }

  $ret = $self->{tp}->parse($ret) || croak "unknown type: $ret";
  my $address = $name =~ /^-?[0-9]+$/ ? $name : $self->find_symbol($name);
  croak "unable to find $name" unless defined $address || $self->ignore_not_found;
  return unless defined $address;
  $address = @args > 0 ? _cast1() : _cast0() if $address == 0;
  my $function = FFI::Platypus::Function::Function->new($self, $address, $self->{abi}, $fixed_arg_count, $ret, @args);
  $wrapper
    ? FFI::Platypus::Function::Wrapper->new($function, $wrapper)
    : $function;
}

sub _function_meta
{
  # NOTE: may be upgraded to a documented function one day,
  # but shouldn't be used externally as we will rename it
  # if that happens.
  my($self, $name, $meta, $args, $ret) = @_;
  $args = ['opaque','int',@$args];
  $self->function(
    $name, $args, $ret, sub {
      my $xsub = shift;
      $xsub->($meta, scalar(@_), @_);
    },
  );
}


sub attach
{
  my $wrapper;
  $wrapper = pop if ref $_[-1] eq 'CODE';

  my $self = shift;
  my $name = shift;
  my $args = shift;
  my $varargs;
  $varargs = shift if defined $_[0] && ref($_[0]) eq 'ARRAY';
  my $ret = shift;
  my $proto = shift;

  $ret = 'void' unless defined $ret;

  my($c_name, $perl_name) = ref($name) ? @$name : ($name, $name);

  croak "you tried to provide a perl name that looks like an address"
    if $perl_name =~ /^-?[0-9]+$/;

  my $function = $varargs
    ? $self->function($c_name, $args, $varargs, $ret, $wrapper)
    : $self->function($c_name, $args, $ret, $wrapper);

  if(defined $function)
  {
    $function->attach($perl_name, $proto);
  }

  $self;
}


sub closure
{
  my($self, $coderef) = @_;
  return undef unless defined $coderef;
  croak "not a coderef" unless ref $coderef eq 'CODE';
  require FFI::Platypus::Closure;
  FFI::Platypus::Closure->new($coderef);
}


sub cast
{
  $_[0]->function(0 => [$_[1]] => $_[2])->call($_[3]);
}


sub attach_cast
{
  my($self, $name, $type1, $type2, $wrapper) = @_;
  my $caller = caller;
  $name = join '::', $caller, $name unless $name =~ /::/;
  if(defined $wrapper && ref($wrapper) eq 'CODE')
  {
    $self->attach([0 => $name] => [$type1] => $type2 => '$', $wrapper);
  }
  else
  {
    $self->attach([0 => $name] => [$type1] => $type2 => '$');
  }
  $self;
}


sub sizeof
{
  my($self,$name) = @_;
  ref $self
    ? $self->{tp}->parse($name)->sizeof
    : $self->new->sizeof($name);
}


sub alignof
{
  my($self, $name) = @_;
  ref $self
    ? $self->{tp}->parse($name)->alignof
    : $self->new->alignof($name);
}


sub kindof
{
  my($self, $name) = @_;
  ref $self
    ? $self->{tp}->parse($name)->kindof
    : $self->new->kindof($name);
}


sub countof
{
  my($self, $name) = @_;
  ref $self
    ? $self->{tp}->parse($name)->countof
    : $self->new->countof($name);
}


sub def
{
  my $self = shift;
  my $package = shift || caller;
  my $type = shift;
  if(@_)
  {
    $self->type($type);
    $self->{def}->{$package}->{$type} = shift;
  }
  $self->{def}->{$package}->{$type};
}


sub unitof
{
  my($self, $name) = @_;
  ref $self
    ? $self->{tp}->parse($name)->unitof
    : $self->new->unitof($name);
}


sub find_lib
{
  my $self = shift;
  require FFI::CheckLib;
  $self->lib(FFI::CheckLib::find_lib(@_));
  $self;
}


sub find_symbol
{
  my($self, $name) = @_;

  $self->{mangler} ||= $self->{mymangler};

  unless(defined $self->{mangler})
  {
    my $class = _lang_class($self->{lang});
    if($class->can('mangler'))
    {
      $self->{mangler} = $class->mangler($self->lib);
    }
    else
    {
      $self->{mangler} = sub { $_[0] };
    }
  }

  foreach my $path (@{ $self->{lib} })
  {
    my $handle = do { no warnings; $self->{handles}->{$path||0} } || FFI::Platypus::DL::dlopen($path, FFI::Platypus::DL::RTLD_PLATYPUS_DEFAULT());
    unless($handle)
    {
      warn "warning: error loading $path: ", FFI::Platypus::DL::dlerror()
        if $self->{api} > 0 || $ENV{FFI_PLATYPUS_DLERROR};
      next;
    }
    my $address = FFI::Platypus::DL::dlsym($handle, $self->{mangler}->($name));
    if($address)
    {
      $self->{handles}->{$path||0} = $handle;
      return $address;
    }
    else
    {
      FFI::Platypus::DL::dlclose($handle) unless $self->{handles}->{$path||0};
    }
  }
  return;
}


sub bundle
{
  croak "bundle method only available with api => 1 or better" if $_[0]->{api} < 1;
  require FFI::Platypus::Bundle;
  goto &_bundle;
}


sub package
{
  croak "package method only available with api => 0" if $_[0]->{api} > 0;
  require FFI::Platypus::Legacy;
  goto &_package;
}


sub abis
{
  require FFI::Platypus::ShareConfig;
  FFI::Platypus::ShareConfig->get("abi");
}


sub abi
{
  my($self, $newabi) = @_;
  unless($newabi =~ /^[0-9]+$/)
  {
    unless(defined $self->abis->{$newabi})
    {
      croak "no such ABI: $newabi";
    }
    $newabi = $self->abis->{$newabi};
  }

  unless(FFI::Platypus::ABI::verify($newabi))
  {
    croak "no such ABI: $newabi";
  }

  $self->{abi} = $newabi;
  $self->{tp}->abi($newabi);

  $self;
}

sub DESTROY
{
  my($self) = @_;
  foreach my $fini (@{ $self->{fini} })
  {
    $fini->($self);
  }
  foreach my $handle (values %{ $self->{handles} })
  {
    next unless $handle;
    FFI::Platypus::DL::dlclose($handle);
  }
  delete $self->{handles};
}

1;

__END__