line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Data::Dump::Streamer; |
2
|
26
|
|
|
26
|
|
1401799
|
use strict; |
|
26
|
|
|
|
|
342
|
|
|
26
|
|
|
|
|
1102
|
|
3
|
26
|
|
|
26
|
|
145
|
use warnings; |
|
26
|
|
|
|
|
48
|
|
|
26
|
|
|
|
|
705
|
|
4
|
26
|
|
|
26
|
|
145
|
use warnings::register; |
|
26
|
|
|
|
|
48
|
|
|
26
|
|
|
|
|
4414
|
|
5
|
|
|
|
|
|
|
|
6
|
26
|
|
|
26
|
|
176
|
use B (); |
|
26
|
|
|
|
|
62
|
|
|
26
|
|
|
|
|
498
|
|
7
|
26
|
|
|
26
|
|
132
|
use B::Deparse (); |
|
26
|
|
|
|
|
66
|
|
|
26
|
|
|
|
|
472
|
|
8
|
26
|
|
|
26
|
|
14507
|
use B::Utils (); |
|
26
|
|
|
|
|
149092
|
|
|
26
|
|
|
|
|
667
|
|
9
|
26
|
|
|
26
|
|
16490
|
use Data::Dumper (); |
|
26
|
|
|
|
|
174809
|
|
|
26
|
|
|
|
|
698
|
|
10
|
26
|
|
|
26
|
|
188
|
use DynaLoader (); |
|
26
|
|
|
|
|
65
|
|
|
26
|
|
|
|
|
360
|
|
11
|
26
|
|
|
26
|
|
112
|
use Exporter (); |
|
26
|
|
|
|
|
56
|
|
|
26
|
|
|
|
|
341
|
|
12
|
26
|
|
|
26
|
|
12749
|
use IO::File (); |
|
26
|
|
|
|
|
225863
|
|
|
26
|
|
|
|
|
640
|
|
13
|
26
|
|
|
26
|
|
187
|
use Symbol (); |
|
26
|
|
|
|
|
72
|
|
|
26
|
|
|
|
|
365
|
|
14
|
26
|
|
|
26
|
|
19310
|
use Text::Abbrev (); |
|
26
|
|
|
|
|
1335
|
|
|
26
|
|
|
|
|
700
|
|
15
|
26
|
|
|
26
|
|
18340
|
use Text::Balanced (); |
|
26
|
|
|
|
|
327823
|
|
|
26
|
|
|
|
|
860
|
|
16
|
26
|
|
|
26
|
|
208
|
use overload (); |
|
26
|
|
|
|
|
57
|
|
|
26
|
|
|
|
|
471
|
|
17
|
|
|
|
|
|
|
|
18
|
26
|
|
|
26
|
|
21344
|
use Data::Dump::Streamer::_::Printers; |
|
26
|
|
|
|
|
79
|
|
|
26
|
|
|
|
|
1234
|
|
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
# The style of this file is determined by: |
21
|
|
|
|
|
|
|
# |
22
|
|
|
|
|
|
|
# perltidy -w -ple -bbb -bbc -bbs -nolq -l=80 -noll -nola -nwls='=' \ |
23
|
|
|
|
|
|
|
# -isbc -nolc -otr -kis -ci=4 -se -sot -sct -nsbl -pt=2 -fs \ |
24
|
|
|
|
|
|
|
# -fsb='#start-no-tidy' -fse='#end-no-tidy' -cpb -bfvt=2 |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
# use overload qw("" printit); # does diabolical stuff. |
27
|
|
|
|
|
|
|
|
28
|
26
|
|
|
|
|
3005
|
use vars qw( |
29
|
|
|
|
|
|
|
$VERSION |
30
|
|
|
|
|
|
|
$XS_VERSION |
31
|
|
|
|
|
|
|
$AUTOLOAD |
32
|
|
|
|
|
|
|
@ISA |
33
|
|
|
|
|
|
|
@EXPORT @EXPORT_OK @EXPORT_FAIL %EXPORT_TAGS |
34
|
|
|
|
|
|
|
%Freeze |
35
|
|
|
|
|
|
|
%Thaw |
36
|
|
|
|
|
|
|
$DEBUG |
37
|
|
|
|
|
|
|
$HasPadWalker |
38
|
26
|
|
|
26
|
|
156
|
); |
|
26
|
|
|
|
|
56
|
|
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
$DEBUG= 0; |
41
|
26
|
|
|
26
|
|
1967
|
BEGIN { $HasPadWalker= eval "use PadWalker 0.99; 1"; } |
|
26
|
|
|
26
|
|
11506
|
|
|
26
|
|
|
|
|
17699
|
|
|
26
|
|
|
|
|
852
|
|
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
BEGIN { |
44
|
26
|
|
|
26
|
|
127
|
$VERSION= '2.42'; |
45
|
26
|
|
|
|
|
61
|
$XS_VERSION= $VERSION; |
46
|
26
|
|
|
|
|
1555
|
$VERSION= eval $VERSION; # used for beta stuff. |
47
|
26
|
|
|
|
|
528
|
@ISA= qw(Exporter DynaLoader); |
48
|
26
|
|
|
|
|
123
|
@EXPORT= qw(Dump DumpLex DumpVars); |
49
|
26
|
|
|
|
|
177
|
@EXPORT_OK= qw( |
50
|
|
|
|
|
|
|
Dump |
51
|
|
|
|
|
|
|
DumpLex |
52
|
|
|
|
|
|
|
DumpVars |
53
|
|
|
|
|
|
|
Stream |
54
|
|
|
|
|
|
|
alias_av |
55
|
|
|
|
|
|
|
alias_hv |
56
|
|
|
|
|
|
|
alias_ref |
57
|
|
|
|
|
|
|
push_alias |
58
|
|
|
|
|
|
|
dualvar |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
alias_to |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
blessed |
63
|
|
|
|
|
|
|
reftype |
64
|
|
|
|
|
|
|
refaddr |
65
|
|
|
|
|
|
|
refcount |
66
|
|
|
|
|
|
|
sv_refcount |
67
|
|
|
|
|
|
|
looks_like_number |
68
|
|
|
|
|
|
|
regex |
69
|
|
|
|
|
|
|
readonly |
70
|
|
|
|
|
|
|
make_ro |
71
|
|
|
|
|
|
|
_make_ro |
72
|
|
|
|
|
|
|
reftype_or_glob |
73
|
|
|
|
|
|
|
refaddr_or_glob |
74
|
|
|
|
|
|
|
globname |
75
|
|
|
|
|
|
|
is_numeric |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
all_keys |
78
|
|
|
|
|
|
|
legal_keys |
79
|
|
|
|
|
|
|
hidden_keys |
80
|
|
|
|
|
|
|
lock_ref_keys |
81
|
|
|
|
|
|
|
lock_keys |
82
|
|
|
|
|
|
|
lock_ref_keys_plus |
83
|
|
|
|
|
|
|
lock_keys_plus |
84
|
|
|
|
|
|
|
SvREADONLY_ref |
85
|
|
|
|
|
|
|
SvREFCNT_ref |
86
|
|
|
|
|
|
|
isweak |
87
|
|
|
|
|
|
|
weaken |
88
|
|
|
|
|
|
|
weak_refcount |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
readonly_set |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
Dumper |
93
|
|
|
|
|
|
|
DDumper |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
alias |
96
|
|
|
|
|
|
|
sqz |
97
|
|
|
|
|
|
|
usqz |
98
|
|
|
|
|
|
|
); |
99
|
|
|
|
|
|
|
|
100
|
26
|
|
|
|
|
563
|
%EXPORT_TAGS= ( |
101
|
|
|
|
|
|
|
undump => [ |
102
|
|
|
|
|
|
|
qw( alias_av alias_hv alias_ref make_ro |
103
|
|
|
|
|
|
|
lock_ref_keys |
104
|
|
|
|
|
|
|
lock_keys |
105
|
|
|
|
|
|
|
lock_ref_keys_plus |
106
|
|
|
|
|
|
|
lock_keys_plus |
107
|
|
|
|
|
|
|
alias_to |
108
|
|
|
|
|
|
|
dualvar |
109
|
|
|
|
|
|
|
weaken |
110
|
|
|
|
|
|
|
usqz |
111
|
|
|
|
|
|
|
) |
112
|
|
|
|
|
|
|
], |
113
|
|
|
|
|
|
|
special => [qw( readonly_set )], |
114
|
|
|
|
|
|
|
all => [ @EXPORT, @EXPORT_OK ], |
115
|
|
|
|
|
|
|
alias => [qw( alias_av alias_hv alias_ref push_alias )], |
116
|
|
|
|
|
|
|
bin => [@EXPORT_OK], |
117
|
|
|
|
|
|
|
Dumper => [qw( Dumper DDumper )], |
118
|
|
|
|
|
|
|
util => [ qw ( |
119
|
|
|
|
|
|
|
dualvar |
120
|
|
|
|
|
|
|
blessed reftype refaddr refcount sv_refcount |
121
|
|
|
|
|
|
|
readonly looks_like_number regex is_numeric |
122
|
|
|
|
|
|
|
make_ro readonly_set reftype_or_glob |
123
|
|
|
|
|
|
|
refaddr_or_glob globname |
124
|
|
|
|
|
|
|
weak_refcount isweak weaken |
125
|
|
|
|
|
|
|
) |
126
|
|
|
|
|
|
|
], |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
); |
129
|
|
|
|
|
|
|
|
130
|
0
|
|
|
0
|
0
|
0
|
sub alias_to { return shift } |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
#warn $VERSION; |
133
|
26
|
|
|
|
|
11028
|
Data::Dump::Streamer->bootstrap($XS_VERSION); |
134
|
26
|
50
|
|
|
|
246
|
if ($] >= 5.013010) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
# As I write this, 5.13.10 doesn't exist so I'm guessing that |
137
|
|
|
|
|
|
|
# we can begin using the ordinary core function again. |
138
|
26
|
50
|
|
26
|
|
2195
|
eval q[ |
|
26
|
|
|
|
|
210
|
|
|
26
|
|
|
|
|
55
|
|
|
26
|
|
|
|
|
6700
|
|
139
|
|
|
|
|
|
|
use re qw(regexp_pattern is_regexp); |
140
|
|
|
|
|
|
|
*regex= *regexp_pattern; |
141
|
|
|
|
|
|
|
] or die $@; |
142
|
|
|
|
|
|
|
} |
143
|
|
|
|
|
|
|
elsif ($] >= 5.013006) { |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
# Perl-5.13.6 through perl-5.13.9 began returning modifier |
146
|
|
|
|
|
|
|
# flags that weren't yet legal at the time. |
147
|
0
|
0
|
|
|
|
0
|
eval q[ |
148
|
|
|
|
|
|
|
use re qw(regexp_pattern is_regexp); |
149
|
|
|
|
|
|
|
sub regex { |
150
|
|
|
|
|
|
|
if (wantarray) { |
151
|
|
|
|
|
|
|
my ($pat,$mod) = regexp_pattern($_[0]); |
152
|
|
|
|
|
|
|
if ($mod) { |
153
|
|
|
|
|
|
|
$mod =~ tr/dlua?//d; |
154
|
|
|
|
|
|
|
} |
155
|
|
|
|
|
|
|
return ($pat,$mod); |
156
|
|
|
|
|
|
|
} |
157
|
|
|
|
|
|
|
else { |
158
|
|
|
|
|
|
|
return scalar regexp_pattern($_[0]); |
159
|
|
|
|
|
|
|
} |
160
|
|
|
|
|
|
|
} |
161
|
|
|
|
|
|
|
1; |
162
|
|
|
|
|
|
|
] or die $@; |
163
|
|
|
|
|
|
|
} |
164
|
|
|
|
|
|
|
elsif ($] >= 5.009004) { |
165
|
0
|
0
|
|
|
|
0
|
eval q[ |
166
|
|
|
|
|
|
|
use re qw(regexp_pattern is_regexp); |
167
|
|
|
|
|
|
|
*regex= *regexp_pattern; |
168
|
|
|
|
|
|
|
1; |
169
|
|
|
|
|
|
|
] or die $@; |
170
|
|
|
|
|
|
|
} |
171
|
|
|
|
|
|
|
else { |
172
|
0
|
|
|
|
|
0
|
eval q[sub is_regexp($) { defined regex($_[0]) }]; |
173
|
|
|
|
|
|
|
} |
174
|
26
|
50
|
|
|
|
202
|
if ($] <= 5.008) { |
175
|
0
|
|
|
|
|
0
|
*hidden_keys= sub(\%) { return () }; |
|
0
|
|
|
|
|
0
|
|
176
|
0
|
|
|
|
|
0
|
*legal_keys= sub(\%) { return keys %{ $_[0] } }; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
177
|
0
|
|
|
|
|
0
|
*all_keys= sub(\%\@\@) { @{ $_[1] }= keys %{ $_[0] }; @$_[2]= (); }; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
178
|
|
|
|
|
|
|
} |
179
|
26
|
50
|
|
|
|
100
|
if ($] < 5.008) { |
180
|
26
|
|
|
26
|
|
215
|
no strict 'refs'; |
|
26
|
|
|
|
|
78
|
|
|
26
|
|
|
|
|
10507
|
|
181
|
0
|
|
|
|
|
0
|
foreach my $sub (qw(lock_keys lock_keys_plus )) { |
182
|
|
|
|
|
|
|
*$sub= sub(\%;@) { |
183
|
0
|
|
|
|
|
0
|
warnings::warn "$sub doesn't do anything before Perl 5.8.0\n"; |
184
|
0
|
|
|
|
|
0
|
return $_[0]; |
185
|
|
|
|
|
|
|
} |
186
|
0
|
|
|
|
|
0
|
} |
187
|
0
|
|
|
|
|
0
|
foreach my $sub (qw(lock_ref_keys lock_ref_keys_plus )) { |
188
|
|
|
|
|
|
|
*$sub= sub($;@) { |
189
|
0
|
|
|
|
|
0
|
warnings::warn "$sub doesn't do anything before Perl 5.8.0\n"; |
190
|
0
|
|
|
|
|
0
|
return $_[0]; |
191
|
|
|
|
|
|
|
} |
192
|
0
|
|
|
|
|
0
|
} |
193
|
|
|
|
|
|
|
} |
194
|
|
|
|
|
|
|
else { |
195
|
|
|
|
|
|
|
eval <<'EO_HU' |
196
|
|
|
|
|
|
|
use Hash::Util qw(lock_keys); |
197
|
|
|
|
|
|
|
sub lock_ref_keys($;@) { |
198
|
|
|
|
|
|
|
my $hash=shift; |
199
|
|
|
|
|
|
|
Carp::confess("lock_ref_keys(): Not a ref '$hash'") |
200
|
|
|
|
|
|
|
unless ref $hash; |
201
|
|
|
|
|
|
|
lock_keys(%$hash,@_); |
202
|
|
|
|
|
|
|
$hash |
203
|
|
|
|
|
|
|
} |
204
|
|
|
|
|
|
|
EO_HU |
205
|
26
|
50
|
|
26
|
0
|
1999
|
; |
|
26
|
|
|
6
|
|
14428
|
|
|
26
|
|
|
|
|
73910
|
|
|
26
|
|
|
|
|
161
|
|
|
6
|
|
|
|
|
11730
|
|
|
6
|
|
|
|
|
23
|
|
|
6
|
|
|
|
|
28
|
|
|
6
|
|
|
|
|
292
|
|
206
|
|
|
|
|
|
|
*lock_ref_keys_plus= sub($;@) { |
207
|
43
|
|
|
43
|
|
6972
|
my ($hash, @keys)= @_; |
208
|
43
|
|
|
|
|
60
|
my @delete; |
209
|
43
|
|
|
|
|
110
|
Internals::hv_clear_placeholders(%$hash); |
210
|
43
|
|
|
|
|
76
|
foreach my $key (@keys) { |
211
|
86
|
100
|
|
|
|
188
|
unless (exists($hash->{$key})) { |
212
|
85
|
|
|
|
|
151
|
$hash->{$key}= undef; |
213
|
85
|
|
|
|
|
150
|
push @delete, $key; |
214
|
|
|
|
|
|
|
} |
215
|
|
|
|
|
|
|
} |
216
|
43
|
|
|
|
|
97
|
SvREADONLY_ref($hash, 1); |
217
|
43
|
|
|
|
|
60
|
delete @{$hash}{@delete}; |
|
43
|
|
|
|
|
93
|
|
218
|
43
|
|
|
|
|
240
|
$hash; |
219
|
26
|
|
|
|
|
3622
|
}; |
220
|
26
|
|
|
6
|
|
103
|
*lock_keys_plus= sub(\%;@) { lock_ref_keys_plus(@_) }; |
|
6
|
|
|
|
|
4158
|
|
221
|
|
|
|
|
|
|
} |
222
|
26
|
50
|
|
|
|
147
|
if ($] <= 5.008008) { |
223
|
0
|
|
|
|
|
0
|
*disable_overloading= \&SvAMAGIC_off; |
224
|
|
|
|
|
|
|
*restore_overloading= sub ($$) { |
225
|
0
|
|
|
|
|
0
|
SvAMAGIC_on($_[0], undef); |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
# Visit all classes we are ISA and fetch the () entry from |
228
|
|
|
|
|
|
|
# every stash. |
229
|
0
|
|
|
|
|
0
|
my %done; |
230
|
0
|
|
|
|
|
0
|
my %todo= ( |
231
|
|
|
|
|
|
|
$_[0] => undef, |
232
|
|
|
|
|
|
|
UNIVERSAL => undef, |
233
|
|
|
|
|
|
|
); |
234
|
26
|
|
|
26
|
|
566
|
no strict 'refs'; |
|
26
|
|
|
|
|
302
|
|
|
26
|
|
|
|
|
6188
|
|
235
|
0
|
|
|
|
|
0
|
for my $todo_class (keys %todo) { |
236
|
0
|
|
|
|
|
0
|
delete $todo{$todo_class}; |
237
|
0
|
|
|
|
|
0
|
$done{$todo_class}= undef; |
238
|
0
|
|
|
|
|
0
|
for my $isa (@{"${todo_class}::ISA"}) { |
|
0
|
|
|
|
|
0
|
|
239
|
0
|
0
|
|
|
|
0
|
$todo{$isa}= undef unless exists $done{$isa}; |
240
|
|
|
|
|
|
|
} |
241
|
|
|
|
|
|
|
} |
242
|
0
|
|
|
|
|
0
|
}; |
243
|
|
|
|
|
|
|
} |
244
|
|
|
|
|
|
|
else { |
245
|
|
|
|
|
|
|
*disable_overloading= sub ($) { |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
# we use eval because $_[0] might be read-only |
248
|
|
|
|
|
|
|
# its a crappy solution, but whatever, it works |
249
|
55
|
|
|
55
|
|
97
|
eval { bless $_[0], 'Does::Not::Exist' }; |
|
55
|
|
|
|
|
138
|
|
250
|
26
|
|
|
|
|
95
|
}; |
251
|
|
|
|
|
|
|
*restore_overloading= sub ($$) { |
252
|
55
|
|
|
55
|
|
91
|
eval { bless $_[0], $_[1] } |
|
55
|
|
|
|
|
159
|
|
253
|
26
|
|
|
|
|
84
|
}; |
254
|
|
|
|
|
|
|
} |
255
|
26
|
|
|
|
|
80
|
my %fail= map { ($_ => 1) } @EXPORT_FAIL; |
|
0
|
|
|
|
|
0
|
|
256
|
26
|
|
|
|
|
64
|
@EXPORT_OK= grep { !$fail{$_} } @EXPORT_OK; |
|
1092
|
|
|
|
|
3817
|
|
257
|
|
|
|
|
|
|
} |
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
sub import { |
260
|
28
|
|
|
28
|
|
1120
|
my ($pkg)= @_; |
261
|
28
|
|
|
|
|
67
|
my ($idx, $alias); |
262
|
|
|
|
|
|
|
|
263
|
28
|
100
|
|
|
|
233
|
if ($idx= (grep lc($_[$_]) eq 'as', 0 .. $#_)) { |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
#print "found alias at $idx:\n"; |
266
|
2
|
|
|
|
|
8
|
($idx, $alias)= splice(@_, $idx, 2); |
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
#print "found alias: $idx => $alias\n"; |
269
|
|
|
|
|
|
|
|
270
|
26
|
|
|
26
|
|
190
|
no strict 'refs'; |
|
26
|
|
|
|
|
66
|
|
|
26
|
|
|
|
|
22762
|
|
271
|
2
|
|
|
|
|
3
|
*{ $alias . '::' }= *{ __PACKAGE__ . '::' }; |
|
2
|
|
|
|
|
49
|
|
|
2
|
|
|
|
|
7
|
|
272
|
|
|
|
|
|
|
} |
273
|
28
|
|
|
|
|
10875
|
$pkg->export_to_level(1, @_); |
274
|
|
|
|
|
|
|
} |
275
|
|
|
|
|
|
|
|
276
|
|
|
|
|
|
|
# NOTE |
277
|
|
|
|
|
|
|
# ---- |
278
|
|
|
|
|
|
|
# This module uses the term 'sv' in a way that is misleading. |
279
|
|
|
|
|
|
|
# It doesn't always mean the same as it would in the core. |
280
|
|
|
|
|
|
|
# |
281
|
|
|
|
|
|
|
# 1. data is breadth first traversed first, in the pretty much |
282
|
|
|
|
|
|
|
# self contained Data() routine which farms out a bit to |
283
|
|
|
|
|
|
|
# _reg_ref and _reg_scalar which handle "registering" items for |
284
|
|
|
|
|
|
|
# later use, such as their depth, refcount, "name", etc. But |
285
|
|
|
|
|
|
|
# ONLY for references and scalars whose refcount is over 2. |
286
|
|
|
|
|
|
|
# Most real SV's will have a refcount of 2 when we look at them |
287
|
|
|
|
|
|
|
# (from the perl side) so we actually don't know about them (trust me) |
288
|
|
|
|
|
|
|
# They _cant_ be referenced twice, and they can't be aliased so we can |
289
|
|
|
|
|
|
|
# can just ignore them until the second pass. |
290
|
|
|
|
|
|
|
# 2.Once this has happened Out() is called which starts off a |
291
|
|
|
|
|
|
|
# normal depth first traverse over the structure. It calls into |
292
|
|
|
|
|
|
|
# 3._dump_sv which in the case of a reference falls through to _dump_rv. |
293
|
|
|
|
|
|
|
# Aliasing and a bunch of stuff like that are checked here before we even |
294
|
|
|
|
|
|
|
# look at the reference type. |
295
|
|
|
|
|
|
|
# 4.If its a ref we fall through to dumping the reference in _dump_rv. |
296
|
|
|
|
|
|
|
# Here we handle duplicate refs, and manage depth checks, blessing, refs |
297
|
|
|
|
|
|
|
#(which is scary nasty horrible code) and then pass on to _dump_type where |
298
|
|
|
|
|
|
|
# type is one of 'code', 'qr', 'array' etc. Each of these which have children |
299
|
|
|
|
|
|
|
# then call back into _dump_sv as required. |
300
|
|
|
|
|
|
|
# 5. Because of the way perl works, we can't emit anything more than a DAG in a |
301
|
|
|
|
|
|
|
# single statement, so for more complex structures we need to add in the broken |
302
|
|
|
|
|
|
|
# links. I call these "fix statements", and they encompass copying reference |
303
|
|
|
|
|
|
|
# values, creating aliases, or even dumping globs. When a fix statement is needed |
304
|
|
|
|
|
|
|
# any of the _dump_foo methods will call _add_fix and add to the list of fixes. |
305
|
|
|
|
|
|
|
# after every root level _dump_sv call from Out() any fix statements possible to be |
306
|
|
|
|
|
|
|
# resolved will be emitted and removed from the fix list. This happens in |
307
|
|
|
|
|
|
|
# _dump_apply_fix, which is another piece of horrible code. |
308
|
|
|
|
|
|
|
# |
309
|
|
|
|
|
|
|
# Anyway, its terribly ugly, but for anything I can think to throw at i works. |
310
|
|
|
|
|
|
|
# demerphq |
311
|
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
=encoding utf8 |
313
|
|
|
|
|
|
|
|
314
|
|
|
|
|
|
|
=head1 NAME |
315
|
|
|
|
|
|
|
|
316
|
|
|
|
|
|
|
Data::Dump::Streamer - Accurately serialize a data structure as Perl code. |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
=head1 SYNOPSIS |
319
|
|
|
|
|
|
|
|
320
|
|
|
|
|
|
|
use Data::Dump::Streamer; |
321
|
|
|
|
|
|
|
use DDS; # optionally installed alias |
322
|
|
|
|
|
|
|
|
323
|
|
|
|
|
|
|
Dump($x,$y); # Prints to STDOUT |
324
|
|
|
|
|
|
|
Dump($x,$y)->Out(); # " " |
325
|
|
|
|
|
|
|
|
326
|
|
|
|
|
|
|
my $o=Data::Dump::Streamer->new(); # Returns a new ... |
327
|
|
|
|
|
|
|
my $o=Dump(); # ... uninitialized object. |
328
|
|
|
|
|
|
|
|
329
|
|
|
|
|
|
|
my $o=Dump($x,$y); # Returns an initialized object |
330
|
|
|
|
|
|
|
my $s=Dump($x,$y)->Out(); # " a string of the dumped obj |
331
|
|
|
|
|
|
|
my @l=Dump($x,$y); # " a list of code fragments |
332
|
|
|
|
|
|
|
my @l=Dump($x,$y)->Out(); # " a list of code fragments |
333
|
|
|
|
|
|
|
|
334
|
|
|
|
|
|
|
Dump($x,$y)->To(\*STDERR)->Out(); # Prints to STDERR |
335
|
|
|
|
|
|
|
|
336
|
|
|
|
|
|
|
Dump($x,$y)->Names('foo','bar') # Specify Names |
337
|
|
|
|
|
|
|
->Out(); |
338
|
|
|
|
|
|
|
|
339
|
|
|
|
|
|
|
Dump($x,$y)->Indent(0)->Out(); # No indent |
340
|
|
|
|
|
|
|
|
341
|
|
|
|
|
|
|
Dump($x,$y)->To(\*STDERR) # Output to STDERR |
342
|
|
|
|
|
|
|
->Indent(0) # ... no indent |
343
|
|
|
|
|
|
|
->Names('foo','bar') # ... specify Names |
344
|
|
|
|
|
|
|
->Out(); # Print... |
345
|
|
|
|
|
|
|
|
346
|
|
|
|
|
|
|
$o->Data($x,$y); # OO form of what Dump($x,$y) does. |
347
|
|
|
|
|
|
|
$o->Names('Foo','Names'); # ... |
348
|
|
|
|
|
|
|
$o->Out(); # ... |
349
|
|
|
|
|
|
|
|
350
|
|
|
|
|
|
|
=head1 DESCRIPTION |
351
|
|
|
|
|
|
|
|
352
|
|
|
|
|
|
|
Given a list of scalars or reference variables, writes out |
353
|
|
|
|
|
|
|
their contents in perl syntax. The references can also be |
354
|
|
|
|
|
|
|
objects. The contents of each variable is output using the least |
355
|
|
|
|
|
|
|
number of Perl statements as convenient, usually only one. |
356
|
|
|
|
|
|
|
Self-referential structures, closures, and objects are output |
357
|
|
|
|
|
|
|
correctly. |
358
|
|
|
|
|
|
|
|
359
|
|
|
|
|
|
|
The return value can be evaled to get back an identical copy |
360
|
|
|
|
|
|
|
of the original reference structure. In some cases this may |
361
|
|
|
|
|
|
|
require the use of utility subs that |
362
|
|
|
|
|
|
|
L will optionally |
363
|
|
|
|
|
|
|
export. |
364
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
This module is very similar in concept to the core module |
366
|
|
|
|
|
|
|
L, with the major differences |
367
|
|
|
|
|
|
|
being that this module is designed to output to a stream |
368
|
|
|
|
|
|
|
instead of constructing its output in memory (trading speed |
369
|
|
|
|
|
|
|
for memory), and that the traversal over the data structure |
370
|
|
|
|
|
|
|
is effectively breadth first versus the depth first |
371
|
|
|
|
|
|
|
traversal done by the others. |
372
|
|
|
|
|
|
|
|
373
|
|
|
|
|
|
|
In fact the data structure is scanned twice, first in |
374
|
|
|
|
|
|
|
breadth first mode to perform structural analysis, and then |
375
|
|
|
|
|
|
|
in depth first mode to actually produce the output, but |
376
|
|
|
|
|
|
|
obeying the depth relationships of the first pass. |
377
|
|
|
|
|
|
|
|
378
|
|
|
|
|
|
|
=head2 Caveats Dumping Closures (CODE Refs) |
379
|
|
|
|
|
|
|
|
380
|
|
|
|
|
|
|
As of version 1.11 DDS has had the ability to dump closures properly. This |
381
|
|
|
|
|
|
|
means that the lexicals that are bound to the closure are dumped along |
382
|
|
|
|
|
|
|
with the subroutine that uses them. This makes it much easier to debug |
383
|
|
|
|
|
|
|
code that uses closures and to a certain extent provides a persistency |
384
|
|
|
|
|
|
|
framework for closure based code. The way this works is that DDS figures |
385
|
|
|
|
|
|
|
out what all the lexicals are that are bound to CODE refs it is dumping |
386
|
|
|
|
|
|
|
and then pretends that it had originally been called with all of them as |
387
|
|
|
|
|
|
|
its arguments, (along with the original arguments as well of course.) |
388
|
|
|
|
|
|
|
|
389
|
|
|
|
|
|
|
One consequence of the way the dumping process works is that all of the |
390
|
|
|
|
|
|
|
recreated subroutines will be in the same scope. This of course can lead |
391
|
|
|
|
|
|
|
to collisions as two subroutines can easily be bound to different |
392
|
|
|
|
|
|
|
variables that have the same name. |
393
|
|
|
|
|
|
|
|
394
|
|
|
|
|
|
|
The way that DDS resolves these collisions is that it renames one of the |
395
|
|
|
|
|
|
|
variables with a special name so that presumably there are no collisions. |
396
|
|
|
|
|
|
|
However this process is very simplistic with no checks to prevent |
397
|
|
|
|
|
|
|
collisions with other lexicals or other globals that may be used by other |
398
|
|
|
|
|
|
|
dumped code. In some situations it may be necessary to change the default |
399
|
|
|
|
|
|
|
value of the rename template which may be done by using the C |
400
|
|
|
|
|
|
|
method. |
401
|
|
|
|
|
|
|
|
402
|
|
|
|
|
|
|
Similarly to the problem of colliding lexicals is the problem of colliding |
403
|
|
|
|
|
|
|
lexicals and globals. DDS pays no attention to globals when dumping |
404
|
|
|
|
|
|
|
closures which can potentially result in lexicals being declared that will |
405
|
|
|
|
|
|
|
eclipse their global namesake. There is currently no way around this other |
406
|
|
|
|
|
|
|
than to avoid accessing a global and a lexical with the same name from the |
407
|
|
|
|
|
|
|
subs being dumped. An example is |
408
|
|
|
|
|
|
|
|
409
|
|
|
|
|
|
|
my $a = sub { $a++ }; |
410
|
|
|
|
|
|
|
Dump( sub { $a->() } ); |
411
|
|
|
|
|
|
|
|
412
|
|
|
|
|
|
|
which will not be dumped correctly. Generally speaking this kind of thing |
413
|
|
|
|
|
|
|
is bad practice anyway, so this should probably be viewed as a "feature". |
414
|
|
|
|
|
|
|
:-) |
415
|
|
|
|
|
|
|
|
416
|
|
|
|
|
|
|
Generally if the closures being dumped avoid accessing lexicals and |
417
|
|
|
|
|
|
|
globals with the same name from out of scope and that all of the CODE |
418
|
|
|
|
|
|
|
being dumped avoids vars with the C in their names the dumps |
419
|
|
|
|
|
|
|
should be valid and should eval back into existence properly. |
420
|
|
|
|
|
|
|
|
421
|
|
|
|
|
|
|
Note that the behaviour of dumping closures is subject to change in future |
422
|
|
|
|
|
|
|
versions as its possible that I will put some additional effort into more |
423
|
|
|
|
|
|
|
sophisticated ways of avoiding name collisions in the dump. |
424
|
|
|
|
|
|
|
|
425
|
|
|
|
|
|
|
=head1 USAGE |
426
|
|
|
|
|
|
|
|
427
|
|
|
|
|
|
|
While Data::Dump::Streamer is at heart an object oriented module, it is |
428
|
|
|
|
|
|
|
expected (based on experience with using L) |
429
|
|
|
|
|
|
|
that the common case will not exploit these features. Nevertheless the |
430
|
|
|
|
|
|
|
method based approach is convenient and accordingly a compromise hybrid |
431
|
|
|
|
|
|
|
approach has been provided via the C subroutine. Such as |
432
|
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
Dump($foo); |
434
|
|
|
|
|
|
|
$as_string= Dump($foo)->Out(); |
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
All attribute methods are designed to be chained together. This means |
437
|
|
|
|
|
|
|
that when used as set attribute (called with arguments) they return the |
438
|
|
|
|
|
|
|
object they were called against. When used as get attributes (called |
439
|
|
|
|
|
|
|
without arguments) they return the value of the attribute. |
440
|
|
|
|
|
|
|
|
441
|
|
|
|
|
|
|
From an OO point of view the key methods are the C and C |
442
|
|
|
|
|
|
|
methods. These correspond to the breadth first and depth first traversal, |
443
|
|
|
|
|
|
|
and need to be called in this order. Some attributes I be set prior |
444
|
|
|
|
|
|
|
to the C phase and some need only be set before the C |
445
|
|
|
|
|
|
|
phase. |
446
|
|
|
|
|
|
|
|
447
|
|
|
|
|
|
|
Attributes once set last the lifetime of the object, unless explicitly |
448
|
|
|
|
|
|
|
reset. |
449
|
|
|
|
|
|
|
|
450
|
|
|
|
|
|
|
=head2 Controlling Object Representation |
451
|
|
|
|
|
|
|
|
452
|
|
|
|
|
|
|
This module provides hooks to allow objects to override how they are |
453
|
|
|
|
|
|
|
represented. The basic idea is that a subroutine (or method) is provided |
454
|
|
|
|
|
|
|
which is responsible for the override. The return of the method governs |
455
|
|
|
|
|
|
|
how the object will be represented when dumped, and how it will be |
456
|
|
|
|
|
|
|
restored. The basic calling convention is |
457
|
|
|
|
|
|
|
|
458
|
|
|
|
|
|
|
my ( $proxy, $thaw, $postop )= $callback->($obj); |
459
|
|
|
|
|
|
|
#or = $obj->$method(); |
460
|
|
|
|
|
|
|
|
461
|
|
|
|
|
|
|
The L|/Freezer> method controls what methods to use as a default method |
462
|
|
|
|
|
|
|
and also allows per class overrides. When dumping an object of a given |
463
|
|
|
|
|
|
|
class the first time it tries to execute the class specific handler if |
464
|
|
|
|
|
|
|
it is specified, then the user specific generic handler if its been |
465
|
|
|
|
|
|
|
specified and then "DDS_freeze". This means that class authors can |
466
|
|
|
|
|
|
|
implement a C method and their objects will automatically |
467
|
|
|
|
|
|
|
be serialized as necessary. B that if either the class specific or |
468
|
|
|
|
|
|
|
generic handler is defined but false C will not be used |
469
|
|
|
|
|
|
|
even if it is present. |
470
|
|
|
|
|
|
|
|
471
|
|
|
|
|
|
|
The interface of the L|/Freezer> handler in detail is as follows: |
472
|
|
|
|
|
|
|
|
473
|
|
|
|
|
|
|
=over 4 |
474
|
|
|
|
|
|
|
|
475
|
|
|
|
|
|
|
=item B> |
476
|
|
|
|
|
|
|
|
477
|
|
|
|
|
|
|
The object being dumped. |
478
|
|
|
|
|
|
|
|
479
|
|
|
|
|
|
|
=item B> |
480
|
|
|
|
|
|
|
|
481
|
|
|
|
|
|
|
This is what will be dumped instead of C<$obj>. It may be one of |
482
|
|
|
|
|
|
|
the following values: |
483
|
|
|
|
|
|
|
|
484
|
|
|
|
|
|
|
=over 8 |
485
|
|
|
|
|
|
|
|
486
|
|
|
|
|
|
|
=item I> (first time only) |
487
|
|
|
|
|
|
|
|
488
|
|
|
|
|
|
|
On the first time a serialization hook is called in a dump it may return |
489
|
|
|
|
|
|
|
undef or the empty list to indicate that it shouldn't be used again for |
490
|
|
|
|
|
|
|
this class during this pass. Any other time undef is treated the same |
491
|
|
|
|
|
|
|
as false. |
492
|
|
|
|
|
|
|
|
493
|
|
|
|
|
|
|
=item I |
494
|
|
|
|
|
|
|
|
495
|
|
|
|
|
|
|
A false value for C<$proxy> is taken to mean that it should be ignored. |
496
|
|
|
|
|
|
|
Its like saying IgnoreClass(ref($obj)); B that undef has a special |
497
|
|
|
|
|
|
|
meaning when the callback is called the first time. |
498
|
|
|
|
|
|
|
|
499
|
|
|
|
|
|
|
=item I |
500
|
|
|
|
|
|
|
|
501
|
|
|
|
|
|
|
A reference that will be dumped instead of the object. |
502
|
|
|
|
|
|
|
|
503
|
|
|
|
|
|
|
=item I |
504
|
|
|
|
|
|
|
|
505
|
|
|
|
|
|
|
A string that is to be treated as code and inserted directly into the |
506
|
|
|
|
|
|
|
dump stream as a proxy for the original. Note that the code must be |
507
|
|
|
|
|
|
|
able to execute inline or in other words must evaluate to a perl EXPR. |
508
|
|
|
|
|
|
|
Use C to wrap multistatement code. |
509
|
|
|
|
|
|
|
|
510
|
|
|
|
|
|
|
=back |
511
|
|
|
|
|
|
|
|
512
|
|
|
|
|
|
|
=item B> |
513
|
|
|
|
|
|
|
|
514
|
|
|
|
|
|
|
This values is used to allow extra control over how the object will be |
515
|
|
|
|
|
|
|
recreated when dumped. It is used for converting the C<$proxy> representation |
516
|
|
|
|
|
|
|
into the real thing. It is only relevant when C<$proxy> is a reference. |
517
|
|
|
|
|
|
|
|
518
|
|
|
|
|
|
|
=over 8 |
519
|
|
|
|
|
|
|
|
520
|
|
|
|
|
|
|
=item I |
521
|
|
|
|
|
|
|
|
522
|
|
|
|
|
|
|
Indicates no thaw action is to be included for this object. |
523
|
|
|
|
|
|
|
|
524
|
|
|
|
|
|
|
=item I |
525
|
|
|
|
|
|
|
|
526
|
|
|
|
|
|
|
A string matching C<< /^(->)?((?:\w*::)\w+)(\(\))?$/ >> in which case it |
527
|
|
|
|
|
|
|
is taken as a sub name when the string ends in () and a method name |
528
|
|
|
|
|
|
|
when the string doesn't. If the C<< -> >> is present then the sub or method |
529
|
|
|
|
|
|
|
is called inline. If it is not then the sub or method is called |
530
|
|
|
|
|
|
|
after the main dump. |
531
|
|
|
|
|
|
|
|
532
|
|
|
|
|
|
|
=item I |
533
|
|
|
|
|
|
|
|
534
|
|
|
|
|
|
|
Any other string, in which case the result will be taken as code |
535
|
|
|
|
|
|
|
which will be emitted after the main dump. It will be wrapped |
536
|
|
|
|
|
|
|
in a for loop that aliases C<$_> to the variable in question. |
537
|
|
|
|
|
|
|
|
538
|
|
|
|
|
|
|
=back |
539
|
|
|
|
|
|
|
|
540
|
|
|
|
|
|
|
=item B> |
541
|
|
|
|
|
|
|
|
542
|
|
|
|
|
|
|
This is the similar to C<$thaw> but is called in process instead |
543
|
|
|
|
|
|
|
of being emitted as part of the dump. Any return is ignored. |
544
|
|
|
|
|
|
|
It is only relevant when C<$proxy> is a reference. |
545
|
|
|
|
|
|
|
|
546
|
|
|
|
|
|
|
=over 8 |
547
|
|
|
|
|
|
|
|
548
|
|
|
|
|
|
|
=item I |
549
|
|
|
|
|
|
|
|
550
|
|
|
|
|
|
|
No postdump action is to occur. |
551
|
|
|
|
|
|
|
|
552
|
|
|
|
|
|
|
=item I |
553
|
|
|
|
|
|
|
|
554
|
|
|
|
|
|
|
The code ref will be called after serialization is complete |
555
|
|
|
|
|
|
|
with the object as the argument. |
556
|
|
|
|
|
|
|
|
557
|
|
|
|
|
|
|
=item I |
558
|
|
|
|
|
|
|
|
559
|
|
|
|
|
|
|
The method will be called after serialization is complete |
560
|
|
|
|
|
|
|
|
561
|
|
|
|
|
|
|
=back |
562
|
|
|
|
|
|
|
|
563
|
|
|
|
|
|
|
=back |
564
|
|
|
|
|
|
|
|
565
|
|
|
|
|
|
|
An example DDS_freeze method is one I had to put together for an object |
566
|
|
|
|
|
|
|
which contained a key whose value was a ref to an array tied to the value |
567
|
|
|
|
|
|
|
of another key. Dumping this got crazy, so I wanted to suppress dumping |
568
|
|
|
|
|
|
|
the tied array. I did it this way: |
569
|
|
|
|
|
|
|
|
570
|
|
|
|
|
|
|
sub DDS_freeze { |
571
|
|
|
|
|
|
|
my $self=shift; |
572
|
|
|
|
|
|
|
delete $self->{'tie'}; |
573
|
|
|
|
|
|
|
return ($self,'->fix_tie','fix_tie'); |
574
|
|
|
|
|
|
|
} |
575
|
|
|
|
|
|
|
|
576
|
|
|
|
|
|
|
sub fix_tie { |
577
|
|
|
|
|
|
|
my $self=shift; |
578
|
|
|
|
|
|
|
if ( ! $self->{'tie'} ) { |
579
|
|
|
|
|
|
|
$self->{str}="" unless defined $self->{str}; |
580
|
|
|
|
|
|
|
tie my @a, 'Tie::Array::PackedC', $self->{str}; |
581
|
|
|
|
|
|
|
$self->{'tie'} = \@a; |
582
|
|
|
|
|
|
|
} |
583
|
|
|
|
|
|
|
return $self; |
584
|
|
|
|
|
|
|
} |
585
|
|
|
|
|
|
|
|
586
|
|
|
|
|
|
|
The C<$postop> means the object is relatively unaffected after the |
587
|
|
|
|
|
|
|
dump, the C<$thaw> says that we should also include the method |
588
|
|
|
|
|
|
|
inline as we dump. An example dump of an object like this might be |
589
|
|
|
|
|
|
|
|
590
|
|
|
|
|
|
|
$Foo1=bless({ str=>'' },'Foo')->fix_tie(); |
591
|
|
|
|
|
|
|
|
592
|
|
|
|
|
|
|
Wheras if we omit the C<< -> >> then we would get: |
593
|
|
|
|
|
|
|
|
594
|
|
|
|
|
|
|
$Foo1=bless({ str=>'' },'Foo'); |
595
|
|
|
|
|
|
|
$Foo1->fix_tie(); |
596
|
|
|
|
|
|
|
|
597
|
|
|
|
|
|
|
In our example it wouldn't actually make a difference, but the former |
598
|
|
|
|
|
|
|
style can be nicer to read if the object is embedded in another. |
599
|
|
|
|
|
|
|
However the non arrow notation is slightly more dangerous, in that |
600
|
|
|
|
|
|
|
its possible that the internals of the object will not be fully linked |
601
|
|
|
|
|
|
|
when the method is evaluated. The second form guarantees that the object |
602
|
|
|
|
|
|
|
will be fully linked when the method is evaluated. |
603
|
|
|
|
|
|
|
|
604
|
|
|
|
|
|
|
See L for a different way |
605
|
|
|
|
|
|
|
to control the representation of hash based objects. |
606
|
|
|
|
|
|
|
|
607
|
|
|
|
|
|
|
=head2 Controlling Hash Traversal and Display Order |
608
|
|
|
|
|
|
|
|
609
|
|
|
|
|
|
|
When dumping a hash you may control the order the keys will be output |
610
|
|
|
|
|
|
|
and which keys will be included. The basic idea is to specify a subroutine |
611
|
|
|
|
|
|
|
which takes a hash as an argument and returns a reference to an array |
612
|
|
|
|
|
|
|
containing the keys to be dumped. |
613
|
|
|
|
|
|
|
|
614
|
|
|
|
|
|
|
You can use the L routine or the L routine to |
615
|
|
|
|
|
|
|
specify the sorter to be used. |
616
|
|
|
|
|
|
|
|
617
|
|
|
|
|
|
|
The routine will be called in the following way: |
618
|
|
|
|
|
|
|
|
619
|
|
|
|
|
|
|
( $key_array, $thaw ) = $sorter->($hash,($pass=0),$addr,$class); |
620
|
|
|
|
|
|
|
( $key_array,) = $sorter->($hash,($pass=1),$addr,$class); |
621
|
|
|
|
|
|
|
|
622
|
|
|
|
|
|
|
C<$hash> is the hash to be dumped, C<$addr> is the refaddr() of the |
623
|
|
|
|
|
|
|
C<$hash>, and C<$class> will be set if the hash has been blessed. |
624
|
|
|
|
|
|
|
|
625
|
|
|
|
|
|
|
When C<$pass> is 0 the C<$thaw> variable may be supplied as well as the |
626
|
|
|
|
|
|
|
keyorder. If it is defined then it specifies what thaw action to perform |
627
|
|
|
|
|
|
|
after dumping the hash. See L|/$thaw> in L
|
628
|
|
|
|
|
|
|
Representation> for details as to how it works. This allows an object |
629
|
|
|
|
|
|
|
to define those keys needed to recreate itself properly, and a followup |
630
|
|
|
|
|
|
|
hook to recreate the rest. |
631
|
|
|
|
|
|
|
|
632
|
|
|
|
|
|
|
B that if a L method is defined and returns |
633
|
|
|
|
|
|
|
a L|/$thaw> then the L|/$thaw> returned by the sorter |
634
|
|
|
|
|
|
|
will override it. |
635
|
|
|
|
|
|
|
|
636
|
|
|
|
|
|
|
=head2 Controlling Array Presentation and Run Length Encoding |
637
|
|
|
|
|
|
|
|
638
|
|
|
|
|
|
|
By default Data::Dump::Streamer will "run length encode" array values. |
639
|
|
|
|
|
|
|
This means that when an array value is simple (ie, its not referenced and |
640
|
|
|
|
|
|
|
does contain a reference) and is repeated multiple times the output will |
641
|
|
|
|
|
|
|
be single a list multiplier statement, and not each item output |
642
|
|
|
|
|
|
|
separately. Thus: L|/Dump> will be output something like |
643
|
|
|
|
|
|
|
|
644
|
|
|
|
|
|
|
$ARRAY1 = [ (0) x 4 ]; |
645
|
|
|
|
|
|
|
|
646
|
|
|
|
|
|
|
This is particularly useful when dealing with large arrays that are only |
647
|
|
|
|
|
|
|
partly filled, and when accidentally the array has been made very large, |
648
|
|
|
|
|
|
|
such as with the improper use of pseudo-hash notation. |
649
|
|
|
|
|
|
|
|
650
|
|
|
|
|
|
|
To disable this feature you may set the L property to FALSE, by |
651
|
|
|
|
|
|
|
default it is enabled and set to TRUE. |
652
|
|
|
|
|
|
|
|
653
|
|
|
|
|
|
|
=head2 Installing I as a package alias |
654
|
|
|
|
|
|
|
|
655
|
|
|
|
|
|
|
Its possible to have an alias to Data::Dump::Streamer created and |
656
|
|
|
|
|
|
|
installed for easier usage in one liners and short scripts. |
657
|
|
|
|
|
|
|
Data::Dump::Streamer is a bit long to type sometimes. However because this |
658
|
|
|
|
|
|
|
technically means polluting the root level namespace, and having it listed |
659
|
|
|
|
|
|
|
on CPAN, I have elected to have the installer not install it by default. |
660
|
|
|
|
|
|
|
If you wish it to be installed you must explicitly state so when |
661
|
|
|
|
|
|
|
Build.Pl is run: |
662
|
|
|
|
|
|
|
|
663
|
|
|
|
|
|
|
perl Build.Pl DDS [Other Module::Build options] |
664
|
|
|
|
|
|
|
|
665
|
|
|
|
|
|
|
Then a normal './Build test, ./Build install' invocation will install DDS. |
666
|
|
|
|
|
|
|
|
667
|
|
|
|
|
|
|
Using DDS is identical to Data::Dump::Streamer. |
668
|
|
|
|
|
|
|
|
669
|
|
|
|
|
|
|
=head2 use-time package aliasing |
670
|
|
|
|
|
|
|
|
671
|
|
|
|
|
|
|
You can also specify an alias at use-time, then use that alias in the rest |
672
|
|
|
|
|
|
|
of your program, thus avoiding the permanent (but modest) namespace |
673
|
|
|
|
|
|
|
pollution of the previous method. |
674
|
|
|
|
|
|
|
|
675
|
|
|
|
|
|
|
use Data::Dumper::Streamer as => 'DDS'; |
676
|
|
|
|
|
|
|
|
677
|
|
|
|
|
|
|
# or if you prefer |
678
|
|
|
|
|
|
|
use Data::Dumper::Streamer; |
679
|
|
|
|
|
|
|
import Data::Dumper::Streamer as => 'DDS'; |
680
|
|
|
|
|
|
|
|
681
|
|
|
|
|
|
|
You can use any alias you like, but that doesn't mean you should.. Folks |
682
|
|
|
|
|
|
|
doing as => 'DBI' will be mercilessly ridiculed. |
683
|
|
|
|
|
|
|
|
684
|
|
|
|
|
|
|
=head2 PadWalker support |
685
|
|
|
|
|
|
|
|
686
|
|
|
|
|
|
|
If PadWalker 1.0 is installed you can use DumpLex() to try to |
687
|
|
|
|
|
|
|
automatically determine the names of the vars being dumped. As |
688
|
|
|
|
|
|
|
long as the vars being dumped have my or our declarations in scope |
689
|
|
|
|
|
|
|
the vars will be correctly named. Padwalker will also be used |
690
|
|
|
|
|
|
|
instead of the B:: modules when dumping closures when it is available. |
691
|
|
|
|
|
|
|
|
692
|
|
|
|
|
|
|
=head1 INTERFACE |
693
|
|
|
|
|
|
|
|
694
|
|
|
|
|
|
|
=head2 Data::Dumper Compatibility |
695
|
|
|
|
|
|
|
|
696
|
|
|
|
|
|
|
For drop in compatibility with the Dumper() usage of Data::Dumper, you may |
697
|
|
|
|
|
|
|
request that the L method is exported. It will not be exported by |
698
|
|
|
|
|
|
|
default. In addition the standard Data::Dumper::Dumper() may be exported |
699
|
|
|
|
|
|
|
on request as C. If you provide the tag C<:Dumper> then both will |
700
|
|
|
|
|
|
|
be exported. |
701
|
|
|
|
|
|
|
|
702
|
|
|
|
|
|
|
=over 4 |
703
|
|
|
|
|
|
|
|
704
|
|
|
|
|
|
|
=item Dumper |
705
|
|
|
|
|
|
|
|
706
|
|
|
|
|
|
|
=item Dumper LIST |
707
|
|
|
|
|
|
|
|
708
|
|
|
|
|
|
|
A synonym for scalar Dump(LIST)->Out for usage compatibility with |
709
|
|
|
|
|
|
|
L |
710
|
|
|
|
|
|
|
|
711
|
|
|
|
|
|
|
=item DDumper |
712
|
|
|
|
|
|
|
|
713
|
|
|
|
|
|
|
=item DDumper LIST |
714
|
|
|
|
|
|
|
|
715
|
|
|
|
|
|
|
A secondary export of the actual L |
716
|
|
|
|
|
|
|
subroutine. |
717
|
|
|
|
|
|
|
|
718
|
|
|
|
|
|
|
=back |
719
|
|
|
|
|
|
|
|
720
|
|
|
|
|
|
|
=head2 Constructors |
721
|
|
|
|
|
|
|
|
722
|
|
|
|
|
|
|
=over 4 |
723
|
|
|
|
|
|
|
|
724
|
|
|
|
|
|
|
=item new |
725
|
|
|
|
|
|
|
|
726
|
|
|
|
|
|
|
Creates a new Data::Dump::Streamer object. Currently takes no |
727
|
|
|
|
|
|
|
arguments and simply returns the new object with a default style |
728
|
|
|
|
|
|
|
configuration. |
729
|
|
|
|
|
|
|
|
730
|
|
|
|
|
|
|
See C for a better way to do things. |
731
|
|
|
|
|
|
|
|
732
|
|
|
|
|
|
|
=cut |
733
|
|
|
|
|
|
|
|
734
|
|
|
|
|
|
|
sub _compressor { |
735
|
4
|
100
|
|
4
|
|
14
|
return "use Data::Dump::Streamer qw(usqz);\n" |
736
|
|
|
|
|
|
|
if !@_; |
737
|
2
|
|
|
|
|
6
|
return sqz($_[0], "usqz('", "')"); |
738
|
|
|
|
|
|
|
} |
739
|
|
|
|
|
|
|
|
740
|
|
|
|
|
|
|
sub new { |
741
|
56
|
|
|
56
|
1
|
154190
|
my $class= shift; |
742
|
56
|
|
|
|
|
1249
|
my $self= bless { |
743
|
|
|
|
|
|
|
style => { |
744
|
|
|
|
|
|
|
hashsep => '=>', # use this to separate key vals |
745
|
|
|
|
|
|
|
arysep => ',', |
746
|
|
|
|
|
|
|
pairsep => ',', |
747
|
|
|
|
|
|
|
optspace => ' ', |
748
|
|
|
|
|
|
|
bless => 'bless()', # use this to bless objects, needs fixing |
749
|
|
|
|
|
|
|
|
750
|
|
|
|
|
|
|
compress => 0, # if nonzero use compressor to compress strings |
751
|
|
|
|
|
|
|
# longer than this value. |
752
|
|
|
|
|
|
|
compressor => \&_compressor, |
753
|
|
|
|
|
|
|
|
754
|
|
|
|
|
|
|
indent => 2, # should we indent at all? |
755
|
|
|
|
|
|
|
indentkeys => 1, # indent keys |
756
|
|
|
|
|
|
|
declare => 0, # predeclare vars? allows refs to root vars if 0 |
757
|
|
|
|
|
|
|
sortkeys => {}, |
758
|
|
|
|
|
|
|
verbose => 1, # use long names and detailed fill ins |
759
|
|
|
|
|
|
|
dumpglob => 1, # dump glob contents |
760
|
|
|
|
|
|
|
deparseglob => 1, |
761
|
|
|
|
|
|
|
deparse => 1, # deparse code refs? |
762
|
|
|
|
|
|
|
freezer => 'DDS_freeze', # default freezer |
763
|
|
|
|
|
|
|
freeze_class => {}, # freeze classes |
764
|
|
|
|
|
|
|
|
765
|
|
|
|
|
|
|
rle => 1, # run length encode arrays |
766
|
|
|
|
|
|
|
ignore => {}, # ignore classes |
767
|
|
|
|
|
|
|
indentcols => 2, # indent this number of cols |
768
|
|
|
|
|
|
|
ro => 1, # track readonly vars |
769
|
|
|
|
|
|
|
dualvars => 1, # dump dualvars |
770
|
|
|
|
|
|
|
eclipsename => "%s_eclipse_%d", |
771
|
|
|
|
|
|
|
|
772
|
|
|
|
|
|
|
purity => 1, # test |
773
|
|
|
|
|
|
|
|
774
|
|
|
|
|
|
|
terse => 0, |
775
|
|
|
|
|
|
|
|
776
|
|
|
|
|
|
|
# use this if deparse is 0 |
777
|
|
|
|
|
|
|
codestub => 'sub { Carp::confess "Dumped code stub!" }', |
778
|
|
|
|
|
|
|
formatstub => |
779
|
|
|
|
|
|
|
'do{ local *F; eval "format F =\nFormat Stub\n.\n"; *F{FORMAT} }', |
780
|
|
|
|
|
|
|
|
781
|
|
|
|
|
|
|
# use these opts if deparse is 1 |
782
|
|
|
|
|
|
|
deparseopts => ["-sCi2v'Useless const omitted'"], |
783
|
|
|
|
|
|
|
special => 0, |
784
|
|
|
|
|
|
|
|
785
|
|
|
|
|
|
|
# not yet implemented |
786
|
|
|
|
|
|
|
array_warn => |
787
|
|
|
|
|
|
|
10_000, # warn if an array has more than this number of elements |
788
|
|
|
|
|
|
|
array_chop => 32_767, # chop arrays over this size |
789
|
|
|
|
|
|
|
array_max => 1_000_000, # die if arrays have more than this size |
790
|
|
|
|
|
|
|
smart_array => 1, # special handling of very large arrays |
791
|
|
|
|
|
|
|
# with hashes as their 0 index. (pseudo-hash error detection) |
792
|
|
|
|
|
|
|
}, |
793
|
|
|
|
|
|
|
debug => 0, |
794
|
|
|
|
|
|
|
cataloged => 0, |
795
|
|
|
|
|
|
|
ref_id => 0, |
796
|
|
|
|
|
|
|
sv_id => 0 |
797
|
|
|
|
|
|
|
}, $class; |
798
|
|
|
|
|
|
|
|
799
|
56
|
|
|
|
|
337
|
return $self; |
800
|
|
|
|
|
|
|
} |
801
|
|
|
|
|
|
|
|
802
|
|
|
|
|
|
|
sub _safe_self { |
803
|
1017
|
|
|
1017
|
|
1786
|
my $self= shift; |
804
|
1017
|
100
|
|
|
|
2820
|
unless (ref $self) { |
805
|
7
|
|
|
|
|
18
|
$self= $self->new(); |
806
|
|
|
|
|
|
|
} |
807
|
1017
|
|
|
|
|
6037
|
return $self; |
808
|
|
|
|
|
|
|
} |
809
|
|
|
|
|
|
|
|
810
|
|
|
|
|
|
|
sub Dumper { |
811
|
0
|
|
|
0
|
1
|
0
|
return scalar Dump(@_)->Out(); |
812
|
|
|
|
|
|
|
} |
813
|
|
|
|
|
|
|
|
814
|
|
|
|
|
|
|
sub DDumper { |
815
|
0
|
|
|
0
|
1
|
0
|
return Data::Dumper::Dumper(@_); |
816
|
|
|
|
|
|
|
} |
817
|
|
|
|
|
|
|
|
818
|
|
|
|
|
|
|
#sub _is_utf8 { length $_[0] != do { use bytes; length $_[0] } } |
819
|
|
|
|
|
|
|
|
820
|
0
|
|
|
|
|
0
|
BEGIN { |
821
|
26
|
|
|
26
|
|
12426
|
my $numeric_rex= qr/\A-?(?:0|[1-9]\d*)(\.\d+(?
|
822
|
|
|
|
|
|
|
|
823
|
|
|
|
|
|
|
# used by _qquote below |
824
|
26
|
|
|
|
|
31151
|
my %esc= ( |
825
|
|
|
|
|
|
|
"\a" => "\\a", |
826
|
|
|
|
|
|
|
"\b" => "\\b", |
827
|
|
|
|
|
|
|
"\t" => "\\t", |
828
|
|
|
|
|
|
|
"\n" => "\\n", |
829
|
|
|
|
|
|
|
"\f" => "\\f", |
830
|
|
|
|
|
|
|
"\r" => "\\r", |
831
|
|
|
|
|
|
|
"\e" => "\\e", |
832
|
|
|
|
|
|
|
); |
833
|
|
|
|
|
|
|
|
834
|
|
|
|
|
|
|
# Taken from Data::Dumper::qquote() 2.12. |
835
|
|
|
|
|
|
|
# Changed utf8 handling from that version |
836
|
|
|
|
|
|
|
# put a string value in double quotes |
837
|
|
|
|
|
|
|
# Fixes by [ysth] |
838
|
|
|
|
|
|
|
sub _qquote { |
839
|
540
|
|
|
540
|
|
843
|
my $str= shift; |
840
|
540
|
|
|
|
|
765
|
my @ret; |
841
|
540
|
|
|
|
|
1040
|
while (length($str)) { |
842
|
540
|
|
|
|
|
1406
|
local ($_)= substr($str, 0, 72, ""); |
843
|
540
|
|
|
|
|
1038
|
s/([\\\"\@\$])/\\$1/g; |
844
|
|
|
|
|
|
|
|
845
|
540
|
100
|
|
|
|
1142
|
unless (/[^ !""\#\$%&''()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~]/) { |
846
|
508
|
|
|
|
|
1072
|
push @ret, qq("$_"); # fast exit |
847
|
508
|
|
|
|
|
1156
|
next; |
848
|
|
|
|
|
|
|
} |
849
|
|
|
|
|
|
|
|
850
|
32
|
|
|
|
|
163
|
s/([\a\b\t\n\f\r\e])/$esc{$1}/g; |
851
|
|
|
|
|
|
|
|
852
|
32
|
|
|
|
|
143
|
if (ord('^') == 94) { |
853
|
|
|
|
|
|
|
|
854
|
|
|
|
|
|
|
# ascii / utf8 |
855
|
|
|
|
|
|
|
# no need for 3 digits in escape if followed by a digit |
856
|
32
|
|
|
|
|
59
|
s/([\0-\037])(?!\d) / sprintf '\\%o', ord($1)/xeg; |
|
0
|
|
|
|
|
0
|
|
857
|
32
|
|
|
|
|
55
|
s/([\0-\037\177]) / sprintf '\\%03o', ord($1)/xeg; |
|
0
|
|
|
|
|
0
|
|
858
|
|
|
|
|
|
|
|
859
|
26
|
100
|
|
26
|
|
221
|
if (length $_ != do { use bytes; length $_ }) { |
|
26
|
|
|
|
|
55
|
|
|
26
|
|
|
|
|
206
|
|
|
32
|
|
|
|
|
148
|
|
|
32
|
|
|
|
|
82
|
|
860
|
26
|
|
|
26
|
|
16901
|
use utf8; #perl 5.6.1 needs this, 5.9.2 doesn't. sigh |
|
26
|
|
|
|
|
402
|
|
|
26
|
|
|
|
|
236
|
|
861
|
6
|
|
|
|
|
17
|
s/([\200-\377]) / sprintf '\\%03o', ord($1)/xeg; |
|
0
|
|
|
|
|
0
|
|
862
|
6
|
|
|
|
|
50
|
s/([^\040-\176])/ sprintf '\\x{%x}', ord($1)/xeg; |
|
10
|
|
|
|
|
56
|
|
863
|
|
|
|
|
|
|
} |
864
|
|
|
|
|
|
|
else { |
865
|
|
|
|
|
|
|
# must not be under "use utf8" for 5.6.x |
866
|
26
|
|
|
|
|
42
|
s/([\200-\377]) / sprintf '\\%03o', ord($1)/xeg; |
|
2
|
|
|
|
|
13
|
|
867
|
|
|
|
|
|
|
} |
868
|
|
|
|
|
|
|
} |
869
|
|
|
|
|
|
|
else { |
870
|
|
|
|
|
|
|
# ebcdic |
871
|
|
|
|
|
|
|
s{([^ !""\#\$%&''()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])(?!\d)} |
872
|
|
|
|
|
|
|
{ |
873
|
|
|
|
|
|
|
my $v = ord($1); '\\'.sprintf(($v <= 037 ? '%o' : '%03o'), $v) |
874
|
|
|
|
|
|
|
}eg; |
875
|
|
|
|
|
|
|
s{([^ !""\#\$%&''()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])} |
876
|
|
|
|
|
|
|
{'\\'.sprintf('%03o',ord($1))}eg; |
877
|
32
|
|
|
|
|
132
|
} |
878
|
|
|
|
|
|
|
|
879
|
540
|
|
|
|
|
1598
|
push @ret, qq("$_"); |
880
|
|
|
|
|
|
|
} |
881
|
|
|
|
|
|
|
return join ".\n\t", @ret; |
882
|
|
|
|
|
|
|
} |
883
|
|
|
|
|
|
|
|
884
|
1749
|
|
|
1749
|
|
3873
|
# single quote |
885
|
1749
|
100
|
|
|
|
10854
|
sub _quote { |
|
|
100
|
|
|
|
|
|
886
|
610
|
|
|
|
|
1647
|
my $v= join "", @_; |
887
|
|
|
|
|
|
|
if ($v =~ $numeric_rex) { |
888
|
|
|
|
|
|
|
return $v; |
889
|
1131
|
|
|
|
|
2222
|
} |
890
|
1131
|
|
|
|
|
3932
|
elsif ($v !~ /[^\x20-\x7E]/) { |
891
|
|
|
|
|
|
|
$v =~ s/([\\''])/\\$1/g; |
892
|
8
|
|
|
|
|
29
|
return "'$v'"; |
893
|
|
|
|
|
|
|
} |
894
|
|
|
|
|
|
|
return _qquote($v); |
895
|
|
|
|
|
|
|
} |
896
|
|
|
|
|
|
|
|
897
|
4768
|
|
|
4768
|
|
7453
|
# quote a key |
898
|
4768
|
50
|
33
|
|
|
38821
|
sub _quotekey { |
|
|
100
|
100
|
|
|
|
|
899
|
0
|
|
|
|
|
0
|
my $key= shift; |
900
|
|
|
|
|
|
|
if (!defined($key) or $key eq '') { |
901
|
|
|
|
|
|
|
return '""'; |
902
|
4236
|
|
|
|
|
11538
|
} |
903
|
|
|
|
|
|
|
elsif ($key =~ $numeric_rex or $key =~ /\A-?[A-Za-z_]\w*\z/) { |
904
|
|
|
|
|
|
|
return $key; |
905
|
532
|
|
|
|
|
1235
|
} |
906
|
|
|
|
|
|
|
else { |
907
|
|
|
|
|
|
|
_qquote($key); |
908
|
|
|
|
|
|
|
} |
909
|
|
|
|
|
|
|
} |
910
|
|
|
|
|
|
|
} |
911
|
|
|
|
|
|
|
|
912
|
|
|
|
|
|
|
my %ttrans= ( |
913
|
|
|
|
|
|
|
reftype({}) => '%', |
914
|
|
|
|
|
|
|
reftype([]) => '@', |
915
|
|
|
|
|
|
|
reftype(\ 'foo') => '$', |
916
|
|
|
|
|
|
|
reftype(\\'foo') => '$', # REF |
917
|
|
|
|
|
|
|
reftype(sub { }) => '&', |
918
|
|
|
|
|
|
|
'' => '$', |
919
|
|
|
|
|
|
|
); |
920
|
795
|
|
|
795
|
|
1643
|
|
921
|
|
|
|
|
|
|
sub _make_name { |
922
|
|
|
|
|
|
|
my ($self, $obj, $indx)= @_; |
923
|
|
|
|
|
|
|
|
924
|
795
|
|
100
|
|
|
3411
|
#warn Dumper($self->{unames})."'$self->{unames}' |
|
|
|
100
|
|
|
|
|
925
|
|
|
|
|
|
|
# : @{$self->{unames}||[]} @{[defined $indx ? $indx : '-']}"; |
926
|
795
|
100
|
|
|
|
2105
|
my $uname= ($self->{unames} || [])->[ $indx || 0 ]; |
|
|
100
|
|
|
|
|
|
927
|
508
|
|
66
|
|
|
2615
|
|
928
|
|
|
|
|
|
|
unless ($uname) { |
929
|
|
|
|
|
|
|
my $name= |
930
|
|
|
|
|
|
|
blessed($_[1]) |
931
|
508
|
100
|
|
|
|
1217
|
|| reftype($_[1]) |
932
|
2
|
|
|
|
|
5
|
|| ((readonly($_[1]) && (\$_[1] != \undef)) ? "RO" : "VAR"); |
933
|
2
|
|
|
|
|
7
|
unless ($self->{style}{verbose}) { |
934
|
2
|
|
33
|
|
|
14
|
my $n= 1; |
935
|
2
|
|
33
|
|
|
15
|
(my $abr= $name) =~ s/(\w)\w*::/$1/g; |
|
|
|
33
|
|
|
|
|
936
|
|
|
|
|
|
|
$self->{type_abrv}{$name} ||= $name; |
937
|
|
|
|
|
|
|
while ( $n <= length($abr) |
938
|
|
|
|
|
|
|
and $self->{type_abrv}{ substr($abr, 0, $n) } |
939
|
0
|
|
|
|
|
0
|
and $self->{type_abrv}{ substr($abr, 0, $n) } ne $name) |
940
|
|
|
|
|
|
|
{ |
941
|
2
|
50
|
|
|
|
7
|
$n++; |
942
|
2
|
|
|
|
|
7
|
} |
943
|
2
|
|
|
|
|
12
|
if ($n <= length($abr)) { |
944
|
|
|
|
|
|
|
$self->{type_abrv}{ substr($abr, 0, $n) }= $name; |
945
|
|
|
|
|
|
|
return '$' . substr($abr, 0, $n) . (++$self->{type_ids}{$name}); |
946
|
506
|
|
|
|
|
1029
|
} |
947
|
506
|
|
|
|
|
1950
|
} |
948
|
506
|
|
|
|
|
2249
|
$name =~ s/::/_/g; |
949
|
|
|
|
|
|
|
($name)= $name =~ /(\w+)/; #take the first word; |
950
|
0
|
|
|
|
|
0
|
return '$' . $name . (++$self->{type_ids}{$name}); |
951
|
155
|
|
100
|
|
|
515
|
} |
952
|
155
|
|
|
|
|
749
|
elsif ($uname =~ /^[-*]/) { |
953
|
155
|
|
|
|
|
500
|
my $type= reftype($_[1]) || ''; |
954
|
|
|
|
|
|
|
$uname =~ s//$ttrans{$type}/; |
955
|
|
|
|
|
|
|
$uname; |
956
|
132
|
|
|
|
|
380
|
} |
957
|
|
|
|
|
|
|
else { |
958
|
|
|
|
|
|
|
return '$' . $uname; |
959
|
|
|
|
|
|
|
} |
960
|
|
|
|
|
|
|
} |
961
|
|
|
|
|
|
|
|
962
|
|
|
|
|
|
|
#=item diag |
963
|
|
|
|
|
|
|
# |
964
|
|
|
|
|
|
|
#Outputs to STDOUT a list of all values that have been identified of being |
965
|
|
|
|
|
|
|
#worth of study. For development/debugging purposes only at this point. |
966
|
|
|
|
|
|
|
# |
967
|
|
|
|
|
|
|
#=cut |
968
|
0
|
|
|
0
|
0
|
0
|
|
969
|
0
|
|
0
|
|
|
0
|
sub diag { |
970
|
0
|
|
|
|
|
0
|
my $self= shift; |
971
|
|
|
|
|
|
|
my $handle= shift || \*STDOUT; |
972
|
0
|
|
|
|
|
0
|
print $handle "+---+\n"; |
973
|
0
|
|
|
|
|
0
|
|
974
|
0
|
|
|
|
|
0
|
my $oidx; |
975
|
|
|
|
|
|
|
foreach my $idx (1 .. $self->{sv_id}) { |
976
|
0
|
0
|
0
|
|
|
0
|
print $handle $self->diag_sv_idx($idx); |
977
|
0
|
|
0
|
|
|
0
|
} |
978
|
0
|
|
|
|
|
0
|
print "-----\n" if $self->{ref_id} and $self->{sv_id}; |
979
|
|
|
|
|
|
|
foreach my $idx (1 .. ($self->{ref_id} || 0)) { |
980
|
|
|
|
|
|
|
print $handle $self->diag_ref_idx($idx); |
981
|
0
|
|
|
|
|
0
|
|
982
|
0
|
|
|
|
|
0
|
} |
983
|
|
|
|
|
|
|
print $handle "+---+\n"; |
984
|
|
|
|
|
|
|
$self; |
985
|
|
|
|
|
|
|
} |
986
|
4690
|
|
|
4690
|
0
|
7775
|
|
987
|
|
|
|
|
|
|
sub remove_deref { |
988
|
4690
|
|
|
|
|
7402
|
my $var= shift; |
989
|
4690
|
100
|
|
|
|
11825
|
|
990
|
220
|
|
|
|
|
556
|
my ($brace, $rest, $sigil); |
991
|
|
|
|
|
|
|
if ($var =~ s/^([\@\%\$])(?=\$)//) { |
992
|
|
|
|
|
|
|
($sigil, $brace)= ($1, $var); |
993
|
4470
|
|
|
|
|
6527
|
} |
994
|
4470
|
|
|
|
|
17385
|
else { |
995
|
|
|
|
|
|
|
local $@; |
996
|
|
|
|
|
|
|
($brace, $rest, $sigil)= |
997
|
4690
|
100
|
100
|
|
|
355445
|
Text::Balanced::extract_bracketed($var, '{q}', qr/[\@\%\$]/); |
998
|
406
|
|
|
|
|
1390
|
} |
999
|
406
|
50
|
|
|
|
1542
|
if ($brace and !$rest) { |
1000
|
|
|
|
|
|
|
$brace =~ s/^\{(.*)\}$/$1/; |
1001
|
|
|
|
|
|
|
return wantarray ? ($sigil, $brace) : $brace; |
1002
|
4284
|
|
|
|
|
9648
|
} |
1003
|
|
|
|
|
|
|
else { |
1004
|
|
|
|
|
|
|
return; |
1005
|
|
|
|
|
|
|
} |
1006
|
|
|
|
|
|
|
} |
1007
|
|
|
|
|
|
|
|
1008
|
|
|
|
|
|
|
my %tname= qw(HASH % ARRAY @ SCALAR $ REF $); |
1009
|
5712
|
|
|
5712
|
|
11843
|
|
1010
|
|
|
|
|
|
|
sub _build_name { |
1011
|
5712
|
50
|
|
|
|
11155
|
my ($self, $name, $type, $val)= @_; |
1012
|
5712
|
50
|
|
|
|
13122
|
|
1013
|
5712
|
100
|
|
|
|
16472
|
$DEBUG > 1 and print STDOUT " _build_name( $name '$type' => "; |
|
|
50
|
|
|
|
|
|
1014
|
|
|
|
|
|
|
$type= $tname{$type} if $tname{$type}; |
1015
|
4580
|
|
|
|
|
9080
|
if ($type =~ /[[{]/) { |
1016
|
4580
|
|
|
|
|
8333
|
|
1017
|
4580
|
100
|
100
|
|
|
21871
|
$name =~ s/[\@\%]\$/\$/; |
|
|
|
100
|
|
|
|
|
1018
|
|
|
|
|
|
|
my ($sigil, $brace)= remove_deref($name); |
1019
|
|
|
|
|
|
|
if ( $name =~ /^([\@\%\$])(\w+)$/ |
1020
|
|
|
|
|
|
|
or $sigil |
1021
|
|
|
|
|
|
|
or $name =~ /^\*.*\{(?:SCALAR|HASH|ARRAY)\}$/) |
1022
|
3245
|
100
|
66
|
|
|
11704
|
{ |
1023
|
|
|
|
|
|
|
|
1024
|
|
|
|
|
|
|
$name .= '->' |
1025
|
3245
|
|
|
|
|
7076
|
if !($name =~ s/^[\@\%]/\$/) |
1026
|
|
|
|
|
|
|
or $sigil; |
1027
|
|
|
|
|
|
|
$name =~ s/^\$(\$.*)->$/\$\{$1\}->/; |
1028
|
4580
|
50
|
|
|
|
9645
|
} |
1029
|
|
|
|
|
|
|
|
1030
|
4580
|
100
|
|
|
|
9592
|
$DEBUG > 1 and print STDOUT "$name => "; |
|
|
50
|
|
|
|
|
|
1031
|
2196
|
|
|
|
|
4665
|
|
1032
|
|
|
|
|
|
|
if ($type eq '[') { |
1033
|
|
|
|
|
|
|
$name .= "[$val]"; |
1034
|
2384
|
|
|
|
|
4675
|
} |
1035
|
|
|
|
|
|
|
elsif ($type eq '{') { |
1036
|
|
|
|
|
|
|
$name .= "{" . _quotekey($val) . "}"; |
1037
|
0
|
|
|
|
|
0
|
} |
1038
|
|
|
|
|
|
|
else { |
1039
|
|
|
|
|
|
|
Carp::confess "Fallen off the end of the world..."; |
1040
|
|
|
|
|
|
|
} |
1041
|
1132
|
100
|
100
|
|
|
4178
|
} |
1042
|
|
|
|
|
|
|
elsif ($type =~ /^[\@\%\$]$/) { |
1043
|
1132
|
50
|
66
|
|
|
5359
|
$name= "{$name}" |
1044
|
|
|
|
|
|
|
if $name =~ /[\[\{]/ or $name =~ /^\*/; |
1045
|
|
|
|
|
|
|
$name= $type . $name |
1046
|
|
|
|
|
|
|
unless substr($name, 0, 1) eq $type and $type ne '$'; |
1047
|
|
|
|
|
|
|
|
1048
|
26
|
|
|
26
|
|
226
|
} |
|
26
|
|
|
|
|
65
|
|
|
26
|
|
|
|
|
222892
|
|
1049
|
0
|
|
|
|
|
0
|
else { |
1050
|
|
|
|
|
|
|
no warnings; # XXX - why is this here? Yves |
1051
|
5712
|
50
|
|
|
|
12258
|
Carp::confess "unimplemented _build_name"; |
1052
|
5712
|
|
|
|
|
15403
|
} |
1053
|
|
|
|
|
|
|
$DEBUG > 1 and print "$name )\n"; |
1054
|
|
|
|
|
|
|
$name; |
1055
|
|
|
|
|
|
|
} |
1056
|
352
|
|
|
352
|
|
608
|
|
1057
|
352
|
|
|
|
|
2511
|
sub _reset { |
1058
|
11353
|
100
|
|
|
|
26038
|
my $self= shift; |
1059
|
8672
|
|
|
|
|
17049
|
foreach my $key (keys %$self) { |
1060
|
|
|
|
|
|
|
next unless $key =~ /^(sv|ref|fix|cat|type|names|reqs|cache)/; |
1061
|
352
|
|
|
|
|
1239
|
delete $self->{$key}; |
1062
|
352
|
|
|
|
|
812
|
} |
1063
|
|
|
|
|
|
|
$self->{sv_id}= $self->{ref_id}= 0; |
1064
|
|
|
|
|
|
|
$self; |
1065
|
|
|
|
|
|
|
} |
1066
|
0
|
|
|
0
|
0
|
0
|
|
1067
|
0
|
|
|
|
|
0
|
sub diag_sv_idx { |
1068
|
0
|
|
0
|
|
|
0
|
my $self= shift; |
1069
|
0
|
|
|
|
|
0
|
my $idx= shift; |
1070
|
|
|
|
|
|
|
my $prefix= shift || ''; |
1071
|
|
|
|
|
|
|
my $oidx= $self->{ref}{ $self->{sva}[$idx] }; |
1072
|
|
|
|
|
|
|
my $ret= $prefix |
1073
|
0
|
|
|
|
|
0
|
. sprintf "S%s%2d : %#x(c%2d|%2d) Dp:%2d %s Du:%s => %s %s %s %s\n", |
1074
|
|
|
|
|
|
|
($self->{special}{$idx} ? '*' : ' '), $idx, |
1075
|
|
|
|
|
|
|
(map { $self->{$_}[$idx] } qw( sva svc svt svd )), |
1076
|
|
|
|
|
|
|
($self->{svro}[$idx] ? 'RO ' : 'RW'), |
1077
|
0
|
|
|
|
|
0
|
( |
|
0
|
|
|
|
|
0
|
|
1078
|
|
|
|
|
|
|
!$self->{svdu}[$idx] ? '-' |
1079
|
|
|
|
|
|
|
: defined ${ $self->{svdu}[$idx] } ? ${ $self->{svdu}[$idx] } |
1080
|
|
|
|
|
|
|
: '?' |
1081
|
|
|
|
|
|
|
), |
1082
|
|
|
|
|
|
|
$self->{svn}[$idx], ( |
1083
|
0
|
0
|
|
|
|
0
|
defined $self->{unames}[ $idx - 1 ] ? "($self->{unames}[$idx-1])" : ""), |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
1084
|
0
|
0
|
0
|
|
|
0
|
(($oidx) ? "< $self->{refn}[$oidx] >" : ""), |
1085
|
0
|
|
|
|
|
0
|
($self->{svon}{$idx} ? ": $self->{svon}{$idx}" : ""); |
1086
|
|
|
|
|
|
|
if ($prefix and $oidx) { |
1087
|
0
|
|
|
|
|
0
|
$ret .= $prefix . $self->diag_ref_idx($oidx); |
1088
|
|
|
|
|
|
|
} |
1089
|
|
|
|
|
|
|
$ret; |
1090
|
|
|
|
|
|
|
} |
1091
|
0
|
|
|
0
|
0
|
0
|
|
1092
|
0
|
|
|
|
|
0
|
sub diag_ref_idx { |
1093
|
0
|
|
|
|
|
0
|
my $self= shift; |
1094
|
|
|
|
|
|
|
my $idx= shift; |
1095
|
|
|
|
|
|
|
my $oidx= $self->{sv}{ $self->{refa}[$idx] }; |
1096
|
0
|
0
|
|
|
|
0
|
sprintf "R %2d : %#x(c%2d|%2d) Dp:%2d Du:%s => %s %s\n", |
1097
|
|
|
|
|
|
|
$idx, |
1098
|
|
|
|
|
|
|
(map { defined $self->{$_}[$idx] ? $self->{$_}[$idx] : -1 } |
1099
|
0
|
|
|
|
|
0
|
qw(refa refc reft refd )), ( |
|
0
|
|
|
|
|
0
|
|
1100
|
|
|
|
|
|
|
!$self->{refdu}[$idx] ? '-' |
1101
|
|
|
|
|
|
|
: defined ${ $self->{refdu}[$idx] } ? ${ $self->{refdu}[$idx] } |
1102
|
0
|
0
|
|
|
|
0
|
: '?' |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
1103
|
|
|
|
|
|
|
), |
1104
|
|
|
|
|
|
|
$self->{refn}[$idx], |
1105
|
|
|
|
|
|
|
(($oidx) ? " < $self->{svn}[$oidx] >" : ""); |
1106
|
|
|
|
|
|
|
} |
1107
|
|
|
|
|
|
|
|
1108
|
|
|
|
|
|
|
=item Dump |
1109
|
|
|
|
|
|
|
|
1110
|
|
|
|
|
|
|
=item Dump VALUES |
1111
|
|
|
|
|
|
|
|
1112
|
|
|
|
|
|
|
Smart non method based constructor. |
1113
|
|
|
|
|
|
|
|
1114
|
|
|
|
|
|
|
This routine behaves very differently depending on the context it is |
1115
|
|
|
|
|
|
|
called in and whether arguments are provided. |
1116
|
|
|
|
|
|
|
|
1117
|
|
|
|
|
|
|
If called with no arguments it is exactly equivalent to calling |
1118
|
|
|
|
|
|
|
|
1119
|
|
|
|
|
|
|
Data::Dump::Streamer->new() |
1120
|
|
|
|
|
|
|
|
1121
|
|
|
|
|
|
|
which means it returns an object reference. |
1122
|
|
|
|
|
|
|
|
1123
|
|
|
|
|
|
|
If called with arguments and in scalar context it is equivalent to calling |
1124
|
|
|
|
|
|
|
|
1125
|
|
|
|
|
|
|
Data::Dump::Streamer->new()->Data(@vals) |
1126
|
|
|
|
|
|
|
|
1127
|
|
|
|
|
|
|
except that the actual depth first traversal is I until C |
1128
|
|
|
|
|
|
|
is called. This means that options that must be provided before the |
1129
|
|
|
|
|
|
|
C phase can be provided after the call to C. Again, it |
1130
|
|
|
|
|
|
|
returns a object reference. |
1131
|
|
|
|
|
|
|
|
1132
|
|
|
|
|
|
|
If called with arguments and in void or list context it is equivelent to |
1133
|
|
|
|
|
|
|
calling |
1134
|
|
|
|
|
|
|
|
1135
|
|
|
|
|
|
|
Data::Dump::Streamer->new()->Data(@vals)->Out() |
1136
|
|
|
|
|
|
|
|
1137
|
|
|
|
|
|
|
The reason this is true in list context is to make |
1138
|
|
|
|
|
|
|
C do the right thing. And also that combined with |
1139
|
|
|
|
|
|
|
method chaining options can be added or removed as required quite easily |
1140
|
|
|
|
|
|
|
and naturally. |
1141
|
|
|
|
|
|
|
|
1142
|
|
|
|
|
|
|
So to put it short: |
1143
|
|
|
|
|
|
|
|
1144
|
|
|
|
|
|
|
my $obj=Dump($x,$y); # Returns an object |
1145
|
|
|
|
|
|
|
my $str=Dump($x,$y)->Out(); # Returns a string of the dump. |
1146
|
|
|
|
|
|
|
my @code=Dump($x,$y); # Returns a list of the dump. |
1147
|
|
|
|
|
|
|
|
1148
|
|
|
|
|
|
|
Dump($x,$y); # prints the dump. |
1149
|
|
|
|
|
|
|
print Dump($x,$y); # prints the dump. |
1150
|
|
|
|
|
|
|
|
1151
|
|
|
|
|
|
|
It should be noted that the setting of C<$\> will affect the behaviour of |
1152
|
|
|
|
|
|
|
both of |
1153
|
|
|
|
|
|
|
|
1154
|
|
|
|
|
|
|
Dump($x,$y); |
1155
|
|
|
|
|
|
|
print Dump($x,$y); |
1156
|
|
|
|
|
|
|
|
1157
|
|
|
|
|
|
|
but it will not affect the behaviour of |
1158
|
|
|
|
|
|
|
|
1159
|
|
|
|
|
|
|
print scalar Dump($x,$y); |
1160
|
|
|
|
|
|
|
|
1161
|
|
|
|
|
|
|
B As of 1.11 Dump also works as a method, with identical properties |
1162
|
|
|
|
|
|
|
as when called as a subroutine, with the exception that when called with |
1163
|
|
|
|
|
|
|
no arguments it is a synonym for C. Thus |
1164
|
|
|
|
|
|
|
|
1165
|
|
|
|
|
|
|
$obj->Dump($foo)->Names('foo')->Out(); |
1166
|
|
|
|
|
|
|
|
1167
|
|
|
|
|
|
|
will work fine, as will the odd looking: |
1168
|
|
|
|
|
|
|
|
1169
|
|
|
|
|
|
|
$obj->Dump($foo)->Names('foo')->Dump(); |
1170
|
|
|
|
|
|
|
|
1171
|
|
|
|
|
|
|
which are both the same as |
1172
|
|
|
|
|
|
|
|
1173
|
|
|
|
|
|
|
$obj->Names('foo')->Data($foo)->Out(); |
1174
|
|
|
|
|
|
|
|
1175
|
|
|
|
|
|
|
Hopefully this should make method use more or less DWIM. |
1176
|
|
|
|
|
|
|
|
1177
|
|
|
|
|
|
|
=cut |
1178
|
|
|
|
|
|
|
|
1179
|
|
|
|
|
|
|
my %args_insideout; |
1180
|
53
|
|
|
53
|
|
23821
|
|
1181
|
53
|
50
|
|
|
|
3335
|
sub DESTROY { |
1182
|
|
|
|
|
|
|
my $self= shift; |
1183
|
|
|
|
|
|
|
delete $args_insideout{ Data::Dump::Streamer::refaddr $self} if $self; |
1184
|
|
|
|
|
|
|
} |
1185
|
40
|
|
|
40
|
1
|
33605
|
|
1186
|
40
|
100
|
100
|
|
|
260
|
sub Dump { |
1187
|
3
|
|
|
|
|
7
|
my $obj; |
1188
|
|
|
|
|
|
|
if (blessed($_[0]) and blessed($_[0]) eq __PACKAGE__) { |
1189
|
40
|
100
|
|
|
|
131
|
$obj= shift; |
1190
|
21
|
100
|
66
|
|
|
104
|
} |
1191
|
14
|
|
66
|
|
|
153
|
if (@_) { |
1192
|
14
|
|
|
|
|
63
|
if (defined wantarray and !wantarray) { |
1193
|
14
|
|
|
|
|
93
|
$obj ||= __PACKAGE__->new(); |
1194
|
|
|
|
|
|
|
$obj->_make_args(@_); |
1195
|
|
|
|
|
|
|
return $obj; |
1196
|
7
|
|
50
|
|
|
34
|
} |
1197
|
7
|
|
|
|
|
37
|
else { |
1198
|
|
|
|
|
|
|
$obj ||= __PACKAGE__; |
1199
|
|
|
|
|
|
|
return $obj->Data(@_)->Out(); |
1200
|
|
|
|
|
|
|
} |
1201
|
19
|
100
|
|
|
|
70
|
} |
1202
|
2
|
|
|
|
|
11
|
else { |
1203
|
|
|
|
|
|
|
if ($obj) { |
1204
|
|
|
|
|
|
|
return $obj->Out(); |
1205
|
17
|
|
|
|
|
76
|
} |
1206
|
|
|
|
|
|
|
else { |
1207
|
|
|
|
|
|
|
return __PACKAGE__->new(); |
1208
|
|
|
|
|
|
|
} |
1209
|
|
|
|
|
|
|
} |
1210
|
|
|
|
|
|
|
} |
1211
|
|
|
|
|
|
|
|
1212
|
|
|
|
|
|
|
=item DumpLex VALUES |
1213
|
|
|
|
|
|
|
|
1214
|
|
|
|
|
|
|
DumpLex is similar to Dump except it will try to automatically determine |
1215
|
|
|
|
|
|
|
the names to use for the variables being dumped by using PadWalker to |
1216
|
|
|
|
|
|
|
have a poke around the calling lexical scope to see what is declared. If |
1217
|
|
|
|
|
|
|
a name for a var can't be found then it will be named according to the |
1218
|
|
|
|
|
|
|
normal scheme. When PadWalker isn't installed this is just a wrapper for |
1219
|
|
|
|
|
|
|
L. |
1220
|
|
|
|
|
|
|
|
1221
|
|
|
|
|
|
|
Thanks to Ovid for the idea of this. See L for a |
1222
|
|
|
|
|
|
|
similar wrapper around L. |
1223
|
|
|
|
|
|
|
|
1224
|
|
|
|
|
|
|
=cut |
1225
|
2
|
50
|
|
2
|
1
|
92
|
|
1226
|
|
|
|
|
|
|
sub DumpLex { |
1227
|
|
|
|
|
|
|
if (!$HasPadWalker) { |
1228
|
|
|
|
|
|
|
|
1229
|
0
|
|
|
|
|
0
|
#warn( "Can't use DumpLex without ". |
1230
|
|
|
|
|
|
|
# "PadWalker v1.0 or later installed."); |
1231
|
2
|
|
|
|
|
4
|
goto &Dump; |
1232
|
2
|
50
|
33
|
|
|
10
|
} |
1233
|
0
|
|
|
|
|
0
|
my $obj; |
1234
|
|
|
|
|
|
|
if (blessed($_[0]) and blessed($_[0]) eq __PACKAGE__) { |
1235
|
2
|
|
|
|
|
3
|
$obj= shift; |
1236
|
|
|
|
|
|
|
} |
1237
|
|
|
|
|
|
|
my @names; |
1238
|
|
|
|
|
|
|
|
1239
|
|
|
|
|
|
|
# = map { |
1240
|
|
|
|
|
|
|
# PadWalker::var_name(1,\$_) |
1241
|
|
|
|
|
|
|
# || PadWalker::var_name(1,\$_) |
1242
|
|
|
|
|
|
|
# (ref $_ && PadWalker::var_name(1,$_)); |
1243
|
|
|
|
|
|
|
# $str |
1244
|
|
|
|
|
|
|
# } @_; |
1245
|
|
|
|
|
|
|
#if ( !@names && @_ ) { |
1246
|
2
|
|
|
|
|
44
|
|
1247
|
4
|
|
|
|
|
18
|
my %pad_vars; |
1248
|
17
|
|
33
|
|
|
93
|
foreach my $pad (PadWalker::peek_my(1), PadWalker::peek_our(1)) { |
1249
|
|
|
|
|
|
|
while (my ($var, $ref)= each %$pad) { |
1250
|
|
|
|
|
|
|
$pad_vars{ refaddr $ref } ||= $var; |
1251
|
2
|
|
|
|
|
14
|
} |
1252
|
5
|
|
|
|
|
12
|
} |
1253
|
5
|
|
|
|
|
11
|
foreach (@_) { |
1254
|
7
|
100
|
|
|
|
22
|
my $name; |
1255
|
|
|
|
|
|
|
INNER: foreach (\$_, $_) { |
1256
|
|
|
|
|
|
|
$name= $pad_vars{ refaddr $_} |
1257
|
5
|
|
|
|
|
10
|
and last INNER; |
1258
|
|
|
|
|
|
|
} |
1259
|
2
|
50
|
33
|
|
|
11
|
push @names, $name; |
1260
|
2
|
|
33
|
|
|
10
|
} |
1261
|
2
|
|
|
|
|
12
|
if (defined wantarray and !wantarray) { |
1262
|
2
|
|
|
|
|
9
|
$obj ||= __PACKAGE__->new(); |
1263
|
2
|
|
|
|
|
13
|
$obj->_make_args(@_); |
1264
|
|
|
|
|
|
|
$obj->Names(@names); |
1265
|
|
|
|
|
|
|
return $obj; |
1266
|
0
|
|
0
|
|
|
0
|
} |
1267
|
0
|
|
|
|
|
0
|
else { |
1268
|
|
|
|
|
|
|
$obj ||= __PACKAGE__; |
1269
|
|
|
|
|
|
|
return $obj->Names(@names)->Data(@_)->Out(); |
1270
|
|
|
|
|
|
|
} |
1271
|
|
|
|
|
|
|
} |
1272
|
|
|
|
|
|
|
|
1273
|
|
|
|
|
|
|
=item DumpVars PAIRS |
1274
|
|
|
|
|
|
|
|
1275
|
|
|
|
|
|
|
This is wrapper around L which expect to receive |
1276
|
|
|
|
|
|
|
a list of name=>value pairs instead of a list of values. |
1277
|
|
|
|
|
|
|
Otherwise behaves like L. Note that names starting |
1278
|
|
|
|
|
|
|
with a '-' are treated the same as those starting with '*' when |
1279
|
|
|
|
|
|
|
passed to L. |
1280
|
|
|
|
|
|
|
|
1281
|
|
|
|
|
|
|
=cut |
1282
|
1
|
|
|
1
|
1
|
3
|
|
1283
|
1
|
50
|
33
|
|
|
7
|
sub DumpVars { |
1284
|
0
|
|
|
|
|
0
|
my $obj; |
1285
|
|
|
|
|
|
|
if (blessed($_[0]) and blessed($_[0]) eq __PACKAGE__) { |
1286
|
1
|
50
|
|
|
|
7
|
$obj= shift; |
1287
|
0
|
|
|
|
|
0
|
} |
1288
|
0
|
|
|
|
|
0
|
if (@_ % 2) { |
1289
|
|
|
|
|
|
|
warnings::warnif "Odd number of arguments in DumpVars"; |
1290
|
1
|
|
|
|
|
3
|
pop @_; |
1291
|
|
|
|
|
|
|
} |
1292
|
1
|
|
|
|
|
7
|
my @names; |
1293
|
3
|
|
|
|
|
8
|
my @args; |
1294
|
3
|
|
|
|
|
8
|
for (0 .. $#_ / 2) { |
1295
|
|
|
|
|
|
|
$names[$_]= $_[ $_ * 2 ]; |
1296
|
|
|
|
|
|
|
$args[$_]= $_ * 2 + 1; |
1297
|
|
|
|
|
|
|
} |
1298
|
1
|
50
|
33
|
|
|
13
|
|
1299
|
1
|
|
33
|
|
|
8
|
#die "@_:@names|@args"; |
1300
|
1
|
|
|
|
|
24
|
if (defined wantarray and !wantarray) { |
1301
|
1
|
|
|
|
|
8
|
$obj ||= __PACKAGE__->new(); |
1302
|
1
|
|
|
|
|
11
|
$obj->_make_args(@_[@args]); |
1303
|
|
|
|
|
|
|
$obj->Names(@names); |
1304
|
|
|
|
|
|
|
return $obj; |
1305
|
0
|
|
0
|
|
|
0
|
} |
1306
|
0
|
|
|
|
|
0
|
else { |
1307
|
|
|
|
|
|
|
$obj ||= __PACKAGE__; |
1308
|
|
|
|
|
|
|
return $obj->Data(@_[@args])->Names(@names)->Out(); |
1309
|
|
|
|
|
|
|
} |
1310
|
|
|
|
|
|
|
} |
1311
|
2278
|
|
|
2278
|
|
4533
|
|
1312
|
|
|
|
|
|
|
sub _reg_ref { |
1313
|
2278
|
50
|
|
|
|
4046
|
my ($self, $item, $depth, $name, $cnt, $arg)= @_; |
1314
|
|
|
|
|
|
|
|
1315
|
2278
|
|
|
|
|
3939
|
print "_reg_ref($depth,$name,$cnt)\n" if $DEBUG; |
1316
|
2278
|
100
|
|
|
|
4461
|
|
1317
|
2278
|
|
|
|
|
2979
|
my $addr= refaddr $item; |
1318
|
2278
|
100
|
|
|
|
5434
|
$arg->{raddr}= $addr if $arg; |
1319
|
1579
|
|
|
|
|
4023
|
my $idx; |
1320
|
1579
|
100
|
|
|
|
3755
|
unless ($idx= $self->{ref}{$addr}) { |
1321
|
1579
|
|
|
|
|
3266
|
$idx= $self->{ref}{$addr}= ++$self->{ref_id}; |
1322
|
1579
|
|
|
|
|
2708
|
$arg->{ridx}= $idx if $arg; |
1323
|
1579
|
|
|
|
|
2884
|
$self->{refn}[$idx]= $name; |
1324
|
1579
|
|
|
|
|
2501
|
$self->{refd}[$idx]= $depth; |
1325
|
1579
|
50
|
|
|
|
4977
|
$self->{refa}[$idx]= $addr; |
1326
|
|
|
|
|
|
|
$self->{refc}[$idx]= $cnt; |
1327
|
699
|
|
|
|
|
1302
|
return wantarray ? ($idx, 0) : $idx; |
1328
|
699
|
100
|
|
|
|
1382
|
} |
1329
|
699
|
50
|
|
|
|
1831
|
$self->{reft}[$idx]++; |
1330
|
|
|
|
|
|
|
$arg->{ridx}= $idx if $arg; |
1331
|
|
|
|
|
|
|
return wantarray ? ($idx, 1) : undef; |
1332
|
|
|
|
|
|
|
} |
1333
|
1553
|
|
|
1553
|
|
3647
|
|
1334
|
1553
|
50
|
|
|
|
3437
|
sub _reg_scalar { |
1335
|
1553
|
|
|
|
|
3277
|
my ($self, $item, $depth, $cnt, $ro, $name, $arg)= @_; |
1336
|
1553
|
|
|
|
|
2310
|
Carp::cluck $name if $name =~ /^\$\*/; |
1337
|
1553
|
100
|
|
|
|
3214
|
my $addr= refaddr \$_[1]; |
1338
|
1553
|
100
|
|
|
|
3982
|
my $idx; |
1339
|
1214
|
|
|
|
|
3134
|
$arg->{addr}= $addr if $arg; |
1340
|
1214
|
|
|
|
|
2626
|
unless ($idx= $self->{sv}{$addr}) { |
1341
|
1214
|
|
|
|
|
2272
|
$idx= $self->{sv}{$addr}= ++$self->{sv_id}; |
1342
|
1214
|
|
|
|
|
2050
|
$self->{svd}[$idx]= $depth; |
1343
|
1214
|
|
|
|
|
1907
|
$self->{sva}[$idx]= $addr; |
1344
|
1214
|
100
|
|
|
|
2994
|
$self->{svro}[$idx]= $ro; |
1345
|
|
|
|
|
|
|
$self->{svc}[$idx]= $cnt; |
1346
|
1214
|
|
|
|
|
3434
|
$self->{svw}{$addr}= !0 |
1347
|
1214
|
100
|
|
|
|
2875
|
if isweak($_[1]); |
1348
|
139
|
|
|
|
|
248
|
($self->{svn}[$idx]= $name) =~ s/^[\@\%\&]/\$/; |
1349
|
|
|
|
|
|
|
if ($self->{svn}[$idx] ne $name) { |
1350
|
139
|
|
|
|
|
411
|
$self->{svn}[$idx] .= "_"; #XXX |
1351
|
|
|
|
|
|
|
#warn "$self->{svn}[$idx] ne $name" |
1352
|
|
|
|
|
|
|
$self->{svon}{$idx}= $name; |
1353
|
|
|
|
|
|
|
} |
1354
|
|
|
|
|
|
|
|
1355
|
339
|
50
|
|
|
|
723
|
} |
1356
|
0
|
|
|
|
|
0
|
else { |
1357
|
0
|
|
|
|
|
0
|
if ($DEBUG > 9) { |
1358
|
|
|
|
|
|
|
print $self->diag_sv_idx($idx); |
1359
|
|
|
|
|
|
|
print "$name is already registered as $self->{svn}[$idx] " |
1360
|
339
|
100
|
100
|
|
|
1150
|
. "Depth ($self->{svd}[$idx]) $depth\n"; |
1361
|
12
|
|
|
|
|
28
|
} |
1362
|
|
|
|
|
|
|
if ($self->{svn}[$idx] =~ /^\$\{?\$/ and $name !~ /^\$\{?\$/) { |
1363
|
|
|
|
|
|
|
$self->{svn}[$idx]= $name; |
1364
|
1553
|
|
|
|
|
2877
|
} |
1365
|
1553
|
100
|
|
|
|
3034
|
} |
1366
|
1553
|
50
|
|
|
|
3335
|
$self->{svt}[$idx]++; |
1367
|
1553
|
|
|
|
|
3267
|
$arg->{idx}= $idx if $arg; |
1368
|
1553
|
|
|
|
|
3082
|
Carp::confess "Dupe name!" if $self->{svrt}{$name}; |
1369
|
|
|
|
|
|
|
$self->{svrt}{$name}= $idx; |
1370
|
|
|
|
|
|
|
return $name; |
1371
|
|
|
|
|
|
|
} |
1372
|
|
|
|
|
|
|
|
1373
|
|
|
|
|
|
|
*Precise= \&Dump; |
1374
|
|
|
|
|
|
|
|
1375
|
357
|
|
|
357
|
|
577
|
# we make an array of hashes containing useful info about the arguments |
1376
|
|
|
|
|
|
|
sub _make_args { |
1377
|
|
|
|
|
|
|
my $self= shift; |
1378
|
357
|
|
|
|
|
1011
|
$args_insideout{ refaddr $self}= [ |
1379
|
755
|
|
|
|
|
5017
|
map { |
1380
|
|
|
|
|
|
|
{ |
1381
|
|
|
|
|
|
|
item => \$_[$_], |
1382
|
|
|
|
|
|
|
ro => readonly($_[$_]), |
1383
|
|
|
|
|
|
|
refcnt => sv_refcount($_[$_]), |
1384
|
|
|
|
|
|
|
} |
1385
|
357
|
|
|
|
|
1109
|
} 0 .. $#_ |
1386
|
|
|
|
|
|
|
]; |
1387
|
|
|
|
|
|
|
return $args_insideout{ refaddr $self}; |
1388
|
|
|
|
|
|
|
} |
1389
|
|
|
|
|
|
|
|
1390
|
|
|
|
|
|
|
=back |
1391
|
|
|
|
|
|
|
|
1392
|
|
|
|
|
|
|
=head2 Methods |
1393
|
|
|
|
|
|
|
|
1394
|
|
|
|
|
|
|
=over 4 |
1395
|
|
|
|
|
|
|
|
1396
|
|
|
|
|
|
|
=item Data |
1397
|
|
|
|
|
|
|
|
1398
|
|
|
|
|
|
|
=item Data LIST |
1399
|
|
|
|
|
|
|
|
1400
|
|
|
|
|
|
|
Analyzes a list of variables in breadth first order. |
1401
|
|
|
|
|
|
|
|
1402
|
|
|
|
|
|
|
If called with arguments then the internal object state is reset before |
1403
|
|
|
|
|
|
|
scanning the list of arguments provided. |
1404
|
|
|
|
|
|
|
|
1405
|
|
|
|
|
|
|
If called with no arguments then whatever arguments were provided to C |
1406
|
|
|
|
|
|
|
will be scanned. |
1407
|
|
|
|
|
|
|
|
1408
|
|
|
|
|
|
|
Returns $self. |
1409
|
|
|
|
|
|
|
|
1410
|
|
|
|
|
|
|
=cut |
1411
|
2263
|
|
|
2263
|
|
5662
|
|
1412
|
2263
|
50
|
|
|
|
4542
|
sub _add_queue { |
1413
|
2263
|
100
|
|
|
|
5047
|
my ($self, $queue, $type, $item, $depth, $name, $rcount, $arg)= @_; |
|
|
50
|
|
|
|
|
|
1414
|
2235
|
|
|
|
|
5657
|
print "add_queue($name)\n" if $DEBUG; |
1415
|
|
|
|
|
|
|
if (substr($type, 0, 1) ne '*') { |
1416
|
|
|
|
|
|
|
push @$queue, [ \$item, $depth, $name, $rcount, $arg ]; |
1417
|
28
|
|
|
|
|
91
|
} |
1418
|
28
|
|
|
|
|
78
|
elsif ($self->{style}{dumpglob}) { |
1419
|
|
|
|
|
|
|
local @_; |
1420
|
|
|
|
|
|
|
foreach my $t ($self->_glob_slots('FORMAT')) { |
1421
|
|
|
|
|
|
|
|
1422
|
|
|
|
|
|
|
#warn $type.":$t\n"; |
1423
|
|
|
|
|
|
|
#register? |
1424
|
|
|
|
|
|
|
#$self->_reg_scalar(*$item{$t},$depth+1,sv_refcount(*$item{$t}), |
1425
|
140
|
|
|
|
|
307
|
# readonly(*$item{$t}),'*'.$name."{$t}"); |
1426
|
140
|
100
|
|
|
|
354
|
|
1427
|
56
|
100
|
100
|
|
|
187
|
my $v= *$item{$t}; |
1428
|
|
|
|
|
|
|
next unless defined $v; |
1429
|
|
|
|
|
|
|
next if $t eq 'SCALAR' and !defined($$v); |
1430
|
45
|
|
|
|
|
248
|
push @$queue, [ |
1431
|
|
|
|
|
|
|
\*$item{$t}, $depth + 1, |
1432
|
|
|
|
|
|
|
$type . "{$t}", refcount(\*$item{$t}) ]; |
1433
|
|
|
|
|
|
|
} |
1434
|
|
|
|
|
|
|
} |
1435
|
2263
|
|
|
|
|
6335
|
|
1436
|
|
|
|
|
|
|
#use Scalar::Util qw(weaken); |
1437
|
|
|
|
|
|
|
$self; |
1438
|
|
|
|
|
|
|
} |
1439
|
352
|
|
|
352
|
1
|
215825
|
|
1440
|
352
|
|
|
|
|
586
|
sub Data { |
1441
|
352
|
50
|
|
|
|
884
|
my $self= shift->_safe_self; |
1442
|
|
|
|
|
|
|
my $args; |
1443
|
352
|
100
|
|
|
|
923
|
print "Data(" . scalar(@_) . " vars)\n" |
|
|
50
|
|
|
|
|
|
1444
|
340
|
|
|
|
|
1047
|
if $DEBUG; |
1445
|
340
|
|
|
|
|
1048
|
if (@_) { |
1446
|
|
|
|
|
|
|
$self->_reset; |
1447
|
|
|
|
|
|
|
$self->_make_args(@_); |
1448
|
0
|
|
|
|
|
0
|
} |
1449
|
|
|
|
|
|
|
elsif ($self->{cataloged}) { |
1450
|
352
|
|
33
|
|
|
1153
|
$self->_reset; |
1451
|
|
|
|
|
|
|
} |
1452
|
352
|
|
|
|
|
612
|
$args= $args_insideout{ refaddr $self} |
1453
|
|
|
|
|
|
|
|| Carp::carp "No arguments!"; |
1454
|
352
|
|
|
|
|
513
|
my $pass= 1; |
|
364
|
|
|
|
|
519
|
|
1455
|
364
|
|
|
|
|
557
|
PASS: { |
1456
|
364
|
|
|
|
|
769
|
my @queue; |
1457
|
|
|
|
|
|
|
my $idx= 0; |
1458
|
|
|
|
|
|
|
foreach my $arg (@$args) { |
1459
|
795
|
|
|
|
|
1107
|
|
|
795
|
|
|
|
|
2018
|
|
1460
|
795
|
|
|
|
|
2304
|
#($self,$item,$depth,$cnt,$ro,$name) |
1461
|
795
|
|
|
|
|
1448
|
my $make_name= $self->_make_name(${ $arg->{item} }, $idx++); |
1462
|
795
|
|
|
|
|
1545
|
my $name= $self->_reg_scalar(${ $arg->{item} }, |
1463
|
795
|
100
|
|
|
|
1137
|
1, $arg->{refcnt}, $arg->{ro}, $make_name, $arg); |
|
795
|
|
|
|
|
2855
|
|
1464
|
686
|
|
|
|
|
1195
|
$arg->{name}= $name; |
1465
|
686
|
|
|
|
|
1163
|
if (my $type= reftype_or_glob ${ $arg->{item} }) { |
|
686
|
|
|
|
|
1973
|
|
1466
|
|
|
|
|
|
|
$self->_add_queue(\@queue, $type, ${ $arg->{item} }, |
1467
|
|
|
|
|
|
|
2, $name, refcount ${ $arg->{item} }, $arg); |
1468
|
|
|
|
|
|
|
} |
1469
|
364
|
|
|
|
|
1218
|
} |
1470
|
|
|
|
|
|
|
|
1471
|
364
|
|
|
|
|
0
|
my %lex_addr; |
1472
|
364
|
|
|
|
|
0
|
my %lex_addr2name; |
1473
|
|
|
|
|
|
|
my %lex_name; |
1474
|
|
|
|
|
|
|
my %lex_special; |
1475
|
364
|
|
|
|
|
901
|
|
1476
|
|
|
|
|
|
|
ITEM: |
1477
|
|
|
|
|
|
|
while (@queue) { |
1478
|
|
|
|
|
|
|
|
1479
|
|
|
|
|
|
|
# If the scalar (container) is of any interest it is |
1480
|
|
|
|
|
|
|
# already registered by the time we see it here. |
1481
|
2280
|
50
|
|
|
|
4710
|
# at this point we only care about the contents, not the |
1482
|
|
|
|
|
|
|
# container. |
1483
|
|
|
|
|
|
|
print Data::Dumper->new([ \@queue ], ['*queue'])->Maxdepth(3)->Dump |
1484
|
2280
|
|
|
|
|
3127
|
if $DEBUG >= 10; |
|
2280
|
|
|
|
|
4948
|
|
1485
|
|
|
|
|
|
|
|
1486
|
2280
|
|
|
|
|
4440
|
my ($ritem, $cdepth, $cname, $rcnt, $arg)= @{ shift @queue }; |
1487
|
|
|
|
|
|
|
|
1488
|
2280
|
|
|
|
|
3199
|
my ($frozen, $item, $raddr, $class); |
|
2284
|
|
|
|
|
3414
|
|
1489
|
2284
|
|
|
|
|
4316
|
DEQUEUE: { |
1490
|
2284
|
|
|
|
|
4052
|
$item= $$ritem; |
1491
|
|
|
|
|
|
|
$raddr= refaddr($item); |
1492
|
2284
|
100
|
|
|
|
5228
|
$class= blessed($item); |
1493
|
1
|
50
|
|
|
|
5
|
|
1494
|
1
|
|
|
|
|
4
|
if ($self->{ref_fz}{$raddr}) { |
1495
|
|
|
|
|
|
|
print "Skipping frozen element $raddr\n" if $DEBUG; |
1496
|
2283
|
50
|
|
|
|
4518
|
next ITEM; |
1497
|
0
|
0
|
|
|
|
0
|
} |
1498
|
0
|
|
|
|
|
0
|
if ($cname =~ /^\*DB::args/) { |
1499
|
|
|
|
|
|
|
print "Skipping \*DB::args\n" if $DEBUG; |
1500
|
|
|
|
|
|
|
next ITEM; |
1501
|
|
|
|
|
|
|
} |
1502
|
2283
|
50
|
|
|
|
4059
|
|
1503
|
|
|
|
|
|
|
$DEBUG |
1504
|
2283
|
50
|
|
|
|
4255
|
and print "Q-> $item $cdepth $cname $rcnt ($raddr)\n"; |
1505
|
0
|
0
|
|
|
|
0
|
|
1506
|
|
|
|
|
|
|
unless ($raddr) { |
1507
|
|
|
|
|
|
|
$DEBUG |
1508
|
0
|
|
|
|
|
0
|
and print |
1509
|
|
|
|
|
|
|
" Skipping '$cname' as it isn't a reference.\n"; |
1510
|
|
|
|
|
|
|
next ITEM; |
1511
|
2283
|
100
|
|
|
|
4294
|
} |
1512
|
2279
|
|
|
|
|
3289
|
|
1513
|
2279
|
100
|
100
|
|
|
12424
|
last DEQUEUE if $frozen; |
|
|
100
|
66
|
|
|
|
|
|
|
|
100
|
|
|
|
|
1514
|
|
|
|
|
|
|
$frozen= 1; |
1515
|
|
|
|
|
|
|
if ($self->{style}{ignore}{"#$raddr"} |
1516
|
1
|
50
|
|
|
|
16
|
|| ($class && $self->{style}{ignore}{".$class"})) |
1517
|
|
|
|
|
|
|
{ |
1518
|
|
|
|
|
|
|
$DEBUG |
1519
|
1
|
|
|
|
|
6
|
and print "Ignoring '$cname' as its class ($class) in " |
1520
|
|
|
|
|
|
|
. "our ignore list.\n"; |
1521
|
|
|
|
|
|
|
next ITEM; |
1522
|
149
|
|
|
|
|
331
|
} |
1523
|
149
|
|
|
|
|
272
|
elsif ($class && !$self->{"cache_skip_freeze"}{$class}) { |
1524
|
149
|
50
|
|
|
|
328
|
my $freezer= $self->{cache_freeze_class}{$class}; |
|
|
0
|
|
|
|
|
|
1525
|
|
|
|
|
|
|
my ($proxy, $thaw, $postop); |
1526
|
149
|
|
|
|
|
435
|
if (!defined $freezer) { |
1527
|
|
|
|
|
|
|
TRY_FREEZE: |
1528
|
|
|
|
|
|
|
for ($self->{style}{freeze_class}{$class}, |
1529
|
440
|
|
|
|
|
694
|
$self->{style}{freezer}, 'DDS_freeze') |
1530
|
440
|
100
|
|
|
|
849
|
{ |
|
|
100
|
|
|
|
|
|
1531
|
290
|
50
|
|
|
|
1672
|
$freezer= $_; |
|
|
100
|
|
|
|
|
|
1532
|
0
|
|
|
|
|
0
|
if ($freezer) { |
1533
|
0
|
|
|
|
|
0
|
if (ref $freezer) { |
1534
|
|
|
|
|
|
|
eval { |
1535
|
|
|
|
|
|
|
($proxy, $thaw, $postop)= |
1536
|
0
|
0
|
|
|
|
0
|
$freezer->($$ritem); |
1537
|
|
|
|
|
|
|
}; |
1538
|
|
|
|
|
|
|
last TRY_FREEZE if !$@; |
1539
|
6
|
|
|
|
|
11
|
} |
1540
|
|
|
|
|
|
|
elsif ($class->can($freezer)) { |
1541
|
6
|
|
|
|
|
10
|
eval { |
|
6
|
|
|
|
|
39
|
|
1542
|
|
|
|
|
|
|
($proxy, $thaw, $postop)= |
1543
|
6
|
50
|
|
|
|
87
|
${$ritem}->$freezer(); |
1544
|
|
|
|
|
|
|
}; |
1545
|
|
|
|
|
|
|
last TRY_FREEZE if !$@; |
1546
|
|
|
|
|
|
|
} |
1547
|
1
|
|
|
|
|
2
|
} |
1548
|
|
|
|
|
|
|
elsif (defined $freezer) { |
1549
|
|
|
|
|
|
|
last TRY_FREEZE; |
1550
|
149
|
100
|
|
|
|
343
|
} |
1551
|
145
|
|
|
|
|
322
|
} |
1552
|
|
|
|
|
|
|
if (!defined $proxy) { |
1553
|
|
|
|
|
|
|
$self->{"cache_skip_freeze"}{$class}= 1; |
1554
|
4
|
|
|
|
|
11
|
} |
1555
|
|
|
|
|
|
|
else { |
1556
|
|
|
|
|
|
|
$self->{cache_freeze_class}{$class}= $freezer; |
1557
|
|
|
|
|
|
|
} |
1558
|
|
|
|
|
|
|
|
1559
|
0
|
|
|
|
|
0
|
} |
1560
|
|
|
|
|
|
|
elsif (ref $freezer) { |
1561
|
|
|
|
|
|
|
($proxy, $thaw)= $freezer->($$ritem); |
1562
|
0
|
|
|
|
|
0
|
} |
|
0
|
|
|
|
|
0
|
|
1563
|
|
|
|
|
|
|
else { |
1564
|
149
|
100
|
|
|
|
329
|
($proxy, $thaw)= ${$ritem}->$freezer(); |
1565
|
4
|
|
|
|
|
10
|
} |
1566
|
|
|
|
|
|
|
if ($thaw) { |
1567
|
149
|
50
|
|
|
|
326
|
$self->{ref_thaw}{$raddr}= $thaw; |
1568
|
0
|
|
|
|
|
0
|
} |
1569
|
|
|
|
|
|
|
if ($postop) { |
1570
|
149
|
50
|
|
|
|
421
|
$self->{ref_postop}{$raddr}= $postop; |
1571
|
149
|
|
|
|
|
430
|
} |
1572
|
149
|
|
|
|
|
274
|
if (refaddr($proxy) != $raddr) { |
1573
|
149
|
100
|
|
|
|
422
|
$self->{ref_fz}{$raddr}= $proxy; |
1574
|
4
|
|
|
|
|
9
|
$ritem= \$proxy; |
1575
|
|
|
|
|
|
|
if (ref $proxy) { |
1576
|
|
|
|
|
|
|
redo DEQUEUE; |
1577
|
|
|
|
|
|
|
} |
1578
|
|
|
|
|
|
|
} |
1579
|
|
|
|
|
|
|
} |
1580
|
2278
|
|
|
|
|
4945
|
} # DEQUEUE |
1581
|
|
|
|
|
|
|
|
1582
|
|
|
|
|
|
|
my ($idx, $dupe)= |
1583
|
2278
|
100
|
33
|
|
|
5486
|
$self->_reg_ref($item, $cdepth, $cname, $rcnt, $arg); |
1584
|
|
|
|
|
|
|
|
1585
|
|
|
|
|
|
|
$DEBUG |
1586
|
|
|
|
|
|
|
and print " Skipping '$cname' as it is a dupe of " |
1587
|
|
|
|
|
|
|
. "$self->{refn}[$idx]\n" |
1588
|
2278
|
50
|
|
|
|
4316
|
if $dupe; |
1589
|
2278
|
100
|
|
|
|
4671
|
|
1590
|
|
|
|
|
|
|
$DEBUG > 9 and $self->diag; |
1591
|
1579
|
|
|
|
|
3550
|
next if $dupe; |
1592
|
1579
|
|
|
|
|
2876
|
|
1593
|
1579
|
|
|
|
|
2314
|
my $reftype= reftype $item; |
1594
|
1579
|
|
|
|
|
2267
|
my $cnt= refcount($item); |
1595
|
1579
|
100
|
100
|
|
|
3772
|
my $overloaded= undef; |
1596
|
26
|
|
|
|
|
733
|
my $isoverloaded= 0; |
1597
|
26
|
|
|
|
|
48
|
if (defined $class and overload::Overloaded($item)) { |
1598
|
26
|
|
|
|
|
38
|
disable_overloading($item); |
1599
|
|
|
|
|
|
|
$overloaded= $class; |
1600
|
|
|
|
|
|
|
$isoverloaded= 1; |
1601
|
1579
|
100
|
100
|
|
|
14408
|
} |
|
|
100
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
1602
|
|
|
|
|
|
|
|
1603
|
|
|
|
|
|
|
if ( $reftype eq 'SCALAR' |
1604
|
|
|
|
|
|
|
or $reftype eq 'REF' |
1605
|
548
|
|
|
|
|
1198
|
or $reftype eq 'GLOB') |
1606
|
548
|
|
|
|
|
1269
|
{ |
1607
|
548
|
50
|
|
|
|
1103
|
my $name= $self->_build_name($cname, '$'); |
1608
|
548
|
|
|
|
|
1577
|
my $cnt= sv_refcount($$item); |
1609
|
|
|
|
|
|
|
if ($cnt > 1) { |
1610
|
|
|
|
|
|
|
$self->_reg_scalar($$item, $cdepth + 1, |
1611
|
548
|
100
|
|
|
|
1902
|
$cnt, readonly($$item), $name); |
1612
|
368
|
|
|
|
|
948
|
} |
1613
|
|
|
|
|
|
|
if (my $type= reftype_or_glob $$item) { |
1614
|
|
|
|
|
|
|
$self->_add_queue(\@queue, $type, $$item, $cdepth + 2, |
1615
|
|
|
|
|
|
|
$name, $cnt); |
1616
|
|
|
|
|
|
|
} |
1617
|
|
|
|
|
|
|
|
1618
|
396
|
|
|
|
|
1135
|
} |
1619
|
1135
|
|
|
|
|
2407
|
elsif ($reftype eq 'ARRAY') { |
1620
|
1135
|
|
|
|
|
2801
|
foreach my $idx (0 .. $#$item) { |
1621
|
1135
|
100
|
|
|
|
2186
|
my $name= $self->_build_name($cname, '[', $idx); |
1622
|
184
|
50
|
|
|
|
370
|
my $cnt= sv_refcount($item->[$idx]); |
1623
|
|
|
|
|
|
|
if ($cnt > 1) { |
1624
|
184
|
|
|
|
|
592
|
print "refcount($name)==$cnt\n" |
1625
|
|
|
|
|
|
|
if $DEBUG > 9; |
1626
|
|
|
|
|
|
|
$self->_reg_scalar($item->[$idx], $cdepth + 1, |
1627
|
1135
|
100
|
|
|
|
3443
|
$cnt, readonly($item->[$idx]), $name); |
1628
|
679
|
|
|
|
|
2012
|
} |
1629
|
|
|
|
|
|
|
if (my $type= reftype_or_glob $item->[$idx]) { |
1630
|
|
|
|
|
|
|
$self->_add_queue(\@queue, $type, $item->[$idx], |
1631
|
|
|
|
|
|
|
$cdepth + 2, |
1632
|
|
|
|
|
|
|
$name, $cnt); |
1633
|
|
|
|
|
|
|
} |
1634
|
|
|
|
|
|
|
} |
1635
|
510
|
|
|
|
|
988
|
} |
1636
|
510
|
|
|
|
|
1323
|
elsif ($reftype eq 'HASH') { |
1637
|
510
|
50
|
|
|
|
1047
|
my $ik= $self->{style}{indentkeys}; |
1638
|
0
|
|
|
|
|
0
|
my ($keyary, $thaw)= $self->_get_keys($item, 0, $raddr, $class); |
1639
|
|
|
|
|
|
|
if ($thaw) { |
1640
|
510
|
|
|
|
|
789
|
$self->{ref_thaw}{$raddr}= $thaw; |
1641
|
510
|
|
|
|
|
719
|
} |
1642
|
510
|
|
|
|
|
778
|
my $key_len= 0; |
1643
|
510
|
50
|
33
|
|
|
1854
|
my $key_sum= 0; |
1644
|
|
|
|
|
|
|
my $key_count= 0; |
1645
|
510
|
50
|
|
|
|
1548
|
die reftype $keyary if $keyary && reftype($keyary) ne 'ARRAY'; |
1646
|
|
|
|
|
|
|
|
1647
|
|
|
|
|
|
|
while ( |
1648
|
|
|
|
|
|
|
defined( |
1649
|
|
|
|
|
|
|
my $key= |
1650
|
|
|
|
|
|
|
defined $keyary |
1651
|
|
|
|
|
|
|
? $keyary->[$key_count] |
1652
|
|
|
|
|
|
|
: each %$item |
1653
|
1192
|
50
|
|
|
|
2286
|
) |
1654
|
1192
|
|
|
|
|
2165
|
) { |
1655
|
1192
|
|
|
|
|
1998
|
if ($ik) { |
1656
|
1192
|
100
|
|
|
|
2500
|
my $qk= _quotekey($key); |
1657
|
|
|
|
|
|
|
$key_sum += length($qk); |
1658
|
1192
|
|
|
|
|
1623
|
$key_len= length($qk) if $key_len < length($qk); |
1659
|
1192
|
|
|
|
|
2447
|
} |
1660
|
1192
|
|
|
|
|
3332
|
$key_count++; |
1661
|
1192
|
100
|
|
|
|
2654
|
my $name= $self->_build_name($cname, '{', $key); |
1662
|
|
|
|
|
|
|
my $cnt= sv_refcount($item->{$key}); |
1663
|
26
|
|
|
|
|
116
|
if ($cnt > 1) { |
1664
|
|
|
|
|
|
|
$self->_reg_scalar($item->{$key}, $cdepth + 1, |
1665
|
1192
|
100
|
|
|
|
4579
|
$cnt, readonly($item->{$key}), $name); |
1666
|
500
|
|
|
|
|
1504
|
} |
1667
|
|
|
|
|
|
|
if (my $type= reftype_or_glob $item->{$key}) { |
1668
|
|
|
|
|
|
|
$self->_add_queue(\@queue, $type, $item->{$key}, |
1669
|
|
|
|
|
|
|
$cdepth + 2, |
1670
|
|
|
|
|
|
|
$name, $cnt); |
1671
|
510
|
100
|
|
|
|
1438
|
} |
1672
|
510
|
50
|
66
|
|
|
1773
|
} |
1673
|
|
|
|
|
|
|
my $avg= $key_count > 0 ? $key_sum / $key_count : 0; |
1674
|
|
|
|
|
|
|
$self->{ref_hklen}{$raddr}= |
1675
|
|
|
|
|
|
|
($key_len > 8 && (2 / 3 * $key_len) > $avg) |
1676
|
510
|
|
|
|
|
1435
|
? int(0.5 + $avg) |
1677
|
|
|
|
|
|
|
: $key_len; |
1678
|
|
|
|
|
|
|
$self->{ref_hkcnt}{$raddr}= $key_count; |
1679
|
|
|
|
|
|
|
|
1680
|
|
|
|
|
|
|
#warn "$raddr => $key_count"; |
1681
|
|
|
|
|
|
|
|
1682
|
69
|
100
|
|
|
|
149
|
} |
1683
|
|
|
|
|
|
|
elsif ($reftype eq 'CODE') { |
1684
|
41
|
|
|
|
|
111
|
if ($pass == 1) { |
1685
|
|
|
|
|
|
|
|
1686
|
41
|
|
|
|
|
123
|
my $used= _get_lexicals($item); |
1687
|
78
|
100
|
|
|
|
222
|
|
1688
|
39
|
|
|
|
|
82
|
foreach my $name (keys %$used) { |
1689
|
39
|
100
|
|
|
|
98
|
next unless $name =~ /\D/; |
1690
|
30
|
|
|
|
|
79
|
my $addr= refaddr($used->{$name}); |
1691
|
30
|
100
|
|
|
|
53
|
if (!$lex_addr{$addr}) { |
1692
|
|
|
|
|
|
|
$lex_addr{$addr}= $used->{$name}; |
1693
|
|
|
|
|
|
|
if ($lex_name{$name}) { |
1694
|
|
|
|
|
|
|
my $tmpname= |
1695
|
|
|
|
|
|
|
sprintf "%s" . $self->{style}{eclipsename}, |
1696
|
|
|
|
|
|
|
substr($name, 0, 1), |
1697
|
7
|
100
|
|
|
|
120
|
$self->{style}{eclipsename} =~ /^[^%]*%s/ |
1698
|
|
|
|
|
|
|
? (substr($name, 1), ++$lex_special{$name},) |
1699
|
7
|
|
|
|
|
32
|
: (++$lex_special{$name}, |
1700
|
7
|
|
|
|
|
11
|
substr($name, 1),); |
1701
|
|
|
|
|
|
|
$lex_name{$tmpname}= $addr; |
1702
|
|
|
|
|
|
|
$lex_addr2name{$addr}= $tmpname; |
1703
|
7
|
|
|
|
|
35
|
$self->_add_queue( |
1704
|
|
|
|
|
|
|
\@queue, reftype_or_glob $used->{$name}, |
1705
|
|
|
|
|
|
|
$used->{$name}, $cdepth + 1, |
1706
|
|
|
|
|
|
|
$tmpname, 2 |
1707
|
|
|
|
|
|
|
); |
1708
|
23
|
|
|
|
|
44
|
} |
1709
|
23
|
|
|
|
|
40
|
else { |
1710
|
|
|
|
|
|
|
$lex_name{$name}= $addr; |
1711
|
|
|
|
|
|
|
$lex_addr2name{$addr}= $name; |
1712
|
23
|
|
|
|
|
87
|
$self->_add_queue( |
1713
|
|
|
|
|
|
|
\@queue, reftype_or_glob $used->{$name}, |
1714
|
|
|
|
|
|
|
$used->{$name}, $cdepth + 1, |
1715
|
|
|
|
|
|
|
$name, 2 |
1716
|
|
|
|
|
|
|
); |
1717
|
|
|
|
|
|
|
} |
1718
|
|
|
|
|
|
|
} |
1719
|
|
|
|
|
|
|
} |
1720
|
|
|
|
|
|
|
} |
1721
|
|
|
|
|
|
|
} |
1722
|
|
|
|
|
|
|
elsif ($reftype eq 'FORMAT') { |
1723
|
|
|
|
|
|
|
|
1724
|
|
|
|
|
|
|
# Code similar to that of CODE should go here I think. |
1725
|
|
|
|
|
|
|
} |
1726
|
|
|
|
|
|
|
else { |
1727
|
|
|
|
|
|
|
# IO? |
1728
|
51
|
50
|
|
|
|
173
|
Carp::confess |
1729
|
|
|
|
|
|
|
"Data() can't handle '$reftype' objects yet ($item)\n :-(\n" |
1730
|
1579
|
100
|
|
|
|
4907
|
if $ENV{DDS_STRICT}; |
1731
|
26
|
|
|
|
|
59
|
} |
1732
|
|
|
|
|
|
|
if ($isoverloaded) { |
1733
|
|
|
|
|
|
|
restore_overloading($item, $overloaded); |
1734
|
364
|
100
|
|
|
|
932
|
} |
1735
|
|
|
|
|
|
|
} |
1736
|
352
|
|
|
|
|
557
|
if ($pass++ == 1) { |
1737
|
352
|
|
|
|
|
499
|
|
|
352
|
|
|
|
|
1465
|
|
1738
|
749
|
|
|
|
|
1585
|
my %items; |
1739
|
749
|
|
|
|
|
1881
|
for my $idx (0 .. $#{ $args_insideout{ refaddr $self} }) { |
1740
|
|
|
|
|
|
|
my $item= $args_insideout{ refaddr $self}[$idx]; |
1741
|
|
|
|
|
|
|
$items{ refaddr $item->{item} }= $idx; |
1742
|
352
|
|
|
|
|
606
|
} |
1743
|
352
|
|
|
|
|
549
|
|
1744
|
352
|
|
|
|
|
517
|
my @add; |
1745
|
|
|
|
|
|
|
my $added= 0; |
1746
|
|
|
|
|
|
|
if (0) { |
1747
|
|
|
|
|
|
|
@add= keys %lex_addr; |
1748
|
352
|
|
|
|
|
839
|
} |
1749
|
30
|
100
|
|
|
|
50
|
else { |
1750
|
3
|
|
|
|
|
6
|
for my $addr (keys %lex_addr) { |
1751
|
3
|
100
|
|
|
|
8
|
if (exists $items{$addr}) { |
1752
|
2
|
|
|
|
|
7
|
my $idx= $items{$addr}; |
1753
|
2
|
|
|
|
|
8
|
if (!$self->{unames}[$idx]) { |
|
2
|
|
|
|
|
10
|
|
1754
|
|
|
|
|
|
|
for ($self->{unames}[$idx]= $lex_addr2name{$addr}) { |
1755
|
2
|
|
|
|
|
5
|
s/^[^\$]/*/; s/^\$//; |
1756
|
|
|
|
|
|
|
} |
1757
|
|
|
|
|
|
|
$added++; |
1758
|
1
|
|
|
|
|
3
|
} |
1759
|
1
|
|
|
|
|
2
|
else { |
1760
|
1
|
|
|
|
|
7
|
my $new= $self->{unames}[$idx]; |
|
1
|
|
|
|
|
4
|
|
1761
|
1
|
|
|
|
|
3
|
my $old= $lex_addr2name{$addr}; |
1762
|
1
|
|
|
|
|
3
|
$new =~ s/^(\*)?/substr($old,0,1)/e; |
1763
|
1
|
|
|
|
|
4
|
delete $lex_name{ $lex_addr2name{$addr} }; |
1764
|
|
|
|
|
|
|
$lex_addr2name{$addr}= $new; |
1765
|
|
|
|
|
|
|
$lex_name{ $self->{unames}[$idx] }= $addr; # xxx |
1766
|
|
|
|
|
|
|
} |
1767
|
27
|
|
|
|
|
60
|
} |
1768
|
|
|
|
|
|
|
else { |
1769
|
|
|
|
|
|
|
push @add, $addr; |
1770
|
|
|
|
|
|
|
} |
1771
|
352
|
|
|
|
|
787
|
} |
|
24
|
|
|
|
|
53
|
|
1772
|
|
|
|
|
|
|
} |
1773
|
|
|
|
|
|
|
@add= sort { $lex_addr2name{$a} cmp $lex_addr2name{$b} } @add; |
1774
|
352
|
|
|
|
|
1521
|
|
1775
|
|
|
|
|
|
|
$self->{lexicals}= { |
1776
|
|
|
|
|
|
|
a2n => \%lex_addr2name, |
1777
|
|
|
|
|
|
|
name => \%lex_name |
1778
|
352
|
100
|
|
|
|
1608
|
}; |
|
|
100
|
|
|
|
|
|
1779
|
11
|
|
|
|
|
28
|
|
1780
|
11
|
|
|
|
|
17
|
if (@add) { |
|
27
|
|
|
|
|
63
|
|
1781
|
27
|
|
|
|
|
33
|
unshift @{ $args_insideout{ refaddr $self} }, map { |
1782
|
27
|
100
|
66
|
|
|
89
|
my $rt= reftype($lex_addr{$_}); |
|
|
|
100
|
|
|
|
|
1783
|
3
|
|
|
|
|
5
|
my $item; |
1784
|
|
|
|
|
|
|
if ($rt ne 'SCALAR' and $rt ne 'GLOB' and $rt ne 'REF') { |
1785
|
|
|
|
|
|
|
$item= \$lex_addr{$_}; |
1786
|
24
|
|
|
|
|
33
|
} |
1787
|
|
|
|
|
|
|
else { |
1788
|
|
|
|
|
|
|
$item= $lex_addr{$_}; |
1789
|
|
|
|
|
|
|
} |
1790
|
|
|
|
|
|
|
{ |
1791
|
|
|
|
|
|
|
item => $item, |
1792
|
27
|
|
|
|
|
117
|
usemy => 1, |
1793
|
|
|
|
|
|
|
ro => 0, |
1794
|
|
|
|
|
|
|
refcnt => refcount($lex_addr{$_}), |
1795
|
|
|
|
|
|
|
} |
1796
|
11
|
|
|
|
|
21
|
} @add; |
|
27
|
|
|
|
|
62
|
|
1797
|
11
|
|
|
|
|
26
|
$self->{lexicals}{added}= |
1798
|
11
|
|
|
|
|
24
|
{ map { $lex_addr2name{$_} => 1 } @add }; |
|
27
|
|
|
|
|
66
|
|
1799
|
27
|
|
|
|
|
75
|
unshift @{ $self->{unames} }, map { |
1800
|
27
|
|
|
|
|
63
|
(my $n= $lex_addr2name{$_}) =~ s/^[^\$]/*/; |
1801
|
|
|
|
|
|
|
$n =~ s/^\$//; |
1802
|
11
|
|
|
|
|
35
|
$n |
1803
|
11
|
|
|
|
|
47
|
} @add; |
1804
|
|
|
|
|
|
|
$self->_reset; |
1805
|
|
|
|
|
|
|
redo PASS; |
1806
|
1
|
|
|
|
|
3
|
} |
1807
|
1
|
|
|
|
|
4
|
elsif ($added) { |
1808
|
|
|
|
|
|
|
$self->_reset; |
1809
|
|
|
|
|
|
|
redo PASS; |
1810
|
|
|
|
|
|
|
} |
1811
|
352
|
|
|
|
|
657
|
} |
1812
|
352
|
|
|
|
|
1428
|
} |
1813
|
|
|
|
|
|
|
$self->{cataloged}= 1; |
1814
|
|
|
|
|
|
|
return $self; |
1815
|
|
|
|
|
|
|
} |
1816
|
519
|
|
|
519
|
|
1421
|
|
1817
|
|
|
|
|
|
|
sub _add_fix { |
1818
|
|
|
|
|
|
|
my ($self, @args)= @_; |
1819
|
|
|
|
|
|
|
|
1820
|
|
|
|
|
|
|
# 'var','glob','method call','lock','ref','sv','#' |
1821
|
519
|
50
|
|
|
|
1678
|
# TODO |
1822
|
519
|
50
|
|
|
|
2336
|
# add a fix statement to the list of fixes. |
1823
|
0
|
|
|
|
|
0
|
my $fix= @args == 1 ? shift @args : [@args]; |
1824
|
|
|
|
|
|
|
unless ($fix->[0] =~ /^(var|glob|thaw|ref|sv|#|sub call|lock|bless)$/) { |
1825
|
519
|
50
|
|
|
|
1207
|
Carp::confess "Unknown variant:" . Dumper($fix); |
1826
|
0
|
|
|
|
|
0
|
} |
|
0
|
|
|
|
|
0
|
|
1827
|
|
|
|
|
|
|
if ($args[0] eq 'var') { |
1828
|
|
|
|
|
|
|
unshift @{ $self->{fix} }, $fix; |
1829
|
519
|
|
|
|
|
719
|
} |
|
519
|
|
|
|
|
1671
|
|
1830
|
|
|
|
|
|
|
else { |
1831
|
|
|
|
|
|
|
push @{ $self->{fix} }, $fix; |
1832
|
|
|
|
|
|
|
} |
1833
|
|
|
|
|
|
|
} |
1834
|
56
|
|
|
56
|
|
131
|
|
1835
|
|
|
|
|
|
|
sub _glob_slots { |
1836
|
|
|
|
|
|
|
my ($self, $inc_format)= @_; |
1837
|
|
|
|
|
|
|
|
1838
|
|
|
|
|
|
|
# $inc_format is for a special case. |
1839
|
|
|
|
|
|
|
return ( |
1840
|
|
|
|
|
|
|
qw(SCALAR HASH ARRAY), ( |
1841
|
|
|
|
|
|
|
($self->{style}{deparse} && $self->{style}{deparseglob}) |
1842
|
|
|
|
|
|
|
? 'CODE' |
1843
|
|
|
|
|
|
|
: () |
1844
|
|
|
|
|
|
|
), (( |
1845
|
|
|
|
|
|
|
$inc_format |
1846
|
56
|
50
|
33
|
|
|
457
|
&& $self->{style}{deparse} |
|
|
100
|
33
|
|
|
|
|
1847
|
|
|
|
|
|
|
&& $self->{style}{deparseglob} |
1848
|
|
|
|
|
|
|
) ? 'FORMAT' : ())); |
1849
|
|
|
|
|
|
|
} |
1850
|
1130
|
|
|
1130
|
|
2111
|
|
1851
|
|
|
|
|
|
|
sub _dump_apply_fix { #handle fix statements and GLOB's here. |
1852
|
|
|
|
|
|
|
my ($self, $isfinal)= @_; |
1853
|
|
|
|
|
|
|
|
1854
|
|
|
|
|
|
|
# go through the fix statements and out any that are |
1855
|
|
|
|
|
|
|
# now fully dumped. |
1856
|
|
|
|
|
|
|
# currently the following types are grokked: |
1857
|
1130
|
|
|
|
|
1602
|
# 'var','glob','method call','tlock','ref','sv','#' |
1858
|
|
|
|
|
|
|
|
1859
|
1130
|
|
|
|
|
1642
|
my @globs; |
|
1156
|
|
|
|
|
1744
|
|
1860
|
1156
|
|
|
|
|
2271
|
GLOB: { |
1861
|
957
|
|
|
|
|
1290
|
@globs= (); |
1862
|
957
|
|
|
|
|
1291
|
@{ $self->{fix} }= grep { |
1863
|
957
|
50
|
|
|
|
2028
|
my $keep= 1; |
1864
|
957
|
|
|
|
|
2032
|
my $fix= $_; |
1865
|
|
|
|
|
|
|
if (ref $fix) { |
1866
|
957
|
50
|
|
|
|
3081
|
my ($type, $lhs, $rhs, $class)= @$fix; |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
1867
|
0
|
|
|
|
|
0
|
|
1868
|
0
|
|
|
|
|
0
|
if ($type eq '#') { |
1869
|
|
|
|
|
|
|
$self->{fh}->print(map "# $_\n", @$fix[ 0 .. $#$fix ]); |
1870
|
|
|
|
|
|
|
$keep= 0; |
1871
|
71
|
100
|
|
|
|
131
|
} |
1872
|
26
|
|
|
|
|
51
|
elsif ($type eq 'bless') { |
1873
|
|
|
|
|
|
|
if ($isfinal) { # $self->{"refdu"}[$lhs] |
1874
|
|
|
|
|
|
|
$lhs= $self->{"refn"}[$lhs]; |
1875
|
|
|
|
|
|
|
$self->{fh}->print( |
1876
|
|
|
|
|
|
|
substr($self->{style}{bless}, 0, -1), |
1877
|
|
|
|
|
|
|
" ", |
1878
|
|
|
|
|
|
|
$lhs, |
1879
|
|
|
|
|
|
|
", ", |
1880
|
26
|
|
|
|
|
86
|
_quote($rhs), |
1881
|
|
|
|
|
|
|
" ", |
1882
|
|
|
|
|
|
|
substr($self->{style}{bless}, -1), |
1883
|
26
|
|
|
|
|
61
|
";\n" |
1884
|
|
|
|
|
|
|
); |
1885
|
|
|
|
|
|
|
$keep= 0; |
1886
|
|
|
|
|
|
|
} |
1887
|
|
|
|
|
|
|
} |
1888
|
290
|
|
|
|
|
480
|
elsif ($type eq 'sv') { |
1889
|
290
|
100
|
66
|
|
|
886
|
|
1890
|
110
|
|
|
|
|
378
|
my $dref= $_->[-1]; |
1891
|
|
|
|
|
|
|
if ($self->{ $type . "du" }[$rhs] |
1892
|
110
|
|
|
|
|
232
|
and ${ $self->{ $type . "du" }[$rhs] }) |
1893
|
110
|
|
|
|
|
265
|
{ |
1894
|
110
|
50
|
|
|
|
270
|
$rhs= $self->{ $type . "n" }[$rhs]; |
1895
|
110
|
|
|
|
|
214
|
my ($sigil, $var)= remove_deref($lhs); |
1896
|
110
|
|
|
|
|
211
|
if ($sigil) { |
1897
|
|
|
|
|
|
|
$rhs= "\\" . $rhs; |
1898
|
110
|
|
|
|
|
506
|
$lhs= $var; |
1899
|
110
|
50
|
|
|
|
330
|
} |
1900
|
110
|
|
|
|
|
209
|
$self->{fh}->print("$lhs = $rhs;\n"); |
1901
|
|
|
|
|
|
|
$$dref= 1 if ref $dref; |
1902
|
|
|
|
|
|
|
$keep= 0; |
1903
|
|
|
|
|
|
|
} |
1904
|
|
|
|
|
|
|
} |
1905
|
436
|
100
|
100
|
|
|
1299
|
elsif ($type eq 'ref') { |
1906
|
360
|
|
|
|
|
1234
|
|
1907
|
|
|
|
|
|
|
if ($self->{ $type . "du" }[$rhs] |
1908
|
|
|
|
|
|
|
and ${ $self->{ $type . "du" }[$rhs] }) |
1909
|
275
|
|
|
|
|
577
|
{ |
1910
|
|
|
|
|
|
|
|
1911
|
275
|
100
|
|
|
|
1189
|
$rhs= $self->{ $type . "n" }[$rhs]; |
1912
|
36
|
|
|
|
|
81
|
|
1913
|
36
|
100
|
|
|
|
106
|
if ($rhs =~ /^[\@\%\&]/) { |
1914
|
|
|
|
|
|
|
$rhs= "\\" . $rhs; |
1915
|
|
|
|
|
|
|
$rhs= "bless( $rhs, " . _quote($class) . ' )' |
1916
|
275
|
|
|
|
|
1094
|
if $class; |
1917
|
275
|
|
|
|
|
512
|
} # Warn if |
1918
|
|
|
|
|
|
|
$self->{fh}->print("$lhs = $rhs;\n"); |
1919
|
|
|
|
|
|
|
$keep= 0; |
1920
|
|
|
|
|
|
|
} |
1921
|
8
|
50
|
33
|
|
|
22
|
} |
|
8
|
|
|
|
|
28
|
|
1922
|
8
|
|
|
|
|
13
|
elsif ($type eq 'lock') { |
1923
|
|
|
|
|
|
|
if ($self->{refdu}[$lhs] and ${ $self->{"refdu"}[$lhs] }) { |
1924
|
|
|
|
|
|
|
$lhs= $self->{"refn"}[$lhs]; |
1925
|
|
|
|
|
|
|
$self->{fh}->print( |
1926
|
|
|
|
|
|
|
@$rhs |
1927
|
8
|
100
|
|
|
|
40
|
? "lock_keys_plus( $lhs, " |
|
8
|
|
|
|
|
15
|
|
1928
|
|
|
|
|
|
|
: "lock_keys( $lhs ", |
1929
|
|
|
|
|
|
|
join(", ", map { _quote($_) } @$rhs), |
1930
|
8
|
|
|
|
|
19
|
");\n" |
1931
|
|
|
|
|
|
|
); |
1932
|
|
|
|
|
|
|
$keep= 0; |
1933
|
|
|
|
|
|
|
} |
1934
|
|
|
|
|
|
|
} |
1935
|
|
|
|
|
|
|
elsif ($type eq 'thaw') { |
1936
|
7
|
100
|
|
|
|
19
|
|
1937
|
|
|
|
|
|
|
# these have to happen at the end. |
1938
|
|
|
|
|
|
|
if ($isfinal) { |
1939
|
3
|
|
|
|
|
4
|
|
|
3
|
|
|
|
|
7
|
|
1940
|
3
|
|
|
|
|
7
|
#if ($self->{refdu}[$lhs] and ${$self->{"refdu"}[$lhs]}) { |
1941
|
3
|
|
|
|
|
8
|
${ $self->{refdu}[$lhs] }= 1; |
1942
|
3
|
50
|
|
|
|
24
|
$lhs= $self->{"refn"}[$lhs]; |
1943
|
3
|
100
|
|
|
|
8
|
my @args= @$_[ 3 .. $#$_ ]; |
1944
|
|
|
|
|
|
|
if ($rhs =~ /^(->)?((?:\w*::)*\w+)(\(\))?$/) { |
1945
|
1
|
|
|
|
|
8
|
if ($3) { |
1946
|
|
|
|
|
|
|
$self->{fh}->print( |
1947
|
|
|
|
|
|
|
"$2( " . join(", ", $lhs, @args) . " );\n"); |
1948
|
|
|
|
|
|
|
} |
1949
|
2
|
|
|
|
|
13
|
else { |
1950
|
|
|
|
|
|
|
$self->{fh}->print( |
1951
|
|
|
|
|
|
|
"$lhs->$2(" . join(", ", @args) . ");\n"); |
1952
|
|
|
|
|
|
|
} |
1953
|
0
|
|
|
|
|
0
|
} |
1954
|
0
|
|
|
|
|
0
|
else { |
1955
|
|
|
|
|
|
|
$rhs =~ s/^\t//mg; |
1956
|
3
|
|
|
|
|
8
|
$self->{fh}->print("for ($lhs) {\n$rhs\n}\n"); |
1957
|
|
|
|
|
|
|
} |
1958
|
|
|
|
|
|
|
$keep= 0; |
1959
|
|
|
|
|
|
|
} |
1960
|
28
|
|
|
|
|
54
|
} |
1961
|
28
|
|
|
|
|
58
|
elsif ($type eq 'glob') { |
1962
|
|
|
|
|
|
|
push @globs, $_; |
1963
|
|
|
|
|
|
|
$keep= 0; |
1964
|
0
|
|
|
|
|
0
|
} |
1965
|
0
|
0
|
|
|
|
0
|
elsif ($type eq 'var') { |
1966
|
|
|
|
|
|
|
$rhs= "\\" . $rhs; |
1967
|
0
|
0
|
|
|
|
0
|
$rhs= "bless( $rhs, " . _quote($class) . ' )' |
1968
|
|
|
|
|
|
|
if $class; |
1969
|
0
|
|
|
|
|
0
|
$self->{fh}->print(($self->{style}{declare} ? 'my ' : ""), |
1970
|
|
|
|
|
|
|
"$lhs = $rhs;\n"); |
1971
|
|
|
|
|
|
|
$keep= 0; |
1972
|
|
|
|
|
|
|
} |
1973
|
117
|
|
|
|
|
203
|
elsif ($type eq 'sub call') { |
1974
|
|
|
|
|
|
|
my @r= grep { |
1975
|
551
|
100
|
66
|
|
|
1356
|
ref $_ |
1976
|
|
|
|
|
|
|
and |
1977
|
117
|
100
|
|
|
|
274
|
(!$self->{svdu}[$$_] or !${ $self->{svdu}[$$_] }) |
1978
|
|
|
|
|
|
|
} @$fix; |
1979
|
69
|
100
|
|
|
|
117
|
unless (@r) { |
|
311
|
|
|
|
|
650
|
|
1980
|
69
|
|
|
|
|
353
|
my ($type, $sub, @args)= |
1981
|
69
|
|
|
|
|
201
|
map { ref $_ ? $self->{svn}[$$_] : $_ } @$fix; |
1982
|
|
|
|
|
|
|
$self->{fh}->print("$sub(", join(", ", @args), ");\n"); |
1983
|
|
|
|
|
|
|
$keep= 0; |
1984
|
|
|
|
|
|
|
} |
1985
|
0
|
|
|
|
|
0
|
} |
1986
|
|
|
|
|
|
|
else { |
1987
|
|
|
|
|
|
|
die "Bad fix: ", Dumper($fix); |
1988
|
|
|
|
|
|
|
} |
1989
|
957
|
|
|
|
|
1906
|
|
1990
|
1156
|
|
|
|
|
1611
|
} |
|
1156
|
|
|
|
|
2402
|
|
1991
|
1156
|
|
|
|
|
2391
|
$keep; |
1992
|
28
|
|
|
|
|
80
|
} @{ $self->{fix} }; |
1993
|
28
|
50
|
33
|
|
|
81
|
foreach my $glob (@globs) { |
1994
|
28
|
|
|
|
|
65
|
my ($type, $lhs, $rhs, $depth, $name)= @$glob; |
1995
|
28
|
100
|
|
|
|
74
|
print "Symbol: $name\n" if $DEBUG and $name; |
1996
|
28
|
|
|
|
|
47
|
local @_; |
1997
|
28
|
|
|
|
|
50
|
$name= $name ? '*' . $name : $rhs; |
1998
|
28
|
100
|
66
|
|
|
107
|
my $overloaded= undef; |
1999
|
|
|
|
|
|
|
my $isoverloaded= 0; |
2000
|
|
|
|
|
|
|
if (defined(blessed $lhs ) |
2001
|
3
|
|
|
|
|
162
|
and overload::Overloaded($lhs)) |
2002
|
3
|
|
|
|
|
23
|
{ |
2003
|
3
|
|
|
|
|
5
|
$overloaded= blessed $lhs; |
2004
|
|
|
|
|
|
|
disable_overloading($lhs); |
2005
|
28
|
|
|
|
|
146
|
$isoverloaded= 1; |
2006
|
112
|
|
|
|
|
266
|
} |
2007
|
|
|
|
|
|
|
foreach my $t ($self->_glob_slots('')) { |
2008
|
112
|
100
|
100
|
|
|
419
|
my $v= *$lhs{$t}; |
|
|
|
100
|
|
|
|
|
2009
|
|
|
|
|
|
|
|
2010
|
|
|
|
|
|
|
if (not(defined $v) |
2011
|
68
|
|
|
|
|
124
|
or ($t eq 'SCALAR' and !defined($$v))) |
2012
|
|
|
|
|
|
|
{ |
2013
|
|
|
|
|
|
|
next; |
2014
|
44
|
|
|
|
|
63
|
} |
2015
|
|
|
|
|
|
|
|
2016
|
44
|
|
|
|
|
119
|
my $dumped= 0; |
2017
|
44
|
|
|
|
|
142
|
|
2018
|
44
|
50
|
66
|
|
|
135
|
my $gaddr= refaddr(*$lhs{$t}); |
2019
|
0
|
|
|
|
|
0
|
my $gidx= $self->{ref}{$gaddr}; |
2020
|
|
|
|
|
|
|
unless ($gidx) { |
2021
|
|
|
|
|
|
|
next; |
2022
|
|
|
|
|
|
|
} |
2023
|
|
|
|
|
|
|
elsif ($self->{refd}[$gidx] < $depth + 1) { |
2024
|
|
|
|
|
|
|
$self->_add_fix('ref', $name, $gidx, blessed(*$lhs{$t})); |
2025
|
|
|
|
|
|
|
next; |
2026
|
27
|
50
|
|
|
|
159
|
} |
2027
|
27
|
|
|
|
|
119
|
|
2028
|
|
|
|
|
|
|
$self->{fh}->print("$name = ") unless $self->{style}{terse}; |
2029
|
27
|
50
|
|
|
|
75
|
my $ret= $self->_dump_sv(*$lhs{$t}, $depth, \$dumped, $name, |
2030
|
|
|
|
|
|
|
length($name) + 3); |
2031
|
|
|
|
|
|
|
Carp::confess |
2032
|
27
|
|
|
|
|
82
|
"\nUnhandled alias value '$ret' returned to _dump_apply_fix()!" |
2033
|
27
|
|
|
|
|
58
|
if $ret; |
2034
|
|
|
|
|
|
|
$self->{fh}->print(";\n"); |
2035
|
|
|
|
|
|
|
$dumped= 1; |
2036
|
28
|
50
|
33
|
|
|
160
|
} |
2037
|
|
|
|
|
|
|
|
2038
|
|
|
|
|
|
|
if ( |
2039
|
|
|
|
|
|
|
$self->{style}{deparse} |
2040
|
|
|
|
|
|
|
&& $self->{style}{deparseglob} |
2041
|
|
|
|
|
|
|
|
2042
|
|
|
|
|
|
|
#and defined *$lhs{FORMAT} |
2043
|
|
|
|
|
|
|
) { |
2044
|
|
|
|
|
|
|
# from link from [ysth]: http://groups.google.com/groups?selm=laUs8gzkgOlT092yn%40efn.org |
2045
|
|
|
|
|
|
|
# translate arg (or reference to it) into a B::* object |
2046
|
|
|
|
|
|
|
|
2047
|
|
|
|
|
|
|
# To work-around perl commit |
2048
|
|
|
|
|
|
|
# 2acc3314e31a9342e325f35c5b592967c9850c9b, keep the |
2049
|
28
|
|
|
|
|
65
|
# value \*$lhs alive while we inspect it as a B object |
2050
|
28
|
|
|
|
|
117
|
# or else it'll be reaped while we're using it. |
2051
|
|
|
|
|
|
|
my $lhs_glob= \*$lhs; |
2052
|
|
|
|
|
|
|
my $Bobj= B::svref_2object($lhs_glob); |
2053
|
28
|
50
|
|
|
|
142
|
|
2054
|
|
|
|
|
|
|
# if passed a glob or globref, get the format |
2055
|
28
|
100
|
|
|
|
97
|
$Bobj= B::GV::FORM($Bobj) if ref $Bobj eq 'B::GV'; |
2056
|
1
|
|
|
|
|
12
|
|
2057
|
1
|
|
|
|
|
7
|
if (ref $Bobj eq 'B::FM') { |
2058
|
1
|
|
|
|
|
74
|
(my $cleaned= $name) =~ s/^\*(::)?//; |
2059
|
|
|
|
|
|
|
$self->{fh}->print("format $cleaned =\n"); |
2060
|
1
|
|
|
|
|
2474
|
my $deparser= Data::Dump::Streamer::Deparser->new(); |
2061
|
1
|
|
|
|
|
19
|
$self->{fh}->print( |
2062
|
|
|
|
|
|
|
$deparser->indent($deparser->deparse_format($Bobj))); |
2063
|
|
|
|
|
|
|
$self->{fh}->print("\n"); |
2064
|
28
|
100
|
|
|
|
100
|
} |
2065
|
3
|
|
|
|
|
6
|
} |
2066
|
|
|
|
|
|
|
if ($isoverloaded) { |
2067
|
|
|
|
|
|
|
restore_overloading($lhs, $overloaded); |
2068
|
|
|
|
|
|
|
} |
2069
|
1156
|
100
|
|
|
|
3131
|
|
2070
|
|
|
|
|
|
|
} |
2071
|
|
|
|
|
|
|
redo GLOB if @globs; |
2072
|
|
|
|
|
|
|
} |
2073
|
|
|
|
|
|
|
} |
2074
|
|
|
|
|
|
|
|
2075
|
|
|
|
|
|
|
=item Out |
2076
|
|
|
|
|
|
|
|
2077
|
|
|
|
|
|
|
=item Out VALUES |
2078
|
|
|
|
|
|
|
|
2079
|
|
|
|
|
|
|
Prints out a set of values to the appropriate location. If provided a list |
2080
|
|
|
|
|
|
|
of values then the values are first scanned with C and then |
2081
|
|
|
|
|
|
|
printed, if called with no values then whatever was scanned last with |
2082
|
|
|
|
|
|
|
C or C is printed. |
2083
|
|
|
|
|
|
|
|
2084
|
|
|
|
|
|
|
If the C attribute was provided then will dump to whatever object |
2085
|
|
|
|
|
|
|
was specified there (any object, including filehandles that accept the |
2086
|
|
|
|
|
|
|
print() method), and will always return $self. |
2087
|
|
|
|
|
|
|
|
2088
|
|
|
|
|
|
|
If the C attribute was not provided then will use an internal |
2089
|
|
|
|
|
|
|
printing object, returning either a list or scalar or printing to STDOUT |
2090
|
|
|
|
|
|
|
in void context. |
2091
|
|
|
|
|
|
|
|
2092
|
|
|
|
|
|
|
This routine is virtually always called without arguments as the last |
2093
|
|
|
|
|
|
|
method in the method chain. |
2094
|
|
|
|
|
|
|
|
2095
|
|
|
|
|
|
|
Dump->Arguments(1)->Out(@vars); |
2096
|
|
|
|
|
|
|
$obj->Data(@vars)->Out(); |
2097
|
|
|
|
|
|
|
Dump(@vars)->Out; |
2098
|
|
|
|
|
|
|
Data::Dump::Streamer->Out(@vars); |
2099
|
|
|
|
|
|
|
|
2100
|
|
|
|
|
|
|
All should DWIM. |
2101
|
|
|
|
|
|
|
|
2102
|
|
|
|
|
|
|
=cut |
2103
|
|
|
|
|
|
|
|
2104
|
|
|
|
|
|
|
# |
2105
|
|
|
|
|
|
|
# Out is just a wrapper. The overall dumping process works like this: |
2106
|
|
|
|
|
|
|
# |
2107
|
|
|
|
|
|
|
# Out |
2108
|
|
|
|
|
|
|
# foreach root value |
2109
|
|
|
|
|
|
|
# _dump_sv |
2110
|
|
|
|
|
|
|
# _dump_rv if ref |
2111
|
|
|
|
|
|
|
# (optionally one of) |
2112
|
|
|
|
|
|
|
# _dump_array |
2113
|
|
|
|
|
|
|
# _dump_hash |
2114
|
|
|
|
|
|
|
# _dump_code |
2115
|
|
|
|
|
|
|
# _dump_qr |
2116
|
|
|
|
|
|
|
# _dump_apply_fix |
2117
|
|
|
|
|
|
|
# (which may call) |
2118
|
|
|
|
|
|
|
# _dump_sv |
2119
|
|
|
|
|
|
|
# |
2120
|
|
|
|
|
|
|
# _dump_array, _dump_hash, _dump_rv if needed may also call _dump_sv |
2121
|
|
|
|
|
|
|
# |
2122
|
|
|
|
|
|
|
# essentially _dump_sv and _dump_rv handle uniqueness checks for scalars, |
2123
|
|
|
|
|
|
|
# and refs. _dump_sv handles the SV's containers and _dump_rv |
2124
|
|
|
|
|
|
|
# handles the things that the SV contains a reference to. _dump_sv also |
2125
|
|
|
|
|
|
|
# handles simple values and globs, and works with _dump_rv to handle |
2126
|
|
|
|
|
|
|
# references to scalars correctly. If "fix" statements are required |
2127
|
|
|
|
|
|
|
# to complete the definition of the structure (self referential structures) |
2128
|
|
|
|
|
|
|
# then _add_fix adds them to the list, and _dump_apply_fix pulls them off. |
2129
|
|
|
|
|
|
|
# note that _dump_apply_fix can also call _dump_sv if needed (to handle globs), |
2130
|
|
|
|
|
|
|
# and will also emit fix statements as early as possible. no require/use |
2131
|
|
|
|
|
|
|
# logic is currently in place. its the evalers responsibility to use the mod |
2132
|
|
|
|
|
|
|
# w/the right tags for now... |
2133
|
353
|
|
|
353
|
1
|
1815
|
|
2134
|
|
|
|
|
|
|
sub Out { |
2135
|
353
|
|
|
|
|
1266
|
local ($\, $", $,)= |
2136
|
353
|
50
|
|
|
|
798
|
("", "", ""); # prevent globals from messing with our output via print |
2137
|
|
|
|
|
|
|
my $self= shift->_safe_self; |
2138
|
353
|
100
|
66
|
|
|
1961
|
print "Out(" . scalar(@_) . " vars)\n" |
|
|
|
66
|
|
|
|
|
2139
|
12
|
|
|
|
|
37
|
if $DEBUG; |
2140
|
|
|
|
|
|
|
if (!$self->{in_printit} and (@_ or !$self->{cataloged})) { |
2141
|
|
|
|
|
|
|
$self->Data(@_); |
2142
|
353
|
|
|
|
|
559
|
} |
2143
|
353
|
50
|
|
|
|
811
|
|
2144
|
353
|
50
|
|
|
|
736
|
my $fh; |
2145
|
|
|
|
|
|
|
unless ($self->{fh}) { |
2146
|
353
|
50
|
|
|
|
746
|
print " no filehandle using " |
2147
|
353
|
100
|
|
|
|
959
|
if $DEBUG; |
2148
|
|
|
|
|
|
|
if (defined wantarray) { |
2149
|
353
|
50
|
|
|
|
704
|
my $class= __PACKAGE__ |
2150
|
|
|
|
|
|
|
. (wantarray ? "::_::ListPrinter" : "::_::StringPrinter"); |
2151
|
353
|
50
|
|
|
|
1626
|
print $class, "\n" |
2152
|
|
|
|
|
|
|
if $DEBUG; |
2153
|
353
|
|
|
|
|
841
|
$fh= $class->new() |
2154
|
|
|
|
|
|
|
or Carp::confess "$class failed to build!"; |
2155
|
|
|
|
|
|
|
$self->{'return'}= $fh; |
2156
|
0
|
0
|
|
|
|
0
|
} |
2157
|
0
|
|
|
|
|
0
|
else { |
2158
|
|
|
|
|
|
|
print "STDOUT\n" if $DEBUG; |
2159
|
353
|
|
|
|
|
656
|
$fh= \*STDOUT; |
2160
|
|
|
|
|
|
|
} |
2161
|
|
|
|
|
|
|
$self->{fh}= $fh; |
2162
|
|
|
|
|
|
|
} |
2163
|
|
|
|
|
|
|
|
2164
|
|
|
|
|
|
|
# loop over the list |
2165
|
|
|
|
|
|
|
# and dump out each one in turn |
2166
|
353
|
|
|
|
|
802
|
# handling any potential fixes after |
2167
|
353
|
|
|
|
|
724
|
# each definition is complete |
2168
|
353
|
|
|
|
|
682
|
$self->{out_names}= []; |
2169
|
353
|
50
|
|
|
|
814
|
$self->{declare}= []; |
2170
|
|
|
|
|
|
|
$self->{special}= {}; |
2171
|
353
|
|
|
|
|
497
|
$DEBUG > 9 and $self->diag; |
|
353
|
|
|
|
|
1220
|
|
2172
|
|
|
|
|
|
|
|
2173
|
353
|
|
|
|
|
659
|
my @items= @{ $args_insideout{ refaddr $self} }; |
2174
|
|
|
|
|
|
|
|
2175
|
353
|
|
|
|
|
519
|
my $namestr= ""; |
|
353
|
|
|
|
|
835
|
|
|
777
|
|
|
|
|
1905
|
|
2176
|
353
|
|
|
|
|
607
|
|
|
353
|
|
|
|
|
727
|
|
|
777
|
|
|
|
|
1423
|
|
2177
|
|
|
|
|
|
|
push @{ $self->{out_names} }, map { $_->{name} } @items; #must |
2178
|
353
|
50
|
|
|
|
919
|
push @{ $self->{declare} }, map { $_->{name} } @items; |
2179
|
|
|
|
|
|
|
|
2180
|
0
|
0
|
|
|
|
0
|
if ($self->{style}{special}) { |
2181
|
|
|
|
|
|
|
|
2182
|
0
|
|
|
|
|
0
|
print DDumper(\@items) if $DEBUG; |
|
0
|
|
|
|
|
0
|
|
2183
|
|
|
|
|
|
|
|
2184
|
|
|
|
|
|
|
$namestr= "# (" . join(", ", @{ $self->{out_names} }) . ")\n"; |
2185
|
0
|
|
|
|
|
0
|
|
2186
|
|
|
|
|
|
|
@items= sort { |
2187
|
0
|
0
|
|
|
|
0
|
$self->{svc}[ $b->{idx} ] <=> $self->{svc}[ $a->{idx} ] |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2188
|
|
|
|
|
|
|
|| ($b->{raddr} ? $self->{refc}[ $b->{ridx} ] : 0) |
2189
|
|
|
|
|
|
|
<=> ($a->{raddr} ? $self->{refc}[ $a->{ridx} ] : 0) |
2190
|
0
|
0
|
|
|
|
0
|
} @items; |
2191
|
|
|
|
|
|
|
|
2192
|
|
|
|
|
|
|
print DDumper(\@items) if $DEBUG; |
2193
|
353
|
50
|
66
|
|
|
909
|
} |
2194
|
2
|
|
|
|
|
10
|
|
2195
|
2
|
50
|
|
|
|
9
|
if ($self->{style}{compress} && $self->{style}{compressor}) { |
2196
|
|
|
|
|
|
|
my $prelude= $self->{style}{compressor}->(); |
2197
|
|
|
|
|
|
|
$self->{fh}->print($prelude) if $prelude; |
2198
|
|
|
|
|
|
|
} |
2199
|
11
|
|
|
|
|
87
|
|
2200
|
|
|
|
|
|
|
$self->{fh} |
2201
|
353
|
100
|
|
|
|
838
|
->print("my (", join(",", sort keys %{ $self->{lexicals}{added} }), |
2202
|
|
|
|
|
|
|
");\n") |
2203
|
353
|
|
|
|
|
665
|
if $self->{lexicals}{added}; |
2204
|
777
|
|
|
|
|
1149
|
|
2205
|
|
|
|
|
|
|
foreach my $item (@items) { |
2206
|
777
|
|
|
|
|
1107
|
my $dumped= 0; |
|
777
|
|
|
|
|
2265
|
|
2207
|
777
|
50
|
|
|
|
1594
|
my $ret= |
2208
|
|
|
|
|
|
|
$self->_dump_sv(${ $item->{item} }, 1, \$dumped, $item->{name}); |
2209
|
777
|
|
|
|
|
2275
|
Carp::confess "\nUnhandled alias value '$ret' returned to Out()!" |
2210
|
777
|
|
|
|
|
1182
|
if $ret; |
2211
|
777
|
|
|
|
|
1690
|
$self->{fh}->print(";\n"); |
2212
|
|
|
|
|
|
|
$dumped= 1; |
2213
|
353
|
|
|
|
|
949
|
$self->_dump_apply_fix(); |
2214
|
353
|
50
|
|
|
|
811
|
} |
2215
|
|
|
|
|
|
|
$self->_dump_apply_fix('final'); |
2216
|
353
|
50
|
|
|
|
759
|
$self->{fh}->print($namestr) if $namestr; |
2217
|
|
|
|
|
|
|
|
2218
|
|
|
|
|
|
|
$self->diag if $DEBUG; |
2219
|
353
|
50
|
33
|
|
|
1387
|
|
2220
|
353
|
|
|
|
|
798
|
#warn "@{$self->{out_names}}"; |
2221
|
353
|
|
|
|
|
658
|
if ($self->{return} and defined wantarray) { |
2222
|
353
|
|
|
|
|
1124
|
my $r= delete $self->{return}; |
2223
|
|
|
|
|
|
|
delete $self->{fh}; |
2224
|
|
|
|
|
|
|
return $r->value; |
2225
|
0
|
|
|
|
|
0
|
} |
2226
|
|
|
|
|
|
|
else { |
2227
|
|
|
|
|
|
|
return $self; |
2228
|
|
|
|
|
|
|
} |
2229
|
|
|
|
|
|
|
|
2230
|
|
|
|
|
|
|
} |
2231
|
|
|
|
|
|
|
|
2232
|
2
|
|
|
2
|
0
|
12
|
# sqz(str,begin,end) |
2233
|
2
|
|
|
|
|
6
|
sub sqz { |
2234
|
2
|
|
|
|
|
7
|
require Compress::Zlib; |
2235
|
2
|
50
|
|
|
|
486
|
require MIME::Base64; |
2236
|
|
|
|
|
|
|
my $res= Compress::Zlib::compress($_[0], 9); |
2237
|
|
|
|
|
|
|
return $_[1] |
2238
|
|
|
|
|
|
|
? $_[1] . MIME::Base64::encode($res, "") . $_[2] |
2239
|
|
|
|
|
|
|
: MIME::Base64::encode($res, ""); |
2240
|
|
|
|
|
|
|
} |
2241
|
|
|
|
|
|
|
|
2242
|
0
|
|
|
0
|
0
|
0
|
# usqz(str) |
2243
|
|
|
|
|
|
|
sub usqz { |
2244
|
|
|
|
|
|
|
return Compress::Zlib::uncompress(MIME::Base64::decode($_[0])); |
2245
|
|
|
|
|
|
|
} |
2246
|
3570
|
|
|
3570
|
|
8219
|
|
2247
|
|
|
|
|
|
|
sub _dump_sv { |
2248
|
3570
|
|
|
|
|
6002
|
my ($self, $item, $depth, $dumped, $name, $indent, $is_ref)= @_; |
2249
|
|
|
|
|
|
|
|
2250
|
3570
|
|
|
|
|
7986
|
$self->{do_nl}= 0; |
2251
|
3570
|
|
|
|
|
7120
|
|
2252
|
3570
|
|
|
|
|
4814
|
my $addr= refaddr(\$_[1]); |
2253
|
3570
|
50
|
0
|
|
|
6953
|
my $idx= $self->{sv}{$addr}; |
2254
|
|
|
|
|
|
|
my $ro; |
2255
|
|
|
|
|
|
|
$DEBUG |
2256
|
3570
|
|
66
|
|
|
6448
|
and printf "_dump_sv %d %s %#x - %d\n", $depth, $name, $addr, $idx || 0; |
2257
|
3570
|
|
|
|
|
8538
|
|
2258
|
3570
|
|
|
|
|
6597
|
$name ||= $self->{svn}[$idx]; |
2259
|
3570
|
100
|
|
|
|
6328
|
(my $clean_name= $name) =~ s/^[\@\%\&](\w+)/\$${1}_/; # XXX |
2260
|
|
|
|
|
|
|
my $optspace= $self->{style}{optspace}; |
2261
|
|
|
|
|
|
|
if ($idx) { |
2262
|
|
|
|
|
|
|
|
2263
|
1496
|
|
|
|
|
2675
|
# Its a monitored scalar. |
2264
|
|
|
|
|
|
|
|
2265
|
|
|
|
|
|
|
my $pre_dumped= $self->{svdu}[$idx]; |
2266
|
1496
|
|
66
|
|
|
7116
|
my $name_diff= |
2267
|
|
|
|
|
|
|
( $self->{svd}[$idx] == $depth |
2268
|
|
|
|
|
|
|
and $self->{svn}[$idx] ne $clean_name |
2269
|
|
|
|
|
|
|
and $clean_name !~ /\*/ |
2270
|
|
|
|
|
|
|
and $name !~ /^\&/); |
2271
|
|
|
|
|
|
|
|
2272
|
|
|
|
|
|
|
#print "Idx: $idx Special keys:",join("-",keys %{$self->{special}}),"\n" |
2273
|
1496
|
50
|
|
|
|
2790
|
# if $DEBUG and keys %{$self->{special}}; |
2274
|
|
|
|
|
|
|
|
2275
|
1496
|
100
|
100
|
|
|
7980
|
print "sv_dump Monitored:\n", $self->diag_sv_idx($idx, " ") if $DEBUG; |
|
|
100
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
2276
|
|
|
|
|
|
|
|
2277
|
|
|
|
|
|
|
if ( |
2278
|
|
|
|
|
|
|
($pre_dumped and !$self->{svon}{$idx}) |
2279
|
|
|
|
|
|
|
or ( |
2280
|
|
|
|
|
|
|
!$self->{svon}{$idx} |
2281
|
|
|
|
|
|
|
? ($self->{svd}[$idx] < $depth or $name_diff) |
2282
|
|
|
|
|
|
|
: undef |
2283
|
|
|
|
|
|
|
) |
2284
|
|
|
|
|
|
|
) { |
2285
|
|
|
|
|
|
|
|
2286
|
316
|
0
|
33
|
|
|
687
|
print "PREDUMPED: $self->{svon}{$idx}\n" |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
2287
|
|
|
|
|
|
|
if $DEBUG |
2288
|
|
|
|
|
|
|
and $self->{svon}{$idx} |
2289
|
|
|
|
|
|
|
and $pre_dumped |
2290
|
|
|
|
|
|
|
and $$pre_dumped; |
2291
|
|
|
|
|
|
|
|
2292
|
316
|
0
|
|
|
|
616
|
# We've seen it before. |
|
|
50
|
|
|
|
|
|
2293
|
|
|
|
|
|
|
# Unless its a ref it must be an alias |
2294
|
|
|
|
|
|
|
print(($name_diff ? "Name diff" : "No name diff"), |
2295
|
|
|
|
|
|
|
" $name, $clean_name", "\n") |
2296
|
316
|
|
|
|
|
685
|
if $DEBUG; |
2297
|
|
|
|
|
|
|
|
2298
|
316
|
100
|
|
|
|
572
|
my ($str, $ret)= ('', undef); |
2299
|
220
|
100
|
100
|
|
|
1048
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
2300
|
|
|
|
|
|
|
if ($is_ref) { |
2301
|
|
|
|
|
|
|
if ($self->{svd}[$idx] == 1 && !$self->{style}{declare} |
2302
|
104
|
|
|
|
|
220
|
|| ($pre_dumped && $$pre_dumped)) |
2303
|
|
|
|
|
|
|
{ |
2304
|
|
|
|
|
|
|
$str= "\\$self->{svn}[$idx]"; |
2305
|
|
|
|
|
|
|
} |
2306
|
|
|
|
|
|
|
else { |
2307
|
|
|
|
|
|
|
#see the 'Many refs' tests in t\dump.t for |
2308
|
|
|
|
|
|
|
#why this is here. basically we need to |
2309
|
|
|
|
|
|
|
#ensure the ref is modifiable. If its two $'s |
2310
|
116
|
100
|
|
|
|
243
|
#then its modifiable anyway, more and it wont be. |
2311
|
6
|
|
|
|
|
12
|
# $ref=\\$x; $ref=RW $$ref=RO $$$ref=$x=RW |
2312
|
|
|
|
|
|
|
unless ($self->{style}{purity}) { |
2313
|
|
|
|
|
|
|
$str= "\\$self->{svn}[$idx]"; |
2314
|
110
|
|
|
|
|
285
|
} |
2315
|
110
|
100
|
|
|
|
236
|
else { |
2316
|
4
|
|
|
|
|
14
|
my $need_do= ($name =~ /^\$\$\$+/); |
2317
|
|
|
|
|
|
|
if ($need_do) { |
2318
|
|
|
|
|
|
|
$str .= join($optspace, qw( do { my $f = ), ''); |
2319
|
|
|
|
|
|
|
} |
2320
|
|
|
|
|
|
|
|
2321
|
110
|
50
|
|
|
|
464
|
$str .= |
|
|
50
|
|
|
|
|
|
2322
|
|
|
|
|
|
|
!$self->{style}{verbose} |
2323
|
|
|
|
|
|
|
? "'R'" |
2324
|
110
|
|
|
|
|
215
|
: _quote($DEBUG ? 'SR: ' : 'R: ', |
|
110
|
|
|
|
|
286
|
|
2325
|
110
|
|
|
|
|
344
|
"$self->{svn}[$idx]"); |
2326
|
|
|
|
|
|
|
$ret= \do { my $nope= 0 }; |
2327
|
110
|
100
|
|
|
|
270
|
$self->_add_fix('sv', $name, $idx, $ret); |
2328
|
|
|
|
|
|
|
|
2329
|
|
|
|
|
|
|
$str .= "$optspace}" if ($need_do); |
2330
|
|
|
|
|
|
|
} |
2331
|
|
|
|
|
|
|
} |
2332
|
96
|
100
|
|
|
|
249
|
} |
|
|
100
|
|
|
|
|
|
2333
|
36
|
50
|
|
|
|
93
|
else { |
2334
|
0
|
|
|
|
|
0
|
if ($depth == 1) { |
2335
|
|
|
|
|
|
|
if ($self->{style}{declare}) { |
2336
|
|
|
|
|
|
|
$str .= "my $name;\n"; |
2337
|
|
|
|
|
|
|
} |
2338
|
|
|
|
|
|
|
|
2339
|
36
|
|
|
|
|
99
|
#push @{$self->{out_names}},$name; |
2340
|
|
|
|
|
|
|
#push @{$self->{declare}},$name; |
2341
|
|
|
|
|
|
|
$str .= "alias_ref(\\$name,\\$self->{svn}[$idx])"; |
2342
|
|
|
|
|
|
|
} |
2343
|
|
|
|
|
|
|
elsif ($self->{style}{purity}) { |
2344
|
|
|
|
|
|
|
$str .= |
2345
|
52
|
50
|
|
|
|
175
|
!$self->{style}{verbose} |
2346
|
52
|
|
|
|
|
112
|
? "'A'" |
2347
|
|
|
|
|
|
|
: _quote("A: ", $self->{svn}[$idx]); |
2348
|
|
|
|
|
|
|
$ret= \$idx; |
2349
|
8
|
|
|
|
|
21
|
} |
2350
|
8
|
|
|
|
|
13
|
else { |
2351
|
|
|
|
|
|
|
$str .= "alias_to($self->{svn}[$idx])"; |
2352
|
|
|
|
|
|
|
$ret= ''; |
2353
|
316
|
|
|
|
|
630
|
} |
2354
|
316
|
50
|
|
|
|
817
|
} |
2355
|
316
|
|
|
|
|
1144
|
$self->{buf} += length($str); |
2356
|
316
|
100
|
|
|
|
1002
|
$self->{buf}= length($1) if $str =~ /\n([^\n]*)\s*\z/; |
2357
|
|
|
|
|
|
|
$self->{fh}->print($str); |
2358
|
|
|
|
|
|
|
return $ret ? $ret : (); |
2359
|
|
|
|
|
|
|
} |
2360
|
1180
|
|
66
|
|
|
4820
|
else { |
2361
|
|
|
|
|
|
|
# we've never seen it before and we need to dump it. |
2362
|
|
|
|
|
|
|
$self->{svdu}[$idx] ||= $dumped; |
2363
|
1180
|
0
|
33
|
|
|
2248
|
|
2364
|
|
|
|
|
|
|
print "Defining Special:" . $self->diag_sv_idx($idx) |
2365
|
1180
|
50
|
|
|
|
2439
|
if $DEBUG and $self->{special}{$idx}; |
2366
|
1180
|
50
|
|
|
|
2456
|
|
2367
|
|
|
|
|
|
|
$self->{svn}[$idx]= $name if $self->{special}{$idx}; |
2368
|
|
|
|
|
|
|
$self->{svd}[$idx]= $depth if $self->{special}{$idx}; |
2369
|
1180
|
|
|
|
|
2207
|
|
2370
|
|
|
|
|
|
|
} |
2371
|
|
|
|
|
|
|
$ro= $self->{svro}[$idx]; |
2372
|
2074
|
50
|
|
|
|
5828
|
} |
2373
|
|
|
|
|
|
|
else { |
2374
|
3254
|
50
|
|
|
|
6024
|
$ro= readonly $_[1] unless defined $ro; |
2375
|
3254
|
100
|
|
|
|
6406
|
} |
2376
|
|
|
|
|
|
|
print "sv_dump: Postindexed\n" if $DEBUG; |
2377
|
|
|
|
|
|
|
if ($depth == 1) { |
2378
|
741
|
50
|
66
|
|
|
2120
|
|
|
|
|
66
|
|
|
|
|
2379
|
|
|
|
|
|
|
# root level object. declare it |
2380
|
|
|
|
|
|
|
if ($name ne $clean_name and $name !~ /^\*/ and $self->{svc}[$idx] > 1) |
2381
|
139
|
50
|
|
|
|
295
|
{ |
2382
|
139
|
|
|
|
|
292
|
|
2383
|
139
|
100
|
|
|
|
288
|
print "Special $name\n" if $DEBUG; |
2384
|
|
|
|
|
|
|
my $oidx= $self->{ref}{ $self->{sva}[$idx] }; |
2385
|
|
|
|
|
|
|
if ($oidx) { |
2386
|
19
|
|
|
|
|
67
|
|
2387
|
19
|
|
|
|
|
78
|
#theres a ref to us out there |
2388
|
19
|
50
|
|
|
|
77
|
my $name= $self->_build_name($self->{refn}[$oidx], '$'); |
2389
|
|
|
|
|
|
|
$self->{svn}[$idx]= $name; |
2390
|
|
|
|
|
|
|
print "Oindex! $oidx $name\n" if $DEBUG; |
2391
|
|
|
|
|
|
|
|
2392
|
|
|
|
|
|
|
#$self->{svd}[$idx]=$self->{refd}[$idx]+1; |
2393
|
|
|
|
|
|
|
} |
2394
|
139
|
|
|
|
|
218
|
|
2395
|
|
|
|
|
|
|
#$self->{special}{$idx}++; |
2396
|
139
|
50
|
|
|
|
315
|
$self->{svdu}[$idx]= undef; |
2397
|
|
|
|
|
|
|
|
2398
|
|
|
|
|
|
|
print $self->diag_sv_idx($idx, 1) if $DEBUG; |
2399
|
|
|
|
|
|
|
} |
2400
|
|
|
|
|
|
|
|
2401
|
741
|
100
|
100
|
|
|
2822
|
#push @{$self->{out_names}},$name; #must |
2402
|
|
|
|
|
|
|
#push @{$self->{declare}},$name; |
2403
|
|
|
|
|
|
|
unless ($self->{style}{terse} || $name =~ /^\&/) { # XXX |
2404
|
|
|
|
|
|
|
my $str= (( |
2405
|
732
|
100
|
66
|
|
|
3421
|
$self->{style}{declare} |
2406
|
|
|
|
|
|
|
&& $name !~ /^\*/ |
2407
|
|
|
|
|
|
|
&& !$self->{lexicals}{added}{$name} |
2408
|
732
|
|
|
|
|
2504
|
) ? "my$optspace" : "" |
2409
|
732
|
|
|
|
|
1225
|
) . "$name$optspace=$optspace"; |
2410
|
732
|
|
|
|
|
1276
|
$self->{fh}->print($str); |
2411
|
|
|
|
|
|
|
$indent= length($str); |
2412
|
|
|
|
|
|
|
$self->{buf}= 0; |
2413
|
9
|
|
|
|
|
15
|
} |
2414
|
|
|
|
|
|
|
else { |
2415
|
741
|
50
|
|
|
|
1540
|
$indent= 0; |
2416
|
|
|
|
|
|
|
} |
2417
|
|
|
|
|
|
|
print "toplevel\n" if $DEBUG; |
2418
|
3254
|
|
|
|
|
6112
|
} |
2419
|
|
|
|
|
|
|
|
2420
|
3254
|
100
|
|
|
|
6515
|
my $iaddr= refaddr $item; |
2421
|
|
|
|
|
|
|
|
2422
|
|
|
|
|
|
|
$self->{fh}->print("\\") |
2423
|
3254
|
|
|
|
|
6522
|
if $is_ref; |
2424
|
|
|
|
|
|
|
|
2425
|
|
|
|
|
|
|
my $glob= globname $item; |
2426
|
|
|
|
|
|
|
my $add_do= |
2427
|
|
|
|
|
|
|
$self->{style}{purity} |
2428
|
|
|
|
|
|
|
&& !$ro |
2429
|
|
|
|
|
|
|
&& $is_ref |
2430
|
3254
|
|
100
|
|
|
16044
|
&& !blessed($_[1]) |
2431
|
|
|
|
|
|
|
&& !$glob |
2432
|
|
|
|
|
|
|
&& do { |
2433
|
|
|
|
|
|
|
my $rtype= reftype($_[1]); |
2434
|
|
|
|
|
|
|
$rtype eq "" |
2435
|
|
|
|
|
|
|
or ($rtype eq "SCALAR" and ($] < 5.020 or !readonly(${ $_[1] }))); |
2436
|
3254
|
100
|
|
|
|
5924
|
}; |
2437
|
|
|
|
|
|
|
|
2438
|
|
|
|
|
|
|
if ($add_do) { |
2439
|
35
|
|
|
|
|
169
|
|
2440
|
35
|
|
|
|
|
76
|
#warn "\n!$ro && $is_ref && !blessed($_[1]) && !$glob"; |
2441
|
|
|
|
|
|
|
$self->{fh}->print(join $optspace, qw(do { my $v = ), ''); |
2442
|
|
|
|
|
|
|
$self->{buf} += 13; |
2443
|
3254
|
100
|
|
|
|
5778
|
} |
2444
|
1252
|
50
|
|
|
|
2303
|
|
2445
|
1252
|
100
|
|
|
|
2226
|
unless ($iaddr) { |
2446
|
116
|
|
|
|
|
457
|
print "iaddr $glob\n" if $DEBUG; |
2447
|
116
|
|
|
|
|
241
|
unless (defined $item) { |
2448
|
|
|
|
|
|
|
$self->{fh}->print('undef'); |
2449
|
|
|
|
|
|
|
$self->{buf} += 5; |
2450
|
1136
|
|
100
|
|
|
3683
|
} |
2451
|
1136
|
100
|
100
|
|
|
2450
|
else { |
|
|
|
66
|
|
|
|
|
2452
|
1
|
|
|
|
|
19
|
my $is_ro= ($self->{style}{ro} && $ro && !$is_ref); |
2453
|
|
|
|
|
|
|
if ($is_ro and !$self->{style}{purity} and !$self->{style}{terse}) { |
2454
|
1136
|
100
|
|
|
|
2003
|
$self->{fh}->print("make_ro($optspace"); |
2455
|
20
|
100
|
|
|
|
52
|
} |
2456
|
1
|
|
|
|
|
5
|
if ($glob) { |
2457
|
|
|
|
|
|
|
if ($glob =~ /^\*Symbol::GEN/) { |
2458
|
|
|
|
|
|
|
$self->_dump_symbol($_[1], $name, $glob, 'deref', $depth); |
2459
|
19
|
|
|
|
|
40
|
} |
2460
|
19
|
|
|
|
|
76
|
else { |
2461
|
19
|
50
|
33
|
|
|
161
|
$self->{buf} += length($glob); |
2462
|
|
|
|
|
|
|
$self->{fh}->print($glob); |
2463
|
|
|
|
|
|
|
if ($self->{style}{dumpglob} |
2464
|
19
|
|
|
|
|
67
|
and !$self->{sv_glob_du}{$glob}++) |
2465
|
|
|
|
|
|
|
{ |
2466
|
|
|
|
|
|
|
$self->_add_fix('glob', $_[1], $glob, $depth + 1); |
2467
|
|
|
|
|
|
|
} |
2468
|
|
|
|
|
|
|
} |
2469
|
1116
|
|
|
|
|
1525
|
} |
2470
|
1116
|
100
|
|
|
|
2178
|
else { |
2471
|
26
|
|
|
26
|
|
303
|
my $quoted; |
|
26
|
|
|
|
|
62
|
|
|
26
|
|
|
|
|
24969
|
|
2472
|
1114
|
100
|
100
|
|
|
3156
|
if ($self->{style}{dualvars}) { |
|
|
|
66
|
|
|
|
|
2473
|
|
|
|
|
|
|
no warnings 'numeric'; # XXX: is this required? |
2474
|
|
|
|
|
|
|
if ( _could_be_dualvar($item) |
2475
|
|
|
|
|
|
|
&& 0 + $item ne $item |
2476
|
2
|
|
|
|
|
11
|
&& "$item" != $item) |
2477
|
|
|
|
|
|
|
{ |
2478
|
|
|
|
|
|
|
$quoted= |
2479
|
|
|
|
|
|
|
"dualvar( " |
2480
|
|
|
|
|
|
|
. join(",$optspace", 0 + $item, _quote("$item")) |
2481
|
|
|
|
|
|
|
. "$optspace)"; |
2482
|
|
|
|
|
|
|
} |
2483
|
|
|
|
|
|
|
} |
2484
|
1116
|
100
|
|
|
|
2194
|
|
2485
|
1114
|
|
|
|
|
1730
|
# XXX main scalar output here! |
2486
|
|
|
|
|
|
|
if (!$quoted) { |
2487
|
1114
|
100
|
66
|
|
|
2582
|
my $style= $self->{style}; |
|
|
|
33
|
|
|
|
|
2488
|
|
|
|
|
|
|
|
2489
|
|
|
|
|
|
|
if ( $style->{compress} |
2490
|
|
|
|
|
|
|
&& $style->{compressor} |
2491
|
2
|
|
|
|
|
6
|
&& length($_[1]) > $style->{compress}) |
2492
|
|
|
|
|
|
|
{ |
2493
|
|
|
|
|
|
|
$quoted= $style->{compressor}->($_[1], $self); |
2494
|
1112
|
|
|
|
|
2004
|
} |
2495
|
|
|
|
|
|
|
else { |
2496
|
|
|
|
|
|
|
$quoted= _quote($item); |
2497
|
|
|
|
|
|
|
} |
2498
|
1116
|
|
|
|
|
2282
|
|
2499
|
1116
|
50
|
|
|
|
2535
|
} |
2500
|
1116
|
|
|
|
|
3370
|
$self->{buf} += length($quoted); |
2501
|
|
|
|
|
|
|
$self->{buf}= length($1) if $quoted =~ /\n([^\n]*)\s*\z/; |
2502
|
1136
|
100
|
|
|
|
2697
|
$self->{fh}->print($quoted); #; |
2503
|
1134
|
100
|
100
|
|
|
3285
|
} |
|
|
100
|
|
|
|
|
|
2504
|
9
|
|
|
|
|
40
|
if (!$self->{style}{terse}) { |
2505
|
|
|
|
|
|
|
if ($is_ro && $self->{style}{purity}) { |
2506
|
|
|
|
|
|
|
$self->_add_fix('sub call', 'make_ro', $name); |
2507
|
1
|
|
|
|
|
8
|
} |
2508
|
|
|
|
|
|
|
elsif ($is_ro) { |
2509
|
|
|
|
|
|
|
$self->{fh}->print("$optspace)"); |
2510
|
|
|
|
|
|
|
} |
2511
|
|
|
|
|
|
|
} |
2512
|
|
|
|
|
|
|
|
2513
|
1252
|
|
|
|
|
1990
|
#return |
2514
|
|
|
|
|
|
|
} |
2515
|
|
|
|
|
|
|
$self->{do_nl}= 0; |
2516
|
2002
|
|
|
|
|
3189
|
} |
2517
|
2002
|
|
100
|
|
|
7482
|
else { |
2518
|
|
|
|
|
|
|
$self->{do_nl}= 1; |
2519
|
|
|
|
|
|
|
$self->_dump_rv($item, $depth + 1, $dumped, $name, $indent, |
2520
|
3254
|
100
|
|
|
|
6171
|
$is_ref && !$add_do); |
2521
|
|
|
|
|
|
|
} |
2522
|
|
|
|
|
|
|
$self->{fh}->print("$optspace}") |
2523
|
3254
|
100
|
|
|
|
6654
|
if $add_do; |
2524
|
3254
|
|
|
|
|
6485
|
$self->_add_fix('sub call', 'weaken', $name) |
2525
|
|
|
|
|
|
|
if $self->{svw}{$addr}; |
2526
|
|
|
|
|
|
|
return; |
2527
|
|
|
|
|
|
|
} |
2528
|
1802
|
|
|
1802
|
|
4010
|
|
2529
|
1802
|
|
|
|
|
4274
|
sub _brace { |
2530
|
|
|
|
|
|
|
my ($self, $name, $type, $cond, $indent, $child)= @_; |
2531
|
1802
|
100
|
|
|
|
4317
|
my $open= $type =~ /[\{\[\(]/; |
|
|
100
|
|
|
|
|
|
2532
|
|
|
|
|
|
|
|
2533
|
|
|
|
|
|
|
my $brace= |
2534
|
|
|
|
|
|
|
$name !~ /^[%@]/ ? $type |
2535
|
1802
|
100
|
|
|
|
3814
|
: $type =~ /[\{\[\(]/ ? '(' |
2536
|
1802
|
100
|
|
|
|
3080
|
: ')'; |
2537
|
|
|
|
|
|
|
$child= $child ? $self->{style}{optspace} : ""; |
2538
|
|
|
|
|
|
|
if ($cond) { |
2539
|
|
|
|
|
|
|
$_[-2] += |
2540
|
982
|
100
|
|
|
|
2146
|
$open |
2541
|
982
|
100
|
|
|
|
4592
|
? $self->{style}{indentcols} |
|
|
100
|
|
|
|
|
|
2542
|
|
|
|
|
|
|
: -$self->{style}{indentcols}; |
2543
|
|
|
|
|
|
|
$self->{fh}->print($open ? "" : "\n" . (" " x $_[-2]), |
2544
|
|
|
|
|
|
|
$brace, $open ? "\n" . (" " x $_[-2]) : ""); |
2545
|
820
|
100
|
|
|
|
3038
|
} |
|
|
100
|
|
|
|
|
|
2546
|
|
|
|
|
|
|
else { |
2547
|
1802
|
|
|
|
|
3654
|
$self->{fh}->print($open ? "" : $child, $brace, $open ? $child : ""); |
2548
|
|
|
|
|
|
|
} |
2549
|
|
|
|
|
|
|
return; |
2550
|
|
|
|
|
|
|
} |
2551
|
49
|
|
|
49
|
|
122
|
|
2552
|
49
|
|
|
|
|
81
|
sub _dump_qr { |
2553
|
49
|
|
|
|
|
472
|
my ($self, $pat, $mod)= @_; |
2554
|
49
|
|
|
|
|
158
|
my %counts; |
2555
|
49
|
|
|
|
|
102
|
$counts{$_}++ foreach split //, $pat; |
2556
|
51
|
|
|
|
|
80
|
my ($quotes, $best)= ('', length($pat) + 1); |
2557
|
51
|
|
100
|
|
|
222
|
foreach my $char (qw( / ! % & <> {} " ), '#') { #" |
2558
|
51
|
50
|
|
|
|
164
|
my $bad= 0; |
2559
|
51
|
100
|
|
|
|
133
|
$bad += $counts{$_} || 0 for split //, $char; |
2560
|
|
|
|
|
|
|
($quotes, $best)= ($char, $bad) if $bad < $best; |
2561
|
49
|
50
|
|
|
|
122
|
last unless $best; |
2562
|
|
|
|
|
|
|
} |
2563
|
|
|
|
|
|
|
$pat =~ s/(?!\\)([$quotes])/\\$1/g |
2564
|
26
|
|
|
26
|
|
223
|
if $best; |
|
26
|
|
|
|
|
72
|
|
|
26
|
|
|
|
|
138
|
|
|
49
|
|
|
|
|
69
|
|
2565
|
|
|
|
|
|
|
{ |
2566
|
|
|
|
|
|
|
use utf8; |
2567
|
49
|
|
|
|
|
146
|
|
|
1
|
|
|
|
|
7
|
|
2568
|
|
|
|
|
|
|
#$pat=~s/([^\x00-\x7f])/sprintf '\\x{%x}',ord $1/ge; |
2569
|
|
|
|
|
|
|
$pat =~ s/([^\040-\176])/sprintf "\\x{%x}", ord($1)/ge; |
2570
|
49
|
|
|
|
|
236
|
} |
2571
|
49
|
|
|
|
|
164
|
$self->{fh} |
2572
|
|
|
|
|
|
|
->print('qr', substr($quotes, 0, 1), $pat, substr($quotes, -1), $mod); |
2573
|
|
|
|
|
|
|
return; |
2574
|
|
|
|
|
|
|
} |
2575
|
|
|
|
|
|
|
|
2576
|
|
|
|
|
|
|
=for uedit32 |
2577
|
|
|
|
|
|
|
sub _default_key_sorters{} |
2578
|
|
|
|
|
|
|
|
2579
|
|
|
|
|
|
|
=cut |
2580
|
|
|
|
|
|
|
|
2581
|
|
|
|
|
|
|
my %default_key_sorters= ( |
2582
|
|
|
|
|
|
|
numeric => sub { |
2583
|
|
|
|
|
|
|
[ sort { $a <=> $b } keys %{ $_[0] } ] |
2584
|
|
|
|
|
|
|
}, |
2585
|
|
|
|
|
|
|
lexical => sub { [ sort keys %{ $_[0] } ] }, |
2586
|
|
|
|
|
|
|
smart => sub { |
2587
|
|
|
|
|
|
|
[ |
2588
|
|
|
|
|
|
|
map { $_->[-1] } |
2589
|
|
|
|
|
|
|
sort { |
2590
|
|
|
|
|
|
|
($a->[2] <=> $b->[2]) |
2591
|
|
|
|
|
|
|
|| ( |
2592
|
|
|
|
|
|
|
defined($a->[0]) |
2593
|
|
|
|
|
|
|
? $a->[0] <=> $b->[0] || ($a->[1] cmp $b->[1]) |
2594
|
|
|
|
|
|
|
: $a->[1] cmp $b->[1]) |
2595
|
|
|
|
|
|
|
|| ($a->[-1] cmp $b->[-1]) |
2596
|
|
|
|
|
|
|
} |
2597
|
|
|
|
|
|
|
map { |
2598
|
|
|
|
|
|
|
my $chars= lc($_); |
2599
|
|
|
|
|
|
|
my $num; |
2600
|
|
|
|
|
|
|
$num= $1 |
2601
|
|
|
|
|
|
|
if $chars =~ |
2602
|
|
|
|
|
|
|
s/\A(-?(?:0|[1-9]\d{0,8})(?:\.\d{0,15})?)(?!\d)//; |
2603
|
|
|
|
|
|
|
$chars =~ s/\W//g; |
2604
|
|
|
|
|
|
|
[ |
2605
|
|
|
|
|
|
|
$num, $chars, |
2606
|
|
|
|
|
|
|
!defined $num ? 2 |
2607
|
|
|
|
|
|
|
: |
2608
|
|
|
|
|
|
|
|
2609
|
|
|
|
|
|
|
# length($chars) ? 1 : |
2610
|
|
|
|
|
|
|
0, $_ |
2611
|
|
|
|
|
|
|
] |
2612
|
|
|
|
|
|
|
} keys %{ $_[0] } ] |
2613
|
|
|
|
|
|
|
}, |
2614
|
|
|
|
|
|
|
'each' => sub { undef }, |
2615
|
|
|
|
|
|
|
); |
2616
|
|
|
|
|
|
|
$default_key_sorters{alphabetical}= $default_key_sorters{lexical}; |
2617
|
|
|
|
|
|
|
$default_key_sorters{intelligent}= $default_key_sorters{smart}; |
2618
|
|
|
|
|
|
|
for my $h (\%default_key_sorters) { |
2619
|
|
|
|
|
|
|
my $abr= Text::Abbrev::abbrev(keys %$h); |
2620
|
|
|
|
|
|
|
foreach my $short (keys %$abr) { |
2621
|
|
|
|
|
|
|
$h->{$short}= $h->{ $abr->{$short} }; |
2622
|
|
|
|
|
|
|
} |
2623
|
|
|
|
|
|
|
} |
2624
|
1020
|
|
|
1020
|
|
2083
|
|
2625
|
|
|
|
|
|
|
sub _get_keys { |
2626
|
1020
|
|
|
|
|
1407
|
my ($self, $item, $pass, $addr, $class)= @_; |
2627
|
1020
|
100
|
|
|
|
2169
|
|
2628
|
|
|
|
|
|
|
my $sorter; |
2629
|
|
|
|
|
|
|
$class= "" if !defined $class; |
2630
|
1020
|
|
100
|
|
|
3681
|
|
2631
|
1020
|
100
|
|
|
|
2098
|
$sorter= $self->{style}{sortkeys}{"#$addr"} |
2632
|
|
|
|
|
|
|
|| $self->{cache_sorter}{$class}; |
2633
|
|
|
|
|
|
|
if (!$sorter) { |
2634
|
|
|
|
|
|
|
$sorter= |
2635
|
239
|
|
33
|
|
|
1589
|
$self->{style}{sortkeys}{".$class"} |
2636
|
|
|
|
|
|
|
|| ($class && $class->can("DDS_sortkeys")) |
2637
|
|
|
|
|
|
|
|| $self->{style}{sortkeys}{"."}; |
2638
|
239
|
|
66
|
|
|
1086
|
|
2639
|
|
|
|
|
|
|
$self->{cache_sorter}{$class}= |
2640
|
1020
|
|
|
|
|
2332
|
($sorter ||= $default_key_sorters{smart}); |
2641
|
1020
|
50
|
33
|
|
|
5489
|
} |
2642
|
|
|
|
|
|
|
my ($ary, $thaw)= $sorter->($item, $pass, $addr, $class); |
2643
|
1020
|
|
|
|
|
2429
|
die "$item:$pass:$addr:$class:$ary:$thaw" |
2644
|
|
|
|
|
|
|
if $ary and reftype($ary) ne "ARRAY"; |
2645
|
|
|
|
|
|
|
return ($ary, $thaw); |
2646
|
|
|
|
|
|
|
} |
2647
|
510
|
|
|
510
|
|
1250
|
|
2648
|
|
|
|
|
|
|
sub _dump_hash { |
2649
|
|
|
|
|
|
|
my ($self, $item, $depth, $dumped, $name, $indent, $addr, $class)= @_; |
2650
|
|
|
|
|
|
|
|
2651
|
510
|
|
|
|
|
1220
|
#Carp::confess "$name" unless defined $self->{ref_hkcnt}{$addr}; |
2652
|
510
|
50
|
33
|
|
|
1827
|
|
2653
|
0
|
|
|
|
|
0
|
my ($keyary)= $self->_get_keys($item, 1, $addr, $class); |
2654
|
|
|
|
|
|
|
if ($keyary and $DEBUG) { |
2655
|
|
|
|
|
|
|
warn "Keys: $keyary : @$keyary"; |
2656
|
510
|
|
|
|
|
1056
|
} |
2657
|
|
|
|
|
|
|
|
2658
|
|
|
|
|
|
|
my $full_indent= $self->{style}{indent} > 1; |
2659
|
510
|
|
100
|
|
|
2557
|
my $ind= ($self->{style}{indent}) |
2660
|
|
|
|
|
|
|
&& (!defined($self->{ref_hkcnt}{$addr}) |
2661
|
510
|
|
|
|
|
1636
|
or $self->{ref_hkcnt}{$addr} > 1); |
2662
|
|
|
|
|
|
|
|
2663
|
|
|
|
|
|
|
$self->_brace($name, '{', $ind, $indent, $self->{ref_hkcnt}{$addr}); |
2664
|
510
|
100
|
66
|
|
|
1975
|
|
2665
|
|
|
|
|
|
|
my $indkey= |
2666
|
510
|
|
|
|
|
752
|
($ind && $self->{style}{indentkeys}) ? $self->{ref_hklen}{$addr} : 0; |
2667
|
510
|
|
|
|
|
838
|
|
2668
|
510
|
|
|
|
|
778
|
my $cindent= $indent; |
2669
|
510
|
|
|
|
|
1063
|
my $style= $self->{style}; |
2670
|
510
|
|
|
|
|
826
|
my $optspace= $style->{optspace}; |
2671
|
510
|
100
|
|
|
|
993
|
my $sep= $optspace . $self->{style}{hashsep} . $optspace; |
2672
|
149
|
|
|
|
|
296
|
my $pairsep= $self->{style}{pairsep}; |
2673
|
|
|
|
|
|
|
if ($indkey) { |
2674
|
510
|
50
|
|
|
|
1066
|
$cindent += $indkey + length($sep); |
2675
|
510
|
|
|
|
|
959
|
} |
2676
|
510
|
|
|
|
|
771
|
$DEBUG == 10 and print "Indent $ind $indkey $cindent\n"; |
2677
|
510
|
|
|
|
|
1042
|
my ($kc, $ix)= (0, 0); |
2678
|
|
|
|
|
|
|
my $last_n= 0; |
2679
|
510
|
50
|
|
|
|
1598
|
my $ind_str= " " x $indent; |
2680
|
1192
|
100
|
|
|
|
2865
|
|
2681
|
1192
|
100
|
|
|
|
2095
|
while (defined(my $k= defined $keyary ? $keyary->[ $ix++ ] : each %$item)) { |
2682
|
696
|
|
66
|
|
|
1904
|
$last_n= 0 if ref $item->{$k}; |
2683
|
696
|
100
|
|
|
|
2883
|
if ($kc) { |
2684
|
696
|
|
|
|
|
1162
|
my $do_ind= $ind && !$last_n; |
2685
|
696
|
100
|
33
|
|
|
1268
|
$self->{fh}->print($pairsep, $do_ind ? "\n$ind_str" : $optspace); |
|
|
50
|
33
|
|
|
|
|
2686
|
686
|
|
|
|
|
1064
|
$self->{buf}++; |
2687
|
|
|
|
|
|
|
if ($do_ind) { |
2688
|
|
|
|
|
|
|
$self->{buf}= 0; |
2689
|
0
|
|
|
|
|
0
|
} |
2690
|
0
|
|
|
|
|
0
|
elsif (!$do_ind && !$optspace && $self->{buf} > 1024) { |
2691
|
|
|
|
|
|
|
$self->{fh}->print("\n"); |
2692
|
|
|
|
|
|
|
$self->{buf}= 0; |
2693
|
|
|
|
|
|
|
} |
2694
|
|
|
|
|
|
|
} |
2695
|
496
|
|
|
|
|
714
|
else { |
2696
|
|
|
|
|
|
|
#$self->{fh}->print("\n$ind_str") if !$last_n; |
2697
|
1192
|
100
|
|
|
|
2021
|
$kc= 1; |
2698
|
835
|
|
|
|
|
1564
|
} |
2699
|
835
|
50
|
|
|
|
2636
|
if ($indkey) { |
2700
|
|
|
|
|
|
|
my $qk= _quotekey($k); |
2701
|
|
|
|
|
|
|
my $str= |
2702
|
|
|
|
|
|
|
$indkey >= length($qk) |
2703
|
|
|
|
|
|
|
? join "", $qk, " " x ($indkey - length($qk)), $sep |
2704
|
835
|
|
|
|
|
1469
|
: join "", $qk, "\n$ind_str", " " x $indkey, $sep; |
2705
|
835
|
|
|
|
|
2062
|
|
2706
|
|
|
|
|
|
|
$self->{buf} += length($str); |
2707
|
|
|
|
|
|
|
$self->{fh}->print($str); |
2708
|
357
|
|
|
|
|
771
|
} |
2709
|
357
|
|
|
|
|
779
|
else { |
2710
|
357
|
|
|
|
|
927
|
my $str= _quotekey($k) . $sep; |
2711
|
|
|
|
|
|
|
$self->{buf} += length($str); |
2712
|
1192
|
|
|
|
|
3160
|
$self->{fh}->print($str); |
2713
|
|
|
|
|
|
|
} |
2714
|
1192
|
100
|
100
|
|
|
3730
|
my $alias= $self->_dump_sv($item->{$k}, $depth + 1, $dumped, |
|
|
|
66
|
|
|
|
|
2715
|
|
|
|
|
|
|
$self->_build_name($name, '{', $k), $cindent); |
2716
|
|
|
|
|
|
|
if (!$full_indent and !$self->{do_nl} and $self->{buf} < 60) { |
2717
|
6
|
|
|
|
|
22
|
|
2718
|
|
|
|
|
|
|
#warn "$self->{buf}\n"; |
2719
|
|
|
|
|
|
|
$last_n++; |
2720
|
|
|
|
|
|
|
} |
2721
|
1186
|
|
|
|
|
1811
|
else { |
2722
|
|
|
|
|
|
|
#warn "$self->{buf}\n"; |
2723
|
1192
|
100
|
|
|
|
4387
|
$last_n= 0; |
2724
|
6
|
|
|
|
|
33
|
} |
2725
|
|
|
|
|
|
|
if ($alias) { |
2726
|
|
|
|
|
|
|
$self->_add_fix('sub call', 'alias_hv', |
2727
|
|
|
|
|
|
|
$self->_build_name($name, '%'), |
2728
|
|
|
|
|
|
|
_quote($k), $alias); |
2729
|
510
|
|
|
|
|
1695
|
} |
2730
|
510
|
|
|
|
|
1438
|
} |
2731
|
|
|
|
|
|
|
$self->_brace($name, '}', $ind, $indent, $self->{ref_hkcnt}{$addr}); |
2732
|
|
|
|
|
|
|
return; |
2733
|
|
|
|
|
|
|
} |
2734
|
391
|
|
|
391
|
|
874
|
|
2735
|
391
|
|
|
|
|
726
|
sub _dump_array { |
2736
|
391
|
|
100
|
|
|
1358
|
my ($self, $item, $depth, $dumped, $name, $indent)= @_; |
2737
|
|
|
|
|
|
|
my $full_indent= $self->{style}{indent} > 1; |
2738
|
391
|
|
|
|
|
1209
|
my $ind= $self->{style}{indent} && @$item > 1; |
2739
|
391
|
|
|
|
|
625
|
|
2740
|
391
|
|
|
|
|
810
|
$self->_brace($name, '[', $ind, $indent, scalar @$item); |
2741
|
391
|
|
|
|
|
647
|
my $last_n= 0; |
|
391
|
|
|
|
|
1113
|
|
2742
|
391
|
100
|
|
|
|
882
|
my $ind_str= (" " x $indent); |
2743
|
2
|
|
|
|
|
8
|
my ($optspace, $sep)= @{ $self->{style} }{qw(optspace arysep)}; |
2744
|
18
|
|
33
|
|
|
86
|
unless ($self->{style}{rle}) { |
2745
|
18
|
100
|
|
|
|
48
|
foreach my $k (0 .. $#$item) { |
2746
|
16
|
50
|
|
|
|
71
|
my $do_ind= $ind && (!$last_n || ref $item->[$k]); |
2747
|
16
|
50
|
0
|
|
|
44
|
if ($k) { |
|
|
0
|
0
|
|
|
|
|
2748
|
16
|
|
|
|
|
27
|
$self->{fh}->print($sep, $do_ind ? "\n$ind_str" : $optspace); |
2749
|
|
|
|
|
|
|
if ($do_ind) { |
2750
|
|
|
|
|
|
|
$self->{buf}= 0; |
2751
|
0
|
|
|
|
|
0
|
} |
2752
|
0
|
|
|
|
|
0
|
elsif (!$do_ind && !$optspace && $self->{buf} > 1024) { |
2753
|
|
|
|
|
|
|
$self->{fh}->print("\n"); |
2754
|
|
|
|
|
|
|
$self->{buf}= 0; |
2755
|
|
|
|
|
|
|
} |
2756
|
18
|
|
|
|
|
44
|
} |
2757
|
|
|
|
|
|
|
|
2758
|
|
|
|
|
|
|
my $alias= $self->_dump_sv($item->[$k], $depth + 1, $dumped, |
2759
|
18
|
50
|
33
|
|
|
120
|
$self->_build_name($name, '[', $k), $indent); |
|
|
|
33
|
|
|
|
|
2760
|
|
|
|
|
|
|
|
2761
|
|
|
|
|
|
|
if (!$full_indent and !$self->{do_nl} and $self->{buf} < 60) { |
2762
|
0
|
|
|
|
|
0
|
|
2763
|
|
|
|
|
|
|
#warn "$last_n\n"; |
2764
|
|
|
|
|
|
|
$last_n++; |
2765
|
18
|
|
|
|
|
29
|
} |
2766
|
|
|
|
|
|
|
else { |
2767
|
18
|
50
|
|
|
|
45
|
$last_n= 0; |
2768
|
0
|
|
|
|
|
0
|
} |
2769
|
|
|
|
|
|
|
if ($alias) { |
2770
|
|
|
|
|
|
|
$self->_add_fix('sub call', 'alias_av', |
2771
|
|
|
|
|
|
|
$self->_build_name($name, '@'), |
2772
|
|
|
|
|
|
|
$k, $alias); |
2773
|
|
|
|
|
|
|
} |
2774
|
|
|
|
|
|
|
} |
2775
|
|
|
|
|
|
|
} |
2776
|
|
|
|
|
|
|
else { |
2777
|
389
|
|
|
|
|
1084
|
# this is evil and must be changed. |
2778
|
1043
|
|
|
|
|
1914
|
# ... evil ... totally evil... blech |
2779
|
1043
|
|
|
|
|
1507
|
for (my $k= 0 ; $k <= $#$item ;) { |
2780
|
1043
|
100
|
100
|
|
|
4975
|
my $v= $item->[$k]; |
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
2781
|
|
|
|
|
|
|
my $count= 1; |
2782
|
|
|
|
|
|
|
if ( |
2783
|
|
|
|
|
|
|
!refaddr($item->[$k]) |
2784
|
|
|
|
|
|
|
and !readonly($item->[$k]) |
2785
|
|
|
|
|
|
|
and ( !$self->{sv}{ refaddr(\$item->[$k]) } |
2786
|
|
|
|
|
|
|
or $self->{svt}[ $self->{sv}{ refaddr(\$item->[$k]) } ] == |
2787
|
|
|
|
|
|
|
1) |
2788
|
293
|
|
100
|
|
|
3143
|
) { |
|
|
|
66
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
66
|
|
|
|
|
2789
|
|
|
|
|
|
|
COUNT: |
2790
|
|
|
|
|
|
|
while ( |
2791
|
|
|
|
|
|
|
$k + $count <= $#$item |
2792
|
|
|
|
|
|
|
|
2793
|
|
|
|
|
|
|
and !refaddr($item->[ $k + $count ]) |
2794
|
|
|
|
|
|
|
|
2795
|
|
|
|
|
|
|
and !readonly($item->[ $k + $count ]) |
2796
|
|
|
|
|
|
|
|
2797
|
|
|
|
|
|
|
and ( !$self->{sv}{ refaddr(\$item->[ $k + $count ]) } |
2798
|
|
|
|
|
|
|
or $self->{svt} |
2799
|
|
|
|
|
|
|
[ $self->{sv}{ refaddr(\$item->[ $k + $count ]) } ] == |
2800
|
|
|
|
|
|
|
1) |
2801
|
|
|
|
|
|
|
|
2802
|
|
|
|
|
|
|
and !$v == !$item->[ $k + $count ] |
2803
|
|
|
|
|
|
|
|
2804
|
|
|
|
|
|
|
and defined($v) == defined($item->[ $k + $count ])) |
2805
|
224
|
50
|
|
|
|
555
|
|
2806
|
0
|
0
|
|
|
|
0
|
{ |
2807
|
|
|
|
|
|
|
if (!defined($item->[ $k + $count ])) { |
2808
|
|
|
|
|
|
|
last COUNT if defined($v); |
2809
|
|
|
|
|
|
|
} |
2810
|
224
|
100
|
|
|
|
749
|
else { |
2811
|
|
|
|
|
|
|
last COUNT |
2812
|
55
|
|
|
|
|
620
|
if $v ne overload::StrVal($item->[ $k + $count ]); |
2813
|
|
|
|
|
|
|
} |
2814
|
|
|
|
|
|
|
$count++; |
2815
|
|
|
|
|
|
|
} |
2816
|
1043
|
|
66
|
|
|
4327
|
} |
2817
|
1043
|
100
|
|
|
|
3874
|
|
|
|
100
|
|
|
|
|
|
2818
|
|
|
|
|
|
|
my $do_ind= $ind && (!$last_n || ref $item->[$k]); |
2819
|
1043
|
100
|
100
|
|
|
3456
|
$self->{fh}->print($sep, $do_ind ? "\n$ind_str" : $optspace) |
2820
|
1043
|
100
|
|
|
|
1991
|
if $k; |
2821
|
19
|
|
|
|
|
83
|
$self->{buf}= 0 if $do_ind and $k; |
2822
|
19
|
|
|
|
|
36
|
if ($count > 1) { |
2823
|
|
|
|
|
|
|
$self->{fh}->print("($optspace"); |
2824
|
1043
|
|
|
|
|
2587
|
$self->{buf} += 2; |
2825
|
|
|
|
|
|
|
} |
2826
|
1043
|
100
|
66
|
|
|
3324
|
my $alias= $self->_dump_sv($item->[$k], $depth + 1, $dumped, |
|
|
|
66
|
|
|
|
|
2827
|
18
|
|
|
|
|
30
|
$self->_build_name($name, '[', $k), $indent); |
2828
|
|
|
|
|
|
|
if (!$full_indent and !$self->{do_nl} and $self->{buf} < 60) { |
2829
|
|
|
|
|
|
|
$last_n++; |
2830
|
1025
|
|
|
|
|
1884
|
} |
2831
|
|
|
|
|
|
|
else { |
2832
|
1043
|
100
|
|
|
|
1929
|
$last_n= 0; |
2833
|
46
|
|
|
|
|
122
|
} |
2834
|
|
|
|
|
|
|
if ($alias) { |
2835
|
|
|
|
|
|
|
$self->_add_fix('sub call', 'alias_av', |
2836
|
|
|
|
|
|
|
$self->_build_name($name, '@'), |
2837
|
1043
|
100
|
|
|
|
2038
|
$k, $alias); |
2838
|
19
|
|
|
|
|
50
|
} |
2839
|
19
|
|
|
|
|
53
|
if ($count > 1) { |
2840
|
19
|
|
|
|
|
47
|
my $str= join $optspace, '', ')', 'x', $count; |
2841
|
|
|
|
|
|
|
$self->{buf} += length($str); |
2842
|
1043
|
|
|
|
|
2755
|
$self->{fh}->print($str); |
2843
|
|
|
|
|
|
|
} |
2844
|
|
|
|
|
|
|
$k += $count; |
2845
|
|
|
|
|
|
|
|
2846
|
391
|
|
|
|
|
1279
|
} |
2847
|
391
|
|
|
|
|
762
|
} |
2848
|
|
|
|
|
|
|
$self->_brace($name, ']', $ind, $indent, scalar @$item); |
2849
|
|
|
|
|
|
|
return; |
2850
|
|
|
|
|
|
|
} |
2851
|
0
|
|
|
0
|
|
0
|
|
2852
|
0
|
0
|
|
|
|
0
|
sub __vstr { |
|
|
0
|
|
|
|
|
|
2853
|
0
|
|
|
|
|
0
|
my ($v, @v); |
2854
|
|
|
|
|
|
|
unless (@_) { |
2855
|
0
|
|
|
|
|
0
|
$v= $]; |
2856
|
0
|
|
|
|
|
0
|
} |
2857
|
|
|
|
|
|
|
elsif (@_ == 1) { |
2858
|
|
|
|
|
|
|
$v= shift; |
2859
|
0
|
|
|
|
|
0
|
} |
2860
|
|
|
|
|
|
|
else { |
2861
|
|
|
|
|
|
|
@v= @_; |
2862
|
|
|
|
|
|
|
} |
2863
|
0
|
0
|
|
|
|
0
|
return join ".", @v |
|
0
|
|
|
|
|
0
|
|
2864
|
|
|
|
|
|
|
? (@v, (0) x 3)[ 0 .. 2 ] |
2865
|
|
|
|
|
|
|
: map { $v * 1000**$_ % 1000 } 0 .. 2; |
2866
|
|
|
|
|
|
|
} |
2867
|
41
|
|
|
41
|
|
111
|
|
2868
|
41
|
50
|
|
|
|
98
|
sub _dump_code { |
2869
|
0
|
|
|
|
|
0
|
my ($self, $item, $name, $indent, $class)= @_; |
2870
|
|
|
|
|
|
|
unless ($self->{style}{deparse}) { |
2871
|
|
|
|
|
|
|
$self->{fh}->print($self->{style}{codestub}); |
2872
|
41
|
|
|
|
|
168
|
} |
2873
|
|
|
|
|
|
|
else { #deparseopts |
2874
|
41
|
100
|
|
|
|
248
|
my $cv= B::svref_2object($item); |
2875
|
1
|
|
|
|
|
10
|
|
2876
|
1
|
|
|
|
|
15
|
if (ref($cv->ROOT) =~ /NULL/) { |
2877
|
1
|
|
|
|
|
3
|
my $gv= $cv->GV; |
2878
|
|
|
|
|
|
|
$self->{fh}->print("\\&", $gv->STASH->NAME, "::", $gv->SAFENAME); |
2879
|
|
|
|
|
|
|
return; |
2880
|
|
|
|
|
|
|
} |
2881
|
40
|
|
|
|
|
88
|
|
|
40
|
|
|
|
|
1859
|
|
2882
|
|
|
|
|
|
|
my $deparser= Data::Dump::Streamer::Deparser->new( |
2883
|
40
|
|
|
|
|
155
|
@{ $self->{style}{deparseopts} }); |
2884
|
40
|
|
|
|
|
72
|
|
2885
|
40
|
|
|
|
|
118
|
my $used= _get_lexicals($item); |
2886
|
78
|
100
|
|
|
|
205
|
my %targ; |
2887
|
39
|
|
|
|
|
89
|
foreach my $targ (keys %$used) { |
2888
|
|
|
|
|
|
|
next if $targ =~ /\D/; |
2889
|
39
|
50
|
|
|
|
130
|
my $addr= refaddr($used->{$targ}); |
2890
|
|
|
|
|
|
|
$targ{$targ}= $self->{lexicals}{a2n}{$addr} |
2891
|
|
|
|
|
|
|
if $self->{lexicals}{a2n}{$addr}; |
2892
|
|
|
|
|
|
|
} |
2893
|
40
|
|
|
|
|
169
|
|
2894
|
|
|
|
|
|
|
# we added this method, its not a normal method. see bottom of file. |
2895
|
40
|
|
|
|
|
66
|
$deparser->dds_usenames(\%targ); |
2896
|
40
|
|
|
|
|
56
|
|
2897
|
|
|
|
|
|
|
my $bless= undef; |
2898
|
40
|
50
|
|
|
|
61
|
my $code; |
|
40
|
|
|
|
|
98
|
|
2899
|
40
|
|
|
|
|
63
|
DEPARSE: { |
|
40
|
|
|
|
|
38008
|
|
2900
|
40
|
50
|
|
|
|
221
|
$bless= ($class, bless($item, $bless))[0] if defined $bless; |
2901
|
40
|
50
|
33
|
|
|
247
|
eval { $code= $deparser->coderef2text($item) }; |
|
|
50
|
33
|
|
|
|
|
2902
|
|
|
|
|
|
|
bless $item, $bless if defined $bless; |
2903
|
|
|
|
|
|
|
if ( !defined $bless |
2904
|
|
|
|
|
|
|
and $@ |
2905
|
0
|
|
|
|
|
0
|
and $@ =~ /^\QUsage: ->coderef2text(CODEREF)\E/) |
2906
|
0
|
|
|
|
|
0
|
{ |
2907
|
|
|
|
|
|
|
$bless= 'CODE'; |
2908
|
|
|
|
|
|
|
redo DEPARSE; |
2909
|
0
|
|
|
|
|
0
|
} |
2910
|
|
|
|
|
|
|
elsif ($@) { |
2911
|
0
|
|
|
|
|
0
|
warnings::warnif "Using CODE stub for $name as " |
2912
|
0
|
|
|
|
|
0
|
. "B::Deparse->coderef2text (v$B::Deparse::VERSION" |
2913
|
0
|
|
|
|
|
0
|
. " on v@{[__vstr]}) failed. Message was:\n $@"; |
2914
|
|
|
|
|
|
|
$self->{fh}->print($self->{style}{codestub}); |
2915
|
|
|
|
|
|
|
return; |
2916
|
|
|
|
|
|
|
} |
2917
|
|
|
|
|
|
|
} |
2918
|
|
|
|
|
|
|
|
2919
|
|
|
|
|
|
|
#$self->{fh}->print("\n#",join " ",keys %$used,"\n"); |
2920
|
|
|
|
|
|
|
|
2921
|
40
|
|
|
|
|
92
|
#$code=~s/^\s*(\([^)]+\)|)\s*/sub$1\n/; |
2922
|
|
|
|
|
|
|
|
2923
|
40
|
50
|
|
|
|
165
|
$code =~ s/(\%\{)(\s*\{\}\s*)/$1;$2/g; |
2924
|
40
|
50
|
|
|
|
127
|
|
2925
|
40
|
|
|
|
|
164
|
$code= "sub" . ($code =~ /^\s*\(/ ? "" : " ") . $code; |
|
165
|
|
|
|
|
445
|
|
2926
|
|
|
|
|
|
|
if ($self->{style}{indent}) { |
2927
|
|
|
|
|
|
|
$code =~ s/\n/"\n"." " x $indent/meg; |
2928
|
|
|
|
|
|
|
} |
2929
|
40
|
100
|
|
|
|
181
|
|
2930
|
4
|
|
|
|
|
26
|
#warn $name; |
2931
|
|
|
|
|
|
|
if ($name =~ s/^\&//) { |
2932
|
40
|
|
|
|
|
219
|
$code =~ s/sub(\s)?/sub $name$1/; |
2933
|
|
|
|
|
|
|
} |
2934
|
40
|
|
|
|
|
95
|
$self->{fh}->print("$code"); |
2935
|
|
|
|
|
|
|
} |
2936
|
|
|
|
|
|
|
return; |
2937
|
|
|
|
|
|
|
} |
2938
|
|
|
|
|
|
|
|
2939
|
|
|
|
|
|
|
sub _dump_format { |
2940
|
|
|
|
|
|
|
|
2941
|
4
|
|
|
4
|
|
14
|
# from link from [ysth]: http://groups.google.com/groups?selm=laUs8gzkgOlT092yn%40efn.org |
2942
|
|
|
|
|
|
|
# translate arg (or reference to it) into a B::* object |
2943
|
4
|
50
|
|
|
|
16
|
my ($self, $item, $name, $indent)= @_; |
2944
|
4
|
|
|
|
|
22
|
|
2945
|
|
|
|
|
|
|
if ($self->{style}{deparse}) { |
2946
|
|
|
|
|
|
|
my $Bobj= B::svref_2object($item); |
2947
|
4
|
50
|
|
|
|
18
|
|
2948
|
4
|
50
|
|
|
|
16
|
# if passed a glob or globref, get the format |
2949
|
4
|
|
|
|
|
6
|
$Bobj= B::GV::FORM($Bobj) if ref $Bobj eq 'B::GV'; |
2950
|
4
|
|
|
|
|
12
|
if (ref $Bobj eq 'B::FM') { |
2951
|
4
|
|
|
|
|
69
|
my $format; |
2952
|
4
|
|
|
|
|
4358
|
eval { |
2953
|
|
|
|
|
|
|
my $deparser= Data::Dump::Streamer::Deparser->new(); |
2954
|
4
|
50
|
|
|
|
49
|
$format= $deparser->indent($deparser->deparse_format($Bobj)); |
2955
|
0
|
|
|
|
|
0
|
}; |
2956
|
0
|
|
|
|
|
0
|
if ($@) { |
2957
|
0
|
|
|
|
|
0
|
warnings::warnif |
2958
|
0
|
|
|
|
|
0
|
"B::Deparse (v$B::Deparse::VERSION on v@{[__vstr]}) failed FORMAT ref deparse.\n"; |
2959
|
|
|
|
|
|
|
$format= |
2960
|
4
|
50
|
|
|
|
27
|
"B::Deparse (v$B::Deparse::VERSION on v@{[__vstr]}) failed FORMAT ref deparse.\n.\n"; |
2961
|
4
|
|
|
|
|
13
|
} |
2962
|
4
|
|
|
|
|
73
|
my $ind= $self->{style}{indent} ? ' ' x $indent : ''; |
2963
|
|
|
|
|
|
|
$format= "format F =\n$format"; |
2964
|
4
|
|
|
|
|
12
|
$format =~ s/^/${ind}# /gm; |
2965
|
4
|
|
0
|
|
|
63
|
|
|
0
|
|
|
|
|
0
|
|
2966
|
|
|
|
|
|
|
my $end= '_EOF_FORMAT_'; |
2967
|
|
|
|
|
|
|
$end =~ s/T(\d*)_/sprintf "T%02d_",($1||0)+1/e |
2968
|
|
|
|
|
|
|
while $format =~ /$end/; |
2969
|
4
|
|
|
|
|
37
|
|
2970
|
|
|
|
|
|
|
$self->{fh}->print( |
2971
|
4
|
|
|
|
|
40
|
"do{ local *F; my \$F=<<'$end'; \$F=~s/^\\s+# //mg; eval \$F; die \$F.\$@ if \$@; *F{FORMAT};\n$format\n$end\n$ind}" |
2972
|
|
|
|
|
|
|
); |
2973
|
|
|
|
|
|
|
return; |
2974
|
|
|
|
|
|
|
} |
2975
|
0
|
|
|
|
|
0
|
} |
2976
|
|
|
|
|
|
|
|
2977
|
|
|
|
|
|
|
$self->{fh}->print($self->{style}{formatstub}); |
2978
|
|
|
|
|
|
|
|
2979
|
|
|
|
|
|
|
} |
2980
|
9
|
|
|
9
|
|
28
|
|
2981
|
|
|
|
|
|
|
sub _dump_symbol { |
2982
|
9
|
|
|
|
|
33
|
my ($self, $item, $name, $glob, $deref, $depth)= @_; |
2983
|
|
|
|
|
|
|
|
2984
|
9
|
100
|
|
|
|
43
|
my $ret= "Symbol::gensym"; |
2985
|
9
|
100
|
|
|
|
23
|
$ret= "do{ require Symbol; $ret }" |
2986
|
|
|
|
|
|
|
unless $self->{reqs}{Symbol}++; |
2987
|
9
|
|
|
|
|
40
|
$ret= "*{ $ret }" |
2988
|
9
|
50
|
33
|
|
|
77
|
if $deref; |
2989
|
9
|
|
|
|
|
34
|
$self->{fh}->print($ret); |
2990
|
|
|
|
|
|
|
if ($self->{style}{dumpglob} and !$self->{sv_glob_du}{$glob}++) { |
2991
|
|
|
|
|
|
|
$self->_add_fix('glob', $_[1], $glob, $depth + 1, $name); |
2992
|
|
|
|
|
|
|
} |
2993
|
|
|
|
|
|
|
} |
2994
|
2002
|
|
|
2002
|
|
4502
|
|
2995
|
|
|
|
|
|
|
sub _dump_rv { |
2996
|
2002
|
|
|
|
|
3162
|
my ($self, $item, $depth, $dumped, $name, $indent, $add_do)= @_; |
2997
|
|
|
|
|
|
|
|
2998
|
|
|
|
|
|
|
my ($addr, $idx, $type, $class, $is_frozen_replacement, $overloaded, |
2999
|
2002
|
50
|
|
|
|
2853
|
$raddr); |
|
2007
|
|
|
|
|
4764
|
|
3000
|
2007
|
|
|
|
|
3798
|
GETITEM: { |
3001
|
2007
|
|
|
|
|
4266
|
$addr= refaddr($item) or Carp::confess "$name : $item"; |
3002
|
2007
|
|
|
|
|
3764
|
$idx= $self->{ref}{$addr}; |
3003
|
2007
|
100
|
100
|
|
|
4576
|
$type= reftype($item); |
|
|
|
66
|
|
|
|
|
3004
|
|
|
|
|
|
|
$class= blessed($item); |
3005
|
2007
|
50
|
|
|
|
3606
|
$class= undef if $class and $class eq 'Regexp' and is_regexp $item; |
3006
|
|
|
|
|
|
|
|
3007
|
|
|
|
|
|
|
$DEBUG |
3008
|
2007
|
|
|
|
|
2755
|
and printf "_dump_rv %d %s %#x\n", $depth, $name, $addr; |
3009
|
2007
|
100
|
|
|
|
4052
|
|
3010
|
5
|
|
|
|
|
11
|
my $ignore= 0; |
3011
|
5
|
50
|
|
|
|
33
|
if ($self->{ref_fz}{$addr}) { |
|
|
50
|
|
|
|
|
|
3012
|
0
|
|
|
|
|
0
|
$item= $self->{ref_fz}{$addr}; |
3013
|
|
|
|
|
|
|
if (!$item) { |
3014
|
|
|
|
|
|
|
$ignore= 1; |
3015
|
5
|
|
|
|
|
9
|
} |
3016
|
5
|
|
|
|
|
9
|
elsif (ref $item) { |
|
5
|
|
|
|
|
10
|
|
3017
|
5
|
|
|
|
|
8
|
$is_frozen_replacement= 1; |
3018
|
5
|
|
|
|
|
11
|
$dumped= \do { my $d }; |
3019
|
|
|
|
|
|
|
$raddr= $addr; |
3020
|
|
|
|
|
|
|
redo GETITEM; |
3021
|
0
|
|
|
|
|
0
|
} |
3022
|
0
|
|
|
|
|
0
|
else { |
3023
|
0
|
|
|
|
|
0
|
$self->{buf} += length($item); |
3024
|
|
|
|
|
|
|
$self->{fh}->print($item); |
3025
|
|
|
|
|
|
|
return; |
3026
|
2002
|
100
|
66
|
|
|
13041
|
} |
|
|
|
33
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
66
|
|
|
|
|
3027
|
|
|
|
|
|
|
} |
3028
|
|
|
|
|
|
|
if ( $ignore |
3029
|
|
|
|
|
|
|
or $self->{style}{ignore}{ "#" . ($raddr || $addr) } |
3030
|
1
|
|
|
|
|
8
|
or (defined $class and $self->{style}{ignore}{".$class"})) |
3031
|
1
|
|
|
|
|
4
|
{ |
3032
|
1
|
|
|
|
|
4
|
my $str= _quote("Ignored Obj [" . overload::StrVal($item) . "]"); |
3033
|
1
|
|
|
|
|
3
|
$self->{buf} += length($str); |
3034
|
|
|
|
|
|
|
$self->{fh}->print($str); |
3035
|
|
|
|
|
|
|
return; |
3036
|
|
|
|
|
|
|
} |
3037
|
2001
|
50
|
|
|
|
4333
|
} |
3038
|
|
|
|
|
|
|
|
3039
|
|
|
|
|
|
|
unless ($idx) { |
3040
|
|
|
|
|
|
|
|
3041
|
0
|
|
|
|
|
0
|
#Carp::confess "Unhandled address $addr $name\n"; |
3042
|
|
|
|
|
|
|
# this should only happen for localized globs. |
3043
|
2001
|
|
|
|
|
3329
|
($idx)= $self->_reg_ref($item, $depth, $name, refcount($item)); |
3044
|
2001
|
50
|
|
|
|
3470
|
} |
3045
|
2001
|
|
|
|
|
3415
|
my $optspace= $self->{style}{optspace}; |
3046
|
2001
|
|
|
|
|
2926
|
if ($idx) { |
3047
|
2001
|
100
|
100
|
|
|
8435
|
my $pre_dumped= $self->{refdu}[$idx]; |
|
|
100
|
100
|
|
|
|
|
3048
|
|
|
|
|
|
|
my $str= ""; |
3049
|
|
|
|
|
|
|
if ($pre_dumped and $$pre_dumped) { |
3050
|
182
|
50
|
|
|
|
414
|
|
3051
|
182
|
100
|
|
|
|
656
|
# its been dumped totally |
3052
|
58
|
100
|
|
|
|
173
|
$DEBUG and print " predumped $self->{refn}[$idx]\n"; |
3053
|
4
|
|
|
|
|
23
|
if ($self->{refn}[$idx] =~ /^[\@\%\&]/) { |
3054
|
4
|
|
|
|
|
16
|
if (SvREADONLY_ref($item)) { |
3055
|
|
|
|
|
|
|
my @hidden_keys= sort(hidden_keys(%$item)); |
3056
|
|
|
|
|
|
|
$self->_add_fix('lock', $idx, \@hidden_keys); |
3057
|
58
|
100
|
|
|
|
257
|
} |
|
|
100
|
|
|
|
|
|
3058
|
|
|
|
|
|
|
$str= join "", ($class ? "bless($optspace" : ''), |
3059
|
|
|
|
|
|
|
'\\' . $self->{refn}[$idx], ( |
3060
|
|
|
|
|
|
|
$class ? ",$optspace" . _quote($class) . "$optspace)" : ''); |
3061
|
124
|
|
|
|
|
259
|
} |
3062
|
|
|
|
|
|
|
else { |
3063
|
182
|
|
|
|
|
348
|
$str= $self->{refn}[$idx]; |
3064
|
182
|
|
|
|
|
692
|
} |
3065
|
182
|
|
|
|
|
400
|
$self->{buf} += length($str); |
3066
|
|
|
|
|
|
|
$self->{fh}->print($str); |
3067
|
|
|
|
|
|
|
return; |
3068
|
301
|
50
|
|
|
|
683
|
} |
3069
|
|
|
|
|
|
|
elsif ($pre_dumped or $self->{refd}[$idx] < $depth) { |
3070
|
|
|
|
|
|
|
$DEBUG |
3071
|
|
|
|
|
|
|
and print |
3072
|
|
|
|
|
|
|
" inprocess or depth violation: $self->{refd}[$idx] < $depth\n"; |
3073
|
|
|
|
|
|
|
|
3074
|
|
|
|
|
|
|
# we are in the process of dumping it |
3075
|
301
|
100
|
100
|
|
|
1349
|
# output a place holder and add a fix statement |
3076
|
|
|
|
|
|
|
# XXX is this sigil test correct? why not $? |
3077
|
|
|
|
|
|
|
if ($self->{refn}[$idx] =~ /^[\@\%\&]/ |
3078
|
|
|
|
|
|
|
and (!$self->{style}{declare})) |
3079
|
38
|
100
|
|
|
|
200
|
{ |
|
|
100
|
|
|
|
|
|
3080
|
|
|
|
|
|
|
$str= join "", ($class ? "bless($optspace" : ''), |
3081
|
|
|
|
|
|
|
'\\' . $self->{refn}[$idx], ( |
3082
|
|
|
|
|
|
|
$class ? ",$optspace" . _quote($class) . "$optspace)" : ''); |
3083
|
263
|
100
|
|
|
|
564
|
} |
3084
|
|
|
|
|
|
|
else { |
3085
|
|
|
|
|
|
|
if ($self->{style}{purity}) { |
3086
|
|
|
|
|
|
|
$str= |
3087
|
|
|
|
|
|
|
join "", |
3088
|
|
|
|
|
|
|
$add_do ? join($optspace, qw(do { my $v = ), '') : '', |
3089
|
258
|
100
|
|
|
|
1006
|
!$self->{style}{verbose} |
|
|
50
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
3090
|
|
|
|
|
|
|
? "'V'" |
3091
|
|
|
|
|
|
|
: _quote("V: ", $self->{refn}[$idx]), |
3092
|
|
|
|
|
|
|
$add_do ? $optspace . "}" : ''; |
3093
|
258
|
|
|
|
|
794
|
|
3094
|
|
|
|
|
|
|
#Carp::cluck "$name $self->{refd}[$idx] < $depth" if $name=~/\*/; |
3095
|
|
|
|
|
|
|
$self->_add_fix('ref', $name, $idx, $class); |
3096
|
5
|
|
|
|
|
11
|
} |
3097
|
|
|
|
|
|
|
else { |
3098
|
|
|
|
|
|
|
$str= $self->{refn}[$idx]; |
3099
|
301
|
|
|
|
|
642
|
} |
3100
|
301
|
|
|
|
|
1084
|
} |
3101
|
301
|
|
|
|
|
699
|
$self->{buf} += length($str); |
3102
|
|
|
|
|
|
|
$self->{fh}->print($str); |
3103
|
1518
|
|
33
|
|
|
5004
|
return; |
3104
|
|
|
|
|
|
|
} |
3105
|
|
|
|
|
|
|
$self->{refdu}[$idx] ||= $dumped; |
3106
|
|
|
|
|
|
|
|
3107
|
|
|
|
|
|
|
#$name=$self->{refn}[$idx]; # override inherited names. ??? maybe not needed |
3108
|
0
|
|
|
|
|
0
|
} |
3109
|
|
|
|
|
|
|
else { |
3110
|
1518
|
|
|
|
|
2284
|
Carp::confess "Unhandled object '$item'\n"; |
3111
|
1518
|
100
|
100
|
|
|
3509
|
} |
3112
|
26
|
|
|
|
|
800
|
my $isoverloaded= 0; |
3113
|
26
|
|
|
|
|
36
|
if (defined $class and overload::Overloaded($item)) { |
3114
|
26
|
|
|
|
|
97
|
disable_overloading($item); |
3115
|
|
|
|
|
|
|
$overloaded= $class; |
3116
|
1518
|
|
66
|
|
|
9862
|
$isoverloaded= 1; |
3117
|
1518
|
|
|
|
|
2349
|
} |
3118
|
1518
|
100
|
|
|
|
2861
|
my $thaw= $self->{ref_thaw}{ $raddr || $addr }; |
3119
|
4
|
50
|
|
|
|
18
|
my ($inline, $thawtype); |
3120
|
0
|
|
|
|
|
0
|
if ($thaw) { |
3121
|
|
|
|
|
|
|
if ($thaw =~ /[^\w:>()-]/) { |
3122
|
|
|
|
|
|
|
$thawtype= "code"; |
3123
|
4
|
|
|
|
|
16
|
} |
3124
|
4
|
100
|
|
|
|
16
|
else { |
3125
|
|
|
|
|
|
|
$inline= $thaw =~ s/^->//; |
3126
|
4
|
50
|
66
|
|
|
22
|
$thawtype= $thaw =~ s/\(\)$// ? "sub" : "method"; |
3127
|
0
|
|
|
|
|
0
|
} |
3128
|
0
|
|
|
|
|
0
|
if ($inline && $thawtype eq 'sub') { |
3129
|
|
|
|
|
|
|
$self->{buf} += length($thaw) + 1; |
3130
|
|
|
|
|
|
|
$self->{fh}->print($thaw . "(${optspace}"); |
3131
|
1518
|
|
|
|
|
2215
|
} |
3132
|
1518
|
|
100
|
|
|
3921
|
} |
3133
|
1518
|
|
|
|
|
2105
|
$self->{do_nl}= 1; |
3134
|
1518
|
100
|
|
|
|
3107
|
my $add_lock= ($type eq 'HASH') && SvREADONLY_ref($item); |
3135
|
1518
|
100
|
|
|
|
2874
|
my $fix_lock= 0; |
3136
|
|
|
|
|
|
|
my @hidden_keys= $add_lock ? sort(hidden_keys(%$item)) : (); |
3137
|
|
|
|
|
|
|
if ($add_lock) { |
3138
|
38
|
100
|
|
|
|
119
|
|
3139
|
8
|
|
|
|
|
11
|
#warn "$name\n"; |
3140
|
8
|
|
|
|
|
15
|
if ($name !~ /^\$/) { |
3141
|
|
|
|
|
|
|
$fix_lock= 1; |
3142
|
|
|
|
|
|
|
$add_lock= 0; |
3143
|
30
|
100
|
|
|
|
135
|
} |
3144
|
|
|
|
|
|
|
else { |
3145
|
|
|
|
|
|
|
$self->{fh}->print("lock_ref_keys", @hidden_keys ? '_plus' : '', |
3146
|
|
|
|
|
|
|
"(${optspace}"); |
3147
|
|
|
|
|
|
|
} |
3148
|
1518
|
|
100
|
|
|
3322
|
} |
3149
|
1518
|
100
|
100
|
|
|
3183
|
|
3150
|
84
|
|
|
|
|
385
|
my $add_bless= defined($class) && ($name !~ /^[\@\%\&]/); |
3151
|
|
|
|
|
|
|
if ($add_bless && !$overloaded) { |
3152
|
|
|
|
|
|
|
$self->{fh}->print(substr($self->{style}{bless}, 0, -1), $optspace); |
3153
|
1518
|
50
|
|
|
|
2925
|
} |
3154
|
1518
|
100
|
100
|
|
|
7581
|
|
|
|
100
|
100
|
|
|
|
|
|
|
100
|
33
|
|
|
|
|
|
|
100
|
33
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
3155
|
521
|
100
|
|
|
|
1357
|
$DEBUG and print " $type : Start typecheck\n"; |
3156
|
521
|
100
|
|
|
|
1095
|
if ($type eq 'SCALAR' or $type eq 'REF' or $type eq 'GLOB') { |
3157
|
521
|
100
|
|
|
|
1267
|
my ($pat, $mod)= $type eq 'SCALAR' ? regex($item) : (); |
|
|
50
|
|
|
|
|
|
3158
|
8
|
|
|
|
|
30
|
my $glob= $type eq 'GLOB' ? globname $$item : ''; |
3159
|
|
|
|
|
|
|
if ($glob =~ /^\*Symbol::GEN/) { |
3160
|
|
|
|
|
|
|
$self->_dump_symbol($_[1], $name, $glob, 0, $depth); |
3161
|
|
|
|
|
|
|
} |
3162
|
|
|
|
|
|
|
elsif (defined $pat) { |
3163
|
0
|
|
|
|
|
0
|
|
3164
|
|
|
|
|
|
|
# its a regex |
3165
|
|
|
|
|
|
|
$self->_dump_qr($pat, $mod); |
3166
|
513
|
|
|
|
|
1268
|
} |
3167
|
|
|
|
|
|
|
else { |
3168
|
|
|
|
|
|
|
my $ret= |
3169
|
|
|
|
|
|
|
$self->_dump_sv($$item, $depth + 1, $dumped, |
3170
|
513
|
100
|
|
|
|
1403
|
$self->_build_name($name, '$'), |
3171
|
|
|
|
|
|
|
$indent, 'is_ref'); |
3172
|
|
|
|
|
|
|
$self->{refdu}[$idx]= $ret if $ret; |
3173
|
|
|
|
|
|
|
} |
3174
|
391
|
|
|
|
|
1227
|
} |
3175
|
|
|
|
|
|
|
elsif ($type eq 'ARRAY') { |
3176
|
|
|
|
|
|
|
$self->_dump_array($item, $depth, $dumped, $name, $indent); |
3177
|
510
|
|
|
|
|
1441
|
} |
3178
|
|
|
|
|
|
|
elsif ($type eq 'HASH') { |
3179
|
|
|
|
|
|
|
$self->_dump_hash($item, $depth, $dumped, $name, $indent, $addr, |
3180
|
|
|
|
|
|
|
$class); |
3181
|
41
|
|
|
|
|
165
|
} |
3182
|
|
|
|
|
|
|
elsif ($type eq 'CODE') { |
3183
|
|
|
|
|
|
|
$self->_dump_code($item, $name, $indent, $class); |
3184
|
|
|
|
|
|
|
} |
3185
|
|
|
|
|
|
|
elsif ($type eq 'FORMAT') { |
3186
|
4
|
|
|
|
|
19
|
|
3187
|
|
|
|
|
|
|
#$self->_dump_code($item,$name,$indent,$class); #muwhahahah |
3188
|
|
|
|
|
|
|
$self->_dump_format($item, $name, $indent); |
3189
|
2
|
|
|
|
|
9
|
} |
3190
|
|
|
|
|
|
|
elsif ($type eq 'IO') { |
3191
|
|
|
|
|
|
|
$self->{fh}->print("*{Symbol::gensym()}{IO}"); |
3192
|
49
|
|
|
|
|
198
|
} |
3193
|
49
|
|
|
|
|
158
|
elsif ($type eq 'ORANGE' || $type eq 'Regexp' || $type eq 'REGEXP') { |
3194
|
|
|
|
|
|
|
my ($pat, $mod)= regex($item); |
3195
|
|
|
|
|
|
|
$self->_dump_qr($pat, $mod); |
3196
|
0
|
|
|
|
|
0
|
} |
3197
|
|
|
|
|
|
|
else { |
3198
|
1518
|
100
|
|
|
|
3106
|
Carp::confess "_dump_rv() can't handle '$type' objects yet\n :-(\n"; |
3199
|
110
|
100
|
|
|
|
276
|
} |
3200
|
|
|
|
|
|
|
if ($add_bless) { |
3201
|
84
|
|
|
|
|
272
|
unless (defined $overloaded) { |
3202
|
|
|
|
|
|
|
$self->{fh}->print(",${optspace}", _quote($class), $optspace, |
3203
|
|
|
|
|
|
|
substr($self->{style}{bless}, -1)); |
3204
|
26
|
|
|
|
|
59
|
} |
3205
|
|
|
|
|
|
|
else { |
3206
|
110
|
100
|
|
|
|
310
|
$self->_add_fix('bless', $idx, $overloaded); |
3207
|
26
|
|
|
|
|
57
|
} |
3208
|
|
|
|
|
|
|
if ($isoverloaded) { |
3209
|
|
|
|
|
|
|
restore_overloading($item, $overloaded); |
3210
|
1518
|
100
|
100
|
|
|
3081
|
} |
3211
|
4
|
|
|
|
|
22
|
} |
3212
|
|
|
|
|
|
|
if ($fix_lock && !defined($class)) { |
3213
|
1518
|
100
|
|
|
|
2683
|
$self->_add_fix('lock', $idx, \@hidden_keys); |
3214
|
30
|
100
|
|
|
|
74
|
} |
3215
|
|
|
|
|
|
|
if ($add_lock) { |
3216
|
26
|
|
|
|
|
69
|
if (@hidden_keys) { |
|
46
|
|
|
|
|
83
|
|
3217
|
|
|
|
|
|
|
$self->{fh}->print(",${optspace}", |
3218
|
30
|
|
|
|
|
100
|
join(",${optspace}", map { _quote($_) } @hidden_keys)); |
3219
|
|
|
|
|
|
|
} |
3220
|
1518
|
100
|
|
|
|
2713
|
$self->{fh}->print("${optspace})"); |
3221
|
4
|
100
|
|
|
|
9
|
} |
3222
|
1
|
50
|
|
|
|
10
|
if ($thaw) { |
|
|
50
|
|
|
|
|
|
3223
|
0
|
|
|
|
|
0
|
if ($inline) { |
3224
|
|
|
|
|
|
|
if ($thawtype eq 'sub') { |
3225
|
|
|
|
|
|
|
$self->{fh}->print("${optspace})"); |
3226
|
1
|
|
|
|
|
5
|
} |
3227
|
|
|
|
|
|
|
elsif ($thawtype eq 'method') { |
3228
|
|
|
|
|
|
|
$self->{fh}->print("->$thaw()"); |
3229
|
|
|
|
|
|
|
} |
3230
|
|
|
|
|
|
|
|
3231
|
|
|
|
|
|
|
#$$dumped=1; |
3232
|
3
|
100
|
|
|
|
15
|
} |
3233
|
|
|
|
|
|
|
else { |
3234
|
|
|
|
|
|
|
$self->_add_fix('thaw', $idx, |
3235
|
|
|
|
|
|
|
$thaw . ($thawtype eq 'sub' ? "()" : "")); |
3236
|
1518
|
50
|
66
|
|
|
5501
|
} |
3237
|
0
|
0
|
|
|
|
0
|
} |
3238
|
0
|
|
|
|
|
0
|
if (my $postop= $self->{ref_postop}{ $raddr || $addr }) { |
3239
|
|
|
|
|
|
|
if (ref $postop) { |
3240
|
|
|
|
|
|
|
$postop->($_[1]); |
3241
|
0
|
|
|
|
|
0
|
} |
3242
|
|
|
|
|
|
|
else { |
3243
|
|
|
|
|
|
|
$_[1]->$postop(); |
3244
|
1518
|
|
|
|
|
2356
|
} |
3245
|
|
|
|
|
|
|
} |
3246
|
1518
|
|
|
|
|
3170
|
$self->{do_nl}= 1; |
3247
|
|
|
|
|
|
|
|
3248
|
|
|
|
|
|
|
return; |
3249
|
|
|
|
|
|
|
} |
3250
|
|
|
|
|
|
|
|
3251
|
|
|
|
|
|
|
=item Names |
3252
|
|
|
|
|
|
|
|
3253
|
|
|
|
|
|
|
=item Names LIST |
3254
|
|
|
|
|
|
|
|
3255
|
|
|
|
|
|
|
=item Names ARRAYREF |
3256
|
|
|
|
|
|
|
|
3257
|
|
|
|
|
|
|
Takes a list of strings or a reference to an array of strings to use for |
3258
|
|
|
|
|
|
|
var names for the objects dumped. The names may be prefixed by a * |
3259
|
|
|
|
|
|
|
indicating the variable is to be dumped as its dereferenced type if it is |
3260
|
|
|
|
|
|
|
an array, hash or code ref. Otherwise the star is ignored. Other sigils |
3261
|
|
|
|
|
|
|
may be prefixed but they will be silently converted to *'s. |
3262
|
|
|
|
|
|
|
|
3263
|
|
|
|
|
|
|
If no names are provided then names are generated automatically based on |
3264
|
|
|
|
|
|
|
the type of object being dumped, with abbreviations applied to compound |
3265
|
|
|
|
|
|
|
class names. |
3266
|
|
|
|
|
|
|
|
3267
|
|
|
|
|
|
|
If called with arguments then returns the object itself, otherwise in list |
3268
|
|
|
|
|
|
|
context returns the list of names in use, or in scalar context a reference |
3269
|
|
|
|
|
|
|
or undef. In void context with no arguments the names are cleared. |
3270
|
|
|
|
|
|
|
|
3271
|
|
|
|
|
|
|
B |
3272
|
|
|
|
|
|
|
Must be called before C is called. |
3273
|
|
|
|
|
|
|
|
3274
|
|
|
|
|
|
|
If you wish to have no names, use L. |
3275
|
|
|
|
|
|
|
|
3276
|
|
|
|
|
|
|
=cut |
3277
|
65
|
|
|
65
|
1
|
9508
|
|
3278
|
65
|
100
|
|
|
|
190
|
sub Names { |
|
|
100
|
|
|
|
|
|
3279
|
60
|
50
|
66
|
|
|
304
|
my $self= shift->_safe_self; |
3280
|
|
|
|
|
|
|
if (@_) { |
3281
|
|
|
|
|
|
|
my $v= (@_ == 1 and reftype $_[0] eq 'ARRAY') ? shift @_ : \@_; |
3282
|
133
|
|
|
|
|
359
|
$self->{unames}= [ |
3283
|
133
|
|
|
|
|
246
|
map { |
3284
|
133
|
50
|
33
|
|
|
663
|
(my $s= $_) =~ s/^[\@\%\&-]/*/; |
3285
|
|
|
|
|
|
|
$s =~ s/^\$//; |
3286
|
133
|
|
|
|
|
426
|
Carp::confess "Bad name '$_'" |
3287
|
60
|
|
|
|
|
212
|
if $s && $s !~ /^\*?\w+$/; |
|
133
|
|
|
|
|
313
|
|
3288
|
|
|
|
|
|
|
$s |
3289
|
60
|
|
|
|
|
419
|
} grep { defined } @$v |
3290
|
|
|
|
|
|
|
]; |
3291
|
|
|
|
|
|
|
return $self; |
3292
|
3
|
|
|
|
|
10
|
} |
3293
|
|
|
|
|
|
|
elsif (!defined wantarray) { |
3294
|
|
|
|
|
|
|
$self->{unames}= []; |
3295
|
|
|
|
|
|
|
} |
3296
|
|
|
|
|
|
|
|
3297
|
|
|
|
|
|
|
#elsif ( eval { require PadWalker; 1 } ) { |
3298
|
|
|
|
|
|
|
# print DDumper(PadWalker::peek_my(1)); |
3299
|
|
|
|
|
|
|
# return $self; |
3300
|
5
|
50
|
|
|
|
25
|
#} |
|
1
|
100
|
|
|
|
10
|
|
3301
|
|
|
|
|
|
|
|
3302
|
|
|
|
|
|
|
return wantarray ? @{ $self->{unames} || [] } : $self->{unames}; |
3303
|
|
|
|
|
|
|
} |
3304
|
|
|
|
|
|
|
|
3305
|
|
|
|
|
|
|
=item Terse |
3306
|
|
|
|
|
|
|
|
3307
|
|
|
|
|
|
|
=item Terse BOOL |
3308
|
|
|
|
|
|
|
|
3309
|
|
|
|
|
|
|
When true, no variable names will be created. Data will be dumped as |
3310
|
|
|
|
|
|
|
anonymous references or values. |
3311
|
|
|
|
|
|
|
|
3312
|
|
|
|
|
|
|
Dump([])->Out; # $ARRAY1 = [] |
3313
|
|
|
|
|
|
|
Dump([])->Terse(1)->Out; # [] |
3314
|
|
|
|
|
|
|
|
3315
|
|
|
|
|
|
|
=cut |
3316
|
5
|
|
|
5
|
1
|
15
|
|
3317
|
5
|
50
|
|
|
|
14
|
sub Terse { |
3318
|
5
|
|
|
|
|
10
|
my $self= shift->_safe_self; |
3319
|
5
|
|
|
|
|
17
|
if (@_) { |
3320
|
|
|
|
|
|
|
$self->{style}{terse}= shift; |
3321
|
|
|
|
|
|
|
return $self; |
3322
|
0
|
|
|
|
|
0
|
} |
3323
|
|
|
|
|
|
|
else { |
3324
|
|
|
|
|
|
|
return $self->{style}{terse}; |
3325
|
|
|
|
|
|
|
} |
3326
|
|
|
|
|
|
|
} |
3327
|
|
|
|
|
|
|
|
3328
|
|
|
|
|
|
|
=for UEDIT |
3329
|
|
|
|
|
|
|
sub Purity {} |
3330
|
|
|
|
|
|
|
|
3331
|
|
|
|
|
|
|
=item Purity |
3332
|
|
|
|
|
|
|
|
3333
|
|
|
|
|
|
|
=item Purity BOOL |
3334
|
|
|
|
|
|
|
|
3335
|
|
|
|
|
|
|
This option can be used to set the level of purity in the output. It |
3336
|
|
|
|
|
|
|
defaults to TRUE, which results in the module doing its best to ensure |
3337
|
|
|
|
|
|
|
that the resulting dump when eval()ed is precisely the same as the input. |
3338
|
|
|
|
|
|
|
However, at times such as debugging this can be tedious, resulting in |
3339
|
|
|
|
|
|
|
extremely long dumps with many "fix" statements involved. By setting |
3340
|
|
|
|
|
|
|
Purity to FALSE the resulting output won't necessarily be legal Perl, but |
3341
|
|
|
|
|
|
|
it will be more legible. In this mode the output is broadly similar to |
3342
|
|
|
|
|
|
|
that of the default setting of Data::Dumper (Purity(0)). When set to TRUE |
3343
|
|
|
|
|
|
|
the behaviour is likewise similar to Data::Dumper in Purity(1) but more |
3344
|
|
|
|
|
|
|
accurate. |
3345
|
|
|
|
|
|
|
|
3346
|
|
|
|
|
|
|
When Purity() is set to FALSE aliases will be output with a function call |
3347
|
|
|
|
|
|
|
wrapper of 'alias_to' whose argument will be the value the item is an |
3348
|
|
|
|
|
|
|
alias to. This wrapper does nothing, and is only there as a visual cue. |
3349
|
|
|
|
|
|
|
Likewise, 'make_ro' will be output when the value was readonly, and again |
3350
|
|
|
|
|
|
|
the effect is cosmetic only. |
3351
|
|
|
|
|
|
|
|
3352
|
|
|
|
|
|
|
=item To |
3353
|
|
|
|
|
|
|
|
3354
|
|
|
|
|
|
|
=item To STREAMER |
3355
|
|
|
|
|
|
|
|
3356
|
|
|
|
|
|
|
Specifies the object to print to. Data::Dump::Streamer can stream its |
3357
|
|
|
|
|
|
|
output to any object supporting the print method. This is primarily meant |
3358
|
|
|
|
|
|
|
for streaming to a filehandle, however any object that supports the method |
3359
|
|
|
|
|
|
|
will do. |
3360
|
|
|
|
|
|
|
|
3361
|
|
|
|
|
|
|
If a filehandle is specified then it is used until it is explicitly |
3362
|
|
|
|
|
|
|
changed, or the object is destroyed. |
3363
|
|
|
|
|
|
|
|
3364
|
|
|
|
|
|
|
=cut |
3365
|
0
|
|
|
0
|
1
|
0
|
|
3366
|
0
|
0
|
|
|
|
0
|
sub To { |
3367
|
0
|
|
|
|
|
0
|
my $self= shift->_safe_self; |
3368
|
0
|
|
|
|
|
0
|
if (@_) { |
3369
|
|
|
|
|
|
|
$self->{fh}= shift; |
3370
|
0
|
|
|
|
|
0
|
return $self; |
3371
|
|
|
|
|
|
|
} |
3372
|
|
|
|
|
|
|
return $self->{fh}; |
3373
|
|
|
|
|
|
|
} |
3374
|
|
|
|
|
|
|
|
3375
|
|
|
|
|
|
|
=for UEDIT |
3376
|
|
|
|
|
|
|
sub Declare {} |
3377
|
|
|
|
|
|
|
|
3378
|
|
|
|
|
|
|
=item Declare |
3379
|
|
|
|
|
|
|
|
3380
|
|
|
|
|
|
|
=item Declare BOOL |
3381
|
|
|
|
|
|
|
|
3382
|
|
|
|
|
|
|
If Declare is True then each object is dumped with 'my' declarations |
3383
|
|
|
|
|
|
|
included, and all rules that follow are obeyed. (Ie, not referencing an |
3384
|
|
|
|
|
|
|
undeclared variable). If Declare is False then all objects are expected to |
3385
|
|
|
|
|
|
|
be previously defined and references to top level objects can be made at |
3386
|
|
|
|
|
|
|
any time. |
3387
|
|
|
|
|
|
|
|
3388
|
|
|
|
|
|
|
Defaults to False. |
3389
|
|
|
|
|
|
|
|
3390
|
|
|
|
|
|
|
=cut |
3391
|
8
|
|
|
8
|
1
|
425
|
|
3392
|
8
|
50
|
|
|
|
23
|
sub Indent { |
3393
|
8
|
|
|
|
|
13
|
my $self= shift->_safe_self(); |
3394
|
|
|
|
|
|
|
if (@_) { |
3395
|
8
|
100
|
66
|
|
|
52
|
my $val= shift; |
|
|
100
|
66
|
|
|
|
|
3396
|
3
|
|
|
|
|
8
|
|
3397
|
3
|
|
|
|
|
8
|
if ($val == 0 && length $self->{style}{optspace}) { |
3398
|
|
|
|
|
|
|
$self->{style}{last_optspace}= $self->{style}{optspace}; |
3399
|
|
|
|
|
|
|
$self->{style}{optspace}= ""; |
3400
|
2
|
|
|
|
|
5
|
} |
3401
|
|
|
|
|
|
|
elsif (!$self->{style}{indent} && !length $self->{style}{optspace}) { |
3402
|
8
|
|
|
|
|
13
|
$self->{style}{optspace}= $self->{style}{last_optspace}; |
3403
|
8
|
|
|
|
|
159
|
} |
3404
|
|
|
|
|
|
|
$self->{style}{indent}= $val; |
3405
|
|
|
|
|
|
|
return $self; |
3406
|
0
|
|
|
|
|
0
|
} |
3407
|
|
|
|
|
|
|
else { |
3408
|
|
|
|
|
|
|
return $self->{style}{indent}; |
3409
|
|
|
|
|
|
|
} |
3410
|
|
|
|
|
|
|
} |
3411
|
|
|
|
|
|
|
|
3412
|
|
|
|
|
|
|
=item Indent |
3413
|
|
|
|
|
|
|
|
3414
|
|
|
|
|
|
|
=item Indent INT |
3415
|
|
|
|
|
|
|
|
3416
|
|
|
|
|
|
|
If Indent is True then data is output in an indented and fairly neat |
3417
|
|
|
|
|
|
|
fashion. If the value is 2 then hash key/value pairs and array values each |
3418
|
|
|
|
|
|
|
on their own line. If the value is 1 then a "smart" indenting mode is |
3419
|
|
|
|
|
|
|
activated where multiple key/value or values may be printed to the same |
3420
|
|
|
|
|
|
|
line. The heuristics for this mode are still experimental so it may |
3421
|
|
|
|
|
|
|
occasional not indent very nicely. |
3422
|
|
|
|
|
|
|
|
3423
|
|
|
|
|
|
|
Default is Indent(2) |
3424
|
|
|
|
|
|
|
|
3425
|
|
|
|
|
|
|
If indent is False then no indentation is done, and all optional whitespace. |
3426
|
|
|
|
|
|
|
is omitted. See for more details. |
3427
|
|
|
|
|
|
|
|
3428
|
|
|
|
|
|
|
Defaults to True. |
3429
|
|
|
|
|
|
|
|
3430
|
|
|
|
|
|
|
Newlines are appended to each statement regardless of this value. |
3431
|
|
|
|
|
|
|
|
3432
|
|
|
|
|
|
|
=for UEDIT |
3433
|
|
|
|
|
|
|
sub IndentKeys {} |
3434
|
|
|
|
|
|
|
|
3435
|
|
|
|
|
|
|
=item Indentkeys |
3436
|
|
|
|
|
|
|
|
3437
|
|
|
|
|
|
|
=item Indentkeys BOOL |
3438
|
|
|
|
|
|
|
|
3439
|
|
|
|
|
|
|
If Indent() and Indentkeys are True then hashes with more than one key |
3440
|
|
|
|
|
|
|
value pair are dumped such that the keys and values line up. Note however |
3441
|
|
|
|
|
|
|
this means each key has to be quoted twice. Not advised for very large |
3442
|
|
|
|
|
|
|
data structures. Additional logic may enhance this feature soon. |
3443
|
|
|
|
|
|
|
|
3444
|
|
|
|
|
|
|
Defaults to True. |
3445
|
|
|
|
|
|
|
|
3446
|
|
|
|
|
|
|
B |
3447
|
|
|
|
|
|
|
Must be set before C is called. |
3448
|
|
|
|
|
|
|
|
3449
|
|
|
|
|
|
|
=for UEDIT |
3450
|
|
|
|
|
|
|
sub OptSpace {} |
3451
|
|
|
|
|
|
|
|
3452
|
|
|
|
|
|
|
=item OptSpace |
3453
|
|
|
|
|
|
|
|
3454
|
|
|
|
|
|
|
=item OptSpace STR |
3455
|
|
|
|
|
|
|
|
3456
|
|
|
|
|
|
|
Normally DDS emits a lot of whitespace in between tokens that it |
3457
|
|
|
|
|
|
|
emits. Using this method you can control how much whitespace it |
3458
|
|
|
|
|
|
|
will emit, or even if some other string should be used. |
3459
|
|
|
|
|
|
|
|
3460
|
|
|
|
|
|
|
If Indent is set to 0 then this value is automatically set to |
3461
|
|
|
|
|
|
|
the empty string. When Indent is set back to a non zero value |
3462
|
|
|
|
|
|
|
the old value will be restored if it has not been changed from |
3463
|
|
|
|
|
|
|
the empty string in the intervening time. |
3464
|
|
|
|
|
|
|
|
3465
|
|
|
|
|
|
|
=for UEDIT |
3466
|
|
|
|
|
|
|
sub Keyorder {} |
3467
|
|
|
|
|
|
|
|
3468
|
|
|
|
|
|
|
=item KeyOrder TYPE_OR_OBJ |
3469
|
|
|
|
|
|
|
|
3470
|
|
|
|
|
|
|
=item KeyOrder TYPE_OR_OBJ, VALUE |
3471
|
|
|
|
|
|
|
|
3472
|
|
|
|
|
|
|
Sets or returns the key order to for use for a given type or object. |
3473
|
|
|
|
|
|
|
|
3474
|
|
|
|
|
|
|
TYPE_OR_OBJ may be a string representing a class, or "" for representing |
3475
|
|
|
|
|
|
|
unblessed objects, or it maybe a reference to a hash. |
3476
|
|
|
|
|
|
|
|
3477
|
|
|
|
|
|
|
VALUE may be a string representing one of built in sort mechanisms, or |
3478
|
|
|
|
|
|
|
it may be a reference to a subroutine, or a method name if TYPE_OR_OBJ |
3479
|
|
|
|
|
|
|
is not an object. |
3480
|
|
|
|
|
|
|
|
3481
|
|
|
|
|
|
|
The built in sort mechanisms are 'aphabetical'/'lexical', 'numeric', |
3482
|
|
|
|
|
|
|
'smart'/'intelligent' and 'each'. |
3483
|
|
|
|
|
|
|
|
3484
|
|
|
|
|
|
|
If VALUE is omitted returns the current value for the given type. |
3485
|
|
|
|
|
|
|
|
3486
|
|
|
|
|
|
|
If TYPE_OR_OBJ is omitted or FALSE it defaults to "" which represents |
3487
|
|
|
|
|
|
|
unblessed hashes. |
3488
|
|
|
|
|
|
|
|
3489
|
|
|
|
|
|
|
See L<"Controlling Hash Traversal and Display Order"> for more details. |
3490
|
|
|
|
|
|
|
|
3491
|
|
|
|
|
|
|
=item SortKeys |
3492
|
|
|
|
|
|
|
|
3493
|
|
|
|
|
|
|
=item SortKeys VALUE |
3494
|
|
|
|
|
|
|
|
3495
|
|
|
|
|
|
|
This is a wrapper for KeyOrder. It allows only the generic hash |
3496
|
|
|
|
|
|
|
sort order to be specified a little more elegantly than via KeyOrder(). |
3497
|
|
|
|
|
|
|
It is syntactically equivalent to |
3498
|
|
|
|
|
|
|
|
3499
|
|
|
|
|
|
|
$self->KeyOrder( "", @_ ); |
3500
|
|
|
|
|
|
|
|
3501
|
|
|
|
|
|
|
=for UEDIT |
3502
|
|
|
|
|
|
|
sub Verbose {} |
3503
|
|
|
|
|
|
|
|
3504
|
|
|
|
|
|
|
=item Verbose |
3505
|
|
|
|
|
|
|
|
3506
|
|
|
|
|
|
|
=item Verbose BOOL |
3507
|
|
|
|
|
|
|
|
3508
|
|
|
|
|
|
|
If Verbose is True then when references that cannot be resolved in a |
3509
|
|
|
|
|
|
|
single statement are encountered the reference is substituted for a |
3510
|
|
|
|
|
|
|
descriptive tag saying what type of forward reference it is, and to what |
3511
|
|
|
|
|
|
|
is being referenced. The type is provided through a prefix, "R:" for |
3512
|
|
|
|
|
|
|
reference, and "A:" for alias, "V:" for a value and then the name of the |
3513
|
|
|
|
|
|
|
var in a string. Automatically generated var names are also reduced to |
3514
|
|
|
|
|
|
|
the shortest possible unique abbreviation, with some tricks thrown in |
3515
|
|
|
|
|
|
|
for Long::Class::Names::Like::This (which would abbreviate most likely |
3516
|
|
|
|
|
|
|
to LCNLT1) |
3517
|
|
|
|
|
|
|
|
3518
|
|
|
|
|
|
|
If Verbose if False then a simple placeholder saying 'A' or 'R' is |
3519
|
|
|
|
|
|
|
provided. (In most situations perl requires a placeholder, and as such |
3520
|
|
|
|
|
|
|
one is always provided, even if technically it could be omitted.) |
3521
|
|
|
|
|
|
|
|
3522
|
|
|
|
|
|
|
This setting does not change the followup statements that fix up the |
3523
|
|
|
|
|
|
|
structure, and does not result in a loss of accuracy, it just makes it a |
3524
|
|
|
|
|
|
|
little harder to read. OTOH, it means dumps can be quite a bit smaller |
3525
|
|
|
|
|
|
|
and less noisy. |
3526
|
|
|
|
|
|
|
|
3527
|
|
|
|
|
|
|
Defaults to True. |
3528
|
|
|
|
|
|
|
|
3529
|
|
|
|
|
|
|
B |
3530
|
|
|
|
|
|
|
Must be set before C is called. |
3531
|
|
|
|
|
|
|
|
3532
|
|
|
|
|
|
|
=for UEDIT |
3533
|
|
|
|
|
|
|
sub DumpGlob {} |
3534
|
|
|
|
|
|
|
|
3535
|
|
|
|
|
|
|
=item DumpGlob |
3536
|
|
|
|
|
|
|
|
3537
|
|
|
|
|
|
|
=item DumpGlob BOOL |
3538
|
|
|
|
|
|
|
|
3539
|
|
|
|
|
|
|
If True then globs will be followed and fully defined, otherwise the globs |
3540
|
|
|
|
|
|
|
will still be referenced but their current value will not be set. |
3541
|
|
|
|
|
|
|
|
3542
|
|
|
|
|
|
|
Defaults to True |
3543
|
|
|
|
|
|
|
|
3544
|
|
|
|
|
|
|
B |
3545
|
|
|
|
|
|
|
Must be set before C is called. |
3546
|
|
|
|
|
|
|
|
3547
|
|
|
|
|
|
|
=for UEDIT |
3548
|
|
|
|
|
|
|
sub Deparse {} |
3549
|
|
|
|
|
|
|
|
3550
|
|
|
|
|
|
|
=item Deparse |
3551
|
|
|
|
|
|
|
|
3552
|
|
|
|
|
|
|
=item Deparse BOOL |
3553
|
|
|
|
|
|
|
|
3554
|
|
|
|
|
|
|
If True then CODE refs will be deparsed use L and |
3555
|
|
|
|
|
|
|
included in the dump. If it is False the a stub subroutine reference will |
3556
|
|
|
|
|
|
|
be output as per the setting of C. |
3557
|
|
|
|
|
|
|
|
3558
|
|
|
|
|
|
|
Caveat Emptor, dumping subroutine references is hardly a secure act, and |
3559
|
|
|
|
|
|
|
it is provided here only for convenience. |
3560
|
|
|
|
|
|
|
|
3561
|
|
|
|
|
|
|
Note using this routine is at your own risk as of DDS 1.11, how it |
3562
|
|
|
|
|
|
|
interacts with the newer advanced closure dumping process is undefined. |
3563
|
|
|
|
|
|
|
|
3564
|
|
|
|
|
|
|
=for UEDIT |
3565
|
|
|
|
|
|
|
sub EclipseName {} |
3566
|
|
|
|
|
|
|
|
3567
|
|
|
|
|
|
|
=item EclipseName |
3568
|
|
|
|
|
|
|
|
3569
|
|
|
|
|
|
|
=item EclipseName SPRINTF_FORMAT |
3570
|
|
|
|
|
|
|
|
3571
|
|
|
|
|
|
|
When necessary DDS will rename vars output during deparsing with this |
3572
|
|
|
|
|
|
|
value. It is a sprintf format string that should contain only and both of |
3573
|
|
|
|
|
|
|
the "%s" and a "%d" formats in any order along with whatever other literal |
3574
|
|
|
|
|
|
|
text you want in the name. No checks are performed on the validity of this |
3575
|
|
|
|
|
|
|
value so be careful. It defaults to |
3576
|
|
|
|
|
|
|
|
3577
|
|
|
|
|
|
|
"%s_eclipse_%d" |
3578
|
|
|
|
|
|
|
|
3579
|
|
|
|
|
|
|
where the "%s" represents the name of the var being eclipsed, and the "%d" |
3580
|
|
|
|
|
|
|
a counter to ensure all such mappings are unique. |
3581
|
|
|
|
|
|
|
|
3582
|
|
|
|
|
|
|
=for UEDIT |
3583
|
|
|
|
|
|
|
sub DeparseOpts {} |
3584
|
|
|
|
|
|
|
|
3585
|
|
|
|
|
|
|
=item DeparseOpts |
3586
|
|
|
|
|
|
|
|
3587
|
|
|
|
|
|
|
=item DeparseOpts LIST |
3588
|
|
|
|
|
|
|
|
3589
|
|
|
|
|
|
|
=item DeparseOpts ARRAY |
3590
|
|
|
|
|
|
|
|
3591
|
|
|
|
|
|
|
If Deparse is True then these options will be passed to B::Deparse->new() |
3592
|
|
|
|
|
|
|
when dumping a CODE ref. If passed a list of scalars the list is used as |
3593
|
|
|
|
|
|
|
the arguments. If passed an array reference then this array is assumed to |
3594
|
|
|
|
|
|
|
contain a list of arguments. If no arguments are provided returns a an |
3595
|
|
|
|
|
|
|
array ref of arguments in scalar context, and a list of arguments in list |
3596
|
|
|
|
|
|
|
context. |
3597
|
|
|
|
|
|
|
|
3598
|
|
|
|
|
|
|
Note using this routine is at your own risk as of DDS 1.11, how it |
3599
|
|
|
|
|
|
|
interacts with the newer advanced closure dumping process is undefined. |
3600
|
|
|
|
|
|
|
|
3601
|
|
|
|
|
|
|
=for UEDIT |
3602
|
|
|
|
|
|
|
sub CodeStub {} |
3603
|
|
|
|
|
|
|
|
3604
|
|
|
|
|
|
|
=item CodeStub |
3605
|
|
|
|
|
|
|
|
3606
|
|
|
|
|
|
|
=item CodeStub STRING |
3607
|
|
|
|
|
|
|
|
3608
|
|
|
|
|
|
|
If Deparse is False then this string will be used in place of CODE |
3609
|
|
|
|
|
|
|
references. Its the users responsibility to make sure its compilable and |
3610
|
|
|
|
|
|
|
blessable. |
3611
|
|
|
|
|
|
|
|
3612
|
|
|
|
|
|
|
Defaults to 'sub { Carp::confess "Dumped code stub!" }' |
3613
|
|
|
|
|
|
|
|
3614
|
|
|
|
|
|
|
=for UEDIT |
3615
|
|
|
|
|
|
|
sub FormatStub {} |
3616
|
|
|
|
|
|
|
|
3617
|
|
|
|
|
|
|
=item FormatStub |
3618
|
|
|
|
|
|
|
|
3619
|
|
|
|
|
|
|
=item FormatStub STRING |
3620
|
|
|
|
|
|
|
|
3621
|
|
|
|
|
|
|
If Deparse is False then this string will be used in place of FORMAT |
3622
|
|
|
|
|
|
|
references. Its the users responsibility to make sure its compilable and |
3623
|
|
|
|
|
|
|
blessable. |
3624
|
|
|
|
|
|
|
|
3625
|
|
|
|
|
|
|
Defaults to 'do{ local *F; eval "format F =\nFormat Stub\n.\n"; *F{FORMAT} }' |
3626
|
|
|
|
|
|
|
|
3627
|
|
|
|
|
|
|
=for UEDIT |
3628
|
|
|
|
|
|
|
sub DeparseGlob {} |
3629
|
|
|
|
|
|
|
|
3630
|
|
|
|
|
|
|
=item DeparseGlob |
3631
|
|
|
|
|
|
|
|
3632
|
|
|
|
|
|
|
=item DeparseGlob BOOL |
3633
|
|
|
|
|
|
|
|
3634
|
|
|
|
|
|
|
If Deparse is TRUE then this style attribute will determine if subroutines |
3635
|
|
|
|
|
|
|
and FORMAT's contained in globs that are dumped will be deparsed or not. |
3636
|
|
|
|
|
|
|
|
3637
|
|
|
|
|
|
|
Defaults to True. |
3638
|
|
|
|
|
|
|
|
3639
|
|
|
|
|
|
|
=for UEDIT |
3640
|
|
|
|
|
|
|
sub DualVars {} |
3641
|
|
|
|
|
|
|
sub Dualvars {} |
3642
|
|
|
|
|
|
|
|
3643
|
|
|
|
|
|
|
=item Dualvars |
3644
|
|
|
|
|
|
|
|
3645
|
|
|
|
|
|
|
=item Dualvars BOOL |
3646
|
|
|
|
|
|
|
|
3647
|
|
|
|
|
|
|
=item Dualvars |
3648
|
|
|
|
|
|
|
|
3649
|
|
|
|
|
|
|
=item Dualvars BOOL |
3650
|
|
|
|
|
|
|
|
3651
|
|
|
|
|
|
|
If TRUE then dualvar checking will occur and the required statements |
3652
|
|
|
|
|
|
|
emitted to recreate dualvars when they are encountered, otherwise items |
3653
|
|
|
|
|
|
|
will be dumped in their stringified form always. It defaults to TRUE. |
3654
|
|
|
|
|
|
|
|
3655
|
|
|
|
|
|
|
=for UEDIT |
3656
|
|
|
|
|
|
|
sub Rle {} |
3657
|
|
|
|
|
|
|
sub RLE {} |
3658
|
|
|
|
|
|
|
|
3659
|
|
|
|
|
|
|
=item Rle |
3660
|
|
|
|
|
|
|
|
3661
|
|
|
|
|
|
|
=item Rle BOOL |
3662
|
|
|
|
|
|
|
|
3663
|
|
|
|
|
|
|
=item RLE |
3664
|
|
|
|
|
|
|
|
3665
|
|
|
|
|
|
|
=item RLE BOOL |
3666
|
|
|
|
|
|
|
|
3667
|
|
|
|
|
|
|
If True then arrays will be run length encoded using the C operator. |
3668
|
|
|
|
|
|
|
What this means is that if an array contains repeated elements then |
3669
|
|
|
|
|
|
|
instead of outputting each and every one a list multiplier will be output. |
3670
|
|
|
|
|
|
|
This means that considerably less space is taken to dump redundant data. |
3671
|
|
|
|
|
|
|
|
3672
|
|
|
|
|
|
|
=item Freezer |
3673
|
|
|
|
|
|
|
|
3674
|
|
|
|
|
|
|
=item Freezer ACTION |
3675
|
|
|
|
|
|
|
|
3676
|
|
|
|
|
|
|
=item Freezer CLASS, ACTION |
3677
|
|
|
|
|
|
|
|
3678
|
|
|
|
|
|
|
This method can be used to override the DDS_freeze hook for a |
3679
|
|
|
|
|
|
|
specific class. If CLASS is omitted then the ACTION applies to |
3680
|
|
|
|
|
|
|
all blessed object. |
3681
|
|
|
|
|
|
|
|
3682
|
|
|
|
|
|
|
If ACTION is false it indicates that the given CLASS should not |
3683
|
|
|
|
|
|
|
have any serilization hooks called. |
3684
|
|
|
|
|
|
|
|
3685
|
|
|
|
|
|
|
If ACTION is a string then it is taken to be the method name that |
3686
|
|
|
|
|
|
|
will be executed to freeze the object. CLASS->can(METHOD) must return |
3687
|
|
|
|
|
|
|
true or the setting will be ignored. |
3688
|
|
|
|
|
|
|
|
3689
|
|
|
|
|
|
|
If ACTION is a code ref it is executed with the object as the argument. |
3690
|
|
|
|
|
|
|
|
3691
|
|
|
|
|
|
|
When called with no arguments returns in scalar context the generic |
3692
|
|
|
|
|
|
|
serialization method (defaults to 'DDS_freeze'), in list context |
3693
|
|
|
|
|
|
|
returns the generic serialization method followed by a list of pairs |
3694
|
|
|
|
|
|
|
of Classname=>ACTION. |
3695
|
|
|
|
|
|
|
|
3696
|
|
|
|
|
|
|
If the action executes a sub or method it is expected to return |
3697
|
|
|
|
|
|
|
a list of three values: |
3698
|
|
|
|
|
|
|
|
3699
|
|
|
|
|
|
|
( $proxy, $thaw, $postdump )=$obj->DDS_Freeze(); |
3700
|
|
|
|
|
|
|
|
3701
|
|
|
|
|
|
|
See L for more details. |
3702
|
|
|
|
|
|
|
|
3703
|
|
|
|
|
|
|
B |
3704
|
|
|
|
|
|
|
Must be set before C is called. |
3705
|
|
|
|
|
|
|
|
3706
|
|
|
|
|
|
|
=cut |
3707
|
2
|
|
|
2
|
1
|
969
|
|
3708
|
2
|
50
|
|
|
|
7
|
sub Freezer { |
|
|
0
|
|
|
|
|
|
3709
|
2
|
|
|
|
|
6
|
my $self= shift; |
3710
|
2
|
|
|
|
|
9
|
if (@_ == 1) { |
3711
|
|
|
|
|
|
|
$self->{style}{freezer}= shift; |
3712
|
|
|
|
|
|
|
return $self; |
3713
|
0
|
|
|
|
|
0
|
} |
3714
|
0
|
|
|
|
|
0
|
elsif (@_ == 2) { |
3715
|
0
|
|
|
|
|
0
|
my ($class, $action)= @_; |
3716
|
|
|
|
|
|
|
$self->{style}{freeze_class}{$class}= $action; |
3717
|
|
|
|
|
|
|
return $self; |
3718
|
|
|
|
|
|
|
} |
3719
|
|
|
|
|
|
|
return wantarray |
3720
|
0
|
|
|
|
|
0
|
? ( |
3721
|
0
|
|
|
|
|
0
|
$self->{style}{freezer}, |
3722
|
0
|
0
|
|
|
|
0
|
map { $_ => $self->{style}{freeze_class}{$_} } |
3723
|
|
|
|
|
|
|
keys %{ $self->{style}{freeze_class} }) |
3724
|
|
|
|
|
|
|
: $self->{style}{freezer}; |
3725
|
|
|
|
|
|
|
} |
3726
|
1
|
|
|
1
|
0
|
490
|
|
3727
|
1
|
|
|
|
|
6
|
sub ResetFreezer { |
3728
|
1
|
|
|
|
|
3
|
my $self= shift; |
3729
|
1
|
|
|
|
|
8
|
$self->{style}{freezer}= 'DDS_freeze'; |
3730
|
|
|
|
|
|
|
$self->{style}{freeze_class}= {}; |
3731
|
|
|
|
|
|
|
return $self; |
3732
|
|
|
|
|
|
|
} |
3733
|
|
|
|
|
|
|
|
3734
|
|
|
|
|
|
|
=item Ignore |
3735
|
|
|
|
|
|
|
|
3736
|
|
|
|
|
|
|
=item Ignore OBJ_OR_CLASS |
3737
|
|
|
|
|
|
|
|
3738
|
|
|
|
|
|
|
=item Ignore OBJ_OR_CLASS, BOOL |
3739
|
|
|
|
|
|
|
|
3740
|
|
|
|
|
|
|
Allows a given object or class to be ignored, and replaced with |
3741
|
|
|
|
|
|
|
a string containing the name of the item ignored. |
3742
|
|
|
|
|
|
|
|
3743
|
|
|
|
|
|
|
If called with no args returns a list of items ignored (using the refaddr |
3744
|
|
|
|
|
|
|
to represent objects). If called with a single argument returns whether |
3745
|
|
|
|
|
|
|
that argument is ignored. If called with more than one arguments then |
3746
|
|
|
|
|
|
|
expects a list of pairs of object => is_ignored. |
3747
|
|
|
|
|
|
|
|
3748
|
|
|
|
|
|
|
Returns $self when setting. |
3749
|
|
|
|
|
|
|
|
3750
|
|
|
|
|
|
|
B |
3751
|
|
|
|
|
|
|
Must be set before C is called. |
3752
|
|
|
|
|
|
|
|
3753
|
|
|
|
|
|
|
=cut |
3754
|
2
|
|
|
2
|
1
|
925
|
|
3755
|
2
|
50
|
|
|
|
10
|
sub Ignore { |
3756
|
0
|
|
|
|
|
0
|
my $self= shift; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
3757
|
|
|
|
|
|
|
if (@_ == 0) { |
3758
|
2
|
50
|
33
|
|
|
16
|
return map { s/^.//; $_ } keys %{ $self->{style}{ignore} }; |
3759
|
|
|
|
|
|
|
} |
3760
|
2
|
|
|
|
|
7
|
Carp::confess("Must have an even number of arguments in Ignore()") |
3761
|
2
|
|
|
|
|
10
|
if @_ > 1 && @_ % 2; |
3762
|
2
|
50
|
|
|
|
10
|
while (@_) { |
3763
|
0
|
|
|
|
|
0
|
my $item= shift; |
3764
|
|
|
|
|
|
|
if (ref $item) { |
3765
|
|
|
|
|
|
|
$item= "#" . refaddr($item); |
3766
|
2
|
|
|
|
|
9
|
} |
3767
|
|
|
|
|
|
|
else { |
3768
|
2
|
50
|
|
|
|
6
|
$item= ".$item"; |
3769
|
0
|
|
|
|
|
0
|
} |
3770
|
|
|
|
|
|
|
if (!@_) { |
3771
|
2
|
100
|
|
|
|
5
|
return $self->{style}{ignore}{$item}; |
3772
|
1
|
|
|
|
|
9
|
} |
3773
|
|
|
|
|
|
|
if (shift) { |
3774
|
|
|
|
|
|
|
$self->{style}{ignore}{$item}= 1; |
3775
|
1
|
|
|
|
|
4
|
} |
3776
|
|
|
|
|
|
|
else { |
3777
|
|
|
|
|
|
|
delete $self->{style}{ignore}{$item}; |
3778
|
2
|
|
|
|
|
18
|
} |
3779
|
|
|
|
|
|
|
} |
3780
|
|
|
|
|
|
|
return $self; |
3781
|
|
|
|
|
|
|
} |
3782
|
|
|
|
|
|
|
|
3783
|
|
|
|
|
|
|
=for UEDIT |
3784
|
|
|
|
|
|
|
sub Compress {} |
3785
|
|
|
|
|
|
|
|
3786
|
|
|
|
|
|
|
=item Compress |
3787
|
|
|
|
|
|
|
|
3788
|
|
|
|
|
|
|
=item Compress SIZE |
3789
|
|
|
|
|
|
|
|
3790
|
|
|
|
|
|
|
Controls compression of string values (not keys). If this value |
3791
|
|
|
|
|
|
|
is nonzero and a string to be dumped is longer than its value then |
3792
|
|
|
|
|
|
|
the L if defined is used to compress |
3793
|
|
|
|
|
|
|
the string. Setting size to -1 will cause all strings to be |
3794
|
|
|
|
|
|
|
processed, setting size to 0 will cause no strings to be processed. |
3795
|
|
|
|
|
|
|
|
3796
|
|
|
|
|
|
|
=for UEDIT |
3797
|
|
|
|
|
|
|
sub Compressor {} |
3798
|
|
|
|
|
|
|
|
3799
|
|
|
|
|
|
|
=item Compressor |
3800
|
|
|
|
|
|
|
|
3801
|
|
|
|
|
|
|
=item Compressor CODE |
3802
|
|
|
|
|
|
|
|
3803
|
|
|
|
|
|
|
This attribute is used to control the compression of strings. |
3804
|
|
|
|
|
|
|
It is expected to be a reference to a subroutine with the following |
3805
|
|
|
|
|
|
|
interface: |
3806
|
|
|
|
|
|
|
|
3807
|
|
|
|
|
|
|
my $prelude_code=$compressor->(); # no arguments. |
3808
|
|
|
|
|
|
|
my $code=$compressor->('string'); # string argument |
3809
|
|
|
|
|
|
|
|
3810
|
|
|
|
|
|
|
The sub will be called with no arguments at the beginning of the |
3811
|
|
|
|
|
|
|
dump to allow any require statements or similar to be added. During |
3812
|
|
|
|
|
|
|
the dump the sub will be called with a single argument when |
3813
|
|
|
|
|
|
|
compression is required. The code returned in this case is expected |
3814
|
|
|
|
|
|
|
to be an EXPR that will evaluate back to the original string. |
3815
|
|
|
|
|
|
|
|
3816
|
|
|
|
|
|
|
By default DDS will use L in conjunction with |
3817
|
|
|
|
|
|
|
L to do compression and encoding, and exposes the |
3818
|
|
|
|
|
|
|
'usqz' subroutine for handling the decoding and decompression. |
3819
|
|
|
|
|
|
|
|
3820
|
|
|
|
|
|
|
The abbreviated name was chosen as when using the default compressor |
3821
|
|
|
|
|
|
|
every string will be represented by a string like |
3822
|
|
|
|
|
|
|
|
3823
|
|
|
|
|
|
|
usqz('....') |
3824
|
|
|
|
|
|
|
|
3825
|
|
|
|
|
|
|
Meaning that eight characters are required without considering the |
3826
|
|
|
|
|
|
|
data itself. Likewise Base64 was chosen because it is a representation |
3827
|
|
|
|
|
|
|
that is high-bit safe, compact and easy to quote. Escaped strings are |
3828
|
|
|
|
|
|
|
much less efficient for storing binary data. |
3829
|
|
|
|
|
|
|
|
3830
|
|
|
|
|
|
|
=cut |
3831
|
|
|
|
|
|
|
|
3832
|
0
|
|
|
0
|
1
|
0
|
# weird styling here deliberate. |
3833
|
0
|
0
|
|
|
|
0
|
sub DeparseOpts { |
3834
|
0
|
0
|
|
|
|
0
|
my $self= shift; |
3835
|
0
|
|
|
|
|
0
|
if (@_) { |
3836
|
|
|
|
|
|
|
if (ref $_[0]) { |
3837
|
|
|
|
|
|
|
$self->{style}{deparseopts}= shift; |
3838
|
0
|
|
|
|
|
0
|
} |
3839
|
|
|
|
|
|
|
else { |
3840
|
0
|
|
|
|
|
0
|
$self->{style}{deparseopts}= [@_]; |
3841
|
|
|
|
|
|
|
} |
3842
|
|
|
|
|
|
|
return $self; |
3843
|
|
|
|
|
|
|
} |
3844
|
0
|
|
|
|
|
0
|
else { |
3845
|
0
|
0
|
|
|
|
0
|
return wantarray |
3846
|
|
|
|
|
|
|
? @{ $self->{style}{deparseopts} } |
3847
|
|
|
|
|
|
|
: $self->{style}{deparseopts}; |
3848
|
|
|
|
|
|
|
} |
3849
|
|
|
|
|
|
|
} |
3850
|
9
|
|
|
9
|
1
|
49
|
|
3851
|
9
|
50
|
66
|
|
|
36
|
sub KeyOrder { |
3852
|
|
|
|
|
|
|
my $self= shift; |
3853
|
|
|
|
|
|
|
Carp::croak( |
3854
|
|
|
|
|
|
|
"KeyOrder() Must have an even number of arguments if doing a multiple set." |
3855
|
9
|
|
|
|
|
24
|
) if @_ > 2 and @_ % 2; |
3856
|
9
|
|
|
|
|
16
|
|
3857
|
9
|
|
|
|
|
14
|
while (@_) { |
3858
|
9
|
100
|
|
|
|
21
|
my $obj= shift; |
3859
|
2
|
|
|
|
|
8
|
my $name; |
3860
|
|
|
|
|
|
|
if (ref $obj) { |
3861
|
|
|
|
|
|
|
$name= "#" . refaddr($obj); |
3862
|
7
|
50
|
|
|
|
16
|
} |
3863
|
7
|
|
|
|
|
13
|
else { |
3864
|
|
|
|
|
|
|
$name= "" if !defined $obj; |
3865
|
9
|
50
|
|
|
|
22
|
$name= ".$obj"; |
3866
|
|
|
|
|
|
|
} |
3867
|
0
|
|
0
|
|
|
0
|
if (!@_) { |
3868
|
|
|
|
|
|
|
return $self->{style}{sortkeys_string}{$name} |
3869
|
9
|
|
|
|
|
14
|
|| $self->{style}{sortkeys}{$name}; |
3870
|
9
|
50
|
|
|
|
20
|
} |
3871
|
0
|
|
|
|
|
0
|
my $val= shift; |
3872
|
0
|
|
|
|
|
0
|
if (!defined $val) { |
3873
|
|
|
|
|
|
|
delete $self->{style}{sortkeys}{$name}; |
3874
|
|
|
|
|
|
|
delete $self->{style}{sortkeys_string}{$name}; |
3875
|
9
|
100
|
|
|
|
54
|
} |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
3876
|
5
|
|
|
|
|
19
|
else { |
3877
|
5
|
50
|
33
|
|
|
45
|
if (!ref $val) { |
|
|
|
33
|
|
|
|
|
3878
|
|
|
|
|
|
|
my $subref= $default_key_sorters{$val}; |
3879
|
|
|
|
|
|
|
Carp::confess( |
3880
|
|
|
|
|
|
|
"Unblessed or per object Sortkeys() must be coderefs:'$val'\n" |
3881
|
|
|
|
|
|
|
) |
3882
|
5
|
|
33
|
|
|
14
|
if (!$subref or $name eq ".") |
3883
|
5
|
50
|
0
|
|
|
11
|
and reftype($subref) ne "CODE"; |
3884
|
|
|
|
|
|
|
$subref ||= $obj->can($val); |
3885
|
|
|
|
|
|
|
die "Unknown sortkeys '$val', and " |
3886
|
|
|
|
|
|
|
. (ref($obj) || $obj) |
3887
|
5
|
|
|
|
|
16
|
. " doesn't know how to do it.\n" |
3888
|
5
|
|
|
|
|
8
|
if !$subref; |
3889
|
|
|
|
|
|
|
$self->{style}{sortkeys_string}{$name}= $val; |
3890
|
|
|
|
|
|
|
$val= $subref; |
3891
|
2
|
|
|
|
|
5
|
} |
3892
|
2
|
|
|
8
|
|
11
|
elsif (reftype($val) eq 'ARRAY') { |
|
8
|
|
|
|
|
17
|
|
3893
|
|
|
|
|
|
|
my $aryref= $val; |
3894
|
|
|
|
|
|
|
$val= sub { return $aryref; }; |
3895
|
0
|
|
|
|
|
0
|
} |
3896
|
|
|
|
|
|
|
elsif (reftype($val) ne 'CODE') { |
3897
|
9
|
|
|
|
|
33
|
Carp::confess("Can't use '$val' as KeyOrder() value"); |
3898
|
|
|
|
|
|
|
} |
3899
|
|
|
|
|
|
|
$self->{style}{sortkeys}{$name}= $val; |
3900
|
9
|
|
|
|
|
44
|
} |
3901
|
|
|
|
|
|
|
} |
3902
|
|
|
|
|
|
|
return $self; |
3903
|
|
|
|
|
|
|
} |
3904
|
|
|
|
|
|
|
*Keyorder= *KeyOrder; |
3905
|
6
|
|
|
6
|
1
|
702
|
|
3906
|
6
|
|
|
|
|
34
|
sub SortKeys { |
3907
|
|
|
|
|
|
|
my $self= shift; |
3908
|
|
|
|
|
|
|
$self->KeyOrder("", @_); |
3909
|
|
|
|
|
|
|
} |
3910
|
|
|
|
|
|
|
*Sortkeys= *SortKeys; |
3911
|
|
|
|
|
|
|
*HashKeys= *Hashkeys= *KeyOrder; |
3912
|
|
|
|
|
|
|
|
3913
|
|
|
|
|
|
|
my %scalar_meth= map { $_ => lc($_) } qw(Declare Indent IndentCols IndentKeys |
3914
|
|
|
|
|
|
|
Verbose DumpGlob Deparse DeparseGlob DeparseFormat CodeStub |
3915
|
|
|
|
|
|
|
FormatStub Rle RLE Purity DualVars Dualvars EclipseName |
3916
|
|
|
|
|
|
|
Compress Compressor OptSpace); |
3917
|
23
|
|
|
23
|
|
75243
|
|
3918
|
23
|
|
|
|
|
208
|
sub AUTOLOAD { |
3919
|
23
|
50
|
|
|
|
138
|
(my $meth= $AUTOLOAD) =~ s/^((?:\w+::)+)//; |
|
|
0
|
|
|
|
|
|
3920
|
23
|
50
|
|
|
|
107
|
my $name; |
3921
|
23
|
100
|
|
221
|
1
|
2718
|
if (defined($name= $scalar_meth{$meth})) { |
|
221
|
50
|
|
2
|
1
|
140869
|
|
|
221
|
50
|
|
3
|
0
|
817
|
|
|
57
|
50
|
|
2
|
1
|
210
|
|
|
57
|
50
|
|
4
|
1
|
383
|
|
|
164
|
50
|
|
2
|
1
|
589
|
|
|
2
|
|
|
|
|
9
|
|
|
2
|
|
|
|
|
8
|
|
|
2
|
|
|
|
|
10
|
|
|
2
|
|
|
|
|
20
|
|
|
0
|
|
|
|
|
0
|
|
|
3
|
|
|
|
|
10
|
|
|
3
|
|
|
|
|
10
|
|
|
3
|
|
|
|
|
12
|
|
|
3
|
|
|
|
|
15
|
|
|
0
|
|
|
|
|
0
|
|
|
2
|
|
|
|
|
32
|
|
|
2
|
|
|
|
|
7
|
|
|
2
|
|
|
|
|
9
|
|
|
2
|
|
|
|
|
6
|
|
|
0
|
|
|
|
|
0
|
|
|
4
|
|
|
|
|
16
|
|
|
4
|
|
|
|
|
14
|
|
|
4
|
|
|
|
|
14
|
|
|
4
|
|
|
|
|
18
|
|
|
0
|
|
|
|
|
0
|
|
|
2
|
|
|
|
|
9
|
|
|
2
|
|
|
|
|
22
|
|
|
2
|
|
|
|
|
10
|
|
|
2
|
|
|
|
|
11
|
|
|
0
|
|
|
|
|
|
|
3922
|
|
|
|
|
|
|
$DEBUG and print "AUTLOADING scalar meth $meth ($name)\n"; |
3923
|
|
|
|
|
|
|
eval ' |
3924
|
|
|
|
|
|
|
sub ' . $meth . ' { |
3925
|
|
|
|
|
|
|
my $self=shift->_safe_self(); |
3926
|
|
|
|
|
|
|
if (@_) { |
3927
|
|
|
|
|
|
|
$self->{style}{' . $name . '}=shift; |
3928
|
|
|
|
|
|
|
return $self |
3929
|
|
|
|
|
|
|
} else { |
3930
|
|
|
|
|
|
|
return $self->{style}{' . $name . '} |
3931
|
|
|
|
|
|
|
} |
3932
|
23
|
50
|
|
|
|
161
|
} |
3933
|
23
|
|
|
|
|
808
|
'; |
3934
|
|
|
|
|
|
|
$@ and die "$meth:$@\n"; |
3935
|
|
|
|
|
|
|
goto &$meth; |
3936
|
0
|
|
|
|
|
0
|
} |
3937
|
|
|
|
|
|
|
elsif ($meth =~ /[^A-Z]/) { |
3938
|
|
|
|
|
|
|
Carp::confess "Unhandled method/subroutine call $AUTOLOAD"; |
3939
|
|
|
|
|
|
|
} |
3940
|
|
|
|
|
|
|
} |
3941
|
81
|
|
|
81
|
|
138
|
|
3942
|
|
|
|
|
|
|
sub _get_lexicals { |
3943
|
81
|
50
|
|
|
|
186
|
my $cv= shift; |
3944
|
81
|
|
|
|
|
447
|
|
3945
|
81
|
50
|
|
|
|
259
|
if ($HasPadWalker) { |
3946
|
0
|
|
|
|
|
0
|
my ($names, $targs)= PadWalker::closed_over($cv); |
3947
|
|
|
|
|
|
|
if ($PadWalker::VERSION < 1) { |
3948
|
|
|
|
|
|
|
$names->{$_}= $names->{ $targs->{$_} } for keys %$targs; |
3949
|
81
|
|
|
|
|
335
|
} |
3950
|
|
|
|
|
|
|
else { |
3951
|
81
|
|
|
|
|
256
|
%$names= (%$names, %$targs); |
3952
|
|
|
|
|
|
|
} |
3953
|
|
|
|
|
|
|
return $names; |
3954
|
0
|
|
|
|
|
0
|
} |
3955
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
3956
|
0
|
|
|
|
|
0
|
my $svo= B::svref_2object($cv); |
|
0
|
|
|
|
|
0
|
|
3957
|
|
|
|
|
|
|
my @pl_array= eval { $svo->PADLIST->ARRAY }; |
3958
|
0
|
|
|
|
|
0
|
my @name_obj= eval { $pl_array[0]->ARRAY }; |
3959
|
0
|
|
|
|
|
0
|
|
3960
|
0
|
0
|
|
|
|
0
|
my %named; |
3961
|
0
|
|
|
|
|
0
|
for my $i (0 .. $#name_obj) { |
3962
|
|
|
|
|
|
|
if (ref($name_obj[$i]) !~ /SPECIAL/) { |
3963
|
|
|
|
|
|
|
$named{$i}= $name_obj[$i]->PV; |
3964
|
|
|
|
|
|
|
} |
3965
|
0
|
|
|
|
|
0
|
} |
3966
|
|
|
|
|
|
|
|
3967
|
|
|
|
|
|
|
my %inited; |
3968
|
|
|
|
|
|
|
my %used; |
3969
|
0
|
|
|
0
|
|
0
|
B::Utils::walkoptree_filtered( |
3970
|
|
|
|
|
|
|
$svo->ROOT, |
3971
|
0
|
|
|
0
|
|
0
|
sub { B::Utils::opgrep { name => [qw[ padsv padav padhv ]] }, @_ }, |
3972
|
0
|
|
|
|
|
0
|
sub { |
3973
|
0
|
0
|
|
|
|
0
|
my ($op, @items)= @_; |
3974
|
|
|
|
|
|
|
my $targ= $op->targ; |
3975
|
|
|
|
|
|
|
my $name= $named{$targ} |
3976
|
0
|
0
|
|
|
|
0
|
or return; |
3977
|
|
|
|
|
|
|
|
3978
|
|
|
|
|
|
|
$inited{$name}++ |
3979
|
0
|
0
|
|
|
|
0
|
if $op->private & 128; |
3980
|
0
|
|
|
|
|
0
|
|
3981
|
0
|
|
|
|
|
0
|
if (!$inited{$name}) { |
3982
|
0
|
|
|
|
|
0
|
$used{$name}= $pl_array[1]->ARRAYelt($targ)->object_2svref; |
3983
|
|
|
|
|
|
|
$used{$targ}= $used{$name}; |
3984
|
0
|
|
|
|
|
0
|
$inited{$name}++; |
3985
|
0
|
|
|
|
|
0
|
} |
3986
|
|
|
|
|
|
|
}); |
3987
|
|
|
|
|
|
|
return \%used; |
3988
|
|
|
|
|
|
|
} |
3989
|
26
|
|
|
26
|
|
186162
|
|
|
26
|
|
|
|
|
79
|
|
|
26
|
|
|
|
|
8882
|
|
3990
|
|
|
|
|
|
|
package Data::Dump::Streamer::Deparser; |
3991
|
|
|
|
|
|
|
use B::Deparse; |
3992
|
|
|
|
|
|
|
our @ISA= qw(B::Deparse); |
3993
|
|
|
|
|
|
|
my %cache; |
3994
|
|
|
|
|
|
|
|
3995
|
|
|
|
|
|
|
our $VERSION= '2.42'; |
3996
|
|
|
|
|
|
|
$VERSION= eval $VERSION; |
3997
|
|
|
|
|
|
|
if ($VERSION ne $Data::Dump::Streamer::VERSION) { |
3998
|
|
|
|
|
|
|
die |
3999
|
|
|
|
|
|
|
"Incompatible Data::Dump::Streamer::Deparser v$VERSION vs Data::Dump::Streamer v$Data::Dump::Streamer::VERSION"; |
4000
|
|
|
|
|
|
|
} |
4001
|
40
|
|
|
40
|
|
72
|
|
4002
|
40
|
|
|
|
|
80
|
sub dds_usenames { |
4003
|
40
|
|
|
|
|
135
|
my $self= shift; |
4004
|
|
|
|
|
|
|
my $names= shift; |
4005
|
|
|
|
|
|
|
$cache{ Data::Dump::Streamer::refaddr $self}= $names; |
4006
|
|
|
|
|
|
|
} |
4007
|
45
|
|
|
45
|
|
137
|
|
4008
|
45
|
|
|
|
|
65
|
sub padname { |
4009
|
45
|
100
|
66
|
|
|
272
|
my $self= shift; |
4010
|
|
|
|
|
|
|
my $targ= shift; |
4011
|
|
|
|
|
|
|
if ( $cache{ Data::Dump::Streamer::refaddr $self} |
4012
|
39
|
|
|
|
|
3951
|
and $cache{ Data::Dump::Streamer::refaddr $self}{$targ}) |
4013
|
|
|
|
|
|
|
{ |
4014
|
6
|
|
|
|
|
1020
|
return $cache{ Data::Dump::Streamer::refaddr $self}{$targ}; |
4015
|
|
|
|
|
|
|
} |
4016
|
|
|
|
|
|
|
return $self->padname_sv($targ)->PVX; |
4017
|
|
|
|
|
|
|
} |
4018
|
45
|
|
|
45
|
|
100
|
|
4019
|
45
|
|
|
|
|
360
|
sub DESTROY { |
4020
|
|
|
|
|
|
|
my $self= shift; |
4021
|
|
|
|
|
|
|
delete $cache{ Data::Dump::Streamer::refaddr $self}; |
4022
|
|
|
|
|
|
|
} |
4023
|
|
|
|
|
|
|
|
4024
|
|
|
|
|
|
|
unless (B::AV->can('ARRAYelt')) { |
4025
|
|
|
|
|
|
|
eval <<'EOF_EVAL'; |
4026
|
|
|
|
|
|
|
sub B::AV::ARRAYelt { |
4027
|
|
|
|
|
|
|
my ($obj,$idx)=@_; |
4028
|
|
|
|
|
|
|
my @array=$obj->ARRAY; |
4029
|
|
|
|
|
|
|
return $array[$idx]; |
4030
|
|
|
|
|
|
|
} |
4031
|
|
|
|
|
|
|
EOF_EVAL |
4032
|
|
|
|
|
|
|
} |
4033
|
|
|
|
|
|
|
|
4034
|
|
|
|
|
|
|
1; |
4035
|
|
|
|
|
|
|
__END__ |