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