File Coverage

blib/lib/Data/Dumper/Interp.pm
Criterion Covered Total %
statement 551 692 79.6
branch 228 426 53.5
condition 67 106 63.2
subroutine 91 116 78.4
pod 18 30 60.0
total 955 1370 69.7


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