File Coverage

blib/lib/FFI/C/Def.pm

Criterion	Covered	Total	%
statement	141	141	100.0
branch	52	68	76.4
condition	25	45	55.5
subroutine	39	39	100.0
pod	8	8	100.0
total	265	301	88.0

package FFI::C::Def;

use strict;
use warnings;
use 5.008001;
use FFI::C::FFI qw( malloc memset );
use FFI::C::Util;
use Ref::Util qw( is_blessed_ref is_ref is_plain_hashref is_plain_arrayref );
use Sub::Install ();
use Sub::Util ();

our @CARP_NOT = qw( FFI::C );

# ABSTRACT: Data definition for FFI
our $VERSION = '0.15'; # VERSION


sub new
{
  my $class = shift;

  Carp::croak("Attempt to call new on a def object (did you mean ->create?)") if is_blessed_ref $class;

  my $ffi = is_blessed_ref($_[0]) && $_[0]->isa('FFI::Platypus') ? shift : FFI::Platypus->new( api => 1 );
  my %args = @_;

  Carp::croak("Only works with FFI::Platypus api level 1 or better") unless $ffi->api >= 1;
  Carp::croak("FFI::C::Def is an abstract class") if $class eq 'FFI::C::Def';

  my $self = bless {
    ffi      => $ffi,
    name     => delete $args{name},
    class    => delete $args{class},
    nullable => delete $args{nullable},
    members  => {},
    align    => 0,
    size     => 0,
    args     => \%args,
  }, $class;

  if($self->name)
  {
    my $cdef = ref($self);
    $cdef =~ s/Def$//;
    $ffi->load_custom_type('::CDef' => $self->name,
      name     => $self->name,
      class    => $self->class,
      nullable => $self->nullable,
      def      => $self,
      cdef    => $cdef,
    );
    $ffi->def('FFI::C::Def', $self->name, $self);
  }

  $self;
}

sub _generate_class
{
  my($self, @accessors) = @_;

  # first run through all the members, and make sure that we
  # can generate a class based on the def.  That means that:
  #  1. there is no constructor or destructor defined yet.
  #  2. none of the member accessors already exist
  #  3. Any nested cdefs have Perl classes, this will be done
  #     in the subclass

  foreach my $method (qw( new DESTROY ))
  {
    my $accessor = join '::', $self->class, $method;
    Carp::croak("$accessor already defined") if $self->class->can($method);
  }

  foreach my $name (@accessors)
  {
    next if $name =~ /^:/;
    my $accessor = $self->class . '::' . $name;
    Carp::croak("$accessor already exists")
      if $self->class->can($name);
  }

  require FFI::Platypus::Memory;

  if($self->isa('FFI::C::ArrayDef'))
  {

    my $size = $self->size;
    my $count = $self->{members}->{count};
    my $member_size = $self->{members}->{member}->size;

    my $code = sub {
      my $class = shift;
      my($ptr, $owner);

      my $size  = $size;
      my $count = $count;
      if(@_ == 1)
      {
        if(!is_ref $_[0])
        {
          $count = shift;
        }
        elsif(is_plain_arrayref $_[0])
        {
          $count = scalar @{$_[0]};
        }
        if($count)
        {
          $size = $member_size * $count;
        }
      }

      if(@_ == 2 && ! is_ref $_[0])
      {
        ($ptr, $owner) = @_;
      }
      else
      {
        Carp::croak("Cannot create array without knowing the number of elements")
          unless $size;
        $ptr = FFI::Platypus::Memory::malloc($size);
        FFI::Platypus::Memory::memset($ptr, 0, $size);
      }
      my $self = bless {
        ptr   => $ptr,
        owner => $owner,
        count => $count,
      }, $class;
      FFI::C::Util::perl_to_c($self, $_[0]) if @_ == 1 && is_ref $_[0];
      $self;
    };

    Sub::Util::set_subname(join('::', $self->class, 'new'), $code);
    Sub::Install::install_sub({
      code => $code,
      into => $self->class,
      as   => 'new',
    });
  }
  else
  {
    my $size = $self->size;
    $size = 1 unless $size > 0;

    my $code =       sub {
      my $class = shift;
      my($ptr, $owner);
      if(@_ == 2 && ! is_ref $_[0])
      {
        ($ptr, $owner) = @_;
      }
      else
      {
        $ptr = FFI::Platypus::Memory::malloc($size);
        FFI::Platypus::Memory::memset($ptr, 0, $size);
      }
      my $self = bless {
        ptr => $ptr,
        owner => $owner,
      }, $class;
      FFI::C::Util::perl_to_c($self, $_[0]) if @_ == 1 && is_ref $_[0];
      $self;
    };

    Sub::Util::set_subname(join('::', $self->class, 'new'), $code);
    Sub::Install::install_sub({
      code => $code,
      into => $self->class,
      as   => 'new',
    });
  }

  Sub::Install::install_sub({
    code => \&_common_destroy,
    into => $self->class,
    as   => 'DESTROY',
  });
}

sub _common_destroy
{
  my($self) = @_;
  if($self->{ptr} && !$self->{owner})
  {
    FFI::Platypus::Memory::free(delete $self->{ptr});
  }
}


sub name     { shift->{name} }
sub class    { shift->{class} }
sub ffi      { shift->{ffi} }
sub size     { shift->{size} }
sub align    { shift->{align} }
sub nullable { shift->{nullable} }


sub create
{
  my $self = shift;

  return $self->class->new(@_) if $self->class;

  my $ptr;
  my $owner;

  if(@_ == 2 && ! is_ref $_[0])
  {
    ($ptr, $owner) = @_;
  }
  else
  {
    # TODO: we use 1 byte for size 0
    # this is needed if malloc(0) returns undef.
    # we could special case for platforms where malloc(0)
    # returns a constant pointer that can be free()'d
    $ptr = malloc($self->size ? $self->size : 1);
    memset($ptr, 0, $self->size);
  }

  my $class = ref($self);
  $class =~ s/Def$//;

  my $inst = bless {
    ptr   => $ptr,
    def   => $self,
    owner => $owner,
  }, $class;

  FFI::C::Util::perl_to_c($inst, $_[0]) if @_ == 1 && is_plain_hashref $_[0];

  $inst;
}

package FFI::Platypus::Type::CDef;

use Ref::Util qw( is_blessed_ref );

push @FFI::Platypus::CARP_NOT, __PACKAGE__;

sub ffi_custom_type_api_1
{
  my(undef, undef, %args) = @_;

  my $perl_to_native;
  my $native_to_perl;

  my $name     = $args{name};
  my $class    = $args{class};
  my $def      = $args{def}  || Carp::croak("no def defined");
  my $cdef     = $args{cdef} || Carp::croak("no cdef defined");
  my $nullable = $args{nullable};

  if($class)
  {
    $perl_to_native = sub {
      return undef if !defined $_[0] && $nullable;
      Carp::croak("argument is not a $class")
        unless is_blessed_ref $_[0]
        && $_[0]->isa($class);
      my $ptr = $_[0]->{ptr};
      Carp::croak("pointer for $name went away")
        unless defined $ptr;
      $ptr;
    };
    $native_to_perl = sub {
      defined $_[0]
        ? bless { ptr => $_[0], owner => 1 }, $class
        : undef;
    };
  }

  elsif($name)
  {
    $perl_to_native = sub {
      return undef if !defined $_[0] && $nullable;
      Carp::croak("argument is not a $name")
        unless is_blessed_ref $_[0]
        && ref($_[0]) eq $cdef
        && $_[0]->{def}->{name} eq $name;
      my $ptr = $_[0]->{ptr};
      Carp::croak("pointer for $name went away")
        unless defined $ptr;
      $ptr;
    };
    $native_to_perl = sub {
      defined $_[0]
        ? bless { ptr => $_[0], def => $def, owner => 1 }, $cdef
        : undef;
    };
  }

  return {
    native_type    => 'opaque',
    perl_to_native => $perl_to_native,
    native_to_perl => $native_to_perl,
  }
}

package FFI::C::EnumDef;

sub new
{
  my($class, %self) = @_;
  bless \%self, $class;
}

sub str_lookup { shift->{str_lookup} }
sub int_lookup { shift->{int_lookup} }
sub type { shift->{type} }
sub rev { shift->{rev} }

1;

__END__