| 1 |
root |
1.1 |
use 5.006_001; # for (defined ref) and $#$v and our |
| 2 |
|
|
package Dumpvalue; |
| 3 |
|
|
use strict; |
| 4 |
|
|
our $VERSION = '1.11'; |
| 5 |
|
|
our(%address, $stab, @stab, %stab, %subs); |
| 6 |
|
|
|
| 7 |
|
|
# documentation nits, handle complex data structures better by chromatic |
| 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 |
|
|
# (IZ) changes for objectification: |
| 16 |
|
|
# c) quote() renamed to method set_quote(); |
| 17 |
|
|
# d) unctrlSet() renamed to method set_unctrl(); |
| 18 |
|
|
# f) Compiles with `use strict', but in two places no strict refs is needed: |
| 19 |
|
|
# maybe more problems are waiting... |
| 20 |
|
|
|
| 21 |
|
|
my %defaults = ( |
| 22 |
|
|
globPrint => 0, |
| 23 |
|
|
printUndef => 1, |
| 24 |
|
|
tick => "auto", |
| 25 |
|
|
unctrl => 'quote', |
| 26 |
|
|
subdump => 1, |
| 27 |
|
|
dumpReused => 0, |
| 28 |
|
|
bareStringify => 1, |
| 29 |
|
|
hashDepth => '', |
| 30 |
|
|
arrayDepth => '', |
| 31 |
|
|
dumpDBFiles => '', |
| 32 |
|
|
dumpPackages => '', |
| 33 |
|
|
quoteHighBit => '', |
| 34 |
|
|
usageOnly => '', |
| 35 |
|
|
compactDump => '', |
| 36 |
|
|
veryCompact => '', |
| 37 |
|
|
stopDbSignal => '', |
| 38 |
|
|
); |
| 39 |
|
|
|
| 40 |
|
|
sub new { |
| 41 |
|
|
my $class = shift; |
| 42 |
|
|
my %opt = (%defaults, @_); |
| 43 |
|
|
bless \%opt, $class; |
| 44 |
|
|
} |
| 45 |
|
|
|
| 46 |
|
|
sub set { |
| 47 |
|
|
my $self = shift; |
| 48 |
|
|
my %opt = @_; |
| 49 |
|
|
@$self{keys %opt} = values %opt; |
| 50 |
|
|
} |
| 51 |
|
|
|
| 52 |
|
|
sub get { |
| 53 |
|
|
my $self = shift; |
| 54 |
|
|
wantarray ? @$self{@_} : $$self{pop @_}; |
| 55 |
|
|
} |
| 56 |
|
|
|
| 57 |
|
|
sub dumpValue { |
| 58 |
|
|
my $self = shift; |
| 59 |
|
|
die "usage: \$dumper->dumpValue(value)" unless @_ == 1; |
| 60 |
|
|
local %address; |
| 61 |
|
|
local $^W=0; |
| 62 |
|
|
(print "undef\n"), return unless defined $_[0]; |
| 63 |
|
|
(print $self->stringify($_[0]), "\n"), return unless ref $_[0]; |
| 64 |
|
|
$self->unwrap($_[0],0); |
| 65 |
|
|
} |
| 66 |
|
|
|
| 67 |
|
|
sub dumpValues { |
| 68 |
|
|
my $self = shift; |
| 69 |
|
|
local %address; |
| 70 |
|
|
local $^W=0; |
| 71 |
|
|
(print "undef\n"), return unless defined $_[0]; |
| 72 |
|
|
$self->unwrap(\@_,0); |
| 73 |
|
|
} |
| 74 |
|
|
|
| 75 |
|
|
# This one is good for variable names: |
| 76 |
|
|
|
| 77 |
|
|
sub unctrl { |
| 78 |
|
|
local($_) = @_; |
| 79 |
|
|
|
| 80 |
|
|
return \$_ if ref \$_ eq "GLOB"; |
| 81 |
|
|
s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg; |
| 82 |
|
|
$_; |
| 83 |
|
|
} |
| 84 |
|
|
|
| 85 |
|
|
sub stringify { |
| 86 |
|
|
my $self = shift; |
| 87 |
|
|
local $_ = shift; |
| 88 |
|
|
my $noticks = shift; |
| 89 |
|
|
my $tick = $self->{tick}; |
| 90 |
|
|
|
| 91 |
|
|
return 'undef' unless defined $_ or not $self->{printUndef}; |
| 92 |
|
|
return $_ . "" if ref \$_ eq 'GLOB'; |
| 93 |
|
|
{ no strict 'refs'; |
| 94 |
|
|
$_ = &{'overload::StrVal'}($_) |
| 95 |
|
|
if $self->{bareStringify} and ref $_ |
| 96 |
|
|
and %overload:: and defined &{'overload::StrVal'}; |
| 97 |
|
|
} |
| 98 |
|
|
|
| 99 |
|
|
if ($tick eq 'auto') { |
| 100 |
|
|
if (/[\000-\011\013-\037\177]/) { |
| 101 |
|
|
$tick = '"'; |
| 102 |
|
|
} else { |
| 103 |
|
|
$tick = "'"; |
| 104 |
|
|
} |
| 105 |
|
|
} |
| 106 |
|
|
if ($tick eq "'") { |
| 107 |
|
|
s/([\'\\])/\\$1/g; |
| 108 |
|
|
} elsif ($self->{unctrl} eq 'unctrl') { |
| 109 |
|
|
s/([\"\\])/\\$1/g ; |
| 110 |
|
|
s/([\000-\037\177])/'^'.pack('c',ord($1)^64)/eg; |
| 111 |
|
|
s/([\200-\377])/'\\0x'.sprintf('%2X',ord($1))/eg |
| 112 |
|
|
if $self->{quoteHighBit}; |
| 113 |
|
|
} elsif ($self->{unctrl} eq 'quote') { |
| 114 |
|
|
s/([\"\\\$\@])/\\$1/g if $tick eq '"'; |
| 115 |
|
|
s/\033/\\e/g; |
| 116 |
|
|
s/([\000-\037\177])/'\\c'.chr(ord($1)^64)/eg; |
| 117 |
|
|
} |
| 118 |
|
|
s/([\200-\377])/'\\'.sprintf('%3o',ord($1))/eg if $self->{quoteHighBit}; |
| 119 |
|
|
($noticks || /^\d+(\.\d*)?\Z/) |
| 120 |
|
|
? $_ |
| 121 |
|
|
: $tick . $_ . $tick; |
| 122 |
|
|
} |
| 123 |
|
|
|
| 124 |
|
|
sub DumpElem { |
| 125 |
|
|
my ($self, $v) = (shift, shift); |
| 126 |
|
|
my $short = $self->stringify($v, ref $v); |
| 127 |
|
|
my $shortmore = ''; |
| 128 |
|
|
if ($self->{veryCompact} && ref $v |
| 129 |
|
|
&& (ref $v eq 'ARRAY' and !grep(ref $_, @$v) )) { |
| 130 |
|
|
my $depth = $#$v; |
| 131 |
|
|
($shortmore, $depth) = (' ...', $self->{arrayDepth} - 1) |
| 132 |
|
|
if $self->{arrayDepth} and $depth >= $self->{arrayDepth}; |
| 133 |
|
|
my @a = map $self->stringify($_), @$v[0..$depth]; |
| 134 |
|
|
print "0..$#{$v} @a$shortmore\n"; |
| 135 |
|
|
} elsif ($self->{veryCompact} && ref $v |
| 136 |
|
|
&& (ref $v eq 'HASH') and !grep(ref $_, values %$v)) { |
| 137 |
|
|
my @a = sort keys %$v; |
| 138 |
|
|
my $depth = $#a; |
| 139 |
|
|
($shortmore, $depth) = (' ...', $self->{hashDepth} - 1) |
| 140 |
|
|
if $self->{hashDepth} and $depth >= $self->{hashDepth}; |
| 141 |
|
|
my @b = map {$self->stringify($_) . " => " . $self->stringify($$v{$_})} |
| 142 |
|
|
@a[0..$depth]; |
| 143 |
|
|
local $" = ', '; |
| 144 |
|
|
print "@b$shortmore\n"; |
| 145 |
|
|
} else { |
| 146 |
|
|
print "$short\n"; |
| 147 |
|
|
$self->unwrap($v,shift); |
| 148 |
|
|
} |
| 149 |
|
|
} |
| 150 |
|
|
|
| 151 |
|
|
sub unwrap { |
| 152 |
|
|
my $self = shift; |
| 153 |
|
|
return if $DB::signal and $self->{stopDbSignal}; |
| 154 |
|
|
my ($v) = shift ; |
| 155 |
|
|
my ($s) = shift ; # extra no of spaces |
| 156 |
|
|
my $sp; |
| 157 |
|
|
my (%v,@v,$address,$short,$fileno); |
| 158 |
|
|
|
| 159 |
|
|
$sp = " " x $s ; |
| 160 |
|
|
$s += 3 ; |
| 161 |
|
|
|
| 162 |
|
|
# Check for reused addresses |
| 163 |
|
|
if (ref $v) { |
| 164 |
|
|
my $val = $v; |
| 165 |
|
|
{ no strict 'refs'; |
| 166 |
|
|
$val = &{'overload::StrVal'}($v) |
| 167 |
|
|
if %overload:: and defined &{'overload::StrVal'}; |
| 168 |
|
|
} |
| 169 |
|
|
($address) = $val =~ /(0x[0-9a-f]+)\)$/ ; |
| 170 |
|
|
if (!$self->{dumpReused} && defined $address) { |
| 171 |
|
|
$address{$address}++ ; |
| 172 |
|
|
if ( $address{$address} > 1 ) { |
| 173 |
|
|
print "${sp}-> REUSED_ADDRESS\n" ; |
| 174 |
|
|
return ; |
| 175 |
|
|
} |
| 176 |
|
|
} |
| 177 |
|
|
} elsif (ref \$v eq 'GLOB') { |
| 178 |
|
|
$address = "$v" . ""; # To avoid a bug with globs |
| 179 |
|
|
$address{$address}++ ; |
| 180 |
|
|
if ( $address{$address} > 1 ) { |
| 181 |
|
|
print "${sp}*DUMPED_GLOB*\n" ; |
| 182 |
|
|
return ; |
| 183 |
|
|
} |
| 184 |
|
|
} |
| 185 |
|
|
|
| 186 |
|
|
if (ref $v eq 'Regexp') { |
| 187 |
|
|
my $re = "$v"; |
| 188 |
|
|
$re =~ s,/,\\/,g; |
| 189 |
|
|
print "$sp-> qr/$re/\n"; |
| 190 |
|
|
return; |
| 191 |
|
|
} |
| 192 |
|
|
|
| 193 |
|
|
if ( UNIVERSAL::isa($v, 'HASH') ) { |
| 194 |
|
|
my @sortKeys = sort keys(%$v) ; |
| 195 |
|
|
my $more; |
| 196 |
|
|
my $tHashDepth = $#sortKeys ; |
| 197 |
|
|
$tHashDepth = $#sortKeys < $self->{hashDepth}-1 ? $#sortKeys : $self->{hashDepth}-1 |
| 198 |
|
|
unless $self->{hashDepth} eq '' ; |
| 199 |
|
|
$more = "....\n" if $tHashDepth < $#sortKeys ; |
| 200 |
|
|
my $shortmore = ""; |
| 201 |
|
|
$shortmore = ", ..." if $tHashDepth < $#sortKeys ; |
| 202 |
|
|
$#sortKeys = $tHashDepth ; |
| 203 |
|
|
if ($self->{compactDump} && !grep(ref $_, values %{$v})) { |
| 204 |
|
|
$short = $sp; |
| 205 |
|
|
my @keys; |
| 206 |
|
|
for (@sortKeys) { |
| 207 |
|
|
push @keys, $self->stringify($_) . " => " . $self->stringify($v->{$_}); |
| 208 |
|
|
} |
| 209 |
|
|
$short .= join ', ', @keys; |
| 210 |
|
|
$short .= $shortmore; |
| 211 |
|
|
(print "$short\n"), return if length $short <= $self->{compactDump}; |
| 212 |
|
|
} |
| 213 |
|
|
for my $key (@sortKeys) { |
| 214 |
|
|
return if $DB::signal and $self->{stopDbSignal}; |
| 215 |
|
|
my $value = $ {$v}{$key} ; |
| 216 |
|
|
print $sp, $self->stringify($key), " => "; |
| 217 |
|
|
$self->DumpElem($value, $s); |
| 218 |
|
|
} |
| 219 |
|
|
print "$sp empty hash\n" unless @sortKeys; |
| 220 |
|
|
print "$sp$more" if defined $more ; |
| 221 |
|
|
} elsif ( UNIVERSAL::isa($v, 'ARRAY') ) { |
| 222 |
|
|
my $tArrayDepth = $#{$v} ; |
| 223 |
|
|
my $more ; |
| 224 |
|
|
$tArrayDepth = $#$v < $self->{arrayDepth}-1 ? $#$v : $self->{arrayDepth}-1 |
| 225 |
|
|
unless $self->{arrayDepth} eq '' ; |
| 226 |
|
|
$more = "....\n" if $tArrayDepth < $#{$v} ; |
| 227 |
|
|
my $shortmore = ""; |
| 228 |
|
|
$shortmore = " ..." if $tArrayDepth < $#{$v} ; |
| 229 |
|
|
if ($self->{compactDump} && !grep(ref $_, @{$v})) { |
| 230 |
|
|
if ($#$v >= 0) { |
| 231 |
|
|
$short = $sp . "0..$#{$v} " . |
| 232 |
|
|
join(" ", |
| 233 |
|
|
map {exists $v->[$_] ? $self->stringify($v->[$_]) : "empty"} ($[..$tArrayDepth) |
| 234 |
|
|
) . "$shortmore"; |
| 235 |
|
|
} else { |
| 236 |
|
|
$short = $sp . "empty array"; |
| 237 |
|
|
} |
| 238 |
|
|
(print "$short\n"), return if length $short <= $self->{compactDump}; |
| 239 |
|
|
} |
| 240 |
|
|
for my $num ($[ .. $tArrayDepth) { |
| 241 |
|
|
return if $DB::signal and $self->{stopDbSignal}; |
| 242 |
|
|
print "$sp$num "; |
| 243 |
|
|
if (exists $v->[$num]) { |
| 244 |
|
|
$self->DumpElem($v->[$num], $s); |
| 245 |
|
|
} else { |
| 246 |
|
|
print "empty slot\n"; |
| 247 |
|
|
} |
| 248 |
|
|
} |
| 249 |
|
|
print "$sp empty array\n" unless @$v; |
| 250 |
|
|
print "$sp$more" if defined $more ; |
| 251 |
|
|
} elsif ( UNIVERSAL::isa($v, 'SCALAR') or ref $v eq 'REF' ) { |
| 252 |
|
|
print "$sp-> "; |
| 253 |
|
|
$self->DumpElem($$v, $s); |
| 254 |
|
|
} elsif ( UNIVERSAL::isa($v, 'CODE') ) { |
| 255 |
|
|
print "$sp-> "; |
| 256 |
|
|
$self->dumpsub(0, $v); |
| 257 |
|
|
} elsif ( UNIVERSAL::isa($v, 'GLOB') ) { |
| 258 |
|
|
print "$sp-> ",$self->stringify($$v,1),"\n"; |
| 259 |
|
|
if ($self->{globPrint}) { |
| 260 |
|
|
$s += 3; |
| 261 |
|
|
$self->dumpglob('', $s, "{$$v}", $$v, 1); |
| 262 |
|
|
} elsif (defined ($fileno = fileno($v))) { |
| 263 |
|
|
print( (' ' x ($s+3)) . "FileHandle({$$v}) => fileno($fileno)\n" ); |
| 264 |
|
|
} |
| 265 |
|
|
} elsif (ref \$v eq 'GLOB') { |
| 266 |
|
|
if ($self->{globPrint}) { |
| 267 |
|
|
$self->dumpglob('', $s, "{$v}", $v, 1); |
| 268 |
|
|
} elsif (defined ($fileno = fileno(\$v))) { |
| 269 |
|
|
print( (' ' x $s) . "FileHandle({$v}) => fileno($fileno)\n" ); |
| 270 |
|
|
} |
| 271 |
|
|
} |
| 272 |
|
|
} |
| 273 |
|
|
|
| 274 |
|
|
sub matchvar { |
| 275 |
|
|
$_[0] eq $_[1] or |
| 276 |
|
|
($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and |
| 277 |
|
|
($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/}); |
| 278 |
|
|
} |
| 279 |
|
|
|
| 280 |
|
|
sub compactDump { |
| 281 |
|
|
my $self = shift; |
| 282 |
|
|
$self->{compactDump} = shift if @_; |
| 283 |
|
|
$self->{compactDump} = 6*80-1 |
| 284 |
|
|
if $self->{compactDump} and $self->{compactDump} < 2; |
| 285 |
|
|
$self->{compactDump}; |
| 286 |
|
|
} |
| 287 |
|
|
|
| 288 |
|
|
sub veryCompact { |
| 289 |
|
|
my $self = shift; |
| 290 |
|
|
$self->{veryCompact} = shift if @_; |
| 291 |
|
|
$self->compactDump(1) if !$self->{compactDump} and $self->{veryCompact}; |
| 292 |
|
|
$self->{veryCompact}; |
| 293 |
|
|
} |
| 294 |
|
|
|
| 295 |
|
|
sub set_unctrl { |
| 296 |
|
|
my $self = shift; |
| 297 |
|
|
if (@_) { |
| 298 |
|
|
my $in = shift; |
| 299 |
|
|
if ($in eq 'unctrl' or $in eq 'quote') { |
| 300 |
|
|
$self->{unctrl} = $in; |
| 301 |
|
|
} else { |
| 302 |
|
|
print "Unknown value for `unctrl'.\n"; |
| 303 |
|
|
} |
| 304 |
|
|
} |
| 305 |
|
|
$self->{unctrl}; |
| 306 |
|
|
} |
| 307 |
|
|
|
| 308 |
|
|
sub set_quote { |
| 309 |
|
|
my $self = shift; |
| 310 |
|
|
if (@_ and $_[0] eq '"') { |
| 311 |
|
|
$self->{tick} = '"'; |
| 312 |
|
|
$self->{unctrl} = 'quote'; |
| 313 |
|
|
} elsif (@_ and $_[0] eq 'auto') { |
| 314 |
|
|
$self->{tick} = 'auto'; |
| 315 |
|
|
$self->{unctrl} = 'quote'; |
| 316 |
|
|
} elsif (@_) { # Need to set |
| 317 |
|
|
$self->{tick} = "'"; |
| 318 |
|
|
$self->{unctrl} = 'unctrl'; |
| 319 |
|
|
} |
| 320 |
|
|
$self->{tick}; |
| 321 |
|
|
} |
| 322 |
|
|
|
| 323 |
|
|
sub dumpglob { |
| 324 |
|
|
my $self = shift; |
| 325 |
|
|
return if $DB::signal and $self->{stopDbSignal}; |
| 326 |
|
|
my ($package, $off, $key, $val, $all) = @_; |
| 327 |
|
|
local(*stab) = $val; |
| 328 |
|
|
my $fileno; |
| 329 |
|
|
if (($key !~ /^_</ or $self->{dumpDBFiles}) and defined $stab) { |
| 330 |
|
|
print( (' ' x $off) . "\$", &unctrl($key), " = " ); |
| 331 |
|
|
$self->DumpElem($stab, 3+$off); |
| 332 |
|
|
} |
| 333 |
|
|
if (($key !~ /^_</ or $self->{dumpDBFiles}) and @stab) { |
| 334 |
|
|
print( (' ' x $off) . "\@$key = (\n" ); |
| 335 |
|
|
$self->unwrap(\@stab,3+$off) ; |
| 336 |
|
|
print( (' ' x $off) . ")\n" ); |
| 337 |
|
|
} |
| 338 |
|
|
if ($key ne "main::" && $key ne "DB::" && %stab |
| 339 |
|
|
&& ($self->{dumpPackages} or $key !~ /::$/) |
| 340 |
|
|
&& ($key !~ /^_</ or $self->{dumpDBFiles}) |
| 341 |
|
|
&& !($package eq "Dumpvalue" and $key eq "stab")) { |
| 342 |
|
|
print( (' ' x $off) . "\%$key = (\n" ); |
| 343 |
|
|
$self->unwrap(\%stab,3+$off) ; |
| 344 |
|
|
print( (' ' x $off) . ")\n" ); |
| 345 |
|
|
} |
| 346 |
|
|
if (defined ($fileno = fileno(*stab))) { |
| 347 |
|
|
print( (' ' x $off) . "FileHandle($key) => fileno($fileno)\n" ); |
| 348 |
|
|
} |
| 349 |
|
|
if ($all) { |
| 350 |
|
|
if (defined &stab) { |
| 351 |
|
|
$self->dumpsub($off, $key); |
| 352 |
|
|
} |
| 353 |
|
|
} |
| 354 |
|
|
} |
| 355 |
|
|
|
| 356 |
|
|
sub CvGV_name { |
| 357 |
|
|
my $self = shift; |
| 358 |
|
|
my $in = shift; |
| 359 |
|
|
return if $self->{skipCvGV}; # Backdoor to avoid problems if XS broken... |
| 360 |
|
|
$in = \&$in; # Hard reference... |
| 361 |
|
|
eval {require Devel::Peek; 1} or return; |
| 362 |
|
|
my $gv = Devel::Peek::CvGV($in) or return; |
| 363 |
|
|
*$gv{PACKAGE} . '::' . *$gv{NAME}; |
| 364 |
|
|
} |
| 365 |
|
|
|
| 366 |
|
|
sub dumpsub { |
| 367 |
|
|
my $self = shift; |
| 368 |
|
|
my ($off,$sub) = @_; |
| 369 |
|
|
my $ini = $sub; |
| 370 |
|
|
my $s; |
| 371 |
|
|
$sub = $1 if $sub =~ /^\{\*(.*)\}$/; |
| 372 |
|
|
my $subref = defined $1 ? \&$sub : \&$ini; |
| 373 |
|
|
my $place = $DB::sub{$sub} || (($s = $subs{"$subref"}) && $DB::sub{$s}) |
| 374 |
|
|
|| (($s = $self->CvGV_name($subref)) && $DB::sub{$s}) |
| 375 |
|
|
|| ($self->{subdump} && ($s = $self->findsubs("$subref")) |
| 376 |
|
|
&& $DB::sub{$s}); |
| 377 |
|
|
$s = $sub unless defined $s; |
| 378 |
|
|
$place = '???' unless defined $place; |
| 379 |
|
|
print( (' ' x $off) . "&$s in $place\n" ); |
| 380 |
|
|
} |
| 381 |
|
|
|
| 382 |
|
|
sub findsubs { |
| 383 |
|
|
my $self = shift; |
| 384 |
|
|
return undef unless %DB::sub; |
| 385 |
|
|
my ($addr, $name, $loc); |
| 386 |
|
|
while (($name, $loc) = each %DB::sub) { |
| 387 |
|
|
$addr = \&$name; |
| 388 |
|
|
$subs{"$addr"} = $name; |
| 389 |
|
|
} |
| 390 |
|
|
$self->{subdump} = 0; |
| 391 |
|
|
$subs{ shift() }; |
| 392 |
|
|
} |
| 393 |
|
|
|
| 394 |
|
|
sub dumpvars { |
| 395 |
|
|
my $self = shift; |
| 396 |
|
|
my ($package,@vars) = @_; |
| 397 |
|
|
local(%address,$^W); |
| 398 |
|
|
my ($key,$val); |
| 399 |
|
|
$package .= "::" unless $package =~ /::$/; |
| 400 |
|
|
*stab = *main::; |
| 401 |
|
|
|
| 402 |
|
|
while ($package =~ /(\w+?::)/g) { |
| 403 |
|
|
*stab = $ {stab}{$1}; |
| 404 |
|
|
} |
| 405 |
|
|
$self->{TotalStrings} = 0; |
| 406 |
|
|
$self->{Strings} = 0; |
| 407 |
|
|
$self->{CompleteTotal} = 0; |
| 408 |
|
|
while (($key,$val) = each(%stab)) { |
| 409 |
|
|
return if $DB::signal and $self->{stopDbSignal}; |
| 410 |
|
|
next if @vars && !grep( matchvar($key, $_), @vars ); |
| 411 |
|
|
if ($self->{usageOnly}) { |
| 412 |
|
|
$self->globUsage(\$val, $key) |
| 413 |
|
|
if ($package ne 'Dumpvalue' or $key ne 'stab') |
| 414 |
|
|
and ref(\$val) eq 'GLOB'; |
| 415 |
|
|
} else { |
| 416 |
|
|
$self->dumpglob($package, 0,$key, $val); |
| 417 |
|
|
} |
| 418 |
|
|
} |
| 419 |
|
|
if ($self->{usageOnly}) { |
| 420 |
|
|
print <<EOP; |
| 421 |
|
|
String space: $self->{TotalStrings} bytes in $self->{Strings} strings. |
| 422 |
|
|
EOP |
| 423 |
|
|
$self->{CompleteTotal} += $self->{TotalStrings}; |
| 424 |
|
|
print <<EOP; |
| 425 |
|
|
Grand total = $self->{CompleteTotal} bytes (1 level deep) + overhead. |
| 426 |
|
|
EOP |
| 427 |
|
|
} |
| 428 |
|
|
} |
| 429 |
|
|
|
| 430 |
|
|
sub scalarUsage { |
| 431 |
|
|
my $self = shift; |
| 432 |
|
|
my $size; |
| 433 |
|
|
if (UNIVERSAL::isa($_[0], 'ARRAY')) { |
| 434 |
|
|
$size = $self->arrayUsage($_[0]); |
| 435 |
|
|
} elsif (UNIVERSAL::isa($_[0], 'HASH')) { |
| 436 |
|
|
$size = $self->hashUsage($_[0]); |
| 437 |
|
|
} elsif (!ref($_[0])) { |
| 438 |
|
|
$size = length($_[0]); |
| 439 |
|
|
} |
| 440 |
|
|
$self->{TotalStrings} += $size; |
| 441 |
|
|
$self->{Strings}++; |
| 442 |
|
|
$size; |
| 443 |
|
|
} |
| 444 |
|
|
|
| 445 |
|
|
sub arrayUsage { # array ref, name |
| 446 |
|
|
my $self = shift; |
| 447 |
|
|
my $size = 0; |
| 448 |
|
|
map {$size += $self->scalarUsage($_)} @{$_[0]}; |
| 449 |
|
|
my $len = @{$_[0]}; |
| 450 |
|
|
print "\@$_[1] = $len item", ($len > 1 ? "s" : ""), " (data: $size bytes)\n" |
| 451 |
|
|
if defined $_[1]; |
| 452 |
|
|
$self->{CompleteTotal} += $size; |
| 453 |
|
|
$size; |
| 454 |
|
|
} |
| 455 |
|
|
|
| 456 |
|
|
sub hashUsage { # hash ref, name |
| 457 |
|
|
my $self = shift; |
| 458 |
|
|
my @keys = keys %{$_[0]}; |
| 459 |
|
|
my @values = values %{$_[0]}; |
| 460 |
|
|
my $keys = $self->arrayUsage(\@keys); |
| 461 |
|
|
my $values = $self->arrayUsage(\@values); |
| 462 |
|
|
my $len = @keys; |
| 463 |
|
|
my $total = $keys + $values; |
| 464 |
|
|
print "\%$_[1] = $len item", ($len > 1 ? "s" : ""), |
| 465 |
|
|
" (keys: $keys; values: $values; total: $total bytes)\n" |
| 466 |
|
|
if defined $_[1]; |
| 467 |
|
|
$total; |
| 468 |
|
|
} |
| 469 |
|
|
|
| 470 |
|
|
sub globUsage { # glob ref, name |
| 471 |
|
|
my $self = shift; |
| 472 |
|
|
local *stab = *{$_[0]}; |
| 473 |
|
|
my $total = 0; |
| 474 |
|
|
$total += $self->scalarUsage($stab) if defined $stab; |
| 475 |
|
|
$total += $self->arrayUsage(\@stab, $_[1]) if @stab; |
| 476 |
|
|
$total += $self->hashUsage(\%stab, $_[1]) |
| 477 |
|
|
if %stab and $_[1] ne "main::" and $_[1] ne "DB::"; |
| 478 |
|
|
#and !($package eq "Dumpvalue" and $key eq "stab")); |
| 479 |
|
|
$total; |
| 480 |
|
|
} |
| 481 |
|
|
|
| 482 |
|
|
1; |
| 483 |
|
|
|
| 484 |
|
|
=head1 NAME |
| 485 |
|
|
|
| 486 |
|
|
Dumpvalue - provides screen dump of Perl data. |
| 487 |
|
|
|
| 488 |
|
|
=head1 SYNOPSIS |
| 489 |
|
|
|
| 490 |
|
|
use Dumpvalue; |
| 491 |
|
|
my $dumper = new Dumpvalue; |
| 492 |
|
|
$dumper->set(globPrint => 1); |
| 493 |
|
|
$dumper->dumpValue(\*::); |
| 494 |
|
|
$dumper->dumpvars('main'); |
| 495 |
|
|
my $dump = $dumper->stringify($some_value); |
| 496 |
|
|
|
| 497 |
|
|
=head1 DESCRIPTION |
| 498 |
|
|
|
| 499 |
|
|
=head2 Creation |
| 500 |
|
|
|
| 501 |
|
|
A new dumper is created by a call |
| 502 |
|
|
|
| 503 |
|
|
$d = new Dumpvalue(option1 => value1, option2 => value2) |
| 504 |
|
|
|
| 505 |
|
|
Recognized options: |
| 506 |
|
|
|
| 507 |
|
|
=over 4 |
| 508 |
|
|
|
| 509 |
|
|
=item C<arrayDepth>, C<hashDepth> |
| 510 |
|
|
|
| 511 |
|
|
Print only first N elements of arrays and hashes. If false, prints all the |
| 512 |
|
|
elements. |
| 513 |
|
|
|
| 514 |
|
|
=item C<compactDump>, C<veryCompact> |
| 515 |
|
|
|
| 516 |
|
|
Change style of array and hash dump. If true, short array |
| 517 |
|
|
may be printed on one line. |
| 518 |
|
|
|
| 519 |
|
|
=item C<globPrint> |
| 520 |
|
|
|
| 521 |
|
|
Whether to print contents of globs. |
| 522 |
|
|
|
| 523 |
|
|
=item C<dumpDBFiles> |
| 524 |
|
|
|
| 525 |
|
|
Dump arrays holding contents of debugged files. |
| 526 |
|
|
|
| 527 |
|
|
=item C<dumpPackages> |
| 528 |
|
|
|
| 529 |
|
|
Dump symbol tables of packages. |
| 530 |
|
|
|
| 531 |
|
|
=item C<dumpReused> |
| 532 |
|
|
|
| 533 |
|
|
Dump contents of "reused" addresses. |
| 534 |
|
|
|
| 535 |
|
|
=item C<tick>, C<quoteHighBit>, C<printUndef> |
| 536 |
|
|
|
| 537 |
|
|
Change style of string dump. Default value of C<tick> is C<auto>, one |
| 538 |
|
|
can enable either double-quotish dump, or single-quotish by setting it |
| 539 |
|
|
to C<"> or C<'>. By default, characters with high bit set are printed |
| 540 |
|
|
I<as is>. If C<quoteHighBit> is set, they will be quoted. |
| 541 |
|
|
|
| 542 |
|
|
=item C<usageOnly> |
| 543 |
|
|
|
| 544 |
|
|
rudimentally per-package memory usage dump. If set, |
| 545 |
|
|
C<dumpvars> calculates total size of strings in variables in the package. |
| 546 |
|
|
|
| 547 |
|
|
=item unctrl |
| 548 |
|
|
|
| 549 |
|
|
Changes the style of printout of strings. Possible values are |
| 550 |
|
|
C<unctrl> and C<quote>. |
| 551 |
|
|
|
| 552 |
|
|
=item subdump |
| 553 |
|
|
|
| 554 |
|
|
Whether to try to find the subroutine name given the reference. |
| 555 |
|
|
|
| 556 |
|
|
=item bareStringify |
| 557 |
|
|
|
| 558 |
|
|
Whether to write the non-overloaded form of the stringify-overloaded objects. |
| 559 |
|
|
|
| 560 |
|
|
=item quoteHighBit |
| 561 |
|
|
|
| 562 |
|
|
Whether to print chars with high bit set in binary or "as is". |
| 563 |
|
|
|
| 564 |
|
|
=item stopDbSignal |
| 565 |
|
|
|
| 566 |
|
|
Whether to abort printing if debugger signal flag is raised. |
| 567 |
|
|
|
| 568 |
|
|
=back |
| 569 |
|
|
|
| 570 |
|
|
Later in the life of the object the methods may be queries with get() |
| 571 |
|
|
method and set() method (which accept multiple arguments). |
| 572 |
|
|
|
| 573 |
|
|
=head2 Methods |
| 574 |
|
|
|
| 575 |
|
|
=over 4 |
| 576 |
|
|
|
| 577 |
|
|
=item dumpValue |
| 578 |
|
|
|
| 579 |
|
|
$dumper->dumpValue($value); |
| 580 |
|
|
$dumper->dumpValue([$value1, $value2]); |
| 581 |
|
|
|
| 582 |
|
|
Prints a dump to the currently selected filehandle. |
| 583 |
|
|
|
| 584 |
|
|
=item dumpValues |
| 585 |
|
|
|
| 586 |
|
|
$dumper->dumpValues($value1, $value2); |
| 587 |
|
|
|
| 588 |
|
|
Same as C< $dumper->dumpValue([$value1, $value2]); >. |
| 589 |
|
|
|
| 590 |
|
|
=item stringify |
| 591 |
|
|
|
| 592 |
|
|
my $dump = $dumper->stringify($value [,$noticks] ); |
| 593 |
|
|
|
| 594 |
|
|
Returns the dump of a single scalar without printing. If the second |
| 595 |
|
|
argument is true, the return value does not contain enclosing ticks. |
| 596 |
|
|
Does not handle data structures. |
| 597 |
|
|
|
| 598 |
|
|
=item dumpvars |
| 599 |
|
|
|
| 600 |
|
|
$dumper->dumpvars('my_package'); |
| 601 |
|
|
$dumper->dumpvars('my_package', 'foo', '~bar$', '!......'); |
| 602 |
|
|
|
| 603 |
|
|
The optional arguments are considered as literal strings unless they |
| 604 |
|
|
start with C<~> or C<!>, in which case they are interpreted as regular |
| 605 |
|
|
expressions (possibly negated). |
| 606 |
|
|
|
| 607 |
|
|
The second example prints entries with names C<foo>, and also entries |
| 608 |
|
|
with names which ends on C<bar>, or are shorter than 5 chars. |
| 609 |
|
|
|
| 610 |
|
|
=item set_quote |
| 611 |
|
|
|
| 612 |
|
|
$d->set_quote('"'); |
| 613 |
|
|
|
| 614 |
|
|
Sets C<tick> and C<unctrl> options to suitable values for printout with the |
| 615 |
|
|
given quote char. Possible values are C<auto>, C<'> and C<">. |
| 616 |
|
|
|
| 617 |
|
|
=item set_unctrl |
| 618 |
|
|
|
| 619 |
|
|
$d->set_unctrl('"'); |
| 620 |
|
|
|
| 621 |
|
|
Sets C<unctrl> option with checking for an invalid argument. |
| 622 |
|
|
Possible values are C<unctrl> and C<quote>. |
| 623 |
|
|
|
| 624 |
|
|
=item compactDump |
| 625 |
|
|
|
| 626 |
|
|
$d->compactDump(1); |
| 627 |
|
|
|
| 628 |
|
|
Sets C<compactDump> option. If the value is 1, sets to a reasonable |
| 629 |
|
|
big number. |
| 630 |
|
|
|
| 631 |
|
|
=item veryCompact |
| 632 |
|
|
|
| 633 |
|
|
$d->veryCompact(1); |
| 634 |
|
|
|
| 635 |
|
|
Sets C<compactDump> and C<veryCompact> options simultaneously. |
| 636 |
|
|
|
| 637 |
|
|
=item set |
| 638 |
|
|
|
| 639 |
|
|
$d->set(option1 => value1, option2 => value2); |
| 640 |
|
|
|
| 641 |
|
|
=item get |
| 642 |
|
|
|
| 643 |
|
|
@values = $d->get('option1', 'option2'); |
| 644 |
|
|
|
| 645 |
|
|
=back |
| 646 |
|
|
|
| 647 |
|
|
=cut |
| 648 |
|
|
|
