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