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