This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Tweaks from Autrijus Tang: should use euc-tw for Taiwan,
[perl5.git] / lib / dumpvar.pl
CommitLineData
d338d6fe
PP
1require 5.002; # For (defined ref)
2package dumpvar;
3
4# Needed for PrettyPrinter only:
5
6# require 5.001; # Well, it coredumps anyway undef DB in 5.000 (not now)
7
8# translate control chars to ^X - Randal Schwartz
9# Modifications to print types by Peter Gordon v1.0
10
11# Ilya Zakharevich -- patches after 5.001 (and some before ;-)
12
13# Won't dump symbol tables and contents of debugged files by default
14
15$winsize = 80 unless defined $winsize;
16
17
18# Defaults
19
20# $globPrint = 1;
21$printUndef = 1 unless defined $printUndef;
54d04a52 22$tick = "auto" unless defined $tick;
d338d6fe 23$unctrl = 'quote' unless defined $unctrl;
54d04a52 24$subdump = 1;
22fae026 25$dumpReused = 0 unless defined $dumpReused;
ee239bfe 26$bareStringify = 1 unless defined $bareStringify;
d338d6fe
PP
27
28sub main::dumpValue {
29 local %address;
b2391ea8 30 local $^W=0;
d338d6fe
PP
31 (print "undef\n"), return unless defined $_[0];
32 (print &stringify($_[0]), "\n"), return unless ref $_[0];
d03c2a1b 33 dumpvar::unwrap($_[0],0, $_[1]);
d338d6fe
PP
34}
35
36# This one is good for variable names:
37
38sub unctrl {
39 local($_) = @_;
40 local($v) ;
41
42 return \$_ if ref \$_ eq "GLOB";
43 s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
44 $_;
45}
46
f8543d02
A
47sub uniescape {
48 join("",
49 map { $_ > 255 ? sprintf("\\x{%04X}", $_) : chr($_) }
50 unpack("U*", $_[0]));
51}
52
d338d6fe
PP
53sub stringify {
54 local($_,$noticks) = @_;
55 local($v) ;
54d04a52 56 my $tick = $tick;
d338d6fe
PP
57
58 return 'undef' unless defined $_ or not $printUndef;
59 return $_ . "" if ref \$_ eq 'GLOB';
ee239bfe
IZ
60 $_ = &{'overload::StrVal'}($_)
61 if $bareStringify and ref $_
475342a6 62 and %overload:: and defined &{'overload::StrVal'};
ee239bfe 63
54d04a52
IZ
64 if ($tick eq 'auto') {
65 if (/[\000-\011\013-\037\177]/) {
66 $tick = '"';
67 }else {
68 $tick = "'";
69 }
70 }
d338d6fe
PP
71 if ($tick eq "'") {
72 s/([\'\\])/\\$1/g;
73 } elsif ($unctrl eq 'unctrl') {
74 s/([\"\\])/\\$1/g ;
75 s/([\000-\037\177])/'^'.pack('c',ord($1)^64)/eg;
f8543d02 76 # uniescape?
d338d6fe
PP
77 s/([\200-\377])/'\\0x'.sprintf('%2X',ord($1))/eg
78 if $quoteHighBit;
79 } elsif ($unctrl eq 'quote') {
80 s/([\"\\\$\@])/\\$1/g if $tick eq '"';
81 s/\033/\\e/g;
82 s/([\000-\037\177])/'\\c'.chr(ord($1)^64)/eg;
83 }
f8543d02 84 $_ = uniescape($_);
d338d6fe
PP
85 s/([\200-\377])/'\\'.sprintf('%3o',ord($1))/eg if $quoteHighBit;
86 ($noticks || /^\d+(\.\d*)?\Z/)
87 ? $_
88 : $tick . $_ . $tick;
89}
90
91sub ShortArray {
92 my $tArrayDepth = $#{$_[0]} ;
93 $tArrayDepth = $#{$_[0]} < $arrayDepth-1 ? $#{$_[0]} : $arrayDepth-1
94 unless $arrayDepth eq '' ;
95 my $shortmore = "";
96 $shortmore = " ..." if $tArrayDepth < $#{$_[0]} ;
97 if (!grep(ref $_, @{$_[0]})) {
98 $short = "0..$#{$_[0]} '" .
99 join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore";
100 return $short if length $short <= $compactDump;
101 }
102 undef;
103}
104
105sub DumpElem {
106 my $short = &stringify($_[0], ref $_[0]);
107 if ($veryCompact && ref $_[0]
108 && (ref $_[0] eq 'ARRAY' and !grep(ref $_, @{$_[0]}) )) {
109 my $end = "0..$#{$v} '" .
110 join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore";
111 } elsif ($veryCompact && ref $_[0]
112 && (ref $_[0] eq 'HASH') and !grep(ref $_, values %{$_[0]})) {
113 my $end = 1;
114 $short = $sp . "0..$#{$v} '" .
115 join("' '", @{$v}[0..$tArrayDepth]) . "'$shortmore";
116 } else {
117 print "$short\n";
d03c2a1b 118 unwrap($_[0],$_[1],$_[2]);
d338d6fe
PP
119 }
120}
121
122sub unwrap {
123 return if $DB::signal;
124 local($v) = shift ;
125 local($s) = shift ; # extra no of spaces
d03c2a1b
MJD
126 local($m) = shift ; # maximum recursion depth
127 return if $m == 0;
ee239bfe 128 local(%v,@v,$sp,$value,$key,@sortKeys,$more,$shortmore,$short) ;
d338d6fe
PP
129 local($tHashDepth,$tArrayDepth) ;
130
131 $sp = " " x $s ;
132 $s += 3 ;
133
134 # Check for reused addresses
135 if (ref $v) {
ee239bfe
IZ
136 my $val = $v;
137 $val = &{'overload::StrVal'}($v)
475342a6 138 if %overload:: and defined &{'overload::StrVal'};
ee239bfe 139 ($address) = $val =~ /(0x[0-9a-f]+)\)$/ ;
22fae026 140 if (!$dumpReused && defined $address) {
d338d6fe
PP
141 $address{$address}++ ;
142 if ( $address{$address} > 1 ) {
143 print "${sp}-> REUSED_ADDRESS\n" ;
144 return ;
145 }
146 }
147 } elsif (ref \$v eq 'GLOB') {
148 $address = "$v" . ""; # To avoid a bug with globs
149 $address{$address}++ ;
150 if ( $address{$address} > 1 ) {
151 print "${sp}*DUMPED_GLOB*\n" ;
152 return ;
153 }
154 }
155
7894fbab
GS
156 if (ref $v eq 'Regexp') {
157 my $re = "$v";
158 $re =~ s,/,\\/,g;
159 print "$sp-> qr/$re/\n";
160 return;
161 }
162
74b5f52c 163 if ( UNIVERSAL::isa($v, 'HASH') ) {
d338d6fe
PP
164 @sortKeys = sort keys(%$v) ;
165 undef $more ;
166 $tHashDepth = $#sortKeys ;
167 $tHashDepth = $#sortKeys < $hashDepth-1 ? $#sortKeys : $hashDepth-1
168 unless $hashDepth eq '' ;
169 $more = "....\n" if $tHashDepth < $#sortKeys ;
170 $shortmore = "";
171 $shortmore = ", ..." if $tHashDepth < $#sortKeys ;
172 $#sortKeys = $tHashDepth ;
173 if ($compactDump && !grep(ref $_, values %{$v})) {
174 #$short = $sp .
175 # (join ', ',
176# Next row core dumps during require from DB on 5.000, even with map {"_"}
177 # map {&stringify($_) . " => " . &stringify($v->{$_})}
178 # @sortKeys) . "'$shortmore";
179 $short = $sp;
180 my @keys;
181 for (@sortKeys) {
182 push @keys, &stringify($_) . " => " . &stringify($v->{$_});
183 }
184 $short .= join ', ', @keys;
185 $short .= $shortmore;
186 (print "$short\n"), return if length $short <= $compactDump;
187 }
188 for $key (@sortKeys) {
189 return if $DB::signal;
190 $value = $ {$v}{$key} ;
191 print "$sp", &stringify($key), " => ";
d03c2a1b 192 DumpElem $value, $s, $m-1;
d338d6fe
PP
193 }
194 print "$sp empty hash\n" unless @sortKeys;
195 print "$sp$more" if defined $more ;
74b5f52c 196 } elsif ( UNIVERSAL::isa($v, 'ARRAY') ) {
d338d6fe
PP
197 $tArrayDepth = $#{$v} ;
198 undef $more ;
199 $tArrayDepth = $#{$v} < $arrayDepth-1 ? $#{$v} : $arrayDepth-1
600d99fa 200 if defined $arrayDepth && $arrayDepth ne '';
d338d6fe
PP
201 $more = "....\n" if $tArrayDepth < $#{$v} ;
202 $shortmore = "";
203 $shortmore = " ..." if $tArrayDepth < $#{$v} ;
204 if ($compactDump && !grep(ref $_, @{$v})) {
205 if ($#$v >= 0) {
54d04a52
IZ
206 $short = $sp . "0..$#{$v} " .
207 join(" ",
d9182636
GS
208 map {exists $v->[$_] ? stringify $v->[$_] : "empty"} ($[..$tArrayDepth)
209 ) . "$shortmore";
d338d6fe
PP
210 } else {
211 $short = $sp . "empty array";
212 }
213 (print "$short\n"), return if length $short <= $compactDump;
214 }
215 #if ($compactDump && $short = ShortArray($v)) {
216 # print "$short\n";
217 # return;
218 #}
219 for $num ($[ .. $tArrayDepth) {
220 return if $DB::signal;
221 print "$sp$num ";
d9182636 222 if (exists $v->[$num]) {
d03c2a1b 223 DumpElem $v->[$num], $s, $m-1;
d9182636
GS
224 } else {
225 print "empty slot\n";
226 }
d338d6fe
PP
227 }
228 print "$sp empty array\n" unless @$v;
229 print "$sp$more" if defined $more ;
74b5f52c 230 } elsif ( UNIVERSAL::isa($v, 'SCALAR') or ref $v eq 'REF' ) {
d338d6fe 231 print "$sp-> ";
d03c2a1b 232 DumpElem $$v, $s, $m-1;
74b5f52c 233 } elsif ( UNIVERSAL::isa($v, 'CODE') ) {
54d04a52
IZ
234 print "$sp-> ";
235 dumpsub (0, $v);
74b5f52c 236 } elsif ( UNIVERSAL::isa($v, 'GLOB') ) {
d338d6fe
PP
237 print "$sp-> ",&stringify($$v,1),"\n";
238 if ($globPrint) {
239 $s += 3;
3a4b996c 240 dumpglob($s, "{$$v}", $$v, 1, $m-1);
d338d6fe
PP
241 } elsif (defined ($fileno = fileno($v))) {
242 print( (' ' x ($s+3)) . "FileHandle({$$v}) => fileno($fileno)\n" );
243 }
244 } elsif (ref \$v eq 'GLOB') {
245 if ($globPrint) {
3a4b996c 246 dumpglob($s, "{$v}", $v, 1, $m-1) if $globPrint;
d338d6fe
PP
247 } elsif (defined ($fileno = fileno(\$v))) {
248 print( (' ' x $s) . "FileHandle({$v}) => fileno($fileno)\n" );
249 }
250 }
251}
252
253sub matchvar {
254 $_[0] eq $_[1] or
b2391ea8
PP
255 ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and
256 ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/});
d338d6fe
PP
257}
258
259sub compactDump {
260 $compactDump = shift if @_;
261 $compactDump = 6*80-1 if $compactDump and $compactDump < 2;
262 $compactDump;
263}
264
265sub veryCompact {
266 $veryCompact = shift if @_;
267 compactDump(1) if !$compactDump and $veryCompact;
268 $veryCompact;
269}
270
271sub unctrlSet {
272 if (@_) {
273 my $in = shift;
274 if ($in eq 'unctrl' or $in eq 'quote') {
275 $unctrl = $in;
276 } else {
277 print "Unknown value for `unctrl'.\n";
278 }
279 }
280 $unctrl;
281}
282
283sub quote {
284 if (@_ and $_[0] eq '"') {
285 $tick = '"';
286 $unctrl = 'quote';
54d04a52
IZ
287 } elsif (@_ and $_[0] eq 'auto') {
288 $tick = 'auto';
289 $unctrl = 'quote';
d338d6fe
PP
290 } elsif (@_) { # Need to set
291 $tick = "'";
292 $unctrl = 'unctrl';
293 }
294 $tick;
295}
296
297sub dumpglob {
298 return if $DB::signal;
3a4b996c 299 my ($off,$key, $val, $all, $m) = @_;
d338d6fe
PP
300 local(*entry) = $val;
301 my $fileno;
54d04a52 302 if (($key !~ /^_</ or $dumpDBFiles) and defined $entry) {
d338d6fe 303 print( (' ' x $off) . "\$", &unctrl($key), " = " );
3a4b996c 304 DumpElem $entry, 3+$off, $m;
d338d6fe 305 }
475342a6 306 if (($key !~ /^_</ or $dumpDBFiles) and @entry) {
d338d6fe 307 print( (' ' x $off) . "\@$key = (\n" );
3a4b996c 308 unwrap(\@entry,3+$off,$m) ;
d338d6fe
PP
309 print( (' ' x $off) . ")\n" );
310 }
475342a6 311 if ($key ne "main::" && $key ne "DB::" && %entry
d338d6fe 312 && ($dumpPackages or $key !~ /::$/)
54d04a52 313 && ($key !~ /^_</ or $dumpDBFiles)
d338d6fe
PP
314 && !($package eq "dumpvar" and $key eq "stab")) {
315 print( (' ' x $off) . "\%$key = (\n" );
3a4b996c 316 unwrap(\%entry,3+$off,$m) ;
d338d6fe
PP
317 print( (' ' x $off) . ")\n" );
318 }
319 if (defined ($fileno = fileno(*entry))) {
320 print( (' ' x $off) . "FileHandle($key) => fileno($fileno)\n" );
321 }
322 if ($all) {
323 if (defined &entry) {
54d04a52 324 dumpsub($off, $key);
d338d6fe
PP
325 }
326 }
327}
328
83ee9e09
GS
329sub CvGV_name_or_bust {
330 my $in = shift;
331 return if $skipCvGV; # Backdoor to avoid problems if XS broken...
332 $in = \&$in; # Hard reference...
333 eval {require Devel::Peek; 1} or return;
334 my $gv = Devel::Peek::CvGV($in) or return;
335 *$gv{PACKAGE} . '::' . *$gv{NAME};
336}
337
54d04a52
IZ
338sub dumpsub {
339 my ($off,$sub) = @_;
83ee9e09
GS
340 my $ini = $sub;
341 my $s;
54d04a52 342 $sub = $1 if $sub =~ /^\{\*(.*)\}$/;
83ee9e09
GS
343 my $subref = defined $1 ? \&$sub : \&$ini;
344 my $place = $DB::sub{$sub} || (($s = $subs{"$subref"}) && $DB::sub{$s})
345 || (($s = CvGV_name_or_bust($subref)) && $DB::sub{$s})
346 || ($subdump && ($s = findsubs("$subref")) && $DB::sub{$s});
54d04a52 347 $place = '???' unless defined $place;
83ee9e09
GS
348 $s = $sub unless defined $s;
349 print( (' ' x $off) . "&$s in $place\n" );
54d04a52
IZ
350}
351
352sub findsubs {
475342a6 353 return undef unless %DB::sub;
54d04a52
IZ
354 my ($addr, $name, $loc);
355 while (($name, $loc) = each %DB::sub) {
356 $addr = \&$name;
357 $subs{"$addr"} = $name;
358 }
359 $subdump = 0;
360 $subs{ shift() };
361}
362
d338d6fe 363sub main::dumpvar {
3a4b996c 364 my ($package,$m,@vars) = @_;
b2391ea8 365 local(%address,$key,$val,$^W);
d338d6fe
PP
366 $package .= "::" unless $package =~ /::$/;
367 *stab = *{"main::"};
368 while ($package =~ /(\w+?::)/g){
369 *stab = $ {stab}{$1};
370 }
371 local $TotalStrings = 0;
372 local $Strings = 0;
373 local $CompleteTotal = 0;
374 while (($key,$val) = each(%stab)) {
375 return if $DB::signal;
376 next if @vars && !grep( matchvar($key, $_), @vars );
377 if ($usageOnly) {
4c82ae22
GS
378 globUsage(\$val, $key)
379 if ($package ne 'dumpvar' or $key ne 'stab')
380 and ref(\$val) eq 'GLOB';
d338d6fe 381 } else {
3a4b996c 382 dumpglob(0,$key, $val, 0, $m);
d338d6fe
PP
383 }
384 }
385 if ($usageOnly) {
386 print "String space: $TotalStrings bytes in $Strings strings.\n";
387 $CompleteTotal += $TotalStrings;
388 print "Grand total = $CompleteTotal bytes (1 level deep) + overhead.\n";
389 }
390}
391
392sub scalarUsage {
393 my $size = length($_[0]);
394 $TotalStrings += $size;
395 $Strings++;
396 $size;
397}
398
399sub arrayUsage { # array ref, name
400 my $size = 0;
401 map {$size += scalarUsage($_)} @{$_[0]};
402 my $len = @{$_[0]};
403 print "\@$_[1] = $len item", ($len > 1 ? "s" : ""),
404 " (data: $size bytes)\n"
405 if defined $_[1];
406 $CompleteTotal += $size;
407 $size;
408}
409
410sub hashUsage { # hash ref, name
411 my @keys = keys %{$_[0]};
412 my @values = values %{$_[0]};
413 my $keys = arrayUsage \@keys;
414 my $values = arrayUsage \@values;
415 my $len = @keys;
416 my $total = $keys + $values;
417 print "\%$_[1] = $len item", ($len > 1 ? "s" : ""),
418 " (keys: $keys; values: $values; total: $total bytes)\n"
419 if defined $_[1];
420 $total;
421}
422
423sub globUsage { # glob ref, name
424 local *name = *{$_[0]};
425 $total = 0;
426 $total += scalarUsage $name if defined $name;
475342a6
GS
427 $total += arrayUsage \@name, $_[1] if @name;
428 $total += hashUsage \%name, $_[1] if %name and $_[1] ne "main::"
d338d6fe
PP
429 and $_[1] ne "DB::"; #and !($package eq "dumpvar" and $key eq "stab"));
430 $total;
431}
432
433sub packageUsage {
434 my ($package,@vars) = @_;
435 $package .= "::" unless $package =~ /::$/;
436 local *stab = *{"main::"};
437 while ($package =~ /(\w+?::)/g){
438 *stab = $ {stab}{$1};
439 }
440 local $TotalStrings = 0;
441 local $CompleteTotal = 0;
442 my ($key,$val);
443 while (($key,$val) = each(%stab)) {
444 next if @vars && !grep($key eq $_,@vars);
445 globUsage \$val, $key unless $package eq 'dumpvar' and $key eq 'stab';
446 }
447 print "String space: $TotalStrings.\n";
448 $CompleteTotal += $TotalStrings;
449 print "\nGrand total = $CompleteTotal bytes\n";
450}
451
4521;
453