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