source: for-distributions/trunk/bin/windows/perl/lib/dumpvar.pl@ 14489

Last change on this file since 14489 was 14489, checked in by oranfry, 17 years ago

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