use 5.006_001
; # for (defined ref) and $#$v and our
our(%address, $stab, @stab, %stab, %subs);
# documentation nits, handle complex data structures better by chromatic
# translate control chars to ^X - Randal Schwartz
# Modifications to print types by Peter Gordon v1.0
# Ilya Zakharevich -- patches after 5.001 (and some before ;-)
# Won't dump symbol tables and contents of debugged files by default
# (IZ) changes for objectification:
# c) quote() renamed to method set_quote();
# d) unctrlSet() renamed to method set_unctrl();
# f) Compiles with `use strict', but in two places no strict refs is needed:
# maybe more problems are waiting...
my %opt = (%defaults, @_);
@
$self{keys %opt} = values %opt;
wantarray ? @
$self{@_} : $$self{pop @_};
die "usage: \$dumper->dumpValue(value)" unless @_ == 1;
(print "undef\n"), return unless defined $_[0];
(print $self->stringify($_[0]), "\n"), return unless ref $_[0];
(print "undef\n"), return unless defined $_[0];
# This one is good for variable names:
return \
$_ if ref \
$_ eq "GLOB";
s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
my $tick = $self->{tick
};
return 'undef' unless defined $_ or not $self->{printUndef
};
return $_ . "" if ref \
$_ eq 'GLOB';
$_ = &{'overload::StrVal'}($_)
if $self->{bareStringify
} and ref $_
and %overload:: and defined &{'overload::StrVal'};
if (/[\000-\011\013-\037\177]/) {
} elsif ($self->{unctrl
} eq 'unctrl') {
s/([\000-\037\177])/'^'.pack('c',ord($1)^64)/eg;
s/([\200-\377])/'\\0x'.sprintf('%2X',ord($1))/eg
if $self->{quoteHighBit
};
} elsif ($self->{unctrl
} eq 'quote') {
s/([\"\\\$\@])/\\$1/g if $tick eq '"';
s/([\000-\037\177])/'\\c'.chr(ord($1)^64)/eg;
s/([\200-\377])/'\\'.sprintf('%3o',ord($1))/eg if $self->{quoteHighBit
};
($noticks || /^\d+(\.\d*)?\Z/)
my ($self, $v) = (shift, shift);
my $short = $self->stringify($v, ref $v);
if ($self->{veryCompact
} && ref $v
&& (ref $v eq 'ARRAY' and !grep(ref $_, @
$v) )) {
($shortmore, $depth) = (' ...', $self->{arrayDepth
} - 1)
if $self->{arrayDepth
} and $depth >= $self->{arrayDepth
};
my @a = map $self->stringify($_), @
$v[0..$depth];
print "0..$#{$v} @a$shortmore\n";
} elsif ($self->{veryCompact
} && ref $v
&& (ref $v eq 'HASH') and !grep(ref $_, values %$v)) {
($shortmore, $depth) = (' ...', $self->{hashDepth
} - 1)
if $self->{hashDepth
} and $depth >= $self->{hashDepth
};
my @b = map {$self->stringify($_) . " => " . $self->stringify($$v{$_})}
return if $DB::signal and $self->{stopDbSignal};
my ($s) = shift ; # extra no of spaces
my (%v,@v,$address,$short,$fileno);
# Check for reused addresses
$val = &{'overload::StrVal'}($v)
if %overload:: and defined &{'overload::StrVal'};
($address) = $val =~ /(0x[0-9a-f]+)\)$/ ;
if (!$self->{dumpReused} && defined $address) {
if ( $address{$address} > 1 ) {
print "${sp
}-> REUSED_ADDRESS
\n" ;
} elsif (ref \$v eq 'GLOB') {
$address = "$v" . ""; # To avoid a bug with globs
if ( $address{$address} > 1 ) {
print "${sp
}*DUMPED_GLOB
*\n" ;
if (ref $v eq 'Regexp') {
if ( UNIVERSAL::isa($v, 'HASH') ) {
my @sortKeys = sort keys(%$v) ;
my $tHashDepth = $#sortKeys ;
$tHashDepth = $#sortKeys < $self->{hashDepth}-1 ? $#sortKeys : $self->{hashDepth}-1
unless $self->{hashDepth} eq '' ;
$more = "....\n" if $tHashDepth < $#sortKeys ;
$shortmore = ", ..." if $tHashDepth < $#sortKeys ;
$#sortKeys = $tHashDepth ;
if ($self->{compactDump} && !grep(ref $_, values %{$v})) {
push @keys, $self->stringify($_) . " => " . $self->stringify($v->{$_});
$short .= join ', ', @keys;
(print "$short\n"), return if length $short <= $self->{compactDump};
for my $key (@sortKeys) {
return if $DB::signal and $self->{stopDbSignal};
my $value = $ {$v}{$key} ;
print $sp, $self->stringify($key), " => ";
$self->DumpElem($value, $s);
print "$sp empty hash
\n" unless @sortKeys;
print "$sp$more" if defined $more ;
} elsif ( UNIVERSAL::isa($v, 'ARRAY') ) {
my $tArrayDepth = $#{$v} ;
$tArrayDepth = $#$v < $self->{arrayDepth}-1 ? $#$v : $self->{arrayDepth}-1
unless $self->{arrayDepth} eq '' ;
$more = "....\n" if $tArrayDepth < $#{$v} ;
$shortmore = " ..." if $tArrayDepth < $#{$v} ;
if ($self->{compactDump} && !grep(ref $_, @{$v})) {
$short = $sp . "0..$#{$v} " .
map {exists $v->[$_] ?
$self->stringify($v->[$_]) : "empty"} ($[..$tArrayDepth)
$short = $sp . "empty array";
(print "$short\n"), return if length $short <= $self->{compactDump
};
for my $num ($[ .. $tArrayDepth) {
return if $DB::signal
and $self->{stopDbSignal
};
$self->DumpElem($v->[$num], $s);
print "$sp empty array\n" unless @
$v;
print "$sp$more" if defined $more ;
} elsif ( UNIVERSAL
::isa
($v, 'SCALAR') or ref $v eq 'REF' ) {
$self->DumpElem($$v, $s);
} elsif ( UNIVERSAL
::isa
($v, 'CODE') ) {
} elsif ( UNIVERSAL
::isa
($v, 'GLOB') ) {
print "$sp-> ",$self->stringify($$v,1),"\n";
if ($self->{globPrint
}) {
$self->dumpglob('', $s, "{$$v}", $$v, 1);
} elsif (defined ($fileno = fileno($v))) {
print( (' ' x
($s+3)) . "FileHandle({$$v}) => fileno($fileno)\n" );
} elsif (ref \
$v eq 'GLOB') {
if ($self->{globPrint
}) {
$self->dumpglob('', $s, "{$v}", $v, 1);
} elsif (defined ($fileno = fileno(\
$v))) {
print( (' ' x
$s) . "FileHandle({$v}) => fileno($fileno)\n" );
($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and
($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/});
$self->{compactDump
} = shift if @_;
$self->{compactDump
} = 6*80-1
if $self->{compactDump
} and $self->{compactDump
} < 2;
$self->{veryCompact
} = shift if @_;
$self->compactDump(1) if !$self->{compactDump
} and $self->{veryCompact
};
if ($in eq 'unctrl' or $in eq 'quote') {
print "Unknown value for `unctrl'.\n";
if (@_ and $_[0] eq '"') {
$self->{unctrl
} = 'quote';
} elsif (@_ and $_[0] eq 'auto') {
$self->{unctrl
} = 'quote';
} elsif (@_) { # Need to set
$self->{unctrl
} = 'unctrl';
return if $DB::signal
and $self->{stopDbSignal
};
my ($package, $off, $key, $val, $all) = @_;
if (($key !~ /^_</ or $self->{dumpDBFiles
}) and defined $stab) {
print( (' ' x
$off) . "\$", &unctrl
($key), " = " );
$self->DumpElem($stab, 3+$off);
if (($key !~ /^_</ or $self->{dumpDBFiles
}) and @stab) {
print( (' ' x
$off) . "\@$key = (\n" );
$self->unwrap(\
@stab,3+$off) ;
print( (' ' x
$off) . ")\n" );
if ($key ne "main::" && $key ne "DB::" && %stab
&& ($self->{dumpPackages
} or $key !~ /::$/)
&& ($key !~ /^_</ or $self->{dumpDBFiles
})
&& !($package eq "Dumpvalue" and $key eq "stab")) {
print( (' ' x
$off) . "\%$key = (\n" );
$self->unwrap(\
%stab,3+$off) ;
print( (' ' x
$off) . ")\n" );
if (defined ($fileno = fileno(*stab
))) {
print( (' ' x
$off) . "FileHandle($key) => fileno($fileno)\n" );
$self->dumpsub($off, $key);
return if $self->{skipCvGV
}; # Backdoor to avoid problems if XS broken...
$in = \
&$in; # Hard reference...
eval {require Devel
::Peek
; 1} or return;
my $gv = Devel
::Peek
::CvGV
($in) or return;
*$gv{PACKAGE
} . '::' . *$gv{NAME
};
$sub = $1 if $sub =~ /^\{\*(.*)\}$/;
my $subref = defined $1 ? \
&$sub : \
&$ini;
my $place = $DB::sub{$sub} || (($s = $subs{"$subref"}) && $DB::sub{$s})
|| (($s = $self->CvGV_name($subref)) && $DB::sub{$s})
|| ($self->{subdump
} && ($s = $self->findsubs("$subref"))
$s = $sub unless defined $s;
$place = '???' unless defined $place;
print( (' ' x
$off) . "&$s in $place\n" );
return undef unless %DB::sub;
while (($name, $loc) = each %DB::sub) {
my ($package,@vars) = @_;
$package .= "::" unless $package =~ /::$/;
while ($package =~ /(\w+?::)/g) {
$self->{TotalStrings
} = 0;
$self->{CompleteTotal
} = 0;
while (($key,$val) = each(%stab)) {
return if $DB::signal
and $self->{stopDbSignal
};
next if @vars && !grep( matchvar
($key, $_), @vars );
if ($self->{usageOnly
}) {
$self->globUsage(\
$val, $key)
if ($package ne 'Dumpvalue' or $key ne 'stab')
and ref(\
$val) eq 'GLOB';
$self->dumpglob($package, 0,$key, $val);
if ($self->{usageOnly
}) {
String space: $self->{TotalStrings} bytes in $self->{Strings} strings.
$self->{CompleteTotal
} += $self->{TotalStrings
};
Grand total = $self->{CompleteTotal} bytes (1 level deep) + overhead.
if (UNIVERSAL
::isa
($_[0], 'ARRAY')) {
$size = $self->arrayUsage($_[0]);
} elsif (UNIVERSAL
::isa
($_[0], 'HASH')) {
$size = $self->hashUsage($_[0]);
$self->{TotalStrings
} += $size;
sub arrayUsage
{ # array ref, name
map {$size += $self->scalarUsage($_)} @
{$_[0]};
print "\@$_[1] = $len item", ($len > 1 ?
"s" : ""), " (data: $size bytes)\n"
$self->{CompleteTotal
} += $size;
sub hashUsage
{ # hash ref, name
my @keys = keys %{$_[0]};
my @values = values %{$_[0]};
my $keys = $self->arrayUsage(\
@keys);
my $values = $self->arrayUsage(\
@values);
my $total = $keys + $values;
print "\%$_[1] = $len item", ($len > 1 ?
"s" : ""),
" (keys: $keys; values: $values; total: $total bytes)\n"
sub globUsage
{ # glob ref, name
$total += $self->scalarUsage($stab) if defined $stab;
$total += $self->arrayUsage(\
@stab, $_[1]) if @stab;
$total += $self->hashUsage(\
%stab, $_[1])
if %stab and $_[1] ne "main::" and $_[1] ne "DB::";
#and !($package eq "Dumpvalue" and $key eq "stab"));
Dumpvalue - provides screen dump of Perl data.
my $dumper = new Dumpvalue;
$dumper->set(globPrint => 1);
$dumper->dumpValue(\*::);
$dumper->dumpvars('main');
my $dump = $dumper->stringify($some_value);
A new dumper is created by a call
$d = new Dumpvalue(option1 => value1, option2 => value2)
=item C<arrayDepth>, C<hashDepth>
Print only first N elements of arrays and hashes. If false, prints all the
=item C<compactDump>, C<veryCompact>
Change style of array and hash dump. If true, short array
may be printed on one line.
Whether to print contents of globs.
Dump arrays holding contents of debugged files.
Dump symbol tables of packages.
Dump contents of "reused" addresses.
=item C<tick>, C<quoteHighBit>, C<printUndef>
Change style of string dump. Default value of C<tick> is C<auto>, one
can enable either double-quotish dump, or single-quotish by setting it
to C<"> or C<'>. By default, characters with high bit set are printed
I<as is>. If C<quoteHighBit> is set, they will be quoted.
rudimentally per-package memory usage dump. If set,
C<dumpvars> calculates total size of strings in variables in the package.
Changes the style of printout of strings. Possible values are
Whether to try to find the subroutine name given the reference.
Whether to write the non-overloaded form of the stringify-overloaded objects.
Whether to print chars with high bit set in binary or "as is".
Whether to abort printing if debugger signal flag is raised.
Later in the life of the object the methods may be queries with get()
method and set() method (which accept multiple arguments).
$dumper->dumpValue($value);
$dumper->dumpValue([$value1, $value2]);
Prints a dump to the currently selected filehandle.
$dumper->dumpValues($value1, $value2);
Same as C< $dumper->dumpValue([$value1, $value2]); >.
my $dump = $dumper->stringify($value [,$noticks] );
Returns the dump of a single scalar without printing. If the second
argument is true, the return value does not contain enclosing ticks.
Does not handle data structures.
$dumper->dumpvars('my_package');
$dumper->dumpvars('my_package', 'foo', '~bar$', '!......');
The optional arguments are considered as literal strings unless they
start with C<~> or C<!>, in which case they are interpreted as regular
expressions (possibly negated).
The second example prints entries with names C<foo>, and also entries
with names which ends on C<bar>, or are shorter than 5 chars.
Sets C<tick> and C<unctrl> options to suitable values for printout with the
given quote char. Possible values are C<auto>, C<'> and C<">.
$d->set_unctrl('unctrl');
Sets C<unctrl> option with checking for an invalid argument.
Possible values are C<unctrl> and C<quote>.
Sets C<compactDump> option. If the value is 1, sets to a reasonable
Sets C<compactDump> and C<veryCompact> options simultaneously.
$d->set(option1 => value1, option2 => value2);
@values = $d->get('option1', 'option2');