This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Enache still wants -pthread gone for FreeBSD 5.x
[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'};
a85f0137 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
a85f0137 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 ;
a85f0137 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]) {
a85f0137 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 ;
a85f0137 230 } elsif ( UNIVERSAL::isa($v, 'SCALAR') or ref $v eq 'REF' ) {
d338d6fe 231 print "$sp-> ";
d03c2a1b 232 DumpElem $$v, $s, $m-1;
a85f0137 233 } elsif ( UNIVERSAL::isa($v, 'CODE') ) {
54d04a52
IZ
234 print "$sp-> ";
235 dumpsub (0, $v);
a85f0137 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
a7b657ee
PS
253sub matchlex {
254 (my $var = $_[0]) =~ s/.//;
255 $var eq $_[1] or
256 ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and
257 ($1 eq '!') ^ (eval { $var =~ /$2$3/ });
258}
259
d338d6fe
PP
260sub matchvar {
261 $_[0] eq $_[1] or
b2391ea8
PP
262 ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and
263 ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/});
d338d6fe
PP
264}
265
266sub compactDump {
267 $compactDump = shift if @_;
268 $compactDump = 6*80-1 if $compactDump and $compactDump < 2;
269 $compactDump;
270}
271
272sub veryCompact {
273 $veryCompact = shift if @_;
274 compactDump(1) if !$compactDump and $veryCompact;
275 $veryCompact;
276}
277
278sub unctrlSet {
279 if (@_) {
280 my $in = shift;
281 if ($in eq 'unctrl' or $in eq 'quote') {
282 $unctrl = $in;
283 } else {
284 print "Unknown value for `unctrl'.\n";
285 }
286 }
287 $unctrl;
288}
289
290sub quote {
291 if (@_ and $_[0] eq '"') {
292 $tick = '"';
293 $unctrl = 'quote';
54d04a52
IZ
294 } elsif (@_ and $_[0] eq 'auto') {
295 $tick = 'auto';
296 $unctrl = 'quote';
d338d6fe
PP
297 } elsif (@_) { # Need to set
298 $tick = "'";
299 $unctrl = 'unctrl';
300 }
301 $tick;
302}
303
304sub dumpglob {
305 return if $DB::signal;
3a4b996c 306 my ($off,$key, $val, $all, $m) = @_;
d338d6fe
PP
307 local(*entry) = $val;
308 my $fileno;
54d04a52 309 if (($key !~ /^_</ or $dumpDBFiles) and defined $entry) {
d338d6fe 310 print( (' ' x $off) . "\$", &unctrl($key), " = " );
3a4b996c 311 DumpElem $entry, 3+$off, $m;
d338d6fe 312 }
475342a6 313 if (($key !~ /^_</ or $dumpDBFiles) and @entry) {
d338d6fe 314 print( (' ' x $off) . "\@$key = (\n" );
3a4b996c 315 unwrap(\@entry,3+$off,$m) ;
d338d6fe
PP
316 print( (' ' x $off) . ")\n" );
317 }
475342a6 318 if ($key ne "main::" && $key ne "DB::" && %entry
d338d6fe 319 && ($dumpPackages or $key !~ /::$/)
54d04a52 320 && ($key !~ /^_</ or $dumpDBFiles)
d338d6fe
PP
321 && !($package eq "dumpvar" and $key eq "stab")) {
322 print( (' ' x $off) . "\%$key = (\n" );
3a4b996c 323 unwrap(\%entry,3+$off,$m) ;
d338d6fe
PP
324 print( (' ' x $off) . ")\n" );
325 }
326 if (defined ($fileno = fileno(*entry))) {
327 print( (' ' x $off) . "FileHandle($key) => fileno($fileno)\n" );
328 }
329 if ($all) {
330 if (defined &entry) {
54d04a52 331 dumpsub($off, $key);
d338d6fe
PP
332 }
333 }
334}
335
a7b657ee
PS
336sub dumplex {
337 return if $DB::signal;
338 my ($key, $val, $m, @vars) = @_;
339 return if @vars && !grep( matchlex($key, $_), @vars );
340 local %address;
341 my $off = 0; # It reads better this way
342 my $fileno;
343 if (UNIVERSAL::isa($val,'ARRAY')) {
344 print( (' ' x $off) . "$key = (\n" );
345 unwrap($val,3+$off,$m) ;
346 print( (' ' x $off) . ")\n" );
347 }
348 elsif (UNIVERSAL::isa($val,'HASH')) {
349 print( (' ' x $off) . "$key = (\n" );
350 unwrap($val,3+$off,$m) ;
351 print( (' ' x $off) . ")\n" );
352 }
353 elsif (UNIVERSAL::isa($val,'IO')) {
354 print( (' ' x $off) . "FileHandle($key) => fileno($fileno)\n" );
355 }
356 # No lexical subroutines yet...
357 # elsif (UNIVERSAL::isa($val,'CODE')) {
358 # dumpsub($off, $$val);
359 # }
360 else {
361 print( (' ' x $off) . &unctrl($key), " = " );
362 DumpElem $$val, 3+$off, $m;
363 }
364}
365
83ee9e09
GS
366sub CvGV_name_or_bust {
367 my $in = shift;
368 return if $skipCvGV; # Backdoor to avoid problems if XS broken...
369 $in = \&$in; # Hard reference...
370 eval {require Devel::Peek; 1} or return;
371 my $gv = Devel::Peek::CvGV($in) or return;
372 *$gv{PACKAGE} . '::' . *$gv{NAME};
373}
374
54d04a52
IZ
375sub dumpsub {
376 my ($off,$sub) = @_;
83ee9e09
GS
377 my $ini = $sub;
378 my $s;
54d04a52 379 $sub = $1 if $sub =~ /^\{\*(.*)\}$/;
83ee9e09
GS
380 my $subref = defined $1 ? \&$sub : \&$ini;
381 my $place = $DB::sub{$sub} || (($s = $subs{"$subref"}) && $DB::sub{$s})
382 || (($s = CvGV_name_or_bust($subref)) && $DB::sub{$s})
383 || ($subdump && ($s = findsubs("$subref")) && $DB::sub{$s});
54d04a52 384 $place = '???' unless defined $place;
83ee9e09
GS
385 $s = $sub unless defined $s;
386 print( (' ' x $off) . "&$s in $place\n" );
54d04a52
IZ
387}
388
389sub findsubs {
475342a6 390 return undef unless %DB::sub;
54d04a52
IZ
391 my ($addr, $name, $loc);
392 while (($name, $loc) = each %DB::sub) {
393 $addr = \&$name;
394 $subs{"$addr"} = $name;
395 }
396 $subdump = 0;
397 $subs{ shift() };
398}
399
d338d6fe 400sub main::dumpvar {
3a4b996c 401 my ($package,$m,@vars) = @_;
b2391ea8 402 local(%address,$key,$val,$^W);
d338d6fe
PP
403 $package .= "::" unless $package =~ /::$/;
404 *stab = *{"main::"};
405 while ($package =~ /(\w+?::)/g){
406 *stab = $ {stab}{$1};
407 }
408 local $TotalStrings = 0;
409 local $Strings = 0;
410 local $CompleteTotal = 0;
411 while (($key,$val) = each(%stab)) {
412 return if $DB::signal;
413 next if @vars && !grep( matchvar($key, $_), @vars );
414 if ($usageOnly) {
4c82ae22
GS
415 globUsage(\$val, $key)
416 if ($package ne 'dumpvar' or $key ne 'stab')
417 and ref(\$val) eq 'GLOB';
d338d6fe 418 } else {
3a4b996c 419 dumpglob(0,$key, $val, 0, $m);
d338d6fe
PP
420 }
421 }
422 if ($usageOnly) {
423 print "String space: $TotalStrings bytes in $Strings strings.\n";
424 $CompleteTotal += $TotalStrings;
425 print "Grand total = $CompleteTotal bytes (1 level deep) + overhead.\n";
426 }
427}
428
429sub scalarUsage {
430 my $size = length($_[0]);
431 $TotalStrings += $size;
432 $Strings++;
433 $size;
434}
435
436sub arrayUsage { # array ref, name
437 my $size = 0;
438 map {$size += scalarUsage($_)} @{$_[0]};
439 my $len = @{$_[0]};
440 print "\@$_[1] = $len item", ($len > 1 ? "s" : ""),
441 " (data: $size bytes)\n"
442 if defined $_[1];
443 $CompleteTotal += $size;
444 $size;
445}
446
447sub hashUsage { # hash ref, name
448 my @keys = keys %{$_[0]};
449 my @values = values %{$_[0]};
450 my $keys = arrayUsage \@keys;
451 my $values = arrayUsage \@values;
452 my $len = @keys;
453 my $total = $keys + $values;
454 print "\%$_[1] = $len item", ($len > 1 ? "s" : ""),
455 " (keys: $keys; values: $values; total: $total bytes)\n"
456 if defined $_[1];
457 $total;
458}
459
460sub globUsage { # glob ref, name
461 local *name = *{$_[0]};
462 $total = 0;
463 $total += scalarUsage $name if defined $name;
475342a6
GS
464 $total += arrayUsage \@name, $_[1] if @name;
465 $total += hashUsage \%name, $_[1] if %name and $_[1] ne "main::"
d338d6fe
PP
466 and $_[1] ne "DB::"; #and !($package eq "dumpvar" and $key eq "stab"));
467 $total;
468}
469
470sub packageUsage {
471 my ($package,@vars) = @_;
472 $package .= "::" unless $package =~ /::$/;
473 local *stab = *{"main::"};
474 while ($package =~ /(\w+?::)/g){
475 *stab = $ {stab}{$1};
476 }
477 local $TotalStrings = 0;
478 local $CompleteTotal = 0;
479 my ($key,$val);
480 while (($key,$val) = each(%stab)) {
481 next if @vars && !grep($key eq $_,@vars);
482 globUsage \$val, $key unless $package eq 'dumpvar' and $key eq 'stab';
483 }
484 print "String space: $TotalStrings.\n";
485 $CompleteTotal += $TotalStrings;
486 print "\nGrand total = $CompleteTotal bytes\n";
487}
488
4891;
490