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