1package FFI::Platypus::TypeParser::Version1;
2
3use strict;
4use warnings;
5use 5.008004;
6use Carp qw( croak );
7use parent qw( FFI::Platypus::TypeParser );
8
9# ABSTRACT: FFI Type Parser Version One
10our $VERSION = '1.56'; # VERSION
11
12
13our @CARP_NOT = qw( FFI::Platypus FFI::Platypus::TypeParser );
14
15my %reserved = map { $_ => 1 } qw(
16  string
17  object
18  type
19  role
20  union
21  class
22  struct
23  record
24  array
25  senum
26  enum
27);
28
29# The type parser is responsible for deciding if something is a legal
30# alias name.  Since this needs to be checked before the type is parsed
31# it is separate from set_alias below.
32sub check_alias
33{
34  my($self, $alias) = @_;
35  croak "spaces not allowed in alias" if $alias =~ /\s/;
36  croak "allowed characters for alias: [A-Za-z0-9_]" if $alias !~ /^[A-Za-z0-9_]+$/;
37  croak "reserved world \"$alias\" cannot be used as an alias"
38    if $reserved{$alias};
39  croak "alias \"$alias\" conflicts with existing type"
40    if defined $self->type_map->{$alias}
41    || $self->types->{$alias}
42    || $self->global_types->{basic}->{$alias};
43  return 1;
44}
45
46sub set_alias
47{
48  my($self, $alias, $type) = @_;
49  $self->types->{$alias} = $type;
50}
51
52use constant type_regex =>
53
54  qr/^                                                                                                                                                            #
55                                                                                                                                                                  #
56    \s*                                                                                                                                                           # prefix white space
57                                                                                                                                                                  #
58    (?:                                                                                                                                                           #
59                                                                                                                                                                  #
60      \( ([^)]*) \) -> (.*)                                                                                                                                       # closure  $1 argument types, $2 return type
61      |                                                                                                                                                           #
62      (?: string | record ) \s* \( \s* ([0-9]+) \s* \)                                                              (?: \s* (\*) | )                              # fixed record, fixed string $3, ponter $4
63      |                                                                                                                                                           #
64      record                \s* \( (  \s* (?: [A-Za-z_] [A-Za-z_0-9]* :: )* [A-Za-z_] [A-Za-z_0-9]* ) \s* \)        (?: \s* (\*) | )                              # record class $5, pointer $6
65      |                                                                                                                                                           #
66      ( (?: [A-Za-z_] [A-Za-z_0-9]* \s+ )* [A-Za-z_] [A-Za-z_0-9]* )         \s*                                                                                  # unit type name $7
67                                                                                                                                                                  #
68              (?:  (\*)  |   \[ ([0-9]*) \]  |  )                                                                                                                 # pointer $8,       array $9
69      |                                                                                                                                                           #
70      object                \s* \( \s* ( (?: [A-Za-z_] [A-Za-z_0-9]* :: )* [A-Za-z_] [A-Za-z_0-9]* )                                                              # object class $10
71                                   (?: \s*,\s* ( (?: [A-Za-z_] [A-Za-z_0-9]* \s+ )* [A-Za-z_] [A-Za-z_0-9]* ) )?                                                  #        type $11
72                                   \s*                                                                            \)                                              #
73    )                                                                                                                                                             #
74                                                                                                                                                                  #
75    \s*                                                                                                                                                           # trailing white space
76                                                                                                                                                                  #
77  $/x;                                                                                                                                                            #
78
79sub parse
80{
81  my($self, $name, $opt) = @_;
82
83  $opt ||= {};
84
85  return $self->types->{$name} if $self->types->{$name};
86
87  $name =~ type_regex or croak "bad type name: $name";
88
89  if(defined (my $at = $1))  # closure
90  {
91    my $rt = $2;
92    return $self->types->{$name} = $self->create_type_closure(
93      $self->abi,
94      $self->parse($rt, $opt),
95      map { $self->parse($_, $opt) } map { my $t = $_; $t =~ s/^\s+//; $t =~ s/\s+$//; $t } split /,/, $at,
96    );
97  }
98
99  if(defined (my $size = $3))  # fixed record / fixed string
100  {
101    croak "fixed record / fixed string size must be larger than 0"
102      unless $size > 0;
103
104    if(my $pointer = $4)
105    {
106      return $self->types->{$name} = $self->create_type_record(
107        0,
108        $size,
109      );
110    }
111    elsif($opt->{member})
112    {
113      return $self->types->{"$name *"} = $self->create_type_record(
114        0,
115        $size,
116      );
117    }
118    else
119    {
120      croak "fixed string / classless record not allowed as value type";
121    }
122  }
123
124  if(defined (my $class = $5))  # class record
125  {
126    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";
127    if(my $pointer = $6)
128    {
129      return $self->types->{$name} = $self->create_type_record(
130        0,
131        $class->$size_method,
132        $class,
133      );
134    }
135    else
136    {
137      return $self->types->{$name} = $self->create_type_record(
138        1,
139        $class->$size_method,
140        $class,
141        $class->_ffi_meta->ptr,
142      );
143    }
144  }
145
146  if(defined (my $unit_name = $7))  # basic type
147  {
148    if($self->global_types->{basic}->{$unit_name})
149    {
150      if(my $pointer = $8)
151      {
152        croak "void pointer not allowed" if $unit_name eq 'void';
153        return $self->types->{$name} = $self->global_types->{ptr}->{$unit_name};
154      }
155
156      if(defined (my $size = $9))  # array
157      {
158        croak "void array not allowed" if $unit_name eq 'void';
159        if($size ne '')
160        {
161          croak "array size must be larger than 0" if $size < 1;
162          return $self->types->{$name} = $self->create_type_array(
163            $self->global_types->{basic}->{$unit_name}->type_code,
164            $size,
165          );
166        }
167        else
168        {
169          return $self->global_types->{array}->{$unit_name} ||= $self->create_type_array(
170            $self->global_types->{basic}->{$unit_name}->type_code,
171            0,
172          );
173        }
174      }
175
176      # basic type with no decorations
177      return $self->global_types->{basic}->{$unit_name};
178    }
179
180    if(my $map_name = $self->type_map->{$unit_name})
181    {
182      if(my $pointer = $8)
183      {
184        return $self->types->{$name} = $self->parse("$map_name *", $opt);
185      }
186      if(defined (my $size = $9))
187      {
188        if($size ne '')
189        {
190          croak "array size must be larger than 0" if $size < 1;
191          return $self->types->{$name} = $self->parse("$map_name [$size]", $opt);
192        }
193        else
194        {
195          return $self->types->{$name} = $self->parse("$map_name []", $opt);
196        }
197      }
198
199      return $self->types->{$name} = $self->parse("$map_name", $opt);
200    }
201
202    if(my $pointer = $8)
203    {
204      my $unit_type = $self->parse($unit_name, $opt);
205
206      if($unit_type->is_record_value)
207      {
208        my $meta = $unit_type->meta;
209        return $self->types->{$name} = $self->create_type_record(
210          0,
211          $meta->{size},
212          $meta->{class},
213        );
214      }
215
216      my $basic_name = $self->global_types->{rev}->{$unit_type->type_code};
217      if($basic_name)
218      {
219        return $self->types->{$name} = $self->parse("$basic_name *", $opt);
220      }
221      else
222      {
223        croak "cannot make a pointer to $unit_name";
224      }
225    }
226
227    if(defined (my $size = $9))
228    {
229      my $unit_type = $self->parse($unit_name, $opt);
230      my $basic_name = $self->global_types->{rev}->{$unit_type->type_code};
231      if($basic_name)
232      {
233        if($size ne '')
234        {
235          croak "array size must be larger than 0" if $size < 1;
236          return $self->types->{$name} = $self->parse("$basic_name [$size]", $opt);
237        }
238        else
239        {
240          return $self->types->{$name} = $self->parse("$basic_name []", $opt);
241        }
242      }
243      else
244      {
245        croak "cannot make an array of $unit_name";
246      }
247    }
248
249    if($name eq 'string ro')
250    {
251      return $self->global_types->{basic}->{string};
252    }
253    elsif($name eq 'string rw')
254    {
255      return $self->global_types->{v2}->{string_rw} ||= $self->create_type_string(1);
256    }
257
258    return $self->types->{$name} || croak "unknown type: $unit_name";
259  }
260
261  if(defined (my $class = $10)) # object type
262  {
263    my $basic_name = $11 || 'opaque';
264    my $basic_type = $self->parse($basic_name);
265    if($basic_type->is_object_ok)
266    {
267      return $self->types->{$name} = $self->create_type_object(
268        $basic_type->type_code,
269        $class,
270      );
271    }
272    else
273    {
274      croak "cannot make an object of $basic_name";
275    }
276  }
277
278  croak "internal error parsing: $name";
279}
280
2811;
282
283__END__
284
285=pod
286
287=encoding UTF-8
288
289=head1 NAME
290
291FFI::Platypus::TypeParser::Version1 - FFI Type Parser Version One
292
293=head1 VERSION
294
295version 1.56
296
297=head1 SYNOPSIS
298
299 use FFI::Platypus 1.00;
300 my $ffi = FFI::Platypus->new( api => 1 );
301 $ffi->type('record(Foo::Bar)' => 'foo_bar_t');
302 $ffi->type('record(Foo::Bar)*' => 'foo_bar_ptr');
303 $ffi->type('opaque' => 'baz_t');
304 $ffi->type('bar_t*' => 'baz_ptr');
305
306=head1 DESCRIPTION
307
308This documents the second (version 1) type parser for L<FFI::Platypus>.
309This type parser was included with L<FFI::Platypus> starting with version
310C<0.91> in an experimental capability, and C<1.00> as a stable interface.
311Starting with version C<1.00> the main L<FFI::Platypus> documentation
312describes the version 1 API and you can refer to
313L<FFI::Platypus::TypeParser::Version0> for details on the version0 API.
314
315=head1 SEE ALSO
316
317=over 4
318
319=item L<FFI::Platypus>
320
321The core L<FFI::Platypus> documentation.
322
323=item L<FFI::Platypus::TypeParser::Version0>
324
325The API C<0.02> type parser.
326
327=back
328
329=head1 AUTHOR
330
331Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>
332
333Contributors:
334
335Bakkiaraj Murugesan (bakkiaraj)
336
337Dylan Cali (calid)
338
339pipcet
340
341Zaki Mughal (zmughal)
342
343Fitz Elliott (felliott)
344
345Vickenty Fesunov (vyf)
346
347Gregor Herrmann (gregoa)
348
349Shlomi Fish (shlomif)
350
351Damyan Ivanov
352
353Ilya Pavlov (Ilya33)
354
355Petr Písař (ppisar)
356
357Mohammad S Anwar (MANWAR)
358
359Håkon Hægland (hakonhagland, HAKONH)
360
361Meredith (merrilymeredith, MHOWARD)
362
363Diab Jerius (DJERIUS)
364
365Eric Brine (IKEGAMI)
366
367szTheory
368
369José Joaquín Atria (JJATRIA)
370
371Pete Houston (openstrike, HOUSTON)
372
373=head1 COPYRIGHT AND LICENSE
374
375This software is copyright (c) 2015,2016,2017,2018,2019,2020 by Graham Ollis.
376
377This is free software; you can redistribute it and/or modify it under
378the same terms as the Perl 5 programming language system itself.
379
380=cut
381