File Coverage

blib/lib/PPIx/Regexp/Dumper.pm
Criterion Covered Total %
statement 253 337 75.0
branch 119 220 54.0
condition 33 71 46.4
subroutine 34 40 85.0
pod 4 4 100.0
total 443 672 65.9


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             PPIx::Regexp::Dumper - Dump the results of parsing regular expressions
4              
5             =head1 SYNOPSIS
6              
7             use PPIx::Regexp::Dumper;
8             PPIx::Regexp::Dumper->new( 'qr{foo}smx' )
9             ->print();
10              
11             =head1 INHERITANCE
12              
13             C is a
14             L.
15              
16             C has no descendants.
17              
18             =head1 DESCRIPTION
19              
20             This class generates a formatted dump of a
21             L object (or any subclass
22             thereof), a L
23             object, or a string that can be made into one of these.
24              
25             =head1 METHODS
26              
27             This class provides the following public methods. Methods not documented
28             here are private, and unsupported in the sense that the author reserves
29             the right to change or remove them without notice.
30              
31             =cut
32              
33             package PPIx::Regexp::Dumper;
34              
35 6     6   2126 use strict;
  6         16  
  6         176  
36 6     6   32 use warnings;
  6         12  
  6         163  
37              
38 6     6   32 use base qw{ PPIx::Regexp::Support };
  6         13  
  6         447  
39              
40 6     6   38 use Carp;
  6         16  
  6         310  
41 6     6   35 use Scalar::Util qw{ blessed looks_like_number };
  6         18  
  6         284  
42              
43 6     6   38 use PPIx::Regexp;
  6         12  
  6         165  
44 6         617 use PPIx::Regexp::Constant qw{
45             ARRAY_REF
46             INFINITY
47             @CARP_NOT
48 6     6   63 };
  6         15  
49 6     6   46 use PPIx::Regexp::Tokenizer;
  6         12  
  6         181  
50 6     6   36 use PPIx::Regexp::Util qw{ __choose_tokenizer_class __instance };
  6         15  
  6         382  
51              
52             our $VERSION = '0.088';
53              
54 6     6   35 use constant LOCATION_WIDTH => 19;
  6         12  
  6         3532  
55              
56             =head2 new
57              
58             my $dumper = PPIx::Regexp::Dumper->new(
59             '/foo/', ordinal => 1,
60             );
61              
62             This static method instantiates the dumper. It takes the string,
63             L,
64             L, or
65             L to be dumped as the
66             first argument. Optional further arguments may be passed as name/value
67             pairs.
68              
69             The following options are recognized:
70              
71             =over
72              
73             =item default_modifiers array_reference
74              
75             This argument is a reference to a list of default modifiers to be
76             applied to the statement being parsed. See L
77             L for the details.
78              
79             =item encoding name
80              
81             This argument is the name of the encoding of the regular expression. If
82             specified, it is passed through to
83             L<< PPIx::Regexp->new()|PPIx::Regexp/new >>. It also causes an
84             C to be done on any parse content dumped.
85              
86             =item explain Boolean
87              
88             If true, this option causes the C output of each object to be
89             dumped.
90              
91             =item indent number
92              
93             This argument is the number of additional spaces to indent each level of
94             the parse hierarchy. This is ignored if either the C or C
95             argument is true.
96              
97             The default is 2.
98              
99             =item margin number
100              
101             This is the number of spaces to indent the top level of the parse
102             hierarchy. This is ignored if the C argument is true.
103              
104             The default is zero.
105              
106             =item ordinal Boolean
107              
108             If true, this option causes the C values of
109             L objects to
110             be dumped.
111              
112             =item perl_version Boolean
113              
114             If true, this option causes the C and
115             C values associated with each object dumped to be
116             displayed.
117              
118             =item ppi Boolean
119              
120             If true, any Perl code contained in the object will be dumped.
121              
122             =item short Boolean
123              
124             If true, leading C<'PPIx::Regexp::'> will be removed from the class
125             names in the output.
126              
127             =item strict Boolean
128              
129             This option is passed on to the parser, where it specifies whether the
130             parse should assume C is in effect.
131              
132             The C<'strict'> pragma was introduced in Perl 5.22, and its
133             documentation says that it is experimental, and that there is no
134             commitment to backward compatibility. The same applies to the
135             parse produced when this option is asserted.
136              
137             The default is false.
138              
139             =item significant Boolean
140              
141             If true, this option causes only significant elements to be dumped.
142              
143             The default is false.
144              
145             =item test Boolean
146              
147             If true, this option causes the output to be formatted as a regression
148             test rather than as a straight dump. The output produced by asserting
149             this option is explicitly undocumented, in the sense that the author
150             reserves the right to change the generated output without notice of any
151             kind.
152              
153             The default is false.
154              
155             =item tokens Boolean
156              
157             If true, this option causes a dump of tokenizer output rather than of a
158             full parse of the regular expression. This is forced true if the dump is
159             of a L.
160              
161             The default is false.
162              
163             =item trace number
164              
165             If greater than zero, this option causes a trace of the parse. This
166             option is unsupported in the sense that the author reserves the right to
167             change it without notice.
168              
169             The default is zero.
170              
171             =item verbose number
172              
173             If greater than zero, this option causes additional information to be
174             given about the elements found. This option is unsupported in the sense
175             that the author reserves the right to change it without notice.
176              
177             The default is zero.
178              
179             =item width Boolean
180              
181             If true, this option causes a dump of the width of the object.
182              
183             =back
184              
185             If the thing to be dumped was a string, unrecognized arguments are
186             passed to C<< PPIx::Regexp::Tokenizer->new() >>. Otherwise they are
187             ignored.
188              
189             =cut
190              
191             {
192              
193             my %default = (
194             explain => 0,
195             indent => 2,
196             locations => 0,
197             margin => 0,
198             ordinal => 0,
199             perl_version => 0,
200             ppi => 0,
201             short => 0,
202             significant => 0,
203             test => 0,
204             tokens => 0,
205             verbose => 0,
206             width => 0,
207             );
208              
209             sub new {
210 6     6 1 663 my ( $class, $re, %args ) = @_;
211 6 50       18 ref $class and $class = ref $class;
212              
213             my $self = {
214             encoding => $args{encoding},
215             lister => undef,
216             object => undef,
217             source => $re,
218             strict => $args{strict},
219 6         29 };
220              
221 6         15 foreach my $key ( qw{ default_modifiers parse } ) {
222             exists $args{$key}
223 12 50       30 and $self->{$key} = $args{$key};
224             }
225              
226 6         27 foreach my $key ( keys %default ) {
227             $self->{$key} = exists $args{$key} ?
228             delete $args{$key} :
229 78 100       177 $default{$key};
230             }
231              
232 6   100     37 $self->{ordinal} ||= $self->{verbose};
233              
234 6 100 33     25 if ( __instance( $re, 'PPIx::Regexp::Tokenizer' ) ) {
    100          
    50          
    50          
    50          
235 2         4 $self->{object} = $re;
236 2         5 $self->{tokens} = 1;
237             } elsif ( __instance( $re, 'PPIx::Regexp::Element' ) ) {
238 3         7 $self->{object} = $re;
239             } elsif ( ARRAY_REF eq ref $re ) {
240 0         0 $self->{object} = $re;
241             } elsif ( ref $re && ! __instance( $re, 'PPI::Element' ) ) {
242 0         0 croak "Do not know how to dump ", ref $re;
243             } elsif ( $self->{tokens} ) {
244 0 0       0 my $tokenizer_class = __choose_tokenizer_class( $re, \%args )
245             or croak 'Unsupported data type';
246             __instance( $re, 'PPI::Element' )
247 0 0       0 or $args{location} = [ 1, 1, 1, 1, undef ];
248             $self->{object} =
249 0 0       0 $tokenizer_class->new( $re, %args )
250             or Carp::croak( $tokenizer_class->errstr() );
251             } else {
252             __instance( $re, 'PPI::Element' )
253 1 50       3 or $args{location} = [ 1, 1, 1, 1, undef ];
254             $self->{object} =
255 1 50       4 PPIx::Regexp->new( $re, %args )
256             or Carp::croak( PPIx::Regexp->errstr() );
257             }
258              
259 6         14 bless $self, $class;
260              
261 6         25 return $self;
262              
263             }
264              
265             }
266              
267             =head2 list
268              
269             print map { "$_\n" } $dumper->list();
270              
271             This method produces an array containing the dump output, one line per
272             element. The output has no left margin applied, and no newlines.
273              
274             =cut
275              
276             sub list {
277 5     5 1 12 my ( $self ) = @_;
278 5 100       13 my $lister = $self->{test} ? '__PPIX_DUMPER__test' : '__PPIX_DUMPER__dump';
279              
280             ARRAY_REF eq ref $self->{object}
281 5 50       16 and return ( map { $_->$lister( $self ) } @{ $self->{object} } );
  0         0  
  0         0  
282              
283 5         58 return $self->{object}->$lister( $self );
284             }
285              
286             =head2 print
287              
288             $dumper->print();
289              
290             This method simply prints the result of L to standard out.
291              
292             =cut
293              
294             sub print : method { ## no critic (ProhibitBuiltinHomonyms)
295 0     0 1 0 my ( $self ) = @_;
296             # Non-characters and Non-Unicode code points are explicitly allowed
297             # as delimiters, at least as of 5.29.0, which is where unassigned
298             # and combining code points became illegal. Unfortunately the
299             # warnings below were not introduced until 5.14, so have to go for
300             # the next-higher warning category.
301             # no warnings qw{ nonchar non_unicode }; ## no critic (ProhibitNoWarnings)
302 6     6   48 no warnings qw{ utf8 }; ## no critic (ProhibitNoWarnings)
  6         23  
  6         26981  
303 0         0 print $self->string();
304 0         0 return;
305             }
306              
307             =head2 string
308              
309             print $dumper->string();
310              
311             This method adds left margin and newlines to the output of L,
312             concatenates the result into a single string, and returns that string.
313              
314             =cut
315              
316             sub string {
317 5     5 1 11 my ( $self ) = @_;
318 5         18 my $margin = ' ' x $self->{margin};
319             return join( '',
320 5         16 map { $margin . $_ . "\n" } $self->list() );
  151         349  
321             }
322              
323             # quote a string.
324             sub _safe {
325 131     131   258 my ( $self, @args ) = @_;
326 131         165 my @rslt;
327 131         202 foreach my $item ( @args ) {
328 196 100       413 if ( blessed( $item ) ) {
329 40         110 $item = $self->encode( $item->content() );
330             }
331 196 50       593 if ( ! defined $item ) {
    100          
    100          
332 0         0 push @rslt, 'undef';
333             } elsif ( ARRAY_REF eq ref $item ) {
334 41         58 push @rslt, join( ' ', '[', $self->_safe( @{ $item } ), ']' );
  41         81  
335             } elsif ( looks_like_number( $item ) ) {
336 48         81 push @rslt, $item;
337             } else {
338 107         212 $item =~ s/ ( [\\'] ) /\\$1/smxg;
339 107         242 push @rslt, "'$item'";
340             }
341             }
342 131         274 my $rslt = join( ', ', @rslt );
343 131         381 return $rslt
344             }
345              
346             sub _safe_version {
347 0     0   0 my ( undef, $version ) = @_; # Invocant unused
348 0 0       0 return defined $version ? "'$version'" : 'undef';
349             }
350              
351             sub __nav {
352 28     28   57 my ( $self, @args ) = @_;
353 28         56 my $rslt = $self->_safe( @args );
354 28         209 $rslt =~ s/ ' (\w+) ' , /$1 =>/smxg;
355 28         77 $rslt =~ s/ \[ \s+ \] /[]/smxg;
356 28         93 $rslt =~ s/ \[ \s* ( [0-9]+ ) \s* \] /$1/smxg;
357 28         124 return $rslt;
358             }
359              
360             sub _perl_version {
361 7     7   13 my ( undef, $elem ) = @_; # Invocant unused
362              
363 7         38 return $elem->requirements_for_perl();
364             }
365              
366             sub _ppi {
367 20     20   35 my ( $self, $elem ) = @_;
368              
369             $self->{ppi}
370 20 50 33     62 and $elem->can( 'ppi' )
371             or return;
372              
373 0         0 require PPI::Dumper;
374              
375             # PPI::Dumper reports line_number(), but I want
376             # logical_line_number(). There is no configuration for this, but the
377             # interface is public, so I mung it to do what I want.
378 0         0 my $locn = PPI::Element->can( 'location' );
379             local *PPI::Element::location = sub {
380 0     0   0 my $loc = $locn->( @_ );
381 0         0 $loc->[0] = $loc->[3];
382 0         0 return $loc;
383 0         0 };
384              
385             my $dumper = PPI::Dumper->new( $elem->ppi(),
386 0         0 map { $_ => $self->{$_} } qw{ indent locations },
  0         0  
387             );
388              
389 0         0 return $dumper->list();
390             }
391              
392             sub _content {
393 22     22   35 my ( $self, $elem, $dflt ) = @_;
394 22 50       47 defined $dflt or $dflt = '';
395              
396 22 50       39 defined $elem or return $dflt;
397 22 100       49 if ( ARRAY_REF eq ref $elem ) {
398             my $rslt = join '',
399 11         25 map { $self->_content( $_ ) }
400 11 50       38 grep { ! $self->{significant} || $_->significant() }
401 11         17 @{ $elem };
  11         18  
402 11 50       41 return $rslt eq '' ? $dflt : $rslt;
403             }
404 11 50       35 blessed( $elem ) or return $dflt;
405 11         28 return $self->encode( $elem->content() );
406             }
407              
408             sub _tokens_dump {
409 1     1   5 my ( $self, $elem, $depth ) = @_;
410              
411 1 50 33     5 not $self->{significant} or $elem->significant() or return;
412              
413 1         3 my @rslt;
414 1         5 foreach my $token ( $elem->tokens() ) {
415 7 50 33     22 not $self->{significant} or $token->significant() or next;
416 7         37 push @rslt, $token->__PPIX_DUMPER__dump( $self, $depth );
417             }
418 1         10 return @rslt;
419             }
420              
421             sub _format_default_modifiers {
422 2     2   6 my ( $self, $subr, $elem ) = @_;
423 2         5 my @arg = $self->_safe( $elem );
424 2         6 foreach my $attr ( qw{ default_modifiers parse strict } ) {
425 6 50       18 defined ( my $val = $self->{$attr} )
426             or next;
427             ARRAY_REF eq ref $val
428 0 0 0     0 and not @{ $val }
  0         0  
429             and next;
430 0         0 push @arg, "$attr => @{[ $self->_safe( $val ) ]}";
  0         0  
431             }
432 2         14 return sprintf '%-8s( %s );', $subr, join ', ', @arg;
433             }
434              
435             sub _format_matcher_dump {
436 12     12   21 my ( undef, $elem ) = @_;
437 12         46 my $value = $elem->is_matcher();
438 12 50       64 return sprintf 'is_matcher=%s',
    100          
439             $value ? 'true' : defined $value ? 'false' : 'undef';
440             }
441              
442             sub _format_modifiers_dump {
443 1     1   3 my ( undef, $elem ) = @_; # Invocant unused
444 1         5 my %mods = $elem->modifiers();
445 1         4 my @accum;
446             $mods{match_semantics}
447             and push @accum, 'match_semantics=' . delete
448 1 50       4 $mods{match_semantics};
449 1         4 foreach my $modifier ( sort keys %mods ) {
450 1 50       6 push @accum, $mods{$modifier} ? $modifier :
451             "-$modifier";
452             }
453 1 50       6 @accum and return join ' ', @accum;
454 0         0 return;
455             }
456              
457             sub _format_width_dump {
458 0     0   0 my @arg = @_;
459 0         0 foreach ( @arg ) {
460 0 0       0 if ( defined ) {
461 0 0       0 $_ == INFINITY
462             and $_ = q<'Inf'>;
463             } else {
464 0         0 $_ = 'undef';
465             }
466             }
467             wantarray
468 0 0       0 and return @arg;
469 0         0 return join ', ', @arg;
470             }
471              
472             sub _format_width_test {
473 0     0   0 my @arg = @_;
474 0         0 foreach ( @arg ) {
475 0 0       0 if ( defined ) {
476 0 0       0 $_ == INFINITY
477             and $_ = 'INFINITY';
478             } else {
479 0         0 $_ = 'undef';
480             }
481             }
482             wantarray
483 0 0       0 and return @arg;
484 0         0 return join ', ', @arg;
485             }
486              
487             sub _tokens_test {
488 1     1   3 my ( $self, $elem ) = @_;
489              
490 1 50 33     39 not $self->{significant} or $elem->significant() or return;
491              
492 1         8 my @tokens = $elem->tokens();
493              
494 1         7 my @rslt = (
495             $self->_format_default_modifiers( tokenize => $elem ),
496             sprintf( 'count ( %d );', scalar @tokens ),
497             );
498              
499 1         4 my $inx = 0;
500 1         4 foreach my $token ( @tokens ) {
501 9 50 33     28 not $self->{significant} or $token->significant() or next;
502 9         45 push @rslt, $token->__PPIX_DUMPER__test( $self, $inx++ );
503             }
504 1         15 return @rslt;
505             }
506              
507             sub PPIx::Regexp::Element::__PPIX_DUMPER__dump_explanation {
508 0     0   0 my ( $self, undef, $line ) = @_; # $dumper unused
509 0 0       0 my @expl = $self->explain()
510             or return $line;
511 0 0       0 1 == @expl
512             and return "$line\t$expl[0]";
513             wantarray
514 0 0       0 or return sprintf "%s\t%s", $line, join '; ', @expl;
515 0         0 ( my $blank = $line ) =~ s/\S/ /smxg;
516 0         0 my @rslt;
517 0         0 foreach my $splain ( @expl ) {
518 0         0 push @rslt, "$line\t$splain";
519 0         0 $line = $blank;
520             }
521 0         0 return @rslt;
522             }
523              
524             sub PPIx::Regexp::__PPIX_DUMPER__test {
525 1     1   4 my ( $self, $dumper ) = @_;
526              
527             $dumper->{tokens}
528 1 50       5 and return $dumper->_tokens_test( $self );
529              
530 1 50 33     6 not $dumper->{significant} or $self->significant() or return;
531              
532             # my $parse = 'parse ( ' . $dumper->_safe( $self ) . ' );';
533 1         4 my $parse = $dumper->_format_default_modifiers( parse => $self );
534 1         5 my $fail = 'value ( failures => [], ' . $self->failures() . ' );';
535              
536             # Note that we can not use SUPER in the following because SUPER goes
537             # by the current package, not by the class of the object.
538 1         5 my @rslt = PPIx::Regexp::Node::__PPIX_DUMPER__test( $self, $dumper );
539              
540             # Get rid of the empty choose();
541 1         2 shift @rslt;
542              
543 1         10 return ( $parse, $fail, @rslt );
544             }
545              
546             sub PPIx::Regexp::Node::__PPIX_DUMPER__dump {
547 3     3   11 my ( $self, $dumper, $depth ) = @_;
548              
549 3   100     15 $depth ||= 0;
550              
551             $dumper->{tokens}
552 3 50       9 and return $dumper->_tokens_dump( $self, $depth );
553              
554 3 50 33     10 not $dumper->{significant} or $self->significant() or return;
555              
556 3         9 my @rslt = ( ref $self );
557             $dumper->{short}
558 3 50       9 and $rslt[0] =~ s/ \A PPIx::Regexp:: //smx;
559             $self->isa( 'PPIx::Regexp' )
560             and $rslt[-1] .= $dumper->{verbose}
561 3 100       24 ? sprintf "\tfailures=%d\tmax_capture_number=%d",
    100          
562             $self->failures(), $self->max_capture_number()
563             : sprintf "\tfailures=%d", $self->failures();
564              
565 3         12 substr $rslt[0], 0, 0, ' ' x ( $depth * $dumper->{indent} );
566              
567             $dumper->{locations}
568 3 50       10 and substr $rslt[0], 0, 0, ' ' x LOCATION_WIDTH;
569              
570 3 50       7 if ( $dumper->{width} ) {
571 0         0 my $width = _format_width_dump( $self->width() );
572 0         0 $rslt[-1] .= "\t{ $width }";
573             }
574              
575             $dumper->{perl_version}
576 3 100       12 and $rslt[-1] .= "\t" . $dumper->_perl_version( $self );
577              
578 3 50       29 if ( defined ( my $err = $self->error() ) ) {
579 0         0 $rslt[-1] .= "\t$err";
580             } else {
581             $dumper->{explain}
582 3 50       11 and push @rslt, $self->__PPIX_DUMPER__dump_explanation(
583             $dumper, pop @rslt );
584             }
585              
586 3         5 $depth++;
587 3         10 foreach my $elem ( $self->children() ) {
588 9         34 push @rslt, $elem->__PPIX_DUMPER__dump( $dumper, $depth );
589             }
590 3         15 return @rslt;
591             }
592              
593             sub PPIx::Regexp::Node::__PPIX_DUMPER__test {
594 2     2   5 my ( $self, $dumper ) = @_;
595              
596 2 50 33     9 not $dumper->{significant} or $self->significant() or return;
597              
598 2         3 my @rslt;
599 2         11 @rslt = (
600             'choose ( ' . $dumper->__nav( $self->nav() ) . ' );',
601             'klass ( ' . $dumper->_safe( ref $self ) . ' );',
602             'count ( ' . scalar $self->children() . ' );',
603             );
604              
605 2 50       9 if ( defined( my $err = $self->error() ) ) {
606              
607 0         0 push @rslt,
608             'error ( ' . $dumper->_safe( $err ) . ' );';
609              
610             }
611              
612 2 50       7 if ( $dumper->{width} ) {
613 0         0 my $raw = _format_width_test( $self->raw_width() );
614 0         0 my $width = _format_width_test( $self->width() );
615 0         0 push @rslt,
616             "raw_width( $raw );",
617             "width ( $width );";
618             }
619              
620 2 50       6 if ( $dumper->{perl_version} ) {
621 0         0 foreach my $method ( qw{
622             perl_version_introduced
623             perl_version_removed
624             } ) {
625 0         0 push @rslt, "value ( $method => [], " .
626             $dumper->_safe_version( $self->$method() ) . ' );';
627             }
628             }
629 2         6 foreach my $elem ( $self->children() ) {
630 6         18 push @rslt, $elem->__PPIX_DUMPER__test( $dumper );
631             }
632 2         18 return @rslt;
633             }
634              
635             sub _format_value {
636 3     3   7 my ( $val ) = @_;
637 3 100       10 defined $val
638             or return 'undef';
639 2 50       21 $val =~ m/ \A [0-9]+ \z /smx
640             and return $val;
641 0         0 $val =~ s/ (?= [\\"] ) /\\/smxg;
642 0         0 return qq{"$val"};
643             }
644              
645             {
646              
647             my %dflt = (
648             start => '???',
649             type => '',
650             finish => '???',
651             );
652              
653             sub PPIx::Regexp::Structure::__PPIX_DUMPER__dump {
654 5     5   17 my ( $self, $dumper, $depth ) = @_;
655              
656 5   50     11 $depth ||= 0;
657              
658 5 50 33     27 not $dumper->{significant} or $self->significant() or return;
659              
660 5         8 my @delim;
661 5         11 foreach my $method ( qw{ start type finish } ) {
662 15         51 my @elem = $self->$method();
663 15 100       57 push @delim, @elem ? $dumper->_content( \@elem ) : $dflt{$method};
664             }
665 5         16 my @rslt = ( ref $self, "$delim[0]$delim[1] ... $delim[2]" );
666             $dumper->{short}
667 5 50       24 and $rslt[0] =~ s/ \A PPIx::Regexp:: //smx;
668              
669 5         18 substr $rslt[0], 0, 0, ' ' x ( $depth * $dumper->{indent} );
670              
671             $dumper->{locations}
672 5 50       13 and substr $rslt[0], 0, 0, ' ' x LOCATION_WIDTH;
673              
674             $dumper->{perl_version}
675 5 100       15 and push @rslt, $dumper->_perl_version( $self );
676              
677 5 50       12 if ( $dumper->{width} ) {
678 0         0 my $width = _format_width_dump( $self->width() );
679 0         0 push @rslt, "{ $width }";
680             }
681              
682 5 100       13 if ( $dumper->{verbose} ) {
683 3         5 foreach my $method ( qw{ number name max_capture_number } ) {
684 9 100       56 $self->can( $method ) or next;
685 3         12 push @rslt, sprintf '%s=%s', $method, _format_value(
686             $self->$method() );
687             }
688 3         7 foreach my $method ( qw{ can_be_quantified is_quantifier } ) {
689             ## is_case_sensitive
690 6 50       30 $self->can( $method ) or next;
691 6 100       18 $self->$method() and push @rslt, $method;
692             }
693 3 50       23 $self->isa( 'PPIx::Regexp::Structure::Modifier' )
694             and push @rslt, $dumper->_format_modifiers_dump(
695             $self->type( 0 ) );
696              
697 3         10 push @rslt, $dumper->_format_matcher_dump( $self );
698             }
699              
700 5         8 foreach my $method ( 'start', undef, 'finish' ) {
701 15 100       52 my $ele = defined $method ? $self->$method() : $self
    50          
702             or next;
703 15 50       70 if ( defined ( my $err = $ele->error() ) ) {
704 0         0 push @rslt, $err;
705             }
706             }
707              
708 5         20 @rslt = ( join "\t", @rslt );
709              
710             $dumper->{explain}
711 5 50 33     27 and not defined $self->error()
712             and push @rslt, $self->__PPIX_DUMPER__dump_explanation(
713             $dumper, pop @rslt );
714              
715 5         8 $depth++;
716 5         15 foreach my $elem ( $self->children() ) {
717 10         82 push @rslt, $elem->__PPIX_DUMPER__dump( $dumper, $depth );
718             }
719 5         22 return @rslt;
720             }
721              
722             }
723              
724             sub PPIx::Regexp::Structure::__PPIX_DUMPER__test {
725 2     2   6 my ( $self, $dumper ) = @_;
726              
727 2 50 33     7 not $dumper->{significant} or $self->significant() or return;
728              
729 2         11 my @nav = $self->nav();
730 2         8 my @rslt = (
731             'choose ( ' . $dumper->__nav( @nav ) . ' );',
732             'klass ( ' . $dumper->_safe( ref $self ) . ' );',
733             'count ( ' . scalar $self->children() . ' );',
734             );
735 2 50       19 if ( $dumper->{verbose} ) {
736 2         6 foreach my $method ( qw{ number name } ) {
737 4 50       17 $self->can( $method ) or next;
738 0         0 push @rslt, 'value ( ' . $method . ' => [], ' .
739             $dumper->_safe( $self->$method() ) . ' );';
740             }
741             }
742              
743 2 50       7 if ( $dumper->{width} ) {
744 0         0 my $raw = _format_width_test( $self->raw_width() );
745 0         0 my $width = _format_width_test( $self->width() );
746 0         0 push @rslt,
747             "raw_width( $raw );",
748             "width ( $width );";
749             }
750              
751 2         5 foreach my $method ( qw{ start type finish } ) {
752 6         24 my @eles = $self->$method();
753 6         18 push @rslt, 'choose ( ' . $dumper->__nav(
754             @nav, $method, [] ) . ' );',
755             'count ( ' . scalar @eles . ' );';
756 6         16 foreach my $inx ( 0 .. $#eles ) {
757 4         8 my $elem = $eles[$inx];
758 4   33     9 push @rslt, 'choose ( ' . $dumper->__nav(
759             @nav, $method, $inx ) . ' );',
760             'klass ( ' . $dumper->_safe( ref $elem || $elem ) . ' );',
761             'content ( ' . $dumper->_safe( $elem ) . ' );';
762             }
763             }
764 2         8 foreach my $elem ( $self->children() ) {
765 2         32 push @rslt, $elem->__PPIX_DUMPER__test( $dumper );
766             }
767 2         23 return @rslt;
768             }
769              
770             sub PPIx::Regexp::Tokenizer::__PPIX_DUMPER__dump {
771 1     1   3 my ( $self, $dumper, $depth ) = @_;
772              
773 1   50     7 $depth ||= 0;
774              
775 1         6 return $dumper->_tokens_dump( $self, $depth );
776              
777             }
778              
779             sub PPIx::Regexp::Tokenizer::__PPIX_DUMPER__test {
780 1     1   4 my ( $self, $dumper ) = @_;
781              
782 1         5 return $dumper->_tokens_test( $self );
783             }
784              
785             sub PPIx::Regexp::Token::__PPIX_DUMPER__dump {
786 20     20   36 my ( $self, $dumper, $depth ) = @_;
787              
788 20   100     52 $depth ||= 0;
789              
790             not $dumper->{significant}
791 20 50 33     46 or $self->significant()
792             or return;
793              
794 20         51 my @rslt = ( ref $self, $dumper->_safe( $self ) );
795             $dumper->{short}
796 20 50       53 and $rslt[0] =~ s/ \A PPIx::Regexp:: //smx;
797              
798 20         72 substr $rslt[0], 0, 0, ' ' x ( $depth * $dumper->{indent} );
799              
800             $dumper->{locations}
801 20 50       46 and substr $rslt[0], 0, 0,
802             sprintf '[ % 4d, % 3d, % 3d ] ',
803             $self->logical_line_number(),
804             $self->column_number(),
805             $self->visual_column_number();
806              
807 20         27 my @ppi;
808 20 50       49 @ppi = $dumper->_ppi( $self )
809             and shift @ppi; # Ignore PPI::Document
810 20         39 foreach ( @ppi ) {
811 0 0       0 if ( $dumper->{locations} ) {
812 0 0       0 s/ ( [0-9]+ \s+ \] ) /$1 /smxg
813             or substr $_, 0, 0, ' ';
814             } else {
815 0         0 substr $_, 0, 0, ' ';
816             }
817             }
818              
819 20 50       38 if ( $dumper->{width} ) {
820 0         0 my $width = _format_width_dump( $self->width() );
821 0         0 push @rslt, "{ $width }";
822             }
823              
824             $dumper->{perl_version}
825 20 100       43 and push @rslt, $dumper->_perl_version( $self );
826              
827 20 50       62 if ( defined( my $err = $self->error() ) ) {
828              
829 0         0 return join "\t", @rslt, $err;
830              
831             } else {
832              
833 20 100 100     123 if ( $dumper->{ordinal} && $self->can( 'ordinal' )
      66        
834             && defined ( my $ord = $self->ordinal() ) ) {
835 8         29 push @rslt, sprintf '0x%02x', $ord;
836             }
837              
838 20 100       42 if ( $dumper->{verbose} ) {
839              
840 9 50       54 if ( $self->isa( 'PPIx::Regexp::Token::Reference' ) ) {
841 0         0 foreach my $method ( qw{ absolute name number } ) {
842 0 0       0 defined( my $val = $self->$method() ) or next;
843 0         0 push @rslt, "$method=$val";
844             }
845             }
846              
847 9         18 foreach my $method (
848             qw{ significant can_be_quantified is_quantifier } ) {
849             ## is_case_sensitive
850 27 100 66     103 $self->can( $method )
851             and $self->$method()
852             and push @rslt, $method;
853             }
854              
855 9 50       55 $self->can( 'ppi' )
856             and push @rslt, $self->ppi()->content();
857              
858 9 100 66     52 if ( $self->isa( 'PPIx::Regexp::Token::Modifier' ) ||
859             $self->isa( 'PPIx::Regexp::Token::GroupType::Modifier' )
860             ) {
861 1         7 push @rslt, $dumper->_format_modifiers_dump( $self );
862             }
863              
864 9         26 push @rslt, $dumper->_format_matcher_dump( $self );
865             }
866              
867 20         89 @rslt = ( join "\t", @rslt );
868              
869             $dumper->{explain}
870 20 50       47 and push @rslt, $self->__PPIX_DUMPER__dump_explanation(
871             $dumper, pop @rslt );
872              
873 20         36 push @rslt, @ppi;
874              
875 20         56 return @rslt;
876             }
877             }
878              
879             sub PPIx::Regexp::Token::__PPIX_DUMPER__test {
880 14     14   28 my ( $self, $dumper, @nav ) = @_;
881              
882 14 50 33     35 not $dumper->{significant} or $self->significant() or return;
883              
884 14 100       43 @nav or @nav = $self->nav();
885 14         38 my @rslt = (
886             'choose ( ' . join(', ', $dumper->__nav( @nav ) ) . ' );',
887             'klass ( ' . $dumper->_safe( ref $self ) . ' );',
888             'content ( ' . $dumper->_safe( $self ) . ' );',
889             );
890              
891 14 50       44 if ( defined( my $err = $self->error() ) ) {
892              
893 0         0 push @rslt,
894             'error ( ' . $dumper->_safe( $err ) . ' );';
895              
896             } else {
897              
898 14 50       34 if ( $dumper->{perl_version} ) {
899 0         0 foreach my $method ( qw{
900             perl_version_introduced
901             perl_version_removed
902             } ) {
903 0         0 push @rslt, "value ( $method => [], " .
904             $dumper->_safe_version( $self->$method() ) . ' );';
905             }
906             }
907              
908 14 50       27 if ( $dumper->{width} ) {
909 0         0 my $raw = _format_width_test( $self->raw_width() );
910 0         0 my $width = _format_width_test( $self->width() );
911 0         0 push @rslt,
912             "raw_width( $raw );",
913             "width ( $width );";
914             }
915              
916 14 50       28 if ( $dumper->{verbose} ) {
917              
918 14         22 foreach my $method (
919             qw{ significant can_be_quantified is_quantifier } ) {
920             ## is_case_sensitive
921 42 50       141 $self->can( $method ) or next;
922 42 100       107 push @rslt, $self->$method() ?
923             "true ( $method => [] );" :
924             "false ( $method => [] );";
925             }
926              
927 14 50       52 $self->can( 'ppi' )
928             and push @rslt, "value ( ppi => [], " .
929             $dumper->_safe( $self->ppi() ) . ' );';
930              
931             }
932             }
933              
934 14         109 return @rslt;
935             }
936              
937             1;
938              
939             __END__