view release on metacpan or  search on metacpan

lib/FFI/C/Def.pm  view on Meta::CPAN

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

lib/FFI/C/Def.pm  view on Meta::CPAN

  });
}

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,
  }