File Coverage

blib/lib/Data/Dump/Color.pm
Criterion Covered Total %
statement 281 479 58.6
branch 110 256 42.9
condition 34 102 33.3
subroutine 18 22 81.8
pod 3 10 30.0
total 446 869 51.3


line stmt bran cond sub pod time code
1             ## no critic: Modules::ProhibitAutomaticExportation
2             ## no critic: BuiltinFunctions::RequireBlockGrep
3             ## no critic: ValuesAndExpressions::ProhibitCommaSeparatedStatements
4              
5             package Data::Dump::Color;
6              
7             our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
8             our $DATE = '2021-06-24'; # DATE
9             our $DIST = 'Data-Dump-Color'; # DIST
10             our $VERSION = '0.247'; # VERSION
11              
12 2     2   124052 use 5.010001;
  2         23  
13 2     2   9 use strict 'subs', 'vars';
  2         4  
  2         65  
14 2     2   1046 use subs qq(dump);
  2         40  
  2         7  
15 2     2   86 use vars qw(@EXPORT @EXPORT_OK $VERSION $DEBUG);
  2         4  
  2         110  
16 2     2   10 use warnings;
  2         3  
  2         138  
17              
18             require Exporter;
19             *import = \&Exporter::import;
20             @EXPORT = qw(dd ddx);
21             @EXPORT_OK = qw(dump pp dumpf quote);
22              
23             $DEBUG = $ENV{DEBUG};
24              
25 2     2   2720 use overload ();
  2         1742  
  2         52  
26 2     2   12 use vars qw(%seen %refcnt @fixup @cfixup %require $TRY_BASE64 @FILTERS $INDENT);
  2         3  
  2         137  
27 2     2   10 use vars qw($COLOR $COLOR_THEME $INDEX $LENTHRESHOLD);
  2         3  
  2         11416  
28              
29             require Win32::Console::ANSI if $^O =~ /Win/;
30              
31             my $lan_available;
32             eval {
33             require Scalar::Util::LooksLikeNumber;
34             *looks_like_number = \&Scalar::Util::LooksLikeNumber::looks_like_number;
35             $lan_available = 1;
36             1;
37             } or do {
38             require Scalar::Util;
39             *looks_like_number = \&Scalar::Util::looks_like_number;
40             };
41              
42             $TRY_BASE64 = 50 unless defined $TRY_BASE64;
43             $INDENT = " " unless defined $INDENT;
44             $INDEX = 1 unless defined $INDEX;
45             $LENTHRESHOLD = 500 unless defined $LENTHRESHOLD;
46             $COLOR = (defined $ENV{NO_COLOR} ? 0 : undef) //
47             $ENV{COLOR} // (-t STDOUT) // 1;
48             $COLOR_THEME = $ENV{DATA_DUMP_COLOR_THEME} //
49             (($ENV{TERM} // "") =~ /256/ ? 'Default256' : 'Default16');
50             our $ct_obj;
51              
52             # from List::Util::PP
53             sub max {
54 59 50   59 0 91 return undef unless @_;
55 59         71 my $max = shift;
56             $_ > $max and $max = $_
57 59   66     138 foreach @_;
58 59         93 return $max;
59             }
60              
61             sub _col {
62 242     242   1923 require ColorThemeUtil::ANSI;
63 242         1107 my ($item, $str) = @_;
64              
65 242 50       1042 return $str unless $COLOR;
66              
67 0         0 my $ansi = '';
68 0         0 $item = $ct_obj->get_item_color($item);
69 0 0       0 if (defined $item) {
70 0         0 $ansi = ColorThemeUtil::ANSI::item_color_to_ansi($item);
71             }
72 0 0       0 if (length $ansi) {
73 0         0 $ansi . $str . "\e[0m";
74             } else {
75 0         0 $str;
76             }
77             }
78              
79             sub dump
80             {
81 3     3   2163 require Module::Load::Util;
82              
83 3         2412 local %seen;
84 3         7 local %refcnt;
85 3         5 local %require;
86 3         7 local @fixup;
87 3         5 local @cfixup;
88              
89 3         14 local $ct_obj = Module::Load::Util::instantiate_class_with_optional_args(
90             {ns_prefixes=>['ColorTheme::Data::Dump::Color','ColorTheme','']}, $COLOR_THEME);
91 3 50       292 require Data::Dump::FilterContext if @FILTERS;
92              
93 3         7 my $name = "var";
94 3         6 my @dump;
95             my @cdump;
96              
97 3         9 for my $v (@_) {
98 3         20 my ($val, $cval) = _dump($v, $name, [], tied($v));
99 3         11 push(@dump , [$name, $val]);
100 3         7 push(@cdump, [$name, $cval]);
101             } continue {
102 3         10 $name++;
103             }
104              
105 3         6 my $out = "";
106 3         13 my $cout = "";
107 3 50       10 if (%require) {
108 0         0 for (sort keys %require) {
109 0         0 $out .= "require $_;\n";
110 0         0 $cout .= _col(keyword=>"require")." "._col(symbol=>$_).";\n";
111             }
112             }
113 3 100       10 if (%refcnt) {
114             # output all those with refcounts first
115 1         3 for my $i (0..$#dump) {
116 1         3 my $name = $dump[ $i][0];
117 1         2 my $cname = $cdump[$i][0];
118 1 50       3 if ($refcnt{$name}) {
119 1         4 $out .= "my \$$name = $dump[$i][1];\n";
120 1         3 $cout .= _col(keyword=>"my")." "._col(symbol=>"\$$cname")." = $cdump[$i][1];\n";
121 1         3 undef $dump[ $i][1];
122 1         2 undef $cdump[$i][1];
123             }
124             }
125 1         3 for my $i (0..$#fixup) {
126 1         3 $out .= "$fixup[$i];\n";
127 1         2 $cout .= "$cfixup[$i];\n";
128             }
129             }
130              
131 3         7 my $paren = (@dump != 1);
132 3 50       8 $out .= "(" if $paren;
133 3 50       7 $cout .= "(" if $paren;
134             my ($f, $cf) = format_list($paren, undef,
135             [0],
136 3 100       16 [map {defined($_->[1]) ? $_->[1] : "\$".$_->[0]} @dump ],
137 3 100       10 [map {defined($_->[1]) ? $_->[1] : "\$".$_->[0]} @cdump],
  3         19  
138             \@_,
139             );
140 3         18 $out .= $f;
141 3         14 $cout .= $cf;
142 3 50       8 $out .= ")" if $paren;
143 3 50       6 $cout .= ")" if $paren;
144              
145 3 100 66     12 if (%refcnt || %require) {
146 1         3 $out .= ";\n";
147 1         2 $cout .= ";\n";
148 1         7 $out =~ s/^/$INDENT/gm;
149 1         4 $cout =~ s/^/$INDENT/gm;
150 1         3 $out = "do {\n$out}";
151 1         2 $cout = _col(keyword=>"do")." {\n$cout}";
152             }
153              
154 3 50       16 print STDERR "$cout\n" unless defined wantarray;
155 3         304 $cout;
156             }
157              
158             *pp = \&dump;
159              
160             sub dd {
161 0     0 1 0 print dump(@_), "\n";
162 0         0 @_;
163             }
164              
165             sub ddx {
166 0     0 1 0 my(undef, $file, $line) = caller;
167 0         0 $file =~ s,.*[\\/],,;
168 0         0 my $out = _col(linum=>"$file:$line: ") . dump(@_) . "\n";
169 0         0 $out =~ s/^/# /gm;
170 0         0 print $out;
171             }
172              
173             sub dumpf {
174 0     0 0 0 require Data::Dump::Filtered;
175 0         0 goto &Data::Dump::Filtered::dump_filtered;
176             }
177              
178             # return two result: (uncolored dump, colored dump)
179             sub _dump
180             {
181 69     69   118 my $ref = ref $_[0];
182 69 100       129 my $rval = $ref ? $_[0] : \$_[0];
183 69         78 shift;
184              
185             # compared to Data::Dump, each @$idx element is also a [uncolored,colored]
186             # instead of just a scalar.
187 69         114 my($name, $idx, $dont_remember, $pclass, $pidx) = @_;
188              
189 69         83 my($class, $type, $id);
190 69         141 my $strval = overload::StrVal($rval);
191             # Parse $strval without using regexps, in order not to clobber $1, $2,...
192 69 50       279 if ((my $i = rindex($strval, "=")) >= 0) {
193 0         0 $class = substr($strval, 0, $i);
194 0         0 $strval = substr($strval, $i+1);
195             }
196 69 50       248 if ((my $i = index($strval, "(0x")) >= 0) {
197 69         103 $type = substr($strval, 0, $i);
198 69         101 $id = substr($strval, $i + 2, -1);
199             }
200             else {
201 0         0 die "Can't parse " . overload::StrVal($rval);
202             }
203 69 50 33     133 if ($] < 5.008 && $type eq "SCALAR") {
204 0 0       0 $type = "REF" if $ref eq "REF";
205             }
206 69 50       96 warn "\$$name(@$idx) $class $type $id ($ref)" if $DEBUG;
207              
208 69         151 my $out;
209             my $cout;
210 69         0 my $comment;
211 69         0 my $hide_keys;
212 69 50       105 if (@FILTERS) {
213 0         0 my $pself = "";
214 0 0       0 ($pself, undef) = fullname("self", [@$idx[$pidx..(@$idx - 1)]]) if $pclass;
215 0         0 my $ctx = Data::Dump::FilterContext->new($rval, $class, $type, $ref, $pclass, $pidx, $idx);
216 0         0 my @bless;
217 0         0 for my $filter (@FILTERS) {
218 0 0       0 if (my $f = $filter->($ctx, $rval)) {
219 0 0       0 if (my $v = $f->{object}) {
220 0         0 local @FILTERS;
221 0         0 ($out, $cout) = _dump($v, $name, $idx, 1);
222 0         0 $dont_remember++;
223             }
224 0 0       0 if (defined(my $c = $f->{bless})) {
225 0         0 push(@bless, $c);
226             }
227 0 0       0 if (my $c = $f->{comment}) {
228 0         0 $comment = $c;
229             }
230 0 0       0 if (defined(my $c = $f->{dump})) {
231 0         0 $out = $c;
232 0         0 $cout = $c; # XXX where's the colored version?
233 0         0 $dont_remember++;
234             }
235 0 0       0 if (my $h = $f->{hide_keys}) {
236 0 0       0 if (ref($h) eq "ARRAY") {
237             $hide_keys = sub {
238 0     0   0 for my $k (@$h) {
239 0 0       0 return (1, 1) if $k eq $_[0]; # XXX color?
240             }
241 0         0 return (0, 0); # XXX color?
242 0         0 };
243             }
244             }
245             }
246             }
247 0 0 0     0 push(@bless, "") if defined($out) && !@bless;
248 0 0       0 if (@bless) {
249 0         0 $class = shift(@bless);
250 0 0       0 warn "More than one filter callback tried to bless object" if @bless;
251             }
252             }
253              
254 69 50       106 unless ($dont_remember) {
255 69 100       120 if (my $s = $seen{$id}) {
256 1         2 my($sname, $sidx) = @$s;
257 1         3 $refcnt{$sname}++;
258 1   33     29 my ($sref, $csref) = fullname($sname, $sidx,
259             ($ref && $type eq "SCALAR"));
260 1 50       3 warn "SEEN: [\$$name(@$idx)] => [\$$sname(@$sidx)] ($ref,$sref)" if $DEBUG;
261 1 50       3 return ($sref, $csref) unless $sname eq $name; # XXX color?
262 1         2 $refcnt{$name}++;
263 1         3 my ($fn, $cfn) = fullname($name, $idx);
264 1         4 push(@fixup , "$fn = $sref");
265 1         2 push(@cfixup, "$cfn = $csref");
266             return (
267 1 50 33     7 "do{my \$fix}",
268             _col(keyword=>"do")."{"._col(keyword=>"my")." "._col(symbol=>"\$fix")."}",
269             ) if @$idx && $idx->[-1] eq '$';
270 1         3 my $str = squote($sref);
271             return (
272 1         3 $str,
273             _col(string => $str),
274             );
275             }
276 68         192 $seen{$id} = [$name, $idx];
277             }
278              
279 68 50       109 if ($class) {
280 0         0 $pclass = $class;
281 0         0 $pidx = @$idx;
282             }
283              
284 68 50 66     224 if (defined $out) {
    100 66        
    50          
    100          
    50          
    0          
    0          
285             # keep it
286             }
287             elsif ($type eq "SCALAR" || $type eq "REF" || $type eq "REGEXP") {
288 54 50       79 if ($ref) {
289 0 0 0     0 if ($class && $class eq "Regexp") {
290 0         0 my $v = "$rval";
291              
292 0         0 my $mod = "";
293 0 0       0 if ($v =~ /^\(\?\^?([msix-]*):([\x00-\xFF]*)\)\z/) {
294 0         0 $mod = $1;
295 0         0 $v = $2;
296 0         0 $mod =~ s/-.*//;
297             }
298              
299 0         0 my $sep = '/';
300 0         0 my $sep_count = ($v =~ tr/\///);
301 0 0       0 if ($sep_count) {
302             # see if we can find a better one
303 0         0 for ('|', ',', ':', '#') {
304 0         0 my $c = eval "\$v =~ tr/\Q$_\E//";
305             #print "SEP $_ $c $sep_count\n";
306 0 0       0 if ($c < $sep_count) {
307 0         0 $sep = $_;
308 0         0 $sep_count = $c;
309 0 0       0 last if $sep_count == 0;
310             }
311             }
312             }
313 0         0 $v =~ s/\Q$sep\E/\\$sep/g;
314              
315 0         0 $out = "qr$sep$v$sep$mod";
316 0         0 $cout = _col('Regexp', $out);
317 0         0 undef($class);
318             }
319             else {
320 0 0       0 delete $seen{$id} if $type eq "SCALAR"; # will be seen again shortly
321 0         0 my ($val, $cval) = _dump($$rval, $name, [@$idx, ["\$","\$"]], 0, $pclass, $pidx);
322 0 0       0 $out = $class ? "do{\\(my \$o = $val)}" : "\\$val";
323 0 0       0 $cout = $class ? _col(keyword=>"do")."{\\("._col(keyword=>"my")." "._col(symbol=>"\$o")." = $cval)}" : "\\$cval";
324             }
325             } else {
326 54 50       178 if (!defined $$rval) {
    100          
327 0         0 $out = 'undef';
328 0         0 $cout = _col('undef', "undef");
329             }
330             elsif (my $ntype = looks_like_number($$rval)) {
331 11 50       18 if ($lan_available) {
332             # ntype returns details of the nature of numeric value in
333             # scalar, including the ability to differentiate stringy
334             # number "123" vs 123.
335 11 100       23 my $val = $ntype < 20 ? qq("$$rval") : $$rval;
336 11 100       44 my $col = $ntype =~ /^(5|13|8704)$/ ? "float":"number";
337 11         14 $out = $val;
338 11         18 $cout = _col($col => $val);
339             } else {
340 0         0 my $val = $$rval;
341 0         0 my $col = "number";
342 0         0 $out = $val;
343 0         0 $cout = _col($col => $val);
344             }
345             }
346             else {
347 43         74 $out = str($$rval);
348 43         67 $cout = _col(string => $out);
349             }
350 54 50 33     95 if ($class && !@$idx) {
351             # Top is an object, not a reference to one as perl needs
352 0         0 $refcnt{$name}++;
353 0         0 my ($obj, $cobj) = fullname($name, $idx);
354 0         0 my $cl = quote($class);
355 0         0 push(@fixup , "bless \\$obj, $cl");
356 0         0 push(@cfixup, _col(keyword => "bless")." \\$cobj, "._col(string=>$cl));
357             }
358             }
359             }
360             elsif ($type eq "GLOB") {
361 0 0       0 if ($ref) {
362 0         0 delete $seen{$id};
363 0         0 my ($val, $cval) = _dump($$rval, $name, [@$idx, ["*","*"]], 0, $pclass, $pidx);
364 0         0 $out = "\\$val";
365 0         0 $cout = "\\$cval";
366 0 0       0 if ($out =~ /^\\\*Symbol::/) {
367 0         0 $require{Symbol}++;
368 0         0 $out = "Symbol::gensym()";
369 0         0 $cout = _col(glob => $out);
370             }
371             } else {
372 0         0 my $val = "$$rval";
373 0         0 $out = "$$rval";
374 0         0 $cout = _col(glob => $out);
375              
376 0         0 for my $k (qw(SCALAR ARRAY HASH)) {
377 0         0 my $gval = *$$rval{$k};
378 0 0       0 next unless defined $gval;
379 0 0 0     0 next if $k eq "SCALAR" && ! defined $$gval; # always there
380 0         0 my $f = scalar @fixup;
381 0         0 push(@fixup, "RESERVED"); # overwritten after _dump() below
382 0         0 my $cgval;
383 0         0 ($gval, $cgval) = _dump($gval, $name, [@$idx, ["*{$k}", "*{"._col(string=>$k)."}"]], 0, $pclass, $pidx);
384 0         0 $refcnt{$name}++;
385 0         0 my ($gname, $cgname) = fullname($name, $idx);
386 0         0 $fixup[ $f] = "$gname = $gval" ; #XXX indent $gval
387 0         0 $cfixup[$f] = "$gname = $cgval"; #XXX indent $gval
388             }
389             }
390             }
391             elsif ($type eq "ARRAY") {
392 3         7 my @vals;
393             my @cvals;
394 3         7 my $tied = tied_str(tied(@$rval));
395 3         3 my $i = 0;
396 3         6 for my $v (@$rval) {
397 7         16 my ($d, $cd) = _dump($v, $name, [@$idx, ["[$i]","["._col(number=>$i)."]"]], $tied, $pclass, $pidx);
398 7         14 push @vals , $d;
399 7         10 push @cvals, $cd;
400 7         12 $i++;
401             }
402 3         9 my ($f, $cf) = format_list(1, $tied, [scalar(@$idx)], \@vals, \@cvals, $rval);
403 3         7 $out = "[$f]";
404 3         8 $cout = "[$cf]";
405             }
406             elsif ($type eq "HASH") {
407 11         16 my(@keys, @vals, @cvals, @origk, @origv);
408 11         22 my $tied = tied_str(tied(%$rval));
409              
410             # statistics to determine variation in key lengths
411 11         17 my $kstat_max = 0;
412 11         13 my $kstat_sum = 0;
413 11         13 my $kstat_sum2 = 0;
414              
415 11         49 my @orig_keys = keys %$rval;
416 11 50       19 if ($hide_keys) {
417 0         0 @orig_keys = grep !$hide_keys->($_), @orig_keys;
418             }
419 11         13 my $text_keys = 0;
420 11         19 for (@orig_keys) {
421 12 100       57 $text_keys++, last unless /^[-+]?(?:0|[1-9]\d*)(?:\.\d+)?\z/;
422             }
423              
424 11 100       20 if ($text_keys) {
425 10         30 @orig_keys = sort { lc($a) cmp lc($b) } @orig_keys;
  98         138  
426             }
427             else {
428 1         18 @orig_keys = sort { $a <=> $b } @orig_keys;
  1         7  
429             }
430              
431 11         17 my $quote;
432 11         15 for my $key (@orig_keys) {
433 59 100       131 next if $key =~ /^-?[a-zA-Z_]\w*\z/;
434 2 50       7 next if $key =~ /^-?[1-9]\d{0,8}\z/;
435 0         0 $quote++;
436 0         0 last;
437             }
438              
439 11         16 my @lenvlastline;
440 11         12 for my $key (@orig_keys) {
441 59         98 my $val = \$rval->{$key}; # capture value before we modify $key
442 59         84 push(@origk, $key);
443 59 50       84 $key = quote($key) if $quote;
444 59 100       99 $kstat_max = length($key) if length($key) > $kstat_max;
445 59         386 $kstat_sum += length($key);
446 59         71 $kstat_sum2 += length($key)*length($key);
447              
448 59         71 push(@keys, $key);
449 59         128 my ($v, $cv) = _dump($$val, $name, [@$idx, ["{$key}","{"._col(string=>$key)."}"]], $tied, $pclass, $pidx);
450 59         106 push(@vals , $v);
451 59         69 push(@cvals, $cv);
452 59         84 push(@origv, $$val);
453              
454 59         303 my ($vlastline) = $v =~ /(.*)\z/;
455             #say "DEBUG: v=<$v>, vlastline=<$vlastline>" if $DEBUG;
456 59         82 my $lenvlastline = length($vlastline);
457 59         116 push @lenvlastline, $lenvlastline;
458             }
459             #$maxvlen += length($INDENT);
460             #say "maxvlen=$maxvlen"; #TMP
461 11         15 my $nl = "";
462 11         13 my $klen_pad = 0;
463 11         65 my $tmp = "@keys @vals";
464 11 0 33     28 if (length($tmp) > 60 || $tmp =~ /\n/ || $tied) {
      33        
465 11         15 $nl = "\n";
466              
467             # Determine what padding to add
468 11 100       38 if ($kstat_max < 4) {
    50          
469 1         2 $klen_pad = $kstat_max;
470             }
471             elsif (@keys >= 2) {
472 10         17 my $n = @keys;
473 10         18 my $avg = $kstat_sum/$n;
474 10         28 my $stddev = sqrt(($kstat_sum2 - $n * $avg * $avg) / ($n - 1));
475              
476             # I am not actually very happy with this heuristics
477 10 100       20 if ($stddev / $kstat_max < 0.25) {
478 7         16 $klen_pad = $kstat_max;
479             }
480 10 50       39 if ($DEBUG) {
481 0         0 push(@keys, "__S");
482 0         0 push(@vals, sprintf("%.2f (%d/%.1f/%.1f)",
483             $stddev / $kstat_max,
484             $kstat_max, $avg, $stddev));
485 0         0 push(@cvals, sprintf("%.2f (%d/%.1f/%.1f)",
486             $stddev / $kstat_max,
487             $kstat_max, $avg, $stddev));
488             }
489             }
490             }
491              
492 11         19 my $maxkvlen = 0;
493 11         21 for (0..$#keys) {
494 59         69 my $klen = length($keys[$_]);
495 59 100       81 $klen = $klen_pad if $klen < $klen_pad;
496 59         104 my $kvlen = $klen + $lenvlastline[$_];
497 59 100       93 $maxkvlen = $kvlen if $maxkvlen < $kvlen;
498             }
499 11 50       49 $maxkvlen = 80 if $maxkvlen > 80;
500              
501 11         18 $out = "{$nl";
502 11         15 $cout = "{$nl";
503 11 50       16 $out .= "$INDENT# $tied$nl" if $tied;
504 11 50       19 $cout .= $INDENT._col(comment=>"# $tied").$nl if $tied;
505 11         13 my $i = 0;
506 11         18 my $idxwidth = length(~~@keys);
507 11         20 while (@keys) {
508 59         82 my $key = shift(@keys);
509 59         81 my $val = shift @vals;
510 59         71 my $cval = shift @cvals;
511 59         69 my $origk = shift @origk;
512 59         71 my $origv = shift @origv;
513 59         64 my $lenvlastline = shift @lenvlastline;
514 59         86 my $vmultiline = length($val) > $lenvlastline;
515 59 100       130 my $vpad = $INDENT . (" " x ($klen_pad ? $klen_pad + 4 : 0));
516 59         202 $val =~ s/\n/\n$vpad/gm;
517 59         121 $cval =~ s/\n/\n$vpad/gm;
518 59 50       92 my $kpad = $nl ? $INDENT : " ";
519 59         69 my $pad_len = ($klen_pad - length($key));
520 59 100       85 if ($pad_len < 0) { $pad_len = 0; }
  18         18  
521 59 50       140 $key .= " " x $pad_len if $nl;
522 59 100       119 my $cpad = " " x max(0, $maxkvlen - ($vmultiline ? -6+length($vpad) : length($key)) - $lenvlastline);
523             #say "DEBUG: key=<$key>, vpad=<$vpad>, val=<$val>, lenvlastline=<$lenvlastline>, cpad=<$cpad>" if $DEBUG;
524 59         74 my $visaid = "";
525 59 50       178 $visaid .= sprintf("%s{%${idxwidth}i}", "." x @$idx, $i) if $INDEX;
526 59 50 33     162 $visaid .= " klen=".length($origk) if defined $origk && length($origk) >= $LENTHRESHOLD;
527 59 50 33     134 $visaid .= " vlen=".length($origv) if defined $origv && length($origv) >= $LENTHRESHOLD;
528 59 50 33     310 $out .= "$kpad$key => $val," . ($nl && length($visaid) ? " $cpad# $visaid" : "") . $nl;
529 59 50 33     93 $cout .= $kpad._col(key=>$key)." => $cval,".($nl && length($visaid) ? " $cpad"._col(comment => "# $visaid") : "") . $nl;
530 59         152 $i++;
531             }
532 11 50       19 $out =~ s/,$/ / unless $nl;
533 11 50       17 $cout =~ s/,$/ / unless $nl;
534 11         13 $out .= "}";
535 11         23 $cout .= "}";
536             }
537             elsif ($type eq "CODE") {
538 0         0 $out = 'sub { ... }';
539 0         0 $cout = _col(keyword=>'sub').' { ... }';
540             }
541             elsif ($type eq "VSTRING") {
542 0 0       0 $out = sprintf +($ref ? '\v%vd' : 'v%vd'), $$rval;
543 0         0 $cout = _col(string => $out);
544             }
545             else {
546 0         0 warn "Can't handle $type data";
547 0         0 $out = "'#$type#'";
548 0         0 $cout = _col(comment => $out);
549             }
550              
551 68 50 33     115 if ($class && $ref) {
552 0         0 $cout = _col(keyword=>"bless")."($cout, " . _col(string => quote($class)) . ")";
553 0         0 $out = "bless($out, ".quote($class).")";
554             }
555 68 50       130 if ($comment) {
556 0         0 $comment =~ s/^/# /gm;
557 0 0       0 $comment .= "\n" unless $comment =~ /\n\z/;
558 0         0 $comment =~ s/^#[ \t]+\n/\n/;
559 0         0 $cout = _col(comment=>$comment).$out;
560 0         0 $out = "$comment$out";
561             }
562 68         181 return ($out, $cout);
563             }
564              
565             sub tied_str {
566 14     14 0 21 my $tied = shift;
567 14 50       27 if ($tied) {
568 0 0       0 if (my $tied_ref = ref($tied)) {
569 0         0 $tied = "tied $tied_ref";
570             }
571             else {
572 0         0 $tied = "tied";
573             }
574             }
575 14         18 return $tied;
576             }
577              
578             # return two result: (uncolored dump, colored dump)
579             sub fullname
580             {
581 2     2 0 5 my($name, $idx, $ref) = @_;
582 2         5 substr($name, 0, 0) = "\$";
583 2         16 my $cname = $name;
584              
585 2         5 my @i = @$idx; # need copy in order to not modify @$idx
586 2 0 33     6 if ($ref && @i && $i[0][0] eq "\$") {
      33        
587 0         0 shift(@i); # remove one deref
588 0         0 $ref = 0;
589             }
590 2   33     9 while (@i && $i[0][0] eq "\$") {
591 0         0 shift @i;
592 0         0 $name = "\$$name";
593 0         0 $cname = _col(symbol=>$name);
594             }
595              
596 2         3 my $last_was_index;
597 2         3 for my $i (@i) {
598 2 50 33     10 if ($i->[0] eq "*" || $i->[0] eq "\$") {
    50          
599 0         0 $last_was_index = 0;
600 0         0 $name = "$i->[0]\{$name}";
601 0         0 $cname = "$i->[1]\{$cname}";
602             } elsif ($i->[0] =~ s/^\*//) {
603 0         0 $name .= $i->[0];
604 0         0 $cname .= $i->[1];
605 0         0 $last_was_index++;
606             } else {
607 2         10 $name .= "->";
608 2         3 $cname .= "->";
609 2         3 $name .= $i->[0];
610 2         4 $cname .= $i->[1];
611             }
612             }
613 2 50       4 $name = "\\$name" if $ref;
614 2         8 ($name, $cname);
615             }
616              
617             # return two result: (uncolored dump, colored dump)
618             sub format_list
619             {
620 6     6 0 10 my $paren = shift;
621 6         10 my $comment = shift;
622 6         9 my $extra = shift; # [level, ]
623 6 100       12 my $indent_lim = $paren ? 0 : 1;
624 6         8 my @vals = @{ shift(@_) };
  6         15  
625 6         9 my @cvals = @{ shift(@_) };
  6         12  
626 6         8 my @orig = @{ shift(@_) };
  6         9  
627              
628 6 100       15 if (@vals > 3) {
629             # can we use range operator to shorten the list?
630 1         1 my $i = 0;
631 1         3 while ($i < @vals) {
632 4         6 my $j = $i + 1;
633 4         5 my $v = $vals[$i];
634 4         26 while ($j < @vals) {
635             # XXX allow string increment too?
636 3 100 66     17 if ($v eq "0" || $v =~ /^-?[1-9]\d{0,9}\z/) {
    50          
637 1         2 $v++;
638             }
639             elsif ($v =~ /^"([A-Za-z]{1,3}\d*)"\z/) {
640 0         0 $v = $1;
641 0         0 $v++;
642 0         0 $v = qq("$v");
643             }
644             else {
645 2         3 last;
646             }
647 1 50       3 last if $vals[$j] ne $v;
648 0         0 $j++;
649             }
650 4 50       8 if ($j - $i > 3) {
651 0         0 splice(@vals , $i, $j - $i, "$vals[$i] .. $vals[$j-1]");
652 0         0 splice(@cvals, $i, $j - $i, "$cvals[$i] .. $cvals[$j-1]");
653 0         0 splice(@orig , $i, $j - $i, [@orig[$i..$j-1]]);
654             }
655 4         8 $i++;
656             }
657             }
658 6         24 my $tmp = "@vals";
659 6 50 33     35 if ($comment || (@vals > $indent_lim && (length($tmp) > 60 || $tmp =~ /\n/))) {
      66        
      33        
660              
661 0         0 my $maxvlen = 0;
662 0         0 for (@vals) {
663 0         0 my ($vfirstline) = /\A(.*)/;
664 0         0 my $lenvfirstline = length($vfirstline);
665 0 0       0 $maxvlen = $lenvfirstline if $maxvlen < $lenvfirstline;
666             }
667 0 0       0 $maxvlen = 80 if $maxvlen > 80;
668 0         0 $maxvlen += length($INDENT);
669              
670 0 0       0 my @res = ("\n", $comment ? "$INDENT# $comment\n" : "");
671 0 0       0 my @cres = ("\n", $comment ? $INDENT._col("# $comment")."\n" : "");
672 0         0 my @elem = @vals;
673 0         0 my @celem = @cvals;
674 0         0 for (@elem ) { s/^/$INDENT/gm; }
  0         0  
675 0         0 for (@celem) { s/^/$INDENT/gm; }
  0         0  
676 0         0 my $idxwidth = length(~~@elem);
677 0         0 for my $i (0..$#elem) {
678 0         0 my ($vlastline) = $elem[$i] =~ /(.*)\z/;
679 0         0 my $cpad = " " x max(0, $maxvlen - length($vlastline));
680 0         0 my $visaid = "";
681 0 0       0 $visaid .= sprintf("%s[%${idxwidth}i]", "." x $extra->[0], $i) if $INDEX;
682 0 0 0     0 $visaid .= " len=".length($orig[$i]) if defined $orig[$i] && length($orig[$i]) >= $LENTHRESHOLD;
683 0 0       0 push @res , $elem[ $i], ",", (length($visaid) ? " $cpad# $visaid" : ""), "\n";
684 0 0       0 push @cres, $celem[$i], ",", (length($visaid) ? " $cpad"._col(comment => "# $visaid") : ""), "\n";
685             }
686 0         0 return (join("", @res), join("", @cres));
687             } else {
688 6         39 return (join(", ", @vals), join(", ", @cvals));
689             }
690             }
691              
692             sub str {
693 43 100   43 1 65 if (length($_[0]) > 20) {
694 3         8 for ($_[0]) {
695             # Check for repeated string
696 3 50       9 if (/^(.)\1\1\1/s) {
697             # seems to be a repeating sequence, let's check if it really is
698             # without backtracking
699 0 0       0 unless (/[^\Q$1\E]/) {
700 0         0 my $base = quote($1);
701 0         0 my $repeat = length;
702 0         0 return "($base x $repeat)"
703             }
704             }
705             # Length protection because the RE engine will blow the stack [RT#33520]
706 3 50 33     22 if (length($_) < 16 * 1024 && /^(.{2,5}?)\1*\z/s) {
707 0         0 my $base = quote($1);
708 0         0 my $repeat = length($_)/length($1);
709 0         0 return "($base x $repeat)";
710             }
711             }
712             }
713              
714 43         64 local $_ = "e;
715              
716 43 50 66     97 if (length($_) > 40 && !/\\x\{/ && length($_) > (length($_[0]) * 2)) {
      66        
717             # too much binary data, better to represent as a hex/base64 string
718              
719             # Base64 is more compact than hex when string is longer than
720             # 17 bytes (not counting any require statement needed).
721             # But on the other hand, hex is much more readable.
722 0 0 0     0 if ($TRY_BASE64 && length($_[0]) > $TRY_BASE64 &&
      0        
      0        
      0        
723             (defined &utf8::is_utf8 && !utf8::is_utf8($_[0])) &&
724 0         0 eval { require MIME::Base64 })
725             {
726 0         0 $require{"MIME::Base64"}++;
727 0         0 return "MIME::Base64::decode(\"" .
728             MIME::Base64::encode($_[0],"") .
729             "\")";
730             }
731 0         0 return "pack(\"H*\",\"" . unpack("H*", $_[0]) . "\")";
732             }
733              
734 43         76 return $_;
735             }
736              
737             my %esc = (
738             "\a" => "\\a",
739             "\b" => "\\b",
740             "\t" => "\\t",
741             "\n" => "\\n",
742             "\f" => "\\f",
743             "\r" => "\\r",
744             "\e" => "\\e",
745             );
746              
747             # put a string value in double quotes
748             sub quote {
749 43     43 0 66 local($_) = $_[0];
750             # If there are many '"' we might want to use qq() instead
751 43         75 s/([\\\"\@\$])/\\$1/g;
752 43 50       135 return qq("$_") unless /[^\040-\176]/; # fast exit
753              
754 0         0 s/([\a\b\t\n\f\r\e])/$esc{$1}/g;
755              
756             # no need for 3 digits in escape for these
757 0         0 s/([\0-\037])(?!\d)/sprintf('\\%o',ord($1))/eg;
  0         0  
758              
759 0         0 s/([\0-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg;
  0         0  
760 0         0 s/([^\040-\176])/sprintf('\\x{%X}',ord($1))/eg;
  0         0  
761              
762 0         0 return qq("$_");
763             }
764              
765             # put a string value in single quotes
766             sub squote {
767 1     1 0 3 local($_) = $_[0];
768 1         3 s/([\\'])/\\$1/g;
769 1         3 return qq('$_');
770             }
771              
772             1;
773             # ABSTRACT: Like Data::Dump, but with color
774              
775             __END__