File Coverage

blib/lib/Devel/DumpTrace/PPI.pm
Criterion Covered Total %
statement 25 27 92.5
branch n/a
condition n/a
subroutine 9 9 100.0
pod n/a
total 34 36 94.4


line stmt bran cond sub pod time code
1             package Devel::DumpTrace::PPI;
2 16     16   2016 use Devel::DumpTrace;
  16         31  
  16         95  
3 16     16   114 use Devel::DumpTrace::Const;
  16         30  
  16         1220  
4 16     16   88 use PadWalker;
  16         36  
  16         472  
5 16     16   97 use Scalar::Util;
  16         26  
  16         592  
6 16     16   8854 use Data::Dumper;
  16         88904  
  16         1089  
7 16     16   119 use Carp;
  16         33  
  16         767  
8 16     16   85 use strict;
  16         49  
  16         331  
9 16     16   75 use warnings;
  16         30  
  16         936  
10              
11             local $| = 1;
12              
13             croak "Devel::DumpTrace::PPI may not be used ",
14             "when \$Devel::DumpTrace::NO_PPI ",
15             "is set (Did you load 'Devel::DumpTrace::noPPI'?\n"
16             if $Devel::DumpTrace::NO_PPI;
17 16     16   2879 eval {use PPI;
  0            
  0            
18             1}
19             or croak "PPI not installed. Can't use Devel::DumpTrace::PPI module";
20              
21              
22             # functions in this file that override functions in Devel/DumpTrace.pm
23              
24             *Devel::DumpTrace::get_source = *get_source_PPI;
25             *Devel::DumpTrace::evaluate_and_display_line = *evaluate_and_display_line_PPI;
26             *Devel::DumpTrace::handle_deferred_output = *handle_deferred_output_PPI;
27              
28             *_display_style = *Devel::DumpTrace::_display_style;
29             *evaluate = *Devel::DumpTrace::evaluate;
30             *current_position_string = *Devel::DumpTrace::current_position_string;
31             *dumptrace = *Devel::DumpTrace::dumptrace;
32              
33              
34              
35             $Devel::DumpTrace::PPI::VERSION = '0.28';
36             use constant ADD_IMPLICIT_ => 1;
37             use constant DECORATE_FOR => 1;
38             use constant DECORATE_FOREACH => 1;
39             use constant DECORATE_WHILE => 1;
40             use constant DECORATE_ELSIF => 1;
41              
42             # built-in functions that may use $_ implicitly
43             # make %implicit_ a package, not lexical, variable on the off
44             # chance that anyone wants to customize this list
45             my %implicit_ = map {; $_ => 1 } qw(abs alarm chomp chop chr chroot cos
46             defined eval exp glob hex int lc lcfirst length log lstat mkdir
47             oct ord pos print quotemeta readlink readpipe ref require
48             reverse rmdir sin split sqrt stat study uc ucfirst unlink
49             unpack say);
50              
51             # see &preval
52             my %assign_ops_ = map {; $_ => 1 } qw(= += -= *= /= %= &= |= ^= .= x= **= &&=
53             ||= //= <<= >>= ++ --);
54              
55             # for persisting the PPI documents we create
56             my (%ppi_src, %ppi_doc);
57              
58             my $last_file_sub_displayed = '';
59             my $last_file_line_displayed = '';
60             my %IGNORE_FILE_LINE = ();
61              
62             sub import {
63             foreach my $PPI_package (grep { m{^PPI[/.]} } keys %INC) {
64             $PPI_package =~ s/\.pm$//;
65             $PPI_package =~ s{/}{::}g;
66             $Devel::DumpTrace::EXCLUDE_PKG{$PPI_package} = 1;
67             }
68             $Devel::DumpTrace::EXCLUDE_PKG{"Carp::Always"} = 1;
69             goto &Devel::DumpTrace::import;
70             }
71              
72             # Overrides get_source in Devel/DumpTrace.pm
73             sub get_source_PPI {
74             my ($file, $line) = @_;
75              
76             if (!defined $ppi_src{$file}) {
77             eval { _update_ppi_src_for_file($file) };
78             }
79             return \@{$ppi_src{$file}[$line]};
80             }
81              
82             sub _update_ppi_src_for_file {
83             my $file = shift;
84              
85             my $doc;
86             if ($file eq '-e' # code from perl -e '...'
87             || $file eq '-' # code from cat prog.pl | perl
88             || $file =~ /^\(eval \d+\)\[/) { # code from an eval statement
89             no strict 'refs'; ## no critic (NoStrict)
90             my $all_code = join "", @{"::_<$file"}[1 .. $#{"::_<$file"}];
91             $doc = $ppi_doc{$file} = PPI::Document->new(\$all_code);
92             } else {
93             $doc = $ppi_doc{$file} = PPI::Document->new($file);
94             }
95             $doc->index_locations;
96              
97             # find every separate statement in the document
98             # and store by its line number.
99              
100             # there may be more than one distinct statement per line ($a=4; $b=6;)
101             # but statements that are children of other statements should not
102             # be included ... ( if ($cond) { $x++ }\n ===> don't store $x++ )
103              
104             my $statements = $doc->find('PPI::Statement') || [];
105             foreach my $element (@$statements) {
106             my $_line = $element->line_number;
107              
108             # 0.28: the first child of a compound statement might begin with one or
109             # more "\n" tokens on the same line as its parent. Ignore these
110             # and treat the statement as starting at the line with the first
111             # darkspace.
112             if (ref($element) eq 'PPI::Statement') {
113             my $children = $element->{children};
114             while (ref($children->[0]) eq 'PPI::Token::Whitespace' &&
115             $children->[0] =~ /\n/) {
116             shift @$children;
117             $_line++;
118             }
119             }
120            
121             __decorate1($element, $file, $doc);
122             next if _element_has_ancestor_on_same_line($element,$_line);
123             __decorate2($element, $file);
124             _update_ppi_src_for_element($element, $file, $_line);
125             }
126             return;
127             }
128              
129             sub _element_has_ancestor_on_same_line {
130             # is the element in a BLOCK that starts on the same line?
131             # e.g. if (cond) { ELEMENT1; ELEMENT2; }\n
132            
133             my ($element,$_line) = @_;
134             return 0 if $element =~ /^\s*\n/;
135             my $parent = $element->parent;
136             while ($parent && ref($parent) ne 'PPI::Document') {
137             my $parent_line = $parent->line_number;
138             if (defined($parent_line)
139             && $parent_line == $_line
140             && ref($parent) =~ /^PPI::Statement/) {
141             return 1;
142             }
143             $parent = $parent->parent;
144             }
145             return 0;
146             }
147              
148             sub _update_ppi_src_for_element {
149             my ($element, $file, $_line) = @_;
150             $ppi_src{$file}[$_line] ||= [];
151             if (ref($element) =~ /^PPI::Statement/) {
152             my ($d1, $d2) = (0,0);
153             my @zrc = _get_source($file, $_line, $element, $d1, $d2);
154             my $elem = { %$element };
155             $elem->{children} = [ @zrc ];
156             push @{$ppi_src{$file}[$_line]}, bless($elem, ref $element);
157             } else {
158             push @{$ppi_src{$file}[$_line]}, $element;
159             }
160             }
161              
162             # decorate
163             sub __decorate1 {
164             my ($element, $file) = @_;
165             if (ADD_IMPLICIT_) {
166             __add_implicit_elements($element);
167             if (ref($element) eq 'PPI::Statement::Given') {
168             __add_implicit_to_given_when_blocks($element);
169             }
170             }
171             __decorate_first_statement_in_for_block($element, $file);
172             __decorate_first_statement_in_foreach_block($element, $file);
173             __decorate_first_statement_AFTER_for_block($element,$file);
174             __decorate_first_statement_AFTER_while_block($element, $file);
175             __decorate_first_statement_in_while_block($element, $file);
176             __decorate_statements_in_ifelse_block($element, $file);
177              
178             return;
179             }
180              
181             sub __decorate2 {
182             my ($element, $file) = @_;
183             __remove_whitespace_and_comments_just_before_end_of_statement($element);
184             __decorate_last_statement_in_dowhile_block($element, $file);
185             return;
186             }
187              
188             # extract source from a compound statement that goes with the
189             # specified line. This involves removing tokens that appear on
190             # other lines AFTER a block opening ("{") has been observed.
191             sub _get_source {
192             my ($file, $line, $node, undef, undef, @src) = @_;
193             my @children = $node->elements;
194              
195             for my $element (@children) {
196             if (defined($element->line_number) && $element->line_number != $line) {
197             $_[3]++;
198             }
199             last if $_[3] && $_[4];
200             if ($element->first_token eq $element) {
201             push @src, $element;
202             } else {
203             my @zrc = _get_source($file, $line, $element, $_[3], $_[4]);
204             push @src, bless( { children=>[@zrc] }, ref($element) );
205             }
206             if (ref $element eq 'PPI::Token::Structure' && $element eq '{') {
207             $_[4]++;
208             }
209             }
210             return @src;
211             }
212              
213             sub _get_decorated_statements {
214              
215             # Many Perl flow control constructs are optimized to not
216             # allow a breakpoint at each iteration of a loop or at each
217             # condition evaluation of a complex if-elsif-else statement.
218             # So there are times when, while evaluating the first statement
219             # in a block, we also want to evaluate some other expressions
220             # from the parent flow control structure.
221              
222             my ($statements, $style) = @_;
223             my @s = @{$statements};
224             foreach my $ss (grep { $_->{__DECORATED__} } @{$statements}) {
225             my $ws = $style == DISPLAY_TERSE ? "\n\t\t\t" : " ";
226              
227             if ($ss->{__DECORATED__} eq 'foreach'
228             && $last_file_line_displayed ne $ss->{__FOREACH_LINE__}) {
229              
230             unshift @s,
231             __new_token('FOREACH: {'),
232             $ss->{__UPDATE__},
233             __new_token("} \t"); # don't use newline even in terse mode
234              
235             } elsif ($ss->{__DECORATED__} eq 'for'
236             && $last_file_line_displayed ne $ss->{__FOR_LINE__}) {
237              
238             unshift @s,
239             __new_token("FOR-UPDATE: {"),
240             $ss->{__CONTINUE__},
241             __new_token(" } FOR-COND: {"),
242             $ss->{__CONDITION__},
243             __new_token(" } $ws");
244              
245             } elsif ($ss->{__DECORATED__} eq 'while/until'
246             && $last_file_line_displayed ne $ss->{__WHILE_LINE__}) {
247              
248             unshift @s,
249             __new_token($ss->{__BLOCK_NAME__} . ": "),
250             $ss->{__CONDITION__},
251             __new_token(" $ws");
252              
253             } elsif ($ss->{__DECORATED__} eq 'if-elsif-else'
254             && $last_file_line_displayed eq $ss->{__IF_LINE__}) {
255              
256             unshift @s,
257             @{$ss->{__CONDITIONS__}},
258             __new_token(" ". $ws);
259              
260             } elsif ($ss->{__DECORATED__} eq 'do-while'
261             && $last_file_line_displayed ne $ss->{__DOWHILE_LINE__}) {
262              
263             push @s,
264             __new_token(" " . $ws),
265             __new_token($ss->{__SENSE__} . ": {"),
266             @{$ss->{__CONDITION__}},
267             __new_token("}");
268              
269             } elsif ($ss->{__DECORATED__} eq 'end-for'
270             && $last_file_line_displayed ne $ss->{__ENDFOR_LINE__}
271             && $ss->{__CONDITIONER__}
272             && $ss->{__CONDITIONER__}{__GP_CONDITION__}) {
273              
274             unshift @s,
275             __new_token("FOR-COND: {"),
276             $ss->{__CONDITIONER__}{__GP_CONDITION__},
277             __new_token("} $ws");
278              
279             } elsif ($ss->{__DECORATED__} eq 'end-while'
280             && $last_file_line_displayed ne $ss->{__ENDWHILE_LINE__}
281             && $ss->{__CONDITIONER__}
282             && $ss->{__CONDITIONER__}{__GP_CONDITION__}) {
283              
284             unshift @s,
285             __new_token($ss->{__SENSE__} . ": ("),
286             $ss->{__CONDITIONER__}{__GP_CONDITION__},
287             __new_token(") $ws");
288              
289             }
290             }
291             return @s;
292             }
293              
294             # Overrides &evaluate_and_display_line in Devel/DumpTrace.pm
295             sub evaluate_and_display_line_PPI {
296             my ($statements, $pkg, $file, $line, $sub) = @_;
297              
298             if (ref $statements ne 'ARRAY') {
299             my $doc = PPI::Document->new(\$statements);
300             $ppi_doc{"$file:$line"} = $doc;
301             $statements = [$doc->elements];
302             }
303              
304             my $style = _display_style();
305             my $code;
306             my @s = _get_decorated_statements($statements, $style);
307             $code = join '', map { "$_" } @s;
308             chomp $code;
309             $code .= "\n";
310             $code =~ s/\n(.)/\n\t\t $1/g;
311              
312             if ($style > DISPLAY_TERSE) {
313             Devel::DumpTrace::_separate();
314             dumptrace(2,0,current_position_string($file,$line,$sub),"\n");
315             dumptrace(3,1,$code);
316             unless ($IGNORE_FILE_LINE{"$file:$line"}) {
317             $last_file_sub_displayed = "$file:$sub";
318             $last_file_line_displayed = "$file:$line";
319             }
320             }
321              
322             my $xcode;
323             my @preval = ();
324              
325             # for a simple lexical declaration with no assignments,
326             # don't evaluate the code:
327             # my ($a, @b, %c);
328             # our $ZZZ;
329             # XXX - these expressions lifted from Devel::DumpTrace. Is that
330             # sufficient or should we analyze the PPI tokens?
331              
332             if ($code =~ /^ \s* (my|our) \s*
333             [\$@%*\(] /x # lexical declaration
334              
335             && $code =~ / (?
336             \s* (\# .* )? $/x # single statement, single line
337              
338             && $code !~ /=/) { # NOT an assignment
339              
340             $xcode = $code;
341              
342             } else {
343              
344             # recursive preval calls will increase the depth levels
345             local $Devel::DumpTrace::DB_ARGS_DEPTH = 4;
346              
347             for my $s (@s) {
348             push @preval, preval($s, $style, $pkg);
349             }
350             $xcode = join '', @preval;
351             }
352              
353             chomp $xcode;
354             $xcode .= "\n";
355             $xcode =~ s/\n(.)/\n\t\t $1/g;
356              
357             if ($style >= DISPLAY_GABBY && $xcode ne $code) {
358             dumptrace(4,1,$xcode);
359             }
360             my $deferred = 0;
361             for my $preval (@preval) {
362             if (ref $preval) {
363              
364             $deferred++;
365             $Devel::DumpTrace::DEFERRED{"$sub : $file"} ||= [];
366             push @{$Devel::DumpTrace::DEFERRED{"$sub : $file"}},
367             { EXPRESSION => [ @preval ],
368             PACKAGE => $pkg,
369             MY_PAD => $Devel::DumpTrace::PAD_MY,
370             OUR_PAD => $Devel::DumpTrace::PAD_OUR,
371             SUB => $sub,
372             FILE => $file,
373             LINE => $line,
374             DISPLAY_FILE_AND_LINE => $style <= DISPLAY_TERSE,
375             };
376             last;
377             }
378             }
379             if ($deferred == 0) {
380             if ($style <= DISPLAY_TERSE) {
381             dumptrace(3,0, current_position_string($file,$line,$sub),
382             "\t$xcode");
383             unless ($IGNORE_FILE_LINE{"$file:$line"}) {
384             $last_file_sub_displayed = "$file:$sub";
385             $last_file_line_displayed = "$file:$line";
386             }
387             }
388             }
389             return;
390             }
391              
392             # any elements that appear AFTER the last assignment operator
393             # are evaluated and tokenized.
394             sub preval {
395             my ($statement,$style,$pkg) = @_;
396             if (ref($statement) =~ /PPI::Token/) {
397             if ($statement->{_PREVAL}) {
398             perform_variable_substitution($statement, 0, $style, $pkg)
399             unless $statement->{_DEFER};
400             return map { ref($_) eq 'ARRAY' ? @{$_} : $_ } $statement;
401             } else {
402             return map {"$_"} $statement->tokens;
403             }
404             }
405             $Devel::DumpTrace::DB_ARGS_DEPTH++;
406              
407             if (ref($statement) !~ /^PPI::/) {
408             Carp::confess "$statement is not a PPI token -- ", %$statement,
409             "\nThis is a bug. Report to bug-Devel-DumpTrace\@rt.cpan.org\n";
410             }
411              
412             my @e = $statement->elements;
413              
414             # look for implicit uses of special vars
415             if (ADD_IMPLICIT_) {
416             __append_implicit_to_naked_shift_pop(\@e);
417             }
418              
419             # find last assignment operator in this expression, if any.
420             my $lao_index = 0;
421             for my $i (0 .. $#e) {
422             if (ref($e[$i]) eq 'PPI::Token::Operator'
423             && $assign_ops_{$e[$i]{content}}) {
424             $lao_index = $i;
425             }
426             }
427             _preval_render(\@e, $lao_index, $style, $pkg);
428             my @output = map { ref($_) eq 'ARRAY' ? @{$_} : $_ } @e;
429             $Devel::DumpTrace::DB_ARGS_DEPTH--;
430             return @output;
431             }
432              
433             sub _preval_render {
434              
435             # evaluate any PPI::Token::Symbol elements after all assignment ops, if any
436             # tokenize other PPI::Token::* elements
437             # pass other elements back to &preval recursively
438              
439             my ($e, $lao_index, $style, $pkg) = @_;
440             $Devel::DumpTrace::DB_ARGS_DEPTH++;
441             for (my $i=$lao_index; $i < @$e; $i++) {
442             if (ref($e->[$i]) eq 'PPI::Token::Symbol') {
443             next if $e->[$i]{_DEFER};
444             perform_variable_substitution(@$e, $i, $style, $pkg);
445             if ($i > 0 && ref($e->[$i-1]) eq 'PPI::Token::Cast') {
446             if ($e->[$i-1] eq '@' && $e->[$i] =~ /^\[(.*)\]$/) {
447              
448             # @$a => @[1,2,3] should render as @$a => (1,2,3)
449              
450             $e->[$i-1] = '';
451             $e->[$i] = '(' . substr($e->[$i],1,-1) . ')';
452             } elsif ($e->[$i-1] eq '%' && $e->[$i] =~ /^\{(.*)\}$/) {
453              
454             # render %$a as ('a'=>1;'b'=>2) , not %{'a'=>1;'b'=>2}
455              
456             $e->[$i-1] = '';
457             $e->[$i] = '(' . substr($e->[$i],1,-1) . ')';
458             }
459             }
460             } elsif (ref $e->[$i] eq 'PPI::Token::Magic') {
461             next if $e->[$i]{_DEFER};
462             perform_variable_substitution(@$e, $i, $style, '');
463             } elsif (ref($e->[$i]) =~ /PPI::Token/) {
464             $e->[$i] = "" . $e->[$i] if ref($e->[$i]) ne 'PPI::Token::Cast';
465             } else {
466             $e->[$i] = [ preval($e->[$i],$style,$pkg) ];
467             }
468             }
469             $Devel::DumpTrace::DB_ARGS_DEPTH--;
470             return;
471             }
472              
473             sub perform_variable_substitution_on_tokens {
474             # needed to evaluate complex lvalues.
475             # Called from handle_deferred_output_PPI()
476             my ($elem, $style, $dpkg) = @_;
477             my @out = ();
478             my $ref = ref($elem);
479             if ($ref =~ /^PPI::Statement/ || $ref =~ /^PPI::Structure/) {
480             foreach my $e ($elem->elements()) {
481             $Devel::DumpTrace::DB_ARGS_DEPTH++;
482             push @out,
483             perform_variable_substitution_on_tokens($e, $style, $dpkg);
484             $Devel::DumpTrace::DB_ARGS_DEPTH--;
485             }
486             } elsif ($ref eq 'PPI::Token::Symbol') {
487             my @e = ($elem);
488             perform_variable_substitution(@e, 0, $style, $dpkg);
489             @out = "$e[0]";
490             } elsif ($ref eq 'PPI::Token::Magic') {
491             my @e = ($elem);
492             perform_variable_substitution(@e, 0, $style, '');
493             @out = "$e[0]";
494             } else {
495             @out = "$elem";
496             }
497             return join '', @out;
498             }
499              
500             # Overrides &handle_deferred_output in Devel/DumpTrace.pm
501             sub handle_deferred_output_PPI {
502              
503             my ($sub, $file) = @_;
504             my $deferred = pop @{$Devel::DumpTrace::DEFERRED{"$sub : $file"}};
505             return unless defined($deferred);
506              
507             my @e = grep defined, @{$deferred->{EXPRESSION}};
508             my $undeferred_output = join '', @e;
509             my $deferred_pkg = $deferred->{PACKAGE};
510             $Devel::DumpTrace::PAD_MY = $deferred->{MY_PAD};
511             $Devel::DumpTrace::PAD_OUR = $deferred->{OUR_PAD};
512             Devel::DumpTrace::refresh_pads();
513              
514             my $style = _display_style();
515             for my $i (0 .. $#e) {
516             if (ref $e[$i] eq 'PPI::Token::Symbol') {
517             perform_variable_substitution(@e, $i, $style, $deferred_pkg);
518             } elsif (ref($e[$i]) eq 'PPI::Token::Magic') {
519             perform_variable_substitution(@e, $i, $style, '');
520             } elsif (ref $e[$i] eq 'PPI::Token::Cast') {
521             eval { $e[$i] = "$e[$i]"; };
522             } elsif (ref($e[$i]) =~ /^PPI::/) {
523             $Devel::DumpTrace::DB_ARGS_DEPTH++;
524             $e[$i] = perform_variable_substitution_on_tokens(
525             $e[$i],$style,$deferred_pkg);
526             $Devel::DumpTrace::DB_ARGS_DEPTH--;
527             }
528             }
529             my $deferred_output = join '', @e;
530             chomp($undeferred_output,$deferred_output);
531             $undeferred_output .= "\n";
532             $undeferred_output =~ s/\n(.)/\n\t\t $1/g;
533             $deferred_output .= "\n";
534             $deferred_output =~ s/\n(.)/\n\t\t $1/g;
535             my $line = $deferred->{LINE};
536             $file = $deferred->{FILE};
537             $sub = $deferred->{SUB};
538             if ($deferred->{DISPLAY_FILE_AND_LINE}
539             || "$file:$sub" ne $last_file_sub_displayed) {
540              
541             if (_display_style() > DISPLAY_TERSE) {
542             Devel::DumpTrace::_separate();
543             dumptrace(4,0,current_position_string($file,$line,$sub),"\n");
544             dumptrace(4,1,$undeferred_output);
545             dumptrace(5,1,$deferred_output)
546             if $deferred_output ne $undeferred_output;
547             } else {
548             dumptrace(5,0,current_position_string($file,$line,$sub),
549             "\t$deferred_output");
550             }
551             } else {
552             dumptrace(5,1,$deferred_output);
553             }
554             unless ($IGNORE_FILE_LINE{"$file:$line"}) {
555             $last_file_sub_displayed = "$file:$sub";
556             $last_file_line_displayed = "$file:$line";
557             }
558             return;
559             }
560              
561             sub perform_variable_substitution {
562             # perform_variable_substitution(LIST,index,style,package)
563             #
564             # evaluate the symbol indicated by LIST[index] in the context
565             # of the given package and produce output in the given style
566             my $pkg = pop @_;
567             my $style = pop @_;
568             my $i = pop @_;
569              
570             my $sigil = substr $_[$i], 0, 1;
571             return if $sigil eq '&' || $sigil eq '*' || $sigil eq "_";
572             my $varname = substr $_[$i], 1;
573             $varname =~ s/^\s+//;
574             $varname =~ s/\s+$//;
575             my $deref_op = '';
576             my $index_op = '';
577             my @keys;
578              
579             my $j = $i+1;
580             while ($j < @_ && ref($_[$j]) eq 'PPI::Token::Whitespace') {
581             $j++;
582             }
583             if (ref($_[$j]) eq 'PPI::Token::Operator' && $_[$j] eq '->') {
584             $deref_op = '->';
585             $j++;
586             while ($j < @_ && ref $_[$j] eq 'PPI::Token::Whitespace') {
587             $j++;
588             }
589             }
590             if (ref($_[$j]) =~ /^PPI::Structure::/) {
591             my @t = $_[$j]->tokens();
592             if ($t[0] eq '[') {
593             $index_op = '[';
594             push @keys, evaluate_subscript($pkg,@t);
595             } elsif ($t[0] eq '{') {
596             $index_op = '{';
597             push @keys, evaluate_subscript($pkg,@t);
598             }
599             }
600              
601             $_[$i] = evaluate($sigil,$varname,$deref_op,$index_op, $pkg, @keys);
602             $_[$i] =~ s/[\[\{]$//;
603             $_[$i] =~ s/\-\>$//;
604             if ($style < DISPLAY_GABBY) {
605             $_[$i] = "$sigil$varname$Devel::DumpTrace::XEVAL_SEPARATOR" . $_[$i];
606             }
607             return $_[$i];
608             }
609              
610             sub evaluate_subscript {
611             my ($pkg, @tokens) = @_;
612              
613             my $abbrev_style = Devel::DumpTrace::_abbrev_style();
614             if ($abbrev_style != ABBREV_SMART && $abbrev_style != ABBREV_MILD_SM) {
615             return ();
616             }
617              
618             shift @tokens;
619             pop @tokens;
620              
621             for (my $i=0; $i<@tokens; $i++) {
622             if (ref $tokens[$i] eq 'PPI::Token::Symbol') {
623             my $y0 = $tokens[$i];
624             my $y1 = perform_variable_substitution(
625             @tokens, $i, DISPLAY_GABBY, $pkg);
626             }
627             }
628              
629             my $ref = join ' ', map { ref($_), ref(\$_) } @tokens;
630             my $key;
631              
632             # don't evaluate expressions that may have side-effects
633             # Any PPI::Token::Symbol's left are probably function calls
634             # PPI::Token::Word could be function calls
635             # Avoid expressions with assignment, postfix operators
636             # Typeglobs won't get eval'd well
637             # actually, any tied variable can have side effects
638             # (through FETCH, e.g.)
639              
640             return if $ref =~ /PPI::Token::Symbol/;
641             return if $ref =~ /PPI::Token::Word/;
642             return if $ref =~ /GLOB/;
643              
644             my $expr = join '', @tokens;
645              
646             return if $expr =~ /=/;
647             return if $expr =~ /\+\+/;
648             return if $expr =~ /--/;
649              
650             $key = eval $expr;
651              
652             if ($@ || !defined $key) {
653             return;
654             } else {
655             return ($key);
656             }
657             }
658              
659             # 0.07: If a statement ends with whitespace and/or comments before the
660             # ';' token, remove them for appearances sake.
661             sub __remove_whitespace_and_comments_just_before_end_of_statement {
662             my $element = shift;
663             my @tokens = $element->tokens();
664             return if @tokens <= 3
665             || ref($tokens[-1]) ne 'PPI::Token::Structure'
666             || $tokens[-1] ne ';';
667              
668             my $j = -2;
669             while (defined($tokens[$j])
670             && (ref($tokens[$j]) eq 'PPI::Token::Whitespace'
671             || ref($tokens[$j]) eq 'PPI::Token::Comment'
672             || ref($tokens[$j]) eq 'PPI::Token::POD')) {
673             $j--;
674             }
675             if ($j < -3 && defined($tokens[$j])) {
676             for my $k ($j+1 .. -1) {
677             $tokens[$k]->delete();
678             }
679             }
680             return;
681             }
682              
683             sub __add_implicit_elements {
684             my ($statement) = @_;
685             return if ref($statement) eq 'PPI::Statement::End';
686              
687             my $e = $statement->{children};
688              
689             __insert_implicit_NR_into_flipflop($e);
690             __prepend_implicit_topic_to_naked_regexp($e);
691             __append_implicit_topic_to_naked_filetest($e);
692             __append_implicit_topic_to_naked_builtins($e);
693             __insert_implicit_topic_into_default_foreach($e);
694             __prepend_implicit_topic_for_readline_op($e);
695              
696             return;
697             }
698              
699             sub __prepend_implicit_topic_for_readline_op {
700             my $e = shift;
701              
702             #
703             # while (<$fh>) means while ( defined($_=<$fh>) )
704             # until (<$fh>) means until ( defined($_=<$fh>) )
705             #
706              
707             # also need to capture:
708             # expression while <$foo>
709             # while ( <$foo> )
710             # while ( readline($foo) ) #
711              
712             # but also need to exclude:
713              
714             # while (<$fh> && condition)
715             # while (condition || <$fh>)
716             # while ( < $foo > )
717              
718             my ($ql,$ql2) = grep ref($_) eq 'PPI::Token::QuoteLike::Readline', @$e;
719             return if $ql2 || !$ql;
720             return if "$ql" !~ /^<[\$\*]?[\w:']+>$/;
721              
722             # we expect either:
723             #
724             # 1a. PPI::Token::QuoteLike::Readline as its own statement
725             # 1b. (grand)parent is a PPI::Structure::Condition
726             # 1c. condition is preceded by while}until (whitespace?)
727             # 1d. condition is followed by NULL | Structure(;)
728             #
729             # -or-
730             #
731             # 2a. PPI::Token::QuoteLike::Readline in statement with many tokens
732             # 2b. preceded by while|until (whitespace?)
733             # 2c. followed by NULL | Structure(;)
734              
735             my $ee = $e;
736             my $ql3 = $ql;
737             my @ref = map { ref } @$e;
738             my @oref = grep { $_ ne 'PPI::Token::Whitespace'
739             && $_ ne 'PPI::Token::QuoteLike::Readline' } @ref;
740              
741             if (@oref == 0) {
742             $ee = $ql->parent; # PPI::Statement::Expression
743             return if ref($ee) ne 'PPI::Statement::Expression';
744             $ee = $ee->parent; # PPI::Structure::Condition
745             $ql3 = "$ee";
746             return if ref($ee) ne 'PPI::Structure::Condition';
747             $ee = $ee->parent; # PPI::Statement
748             return if ref($ee) !~ /^PPI::Statement/;
749             $ee = $ee->{children};
750             }
751              
752             for (my $i=0; $i<@$ee; $i++) {
753              
754             next if $ee->[$i] ne "$ql" && $ee->[$i] ne $ql3;
755              
756             my $j = $i+1;
757             $j++ while $j<@$ee && ref($ee->[$j]) eq 'PPI::Token::Whitespace';
758             return if $j<@$ee && (ref($ee->[$j]) ne 'PPI::Token::Structure' ||
759             $ee->[$j] ne ';')
760             && ref($ee->[$j]) ne 'PPI::Structure::Block';
761              
762             $j = $i-1;
763             $j-- while $j>=0 && ref($ee->[$j]) eq 'PPI::Token::Whitespace';
764              
765             return if $j<0;
766             return if ref($ee->[$j]) ne 'PPI::Token::Word';
767             return if $ee->[$j] ne 'while' && $ee->[$j] ne 'until';
768              
769             for (my $k=0; $k<@$e; $k++) {
770             next if ref($e->[$k]) ne 'PPI::Token::QuoteLike::Readline';
771             splice @$e, $k, 0,
772             bless({content=>'$_',_DEFER=>1},'PPI::Token::Magic'),
773             bless({content=>'='}, 'PPI::Token::Operator');
774             return 1;
775             }
776             }
777             return;
778             }
779              
780             sub __prepend_implicit_topic_to_naked_regexp {
781             my $e = shift;
782              
783             #
784             # /pattern/ means $_ =~ /pattern/
785             #
786             # TODO: but split(/pattern/,...)
787             # is not split($_=~/pattern/,...)
788             # TODO: other functions that expect regexp
789             # TODO: functions that don't expect regexp but can accept them
790             #
791             for (my $i = 0; $i < @$e; $i++) {
792             next unless ref($e->[$i]) =~ /^PPI::Token::Regexp/;
793             my $j = $i-1;
794             $j-- while $j >= 0 && ref($e->[$j]) eq 'PPI::Token::Whitespace';
795             if ($j < 0 || ref($e->[$j]) ne 'PPI::Token::Operator'
796             || ($e->[$j] ne '=~' && $e->[$j] ne '!~')) {
797              
798             splice @$e, $i, 0,
799             bless( { content => '$_' }, 'PPI::Token::Magic' ),
800             bless( { content => '=~' }, 'PPI::Token::Operator' );
801             }
802             }
803             return;
804             }
805              
806             sub __append_implicit_topic_to_naked_filetest {
807             my $e = shift;
808              
809             #
810             # bare -X means -X $_ (except for -t)
811             #
812             for (my $i=0; $i<@$e; $i++) {
813             if (ref $e->[$i] eq 'PPI::Token::Operator'
814             && $e->[$i] =~ /^-[a-su-zA-Z]$/) {
815             my $j = $i + 1;
816             while ($j <= @$e && ref($e->[$j]) eq 'PPI::Token::Whitespace') {
817             $j++;
818             }
819             if ($j >= @$e || ref($e->[$j]) eq 'PPI::Token::Operator'
820             || ref($e->[$j]) eq 'PPI::Token::Structure') {
821             splice @$e, $i+1, 0,
822             bless( { content=>' ' }, 'PPI::Token::Whitespace' ),
823             bless( { content=>'$_' }, 'PPI::Token::Magic' );
824             }
825             }
826             }
827             return;
828             }
829              
830             sub __append_implicit_topic_to_naked_builtins {
831             my $e = shift;
832              
833             #
834             # for many builtin functions (print, sin, log, ...)
835             #
836             # func; means func($_);
837             #
838             # but $hash{barword}
839             # never means $hash{bareword $_}
840             #
841             for (my $i=0; $i<@$e; $i++) {
842             if (ref($e->[$i]) eq 'PPI::Token::Word'
843             && defined $implicit_{"$e->[$i]"}) {
844              
845             my $j = $i + 1;
846             my $gparent = $e->[$i]->parent && $e->[$i]->parent->parent;
847             next if $gparent && ref($gparent) eq 'PPI::Structure::Subscript'
848             && $gparent =~ /^{/;
849             $j++ while $j <= @$e && ref($e->[$j]) eq 'PPI::Token::Whitespace';
850             if ($j >= @$e || ref($e->[$j]) eq 'PPI::Token::Structure'
851             || (ref($e->[$j]) eq 'PPI::Token::Operator' &&
852             ($e->[$j] eq '..' || $e->[$j] eq '...'))) {
853             if ($e->[$i] eq 'split') {
854             # naked split is parsed as split /\s+/, $_
855             splice @$e, $i+1, 0,
856             bless({content=>' '}, 'PPI::Token::Whitespace'),
857             bless({content=>'m/\\s+/'},
858             'PPI::Token::Regexp::Match'),
859             bless({content=>','}, 'PPI::Token::Operator'),
860             bless({content=>'$_'}, 'PPI::Token::Magic');
861             } else {
862             splice @$e, $i+1, 0,
863             bless({content=>' '}, 'PPI::Token::Whitespace'),
864             bless({content=>'$_'}, 'PPI::Token::Magic');
865             }
866             }
867             }
868             }
869             return;
870             }
871              
872             sub __insert_implicit_topic_into_default_foreach {
873             my $e = shift;
874              
875             # for (LIST) means for $_ (LIST)
876              
877             for (my $i=0; $i<@$e; $i++) {
878             next unless ref($e->[$i]) eq 'PPI::Token::Word'
879             && ($e->[$i] eq 'for' || $e->[$i] eq 'foreach');
880              
881             my $j = $i + 1;
882             $j++ while $j < @$e && ref($e->[$j]) eq 'PPI::Token::Whitespace';
883             if ($j < @$e && ref($e->[$j]) eq 'PPI::Structure::List') {
884              
885             splice @$e, $i+1, 0,
886             bless({content=>' '}, 'PPI::Token::Whitespace'),
887             bless({content=>'$_', _DEFER => 1}, 'PPI::Token::Magic');
888              
889             }
890             }
891             return;
892             }
893              
894             sub __insert_implicit_NR_into_flipflop {
895             # (m ... n) means ($.==m ... $.==n)
896             # (m .. n) means ($.==m .. $.==n) in list context only
897             my $e = shift;
898             for (my $i=0; $i<@$e; $i++) {
899             next unless ref($e->[$i]) eq 'PPI::Token::Operator';
900             next unless $e->[$i] eq '...' || $e->[$i] eq '..';
901             if ($e->[$i] eq '..') {
902             # must also guess whether this is evaluated in scalar context
903             # some heuristics we will use:
904             # no if preceded by 'for','foreach' keyword
905             # no if preceded by '=' operator
906             # yes if preceded by other assignment operator
907             # yes if preceded by 'if','while',or 'until'
908             my $ee = $e;
909             my $ff = join '', @$e;
910             my @ref = map { ref } @$e;
911             my @oref = grep { !/::Whitespace/ && !/::Operator/
912             && !/::Number/ } @ref;
913              
914             if (@oref == 0) {
915             $ee = $e->[0]->parent;
916             return if ref($ee) ne 'PPI::Statement::Expression';
917             $ee = $ee->parent;
918             return if ref($ee) ne 'PPI::Structure::Condition';
919             # ah, there we go. In list context PPI will call $ee
920             # a PPI::Structure::List
921             $ee = $ee->parent;
922             return if ref($ee) !~ /^PPI::Statement/;
923             $ee = $ee->{children};
924             }
925             for (my $k=0; $k<@$ee; $k++) {
926             next if $ee->[$k] ne $ff && $ee->[$k] ne "($ff)";
927             my $l = $k+1;
928             $l++ while $l<@$ee &&
929             'PPI::Token::Whitespace' eq ref $ee->[$l];
930             return if $l<@$ee &&
931             (ref($ee->[$l]) ne 'PPI::Token::Structure'
932             || $ee->[$l] ne ';') &&
933             ref($ee->[$l]) ne 'PPI::Structure::Block';
934             $l = $k-1;
935             $l-- while $l>=0 && 'PPI::Token::Whitespace' eq ref $ee->[$l];
936             return if $l<0;
937             return if ref($ee->[$l]) ne 'PPI::Token::Word';
938             return if $ee->[$l] ne 'if' && $ee->[$l] ne 'while' &&
939             $ee->[$l] ne 'until';
940             last;
941             }
942             }
943              
944             # token before the ... operator
945             my $j = $i - 1;
946             $j-- while $j>0 && ref($e->[$j]) eq 'PPI::Token::Whitespace';
947              
948             if ($j >= 0 && ref($e->[$j]) =~ /PPI::Token::Number/) {
949             if ($j==0) {
950             unshift @$e,
951             bless({content => '$.', _location => $e->[$j]{_location}},
952             'PPI::Token::Magic'),
953             bless({content => '==', _location => $e->[$j]{_location}},
954             'PPI::Token::Operator');
955             return 1;
956             } else {
957             splice @$e, $j, 0,
958             bless({content => '$.'}, 'PPI::Token::Magic'),
959             bless({content => '=='}, 'PPI::Token::Operator');
960             return 1;
961             # how to tell if Number represents a standalone expression?
962             # or a numerical expression like + 40
963             }
964             }
965             # token after the ... operator
966             $j = $i + 1;
967             $j++ while $j<@$e && ref($e->[$j]) eq 'PPI::Token::Whitespace';
968             if ($j < @$e && (ref($e->[$j]) eq 'PPI::Token::Number' ||
969             ref($e->[$j]) eq 'PPI::Token::Number::Float')) {
970             if ($j == $#$e) {
971             splice @$e, $j, 0,
972             bless({content => '$.'}, 'PPI::Token::Magic'),
973             bless({content => '=='}, 'PPI::Token::Operator');
974             return 1;
975             }
976             }
977             }
978             return;
979             }
980              
981             sub __append_implicit_to_naked_shift_pop {
982             #
983             # look for use of implicit @_/@ARGV with shift/pop.
984             #
985             # This cannot be done when the document is initially parsed
986             # (in &__add_implicit_elements, for example) because
987             # we can only definitively determine whether or not we
988             # are inside a subroutine at runtime.
989             #
990             my $e = shift;
991             for (my $i=0; $i<@$e; $i++) {
992             next if ref($e->[$i]) ne 'PPI::Token::Word';
993             next if $e->[$i] ne 'shift' && $e->[$i] ne 'pop';
994              
995             my $j = $i + 1;
996             while ($j <= @$e && ref($e->[$j]) eq 'PPI::Token::Whitespace') {
997             $j++;
998             }
999             if ($j >= @$e || ref($e->[$j]) eq 'PPI::Token::Operator'
1000             || ref($e->[$j]) eq 'PPI::Token::Structure') {
1001              
1002             # found naked pop/shift. Determine if we are inside a sub
1003             # so we know whether to apply @ARGV or @_.
1004             my $n = 0;
1005             my $xp = 0;
1006             while (my @p = caller($n++)) {
1007             $xp += $p[CALLER_PKG] !~ /^Devel::DumpTrace/ &&
1008             $p[CALLER_SUB] !~ /^\(eval/;
1009             }
1010              
1011             if ($xp >= 2) { # inside sub, manip @_
1012             splice @$e, $i+1, 0,
1013             bless({content=>' '}, 'PPI::Token::Whitespace'),
1014             bless({content=>'@_'}, 'PPI::Token::Magic');
1015             } else { # not inside sub, manip @ARGV
1016             splice @$e, $i+1, 0,
1017             bless({content=>' '}, 'PPI::Token::Whitespace'),
1018             bless({content=>'@ARGV'}, 'PPI::Token::Symbol');
1019             }
1020             }
1021             }
1022             }
1023              
1024             sub __add_implicit_to_given_when_blocks {
1025              
1026             # given($foo)
1027             # when($bar) means when ($foo ~~ $bar)
1028             # when(\@list) means when ($foo ~~ \@list)
1029             # when(&func) means ???
1030             # when(\&func) means when (&func($foo))
1031             # when(m/patt/) means when ($foo ~= m/patt/)
1032             # when($a <=> cmp $b) means what it says
1033             # when(defined ... exists ... eof) means what it says
1034             # when(!something) means what it says
1035             # when(-X file) means what it says for X not in {sMAC}
1036             # when(flip..flop) means what it says
1037              
1038              
1039             # there are probably a lot of incorrect edge cases,
1040             # but this is a good start
1041              
1042              
1043              
1044             my $given = shift;
1045              
1046             # what to do with a given block:
1047             # extra token(s) from child PPI::Structure::Given
1048             # extract structure tokens from front,back
1049             # this becomes the _given_ expression
1050             # find child PPI::Structure::Block
1051             # find grandchild PPI::Statement::When
1052             # find greatgrandchild PPI::Structure::When
1053             # analyze PPI::Structure::When element
1054             # if there is an "implicit smart match",
1055             # insert << $_ ~~ >> at the beginning of the struct
1056             my $given_child = $given->find('PPI::Structure::Given') or return;
1057             my $given_expr
1058             = $given_child->[0]->find('PPI::Statement::Expression') or return;
1059              
1060             my $given_tok = join '', $given_expr->[0]->tokens;
1061              
1062             my $whens = $given->find('PPI::Statement::When') || [];
1063             foreach my $when (@$whens) {
1064             if ($when->parent->parent ne $given) {
1065             next;
1066             }
1067             my $structure = $when->find('PPI::Structure::When');
1068             unless ($structure) {
1069             next;
1070             }
1071             $structure = $structure->[0];
1072            
1073             my $when_expr = $structure->find('PPI::Statement::Expression');
1074             unless ($when_expr) {
1075             $when_expr = $structure->find('PPI::Statement');
1076             next unless $when_expr;
1077             }
1078             my $first_when_expr = $when_expr->[0];
1079             my $is_implicit_smart_match = 0;
1080              
1081             my @e = $first_when_expr->elements();
1082              
1083             if (ref($e[0]) eq 'PPI::Token::Word'
1084             || ref($e[0]) =~ /PPI::Token::Quote::/) {
1085              
1086             $is_implicit_smart_match = 2;
1087              
1088             if ($e[0] eq 'defined' || $e[0] eq 'exists' || $e[0] eq 'eof') {
1089             $is_implicit_smart_match = 0;
1090             }
1091              
1092             } elsif (ref($e[0]) eq 'PPI::Structure::Constructor'
1093             && $e[0] =~ /^\[/) {
1094              
1095             $is_implicit_smart_match = 3;
1096              
1097             } elsif (@e == 1 &&
1098             (ref($e[0]) eq 'PPI::Token::Symbol' ||
1099             ref($e[0]) eq 'PPI::Token::Magic' ||
1100             ref($e[0]) =~ 'PPI::Token::Number')) {
1101              
1102             $is_implicit_smart_match = 1;
1103              
1104             } elsif (ref($e[0]) eq 'PPI::Token::Cast' && $e[0] eq '\\'
1105             && ref($e[1]) =~ /PPI::Token::(Symbol|Magic)/
1106             && $e[1] !~ /[&*]/) {
1107              
1108             $is_implicit_smart_match = 4;
1109              
1110             }
1111              
1112             for (my $i=0; $i<@e; $i++) {
1113             my $e = $e[$i];
1114              
1115             if (ref($e) =~ /Operator/
1116             && ($e eq '<' || $e eq '>' || $e eq '==' ||
1117             $e eq '<=' || $e eq '>=' || $e eq 'le' || $e eq 'ge' ||
1118             $e eq 'lt' || $e eq 'gt' || $e eq 'eq' || $e eq 'ne' ||
1119             $e eq '<=>' || $e eq 'cmp' || $e eq '!' || $e eq 'not' ||
1120             $e eq '^' || $e eq 'xor' || $e eq '~~' || $e eq '..')) {
1121              
1122             $is_implicit_smart_match = 0;
1123             last;
1124             } elsif (ref($e) =~ /::Regexp/) {
1125              
1126             $is_implicit_smart_match = 0;
1127             last;
1128             } elsif (ref($e) eq 'PPI::Token::Cast' && $e eq '\\'
1129             && ref($e[$i+1]) eq 'PPI::Token::Symbol'
1130             && $e[$i+1] =~ /^&/) {
1131              
1132             $is_implicit_smart_match = 0;
1133             last;
1134             } elsif (ref($e) =~ /Operator/
1135             && ($e eq '||' || $e eq '&&' || $e eq '//' ||
1136             $e eq 'or' || $e eq 'and')) {
1137              
1138             # these operators make it ambiguous whether an implicit
1139             # smart match is being used. Disable for now and the task
1140             # of making this more sophisticated will go on the todo list.
1141              
1142             $is_implicit_smart_match = 0;
1143              
1144             }
1145            
1146             }
1147              
1148             if ($is_implicit_smart_match) {
1149             my $elem = $first_when_expr->{children};
1150             my $location = $elem->[0]->location;
1151              
1152             unshift @$elem,
1153             bless( { content => '$_', _location => $location },
1154             'PPI::Token::Magic' ),
1155             bless( { content => '~~', _location => $location },
1156             'PPI::Token::Operator');
1157             $first_when_expr->{children} = $elem;
1158             }
1159             }
1160             return;
1161             }
1162              
1163             # A C-style for-loop has the structure:
1164             # for (INIT ; CONDITION ; CONTINUE) BLOCK
1165             #
1166             # The CONDITION expression (and sometimes the CONTINUE) expression sure
1167             # would be interesting to see while you are tracing through a program.
1168             # Unfortunately, DB::DB will typically only get called at the very
1169             # start of the loop.
1170             #
1171             # One workaround might be to prepend the for statement to the
1172             # source code associated with the first statement in the BLOCK.
1173             # That way, each time a new iteration starts, you would get
1174             # the chance to observe the CONDITION and CONTINUE expressions.
1175             #
1176             sub __decorate_first_statement_in_for_block {
1177              
1178             # We expect a particular pattern of PPI elements to describe the
1179             # "first statement in the block of a C-style for-loop":
1180             #
1181             # PPI::Statement::Compound $gparent
1182             # PPI::Token::Word (for/foreach)
1183             # zero of more PPI::Token::Whitespace
1184             # PPI::Structure::For $for
1185             # ...
1186             # zero or more PPI::Token::Whitespace
1187             # PPI::Structure::Block $parent
1188             # zero or more PPI::Token::xxx
1189             # PPI::Statement::xxx $element
1190             #
1191             return unless DECORATE_FOR;
1192              
1193             my ($element, $file) = (@_);
1194             return if ref($element) !~ /^PPI::Statement/;
1195             my $parent = $element->parent;
1196             return if !defined($parent) || ref($parent) ne 'PPI::Structure::Block';
1197              
1198             my $gparent = $parent->parent;
1199             return if !defined($gparent) ||
1200             ref($gparent) ne 'PPI::Statement::Compound';
1201              
1202             my @parent_elem = grep { ref($_) !~ /^PPI::Token/ } $parent->elements();
1203             return if $parent_elem[0] ne $element;
1204              
1205             my @gparent_elem = grep { ref($_) !~ /^PPI::Token/ } $gparent->elements();
1206             my $for = $gparent_elem[0];
1207             return if ref($for) ne 'PPI::Structure::For';
1208             return if @gparent_elem < 2 || $gparent_elem[1] ne $parent;
1209              
1210             # now what do we do with it ... ?
1211             # we want to _prepend_ the tokens^H^H^H^H^H elements of $element
1212             # with all the tokens in $gparent up to $parent, plus all
1213             # the tokens of $parent up to $element.
1214              
1215             foreach my $gparent_elem ($gparent->elements()) {
1216              
1217             last if $gparent_elem eq $parent;
1218             if ($gparent_elem eq $for) {
1219              
1220             my @for_statements
1221             = grep { ref($_) =~ /^PPI::Statement/ } $for->elements();
1222              
1223             my $condition_statement = $for_statements[1]->clone();
1224             $element->{__CONDITION__} = $condition_statement;
1225             $gparent->{__GP_CONDITION__} = $condition_statement;
1226              
1227             if (@for_statements > 2) {
1228             my $continue_statement = $for_statements[2]->clone();
1229             $element->{__CONTINUE__} = $continue_statement->clone();
1230             } else {
1231             $element->{__CONTINUE__} = __new_null_statement()->clone();
1232             }
1233              
1234             my $line = $for->line_number;
1235             my $line2 = ($gparent->tokens)[-1]->line_number;
1236             $element->{__FOR_LINE__} = "$file:$line";
1237             $IGNORE_FILE_LINE{"$file:$line2"} = 1;
1238             $element->{__DECORATED__} = 'for';
1239             }
1240             }
1241             return;
1242             }
1243              
1244             sub __decorate_first_statement_AFTER_for_block {
1245            
1246             return unless DECORATE_FOR;
1247              
1248             my ($element, $file,$doc) = @_;
1249              
1250             return if ref($element) ne 'PPI::Statement::Compound';
1251             my @children = $element->children;
1252             @children = grep { ref($_) ne 'PPI::Token::Whitespace' } @children;
1253             return if ref($children[0]) ne 'PPI::Token::Word';
1254             return if "$children[0]" ne "for" && "$children[0]" ne "foreach";
1255            
1256             my $next = __next_sibling($element);
1257             return unless $next;
1258              
1259              
1260             if (0) {
1261             open TTY,">","/dev/tty";
1262             print TTY "WANT TO DECORATE STATEMENT\n\n\t$next\n\n\nAFTER FOR";
1263             print TTY "PREV STATEMENT IS\n\n\t$element\n\n",ref($element),"\n\n\n";
1264             local $Data::Dumper::Indent = 0;
1265             # print TTY "\n", Dumper($element);
1266             print TTY "\n",join("\n",sort keys %$element),"\n";
1267             print TTY "\n";
1268             }
1269              
1270             my $line = $next->line_number;
1271             $next->{__DECORATED__} = "end-for";
1272             $next->{__ENDFOR_LINE__} = "$file:$line";
1273             $next->{__CONDITIONER__} = $element;
1274             return;
1275             }
1276              
1277             sub __decorate_first_statement_in_foreach_block {
1278             # We expect a particular pattern of PPI elements to describe the
1279             # "first statement in block of a foreach loop"
1280             #
1281             #PPI::Statement::Compound $gparent
1282             # PPI::Token::Word for/foreach
1283             # zero or more PPI::Token::Whitespace
1284             # optional PPI::Token::Symbol optional $loop_var
1285             # zero or more PPI::Token::Whitespace
1286             # PPI::Structure::List $list
1287             # ...
1288             # zero or more PPI::Token::Whitespace
1289             # PPI::Structure::Block $parent
1290             # optional PPI::Token::Structure
1291             # zero or more PPI::Token::Whitespace
1292             # PPI::Statement $element
1293              
1294             return unless DECORATE_FOREACH;
1295              
1296             my ($element, $file) = @_;
1297             return if ref($element) !~ /^PPI::Statement/;
1298              
1299             my $parent = $element->parent;
1300             return if !defined($parent) || ref($parent) ne 'PPI::Structure::Block';
1301              
1302             my @parent_sts = grep { ref($_) !~ /^PPI::Token/ } $parent->elements();
1303             return if $parent_sts[0] ne $element; # not the first statement in block
1304              
1305             my $gparent = $parent->parent;
1306             return if !defined($gparent) ||
1307             ref($gparent) ne 'PPI::Statement::Compound';
1308             my $keyword = ($gparent->elements())[0];
1309             return if $keyword ne 'foreach' && $keyword ne 'for';
1310              
1311             my @gparent_elem = grep { ref($_) !~ /^PPI::Token/ } $gparent->elements();
1312             return if @gparent_elem < 2 || $gparent_elem[1] ne $parent;
1313             my $list = $gparent_elem[0];
1314             return if ref($list) ne 'PPI::Structure::List';
1315              
1316             # find the name of the loop var. Could be implicit $_ if var can't be
1317             # found in the PPI.
1318             my ($loop_var) = grep {
1319             ref($_) eq 'PPI::Token::Symbol'
1320             || ref($_) eq 'PPI::Token::Magic'
1321             } $gparent->elements();
1322             if (!defined($loop_var)) {
1323             $loop_var = bless { content => '$_' }, 'PPI::Token::Magic';
1324             } else {
1325             $loop_var = $loop_var->clone;
1326             }
1327             $loop_var->{_PREVAL} = 1;
1328              
1329              
1330             $element->{__DECORATED__} = 'foreach';
1331             my $line = $keyword->line_number;
1332             $element->{__FOREACH_LINE__} = "$file:$line";
1333             $element->{__UPDATE__} = $loop_var;
1334             return;
1335             }
1336              
1337             sub __decorate_first_statement_in_while_block {
1338             # We expect a particular pattern of PPI elements to describe the
1339             # "first statement in a while/until block"
1340             #
1341             # PPI::Statement::Compound $gparent
1342             # PPI::Token::Word (while/until)
1343             # zero or more PPI::Token::Whitespace
1344             # PPI::Structure::Condition $cond
1345             # ...
1346             # zero or more PPI::Token::Whitespace
1347             # PPI::Structure::Block $parent
1348             # zero or more PPI::Token::xxx
1349             # PPI::Statement::xxx $element
1350             #
1351             return unless DECORATE_WHILE;
1352              
1353             my ($element, $file) = (@_);
1354             return if ref($element) !~ /^PPI::Statement/;
1355             my $parent = $element->parent;
1356             return if !defined($parent) || ref($parent) ne 'PPI::Structure::Block';
1357              
1358             my $gparent = $parent->parent;
1359             return if !defined($gparent) ||
1360             ref($gparent) ne 'PPI::Statement::Compound';
1361              
1362             my @parent_elem = grep { ref($_) !~ /^PPI::Token/ } $parent->elements();
1363             return if $parent_elem[0] ne $element;
1364              
1365             my @gparent_elem = grep { ref($_) !~ /^PPI::Token/ } $gparent->elements();
1366             my $cond = $gparent_elem[0];
1367             return if ref($cond) ne 'PPI::Structure::Condition';
1368             return if @gparent_elem < 2 || $gparent_elem[1] ne $parent;
1369              
1370             my $cond_name = '';
1371             foreach my $gparent_elem ($gparent->elements()) {
1372              
1373             if (ref($gparent_elem) eq 'PPI::Token::Word' && $cond_name eq '') {
1374             $cond_name = "$gparent_elem";
1375             }
1376              
1377             last if $gparent_elem eq $parent;
1378             if ($gparent_elem eq $cond) {
1379              
1380             $element->{__BLOCK_NAME__} = uc ($cond_name || 'COND');
1381             $element->{__CONDITION__} = $cond->clone();
1382             $gparent->{__GP_CONDITION__} = $element->{__CONDITION__};
1383             my $line = $cond->line_number;
1384             $element->{__WHILE_LINE__} = "$file:$line";
1385             $element->{__DECORATED__} = 'while/until';
1386             return;
1387             }
1388             }
1389             return;
1390             }
1391              
1392             sub __decorate_first_statement_AFTER_while_block {
1393            
1394             return unless DECORATE_WHILE;
1395              
1396             my ($element, $file) = @_;
1397              
1398             return if ref($element) ne 'PPI::Statement::Compound';
1399             my @children = $element->children;
1400             @children = grep { ref($_) ne 'PPI::Token::Whitespace' } @children;
1401             return if ref($children[0]) ne 'PPI::Token::Word';
1402             return if "$children[0]" ne "while" && "$children[0]" ne "until";
1403             my $sense = uc($children[0]);
1404            
1405             my $next = __next_sibling($element);
1406             return unless $next;
1407              
1408              
1409             if (0) {
1410             open TTY,">","/dev/tty";
1411             print TTY "WANT TO DECORATE STATEMENT\n\n\t$next\n\n\nAFTER WHILE";
1412             print TTY "PREV STATEMENT IS\n\n\t$element\n\n",ref($element),"\n\n\n";
1413             local $Data::Dumper::Indent = 0;
1414             # print TTY "\n", Dumper($element);
1415             print TTY "\n",join("\n",sort keys %$element),"\n";
1416             print TTY "\n";
1417             }
1418              
1419             my $line = $next->line_number;
1420             $next->{__DECORATED__} = "end-while";
1421             $next->{__SENSE__} = $sense;
1422             $next->{__ENDWHILE_LINE__} = "$file:$line";
1423             $next->{__CONDITIONER__} = $element;
1424             return;
1425             }
1426              
1427             sub __decorate_last_statement_in_dowhile_block {
1428             # Looking for (optional whitespace removed):
1429             # PPI::Statement $gparent
1430             # PPI::Token::Word "do"
1431             # PPI::Structure::Block $parent
1432             # PPI::Token::Structure "{"
1433             # *PPI::Statement, PPI::Statement::xxx
1434             # PPI::Statement $element
1435             # ...
1436             # PPI::Token::Structure "}"
1437             # PPI::Token::Word "while" or "until"
1438             # ... @condition
1439              
1440             my ($element, $file) = @_;
1441             return if ref($element) !~ /^PPI::Statement/;
1442              
1443             my $parent = $element->parent;
1444             return if ref($parent) ne 'PPI::Structure::Block';
1445             my @parent_stmnts = grep {
1446             ref($_) =~ /^PPI::Statement/
1447             } $parent->elements;
1448             return if @parent_stmnts < 1 || $parent_stmnts[-1] ne $element;
1449              
1450             my $gparent = $parent->parent;
1451             return if ref($gparent) !~ /^PPI::Statement/;
1452             my @gparent_elem = grep {
1453             ref($_) ne 'PPI::Token::Whitespace'
1454             } $gparent->elements();
1455              
1456             return if $gparent_elem[0] ne "do";
1457             return if $gparent_elem[1] ne $parent;
1458             my $sense = $gparent_elem[2];
1459             return if $sense ne 'while' && $sense ne 'until';
1460             my @condition = map {
1461             my $z = $_->clone;
1462             $z->{_PREVAL} = $z->{_DEFER} = 1
1463             if ref($z) eq 'PPI::Token::Symbol'
1464             || ref($z) eq 'PPI::Token::Magic';
1465             $z
1466             } grep {
1467             $_->line_number > $sense->line_number
1468             || ($_->line_number == $sense->line_number
1469             && $_->column_number > $sense->column_number)
1470             } $gparent->elements();
1471              
1472             $element->{__DECORATED__} = 'do-while';
1473             my $line = $sense->line_number;
1474             $element->{__DOWHILE_LINE__} = "$file:$line";
1475             $element->{__SENSE__} = "DO-" . uc "$sense";
1476             $element->{__CONDITION__} = [ @condition ];
1477             return;
1478             }
1479              
1480             sub __next_sibling {
1481             my ($element) = @_;
1482             my $parent = $element->parent;
1483             return unless $parent;
1484             my $last = undef;
1485             foreach my $sib ($parent->children) {
1486             next if ref($sib) eq 'PPI::Token::Whitespace';
1487             if ($last eq $element) {
1488             return $sib;
1489             }
1490             $last = $sib;
1491             }
1492             return;
1493             }
1494              
1495             # in a long chain of if/elsif/else blocks,
1496             # say if(COND1) BLOCK1 elsif(COND2) BLOCK2 elsif(COND3) BLOCK3 else BLOCK4,
1497             # only the first condition (COND1) gets displayed in a trace. To get more
1498             # useful trace output, prepend conditions to the first statement in
1499             # each block to be displayed with the trace. That is, display
1500             # COND2 with the first statement in BLOCK2,
1501             # COND2 and COND3 with the first statement in BLOCK3, and
1502             # COND2 and COND3 with the first statement in BLOCK4.
1503             #
1504             sub __decorate_statements_in_ifelse_block {
1505              
1506             return unless DECORATE_ELSIF;
1507              
1508             my ($element, $file) = @_;
1509             return if ref($element) !~ /^PPI::Statement/;
1510             my $parent = $element->parent;
1511             return if !defined($parent) || ref($parent) ne 'PPI::Structure::Block';
1512              
1513             my $gparent = $parent->parent;
1514             return if !defined($gparent) ||
1515             ref($gparent) ne 'PPI::Statement::Compound';
1516              
1517             my @parent_elem = grep { ref($_) !~ /^PPI::Token/ } $parent->elements();
1518             return if $parent_elem[0] ne $element;
1519              
1520             my @gparent_elem = grep { ref($_) !~ /^PPI::Token/ } $gparent->elements();
1521             my $cond = $gparent_elem[0];
1522             return if ref($cond) ne 'PPI::Structure::Condition';
1523              
1524             my @gparent_blocks = grep {
1525             ref($_) eq 'PPI::Structure::Block'
1526             } $gparent->elements();
1527             return if @gparent_blocks < 2 || $gparent_blocks[0] eq $parent;
1528              
1529             my @gparent_cond = grep {
1530             ref($_) eq 'PPI::Structure::Condition'
1531             } $gparent->elements();
1532              
1533             my $line = $gparent_cond[0]->line_number;
1534             $element->{__IF_LINE__} = "$file:$line";
1535             $element->{__DECORATED__} = 'if-elsif-else';
1536             $element->{__CONDITIONS__} = [];
1537             my $ws = '';
1538             my $style = _display_style();
1539             for (my $i=0; $i<@gparent_blocks; $i++) {
1540             if ($i < @gparent_cond) {
1541             push @{$element->{__CONDITIONS__}},
1542             __new_token("${ws}ELSEIF "),
1543             $gparent_cond[$i]->clone();
1544             } else {
1545             push @{$element->{__CONDITIONS__}},
1546             __new_token("${ws}ELSE");
1547             }
1548             if ($gparent_blocks[$i] eq $parent) {
1549             return;
1550             }
1551             $ws ||= $style == DISPLAY_TERSE ? "\n\t\t\t" : " ";
1552             }
1553             return;
1554             }
1555              
1556             sub __new_token {
1557             my ($text) = @_;
1558             my $element = bless { content => $text }, 'PPI::Token';
1559             return $element->clone();
1560             }
1561              
1562             our $NULL_DOC = '';
1563             our $NULL_STATEMENT; # for empty clause in for(...; ...; ...) statement
1564             sub __new_null_statement {
1565             unless ($NULL_STATEMENT) {
1566             $NULL_DOC = PPI::Document->new(\' '); #' \');
1567             $NULL_STATEMENT = ($NULL_DOC->elements)[0];
1568             }
1569             return $NULL_STATEMENT->clone();
1570             }
1571              
1572             sub main::TOKENIZE {
1573             # invoke with perl -MDevel::DumpTrace::PPI -e TOKENIZE file
1574             # to see how an input script is tokenized by PPI and broken
1575             # into statements by this package
1576             open(my $fh, '<', $ARGV[0]) or die;
1577             my $all_code = join '', <$fh>;
1578             close $fh;
1579             my $doc = PPI::Document->new(\$all_code);
1580             $doc->index_locations;
1581             my $ss = $doc->find('PPI::Statement');
1582             foreach my $i (0 .. $#$ss) {
1583             my $s = $ss->[$i];
1584             my @e = $s->elements;
1585             for my $j (0 .. $#e) {
1586             my $w = "$e[$j]";
1587             $w =~ s/\n/\\n/g;
1588             $w =~ s/^\s+//;
1589             $w =~ s/\s+$//;
1590             my $ref = ref($e[$j]);
1591             $ref =~ s/PPI:://;
1592             printf "%d:%d\t%-20s\t%s\n", $i, $j, $ref, $w;
1593             }
1594             }
1595             print "\n";
1596             }
1597              
1598             1;
1599              
1600             __END__