File Coverage

blib/lib/Pcore/Core/Dump/Dumper.pm
Criterion Covered Total %
statement 27 235 11.4
branch 0 80 0.0
condition 0 35 0.0
subroutine 9 29 31.0
pod 0 13 0.0
total 36 392 9.1


line stmt bran cond sub pod time code
1             package Pcore::Core::Dump::Dumper;
2              
3 5     5   31 use Pcore -class, -ansi;
  5         8  
  5         27  
4 5     5   1893 use Pcore::Util::Scalar qw[refaddr isweak reftype blessed looks_like_number tainted];
  5         45  
  5         30  
5 5     5   1601 use Pcore::Util::Text qw[escape_scalar remove_ansi add_num_sep];
  5         15  
  5         49  
6 5     5   46 use re qw[];
  5         8  
  5         88  
7 5     5   2123 use Sort::Naturally qw[nsort];
  5         16336  
  5         321  
8 5     5   1325 use PerlIO::Layers qw[];
  5         9104  
  5         6985  
9              
10             has color => ( is => 'ro', isa => Bool, default => 0 ); # colorize dump
11             has tags => ( is => 'ro', isa => Bool, default => 0 ); # do not add tags
12             has indent => ( is => 'ro', isa => Int, default => 4 ); # indent spaces
13              
14             has _indent => ( is => 'ro', isa => Str, init_arg => undef );
15             has _seen => ( is => 'ro', isa => HashRef, default => sub { {} }, init_arg => undef );
16              
17             our $COLOR = {
18             number => $BOLD . $CYAN, # numbers
19             string => $BOLD . $YELLOW, # strings
20             class => $BOLD . $GREEN, # class names
21             regex => $YELLOW, # regular expressions
22             code => $GREEN, # code references
23             glob => $BOLD . $CYAN, # globs (usually file handles)
24             vstring => $BOLD . $YELLOW, # version strings (v5.16.0, etc)
25             format => $BOLD . $CYAN,
26              
27             array => $WHITE, # array index numbers
28             hash => $BOLD . $MAGENTA, # hash keys
29              
30             refs => $BOLD . $WHITE,
31             unknown => $BLACK . $ON_YELLOW, # potential new Perl datatypes
32             undef => $BOLD . $RED, # the 'undef' value
33             escaped => $BOLD . $RED, # escaped characters (\t, \n, etc)
34             seen => $WHITE . $ON_RED, # references to seen values
35             };
36              
37             our $DUMPERS = {
38             'DateTime' => sub {
39             my $self = shift;
40             my $dumper = shift;
41             my %args = (
42             path => undef,
43             @_,
44             );
45              
46             my $res;
47             my $tags;
48              
49             $res .= q[] . $self; # stringify
50             $res .= ' [' . $self->time_zone->name . ']'; # timezone
51              
52             return $res, $tags;
53             },
54             'File::Temp' => sub {
55             my $self = shift;
56             my $dumper = shift;
57             my %args = (
58             path => undef,
59             @_,
60             );
61              
62             my $res;
63             my $tags;
64              
65             $res .= $dumper->_dump_blessed( $self, path => $args{path} );
66             $res .= qq[,\npath: "] . $self->filename . q["];
67              
68             return $res, $tags;
69             },
70             };
71              
72 0     0 0   sub run ( $self, @ ) {
  0            
  0            
73 0   0       $self->{_indent} = q[ ] x ( $self->{indent} // 4 );
74              
75 0 0         if ( !$self->{color} ) {
76 0           return remove_ansi $self->_dump( $_[1], path => '$VAR' );
77             }
78             else {
79 0           return $self->_dump( $_[1], path => '$VAR' );
80             }
81             }
82              
83             # INTERNAL METHODS
84 0     0     sub _dump ( $self, @ ) {
  0            
  0            
85 0           my %args = (
86             path => '',
87             unbless => 0,
88             splice @_, 2,
89             );
90              
91 0 0         local $ENV{ANSI_COLORS_DISABLED} = 1 if !$self->{color};
92              
93 0           my ( $var_type, $blessed ) = $self->_var_type( $_[1], unbless => $args{unbless} );
94              
95             # detect var addr
96 0           my $var_addr = "${var_type}_";
97              
98 0 0         if ( ref $_[1] ) {
99 0           $var_addr .= refaddr $_[1];
100             }
101             else {
102 0           $var_addr .= refaddr \$_[1];
103             }
104              
105 0           my ( $res, $tags );
106              
107 0 0 0       if ( $var_addr && exists $self->{_seen}->{$var_addr} ) {
108 0           $res = $COLOR->{seen} . $self->{_seen}->{$var_addr} . $RESET;
109             }
110             else {
111 0           $self->{_seen}->{$var_addr} = $args{path};
112              
113 0 0         my $dump_method = $blessed ? 'BLESSED' : $var_type;
114              
115 0 0         $dump_method = 'UNKNOWN' if !$self->can($dump_method);
116              
117 0           ( $res, $tags ) = $self->$dump_method( $_[1], path => $args{path}, var_type => $var_type );
118             }
119              
120             # weak
121 0 0         push $tags->@*, 'weak' if isweak( $_[1] );
122             #
123             # $res .= ',';
124              
125             # add tags
126             # $res .= q[ # ] . join q[, ], $tags->@* if $tags;
127              
128 0   0       return bless { text => \$res, tags => $self->{tags} && $tags }, 'Pcore::Core::Dump::Dumper::_Item';
129             }
130              
131             sub _var_type {
132 0     0     my $self = shift;
133 0           my %args = (
134             unbless => 0,
135             splice( @_, 1 ),
136             );
137              
138 0           my $ref_type = reftype $_[0];
139              
140 0 0         if ( my $blessed = blessed $_[0] ) { # blessed
141 0 0 0       if ( $args{unbless} ) {
    0          
    0          
142 0           return $ref_type;
143             }
144             elsif ( $ref_type eq 'REGEXP' && $blessed eq 'Regexp' ) {
145 0           return $ref_type;
146             }
147             elsif ( $ref_type eq 'IO' ) {
148 0           return $blessed, 1;
149             }
150             else {
151 0           return $blessed, 1;
152             }
153             }
154             else {
155 0 0         if ( defined $ref_type ) {
156 0 0 0       if ( $ref_type eq 'SCALAR' || $ref_type eq 'VSTRING' || $ref_type eq 'GLOB' ) {
      0        
157 0           return 'REF';
158             }
159             else {
160 0           return $ref_type;
161             }
162             }
163             else {
164 0           return CORE::ref \$_[0];
165             }
166             }
167             }
168              
169             sub _indent_text {
170 0     0     my $self = shift;
171              
172 0           $_[0] =~ s/\n/\n$self->{_indent}/smg;
173              
174 0           return;
175             }
176              
177             sub _dump_blessed {
178 0     0     my $self = shift;
179 0           my $obj = shift;
180 0           my %args = (
181             path => undef,
182             @_,
183             );
184              
185 0           return 'blessed: ' . $self->_dump( $obj, path => $args{path}, unbless => 1 );
186             }
187              
188             sub _tied_to {
189 0     0     my $self = shift;
190 0           my $tied = shift;
191              
192 0 0         if ($tied) {
193 0   0       $_[0] //= [];
194              
195 0           push $_[0]->@*, 'tied to ' . ref $tied;
196             }
197              
198 0           return;
199             }
200              
201             # DUMPERS
202             sub UNKNOWN {
203 0     0 0   my $self = shift;
204 0           my %args = (
205             var_type => q[],
206             @_,
207             );
208              
209 0           return $COLOR->{unknown} . 'unknown: ' . $args{var_type} . $RESET;
210             }
211              
212             sub BLESSED {
213 0     0 0   my $self = shift;
214 0           my $obj = shift;
215 0           my %args = (
216             path => undef,
217             @_,
218             );
219              
220 0           my $ref = ref $obj;
221              
222 0           my $res = $COLOR->{class} . $ref . ' {' . $RESET . "\n";
223              
224 0           my ( $tags, $dumped );
225              
226             # @ISA
227             {
228 5     5   39 no strict qw[refs];
  5         11  
  5         9775  
  0            
229              
230 0 0         if ( my @superclasses = @{ $ref . '::ISA' } ) {
  0            
231 0           $res .= $self->{_indent} . '@ISA: ' . join q[, ], map { $COLOR->{class} . $_ . $RESET } @superclasses;
  0            
232              
233 0           $res .= ",\n";
234             }
235             }
236              
237             # reafddr
238 0           $res .= $self->{_indent} . 'refaddr: ' . refaddr($obj) . ",\n";
239              
240             # class dump method
241 0 0         if ( my $to_dump = $obj->can('TO_DUMP') ) {
242 0           my ( $dump, $dump_tags ) = $to_dump->( $obj, $self, path => $args{path} );
243              
244 0 0         if ($dump) {
245 0           $dumped = 1;
246              
247 0           $self->_indent_text($dump);
248              
249 0           $res .= $self->{_indent} . $dump;
250             }
251              
252 0 0         push $tags->@*, $dump_tags->@* if $dump_tags;
253             }
254              
255             # predefined dumper sub for class
256 0 0 0       if ( !$dumped && $DUMPERS->{$ref} ) {
257 0           my ( $dump, $dump_tags ) = $DUMPERS->{$ref}->( $obj, $self, path => $args{path} );
258              
259 0 0         if ($dump) {
260 0           $dumped = 1;
261              
262 0           $self->_indent_text($dump);
263              
264 0           $res .= $self->{_indent} . $dump;
265             }
266              
267 0 0         push $tags->@*, $dump_tags->@* if $dump_tags;
268             }
269              
270 0 0         if ( !$dumped ) {
271              
272             # blessed
273 0           my $blessed = $self->_dump_blessed( $obj, path => $args{path} );
274              
275 0           $self->_indent_text($blessed);
276              
277 0           $res .= $self->{_indent} . $blessed;
278             }
279              
280 0           $res .= "\n" . $COLOR->{class} . '}' . $RESET;
281              
282 0           return $res, $tags;
283             }
284              
285             sub REF {
286 0     0 0   my $self = shift;
287 0           my $ref = shift;
288 0           my %args = (
289             path => undef,
290             @_,
291             );
292              
293 0           my $item = $self->_dump( $ref->$*, path => $args{path} . '->$*' );
294              
295 0           $item->{prefix} = $COLOR->{refs} . '\\ ' . $RESET;
296              
297 0           return "$item";
298             }
299              
300             sub SCALAR {
301 0     0     my $self = shift;
302              
303 0           my ( $res, $tags );
304              
305 0 0         if ( !defined $_[0] ) { # undefined value
    0          
306 0           $res = $COLOR->{undef} . 'undef' . $RESET;
307             }
308             elsif ( looks_like_number( $_[0] ) ) {
309 0           $res = $COLOR->{number} . add_num_sep( $_[0] ) . $RESET;
310             }
311             else {
312 0           my $item = $_[0]; # scalar become untied
313 0           my $bytes_length = bytes::length($item);
314 0           my $length = length $item;
315 0           escape_scalar( $item, esc_color => $COLOR->{escaped}, reset_color => $COLOR->{string} );
316              
317 0 0         if ( utf8::is_utf8 $item ) { # characters
318 0           push $tags->@*, 'UTF8';
319              
320 0 0         if ( $bytes_length == $length ) {
321 0           push $tags->@*, 'single-byte, downgradable'; # ASCII-7bit (bytes in perl terminology), UTF8 flag can be dropped
322             }
323             else {
324 0           push $tags->@*, 'multi-byte';
325             }
326              
327 0           push $tags->@*, 'chars: ' . $length;
328             }
329             else { # octets
330 0 0         if ( $item =~ /[[:^ascii:]]/sm ) { # if has non-ASCII-7bit bytes - treats buffer as binary
331 0           push $tags->@*, 'latin1';
332             }
333             else { # if contains only ASCII-7bit bytes - treats buffer as string
334 0           push $tags->@*, 'ASCII';
335             }
336             }
337              
338 0           push $tags->@*, 'bytes: ' . $bytes_length;
339              
340 0 0         push $tags->@*, 'tied to ' . ref tied $_[0] if tainted $_[0];
341              
342 0           $res = 'qq[' . $COLOR->{string} . $item . $RESET . ']';
343             }
344              
345 0           $self->_tied_to( tied $_[0], $tags );
346              
347 0           return $res, $tags;
348             }
349              
350             sub ARRAY {
351 0     0 0   my $self = shift;
352 0           my $array_ref = shift;
353 0           my %args = (
354             path => undef,
355             @_,
356             );
357              
358 0           my ( $res, $tags );
359              
360 0 0         if ( !$array_ref->@* ) {
361 0           $res = $COLOR->{refs} . '[]' . $RESET;
362             }
363             else {
364 0           $res = $COLOR->{refs} . '[' . $RESET . $LF;
365              
366 0           my $max_index_length = length( $#{$array_ref} ) + 2;
  0            
367              
368 0           for my $i ( 0 .. $array_ref->$#* ) {
369 0           my $index = sprintf( '%-*s', $max_index_length, "[$i]" ) . q[ ];
370              
371 0           $res .= $self->{_indent} . $COLOR->{array} . $index . $RESET;
372              
373 0           my $el = $self->_dump( $array_ref->[$i], path => $args{path} . "->[$i]" );
374              
375             # not last array element
376 0 0         if ( $i != $array_ref->$#* ) {
377 0           $el->{sep} = ',';
378             }
379              
380 0           $self->_indent_text($el);
381              
382 0           $res .= "$el\n";
383             }
384              
385 0           $res .= $COLOR->{refs} . ']' . $RESET;
386             }
387              
388 0           $self->_tied_to( tied $array_ref->@*, $tags );
389              
390 0           return $res, $tags;
391             }
392              
393             sub HASH {
394 0     0 0   my $self = shift;
395 0           my $hash_ref = shift;
396 0           my %args = (
397             path => undef,
398             @_,
399             );
400              
401 0           my ( $res, $tags );
402              
403 0 0         if ( !keys $hash_ref->%* ) {
404 0           $res = $COLOR->{refs} . '{}' . $RESET;
405             }
406             else {
407 0           $res = $COLOR->{refs} . '{' . $RESET . $LF;
408              
409 0           my $keys;
410 0           my $max_length = 0;
411              
412             # index hash keys
413 0           for ( nsort keys $hash_ref->%* ) {
414             my $indexed_key = {
415             raw_key => $_,
416 0           escaped_key => \escape_scalar( $_, esc_color => $COLOR->{escaped}, reset_color => $COLOR->{hash} ),
417             };
418              
419             # hash key requires to be quoted
420 0 0 0       if ( $_ eq q[] || /[^[:alnum:]_]/sm ) {
421 0           $indexed_key->{escaped_key} = \( 'q[' . $indexed_key->{escaped_key}->$* . ']' );
422             }
423              
424 0           $indexed_key->{escaped_key_nc} = $indexed_key->{escaped_key}->$*;
425              
426 0           remove_ansi $indexed_key->{escaped_key_nc};
427              
428 0           $indexed_key->{escaped_key_nc_len} = length $indexed_key->{escaped_key_nc};
429              
430 0           push $keys->@*, $indexed_key;
431              
432 0 0         $max_length = $indexed_key->{escaped_key_nc_len} if $indexed_key->{escaped_key_nc_len} > $max_length;
433             }
434              
435 0           my $indent = $max_length + 8;
436              
437 0           for my $i ( 0 .. $keys->$#* ) {
438 0           $res .= $self->{_indent} . $COLOR->{hash} . $keys->[$i]->{escaped_key}->$* . $RESET;
439              
440 0           $res .= sprintf '%*s', ( $max_length - $keys->[$i]->{escaped_key_nc_len} + 4 ), ' => ';
441              
442 0           my $el = $self->_dump( $hash_ref->{ $keys->[$i]->{raw_key} }, path => $args{path} . '->{"' . $keys->[$i]->{escaped_key_nc} . '"}' );
443              
444             # not last hash key
445 0 0         if ( $i != $keys->$#* ) {
446 0           $el->{sep} = ',';
447             }
448              
449 0           $self->_indent_text($el);
450              
451 0           $res .= "$el\n";
452             }
453              
454 0           $res .= $COLOR->{refs} . '}' . $RESET;
455             }
456              
457 0           $self->_tied_to( tied $hash_ref->%*, $tags );
458              
459 0           return $res, $tags;
460             }
461              
462             sub VSTRING {
463 0     0 0   my $self = shift;
464              
465 0           return $COLOR->{vstring} . version->declare( $_[0] )->normal . $RESET;
466             }
467              
468             sub GLOB {
469 0     0 0   my $self = shift;
470              
471 0           my ( $res, $tags, $i );
472 0           my $flags = [];
473 0           my $layers = q[];
474              
475 0           for ( PerlIO::Layers::get_layers( $_[0] ) ) {
476 0 0         unless ($i) {
477 0           $i = 1;
478              
479 0           $flags = $_->[2];
480             }
481 0           $layers .= ":$_->[0]";
482              
483 0 0         $layers .= "($_->[1])" if defined $_->[1]; # add layer encoding
484              
485 0 0         $layers .= ':utf8' if 'UTF8' ~~ $_->[2]; # add :utf8 layer, if defined
486             }
487              
488 0           my $fileno = eval { fileno $_[0] };
  0            
489              
490 0           push $tags->@*, nsort $flags->@*;
491              
492 0 0         push $tags->@*, $layers if $layers;
493              
494 0 0         push $tags->@*, "fileno: $fileno" if defined $fileno;
495              
496 0           $self->_tied_to( tied $_[0], $tags );
497              
498             {
499 5     5   39 no overloading;
  5         10  
  5         2177  
  0            
500              
501 0           $res = $COLOR->{glob} . "$_[0]";
502             }
503              
504 0           $res .= $RESET;
505              
506 0           return $res, $tags;
507             }
508              
509             # TODO - more informative dumper for IO refs
510             sub IO {
511 0     0 0   my $self = shift;
512              
513 0           return $self->GLOB(@_);
514             }
515              
516             sub CODE {
517 0     0 0   my $self = shift;
518              
519 0           return $COLOR->{code} . 'sub { ... }' . $RESET;
520             }
521              
522             sub REGEXP {
523 0     0 0   my $self = shift;
524              
525 0           my ( $pat, $flags ) = re::regexp_pattern( $_[0] );
526              
527 0   0       $flags //= q[];
528              
529 0           return $COLOR->{regex} . qq[qr/$pat/$flags] . $RESET;
530             }
531              
532             sub FORMAT {
533 0     0 0   my $self = shift;
534              
535 0           return $COLOR->{format} . 'FORMAT' . $RESET;
536             }
537              
538             sub LVALUE {
539 0     0 0   my $self = shift;
540              
541 0           my ( $res, $tags ) = $self->SCALAR( $_[0]->$* );
542              
543 0           unshift $tags->@*, 'LVALUE';
544              
545 0           return $res, $tags;
546             }
547              
548             package Pcore::Core::Dump::Dumper::_Item {
549             use overload #
550             q[""] => sub {
551 0 0   0     if ( $_[0]->{tags} ) {
552 0   0       return ( $_[0]->{prefix} // q[] ) . $_[0]->{text}->$* . ( $_[0]->{sep} // q[] ) . ' # ' . join q[, ], $_[0]->{tags}->@*;
      0        
553             }
554             else {
555 0   0       return ( $_[0]->{prefix} // q[] ) . $_[0]->{text}->$* . ( $_[0]->{sep} // q[] );
      0        
556             }
557 5     5   34 };
  5         9  
  5         56  
558             }
559              
560             1;
561             ## -----SOURCE FILTER LOG BEGIN-----
562             ##
563             ## PerlCritic profile "pcore-script" policy violations:
564             ## +------+----------------------+----------------------------------------------------------------------------------------------------------------+
565             ## | Sev. | Lines | Policy |
566             ## |======+======================+================================================================================================================|
567             ## | 2 | 86 | ValuesAndExpressions::ProhibitEmptyQuotes - Quotes used with a string containing no non-whitespace characters |
568             ## |------+----------------------+----------------------------------------------------------------------------------------------------------------|
569             ## | 1 | 76, 79, 231, 293 | ValuesAndExpressions::RequireInterpolationOfMetachars - String *may* require interpolation |
570             ## +------+----------------------+----------------------------------------------------------------------------------------------------------------+
571             ##
572             ## -----SOURCE FILTER LOG END-----
573             __END__
574             =pod
575              
576             =encoding utf8
577              
578             =head1 NAME
579              
580             Pcore::Core::Dump::Dumper
581              
582             =head1 SYNOPSIS
583              
584             =head1 DESCRIPTION
585              
586             =cut