line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# License: Public Domain or CC0 |
2
|
|
|
|
|
|
|
# See https://creativecommons.org/publicdomain/zero/1.0/ |
3
|
|
|
|
|
|
|
# The author, Jim Avera (jim.avera at gmail) has waived all copyright and |
4
|
|
|
|
|
|
|
# related or neighboring rights. Attribution is requested but is not required. |
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
##FIXME: Refaddr(1) has no effect inside Blessed structures |
7
|
|
|
|
|
|
|
|
8
|
9
|
|
|
9
|
|
94873
|
use strict; use warnings FATAL => 'all'; use utf8; |
|
9
|
|
|
9
|
|
61
|
|
|
9
|
|
|
9
|
|
287
|
|
|
9
|
|
|
|
|
48
|
|
|
9
|
|
|
|
|
17
|
|
|
9
|
|
|
|
|
292
|
|
|
9
|
|
|
|
|
5154
|
|
|
9
|
|
|
|
|
127
|
|
|
9
|
|
|
|
|
47
|
|
9
|
|
|
|
|
|
|
#use 5.010; # say, state |
10
|
|
|
|
|
|
|
#use 5.011; # cpantester gets warning that 5.11 is the minimum acceptable |
11
|
|
|
|
|
|
|
#use 5.014; # /r for non-destructive substitution |
12
|
9
|
|
|
9
|
|
374
|
use 5.018; # lexical_subs |
|
9
|
|
|
|
|
34
|
|
13
|
9
|
|
|
9
|
|
48
|
use feature qw(say state lexical_subs current_sub); |
|
9
|
|
|
|
|
14
|
|
|
9
|
|
|
|
|
867
|
|
14
|
9
|
|
|
9
|
|
57
|
use feature 'lexical_subs'; |
|
9
|
|
|
|
|
16
|
|
|
9
|
|
|
|
|
250
|
|
15
|
|
|
|
|
|
|
|
16
|
9
|
|
|
9
|
|
57
|
no warnings "experimental::lexical_subs"; |
|
9
|
|
|
|
|
20
|
|
|
9
|
|
|
|
|
645
|
|
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
package Data::Dumper::Interp; |
19
|
9
|
|
|
9
|
|
58
|
{ no strict 'refs'; ${__PACKAGE__."::VER"."SION"} = 997.999; } |
|
9
|
|
|
|
|
28
|
|
|
9
|
|
|
|
|
1570
|
|
20
|
|
|
|
|
|
|
our $VERSION = '6.008'; # VERSION from Dist::Zilla::Plugin::OurPkgVersion |
21
|
|
|
|
|
|
|
our $DATE = '2023-10-15'; # DATE from Dist::Zilla::Plugin::OurDate |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
package |
24
|
|
|
|
|
|
|
# newline so Dist::Zilla::Plugin::PkgVersion won't add $VERSION |
25
|
|
|
|
|
|
|
DB { |
26
|
|
|
|
|
|
|
sub DB_Vis_Evalwrapper { |
27
|
1670
|
|
|
1670
|
0
|
279396
|
eval $Data::Dumper::Interp::string_to_eval; ## no critic |
28
|
|
|
|
|
|
|
} |
29
|
|
|
|
|
|
|
} |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
package Data::Dumper::Interp; |
32
|
|
|
|
|
|
|
|
33
|
9
|
|
|
9
|
|
4964
|
use Moose; |
|
9
|
|
|
|
|
4204753
|
|
|
9
|
|
|
|
|
62
|
|
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
extends 'Data::Visitor' => { -version => 0.32 }, |
36
|
|
|
|
|
|
|
'Exporter' => { -version => 5.57 }, |
37
|
|
|
|
|
|
|
; |
38
|
|
|
|
|
|
|
|
39
|
9
|
|
|
9
|
|
69317
|
no warnings "experimental::lexical_subs"; # un-do Moose forcing these on!! |
|
9
|
|
|
|
|
23
|
|
|
9
|
|
|
|
|
448
|
|
40
|
|
|
|
|
|
|
|
41
|
9
|
|
|
9
|
|
7212
|
use Data::Dumper (); |
|
9
|
|
|
|
|
64545
|
|
|
9
|
|
|
|
|
276
|
|
42
|
9
|
|
|
9
|
|
63
|
use Carp; |
|
9
|
|
|
|
|
30
|
|
|
9
|
|
|
|
|
746
|
|
43
|
9
|
|
|
9
|
|
4622
|
use POSIX qw(INT_MAX); |
|
9
|
|
|
|
|
59972
|
|
|
9
|
|
|
|
|
55
|
|
44
|
9
|
|
|
9
|
|
13746
|
use Scalar::Util qw(blessed reftype refaddr looks_like_number weaken); |
|
9
|
|
|
|
|
26
|
|
|
9
|
|
|
|
|
744
|
|
45
|
9
|
|
|
9
|
|
69
|
use List::Util 1.45 qw(min max first none all any sum0); |
|
9
|
|
|
|
|
229
|
|
|
9
|
|
|
|
|
878
|
|
46
|
9
|
|
|
9
|
|
4770
|
use Data::Structure::Util qw/circular_off/; |
|
9
|
|
|
|
|
66597
|
|
|
9
|
|
|
|
|
650
|
|
47
|
9
|
|
|
9
|
|
4971
|
use Regexp::Common qw/RE_balanced/; |
|
9
|
|
|
|
|
25011
|
|
|
9
|
|
|
|
|
39
|
|
48
|
9
|
|
|
9
|
|
1453593
|
use Term::ReadKey (); |
|
9
|
|
|
|
|
18361
|
|
|
9
|
|
|
|
|
240
|
|
49
|
9
|
|
|
9
|
|
66
|
use overload (); |
|
9
|
|
|
|
|
23
|
|
|
9
|
|
|
|
|
11898
|
|
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
############################ Exports ####################################### |
52
|
|
|
|
|
|
|
# Short-hand functions/methods are generated on demand (i.e. if imported or |
53
|
|
|
|
|
|
|
# called as a method) based on a naming convention. |
54
|
|
|
|
|
|
|
############################################################################ |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
our @EXPORT = qw( visnew |
57
|
|
|
|
|
|
|
vis avis hvis ivis dvis |
58
|
|
|
|
|
|
|
viso aviso hviso iviso dviso |
59
|
|
|
|
|
|
|
visq avisq hvisq ivisq dvisq |
60
|
|
|
|
|
|
|
visr avisr hvisr ivisr dvisr |
61
|
|
|
|
|
|
|
rvis rvisq |
62
|
|
|
|
|
|
|
addrvis addrvisl |
63
|
|
|
|
|
|
|
u quotekey qsh qshlist qshpath |
64
|
|
|
|
|
|
|
); |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
our @EXPORT_OK = qw(addrvis_digits |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
$Debug $MaxStringwidth $Truncsuffix $Objects $Foldwidth |
69
|
|
|
|
|
|
|
$Useqq $Quotekeys $Sortkeys |
70
|
|
|
|
|
|
|
$Maxdepth $Maxrecurse $Deparse $Deepcopy); |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
our %EXPORT_TAGS = ( |
73
|
|
|
|
|
|
|
null => [], |
74
|
|
|
|
|
|
|
); |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
sub _generate_sub($;$); # forward |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
#--------------------------------------------------------------------------- |
79
|
|
|
|
|
|
|
my $sane_cW = $^W; |
80
|
|
|
|
|
|
|
my $sane_cH = $^H; |
81
|
|
|
|
|
|
|
our @save_stack; |
82
|
|
|
|
|
|
|
sub _SaveAndResetPunct() { |
83
|
|
|
|
|
|
|
# Save things which will later be restored |
84
|
7335
|
|
|
7335
|
|
70969
|
push @save_stack, [ $@, $!+0, $^E+0, $,, $/, $\, $?, $^W ]; |
85
|
|
|
|
|
|
|
# Reset sane values |
86
|
7335
|
|
|
|
|
15942
|
$, = ""; # output field separator is null string |
87
|
7335
|
|
|
|
|
17220
|
$/ = "\n"; # input record separator is newline |
88
|
7335
|
|
|
|
|
14406
|
$\ = ""; # output record separator is null string |
89
|
7335
|
|
|
|
|
12090
|
$? = 0; # child process exit status |
90
|
7335
|
|
|
|
|
15460
|
$^W = $sane_cW; # our load-time warnings |
91
|
|
|
|
|
|
|
#$^H = $sane_cH; # our load-time pragmas (strict etc.) |
92
|
|
|
|
|
|
|
} |
93
|
|
|
|
|
|
|
sub _RestorePunct_NoPop() { |
94
|
9005
|
|
|
9005
|
|
15301
|
( $@, $!, $^E, $,, $/, $\, $?, $^W ) = @{ $save_stack[-1] }; |
|
9005
|
|
|
|
|
90881
|
|
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
sub _RestorePunct() { |
97
|
7335
|
|
|
7335
|
|
16753
|
&_RestorePunct_NoPop; |
98
|
7335
|
|
|
|
|
16016
|
pop @save_stack; |
99
|
|
|
|
|
|
|
} |
100
|
|
|
|
|
|
|
#--------------------------------------------------------------------------- |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
our $AUTOLOAD_debug; |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
sub import { |
105
|
9
|
|
|
9
|
|
3212836
|
my $class = shift; |
106
|
9
|
|
|
|
|
39
|
my @args = @_; |
107
|
|
|
|
|
|
|
|
108
|
9
|
|
100
|
|
|
63
|
my $exporting_default = (@args==0 or grep{ /:DEFAULT/ } @args); |
109
|
|
|
|
|
|
|
|
110
|
9
|
|
|
|
|
22
|
our $Debug; |
111
|
9
|
|
|
|
|
32
|
local $Debug = $Debug; |
112
|
9
|
50
|
|
6
|
|
101
|
if (my $tag = first{ /^:debug/i } @args) { |
|
6
|
|
|
|
|
25
|
|
113
|
0
|
|
|
|
|
0
|
@args = grep{ ! /^:debug/i } @args; |
|
0
|
|
|
|
|
0
|
|
114
|
0
|
0
|
|
|
|
0
|
my $level = ($tag =~ /=(\d+)/ ? $1 : 1); |
115
|
0
|
|
|
|
|
0
|
$AUTOLOAD_debug = $Debug = $level; # show generated code |
116
|
|
|
|
|
|
|
} |
117
|
|
|
|
|
|
|
|
118
|
9
|
100
|
|
|
|
61
|
if (grep{ /^:all$/i } @args) { |
|
6
|
|
|
|
|
85
|
|
119
|
2
|
|
|
|
|
10
|
@args = grep{ ! /^:all$/i } @args; |
|
5
|
|
|
|
|
19
|
|
120
|
|
|
|
|
|
|
# Generate all modifiers combinations as suffixes in alphabetical order. |
121
|
2
|
|
|
|
|
8
|
my %already = map{$_ => 1} @args; |
|
3
|
|
|
|
|
11
|
|
122
|
2
|
50
|
|
|
|
12
|
push @args, ":DEFAULT" unless $already{':DEFAULT'}; |
123
|
2
|
|
|
|
|
8
|
for my $v1 (qw/avis hvis vis ivis dvis/) { # avisl hvisl ? |
124
|
10
|
|
|
|
|
22
|
for my $v2 ('1', '2', "") { |
125
|
30
|
|
|
|
|
41
|
for my $v3 ('l', "") { |
126
|
60
|
100
|
100
|
|
|
174
|
next if $v3 && $v1 !~ /^[ah]/; # 'l' only with avis or hvis |
127
|
42
|
|
|
|
|
65
|
for my $v4 ('o', "") { |
128
|
84
|
|
|
|
|
125
|
for my $v5 ('q', "") { |
129
|
168
|
|
|
|
|
222
|
for my $v6 ('r', "") { |
130
|
336
|
|
|
|
|
582
|
my $subname = $v1.$v2.$v3.$v4.$v5.$v6; |
131
|
336
|
50
|
|
|
|
836
|
next if $already{$subname}++; |
132
|
336
|
|
|
|
|
701
|
push @args, $subname; |
133
|
|
|
|
|
|
|
} |
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
} |
136
|
|
|
|
|
|
|
} |
137
|
|
|
|
|
|
|
} |
138
|
|
|
|
|
|
|
} |
139
|
|
|
|
|
|
|
} |
140
|
|
|
|
|
|
|
|
141
|
9
|
100
|
|
|
|
66
|
foreach my $subname (@args, ($exporting_default ? @EXPORT : ())) { |
142
|
552
|
100
|
|
|
|
2255
|
next unless $subname =~ /^[a-zA-Z]/a; # skip :tag or $var |
143
|
549
|
|
|
|
|
1452
|
push @EXPORT_OK, $subname; |
144
|
9
|
|
|
9
|
|
82
|
no strict 'refs'; |
|
9
|
|
|
|
|
19
|
|
|
9
|
|
|
|
|
3053
|
|
145
|
549
|
100
|
|
|
|
2528
|
if (defined(*$subname{CODE})) { |
146
|
58
|
50
|
50
|
|
|
199
|
warn "# $subname ALREADY DEFINED\n" if ($Debug//0) > 1; |
147
|
|
|
|
|
|
|
} else { |
148
|
|
|
|
|
|
|
# Only generate a 'forward' stub to allow prototype checks. |
149
|
|
|
|
|
|
|
# Subs actually called will be defined via AUTOLOAD |
150
|
491
|
|
|
|
|
2166
|
_generate_sub($subname, 1); |
151
|
|
|
|
|
|
|
} |
152
|
|
|
|
|
|
|
} |
153
|
|
|
|
|
|
|
|
154
|
9
|
50
|
66
|
|
|
67
|
@args = (':null') if @_ && !@args; |
155
|
|
|
|
|
|
|
|
156
|
9
|
50
|
|
|
|
37
|
warn "Passing to Exporter::import ",&_dbavis(@args),"\n" |
157
|
|
|
|
|
|
|
if $Debug; |
158
|
|
|
|
|
|
|
|
159
|
9
|
|
|
|
|
193182
|
__PACKAGE__->export_to_level(1, $class, @args); |
160
|
|
|
|
|
|
|
} |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
sub AUTOLOAD { # invoked on call to undefined *method* |
163
|
31
|
|
|
31
|
|
1276847
|
our $AUTOLOAD; |
164
|
31
|
|
|
|
|
136
|
_SaveAndResetPunct(); |
165
|
31
|
|
|
|
|
56
|
our $Debug; |
166
|
31
|
|
|
|
|
99
|
local $Debug = $AUTOLOAD_debug; |
167
|
31
|
50
|
|
|
|
123
|
carp "AUTOLOAD $AUTOLOAD" if $Debug; |
168
|
31
|
|
|
|
|
311
|
_generate_sub($AUTOLOAD); |
169
|
31
|
|
|
|
|
134
|
_RestorePunct(); |
170
|
9
|
|
|
9
|
|
77
|
no strict 'refs'; |
|
9
|
|
|
|
|
22
|
|
|
9
|
|
|
|
|
39082
|
|
171
|
31
|
|
|
|
|
1177
|
goto &$AUTOLOAD; |
172
|
|
|
|
|
|
|
} |
173
|
|
|
|
|
|
|
#sub DESTROY {} #unnecessary: No D::D::Interp objects are ever instantiated |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
############################################################################ |
176
|
|
|
|
|
|
|
# Internal debug-message utilities |
177
|
|
|
|
|
|
|
|
178
|
0
|
|
|
0
|
0
|
0
|
sub oops(@) { @_=("\n".(caller)." oops:\n",@_,"\n"); goto &Carp::confess } |
|
0
|
|
|
|
|
0
|
|
179
|
0
|
|
|
0
|
0
|
0
|
sub btwN($@) { my $N=shift; local $_=join("",@_); s/\n\z//s; printf "%4d: %s\n",(caller($N))[2],$_; } |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
180
|
0
|
|
|
0
|
0
|
0
|
sub btw(@) { unshift @_,0; goto &btwN } |
|
0
|
|
|
|
|
0
|
|
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
sub _chop_ateval($) { # remove "at (eval N) line..." from an exception message |
183
|
0
|
|
|
0
|
|
0
|
(local $_ = shift) =~ s/ at \(eval[^\)]*\) line \d+[^\n]*\n?\z//s; |
184
|
0
|
|
|
|
|
0
|
$_ |
185
|
|
|
|
|
|
|
} |
186
|
|
|
|
|
|
|
sub _croak_or_confess(@) { |
187
|
|
|
|
|
|
|
# Chain to croak, or to confess if there is an eval in the call stack |
188
|
0
|
0
|
|
0
|
|
0
|
if (Carp::longmess("") =~ /\beval\b/) { |
189
|
0
|
|
|
|
|
0
|
goto &Carp::confess; |
190
|
|
|
|
|
|
|
} |
191
|
0
|
|
|
|
|
0
|
goto &Carp::croak; |
192
|
|
|
|
|
|
|
} |
193
|
|
|
|
|
|
|
|
194
|
0
|
0
|
|
0
|
|
0
|
sub _tf($) { $_[0] ? "T" : "F" } |
195
|
0
|
0
|
|
0
|
|
0
|
sub _showfalse(_) { $_[0] ? $_[0] : 0 } |
196
|
|
|
|
|
|
|
sub _dbvisnew($) { |
197
|
800
|
|
|
800
|
|
1338
|
my $v = shift; |
198
|
800
|
|
|
|
|
3394
|
Data::Dumper->new([$v])->Terse(1)->Indent(0)->Quotekeys(0)->Useqq(1) |
199
|
|
|
|
|
|
|
#->Useperl(1) |
200
|
|
|
|
|
|
|
###->Sortkeys(\&__sortkeys)->Pair("=>") |
201
|
|
|
|
|
|
|
} |
202
|
800
|
|
|
800
|
|
7453
|
sub _dbvis(_) {chomp(my $s=_dbvisnew(shift)->Useqq(1)->Dump); $s } |
|
800
|
|
|
|
|
53626
|
|
203
|
0
|
|
|
0
|
|
0
|
sub _dbvisq(_){chomp(my $s=_dbvisnew(shift)->Useqq(0)->Dump); $s } |
|
0
|
|
|
|
|
0
|
|
204
|
0
|
|
|
0
|
|
0
|
sub _dbvis1(_){chomp(my $s=_dbvisnew(shift)->Maxdepth(1)->Useqq(1)->Dump); $s } |
|
0
|
|
|
|
|
0
|
|
205
|
0
|
|
|
0
|
|
0
|
sub _dbvis2(_){chomp(my $s=_dbvisnew(shift)->Maxdepth(3)->Useqq(1)->Dump); $s } |
|
0
|
|
|
|
|
0
|
|
206
|
0
|
|
|
0
|
|
0
|
sub _dbavis(@){ "(" . join(", ", map{_dbvis} @_) . ")" } |
|
0
|
|
|
|
|
0
|
|
207
|
0
|
|
|
0
|
|
0
|
sub _dbavis2(@){ "(" . join(", ", map{_dbvis2} @_) . ")" } |
|
0
|
|
|
|
|
0
|
|
208
|
0
|
0
|
|
0
|
|
0
|
sub _dbrvis(_) { (ref($_[0]) ? addrvis(refaddr $_[0]) : "")._dbvis($_[0]) } |
209
|
0
|
0
|
|
0
|
|
0
|
sub _dbrvis2(_){ (ref($_[0]) ? addrvis(refaddr $_[0]) : "")._dbvis2($_[0]) } |
210
|
0
|
|
|
0
|
|
0
|
sub _dbravis2(@){ "(" . join(", ", map{_dbrvis2} @_) . ")" } |
|
0
|
|
|
|
|
0
|
|
211
|
|
|
|
|
|
|
sub _dbshow(_) { |
212
|
0
|
|
|
0
|
|
0
|
my $v = shift; |
213
|
0
|
0
|
|
|
|
0
|
blessed($v) ? "(".blessed($v).")".$v # stringify with (classname) prefix |
214
|
|
|
|
|
|
|
: _dbvis($v) # something else |
215
|
|
|
|
|
|
|
} |
216
|
|
|
|
|
|
|
our $_dbmaxlen = 300; |
217
|
0
|
0
|
|
0
|
|
0
|
sub _dbrawstr(_) { "«".(length($_[0])>$_dbmaxlen ? substr($_[0],0,$_dbmaxlen-3)."..." : $_[0])."»" } |
218
|
|
|
|
|
|
|
sub _dbstr($) { |
219
|
0
|
|
|
0
|
|
0
|
local $_ = shift; |
220
|
0
|
0
|
|
|
|
0
|
return "undef" if !defined; |
221
|
0
|
|
|
|
|
0
|
s/\x{0a}/\N{U+2424}/sg; # a special NL glyph |
222
|
0
|
|
|
|
|
0
|
s/ /\N{U+00B7}/sg; # space -> Middle Dot |
223
|
0
|
|
|
|
|
0
|
s/[\x{00}-\x{1F}]/ chr( ord($&)+0x2400 ) /aseg; |
|
0
|
|
|
|
|
0
|
|
224
|
0
|
|
|
|
|
0
|
$_ |
225
|
|
|
|
|
|
|
} |
226
|
|
|
|
|
|
|
sub _dbstrposn($$) { |
227
|
0
|
|
|
0
|
|
0
|
local $_ = shift; |
228
|
0
|
|
|
|
|
0
|
my $posn = shift; |
229
|
0
|
|
|
|
|
0
|
local $_dbmaxlen = max($_dbmaxlen+8, $posn+8); |
230
|
0
|
|
|
|
|
0
|
my $visible = _dbstr($_); # simplified 'controlpics' |
231
|
0
|
|
|
|
|
0
|
"posn=$posn shown at '(<<HERE)':" |
232
|
|
|
|
|
|
|
. substr($visible, 0, $posn+1)."(<<HERE)".substr($visible,$posn+1) |
233
|
|
|
|
|
|
|
} |
234
|
|
|
|
|
|
|
############################################################################ |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
#################### Configuration Globals ################# |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
our ($Debug, $MaxStringwidth, $Truncsuffix, $Objects, |
240
|
|
|
|
|
|
|
$Refaddr, $Foldwidth, $Foldwidth1, |
241
|
|
|
|
|
|
|
$Useqq, $Quotekeys, $Sortkeys, |
242
|
|
|
|
|
|
|
$Maxdepth, $Maxrecurse, $Deparse, $Deepcopy); |
243
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
$Debug = 0 unless defined $Debug; |
245
|
|
|
|
|
|
|
$MaxStringwidth = 0 unless defined $MaxStringwidth; |
246
|
|
|
|
|
|
|
$Truncsuffix = "..." unless defined $Truncsuffix; |
247
|
|
|
|
|
|
|
$Objects = 1 unless defined $Objects; |
248
|
|
|
|
|
|
|
$Refaddr = 0 unless defined $Refaddr; |
249
|
|
|
|
|
|
|
$Foldwidth = undef unless defined $Foldwidth; # undef auto-detects |
250
|
|
|
|
|
|
|
$Foldwidth1 = undef unless defined $Foldwidth1; # override for 1st |
251
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
# The following override Data::Dumper defaults |
253
|
|
|
|
|
|
|
# Initial D::D values are captured once when we are first loaded. |
254
|
|
|
|
|
|
|
# |
255
|
|
|
|
|
|
|
#$Useqq = "unicode:controlpic" unless defined $Useqq; |
256
|
|
|
|
|
|
|
$Useqq = "unicode" unless defined $Useqq; |
257
|
|
|
|
|
|
|
$Quotekeys = 0 unless defined $Quotekeys; |
258
|
|
|
|
|
|
|
$Sortkeys = \&__sortkeys unless defined $Sortkeys; |
259
|
|
|
|
|
|
|
$Maxdepth = $Data::Dumper::Maxdepth unless defined $Maxdepth; |
260
|
|
|
|
|
|
|
$Maxrecurse = $Data::Dumper::Maxrecurse unless defined $Maxrecurse; |
261
|
|
|
|
|
|
|
$Deparse = 0 unless defined $Deparse; |
262
|
|
|
|
|
|
|
$Deepcopy = 0 unless defined $Deepcopy; |
263
|
|
|
|
|
|
|
|
264
|
|
|
|
|
|
|
#################### Methods ################# |
265
|
|
|
|
|
|
|
|
266
|
|
|
|
|
|
|
has dd => ( |
267
|
|
|
|
|
|
|
is => 'ro', |
268
|
|
|
|
|
|
|
lazy => 1, |
269
|
|
|
|
|
|
|
default => sub{ |
270
|
|
|
|
|
|
|
my $self = shift; |
271
|
|
|
|
|
|
|
Data::Dumper->new([],[]) |
272
|
|
|
|
|
|
|
->Terse(1) |
273
|
|
|
|
|
|
|
->Indent(0) |
274
|
|
|
|
|
|
|
->Sparseseen(1) |
275
|
|
|
|
|
|
|
->Useqq($Useqq) |
276
|
|
|
|
|
|
|
->Quotekeys($Quotekeys) |
277
|
|
|
|
|
|
|
->Sortkeys($Sortkeys) |
278
|
|
|
|
|
|
|
->Maxdepth($Maxdepth) |
279
|
|
|
|
|
|
|
->Maxrecurse($Maxrecurse) |
280
|
|
|
|
|
|
|
->Deparse($Deparse) |
281
|
|
|
|
|
|
|
->Deepcopy($Deepcopy) |
282
|
|
|
|
|
|
|
}, |
283
|
|
|
|
|
|
|
# This generates pass-through methods which call the dd object |
284
|
|
|
|
|
|
|
handles => [qw/Values Useqq Quotekeys Trailingcomma Pad Varname Quotekeys |
285
|
|
|
|
|
|
|
Maxdepth Maxrecurse Useperl Sortkeys Deparse Deepcopy |
286
|
|
|
|
|
|
|
/], |
287
|
|
|
|
|
|
|
); |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
# Config values which have no counter part in Data::Dumper |
290
|
|
|
|
|
|
|
has Debug => (is=>'rw', default => sub{ $Debug }); |
291
|
|
|
|
|
|
|
has MaxStringwidth => (is=>'rw', default => sub{ $MaxStringwidth }); |
292
|
|
|
|
|
|
|
has Truncsuffix => (is=>'rw', default => sub{ $Truncsuffix }); |
293
|
|
|
|
|
|
|
has Objects => (is=>'rw', default => sub{ $Objects }); |
294
|
|
|
|
|
|
|
has Refaddr => (is=>'rw', default => sub{ $Refaddr }); |
295
|
|
|
|
|
|
|
has Foldwidth => (is=>'rw', default => sub{ |
296
|
|
|
|
|
|
|
$Foldwidth // do{ |
297
|
|
|
|
|
|
|
_set_default_Foldwidth(); |
298
|
|
|
|
|
|
|
$Foldwidth |
299
|
|
|
|
|
|
|
} |
300
|
|
|
|
|
|
|
}); |
301
|
|
|
|
|
|
|
has Foldwidth1 => (is=>'rw', default => sub{ $Foldwidth1 }); |
302
|
|
|
|
|
|
|
has _Listform => (is=>'rw'); |
303
|
|
|
|
|
|
|
|
304
|
|
|
|
|
|
|
# Make "setters" return the outer object $self |
305
|
|
|
|
|
|
|
around [qw/Values Useqq Quotekeys Trailingcomma Pad Varname Quotekeys |
306
|
|
|
|
|
|
|
Maxdepth Maxrecurse Useperl Sortkeys Deparse Deepcopy |
307
|
|
|
|
|
|
|
|
308
|
|
|
|
|
|
|
Debug MaxStringwidth Truncsuffix Objects Refaddr |
309
|
|
|
|
|
|
|
Foldwidth Foldwidth1 _Listform |
310
|
|
|
|
|
|
|
/] => sub{ |
311
|
|
|
|
|
|
|
my $orig = shift; |
312
|
|
|
|
|
|
|
my $self = shift; |
313
|
|
|
|
|
|
|
#Carp::cluck("##around (@_)\n"); |
314
|
|
|
|
|
|
|
if (@_ > 0) { |
315
|
|
|
|
|
|
|
$self->$orig(@_); |
316
|
|
|
|
|
|
|
return $self; |
317
|
|
|
|
|
|
|
} |
318
|
|
|
|
|
|
|
$self->$orig |
319
|
|
|
|
|
|
|
}; |
320
|
|
|
|
|
|
|
|
321
|
|
|
|
|
|
|
############### Utility Functions ################# |
322
|
|
|
|
|
|
|
|
323
|
|
|
|
|
|
|
#--------------------------------------------------------------------------- |
324
|
|
|
|
|
|
|
# Display an address as <decimal:hex> showing only the last few digits. |
325
|
|
|
|
|
|
|
# The number of digits shown increases when collisions occur. |
326
|
|
|
|
|
|
|
# The arg can be a numeric address or a ref from which the addr is taken. |
327
|
|
|
|
|
|
|
# If a ref the result is REFTYPEorOBJTYPE<dec:hex> otherwise just <dec:hex> |
328
|
|
|
|
|
|
|
our $addrvis_ndigits = 3; |
329
|
|
|
|
|
|
|
our $addrvis_seen = {}; # full (decimal) address => undef |
330
|
|
|
|
|
|
|
our $addrvis_dec_abbrs = {}; # abbreviated decimal digits => undef |
331
|
|
|
|
|
|
|
sub _abbr_hex($) { |
332
|
170573
|
|
|
170573
|
|
564723
|
substr(sprintf("%0*x", $addrvis_ndigits, $_[0]), -$addrvis_ndigits) } |
333
|
|
|
|
|
|
|
sub _abbr_dec($) { |
334
|
176946
|
|
|
176946
|
|
554510
|
substr(sprintf("%0*d", $addrvis_ndigits, $_[0]), -$addrvis_ndigits) } |
335
|
|
|
|
|
|
|
sub addrvis(_) { |
336
|
170575
|
|
100
|
170575
|
1
|
3194437
|
my $arg = shift // return("undef"); |
337
|
170573
|
|
|
|
|
251470
|
my $refstr = ref($arg); |
338
|
170573
|
|
|
|
|
205004
|
my $addr; |
339
|
170573
|
100
|
|
|
|
402034
|
if ($refstr ne "") { $addr = refaddr($arg) } |
|
39
|
50
|
|
|
|
90
|
|
340
|
170534
|
|
|
|
|
231258
|
elsif (looks_like_number($arg)) { $addr = $arg } |
341
|
|
|
|
|
|
|
else { |
342
|
0
|
|
|
|
|
0
|
carp("addrvis arg '$arg' is neither a ref or a number\n"); |
343
|
0
|
|
|
|
|
0
|
return "" |
344
|
|
|
|
|
|
|
} |
345
|
|
|
|
|
|
|
|
346
|
170573
|
100
|
|
|
|
356011
|
if (! exists $addrvis_seen->{$addr}) { |
347
|
2168
|
|
|
|
|
3411
|
my $dec_abbr = _abbr_dec($addr); |
348
|
2168
|
|
|
|
|
5193
|
while (exists $addrvis_dec_abbrs->{$dec_abbr}) { |
349
|
3
|
|
|
|
|
8
|
++$addrvis_ndigits; |
350
|
3
|
|
|
|
|
443
|
%$addrvis_dec_abbrs = map{ (_abbr_dec($_) => undef) } keys %$addrvis_seen; |
|
3202
|
|
|
|
|
6406
|
|
351
|
3
|
|
|
|
|
271
|
$dec_abbr = _abbr_dec($addr); |
352
|
|
|
|
|
|
|
} |
353
|
2168
|
|
|
|
|
5092
|
$addrvis_dec_abbrs->{$dec_abbr} = undef; |
354
|
2168
|
|
|
|
|
4367
|
$addrvis_seen->{$addr} = undef; |
355
|
|
|
|
|
|
|
} |
356
|
|
|
|
|
|
|
#$refstr ne "" ? $refstr.'<'._abbr_dec($addr).':'._abbr_hex($addr).'>' |
357
|
|
|
|
|
|
|
# : _abbr_dec($addr).':'._abbr_hex($addr) |
358
|
170573
|
|
|
|
|
303471
|
$refstr.'<'._abbr_dec($addr).':'._abbr_hex($addr).'>' |
359
|
|
|
|
|
|
|
} |
360
|
|
|
|
|
|
|
sub addrvisl(_) { |
361
|
|
|
|
|
|
|
# Return bare "hex:dec" or "Typename hex:dec" |
362
|
2
|
100
|
|
2
|
1
|
7
|
&addrvis =~ s/^([^\<]*)\<(.*)\>$/ $1 ? "$1 $2" : $2 /er or oops |
|
2
|
50
|
|
|
|
38
|
|
363
|
|
|
|
|
|
|
} |
364
|
|
|
|
|
|
|
sub addrvis_digits(;$) { |
365
|
1
|
50
|
|
1
|
0
|
395
|
return $addrvis_ndigits if ! defined $_[0]; # "get" request |
366
|
1
|
50
|
|
|
|
7
|
if ($_[0] <= $addrvis_ndigits) { |
367
|
0
|
|
|
|
|
0
|
return $addrvis_ndigits; # can not decrease |
368
|
|
|
|
|
|
|
} |
369
|
1
|
|
|
|
|
3
|
$addrvis_ndigits = $_[0]; |
370
|
1
|
|
|
|
|
112
|
%$addrvis_dec_abbrs = map{ (_abbr_dec($_) => undef) } keys %$addrvis_seen; |
|
1000
|
|
|
|
|
1587
|
|
371
|
1
|
|
|
|
|
91
|
$addrvis_ndigits; |
372
|
|
|
|
|
|
|
} |
373
|
|
|
|
|
|
|
sub addrvis_forget() { |
374
|
2
|
|
|
2
|
0
|
766
|
$addrvis_seen = {}; |
375
|
2
|
|
|
|
|
284
|
$addrvis_dec_abbrs = {}; |
376
|
2
|
|
|
|
|
9
|
$addrvis_ndigits = 3; |
377
|
|
|
|
|
|
|
} |
378
|
|
|
|
|
|
|
|
379
|
|
|
|
|
|
|
=for Pod::Coverage addrvis_digits addrvis_forget |
380
|
|
|
|
|
|
|
|
381
|
|
|
|
|
|
|
=cut |
382
|
|
|
|
|
|
|
|
383
|
688
|
|
100
|
688
|
1
|
38710
|
sub u(_) { $_[0] // "undef" } |
384
|
|
|
|
|
|
|
sub quotekey(_); # forward. Implemented after regex declarations. |
385
|
|
|
|
|
|
|
|
386
|
|
|
|
|
|
|
sub __stringify($) { |
387
|
29
|
50
|
|
29
|
|
89
|
if (defined(my $class = blessed($_[0]))) { |
388
|
0
|
0
|
|
|
|
0
|
return "$_[0]" if overload::Method($class,'""'); |
389
|
|
|
|
|
|
|
} |
390
|
29
|
|
|
|
|
59
|
$_[0] |
391
|
|
|
|
|
|
|
} |
392
|
|
|
|
|
|
|
|
393
|
9
|
50
|
|
|
|
22916
|
use constant _SHELL_UNSAFE_REGEX => |
394
|
9
|
|
|
9
|
|
97
|
($^O eq "MSWin32" ? qr/[^-=\w_:\.,\\]/ : qr/[^-=\w_\/:\.,]/); |
|
9
|
|
|
|
|
20
|
|
395
|
|
|
|
|
|
|
|
396
|
|
|
|
|
|
|
sub __forceqsh(_) { |
397
|
12
|
|
|
12
|
|
26
|
local $_ = shift; |
398
|
12
|
100
|
|
|
|
48
|
return "undef" if !defined; # undef without quotes |
399
|
11
|
50
|
|
|
|
23
|
$_ = vis($_) if ref; |
400
|
11
|
50
|
|
|
|
28
|
if ($^O eq "MSWin32") { |
401
|
|
|
|
|
|
|
# Backslash usually need not be protected, except: |
402
|
|
|
|
|
|
|
# \" quotes the " whether inside "quoes" or bare (!) |
403
|
|
|
|
|
|
|
# \\ quotes the \ ONLY(?) if immediately followed by \" |
404
|
0
|
|
|
|
|
0
|
s/\\(?=")/\\\\/g; |
405
|
0
|
|
|
|
|
0
|
s/"/\\"/g; |
406
|
0
|
|
|
|
|
0
|
return "\"${_}\""; # 6/7/23: UNtested |
407
|
|
|
|
|
|
|
} else { |
408
|
|
|
|
|
|
|
# Prefer "double quoted" if no shell escapes would be needed. |
409
|
11
|
100
|
|
|
|
25
|
if (/["\$`!\\\x{00}-\x{1F}\x{7F}]/) { |
410
|
|
|
|
|
|
|
# Unlike Perl, /bin/sh does not recognize any backslash escapes in '...' |
411
|
1
|
|
|
|
|
5
|
s/'/'\\''/g; # foo'bar => foo'\''bar |
412
|
1
|
|
|
|
|
13
|
return "'${_}'"; |
413
|
|
|
|
|
|
|
} else { |
414
|
10
|
|
|
|
|
123
|
return "\"${_}\""; |
415
|
|
|
|
|
|
|
} |
416
|
|
|
|
|
|
|
} |
417
|
|
|
|
|
|
|
} |
418
|
|
|
|
|
|
|
sub qsh(_) { |
419
|
20
|
|
|
20
|
1
|
13044
|
local $_ = __stringify(shift()); |
420
|
20
|
100
|
100
|
|
|
231
|
defined && !ref && ($_ !~ _SHELL_UNSAFE_REGEX) |
421
|
|
|
|
|
|
|
&& $_ ne "" && $_ ne "undef" ? $_ : __forceqsh |
422
|
|
|
|
|
|
|
} |
423
|
|
|
|
|
|
|
sub qshpath(_) { # like qsh but does not quote initial ~ or ~username |
424
|
9
|
|
|
9
|
1
|
1349
|
local $_ = __stringify(shift()); |
425
|
9
|
50
|
33
|
|
|
50
|
return qsh($_) if !defined or ref; |
426
|
9
|
50
|
|
|
|
56
|
my ($tilde_prefix, $rest) = /^( (?:\~[^\/\\]*[\/\\]?+)? )(.*)/xs or die; |
427
|
9
|
100
|
|
|
|
49
|
$rest eq "" ? $tilde_prefix : $tilde_prefix.qsh($rest) |
428
|
|
|
|
|
|
|
} |
429
|
|
|
|
|
|
|
|
430
|
|
|
|
|
|
|
# Should this have been called 'aqsh' ? |
431
|
1
|
|
|
1
|
1
|
128
|
sub qshlist(@) { join " ", map{qsh} @_ } |
|
3
|
|
|
|
|
8
|
|
432
|
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
########### Subs callable as either a Function or Method ############# |
434
|
|
|
|
|
|
|
|
435
|
|
|
|
|
|
|
sub __getself { # Return $self if passed or else create a new object |
436
|
7297
|
|
|
7297
|
|
12007
|
local $@; |
437
|
7297
|
|
|
|
|
14197
|
my $blessed = eval{ blessed($_[0]) }; # In case a tie handler throws |
|
7297
|
|
|
|
|
26894
|
|
438
|
7297
|
50
|
|
|
|
20698
|
croak _chop_ateval($@) if $@; |
439
|
7297
|
100
|
100
|
|
|
84876
|
$blessed && $_[0]->isa(__PACKAGE__) ? shift : __PACKAGE__->new() |
440
|
|
|
|
|
|
|
} |
441
|
5564
|
|
|
5564
|
|
12775
|
sub __getself_s { &__getself->Values([$_[0]]) } |
442
|
320
|
|
|
320
|
|
960
|
sub __getself_a { &__getself->Values([[@_]]) } |
443
|
|
|
|
|
|
|
sub __getself_h { |
444
|
140
|
|
|
140
|
|
401
|
my $obj = &__getself; |
445
|
140
|
50
|
|
|
|
4710
|
($#_ % 2)==1 or croak "Uneven arg count for key => val pairs"; |
446
|
140
|
|
|
|
|
1072
|
$obj->Values([{@_}]) |
447
|
|
|
|
|
|
|
} |
448
|
|
|
|
|
|
|
|
449
|
|
|
|
|
|
|
sub _EnabSpacedots { |
450
|
|
|
|
|
|
|
# Append :spacedots to Useqq if Useqq matches the global default |
451
|
|
|
|
|
|
|
# (and if the default used extended options). |
452
|
1201
|
|
|
1201
|
|
454699
|
my $self = shift; |
453
|
1201
|
|
|
|
|
4351
|
my $curr = $self->Useqq; |
454
|
1201
|
50
|
50
|
|
|
49201
|
return $self if length($curr//"") <= 1 or $curr eq $Useqq; |
|
|
|
33
|
|
|
|
|
455
|
0
|
|
|
|
|
0
|
$self->Useqq($curr.":spacedots") |
456
|
|
|
|
|
|
|
} |
457
|
|
|
|
|
|
|
|
458
|
|
|
|
|
|
|
sub _generate_sub($;$) { |
459
|
|
|
|
|
|
|
my ($arg, $proto_only) = @_; |
460
|
|
|
|
|
|
|
(my $methname = $arg) =~ s/.*:://; |
461
|
|
|
|
|
|
|
my sub error($) { |
462
|
|
|
|
|
|
|
_croak_or_confess "Invalid sub/method name '$methname' (@_)\n" |
463
|
|
|
|
|
|
|
} |
464
|
|
|
|
|
|
|
|
465
|
|
|
|
|
|
|
# Method names are ivis, dvis, vis, avis, or hvis with prepended |
466
|
|
|
|
|
|
|
# or appended modifier letters or digits (in any order), with |
467
|
|
|
|
|
|
|
# optional underscore separators. |
468
|
|
|
|
|
|
|
local $_ = $methname; |
469
|
|
|
|
|
|
|
|
470
|
|
|
|
|
|
|
s/alvis/avisl/; # backwards compat. |
471
|
|
|
|
|
|
|
s/hlvis/hvisl/; # backwards compat. |
472
|
|
|
|
|
|
|
|
473
|
|
|
|
|
|
|
s/^[^diha]*\K(?:lvis|visl)/avisl/; # 'visl' same as 'avisl' for bw compat. |
474
|
|
|
|
|
|
|
|
475
|
|
|
|
|
|
|
s/([ahid]?vis)// or error "can not infer the basic function"; |
476
|
|
|
|
|
|
|
my $basename = $1; # avis, hvis, ivis, dvis, or vis |
477
|
|
|
|
|
|
|
my $N = s/(\d+)// ? $1 : undef; |
478
|
|
|
|
|
|
|
my %mod = map{$_ => 1} split //, $_; |
479
|
|
|
|
|
|
|
delete $mod{"_"}; # ignore underscores |
480
|
|
|
|
|
|
|
|
481
|
|
|
|
|
|
|
if (($Debug//0) > 1) { |
482
|
|
|
|
|
|
|
warn "## (D=$Debug) methname=$methname base=$basename \$_=$_\n"; |
483
|
|
|
|
|
|
|
} |
484
|
|
|
|
|
|
|
if ($basename =~ /^[id]/) { |
485
|
|
|
|
|
|
|
error "'$1' is inapplicable to $basename" if /([ahl])/; |
486
|
|
|
|
|
|
|
} |
487
|
|
|
|
|
|
|
error "'$1' mis-placed: Only allowed as '${1}vis'" if /([ahi])/; |
488
|
|
|
|
|
|
|
|
489
|
|
|
|
|
|
|
|
490
|
|
|
|
|
|
|
# All these subs can be called as either or methods or functions. |
491
|
|
|
|
|
|
|
# If the first argument is an object it is used, otherwise a new object |
492
|
|
|
|
|
|
|
# is created; then option-setting methods are called as implied by |
493
|
|
|
|
|
|
|
# the specific sub name. |
494
|
|
|
|
|
|
|
# |
495
|
|
|
|
|
|
|
# Finally the _Do() method is invoked for primatives like 'vis'. |
496
|
|
|
|
|
|
|
# |
497
|
|
|
|
|
|
|
# For ivis/dvis, control jumps to _Interpolate() which uses the object |
498
|
|
|
|
|
|
|
# repeatedly when calling primatives to interpolate values into the string. |
499
|
|
|
|
|
|
|
|
500
|
|
|
|
|
|
|
my $listform = ''; |
501
|
|
|
|
|
|
|
my $signature = $basename =~ /^[ah]/ ? '@' : '_'; # avis(@) ivis(_) vis(_) |
502
|
|
|
|
|
|
|
my $code = "sub $methname($signature)"; |
503
|
|
|
|
|
|
|
if ($proto_only) { |
504
|
|
|
|
|
|
|
$code .= ";"; |
505
|
|
|
|
|
|
|
} else { |
506
|
|
|
|
|
|
|
if ($basename eq "vis") { |
507
|
|
|
|
|
|
|
$code .= " { &__getself_s->_Listform('')"; |
508
|
|
|
|
|
|
|
} |
509
|
|
|
|
|
|
|
elsif ($basename eq "avis") { |
510
|
|
|
|
|
|
|
my $listform = delete($mod{l}) ? 'l' : 'a'; |
511
|
|
|
|
|
|
|
$code .= " { &__getself_a->_Listform('$listform')"; |
512
|
|
|
|
|
|
|
} |
513
|
|
|
|
|
|
|
elsif ($basename eq "hvis") { |
514
|
|
|
|
|
|
|
my $listform = delete($mod{l}) ? 'l' : 'h'; |
515
|
|
|
|
|
|
|
$code .= " { &__getself_h->_Listform('$listform')"; |
516
|
|
|
|
|
|
|
} |
517
|
|
|
|
|
|
|
elsif ($basename eq "ivis") { |
518
|
|
|
|
|
|
|
$code .= " { \@_ = ( &__getself" ; |
519
|
|
|
|
|
|
|
} |
520
|
|
|
|
|
|
|
elsif ($basename eq "dvis") { |
521
|
|
|
|
|
|
|
$code .= " { \@_ = ( &__getself->_EnabSpacedots" ; |
522
|
|
|
|
|
|
|
} |
523
|
|
|
|
|
|
|
else { oops } |
524
|
|
|
|
|
|
|
|
525
|
|
|
|
|
|
|
$code .= "->Maxdepth($N)" if defined($N); |
526
|
|
|
|
|
|
|
$code .= '->Objects(0)' if delete $mod{o}; |
527
|
|
|
|
|
|
|
$code .= '->Useqq(0)' if delete $mod{q}; |
528
|
|
|
|
|
|
|
$code .= '->Useqq("unicode:controlpics")' if delete $mod{c}; |
529
|
|
|
|
|
|
|
$code .= '->Refaddr(1)' if delete $mod{r}; |
530
|
|
|
|
|
|
|
$code .= '->Debug(2)' if delete $mod{d}; |
531
|
|
|
|
|
|
|
|
532
|
|
|
|
|
|
|
if ($basename =~ /^([id])vis/) { |
533
|
|
|
|
|
|
|
$code .= ", shift, '$1' ); goto &_Interpolate }"; |
534
|
|
|
|
|
|
|
} else { |
535
|
|
|
|
|
|
|
$code .= "->_Do }"; |
536
|
|
|
|
|
|
|
} |
537
|
|
|
|
|
|
|
|
538
|
|
|
|
|
|
|
for (keys %mod) { error "Unknown or inappropriate modifier '$_'" } |
539
|
|
|
|
|
|
|
} |
540
|
|
|
|
|
|
|
|
541
|
|
|
|
|
|
|
# To see the generated code |
542
|
|
|
|
|
|
|
# use Data::Dumper::Interp qw/:debug :DEFAULT/; # or :all |
543
|
|
|
|
|
|
|
if ($Debug) { |
544
|
|
|
|
|
|
|
warn "# generated: $code\n"; |
545
|
|
|
|
|
|
|
} |
546
|
54
|
|
|
54
|
1
|
30104
|
eval "$code"; oops "code=$code\n\$@=$@" if $@; |
|
54
|
|
|
6918
|
1
|
25849
|
|
|
6918
|
|
|
99
|
0
|
677438
|
|
|
1219
|
|
|
129
|
1
|
38887
|
|
|
67
|
|
|
46
|
0
|
34853
|
|
|
67
|
|
|
17
|
0
|
16001
|
|
|
103
|
|
|
17
|
0
|
15878
|
|
|
20
|
|
|
|
|
12603
|
|
|
17
|
|
|
|
|
12793
|
|
|
17
|
|
|
|
|
11388
|
|
547
|
|
|
|
|
|
|
}#_generate_sub |
548
|
|
|
|
|
|
|
|
549
|
|
|
|
|
|
|
|
550
|
41
|
|
|
41
|
1
|
34439
|
sub visnew() { __PACKAGE__->new() } # shorthand |
551
|
|
|
|
|
|
|
|
552
|
|
|
|
|
|
|
|
553
|
|
|
|
|
|
|
############# only internals follow ############ |
554
|
|
|
|
|
|
|
|
555
|
|
|
|
|
|
|
BEGIN { |
556
|
9
|
50
|
|
9
|
|
4878
|
if (! Data::Dumper->can("Maxrecurse")) { |
557
|
|
|
|
|
|
|
# Supply if missing in older Data::Dumper |
558
|
0
|
|
|
|
|
0
|
eval q(sub Data::Dumper::Maxrecurse { |
559
|
|
|
|
|
|
|
my($s, $v) = @_; |
560
|
|
|
|
|
|
|
@_ == 2 ? (($s->{Maxrecurse} = $v), return $s) |
561
|
|
|
|
|
|
|
: $s->{Maxrecurse}//0; |
562
|
|
|
|
|
|
|
}); |
563
|
0
|
0
|
|
|
|
0
|
die $@ if $@; |
564
|
|
|
|
|
|
|
} |
565
|
|
|
|
|
|
|
} |
566
|
|
|
|
|
|
|
|
567
|
|
|
|
|
|
|
sub _get_terminal_width() { # returns undef if unknowable |
568
|
27
|
100
|
|
10
|
|
176
|
if (u($ENV{COLUMNS}) =~ /^[1-9]\d*$/) { |
569
|
2
|
|
|
|
|
24
|
return $ENV{COLUMNS}; # overrides actual terminal width |
570
|
|
|
|
|
|
|
} else { |
571
|
8
|
|
|
|
|
50
|
local *_; # Try to avoid clobbering special filehandle "_" |
572
|
|
|
|
|
|
|
# This does not actualy work; https://github.com/Perl/perl5/issues/19142 |
573
|
|
|
|
|
|
|
|
574
|
|
|
|
|
|
|
my $fh = -t STDERR ? *STDERR : |
575
|
|
|
|
|
|
|
-t STDOUT ? *STDOUT : |
576
|
|
|
|
|
|
|
-t STDIN ? *STDIN : |
577
|
8
|
50
|
|
|
|
121
|
do{my $fh; for("/dev/tty",'CONOUT$') { last if open $fh, $_ } $fh} ; |
|
8
|
50
|
|
|
|
33
|
|
|
8
|
50
|
|
|
|
26
|
|
|
16
|
50
|
|
|
|
2299
|
|
|
8
|
|
|
|
|
70
|
|
578
|
8
|
|
|
|
|
64
|
my $wmsg = ""; # Suppress a "didn't work" warning from Term::ReadKey. |
579
|
|
|
|
|
|
|
# On some platforms (different libc?) "stty" directly |
580
|
|
|
|
|
|
|
# outputs "stdin is not a tty" which we can not trap. |
581
|
|
|
|
|
|
|
# Probably this is a Term::Readkey bug where it should |
582
|
|
|
|
|
|
|
# redirect such messages to /dev/null... |
583
|
8
|
|
|
|
|
26
|
my ($width, $height) = do { |
584
|
8
|
|
|
8
|
|
149
|
local $SIG{'__WARN__'} = sub { $wmsg .= $_[0] }; |
|
8
|
|
|
|
|
105757
|
|
585
|
8
|
50
|
|
|
|
99
|
$fh ? Term::ReadKey::GetTerminalSize($fh) : () |
586
|
|
|
|
|
|
|
}; |
587
|
8
|
|
|
|
|
843
|
return $width; # possibly undef (sometimes seems to be zero ?!?) |
588
|
|
|
|
|
|
|
} |
589
|
|
|
|
|
|
|
} |
590
|
|
|
|
|
|
|
|
591
|
|
|
|
|
|
|
sub _set_default_Foldwidth() { |
592
|
10
|
|
|
10
|
|
52
|
_SaveAndResetPunct(); |
593
|
10
|
|
100
|
|
|
60
|
$Foldwidth = _get_terminal_width || 80; |
594
|
10
|
|
|
|
|
213
|
_RestorePunct(); |
595
|
10
|
|
|
|
|
97
|
undef $Foldwidth1; |
596
|
|
|
|
|
|
|
} |
597
|
|
|
|
|
|
|
|
598
|
9
|
|
|
9
|
|
76
|
use constant _UNIQUE => substr(refaddr \&oops,-5); |
|
9
|
|
|
|
|
22
|
|
|
9
|
|
|
|
|
1698
|
|
599
|
|
|
|
|
|
|
use constant { |
600
|
9
|
|
|
|
|
19
|
_MAGIC_NOQUOTES_PFX => "|NQMagic${\_UNIQUE}|", |
|
9
|
|
|
|
|
27
|
|
601
|
9
|
|
|
|
|
27
|
_MAGIC_KEEPQUOTES_PFX => "|KQMagic${\_UNIQUE}|", |
602
|
9
|
|
|
|
|
18
|
_MAGIC_REFPFX => "|RPMagic${\_UNIQUE}|", |
603
|
9
|
|
|
|
|
11526
|
_MAGIC_ELIDE_NEXT => "|ENMagic${\_UNIQUE}|", |
604
|
9
|
|
|
9
|
|
76
|
}; |
|
9
|
|
|
|
|
21
|
|
605
|
|
|
|
|
|
|
|
606
|
|
|
|
|
|
|
#--------------------------------------------------------------------------- |
607
|
|
|
|
|
|
|
my $my_maxdepth; |
608
|
|
|
|
|
|
|
our $my_visit_depth = 0; |
609
|
|
|
|
|
|
|
|
610
|
|
|
|
|
|
|
my ($maxstringwidth, $truncsuffix, $objects, $opt_refaddr, $listform, $debug); |
611
|
|
|
|
|
|
|
my ($sortkeys); |
612
|
|
|
|
|
|
|
|
613
|
|
|
|
|
|
|
sub _Do { |
614
|
6024
|
50
|
|
6024
|
|
15176
|
oops unless @_ == 1; |
615
|
6024
|
|
|
|
|
10502
|
my $self = $_[0]; |
616
|
|
|
|
|
|
|
|
617
|
6024
|
|
|
|
|
10481
|
local $_; |
618
|
6024
|
|
|
|
|
15529
|
&_SaveAndResetPunct; |
619
|
|
|
|
|
|
|
|
620
|
|
|
|
|
|
|
($maxstringwidth, $truncsuffix, $objects, $opt_refaddr, $listform, $debug) |
621
|
6024
|
|
|
|
|
24488
|
= @$self{qw/MaxStringwidth Truncsuffix Objects Refaddr _Listform Debug/}; |
622
|
6024
|
|
|
|
|
20442
|
$sortkeys = $self->Sortkeys; |
623
|
|
|
|
|
|
|
|
624
|
6024
|
50
|
100
|
|
|
96740
|
$maxstringwidth = 0 if ($maxstringwidth //= 0) >= INT_MAX; |
625
|
6024
|
|
50
|
|
|
13902
|
$truncsuffix //= "..."; |
626
|
6024
|
100
|
100
|
|
|
22430
|
$objects = [ $objects ] unless ref($objects //= []) eq 'ARRAY'; |
627
|
|
|
|
|
|
|
|
628
|
6024
|
|
|
|
|
160622
|
my @orig_values = $self->dd->Values; |
629
|
6024
|
50
|
|
|
|
60352
|
croak "Exactly one item may be in Values" if @orig_values != 1; |
630
|
6024
|
|
|
|
|
11945
|
my $original = $orig_values[0]; |
631
|
6024
|
50
|
|
|
|
13462
|
btw "##ORIGINAL=",u($original),"=",_dbvis($original) if $debug; |
632
|
|
|
|
|
|
|
|
633
|
6024
|
50
|
|
|
|
13034
|
_croak_or_confess "*vis($original) called in void context.\nDid you forget to 'say ...'?" |
634
|
|
|
|
|
|
|
if ! defined wantarray; |
635
|
|
|
|
|
|
|
|
636
|
|
|
|
|
|
|
# Allow one extra level if we wrapped the user's args in __getself_[ah] |
637
|
6024
|
|
100
|
|
|
17279
|
$my_maxdepth = $self->Maxdepth || INT_MAX; |
638
|
6024
|
50
|
66
|
|
|
100084
|
++$my_maxdepth if $listform && $my_maxdepth < INT_MAX; |
639
|
|
|
|
|
|
|
|
640
|
6024
|
50
|
|
|
|
13294
|
oops unless $my_visit_depth == 0; |
641
|
6024
|
|
|
|
|
18852
|
my $modified = $self->visit($original); # see Data::Visitor |
642
|
|
|
|
|
|
|
|
643
|
6024
|
50
|
|
|
|
39384
|
btw "## DD input : ",_dbvis($modified) if $debug; |
644
|
6024
|
|
|
|
|
178587
|
$self->dd->Values([$modified]); |
645
|
|
|
|
|
|
|
|
646
|
|
|
|
|
|
|
# Always call Data::Dumper with Indent(0) and Pad("") to get a single |
647
|
|
|
|
|
|
|
# maximally-compact string, and then manually fold the result to Foldwidth, |
648
|
|
|
|
|
|
|
# inserting the user's Pad before each line *except* the first. |
649
|
|
|
|
|
|
|
# |
650
|
|
|
|
|
|
|
# Also disable Maxdepth because we handle that ourself (see visit_ref). |
651
|
6024
|
|
|
|
|
70974
|
my $users_Maxdepth = $self->Maxdepth; # implemented by D::D |
652
|
6024
|
|
|
|
|
85265
|
$self->Maxdepth(0); |
653
|
6024
|
|
|
|
|
16212
|
my $users_pad = $self->Pad(); |
654
|
6024
|
|
|
|
|
89342
|
$self->Pad(""); |
655
|
|
|
|
|
|
|
|
656
|
6024
|
|
|
|
|
10837
|
my ($dd_result, $our_result); |
657
|
6024
|
|
|
|
|
15593
|
my ($sAt, $sQ) = ($@, $?); |
658
|
6024
|
|
|
|
|
9196
|
{ my $dd_warning = ""; |
|
6024
|
|
|
|
|
9668
|
|
659
|
|
|
|
|
|
|
|
660
|
6024
|
|
|
0
|
|
8862
|
{ local $SIG{__WARN__} = sub{ $dd_warning .= $_[0] }; |
|
6024
|
|
|
|
|
38912
|
|
|
0
|
|
|
|
|
0
|
|
661
|
6024
|
|
|
|
|
12765
|
eval{ $dd_result = $self->dd->Dump }; |
|
6024
|
|
|
|
|
162631
|
|
662
|
|
|
|
|
|
|
} |
663
|
6024
|
50
|
33
|
|
|
148625
|
if ($dd_warning || $@) { |
664
|
0
|
0
|
|
|
|
0
|
warn "Data::Dumper complained:\n$dd_warning\n$@" if $debug; |
665
|
0
|
|
|
|
|
0
|
($@, $?) = ($sAt, $sQ); |
666
|
0
|
|
|
|
|
0
|
$our_result = $self->dd->Values([$original])->Dump; |
667
|
|
|
|
|
|
|
} |
668
|
|
|
|
|
|
|
} |
669
|
6024
|
|
|
|
|
16564
|
($@, $?) = ($sAt, $sQ); |
670
|
6024
|
|
|
|
|
19896
|
$self->Pad($users_pad); |
671
|
6024
|
|
|
|
|
19445
|
$self->Maxdepth($users_Maxdepth); |
672
|
|
|
|
|
|
|
|
673
|
6024
|
|
66
|
|
|
100836
|
$our_result //= $self->_postprocess_DD_result($dd_result, $original); |
674
|
|
|
|
|
|
|
|
675
|
|
|
|
|
|
|
# Allow deletion of the possibly-recursive clone |
676
|
6024
|
|
|
|
|
26637
|
circular_off($modified); |
677
|
6024
|
|
|
|
|
244798
|
$self->dd->Values([]); |
678
|
|
|
|
|
|
|
|
679
|
6024
|
|
|
|
|
71641
|
&_RestorePunct; |
680
|
6024
|
|
|
|
|
39466
|
$our_result; |
681
|
|
|
|
|
|
|
} |
682
|
|
|
|
|
|
|
|
683
|
|
|
|
|
|
|
#---------------------------------------------------------------------------- |
684
|
|
|
|
|
|
|
# methods called from Data::Visitor (and helpers) when transforming the input |
685
|
|
|
|
|
|
|
|
686
|
|
|
|
|
|
|
our $in_overload_replacement = 0; |
687
|
|
|
|
|
|
|
|
688
|
|
|
|
|
|
|
sub _prefix_refaddr($;$) { |
689
|
2008
|
|
|
2008
|
|
3570
|
my ($item, $original) = @_; |
690
|
|
|
|
|
|
|
# If enabled by Refaddr(true): |
691
|
|
|
|
|
|
|
# |
692
|
|
|
|
|
|
|
# Prefix (the formatted representation of) a ref with it's abbreviated |
693
|
|
|
|
|
|
|
# address. This is done by wrapping the ref in a temporary [array] with the |
694
|
|
|
|
|
|
|
# prefix, and unwrapping the Data::Dumper result in _postprocess_DD_result(). |
695
|
2008
|
100
|
66
|
|
|
5560
|
return $item |
|
|
50
|
66
|
|
|
|
|
696
|
|
|
|
|
|
|
unless $opt_refaddr |
697
|
|
|
|
|
|
|
&& ! $in_overload_replacement |
698
|
|
|
|
|
|
|
&& ($listform ? ($my_visit_depth > 0) # Not on our argument container |
699
|
|
|
|
|
|
|
: 1); # Else always if not a (list) |
700
|
37
|
|
33
|
|
|
143
|
my $pfx = addrvis(refaddr($original//$item)); |
701
|
37
|
|
|
|
|
105
|
my $ix = index($item,$pfx); |
702
|
37
|
50
|
|
|
|
387
|
say "_prefix_refaddr: ior=$in_overload_replacement pfx=$pfx ix=$ix original=",_dbvis1($original)," item=$item" if $debug; |
703
|
|
|
|
|
|
|
# However don't do this if $item already has an addrvis() substituted, |
704
|
|
|
|
|
|
|
# which happens if an object does not stringify or provide another overload |
705
|
|
|
|
|
|
|
# replacement -- see _object_subst(). |
706
|
37
|
50
|
|
|
|
83
|
return $item if $ix >= 0; |
707
|
37
|
|
|
|
|
114
|
$item = [ _MAGIC_REFPFX.$pfx, $item, _MAGIC_ELIDE_NEXT ]; |
708
|
37
|
50
|
|
|
|
80
|
btwN 1, '@@@addrvis-prefixed object:',_dbvis2($item) if $debug; |
709
|
37
|
|
|
|
|
73
|
$item |
710
|
|
|
|
|
|
|
}#_prefix_refaddr |
711
|
|
|
|
|
|
|
|
712
|
|
|
|
|
|
|
sub _object_subst($) { |
713
|
319
|
|
|
319
|
|
610
|
my $item = shift; |
714
|
319
|
|
|
|
|
570
|
my $overload_depth; |
715
|
|
|
|
|
|
|
CHECKObject: { |
716
|
319
|
100
|
|
|
|
500
|
if (my $class = blessed($item)) { |
|
479
|
|
|
|
|
1587
|
|
717
|
319
|
50
|
|
|
|
1094
|
btw '@@@repl item is obj ',$item if $debug; |
718
|
319
|
|
|
|
|
657
|
my $enabled; |
719
|
|
|
|
|
|
|
OSPEC: |
720
|
319
|
|
|
|
|
733
|
foreach my $ospec (@$objects) { |
721
|
362
|
100
|
|
|
|
1211
|
if (ref($ospec) eq "Regexp") { |
722
|
46
|
|
|
|
|
99
|
my @stack = ($class); |
723
|
46
|
|
|
|
|
71
|
my %seen; |
724
|
46
|
|
|
|
|
101
|
while (my $c = shift @stack) { |
725
|
78
|
100
|
|
|
|
484
|
$enabled=1, last OSPEC if $c =~ $ospec; |
726
|
48
|
50
|
|
|
|
138
|
last CHECKObject if $seen{$c}++; # circular ISAs ! |
727
|
9
|
|
|
9
|
|
76
|
no strict 'refs'; |
|
9
|
|
|
|
|
23
|
|
|
9
|
|
|
|
|
23253
|
|
728
|
48
|
|
|
|
|
69
|
push @stack, @{"${c}::ISA"}; |
|
48
|
|
|
|
|
240
|
|
729
|
|
|
|
|
|
|
} |
730
|
|
|
|
|
|
|
} else { |
731
|
316
|
100
|
100
|
|
|
1548
|
$enabled=1, last OSPEC if ($ospec eq "1" || $item->isa($ospec)); |
732
|
|
|
|
|
|
|
} |
733
|
|
|
|
|
|
|
} |
734
|
|
|
|
|
|
|
last CHECKObject |
735
|
319
|
100
|
|
|
|
2184
|
unless $enabled; |
736
|
299
|
100
|
|
|
|
1024
|
if (overload::Overloaded($item)) { |
737
|
160
|
50
|
|
|
|
9624
|
btw '@@@repl obj is overloaded' if $debug; |
738
|
|
|
|
|
|
|
# N.B. Overloaded(...) also returns true if it's a NAME of an |
739
|
|
|
|
|
|
|
# overloaded package; should not happen in this case. |
740
|
160
|
50
|
|
|
|
442
|
warn("Recursive overloads on $item ?\n"),last |
741
|
|
|
|
|
|
|
if $overload_depth++ > 10; |
742
|
|
|
|
|
|
|
# Stringify objects which have the stringification operator |
743
|
160
|
100
|
|
|
|
386
|
if (overload::Method($class,'""')) { |
744
|
155
|
50
|
|
|
|
5609
|
my $prefix = _show_as_number($item) ? _MAGIC_NOQUOTES_PFX : ""; |
745
|
155
|
50
|
|
|
|
342
|
btw '@@@repl prefix="',$prefix,'"' if $debug; |
746
|
155
|
|
|
|
|
476
|
$item = $item.""; # stringify; |
747
|
155
|
50
|
|
|
|
9308
|
if ($item !~ /^${class}=REF/) { |
748
|
155
|
|
|
|
|
497
|
$item = "${prefix}($class)$item"; |
749
|
|
|
|
|
|
|
} else { |
750
|
|
|
|
|
|
|
# The "stringification" looks like Perl's default; don't prefix it |
751
|
|
|
|
|
|
|
} |
752
|
155
|
50
|
|
|
|
327
|
btw '@@@repl stringified:',$item if $debug; |
753
|
155
|
|
|
|
|
498
|
redo CHECKObject; |
754
|
|
|
|
|
|
|
} |
755
|
|
|
|
|
|
|
# Substitute the virtual value behind an overloaded deref operator |
756
|
|
|
|
|
|
|
# and prefix with (classname) to make clear what happened. |
757
|
5
|
100
|
|
|
|
153
|
if (overload::Method($class,'@{}')) { |
758
|
|
|
|
|
|
|
#$item = \@{ $item }; |
759
|
1
|
|
|
|
|
49
|
$item = [ _MAGIC_REFPFX."($class)", \@{ $item }, _MAGIC_ELIDE_NEXT ]; |
|
1
|
|
|
|
|
30
|
|
760
|
1
|
50
|
|
|
|
11
|
btw '@@@repl (overload @{} --> ', $item,')' if $debug; |
761
|
1
|
|
|
|
|
3
|
redo CHECKObject; |
762
|
|
|
|
|
|
|
} |
763
|
4
|
100
|
|
|
|
99
|
if (overload::Method($class,'%{}')) { |
764
|
|
|
|
|
|
|
#$item = \%{ $item }; |
765
|
1
|
|
|
|
|
46
|
$item = [ _MAGIC_REFPFX."($class)", \%{ $item }, _MAGIC_ELIDE_NEXT ]; |
|
1
|
|
|
|
|
26
|
|
766
|
1
|
50
|
|
|
|
35
|
btw '@@@repl (overload %{} --> ', $item,')' if $debug; |
767
|
1
|
|
|
|
|
4
|
redo CHECKObject; |
768
|
|
|
|
|
|
|
} |
769
|
3
|
100
|
|
|
|
70
|
if (overload::Method($class,'${}')) { |
770
|
|
|
|
|
|
|
#$item = \${ $item }; |
771
|
1
|
|
|
|
|
34
|
$item = [ _MAGIC_REFPFX."($class)", \${ $item }, _MAGIC_ELIDE_NEXT ]; |
|
1
|
|
|
|
|
27
|
|
772
|
1
|
50
|
|
|
|
9
|
btw '@@@repl (overload ${} --> ', $item,')' if $debug; |
773
|
1
|
|
|
|
|
3
|
redo CHECKObject; |
774
|
|
|
|
|
|
|
} |
775
|
2
|
100
|
|
|
|
50
|
if (overload::Method($class,'&{}')) { |
776
|
|
|
|
|
|
|
#$item = \&{ $item }; |
777
|
1
|
|
|
|
|
39
|
$item = [ _MAGIC_REFPFX."($class)", \&{ $item }, _MAGIC_ELIDE_NEXT ]; |
|
1
|
|
|
|
|
28
|
|
778
|
1
|
50
|
|
|
|
14
|
btw '@@@repl (overload &{} --> ', $item,')' if $debug; |
779
|
1
|
|
|
|
|
4
|
redo CHECKObject; |
780
|
|
|
|
|
|
|
} |
781
|
1
|
50
|
|
|
|
33
|
if (overload::Method($class,'*{}')) { |
782
|
|
|
|
|
|
|
#$item = \*{ $item }; |
783
|
1
|
|
|
|
|
35
|
$item = [ _MAGIC_REFPFX."($class)", \*{ $item }, _MAGIC_ELIDE_NEXT ]; |
|
1
|
|
|
|
|
26
|
|
784
|
1
|
50
|
|
|
|
9
|
btw '@@@repl (overload *{} --> ', $item,')' if $debug; |
785
|
1
|
|
|
|
|
4
|
redo CHECKObject; |
786
|
|
|
|
|
|
|
} |
787
|
|
|
|
|
|
|
} |
788
|
139
|
100
|
|
|
|
8197
|
if ($class eq 'Regexp') { |
789
|
|
|
|
|
|
|
# D::D will just stringify it, which is fine except actual tabs etc. |
790
|
|
|
|
|
|
|
# will be shown as themselves and not \t etc. |
791
|
|
|
|
|
|
|
# We try to fix that in _postprocess_DD_result; |
792
|
|
|
|
|
|
|
} else { |
793
|
|
|
|
|
|
|
# No overloaded operator (that we care about); |
794
|
|
|
|
|
|
|
# substitute addrvis(obj) |
795
|
1
|
50
|
|
|
|
4
|
btw '@@@repl (no overload repl, not Regexp)' if $debug; |
796
|
1
|
|
|
|
|
13
|
$item = _MAGIC_NOQUOTES_PFX.addrvis($item); |
797
|
|
|
|
|
|
|
} |
798
|
|
|
|
|
|
|
} |
799
|
|
|
|
|
|
|
}#CHECKObject |
800
|
|
|
|
|
|
|
$item |
801
|
319
|
|
|
|
|
1401
|
}#_object_subst |
802
|
|
|
|
|
|
|
|
803
|
|
|
|
|
|
|
sub visit_value { |
804
|
8376
|
|
|
8376
|
1
|
211934
|
my $self = shift; |
805
|
8376
|
50
|
|
|
|
17928
|
say "!V value ",_dbravis2(@_)," depth:$my_visit_depth" if $debug; |
806
|
8376
|
|
|
|
|
13379
|
my $item = shift; |
807
|
|
|
|
|
|
|
# N.B. Not called for hash keys (short-circuited in visit_hash_key) |
808
|
|
|
|
|
|
|
|
809
|
8376
|
100
|
|
|
|
16821
|
return $item |
810
|
|
|
|
|
|
|
if !defined($item); |
811
|
|
|
|
|
|
|
|
812
|
8359
|
100
|
|
|
|
22775
|
return _object_subst($item) |
813
|
|
|
|
|
|
|
if defined(blessed $item); |
814
|
|
|
|
|
|
|
|
815
|
8040
|
100
|
|
|
|
20504
|
return $item |
816
|
|
|
|
|
|
|
if reftype($item); # some other (i.e. not blessed) reference |
817
|
|
|
|
|
|
|
|
818
|
|
|
|
|
|
|
# Prepend a "magic prefix" (later removed) to items which Data::Dumper is |
819
|
|
|
|
|
|
|
# likely to represent wrongly or anyway not how we want: |
820
|
|
|
|
|
|
|
# |
821
|
|
|
|
|
|
|
# 1. Scalars set to strings like "6" will come out as a number 6 rather |
822
|
|
|
|
|
|
|
# than "6" with Useqq(1) or Useperl(1) (string-ness is preserved |
823
|
|
|
|
|
|
|
# with other options). IMO this is a Data::Dumper bug which the |
824
|
|
|
|
|
|
|
# maintainers won't fix it because the difference isn't functionally |
825
|
|
|
|
|
|
|
# relevant to correctly-written Perl code. However we want to help |
826
|
|
|
|
|
|
|
# humans debug their software by showing the representation they |
827
|
|
|
|
|
|
|
# most likely used to create the datum. |
828
|
|
|
|
|
|
|
# |
829
|
|
|
|
|
|
|
# 2. Floating point values come out as "strings" to avoid some |
830
|
|
|
|
|
|
|
# cross-platform issue. For our purposes we want all numbers |
831
|
|
|
|
|
|
|
# to appear unquoted. |
832
|
|
|
|
|
|
|
# |
833
|
8037
|
100
|
66
|
|
|
40473
|
if (looks_like_number($item) && $item !~ /^0\d/) { |
|
|
100
|
66
|
|
|
|
|
|
|
|
100
|
|
|
|
|
834
|
3011
|
100
|
|
|
|
7060
|
my $prefix = _show_as_number($item) ? _MAGIC_NOQUOTES_PFX |
835
|
|
|
|
|
|
|
: _MAGIC_KEEPQUOTES_PFX ; |
836
|
3011
|
|
|
|
|
7167
|
$item = $prefix.$item; |
837
|
3011
|
50
|
|
|
|
7321
|
btw '@@@repl prefixed item:',$item if $debug; |
838
|
|
|
|
|
|
|
} |
839
|
|
|
|
|
|
|
|
840
|
|
|
|
|
|
|
# Truncacte overly-long strings |
841
|
|
|
|
|
|
|
elsif ($maxstringwidth && !_show_as_number($item) |
842
|
|
|
|
|
|
|
&& length($item) > $maxstringwidth + length($truncsuffix)) { |
843
|
9
|
50
|
|
|
|
20
|
btw '@@@repl truncating ',substr($item,0,10),"..." if $debug; |
844
|
9
|
|
|
|
|
24
|
$item = "".substr($item,0,$maxstringwidth).$truncsuffix; |
845
|
|
|
|
|
|
|
} |
846
|
|
|
|
|
|
|
$item |
847
|
8037
|
|
|
|
|
25672
|
}#visit_value |
848
|
|
|
|
|
|
|
|
849
|
|
|
|
|
|
|
sub visit_hash_key { |
850
|
1521
|
|
|
1521
|
1
|
12681
|
my ($self, $item) = @_; |
851
|
1521
|
50
|
|
|
|
3181
|
say "!V visit_hash_key ",_dbravis2($item)," depth:$my_visit_depth" if $debug; |
852
|
1521
|
|
|
|
|
4567
|
return $item; # don't truncate or otherwise munge |
853
|
|
|
|
|
|
|
} |
854
|
|
|
|
|
|
|
|
855
|
|
|
|
|
|
|
sub visit_object { |
856
|
319
|
|
|
319
|
1
|
11120
|
my $self = shift; |
857
|
319
|
|
|
|
|
559
|
my $item = shift; |
858
|
319
|
50
|
|
|
|
760
|
say "!V object a=",addrvis(refaddr $item)," depth:$my_visit_depth"," item=",_dbvis1($item) if $debug; |
859
|
319
|
|
|
|
|
663
|
my $original = $item; |
860
|
|
|
|
|
|
|
|
861
|
319
|
|
|
|
|
601
|
local $my_visit_depth = $my_visit_depth + 1; |
862
|
|
|
|
|
|
|
# FIXME: with Objects(0) we should visit object internals so $my_maxdepth |
863
|
|
|
|
|
|
|
# can be applied correctly. Currently we just leave object refs as-is |
864
|
|
|
|
|
|
|
# for D::D to expand, and Maxdepth will be handled incorrectly if this |
865
|
|
|
|
|
|
|
# is underneath a magic_refaddr wrapper or avis/hvis top wrapper. |
866
|
|
|
|
|
|
|
|
867
|
|
|
|
|
|
|
# First register the ref (to detect duplicates); this calls visit_seen() |
868
|
|
|
|
|
|
|
# which usually substitutes something. |
869
|
|
|
|
|
|
|
{ # Suppress Refaddr treatment of the results of any overloads |
870
|
319
|
|
|
|
|
497
|
local $in_overload_replacement = $in_overload_replacement + 1; |
|
319
|
|
|
|
|
593
|
|
871
|
319
|
|
|
|
|
926
|
my $nitem = $self->SUPER::visit_object($item); |
872
|
|
|
|
|
|
|
# Can compare object refs with != in case that op is not defined! |
873
|
319
|
100
|
|
|
|
4128
|
if (u(refaddr($nitem)) ne u(refaddr($item))) { |
874
|
161
|
50
|
|
|
|
373
|
say "! (obj) new: $item --> ",_dbvis2($nitem) if $debug; |
875
|
161
|
|
|
|
|
246
|
$item = $nitem; |
876
|
|
|
|
|
|
|
# Re-visit the replacement item, which might contain inner structure. |
877
|
161
|
|
|
|
|
503
|
$nitem = $self->SUPER::visit($item); |
878
|
161
|
50
|
|
|
|
1309
|
say "! (obj) recursion on repl: $item --> $nitem" if $debug; |
879
|
161
|
|
|
|
|
319
|
$item = $nitem; |
880
|
|
|
|
|
|
|
} |
881
|
|
|
|
|
|
|
} |
882
|
319
|
|
|
|
|
831
|
$item = _prefix_refaddr($item, $original); |
883
|
319
|
|
|
|
|
1087
|
$item |
884
|
|
|
|
|
|
|
}#visit_object |
885
|
|
|
|
|
|
|
|
886
|
|
|
|
|
|
|
sub visit_ref { |
887
|
1689
|
|
|
1689
|
1
|
58456
|
my ($self, $item) = @_; |
888
|
1689
|
100
|
|
|
|
4548
|
if (ref($item) eq 'ARRAY') { |
889
|
552
|
50
|
|
|
|
1624
|
say "!V ref A=",addrvis(refaddr $item)," depth:$my_visit_depth max:$my_maxdepth item=",_dbavis2(@$item) if $debug; |
890
|
|
|
|
|
|
|
} else { |
891
|
1137
|
50
|
|
|
|
2574
|
say "!V ref a=",addrvis(refaddr $item)," depth:$my_visit_depth max:$my_maxdepth item=",_dbvis1($item) if $debug; |
892
|
|
|
|
|
|
|
} |
893
|
1689
|
|
|
|
|
2699
|
my $original = $item; |
894
|
|
|
|
|
|
|
|
895
|
|
|
|
|
|
|
# The Refaddr option introduces [...] wrappers in the tree and so |
896
|
|
|
|
|
|
|
# Data::Dumper's Maxdepth() option will not work as we intend. |
897
|
|
|
|
|
|
|
# Therefore we implement Maxdepth ourself |
898
|
1689
|
50
|
|
|
|
3479
|
if ($my_visit_depth >= $my_maxdepth) { |
899
|
0
|
0
|
|
|
|
0
|
oops unless $my_visit_depth == $my_maxdepth; |
900
|
0
|
|
|
|
|
0
|
$item = _MAGIC_NOQUOTES_PFX.addrvis($item); |
901
|
0
|
0
|
|
|
|
0
|
say "! maxdepth reached, returning ",_dbvis2($item) if $debug; |
902
|
0
|
|
|
|
|
0
|
return $item |
903
|
|
|
|
|
|
|
} |
904
|
|
|
|
|
|
|
|
905
|
|
|
|
|
|
|
# First descend into the structure, probably returning a clone |
906
|
1689
|
|
|
|
|
3048
|
local $my_visit_depth = $my_visit_depth + 1; |
907
|
1689
|
|
|
|
|
4753
|
my $nitem = $self->SUPER::visit_ref($item); |
908
|
1689
|
50
|
|
|
|
34306
|
say "! (ref) new: ",_dbvis2($item), " --> ",_dbvis2($nitem) if $debug; |
909
|
1689
|
|
|
|
|
2523
|
$item = $nitem; |
910
|
|
|
|
|
|
|
|
911
|
|
|
|
|
|
|
# Prepend the original address to whatever the representation is now |
912
|
1689
|
|
|
|
|
3514
|
$item = _prefix_refaddr($item, $original); |
913
|
|
|
|
|
|
|
|
914
|
1689
|
|
|
|
|
5126
|
$item |
915
|
|
|
|
|
|
|
} |
916
|
|
|
|
|
|
|
sub visit_hash_entries { |
917
|
562
|
|
|
562
|
1
|
22035
|
my ($self, $hash) = @_; |
918
|
|
|
|
|
|
|
# Visit in sorted order |
919
|
1521
|
|
|
|
|
9856
|
return map { $self->visit_hash_entry( $_, $hash->{$_}, $hash ) } |
920
|
562
|
100
|
|
|
|
1478
|
(ref($sortkeys) ? @{ $sortkeys->($hash) } : (sort keys %$hash)); |
|
554
|
|
|
|
|
1298
|
|
921
|
|
|
|
|
|
|
} |
922
|
|
|
|
|
|
|
|
923
|
|
|
|
|
|
|
sub visit_glob { |
924
|
4
|
|
|
4
|
1
|
89
|
my ($self, $item) = @_; |
925
|
4
|
50
|
|
|
|
12
|
say "!V glob ref()=",ref($item)," depth:$my_visit_depth"," item=",_dbravis2($item) if $debug; |
926
|
|
|
|
|
|
|
# By default Data::Visitor will create a new anon glob in the output tree. |
927
|
|
|
|
|
|
|
# Instead, put the original into the output so the user can recognize |
928
|
|
|
|
|
|
|
# it e.g. "*main::STDOUT" instead of an anonymous from Symbol::gensym |
929
|
4
|
|
|
|
|
15
|
return $item |
930
|
|
|
|
|
|
|
} |
931
|
|
|
|
|
|
|
|
932
|
|
|
|
|
|
|
sub visit_seen { |
933
|
18
|
|
|
18
|
1
|
647
|
my ($self, $data, $first_result) = @_; |
934
|
18
|
50
|
|
|
|
46
|
say "!V seen orig=",_dbrvis2($data)," depth:$my_visit_depth"," 1stres=",_dbrvis2($first_result) |
935
|
|
|
|
|
|
|
if $debug; |
936
|
|
|
|
|
|
|
|
937
|
|
|
|
|
|
|
# $data is a ref which has been visited before, i.e. there is a circularity. |
938
|
|
|
|
|
|
|
# Data::Dumper will display a $VAR->... expression. |
939
|
|
|
|
|
|
|
# With the Refaddr option the $VAR index may be incorrect due to the |
940
|
|
|
|
|
|
|
# temporary [...] wrappers inserted into the cloned tree. |
941
|
|
|
|
|
|
|
# |
942
|
|
|
|
|
|
|
# Therefore if Refaddr is in effect substitute an addrvis() string |
943
|
|
|
|
|
|
|
# which the user will be able to match with other refs to the same thing. |
944
|
18
|
100
|
|
|
|
41
|
if ($opt_refaddr) { |
945
|
7
|
|
|
|
|
17
|
my $t = ref($data); |
946
|
7
|
100
|
|
|
|
22
|
return _MAGIC_NOQUOTES_PFX.addrvis(refaddr $data)."[...]" if $t eq "ARRAY"; |
947
|
5
|
100
|
|
|
|
21
|
return _MAGIC_NOQUOTES_PFX.addrvis(refaddr $data)."{...}" if $t eq "HASH"; |
948
|
3
|
100
|
|
|
|
14
|
return _MAGIC_NOQUOTES_PFX.addrvis(refaddr $data)."\\..." if $t eq "SCALAR"; |
949
|
1
|
|
|
|
|
8
|
return _MAGIC_NOQUOTES_PFX.addrvis($data); |
950
|
|
|
|
|
|
|
} |
951
|
|
|
|
|
|
|
|
952
|
|
|
|
|
|
|
$first_result |
953
|
11
|
|
|
|
|
24
|
} |
954
|
|
|
|
|
|
|
|
955
|
|
|
|
|
|
|
#--------------------------------------------------------------------- |
956
|
|
|
|
|
|
|
sub _preprocess { # Modify the cloned data |
957
|
9
|
|
|
9
|
|
82
|
no warnings 'recursion'; |
|
9
|
|
|
|
|
23
|
|
|
9
|
|
|
|
|
8279
|
|
958
|
0
|
|
|
0
|
|
0
|
my ($self, $cloned_itemref, $orig_itemref) = @_; |
959
|
0
|
|
|
|
|
0
|
my ($debug, $seenhash) = @$self{qw/Debug Seenhash/}; |
960
|
|
|
|
|
|
|
|
961
|
0
|
0
|
|
|
|
0
|
btw '##pp AAA cloned=",addrvis($cloned_itemref)," -> ',_dbvis($$cloned_itemref) if $debug; |
962
|
0
|
0
|
|
|
|
0
|
btw '## orig=",addrvis($orig_itemref)," -> ",_dbvis($$orig_itemref)' if $debug; |
963
|
|
|
|
|
|
|
|
964
|
|
|
|
|
|
|
# Pop back if this item was visited previously |
965
|
0
|
0
|
|
|
|
0
|
if ($seenhash->{ refaddr($cloned_itemref) }++) { |
966
|
0
|
0
|
|
|
|
0
|
btw ' Seen already' if $debug; |
967
|
|
|
|
|
|
|
return |
968
|
0
|
|
|
|
|
0
|
} |
969
|
|
|
|
|
|
|
|
970
|
|
|
|
|
|
|
# About TIED VARIABLES: |
971
|
|
|
|
|
|
|
# We must never modify a tied variable because of user-defined side-effects. |
972
|
|
|
|
|
|
|
# So when we want to replace a tied variable we untie it first, if possible. |
973
|
|
|
|
|
|
|
# N.B. The whole structure was cloned, so this does not untie the |
974
|
|
|
|
|
|
|
# user's variables. |
975
|
|
|
|
|
|
|
# |
976
|
|
|
|
|
|
|
# All modifications (untie and over-writing) is done in eval{...} in case |
977
|
|
|
|
|
|
|
# the data is read-only or an UNTIE handler throws -- in which case we leave |
978
|
|
|
|
|
|
|
# the cloned item as it is. This occurs e.g. with the 'Readonly' module; |
979
|
|
|
|
|
|
|
# I tried using Readonly::Clone (insterad of Clone::clone) to copy the input, |
980
|
|
|
|
|
|
|
# since it is supposed to make a mutable copy; but it has bugs with refs to |
981
|
|
|
|
|
|
|
# other refs, and doesn't actually make everything mutable; it was a big mess |
982
|
|
|
|
|
|
|
# so now taking the simple way out. |
983
|
|
|
|
|
|
|
|
984
|
|
|
|
|
|
|
# Side note: Taking a ref to a member of a tied container, |
985
|
|
|
|
|
|
|
# e.g. \$tiedhash{key}, actually returns an overloaded object or some other |
986
|
|
|
|
|
|
|
# magical thing which, every time it is de-referenced, FETCHes the datum |
987
|
|
|
|
|
|
|
# into a temporary. |
988
|
|
|
|
|
|
|
# |
989
|
|
|
|
|
|
|
# There is a bug somewhere which makes it unsafe to store these fake |
990
|
|
|
|
|
|
|
# references inside tied variables because after the variable is 'untie'd |
991
|
|
|
|
|
|
|
# bad things can happen (refcount problems?). So after a lot of mucking |
992
|
|
|
|
|
|
|
# around I gave up trying to do anything intelligent about tied data. |
993
|
|
|
|
|
|
|
# I still have to untie variables before over-writing them with substitute |
994
|
|
|
|
|
|
|
# content. |
995
|
|
|
|
|
|
|
|
996
|
|
|
|
|
|
|
# Note: Our Item is only ever a scalar, either the top-level item from the |
997
|
|
|
|
|
|
|
# user or a member of a container we unroll below. In either case the |
998
|
|
|
|
|
|
|
# scalar could be either a ref to something or a non-ref value. |
999
|
|
|
|
|
|
|
|
1000
|
0
|
|
|
|
|
0
|
eval { |
1001
|
0
|
0
|
|
|
|
0
|
if (tied($$cloned_itemref)) { |
1002
|
0
|
0
|
|
|
|
0
|
btw ' Item itself is tied' if $debug; |
1003
|
0
|
|
|
|
|
0
|
my $copy = $$cloned_itemref; |
1004
|
0
|
|
|
|
|
0
|
untie $$cloned_itemref; |
1005
|
0
|
|
|
|
|
0
|
$$cloned_itemref = $copy; # n.b. $copy might be a ref to a tied variable |
1006
|
0
|
0
|
|
|
|
0
|
oops if tied($$cloned_itemref); |
1007
|
|
|
|
|
|
|
} |
1008
|
|
|
|
|
|
|
|
1009
|
0
|
|
0
|
|
|
0
|
my $rt = reftype($$cloned_itemref) // ""; # "" if item is not a ref |
1010
|
0
|
0
|
|
|
|
0
|
if (reftype($cloned_itemref) eq "SCALAR") { |
1011
|
0
|
0
|
|
|
|
0
|
oops if $rt; |
1012
|
0
|
0
|
|
|
|
0
|
btw '##pp item is non-ref scalar; stop.' if $debug; |
1013
|
|
|
|
|
|
|
return |
1014
|
0
|
|
|
|
|
0
|
} |
1015
|
|
|
|
|
|
|
|
1016
|
|
|
|
|
|
|
# Item is some kind of ref |
1017
|
0
|
0
|
|
|
|
0
|
oops unless reftype($cloned_itemref) eq "REF"; |
1018
|
0
|
0
|
|
|
|
0
|
oops unless reftype($orig_itemref) eq "REF"; |
1019
|
|
|
|
|
|
|
|
1020
|
0
|
0
|
0
|
|
|
0
|
if ($rt eq "SCALAR" || $rt eq "LVALUE" || $rt eq "REF") { |
|
|
0
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
1021
|
0
|
0
|
|
|
|
0
|
btw '##pp dereferencing ref-to-scalarish $rt' if $debug; |
1022
|
0
|
|
|
|
|
0
|
$self->_preprocess($$cloned_itemref, $$orig_itemref); |
1023
|
|
|
|
|
|
|
} |
1024
|
|
|
|
|
|
|
elsif ($rt eq "ARRAY") { |
1025
|
0
|
0
|
|
|
|
0
|
btw '##pp ARRAY ref' if $debug; |
1026
|
0
|
0
|
|
|
|
0
|
if (tied @$$cloned_itemref) { |
1027
|
0
|
0
|
|
|
|
0
|
btw ' aref to *tied* ARRAY' if $debug; |
1028
|
0
|
|
|
|
|
0
|
my $copy = [ @$$cloned_itemref ]; # only 1 level |
1029
|
0
|
|
|
|
|
0
|
untie @$$cloned_itemref; |
1030
|
0
|
|
|
|
|
0
|
@$$cloned_itemref = @$copy; |
1031
|
|
|
|
|
|
|
} |
1032
|
0
|
|
|
|
|
0
|
for my $ix (0..$#{$$cloned_itemref}) { |
|
0
|
|
|
|
|
0
|
|
1033
|
0
|
|
|
|
|
0
|
$self->_preprocess(\$$cloned_itemref->[$ix], \$$orig_itemref->[$ix]); |
1034
|
|
|
|
|
|
|
} |
1035
|
|
|
|
|
|
|
} |
1036
|
|
|
|
|
|
|
elsif ($rt eq "HASH") { |
1037
|
0
|
0
|
|
|
|
0
|
btw '##pp HASH ref' if $debug; |
1038
|
0
|
0
|
|
|
|
0
|
if (tied %$$cloned_itemref) { |
1039
|
0
|
0
|
|
|
|
0
|
btw ' href to *tied* HASH' if $debug; |
1040
|
0
|
|
|
|
|
0
|
my $copy = { %$$cloned_itemref }; # only 1 level |
1041
|
0
|
|
|
|
|
0
|
untie %$$cloned_itemref; |
1042
|
0
|
|
|
|
|
0
|
%$$cloned_itemref = %$copy; |
1043
|
0
|
0
|
|
|
|
0
|
die if tied %$$cloned_itemref; |
1044
|
|
|
|
|
|
|
} |
1045
|
|
|
|
|
|
|
#For easier debugging, do in sorted order |
1046
|
0
|
0
|
|
|
|
0
|
btw ' #### iterating hash values...' if $debug; |
1047
|
0
|
|
|
|
|
0
|
for my $key (sort keys %$$cloned_itemref) { |
1048
|
0
|
|
|
|
|
0
|
$self->_preprocess(\$$cloned_itemref->{$key}, \$$orig_itemref->{$key}); |
1049
|
|
|
|
|
|
|
} |
1050
|
|
|
|
|
|
|
} |
1051
|
|
|
|
|
|
|
};#eval |
1052
|
0
|
0
|
|
|
|
0
|
if ($@) { |
1053
|
0
|
0
|
|
|
|
0
|
btw "*EXCEPTION*, just returning\n$@\n" if $debug; |
1054
|
|
|
|
|
|
|
} |
1055
|
|
|
|
|
|
|
} |
1056
|
|
|
|
|
|
|
|
1057
|
|
|
|
|
|
|
sub _show_as_number(_) { |
1058
|
4022
|
|
|
4022
|
|
380018
|
my $value = shift; |
1059
|
|
|
|
|
|
|
|
1060
|
|
|
|
|
|
|
# IMPORTANT: We must not do any numeric ops or comparisions |
1061
|
|
|
|
|
|
|
# on $value because that may set some magic which defeats our attempt |
1062
|
|
|
|
|
|
|
# to try bitstring unary & below (after a numeric compare, $value is |
1063
|
|
|
|
|
|
|
# apparently assumed to be numeric or dual-valued even if it |
1064
|
|
|
|
|
|
|
# is/was just a "string"). |
1065
|
|
|
|
|
|
|
|
1066
|
4022
|
100
|
|
|
|
9051
|
return 0 if !defined $value; |
1067
|
|
|
|
|
|
|
|
1068
|
|
|
|
|
|
|
# if the utf8 flag is on, it almost certainly started as a string |
1069
|
4021
|
100
|
100
|
|
|
16952
|
return 0 if (ref($value) eq "") && utf8::is_utf8($value); |
1070
|
|
|
|
|
|
|
|
1071
|
|
|
|
|
|
|
# There was a Perl bug where looks_like_number() provoked a warning from |
1072
|
|
|
|
|
|
|
# BigRat.pm if it is called under 'use bigrat;' so we must not do that. |
1073
|
|
|
|
|
|
|
# https://github.com/Perl/perl5/issues/20685 |
1074
|
|
|
|
|
|
|
#return 0 unless looks_like_number($value); |
1075
|
|
|
|
|
|
|
|
1076
|
|
|
|
|
|
|
# JSON::PP uses these tricks: |
1077
|
|
|
|
|
|
|
# string & "" -> "" # bitstring AND, truncating to shortest operand |
1078
|
|
|
|
|
|
|
# number & "" -> 0 (with warning) |
1079
|
|
|
|
|
|
|
# number * 0 -> 0 unless number is nan or inf |
1080
|
|
|
|
|
|
|
|
1081
|
|
|
|
|
|
|
# Attempt uniary & with "string" and see what happens |
1082
|
4006
|
|
|
|
|
6964
|
my $uand_str_result = eval { |
1083
|
9
|
|
|
9
|
|
73
|
use warnings "FATAL" => "all"; # Convert warnings into exceptions |
|
9
|
|
|
|
|
24
|
|
|
9
|
|
|
|
|
1046
|
|
1084
|
|
|
|
|
|
|
# 'bitwise' is the default only in newer perls. So disable. |
1085
|
|
|
|
|
|
|
BEGIN { |
1086
|
9
|
|
|
9
|
|
41
|
eval { # "no feature 'bitwise'" won't compile on Perl 5.20 |
1087
|
9
|
|
|
|
|
397
|
feature->unimport( 'bitwise' ); |
1088
|
9
|
|
|
|
|
160
|
warnings->unimport("experimental::bitwise"); |
1089
|
|
|
|
|
|
|
}; |
1090
|
9
|
|
|
|
|
290
|
$@ = ""; |
1091
|
|
|
|
|
|
|
} |
1092
|
9
|
|
|
9
|
|
68
|
no warnings "once"; |
|
9
|
|
|
|
|
58
|
|
|
9
|
|
|
|
|
9532
|
|
1093
|
|
|
|
|
|
|
# Use FF... so we can see what $value was in debug messages below |
1094
|
4006
|
|
|
|
|
45094
|
my $dummy = ($value & "\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}"); |
1095
|
|
|
|
|
|
|
}; |
1096
|
4006
|
50
|
|
|
|
105048
|
btw '##_san $value \$@=$@' if $Debug; |
1097
|
4006
|
100
|
100
|
|
|
9983
|
if ($@) { |
|
|
100
|
|
|
|
|
|
1098
|
3032
|
50
|
|
|
|
18295
|
if ($@ =~ /".*" isn't numeric/) { |
1099
|
3032
|
|
|
|
|
9001
|
return 1; # Ergo $value must be numeric |
1100
|
|
|
|
|
|
|
} |
1101
|
0
|
0
|
|
|
|
0
|
if ($@ =~ /\& not supported/) { |
1102
|
|
|
|
|
|
|
# If it is an object then it probably (but not necessarily) |
1103
|
|
|
|
|
|
|
# is numeric but just doesn't support bitwise operators, |
1104
|
|
|
|
|
|
|
# for example BigRat. |
1105
|
0
|
0
|
|
|
|
0
|
return 1 if defined blessed($value); |
1106
|
|
|
|
|
|
|
} |
1107
|
0
|
0
|
|
|
|
0
|
if ($@ =~ /no method found/) { # overloaded but does not do '&' |
1108
|
|
|
|
|
|
|
# It must use overloads, but does not implement '&' |
1109
|
|
|
|
|
|
|
# Assume it is string-ish |
1110
|
0
|
0
|
|
|
|
0
|
return 0 if defined blessed($value); # else our mistake, isn't overloaded |
1111
|
|
|
|
|
|
|
} |
1112
|
0
|
0
|
|
|
|
0
|
warn "# ".__PACKAGE__." : value=",_dbshow($value), |
1113
|
|
|
|
|
|
|
"\n Unhandled warn/exception from unary & :$@\n" |
1114
|
|
|
|
|
|
|
if $Debug; |
1115
|
|
|
|
|
|
|
# Unknown problem, treat as a string |
1116
|
0
|
|
|
|
|
0
|
return 0; |
1117
|
|
|
|
|
|
|
} |
1118
|
|
|
|
|
|
|
elsif (ref($uand_str_result) ne "" && $uand_str_result =~ /NaN|Inf/) { |
1119
|
|
|
|
|
|
|
# unary & returned an object representing Nan or Inf |
1120
|
|
|
|
|
|
|
# (e.g. Math::BigFloat) so $value must be numberish. |
1121
|
140
|
|
|
|
|
2807
|
return 1; |
1122
|
|
|
|
|
|
|
} |
1123
|
834
|
50
|
|
|
|
2521
|
warn "# ".__PACKAGE__." : (value & \"...\") succeeded\n", |
1124
|
|
|
|
|
|
|
" value=", _dbshow($value), "\n", |
1125
|
|
|
|
|
|
|
" uand_str_result=", _dbvis($uand_str_result),"\n" |
1126
|
|
|
|
|
|
|
if $Debug; |
1127
|
|
|
|
|
|
|
# Sigh. With Perl 5.32 (at least) $value & "..." stringifies $value |
1128
|
|
|
|
|
|
|
# or so it seems. |
1129
|
834
|
100
|
|
|
|
2393
|
if (blessed($value)) { |
1130
|
|
|
|
|
|
|
# +42 might throw if object is not numberish e.g. a DateTime |
1131
|
28
|
50
|
|
|
|
47
|
if (blessed(eval{ $value + 42 })) { |
|
28
|
|
|
|
|
85
|
|
1132
|
28
|
50
|
|
|
|
21047
|
warn " Object and value+42 is still an object, so probably numberish\n" |
1133
|
|
|
|
|
|
|
if $Debug; |
1134
|
28
|
|
|
|
|
148
|
return 1 |
1135
|
|
|
|
|
|
|
} else { |
1136
|
0
|
0
|
|
|
|
0
|
warn " Object and value+42 is NOT an object, so it must be stringish\n" |
1137
|
|
|
|
|
|
|
if $Debug; |
1138
|
0
|
|
|
|
|
0
|
return 0 |
1139
|
|
|
|
|
|
|
} |
1140
|
|
|
|
|
|
|
} else { |
1141
|
806
|
50
|
|
|
|
1641
|
warn " NOT an object, so must be a string\n", |
1142
|
|
|
|
|
|
|
if $Debug; |
1143
|
806
|
|
|
|
|
1995
|
return 0; |
1144
|
|
|
|
|
|
|
} |
1145
|
|
|
|
|
|
|
}# _show_as_number |
1146
|
|
|
|
|
|
|
|
1147
|
|
|
|
|
|
|
# Split keys into "components" (e.g. 2_16.A has 3 components) and sort |
1148
|
|
|
|
|
|
|
# components containing only digits numerically. |
1149
|
|
|
|
|
|
|
sub __sortkeys { |
1150
|
1119
|
|
|
1119
|
|
7890
|
my $hash = shift; |
1151
|
|
|
|
|
|
|
my $r = [ |
1152
|
1119
|
|
|
|
|
5025
|
sort { my @a = split /(?<=\d)(?=\D)|(?<=\D)(?=\d)/,$a; |
|
4470
|
|
|
|
|
23294
|
|
1153
|
4470
|
|
|
|
|
24305
|
my @b = split /(?<=\d)(?=\D)|(?<=\D)(?=\d)/,$b; |
1154
|
4470
|
|
|
|
|
9746
|
for (my $i=0; $i <= $#a; ++$i) { |
1155
|
3988
|
100
|
|
|
|
7312
|
return 1 if $i > $#b; # a is longer |
1156
|
3678
|
50
|
33
|
|
|
10775
|
my $r = ($a[$i] =~ /^\d+$/ && $b[$i] =~ /^\d+$/) |
1157
|
|
|
|
|
|
|
? ($a[$i] <=> $b[$i]) : ($a[$i] cmp $b[$i]) ; |
1158
|
3678
|
50
|
|
|
|
10294
|
return $r if $r != 0; |
1159
|
|
|
|
|
|
|
} |
1160
|
482
|
50
|
|
|
|
1389
|
return -1 if $#a < $#b; # a is shorter |
1161
|
0
|
|
|
|
|
0
|
return 0; |
1162
|
|
|
|
|
|
|
} |
1163
|
|
|
|
|
|
|
keys %$hash |
1164
|
|
|
|
|
|
|
]; |
1165
|
1119
|
|
|
|
|
12279
|
$r |
1166
|
|
|
|
|
|
|
} |
1167
|
|
|
|
|
|
|
|
1168
|
|
|
|
|
|
|
my $balanced_re = RE_balanced(-parens=>'{}[]()'); |
1169
|
|
|
|
|
|
|
|
1170
|
|
|
|
|
|
|
# cf man perldata |
1171
|
|
|
|
|
|
|
my $userident_re = qr/ (?: (?=\p{Word})\p{XID_Start} | _ ) |
1172
|
|
|
|
|
|
|
(?: (?=\p{Word})\p{XID_Continue} )* /x; |
1173
|
|
|
|
|
|
|
|
1174
|
|
|
|
|
|
|
my $pkgname_re = qr/ ${userident_re} (?: :: ${userident_re} )* /x; |
1175
|
|
|
|
|
|
|
|
1176
|
|
|
|
|
|
|
our $curlies_re = RE_balanced(-parens=>'{}'); |
1177
|
|
|
|
|
|
|
our $parens_re = RE_balanced(-parens=>'()'); |
1178
|
|
|
|
|
|
|
our $curliesorsquares_re = RE_balanced(-parens=>'{}[]'); |
1179
|
|
|
|
|
|
|
|
1180
|
|
|
|
|
|
|
my $anyvname_re = |
1181
|
|
|
|
|
|
|
qr/ ${pkgname_re} | [0-9]+ | \^[A-Z] |
1182
|
|
|
|
|
|
|
| [-+!\$\&\;i"'().,\@\/:<>?\[\]\~\^\\] /x; |
1183
|
|
|
|
|
|
|
|
1184
|
|
|
|
|
|
|
my $anyvname_or_refexpr_re = qr/ ${anyvname_re} | ${curlies_re} /x; |
1185
|
|
|
|
|
|
|
|
1186
|
|
|
|
|
|
|
my $addrvis_re = qr/\<\d+:[\da-fA-F]+\>/; |
1187
|
|
|
|
|
|
|
|
1188
|
|
|
|
|
|
|
sub __unmagic_atom() { # edits $_ |
1189
|
|
|
|
|
|
|
## # FIXME this probably could omit the ([^'"]*?) bc there is never anything |
1190
|
|
|
|
|
|
|
## # between the open quote and the _MAGIC_NOQUOTES_PFX |
1191
|
|
|
|
|
|
|
## s/(['"])([^'"]*?) |
1192
|
|
|
|
|
|
|
## (?:\Q${\_MAGIC_NOQUOTES_PFX}\E) |
1193
|
|
|
|
|
|
|
## (.*?)(\1)/$2$3/xgs; |
1194
|
|
|
|
|
|
|
|
1195
|
17165
|
|
|
17165
|
|
24963
|
s/(['"]) |
1196
|
17165
|
|
|
|
|
66407
|
(?:\Q${\_MAGIC_NOQUOTES_PFX}\E) (.*?) |
1197
|
3173
|
|
|
|
|
6038
|
(\1)/do{ local $_ = $2; |
|
3173
|
|
|
|
|
6940
|
|
1198
|
3173
|
|
|
|
|
5455
|
s!\\(.)!$1!g; # undo double-quotish backslash escapes |
1199
|
3173
|
|
|
|
|
10183
|
$_ }/xegs; |
1200
|
|
|
|
|
|
|
|
1201
|
17165
|
|
|
|
|
27964
|
s/\Q${\_MAGIC_KEEPQUOTES_PFX}\E//gs; |
|
17165
|
|
|
|
|
37743
|
|
1202
|
|
|
|
|
|
|
} |
1203
|
|
|
|
|
|
|
|
1204
|
|
|
|
|
|
|
sub __unesc_unicode() { # edits $_ |
1205
|
15044
|
100
|
|
15044
|
|
35888
|
if (/^"/) { |
1206
|
|
|
|
|
|
|
# Data::Dumper with Useqq(1) outputs wide characters as hex escapes |
1207
|
|
|
|
|
|
|
# Note that a BOM is the ZERO WIDTH NO-BREAK SPACE character and |
1208
|
|
|
|
|
|
|
# so is considered "Graphical", but we want to see it as hex rather |
1209
|
|
|
|
|
|
|
# than "", and probably any other "Format" category Unicode characters. |
1210
|
|
|
|
|
|
|
|
1211
|
3498
|
|
|
|
|
7725
|
s/ |
1212
|
|
|
|
|
|
|
\G (?: [^\\]++ | \\[^x] )*+ \K (?<w> \\x\x{7B} (?<hex>[a-fA-F0-9]+) \x{7D} ) |
1213
|
|
|
|
|
|
|
/ |
1214
|
9
|
|
|
9
|
|
31864
|
my $orig = $+{w}; |
|
9
|
|
|
|
|
3819
|
|
|
9
|
|
|
|
|
952
|
|
|
312
|
|
|
|
|
1695
|
|
1215
|
312
|
100
|
|
|
|
1746
|
local $_ = hex( length($+{hex}) > 6 ? '0' : $+{hex} ); |
1216
|
312
|
100
|
|
|
|
906
|
$_ = $_ > 0x10FFFF ? "\0" : chr($_); # 10FFFF is Unicode limit |
1217
|
|
|
|
|
|
|
# Using 'lc' so regression tests do not depend on Data::Dumper's |
1218
|
|
|
|
|
|
|
# choice of case when escaping wide characters. |
1219
|
312
|
100
|
66
|
|
|
2502
|
(m<\P{XPosixGraph}|[\0-\177]> |
1220
|
|
|
|
|
|
|
|| m<\p{General_Category=Format}>) ? lc($orig) : $_ |
1221
|
|
|
|
|
|
|
/xesg; |
1222
|
|
|
|
|
|
|
} |
1223
|
|
|
|
|
|
|
} |
1224
|
|
|
|
|
|
|
|
1225
|
|
|
|
|
|
|
sub __change_quotechars($) { # edits $_ |
1226
|
1653
|
50
|
|
1653
|
|
8044
|
if (s/^"//) { |
1227
|
1653
|
50
|
|
|
|
7699
|
oops unless s/"$//; |
1228
|
1653
|
|
|
|
|
7477
|
s/\\"/"/g; |
1229
|
1653
|
50
|
|
|
|
6620
|
my ($l, $r) = split //, $_[0]; oops unless $r; |
|
1653
|
|
|
|
|
4156
|
|
1230
|
1653
|
|
|
|
|
33102
|
s/([\Q$l$r\E])/\\$1/g; |
1231
|
1653
|
|
|
|
|
7477
|
$_ = "qq".$l.$_.$r; |
1232
|
|
|
|
|
|
|
} |
1233
|
|
|
|
|
|
|
} |
1234
|
|
|
|
|
|
|
|
1235
|
|
|
|
|
|
|
my %qqesc2controlpic = ( |
1236
|
9
|
|
|
9
|
|
15477
|
'\0' => "\N{SYMBOL FOR NULL}", |
|
9
|
|
|
|
|
23
|
|
|
9
|
|
|
|
|
82
|
|
1237
|
|
|
|
|
|
|
'\a' => "\N{SYMBOL FOR BELL}", |
1238
|
|
|
|
|
|
|
'\b' => "\N{SYMBOL FOR BACKSPACE}", |
1239
|
|
|
|
|
|
|
'\e' => "\N{SYMBOL FOR ESCAPE}", |
1240
|
|
|
|
|
|
|
'\f' => "\N{SYMBOL FOR FORM FEED}", |
1241
|
|
|
|
|
|
|
'\n' => "\N{SYMBOL FOR NEWLINE}", |
1242
|
|
|
|
|
|
|
'\r' => "\N{SYMBOL FOR CARRIAGE RETURN}", |
1243
|
|
|
|
|
|
|
'\t' => "\N{SYMBOL FOR HORIZONTAL TABULATION}", |
1244
|
|
|
|
|
|
|
); |
1245
|
|
|
|
|
|
|
my %char2controlpic = ( |
1246
|
|
|
|
|
|
|
map{ |
1247
|
|
|
|
|
|
|
my $cp = $qqesc2controlpic{$_}; |
1248
|
|
|
|
|
|
|
my $char = eval(qq("$_")) // die; |
1249
|
|
|
|
|
|
|
die "XX<<$_>> YY<<$char>>" unless length($char) == 1; |
1250
|
|
|
|
|
|
|
($char => $cp) |
1251
|
|
|
|
|
|
|
} keys %qqesc2controlpic |
1252
|
|
|
|
|
|
|
); |
1253
|
|
|
|
|
|
|
sub __subst_controlpic_backesc() { # edits $_ |
1254
|
|
|
|
|
|
|
# Replace '\t' '\n' etc. escapes with "control picture" characters |
1255
|
551
|
50
|
|
551
|
|
2848
|
return unless/^"/; |
1256
|
551
|
|
|
|
|
4460
|
s{ \G (?: [^\\]++ | \\[^0abefnrt] )*+ \K ( \\[abefnrt] | \\0(?![0-7]) ) |
1257
|
|
|
|
|
|
|
}{ |
1258
|
1623
|
|
33
|
|
|
12330
|
$qqesc2controlpic{$1} // $1 |
1259
|
|
|
|
|
|
|
}xesg; |
1260
|
|
|
|
|
|
|
} |
1261
|
|
|
|
|
|
|
sub __subst_spacedots() { # edits $_ |
1262
|
0
|
0
|
|
0
|
|
0
|
if (/^"/) { |
1263
|
0
|
|
|
|
|
0
|
s{\N{MIDDLE DOT}}{\N{BLACK LARGE CIRCLE}}g; |
1264
|
0
|
|
|
|
|
0
|
s{ }{\N{MIDDLE DOT}}g; |
1265
|
|
|
|
|
|
|
} |
1266
|
|
|
|
|
|
|
} |
1267
|
|
|
|
|
|
|
|
1268
|
|
|
|
|
|
|
my $indent_unit; |
1269
|
|
|
|
|
|
|
|
1270
|
|
|
|
|
|
|
sub _mycallloc(;@) { |
1271
|
0
|
|
|
0
|
|
0
|
my ($lno, $subcalled) = (caller(1))[2,3]; |
1272
|
0
|
0
|
|
|
|
0
|
":".$lno.(@_ ? _dbavis(@_) : "")." " |
1273
|
|
|
|
|
|
|
} |
1274
|
|
|
|
|
|
|
|
1275
|
|
|
|
|
|
|
use constant { |
1276
|
9
|
|
|
|
|
753
|
_WRAP_ALWAYS => 1, |
1277
|
|
|
|
|
|
|
_WRAP_ALLHASH => 2, |
1278
|
9
|
|
|
9
|
|
31501
|
}; |
|
9
|
|
|
|
|
26
|
|
1279
|
9
|
|
|
9
|
|
63
|
use constant _WRAP_STYLE => (_WRAP_ALLHASH); |
|
9
|
|
|
|
|
20
|
|
|
9
|
|
|
|
|
951
|
|
1280
|
|
|
|
|
|
|
|
1281
|
|
|
|
|
|
|
sub _postprocess_DD_result { |
1282
|
|
|
|
|
|
|
(my $self, local $_, my $original) = @_; |
1283
|
9
|
|
|
9
|
|
68
|
no warnings 'recursion'; |
|
9
|
|
|
|
|
21
|
|
|
9
|
|
|
|
|
35642
|
|
1284
|
|
|
|
|
|
|
my ($debug, $listform, $foldwidth, $foldwidth1) |
1285
|
|
|
|
|
|
|
= @$self{qw/Debug _Listform Foldwidth Foldwidth1/}; |
1286
|
|
|
|
|
|
|
my $useqq = $self->Useqq(); |
1287
|
|
|
|
|
|
|
my $unesc_unicode = $useqq =~ /utf|unic/; |
1288
|
|
|
|
|
|
|
my $controlpics = $useqq =~ /pic/; |
1289
|
|
|
|
|
|
|
my $spacedots = $useqq =~ /space/; |
1290
|
|
|
|
|
|
|
my $qq = $useqq =~ /qq(?:=(..))?/ ? ($1//'{}') : ''; |
1291
|
|
|
|
|
|
|
my $pad = $self->Pad() // ""; |
1292
|
|
|
|
|
|
|
|
1293
|
|
|
|
|
|
|
$indent_unit = 2; # make configurable? |
1294
|
|
|
|
|
|
|
|
1295
|
|
|
|
|
|
|
my $maxlinelen = $foldwidth1 || $foldwidth || INT_MAX; |
1296
|
|
|
|
|
|
|
my $maxlineNlen = ($foldwidth // INT_MAX) - length($pad); |
1297
|
|
|
|
|
|
|
|
1298
|
|
|
|
|
|
|
if ($debug) { |
1299
|
|
|
|
|
|
|
our $_dbmaxlen = INT_MAX; |
1300
|
|
|
|
|
|
|
btw "## DD result: fw1=",u($foldwidth1)," fw=",u($foldwidth)," pad='${pad}' maxll=$maxlinelen maxlNl=$maxlineNlen\n result=",_dbrawstr($_); |
1301
|
|
|
|
|
|
|
} |
1302
|
|
|
|
|
|
|
|
1303
|
|
|
|
|
|
|
my $top = { tlen => 0, children => [] }; |
1304
|
|
|
|
|
|
|
my $context = $top; |
1305
|
|
|
|
|
|
|
my $prepending = ""; |
1306
|
|
|
|
|
|
|
|
1307
|
|
|
|
|
|
|
my sub atom($;$) { |
1308
|
|
|
|
|
|
|
(local $_, my $mode) = @_; |
1309
|
|
|
|
|
|
|
$mode //= ""; |
1310
|
|
|
|
|
|
|
|
1311
|
|
|
|
|
|
|
__unmagic_atom ; |
1312
|
|
|
|
|
|
|
__unesc_unicode if $unesc_unicode; |
1313
|
|
|
|
|
|
|
__subst_controlpic_backesc if $controlpics; |
1314
|
|
|
|
|
|
|
__subst_spacedots if $spacedots; |
1315
|
|
|
|
|
|
|
__change_quotechars($qq) if $qq; |
1316
|
|
|
|
|
|
|
|
1317
|
|
|
|
|
|
|
if ($prepending) { $_ = $prepending . $_; $prepending = ""; } |
1318
|
|
|
|
|
|
|
|
1319
|
|
|
|
|
|
|
btw "###atom",_mycallloc(), _dbrawstr($_),"($mode)" |
1320
|
|
|
|
|
|
|
,"\n context:",_dbvisnew($context)->Sortkeys(sub{[grep{exists $_[0]->{$_}} qw/O C tlen children CLOSE_AFTER_NEXT/]})->Dump() |
1321
|
|
|
|
|
|
|
if $debug; |
1322
|
|
|
|
|
|
|
if ($mode eq "prepend_to_next") { |
1323
|
|
|
|
|
|
|
$prepending .= $_; |
1324
|
|
|
|
|
|
|
} else { |
1325
|
|
|
|
|
|
|
if ($mode eq "") { |
1326
|
|
|
|
|
|
|
push @{ $context->{children} }, $_; |
1327
|
|
|
|
|
|
|
} |
1328
|
|
|
|
|
|
|
elsif ($mode eq "open") { |
1329
|
|
|
|
|
|
|
my $child = { |
1330
|
|
|
|
|
|
|
O => $_, |
1331
|
|
|
|
|
|
|
tlen => 0, # incremented below |
1332
|
|
|
|
|
|
|
children => [], |
1333
|
|
|
|
|
|
|
C => undef, |
1334
|
|
|
|
|
|
|
parent => $context, |
1335
|
|
|
|
|
|
|
}; |
1336
|
|
|
|
|
|
|
weaken( $child->{parent} ); |
1337
|
|
|
|
|
|
|
push @{ $context->{children} }, $child; |
1338
|
|
|
|
|
|
|
$context = $child; |
1339
|
|
|
|
|
|
|
} |
1340
|
|
|
|
|
|
|
elsif ($mode eq "close") { |
1341
|
|
|
|
|
|
|
oops if defined($context->{C}); |
1342
|
|
|
|
|
|
|
$context->{C} = $_; |
1343
|
|
|
|
|
|
|
$context->{tlen} += length; |
1344
|
|
|
|
|
|
|
$context = $context->{parent}; # undef if closing the top item |
1345
|
|
|
|
|
|
|
} |
1346
|
|
|
|
|
|
|
elsif ($mode eq "append_to_prev") { |
1347
|
|
|
|
|
|
|
my $prev = $context; |
1348
|
|
|
|
|
|
|
{ #block for 'redo' |
1349
|
|
|
|
|
|
|
oops "No previous!" unless @{$prev->{children}} > 0; |
1350
|
|
|
|
|
|
|
if (ref($prev->{children}->[-1] // oops)) { |
1351
|
|
|
|
|
|
|
$prev = $prev->{children}->[-1]; |
1352
|
|
|
|
|
|
|
if (! $prev->{C}) { # empty or not-yet-read closer? |
1353
|
|
|
|
|
|
|
redo; # *** |
1354
|
|
|
|
|
|
|
} |
1355
|
|
|
|
|
|
|
$prev->{C} .= $_; |
1356
|
|
|
|
|
|
|
} else { |
1357
|
|
|
|
|
|
|
$prev->{children}->[-1] .= $_; |
1358
|
|
|
|
|
|
|
} |
1359
|
|
|
|
|
|
|
} |
1360
|
|
|
|
|
|
|
} |
1361
|
|
|
|
|
|
|
else { |
1362
|
|
|
|
|
|
|
oops "mode=",_dbvis($mode); |
1363
|
|
|
|
|
|
|
} |
1364
|
|
|
|
|
|
|
my $c = $context; |
1365
|
|
|
|
|
|
|
while(defined $c) { |
1366
|
|
|
|
|
|
|
$c->{tlen} += length($_); |
1367
|
|
|
|
|
|
|
$c = $c->{parent}; |
1368
|
|
|
|
|
|
|
} |
1369
|
|
|
|
|
|
|
if ($context->{CLOSE_AFTER_NEXT}) { |
1370
|
|
|
|
|
|
|
oops(_dbvis($context)) if defined($context->{C}); |
1371
|
|
|
|
|
|
|
$context->{C} = ""; |
1372
|
|
|
|
|
|
|
$context = $context->{parent}; |
1373
|
|
|
|
|
|
|
} |
1374
|
|
|
|
|
|
|
} |
1375
|
|
|
|
|
|
|
}#atom |
1376
|
|
|
|
|
|
|
|
1377
|
|
|
|
|
|
|
my sub fat_arrow($) { # => |
1378
|
|
|
|
|
|
|
my $lhs = $context->{children}->[-1] // oops; |
1379
|
|
|
|
|
|
|
oops if ref($lhs); |
1380
|
|
|
|
|
|
|
my $newchild = { |
1381
|
|
|
|
|
|
|
O => "", |
1382
|
|
|
|
|
|
|
tlen => length($lhs), |
1383
|
|
|
|
|
|
|
children => [ $lhs ], |
1384
|
|
|
|
|
|
|
C => undef, |
1385
|
|
|
|
|
|
|
parent => $context, |
1386
|
|
|
|
|
|
|
}; |
1387
|
|
|
|
|
|
|
weaken($newchild->{parent}); |
1388
|
|
|
|
|
|
|
$context->{children}->[-1] = $newchild; |
1389
|
|
|
|
|
|
|
$context = $newchild; |
1390
|
|
|
|
|
|
|
atom($_[0]); # the " => " |
1391
|
|
|
|
|
|
|
oops unless $context == $newchild; |
1392
|
|
|
|
|
|
|
$context->{CLOSE_AFTER_NEXT} = 1; |
1393
|
|
|
|
|
|
|
} |
1394
|
|
|
|
|
|
|
|
1395
|
|
|
|
|
|
|
# There is a trade-off between compactness (e.g. want a single line when |
1396
|
|
|
|
|
|
|
# possible), and ease of reading large structures. |
1397
|
|
|
|
|
|
|
# |
1398
|
|
|
|
|
|
|
# At any nesting level, if everything (including any nested levels) fits |
1399
|
|
|
|
|
|
|
# on a single line, then that part is output without folding; |
1400
|
|
|
|
|
|
|
# |
1401
|
|
|
|
|
|
|
# 4/25/2023: Now controlled by constant _WRAP_STYLE: |
1402
|
|
|
|
|
|
|
# |
1403
|
|
|
|
|
|
|
# (_WRAP_STYLE == _WRAP_ALWAYS): |
1404
|
|
|
|
|
|
|
# If folding is necessary, then *every* member of the folded block |
1405
|
|
|
|
|
|
|
# appears on a separate line, so members all vertically align. |
1406
|
|
|
|
|
|
|
# |
1407
|
|
|
|
|
|
|
# *(_WRAP_STYLE & _WRAP_ALLHASH): Members of a hash (key => value) |
1408
|
|
|
|
|
|
|
# are shown on separate lines, but not members of an array. |
1409
|
|
|
|
|
|
|
# |
1410
|
|
|
|
|
|
|
# Otherwise: |
1411
|
|
|
|
|
|
|
# |
1412
|
|
|
|
|
|
|
# When folding is necessary, every member appears on a separate |
1413
|
|
|
|
|
|
|
# line if ANY of them will not fit on a single line; however if |
1414
|
|
|
|
|
|
|
# they all fit individually, then shorter members will be run |
1415
|
|
|
|
|
|
|
# together on the same line. For example: |
1416
|
|
|
|
|
|
|
# |
1417
|
|
|
|
|
|
|
# [aaa,bbb,[ccc,ddd,[eee,fff,hhhhhhhhhhhhhhhhhhhhh,{key => value}]]] |
1418
|
|
|
|
|
|
|
# |
1419
|
|
|
|
|
|
|
# might be shown as |
1420
|
|
|
|
|
|
|
# [ aaa,bbb, # N.B. space inserted before aaa to line up with next level |
1421
|
|
|
|
|
|
|
# [ ccc,ddd, # packed because all siblings fit individually |
1422
|
|
|
|
|
|
|
# [eee,fff,hhhhhhhhhhhhhhhhhhhhh,{key => value}] # entirely fits |
1423
|
|
|
|
|
|
|
# ] |
1424
|
|
|
|
|
|
|
# ] |
1425
|
|
|
|
|
|
|
# but if Foldwidth is smaller then like this: |
1426
|
|
|
|
|
|
|
# [ aaa,bbb, |
1427
|
|
|
|
|
|
|
# [ ccc, # sibs vertically-aligned because not all of them fit |
1428
|
|
|
|
|
|
|
# ddd, |
1429
|
|
|
|
|
|
|
# [ eee,fff, # but within this level, all siblings fit |
1430
|
|
|
|
|
|
|
# hhhhhhhhhhhhhhhhhhhhh, |
1431
|
|
|
|
|
|
|
# {key => value} |
1432
|
|
|
|
|
|
|
# ] |
1433
|
|
|
|
|
|
|
# ] |
1434
|
|
|
|
|
|
|
# ] |
1435
|
|
|
|
|
|
|
# or if Foldwidth is very small then: |
1436
|
|
|
|
|
|
|
# [ aaa, |
1437
|
|
|
|
|
|
|
# bbb, |
1438
|
|
|
|
|
|
|
# [ ccc, |
1439
|
|
|
|
|
|
|
# ddd, |
1440
|
|
|
|
|
|
|
# [ eee, |
1441
|
|
|
|
|
|
|
# fff, |
1442
|
|
|
|
|
|
|
# hhhhhhhhhhhhhhhhhhhhh, |
1443
|
|
|
|
|
|
|
# { key |
1444
|
|
|
|
|
|
|
# => |
1445
|
|
|
|
|
|
|
# value |
1446
|
|
|
|
|
|
|
# } |
1447
|
|
|
|
|
|
|
# ] |
1448
|
|
|
|
|
|
|
# ] |
1449
|
|
|
|
|
|
|
# ] |
1450
|
|
|
|
|
|
|
# |
1451
|
|
|
|
|
|
|
# Note: Indentation is done regardless of Foldwidth, so deeply nested |
1452
|
|
|
|
|
|
|
# structures may extend beyond Foldwidth even if all elements are short. |
1453
|
|
|
|
|
|
|
|
1454
|
|
|
|
|
|
|
my $outstr; |
1455
|
|
|
|
|
|
|
my $linelen; |
1456
|
|
|
|
|
|
|
our $level; |
1457
|
|
|
|
|
|
|
my sub expand_children($) { |
1458
|
|
|
|
|
|
|
my $parent = shift; |
1459
|
|
|
|
|
|
|
# $level is already set appropriately for $parent->{children}, |
1460
|
|
|
|
|
|
|
# and the parent's {opener} is at the end of $outstr. |
1461
|
|
|
|
|
|
|
# |
1462
|
|
|
|
|
|
|
# Intially we are called with a fake parent ($top) containing |
1463
|
|
|
|
|
|
|
# no {opener} and the top-most item as its only child, with $level==0; |
1464
|
|
|
|
|
|
|
# this puts the top item at the left margin. |
1465
|
|
|
|
|
|
|
# |
1466
|
|
|
|
|
|
|
# If all children individually fit then run them all together, |
1467
|
|
|
|
|
|
|
# wrapping only between siblings; otherwise start each sibling on |
1468
|
|
|
|
|
|
|
# it's own line so they line up vertically. |
1469
|
|
|
|
|
|
|
# [4/25/2023: Now controlled by _WRAP_STYLE] |
1470
|
|
|
|
|
|
|
|
1471
|
|
|
|
|
|
|
my $available = $maxlinelen - $linelen; |
1472
|
|
|
|
|
|
|
my $indent_width = $level * $indent_unit; |
1473
|
|
|
|
|
|
|
|
1474
|
|
|
|
|
|
|
my $run_together = |
1475
|
|
|
|
|
|
|
(_WRAP_STYLE & _WRAP_ALWAYS)==0 |
1476
|
|
|
|
|
|
|
&& |
1477
|
|
|
|
|
|
|
all{ (ref() ? $_->{tlen} : length) <= $available } @{$parent->{children}} |
1478
|
|
|
|
|
|
|
; |
1479
|
|
|
|
|
|
|
|
1480
|
|
|
|
|
|
|
if (!$run_together |
1481
|
|
|
|
|
|
|
&& @{$parent->{children}}==3 |
1482
|
|
|
|
|
|
|
&& !ref(my $item=$parent->{children}->[1])) { |
1483
|
|
|
|
|
|
|
# Concatenate (key,=>) if possible |
1484
|
|
|
|
|
|
|
if ($item =~ /\A *=> *\z/) { |
1485
|
|
|
|
|
|
|
$run_together = 1; |
1486
|
|
|
|
|
|
|
btw "# (level $level): Running together $parent->{children}->[0] => value" if $debug; |
1487
|
|
|
|
|
|
|
} |
1488
|
|
|
|
|
|
|
} |
1489
|
|
|
|
|
|
|
|
1490
|
|
|
|
|
|
|
my $indent = ' ' x $indent_width; |
1491
|
|
|
|
|
|
|
|
1492
|
|
|
|
|
|
|
btw "###expand",_mycallloc(), "level $level, avail=$available", |
1493
|
|
|
|
|
|
|
" rt=",_tf($run_together), |
1494
|
|
|
|
|
|
|
" indw=$indent_width ll=$linelen maxll=$maxlinelen : ", |
1495
|
|
|
|
|
|
|
#"{ tlen=",$parent->{tlen}," }", |
1496
|
|
|
|
|
|
|
" p=",_dbvisnew($parent)->Sortkeys(sub{[grep{exists $_[0]->{$_}} qw/O C tlen CLOSE_AFTER_NEXT/]})->Dump(), |
1497
|
|
|
|
|
|
|
"\n os=",_dbstr($outstr) if $debug; |
1498
|
|
|
|
|
|
|
|
1499
|
|
|
|
|
|
|
#oops(_dbavis($linelen,$indent_width)) unless $linelen >= $indent_width; |
1500
|
|
|
|
|
|
|
|
1501
|
|
|
|
|
|
|
my $first = 1; |
1502
|
|
|
|
|
|
|
for my $child (@{$parent->{children}}) { |
1503
|
|
|
|
|
|
|
my $child_len = ref($child) ? $child->{tlen} : length($child); |
1504
|
|
|
|
|
|
|
my $fits = ($child_len <= $available) || 0; |
1505
|
|
|
|
|
|
|
|
1506
|
|
|
|
|
|
|
if ($first) { |
1507
|
|
|
|
|
|
|
} else { |
1508
|
|
|
|
|
|
|
if(!$fits && !ref($child)) { |
1509
|
|
|
|
|
|
|
if ($child =~ /( +)\z/ && ($child_len-length($1)) <= $available) { |
1510
|
|
|
|
|
|
|
# remove trailing space(s) e.g. in ' => ' |
1511
|
|
|
|
|
|
|
substr($child,-length($1),INT_MAX,""); |
1512
|
|
|
|
|
|
|
$child_len -= length($1); |
1513
|
|
|
|
|
|
|
oops unless $child_len <= $available; |
1514
|
|
|
|
|
|
|
$fits = 2; |
1515
|
|
|
|
|
|
|
btw "# (level $level): Chopped ",_dbstr($1)," from child" if $debug; |
1516
|
|
|
|
|
|
|
} |
1517
|
|
|
|
|
|
|
if (!$fits && $linelen <= $indent_width && $run_together) { |
1518
|
|
|
|
|
|
|
# If we wrap we'll end up at the same or worse position after |
1519
|
|
|
|
|
|
|
# indenting, so don't bother wrapping if running together |
1520
|
|
|
|
|
|
|
$fits = 3; |
1521
|
|
|
|
|
|
|
btw "# (level $level): Wrap would not help" if $debug |
1522
|
|
|
|
|
|
|
} |
1523
|
|
|
|
|
|
|
} |
1524
|
|
|
|
|
|
|
if (!$fits || !$run_together) { |
1525
|
|
|
|
|
|
|
# start a second+ line |
1526
|
|
|
|
|
|
|
$outstr =~ s/ +\z//; |
1527
|
|
|
|
|
|
|
$outstr .= "\n$indent"; |
1528
|
|
|
|
|
|
|
$linelen = $indent_width; |
1529
|
|
|
|
|
|
|
$maxlinelen = $maxlineNlen; |
1530
|
|
|
|
|
|
|
|
1531
|
|
|
|
|
|
|
# elide any initial spaces after wrapping, e.g. in " => " |
1532
|
|
|
|
|
|
|
$child =~ s/^ +// unless ref($child); |
1533
|
|
|
|
|
|
|
|
1534
|
|
|
|
|
|
|
$available = $maxlinelen - $linelen; |
1535
|
|
|
|
|
|
|
$child_len = ref($child) ? $child->{tlen} : length($child); |
1536
|
|
|
|
|
|
|
$fits = ($child_len <= $available); |
1537
|
|
|
|
|
|
|
btw "# (level $level): 2nd+ Pre-WRAP; ",_dbstr($child)," cl=$child_len av=$available ll=$linelen f=$fits rt=",_tf($run_together)," os=",_dbstr($outstr) if $debug; |
1538
|
|
|
|
|
|
|
} else { |
1539
|
|
|
|
|
|
|
btw "# (level $level): (no 2nd+ pre-wrap); ",_dbstr($child)," cl=$child_len av=$available ll=$linelen f=$fits rt=",_tf($run_together) if $debug; |
1540
|
|
|
|
|
|
|
} |
1541
|
|
|
|
|
|
|
} |
1542
|
|
|
|
|
|
|
|
1543
|
|
|
|
|
|
|
if (ref($child)) { |
1544
|
|
|
|
|
|
|
++$level; |
1545
|
|
|
|
|
|
|
$outstr .= $child->{O}; |
1546
|
|
|
|
|
|
|
$linelen += length($child->{O}); |
1547
|
|
|
|
|
|
|
if (! $fits && $child->{O} ne "") { |
1548
|
|
|
|
|
|
|
# Wrap before first child, if there is a real opener (not for '=>') |
1549
|
|
|
|
|
|
|
$outstr =~ s/ +\z//; |
1550
|
|
|
|
|
|
|
$outstr .= "\n$indent" . (' ' x $indent_unit); |
1551
|
|
|
|
|
|
|
$linelen = $indent_width + $indent_unit; |
1552
|
|
|
|
|
|
|
$maxlinelen = $maxlineNlen; |
1553
|
|
|
|
|
|
|
btw "# (l $level): Wrap after opener: os=",_dbstr($outstr) if $debug; |
1554
|
|
|
|
|
|
|
} |
1555
|
|
|
|
|
|
|
__SUB__->($child); |
1556
|
|
|
|
|
|
|
if (! $fits && $child->{O} ne "") { |
1557
|
|
|
|
|
|
|
# Wrap before closer if we wrapped after opener |
1558
|
|
|
|
|
|
|
$outstr =~ s/ +\z//; |
1559
|
|
|
|
|
|
|
$outstr .= "\n$indent"; |
1560
|
|
|
|
|
|
|
$linelen = $indent_width; |
1561
|
|
|
|
|
|
|
$maxlinelen = $maxlineNlen; |
1562
|
|
|
|
|
|
|
btw "# (l $level): Wrap after closer; ll=$linelen os=",_dbstr($outstr) if $debug; |
1563
|
|
|
|
|
|
|
} |
1564
|
|
|
|
|
|
|
$outstr .= $child->{C}; |
1565
|
|
|
|
|
|
|
$linelen += length($child->{C}); |
1566
|
|
|
|
|
|
|
--$level; |
1567
|
|
|
|
|
|
|
} else { |
1568
|
|
|
|
|
|
|
$outstr .= $child; |
1569
|
|
|
|
|
|
|
$linelen += length($child); |
1570
|
|
|
|
|
|
|
btw "# (level $level): appended SCALAR ",_dbstr($child)," os=",_dbstr($outstr) if $debug; |
1571
|
|
|
|
|
|
|
} |
1572
|
|
|
|
|
|
|
$available = $maxlinelen - $linelen; |
1573
|
|
|
|
|
|
|
$first = 0; |
1574
|
|
|
|
|
|
|
} |
1575
|
|
|
|
|
|
|
}#expand_children |
1576
|
|
|
|
|
|
|
|
1577
|
|
|
|
|
|
|
# Remove the [array wrapper] used to prepend a string to the |
1578
|
|
|
|
|
|
|
# representation of a ref, e.g. as created by _prefix_refaddr(). |
1579
|
|
|
|
|
|
|
# |
1580
|
|
|
|
|
|
|
# The original $ref was replaced by |
1581
|
|
|
|
|
|
|
# |
1582
|
|
|
|
|
|
|
# [ _MAGIC_REFPFX."prefix", $ref, _MAGIC_ELIDE_NEXT ]; |
1583
|
|
|
|
|
|
|
# |
1584
|
|
|
|
|
|
|
# Whieh Data::Dumper formatted as |
1585
|
|
|
|
|
|
|
# |
1586
|
|
|
|
|
|
|
# ["_MAGIC_REFPFXprefix", <representation of $ref> "_MAGIC_ELIDE_NEXT"] |
1587
|
|
|
|
|
|
|
# |
1588
|
|
|
|
|
|
|
# and we want to end up with |
1589
|
|
|
|
|
|
|
# |
1590
|
|
|
|
|
|
|
# prefix<representation of $ref> e.g. <984:ef8>[42,77] |
1591
|
|
|
|
|
|
|
# |
1592
|
|
|
|
|
|
|
s/\[\s*(["'])\Q${\_MAGIC_REFPFX}\E(.*?)\1,\s*/$2/gs; |
1593
|
|
|
|
|
|
|
s/,\s*(["'])\Q${\_MAGIC_ELIDE_NEXT}\E\1,?\s*\]//gs |
1594
|
|
|
|
|
|
|
&& $debug && btw "Unwrapped REFPFX ",_dbvis($_); |
1595
|
|
|
|
|
|
|
|
1596
|
|
|
|
|
|
|
while ((pos()//0) < length) { |
1597
|
|
|
|
|
|
|
if (/\G[\\\*\!]/gc) { atom($&, "prepend_to_next") } |
1598
|
|
|
|
|
|
|
elsif (/\G[,;]/gc) { atom($&, "append_to_prev") } |
1599
|
|
|
|
|
|
|
elsif (/\G"(?:[^"\\]++|\\.)*+"/gsc) { atom($&) } # "quoted" |
1600
|
|
|
|
|
|
|
elsif (/\G'(?:[^'\\]++|\\.)*+'/gsc) { atom($&) } # 'quoted' |
1601
|
|
|
|
|
|
|
elsif (m(\Gqr/(?:[^\\\/]++|\\.)*+/[a-z]*)gsc){ # Regexp |
1602
|
|
|
|
|
|
|
local $_ = $&; |
1603
|
|
|
|
|
|
|
# Data::Dumper just stringifies a compiled regex, and Perl (v5.34) |
1604
|
|
|
|
|
|
|
# does not stringify actual tab as \t etc. probably because the result |
1605
|
|
|
|
|
|
|
# would be ambiguous if preceeded by another backslash, e.g. |
1606
|
|
|
|
|
|
|
# \<tab> -> \\t would be wrong (backslash character + 't'). |
1607
|
|
|
|
|
|
|
# |
1608
|
|
|
|
|
|
|
# If 'controlpics' is enabled, they are always substituted and then |
1609
|
|
|
|
|
|
|
# a preceding backslash is not a problem; otherwise \-escapes are |
1610
|
|
|
|
|
|
|
# substituted only if not preceded by another backslash. |
1611
|
|
|
|
|
|
|
if ($controlpics) { |
1612
|
|
|
|
|
|
|
s{([\x{0}\a\b\e\f\n\r\t])}{ $char2controlpic{$1} // $1 }esg; |
1613
|
|
|
|
|
|
|
} else { |
1614
|
|
|
|
|
|
|
if (/[\x{0}\a\b\e\f\n\r\t]/) { |
1615
|
|
|
|
|
|
|
s/(?<!\\)\x{0}/\\0/g; |
1616
|
|
|
|
|
|
|
s/(?<!\\)[\b]/\N{SYMBOL FOR BACKSPACE}/; # Bare \b matches boundaries |
1617
|
|
|
|
|
|
|
s/(?<!\\)\e/\\e/g; |
1618
|
|
|
|
|
|
|
s/(?<!\\)\f/\\f/g; |
1619
|
|
|
|
|
|
|
s/(?<!\\)\x{0A}/\\n/g; |
1620
|
|
|
|
|
|
|
s/(?<!\\)\x{0D}/\\r/g; |
1621
|
|
|
|
|
|
|
s/(?<!\\)\t/\\t/g; |
1622
|
|
|
|
|
|
|
} |
1623
|
|
|
|
|
|
|
} |
1624
|
|
|
|
|
|
|
atom($_) |
1625
|
|
|
|
|
|
|
} |
1626
|
|
|
|
|
|
|
elsif (/\G${addrvis_re}/gsc) { atom($&, "prepend_to_next") } |
1627
|
|
|
|
|
|
|
|
1628
|
|
|
|
|
|
|
# With Deparse(1) the body has arbitrary Perl code, which we can't parse |
1629
|
|
|
|
|
|
|
elsif (/\Gsub\s*${curlies_re}/gc) { atom($&) } # sub{...} |
1630
|
|
|
|
|
|
|
|
1631
|
|
|
|
|
|
|
# $VAR1->[ix] $VAR1->{key} or just $varname |
1632
|
|
|
|
|
|
|
elsif (/\G(?:my\s+)?\$(?:${userident_re}|\s*->\s*|${balanced_re}+)++/gsc) { atom($&) } |
1633
|
|
|
|
|
|
|
|
1634
|
|
|
|
|
|
|
elsif (/\G\b[A-Za-z_][A-Za-z0-9_]*+\b/gc) { atom($&) } # bareword? |
1635
|
|
|
|
|
|
|
elsif (/\G-?\d[\deE\.]*+\b/gc) { atom($&) } # number |
1636
|
|
|
|
|
|
|
elsif (/\G\s*=>\s*/gc) { fat_arrow($&) } |
1637
|
|
|
|
|
|
|
elsif (/\G\s*=(?=[\w\s'"])\s*/gc) { atom($&) } |
1638
|
|
|
|
|
|
|
elsif (/\G:*${pkgname_re}/gc) { atom($&) } |
1639
|
|
|
|
|
|
|
elsif (/\G[\[\{\(]/gc) { atom($&, "open") } |
1640
|
|
|
|
|
|
|
elsif (/\G[\]\}\)]/gc) { atom($&, "close") } |
1641
|
|
|
|
|
|
|
elsif (/\G\s+/sgc) { } |
1642
|
|
|
|
|
|
|
else { |
1643
|
|
|
|
|
|
|
my $remnant = substr($_,pos//0); |
1644
|
|
|
|
|
|
|
Carp::cluck "UNPARSED ",_dbstr(substr($remnant,0,30)."...")," ",_dbstrposn($_,pos()//0),"\nFULL STRING:",_dbstr($_),"\n(Using remainder as-is)\n" ; |
1645
|
|
|
|
|
|
|
atom($remnant); |
1646
|
|
|
|
|
|
|
while (defined $context->{parent}) { atom("", "close"); } |
1647
|
|
|
|
|
|
|
last; |
1648
|
|
|
|
|
|
|
} |
1649
|
|
|
|
|
|
|
} |
1650
|
|
|
|
|
|
|
oops "Dangling prepend ",_dbstr($prepending) if $prepending; |
1651
|
|
|
|
|
|
|
|
1652
|
0
|
|
|
0
|
|
0
|
btw "--------top-------\n",_dbvisnew($top)->Sortkeys(sub{[qw/O C tlen children/]})->Dump,"\n-----------------" if $debug; |
1653
|
|
|
|
|
|
|
|
1654
|
|
|
|
|
|
|
$outstr = ""; |
1655
|
|
|
|
|
|
|
$linelen = 0; |
1656
|
|
|
|
|
|
|
$level = 0; |
1657
|
|
|
|
|
|
|
expand_children($top); |
1658
|
|
|
|
|
|
|
|
1659
|
|
|
|
|
|
|
if (index($listform,'a') >= 0) { |
1660
|
|
|
|
|
|
|
# show [...] as (val1,val2,...) array initializer |
1661
|
|
|
|
|
|
|
# Remove any initial Addrvis prefix |
1662
|
|
|
|
|
|
|
$outstr =~ s/\A(?:${addrvis_re})?\[/(/ && $outstr =~ s/\]\z/)/s or oops _dbvis($outstr); |
1663
|
|
|
|
|
|
|
} |
1664
|
|
|
|
|
|
|
elsif (index($listform,'h') >= 0) { |
1665
|
|
|
|
|
|
|
# show {...} as (key => val, ...) hash initializer |
1666
|
|
|
|
|
|
|
$outstr =~ s/\A(?:${addrvis_re})?\{/(/ && $outstr =~ s/\}\z/)/s or oops; |
1667
|
|
|
|
|
|
|
} |
1668
|
|
|
|
|
|
|
elsif (index($listform,'l') >= 0) { |
1669
|
|
|
|
|
|
|
# show as a bare list without brackets |
1670
|
|
|
|
|
|
|
$outstr =~ s/\A(?:${addrvis_re})?[\[\{]// && $outstr =~ s/[\]\}]\z//s or oops; |
1671
|
|
|
|
|
|
|
} |
1672
|
|
|
|
|
|
|
|
1673
|
|
|
|
|
|
|
# Insert user-specified padding after each embedded newline |
1674
|
|
|
|
|
|
|
if ($pad) { |
1675
|
|
|
|
|
|
|
$outstr =~ s/\n\K(?=[^\n])/$pad/g; |
1676
|
|
|
|
|
|
|
} |
1677
|
|
|
|
|
|
|
|
1678
|
|
|
|
|
|
|
$outstr |
1679
|
|
|
|
|
|
|
} #_postprocess_DD_result { |
1680
|
|
|
|
|
|
|
|
1681
|
|
|
|
|
|
|
sub _Interpolate { |
1682
|
1273
|
|
|
1273
|
|
3761
|
my ($self, $input, $i_or_d) = @_; |
1683
|
1273
|
50
|
|
|
|
3594
|
_croak_or_confess $i_or_d."vis('$input') called in void context.\nDid you forget to 'say ...'?" |
1684
|
|
|
|
|
|
|
unless defined wantarray; |
1685
|
|
|
|
|
|
|
|
1686
|
1273
|
100
|
|
|
|
3185
|
return "<undef arg>" if ! defined $input; |
1687
|
|
|
|
|
|
|
|
1688
|
1270
|
|
|
|
|
3551
|
&_SaveAndResetPunct; |
1689
|
|
|
|
|
|
|
|
1690
|
1270
|
|
|
|
|
5377
|
my $debug = $self->Debug; |
1691
|
1270
|
|
|
|
|
4555
|
my $useqq = $self->Useqq; |
1692
|
|
|
|
|
|
|
|
1693
|
1270
|
100
|
|
|
|
19604
|
my $q = $useqq ? "" : "q"; |
1694
|
1270
|
|
|
|
|
3417
|
my $funcname = $i_or_d . "vis" .$q; |
1695
|
|
|
|
|
|
|
|
1696
|
1270
|
|
|
|
|
2187
|
my @pieces; # list of [visfuncname or 'p' or 'e', inputstring] |
1697
|
1270
|
|
|
|
|
2086
|
{ local $_ = $input; |
|
1270
|
|
|
|
|
2557
|
|
1698
|
1270
|
50
|
|
|
|
4539
|
if (/\b((?:ARRAY|HASH|SCALAR)\(0x[a-fA-F0-9]+\))/) { |
1699
|
0
|
|
|
|
|
0
|
state $warned=0; |
1700
|
0
|
0
|
|
|
|
0
|
carp("Warning: String passed to $funcname may have been interpolated by Perl\n(use 'single quotes' to avoid this)\n") unless $warned++; |
1701
|
|
|
|
|
|
|
} |
1702
|
1270
|
|
|
|
|
3156
|
while ( |
1703
|
|
|
|
|
|
|
/\G ( |
1704
|
|
|
|
|
|
|
# Stuff without variable references (might include \n etc. escapes) |
1705
|
|
|
|
|
|
|
|
1706
|
|
|
|
|
|
|
#This gets "recursion limit exceeded" |
1707
|
|
|
|
|
|
|
#( (?: [^\\\$\@\%] | \\[^\$\@\%] )++ ) |
1708
|
|
|
|
|
|
|
#| |
1709
|
|
|
|
|
|
|
|
1710
|
|
|
|
|
|
|
(?: [^\\\$\@\%]++ ) |
1711
|
|
|
|
|
|
|
| |
1712
|
|
|
|
|
|
|
#(?: (?: \\[^\$\@\%] )++ ) |
1713
|
|
|
|
|
|
|
(?: (?: \\. )++ ) |
1714
|
|
|
|
|
|
|
| |
1715
|
|
|
|
|
|
|
|
1716
|
|
|
|
|
|
|
# $#arrayvar $#$$...refvarname $#{aref expr} $#$$...{ref2ref expr} |
1717
|
|
|
|
|
|
|
# |
1718
|
|
|
|
|
|
|
(?: \$\#\$*+\K ${anyvname_or_refexpr_re} ) |
1719
|
|
|
|
|
|
|
| |
1720
|
|
|
|
|
|
|
|
1721
|
|
|
|
|
|
|
# $scalarvar $$$...refvarname ${sref expr} $$$...{ref2ref expr} |
1722
|
|
|
|
|
|
|
# followed by [] {} ->[] ->{} ->method() ... «zero or more» |
1723
|
|
|
|
|
|
|
# EXCEPT $$<punctchar> is parsed as $$ followed by <punctchar> |
1724
|
|
|
|
|
|
|
|
1725
|
|
|
|
|
|
|
(?: |
1726
|
|
|
|
|
|
|
(?: \$\$++ ${pkgname_re} \K | \$ ${anyvname_or_refexpr_re} \K ) |
1727
|
|
|
|
|
|
|
(?: |
1728
|
|
|
|
|
|
|
(?: ->\K(?: ${curliesorsquares_re}|${userident_re}${parens_re}? )) |
1729
|
|
|
|
|
|
|
| |
1730
|
|
|
|
|
|
|
${curliesorsquares_re} |
1731
|
|
|
|
|
|
|
)* |
1732
|
|
|
|
|
|
|
) |
1733
|
|
|
|
|
|
|
| |
1734
|
|
|
|
|
|
|
|
1735
|
|
|
|
|
|
|
# @arrayvar @$$...varname @{aref expr} @$$...{ref2ref expr} |
1736
|
|
|
|
|
|
|
# followed by [] {} «zero or one» |
1737
|
|
|
|
|
|
|
# |
1738
|
4374
|
|
|
|
|
58971
|
(?: \@\$*+\K ${anyvname_or_refexpr_re} ${$curliesorsquares_re}? ) |
1739
|
|
|
|
|
|
|
| |
1740
|
|
|
|
|
|
|
# %hash %$hrefvar %{href expr} %$$...sref2hrefvar «no follow-ons» |
1741
|
|
|
|
|
|
|
(?: \%\$*+\K ${anyvname_or_refexpr_re} ) |
1742
|
|
|
|
|
|
|
) /xsgc) |
1743
|
|
|
|
|
|
|
{ |
1744
|
3104
|
50
|
|
|
|
32369
|
local $_ = $1; oops unless length() > 0; |
|
3104
|
|
|
|
|
6990
|
|
1745
|
3104
|
100
|
|
|
|
9170
|
if (/^[\$\@\%]/) { |
1746
|
1207
|
|
|
|
|
3443
|
my $sigl = substr($_,0,1); |
1747
|
1207
|
100
|
|
|
|
3989
|
if ($i_or_d eq 'd') { |
1748
|
|
|
|
|
|
|
# Inject a "plain text" fragment containing the "expr=" prefix, |
1749
|
|
|
|
|
|
|
# omitting the '$' sigl if the expr is a plain '$name'. |
1750
|
1178
|
100
|
|
|
|
10310
|
push @pieces, ['P', (/^\$(?!_)(${userident_re})\z/ ? $1 : $_)."="]; |
1751
|
|
|
|
|
|
|
} |
1752
|
1207
|
100
|
|
|
|
5068
|
if ($sigl eq '$') { |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
1753
|
939
|
|
|
|
|
3641
|
push @pieces, ["vis", $_]; |
1754
|
|
|
|
|
|
|
} |
1755
|
|
|
|
|
|
|
elsif ($sigl eq '@') { |
1756
|
203
|
|
|
|
|
862
|
push @pieces, ["avis", $_]; |
1757
|
|
|
|
|
|
|
} |
1758
|
|
|
|
|
|
|
elsif ($sigl eq '%') { |
1759
|
65
|
|
|
|
|
282
|
push @pieces, ["hvis", $_]; |
1760
|
|
|
|
|
|
|
} |
1761
|
0
|
|
|
|
|
0
|
else { oops } |
1762
|
|
|
|
|
|
|
} |
1763
|
|
|
|
|
|
|
else { |
1764
|
1897
|
50
|
|
|
|
6563
|
if (/^.+?(?<!\\)([\$\@\%])/) { |
1765
|
0
|
|
|
|
|
0
|
confess __PACKAGE__." bug: Missed '$1' in «$_»" |
1766
|
|
|
|
|
|
|
} |
1767
|
|
|
|
|
|
|
# Due to the need to simplify the big regexp above, \x{abcd} is now |
1768
|
|
|
|
|
|
|
# split into "\x" and "{abcd}". Combine consecutive pass-thrus |
1769
|
|
|
|
|
|
|
# into a single passthru ('p'), converted later to 'e' if an eval |
1770
|
|
|
|
|
|
|
# is needed. |
1771
|
1897
|
100
|
100
|
|
|
8140
|
if (@pieces && $pieces[-1]->[0] eq 'p') { |
1772
|
107
|
|
|
|
|
272
|
$pieces[-1]->[1] .= $_; |
1773
|
|
|
|
|
|
|
} else { |
1774
|
1790
|
|
|
|
|
7073
|
push @pieces, [ 'p', $_ ]; |
1775
|
|
|
|
|
|
|
} |
1776
|
|
|
|
|
|
|
} |
1777
|
|
|
|
|
|
|
} |
1778
|
1270
|
50
|
33
|
|
|
7179
|
if (!defined(pos) || pos() < length($_)) { |
1779
|
0
|
|
0
|
|
|
0
|
my $leftover = substr($_,pos()//0); |
1780
|
0
|
|
|
|
|
0
|
my $e; |
1781
|
|
|
|
|
|
|
# Try to recognize user syntax errors |
1782
|
0
|
0
|
|
|
|
0
|
if ($leftover =~ /^[\$\@\%][\s\%\@]/) { |
1783
|
0
|
|
|
|
|
0
|
$e = "Invalid expression syntax starting at '$leftover' in $funcname arg" |
1784
|
|
|
|
|
|
|
} else { |
1785
|
|
|
|
|
|
|
# Otherwise we may have a parser bug |
1786
|
0
|
|
|
|
|
0
|
$e = "Invalid expression (or ".__PACKAGE__." bug):\n«$leftover»"; |
1787
|
|
|
|
|
|
|
} |
1788
|
0
|
|
|
|
|
0
|
carp "$e\n"; |
1789
|
0
|
|
|
|
|
0
|
push @pieces, ['p',"<INVALID EXPRESSION>".$leftover]; |
1790
|
|
|
|
|
|
|
} |
1791
|
1270
|
|
|
|
|
3276
|
foreach (@pieces) { |
1792
|
4175
|
|
|
|
|
8577
|
my ($meth, $str) = @$_; |
1793
|
|
|
|
|
|
|
# If the user uses 'single quoted' strings then backslash escapes |
1794
|
|
|
|
|
|
|
# can not be emulated exactly as they would work in double-quoted strings |
1795
|
|
|
|
|
|
|
# because \ is inconsistently passed through, namely only when not |
1796
|
|
|
|
|
|
|
# followed by another backslash (or a quote character). |
1797
|
|
|
|
|
|
|
# say ivis '\015'; # octal escape for CR intended? |
1798
|
|
|
|
|
|
|
# say ivis '\\015'; # four literal characters \015 intended? |
1799
|
|
|
|
|
|
|
# We can not tell the difference because we get \015 in both cases. |
1800
|
|
|
|
|
|
|
# |
1801
|
|
|
|
|
|
|
# Currently we interpolate all \-escapes we see, so to get a literal |
1802
|
|
|
|
|
|
|
# backslash users must double them, e.g. |
1803
|
|
|
|
|
|
|
# say ivis 'The four char escape sequence \\\\015 produces \015'; |
1804
|
|
|
|
|
|
|
# Here-docs do not treat \ specially and so avoid this problem: |
1805
|
|
|
|
|
|
|
# say ivis <<\END; |
1806
|
|
|
|
|
|
|
# The four char escape sequence \\015 produces \015 |
1807
|
|
|
|
|
|
|
# END |
1808
|
|
|
|
|
|
|
# |
1809
|
|
|
|
|
|
|
# 0/18/23: Now really *all* \-escapes are interpolated, so this works: |
1810
|
|
|
|
|
|
|
# say ivis '\$foo = $foo' # $foo = <value> |
1811
|
|
|
|
|
|
|
|
1812
|
|
|
|
|
|
|
#next unless $meth eq 'p' && $str =~ /\\[abtnfrexXN0-7]/; |
1813
|
|
|
|
|
|
|
#$str =~ s/([()\$\@\%])/\\$1/g; # dont hide \-escapes to be interpolated! |
1814
|
|
|
|
|
|
|
|
1815
|
4175
|
100
|
|
|
|
10713
|
if ($meth eq 'p') { |
|
|
100
|
|
|
|
|
|
1816
|
1790
|
100
|
|
|
|
6330
|
if ($str =~ /\\./) { |
1817
|
463
|
|
|
|
|
1194
|
$str =~ s/\$\\/\$\\\\/g; # Assume the punct var $\ is not intended |
1818
|
463
|
|
|
|
|
1254
|
$_->[1] = "qq(" . $str . ")"; |
1819
|
463
|
|
|
|
|
1432
|
$_->[0] = 'e'; |
1820
|
|
|
|
|
|
|
} |
1821
|
|
|
|
|
|
|
} |
1822
|
|
|
|
|
|
|
elsif ($meth eq 'P') { |
1823
|
1178
|
|
|
|
|
2701
|
$_->[0] = 'p'; |
1824
|
|
|
|
|
|
|
} |
1825
|
|
|
|
|
|
|
} |
1826
|
|
|
|
|
|
|
} #local $_ |
1827
|
|
|
|
|
|
|
|
1828
|
1270
|
|
|
|
|
4533
|
@_ = ($self, $funcname, \@pieces); |
1829
|
1270
|
|
|
|
|
5057
|
goto &DB::DB_Vis_Interpolate |
1830
|
|
|
|
|
|
|
} |
1831
|
|
|
|
|
|
|
|
1832
|
|
|
|
|
|
|
sub quotekey(_) { # Quote a hash key if not a valid bareword |
1833
|
0
|
0
|
0
|
0
|
1
|
0
|
$_[0] =~ /\A${userident_re}\z/s ? $_[0] : |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
1834
|
|
|
|
|
|
|
$_[0] =~ /(?!.*')["\$\@]/ ? visq("$_[0]") : |
1835
|
|
|
|
|
|
|
$_[0] =~ /\W/ && !looks_like_number($_[0]) ? vis("$_[0]") : |
1836
|
|
|
|
|
|
|
"\"$_[0]\"" |
1837
|
|
|
|
|
|
|
} |
1838
|
|
|
|
|
|
|
|
1839
|
|
|
|
|
|
|
package |
1840
|
|
|
|
|
|
|
DB; |
1841
|
|
|
|
|
|
|
|
1842
|
|
|
|
|
|
|
sub DB_Vis_Interpolate { |
1843
|
1270
|
|
|
1270
|
0
|
3502
|
my ($self, $funcname, $pieces) = @_; |
1844
|
1270
|
|
|
|
|
2718
|
my $result = ""; |
1845
|
1270
|
|
|
|
|
3055
|
foreach my $p (@$pieces) { |
1846
|
4175
|
|
|
|
|
9147
|
my ($methname, $arg) = @$p; |
1847
|
|
|
|
|
|
|
#say "III methname=$methname arg='$arg'"; |
1848
|
4175
|
100
|
|
|
|
10148
|
if ($methname eq 'p') { |
|
|
100
|
|
|
|
|
|
1849
|
2505
|
|
|
|
|
5629
|
$result .= $arg; |
1850
|
|
|
|
|
|
|
} |
1851
|
|
|
|
|
|
|
elsif ($methname eq 'e') { |
1852
|
463
|
|
|
|
|
1362
|
$result .= DB::DB_Vis_Eval($funcname, $arg); |
1853
|
|
|
|
|
|
|
} else { |
1854
|
|
|
|
|
|
|
# Reduce width before first wrap to account for stuff already on the line |
1855
|
1207
|
|
|
|
|
3561
|
my $leftwid = length($result) - rindex($result,"\n") - 1; |
1856
|
1207
|
|
|
|
|
2382
|
my $foldwidth = $self->{Foldwidth}; |
1857
|
1207
|
|
66
|
|
|
5413
|
local $self->{Foldwidth1} = $self->{Foldwidth1} // $foldwidth; |
1858
|
1207
|
100
|
|
|
|
3035
|
if ($foldwidth) { |
1859
|
|
|
|
|
|
|
$self->{Foldwidth1} -= $leftwid if $leftwid < $self->{Foldwidth1} |
1860
|
1121
|
50
|
|
|
|
3590
|
} |
1861
|
1207
|
|
|
|
|
2962
|
$result .= $self->$methname( DB::DB_Vis_Eval($funcname, $arg) ); |
1862
|
|
|
|
|
|
|
} |
1863
|
|
|
|
|
|
|
} |
1864
|
|
|
|
|
|
|
|
1865
|
1270
|
|
|
|
|
3578
|
&Data::Dumper::Interp::_RestorePunct; # saved in _Interpolate |
1866
|
1270
|
|
|
|
|
24197
|
$result |
1867
|
|
|
|
|
|
|
}# DB_Vis_Interpolate |
1868
|
|
|
|
|
|
|
|
1869
|
|
|
|
|
|
|
# eval a string in the user's context and return the result. The nearest |
1870
|
|
|
|
|
|
|
# non-DB frame must be the original user's call; this is accomplished by |
1871
|
|
|
|
|
|
|
# dvis(), and friends using "goto &_Interpolate", which in turn |
1872
|
|
|
|
|
|
|
# does "goto &DB::DB_Vis_Interpolate" to enter package DB. |
1873
|
|
|
|
|
|
|
sub DB_Vis_Eval($$) { |
1874
|
1670
|
|
|
1670
|
0
|
3712
|
my ($label_for_errmsg, $evalarg) = @_; |
1875
|
1670
|
50
|
|
|
|
4092
|
Carp::confess("Data::Dumper::Interp bug:empty evalarg") if $evalarg eq ""; |
1876
|
|
|
|
|
|
|
# Inspired perl5db.pl but at this point has been rewritten |
1877
|
|
|
|
|
|
|
|
1878
|
|
|
|
|
|
|
# Find the closest non-DB caller. The eval will be done in that package. |
1879
|
|
|
|
|
|
|
# Find the next caller further up which has arguments (i.e. wasn't doing |
1880
|
|
|
|
|
|
|
# "&subname;"), and make @_ contain those arguments. |
1881
|
1670
|
|
|
|
|
3069
|
my ($distance, $pkg, $fname, $lno); |
1882
|
1670
|
|
|
|
|
2950
|
for ($distance = 0 ; ; $distance++) { |
1883
|
3340
|
|
|
|
|
85468
|
($pkg, $fname, $lno) = caller($distance); |
1884
|
3340
|
100
|
|
|
|
15747
|
last if $pkg ne "DB"; |
1885
|
|
|
|
|
|
|
} |
1886
|
1670
|
|
|
|
|
4783
|
local *_ = []; |
1887
|
1670
|
|
|
|
|
2704
|
while() { |
1888
|
3305
|
|
|
|
|
4508
|
$distance++; |
1889
|
3305
|
|
|
|
|
18801
|
my ($p, $hasargs) = (caller($distance))[0,4]; |
1890
|
3305
|
100
|
|
|
|
11181
|
if (! defined $p){ |
1891
|
45
|
|
|
|
|
107
|
*_ = [ '<@_ is not defined in the outer block>' ]; |
1892
|
|
|
|
|
|
|
last |
1893
|
45
|
|
|
|
|
89
|
} |
1894
|
3260
|
100
|
|
|
|
7052
|
if ($hasargs) { |
1895
|
1625
|
|
|
|
|
4830
|
*_ = [ @DB::args ]; # copy in case of recursion |
1896
|
|
|
|
|
|
|
last |
1897
|
1625
|
|
|
|
|
3521
|
} |
1898
|
|
|
|
|
|
|
} |
1899
|
|
|
|
|
|
|
|
1900
|
1670
|
|
|
|
|
3230
|
my @result = do { |
1901
|
1670
|
|
|
|
|
3405
|
local @Data::Dumper::Interp::result; |
1902
|
1670
|
|
|
|
|
6429
|
local $Data::Dumper::Interp::string_to_eval = |
1903
|
|
|
|
|
|
|
"package $pkg; " |
1904
|
|
|
|
|
|
|
# N.B. eval first clears $@ so we must restore $@ inside the eval |
1905
|
|
|
|
|
|
|
.' &Data::Dumper::Interp::_RestorePunct_NoPop;' # saved in _Interpolate |
1906
|
|
|
|
|
|
|
# In case something carps or croaks (e.g. because of ${\(somefunc())} |
1907
|
|
|
|
|
|
|
# or a tie handler), force a full backtrace so the user's call location |
1908
|
|
|
|
|
|
|
# is visible. Unfortunately there is no way to make carp() show only |
1909
|
|
|
|
|
|
|
# the location of the user's call because we must force the eval'd |
1910
|
|
|
|
|
|
|
# string into in e.g. package main so user functions can be found. |
1911
|
|
|
|
|
|
|
.' local $Carp::Verbose = 1;' |
1912
|
|
|
|
|
|
|
.' @Data::Dumper::Interp::result = '.$evalarg.';' |
1913
|
|
|
|
|
|
|
.' $Data::Dumper::Interp::save_stack[-1]->[0] = $@;' # possibly changed by a tie handler |
1914
|
|
|
|
|
|
|
; |
1915
|
|
|
|
|
|
|
###??? FIXME why is DB_Vis_Evalwrapper needed? Lexical scope? |
1916
|
1670
|
|
|
|
|
4273
|
&DB_Vis_Evalwrapper; |
1917
|
|
|
|
|
|
|
@Data::Dumper::Interp::result |
1918
|
1670
|
|
|
|
|
13265
|
}; |
1919
|
1670
|
|
|
|
|
4035
|
my $errmsg = $@; |
1920
|
|
|
|
|
|
|
|
1921
|
1670
|
50
|
|
|
|
4458
|
if ($errmsg) { |
1922
|
0
|
|
|
|
|
0
|
$errmsg = Data::Dumper::Interp::_chop_ateval($errmsg); |
1923
|
0
|
|
|
|
|
0
|
Carp::carp("${label_for_errmsg} interpolation error: $errmsg\n"); |
1924
|
0
|
0
|
|
|
|
0
|
@result = ( (defined($result[0]) ? $result[0] : "")."<invalid/error>" ); |
1925
|
|
|
|
|
|
|
} |
1926
|
|
|
|
|
|
|
|
1927
|
1670
|
50
|
|
|
|
34806
|
wantarray ? @result : (do{die "bug" if @result>1}, $result[0]) |
|
463
|
100
|
|
|
|
3629
|
|
1928
|
|
|
|
|
|
|
}# DB_Vis_Eval |
1929
|
|
|
|
|
|
|
|
1930
|
|
|
|
|
|
|
1; |
1931
|
|
|
|
|
|
|
__END__ |
1932
|
|
|
|
|
|
|
|
1933
|
|
|
|
|
|
|
=pod |
1934
|
|
|
|
|
|
|
|
1935
|
|
|
|
|
|
|
=encoding UTF-8 |
1936
|
|
|
|
|
|
|
|
1937
|
|
|
|
|
|
|
=head1 NAME |
1938
|
|
|
|
|
|
|
|
1939
|
|
|
|
|
|
|
Data::Dumper::Interp - interpolate Data::Dumper output into strings for human consumption |
1940
|
|
|
|
|
|
|
|
1941
|
|
|
|
|
|
|
=head1 SYNOPSIS |
1942
|
|
|
|
|
|
|
|
1943
|
|
|
|
|
|
|
use open IO => ':locale'; |
1944
|
|
|
|
|
|
|
use Data::Dumper::Interp; |
1945
|
|
|
|
|
|
|
|
1946
|
|
|
|
|
|
|
@ARGV = ('-i', '/file/path'); |
1947
|
|
|
|
|
|
|
my %hash = (abc => [1,2,3,4,5], def => undef); |
1948
|
|
|
|
|
|
|
my $ref = \%hash; |
1949
|
|
|
|
|
|
|
my $obj = bless {}, "Foo::Bar"; |
1950
|
|
|
|
|
|
|
|
1951
|
|
|
|
|
|
|
# Interpolate variables in strings with Data::Dumper output |
1952
|
|
|
|
|
|
|
say ivis 'FYI ref is $ref\nThat hash is: %hash\nArgs are @ARGV'; |
1953
|
|
|
|
|
|
|
|
1954
|
|
|
|
|
|
|
# -->FYI ref is {abc => [1,2,3,4,5], def => undef} |
1955
|
|
|
|
|
|
|
# That hash is: (abc => [1,2,3,4,5], def => undef) |
1956
|
|
|
|
|
|
|
# Args are ("-i","/file/path") |
1957
|
|
|
|
|
|
|
|
1958
|
|
|
|
|
|
|
# Label interpolated values with "expr=" |
1959
|
|
|
|
|
|
|
say dvis '$ref\nand @ARGV'; |
1960
|
|
|
|
|
|
|
|
1961
|
|
|
|
|
|
|
#-->ref={abc => [1,2,3,4,5], def => undef} |
1962
|
|
|
|
|
|
|
# and @ARGV=("-i","/file/path") |
1963
|
|
|
|
|
|
|
|
1964
|
|
|
|
|
|
|
# Functions to format one thing |
1965
|
|
|
|
|
|
|
say vis $ref; # {abc => [1,2,3,4,5], def => undef} |
1966
|
|
|
|
|
|
|
say vis \@ARGV; # ["-i", "/file/path"] # any scalar |
1967
|
|
|
|
|
|
|
say avis @ARGV; # ("-i", "/file/path") |
1968
|
|
|
|
|
|
|
say hvis %hash; # (abc => [1,2,3,4,5], def => undef) |
1969
|
|
|
|
|
|
|
|
1970
|
|
|
|
|
|
|
# Format a reference with abbreviated referent address |
1971
|
|
|
|
|
|
|
say visr $href; # HASH<457:1c9>{abc => [1,2,3,4,5], ...} |
1972
|
|
|
|
|
|
|
|
1973
|
|
|
|
|
|
|
# Just abbreviate a referent address or arbitrary number |
1974
|
|
|
|
|
|
|
say addrvis refaddr($ref); # 457:1c9 |
1975
|
|
|
|
|
|
|
say addrvis $ref; # HASH<457:1c9> |
1976
|
|
|
|
|
|
|
say addrvis $obj; # Foo::Bar<984:ef8> |
1977
|
|
|
|
|
|
|
|
1978
|
|
|
|
|
|
|
# Stringify objects |
1979
|
|
|
|
|
|
|
{ use bigint; |
1980
|
|
|
|
|
|
|
my $struct = { debt => 999_999_999_999_999_999.02 }; |
1981
|
|
|
|
|
|
|
say vis $struct; |
1982
|
|
|
|
|
|
|
# --> {debt => (Math::BigFloat)999999999999999999.02} |
1983
|
|
|
|
|
|
|
|
1984
|
|
|
|
|
|
|
# But if you do want to see object internals... |
1985
|
|
|
|
|
|
|
# |
1986
|
|
|
|
|
|
|
say visnew->viso($struct); |
1987
|
|
|
|
|
|
|
# --> {debt => bless({...lots of stuff...},'Math::BigInt')} |
1988
|
|
|
|
|
|
|
|
1989
|
|
|
|
|
|
|
# These do the same thing |
1990
|
|
|
|
|
|
|
say visnew->Objects(0)->vis($struct); |
1991
|
|
|
|
|
|
|
{ local $Data::Dumper::Interp::Objects=0; say vis $struct; } |
1992
|
|
|
|
|
|
|
say viso $struct; # 'viso' is not exported by default |
1993
|
|
|
|
|
|
|
} |
1994
|
|
|
|
|
|
|
|
1995
|
|
|
|
|
|
|
# Wide characters are readable |
1996
|
|
|
|
|
|
|
use utf8; |
1997
|
|
|
|
|
|
|
my $h = {msg => "My language is not ASCII ☻ ☺ 😊 \N{U+2757}!"}; |
1998
|
|
|
|
|
|
|
say dvis '$h' ; |
1999
|
|
|
|
|
|
|
# --> h={msg => "My language is not ASCII ☻ ☺ 😊 ❗!"} |
2000
|
|
|
|
|
|
|
|
2001
|
|
|
|
|
|
|
#-------- OO API -------- |
2002
|
|
|
|
|
|
|
|
2003
|
|
|
|
|
|
|
say visnew->MaxStringwidth(50)->Maxdepth($levels)->vis($datum); |
2004
|
|
|
|
|
|
|
|
2005
|
|
|
|
|
|
|
say Data::Dumper::Interp->new() |
2006
|
|
|
|
|
|
|
->MaxStringwidth(50)->Maxdepth($levels)->vis($datum); |
2007
|
|
|
|
|
|
|
|
2008
|
|
|
|
|
|
|
#-------- UTILITY FUNCTIONS -------- |
2009
|
|
|
|
|
|
|
say u($might_be_undef); # $_[0] // "undef" |
2010
|
|
|
|
|
|
|
say quotekey($string); # quote if not a valid bareword |
2011
|
|
|
|
|
|
|
say qsh($string); # quote if needed for /bin/sh |
2012
|
|
|
|
|
|
|
say qshpath($pathname); # shell quote excepting ~ prefix |
2013
|
|
|
|
|
|
|
say "Runing this: ", qshlist(@command_and_args); |
2014
|
|
|
|
|
|
|
|
2015
|
|
|
|
|
|
|
system "ls -ld ".join(" ",map{ qshpath } |
2016
|
|
|
|
|
|
|
("/tmp", "~sally/My Documents", "~")); |
2017
|
|
|
|
|
|
|
|
2018
|
|
|
|
|
|
|
|
2019
|
|
|
|
|
|
|
=head1 DESCRIPTION |
2020
|
|
|
|
|
|
|
|
2021
|
|
|
|
|
|
|
This Data::Dumper wrapper optimizes output for human consumption |
2022
|
|
|
|
|
|
|
and avoids side-effects which interfere with debugging. |
2023
|
|
|
|
|
|
|
|
2024
|
|
|
|
|
|
|
The namesake feature is interpolating Data::Dumper output |
2025
|
|
|
|
|
|
|
into strings. Simple functions are also provided |
2026
|
|
|
|
|
|
|
to format a scalar, array, or hash. |
2027
|
|
|
|
|
|
|
|
2028
|
|
|
|
|
|
|
Internally, Data::Dumper is called to visualize (i.e. format) data |
2029
|
|
|
|
|
|
|
with pre- and post-processing to "improve" the results: |
2030
|
|
|
|
|
|
|
|
2031
|
|
|
|
|
|
|
=over 2 |
2032
|
|
|
|
|
|
|
|
2033
|
|
|
|
|
|
|
=item * Output is 1 line if possible, |
2034
|
|
|
|
|
|
|
otherwise folded at your terminal width, WITHOUT a trailing newline. |
2035
|
|
|
|
|
|
|
|
2036
|
|
|
|
|
|
|
=item * Safely printable Unicode characters appear as themselves. |
2037
|
|
|
|
|
|
|
|
2038
|
|
|
|
|
|
|
=item * Object internals are not shown by default; Math:BigInt etc. are stringified. |
2039
|
|
|
|
|
|
|
|
2040
|
|
|
|
|
|
|
=item * "virtual" values behind overloaded deref operators are shown. |
2041
|
|
|
|
|
|
|
|
2042
|
|
|
|
|
|
|
=item * Data::Dumper bugs^H^H^H^Hquirks are circumvented. |
2043
|
|
|
|
|
|
|
|
2044
|
|
|
|
|
|
|
=back |
2045
|
|
|
|
|
|
|
|
2046
|
|
|
|
|
|
|
See "DIFFERENCES FROM Data::Dumper". |
2047
|
|
|
|
|
|
|
|
2048
|
|
|
|
|
|
|
Utilities are also provided to quote strings for /bin/sh. |
2049
|
|
|
|
|
|
|
|
2050
|
|
|
|
|
|
|
=head1 FUNCTIONS |
2051
|
|
|
|
|
|
|
|
2052
|
|
|
|
|
|
|
=head2 ivis I<'string to be interpolated'> |
2053
|
|
|
|
|
|
|
|
2054
|
|
|
|
|
|
|
Returns the argument with variable references and escapes interpolated |
2055
|
|
|
|
|
|
|
as in in Perl double-quotish strings, but using Data::Dumper to |
2056
|
|
|
|
|
|
|
format variable values. |
2057
|
|
|
|
|
|
|
|
2058
|
|
|
|
|
|
|
C<$var> is replaced by its value, |
2059
|
|
|
|
|
|
|
C<@var> is replaced by "(comma, sparated, list)", |
2060
|
|
|
|
|
|
|
and C<%hash> by "(key => value, ...)" . |
2061
|
|
|
|
|
|
|
Complex expressions with indexing, dereferences, slices |
2062
|
|
|
|
|
|
|
and method calls are also recognized. |
2063
|
|
|
|
|
|
|
|
2064
|
|
|
|
|
|
|
Expressions are evaluated in the caller's context using Perl's debugger |
2065
|
|
|
|
|
|
|
hooks, and may refer to almost any lexical or global visible at |
2066
|
|
|
|
|
|
|
the point of call (see "LIMITATIONS"). |
2067
|
|
|
|
|
|
|
|
2068
|
|
|
|
|
|
|
IMPORTANT: The argument must be single-quoted to prevent Perl |
2069
|
|
|
|
|
|
|
from interpolating it beforehand. |
2070
|
|
|
|
|
|
|
|
2071
|
|
|
|
|
|
|
=head2 dvis I<'string to be interpolated'> |
2072
|
|
|
|
|
|
|
|
2073
|
|
|
|
|
|
|
Like C<ivis> but interpolations are prefixed with a "expr=" label |
2074
|
|
|
|
|
|
|
and spaces are shown visibly as '·'. |
2075
|
|
|
|
|
|
|
|
2076
|
|
|
|
|
|
|
The 'd' in 'dvis' stands for B<d>ebugging messages, a frequent use case where |
2077
|
|
|
|
|
|
|
brevity of typing is needed. |
2078
|
|
|
|
|
|
|
|
2079
|
|
|
|
|
|
|
=head2 vis [I<SCALAREXPR>] |
2080
|
|
|
|
|
|
|
|
2081
|
|
|
|
|
|
|
=head2 avis I<LIST> |
2082
|
|
|
|
|
|
|
|
2083
|
|
|
|
|
|
|
=head2 hvis I<EVENLIST> |
2084
|
|
|
|
|
|
|
|
2085
|
|
|
|
|
|
|
C<vis> formats a single scalar ($_ if no argument is given) |
2086
|
|
|
|
|
|
|
and returns the resulting string. |
2087
|
|
|
|
|
|
|
|
2088
|
|
|
|
|
|
|
C<avis> formats an array (or any list) as comma-separated values in parenthesis. |
2089
|
|
|
|
|
|
|
|
2090
|
|
|
|
|
|
|
C<hvis> formats key => value pairs in parenthesis. |
2091
|
|
|
|
|
|
|
|
2092
|
|
|
|
|
|
|
=head2 FUNCTION (and METHOD) VARIATIONS |
2093
|
|
|
|
|
|
|
|
2094
|
|
|
|
|
|
|
Variations of the above five functions have extra characters |
2095
|
|
|
|
|
|
|
in their names to imply certain options. |
2096
|
|
|
|
|
|
|
For example C<visq> is like C<vis> but |
2097
|
|
|
|
|
|
|
shows strings in single-quoted form (implied by the 'B<q>' suffix). |
2098
|
|
|
|
|
|
|
|
2099
|
|
|
|
|
|
|
There are no fixed function names; you can use any combination of |
2100
|
|
|
|
|
|
|
characters in any order, prefixed or suffixed to the primary name |
2101
|
|
|
|
|
|
|
with optional '_' separators. |
2102
|
|
|
|
|
|
|
The function will be I<generated> when it is imported* or called as a method. |
2103
|
|
|
|
|
|
|
|
2104
|
|
|
|
|
|
|
The available modifier characters are: |
2105
|
|
|
|
|
|
|
|
2106
|
|
|
|
|
|
|
=over 2 |
2107
|
|
|
|
|
|
|
|
2108
|
|
|
|
|
|
|
B<l> - omit parenthesis to return a bare list (only with "avis" or "hvis") |
2109
|
|
|
|
|
|
|
|
2110
|
|
|
|
|
|
|
B<o> - show object internals |
2111
|
|
|
|
|
|
|
|
2112
|
|
|
|
|
|
|
=over |
2113
|
|
|
|
|
|
|
|
2114
|
|
|
|
|
|
|
Calling B<< Objects(0) >> using the OO api has the same effect. |
2115
|
|
|
|
|
|
|
|
2116
|
|
|
|
|
|
|
=back |
2117
|
|
|
|
|
|
|
|
2118
|
|
|
|
|
|
|
B<q> - show strings 'single quoted' if possible |
2119
|
|
|
|
|
|
|
|
2120
|
|
|
|
|
|
|
=over |
2121
|
|
|
|
|
|
|
|
2122
|
|
|
|
|
|
|
Internally, Data::Dumper is called with C<Useqq(0)>, but depending |
2123
|
|
|
|
|
|
|
on the version of Data::Dumper the result may be "double quoted" |
2124
|
|
|
|
|
|
|
anyway if wide characters are present. |
2125
|
|
|
|
|
|
|
|
2126
|
|
|
|
|
|
|
=back |
2127
|
|
|
|
|
|
|
|
2128
|
|
|
|
|
|
|
B<r> - show abbreviated addresses of objects and other refs |
2129
|
|
|
|
|
|
|
|
2130
|
|
|
|
|
|
|
=over |
2131
|
|
|
|
|
|
|
|
2132
|
|
|
|
|
|
|
Calling B<< Reftype(1) >> using the OO api has the same effect. |
2133
|
|
|
|
|
|
|
|
2134
|
|
|
|
|
|
|
=back |
2135
|
|
|
|
|
|
|
|
2136
|
|
|
|
|
|
|
B<< <NUMBER> >> - limit nested structure depth to <NUMBER> levels |
2137
|
|
|
|
|
|
|
|
2138
|
|
|
|
|
|
|
=over |
2139
|
|
|
|
|
|
|
|
2140
|
|
|
|
|
|
|
Calling B<< Maxdepth(NUMBER) >> using the OO api has the same effect. |
2141
|
|
|
|
|
|
|
|
2142
|
|
|
|
|
|
|
=back |
2143
|
|
|
|
|
|
|
|
2144
|
|
|
|
|
|
|
=back |
2145
|
|
|
|
|
|
|
|
2146
|
|
|
|
|
|
|
Functions must be imported explicitly |
2147
|
|
|
|
|
|
|
unless they are imported by default (list shown below) |
2148
|
|
|
|
|
|
|
or created via the :all tag. |
2149
|
|
|
|
|
|
|
|
2150
|
|
|
|
|
|
|
To avoid having to import functions in advance, you can |
2151
|
|
|
|
|
|
|
use them as methods and import only the C<visnew> function: |
2152
|
|
|
|
|
|
|
|
2153
|
|
|
|
|
|
|
use Spreadsheet::Edit::Interp qw/visnew/; |
2154
|
|
|
|
|
|
|
... |
2155
|
|
|
|
|
|
|
say visnew->vis($struct); |
2156
|
|
|
|
|
|
|
say visnew->visrq($my_object); |
2157
|
|
|
|
|
|
|
say visnew->avis(@ARGV); |
2158
|
|
|
|
|
|
|
say visnew->avis2lrq(@ARGV); |
2159
|
|
|
|
|
|
|
etc. |
2160
|
|
|
|
|
|
|
|
2161
|
|
|
|
|
|
|
(C<visnew> creates a new object. Non-existent methods are auto-generated when |
2162
|
|
|
|
|
|
|
first called via the AUTOLOAD mechanism). |
2163
|
|
|
|
|
|
|
|
2164
|
|
|
|
|
|
|
=head2 Functions imported by default |
2165
|
|
|
|
|
|
|
|
2166
|
|
|
|
|
|
|
ivis dvis vis avis hvis |
2167
|
|
|
|
|
|
|
|
2168
|
|
|
|
|
|
|
ivisq dvisq visq avisq hvisq rvis rvisq |
2169
|
|
|
|
|
|
|
|
2170
|
|
|
|
|
|
|
visnew |
2171
|
|
|
|
|
|
|
addrvis addrvisl |
2172
|
|
|
|
|
|
|
u quotekey qsh qshlist qshpath |
2173
|
|
|
|
|
|
|
|
2174
|
|
|
|
|
|
|
=head2 The :all import tag |
2175
|
|
|
|
|
|
|
Z<> Z<> |
2176
|
|
|
|
|
|
|
|
2177
|
|
|
|
|
|
|
use Data::Dumper::Interp qw/:all/; |
2178
|
|
|
|
|
|
|
|
2179
|
|
|
|
|
|
|
This generates and imports all possible variations using suffix |
2180
|
|
|
|
|
|
|
characters in alphabetical order, without underscores, with NUMBER <= 2. |
2181
|
|
|
|
|
|
|
There are 119 variations, too many to remember. |
2182
|
|
|
|
|
|
|
|
2183
|
|
|
|
|
|
|
You only need to know the basic names |
2184
|
|
|
|
|
|
|
|
2185
|
|
|
|
|
|
|
ivis, dvis, vis, avis, and hvis |
2186
|
|
|
|
|
|
|
|
2187
|
|
|
|
|
|
|
and the possible suffixes and their |
2188
|
|
|
|
|
|
|
order (I<< <NUMBER> >>,C<l>,C<o>,C<q>,C<r>). |
2189
|
|
|
|
|
|
|
|
2190
|
|
|
|
|
|
|
For example, one function is C<< B<avis2lq> >>, which |
2191
|
|
|
|
|
|
|
|
2192
|
|
|
|
|
|
|
* Formats multiple arguments as an array ('avis') |
2193
|
|
|
|
|
|
|
* Decends at most 2 levels into structures ('2') |
2194
|
|
|
|
|
|
|
* Returns a comma-separated list *without* parenthesis ('l') |
2195
|
|
|
|
|
|
|
* Shows strings in single-quoted form ('q') |
2196
|
|
|
|
|
|
|
|
2197
|
|
|
|
|
|
|
You could have used alternate names for the same function such as C<avis2ql>, |
2198
|
|
|
|
|
|
|
C<q2avisl>, C<q_2_avis_l> etc. if called as methods or explicitly imported. |
2199
|
|
|
|
|
|
|
|
2200
|
|
|
|
|
|
|
* To save memory, only stub declarations with prototypes are generated |
2201
|
|
|
|
|
|
|
for imported functions. |
2202
|
|
|
|
|
|
|
Bodies are generated when actually used via the AUTOLOAD mechanism. |
2203
|
|
|
|
|
|
|
The C<:debug> import tag prints messages chronicling these events. |
2204
|
|
|
|
|
|
|
|
2205
|
|
|
|
|
|
|
=head1 Showing Abbreviated Addresses |
2206
|
|
|
|
|
|
|
|
2207
|
|
|
|
|
|
|
=head2 addrvis I<REF_or_NUMBER> |
2208
|
|
|
|
|
|
|
|
2209
|
|
|
|
|
|
|
This function returns a string representing an address in both decimal and |
2210
|
|
|
|
|
|
|
hexadecimal, but abbreviated to only the last few digits. |
2211
|
|
|
|
|
|
|
|
2212
|
|
|
|
|
|
|
The number of digits starts at 3 and increases over time if necessary |
2213
|
|
|
|
|
|
|
to keep new results unambiguous. |
2214
|
|
|
|
|
|
|
|
2215
|
|
|
|
|
|
|
For REFs, the result is like I<< "HASHE<lt>457:1c9E<gt>" >> |
2216
|
|
|
|
|
|
|
or, for blessed objects, I<< "Package::NameE<lt>457:1c9E<gt>" >>. |
2217
|
|
|
|
|
|
|
|
2218
|
|
|
|
|
|
|
If the argument is a plain number, just the abbreviated address |
2219
|
|
|
|
|
|
|
is returned, e.g. I<< "E<lt>457:1c9E<gt>" >>. |
2220
|
|
|
|
|
|
|
|
2221
|
|
|
|
|
|
|
I<"undef"> is returned if the argument is undefined. |
2222
|
|
|
|
|
|
|
Croaks if the argument is defined but not a ref. |
2223
|
|
|
|
|
|
|
|
2224
|
|
|
|
|
|
|
C<addrvis_digits(NUMBER)> forces a minimum width |
2225
|
|
|
|
|
|
|
and C<addrvis_forget()> discards past values and resets to 3 digits. |
2226
|
|
|
|
|
|
|
|
2227
|
|
|
|
|
|
|
=head2 addrvisl I<REF_or_NUMBER> |
2228
|
|
|
|
|
|
|
|
2229
|
|
|
|
|
|
|
Like C<addrvis> but omits the <angle brackets>. |
2230
|
|
|
|
|
|
|
|
2231
|
|
|
|
|
|
|
=head1 OBJECT-ORIENTED API |
2232
|
|
|
|
|
|
|
|
2233
|
|
|
|
|
|
|
=head2 Data::Dumper::Interp->new() |
2234
|
|
|
|
|
|
|
|
2235
|
|
|
|
|
|
|
=head2 visnew() |
2236
|
|
|
|
|
|
|
|
2237
|
|
|
|
|
|
|
These create an object initialized from the global configuration |
2238
|
|
|
|
|
|
|
variables listed below. No arguments are permitted. |
2239
|
|
|
|
|
|
|
C<visnew> is simply a shorthand wrapper. |
2240
|
|
|
|
|
|
|
|
2241
|
|
|
|
|
|
|
B<All the functions described above> and any variations |
2242
|
|
|
|
|
|
|
may be called as I<methods> on an object |
2243
|
|
|
|
|
|
|
(when not called as a method the functions create a new object internally). |
2244
|
|
|
|
|
|
|
|
2245
|
|
|
|
|
|
|
For example: |
2246
|
|
|
|
|
|
|
|
2247
|
|
|
|
|
|
|
$msg = visnew->Foldwidth(40)->avis(@ARGV); |
2248
|
|
|
|
|
|
|
|
2249
|
|
|
|
|
|
|
returns the same string as |
2250
|
|
|
|
|
|
|
|
2251
|
|
|
|
|
|
|
local $Data::Dumper::Interp::Foldwidth = 40; |
2252
|
|
|
|
|
|
|
$msg = avis @ARGV; |
2253
|
|
|
|
|
|
|
|
2254
|
|
|
|
|
|
|
"Variations" can be called similarly, for example |
2255
|
|
|
|
|
|
|
|
2256
|
|
|
|
|
|
|
$msg = visnew->Foldwidth(40)->vis_r2($x); # show addresses; Maxdepth 2 |
2257
|
|
|
|
|
|
|
|
2258
|
|
|
|
|
|
|
=head1 Configuration Variables / Methods |
2259
|
|
|
|
|
|
|
|
2260
|
|
|
|
|
|
|
These work the same way as variables/methods in Data::Dumper. |
2261
|
|
|
|
|
|
|
|
2262
|
|
|
|
|
|
|
Each config method has a corresponding global variable |
2263
|
|
|
|
|
|
|
in package C<Data::Dumper::Interp> which provides the default value. |
2264
|
|
|
|
|
|
|
|
2265
|
|
|
|
|
|
|
When a config method is called without arguments the current value is returned, |
2266
|
|
|
|
|
|
|
and when called with an argument the value is changed and |
2267
|
|
|
|
|
|
|
the object is returned so that calls can be chained. |
2268
|
|
|
|
|
|
|
|
2269
|
|
|
|
|
|
|
=head2 MaxStringwidth(I<INTEGER>) |
2270
|
|
|
|
|
|
|
|
2271
|
|
|
|
|
|
|
=head2 Truncsuffix(I<"...">) |
2272
|
|
|
|
|
|
|
|
2273
|
|
|
|
|
|
|
Longer strings are truncated and I<Truncsuffix> appended. |
2274
|
|
|
|
|
|
|
MaxStringwidth=0 (the default) means no limit. |
2275
|
|
|
|
|
|
|
|
2276
|
|
|
|
|
|
|
=head2 Foldwidth(I<INTEGER>) |
2277
|
|
|
|
|
|
|
|
2278
|
|
|
|
|
|
|
Defaults to the terminal width at the time of first use. |
2279
|
|
|
|
|
|
|
|
2280
|
|
|
|
|
|
|
=head2 Objects(I<BOOL>); |
2281
|
|
|
|
|
|
|
|
2282
|
|
|
|
|
|
|
=head2 Objects(I<"classname">) |
2283
|
|
|
|
|
|
|
|
2284
|
|
|
|
|
|
|
=head2 Objects(I<[ list of classnames ]>) |
2285
|
|
|
|
|
|
|
|
2286
|
|
|
|
|
|
|
A I<false> value disables special handling of objects |
2287
|
|
|
|
|
|
|
(that is, blessed things) and internals are shown as with Data::Dumper. |
2288
|
|
|
|
|
|
|
|
2289
|
|
|
|
|
|
|
A "1" (the default) enables for all objects, |
2290
|
|
|
|
|
|
|
otherwise only for the specified class name(s) or derived classes. |
2291
|
|
|
|
|
|
|
|
2292
|
|
|
|
|
|
|
When enabled, object internals are never shown. |
2293
|
|
|
|
|
|
|
The class and abbreviated address are shown as with C<addrvis> |
2294
|
|
|
|
|
|
|
e.g. "Foo::Bar<392:0f0>", unless the object overloads |
2295
|
|
|
|
|
|
|
the stringification ('""') operator, |
2296
|
|
|
|
|
|
|
or array-, hash-, scalar-, or glob- deref operators; |
2297
|
|
|
|
|
|
|
in that case the first overloaded operator found will be evaluated, |
2298
|
|
|
|
|
|
|
the object replaced by the result, and the check repeated. |
2299
|
|
|
|
|
|
|
|
2300
|
|
|
|
|
|
|
=head2 Sortkeys(I<SUBREF>) |
2301
|
|
|
|
|
|
|
|
2302
|
|
|
|
|
|
|
The default sorts numeric substrings in keys by numerical |
2303
|
|
|
|
|
|
|
value, e.g. "A.20" sorts before "A.100". See C<Data::Dumper> documentation. |
2304
|
|
|
|
|
|
|
|
2305
|
|
|
|
|
|
|
=head2 Useqq(I<argument>) |
2306
|
|
|
|
|
|
|
|
2307
|
|
|
|
|
|
|
0 means generate 'single quoted' strings when possible. |
2308
|
|
|
|
|
|
|
|
2309
|
|
|
|
|
|
|
1 means generate "double quoted" strings as-is from Data::Dumper. |
2310
|
|
|
|
|
|
|
Non-ASCII charcters will be shown as hex escapes. |
2311
|
|
|
|
|
|
|
|
2312
|
|
|
|
|
|
|
Otherwise generate "double quoted" strings enhanced according to option |
2313
|
|
|
|
|
|
|
keywords given as a :-separated list, e.g. Useqq("unicode:controlpics"). |
2314
|
|
|
|
|
|
|
The avilable options are: |
2315
|
|
|
|
|
|
|
|
2316
|
|
|
|
|
|
|
=over 4 |
2317
|
|
|
|
|
|
|
|
2318
|
|
|
|
|
|
|
=item "unicode" |
2319
|
|
|
|
|
|
|
|
2320
|
|
|
|
|
|
|
Printable ("graphic") |
2321
|
|
|
|
|
|
|
characters are shown as themselves rather than hex escapes, and |
2322
|
|
|
|
|
|
|
'\n', '\t', etc. are shown for ASCII control codes. |
2323
|
|
|
|
|
|
|
|
2324
|
|
|
|
|
|
|
=item "controlpics" |
2325
|
|
|
|
|
|
|
|
2326
|
|
|
|
|
|
|
Show ASCII control characters using single "control picture" characters: |
2327
|
|
|
|
|
|
|
'' is shown for newline instead of '\n', and |
2328
|
|
|
|
|
|
|
similarly ␀ ␇ ␈ ␛ ␌ ␍ ␉ for \0 \a \b \e \f \r \t. |
2329
|
|
|
|
|
|
|
|
2330
|
|
|
|
|
|
|
Every character occupies the same space with a fixed-width font, but |
2331
|
|
|
|
|
|
|
the tiny "control picures" can be hard to read; |
2332
|
|
|
|
|
|
|
to see traditional \n etc. while still seeing wide characters as themselves, |
2333
|
|
|
|
|
|
|
set C<Useqq> to just "unicode"; |
2334
|
|
|
|
|
|
|
|
2335
|
|
|
|
|
|
|
=item "spacedots" |
2336
|
|
|
|
|
|
|
|
2337
|
|
|
|
|
|
|
Space characters are shown as '·' (Middle Dot). |
2338
|
|
|
|
|
|
|
|
2339
|
|
|
|
|
|
|
=item "qq" |
2340
|
|
|
|
|
|
|
|
2341
|
|
|
|
|
|
|
=item "qq=XY" |
2342
|
|
|
|
|
|
|
|
2343
|
|
|
|
|
|
|
Show using Perl's qq{...} or qqX...Y syntax, rather than "double quotes". |
2344
|
|
|
|
|
|
|
|
2345
|
|
|
|
|
|
|
=back |
2346
|
|
|
|
|
|
|
|
2347
|
|
|
|
|
|
|
The default is C<Useqq('unicode')> except for |
2348
|
|
|
|
|
|
|
functions/methods with 'q' in their name, which force C<Useqq(0)>. |
2349
|
|
|
|
|
|
|
|
2350
|
|
|
|
|
|
|
=head2 Quotekeys |
2351
|
|
|
|
|
|
|
|
2352
|
|
|
|
|
|
|
=head2 Maxdepth |
2353
|
|
|
|
|
|
|
|
2354
|
|
|
|
|
|
|
=head2 Maxrecurse |
2355
|
|
|
|
|
|
|
|
2356
|
|
|
|
|
|
|
=head2 Deparse |
2357
|
|
|
|
|
|
|
|
2358
|
|
|
|
|
|
|
=head2 Deepcopy |
2359
|
|
|
|
|
|
|
|
2360
|
|
|
|
|
|
|
See C<Data::Dumper> documentation. |
2361
|
|
|
|
|
|
|
|
2362
|
|
|
|
|
|
|
=head1 |
2363
|
|
|
|
|
|
|
|
2364
|
|
|
|
|
|
|
=head1 UTILITY FUNCTIONS |
2365
|
|
|
|
|
|
|
|
2366
|
|
|
|
|
|
|
=head2 u |
2367
|
|
|
|
|
|
|
|
2368
|
|
|
|
|
|
|
=head2 u I<SCALAR> |
2369
|
|
|
|
|
|
|
|
2370
|
|
|
|
|
|
|
Returns the argument ($_ by default) if it is defined, otherwise |
2371
|
|
|
|
|
|
|
the string "undef". |
2372
|
|
|
|
|
|
|
|
2373
|
|
|
|
|
|
|
=head2 quotekey |
2374
|
|
|
|
|
|
|
|
2375
|
|
|
|
|
|
|
=head2 quotekey I<SCALAR> |
2376
|
|
|
|
|
|
|
|
2377
|
|
|
|
|
|
|
Returns the argument ($_ by default) if it is a valid bareword, |
2378
|
|
|
|
|
|
|
otherwise a "quoted string". |
2379
|
|
|
|
|
|
|
|
2380
|
|
|
|
|
|
|
=head2 qsh |
2381
|
|
|
|
|
|
|
|
2382
|
|
|
|
|
|
|
=head2 qsh I<$string> |
2383
|
|
|
|
|
|
|
|
2384
|
|
|
|
|
|
|
The string ($_ by default) is quoted if necessary for parsing |
2385
|
|
|
|
|
|
|
by the shell (/bin/sh), which has different quoting rules than Perl. |
2386
|
|
|
|
|
|
|
On Win32 quoting is for cmd.com. |
2387
|
|
|
|
|
|
|
|
2388
|
|
|
|
|
|
|
If the string contains only "shell-safe" ASCII characters |
2389
|
|
|
|
|
|
|
it is returned as-is, without quotes. |
2390
|
|
|
|
|
|
|
|
2391
|
|
|
|
|
|
|
If the argument is a ref but is not an object which stringifies, |
2392
|
|
|
|
|
|
|
then vis() is called and the resulting string quoted. |
2393
|
|
|
|
|
|
|
An undefined value is shown as C<undef> without quotes; |
2394
|
|
|
|
|
|
|
as a special case to avoid ambiguity the string 'undef' is always "quoted". |
2395
|
|
|
|
|
|
|
|
2396
|
|
|
|
|
|
|
=head2 qshpath I<$might_have_tilde_prefix> |
2397
|
|
|
|
|
|
|
|
2398
|
|
|
|
|
|
|
Like C<qsh> except that an initial ~ or ~username is left |
2399
|
|
|
|
|
|
|
unquoted. Useful with bash or csh. |
2400
|
|
|
|
|
|
|
|
2401
|
|
|
|
|
|
|
=head2 qshlist I<@items> |
2402
|
|
|
|
|
|
|
|
2403
|
|
|
|
|
|
|
Format e.g. a shell command and arguments, quoting when necessary. |
2404
|
|
|
|
|
|
|
|
2405
|
|
|
|
|
|
|
Returns a string with the items separated by spaces. |
2406
|
|
|
|
|
|
|
|
2407
|
|
|
|
|
|
|
=head1 LIMITATIONS |
2408
|
|
|
|
|
|
|
|
2409
|
|
|
|
|
|
|
=over 2 |
2410
|
|
|
|
|
|
|
|
2411
|
|
|
|
|
|
|
=item Interpolated Strings |
2412
|
|
|
|
|
|
|
|
2413
|
|
|
|
|
|
|
C<ivis> and C<dvis> evaluate expressions in the user's context |
2414
|
|
|
|
|
|
|
using Perl's debugger support ('eval' in package DB -- see I<perlfunc>). |
2415
|
|
|
|
|
|
|
This mechanism has some limitations: |
2416
|
|
|
|
|
|
|
|
2417
|
|
|
|
|
|
|
@_ may show incorrect values except immediately after sub entry. |
2418
|
|
|
|
|
|
|
For example after "shift" @_ will appear to still have the original arguments. |
2419
|
|
|
|
|
|
|
|
2420
|
|
|
|
|
|
|
A lexical ("my") sub creates a closure, and variables in visible scopes |
2421
|
|
|
|
|
|
|
which are not actually referenced by your code may not exist in the closure; |
2422
|
|
|
|
|
|
|
an attempt to display them with C<ivis> will fail. For example: |
2423
|
|
|
|
|
|
|
|
2424
|
|
|
|
|
|
|
our $global; |
2425
|
|
|
|
|
|
|
sub outerfunc { |
2426
|
|
|
|
|
|
|
my sub inner { |
2427
|
|
|
|
|
|
|
say dvis '$global'; # croaks with "Error interpolating '$global'" |
2428
|
|
|
|
|
|
|
# my $x = $global; # ... unless this is un-commented |
2429
|
|
|
|
|
|
|
} |
2430
|
|
|
|
|
|
|
&inner(); |
2431
|
|
|
|
|
|
|
} |
2432
|
|
|
|
|
|
|
&outerfunc; |
2433
|
|
|
|
|
|
|
|
2434
|
|
|
|
|
|
|
|
2435
|
|
|
|
|
|
|
=item Multiply-referenced items |
2436
|
|
|
|
|
|
|
|
2437
|
|
|
|
|
|
|
If a structure contains several refs to the same item, |
2438
|
|
|
|
|
|
|
the first ref will be visualized by showing the referenced item |
2439
|
|
|
|
|
|
|
as you might expect. |
2440
|
|
|
|
|
|
|
|
2441
|
|
|
|
|
|
|
However subsequent refs will look like C<< $VAR1->place >> |
2442
|
|
|
|
|
|
|
where C<place> is the location of the first ref in the overall structure. |
2443
|
|
|
|
|
|
|
This is how Data::Dumper indicates that the ref is a copy of the first |
2444
|
|
|
|
|
|
|
ref and thus points to the same datum. |
2445
|
|
|
|
|
|
|
"$VAR1" is an artifact of how Data::Dumper would generate code |
2446
|
|
|
|
|
|
|
using its "Purity" feature. |
2447
|
|
|
|
|
|
|
Data::Dumper::Interp simply passed through these annotations. |
2448
|
|
|
|
|
|
|
|
2449
|
|
|
|
|
|
|
However with I<Refaddr(true)>, multiple references to the same thing |
2450
|
|
|
|
|
|
|
will all show the address of the referenced thing. |
2451
|
|
|
|
|
|
|
|
2452
|
|
|
|
|
|
|
=item The special "_" stat filehandle may not be preserved |
2453
|
|
|
|
|
|
|
|
2454
|
|
|
|
|
|
|
Data::Dumper::Interp queries the operating |
2455
|
|
|
|
|
|
|
system to obtain the window size to initialize C<$Foldwidth>, if it |
2456
|
|
|
|
|
|
|
is not already defined; this may change the "_" filehandle. |
2457
|
|
|
|
|
|
|
After the first call (or if you pre-set C<$Foldwidth>), |
2458
|
|
|
|
|
|
|
the "_" filehandle will not change across calls. |
2459
|
|
|
|
|
|
|
|
2460
|
|
|
|
|
|
|
=back |
2461
|
|
|
|
|
|
|
|
2462
|
|
|
|
|
|
|
=head1 DIFFERENCES FROM Data::Dumper |
2463
|
|
|
|
|
|
|
|
2464
|
|
|
|
|
|
|
Results differ from plain C<Data::Dumper> output in the following ways |
2465
|
|
|
|
|
|
|
(most of these can be controlled via Config options): |
2466
|
|
|
|
|
|
|
|
2467
|
|
|
|
|
|
|
=over 2 |
2468
|
|
|
|
|
|
|
|
2469
|
|
|
|
|
|
|
=item * |
2470
|
|
|
|
|
|
|
|
2471
|
|
|
|
|
|
|
A final newline is I<never> included. |
2472
|
|
|
|
|
|
|
|
2473
|
|
|
|
|
|
|
Everything is shown on a single line if possible, otherwise wrapped to |
2474
|
|
|
|
|
|
|
your terminal width (or C<$Foldwidth>), with indented structure levels. |
2475
|
|
|
|
|
|
|
|
2476
|
|
|
|
|
|
|
=item * |
2477
|
|
|
|
|
|
|
|
2478
|
|
|
|
|
|
|
Printable Unicode characters appear as themselves instead of \x{ABCD}. |
2479
|
|
|
|
|
|
|
|
2480
|
|
|
|
|
|
|
Note: If your data contains 'wide characters', you should |
2481
|
|
|
|
|
|
|
C<< use open IO => ':locale'; >> or otherwise arrange to |
2482
|
|
|
|
|
|
|
encode the output for your terminal. |
2483
|
|
|
|
|
|
|
You'll also want C<< use utf8; >> if your Perl source |
2484
|
|
|
|
|
|
|
contains characters outside the ASCII range. |
2485
|
|
|
|
|
|
|
|
2486
|
|
|
|
|
|
|
Undecoded binary octets (e.g. data read from a 'binmode' file) |
2487
|
|
|
|
|
|
|
will still be escaped as individual bytes. |
2488
|
|
|
|
|
|
|
|
2489
|
|
|
|
|
|
|
=item * |
2490
|
|
|
|
|
|
|
|
2491
|
|
|
|
|
|
|
Depending on options, spaces·may·be·shown·visibly |
2492
|
|
|
|
|
|
|
and '' may be shown for newline (and similarly for other ASCII controls). |
2493
|
|
|
|
|
|
|
|
2494
|
|
|
|
|
|
|
"White space" characters in qr/compiled regex/ are shown as \t, \n etc. |
2495
|
|
|
|
|
|
|
|
2496
|
|
|
|
|
|
|
=item * |
2497
|
|
|
|
|
|
|
|
2498
|
|
|
|
|
|
|
The internals of objects are not shown by default. |
2499
|
|
|
|
|
|
|
|
2500
|
|
|
|
|
|
|
If stringifcation is overloaded it is used to obtain the object's |
2501
|
|
|
|
|
|
|
representation. For example, C<bignum> and C<bigrat> numbers are shown as easily |
2502
|
|
|
|
|
|
|
readable values rather than S<"bless( {...}, 'Math::...')">. |
2503
|
|
|
|
|
|
|
|
2504
|
|
|
|
|
|
|
Stingified objects are prefixed with "(classname)" to make clear what |
2505
|
|
|
|
|
|
|
happened. |
2506
|
|
|
|
|
|
|
|
2507
|
|
|
|
|
|
|
The "virtual" value of objects which overload a dereference operator |
2508
|
|
|
|
|
|
|
(C<@{}> or C<%{}>) is displayed instead of the object's internals. |
2509
|
|
|
|
|
|
|
|
2510
|
|
|
|
|
|
|
=item * |
2511
|
|
|
|
|
|
|
|
2512
|
|
|
|
|
|
|
Hash keys are sorted treating numeric "components" numerically. |
2513
|
|
|
|
|
|
|
For example "A.20" sorts before "A.100". |
2514
|
|
|
|
|
|
|
|
2515
|
|
|
|
|
|
|
=item * |
2516
|
|
|
|
|
|
|
|
2517
|
|
|
|
|
|
|
Punctuation variables such as $@, $!, and $?, are preserved over calls. |
2518
|
|
|
|
|
|
|
|
2519
|
|
|
|
|
|
|
=item * |
2520
|
|
|
|
|
|
|
|
2521
|
|
|
|
|
|
|
Numbers and strings which look like numbers are kept distinct when displayed, |
2522
|
|
|
|
|
|
|
i.e. "0" does not become 0 or vice-versa. Floating-point values are shown |
2523
|
|
|
|
|
|
|
as numbers not 'quoted strings' and similarly for stringified objects. |
2524
|
|
|
|
|
|
|
|
2525
|
|
|
|
|
|
|
Although such differences might be immaterial to Perl during execution, |
2526
|
|
|
|
|
|
|
they may be important when communicating to a human. |
2527
|
|
|
|
|
|
|
|
2528
|
|
|
|
|
|
|
=back |
2529
|
|
|
|
|
|
|
|
2530
|
|
|
|
|
|
|
=head1 SEE ALSO |
2531
|
|
|
|
|
|
|
|
2532
|
|
|
|
|
|
|
Data::Dumper |
2533
|
|
|
|
|
|
|
|
2534
|
|
|
|
|
|
|
=head1 AUTHOR |
2535
|
|
|
|
|
|
|
|
2536
|
|
|
|
|
|
|
Jim Avera (jim.avera AT gmail) |
2537
|
|
|
|
|
|
|
|
2538
|
|
|
|
|
|
|
=head1 LICENSE |
2539
|
|
|
|
|
|
|
|
2540
|
|
|
|
|
|
|
Public Domain or CC0. |
2541
|
|
|
|
|
|
|
|
2542
|
|
|
|
|
|
|
=for nobody Foldwidth1 is currently an undocumented experimental method |
2543
|
|
|
|
|
|
|
=for nobody which sets a different fold width for the first line only. |
2544
|
|
|
|
|
|
|
=for nobody The Debug method is for author's debugging, and not documented. |
2545
|
|
|
|
|
|
|
=for nobody |
2546
|
|
|
|
|
|
|
=for nobody oops and btw btwN are internal debugging functions |
2547
|
|
|
|
|
|
|
|
2548
|
|
|
|
|
|
|
=for Pod::Coverage Foldwidth1 oops btw btwN Debug |
2549
|
|
|
|
|
|
|
|
2550
|
|
|
|
|
|
|
=cut |