1# this module will be loaded by ExtUtils/XSpp/Grammar.pm and needs to 2# define subroutines in the ExtUtils::XSpp::Grammar namespace 3package ExtUtils::XSpp::Lexer; 4# for the indexer and friends 5use strict; 6use warnings; 7 8package ExtUtils::XSpp::Grammar; 9 10use ExtUtils::XSpp::Node; 11use ExtUtils::XSpp::Node::Access; 12use ExtUtils::XSpp::Node::Argument; 13use ExtUtils::XSpp::Node::Class; 14use ExtUtils::XSpp::Node::Comment; 15use ExtUtils::XSpp::Node::Constructor; 16use ExtUtils::XSpp::Node::Destructor; 17use ExtUtils::XSpp::Node::File; 18use ExtUtils::XSpp::Node::Function; 19use ExtUtils::XSpp::Node::Member; 20use ExtUtils::XSpp::Node::Method; 21use ExtUtils::XSpp::Node::Module; 22use ExtUtils::XSpp::Node::Package; 23use ExtUtils::XSpp::Node::Raw; 24use ExtUtils::XSpp::Node::Type; 25use ExtUtils::XSpp::Node::PercAny; 26use ExtUtils::XSpp::Node::Enum; 27use ExtUtils::XSpp::Node::EnumValue; 28use ExtUtils::XSpp::Node::Preprocessor; 29 30use ExtUtils::XSpp::Typemap; 31use ExtUtils::XSpp::Exception; 32 33use Digest::MD5 qw(md5_hex); 34 35my %tokens = ( '::' => 'DCOLON', 36 ':' => 'COLON', 37 '%{' => 'OPSPECIAL', 38 '%}' => 'CLSPECIAL', 39 '{%' => 'OPSPECIAL', 40 '{' => 'OPCURLY', 41 '}' => 'CLCURLY', 42 '(' => 'OPPAR', 43 ')' => 'CLPAR', 44 ';' => 'SEMICOLON', 45 '%' => 'PERC', 46 '~' => 'TILDE', 47 '*' => 'STAR', 48 '&' => 'AMP', 49 '|' => 'PIPE', 50 ',' => 'COMMA', 51 '=' => 'EQUAL', 52 '/' => 'SLASH', 53 '.' => 'DOT', 54 '-' => 'DASH', 55 '<' => 'OPANG', 56 '>' => 'CLANG', 57 # these are here due to my lack of skill with yacc 58 '%name' => 'p_name', 59 '%typemap' => 'p_typemap', 60 '%exception' => 'p_exceptionmap', 61 '%catch' => 'p_catch', 62 '%file' => 'p_file', 63 '%module' => 'p_module', 64 '%code' => 'p_code', 65 '%cleanup' => 'p_cleanup', 66 '%postcall' => 'p_postcall', 67 '%package' => 'p_package', 68 '%length' => 'p_length', 69 '%loadplugin' => 'p_loadplugin', 70 '%include' => 'p_include', 71 '%alias' => 'p_alias', 72 '%_type' => 'p__type', 73 ); 74 75my %keywords = ( const => 1, 76 class => 1, 77 unsigned => 1, 78 short => 1, 79 long => 1, 80 int => 1, 81 char => 1, 82 void => 1, 83 package_static => 1, 84 class_static => 1, 85 static => 1, 86 public => 1, 87 private => 1, 88 protected => 1, 89 virtual => 1, 90 enum => 1, 91 ); 92 93sub get_lex_mode { return $_[0]->YYData->{LEX}{MODES}[0] || '' } 94 95sub push_lex_mode { 96 my( $p, $mode ) = @_; 97 98 push @{$p->YYData->{LEX}{MODES}}, $mode; 99} 100 101sub pop_lex_mode { 102 my( $p, $mode ) = @_; 103 104 die "Unexpected mode: '$mode'" 105 unless get_lex_mode( $p ) eq $mode; 106 107 pop @{$p->YYData->{LEX}{MODES}}; 108} 109 110sub read_more { 111 my $v = readline $_[0]->YYData->{LEX}{FH}; 112 my $buf = $_[0]->YYData->{LEX}{BUFFER}; 113 114 unless( defined $v ) { 115 if( $_[0]->YYData->{LEX}{NEXT} ) { 116 $_[0]->YYData->{LEX} = $_[0]->YYData->{LEX}{NEXT}; 117 $buf = $_[0]->YYData->{LEX}{BUFFER}; 118 119 return $buf if length $$buf; 120 return read_more( $_[0] ); 121 } else { 122 return; 123 } 124 } 125 126 $$buf .= $v; 127 128 return $buf; 129} 130 131# for tests 132sub _random_digits { sprintf '%06d', rand 100000 } 133 134sub push_conditional { 135 my $p = $_[0]; 136 my $file = $p->YYData->{LEX}{FILE} ? 137 substr md5_hex( $p->YYData->{LEX}{FILE} ), 0, 8 : 138 'zzzzzzzz'; 139 my $rand = _random_digits; 140 141 my $symbol = 'XSpp_' . $file . '_' . $rand; 142 push @{$p->YYData->{LEX}{CONDITIONAL}}, $symbol; 143 144 return $symbol; 145} 146 147sub pop_conditional { 148 pop @{$_[0]->YYData->{LEX}{CONDITIONAL}}; 149} 150 151sub get_conditional { 152 return undef unless $_[0]->YYData->{LEX}{CONDITIONAL}; 153 return undef unless @{$_[0]->YYData->{LEX}{CONDITIONAL}}; 154 return $_[0]->YYData->{LEX}{CONDITIONAL}[-1]; 155} 156 157sub yylex { 158 my $data = $_[0]->YYData->{LEX}; 159 my $buf = $data->{BUFFER}; 160 161 for(;;) { 162 if( !length( $$buf ) && !( $buf = read_more( $_[0] ) ) ) { 163 return ( '', undef ); 164 } 165 166 if( get_lex_mode( $_[0] ) eq 'special' ) { 167 if( $$buf =~ s/^%}// ) { 168 return ( 'CLSPECIAL', '%}' ); 169 } elsif( $$buf =~ s/^([^\n]*)\n$// ) { 170 my $line = $1; 171 172 if( $line =~ m/^(.*?)\%}(.*)$/ ) { 173 $$buf = "%}$2\n"; 174 $line = $1; 175 } 176 177 return ( 'line', $line ); 178 } 179 } else { 180 $$buf =~ s/^[\s\n\r]+//; 181 next unless length $$buf; 182 183 if( $$buf =~ s/^([+-]?0x[0-9a-fA-F]+)// ) { 184 return ( 'INTEGER', $1 ); 185 } elsif( $$buf =~ s/^([+-]?(?=\d|\.\d)\d*(?:\.\d*)?(?:[Ee](?:[+-]?\d+))?)// ) { 186 my $v = $1; 187 return ( 'INTEGER', $v ) if $v =~ /^[+-]?\d+$/; 188 return ( 'FLOAT', $v ); 189 } elsif( $$buf =~ s/^\/\/(.*)(?:\r\n|\r|\n)// ) { 190 return ( 'COMMENT', [ $1 ] ); 191 } elsif( $$buf =~ /^\/\*/ ) { 192 my @rows; 193 for(; length( $$buf ) || ( $buf = read_more( $_[0] ) ); $$buf = '') { 194 if( $$buf =~ s/(.*?\*\/)// ) { 195 push @rows, $1; 196 return ( 'COMMENT', \@rows ); 197 } 198 $$buf =~ s/(?:\r\n|\r|\n)$//; 199 push @rows, $$buf; 200 } 201 } elsif( $$buf =~ s/^(\%\w+)// ) { 202 return ( $tokens{$1}, $1 ) if exists $tokens{$1}; 203 return ( 'p_any', substr $1, 1 ); 204 } elsif( $$buf =~ s/^( \%} 205 | \%\{ | \{\% 206 | [{}();%~*&,=\/\.\-<>|] 207 | :: | : 208 )//x ) { 209 return ( $tokens{$1}, $1 ); 210 } elsif( $$buf =~ s/^(INCLUDE(?:_COMMAND)?:.*)(?:\r\n|\r|\n)// ) { 211 return ( 'RAW_CODE', "$1\n" ); 212 } elsif( $$buf =~ s/^([a-zA-Z_]\w*)// ) { 213 return ( $1, $1 ) if exists $keywords{$1}; 214 215 return ( 'ID', $1 ); 216 } elsif( $$buf =~ s/^("[^"]*")// ) { 217 return ( 'QUOTED_STRING', $1 ); 218 } elsif( $$buf =~ s/^(#\s*(if|ifdef|ifndef|else|elif|endif)\b.*)(?:\r\n|\r|\n)// ) { 219 my $symbol; 220 if( $2 eq 'else' || $2 eq 'elif' || $2 eq 'endif' ) { 221 pop_conditional( $_[0] ); 222 } 223 if( $2 ne 'endif' ) { 224 $symbol = push_conditional( $_[0] ); 225 } 226 227 return ( 'PREPROCESSOR', [ $1, $symbol ] ); 228 } elsif( $$buf =~ s/^(#.*)(?:\r\n|\r|\n)// ) { 229 return ( 'RAW_CODE', $1 ); 230 } else { 231 die $$buf; 232 } 233 } 234 } 235} 236 237sub yyerror { 238 my $data = $_[0]->YYData->{LEX}; 239 my $buf = $data->{BUFFER}; 240 my $fh = $data->{FH}; 241 242 print STDERR "Error: line " . $fh->input_line_number . " (Current token type: '", 243 $_[0]->YYCurtok, "') (Current value: '", 244 $_[0]->YYCurval, '\') Buffer: "', ( $buf ? $$buf : '--empty buffer--' ), 245 q{"} . "\n"; 246 print STDERR "Expecting: (", ( join ", ", map { "'$_'" } $_[0]->YYExpect ), 247 ")\n"; 248} 249 250sub make_const { $_[0]->{CONST} = 1; $_[0] } 251sub make_ref { $_[0]->{REFERENCE} = 1; $_[0] } 252sub make_ptr { $_[0]->{POINTER}++; $_[0] } 253sub make_type { ExtUtils::XSpp::Node::Type->new( base => $_[0] ) } 254 255sub make_template { 256 ExtUtils::XSpp::Node::Type->new( base => $_[0], 257 template_args => $_[1], 258 ) 259} 260 261sub add_typemap { 262 my( $name, $type, @args ) = @_; 263 my $tm = ExtUtils::XSpp::Typemap::create( $name, type => $type, @args ); 264 265 ExtUtils::XSpp::Typemap::add_typemap_for_type( $type, $tm ); 266} 267 268sub add_data_raw { 269 my $p = shift; 270 my $rows = shift; 271 272 ExtUtils::XSpp::Node::Raw->new( rows => $rows ); 273} 274 275sub add_data_comment { 276 my $p = shift; 277 my $rows = shift; 278 279 ExtUtils::XSpp::Node::Comment->new( rows => $rows ); 280} 281 282sub add_top_level_directive { 283 my( $parser, %args ) = @_; 284 285 $parser->YYData->{PARSER}->handle_toplevel_tag_plugins 286 ( $args{any}, 287 named => $args{named}, 288 positional => $args{positional}, 289 any_named_arguments => $args{named}, 290 any_positional_arguments => $args{positional}, 291 condition => $parser->get_conditional, 292 ); 293} 294 295sub make_argument { 296 my( $p, $type, $name, $default, @args ) = @_; 297 my %args = @args; 298 _merge_keys( 'tag', \%args, \@args ); 299 300 my $arg = ExtUtils::XSpp::Node::Argument->new 301 ( type => $type, 302 name => $name, 303 default => $default, 304 tags => $args{tag} ); 305 306 return $arg; 307} 308 309sub create_class { 310 my( $parser, $name, $bases, $metadata, $methods, $condition ) = @_; 311 my %args = @$metadata; 312 _merge_keys( 'catch', \%args, $metadata ); 313 314 my $class = ExtUtils::XSpp::Node::Class->new( %args, # <-- catch only for now 315 cpp_name => $name, 316 base_classes => $bases, 317 condition => $condition, 318 ); 319 320 # when adding a class C, automatically add weak typemaps for C* and C& 321 ExtUtils::XSpp::Typemap::add_class_default_typemaps( $name ); 322 323 my @any = grep $_->isa( 'ExtUtils::XSpp::Node::PercAny' ), @$methods; 324 my @rest = grep !$_->isa( 'ExtUtils::XSpp::Node::PercAny' ), @$methods; 325 326 # finish creating the class 327 $class->add_methods( @rest ); 328 329 foreach my $meth ( grep $_->isa( 'ExtUtils::XSpp::Node::Method' ), @rest ) { 330 call_argument_tags( $parser, $meth ); 331 332 my $nodes = $parser->YYData->{PARSER}->handle_method_tags_plugins( $meth, $meth->tags ); 333 334 $class->add_methods( @$nodes ); 335 } 336 337 foreach my $any ( @any ) { 338 if( $any->{NAME} eq 'accessors' ) { 339 # TODO use plugin infrastructure, add decent validation 340 my %args = @{$any->{NAMED_ARGUMENTS}}; 341 if( $args{get_style} ) { 342 if( @{$args{get_style}} ) { 343 $class->set_getter_style( $args{get_style}[0][0] ); 344 } else { 345 die "Invalid accessor style declaration"; 346 } 347 } 348 if( $args{set_style} ) { 349 if( @{$args{set_style}} ) { 350 $class->set_setter_style( $args{set_style}[0][0] ); 351 } else { 352 die "Invalid accessor style declaration"; 353 } 354 } 355 next; 356 } 357 358 my $nodes = $parser->YYData->{PARSER}->handle_class_tag_plugins 359 ( $class, $any->{NAME}, 360 named => $any->{NAMED_ARGUMENTS}, 361 positional => $any->{POSITIONAL_ARGUMENTS}, 362 any_named_arguments => $any->{NAMED_ARGUMENTS}, 363 any_positional_arguments => $any->{POSITIONAL_ARGUMENTS}, 364 ); 365 366 $class->add_methods( @$nodes ); 367 } 368 369 return $class; 370} 371 372# support multiple occurrances of specific keys 373# => transform to flattened array ref 374sub _merge_keys { 375 my $key = shift; 376 my $argshash = shift; 377 my $paramlist = shift; 378 my @occurrances; 379 for (my $i = 0; $i < @$paramlist; $i += 2) { 380 if (defined $paramlist->[$i] and $paramlist->[$i] eq $key) { 381 push @occurrances, $paramlist->[$i+1]; 382 } 383 } 384 @occurrances = map {ref($_) eq 'ARRAY' ? @$_ : $_} @occurrances; 385 $argshash->{$key} = \@occurrances; 386} 387 388 389sub create_member { 390 my( $parser, @args ) = @_; 391 my %args = @args; 392 _merge_keys( 'tag', \%args, \@args ); 393 394 return ExtUtils::XSpp::Node::Member->new 395 ( cpp_name => $args{name}, 396 perl_name => $args{perl_name}, 397 class => $args{class}, 398 type => $args{type}, 399 condition => $args{condition}, 400 tags => $args{tag}, 401 ); 402} 403 404sub add_data_function { 405 my( $parser, @args ) = @_; 406 my %args = @args; 407 _merge_keys( 'catch', \%args, \@args ); 408 _merge_keys( 'alias', \%args, \@args ); 409 _merge_keys( 'tag', \%args, \@args ); 410 $args{alias} = +{@{$args{alias}}} if exists $args{alias}; 411 412 return ExtUtils::XSpp::Node::Function->new 413 ( cpp_name => $args{name}, 414 perl_name => $args{perl_name}, 415 class => $args{class}, 416 ret_type => $args{ret_type}, 417 arguments => $args{arguments}, 418 code => $args{code}, 419 cleanup => $args{cleanup}, 420 postcall => $args{postcall}, 421 catch => $args{catch}, 422 condition => $args{condition}, 423 alias => $args{alias}, 424 tags => $args{tag}, 425 ); 426} 427 428sub add_data_method { 429 my( $parser, @args ) = @_; 430 my %args = @args; 431 _merge_keys( 'catch', \%args, \@args ); 432 _merge_keys( 'alias', \%args, \@args ); 433 _merge_keys( 'tag', \%args, \@args ); 434 $args{alias} = +{@{$args{alias}}} if exists $args{alias}; 435 436 my $m = ExtUtils::XSpp::Node::Method->new 437 ( cpp_name => $args{name}, 438 ret_type => $args{ret_type}, 439 arguments => $args{arguments}, 440 const => $args{const}, 441 code => $args{code}, 442 cleanup => $args{cleanup}, 443 postcall => $args{postcall}, 444 perl_name => $args{perl_name}, 445 catch => $args{catch}, 446 condition => $args{condition}, 447 alias => $args{alias}, 448 tags => $args{tag}, 449 ); 450 451 return $m; 452} 453 454sub add_data_ctor { 455 my( $parser, @args ) = @_; 456 my %args = @args; 457 _merge_keys( 'catch', \%args, \@args ); 458 _merge_keys( 'tag', \%args, \@args ); 459 460 my $m = ExtUtils::XSpp::Node::Constructor->new 461 ( cpp_name => $args{name}, 462 arguments => $args{arguments}, 463 code => $args{code}, 464 cleanup => $args{cleanup}, 465 postcall => $args{postcall}, 466 catch => $args{catch}, 467 condition => $args{condition}, 468 tags => $args{tag}, 469 ); 470 471 return $m; 472} 473 474sub add_data_dtor { 475 my( $parser, @args ) = @_; 476 my %args = @args; 477 _merge_keys( 'catch', \%args, \@args ); 478 _merge_keys( 'tag', \%args, \@args ); 479 480 my $m = ExtUtils::XSpp::Node::Destructor->new 481 ( cpp_name => $args{name}, 482 code => $args{code}, 483 cleanup => $args{cleanup}, 484 postcall => $args{postcall}, 485 catch => $args{catch}, 486 condition => $args{condition}, 487 tags => $args{tag}, 488 ); 489 490 return $m; 491} 492 493sub process_function { 494 my( $parser, $function ) = @_; 495 496 $function->resolve_typemaps; 497 $function->resolve_exceptions; 498 call_argument_tags( $parser, $function ); 499 500 my $nodes = $parser->YYData->{PARSER}->handle_function_tags_plugins( $function, $function->tags ); 501 502 return [ $function, @$nodes ]; 503} 504 505sub call_argument_tags { 506 my( $parser, $function ) = @_; 507 508 foreach my $arg ( @{$function->arguments} ) { 509 $parser->YYData->{PARSER}->handle_argument_tags_plugins( $arg, $arg->tags ); 510 } 511} 512 5131; 514