require 5.014; # For more reliable $@ after eval

[0] Fix | Delete

package dumpvar;

[1] Fix | Delete

[2] Fix | Delete

# Needed for PrettyPrinter only:

[3] Fix | Delete

[4] Fix | Delete

# require 5.001; # Well, it coredumps anyway undef DB in 5.000 (not now)

[5] Fix | Delete

[6] Fix | Delete

# translate control chars to ^X - Randal Schwartz

[7] Fix | Delete

# Modifications to print types by Peter Gordon v1.0

[8] Fix | Delete

[9] Fix | Delete

# Ilya Zakharevich -- patches after 5.001 (and some before ;-)

[10] Fix | Delete

[11] Fix | Delete

# Won't dump symbol tables and contents of debugged files by default

[12] Fix | Delete

[13] Fix | Delete

$winsize = 80 unless defined $winsize;

[14] Fix | Delete

[15] Fix | Delete

sub ASCII { return ord('A') == 65; }

[16] Fix | Delete

[17] Fix | Delete

[18] Fix | Delete

# Defaults

[19] Fix | Delete

[20] Fix | Delete

# $globPrint = 1;

[21] Fix | Delete

$printUndef = 1 unless defined $printUndef;

[22] Fix | Delete

$tick = "auto" unless defined $tick;

[23] Fix | Delete

$unctrl = 'quote' unless defined $unctrl;

[24] Fix | Delete

$subdump = 1;

[25] Fix | Delete

$dumpReused = 0 unless defined $dumpReused;

[26] Fix | Delete

$bareStringify = 1 unless defined $bareStringify;

[27] Fix | Delete

[28] Fix | Delete

my $APC = chr utf8::unicode_to_native(0x9F);

[29] Fix | Delete

my $backslash_c_question = (ASCII) ? '\177' : $APC;

[30] Fix | Delete

[31] Fix | Delete

sub main::dumpValue {

[32] Fix | Delete

local %address;

[33] Fix | Delete

local $^W=0;

[34] Fix | Delete

(print "undef\n"), return unless defined $_[0];

[35] Fix | Delete

(print &stringify($_[0]), "\n"), return unless ref $_[0];

[36] Fix | Delete

push @_, -1 if @_ == 1;

[37] Fix | Delete

dumpvar::unwrap($_[0], 0, $_[1]);

[38] Fix | Delete

}

[39] Fix | Delete

[40] Fix | Delete

# This one is good for variable names:

[41] Fix | Delete

[42] Fix | Delete

sub unctrl {

[43] Fix | Delete

for (my($dummy) = shift) {

[44] Fix | Delete

local($v) ;

[45] Fix | Delete

[46] Fix | Delete

return \$_ if ref \$_ eq "GLOB";

[47] Fix | Delete

s/([\000-\037])/ '^' . chr(utf8::unicode_to_native(ord($1)^64))/eg;

[48] Fix | Delete

s/ $backslash_c_question /^?/xg;

[49] Fix | Delete

return $_;

[50] Fix | Delete

}

[51] Fix | Delete

}

[52] Fix | Delete

[53] Fix | Delete

sub uniescape {

[54] Fix | Delete

join("",

[55] Fix | Delete

map { $_ > 255 ? sprintf("\\x{%04X}", $_) : chr($_) }

[56] Fix | Delete

unpack("W*", $_[0]));

[57] Fix | Delete

}

[58] Fix | Delete

[59] Fix | Delete

sub stringify {

[60] Fix | Delete

my $string;

[61] Fix | Delete

if (eval { $string = _stringify(@_); 1 }) {

[62] Fix | Delete

return $string;

[63] Fix | Delete

}

[64] Fix | Delete

[65] Fix | Delete

return "<< value could not be dumped: $@ >>";

[66] Fix | Delete

}

[67] Fix | Delete

[68] Fix | Delete

sub _stringify {

[69] Fix | Delete

(my $__, local $noticks) = @_;

[70] Fix | Delete

for ($__) {

[71] Fix | Delete

local($v) ;

[72] Fix | Delete

my $tick = $tick;

[73] Fix | Delete

[74] Fix | Delete

return 'undef' unless defined $_ or not $printUndef;

[75] Fix | Delete

return $_ . "" if ref \$_ eq 'GLOB';

[76] Fix | Delete

$_ = &{'overload::StrVal'}($_)

[77] Fix | Delete

if $bareStringify and ref $_

[78] Fix | Delete

and %overload:: and defined &{'overload::StrVal'};

[79] Fix | Delete

[80] Fix | Delete

if ($tick eq 'auto') {

[81] Fix | Delete

if (/[^[:^cntrl:]\n]/u) { # All controls but \n get '"'

[82] Fix | Delete

$tick = '"';

[83] Fix | Delete

} else {

[84] Fix | Delete

$tick = "'";

[85] Fix | Delete

}

[86] Fix | Delete

}

[87] Fix | Delete

if ($tick eq "'") {

[88] Fix | Delete

s/([\'\\])/\\$1/g;

[89] Fix | Delete

} elsif ($unctrl eq 'unctrl') {

[90] Fix | Delete

s/([\"\\])/\\$1/g ;

[91] Fix | Delete

$_ = &unctrl($_);

[92] Fix | Delete

# uniescape?

[93] Fix | Delete

s/([[:^ascii:]])/'\\0x'.sprintf('%2X',ord($1))/eg

[94] Fix | Delete

if $quoteHighBit;

[95] Fix | Delete

} elsif ($unctrl eq 'quote') {

[96] Fix | Delete

s/([\"\\\$\@])/\\$1/g if $tick eq '"';

[97] Fix | Delete

s/\e/\\e/g;

[98] Fix | Delete

s/([\000-\037$backslash_c_question])/'\\c'._escaped_ord($1)/eg;

[99] Fix | Delete

}

[100] Fix | Delete

$_ = uniescape($_);

[101] Fix | Delete

s/([[:^ascii:]])/'\\'.sprintf('%3o',ord($1))/eg if $quoteHighBit;

[102] Fix | Delete

return ($noticks || /^\d+(\.\d*)?\Z/)

[103] Fix | Delete

? $_

[104] Fix | Delete

: $tick . $_ . $tick;

[105] Fix | Delete

}

[106] Fix | Delete

}

[107] Fix | Delete

[108] Fix | Delete

# Ensure a resulting \ is escaped to be \\

[109] Fix | Delete

sub _escaped_ord {

[110] Fix | Delete

my $chr = shift;

[111] Fix | Delete

if ($chr eq $backslash_c_question) {

[112] Fix | Delete

$chr = '?';

[113] Fix | Delete

}

[114] Fix | Delete

else {

[115] Fix | Delete

$chr = chr(utf8::unicode_to_native(ord($chr)^64));

[116] Fix | Delete

$chr =~ s{\\}{\\\\}g;

[117] Fix | Delete

}

[118] Fix | Delete

return $chr;

[119] Fix | Delete

}

[120] Fix | Delete

[121] Fix | Delete

sub ShortArray {

[122] Fix | Delete

my $tArrayDepth = $#{$_[0]} ;

[123] Fix | Delete

$tArrayDepth = $#{$_[0]} < $arrayDepth-1 ? $#{$_[0]} : $arrayDepth-1

[124] Fix | Delete

unless $arrayDepth eq '' ;

[125] Fix | Delete

my $shortmore = "";

[126] Fix | Delete

$shortmore = " ..." if $tArrayDepth < $#{$_[0]} ;

[127] Fix | Delete

if (!grep(ref $_, @{$_[0]})) {

[128] Fix | Delete

$short = "0..$#{$_[0]} '" .

[129] Fix | Delete

join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore";

[130] Fix | Delete

return $short if length $short <= $compactDump;

[131] Fix | Delete

}

[132] Fix | Delete

undef;

[133] Fix | Delete

}

[134] Fix | Delete

[135] Fix | Delete

sub DumpElem {

[136] Fix | Delete

my $short = &stringify($_[0], ref $_[0]);

[137] Fix | Delete

if ($veryCompact && ref $_[0]

[138] Fix | Delete

&& (ref $_[0] eq 'ARRAY' and !grep(ref $_, @{$_[0]}) )) {

[139] Fix | Delete

my $end = "0..$#{$v} '" .

[140] Fix | Delete

join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore";

[141] Fix | Delete

} elsif ($veryCompact && ref $_[0]

[142] Fix | Delete

&& (ref $_[0] eq 'HASH') and !grep(ref $_, values %{$_[0]})) {

[143] Fix | Delete

my $end = 1;

[144] Fix | Delete

$short = $sp . "0..$#{$v} '" .

[145] Fix | Delete

join("' '", @{$v}[0..$tArrayDepth]) . "'$shortmore";

[146] Fix | Delete

} else {

[147] Fix | Delete

print "$short\n";

[148] Fix | Delete

unwrap($_[0],$_[1],$_[2]) if ref $_[0];

[149] Fix | Delete

}

[150] Fix | Delete

}

[151] Fix | Delete

[152] Fix | Delete

sub unwrap {

[153] Fix | Delete

return if $DB::signal;

[154] Fix | Delete

local($v) = shift ;

[155] Fix | Delete

local($s) = shift ; # extra no of spaces

[156] Fix | Delete

local($m) = shift ; # maximum recursion depth

[157] Fix | Delete

return if $m == 0;

[158] Fix | Delete

local(%v,@v,$sp,$value,$key,@sortKeys,$more,$shortmore,$short) ;

[159] Fix | Delete

local($tHashDepth,$tArrayDepth) ;

[160] Fix | Delete

[161] Fix | Delete

$sp = " " x $s ;

[162] Fix | Delete

$s += 3 ;

[163] Fix | Delete

[164] Fix | Delete

eval {

[165] Fix | Delete

# Check for reused addresses

[166] Fix | Delete

if (ref $v) {

[167] Fix | Delete

my $val = $v;

[168] Fix | Delete

$val = &{'overload::StrVal'}($v)

[169] Fix | Delete

if %overload:: and defined &{'overload::StrVal'};

[170] Fix | Delete

# Match type and address.

[171] Fix | Delete

# Unblessed references will look like TYPE(0x...)

[172] Fix | Delete

# Blessed references will look like Class=TYPE(0x...)

[173] Fix | Delete

$val =~ s/^.*=//; # suppress the Class part, just keep TYPE(0x...)

[174] Fix | Delete

($item_type, $address) =

[175] Fix | Delete

$val =~ /([^\(]+) # Keep stuff that's

[176] Fix | Delete

# not an open paren

[177] Fix | Delete

\( # Skip open paren

[178] Fix | Delete

(0x[0-9a-f]+) # Save the address

[179] Fix | Delete

\) # Skip close paren

[180] Fix | Delete

$/x; # Should be at end now

[181] Fix | Delete

[182] Fix | Delete

if (!$dumpReused && defined $address) {

[183] Fix | Delete

$address{$address}++ ;

[184] Fix | Delete

if ( $address{$address} > 1 ) {

[185] Fix | Delete

print "${sp}-> REUSED_ADDRESS\n" ;

[186] Fix | Delete

return ;

[187] Fix | Delete

}

[188] Fix | Delete

}

[189] Fix | Delete

} elsif (ref \$v eq 'GLOB') {

[190] Fix | Delete

# This is a raw glob. Special handling for that.

[191] Fix | Delete

$address = "$v" . ""; # To avoid a bug with globs

[192] Fix | Delete

$address{$address}++ ;

[193] Fix | Delete

if ( $address{$address} > 1 ) {

[194] Fix | Delete

print "${sp}*DUMPED_GLOB*\n" ;

[195] Fix | Delete

return ;

[196] Fix | Delete

}

[197] Fix | Delete

}

[198] Fix | Delete

[199] Fix | Delete

if (ref $v eq 'Regexp') {

[200] Fix | Delete

# Reformat the regexp to look the standard way.

[201] Fix | Delete

my $re = "$v";

[202] Fix | Delete

$re =~ s,/,\\/,g;

[203] Fix | Delete

print "$sp-> qr/$re/\n";

[204] Fix | Delete

return;

[205] Fix | Delete

}

[206] Fix | Delete

[207] Fix | Delete

if ( $item_type eq 'HASH' ) {

[208] Fix | Delete

# Hash ref or hash-based object.

[209] Fix | Delete

my @sortKeys = sort keys(%$v) ;

[210] Fix | Delete

undef $more ;

[211] Fix | Delete

$tHashDepth = $#sortKeys ;

[212] Fix | Delete

$tHashDepth = $#sortKeys < $hashDepth-1 ? $#sortKeys : $hashDepth-1

[213] Fix | Delete

unless $hashDepth eq '' ;

[214] Fix | Delete

$more = "....\n" if $tHashDepth < $#sortKeys ;

[215] Fix | Delete

$shortmore = "";

[216] Fix | Delete

$shortmore = ", ..." if $tHashDepth < $#sortKeys ;

[217] Fix | Delete

$#sortKeys = $tHashDepth ;

[218] Fix | Delete

if ($compactDump && !grep(ref $_, values %{$v})) {

[219] Fix | Delete

#$short = $sp .

[220] Fix | Delete

# (join ', ',

[221] Fix | Delete

# Next row core dumps during require from DB on 5.000, even with map {"_"}

[222] Fix | Delete

# map {&stringify($_) . " => " . &stringify($v->{$_})}

[223] Fix | Delete

# @sortKeys) . "'$shortmore";

[224] Fix | Delete

$short = $sp;

[225] Fix | Delete

my @keys;

[226] Fix | Delete

for (@sortKeys) {

[227] Fix | Delete

push @keys, &stringify($_) . " => " . &stringify($v->{$_});

[228] Fix | Delete

}

[229] Fix | Delete

$short .= join ', ', @keys;

[230] Fix | Delete

$short .= $shortmore;

[231] Fix | Delete

(print "$short\n"), return if length $short <= $compactDump;

[232] Fix | Delete

}

[233] Fix | Delete

for $key (@sortKeys) {

[234] Fix | Delete

return if $DB::signal;

[235] Fix | Delete

$value = $ {$v}{$key} ;

[236] Fix | Delete

print "$sp", &stringify($key), " => ";

[237] Fix | Delete

DumpElem $value, $s, $m-1;

[238] Fix | Delete

}

[239] Fix | Delete

print "$sp empty hash\n" unless @sortKeys;

[240] Fix | Delete

print "$sp$more" if defined $more ;

[241] Fix | Delete

} elsif ( $item_type eq 'ARRAY' ) {

[242] Fix | Delete

# Array ref or array-based object. Also: undef.

[243] Fix | Delete

# See how big the array is.

[244] Fix | Delete

$tArrayDepth = $#{$v} ;

[245] Fix | Delete

undef $more ;

[246] Fix | Delete

# Bigger than the max?

[247] Fix | Delete

$tArrayDepth = $#{$v} < $arrayDepth-1 ? $#{$v} : $arrayDepth-1

[248] Fix | Delete

if defined $arrayDepth && $arrayDepth ne '';

[249] Fix | Delete

# Yep. Don't show it all.

[250] Fix | Delete

$more = "....\n" if $tArrayDepth < $#{$v} ;

[251] Fix | Delete

$shortmore = "";

[252] Fix | Delete

$shortmore = " ..." if $tArrayDepth < $#{$v} ;

[253] Fix | Delete

[254] Fix | Delete

if ($compactDump && !grep(ref $_, @{$v})) {

[255] Fix | Delete

if ($#$v >= 0) {

[256] Fix | Delete

$short = $sp . "0..$#{$v} " .

[257] Fix | Delete

join(" ",

[258] Fix | Delete

map {exists $v->[$_] ? stringify $v->[$_] : "empty"} (0..$tArrayDepth)

[259] Fix | Delete

) . "$shortmore";

[260] Fix | Delete

} else {

[261] Fix | Delete

$short = $sp . "empty array";

[262] Fix | Delete

}

[263] Fix | Delete

(print "$short\n"), return if length $short <= $compactDump;

[264] Fix | Delete

}

[265] Fix | Delete

#if ($compactDump && $short = ShortArray($v)) {

[266] Fix | Delete

# print "$short\n";

[267] Fix | Delete

# return;

[268] Fix | Delete

#}

[269] Fix | Delete

for $num (0 .. $tArrayDepth) {

[270] Fix | Delete

return if $DB::signal;

[271] Fix | Delete

print "$sp$num ";

[272] Fix | Delete

if (exists $v->[$num]) {

[273] Fix | Delete

if (defined $v->[$num]) {

[274] Fix | Delete

DumpElem $v->[$num], $s, $m-1;

[275] Fix | Delete

}

[276] Fix | Delete

else {

[277] Fix | Delete

print "undef\n";

[278] Fix | Delete

}

[279] Fix | Delete

} else {

[280] Fix | Delete

print "empty slot\n";

[281] Fix | Delete

}

[282] Fix | Delete

}

[283] Fix | Delete

print "$sp empty array\n" unless @$v;

[284] Fix | Delete

print "$sp$more" if defined $more ;

[285] Fix | Delete

} elsif ( $item_type eq 'SCALAR' ) {

[286] Fix | Delete

unless (defined $$v) {

[287] Fix | Delete

print "$sp-> undef\n";

[288] Fix | Delete

return;

[289] Fix | Delete

}

[290] Fix | Delete

print "$sp-> ";

[291] Fix | Delete

DumpElem $$v, $s, $m-1;

[292] Fix | Delete

} elsif ( $item_type eq 'REF' ) {

[293] Fix | Delete

print "$sp-> $$v\n";

[294] Fix | Delete

return unless defined $$v;

[295] Fix | Delete

unwrap($$v, $s+3, $m-1);

[296] Fix | Delete

} elsif ( $item_type eq 'CODE' ) {

[297] Fix | Delete

# Code object or reference.

[298] Fix | Delete

print "$sp-> ";

[299] Fix | Delete

dumpsub (0, $v);

[300] Fix | Delete

} elsif ( $item_type eq 'GLOB' ) {

[301] Fix | Delete

# Glob object or reference.

[302] Fix | Delete

print "$sp-> ",&stringify($$v,1),"\n";

[303] Fix | Delete

if ($globPrint) {

[304] Fix | Delete

$s += 3;

[305] Fix | Delete

dumpglob($s, "{$$v}", $$v, 1, $m-1);

[306] Fix | Delete

} elsif (defined ($fileno = eval {fileno($v)})) {

[307] Fix | Delete

print( (' ' x ($s+3)) . "FileHandle({$$v}) => fileno($fileno)\n" );

[308] Fix | Delete

}

[309] Fix | Delete

} elsif (ref \$v eq 'GLOB') {

[310] Fix | Delete

# Raw glob (again?)

[311] Fix | Delete

if ($globPrint) {

[312] Fix | Delete

dumpglob($s, "{$v}", $v, 1, $m-1) if $globPrint;

[313] Fix | Delete

} elsif (defined ($fileno = eval {fileno(\$v)})) {

[314] Fix | Delete

print( (' ' x $s) . "FileHandle({$v}) => fileno($fileno)\n" );

[315] Fix | Delete

}

[316] Fix | Delete

}

[317] Fix | Delete

};

[318] Fix | Delete

if ($@) {

[319] Fix | Delete

print( (' ' x $s) . "<< value could not be dumped: $@ >>\n");

[320] Fix | Delete

}

[321] Fix | Delete

[322] Fix | Delete

return;

[323] Fix | Delete

}

[324] Fix | Delete

[325] Fix | Delete

sub matchlex {

[326] Fix | Delete

(my $var = $_[0]) =~ s/.//;

[327] Fix | Delete

$var eq $_[1] or

[328] Fix | Delete

($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and

[329] Fix | Delete

($1 eq '!') ^ (eval { $var =~ /$2$3/ });

[330] Fix | Delete

}

[331] Fix | Delete

[332] Fix | Delete

sub matchvar {

[333] Fix | Delete

$_[0] eq $_[1] or

[334] Fix | Delete

($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and

[335] Fix | Delete

($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/});

[336] Fix | Delete

}

[337] Fix | Delete

[338] Fix | Delete

sub compactDump {

[339] Fix | Delete

$compactDump = shift if @_;

[340] Fix | Delete

$compactDump = 6*80-1 if $compactDump and $compactDump < 2;

[341] Fix | Delete

$compactDump;

[342] Fix | Delete

}

[343] Fix | Delete

[344] Fix | Delete

sub veryCompact {

[345] Fix | Delete

$veryCompact = shift if @_;

[346] Fix | Delete

compactDump(1) if !$compactDump and $veryCompact;

[347] Fix | Delete

$veryCompact;

[348] Fix | Delete

}

[349] Fix | Delete

[350] Fix | Delete

sub unctrlSet {

[351] Fix | Delete

if (@_) {

[352] Fix | Delete

my $in = shift;

[353] Fix | Delete

if ($in eq 'unctrl' or $in eq 'quote') {

[354] Fix | Delete

$unctrl = $in;

[355] Fix | Delete

} else {

[356] Fix | Delete

print "Unknown value for 'unctrl'.\n";

[357] Fix | Delete

}

[358] Fix | Delete

}

[359] Fix | Delete

$unctrl;

[360] Fix | Delete

}

[361] Fix | Delete

[362] Fix | Delete

sub quote {

[363] Fix | Delete

if (@_ and $_[0] eq '"') {

[364] Fix | Delete

$tick = '"';

[365] Fix | Delete

$unctrl = 'quote';

[366] Fix | Delete

} elsif (@_ and $_[0] eq 'auto') {

[367] Fix | Delete

$tick = 'auto';

[368] Fix | Delete

$unctrl = 'quote';

[369] Fix | Delete

} elsif (@_) { # Need to set

[370] Fix | Delete

$tick = "'";

[371] Fix | Delete

$unctrl = 'unctrl';

[372] Fix | Delete

}

[373] Fix | Delete

$tick;

[374] Fix | Delete

}

[375] Fix | Delete

[376] Fix | Delete

sub dumpglob {

[377] Fix | Delete

return if $DB::signal;

[378] Fix | Delete

my ($off,$key, $val, $all, $m) = @_;

[379] Fix | Delete

local(*entry) = $val;

[380] Fix | Delete

my $fileno;

[381] Fix | Delete

if (($key !~ /^_</ or $dumpDBFiles) and defined $entry) {

[382] Fix | Delete

print( (' ' x $off) . "\$", &unctrl($key), " = " );

[383] Fix | Delete

DumpElem $entry, 3+$off, $m;

[384] Fix | Delete

}

[385] Fix | Delete

if (($key !~ /^_</ or $dumpDBFiles) and @entry) {

[386] Fix | Delete

print( (' ' x $off) . "\@$key = (\n" );

[387] Fix | Delete

unwrap(\@entry,3+$off,$m) ;

[388] Fix | Delete

print( (' ' x $off) . ")\n" );

[389] Fix | Delete

}

[390] Fix | Delete

if ($key ne "main::" && $key ne "DB::" && %entry

[391] Fix | Delete

&& ($dumpPackages or $key !~ /::$/)

[392] Fix | Delete

&& ($key !~ /^_</ or $dumpDBFiles)

[393] Fix | Delete

&& !($package eq "dumpvar" and $key eq "stab")) {

[394] Fix | Delete

print( (' ' x $off) . "\%$key = (\n" );

[395] Fix | Delete

unwrap(\%entry,3+$off,$m) ;

[396] Fix | Delete

print( (' ' x $off) . ")\n" );

[397] Fix | Delete

}

[398] Fix | Delete

if (defined ($fileno = eval{fileno(*entry)})) {

[399] Fix | Delete

print( (' ' x $off) . "FileHandle($key) => fileno($fileno)\n" );

[400] Fix | Delete

}

[401] Fix | Delete

if ($all) {

[402] Fix | Delete

if (defined &entry) {

[403] Fix | Delete

dumpsub($off, $key);

[404] Fix | Delete

}

[405] Fix | Delete

}

[406] Fix | Delete

}

[407] Fix | Delete

[408] Fix | Delete

sub dumplex {

[409] Fix | Delete

return if $DB::signal;

[410] Fix | Delete

my ($key, $val, $m, @vars) = @_;

[411] Fix | Delete

return if @vars && !grep( matchlex($key, $_), @vars );

[412] Fix | Delete

local %address;

[413] Fix | Delete

my $off = 0; # It reads better this way

[414] Fix | Delete

my $fileno;

[415] Fix | Delete

if (UNIVERSAL::isa($val,'ARRAY')) {

[416] Fix | Delete

print( (' ' x $off) . "$key = (\n" );

[417] Fix | Delete

unwrap($val,3+$off,$m) ;

[418] Fix | Delete

print( (' ' x $off) . ")\n" );

[419] Fix | Delete

}

[420] Fix | Delete

elsif (UNIVERSAL::isa($val,'HASH')) {

[421] Fix | Delete

print( (' ' x $off) . "$key = (\n" );

[422] Fix | Delete

unwrap($val,3+$off,$m) ;

[423] Fix | Delete

print( (' ' x $off) . ")\n" );

[424] Fix | Delete

}

[425] Fix | Delete

elsif (UNIVERSAL::isa($val,'IO')) {

[426] Fix | Delete

print( (' ' x $off) . "FileHandle($key) => fileno($fileno)\n" );

[427] Fix | Delete

}

[428] Fix | Delete

# No lexical subroutines yet...

[429] Fix | Delete

# elsif (UNIVERSAL::isa($val,'CODE')) {

[430] Fix | Delete

# dumpsub($off, $$val);

[431] Fix | Delete

# }

[432] Fix | Delete

else {

[433] Fix | Delete

print( (' ' x $off) . &unctrl($key), " = " );

[434] Fix | Delete

DumpElem $$val, 3+$off, $m;

[435] Fix | Delete

}

[436] Fix | Delete

}

[437] Fix | Delete

[438] Fix | Delete

sub CvGV_name_or_bust {

[439] Fix | Delete

my $in = shift;

[440] Fix | Delete

return if $skipCvGV; # Backdoor to avoid problems if XS broken...

[441] Fix | Delete

$in = \&$in; # Hard reference...

[442] Fix | Delete

eval {require Devel::Peek; 1} or return;

[443] Fix | Delete

my $gv = Devel::Peek::CvGV($in) or return;

[444] Fix | Delete

*$gv{PACKAGE} . '::' . *$gv{NAME};

[445] Fix | Delete

}

[446] Fix | Delete

[447] Fix | Delete

sub dumpsub {

[448] Fix | Delete

my ($off,$sub) = @_;

[449] Fix | Delete

my $ini = $sub;

[450] Fix | Delete

my $s;

[451] Fix | Delete

$sub = $1 if $sub =~ /^\{\*(.*)\}$/;

[452] Fix | Delete

my $subref = defined $1 ? \&$sub : \&$ini;

[453] Fix | Delete

my $place = $DB::sub{$sub} || (($s = $subs{"$subref"}) && $DB::sub{$s})

[454] Fix | Delete

|| (($s = CvGV_name_or_bust($subref)) && $DB::sub{$s})

[455] Fix | Delete

|| ($subdump && ($s = findsubs("$subref")) && $DB::sub{$s});

[456] Fix | Delete

$place = '???' unless defined $place;

[457] Fix | Delete

$s = $sub unless defined $s;

[458] Fix | Delete

print( (' ' x $off) . "&$s in $place\n" );

[459] Fix | Delete

}

[460] Fix | Delete

[461] Fix | Delete

sub findsubs {

[462] Fix | Delete

return undef unless %DB::sub;

[463] Fix | Delete

my ($addr, $name, $loc);

[464] Fix | Delete

while (($name, $loc) = each %DB::sub) {

[465] Fix | Delete

$addr = \&$name;

[466] Fix | Delete

$subs{"$addr"} = $name;

[467] Fix | Delete

}

[468] Fix | Delete

$subdump = 0;

[469] Fix | Delete

$subs{ shift() };

[470] Fix | Delete

}

[471] Fix | Delete

[472] Fix | Delete

sub main::dumpvar {

[473] Fix | Delete

my ($package,$m,@vars) = @_;

[474] Fix | Delete

local(%address,$key,$val,$^W);

[475] Fix | Delete

$package .= "::" unless $package =~ /::$/;

[476] Fix | Delete

*stab = *{"main::"};

[477] Fix | Delete

while ($package =~ /(\w+?::)/g){

[478] Fix | Delete

*stab = $ {stab}{$1};

[479] Fix | Delete

}

[480] Fix | Delete

local $TotalStrings = 0;

[481] Fix | Delete

local $Strings = 0;

[482] Fix | Delete

local $CompleteTotal = 0;

[483] Fix | Delete

while (($key,$val) = each(%stab)) {

[484] Fix | Delete

return if $DB::signal;

[485] Fix | Delete

next if @vars && !grep( matchvar($key, $_), @vars );

[486] Fix | Delete

if ($usageOnly) {

[487] Fix | Delete

globUsage(\$val, $key)

[488] Fix | Delete

if ($package ne 'dumpvar' or $key ne 'stab')

[489] Fix | Delete

and ref(\$val) eq 'GLOB';

[490] Fix | Delete

} else {

[491] Fix | Delete

dumpglob(0,$key, $val, 0, $m);

[492] Fix | Delete

}

[493] Fix | Delete

}

[494] Fix | Delete

if ($usageOnly) {

[495] Fix | Delete

print "String space: $TotalStrings bytes in $Strings strings.\n";

[496] Fix | Delete

$CompleteTotal += $TotalStrings;

[497] Fix | Delete

print "Grand total = $CompleteTotal bytes (1 level deep) + overhead.\n";

[498] Fix | Delete

}

[499] Fix | Delete