File Coverage

blib/lib/FFI/Platypus/TypeParser/Version0.pm

Criterion	Covered	Total	%
statement	64	68	94.1
branch	35	40	87.5
condition	21	32	65.6
subroutine	8	8	100.0
pod	0	3	0.0
total	128	151	84.7

package FFI::Platypus::TypeParser::Version0;

use strict;
use warnings;
use 5.008004;
use Carp qw( croak );
use parent qw( FFI::Platypus::TypeParser );

# ABSTRACT: FFI Type Parser Version Zero
our $VERSION = '2.06_01'; # TRIAL VERSION


our @CARP_NOT = qw( FFI::Platypus FFI::Platypus::TypeParser );

# The type parser is responsible for deciding if something is a legal
# alias name.  Since this needs to be checked before the type is parsed
# it is separate from set_alias below.
sub check_alias
{
  my($self, $alias) = @_;
  croak "spaces not allowed in alias" if $alias =~ /\s/;
  croak "allowed characters for alias: [A-Za-z0-9_]" if $alias !~ /^[A-Za-z0-9_]+$/;
  croak "alias \"$alias\" conflicts with existing type"
    if defined $self->type_map->{$alias}
    || $self->types->{$alias};
  return 1;
}

sub set_alias
{
  my($self, $alias, $type) = @_;
  $self->types->{$alias} = $type;
}

# This method takes a string representation of the a type and
# returns the internal platypus type representation.
sub parse
{
  my($self, $name) = @_;

  return $self->types->{$name} if defined $self->types->{$name};

  # Darmock and Legacy Code at Tanagra
  unless($name =~ /-\>/ || $name =~ /^record\s*\([0-9A-Z:a-z_]+\)$/
  || $name =~ /^string(_rw|_ro|\s+rw|\s+ro|\s*\([0-9]+\))$/)
  {
    my $basic = $name;
    my $extra = '';
    if($basic =~ s/\s*((\*|\[|\<).*)$//)
    {
      $extra = " $1";
    }
    if(defined $self->type_map->{$basic})
    {
      my $new_name = $self->type_map->{$basic} . $extra;
      if($new_name ne $name)
      {
        # hopefully no recursion here.
        return $self->types->{$name} = $self->parse($new_name);
      }
    }
  }

  if($name =~ m/^ \( (.*) \) \s* -\> \s* (.*) \s* $/x)
  {
    my @argument_types = map { $self->parse($_) } map { my $t = $_; $t =~ s/^\s+//; $t =~ s/\s+$//; $t } split /,/, $1;
    my $return_type = $self->parse($2);
    return $self->types->{$name} = $self->create_type_closure($self->abi, $return_type, @argument_types);
  }

  if($name =~ /^ string \s* \( ([0-9]+) \) $/x)
  {
    return $self->types->{$name} = $self->create_type_record(
      0,
      $1,    # size
    );
  }

  if($name =~ /^ string ( _rw | _ro | \s+ro | \s+rw | ) $/x)
  {
    return $self->types->{$name} = $self->create_type_string(
      defined $1 && $1 =~ /rw/ ? 1 : 0,   # rw
   );
  }

  if($name =~ /^ record \s* \( ([0-9]+) \) $/x)
  {
    return $self->types->{$name} = $self->create_type_record(
      0,
      $1,             # size
    );
  }

  if($name =~ /^ record \s* \( ([0-9:A-Za-z_]+) \) $/x)
  {
    my $size;
    my $classname = $1;
    unless($classname->can('ffi_record_size') || $classname->can('_ffi_record_size'))
    {
      my $pm = "$classname.pm";
      $pm =~ s/\//::/g;
      require $pm;
    }
    if($classname->can('ffi_record_size'))
    {
      $size = $classname->ffi_record_size;
    }
    elsif($classname->can('_ffi_record_size'))
    {
      $size = $classname->_ffi_record_size;
    }
    else
    {
      croak "$classname has not ffi_record_size or _ffi_record_size method";
    }
    return $self->global_types->{record}->{$classname} ||= $self->create_type_record(
      0,
      $size,          # size
      $classname,     # record_class
    );
  }

  # array types
  if($name =~ /^([\S]+)\s+ \[ ([0-9]*) \] $/x)
  {
    my $size = $2 || '';
    my $basic = $self->global_types->{basic}->{$1} || croak("unknown ffi/platypus type $name [$size]");
    if($size)
    {
      return $self->types->{$name} = $self->create_type_array(
        $basic->type_code,
        $size,
      );
    }
    else
    {
      return $self->global_types->{array}->{$name} ||= $self->create_type_array(
        $basic->type_code,
        0
      );
    }
  }

  # pointer types
  if($name =~ s/\s+\*$//)
  {
    return $self->global_types->{ptr}->{$name} || croak("unknown ffi/platypus type $name *");
  }

  # basic types
  return $self->global_types->{basic}->{$name} || croak("unknown ffi/platypus type $name");
}

1;

__END__