This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[BUG:PATCH] dumpvar.pl parses some references incorrectly
[perl5.git] / lib / dumpvar.pl
1 require 5.002;                  # For (defined ref)
2 package 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;
22 $tick = "auto" unless defined $tick;
23 $unctrl = 'quote' unless defined $unctrl;
24 $subdump = 1;
25
26 sub main::dumpValue {
27   local %address;
28   local $^W=0;
29   (print "undef\n"), return unless defined $_[0];
30   (print &stringify($_[0]), "\n"), return unless ref $_[0];
31   dumpvar::unwrap($_[0],0);
32 }
33
34 # This one is good for variable names:
35
36 sub unctrl {
37         local($_) = @_;
38         local($v) ; 
39
40         return \$_ if ref \$_ eq "GLOB";
41         s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
42         $_;
43 }
44
45 sub stringify {
46         local($_,$noticks) = @_;
47         local($v) ; 
48         my $tick = $tick;
49
50         return 'undef' unless defined $_ or not $printUndef;
51         return $_ . "" if ref \$_ eq 'GLOB';
52         if ($tick eq 'auto') {
53           if (/[\000-\011\013-\037\177]/) {
54             $tick = '"';
55           }else {
56             $tick = "'";
57           }
58         }
59         if ($tick eq "'") {
60           s/([\'\\])/\\$1/g;
61         } elsif ($unctrl eq 'unctrl') {
62           s/([\"\\])/\\$1/g ;
63           s/([\000-\037\177])/'^'.pack('c',ord($1)^64)/eg;
64           s/([\200-\377])/'\\0x'.sprintf('%2X',ord($1))/eg 
65             if $quoteHighBit;
66         } elsif ($unctrl eq 'quote') {
67           s/([\"\\\$\@])/\\$1/g if $tick eq '"';
68           s/\033/\\e/g;
69           s/([\000-\037\177])/'\\c'.chr(ord($1)^64)/eg;
70         }
71         s/([\200-\377])/'\\'.sprintf('%3o',ord($1))/eg if $quoteHighBit;
72         ($noticks || /^\d+(\.\d*)?\Z/) 
73           ? $_ 
74           : $tick . $_ . $tick;
75 }
76
77 sub ShortArray {
78   my $tArrayDepth = $#{$_[0]} ; 
79   $tArrayDepth = $#{$_[0]} < $arrayDepth-1 ? $#{$_[0]} : $arrayDepth-1 
80     unless  $arrayDepth eq '' ; 
81   my $shortmore = "";
82   $shortmore = " ..." if $tArrayDepth < $#{$_[0]} ;
83   if (!grep(ref $_, @{$_[0]})) {
84     $short = "0..$#{$_[0]}  '" . 
85       join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore";
86     return $short if length $short <= $compactDump;
87   }
88   undef;
89 }
90
91 sub DumpElem {
92   my $short = &stringify($_[0], ref $_[0]);
93   if ($veryCompact && ref $_[0]
94       && (ref $_[0] eq 'ARRAY' and !grep(ref $_, @{$_[0]}) )) {
95     my $end = "0..$#{$v}  '" . 
96       join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore";
97   } elsif ($veryCompact && ref $_[0]
98       && (ref $_[0] eq 'HASH') and !grep(ref $_, values %{$_[0]})) {
99     my $end = 1;
100           $short = $sp . "0..$#{$v}  '" . 
101             join("' '", @{$v}[0..$tArrayDepth]) . "'$shortmore";
102   } else {
103     print "$short\n";
104     unwrap($_[0],$_[1]);
105   }
106 }
107
108 sub unwrap {
109     return if $DB::signal;
110     local($v) = shift ; 
111     local($s) = shift ; # extra no of spaces
112     local(%v,@v,$sp,$value,$key,$type,@sortKeys,$more,$shortmore,$short) ;
113     local($tHashDepth,$tArrayDepth) ;
114
115     $sp = " " x $s ;
116     $s += 3 ; 
117
118     # Check for reused addresses
119     if (ref $v) { 
120       ($address) = $v =~ /(0x[0-9a-f]+)\)$/ ; 
121       if (defined $address) { 
122         ($type) = $v =~ /=(.*?)\([^=]+$/ ;
123         $address{$address}++ ;
124         if ( $address{$address} > 1 ) { 
125           print "${sp}-> REUSED_ADDRESS\n" ; 
126           return ; 
127         } 
128       }
129     } elsif (ref \$v eq 'GLOB') {
130       $address = "$v" . "";     # To avoid a bug with globs
131       $address{$address}++ ;
132       if ( $address{$address} > 1 ) { 
133         print "${sp}*DUMPED_GLOB*\n" ; 
134         return ; 
135       } 
136     }
137
138     if ( UNIVERSAL::isa($v, 'HASH') ) { 
139         @sortKeys = sort keys(%$v) ;
140         undef $more ; 
141         $tHashDepth = $#sortKeys ; 
142         $tHashDepth = $#sortKeys < $hashDepth-1 ? $#sortKeys : $hashDepth-1
143           unless $hashDepth eq '' ; 
144         $more = "....\n" if $tHashDepth < $#sortKeys ; 
145         $shortmore = "";
146         $shortmore = ", ..." if $tHashDepth < $#sortKeys ; 
147         $#sortKeys = $tHashDepth ; 
148         if ($compactDump && !grep(ref $_, values %{$v})) {
149           #$short = $sp . 
150           #  (join ', ', 
151 # Next row core dumps during require from DB on 5.000, even with map {"_"}
152           #   map {&stringify($_) . " => " . &stringify($v->{$_})} 
153           #   @sortKeys) . "'$shortmore";
154           $short = $sp;
155           my @keys;
156           for (@sortKeys) {
157             push @keys, &stringify($_) . " => " . &stringify($v->{$_});
158           }
159           $short .= join ', ', @keys;
160           $short .= $shortmore;
161           (print "$short\n"), return if length $short <= $compactDump;
162         }
163         for $key (@sortKeys) {
164             return if $DB::signal;
165             $value = $ {$v}{$key} ;
166             print "$sp", &stringify($key), " => ";
167             DumpElem $value, $s;
168         }
169         print "$sp  empty hash\n" unless @sortKeys;
170         print "$sp$more" if defined $more ;
171     } elsif ( UNIVERSAL::isa($v, 'ARRAY') ) { 
172         $tArrayDepth = $#{$v} ; 
173         undef $more ; 
174         $tArrayDepth = $#{$v} < $arrayDepth-1 ? $#{$v} : $arrayDepth-1 
175           unless  $arrayDepth eq '' ; 
176         $more = "....\n" if $tArrayDepth < $#{$v} ; 
177         $shortmore = "";
178         $shortmore = " ..." if $tArrayDepth < $#{$v} ;
179         if ($compactDump && !grep(ref $_, @{$v})) {
180           if ($#$v >= 0) {
181             $short = $sp . "0..$#{$v}  " . 
182               join(" ", 
183                    map {stringify $_} @{$v}[0..$tArrayDepth])
184                 . "$shortmore";
185           } else {
186             $short = $sp . "empty array";
187           }
188           (print "$short\n"), return if length $short <= $compactDump;
189         }
190         #if ($compactDump && $short = ShortArray($v)) {
191         #  print "$short\n";
192         #  return;
193         #}
194         for $num ($[ .. $tArrayDepth) {
195             return if $DB::signal;
196             print "$sp$num  ";
197             DumpElem $v->[$num], $s;
198         }
199         print "$sp  empty array\n" unless @$v;
200         print "$sp$more" if defined $more ;  
201     } elsif (  UNIVERSAL::isa($v, 'SCALAR') or ref $v eq 'REF' ) { 
202             print "$sp-> ";
203             DumpElem $$v, $s;
204     } elsif ( UNIVERSAL::isa($v, 'CODE') ) { 
205             print "$sp-> ";
206             dumpsub (0, $v);
207     } elsif ( UNIVERSAL::isa($v, 'GLOB') ) {
208       print "$sp-> ",&stringify($$v,1),"\n";
209       if ($globPrint) {
210         $s += 3;
211         dumpglob($s, "{$$v}", $$v, 1);
212       } elsif (defined ($fileno = fileno($v))) {
213         print( (' ' x ($s+3)) .  "FileHandle({$$v}) => fileno($fileno)\n" );
214       }
215     } elsif (ref \$v eq 'GLOB') {
216       if ($globPrint) {
217         dumpglob($s, "{$v}", $v, 1) if $globPrint;
218       } elsif (defined ($fileno = fileno(\$v))) {
219         print( (' ' x $s) .  "FileHandle({$v}) => fileno($fileno)\n" );
220       }
221     }
222 }
223
224 sub matchvar {
225   $_[0] eq $_[1] or 
226     ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and 
227       ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/});
228 }
229
230 sub compactDump {
231   $compactDump = shift if @_;
232   $compactDump = 6*80-1 if $compactDump and $compactDump < 2;
233   $compactDump;
234 }
235
236 sub veryCompact {
237   $veryCompact = shift if @_;
238   compactDump(1) if !$compactDump and $veryCompact;
239   $veryCompact;
240 }
241
242 sub unctrlSet {
243   if (@_) {
244     my $in = shift;
245     if ($in eq 'unctrl' or $in eq 'quote') {
246       $unctrl = $in;
247     } else {
248       print "Unknown value for `unctrl'.\n";
249     }
250   }
251   $unctrl;
252 }
253
254 sub quote {
255   if (@_ and $_[0] eq '"') {
256     $tick = '"';
257     $unctrl = 'quote';
258   } elsif (@_ and $_[0] eq 'auto') {
259     $tick = 'auto';
260     $unctrl = 'quote';
261   } elsif (@_) {                # Need to set
262     $tick = "'";
263     $unctrl = 'unctrl';
264   }
265   $tick;
266 }
267
268 sub dumpglob {
269     return if $DB::signal;
270     my ($off,$key, $val, $all) = @_;
271     local(*entry) = $val;
272     my $fileno;
273     if (($key !~ /^_</ or $dumpDBFiles) and defined $entry) {
274       print( (' ' x $off) . "\$", &unctrl($key), " = " );
275       DumpElem $entry, 3+$off;
276     }
277     if (($key !~ /^_</ or $dumpDBFiles) and defined @entry) {
278       print( (' ' x $off) . "\@$key = (\n" );
279       unwrap(\@entry,3+$off) ;
280       print( (' ' x $off) .  ")\n" );
281     }
282     if ($key ne "main::" && $key ne "DB::" && defined %entry
283         && ($dumpPackages or $key !~ /::$/)
284         && ($key !~ /^_</ or $dumpDBFiles)
285         && !($package eq "dumpvar" and $key eq "stab")) {
286       print( (' ' x $off) . "\%$key = (\n" );
287       unwrap(\%entry,3+$off) ;
288       print( (' ' x $off) .  ")\n" );
289     }
290     if (defined ($fileno = fileno(*entry))) {
291       print( (' ' x $off) .  "FileHandle($key) => fileno($fileno)\n" );
292     }
293     if ($all) {
294       if (defined &entry) {
295         dumpsub($off, $key);
296       }
297     }
298 }
299
300 sub dumpsub {
301     my ($off,$sub) = @_;
302     $sub = $1 if $sub =~ /^\{\*(.*)\}$/;
303     my $subref = \&$sub;
304     my $place = $DB::sub{$sub} || (($sub = $subs{"$subref"}) && $DB::sub{$sub})
305       || ($subdump && ($sub = findsubs("$subref")) && $DB::sub{$sub});
306     $place = '???' unless defined $place;
307     print( (' ' x $off) .  "&$sub in $place\n" );
308 }
309
310 sub findsubs {
311   return undef unless defined %DB::sub;
312   my ($addr, $name, $loc);
313   while (($name, $loc) = each %DB::sub) {
314     $addr = \&$name;
315     $subs{"$addr"} = $name;
316   }
317   $subdump = 0;
318   $subs{ shift() };
319 }
320
321 sub main::dumpvar {
322     my ($package,@vars) = @_;
323     local(%address,$key,$val,$^W);
324     $package .= "::" unless $package =~ /::$/;
325     *stab = *{"main::"};
326     while ($package =~ /(\w+?::)/g){
327       *stab = $ {stab}{$1};
328     }
329     local $TotalStrings = 0;
330     local $Strings = 0;
331     local $CompleteTotal = 0;
332     while (($key,$val) = each(%stab)) {
333       return if $DB::signal;
334       next if @vars && !grep( matchvar($key, $_), @vars );
335       if ($usageOnly) {
336         globUsage(\$val, $key) unless $package eq 'dumpvar' and $key eq 'stab';
337       } else {
338         dumpglob(0,$key, $val);
339       }
340     }
341     if ($usageOnly) {
342       print "String space: $TotalStrings bytes in $Strings strings.\n";
343       $CompleteTotal += $TotalStrings;
344       print "Grand total = $CompleteTotal bytes (1 level deep) + overhead.\n";
345     }
346 }
347
348 sub scalarUsage {
349   my $size = length($_[0]);
350   $TotalStrings += $size;
351   $Strings++;
352   $size;
353 }
354
355 sub arrayUsage {                # array ref, name
356   my $size = 0;
357   map {$size += scalarUsage($_)} @{$_[0]};
358   my $len = @{$_[0]};
359   print "\@$_[1] = $len item", ($len > 1 ? "s" : ""),
360     " (data: $size bytes)\n"
361       if defined $_[1];
362   $CompleteTotal +=  $size;
363   $size;
364 }
365
366 sub hashUsage {         # hash ref, name
367   my @keys = keys %{$_[0]};
368   my @values = values %{$_[0]};
369   my $keys = arrayUsage \@keys;
370   my $values = arrayUsage \@values;
371   my $len = @keys;
372   my $total = $keys + $values;
373   print "\%$_[1] = $len item", ($len > 1 ? "s" : ""),
374     " (keys: $keys; values: $values; total: $total bytes)\n"
375       if defined $_[1];
376   $total;
377 }
378
379 sub globUsage {                 # glob ref, name
380   local *name = *{$_[0]};
381   $total = 0;
382   $total += scalarUsage $name if defined $name;
383   $total += arrayUsage \@name, $_[1] if defined @name;
384   $total += hashUsage \%name, $_[1] if defined %name and $_[1] ne "main::" 
385     and $_[1] ne "DB::";   #and !($package eq "dumpvar" and $key eq "stab"));
386   $total;
387 }
388
389 sub packageUsage {
390   my ($package,@vars) = @_;
391   $package .= "::" unless $package =~ /::$/;
392   local *stab = *{"main::"};
393   while ($package =~ /(\w+?::)/g){
394     *stab = $ {stab}{$1};
395   }
396   local $TotalStrings = 0;
397   local $CompleteTotal = 0;
398   my ($key,$val);
399   while (($key,$val) = each(%stab)) {
400     next if @vars && !grep($key eq $_,@vars);
401     globUsage \$val, $key unless $package eq 'dumpvar' and $key eq 'stab';
402   }
403   print "String space: $TotalStrings.\n";
404   $CompleteTotal += $TotalStrings;
405   print "\nGrand total = $CompleteTotal bytes\n";
406 }
407
408 1;
409