1 require 5.002; # For (defined ref)
4 # Needed for PrettyPrinter only:
6 # require 5.001; # Well, it coredumps anyway undef DB in 5.000 (not now)
8 # translate control chars to ^X - Randal Schwartz
9 # Modifications to print types by Peter Gordon v1.0
11 # Ilya Zakharevich -- patches after 5.001 (and some before ;-)
13 # Won't dump symbol tables and contents of debugged files by default
15 $winsize = 80 unless defined $winsize;
21 $printUndef = 1 unless defined $printUndef;
22 $tick = "auto" unless defined $tick;
23 $unctrl = 'quote' unless defined $unctrl;
25 $dumpReused = 0 unless defined $dumpReused;
26 $bareStringify = 1 unless defined $bareStringify;
31 (print "undef\n"), return unless defined $_[0];
32 (print &stringify($_[0]), "\n"), return unless ref $_[0];
33 dumpvar::unwrap($_[0],0);
36 # This one is good for variable names:
42 return \$_ if ref \$_ eq "GLOB";
43 s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
48 local($_,$noticks) = @_;
52 return 'undef' unless defined $_ or not $printUndef;
53 return $_ . "" if ref \$_ eq 'GLOB';
54 $_ = &{'overload::StrVal'}($_)
55 if $bareStringify and ref $_
56 and defined %overload:: and defined &{'overload::StrVal'};
58 if ($tick eq 'auto') {
59 if (/[\000-\011\013-\037\177]/) {
67 } elsif ($unctrl eq 'unctrl') {
69 s/([\000-\037\177])/'^'.pack('c',ord($1)^64)/eg;
70 s/([\200-\377])/'\\0x'.sprintf('%2X',ord($1))/eg
72 } elsif ($unctrl eq 'quote') {
73 s/([\"\\\$\@])/\\$1/g if $tick eq '"';
75 s/([\000-\037\177])/'\\c'.chr(ord($1)^64)/eg;
77 s/([\200-\377])/'\\'.sprintf('%3o',ord($1))/eg if $quoteHighBit;
78 ($noticks || /^\d+(\.\d*)?\Z/)
84 my $tArrayDepth = $#{$_[0]} ;
85 $tArrayDepth = $#{$_[0]} < $arrayDepth-1 ? $#{$_[0]} : $arrayDepth-1
86 unless $arrayDepth eq '' ;
88 $shortmore = " ..." if $tArrayDepth < $#{$_[0]} ;
89 if (!grep(ref $_, @{$_[0]})) {
90 $short = "0..$#{$_[0]} '" .
91 join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore";
92 return $short if length $short <= $compactDump;
98 my $short = &stringify($_[0], ref $_[0]);
99 if ($veryCompact && ref $_[0]
100 && (ref $_[0] eq 'ARRAY' and !grep(ref $_, @{$_[0]}) )) {
101 my $end = "0..$#{$v} '" .
102 join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore";
103 } elsif ($veryCompact && ref $_[0]
104 && (ref $_[0] eq 'HASH') and !grep(ref $_, values %{$_[0]})) {
106 $short = $sp . "0..$#{$v} '" .
107 join("' '", @{$v}[0..$tArrayDepth]) . "'$shortmore";
115 return if $DB::signal;
117 local($s) = shift ; # extra no of spaces
118 local(%v,@v,$sp,$value,$key,@sortKeys,$more,$shortmore,$short) ;
119 local($tHashDepth,$tArrayDepth) ;
124 # Check for reused addresses
127 $val = &{'overload::StrVal'}($v)
128 if defined %overload:: and defined &{'overload::StrVal'};
129 ($address) = $val =~ /(0x[0-9a-f]+)\)$/ ;
130 if (!$dumpReused && defined $address) {
131 $address{$address}++ ;
132 if ( $address{$address} > 1 ) {
133 print "${sp}-> REUSED_ADDRESS\n" ;
137 } elsif (ref \$v eq 'GLOB') {
138 $address = "$v" . ""; # To avoid a bug with globs
139 $address{$address}++ ;
140 if ( $address{$address} > 1 ) {
141 print "${sp}*DUMPED_GLOB*\n" ;
146 if ( UNIVERSAL::isa($v, 'HASH') ) {
147 @sortKeys = sort keys(%$v) ;
149 $tHashDepth = $#sortKeys ;
150 $tHashDepth = $#sortKeys < $hashDepth-1 ? $#sortKeys : $hashDepth-1
151 unless $hashDepth eq '' ;
152 $more = "....\n" if $tHashDepth < $#sortKeys ;
154 $shortmore = ", ..." if $tHashDepth < $#sortKeys ;
155 $#sortKeys = $tHashDepth ;
156 if ($compactDump && !grep(ref $_, values %{$v})) {
159 # Next row core dumps during require from DB on 5.000, even with map {"_"}
160 # map {&stringify($_) . " => " . &stringify($v->{$_})}
161 # @sortKeys) . "'$shortmore";
165 push @keys, &stringify($_) . " => " . &stringify($v->{$_});
167 $short .= join ', ', @keys;
168 $short .= $shortmore;
169 (print "$short\n"), return if length $short <= $compactDump;
171 for $key (@sortKeys) {
172 return if $DB::signal;
173 $value = $ {$v}{$key} ;
174 print "$sp", &stringify($key), " => ";
177 print "$sp empty hash\n" unless @sortKeys;
178 print "$sp$more" if defined $more ;
179 } elsif ( UNIVERSAL::isa($v, 'ARRAY') ) {
180 $tArrayDepth = $#{$v} ;
182 $tArrayDepth = $#{$v} < $arrayDepth-1 ? $#{$v} : $arrayDepth-1
183 unless $arrayDepth eq '' ;
184 $more = "....\n" if $tArrayDepth < $#{$v} ;
186 $shortmore = " ..." if $tArrayDepth < $#{$v} ;
187 if ($compactDump && !grep(ref $_, @{$v})) {
189 $short = $sp . "0..$#{$v} " .
191 map {stringify $_} @{$v}[0..$tArrayDepth])
194 $short = $sp . "empty array";
196 (print "$short\n"), return if length $short <= $compactDump;
198 #if ($compactDump && $short = ShortArray($v)) {
202 for $num ($[ .. $tArrayDepth) {
203 return if $DB::signal;
205 DumpElem $v->[$num], $s;
207 print "$sp empty array\n" unless @$v;
208 print "$sp$more" if defined $more ;
209 } elsif ( UNIVERSAL::isa($v, 'SCALAR') or ref $v eq 'REF' ) {
212 } elsif ( UNIVERSAL::isa($v, 'CODE') ) {
215 } elsif ( UNIVERSAL::isa($v, 'GLOB') ) {
216 print "$sp-> ",&stringify($$v,1),"\n";
219 dumpglob($s, "{$$v}", $$v, 1);
220 } elsif (defined ($fileno = fileno($v))) {
221 print( (' ' x ($s+3)) . "FileHandle({$$v}) => fileno($fileno)\n" );
223 } elsif (ref \$v eq 'GLOB') {
225 dumpglob($s, "{$v}", $v, 1) if $globPrint;
226 } elsif (defined ($fileno = fileno(\$v))) {
227 print( (' ' x $s) . "FileHandle({$v}) => fileno($fileno)\n" );
234 ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and
235 ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/});
239 $compactDump = shift if @_;
240 $compactDump = 6*80-1 if $compactDump and $compactDump < 2;
245 $veryCompact = shift if @_;
246 compactDump(1) if !$compactDump and $veryCompact;
253 if ($in eq 'unctrl' or $in eq 'quote') {
256 print "Unknown value for `unctrl'.\n";
263 if (@_ and $_[0] eq '"') {
266 } elsif (@_ and $_[0] eq 'auto') {
269 } elsif (@_) { # Need to set
277 return if $DB::signal;
278 my ($off,$key, $val, $all) = @_;
279 local(*entry) = $val;
281 if (($key !~ /^_</ or $dumpDBFiles) and defined $entry) {
282 print( (' ' x $off) . "\$", &unctrl($key), " = " );
283 DumpElem $entry, 3+$off;
285 if (($key !~ /^_</ or $dumpDBFiles) and defined @entry) {
286 print( (' ' x $off) . "\@$key = (\n" );
287 unwrap(\@entry,3+$off) ;
288 print( (' ' x $off) . ")\n" );
290 if ($key ne "main::" && $key ne "DB::" && defined %entry
291 && ($dumpPackages or $key !~ /::$/)
292 && ($key !~ /^_</ or $dumpDBFiles)
293 && !($package eq "dumpvar" and $key eq "stab")) {
294 print( (' ' x $off) . "\%$key = (\n" );
295 unwrap(\%entry,3+$off) ;
296 print( (' ' x $off) . ")\n" );
298 if (defined ($fileno = fileno(*entry))) {
299 print( (' ' x $off) . "FileHandle($key) => fileno($fileno)\n" );
302 if (defined &entry) {
310 $sub = $1 if $sub =~ /^\{\*(.*)\}$/;
312 my $place = $DB::sub{$sub} || (($sub = $subs{"$subref"}) && $DB::sub{$sub})
313 || ($subdump && ($sub = findsubs("$subref")) && $DB::sub{$sub});
314 $place = '???' unless defined $place;
315 print( (' ' x $off) . "&$sub in $place\n" );
319 return undef unless defined %DB::sub;
320 my ($addr, $name, $loc);
321 while (($name, $loc) = each %DB::sub) {
323 $subs{"$addr"} = $name;
330 my ($package,@vars) = @_;
331 local(%address,$key,$val,$^W);
332 $package .= "::" unless $package =~ /::$/;
334 while ($package =~ /(\w+?::)/g){
335 *stab = $ {stab}{$1};
337 local $TotalStrings = 0;
339 local $CompleteTotal = 0;
340 while (($key,$val) = each(%stab)) {
341 return if $DB::signal;
342 next if @vars && !grep( matchvar($key, $_), @vars );
344 globUsage(\$val, $key) unless $package eq 'dumpvar' and $key eq 'stab';
346 dumpglob(0,$key, $val);
350 print "String space: $TotalStrings bytes in $Strings strings.\n";
351 $CompleteTotal += $TotalStrings;
352 print "Grand total = $CompleteTotal bytes (1 level deep) + overhead.\n";
357 my $size = length($_[0]);
358 $TotalStrings += $size;
363 sub arrayUsage { # array ref, name
365 map {$size += scalarUsage($_)} @{$_[0]};
367 print "\@$_[1] = $len item", ($len > 1 ? "s" : ""),
368 " (data: $size bytes)\n"
370 $CompleteTotal += $size;
374 sub hashUsage { # hash ref, name
375 my @keys = keys %{$_[0]};
376 my @values = values %{$_[0]};
377 my $keys = arrayUsage \@keys;
378 my $values = arrayUsage \@values;
380 my $total = $keys + $values;
381 print "\%$_[1] = $len item", ($len > 1 ? "s" : ""),
382 " (keys: $keys; values: $values; total: $total bytes)\n"
387 sub globUsage { # glob ref, name
388 local *name = *{$_[0]};
390 $total += scalarUsage $name if defined $name;
391 $total += arrayUsage \@name, $_[1] if defined @name;
392 $total += hashUsage \%name, $_[1] if defined %name and $_[1] ne "main::"
393 and $_[1] ne "DB::"; #and !($package eq "dumpvar" and $key eq "stab"));
398 my ($package,@vars) = @_;
399 $package .= "::" unless $package =~ /::$/;
400 local *stab = *{"main::"};
401 while ($package =~ /(\w+?::)/g){
402 *stab = $ {stab}{$1};
404 local $TotalStrings = 0;
405 local $CompleteTotal = 0;
407 while (($key,$val) = each(%stab)) {
408 next if @vars && !grep($key eq $_,@vars);
409 globUsage \$val, $key unless $package eq 'dumpvar' and $key eq 'stab';
411 print "String space: $TotalStrings.\n";
412 $CompleteTotal += $TotalStrings;
413 print "\nGrand total = $CompleteTotal bytes\n";