Remove very obsolete comment
[perl.git] / lib / dumpvar.pl
1 require 5.014;                  # For more reliable $@ after eval
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 $bareStringify = 1 unless defined $bareStringify;
27
28 sub main::dumpValue {
29   local %address;
30   local $^W=0;
31   (print "undef\n"), return unless defined $_[0];
32   (print &stringify($_[0]), "\n"), return unless ref $_[0];
33   push @_, -1 if @_ == 1;
34   dumpvar::unwrap($_[0], 0, $_[1]);
35 }
36
37 # This one is good for variable names:
38
39 sub unctrl {
40     for (my($dummy) = shift) {
41         local($v) ; 
42
43         return \$_ if ref \$_ eq "GLOB";
44         if (ord('A') == 193) { # EBCDIC.
45             # EBCDIC has no concept of "\cA" or "A" being related
46             # to each other by a linear/boolean mapping.
47         } else {
48             s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
49         }
50         return $_;
51     }
52 }
53
54 sub uniescape {
55     join("",
56          map { $_ > 255 ? sprintf("\\x{%04X}", $_) : chr($_) }
57              unpack("U*", $_[0]));
58 }
59
60 sub stringify {
61   my $string;
62   if (eval { $string = _stringify(@_); 1 }) {
63     return $string;
64   }
65
66   return "<< value could not be dumped: $@ >>";
67 }
68
69 sub _stringify {
70     (my $__, local $noticks) = @_;
71     for ($__) {
72         local($v) ; 
73         my $tick = $tick;
74
75         return 'undef' unless defined $_ or not $printUndef;
76         return $_ . "" if ref \$_ eq 'GLOB';
77         $_ = &{'overload::StrVal'}($_) 
78           if $bareStringify and ref $_ 
79             and %overload:: and defined &{'overload::StrVal'};
80         
81         if ($tick eq 'auto') {
82             if (ord('A') == 193) {
83                 if (/[\000-\011]/ or /[\013-\024\31-\037\177]/) {
84                     $tick = '"';
85                 } else {
86                     $tick = "'";
87                 }
88             }  else {
89                 if (/[\000-\011\013-\037\177]/) {
90                     $tick = '"';
91                 } else {
92                     $tick = "'";
93                 }
94             }
95         }
96         if ($tick eq "'") {
97           s/([\'\\])/\\$1/g;
98         } elsif ($unctrl eq 'unctrl') {
99           s/([\"\\])/\\$1/g ;
100           s/([\000-\037\177])/'^'.pack('c',ord($1)^64)/eg;
101           # uniescape?
102           s/([\200-\377])/'\\0x'.sprintf('%2X',ord($1))/eg 
103             if $quoteHighBit;
104         } elsif ($unctrl eq 'quote') {
105           s/([\"\\\$\@])/\\$1/g if $tick eq '"';
106           s/\033/\\e/g;
107           if (ord('A') == 193) { # EBCDIC.
108               s/([\000-\037\177])/'\\c'.chr(193)/eg; # Unfinished.
109           } else {
110               s/([\000-\037\177])/'\\c'._escaped_ord($1)/eg;
111           }
112         }
113         $_ = uniescape($_);
114         s/([\200-\377])/'\\'.sprintf('%3o',ord($1))/eg if $quoteHighBit;
115         return ($noticks || /^\d+(\.\d*)?\Z/) 
116           ? $_ 
117           : $tick . $_ . $tick;
118     }
119 }
120
121 # Ensure a resulting \ is escaped to be \\
122 sub _escaped_ord {
123     my $chr = shift;
124     $chr = chr(ord($chr)^64);
125     $chr =~ s{\\}{\\\\}g;
126     return $chr;
127 }
128
129 sub ShortArray {
130   my $tArrayDepth = $#{$_[0]} ; 
131   $tArrayDepth = $#{$_[0]} < $arrayDepth-1 ? $#{$_[0]} : $arrayDepth-1 
132     unless  $arrayDepth eq '' ; 
133   my $shortmore = "";
134   $shortmore = " ..." if $tArrayDepth < $#{$_[0]} ;
135   if (!grep(ref $_, @{$_[0]})) {
136     $short = "0..$#{$_[0]}  '" . 
137       join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore";
138     return $short if length $short <= $compactDump;
139   }
140   undef;
141 }
142
143 sub DumpElem {
144   my $short = &stringify($_[0], ref $_[0]);
145   if ($veryCompact && ref $_[0]
146       && (ref $_[0] eq 'ARRAY' and !grep(ref $_, @{$_[0]}) )) {
147     my $end = "0..$#{$v}  '" . 
148       join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore";
149   } elsif ($veryCompact && ref $_[0]
150       && (ref $_[0] eq 'HASH') and !grep(ref $_, values %{$_[0]})) {
151     my $end = 1;
152           $short = $sp . "0..$#{$v}  '" . 
153             join("' '", @{$v}[0..$tArrayDepth]) . "'$shortmore";
154   } else {
155     print "$short\n";
156     unwrap($_[0],$_[1],$_[2]) if ref $_[0];
157   }
158 }
159
160 sub unwrap {
161     return if $DB::signal;
162     local($v) = shift ; 
163     local($s) = shift ; # extra no of spaces
164     local($m) = shift ; # maximum recursion depth
165     return if $m == 0;
166     local(%v,@v,$sp,$value,$key,@sortKeys,$more,$shortmore,$short) ;
167     local($tHashDepth,$tArrayDepth) ;
168
169     $sp = " " x $s ;
170     $s += 3 ; 
171
172     eval {
173     # Check for reused addresses
174     if (ref $v) { 
175       my $val = $v;
176       $val = &{'overload::StrVal'}($v) 
177         if %overload:: and defined &{'overload::StrVal'};
178       # Match type and address.                      
179       # Unblessed references will look like TYPE(0x...)
180       # Blessed references will look like Class=TYPE(0x...)
181       $val =~ s/^.*=//; # suppress the Class part, just keep TYPE(0x...)
182       ($item_type, $address) = 
183         $val =~ /([^\(]+)        # Keep stuff that's     
184                                  # not an open paren
185                  \(              # Skip open paren
186                  (0x[0-9a-f]+)   # Save the address
187                  \)              # Skip close paren
188                  $/x;            # Should be at end now
189
190       if (!$dumpReused && defined $address) { 
191         $address{$address}++ ;
192         if ( $address{$address} > 1 ) { 
193           print "${sp}-> REUSED_ADDRESS\n" ; 
194           return ; 
195         } 
196       }
197     } elsif (ref \$v eq 'GLOB') {
198       # This is a raw glob. Special handling for that.
199       $address = "$v" . "";     # To avoid a bug with globs
200       $address{$address}++ ;
201       if ( $address{$address} > 1 ) { 
202         print "${sp}*DUMPED_GLOB*\n" ; 
203         return ; 
204       } 
205     }
206
207     if (ref $v eq 'Regexp') {
208       # Reformat the regexp to look the standard way.
209       my $re = "$v";
210       $re =~ s,/,\\/,g;
211       print "$sp-> qr/$re/\n";
212       return;
213     }
214
215     if ( $item_type eq 'HASH' ) { 
216         # Hash ref or hash-based object.
217         my @sortKeys = sort keys(%$v) ;
218         undef $more ; 
219         $tHashDepth = $#sortKeys ; 
220         $tHashDepth = $#sortKeys < $hashDepth-1 ? $#sortKeys : $hashDepth-1
221           unless $hashDepth eq '' ; 
222         $more = "....\n" if $tHashDepth < $#sortKeys ; 
223         $shortmore = "";
224         $shortmore = ", ..." if $tHashDepth < $#sortKeys ; 
225         $#sortKeys = $tHashDepth ; 
226         if ($compactDump && !grep(ref $_, values %{$v})) {
227           #$short = $sp . 
228           #  (join ', ', 
229 # Next row core dumps during require from DB on 5.000, even with map {"_"}
230           #   map {&stringify($_) . " => " . &stringify($v->{$_})} 
231           #   @sortKeys) . "'$shortmore";
232           $short = $sp;
233           my @keys;
234           for (@sortKeys) {
235             push @keys, &stringify($_) . " => " . &stringify($v->{$_});
236           }
237           $short .= join ', ', @keys;
238           $short .= $shortmore;
239           (print "$short\n"), return if length $short <= $compactDump;
240         }
241         for $key (@sortKeys) {
242             return if $DB::signal;
243             $value = $ {$v}{$key} ;
244             print "$sp", &stringify($key), " => ";
245             DumpElem $value, $s, $m-1;
246         }
247         print "$sp  empty hash\n" unless @sortKeys;
248         print "$sp$more" if defined $more ;
249     } elsif ( $item_type eq 'ARRAY' ) { 
250         # Array ref or array-based object. Also: undef.
251         # See how big the array is.
252         $tArrayDepth = $#{$v} ; 
253         undef $more ; 
254         # Bigger than the max?
255         $tArrayDepth = $#{$v} < $arrayDepth-1 ? $#{$v} : $arrayDepth-1 
256           if defined $arrayDepth && $arrayDepth ne '';
257         # Yep. Don't show it all.
258         $more = "....\n" if $tArrayDepth < $#{$v} ; 
259         $shortmore = "";
260         $shortmore = " ..." if $tArrayDepth < $#{$v} ;
261
262         if ($compactDump && !grep(ref $_, @{$v})) {
263           if ($#$v >= 0) {
264             $short = $sp . "0..$#{$v}  " . 
265               join(" ", 
266                    map {exists $v->[$_] ? stringify $v->[$_] : "empty"} (0..$tArrayDepth)
267                   ) . "$shortmore";
268           } else {
269             $short = $sp . "empty array";
270           }
271           (print "$short\n"), return if length $short <= $compactDump;
272         }
273         #if ($compactDump && $short = ShortArray($v)) {
274         #  print "$short\n";
275         #  return;
276         #}
277         for $num (0 .. $tArrayDepth) {
278             return if $DB::signal;
279             print "$sp$num  ";
280             if (exists $v->[$num]) {
281                 if (defined $v->[$num]) {
282                   DumpElem $v->[$num], $s, $m-1;
283                 } 
284                 else {
285                   print "undef\n";
286                 }
287             } else {
288                 print "empty slot\n";
289             }
290         }
291         print "$sp  empty array\n" unless @$v;
292         print "$sp$more" if defined $more ;  
293     } elsif ( $item_type eq 'SCALAR' ) { 
294             unless (defined $$v) {
295               print "$sp-> undef\n";
296               return;
297             }
298             print "$sp-> ";
299             DumpElem $$v, $s, $m-1;
300     } elsif ( $item_type eq 'REF' ) { 
301             print "$sp-> $$v\n";
302             return unless defined $$v;
303             unwrap($$v, $s+3, $m-1);
304     } elsif ( $item_type eq 'CODE' ) { 
305             # Code object or reference.
306             print "$sp-> ";
307             dumpsub (0, $v);
308     } elsif ( $item_type eq 'GLOB' ) {
309       # Glob object or reference.
310       print "$sp-> ",&stringify($$v,1),"\n";
311       if ($globPrint) {
312         $s += 3;
313        dumpglob($s, "{$$v}", $$v, 1, $m-1);
314       } elsif (defined ($fileno = eval {fileno($v)})) {
315         print( (' ' x ($s+3)) .  "FileHandle({$$v}) => fileno($fileno)\n" );
316       }
317     } elsif (ref \$v eq 'GLOB') {
318       # Raw glob (again?)
319       if ($globPrint) {
320        dumpglob($s, "{$v}", $v, 1, $m-1) if $globPrint;
321       } elsif (defined ($fileno = eval {fileno(\$v)})) {
322         print( (' ' x $s) .  "FileHandle({$v}) => fileno($fileno)\n" );
323       }
324     }
325     };
326     if ($@) {
327       print( (' ' x $s) .  "<< value could not be dumped: $@ >>\n");
328     }
329
330     return;
331 }
332
333 sub matchlex {
334   (my $var = $_[0]) =~ s/.//;
335   $var eq $_[1] or 
336     ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and 
337       ($1 eq '!') ^ (eval { $var =~ /$2$3/ });
338 }
339
340 sub matchvar {
341   $_[0] eq $_[1] or 
342     ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and 
343       ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/});
344 }
345
346 sub compactDump {
347   $compactDump = shift if @_;
348   $compactDump = 6*80-1 if $compactDump and $compactDump < 2;
349   $compactDump;
350 }
351
352 sub veryCompact {
353   $veryCompact = shift if @_;
354   compactDump(1) if !$compactDump and $veryCompact;
355   $veryCompact;
356 }
357
358 sub unctrlSet {
359   if (@_) {
360     my $in = shift;
361     if ($in eq 'unctrl' or $in eq 'quote') {
362       $unctrl = $in;
363     } else {
364       print "Unknown value for 'unctrl'.\n";
365     }
366   }
367   $unctrl;
368 }
369
370 sub quote {
371   if (@_ and $_[0] eq '"') {
372     $tick = '"';
373     $unctrl = 'quote';
374   } elsif (@_ and $_[0] eq 'auto') {
375     $tick = 'auto';
376     $unctrl = 'quote';
377   } elsif (@_) {                # Need to set
378     $tick = "'";
379     $unctrl = 'unctrl';
380   }
381   $tick;
382 }
383
384 sub dumpglob {
385     return if $DB::signal;
386     my ($off,$key, $val, $all, $m) = @_;
387     local(*entry) = $val;
388     my $fileno;
389     if (($key !~ /^_</ or $dumpDBFiles) and defined $entry) {
390       print( (' ' x $off) . "\$", &unctrl($key), " = " );
391       DumpElem $entry, 3+$off, $m;
392     }
393     if (($key !~ /^_</ or $dumpDBFiles) and @entry) {
394       print( (' ' x $off) . "\@$key = (\n" );
395       unwrap(\@entry,3+$off,$m) ;
396       print( (' ' x $off) .  ")\n" );
397     }
398     if ($key ne "main::" && $key ne "DB::" && %entry
399         && ($dumpPackages or $key !~ /::$/)
400         && ($key !~ /^_</ or $dumpDBFiles)
401         && !($package eq "dumpvar" and $key eq "stab")) {
402       print( (' ' x $off) . "\%$key = (\n" );
403       unwrap(\%entry,3+$off,$m) ;
404       print( (' ' x $off) .  ")\n" );
405     }
406     if (defined ($fileno = eval{fileno(*entry)})) {
407       print( (' ' x $off) .  "FileHandle($key) => fileno($fileno)\n" );
408     }
409     if ($all) {
410       if (defined &entry) {
411         dumpsub($off, $key);
412       }
413     }
414 }
415
416 sub dumplex {
417   return if $DB::signal;
418   my ($key, $val, $m, @vars) = @_;
419   return if @vars && !grep( matchlex($key, $_), @vars );
420   local %address;
421   my $off = 0;  # It reads better this way
422   my $fileno;
423   if (UNIVERSAL::isa($val,'ARRAY')) {
424     print( (' ' x $off) . "$key = (\n" );
425     unwrap($val,3+$off,$m) ;
426     print( (' ' x $off) .  ")\n" );
427   }
428   elsif (UNIVERSAL::isa($val,'HASH')) {
429     print( (' ' x $off) . "$key = (\n" );
430     unwrap($val,3+$off,$m) ;
431     print( (' ' x $off) .  ")\n" );
432   }
433   elsif (UNIVERSAL::isa($val,'IO')) {
434     print( (' ' x $off) .  "FileHandle($key) => fileno($fileno)\n" );
435   }
436   #  No lexical subroutines yet...
437   #  elsif (UNIVERSAL::isa($val,'CODE')) {
438   #    dumpsub($off, $$val);
439   #  }
440   else {
441     print( (' ' x $off) . &unctrl($key), " = " );
442     DumpElem $$val, 3+$off, $m;
443   }
444 }
445
446 sub CvGV_name_or_bust {
447   my $in = shift;
448   return if $skipCvGV;          # Backdoor to avoid problems if XS broken...
449   $in = \&$in;                  # Hard reference...
450   eval {require Devel::Peek; 1} or return;
451   my $gv = Devel::Peek::CvGV($in) or return;
452   *$gv{PACKAGE} . '::' . *$gv{NAME};
453 }
454
455 sub dumpsub {
456     my ($off,$sub) = @_;
457     my $ini = $sub;
458     my $s;
459     $sub = $1 if $sub =~ /^\{\*(.*)\}$/;
460     my $subref = defined $1 ? \&$sub : \&$ini;
461     my $place = $DB::sub{$sub} || (($s = $subs{"$subref"}) && $DB::sub{$s})
462       || (($s = CvGV_name_or_bust($subref)) && $DB::sub{$s})
463       || ($subdump && ($s = findsubs("$subref")) && $DB::sub{$s});
464     $place = '???' unless defined $place;
465     $s = $sub unless defined $s;
466     print( (' ' x $off) .  "&$s in $place\n" );
467 }
468
469 sub findsubs {
470   return undef unless %DB::sub;
471   my ($addr, $name, $loc);
472   while (($name, $loc) = each %DB::sub) {
473     $addr = \&$name;
474     $subs{"$addr"} = $name;
475   }
476   $subdump = 0;
477   $subs{ shift() };
478 }
479
480 sub main::dumpvar {
481     my ($package,$m,@vars) = @_;
482     local(%address,$key,$val,$^W);
483     $package .= "::" unless $package =~ /::$/;
484     *stab = *{"main::"};
485     while ($package =~ /(\w+?::)/g){
486       *stab = $ {stab}{$1};
487     }
488     local $TotalStrings = 0;
489     local $Strings = 0;
490     local $CompleteTotal = 0;
491     while (($key,$val) = each(%stab)) {
492       return if $DB::signal;
493       next if @vars && !grep( matchvar($key, $_), @vars );
494       if ($usageOnly) {
495         globUsage(\$val, $key)
496           if ($package ne 'dumpvar' or $key ne 'stab')
497              and ref(\$val) eq 'GLOB';
498       } else {
499        dumpglob(0,$key, $val, 0, $m);
500       }
501     }
502     if ($usageOnly) {
503       print "String space: $TotalStrings bytes in $Strings strings.\n";
504       $CompleteTotal += $TotalStrings;
505       print "Grand total = $CompleteTotal bytes (1 level deep) + overhead.\n";
506     }
507 }
508
509 sub scalarUsage {
510   my $size = length($_[0]);
511   $TotalStrings += $size;
512   $Strings++;
513   $size;
514 }
515
516 sub arrayUsage {                # array ref, name
517   my $size = 0;
518   map {$size += scalarUsage($_)} @{$_[0]};
519   my $len = @{$_[0]};
520   print "\@$_[1] = $len item", ($len > 1 ? "s" : ""),
521     " (data: $size bytes)\n"
522       if defined $_[1];
523   $CompleteTotal +=  $size;
524   $size;
525 }
526
527 sub hashUsage {         # hash ref, name
528   my @keys = keys %{$_[0]};
529   my @values = values %{$_[0]};
530   my $keys = arrayUsage \@keys;
531   my $values = arrayUsage \@values;
532   my $len = @keys;
533   my $total = $keys + $values;
534   print "\%$_[1] = $len item", ($len > 1 ? "s" : ""),
535     " (keys: $keys; values: $values; total: $total bytes)\n"
536       if defined $_[1];
537   $total;
538 }
539
540 sub globUsage {                 # glob ref, name
541   local *name = *{$_[0]};
542   $total = 0;
543   $total += scalarUsage $name if defined $name;
544   $total += arrayUsage \@name, $_[1] if @name;
545   $total += hashUsage \%name, $_[1] if %name and $_[1] ne "main::" 
546     and $_[1] ne "DB::";   #and !($package eq "dumpvar" and $key eq "stab"));
547   $total;
548 }
549
550 sub packageUsage {
551   my ($package,@vars) = @_;
552   $package .= "::" unless $package =~ /::$/;
553   local *stab = *{"main::"};
554   while ($package =~ /(\w+?::)/g){
555     *stab = $ {stab}{$1};
556   }
557   local $TotalStrings = 0;
558   local $CompleteTotal = 0;
559   my ($key,$val);
560   while (($key,$val) = each(%stab)) {
561     next if @vars && !grep($key eq $_,@vars);
562     globUsage \$val, $key unless $package eq 'dumpvar' and $key eq 'stab';
563   }
564   print "String space: $TotalStrings.\n";
565   $CompleteTotal += $TotalStrings;
566   print "\nGrand total = $CompleteTotal bytes\n";
567 }
568
569 1;
570