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