File Coverage

blib/lib/FFI/Platypus/TypeParser/Version1.pm
Criterion Covered Total %
statement 102 103 99.0
branch 74 76 97.3
condition 22 28 78.5
subroutine 10 10 100.0
pod 0 3 0.0
total 208 220 94.5


line stmt bran cond sub pod time code
1             package FFI::Platypus::TypeParser::Version1;
2              
3 37     37   9503 use strict;
  37         96  
  37         1174  
4 37     37   195 use warnings;
  37         76  
  37         893  
5 37     37   657 use 5.008004;
  37         151  
6 37     37   219 use Carp qw( croak );
  37         127  
  37         2221  
7 37     37   268 use parent qw( FFI::Platypus::TypeParser );
  37         93  
  37         311  
8 37     37   2191 use constant _version => 1;
  37         91  
  37         23092  
9              
10             # ABSTRACT: FFI Type Parser Version One
11             our $VERSION = '2.06_01'; # TRIAL VERSION
12              
13              
14             our @CARP_NOT = qw( FFI::Platypus FFI::Platypus::TypeParser );
15              
16             my %reserved = map { $_ => 1 } qw(
17             string
18             object
19             type
20             role
21             union
22             class
23             struct
24             record
25             array
26             senum
27             enum
28             );
29              
30             # The type parser is responsible for deciding if something is a legal
31             # alias name. Since this needs to be checked before the type is parsed
32             # it is separate from set_alias below.
33             sub check_alias
34             {
35 237     237 0 7860 my($self, $alias) = @_;
36 237 100       1108 croak "spaces not allowed in alias" if $alias =~ /\s/;
37 235 100       1291 croak "allowed characters for alias: [A-Za-z0-9_]" if $alias !~ /^[A-Za-z0-9_]+$/;
38             croak "reserved world \"$alias\" cannot be used as an alias"
39 233 100       1082 if $reserved{$alias};
40             croak "alias \"$alias\" conflicts with existing type"
41             if defined $self->type_map->{$alias}
42             || $self->types->{$alias}
43 229 100 100     660 || $self->global_types->{basic}->{$alias};
      100        
44 223         522 return 1;
45             }
46              
47             sub set_alias
48             {
49 225     225 0 532 my($self, $alias, $type) = @_;
50 225         516 $self->types->{$alias} = $type;
51             }
52              
53 37         44503 use constant type_regex =>
54              
55             qr/^ #
56             #
57             \s* # prefix white space
58             #
59             (?: #
60             #
61             \( ([^)]*) \) -> (.*) # closure, argument types $1, return type $2
62             | #
63             ( string | record ) \s* \( \s* ([0-9]+) \s* \) (?: \s* (\*) | ) # fixed record $3, fixed string $4, ponter $5
64             | #
65             record \s* \( ( \s* (?: [A-Za-z_] [A-Za-z_0-9]* :: )* [A-Za-z_] [A-Za-z_0-9]* ) \s* \) (?: \s* (\*) | ) # record class $6, pointer $7
66             | #
67             ( (?: [A-Za-z_] [A-Za-z_0-9]* \s+ )* [A-Za-z_] [A-Za-z_0-9]* ) \s* # unit type name $8
68             #
69             (?: (\*) | \[ ([0-9]*) \] | ) # pointer $9, array $10
70             | #
71             object \s* \( \s* ( (?: [A-Za-z_] [A-Za-z_0-9]* :: )* [A-Za-z_] [A-Za-z_0-9]* ) # object class $11
72             (?: \s*,\s* ( (?: [A-Za-z_] [A-Za-z_0-9]* \s+ )* [A-Za-z_] [A-Za-z_0-9]* ) )? # type $12
73             \s* \) #
74             ) #
75             #
76             \s* # trailing white space
77             #
78 37     37   313 $/x; #
  37         95  
79              
80             sub parse
81             {
82 2662     2662 0 97073 my($self, $name, $opt) = @_;
83              
84 2662   100     9898 $opt ||= {};
85              
86 2662 100       6277 return $self->types->{$name} if $self->types->{$name};
87              
88 1935 100       13546 $name =~ type_regex or croak "bad type name: $name";
89              
90 1926 100       5457 if(defined (my $at = $1)) # closure
91             {
92 54         128 my $rt = $2;
93             return $self->types->{$name} = $self->create_type_closure(
94             $self->abi,
95             $self->parse($rt, $opt),
96 54         256 map { $self->parse($_, $opt) } map { my $t = $_; $t =~ s/^\s+//; $t =~ s/\s+$//; $t } split /,/, $at,
  37         90  
  37         95  
  37         101  
  37         89  
  37         116  
97             );
98             }
99              
100 1872 100       4143 if(defined (my $size = $4)) # fixed record / fixed string
101             {
102 45 100       1380 croak "fixed record / fixed string size must be larger than 0"
103             unless $size > 0;
104              
105 33 100 100     200 if(my $pointer = $5)
    100 66        
106             {
107 19         141 return $self->types->{$name} = $self->create_type_record(
108             0,
109             $size,
110             );
111             }
112             elsif($opt->{member} || ($3 eq 'string' && $self->_version > 1))
113             {
114 7         60 return $self->types->{"$name *"} = $self->create_type_record(
115             0,
116             $size,
117             );
118             }
119             else
120             {
121 7 100       28 if($self->_version > 1)
122             {
123 1         163 croak "classless record not allowed as value type";
124             }
125             else
126             {
127 6         669 croak "fixed string / classless record not allowed as value type";
128             }
129             }
130             }
131              
132 1827 100       4138 if(defined (my $class = $6)) # class record
133             {
134 15   66     718 my $size_method = $class->can('ffi_record_size') || $class->can('_ffi_record_size') || croak "$class has no ffi_record_size or _ffi_record_size method";
135 11 100       50 if(my $pointer = $7)
136             {
137 5         32 return $self->types->{$name} = $self->create_type_record(
138             0,
139             $class->$size_method,
140             $class,
141             );
142             }
143             else
144             {
145 6         54 return $self->types->{$name} = $self->create_type_record(
146             1,
147             $class->$size_method,
148             $class,
149             $class->_ffi_meta->ptr,
150             );
151             }
152             }
153              
154 1812 100       4308 if(defined (my $unit_name = $8)) # basic type
155             {
156 1786 100       4344 if($self->global_types->{basic}->{$unit_name})
157             {
158 1590 100       3464 if(my $pointer = $9)
159             {
160 69 100       434 croak "void pointer not allowed" if $unit_name eq 'void';
161 67         183 return $self->types->{$name} = $self->global_types->{ptr}->{$unit_name};
162             }
163              
164 1521 100       3581 if(defined (my $size = $10)) # array
165             {
166 144 100       672 croak "void array not allowed" if $unit_name eq 'void';
167 142 100       396 if($size ne '')
168             {
169 55 100       427 croak "array size must be larger than 0" if $size < 1;
170             return $self->types->{$name} = $self->create_type_array(
171 53         162 $self->global_types->{basic}->{$unit_name}->type_code,
172             $size,
173             );
174             }
175             else
176             {
177             return $self->global_types->{array}->{$unit_name} ||= $self->create_type_array(
178 87   66     260 $self->global_types->{basic}->{$unit_name}->type_code,
179             0,
180             );
181             }
182             }
183              
184             # basic type with no decorations
185 1377         2877 return $self->global_types->{basic}->{$unit_name};
186             }
187              
188 196 100       569 if(my $map_name = $self->type_map->{$unit_name})
189             {
190 158 100       470 if(my $pointer = $9)
191             {
192 14         53 return $self->types->{$name} = $self->parse("$map_name *", $opt);
193             }
194 144 100       448 if(defined (my $size = $10))
195             {
196 19 100       51 if($size ne '')
197             {
198 11 100       323 croak "array size must be larger than 0" if $size < 1;
199 9         38 return $self->types->{$name} = $self->parse("$map_name [$size]", $opt);
200             }
201             else
202             {
203 8         29 return $self->types->{$name} = $self->parse("$map_name []", $opt);
204             }
205             }
206              
207 125         670 return $self->types->{$name} = $self->parse("$map_name", $opt);
208             }
209              
210 38 100       124 if(my $pointer = $9)
211             {
212 7         23 my $unit_type = $self->parse($unit_name, $opt);
213              
214 7 100       39 if($unit_type->is_record_value)
215             {
216 3         24 my $meta = $unit_type->meta;
217             return $self->types->{$name} = $self->create_type_record(
218             0,
219             $meta->{size},
220             $meta->{class},
221 3         23 );
222             }
223              
224 4         15 my $basic_name = $self->global_types->{rev}->{$unit_type->type_code};
225 4 100       13 if($basic_name)
226             {
227 2         9 return $self->types->{$name} = $self->parse("$basic_name *", $opt);
228             }
229             else
230             {
231 2         237 croak "cannot make a pointer to $unit_name";
232             }
233             }
234              
235 31 100       94 if(defined (my $size = $10))
236             {
237 18         125 my $unit_type = $self->parse($unit_name, $opt);
238 18         58 my $basic_name = $self->global_types->{rev}->{$unit_type->type_code};
239 18 100       70 if($basic_name)
240             {
241 14 100       79 if($size ne '')
242             {
243 2 50       13 croak "array size must be larger than 0" if $size < 1;
244 2         13 return $self->types->{$name} = $self->parse("$basic_name [$size]", $opt);
245             }
246             else
247             {
248 12         54 return $self->types->{$name} = $self->parse("$basic_name []", $opt);
249             }
250             }
251             else
252             {
253 4         431 croak "cannot make an array of $unit_name";
254             }
255             }
256              
257 13 100       60 if($name eq 'string ro')
    100          
258             {
259 4         13 return $self->global_types->{basic}->{string};
260             }
261             elsif($name eq 'string rw')
262             {
263 7   66     21 return $self->global_types->{v2}->{string_rw} ||= $self->create_type_string(1);
264             }
265              
266 2   33     16 return $self->types->{$name} || croak "unknown type: $unit_name";
267             }
268              
269 26 50       108 if(defined (my $class = $11)) # object type
270             {
271 26   100     172 my $basic_name = $12 || 'opaque';
272 26         82 my $basic_type = $self->parse($basic_name);
273 26 100       148 if($basic_type->is_object_ok)
274             {
275 24         290 return $self->types->{$name} = $self->create_type_object(
276             $basic_type->type_code,
277             $class,
278             );
279             }
280             else
281             {
282 2         229 croak "cannot make an object of $basic_name";
283             }
284             }
285              
286 0           croak "internal error parsing: $name";
287             }
288              
289             1;
290              
291             __END__