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


line stmt bran cond sub pod time code
1             package FFI::Platypus::TypeParser::Version0;
2              
3 48     48   9516 use strict;
  48         139  
  48         1620  
4 48     48   288 use warnings;
  48         150  
  48         1672  
5 48     48   1088 use 5.008004;
  48         229  
6 48     48   324 use Carp qw( croak );
  48         109  
  48         3028  
7 48     48   362 use parent qw( FFI::Platypus::TypeParser );
  48         186  
  48         317  
8              
9             # ABSTRACT: FFI Type Parser Version Zero
10             our $VERSION = '2.08'; # VERSION
11              
12              
13             our @CARP_NOT = qw( FFI::Platypus FFI::Platypus::TypeParser );
14              
15             # The type parser is responsible for deciding if something is a legal
16             # alias name. Since this needs to be checked before the type is parsed
17             # it is separate from set_alias below.
18             sub check_alias
19             {
20 197     197 0 417 my($self, $alias) = @_;
21 197 50       687 croak "spaces not allowed in alias" if $alias =~ /\s/;
22 197 50       940 croak "allowed characters for alias: [A-Za-z0-9_]" if $alias !~ /^[A-Za-z0-9_]+$/;
23             croak "alias \"$alias\" conflicts with existing type"
24             if defined $self->type_map->{$alias}
25 197 50 33     597 || $self->types->{$alias};
26 197         468 return 1;
27             }
28              
29             sub set_alias
30             {
31 197     197 0 439 my($self, $alias, $type) = @_;
32 197         428 $self->types->{$alias} = $type;
33             }
34              
35             # This method takes a string representation of the a type and
36             # returns the internal platypus type representation.
37             sub parse
38             {
39 2034     2034 0 3983 my($self, $name) = @_;
40              
41 2034 100       4640 return $self->types->{$name} if defined $self->types->{$name};
42              
43             # Darmock and Legacy Code at Tanagra
44 1380 100 100     8071 unless($name =~ /-\>/ || $name =~ /^record\s*\([0-9A-Z:a-z_]+\)$/
      100        
45             || $name =~ /^string(_rw|_ro|\s+rw|\s+ro|\s*\([0-9]+\))$/)
46             {
47 1278         2181 my $basic = $name;
48 1278         1904 my $extra = '';
49 1278 100       6611 if($basic =~ s/\s*((\*|\[|\<).*)$//)
50             {
51 357         930 $extra = " $1";
52             }
53 1278 100       3049 if(defined $self->type_map->{$basic})
54             {
55 1243         2588 my $new_name = $self->type_map->{$basic} . $extra;
56 1243 100       3218 if($new_name ne $name)
57             {
58             # hopefully no recursion here.
59 149         554 return $self->types->{$name} = $self->parse($new_name);
60             }
61             }
62             }
63              
64 1231 100       3050 if($name =~ m/^ \( (.*) \) \s* -\> \s* (.*) \s* $/x)
65             {
66 41         188 my @argument_types = map { $self->parse($_) } map { my $t = $_; $t =~ s/^\s+//; $t =~ s/\s+$//; $t } split /,/, $1;
  36         126  
  36         100  
  36         91  
  36         73  
  36         108  
67 41         124 my $return_type = $self->parse($2);
68 41         178 return $self->types->{$name} = $self->create_type_closure($self->abi, $return_type, @argument_types);
69             }
70              
71 1190 100       2784 if($name =~ /^ string \s* \( ([0-9]+) \) $/x)
72             {
73 11         165 return $self->types->{$name} = $self->create_type_record(
74             0,
75             $1, # size
76             );
77             }
78              
79 1179 100       2523 if($name =~ /^ string ( _rw | _ro | \s+ro | \s+rw | ) $/x)
80             {
81 67 100 66     847 return $self->types->{$name} = $self->create_type_string(
82             defined $1 && $1 =~ /rw/ ? 1 : 0, # rw
83             );
84             }
85              
86 1112 100       2197 if($name =~ /^ record \s* \( ([0-9]+) \) $/x)
87             {
88 6         106 return $self->types->{$name} = $self->create_type_record(
89             0,
90             $1, # size
91             );
92             }
93              
94 1106 100       2292 if($name =~ /^ record \s* \( ([0-9:A-Za-z_]+) \) $/x)
95             {
96 33         53 my $size;
97 33         84 my $classname = $1;
98 33 50 66     278 unless($classname->can('ffi_record_size') || $classname->can('_ffi_record_size'))
99             {
100 0         0 my $pm = "$classname.pm";
101 0         0 $pm =~ s/\//::/g;
102 0         0 require $pm;
103             }
104 33 100       160 if($classname->can('ffi_record_size'))
    50          
105             {
106 2         12 $size = $classname->ffi_record_size;
107             }
108             elsif($classname->can('_ffi_record_size'))
109             {
110 31         75 $size = $classname->_ffi_record_size;
111             }
112             else
113             {
114 0         0 croak "$classname has not ffi_record_size or _ffi_record_size method";
115             }
116 33   66     98 return $self->global_types->{record}->{$classname} ||= $self->create_type_record(
117             0,
118             $size, # size
119             $classname, # record_class
120             );
121             }
122              
123             # array types
124 1073 100       2672 if($name =~ /^([\S]+)\s+ \[ ([0-9]*) \] $/x)
125             {
126 207   100     790 my $size = $2 || '';
127 207   33     540 my $basic = $self->global_types->{basic}->{$1} || croak("unknown ffi/platypus type $name [$size]");
128 207 100       526 if($size)
129             {
130 183         1463 return $self->types->{$name} = $self->create_type_array(
131             $basic->type_code,
132             $size,
133             );
134             }
135             else
136             {
137 24   66     75 return $self->global_types->{array}->{$name} ||= $self->create_type_array(
138             $basic->type_code,
139             0
140             );
141             }
142             }
143              
144             # pointer types
145 866 100       2088 if($name =~ s/\s+\*$//)
146             {
147 81   33     273 return $self->global_types->{ptr}->{$name} || croak("unknown ffi/platypus type $name *");
148             }
149              
150             # basic types
151 785   66     1917 return $self->global_types->{basic}->{$name} || croak("unknown ffi/platypus type $name");
152             }
153              
154             1;
155              
156             __END__