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