1package Perl::PrereqScanner::NotQuiteLite; 2 3use strict; 4use warnings; 5use Carp; 6use Perl::PrereqScanner::NotQuiteLite::Context; 7use Perl::PrereqScanner::NotQuiteLite::Util; 8 9our $VERSION = '0.9914'; 10 11our @BUNDLED_PARSERS = qw/ 12 Aliased AnyMoose Autouse Catalyst ClassAccessor 13 ClassAutouse ClassLoad Core Inline KeywordDeclare Later 14 Mixin ModuleRuntime MojoBase Moose MooseXDeclare ObjectPad Only 15 PackageVariant Plack POE Prefork Superclass Syntax SyntaxCollector 16 TestClassMost TestMore TestRequires UniversalVersion Unless 17/; 18our @DEFAULT_PARSERS = qw/Core Moose/; 19 20### Helpers For Debugging 21 22use constant DEBUG => !!$ENV{PERL_PSNQL_DEBUG} || 0; 23use constant DEBUG_RE => DEBUG > 3 ? 1 : 0; 24 25sub _debug {} 26sub _error {} 27sub _dump_stack {} 28 29if (DEBUG) { 30 require Data::Dump; Data::Dump->import(qw/dump/); 31 no warnings 'redefine'; 32 *_debug = sub { print @_, "\n" }; 33 *_error = sub { print @_, "*" x 50, "\n" }; 34 *_dump_stack = sub { 35 my ($c, $char) = @_; 36 my $stacked = join '', map {($_->[2] ? "($_->[2])" : '').$_->[0]} @{$c->{stack}}; 37 _debug("$char \t\t\t\t stacked: $stacked"); 38 }; 39} 40 41sub _match_error { 42 my $rstr = shift; 43 $@ = shift() . substr($$rstr, pos($$rstr), 100); 44 return; 45} 46 47### Global Variables To Be Sorted Out Later 48 49my %unsupported_packages = map {$_ => 1} qw( 50); 51 52my %sub_keywords = ( 53 'Function::Parameters' => [qw/fun method/], 54 'TryCatch' => [qw/try catch/], 55); 56 57my %filter_modules = ( 58 tt => sub { ${$_[0]} =~ s|\G.+?no\s*tt\s*;||s; 0; }, 59 'Text::RewriteRules' => sub { ${$_[0]} =~ s|RULES.+?ENDRULES\n||gs; 1 }, 60); 61 62my %is_conditional = map {$_ => 1} qw( 63 if elsif unless else given when 64 for foreach while until 65); 66 67my %ends_expr = map {$_ => 1} qw( 68 and or xor 69 if else elsif unless when default 70 for foreach while until 71 && || !~ =~ = += -= *= /= **= //= %= ^= |= 72 > < >= <= <> <=> cmp ge gt le lt eq ne ? : 73); 74 75my %has_sideff = map {$_ => 1} qw( 76 and or xor && || // 77 if unless when 78); 79 80# keywords that allow /regexp/ to follow directly 81my %regexp_may_follow = map {$_ => 1} qw( 82 and or cmp if elsif unless eq ne 83 gt lt ge le for while until grep map not split when 84 return 85); 86 87my $re_namespace = qr/(?:::|')?(?:[a-zA-Z0-9_]+(?:(?:::|')[a-zA-Z0-9_]+)*)/; 88my $re_nonblock_chars = qr/[^\\\(\)\{\}\[\]\<\>\/"'`#q~,\s]*/; 89my $re_variable = qr/ 90 (?:$re_namespace) 91 | (?:\^[A-Z\]]) 92 | (?:\{\^[A-Z0-9_]+\}) 93 | (?:[_"\(\)<\\\&`'\+\-,.\/\%#:=~\|?!\@\*\[\]\^]) 94/x; 95my $re_pod = qr/( 96 =[a-zA-Z]\w*\b 97 .*? 98 (?:(?:\n) 99 =cut\b.*?(?:\n|\z)|\z) 100)/sx; 101my $re_comment = qr/(?:\s*#[^\n]*?\n)*(?:\s*#[^\n]*?)(?:\n|$)/s; 102 103my $g_re_scalar_variable = qr{\G(\$(?:$re_variable))}; 104my $g_re_hash_shortcut = qr{\G(\{\s*(?:[\+\-]?\w+|(['"])[\w\s]+\2|(?:$re_nonblock_chars))\s*(?<!\$)\})}; 105my $g_re_prototype = qr{\G(\([^\)]*?\))}; 106 107my %ReStrInDelims; 108sub _gen_re_str_in_delims { 109 my $delim = shift; 110 $ReStrInDelims{$delim} ||= do { 111 if ($delim eq '\\') { 112 qr/(?:[^\\]*(?:(?:\\\\)[^\\]*)*)/s; 113 } else { 114 $delim = quotemeta $delim; 115 qr/(?:[^\\$delim]*(?:\\.[^\\$delim]*)*)/s; 116 } 117 }; 118} 119 120my $re_str_in_single_quotes = _gen_re_str_in_delims(q{'}); 121my $re_str_in_double_quotes = _gen_re_str_in_delims(q{"}); 122my $re_str_in_backticks = _gen_re_str_in_delims(q{`}); 123 124my %ReStrInDelimsWithEndDelim; 125sub _gen_re_str_in_delims_with_end_delim { 126 my $delim = shift; 127 $ReStrInDelimsWithEndDelim{$delim} ||= do { 128 my $re = _gen_re_str_in_delims($delim); 129 qr{$re\Q$delim\E}; 130 }; 131} 132 133my %RdelSkip; 134sub _gen_rdel_and_re_skip { 135 my $ldel = shift; 136 @{$RdelSkip{$ldel} ||= do { 137 (my $rdel = $ldel) =~ tr/[({</])}>/; 138 my $re_skip = qr{[^\Q$ldel$rdel\E\\]+}; 139 [$rdel, $re_skip]; 140 }}; 141} 142 143my %RegexpShortcut; 144sub _gen_re_regexp_shortcut { 145 my ($ldel, $rdel) = @_; 146 $RegexpShortcut{$ldel} ||= do { 147 $ldel = quotemeta $ldel; 148 $rdel = $rdel ? quotemeta $rdel : $ldel; 149 qr{(?:[^\\\(\)\{\}\[\]<>$ldel$rdel]*(?:\\.[^\\\(\)\[\]\{\}<>$ldel$rdel]*)*)$rdel}; 150 }; 151} 152 153############################ 154 155my %LOADED; 156 157sub new { 158 my ($class, %args) = @_; 159 160 my %mapping; 161 my @parsers = $class->_get_parsers($args{parsers}); 162 for my $parser (@parsers) { 163 if (!exists $LOADED{$parser}) { 164 eval "require $parser; 1"; 165 if (my $error = $@) { 166 $parser->can('register') or die "Parser Error: $error"; 167 } 168 $LOADED{$parser} = $parser->can('register') ? $parser->register(%args) : undef; 169 } 170 my $parser_mapping = $LOADED{$parser} or next; 171 for my $type (qw/use no keyword method/) { 172 next unless exists $parser_mapping->{$type}; 173 for my $name (keys %{$parser_mapping->{$type}}) { 174 $mapping{$type}{$name} = [ 175 $parser, 176 $parser_mapping->{$type}{$name}, 177 (($type eq 'use' or $type eq 'no') ? ($name) : ()), 178 ]; 179 } 180 } 181 if ($parser->can('register_fqfn')) { 182 my $fqfn_mapping = $parser->register_fqfn; 183 for my $name (keys %$fqfn_mapping) { 184 my ($module) = $name =~ /^(.+)::/; 185 $mapping{keyword}{$name} = [ 186 $parser, 187 $fqfn_mapping->{$name}, 188 $module, 189 ]; 190 } 191 } 192 } 193 $args{_} = \%mapping; 194 195 bless \%args, $class; 196} 197 198sub _get_parsers { 199 my ($class, $list) = @_; 200 my @parsers; 201 my %should_ignore; 202 for my $parser (@{$list || [qw/:default/]}) { 203 if ($parser eq ':installed') { 204 require Module::Find; 205 push @parsers, Module::Find::findsubmod("$class\::Parser"); 206 } elsif ($parser eq ':bundled') { 207 push @parsers, map {"$class\::Parser::$_"} @BUNDLED_PARSERS; 208 } elsif ($parser eq ':default') { 209 push @parsers, map {"$class\::Parser::$_"} @DEFAULT_PARSERS; 210 } elsif ($parser =~ s/^\+//) { 211 push @parsers, $parser; 212 } elsif ($parser =~ s/^\-//) { 213 $should_ignore{"$class\::Parser\::$parser"} = 1; 214 } elsif ($parser =~ /^$class\::Parser::/) { 215 push @parsers, $parser; 216 } else { 217 push @parsers, "$class\::Parser\::$parser"; 218 } 219 } 220 grep {!$should_ignore{$_}} @parsers; 221} 222 223sub scan_file { 224 my ($self, $file) = @_; 225 _debug("START SCANNING $file") if DEBUG; 226 print STDERR " Scanning $file\n" if $self->{verbose}; 227 open my $fh, '<', $file or croak "Can't open $file: $!"; 228 my $code = do { local $/; <$fh> }; 229 $self->{file} = $file; 230 $self->scan_string($code); 231} 232 233sub scan_string { 234 my ($self, $string) = @_; 235 236 $string = '' unless defined $string; 237 238 my $c = Perl::PrereqScanner::NotQuiteLite::Context->new(%$self); 239 240 if ($self->{quick}) { 241 $c->{file_size} = length $string; 242 $self->_skim_string($c, \$string) if $c->{file_size} > 30_000; 243 } 244 245 # UTF8 BOM 246 if ($string =~ s/\A(\xef\xbb\xbf)//s) { 247 utf8::decode($string); 248 $c->{decoded} = 1; 249 } 250 # Other BOMs (TODO: also decode?) 251 $string =~ s/\A(\x00\x00\xfe\xff|\xff\xfe\x00\x00|\xfe\xff|\xff\xfe)//s; 252 253 # normalize 254 if ("\n" eq "\015") { 255 $string =~ s/(?:\015?\012)/\n/gs; 256 } elsif ("\n" eq "\012") { 257 $string =~ s/(?:\015\012?)/\n/gs; 258 } elsif ("\n" eq "\015\012") { 259 $string =~ s/(?:\015(?!\012)|(?<!\015)\012)/\n/gs; 260 } else { 261 $string =~ s/(?:\015\012|\015|\012)/\n/gs; 262 } 263 $string =~ s/[ \t]+/ /g; 264 $string =~ s/(?: *\n)+/\n/gs; 265 266 # FIXME 267 $c->{stack} = []; 268 $c->{errors} = []; 269 $c->{callback} = { 270 use => \&_use, 271 require => \&_require, 272 no => \&_no, 273 }; 274 $c->{wants_doc} = 0; 275 276 pos($string) = 0; 277 278 { 279 local $@; 280 eval { $self->_scan($c, \$string, 0) }; 281 push @{$c->{errors}}, "Scan Error: $@" if $@; 282 if ($c->{redo}) { 283 delete $c->{redo}; 284 delete $c->{ended}; 285 @{$c->{stack}} = (); 286 redo; 287 } 288 } 289 290 if (@{$c->{stack}} and !$c->{quick}) { 291 require Data::Dump; 292 push @{$c->{errors}}, Data::Dump::dump($c->{stack}); 293 } 294 295 $c->remove_inner_packages_from_requirements; 296 $c->merge_perl; 297 298 $c; 299} 300 301sub _skim_string { 302 my ($self, $c, $rstr) = @_; 303 my $pos = pos($$rstr) || 0; 304 my $last_found = 0; 305 my $saw_moose; 306 my $re = qr/\G.*?\b((?:use|require|no)\s+(?:[A-Za-z][A-Za-z0-9_]*::)*[A-Za-z][A-Za-z0-9_]*)/; 307 while(my ($match) = $$rstr =~ /$re/gc) { 308 $last_found = pos($$rstr) + length $match; 309 if (!$saw_moose and $match =~ /^use\s+(?:Mo(?:o|(?:[ou]se))?X?|MooseX::Declare)\b/) { 310 $re = qr/\G.*?\b((?:(?:use|require|no)\s+(?:[A-Za-z][A-Za-z0-9_]*::)*[A-Za-z][A-Za-z0-9_]*)|(?:(?:extends|with)\s+(?:["']|q[a-z]*[^a-zA-Z0-9_])(?:[A-Za-z][A-Za-z0-9_]*::)*[A-Za-z][A-Za-z0-9_]*))/; 311 $saw_moose = 1; 312 } 313 } 314 $c->{last_found_by_skimming} = $last_found; 315 pos($$rstr) = $pos; 316} 317 318sub _scan { 319 my ($self, $c, $rstr, $parent_scope) = @_; 320 321 if (@{$c->{stack}} > 90) { 322 _error("deep recursion found"); 323 $c->{ended} = 1; 324 } 325 326 _dump_stack($c, "BEGIN SCOPE") if DEBUG; 327 328 # found __DATA|END__ somewhere? 329 return $c if $c->{ended}; 330 331 my $wants_doc = $c->{wants_doc}; 332 my $line_top = 1; 333 my $waiting_for_a_block; 334 335 my $current_scope = 0; 336 my ($token, $token_desc, $token_type) = ('', '', ''); 337 my ($prev_token, $prev_token_type) = ('', ''); 338 my ($stack, $unstack); 339 my (@keywords, @tokens, @scope_tokens); 340 my $caller_package; 341 my $prepend; 342 my ($pos, $c1); 343 my $prev_pos = 0; 344 while(defined($pos = pos($$rstr))) { 345 $token = undef; 346 347 # cache first letter for better performance 348 $c1 = substr($$rstr, $pos, 1); 349 350 if ($line_top) { 351 if ($c1 eq '=') { 352 if ($$rstr =~ m/\G($re_pod)/gcsx) { 353 ($token, $token_desc, $token_type) = ($1, 'POD', '') if $wants_doc; 354 next; 355 } 356 } 357 } 358 if ($c1 eq "\n") { 359 pos($$rstr)++; 360 $line_top = 1; 361 next; 362 } 363 364 $line_top = 0; 365 # ignore whitespaces 366 if ($c1 eq ' ') { 367 pos($$rstr)++; 368 next; 369 } elsif ($c1 eq '_') { 370 my $c2 = substr($$rstr, $pos + 1, 1); 371 if ($c2 eq '_' and $$rstr =~ m/\G(__(?:DATA|END)__\b)(?!\s*=>)/gc) { 372 if ($wants_doc) { 373 ($token, $token_desc, $token_type) = ($1, 'END_OF_CODE', ''); 374 next; 375 } else { 376 $c->{ended} = 1; 377 last; 378 } 379 } 380 } elsif ($c1 eq '#') { 381 if ($$rstr =~ m{\G($re_comment)}gcs) { 382 ($token, $token_desc, $token_type) = ($1, 'COMMENT', '') if $wants_doc; 383 $line_top = 1; 384 next; 385 } 386 } elsif ($c1 eq ';') { 387 pos($$rstr) = $pos + 1; 388 ($token, $token_desc, $token_type) = ($c1, ';', ';'); 389 $current_scope |= F_STATEMENT_END|F_EXPR_END; 390 next; 391 } elsif ($c1 eq '$') { 392 my $c2 = substr($$rstr, $pos + 1, 1); 393 if ($c2 eq '#') { 394 if (substr($$rstr, $pos + 2, 1) eq '{') { 395 if ($$rstr =~ m{\G(\$\#\{[\w\s]+\})}gc) { 396 ($token, $token_desc, $token_type) = ($1, '$#{NAME}', 'EXPR'); 397 next; 398 } else { 399 pos($$rstr) = $pos + 3; 400 ($token, $token_desc, $token_type) = ('$#{', '$#{', 'EXPR'); 401 $stack = [$token, $pos, 'VARIABLE']; 402 next; 403 } 404 } elsif ($$rstr =~ m{\G(\$\#(?:$re_namespace))}gc) { 405 ($token, $token_desc, $token_type) = ($1, '$#NAME', 'EXPR'); 406 next; 407 } elsif ($prev_token_type eq 'ARROW') { 408 my $c3 = substr($$rstr, $pos + 2, 1); 409 if ($c3 eq '*') { 410 pos($$rstr) = $pos + 3; 411 ($token, $token_desc, $token_type) = ('$#*', 'VARIABLE', 'VARIABLE'); 412 $c->add_perl('5.020', '->$#*'); 413 next; 414 } 415 } else { 416 pos($$rstr) = $pos + 2; 417 ($token, $token_desc, $token_type) = ('$#', 'SPECIAL_VARIABLE', 'EXPR'); 418 next; 419 } 420 } elsif ($c2 eq '$') { 421 if ($$rstr =~ m{\G(\$(?:\$)+(?:$re_namespace))}gc) { 422 ($token, $token_desc, $token_type) = ($1, '$$NAME', 'VARIABLE'); 423 next; 424 } else { 425 pos($$rstr) = $pos + 2; 426 ($token, $token_desc, $token_type) = ('$$', 'SPECIAL_VARIABLE', 'EXPR'); 427 next; 428 } 429 } elsif ($c2 eq '{') { 430 if ($$rstr =~ m{\G(\$\{[\w\s]+\})}gc) { 431 ($token, $token_desc, $token_type) = ($1, '${NAME}', 'VARIABLE'); 432 if ($prev_token_type eq 'KEYWORD' and $c->token_expects_fh_or_block_list($prev_token)) { 433 $token_type = ''; 434 next; 435 } 436 } elsif ($$rstr =~ m{\G(\$\{\^[A-Z_]+\})}gc) { 437 ($token, $token_desc, $token_type) = ($1, '${^NAME}', 'VARIABLE'); 438 if ($token eq '${^CAPTURE}' or $token eq '${^CAPTURE_ALL}') { 439 $c->add_perl('5.026', '${^CAPTURE}'); 440 } 441 if ($token eq '${^SAFE_LOCALES}') { 442 $c->add_perl('5.028', '${^SAFE_LOCALES}'); 443 } 444 } else { 445 pos($$rstr) = $pos + 2; 446 ($token, $token_desc, $token_type) = ('${', '${', 'VARIABLE'); 447 $stack = [$token, $pos, 'VARIABLE']; 448 } 449 if ($parent_scope & F_EXPECTS_BRACKET) { 450 $current_scope |= F_SCOPE_END; 451 } 452 next; 453 } elsif ($c2 eq '*' and $prev_token_type eq 'ARROW') { 454 pos($$rstr) = $pos + 2; 455 ($token, $token_desc, $token_type) = ('$*', '$*', 'VARIABLE'); 456 $c->add_perl('5.020', '->$*'); 457 next; 458 } elsif ($c2 eq '+' or $c2 eq '-') { 459 pos($$rstr) = $pos + 2; 460 ($token, $token_desc, $token_type) = ('$'.$c2, 'SPECIAL_VARIABLE', 'VARIABLE'); 461 $c->add_perl('5.010', '$'.$c2); 462 next; 463 } elsif ($$rstr =~ m{$g_re_scalar_variable}gc) { 464 ($token, $token_desc, $token_type) = ($1, '$NAME', 'VARIABLE'); 465 next; 466 } else { 467 pos($$rstr) = $pos + 1; 468 ($token, $token_desc, $token_type) = ($c1, $c1, 'VARIABLE'); 469 next; 470 } 471 } elsif ($c1 eq '@') { 472 my $c2 = substr($$rstr, $pos + 1, 1); 473 if ($c2 eq '_' and $$rstr =~ m{\G\@_\b}gc) { 474 ($token, $token_desc, $token_type) = ('@_', 'SPECIAL_VARIABLE', 'VARIABLE'); 475 next; 476 } elsif ($c2 eq '{') { 477 if ($$rstr =~ m{\G(\@\{[\w\s]+\})}gc) { 478 ($token, $token_desc, $token_type) = ($1, '@{NAME}', 'VARIABLE'); 479 if ($token eq '@{^CAPTURE}' or $token eq '@{^CAPTURE_ALL}') { 480 $c->add_perl('5.026', '@{^CAPTURE}'); 481 } 482 } elsif ($$rstr =~ m{\G(\@\{\^[A-Z_]+\})}gc) { 483 ($token, $token_desc, $token_type) = ($1, '@{^NAME}', 'VARIABLE'); 484 if ($token eq '@{^CAPTURE}' or $token eq '@{^CAPTURE_ALL}') { 485 $c->add_perl('5.026', '@{^CAPTURE}'); 486 } 487 } else { 488 pos($$rstr) = $pos + 2; 489 ($token, $token_desc, $token_type) = ('@{', '@{', 'VARIABLE'); 490 $stack = [$token, $pos, 'VARIABLE']; 491 } 492 if ($prev_token_type eq 'ARROW') { 493 $c->add_perl('5.020', '->@{}'); 494 } 495 if ($parent_scope & F_EXPECTS_BRACKET) { 496 $current_scope |= F_SCOPE_END; 497 } 498 next; 499 } elsif ($c2 eq '$') { 500 if ($$rstr =~ m{\G(\@\$(?:$re_namespace))}gc) { 501 ($token, $token_desc, $token_type) = ($1, '@$NAME', 'VARIABLE'); 502 next; 503 } else { 504 pos($$rstr) = $pos + 2; 505 ($token, $token_desc, $token_type) = ('@$', '@$', 'VARIABLE'); 506 next; 507 } 508 } elsif ($prev_token_type eq 'ARROW') { 509 # postderef 510 if ($c2 eq '*') { 511 pos($$rstr) = $pos + 2; 512 ($token, $token_desc, $token_type) = ('@*', '@*', 'VARIABLE'); 513 $c->add_perl('5.020', '->@*'); 514 next; 515 } else { 516 pos($$rstr) = $pos + 1; 517 ($token, $token_desc, $token_type) = ('@', '@', 'VARIABLE'); 518 $c->add_perl('5.020', '->@'); 519 next; 520 } 521 } elsif ($c2 eq '[') { 522 pos($$rstr) = $pos + 2; 523 ($token, $token_desc, $token_type) = ('@[', 'SPECIAL_VARIABLE', 'VARIABLE'); 524 next; 525 } elsif ($c2 eq '+' or $c2 eq '-') { 526 pos($$rstr) = $pos + 2; 527 ($token, $token_desc, $token_type) = ('@'.$c2, 'SPECIAL_VARIABLE', 'VARIABLE'); 528 $c->add_perl('5.010', '@'.$c2); 529 next; 530 } elsif ($$rstr =~ m{\G(\@(?:$re_namespace))}gc) { 531 ($token, $token_desc, $token_type) = ($1, '@NAME', 'VARIABLE'); 532 next; 533 } else { 534 pos($$rstr) = $pos + 1; 535 ($token, $token_desc, $token_type) = ($c1, $c1, 'VARIABLE'); 536 next; 537 } 538 } elsif ($c1 eq '%') { 539 my $c2 = substr($$rstr, $pos + 1, 1); 540 if ($c2 eq '{') { 541 if ($$rstr =~ m{\G(\%\{[\w\s]+\})}gc) { 542 ($token, $token_desc, $token_type) = ($1, '%{NAME}', 'VARIABLE'); 543 } elsif ($$rstr =~ m{\G(\%\{\^[A-Z_]+\})}gc) { 544 ($token, $token_desc, $token_type) = ($1, '%{^NAME}', 'VARIABLE'); 545 if ($token eq '%{^CAPTURE}' or $token eq '%{^CAPTURE_ALL}') { 546 $c->add_perl('5.026', '%{^CAPTURE}'); 547 } 548 } else { 549 pos($$rstr) = $pos + 2; 550 ($token, $token_desc, $token_type) = ('%{', '%{', 'VARIABLE'); 551 $stack = [$token, $pos, 'VARIABLE']; 552 } 553 if ($prev_token_type eq 'ARROW') { 554 $c->add_perl('5.020', '->%{'); 555 } 556 if ($parent_scope & F_EXPECTS_BRACKET) { 557 $current_scope |= F_SCOPE_END; 558 } 559 next; 560 } elsif ($c2 eq '=') { 561 pos($$rstr) = $pos + 2; 562 ($token, $token_desc, $token_type) = ('%=', '%=', 'OP'); 563 next; 564 } elsif ($$rstr =~ m{\G(\%\$(?:$re_namespace))}gc) { 565 ($token, $token_desc, $token_type) = ($1, '%$NAME', 'VARIABLE'); 566 next; 567 } elsif ($$rstr =~ m{\G(\%(?:$re_namespace))}gc) { 568 ($token, $token_desc, $token_type) = ($1, '%NAME', 'VARIABLE'); 569 next; 570 } elsif ($prev_token_type eq 'VARIABLE' or $prev_token_type eq 'EXPR') { 571 pos($$rstr) = $pos + 1; 572 ($token, $token_desc, $token_type) = ($c1, $c1, 'OP'); 573 next; 574 } elsif ($prev_token_type eq 'ARROW') { 575 if ($c2 eq '*') { 576 pos($$rstr) = $pos + 2; 577 ($token, $token_desc, $token_type) = ('%*', '%*', 'VARIABLE'); 578 $c->add_perl('5.020', '->%*'); 579 next; 580 } else { 581 pos($$rstr) = $pos + 1; 582 ($token, $token_desc, $token_type) = ('%', '%', 'VARIABLE'); 583 $c->add_perl('5.020', '->%'); 584 next; 585 } 586 } elsif ($c2 eq '+' or $c2 eq '-') { 587 pos($$rstr) = $pos + 2; 588 ($token, $token_desc, $token_type) = ('%'.$c2, 'SPECIAL_VARIABLE', 'VARIABLE'); 589 $c->add_perl('5.010', '%'.$c2); 590 next; 591 } else { 592 pos($$rstr) = $pos + 1; 593 ($token, $token_desc, $token_type) = ($c1, $c1, 'VARIABLE'); 594 next; 595 } 596 } elsif ($c1 eq '*') { 597 my $c2 = substr($$rstr, $pos + 1, 1); 598 if ($c2 eq '{') { 599 if ($prev_token_type eq 'ARROW') { 600 pos($$rstr) = $pos + 2; 601 ($token, $token_desc, $token_type) = ('*{', '*{', 'VARIABLE'); 602 $c->add_perl('5.020', '->*{}'); 603 next; 604 } elsif ($$rstr =~ m{\G(\*\{[\w\s]+\})}gc) { 605 ($token, $token_desc, $token_type) = ($1, '*{NAME}', 'VARIABLE'); 606 if ($prev_token eq 'KEYWORD' and $c->token_expects_fh_or_block_list($prev_token)) { 607 $token_type = ''; 608 next; 609 } 610 } else { 611 pos($$rstr) = $pos + 2; 612 ($token, $token_desc, $token_type) = ('*{', '*{', 'VARIABLE'); 613 $stack = [$token, $pos, 'VARIABLE']; 614 } 615 if ($parent_scope & F_EXPECTS_BRACKET) { 616 $current_scope |= F_SCOPE_END; 617 } 618 next; 619 } elsif ($c2 eq '*') { 620 if (substr($$rstr, $pos + 2, 1) eq '=') { 621 pos($$rstr) = $pos + 3; 622 ($token, $token_desc, $token_type) = ('**=', '**=', 'OP'); 623 next; 624 } elsif ($prev_token_type eq 'ARROW') { 625 pos($$rstr) = $pos + 2; 626 ($token, $token_desc, $token_type) = ('**', '**', 'VARIABLE'); 627 $c->add_perl('5.020', '->**'); 628 next; 629 } else { 630 pos($$rstr) = $pos + 2; 631 ($token, $token_desc, $token_type) = ('**', '**', 'OP'); 632 next; 633 } 634 } elsif ($c2 eq '=') { 635 pos($$rstr) = $pos + 2; 636 ($token, $token_desc, $token_type) = ('*=', '*=', 'OP'); 637 next; 638 } elsif ($$rstr =~ m{\G(\*(?:$re_namespace))}gc) { 639 ($token, $token_desc, $token_type) = ($1, '*NAME', 'VARIABLE'); 640 next; 641 } else { 642 pos($$rstr) = $pos + 1; 643 ($token, $token_desc, $token_type) = ($c1, $c1, 'OP'); 644 next; 645 } 646 } elsif ($c1 eq '&') { 647 my $c2 = substr($$rstr, $pos + 1, 1); 648 if ($c2 eq '&') { 649 pos($$rstr) = $pos + 2; 650 ($token, $token_desc, $token_type) = ('&&', '&&', 'OP'); 651 next; 652 } elsif ($c2 eq '=') { 653 pos($$rstr) = $pos + 2; 654 ($token, $token_desc, $token_type) = ('&=', '&=', 'OP'); 655 next; 656 } elsif ($c2 eq '{') { 657 if ($$rstr =~ m{\G(\&\{[\w\s]+\})}gc) { 658 ($token, $token_desc, $token_type) = ($1, '&{NAME}', 'EXPR'); 659 } else { 660 pos($$rstr) = $pos + 2; 661 ($token, $token_desc, $token_type) = ('&{', '&{', 'EXPR'); 662 $stack = [$token, $pos, 'FUNC']; 663 } 664 if ($parent_scope & F_EXPECTS_BRACKET) { 665 $current_scope |= F_SCOPE_END; 666 } 667 next; 668 } elsif ($c2 eq '.') { 669 if (substr($$rstr, $pos + 2, 1) eq '=') { 670 pos($$rstr) = $pos + 3; 671 ($token, $token_desc, $token_type) = ('&.=', '&.=', 'OP'); 672 } else { 673 pos($$rstr) = $pos + 2; 674 ($token, $token_desc, $token_type) = ('&.', '&.', 'OP'); 675 } 676 $c->add_perl('5.022', '&.'); 677 next; 678 } elsif ($$rstr =~ m{\G(\&(?:$re_namespace))}gc) { 679 ($token, $token_desc, $token_type) = ($1, '&NAME', 'EXPR'); 680 next; 681 } elsif ($$rstr =~ m{\G(\&\$(?:$re_namespace))}gc) { 682 ($token, $token_desc, $token_type) = ($1, '&$NAME', 'EXPR'); 683 next; 684 } elsif ($prev_token_type eq 'ARROW') { 685 if ($c2 eq '*') { 686 pos($$rstr) = $pos + 2; 687 ($token, $token_desc, $token_type) = ('&*', '&*', 'VARIABLE'); 688 $c->add_perl('5.020', '->&*'); 689 next; 690 } 691 } else { 692 pos($$rstr) = $pos + 1; 693 ($token, $token_desc, $token_type) = ($c1, $c1, 'OP'); 694 next; 695 } 696 } elsif ($c1 eq '\\') { 697 my $c2 = substr($$rstr, $pos + 1, 1); 698 if ($c2 eq '{') { 699 if ($$rstr =~ m{\G(\\\{[\w\s]+\})}gc) { 700 ($token, $token_desc, $token_type) = ($1, '\\{NAME}', 'VARIABLE'); 701 } else { 702 pos($$rstr) = $pos + 2; 703 ($token, $token_desc, $token_type) = ('\\{', '\\{', 'VARIABLE'); 704 $stack = [$token, $pos, 'VARIABLE']; 705 } 706 if ($parent_scope & F_EXPECTS_BRACKET) { 707 $current_scope |= F_SCOPE_END; 708 } 709 next; 710 } else { 711 pos($$rstr) = $pos + 1; 712 ($token, $token_desc, $token_type) = ($c1, $c1, ''); 713 next; 714 } 715 } elsif ($c1 eq '-') { 716 my $c2 = substr($$rstr, $pos + 1, 1); 717 if ($c2 eq '>') { 718 pos($$rstr) = $pos + 2; 719 ($token, $token_desc, $token_type) = ('->', 'ARROW', 'ARROW'); 720 if ($prev_token_type eq 'WORD' or $prev_token_type eq 'KEYWORD') { 721 $caller_package = $prev_token; 722 $current_scope |= F_KEEP_TOKENS; 723 } 724 next; 725 } elsif ($c2 eq '-') { 726 pos($$rstr) = $pos + 2; 727 ($token, $token_desc, $token_type) = ('--', '--', $prev_token_type); 728 next; 729 } elsif ($c2 eq '=') { 730 pos($$rstr) = $pos + 2; 731 ($token, $token_desc, $token_type) = ('-=', '-=', 'OP'); 732 next; 733 } elsif ($$rstr =~ m{\G(\-[ABCMORSTWXbcdefgkloprstuwxz]\b)}gc) { 734 ($token, $token_desc, $token_type) = ($1, 'FILE_TEST', 'EXPR'); 735 next; 736 } else { 737 pos($$rstr) = $pos + 1; 738 ($token, $token_desc, $token_type) = ($c1, $c1, 'OP'); 739 next; 740 } 741 } elsif ($c1 eq q{"}) { 742 if ($$rstr =~ m{\G(?:\"($re_str_in_double_quotes)\")}gcs) { 743 ($token, $token_desc, $token_type) = ([$1, q{"}], 'STRING', 'STRING'); 744 next; 745 } 746 } elsif ($c1 eq q{'}) { 747 if ($$rstr =~ m{\G(?:\'($re_str_in_single_quotes)\')}gcs) { 748 ($token, $token_desc, $token_type) = ([$1, q{'}], 'STRING', 'STRING'); 749 next; 750 } 751 } elsif ($c1 eq '`') { 752 if ($$rstr =~ m{\G(?:\`($re_str_in_backticks)\`)}gcs) { 753 ($token, $token_desc, $token_type) = ([$1, q{`}], 'BACKTICK', 'EXPR'); 754 next; 755 } 756 } elsif ($c1 eq '/') { 757 if ($prev_token_type eq '' or $prev_token_type eq 'OP' or ($prev_token_type eq 'KEYWORD' and $regexp_may_follow{$prev_token})) { # undoubtedly regexp 758 if (my $regexp = $self->_match_regexp0($c, $rstr, $pos, 'm')) { 759 ($token, $token_desc, $token_type) = ($regexp, 'REGEXP', 'EXPR'); 760 next; 761 } else { 762 # the above may fail 763 _debug("REGEXP ERROR: $@") if DEBUG; 764 pos($$rstr) = $pos; 765 } 766 } 767 if (($prev_token_type eq '' or (!($current_scope & F_EXPR) and $prev_token_type eq 'WORD')) or ($prev_token_type eq 'KEYWORD' and @keywords and $prev_token eq $keywords[-1] and $regexp_may_follow{$prev_token})) { 768 769 if (my $regexp = $self->_match_regexp0($c, $rstr, $pos)) { 770 ($token, $token_desc, $token_type) = ($regexp, 'REGEXP', 'EXPR'); 771 next; 772 } else { 773 # the above may fail 774 _debug("REGEXP ERROR: $@") if DEBUG; 775 pos($$rstr) = $pos; 776 } 777 } 778 my $c2 = substr($$rstr, $pos + 1, 1); 779 if ($c2 eq '/') { 780 if (substr($$rstr, $pos + 2, 1) eq '=') { 781 pos($$rstr) = $pos + 3; 782 ($token, $token_desc, $token_type) = ('//=', '//=', 'OP'); 783 $c->add_perl('5.010', '//='); 784 next; 785 } else { 786 pos($$rstr) = $pos + 2; 787 ($token, $token_desc, $token_type) = ('//', '//', 'OP'); 788 $c->add_perl('5.010', '//'); 789 next; 790 } 791 } 792 if ($c2 eq '=') { # this may be a part of /=.../ 793 pos($$rstr) = $pos + 2; 794 ($token, $token_desc, $token_type) = ('/=', '/=', 'OP'); 795 next; 796 } else { 797 pos($$rstr) = $pos + 1; 798 ($token, $token_desc, $token_type) = ($c1, $c1, 'OP'); 799 next; 800 } 801 } elsif ($c1 eq '{') { 802 if ($$rstr =~ m{$g_re_hash_shortcut}gc) { 803 ($token, $token_desc) = ($1, '{EXPR}'); 804 if ($current_scope & F_EVAL) { 805 $current_scope &= MASK_EVAL; 806 $c->{eval} = ($current_scope | $parent_scope) & F_EVAL ? 1 : 0; 807 } 808 if ($parent_scope & F_EXPECTS_BRACKET) { 809 $current_scope |= F_SCOPE_END; 810 next; 811 } 812 if ($prev_token_type eq 'ARROW' or $prev_token_type eq 'VARIABLE') { 813 $token_type = 'VARIABLE'; 814 next; 815 } elsif ($waiting_for_a_block) { 816 $waiting_for_a_block = 0; 817 if (@keywords and $c->token_expects_block($keywords[0])) { 818 my $first_token = $keywords[0]; 819 $current_scope |= F_EXPR_END; 820 if ($c->token_defines_sub($first_token) and $c->has_callback_for(sub => $first_token)) { 821 $c->run_callback_for(sub => $first_token, \@tokens); 822 $current_scope &= MASK_KEEP_TOKENS; 823 @tokens = (); 824 } 825 } 826 next; 827 } elsif ($prev_token_type eq 'KEYWORD' and $c->token_expects_fh_or_block_list($prev_token)) { 828 $token_type = ''; 829 next; 830 } else { 831 $token_type = 'EXPR'; 832 next; 833 } 834 } 835 pos($$rstr) = $pos + 1; 836 ($token, $token_desc) = ($c1, $c1); 837 my $stack_owner; 838 if (@keywords) { 839 for(my $i = @keywords; $i > 0; $i--) { 840 my $keyword = $keywords[$i - 1]; 841 if ($c->token_expects_block($keyword)) { 842 $stack_owner = $keyword; 843 if (@tokens and $c->token_defines_sub($keyword) and $c->has_callback_for(sub => $keyword)) { 844 $c->run_callback_for(sub => $keyword, \@tokens); 845 $current_scope &= MASK_KEEP_TOKENS; 846 @tokens = (); 847 } 848 last; 849 } 850 } 851 } 852 $stack = [$token, $pos, $stack_owner || '']; 853 if ($parent_scope & F_EXPECTS_BRACKET) { 854 $current_scope |= F_SCOPE_END|F_STATEMENT_END|F_EXPR_END; 855 next; 856 } 857 if ($prev_token_type eq 'ARROW' or $prev_token_type eq 'VARIABLE') { 858 $token_type = 'VARIABLE'; 859 } elsif ($waiting_for_a_block) { 860 $waiting_for_a_block = 0; 861 } else { 862 $token_type = (($current_scope | $parent_scope) & F_KEEP_TOKENS) ? 'EXPR' : ''; 863 } 864 next; 865 } elsif ($c1 eq '[') { 866 if ($$rstr =~ m{\G(\[(?:$re_nonblock_chars)\])}gc) { 867 ($token, $token_desc, $token_type) = ($1, '[EXPR]', 'VARIABLE'); 868 next; 869 } else { 870 pos($$rstr) = $pos + 1; 871 ($token, $token_desc, $token_type) = ($c1, $c1, 'VARIABLE'); 872 $stack = [$token, $pos, 'VARIABLE']; 873 next; 874 } 875 } elsif ($c1 eq '(') { 876 my $prototype_re = $c->prototype_re; 877 if ($waiting_for_a_block and @keywords and $c->token_defines_sub($keywords[-1]) and $$rstr =~ m{$prototype_re}gc) { 878 my $proto = $1; 879 if ($proto =~ /^\([\\\$\@\%\&\[\]\*;\+]*\)$/) { 880 ($token, $token_desc, $token_type) = ($proto, '(PROTOTYPE)', ''); 881 } else { 882 ($token, $token_desc, $token_type) = ($proto, '(SIGNATURES)', ''); 883 $c->add_perl('5.020', 'signatures'); 884 } 885 next; 886 } elsif ($$rstr =~ m{\G\(((?:$re_nonblock_chars)(?<!\$))\)}gc) { 887 ($token, $token_desc, $token_type) = ([[[$1, 'EXPR']]], '()', 'EXPR'); 888 if ($prev_token_type eq 'KEYWORD' and @keywords and $keywords[-1] eq $prev_token and !$c->token_expects_expr_block($prev_token)) { 889 if ($prev_token eq 'eval') { 890 $current_scope &= MASK_EVAL; 891 $c->{eval} = ($current_scope | $parent_scope) & F_EVAL ? 1 : 0; 892 } 893 pop @keywords; 894 } 895 next; 896 } else { 897 pos($$rstr) = $pos + 1; 898 ($token, $token_desc, $token_type) = ($c1, $c1, 'EXPR'); 899 my $stack_owner; 900 if (@keywords) { 901 for (my $i = @keywords; $i > 0; $i--) { 902 my $keyword = $keywords[$i - 1]; 903 if ($c->token_expects_block($keyword)) { 904 $stack_owner = $keyword; 905 last; 906 } 907 } 908 } 909 $stack = [$token, $pos, $stack_owner || '']; 910 next; 911 } 912 } elsif ($c1 eq '}') { 913 pos($$rstr) = $pos + 1; 914 ($token, $token_desc, $token_type) = ($c1, $c1, ''); 915 $unstack = $token; 916 $current_scope |= F_STATEMENT_END|F_EXPR_END; 917 next; 918 } elsif ($c1 eq ']') { 919 pos($$rstr) = $pos + 1; 920 ($token, $token_desc, $token_type) = ($c1, $c1, ''); 921 $unstack = $token; 922 next; 923 } elsif ($c1 eq ')') { 924 pos($$rstr) = $pos + 1; 925 ($token, $token_desc, $token_type) = ($c1, $c1, ''); 926 $unstack = $token; 927 next; 928 } elsif ($c1 eq '<') { 929 my $c2 = substr($$rstr, $pos + 1, 1); 930 if ($c2 eq '<'){ 931 if ($$rstr =~ m{\G(<<(?: 932 \\. | 933 \w+ | 934 [./-] | 935 \[[^\]]*\] | 936 \{[^\}]*\} | 937 \* | 938 \? | 939 \~ | 940 \$ | 941 )*(?<!\-)>>)}gcx) { 942 ($token, $token_desc, $token_type) = ($1, '<<NAME>>', 'EXPR'); 943 $c->add_perl('5.022', '<<NAME>>'); 944 next; 945 } elsif ($$rstr =~ m{\G<<~?\s*(?: 946 \\?[A-Za-z_][\w]* | 947 "(?:[^\\"]*(?:\\.[^\\"]*)*)" | 948 '(?:[^\\']*(?:\\.[^\\']*)*)' | 949 `(?:[^\\`]*(?:\\.[^\\`]*)*)` 950 )}sx) { 951 if (my $heredoc = $self->_match_heredoc($c, $rstr)) { 952 ($token, $token_desc, $token_type) = ($heredoc, 'HEREDOC', 'EXPR'); 953 next; 954 } else { 955 # the above may fail 956 pos($$rstr) = $pos; 957 } 958 } 959 if (substr($$rstr, $pos + 2, 1) eq '=') { 960 pos($$rstr) = $pos + 3; 961 ($token, $token_desc, $token_type) = ('<<=', '<<=', 'OP'); 962 next; 963 } else { 964 pos($$rstr) = $pos + 2; 965 ($token, $token_desc, $token_type) = ('<<', '<<', 'OP'); 966 next; 967 } 968 } elsif ($c2 eq '=') { 969 if (substr($$rstr, $pos + 2, 1) eq '>') { 970 pos($$rstr) = $pos + 3; 971 ($token, $token_desc, $token_type) = ('<=>', '<=>', 'OP'); 972 next; 973 } else { 974 pos($$rstr) = $pos + 2; 975 ($token, $token_desc, $token_type) = ('<=', '<=', 'OP'); 976 next; 977 } 978 } elsif ($c2 eq '>') { 979 pos($$rstr) = $pos + 2; 980 ($token, $token_desc, $token_type) = ('<>', '<>', 'OP'); 981 next; 982 } elsif ($$rstr =~ m{\G(<(?: 983 \\. | 984 \w+ | 985 [./-] | 986 \[[^\]]*\] | 987 \{[^\}]*\} | 988 \* | 989 \? | 990 \~ | 991 \$ | 992 )*(?<!\-)>)}gcx) { 993 ($token, $token_desc, $token_type) = ($1, '<NAME>', 'EXPR'); 994 next; 995 } else { 996 pos($$rstr) = $pos + 1; 997 ($token, $token_desc, $token_type) = ($c1, $c1, 'OP'); 998 next; 999 } 1000 } elsif ($c1 eq ':') { 1001 my $c2 = substr($$rstr, $pos + 1, 1); 1002 if ($c2 eq ':') { 1003 pos($$rstr) = $pos + 2; 1004 ($token, $token_desc, $token_type) = ('::', '::', ''); 1005 next; 1006 } 1007 if ($waiting_for_a_block and @keywords and $c->token_defines_sub($keywords[-1])) { 1008 while($$rstr =~ m{\G\s*(:?\s*[\w]+)}gcs) { 1009 my $startpos = pos($$rstr); 1010 if (substr($$rstr, $startpos, 1) eq '(') { 1011 my @nest = '('; 1012 pos($$rstr) = $startpos + 1; 1013 my ($p, $c1); 1014 while(defined($p = pos($$rstr))) { 1015 $c1 = substr($$rstr, $p, 1); 1016 if ($c1 eq '\\') { 1017 pos($$rstr) = $p + 2; 1018 next; 1019 } 1020 if ($c1 eq ')') { 1021 pop @nest; 1022 pos($$rstr) = $p + 1; 1023 last unless @nest; 1024 } 1025 if ($c1 eq '(') { 1026 push @nest, $c1; 1027 pos($$rstr) = $p + 1; 1028 next; 1029 } 1030 $$rstr =~ m{\G([^\\()]+)}gc and next; 1031 } 1032 } 1033 } 1034 $token = substr($$rstr, $pos, pos($$rstr) - $pos); 1035 ($token_desc, $token_type) = ('ATTRIBUTE', ''); 1036 if ($token =~ /^:prototype\(/) { 1037 $c->add_perl('5.020', ':prototype'); 1038 } 1039 next; 1040 } else { 1041 pos($$rstr) = $pos + 1; 1042 ($token, $token_desc, $token_type) = ($c1, $c1, 'OP'); 1043 next; 1044 } 1045 } elsif ($c1 eq '=') { 1046 my $c2 = substr($$rstr, $pos + 1, 1); 1047 if ($c2 eq '>') { 1048 pos($$rstr) = $pos + 2; 1049 ($token, $token_desc, $token_type) = ('=>', 'COMMA', 'OP'); 1050 if (@keywords and $prev_token_type eq 'KEYWORD' and $keywords[-1] eq $prev_token) { 1051 pop @keywords; 1052 if (!@keywords and ($current_scope & F_KEEP_TOKENS)) { 1053 $current_scope &= MASK_KEEP_TOKENS; 1054 @tokens = (); 1055 } 1056 } 1057 next; 1058 } elsif ($c2 eq '=') { 1059 pos($$rstr) = $pos + 2; 1060 ($token, $token_desc, $token_type) = ('==', '==', 'OP'); 1061 next; 1062 } elsif ($c2 eq '~') { 1063 pos($$rstr) = $pos + 2; 1064 ($token, $token_desc, $token_type) = ('=~', '=~', 'OP'); 1065 next; 1066 } else { 1067 pos($$rstr) = $pos + 1; 1068 ($token, $token_desc, $token_type) = ($c1, $c1, 'OP'); 1069 next; 1070 } 1071 } elsif ($c1 eq '>') { 1072 my $c2 = substr($$rstr, $pos + 1, 1); 1073 if ($c2 eq '>') { 1074 if (substr($$rstr, $pos + 2, 1) eq '=') { 1075 pos($$rstr) = $pos + 3; 1076 ($token, $token_desc, $token_type) = ('>>=', '>>=', 'OP'); 1077 next; 1078 } else { 1079 pos($$rstr) = $pos + 2; 1080 ($token, $token_desc, $token_type) = ('>>', '>>', 'OP'); 1081 next; 1082 } 1083 } elsif ($c2 eq '=') { 1084 pos($$rstr) = $pos + 2; 1085 ($token, $token_desc, $token_type) = ('>=', '>=', 'OP'); 1086 next; 1087 } else { 1088 pos($$rstr) = $pos + 1; 1089 ($token, $token_desc, $token_type) = ($c1, $c1, 'OP'); 1090 next; 1091 } 1092 } elsif ($c1 eq '+') { 1093 my $c2 = substr($$rstr, $pos + 1, 1); 1094 if ($c2 eq '+') { 1095 if (substr($$rstr, $pos + 2, 1) eq '=') { 1096 pos($$rstr) = $pos + 3; 1097 ($token, $token_desc, $token_type) = ('++=', '++=', 'OP'); 1098 next; 1099 } else { 1100 pos($$rstr) = $pos + 2; 1101 ($token, $token_desc, $token_type) = ('++', '++', $prev_token_type); 1102 next; 1103 } 1104 } elsif ($c2 eq '=') { 1105 pos($$rstr) = $pos + 2; 1106 ($token, $token_desc, $token_type) = ('+=', '+=', 'OP'); 1107 next; 1108 } else { 1109 pos($$rstr) = $pos + 1; 1110 ($token, $token_desc, $token_type) = ($c1, $c1, 'OP'); 1111 next; 1112 } 1113 } elsif ($c1 eq '|') { 1114 my $c2 = substr($$rstr, $pos + 1, 1); 1115 if ($c2 eq '|') { 1116 if (substr($$rstr, $pos + 2, 1) eq '=') { 1117 pos($$rstr) = $pos + 3; 1118 ($token, $token_desc, $token_type) = ('||=', '||=', 'OP'); 1119 next; 1120 } else { 1121 pos($$rstr) = $pos + 2; 1122 ($token, $token_desc, $token_type) = ('||', '||', 'OP'); 1123 next; 1124 } 1125 } elsif ($c2 eq '=') { 1126 pos($$rstr) = $pos + 2; 1127 ($token, $token_desc, $token_type) = ('|=', '|=', 'OP'); 1128 next; 1129 } elsif ($c2 eq '.') { 1130 if (substr($$rstr, $pos + 2, 1) eq '=') { 1131 pos($$rstr) = $pos + 3; 1132 ($token, $token_desc, $token_type) = ('|.=', '|.=', 'OP'); 1133 } else { 1134 pos($$rstr) = $pos + 2; 1135 ($token, $token_desc, $token_type) = ('|.', '|.', 'OP'); 1136 } 1137 $c->add_perl('5.022', '|.'); 1138 next; 1139 } else { 1140 pos($$rstr) = $pos + 1; 1141 ($token, $token_desc, $token_type) = ($c1, $c1, 'OP'); 1142 next; 1143 } 1144 } elsif ($c1 eq '^') { 1145 my $c2 = substr($$rstr, $pos + 1, 1); 1146 if ($c2 eq '=') { 1147 pos($$rstr) = $pos + 2; 1148 ($token, $token_desc, $token_type) = ('^=', '^=', 'OP'); 1149 next; 1150 } elsif ($c2 eq '.') { 1151 if (substr($$rstr, $pos + 2, 1) eq '=') { 1152 pos($$rstr) = $pos + 3; 1153 ($token, $token_desc, $token_type) = ('^.=', '^.=', 'OP'); 1154 } else { 1155 pos($$rstr) = $pos + 2; 1156 ($token, $token_desc, $token_type) = ('^.', '^.', 'OP'); 1157 } 1158 $c->add_perl('5.022', '^.'); 1159 next; 1160 } else { 1161 pos($$rstr) = $pos + 1; 1162 ($token, $token_desc, $token_type) = ($c1, $c1, 'OP'); 1163 next; 1164 } 1165 } elsif ($c1 eq '!') { 1166 my $c2 = substr($$rstr, $pos + 1, 1); 1167 if ($c2 eq '~') { 1168 pos($$rstr) = $pos + 2; 1169 ($token, $token_desc, $token_type) = ('!~', '!~', 'OP'); 1170 next; 1171 } else { 1172 pos($$rstr) = $pos + 1; 1173 ($token, $token_desc, $token_type) = ($c1, $c1, 'OP'); 1174 next; 1175 } 1176 } elsif ($c1 eq '~') { 1177 my $c2 = substr($$rstr, $pos + 1, 1); 1178 if ($c2 eq '~') { 1179 pos($$rstr) = $pos + 2; 1180 ($token, $token_desc, $token_type) = ('~~', '~~', 'OP'); 1181 $c->add_perl('5.010', '~~'); 1182 next; 1183 } elsif ($c2 eq '.') { 1184 pos($$rstr) = $pos + 2; 1185 ($token, $token_desc, $token_type) = ('~.', '~.', 'OP'); 1186 $c->add_perl('5.022', '~.'); 1187 next; 1188 } else { 1189 pos($$rstr) = $pos + 1; 1190 ($token, $token_desc, $token_type) = ($c1, $c1, 'OP'); 1191 next; 1192 } 1193 } elsif ($c1 eq ',') { 1194 pos($$rstr) = $pos + 1; 1195 ($token, $token_desc, $token_type) = ($c1, 'COMMA', 'OP'); 1196 next; 1197 } elsif ($c1 eq '?') { 1198 pos($$rstr) = $pos + 1; 1199 ($token, $token_desc, $token_type) = ($c1, $c1, 'OP'); 1200 next; 1201 } elsif ($c1 eq '.') { 1202 my $c2 = substr($$rstr, $pos + 1, 1); 1203 if ($c2 eq '.') { 1204 if (substr($$rstr, $pos + 2, 1) eq '.') { 1205 pos($$rstr) = $pos + 3; 1206 ($token, $token_desc, $token_type) = ('...', '...', 'OP'); 1207 $c->add_perl('5.012', '...'); 1208 next; 1209 } else { 1210 pos($$rstr) = $pos + 2; 1211 ($token, $token_desc, $token_type) = ('..', '..', 'OP'); 1212 next; 1213 } 1214 } elsif ($c2 eq '=') { 1215 pos($$rstr) = $pos + 2; 1216 ($token, $token_desc, $token_type) = ('.=', '.=', 'OP'); 1217 next; 1218 } else { 1219 pos($$rstr) = $pos + 1; 1220 ($token, $token_desc, $token_type) = ($c1, $c1, 'OP'); 1221 next; 1222 } 1223 } elsif ($c1 eq '0') { 1224 my $c2 = substr($$rstr, $pos + 1, 1); 1225 if ($c2 eq 'x') { 1226 if ($$rstr =~ m{\G(0x[0-9A-Fa-f_]+)}gc) { 1227 ($token, $token_desc, $token_type) = ($1, 'HEX NUMBER', 'EXPR'); 1228 next; 1229 } 1230 } elsif ($c2 eq 'b') { 1231 if ($$rstr =~ m{\G(0b[01_]+)}gc) { 1232 ($token, $token_desc, $token_type) = ($1, 'BINARY NUMBER', 'EXPR'); 1233 next; 1234 } 1235 } 1236 } 1237 1238 if ($$rstr =~ m{\G((?:0|[1-9][0-9_]*)(?:\.[0-9][0-9_]*)?)}gc) { 1239 my $number = $1; 1240 my $p = pos($$rstr); 1241 my $n1 = substr($$rstr, $p, 1); 1242 if ($n1 eq '.') { 1243 if ($$rstr =~ m{\G((?:\.[0-9_])+)}gc) { 1244 $number .= $1; 1245 ($token, $token_desc, $token_type) = ($number, 'VERSION_STRING', 'EXPR'); 1246 next; 1247 } elsif (substr($$rstr, $p, 2) ne '..') { 1248 $number .= '.'; 1249 pos($$rstr) = $p + 1; 1250 } 1251 } elsif ($n1 eq 'E' or $n1 eq 'e') { 1252 if ($$rstr =~ m{\G([Ee][+-]?[0-9]+)}gc) { 1253 $number .= $1; 1254 } 1255 } 1256 ($token, $token_desc, $token_type) = ($number, 'NUMBER', 'EXPR'); 1257 if ($prepend) { 1258 $token = "$prepend$token"; 1259 pop @tokens if @tokens and $tokens[-1][0] eq $prepend; 1260 pop @scope_tokens if @scope_tokens and $scope_tokens[-1][0] eq $prepend; 1261 } 1262 next; 1263 } 1264 1265 if ($prev_token_type ne 'ARROW' and ($prev_token_type ne 'KEYWORD' or !$c->token_expects_word($prev_token))) { 1266 if ($prev_token_type eq 'EXPR' or $prev_token_type eq 'VARIABLE') { 1267 if ($c1 eq 'x') { 1268 if ($$rstr =~ m{\G(x\b(?!\s*=>))}gc){ 1269 ($token, $token_desc, $token_type) = ($1, $1, ''); 1270 next; 1271 } 1272 } 1273 } 1274 1275 if ($c1 eq 'q') { 1276 my $quotelike_re = $c->quotelike_re; 1277 if ($$rstr =~ m{\G((?:$quotelike_re)\b(?!\s*=>))}gc) { 1278 if (my $quotelike = $self->_match_quotelike($c, $rstr, $1)) { 1279 ($token, $token_desc, $token_type) = ($quotelike, 'STRING', 'STRING'); 1280 next; 1281 } else { 1282 _debug("QUOTELIKE ERROR: $@") if DEBUG; 1283 pos($$rstr) = $pos; 1284 } 1285 } elsif ($$rstr =~ m{\G((?:qw)\b(?!\s*=>))}gc) { 1286 if (my $quotelike = $self->_match_quotelike($c, $rstr, $1)) { 1287 ($token, $token_desc, $token_type) = ($quotelike, 'QUOTED_WORD_LIST', 'EXPR'); 1288 next; 1289 } else { 1290 _debug("QUOTELIKE ERROR: $@") if DEBUG; 1291 pos($$rstr) = $pos; 1292 } 1293 } elsif ($$rstr =~ m{\G((?:qx)\b(?!\s*=>))}gc) { 1294 if (my $quotelike = $self->_match_quotelike($c, $rstr, $1)) { 1295 ($token, $token_desc, $token_type) = ($quotelike, 'BACKTICK', 'EXPR'); 1296 next; 1297 } else { 1298 _debug("QUOTELIKE ERROR: $@") if DEBUG; 1299 pos($$rstr) = $pos; 1300 } 1301 } elsif ($$rstr =~ m{\G(qr\b(?!\s*=>))}gc) { 1302 if (my $regexp = $self->_match_regexp($c, $rstr)) { 1303 ($token, $token_desc, $token_type) = ($regexp, 'qr', 'EXPR'); 1304 next; 1305 } else { 1306 _debug("QUOTELIKE ERROR: $@") if DEBUG; 1307 pos($$rstr) = $pos; 1308 } 1309 } 1310 } elsif ($c1 eq 'm') { 1311 if ($$rstr =~ m{\G(m\b(?!\s*=>))}gc) { 1312 if (my $regexp = $self->_match_regexp($c, $rstr)) { 1313 ($token, $token_desc, $token_type) = ($regexp, 'm', 'EXPR'); 1314 next; 1315 } else { 1316 _debug("REGEXP ERROR: $@") if DEBUG; 1317 pos($$rstr) = $pos; 1318 } 1319 } 1320 } elsif ($c1 eq 's') { 1321 if ($$rstr =~ m{\G(s\b(?!\s*=>))}gc) { 1322 if (my $regexp = $self->_match_substitute($c, $rstr)) { 1323 ($token, $token_desc, $token_type) = ($regexp, 's', 'EXPR'); 1324 next; 1325 } else { 1326 _debug("SUBSTITUTE ERROR: $@") if DEBUG; 1327 pos($$rstr) = $pos; 1328 } 1329 } 1330 } elsif ($c1 eq 't') { 1331 if ($$rstr =~ m{\G(tr\b(?!\s*=>))}gc) { 1332 if (my $trans = $self->_match_transliterate($c, $rstr)) { 1333 ($token, $token_desc, $token_type) = ($trans, 'tr', 'EXPR'); 1334 next; 1335 } else { 1336 _debug("TRANSLITERATE ERROR: $@") if DEBUG; 1337 pos($$rstr) = $pos; 1338 } 1339 } 1340 } elsif ($c1 eq 'y') { 1341 if ($$rstr =~ m{\G(y\b(?!\s*=>))}gc) { 1342 if (my $trans = $self->_match_transliterate($c, $rstr)) { 1343 ($token, $token_desc, $token_type) = ($trans, 'y', 'EXPR'); 1344 next; 1345 } else { 1346 _debug("TRANSLITERATE ERROR: $@") if DEBUG; 1347 pos($$rstr) = $pos; 1348 } 1349 } 1350 } 1351 } 1352 1353 if ($$rstr =~ m{\G(\w+)}gc) { 1354 $token = $1; 1355 if ($prev_token_type eq 'ARROW') { 1356 $$rstr =~ m{\G((?:(?:::|')\w+)+)\b}gc and $token .= $1; 1357 ($token_desc, $token_type) = ('METHOD', 'METHOD'); 1358 } elsif ($token eq 'CORE') { 1359 ($token_desc, $token_type) = ('NAMESPACE', 'WORD'); 1360 } elsif ($token eq 'format') { 1361 if ($$rstr =~ m{\G([^=]*?=[ \t]*\n.*?\n\.\n)}gcs) { 1362 $token .= $1; 1363 ($token_desc, $token_type) = ('FORMAT', ''); 1364 $current_scope |= F_STATEMENT_END|F_EXPR_END; 1365 next; 1366 } 1367 } elsif ($c->token_is_keyword($token) and ($prev_token_type ne 'KEYWORD' or !$c->token_expects_word($prev_token) or ($prev_token eq 'sub' and $token eq 'BEGIN'))) { 1368 if ($c->token_is_op_keyword($token)) { 1369 ($token_desc, $token_type) = ($token, 'OP'); 1370 } else { 1371 ($token_desc, $token_type) = ('KEYWORD', 'KEYWORD'); 1372 $c->check_new_keyword($token); 1373 push @keywords, $token unless $token eq 'undef'; 1374 } 1375 } else { 1376 if ($c1 eq 'v' and $token =~ /^v(?:0|[1-9][0-9]*)$/) { 1377 if ($$rstr =~ m{\G((?:\.[0-9][0-9_]*)+)}gc) { 1378 $token .= $1; 1379 ($token_desc, $token_type) = ('VERSION_STRING', 'EXPR'); 1380 next; 1381 } 1382 } 1383 $$rstr =~ m{\G((?:(?:::|')\w+)+)\b}gc and $token .= $1; 1384 ($token_desc, $token_type) = ('WORD', 'WORD'); 1385 if ($prepend) { 1386 $token = "$prepend$token"; 1387 pop @tokens if @tokens and $tokens[-1][0] eq $prepend; 1388 pop @scope_tokens if @scope_tokens and $scope_tokens[-1][0] eq $prepend; 1389 } 1390 } 1391 next; 1392 } 1393 1394 # ignore control characters 1395 if ($$rstr =~ m{\G([[:cntrl:]]+)}gc) { 1396 next; 1397 } 1398 1399 if ($$rstr =~ m{\G([[:ascii:]]+)}gc) { 1400 last if $parent_scope & F_STRING_EVAL; 1401 _error("UNKNOWN: $1"); 1402 push @{$c->{errors}}, qq{"$1"}; 1403 $token = $1; 1404 next; 1405 } 1406 if ($$rstr =~ m{\G([[:^ascii:]](?:[[:^ascii:]]|\w)*)}gc) { 1407 if (!$c->{utf8}) { 1408 last if $parent_scope & F_STRING_EVAL; 1409 _error("UNICODE?: $1"); 1410 push @{$c->{errors}}, qq{"$1"}; 1411 } else { 1412 _debug("UTF8: $1") if DEBUG; 1413 } 1414 $token = $1; 1415 next; 1416 } 1417 if ($$rstr =~ m{\G(\S+)}gc) { 1418 last if $parent_scope & F_STRING_EVAL; 1419 _error("UNEXPECTED: $1"); 1420 push @{$c->{errors}}, qq{"$1"}; 1421 $token = $1; 1422 } 1423 1424 last; 1425 } continue { 1426 die "Aborted at $prev_pos" if $prev_pos == pos($$rstr); 1427 $prev_pos = pos($$rstr); 1428 1429 if (defined $token) { 1430 if (!($current_scope & F_EXPR)) { 1431 _debug('BEGIN EXPR') if DEBUG; 1432 $current_scope |= F_EXPR; 1433 } elsif (($current_scope & F_EXPR) and (($current_scope & F_EXPR_END) or ($ends_expr{$token} and $token_type eq 'KEYWORD' and $prev_token ne ',' and $prev_token ne '=>'))) { 1434 @keywords = (); 1435 _debug('END EXPR') if DEBUG; 1436 $current_scope &= MASK_EXPR_END; 1437 } 1438 $prepend = undef; 1439 1440 if (DEBUG) { 1441 my $token_str = ref $token ? Data::Dump::dump($token) : $token; 1442 _debug("GOT: $token_str ($pos) TYPE: $token_desc ($token_type)".($prev_token_type ? " PREV: $prev_token_type" : '').(@keywords ? " KEYWORD: @keywords" : '').(($current_scope | $parent_scope) & F_EVAL ? ' EVAL' : '').(($current_scope | $parent_scope) & F_KEEP_TOKENS ? ' KEEP' : '')); 1443 } 1444 1445 if ($parent_scope & F_KEEP_TOKENS) { 1446 push @scope_tokens, [$token, $token_desc]; 1447 if ($token eq '-' or $token eq '+') { 1448 $prepend = $token; 1449 } 1450 } 1451 if (!($current_scope & F_KEEP_TOKENS) and (exists $c->{callback}{$token} or exists $c->{keyword}{$token} or exists $c->{sub}{$token}) and $token_type ne 'METHOD' and !$c->token_expects_word($prev_token)) { 1452 $current_scope |= F_KEEP_TOKENS; 1453 } 1454 if ($c->token_expects_block($token)) { 1455 $waiting_for_a_block = 1; 1456 } 1457 if ($current_scope & F_EVAL or ($parent_scope & F_EVAL and (!@{$c->{stack}} or $c->{stack}[-1][0] ne '{'))) { 1458 if ($token_type eq 'STRING') { 1459 if ($token->[0] =~ /\b(?:(?:use|no)\s+[A-Za-z]|require\s+(?:q[qw]?.|['"])?[A-Za-z])/) { 1460 my $eval_string = $token->[0]; 1461 if (defined $eval_string and $eval_string ne '') { 1462 $eval_string =~ s/\\(.)/$1/g; 1463 pos($eval_string) = 0; 1464 $c->{eval} = 1; 1465 my $saved_stack = $c->{stack}; 1466 $c->{stack} = []; 1467 eval { $self->_scan($c, \$eval_string, ( 1468 ($current_scope | $parent_scope | F_STRING_EVAL) & 1469 F_RESCAN 1470 ))}; 1471 $c->{stack} = $saved_stack; 1472 } 1473 } 1474 $current_scope &= MASK_EVAL; 1475 } elsif ($token_desc eq 'HEREDOC') { 1476 if ($token->[0] =~ /\b(?:use|require|no)\s+[A-Za-z]/) { 1477 my $eval_string = $token->[0]; 1478 if (defined $eval_string and $eval_string ne '') { 1479 $eval_string =~ s/\\(.)/$1/g; 1480 pos($eval_string) = 0; 1481 $c->{eval} = 1; 1482 my $saved_stack = $c->{stack}; 1483 $c->{stack} = []; 1484 eval { $self->_scan($c, \$eval_string, ( 1485 ($current_scope | $parent_scope | F_STRING_EVAL) & 1486 F_RESCAN 1487 ))}; 1488 $c->{stack} = $saved_stack; 1489 } 1490 } 1491 $current_scope &= MASK_EVAL; 1492 } elsif ($token_type eq 'VARIABLE') { 1493 $current_scope &= MASK_EVAL; 1494 } 1495 $c->{eval} = ($current_scope | $parent_scope) & F_EVAL ? 1 : 0; 1496 } 1497 if ($token eq 'eval') { 1498 $current_scope |= F_EVAL; 1499 $c->{eval} = 1; 1500 } 1501 1502 if ($current_scope & F_KEEP_TOKENS) { 1503 push @tokens, [$token, $token_desc]; 1504 if ($token eq '-' or $token eq '+') { 1505 $prepend = $token; 1506 } 1507 if ($token_type eq 'KEYWORD' and $has_sideff{$token}) { 1508 $current_scope |= F_SIDEFF; 1509 } 1510 } 1511 if ($stack) { 1512 push @{$c->{stack}}, $stack; 1513 _dump_stack($c, $stack->[0]) if DEBUG; 1514 my $child_scope = $current_scope | $parent_scope; 1515 if ($token eq '{' and $is_conditional{$stack->[2]}) { 1516 $child_scope |= F_CONDITIONAL 1517 } 1518 my $scanned_tokens = $self->_scan($c, $rstr, ( 1519 $child_scope & F_RESCAN 1520 )); 1521 if ($token eq '{' and $current_scope & F_EVAL) { 1522 $current_scope &= MASK_EVAL; 1523 $c->{eval} = ($current_scope | $parent_scope) & F_EVAL ? 1 : 0; 1524 } 1525 if ($current_scope & F_KEEP_TOKENS) { 1526 my $start = pop @tokens || ''; 1527 my $end = pop @$scanned_tokens || ''; 1528 push @tokens, [$scanned_tokens, "$start->[0]$end->[0]"]; 1529 } elsif ($parent_scope & F_KEEP_TOKENS) { 1530 my $start = pop @scope_tokens || ''; 1531 my $end = pop @$scanned_tokens || ''; 1532 push @scope_tokens, [$scanned_tokens, "$start->[0]$end->[0]"]; 1533 } 1534 1535 if ($stack->[0] eq '(' and $prev_token_type eq 'KEYWORD' and @keywords and $keywords[-1] eq $prev_token and !$c->token_expects_expr_block($prev_token)) { 1536 pop @keywords; 1537 } 1538 1539 if ($stack->[0] eq '{' and @keywords and $c->token_expects_block($keywords[0]) and !$c->token_expects_block_list($keywords[-1])) { 1540 $current_scope |= F_STATEMENT_END unless @tokens and ($c->token_defines_sub($keywords[-1]) or $keywords[-1] eq 'eval'); 1541 } 1542 $stack = undef; 1543 } 1544 if ($current_scope & F_STATEMENT_END) { 1545 if (($current_scope & F_KEEP_TOKENS) and @tokens) { 1546 my $first_token = $tokens[0][0]; 1547 if ($first_token eq '->') { 1548 $first_token = $tokens[1][0]; 1549 # ignore ->use and ->no 1550 # ->require may be from UNIVERSAL::require 1551 if ($first_token eq 'use' or $first_token eq 'no') { 1552 $first_token = ''; 1553 } 1554 } 1555 my $cond = (($current_scope | $parent_scope) & (F_CONDITIONAL|F_SIDEFF)) ? 1 : 0; 1556 if (exists $c->{callback}{$first_token}) { 1557 $c->{current_scope} = \$current_scope; 1558 $c->{cond} = $cond; 1559 $c->{callback}{$first_token}->($c, $rstr, \@tokens); 1560 1561 if ($c->{found_unsupported_package} and !$c->{quick}) { 1562 my $unsupported = $c->{found_unsupported_package}; 1563 $c->{quick} = 1; 1564 $self->_skim_string($c, $rstr); 1565 warn "Unsupported package '$unsupported' is found. Result may be incorrect.\n"; 1566 } 1567 } 1568 if (exists $c->{keyword}{$first_token}) { 1569 $c->{current_scope} = \$current_scope; 1570 $c->{cond} = $cond; 1571 $tokens[0][1] = 'KEYWORD'; 1572 $c->run_callback_for(keyword => $first_token, \@tokens); 1573 } 1574 if (exists $c->{method}{$first_token} and $caller_package) { 1575 unshift @tokens, [$caller_package, 'WORD']; 1576 $c->{current_scope} = \$current_scope; 1577 $c->{cond} = $cond; 1578 $c->run_callback_for(method => $first_token, \@tokens); 1579 } 1580 if ($current_scope & F_SIDEFF) { 1581 $current_scope &= MASK_SIDEFF; 1582 while(my $token = shift @tokens) { 1583 last if $has_sideff{$token->[0]}; 1584 } 1585 $current_scope &= F_SIDEFF if grep {$has_sideff{$_->[0]}} @tokens; 1586 if (@tokens) { 1587 $first_token = $tokens[0][0]; 1588 $cond = (($current_scope | $parent_scope) & (F_CONDITIONAL|F_SIDEFF)) ? 1 : 0; 1589 if (exists $c->{callback}{$first_token}) { 1590 $c->{current_scope} = \$current_scope; 1591 $c->{cond} = $cond; 1592 $c->{callback}{$first_token}->($c, $rstr, \@tokens); 1593 } 1594 if (exists $c->{keyword}{$first_token}) { 1595 $c->{current_scope} = \$current_scope; 1596 $c->{cond} = $cond; 1597 $tokens[0][1] = 'KEYWORD'; 1598 $c->run_callback_for(keyword => $first_token, \@tokens); 1599 } 1600 if (exists $c->{method}{$first_token} and $caller_package) { 1601 unshift @tokens, [$caller_package, 'WORD']; 1602 $c->{current_scope} = \$current_scope; 1603 $c->{cond} = $cond; 1604 $c->run_callback_for(method => $first_token, \@tokens); 1605 } 1606 } 1607 } 1608 } 1609 @tokens = (); 1610 @keywords = (); 1611 $current_scope &= MASK_STATEMENT_END; 1612 $caller_package = undef; 1613 $token = $token_type = ''; 1614 _debug('END SENTENSE') if DEBUG; 1615 } 1616 if ($unstack and @{$c->{stack}}) { 1617 my $stacked = pop @{$c->{stack}}; 1618 my $stacked_type = substr($stacked->[0], -1); 1619 if ( 1620 ($unstack eq '}' and $stacked_type ne '{') or 1621 ($unstack eq ']' and $stacked_type ne '[') or 1622 ($unstack eq ')' and $stacked_type ne '(') 1623 ) { 1624 my $prev_pos = $stacked->[1] || 0; 1625 die "mismatch $stacked_type $unstack\n" . 1626 substr($$rstr, $prev_pos, pos($$rstr) - $prev_pos); 1627 } 1628 _dump_stack($c, $unstack) if DEBUG; 1629 $current_scope |= F_SCOPE_END; 1630 $unstack = undef; 1631 } 1632 1633 last if $current_scope & F_SCOPE_END; 1634 last if $c->{ended}; 1635 last if $c->{last_found_by_skimming} and $c->{last_found_by_skimming} < pos($$rstr); 1636 1637 ($prev_token, $prev_token_type) = ($token, $token_type); 1638 } 1639 1640 if (@{$c->{errors}} and !($parent_scope & F_STRING_EVAL)) { 1641 my $rest = substr($$rstr, pos($$rstr)); 1642 _error("REST:\n\n".$rest) if $rest; 1643 last; 1644 } 1645 } 1646 1647 if (@tokens) { 1648 if (my $first_token = $tokens[0][0]) { 1649 if (exists $c->{callback}{$first_token}) { 1650 $c->{callback}{$first_token}->($c, $rstr, \@tokens); 1651 } 1652 if (exists $c->{keyword}{$first_token}) { 1653 $tokens[0][1] = 'KEYWORD'; 1654 $c->run_callback_for(keyword => $first_token, \@tokens); 1655 } 1656 } 1657 } 1658 1659 _dump_stack($c, "END SCOPE") if DEBUG; 1660 1661 \@scope_tokens; 1662} 1663 1664sub _match_quotelike { 1665 my ($self, $c, $rstr, $op) = @_; 1666 1667 # '#' only works when it comes just after the op, 1668 # without prepending spaces 1669 $$rstr =~ m/\G(?:\s(?:$re_comment))?\s*/gcs; 1670 1671 unless ($$rstr =~ m/\G(\S)/gc) { 1672 return _match_error($rstr, "No block delimiter found after $op"); 1673 } 1674 my $ldel = $1; 1675 my $startpos = pos($$rstr); 1676 1677 if ($ldel =~ /[[(<{]/) { 1678 my ($rdel, $re_skip) = _gen_rdel_and_re_skip($ldel); 1679 my @nest = ($ldel); 1680 my ($p, $c1); 1681 while(defined($p = pos($$rstr))) { 1682 $c1 = substr($$rstr, $p, 1); 1683 if ($c1 eq '\\') { 1684 pos($$rstr) = $p + 2; 1685 next; 1686 } 1687 if ($c1 eq $ldel) { 1688 pos($$rstr) = $p + 1; 1689 push @nest, $ldel; 1690 next; 1691 } 1692 if ($c1 eq $rdel) { 1693 pos($$rstr) = $p + 1; 1694 pop @nest; 1695 last unless @nest; 1696 next; 1697 } 1698 $$rstr =~ m{\G$re_skip}gc and next; 1699 last; 1700 } 1701 return if @nest; 1702 } else { 1703 my $re = _gen_re_str_in_delims_with_end_delim($ldel); 1704 $$rstr =~ /\G$re/gcs or return; 1705 } 1706 1707 my $endpos = pos($$rstr); 1708 1709 return [substr($$rstr, $startpos, $endpos - $startpos - 1), $op]; 1710} 1711 1712sub _match_regexp0 { # // 1713 my ($self, $c, $rstr, $startpos, $token_type) = @_; 1714 pos($$rstr) = $startpos + 1; 1715 1716 my $re_shortcut = _gen_re_regexp_shortcut('/'); 1717 $$rstr =~ m{\G$re_shortcut}gcs or # shortcut 1718 defined($self->_scan_re($c, $rstr, '/', '/', $token_type ? 'm' : '')) or return _match_error($rstr, "Closing delimiter was not found: $@"); 1719 1720 $$rstr =~ m/\G([msixpodualgc]*)/gc; 1721 my $mod = $1; 1722 1723 my $endpos = pos($$rstr); 1724 1725 my $re = substr($$rstr, $startpos, $endpos - $startpos); 1726 if ($re =~ /\n/s and $mod !~ /x/) { 1727 return _match_error($rstr, "multiline without x"); 1728 } 1729 return $re; 1730} 1731 1732sub _match_regexp { 1733 my ($self, $c, $rstr) = @_; 1734 my $startpos = pos($$rstr) || 0; 1735 1736 # '#' only works when it comes just after the op, 1737 # without prepending spaces 1738 $$rstr =~ m/\G(?:\s(?:$re_comment))?\s*/gcs; 1739 1740 unless ($$rstr =~ m/\G(\S)/gc) { 1741 return _match_error($rstr, "No block delimiter found"); 1742 } 1743 my ($ldel, $rdel) = ($1, $1); 1744 1745 if ($ldel =~ /[[(<{]/) { 1746 $rdel =~ tr/[({</])}>/; 1747 } 1748 1749 my $re_shortcut = _gen_re_regexp_shortcut($ldel, $rdel); 1750 $$rstr =~ m{\G$re_shortcut}gcs or # shortcut 1751 defined($self->_scan_re($c, $rstr, $ldel, $rdel, 'm/qr')) or return _match_error($rstr, "Closing delimiter was not found: $@"); 1752 1753 # strictly speaking, qr// doesn't support gc. 1754 $$rstr =~ m/\G[msixpodualgc]*/gc; 1755 my $endpos = pos($$rstr); 1756 1757 return substr($$rstr, $startpos, $endpos - $startpos); 1758} 1759 1760sub _match_substitute { 1761 my ($self, $c, $rstr) = @_; 1762 my $startpos = pos($$rstr) || 0; 1763 1764 # '#' only works when it comes just after the op, 1765 # without prepending spaces 1766 $$rstr =~ m/\G(?:\s(?:$re_comment))?\s*/gcs; 1767 1768 unless ($$rstr =~ m/\G(\S)/gc) { 1769 return _match_error($rstr, "No block delimiter found"); 1770 } 1771 my ($ldel1, $rdel1) = ($1, $1); 1772 1773 if ($ldel1 =~ /[[(<{]/) { 1774 $rdel1 =~ tr/[({</])}>/; 1775 } 1776 1777 my $re_shortcut = _gen_re_regexp_shortcut($ldel1, $rdel1); 1778 ($ldel1 ne '\\' and $$rstr =~ m{\G$re_shortcut}gcs) or # shortcut 1779 defined($self->_scan_re($c, $rstr, $ldel1, $rdel1, 's')) or return _match_error($rstr, "Closing delimiter was not found: $@"); 1780 defined($self->_scan_re2($c, $rstr, $ldel1, 's')) or return; 1781 $$rstr =~ m/\G[msixpodualgcer]*/gc; 1782 my $endpos = pos($$rstr); 1783 1784 return substr($$rstr, $startpos, $endpos - $startpos); 1785} 1786 1787sub _match_transliterate { 1788 my ($self, $c, $rstr) = @_; 1789 my $startpos = pos($$rstr) || 0; 1790 1791 # '#' only works when it comes just after the op, 1792 # without prepending spaces 1793 $$rstr =~ m/\G(?:\s(?:$re_comment))?\s*/gcs; 1794 1795 unless ($$rstr =~ m/\G(\S)/gc) { 1796 return _match_error($rstr, "No block delimiter found"); 1797 } 1798 my $ldel1 = $1; 1799 my $ldel2; 1800 1801 if ($ldel1 =~ /[[(<{]/) { 1802 (my $rdel1 = $ldel1) =~ tr/[({</])}>/; 1803 my $re = _gen_re_str_in_delims_with_end_delim($rdel1); 1804 $$rstr =~ /\G$re/gcs or return; 1805 $$rstr =~ /\G(?:$re_comment)/gcs; 1806 unless ($$rstr =~ /\G\s*(\S)/gc) { 1807 return _match_error($rstr, "Missing second block"); 1808 } 1809 $ldel2 = $1; 1810 } else { 1811 my $re = _gen_re_str_in_delims_with_end_delim($ldel1); 1812 $$rstr =~ /\G$re/gcs or return; 1813 $ldel2 = $ldel1; 1814 } 1815 1816 if ($ldel2 =~ /[[(<{]/) { 1817 (my $rdel2 = $ldel2) =~ tr/[({</])}>/; 1818 my $re = _gen_re_str_in_delims_with_end_delim($rdel2); 1819 $$rstr =~ /\G$re/gcs or return; 1820 } else { 1821 my $re = _gen_re_str_in_delims_with_end_delim($ldel2); 1822 $$rstr =~ /\G$re/gcs or return; 1823 } 1824 1825 $$rstr =~ m/\G[cdsr]*/gc; 1826 my $endpos = pos($$rstr); 1827 1828 return substr($$rstr, $startpos, $endpos - $startpos); 1829} 1830 1831sub _match_heredoc { 1832 my ($self, $c, $rstr) = @_; 1833 1834 my $startpos = pos($$rstr) || 0; 1835 1836 $$rstr =~ m{\G(?:<<(~)?\s*)}gc; 1837 my $indent = $1 ? "\\s*" : ""; 1838 1839 my $label; 1840 if ($$rstr =~ m{\G\\?([A-Za-z_]\w*)}gc) { 1841 $label = $1; 1842 } elsif ($$rstr =~ m{ 1843 \G ' ($re_str_in_single_quotes) ' 1844 | \G " ($re_str_in_double_quotes) " 1845 | \G ` ($re_str_in_backticks) ` 1846 }gcsx) { 1847 $label = $+; 1848 } else { 1849 return; 1850 } 1851 $label =~ s/\\(.)/$1/g; 1852 my $extrapos = pos($$rstr); 1853 $$rstr =~ m{\G.*\n}gc; 1854 my $str1pos = pos($$rstr)--; 1855 unless ($$rstr =~ m{\G.*?\n$indent(?=\Q$label\E\n)}gcs) { 1856 return _match_error($rstr, qq{Missing here doc terminator ('$label')}); 1857 } 1858 my $ldpos = pos($$rstr); 1859 $$rstr =~ m{\G\Q$label\E\n}gc; 1860 my $ld2pos = pos($$rstr); 1861 1862 my $heredoc = [ 1863 substr($$rstr, $str1pos, $ldpos-$str1pos), 1864 substr($$rstr, $startpos, $extrapos-$startpos), 1865 substr($$rstr, $ldpos, $ld2pos-$ldpos), 1866 ]; 1867 substr($$rstr, $str1pos, $ld2pos - $str1pos) = ''; 1868 pos($$rstr) = $extrapos; 1869 if ($indent) { 1870 $c->add_perl('5.026', '<<~'); 1871 } 1872 return $heredoc; 1873} 1874 1875sub _scan_re { 1876 my ($self, $c, $rstr, $ldel, $rdel, $op) = @_; 1877 my $startpos = pos($$rstr) || 0; 1878 1879 _debug(" L $ldel R $rdel") if DEBUG_RE; 1880 1881 my ($outer_opening_delimiter, $outer_closing_delimiter); 1882 if (@{$c->{stack}}) { 1883 ($outer_closing_delimiter = $outer_opening_delimiter = $c->{stack}[-1][0]) =~ tr/[({</])}>/; 1884 } 1885 1886 my @nesting = ($ldel); 1887 my $multiline = 0; 1888 my $saw_sharp = 0; 1889 my $prev; 1890 my ($p, $c1); 1891 while (defined($p = pos($$rstr))) { 1892 $c1 = substr($$rstr, $p, 1); 1893 if ($c1 eq "\n") { 1894 $$rstr =~ m{\G\n\s*}gcs; 1895 $multiline = 1; 1896 $saw_sharp = 0; 1897 # _debug("CRLF") if DEBUG_RE; 1898 next; 1899 } 1900 if ($c1 eq ' ' or $c1 eq "\t") { 1901 $$rstr =~ m{\G\s*}gc; 1902 # _debug("WHITESPACE") if DEBUG_RE; 1903 next; 1904 } 1905 if ($c1 eq '#' and $rdel ne '#') { 1906 if ($multiline and $$rstr =~ m{\G(#[^\Q$rdel\E]*?)\n}gcs) { 1907 _debug(" comment $1") if DEBUG_RE 1908 } else { 1909 pos($$rstr) = $p + 1; 1910 $saw_sharp = 1; 1911 _debug(" saw #") if DEBUG_RE; 1912 } 1913 next; 1914 } 1915 1916 if ($c1 eq '\\' and $rdel ne '\\') { 1917 if ($$rstr =~ m/\G(\\.)/gcs) { 1918 _debug(" escaped $1") if DEBUG_RE; 1919 next; 1920 } 1921 } 1922 1923 _debug(" looking @nesting: $c1") if DEBUG_RE; 1924 1925 if ($c1 eq '[') { 1926 # character class may have other (ignorable) delimiters 1927 if ($$rstr =~ m/\G(\[\[:\w+?:\]\])/gcs) { 1928 _debug(" character class $1") if DEBUG_RE; 1929 next; 1930 } 1931 if ($$rstr =~ m/\G(\[[^\\\]]]*?(\\.[^\\\]]]*)*\])/gcs) { 1932 _debug(" character class: $1") if DEBUG_RE; 1933 next; 1934 } 1935 } 1936 1937 if ($c1 eq $rdel) { 1938 pos($$rstr) = $p + 1; 1939 if ($saw_sharp) { 1940 my $tmp_pos = $p + 1; 1941 if ($op eq 's') { 1942 _debug(" looking for latter part") if DEBUG_RE; 1943 my $latter = $self->_scan_re2($c, $rstr, $ldel, $op); 1944 if (!defined $latter) { 1945 pos($$rstr) = $tmp_pos; 1946 next; 1947 } 1948 _debug(" latter: $latter") if DEBUG_RE; 1949 } 1950 if ($$rstr =~ m/\G[a-wyz]*x/) { 1951 # looks like an end of block 1952 _debug(" end of block $rdel (after #)") if DEBUG_RE; 1953 @nesting = (); 1954 pos($$rstr) = $tmp_pos; 1955 last; 1956 } 1957 pos($$rstr) = $tmp_pos; 1958 if ($multiline) { 1959 next; # part of a comment 1960 } 1961 } 1962 _debug(" end of block $rdel") if DEBUG_RE; 1963 my $expected = $rdel; 1964 if ($ldel ne $rdel) { 1965 $expected =~ tr/)}]>/({[</; 1966 } 1967 while(my $nested = pop @nesting) { 1968 last if $nested eq $expected; 1969 } 1970 last unless @nesting; 1971 next; 1972 } elsif ($c1 eq $ldel) { 1973 pos($$rstr) = $p + 1; 1974 if ($multiline and $saw_sharp) { 1975 } else { 1976 _debug(" block $ldel") if DEBUG_RE; 1977 push @nesting, $ldel; 1978 next; 1979 } 1980 } 1981 1982 if ($c1 eq '{') { 1983 # quantifier shouldn't be nested 1984 if ($$rstr =~ m/\G(\{[0-9]+(?:,(?:[0-9]+)?)?})/gcs) { 1985 _debug(" quantifier $1") if DEBUG_RE; 1986 next; 1987 } 1988 } 1989 1990 if ($c1 eq '(') { 1991 my $c2 = substr($$rstr, $p + 1, 1); 1992 if ($c2 eq '?' and !($multiline and $saw_sharp)) { 1993 # code 1994 if ($$rstr =~ m/\G((\()\?+?)(?=\{)/gc) { 1995 _debug(" code $1") if DEBUG_RE; 1996 push @nesting, $2; 1997 unless (eval { $self->_scan($c, $rstr, F_EXPECTS_BRACKET); 1 }) { 1998 _debug("scan failed") if DEBUG_RE; 1999 return; 2000 } 2001 next; 2002 } 2003 # comment 2004 if ($$rstr =~ m{\G(\(\?\#[^\\\)]*(?:\\.[^\\\)]*)*\))}gcs) { 2005 _debug(" comment $1") if DEBUG_RE; 2006 next; 2007 } 2008 } 2009 2010 # grouping may have (ignorable) <> 2011 if ($$rstr =~ m/\G((\()(?:<[!=]|<\w+?>|>)?)/gc) { 2012 _debug(" group $1") if DEBUG_RE; 2013 push @nesting, $2; 2014 next; 2015 } 2016 } 2017 2018 # maybe variables (maybe not) 2019 if ($c1 eq '$' and substr($$rstr, $p + 1, 1) eq '{') { 2020 my @tmp_stack = @{$c->{stack}}; 2021 next if eval { $self->_scan($c, $rstr, F_EXPECTS_BRACKET); 1 }; 2022 pos($$rstr) = $p; 2023 $c->{stack} = \@tmp_stack; 2024 } 2025 2026 if ($c1 eq ')') { 2027 if (@nesting and $nesting[-1] eq '(') { 2028 _debug(" end of group $c1") if DEBUG_RE; 2029 pop @nesting; 2030 pos($$rstr) = $p + 1; 2031 next; 2032 } else { 2033 # die "unnested @nesting" unless $saw_sharp; 2034 } 2035 } 2036 2037 # for //, see if an outer closing delimiter is found first (ie. see if it was actually a /) 2038 if (!$op) { 2039 if ($outer_opening_delimiter and $c1 eq $outer_opening_delimiter) { 2040 push @nesting, $c1; 2041 pos($$rstr) = $p + 1; 2042 next; 2043 } 2044 2045 if ($outer_closing_delimiter and $c1 eq $outer_closing_delimiter) { 2046 if (@nesting and $nesting[-1] eq $outer_opening_delimiter) { 2047 pop @nesting; 2048 pos($$rstr) = $p + 1; 2049 next; 2050 } 2051 2052 return _match_error($rstr, "Outer closing delimiter: $outer_closing_delimiter is found"); 2053 } 2054 } 2055 2056 if ($$rstr =~ m/\G(\w+|.)/gcs) { 2057 _debug(" rest $1") if DEBUG_RE; 2058 next; 2059 } 2060 last; 2061 } 2062 if ($#nesting>=0) { 2063 return _match_error($rstr, "Unmatched opening bracket(s): ". join("..",@nesting).".."); 2064 } 2065 2066 my $endpos = pos($$rstr); 2067 2068 return substr($$rstr, $startpos, $endpos - $startpos); 2069} 2070 2071 2072sub _scan_re2 { 2073 my ($self, $c, $rstr, $ldel, $op) = @_; 2074 my $startpos = pos($$rstr); 2075 2076 if ($ldel =~ /[[(<{]/) { 2077 $$rstr =~ /\G(?:$re_comment)/gcs; 2078 2079 unless ($$rstr =~ /\G\s*(\S)/gc) { 2080 return _match_error($rstr, "Missing second block for quotelike $op"); 2081 } 2082 $ldel = $1; 2083 } 2084 2085 if ($ldel =~ /[[(<{]/) { 2086 my ($rdel, $re_skip) = _gen_rdel_and_re_skip($ldel); 2087 my @nest = $ldel; 2088 my ($p, $c1); 2089 while(defined($p = pos($$rstr))) { 2090 $c1 = substr($$rstr, $p, 1); 2091 if ($c1 eq '\\') { 2092 pos($$rstr) = $p + 2; 2093 next; 2094 } 2095 if ($c1 eq $ldel) { 2096 pos($$rstr) = $p + 1; 2097 push @nest, $ldel; 2098 next; 2099 } 2100 if ($c1 eq $rdel) { 2101 pos($$rstr) = $p + 1; 2102 pop @nest; 2103 last unless @nest; 2104 next; 2105 } 2106 $$rstr =~ m{\G$re_skip}gc and next; 2107 last; 2108 } 2109 return _match_error($rstr, "nesting mismatch: @nest") if @nest; 2110 } else { 2111 my $re = _gen_re_str_in_delims_with_end_delim($ldel); 2112 $$rstr =~ /\G$re/gcs or return; 2113 } 2114 2115 my $endpos = pos($$rstr); 2116 2117 return substr($$rstr, $startpos, $endpos - $startpos); 2118} 2119 2120sub _use { 2121 my ($c, $rstr, $tokens) = @_; 2122_debug("USE TOKENS: ".(Data::Dump::dump($tokens))) if DEBUG; 2123 shift @$tokens; # discard 'use' itself 2124 2125 # TODO: see if the token is WORD or not? 2126 my $name_token = shift @$tokens or return; 2127 my $name = $name_token->[0]; 2128 return if !defined $name or ref $name or $name eq ''; 2129 2130 my $c1 = substr($name, 0, 1); 2131 if ($c1 eq '5') { 2132 $c->add(perl => $name); 2133 return; 2134 } 2135 if ($c1 eq 'v') { 2136 my $c2 = substr($name, 1, 1); 2137 if ($c2 eq '5') { 2138 $c->add(perl => $name); 2139 return; 2140 } 2141 if ($c2 eq '6') { 2142 $c->{perl6} = 1; 2143 $c->{ended} = 1; 2144 return; 2145 } 2146 } 2147 if ($c->enables_utf8($name)) { 2148 $c->add($name => 0); 2149 $c->{utf8} = 1; 2150 if (!$c->{decoded}) { 2151 $c->{decoded} = 1; 2152 _debug("UTF8 IS ON") if DEBUG; 2153 utf8::decode($$rstr); 2154 pos($$rstr) = 0; 2155 $c->{ended} = $c->{redo} = 1; 2156 } 2157 } 2158 2159 if (is_module_name($name)) { 2160 my $maybe_version_token = $tokens->[0]; 2161 my $maybe_version_token_desc = $maybe_version_token->[1]; 2162 if ($maybe_version_token_desc and ($maybe_version_token_desc eq 'NUMBER' or $maybe_version_token_desc eq 'VERSION_STRING')) { 2163 $c->add($name => $maybe_version_token->[0]); 2164 shift @$tokens; 2165 } else { 2166 $c->add($name => 0); 2167 } 2168 2169 if (exists $sub_keywords{$name}) { 2170 $c->register_sub_keywords(@{$sub_keywords{$name}}); 2171 $c->prototype_re(qr{\G(\((?:[^\\\(\)]*(?:\\.[^\\\(\)]*)*)\))}); 2172 } 2173 if (exists $filter_modules{$name}) { 2174 my $tmp = pos($$rstr); 2175 my $redo = $filter_modules{$name}->($rstr); 2176 pos($$rstr) = $tmp; 2177 $c->{ended} = $c->{redo} = 1 if $redo; 2178 } 2179 } 2180 2181 if ($c->has_callback_for(use => $name)) { 2182 eval { $c->run_callback_for(use => $name, $tokens) }; 2183 warn "Callback Error: $@" if $@; 2184 } elsif ($name =~ /\b(?:Mo[ou]se?X?|MooX?|Elk|Antlers|Role)\b/) { 2185 my $module = $name =~ /Role/ ? 'Moose::Role' : 'Moose'; 2186 if ($c->has_callback_for(use => $module)) { 2187 eval { $c->run_callback_for(use => $module, $tokens) }; 2188 warn "Callback Error: $@" if $@; 2189 } 2190 } 2191 2192 if (exists $unsupported_packages{$name}) { 2193 $c->{found_unsupported_package} = $name; 2194 } 2195} 2196 2197sub _require { 2198 my ($c, $rstr, $tokens) = @_; 2199_debug("REQUIRE TOKENS: ".(Data::Dump::dump($tokens))) if DEBUG; 2200 shift @$tokens; # discard 'require' itself 2201 2202 # TODO: see if the token is WORD or not? 2203 my $name_token = shift @$tokens or return; 2204 my $name = $name_token->[0]; 2205 if (ref $name) { 2206 $name = $name->[0]; 2207 return if $name =~ /\.pl$/i; 2208 2209 $name =~ s|/|::|g; 2210 $name =~ s|\.pm$||i; 2211 } 2212 return if !defined $name or $name eq ''; 2213 2214 my $c1 = substr($name, 0, 1); 2215 if ($c1 eq '5') { 2216 $c->add_conditional(perl => $name); 2217 return; 2218 } 2219 if ($c1 eq 'v') { 2220 my $c2 = substr($name, 1, 1); 2221 if ($c2 eq '5') { 2222 $c->add_conditional(perl => $name); 2223 return; 2224 } 2225 if ($c2 eq '6') { 2226 $c->{perl6} = 1; 2227 $c->{ended} = 1; 2228 return; 2229 } 2230 } 2231 if (is_module_name($name)) { 2232 $c->add_conditional($name => 0); 2233 return; 2234 } 2235} 2236 2237sub _no { 2238 my ($c, $rstr, $tokens) = @_; 2239_debug("NO TOKENS: ".(Data::Dump::dump($tokens))) if DEBUG; 2240 shift @$tokens; # discard 'no' itself 2241 2242 # TODO: see if the token is WORD or not? 2243 my $name_token = shift @$tokens or return; 2244 my $name = $name_token->[0]; 2245 return if !defined $name or ref $name or $name eq ''; 2246 2247 my $c1 = substr($name, 0, 1); 2248 if ($c1 eq '5') { 2249 $c->add_no(perl => $name); 2250 return; 2251 } 2252 if ($c1 eq 'v') { 2253 my $c2 = substr($name, 1, 1); 2254 if ($c2 eq '5') { 2255 $c->add_no(perl => $name); 2256 return; 2257 } 2258 if ($c2 eq '6') { 2259 $c->{perl6} = 1; 2260 $c->{ended} = 1; 2261 return; 2262 } 2263 } 2264 if ($name eq 'utf8') { 2265 $c->{utf8} = 0; 2266 } 2267 2268 if (is_module_name($name)) { 2269 my $maybe_version_token = $tokens->[0]; 2270 my $maybe_version_token_desc = $maybe_version_token->[1]; 2271 if ($maybe_version_token_desc and ($maybe_version_token_desc eq 'NUMBER' or $maybe_version_token_desc eq 'VERSION_STRING')) { 2272 $c->add_no($name => $maybe_version_token->[0]); 2273 shift @$tokens; 2274 } else { 2275 $c->add_no($name => 0); 2276 } 2277 } 2278 2279 if ($c->has_callback_for(no => $name)) { 2280 eval { $c->run_callback_for(no => $name, $tokens) }; 2281 warn "Callback Error: $@" if $@; 2282 return; 2283 } 2284} 2285 22861; 2287 2288__END__ 2289 2290=encoding utf-8 2291 2292=head1 NAME 2293 2294Perl::PrereqScanner::NotQuiteLite - a tool to scan your Perl code for its prerequisites 2295 2296=head1 SYNOPSIS 2297 2298 use Perl::PrereqScanner::NotQuiteLite; 2299 my $scanner = Perl::PrereqScanner::NotQuiteLite->new( 2300 parsers => [qw/:installed -UniversalVersion/], 2301 suggests => 1, 2302 perl_minimum_version => 1, 2303 ); 2304 my $context = $scanner->scan_file('path/to/file'); 2305 my $requirements = $context->requires; 2306 my $recommends = $context->recommends; 2307 my $suggestions = $context->suggests; # requirements in evals 2308 my $noes = $context->noes; 2309 2310=head1 DESCRIPTION 2311 2312Perl::PrereqScanner::NotQuiteLite is yet another prerequisites 2313scanner. It passes almost all the scanning tests for 2314L<Perl::PrereqScanner> and L<Module::ExtractUse> (ie. except for 2315a few dubious ones), and runs slightly faster than PPI-based 2316Perl::PrereqScanner. However, it doesn't run as fast as 2317L<Perl::PrereqScanner::Lite> (which uses an XS lexer). 2318 2319Perl::PrereqScanner::NotQuiteLite also recognizes C<eval>. 2320Prerequisites in C<eval> are not considered as requirements, but you 2321can collect them as suggestions. 2322 2323Conditional requirements or requirements loaded in a block are 2324treated as recommends. Noed modules are stored separately (since 0.94). 2325You may or may not need to merge them into requires. 2326 2327Perl::PrereqScanner::NotQuiteLite can also recognize some of 2328the new language features such as C<say>, subroutine signatures, 2329and postfix dereferences, to improve the minimum perl requirement 2330(since 0.9905). 2331 2332=head1 METHODS 2333 2334=head2 new 2335 2336creates a scanner object. Options are: 2337 2338=over 4 2339 2340=item parsers 2341 2342By default, Perl::PrereqScanner::NotQuiteLite only recognizes 2343modules loaded directly by C<use>, C<require>, C<no> statements, 2344plus modules loaded by a few common modules such as C<base>, 2345C<parent>, C<if> (that are in the Perl core), and by two keywords 2346exported by L<Moose> family (C<extends> and C<with>). 2347 2348If you need more, you can pass extra parser names to the scanner, 2349or C<:bundled>, which loads and registers all the parsers bundled 2350with this distribution. If you have your own parsers, you can 2351specify C<:installed> to load and register all the installed parsers. 2352 2353You can also pass a project-specific parser (that lies outside the 2354C<Perl::PrereqScanner::NotQuiteLite::Parser> namespace) by 2355prepending C<+> to the name. 2356 2357 use Perl::PrereqScanner::NotQuiteLite; 2358 my $scanner = Perl::PrereqScanner::NotQuiteLite->new( 2359 parsers => [qw/+PrereqParser::For::MyProject/], 2360 ); 2361 2362If you don't want to load a specific parser for some reason, 2363prepend C<-> to the parser name. 2364 2365=item suggests 2366 2367Perl::PrereqScanner::NotQuiteLite ignores C<use>-like statements in 2368C<eval> by default. If you set this option to true, 2369Perl::PrereqScanner::NotQuiteLite also parses statements in C<eval>, 2370and records requirements as suggestions. 2371 2372=item recommends 2373 2374Perl::PrereqScanner::NotQuiteLite usually ignores C<require>-like 2375statements in a block by default. If you set this option to true, 2376Perl::PrereqScanner::NotQuiteLite also records requirements in 2377a block as recommendations. 2378 2379=item perl_minimum_version 2380 2381If you set this option to true, Perl::PrereqScanner::NotQuiteLite 2382adds a specific version of perl as a requirement when it finds 2383some of the new perl language features. 2384 2385=back 2386 2387=head2 scan_file 2388 2389takes a path to a file and returns a ::Context object. 2390 2391=head2 scan_string 2392 2393takes a string, scans and returns a ::Context object. 2394 2395=head1 SEE ALSO 2396 2397L<Perl::PrereqScanner>, L<Perl::PrereqScanner::Lite>, L<Module::ExtractUse> 2398 2399L<Perl::PrereqScanner::NotQuiteLite::App> to scan a whole distribution. 2400 2401L<scan-perl-prereqs-nqlite> is a command line interface of the above. 2402 2403=head1 AUTHOR 2404 2405Kenichi Ishigaki, E<lt>ishigaki@cpan.orgE<gt> 2406 2407=head1 COPYRIGHT AND LICENSE 2408 2409This software is copyright (c) 2015 by Kenichi Ishigaki. 2410 2411This is free software; you can redistribute it and/or modify it under 2412the same terms as the Perl 5 programming language system itself. 2413 2414=cut 2415