File Coverage

blib/lib/FFI/Platypus/Record.pm

Criterion	Covered	Total	%
statement	115	117	98.2
branch	35	44	79.5
condition	11	18	61.1
subroutine	14	15	93.3
pod	2	2	100.0
total	177	196	90.3

package FFI::Platypus::Record;

use strict;
use warnings;
use 5.008004;
use Carp qw( croak );
use FFI::Platypus;
use Exporter qw( import );
use constant 1.32 ();

our @EXPORT = qw( record_layout record_layout_1 );

# ABSTRACT: FFI support for structured records data
our $VERSION = '2.08'; # VERSION


sub record_layout_1
{
  if(@_ % 2 == 0)
  {
    my $ffi = FFI::Platypus->new( api => 2);
    unshift @_, $ffi;
    goto &record_layout;
  }
  elsif(defined $_[0] && ref($_[0]) eq 'ARRAY')
  {
    my @args = @{ shift @_ };
    unshift @args, api => 2;
    unshift @_, \@args;
    goto &record_layout;
  }
  elsif(defined $_[0] && eval { $_[0]->isa('FFI::Platypus') })
  {
    goto &record_layout;
  }
  else
  {
    croak "odd number of arguments, but first argument is not either an array reference or Platypus instance";
  }
}


sub record_layout
{
  my $ffi;

  if(defined $_[0])
  {
    if(ref($_[0]) eq 'ARRAY')
    {
      my @args = @{ shift() };
      $ffi = FFI::Platypus->new(@args);
    }
    elsif(eval { $_[0]->isa('FFI::Platypus') })
    {
      $ffi = shift;
    }
  }

  $ffi ||= FFI::Platypus->new;

  my $offset = 0;
  my $record_align = 0;

  croak "uneven number of arguments!" if scalar(@_) % 2;

  my($caller, $filename, $line) = caller;

  if($caller->can("_ffi_record_size")
  || $caller->can("ffi_record_size"))
  {
    croak "record already defined for the class $caller";
  }

  my @destroy;
  my @ffi_types;
  my $has_string;

  while(@_)
  {
    my $spec = shift;
    my $name = shift;
    my $type = $ffi->{tp}->parse( $spec, { member => 1 } );

    croak "illegal name $name"
      unless $name =~ /^[A-Za-z_][A-Za-z_0-9]*$/
      ||     $name eq ':';
    croak "accessor/method $name already exists"
      if $caller->can($name);

    my $size      = $type->sizeof;
    my $align     = $type->alignof;
    $record_align = $align if $align > $record_align;
    my $meta      = $type->meta;

    $offset++ while $offset % $align;

    {
      my $count;
      my $ffi_type;

      if($meta->{type} eq 'record') # this means fixed string atm
      {
        $ffi_type = 'sint8';
        $count = $size;
      }
      else
      {
        $ffi_type = $meta->{ffi_type};
        $count    = $meta->{element_count};
        $count    = 1 unless defined $count;

        $has_string = 1 if $meta->{type} eq 'string';
      }
      push @ffi_types, $ffi_type for 1..$count;
    }

    if($name ne ':')
    {

      if($meta->{type} eq 'string'
      && $meta->{access} eq 'rw')
      {
        push @destroy, eval '# line '. __LINE__ . ' "' . __FILE__ . qq("\n) .qq{
          sub {
            shift->$name(undef);
          };
        };
        die $@ if $@;
      }

      my $full_name = join '::', $caller, $name;
      my $error_str = _accessor
        $full_name,
        "$filename:$line",
        $type,
        $offset;
      croak("$error_str ($spec $name)") if $error_str;
    };

    $offset += $size;
  }

  my $size = $offset;

  no strict 'refs';
  constant->import("${caller}::_ffi_record_size", $size);
  constant->import("${caller}::_ffi_record_align", $record_align);
  *{join '::', $caller, '_ffi_record_ro'} = \&_ffi_record_ro;
  *{join '::', $caller, 'new'} = sub {
    my $class = shift;
    my $args = ref($_[0]) ? [%{$_[0]}] : \@_;
    croak "uneven number of arguments to record constructor"
      if @$args % 2;
    my $record = "\0" x $class->_ffi_record_size;
    my $self = bless \$record, $class;

    while(@$args)
    {
      my $key = shift @$args;
      my $value = shift @$args;
      $self->$key($value);
    }

    $self;
  };

  {
    require FFI::Platypus::Record::Meta;
    my $ffi_meta = FFI::Platypus::Record::Meta->new(
      \@ffi_types,
      !$has_string,
    );
    *{join '::', $caller, '_ffi_meta'} = sub { $ffi_meta };
  }

  my $destroy_sub = sub {};

  if(@destroy)
  {
    $destroy_sub = sub {
      return if _ffi_record_ro($_[0]);
      $_->($_[0]) for @destroy;
    };
  }
  do {
    no strict 'refs';
    *{"${caller}::DESTROY"} = $destroy_sub;
  };
  ();
}

1;

__END__