line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Data::Dump; |
2
|
|
|
|
|
|
|
|
3
|
15
|
|
|
15
|
|
88396
|
use strict; |
|
15
|
|
|
|
|
32
|
|
|
15
|
|
|
|
|
763
|
|
4
|
15
|
|
|
15
|
|
85
|
use vars qw(@EXPORT @EXPORT_OK $VERSION $DEBUG); |
|
15
|
|
|
|
|
29
|
|
|
15
|
|
|
|
|
1341
|
|
5
|
15
|
|
|
15
|
|
10061
|
use subs qq(dump); |
|
15
|
|
|
|
|
388
|
|
|
15
|
|
|
|
|
69
|
|
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
require Exporter; |
8
|
|
|
|
|
|
|
*import = \&Exporter::import; |
9
|
|
|
|
|
|
|
@EXPORT = qw(dd ddx); |
10
|
|
|
|
|
|
|
@EXPORT_OK = qw(dump pp dumpf quote); |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
$VERSION = "1.23"; |
13
|
|
|
|
|
|
|
$DEBUG = 0; |
14
|
|
|
|
|
|
|
|
15
|
15
|
|
|
15
|
|
22103
|
use overload (); |
|
15
|
|
|
|
|
16732
|
|
|
15
|
|
|
|
|
531
|
|
16
|
15
|
|
|
15
|
|
101
|
use vars qw(%seen %refcnt @dump @fixup %require $TRY_BASE64 @FILTERS $INDENT); |
|
15
|
|
|
|
|
21
|
|
|
15
|
|
|
|
|
27029
|
|
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
$TRY_BASE64 = 50 unless defined $TRY_BASE64; |
19
|
|
|
|
|
|
|
$INDENT = " " unless defined $INDENT; |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
sub dump |
22
|
|
|
|
|
|
|
{ |
23
|
107
|
|
|
107
|
|
7955
|
local %seen; |
24
|
107
|
|
|
|
|
144
|
local %refcnt; |
25
|
107
|
|
|
|
|
124
|
local %require; |
26
|
107
|
|
|
|
|
142
|
local @fixup; |
27
|
|
|
|
|
|
|
|
28
|
107
|
100
|
|
|
|
1039
|
require Data::Dump::FilterContext if @FILTERS; |
29
|
|
|
|
|
|
|
|
30
|
107
|
|
|
|
|
150
|
my $name = "a"; |
31
|
107
|
|
|
|
|
114
|
my @dump; |
32
|
|
|
|
|
|
|
|
33
|
107
|
|
|
|
|
210
|
for my $v (@_) { |
34
|
155
|
|
|
|
|
353
|
my $val = _dump($v, $name, [], tied($v)); |
35
|
155
|
|
|
|
|
378
|
push(@dump, [$name, $val]); |
36
|
|
|
|
|
|
|
} continue { |
37
|
155
|
|
|
|
|
321
|
$name++; |
38
|
|
|
|
|
|
|
} |
39
|
|
|
|
|
|
|
|
40
|
107
|
|
|
|
|
158
|
my $out = ""; |
41
|
107
|
100
|
|
|
|
245
|
if (%require) { |
42
|
4
|
|
|
|
|
18
|
for (sort keys %require) { |
43
|
4
|
|
|
|
|
14
|
$out .= "require $_;\n"; |
44
|
|
|
|
|
|
|
} |
45
|
|
|
|
|
|
|
} |
46
|
107
|
100
|
|
|
|
214
|
if (%refcnt) { |
47
|
|
|
|
|
|
|
# output all those with refcounts first |
48
|
10
|
|
|
|
|
19
|
for (@dump) { |
49
|
27
|
|
|
|
|
32
|
my $name = $_->[0]; |
50
|
27
|
100
|
|
|
|
59
|
if ($refcnt{$name}) { |
51
|
10
|
|
|
|
|
30
|
$out .= "my \$$name = $_->[1];\n"; |
52
|
10
|
|
|
|
|
24
|
undef $_->[1]; |
53
|
|
|
|
|
|
|
} |
54
|
|
|
|
|
|
|
} |
55
|
10
|
|
|
|
|
19
|
for (@fixup) { |
56
|
17
|
|
|
|
|
140
|
$out .= "$_;\n"; |
57
|
|
|
|
|
|
|
} |
58
|
|
|
|
|
|
|
} |
59
|
|
|
|
|
|
|
|
60
|
107
|
|
|
|
|
176
|
my $paren = (@dump != 1); |
61
|
107
|
100
|
|
|
|
200
|
$out .= "(" if $paren; |
62
|
155
|
100
|
|
|
|
604
|
$out .= format_list($paren, undef, |
63
|
107
|
|
|
|
|
202
|
map {defined($_->[1]) ? $_->[1] : "\$".$_->[0]} |
64
|
|
|
|
|
|
|
@dump |
65
|
|
|
|
|
|
|
); |
66
|
107
|
100
|
|
|
|
660
|
$out .= ")" if $paren; |
67
|
|
|
|
|
|
|
|
68
|
107
|
100
|
100
|
|
|
486
|
if (%refcnt || %require) { |
69
|
13
|
|
|
|
|
27
|
$out .= ";\n"; |
70
|
13
|
|
|
|
|
528
|
$out =~ s/^/$INDENT/gm; |
71
|
13
|
|
|
|
|
90
|
$out = "do {\n$out}"; |
72
|
|
|
|
|
|
|
} |
73
|
|
|
|
|
|
|
|
74
|
107
|
50
|
|
|
|
226
|
print STDERR "$out\n" unless defined wantarray; |
75
|
107
|
|
|
|
|
2243
|
$out; |
76
|
|
|
|
|
|
|
} |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
*pp = \&dump; |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
sub dd { |
81
|
1
|
|
|
1
|
1
|
1142
|
print dump(@_), "\n"; |
82
|
|
|
|
|
|
|
} |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
sub ddx { |
85
|
2
|
|
|
2
|
1
|
56
|
my(undef, $file, $line) = caller; |
86
|
2
|
|
|
|
|
11
|
$file =~ s,.*[\\/],,; |
87
|
2
|
|
|
|
|
7
|
my $out = "$file:$line: " . dump(@_) . "\n"; |
88
|
2
|
|
|
|
|
495
|
$out =~ s/^/# /gm; |
89
|
2
|
|
|
|
|
119
|
print $out; |
90
|
|
|
|
|
|
|
} |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
sub dumpf { |
93
|
8
|
|
|
8
|
1
|
911
|
require Data::Dump::Filtered; |
94
|
8
|
|
|
|
|
22
|
goto &Data::Dump::Filtered::dump_filtered; |
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
sub _dump |
98
|
|
|
|
|
|
|
{ |
99
|
1106
|
|
|
1106
|
|
1443
|
my $ref = ref $_[0]; |
100
|
1106
|
100
|
|
|
|
1972
|
my $rval = $ref ? $_[0] : \$_[0]; |
101
|
1106
|
|
|
|
|
1023
|
shift; |
102
|
|
|
|
|
|
|
|
103
|
1106
|
|
|
|
|
1346
|
my($name, $idx, $dont_remember, $pclass, $pidx) = @_; |
104
|
|
|
|
|
|
|
|
105
|
1106
|
|
|
|
|
850
|
my($class, $type, $id); |
106
|
1106
|
|
|
|
|
2393
|
my $strval = overload::StrVal($rval); |
107
|
|
|
|
|
|
|
# Parse $strval without using regexps, in order not to clobber $1, $2,... |
108
|
1106
|
100
|
|
|
|
5102
|
if ((my $i = rindex($strval, "=")) >= 0) { |
109
|
26
|
|
|
|
|
40
|
$class = substr($strval, 0, $i); |
110
|
26
|
|
|
|
|
44
|
$strval = substr($strval, $i+1); |
111
|
|
|
|
|
|
|
} |
112
|
1106
|
50
|
|
|
|
2193
|
if ((my $i = index($strval, "(0x")) >= 0) { |
113
|
1106
|
|
|
|
|
1547
|
$type = substr($strval, 0, $i); |
114
|
1106
|
|
|
|
|
1509
|
$id = substr($strval, $i + 2, -1); |
115
|
|
|
|
|
|
|
} |
116
|
|
|
|
|
|
|
else { |
117
|
0
|
|
|
|
|
0
|
die "Can't parse " . overload::StrVal($rval); |
118
|
|
|
|
|
|
|
} |
119
|
1106
|
50
|
33
|
|
|
3299
|
if ($] < 5.008 && $type eq "SCALAR") { |
120
|
0
|
0
|
|
|
|
0
|
$type = "REF" if $ref eq "REF"; |
121
|
|
|
|
|
|
|
} |
122
|
1106
|
50
|
|
|
|
1682
|
warn "\$$name(@$idx) $class $type $id ($ref)" if $DEBUG; |
123
|
|
|
|
|
|
|
|
124
|
1106
|
|
|
|
|
943
|
my $out; |
125
|
|
|
|
|
|
|
my $comment; |
126
|
0
|
|
|
|
|
0
|
my $hide_keys; |
127
|
1106
|
100
|
|
|
|
1826
|
if (@FILTERS) { |
128
|
11
|
|
|
|
|
6
|
my $pself = ""; |
129
|
11
|
100
|
|
|
|
24
|
$pself = fullname("self", [@$idx[$pidx..(@$idx - 1)]]) if $pclass; |
130
|
11
|
|
|
|
|
29
|
my $ctx = Data::Dump::FilterContext->new($rval, $class, $type, $ref, $pclass, $pidx, $idx); |
131
|
11
|
|
|
|
|
8
|
my @bless; |
132
|
11
|
|
|
|
|
12
|
for my $filter (@FILTERS) { |
133
|
11
|
100
|
|
|
|
17
|
if (my $f = $filter->($ctx, $rval)) { |
134
|
6
|
100
|
|
|
|
30
|
if (my $v = $f->{object}) { |
135
|
1
|
|
|
|
|
2
|
local @FILTERS; |
136
|
1
|
|
|
|
|
25
|
$out = _dump($v, $name, $idx, 1); |
137
|
1
|
|
|
|
|
1
|
$dont_remember++; |
138
|
|
|
|
|
|
|
} |
139
|
6
|
100
|
|
|
|
11
|
if (defined(my $c = $f->{bless})) { |
140
|
1
|
|
|
|
|
1
|
push(@bless, $c); |
141
|
|
|
|
|
|
|
} |
142
|
6
|
100
|
|
|
|
9
|
if (my $c = $f->{comment}) { |
143
|
1
|
|
|
|
|
1
|
$comment = $c; |
144
|
|
|
|
|
|
|
} |
145
|
6
|
100
|
|
|
|
12
|
if (defined(my $c = $f->{dump})) { |
146
|
1
|
|
|
|
|
1
|
$out = $c; |
147
|
1
|
|
|
|
|
2
|
$dont_remember++; |
148
|
|
|
|
|
|
|
} |
149
|
6
|
100
|
|
|
|
15
|
if (my $h = $f->{hide_keys}) { |
150
|
2
|
50
|
|
|
|
4
|
if (ref($h) eq "ARRAY") { |
151
|
|
|
|
|
|
|
$hide_keys = sub { |
152
|
2
|
|
|
2
|
|
3
|
for my $k (@$h) { |
153
|
2
|
100
|
|
|
|
7
|
return 1 if $k eq $_[0]; |
154
|
|
|
|
|
|
|
} |
155
|
1
|
|
|
|
|
2
|
return 0; |
156
|
2
|
|
|
|
|
55
|
}; |
157
|
|
|
|
|
|
|
} |
158
|
|
|
|
|
|
|
} |
159
|
|
|
|
|
|
|
} |
160
|
|
|
|
|
|
|
} |
161
|
11
|
100
|
66
|
|
|
37
|
push(@bless, "") if defined($out) && !@bless; |
162
|
11
|
100
|
|
|
|
26
|
if (@bless) { |
163
|
3
|
|
|
|
|
3
|
$class = shift(@bless); |
164
|
3
|
50
|
|
|
|
14
|
warn "More than one filter callback tried to bless object" if @bless; |
165
|
|
|
|
|
|
|
} |
166
|
|
|
|
|
|
|
} |
167
|
|
|
|
|
|
|
|
168
|
1106
|
100
|
|
|
|
1780
|
unless ($dont_remember) { |
169
|
1091
|
100
|
|
|
|
2260
|
if (my $s = $seen{$id}) { |
170
|
19
|
|
|
|
|
22
|
my($sname, $sidx) = @$s; |
171
|
19
|
|
|
|
|
23
|
$refcnt{$sname}++; |
172
|
19
|
|
100
|
|
|
67
|
my $sref = fullname($sname, $sidx, |
173
|
|
|
|
|
|
|
($ref && $type eq "SCALAR")); |
174
|
19
|
50
|
|
|
|
63
|
warn "SEEN: [\$$name(@$idx)] => [\$$sname(@$sidx)] ($ref,$sref)" if $DEBUG; |
175
|
19
|
100
|
|
|
|
50
|
return $sref unless $sname eq $name; |
176
|
4
|
|
|
|
|
6
|
$refcnt{$name}++; |
177
|
4
|
|
|
|
|
8
|
push(@fixup, fullname($name,$idx)." = $sref"); |
178
|
4
|
100
|
66
|
|
|
20
|
return "do{my \$fix}" if @$idx && $idx->[-1] eq '$'; |
179
|
3
|
|
|
|
|
16
|
return "'fix'"; |
180
|
|
|
|
|
|
|
} |
181
|
1072
|
|
|
|
|
5126
|
$seen{$id} = [$name, $idx]; |
182
|
|
|
|
|
|
|
} |
183
|
|
|
|
|
|
|
|
184
|
1087
|
100
|
|
|
|
1875
|
if ($class) { |
185
|
27
|
|
|
|
|
50
|
$pclass = $class; |
186
|
27
|
|
|
|
|
36
|
$pidx = @$idx; |
187
|
|
|
|
|
|
|
} |
188
|
|
|
|
|
|
|
|
189
|
1087
|
100
|
100
|
|
|
4192
|
if (defined $out) { |
|
|
100
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
190
|
|
|
|
|
|
|
# keep it |
191
|
|
|
|
|
|
|
} |
192
|
|
|
|
|
|
|
elsif ($type eq "SCALAR" || $type eq "REF" || $type eq "REGEXP") { |
193
|
963
|
100
|
|
|
|
1213
|
if ($ref) { |
194
|
32
|
100
|
100
|
|
|
116
|
if ($class && $class eq "Regexp") { |
195
|
9
|
|
|
|
|
10
|
my $v = "$rval"; |
196
|
|
|
|
|
|
|
|
197
|
9
|
|
|
|
|
5
|
my $mod = ""; |
198
|
9
|
50
|
|
|
|
44
|
if ($v =~ /^\(\?\^?([msix-]*):([\x00-\xFF]*)\)\z/) { |
199
|
9
|
|
|
|
|
14
|
$mod = $1; |
200
|
9
|
|
|
|
|
10
|
$v = $2; |
201
|
9
|
|
|
|
|
8
|
$mod =~ s/-.*//; |
202
|
|
|
|
|
|
|
} |
203
|
|
|
|
|
|
|
|
204
|
9
|
|
|
|
|
9
|
my $sep = '/'; |
205
|
9
|
|
|
|
|
7
|
my $sep_count = ($v =~ tr/\///); |
206
|
9
|
100
|
|
|
|
14
|
if ($sep_count) { |
207
|
|
|
|
|
|
|
# see if we can find a better one |
208
|
4
|
|
|
|
|
6
|
for ('|', ',', ':', '#') { |
209
|
10
|
|
|
|
|
449
|
my $c = eval "\$v =~ tr/\Q$_\E//"; |
210
|
|
|
|
|
|
|
#print "SEP $_ $c $sep_count\n"; |
211
|
10
|
100
|
|
|
|
29
|
if ($c < $sep_count) { |
212
|
3
|
|
|
|
|
4
|
$sep = $_; |
213
|
3
|
|
|
|
|
3
|
$sep_count = $c; |
214
|
3
|
50
|
|
|
|
6
|
last if $sep_count == 0; |
215
|
|
|
|
|
|
|
} |
216
|
|
|
|
|
|
|
} |
217
|
|
|
|
|
|
|
} |
218
|
9
|
|
|
|
|
61
|
$v =~ s/\Q$sep\E/\\$sep/g; |
219
|
|
|
|
|
|
|
|
220
|
9
|
|
|
|
|
14
|
$out = "qr$sep$v$sep$mod"; |
221
|
9
|
|
|
|
|
11
|
undef($class); |
222
|
|
|
|
|
|
|
} |
223
|
|
|
|
|
|
|
else { |
224
|
23
|
100
|
|
|
|
75
|
delete $seen{$id} if $type eq "SCALAR"; # will be seen again shortly |
225
|
23
|
|
|
|
|
303
|
my $val = _dump($$rval, $name, [@$idx, "\$"], 0, $pclass, $pidx); |
226
|
23
|
100
|
|
|
|
76
|
$out = $class ? "do{\\(my \$o = $val)}" : "\\$val"; |
227
|
|
|
|
|
|
|
} |
228
|
|
|
|
|
|
|
} else { |
229
|
15
|
100
|
|
|
|
50769
|
if (!defined $$rval) { |
|
931
|
100
|
|
|
|
1627
|
|
230
|
3
|
|
|
|
|
8
|
$out = "undef"; |
231
|
|
|
|
|
|
|
} |
232
|
15
|
|
|
15
|
|
133
|
elsif (do {no warnings 'numeric'; $$rval + 0 eq $$rval}) { |
|
15
|
|
|
|
|
28
|
|
|
928
|
|
|
|
|
5962
|
|
233
|
615
|
|
|
|
|
660
|
$out = $$rval; |
234
|
|
|
|
|
|
|
} |
235
|
|
|
|
|
|
|
else { |
236
|
313
|
|
|
|
|
663
|
$out = str($$rval); |
237
|
|
|
|
|
|
|
} |
238
|
931
|
100
|
100
|
|
|
2044
|
if ($class && !@$idx) { |
239
|
|
|
|
|
|
|
# Top is an object, not a reference to one as perl needs |
240
|
1
|
|
|
|
|
4
|
$refcnt{$name}++; |
241
|
1
|
|
|
|
|
6
|
my $obj = fullname($name, $idx); |
242
|
1
|
|
|
|
|
6
|
my $cl = quote($class); |
243
|
1
|
|
|
|
|
4
|
push(@fixup, "bless \\$obj, $cl"); |
244
|
|
|
|
|
|
|
} |
245
|
|
|
|
|
|
|
} |
246
|
|
|
|
|
|
|
} |
247
|
|
|
|
|
|
|
elsif ($type eq "GLOB") { |
248
|
38
|
100
|
|
|
|
56
|
if ($ref) { |
249
|
5
|
|
|
|
|
12
|
delete $seen{$id}; |
250
|
5
|
|
|
|
|
41
|
my $val = _dump($$rval, $name, [@$idx, "*"], 0, $pclass, $pidx); |
251
|
5
|
|
|
|
|
8
|
$out = "\\$val"; |
252
|
5
|
100
|
|
|
|
20
|
if ($out =~ /^\\\*Symbol::/) { |
253
|
3
|
|
|
|
|
8
|
$require{Symbol}++; |
254
|
3
|
|
|
|
|
5
|
$out = "Symbol::gensym()"; |
255
|
|
|
|
|
|
|
} |
256
|
|
|
|
|
|
|
} else { |
257
|
33
|
|
|
|
|
129
|
my $val = "$$rval"; |
258
|
33
|
|
|
|
|
64
|
$out = "$$rval"; |
259
|
|
|
|
|
|
|
|
260
|
33
|
|
|
|
|
54
|
for my $k (qw(SCALAR ARRAY HASH)) { |
261
|
99
|
|
|
|
|
125
|
my $gval = *$$rval{$k}; |
262
|
99
|
100
|
|
|
|
202
|
next unless defined $gval; |
263
|
40
|
100
|
100
|
|
|
157
|
next if $k eq "SCALAR" && ! defined $$gval; # always there |
264
|
12
|
|
|
|
|
17
|
my $f = scalar @fixup; |
265
|
12
|
|
|
|
|
23
|
push(@fixup, "RESERVED"); # overwritten after _dump() below |
266
|
12
|
|
|
|
|
70
|
$gval = _dump($gval, $name, [@$idx, "*{$k}"], 0, $pclass, $pidx); |
267
|
12
|
|
|
|
|
29
|
$refcnt{$name}++; |
268
|
12
|
|
|
|
|
29
|
my $gname = fullname($name, $idx); |
269
|
12
|
|
|
|
|
62
|
$fixup[$f] = "$gname = $gval"; #XXX indent $gval |
270
|
|
|
|
|
|
|
} |
271
|
|
|
|
|
|
|
} |
272
|
|
|
|
|
|
|
} |
273
|
|
|
|
|
|
|
elsif ($type eq "ARRAY") { |
274
|
18
|
|
|
|
|
24
|
my @vals; |
275
|
18
|
|
|
|
|
50
|
my $tied = tied_str(tied(@$rval)); |
276
|
18
|
|
|
|
|
27
|
my $i = 0; |
277
|
18
|
|
|
|
|
533
|
for my $v (@$rval) { |
278
|
291
|
|
|
|
|
1253
|
push(@vals, _dump($v, $name, [@$idx, "[$i]"], $tied, $pclass, $pidx)); |
279
|
291
|
|
|
|
|
539
|
$i++; |
280
|
|
|
|
|
|
|
} |
281
|
18
|
|
|
|
|
77
|
$out = "[" . format_list(1, $tied, @vals) . "]"; |
282
|
|
|
|
|
|
|
} |
283
|
|
|
|
|
|
|
elsif ($type eq "HASH") { |
284
|
54
|
|
|
|
|
55
|
my(@keys, @vals); |
285
|
54
|
|
|
|
|
196
|
my $tied = tied_str(tied(%$rval)); |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
# statistics to determine variation in key lengths |
288
|
54
|
|
|
|
|
66
|
my $kstat_max = 0; |
289
|
54
|
|
|
|
|
60
|
my $kstat_sum = 0; |
290
|
54
|
|
|
|
|
64
|
my $kstat_sum2 = 0; |
291
|
|
|
|
|
|
|
|
292
|
54
|
|
|
|
|
484
|
my @orig_keys = keys %$rval; |
293
|
54
|
100
|
|
|
|
180
|
if ($hide_keys) { |
294
|
1
|
|
|
|
|
3
|
@orig_keys = grep !$hide_keys->($_), @orig_keys; |
295
|
|
|
|
|
|
|
} |
296
|
54
|
|
|
|
|
56
|
my $text_keys = 0; |
297
|
54
|
|
|
|
|
94
|
for (@orig_keys) { |
298
|
40
|
100
|
|
|
|
291
|
$text_keys++, last unless /^[-+]?(?:0|[1-9]\d*)(?:\.\d+)?\z/; |
299
|
|
|
|
|
|
|
} |
300
|
|
|
|
|
|
|
|
301
|
54
|
100
|
|
|
|
108
|
if ($text_keys) { |
302
|
33
|
|
|
|
|
137
|
@orig_keys = sort { lc($a) cmp lc($b) } @orig_keys; |
|
3529
|
|
|
|
|
3055
|
|
303
|
|
|
|
|
|
|
} |
304
|
|
|
|
|
|
|
else { |
305
|
21
|
|
|
|
|
43
|
@orig_keys = sort { $a <=> $b } @orig_keys; |
|
5
|
|
|
|
|
15
|
|
306
|
|
|
|
|
|
|
} |
307
|
|
|
|
|
|
|
|
308
|
54
|
|
|
|
|
53
|
my $quote; |
309
|
54
|
|
|
|
|
85
|
for my $key (@orig_keys) { |
310
|
266
|
100
|
|
|
|
801
|
next if $key =~ /^-?[a-zA-Z_]\w*\z/; |
311
|
10
|
100
|
|
|
|
39
|
next if $key =~ /^-?[1-9]\d{0,8}\z/; |
312
|
6
|
|
|
|
|
11
|
$quote++; |
313
|
6
|
|
|
|
|
8
|
last; |
314
|
|
|
|
|
|
|
} |
315
|
|
|
|
|
|
|
|
316
|
54
|
|
|
|
|
93
|
for my $key (@orig_keys) { |
317
|
619
|
|
|
|
|
964
|
my $val = \$rval->{$key}; # capture value before we modify $key |
318
|
619
|
100
|
|
|
|
1181
|
$key = quote($key) if $quote; |
319
|
619
|
100
|
|
|
|
1090
|
$kstat_max = length($key) if length($key) > $kstat_max; |
320
|
619
|
|
|
|
|
531
|
$kstat_sum += length($key); |
321
|
619
|
|
|
|
|
707
|
$kstat_sum2 += length($key)*length($key); |
322
|
|
|
|
|
|
|
|
323
|
619
|
|
|
|
|
701
|
push(@keys, $key); |
324
|
619
|
|
|
|
|
2196
|
push(@vals, _dump($$val, $name, [@$idx, "{$key}"], $tied, $pclass, $pidx)); |
325
|
|
|
|
|
|
|
} |
326
|
54
|
|
|
|
|
77
|
my $nl = ""; |
327
|
54
|
|
|
|
|
60
|
my $klen_pad = 0; |
328
|
54
|
|
|
|
|
445
|
my $tmp = "@keys @vals"; |
329
|
54
|
100
|
66
|
|
|
850
|
if (length($tmp) > 60 || $tmp =~ /\n/ || $tied) { |
|
|
|
100
|
|
|
|
|
330
|
15
|
|
|
|
|
23
|
$nl = "\n"; |
331
|
|
|
|
|
|
|
|
332
|
|
|
|
|
|
|
# Determine what padding to add |
333
|
15
|
100
|
|
|
|
53
|
if ($kstat_max < 4) { |
|
|
50
|
|
|
|
|
|
334
|
5
|
|
|
|
|
8
|
$klen_pad = $kstat_max; |
335
|
|
|
|
|
|
|
} |
336
|
|
|
|
|
|
|
elsif (@keys >= 2) { |
337
|
10
|
|
|
|
|
17
|
my $n = @keys; |
338
|
10
|
|
|
|
|
22
|
my $avg = $kstat_sum/$n; |
339
|
10
|
|
|
|
|
75
|
my $stddev = sqrt(($kstat_sum2 - $n * $avg * $avg) / ($n - 1)); |
340
|
|
|
|
|
|
|
|
341
|
|
|
|
|
|
|
# I am not actually very happy with this heuristics |
342
|
10
|
100
|
|
|
|
36
|
if ($stddev / $kstat_max < 0.25) { |
343
|
6
|
|
|
|
|
13
|
$klen_pad = $kstat_max; |
344
|
|
|
|
|
|
|
} |
345
|
10
|
50
|
|
|
|
25
|
if ($DEBUG) { |
346
|
0
|
|
|
|
|
0
|
push(@keys, "__S"); |
347
|
0
|
|
|
|
|
0
|
push(@vals, sprintf("%.2f (%d/%.1f/%.1f)", |
348
|
|
|
|
|
|
|
$stddev / $kstat_max, |
349
|
|
|
|
|
|
|
$kstat_max, $avg, $stddev)); |
350
|
|
|
|
|
|
|
} |
351
|
|
|
|
|
|
|
} |
352
|
|
|
|
|
|
|
} |
353
|
54
|
|
|
|
|
101
|
$out = "{$nl"; |
354
|
54
|
100
|
|
|
|
99
|
$out .= "$INDENT# $tied$nl" if $tied; |
355
|
54
|
|
|
|
|
117
|
while (@keys) { |
356
|
619
|
|
|
|
|
623
|
my $key = shift @keys; |
357
|
619
|
|
|
|
|
554
|
my $val = shift @vals; |
358
|
619
|
100
|
|
|
|
1006
|
my $vpad = $INDENT . (" " x ($klen_pad ? $klen_pad + 4 : 0)); |
359
|
619
|
|
|
|
|
766
|
$val =~ s/\n/\n$vpad/gm; |
360
|
619
|
100
|
|
|
|
721
|
my $kpad = $nl ? $INDENT : " "; |
361
|
619
|
100
|
100
|
|
|
2023
|
$key .= " " x ($klen_pad - length($key)) if $nl && $klen_pad > length($key); |
362
|
619
|
|
|
|
|
1319
|
$out .= "$kpad$key => $val,$nl"; |
363
|
|
|
|
|
|
|
} |
364
|
54
|
100
|
|
|
|
204
|
$out =~ s/,$/ / unless $nl; |
365
|
54
|
|
|
|
|
248
|
$out .= "}"; |
366
|
|
|
|
|
|
|
} |
367
|
|
|
|
|
|
|
elsif ($type eq "CODE") { |
368
|
1
|
|
|
|
|
3
|
$out = 'sub { ... }'; |
369
|
|
|
|
|
|
|
} |
370
|
|
|
|
|
|
|
elsif ($type eq "VSTRING") { |
371
|
11
|
100
|
|
|
|
45
|
$out = sprintf +($ref ? '\v%vd' : 'v%vd'), $$rval; |
372
|
|
|
|
|
|
|
} |
373
|
|
|
|
|
|
|
else { |
374
|
0
|
|
|
|
|
0
|
warn "Can't handle $type data"; |
375
|
0
|
|
|
|
|
0
|
$out = "'#$type#'"; |
376
|
|
|
|
|
|
|
} |
377
|
|
|
|
|
|
|
|
378
|
1087
|
100
|
100
|
|
|
2510
|
if ($class && $ref) { |
379
|
14
|
|
|
|
|
43
|
$out = "bless($out, " . quote($class) . ")"; |
380
|
|
|
|
|
|
|
} |
381
|
1087
|
100
|
|
|
|
1759
|
if ($comment) { |
382
|
1
|
|
|
|
|
5
|
$comment =~ s/^/# /gm; |
383
|
1
|
50
|
|
|
|
4
|
$comment .= "\n" unless $comment =~ /\n\z/; |
384
|
1
|
|
|
|
|
4
|
$comment =~ s/^#[ \t]+\n/\n/; |
385
|
1
|
|
|
|
|
1
|
$out = "$comment$out"; |
386
|
|
|
|
|
|
|
} |
387
|
1087
|
|
|
|
|
3113
|
return $out; |
388
|
|
|
|
|
|
|
} |
389
|
|
|
|
|
|
|
|
390
|
|
|
|
|
|
|
sub tied_str { |
391
|
72
|
|
|
72
|
0
|
83
|
my $tied = shift; |
392
|
72
|
100
|
|
|
|
155
|
if ($tied) { |
393
|
2
|
50
|
|
|
|
6
|
if (my $tied_ref = ref($tied)) { |
394
|
2
|
|
|
|
|
5
|
$tied = "tied $tied_ref"; |
395
|
|
|
|
|
|
|
} |
396
|
|
|
|
|
|
|
else { |
397
|
0
|
|
|
|
|
0
|
$tied = "tied"; |
398
|
|
|
|
|
|
|
} |
399
|
|
|
|
|
|
|
} |
400
|
72
|
|
|
|
|
103
|
return $tied; |
401
|
|
|
|
|
|
|
} |
402
|
|
|
|
|
|
|
|
403
|
|
|
|
|
|
|
sub fullname |
404
|
|
|
|
|
|
|
{ |
405
|
41
|
|
|
41
|
0
|
51
|
my($name, $idx, $ref) = @_; |
406
|
41
|
|
|
|
|
66
|
substr($name, 0, 0) = "\$"; |
407
|
|
|
|
|
|
|
|
408
|
41
|
|
|
|
|
63
|
my @i = @$idx; # need copy in order to not modify @$idx |
409
|
41
|
100
|
100
|
|
|
119
|
if ($ref && @i && $i[0] eq "\$") { |
|
|
|
100
|
|
|
|
|
410
|
2
|
|
|
|
|
2
|
shift(@i); # remove one deref |
411
|
2
|
|
|
|
|
3
|
$ref = 0; |
412
|
|
|
|
|
|
|
} |
413
|
41
|
|
100
|
|
|
165
|
while (@i && $i[0] eq "\$") { |
414
|
5
|
|
|
|
|
4
|
shift @i; |
415
|
5
|
|
|
|
|
12
|
$name = "\$$name"; |
416
|
|
|
|
|
|
|
} |
417
|
|
|
|
|
|
|
|
418
|
41
|
|
|
|
|
36
|
my $last_was_index; |
419
|
41
|
|
|
|
|
54
|
for my $i (@i) { |
420
|
35
|
100
|
100
|
|
|
163
|
if ($i eq "*" || $i eq "\$") { |
|
|
100
|
|
|
|
|
|
421
|
7
|
|
|
|
|
8
|
$last_was_index = 0; |
422
|
7
|
|
|
|
|
379
|
$name = "$i\{$name}"; |
423
|
|
|
|
|
|
|
} elsif ($i =~ s/^\*//) { |
424
|
2
|
|
|
|
|
3
|
$name .= $i; |
425
|
2
|
|
|
|
|
4
|
$last_was_index++; |
426
|
|
|
|
|
|
|
} else { |
427
|
26
|
100
|
|
|
|
60
|
$name .= "->" unless $last_was_index++; |
428
|
26
|
|
|
|
|
49
|
$name .= $i; |
429
|
|
|
|
|
|
|
} |
430
|
|
|
|
|
|
|
} |
431
|
41
|
100
|
|
|
|
78
|
$name = "\\$name" if $ref; |
432
|
41
|
|
|
|
|
89
|
$name; |
433
|
|
|
|
|
|
|
} |
434
|
|
|
|
|
|
|
|
435
|
|
|
|
|
|
|
sub format_list |
436
|
|
|
|
|
|
|
{ |
437
|
125
|
|
|
125
|
0
|
169
|
my $paren = shift; |
438
|
125
|
|
|
|
|
111
|
my $comment = shift; |
439
|
125
|
100
|
|
|
|
562
|
my $indent_lim = $paren ? 0 : 1; |
440
|
125
|
100
|
|
|
|
252
|
if (@_ > 3) { |
441
|
|
|
|
|
|
|
# can we use range operator to shorten the list? |
442
|
12
|
|
|
|
|
19
|
my $i = 0; |
443
|
12
|
|
|
|
|
38
|
while ($i < @_) { |
444
|
40
|
|
|
|
|
48
|
my $j = $i + 1; |
445
|
40
|
|
|
|
|
53
|
my $v = $_[$i]; |
446
|
40
|
|
|
|
|
71
|
while ($j < @_) { |
447
|
|
|
|
|
|
|
# XXX allow string increment too? |
448
|
316
|
100
|
100
|
|
|
2680
|
if ($v eq "0" || $v =~ /^-?[1-9]\d{0,9}\z/) { |
|
|
100
|
|
|
|
|
|
449
|
37
|
|
|
|
|
59
|
$v++; |
450
|
|
|
|
|
|
|
} |
451
|
|
|
|
|
|
|
elsif ($v =~ /^"([A-Za-z]{1,3}\d*)"\z/) { |
452
|
266
|
|
|
|
|
543
|
$v = $1; |
453
|
266
|
|
|
|
|
287
|
$v++; |
454
|
266
|
|
|
|
|
383
|
$v = qq("$v"); |
455
|
|
|
|
|
|
|
} |
456
|
|
|
|
|
|
|
else { |
457
|
13
|
|
|
|
|
12
|
last; |
458
|
|
|
|
|
|
|
} |
459
|
303
|
100
|
|
|
|
712
|
last if $_[$j] ne $v; |
460
|
289
|
|
|
|
|
584
|
$j++; |
461
|
|
|
|
|
|
|
} |
462
|
40
|
100
|
|
|
|
90
|
if ($j - $i > 3) { |
463
|
9
|
|
|
|
|
55
|
splice(@_, $i, $j - $i, "$_[$i] .. $_[$j-1]"); |
464
|
|
|
|
|
|
|
} |
465
|
40
|
|
|
|
|
82
|
$i++; |
466
|
|
|
|
|
|
|
} |
467
|
|
|
|
|
|
|
} |
468
|
125
|
|
|
|
|
291
|
my $tmp = "@_"; |
469
|
125
|
100
|
33
|
|
|
670
|
if ($comment || (@_ > $indent_lim && (length($tmp) > 60 || $tmp =~ /\n/))) { |
|
|
|
66
|
|
|
|
|
|
|
|
66
|
|
|
|
|
470
|
1
|
|
|
|
|
3
|
my @elem = @_; |
471
|
1
|
|
|
|
|
3
|
for (@elem) { s/^/$INDENT/gm; } |
|
1
|
|
|
|
|
7
|
|
472
|
1
|
50
|
|
|
|
12
|
return "\n" . ($comment ? "$INDENT# $comment\n" : "") . |
473
|
|
|
|
|
|
|
join(",\n", @elem, ""); |
474
|
|
|
|
|
|
|
} else { |
475
|
124
|
|
|
|
|
452
|
return join(", ", @_); |
476
|
|
|
|
|
|
|
} |
477
|
|
|
|
|
|
|
} |
478
|
|
|
|
|
|
|
|
479
|
|
|
|
|
|
|
sub str { |
480
|
313
|
100
|
|
313
|
0
|
916
|
if (length($_[0]) > 20) { |
481
|
14
|
|
|
|
|
28
|
for ($_[0]) { |
482
|
|
|
|
|
|
|
# Check for repeated string |
483
|
14
|
100
|
|
|
|
71
|
if (/^(.)\1\1\1/s) { |
484
|
|
|
|
|
|
|
# seems to be a repeating sequence, let's check if it really is |
485
|
|
|
|
|
|
|
# without backtracking |
486
|
4
|
50
|
|
|
|
48849
|
unless (/[^\Q$1\E]/) { |
487
|
4
|
|
|
|
|
14
|
my $base = quote($1); |
488
|
4
|
|
|
|
|
6
|
my $repeat = length; |
489
|
4
|
|
|
|
|
16
|
return "($base x $repeat)" |
490
|
|
|
|
|
|
|
} |
491
|
|
|
|
|
|
|
} |
492
|
|
|
|
|
|
|
# Length protection because the RE engine will blow the stack [RT#33520] |
493
|
10
|
100
|
66
|
|
|
147
|
if (length($_) < 16 * 1024 && /^(.{2,5}?)\1*\z/s) { |
494
|
2
|
|
|
|
|
10
|
my $base = quote($1); |
495
|
2
|
|
|
|
|
6
|
my $repeat = length($_)/length($1); |
496
|
2
|
|
|
|
|
35
|
return "($base x $repeat)"; |
497
|
|
|
|
|
|
|
} |
498
|
|
|
|
|
|
|
} |
499
|
|
|
|
|
|
|
} |
500
|
|
|
|
|
|
|
|
501
|
307
|
|
|
|
|
504
|
local $_ = "e; |
502
|
|
|
|
|
|
|
|
503
|
307
|
100
|
100
|
|
|
918
|
if (length($_) > 40 && !/\\x\{/ && length($_) > (length($_[0]) * 2)) { |
|
|
|
100
|
|
|
|
|
504
|
|
|
|
|
|
|
# too much binary data, better to represent as a hex/base64 string |
505
|
|
|
|
|
|
|
|
506
|
|
|
|
|
|
|
# Base64 is more compact than hex when string is longer than |
507
|
|
|
|
|
|
|
# 17 bytes (not counting any require statement needed). |
508
|
|
|
|
|
|
|
# But on the other hand, hex is much more readable. |
509
|
3
|
100
|
66
|
|
|
36
|
if ($TRY_BASE64 && length($_[0]) > $TRY_BASE64 && |
|
|
|
66
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
|
66
|
|
|
|
|
510
|
|
|
|
|
|
|
(defined &utf8::is_utf8 && !utf8::is_utf8($_[0])) && |
511
|
1
|
|
|
|
|
9
|
eval { require MIME::Base64 }) |
512
|
|
|
|
|
|
|
{ |
513
|
1
|
|
|
|
|
2
|
$require{"MIME::Base64"}++; |
514
|
1
|
|
|
|
|
16
|
return "MIME::Base64::decode(\"" . |
515
|
|
|
|
|
|
|
MIME::Base64::encode($_[0],"") . |
516
|
|
|
|
|
|
|
"\")"; |
517
|
|
|
|
|
|
|
} |
518
|
2
|
|
|
|
|
22
|
return "pack(\"H*\",\"" . unpack("H*", $_[0]) . "\")"; |
519
|
|
|
|
|
|
|
} |
520
|
|
|
|
|
|
|
|
521
|
304
|
|
|
|
|
741
|
return $_; |
522
|
|
|
|
|
|
|
} |
523
|
|
|
|
|
|
|
|
524
|
|
|
|
|
|
|
my %esc = ( |
525
|
|
|
|
|
|
|
"\a" => "\\a", |
526
|
|
|
|
|
|
|
"\b" => "\\b", |
527
|
|
|
|
|
|
|
"\t" => "\\t", |
528
|
|
|
|
|
|
|
"\n" => "\\n", |
529
|
|
|
|
|
|
|
"\f" => "\\f", |
530
|
|
|
|
|
|
|
"\r" => "\\r", |
531
|
|
|
|
|
|
|
"\e" => "\\e", |
532
|
|
|
|
|
|
|
); |
533
|
|
|
|
|
|
|
|
534
|
|
|
|
|
|
|
# put a string value in double quotes |
535
|
|
|
|
|
|
|
sub quote { |
536
|
708
|
|
|
708
|
1
|
1368
|
local($_) = $_[0]; |
537
|
|
|
|
|
|
|
# If there are many '"' we might want to use qq() instead |
538
|
708
|
|
|
|
|
1353
|
s/([\\\"\@\$])/\\$1/g; |
539
|
708
|
100
|
|
|
|
3393
|
return qq("$_") unless /[^\040-\176]/; # fast exit |
540
|
|
|
|
|
|
|
|
541
|
16
|
|
|
|
|
89
|
s/([\a\b\t\n\f\r\e])/$esc{$1}/g; |
542
|
|
|
|
|
|
|
|
543
|
|
|
|
|
|
|
# no need for 3 digits in escape for these |
544
|
16
|
|
|
|
|
43
|
s/([\0-\037])(?!\d)/sprintf('\\%o',ord($1))/eg; |
|
1103
|
|
|
|
|
2057
|
|
545
|
|
|
|
|
|
|
|
546
|
16
|
|
|
|
|
56
|
s/([\0-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg; |
|
393
|
|
|
|
|
636
|
|
547
|
16
|
|
|
|
|
99
|
s/([^\040-\176])/sprintf('\\x{%X}',ord($1))/eg; |
|
105
|
|
|
|
|
305
|
|
548
|
|
|
|
|
|
|
|
549
|
16
|
|
|
|
|
109
|
return qq("$_"); |
550
|
|
|
|
|
|
|
} |
551
|
|
|
|
|
|
|
|
552
|
|
|
|
|
|
|
1; |
553
|
|
|
|
|
|
|
|
554
|
|
|
|
|
|
|
__END__ |