Edit: /usr/share/perl5/Dumpvalue.pm (16899B)
use 5.006_001; # for (defined ref) and $#$v and our
package Dumpvalue;
use strict;
our $VERSION = '1.13';
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 %defaults = (
globPrint => 0,
printUndef => 1,
tick => "auto",
unctrl => 'quote',
subdump => 1,
dumpReused => 0,
bareStringify => 1,
hashDepth => '',
arrayDepth => '',
dumpDBFiles => '',
dumpPackages => '',
quoteHighBit => '',
usageOnly => '',
compactDump => '',
veryCompact => '',
stopDbSignal => '',
);
sub new {
my $class = shift;
my %opt = (%defaults, @_);
bless \%opt, $class;
}
sub set {
my $self = shift;
my %opt = @_;
@$self{keys %opt} = values %opt;
}
sub get {
my $self = shift;
wantarray ? @$self{@_} : $$self{pop @_};
}
sub dumpValue {
my $self = shift;
die "usage: \$dumper->dumpValue(value)" unless @_ == 1;
local %address;
local $^W=0;
(print "undef\n"), return unless defined $_[0];
(print $self->stringify($_[0]), "\n"), return unless ref $_[0];
$self->unwrap($_[0],0);
}
sub dumpValues {
my $self = shift;
local %address;
local $^W=0;
(print "undef\n"), return unless defined $_[0];
$self->unwrap(\@_,0);
}
# This one is good for variable names:
sub unctrl {
local($_) = @_;
return \$_ if ref \$_ eq "GLOB";
s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
$_;
}
sub stringify {
my $self = shift;
local $_ = shift;
my $noticks = shift;
my $tick = $self->{tick};
return 'undef' unless defined $_ or not $self->{printUndef};
return $_ . "" if ref \$_ eq 'GLOB';
{ no strict 'refs';
$_ = &{'overload::StrVal'}($_)
if $self->{bareStringify} and ref $_
and %overload:: and defined &{'overload::StrVal'};
}
if ($tick eq 'auto') {
if (/[\000-\011\013-\037\177]/) {
$tick = '"';
} else {
$tick = "'";
}
}
if ($tick eq "'") {
s/([\'\\])/\\$1/g;
} elsif ($self->{unctrl} eq 'unctrl') {
s/([\"\\])/\\$1/g ;
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/\033/\\e/g;
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/)
? $_
: $tick . $_ . $tick;
}
sub DumpElem {
my ($self, $v) = (shift, shift);
my $short = $self->stringify($v, ref $v);
my $shortmore = '';
if ($self->{veryCompact} && ref $v
&& (ref $v eq 'ARRAY' and !grep(ref $_, @$v) )) {
my $depth = $#$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)) {
my @a = sort keys %$v;
my $depth = $#a;
($shortmore, $depth) = (' ...', $self->{hashDepth} - 1)
if $self->{hashDepth} and $depth >= $self->{hashDepth};
my @b = map {$self->stringify($_) . " => " . $self->stringify($$v{$_})}
@a[0..$depth];
local $" = ', ';
print "@b$shortmore\n";
} else {
print "$short\n";
$self->unwrap($v,shift);
}
}
sub unwrap {
my $self = shift;
return if $DB::signal and $self->{stopDbSignal};
my ($v) = shift ;
my ($s) = shift ; # extra no of spaces
my $sp;
my (%v,@v,$address,$short,$fileno);
$sp = " " x $s ;
$s += 3 ;
# Check for reused addresses
if (ref $v) {
my $val = $v;
{ no strict 'refs';
$val = &{'overload::StrVal'}($v)
if %overload:: and defined &{'overload::StrVal'};
}
($address) = $val =~ /(0x[0-9a-f]+)\)$/ ;
if (!$self->{dumpReused} && defined $address) {
$address{$address}++ ;
if ( $address{$address} > 1 ) {
print "${sp}-> REUSED_ADDRESS\n" ;
return ;
}
}
} elsif (ref \$v eq 'GLOB') {
$address = "$v" . ""; # To avoid a bug with globs
$address{$address}++ ;
if ( $address{$address} > 1 ) {
print "${sp}*DUMPED_GLOB*\n" ;
return ;
}
}
if (ref $v eq 'Regexp') {
my $re = "$v";
$re =~ s,/,\\/,g;
print "$sp-> qr/$re/\n";
return;
}
if ( UNIVERSAL::isa($v, 'HASH') ) {
my @sortKeys = sort keys(%$v) ;
my $more;
my $tHashDepth = $#sortKeys ;
$tHashDepth = $#sortKeys < $self->{hashDepth}-1 ? $#sortKeys : $self->{hashDepth}-1
unless $self->{hashDepth} eq '' ;
$more = "....\n" if $tHashDepth < $#sortKeys ;
my $shortmore = "";
$shortmore = ", ..." if $tHashDepth < $#sortKeys ;
$#sortKeys = $tHashDepth ;
if ($self->{compactDump} && !grep(ref $_, values %{$v})) {
$short = $sp;
my @keys;
for (@sortKeys) {
push @keys, $self->stringify($_) . " => " . $self->stringify($v->{$_});
}
$short .= join ', ', @keys;
$short .= $shortmore;
(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} ;
my $more ;
$tArrayDepth = $#$v < $self->{arrayDepth}-1 ? $#$v : $self->{arrayDepth}-1
unless $self->{arrayDepth} eq '' ;
$more = "....\n" if $tArrayDepth < $#{$v} ;
my $shortmore = "";
$shortmore = " ..." if $tArrayDepth < $#{$v} ;
if ($self->{compactDump} && !grep(ref $_, @{$v})) {
if ($#$v >= 0) {
$short = $sp . "0..$#{$v} " .
join(" ",
map {exists $v->[$_] ? $self->stringify($v->[$_]) : "empty"} ($[..$tArrayDepth)
) . "$shortmore";
} else {
$short = $sp . "empty array";
}
(print "$short\n"), return if length $short <= $self->{compactDump};
}
for my $num ($[ .. $tArrayDepth) {
return if $DB::signal and $self->{stopDbSignal};
print "$sp$num ";
if (exists $v->[$num]) {
$self->DumpElem($v->[$num], $s);
} else {
print "empty slot\n";
}
}
print "$sp empty array\n" unless @$v;
print "$sp$more" if defined $more ;
} elsif ( UNIVERSAL::isa($v, 'SCALAR') or ref $v eq 'REF' ) {
print "$sp-> ";
$self->DumpElem($$v, $s);
} elsif ( UNIVERSAL::isa($v, 'CODE') ) {
print "$sp-> ";
$self->dumpsub(0, $v);
} elsif ( UNIVERSAL::isa($v, 'GLOB') ) {
print "$sp-> ",$self->stringify($$v,1),"\n";
if ($self->{globPrint}) {
$s += 3;
$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" );
}
}
}
sub matchvar {
$_[0] eq $_[1] or
($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and
($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/});
}
sub compactDump {
my $self = shift;
$self->{compactDump} = shift if @_;
$self->{compactDump} = 6*80-1
if $self->{compactDump} and $self->{compactDump} < 2;
$self->{compactDump};
}
sub veryCompact {
my $self = shift;
$self->{veryCompact} = shift if @_;
$self->compactDump(1) if !$self->{compactDump} and $self->{veryCompact};
$self->{veryCompact};
}
sub set_unctrl {
my $self = shift;
if (@_) {
my $in = shift;
if ($in eq 'unctrl' or $in eq 'quote') {
$self->{unctrl} = $in;
} else {
print "Unknown value for `unctrl'.\n";
}
}
$self->{unctrl};
}
sub set_quote {
my $self = shift;
if (@_ and $_[0] eq '"') {
$self->{tick} = '"';
$self->{unctrl} = 'quote';
} elsif (@_ and $_[0] eq 'auto') {
$self->{tick} = 'auto';
$self->{unctrl} = 'quote';
} elsif (@_) { # Need to set
$self->{tick} = "'";
$self->{unctrl} = 'unctrl';
}
$self->{tick};
}
sub dumpglob {
my $self = shift;
return if $DB::signal and $self->{stopDbSignal};
my ($package, $off, $key, $val, $all) = @_;
local(*stab) = $val;
my $fileno;
if (($key !~ /^_{dumpDBFiles}) and defined $stab) {
print( (' ' x $off) . "\$", &unctrl($key), " = " );
$self->DumpElem($stab, 3+$off);
}
if (($key !~ /^_{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 !~ /^_{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" );
}
if ($all) {
if (defined &stab) {
$self->dumpsub($off, $key);
}
}
}
sub CvGV_name {
my $self = shift;
my $in = shift;
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 dumpsub {
my $self = shift;
my ($off,$sub) = @_;
my $ini = $sub;
my $s;
$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"))
&& $DB::sub{$s});
$s = $sub unless defined $s;
$place = '???' unless defined $place;
print( (' ' x $off) . "&$s in $place\n" );
}
sub findsubs {
my $self = shift;
return undef unless %DB::sub;
my ($addr, $name, $loc);
while (($name, $loc) = each %DB::sub) {
$addr = \&$name;
$subs{"$addr"} = $name;
}
$self->{subdump} = 0;
$subs{ shift() };
}
sub dumpvars {
my $self = shift;
my ($package,@vars) = @_;
local(%address,$^W);
my ($key,$val);
$package .= "::" unless $package =~ /::$/;
*stab = *main::;
while ($package =~ /(\w+?::)/g) {
*stab = $ {stab}{$1};
}
$self->{TotalStrings} = 0;
$self->{Strings} = 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';
} else {
$self->dumpglob($package, 0,$key, $val);
}
}
if ($self->{usageOnly}) {
print <
{TotalStrings} bytes in $self->{Strings} strings.
EOP
$self->{CompleteTotal} += $self->{TotalStrings};
print <{CompleteTotal} bytes (1 level deep) + overhead.
EOP
}
}
sub scalarUsage {
my $self = shift;
my $size;
if (UNIVERSAL::isa($_[0], 'ARRAY')) {
$size = $self->arrayUsage($_[0]);
} elsif (UNIVERSAL::isa($_[0], 'HASH')) {
$size = $self->hashUsage($_[0]);
} elsif (!ref($_[0])) {
$size = length($_[0]);
}
$self->{TotalStrings} += $size;
$self->{Strings}++;
$size;
}
sub arrayUsage { # array ref, name
my $self = shift;
my $size = 0;
map {$size += $self->scalarUsage($_)} @{$_[0]};
my $len = @{$_[0]};
print "\@$_[1] = $len item", ($len > 1 ? "s" : ""), " (data: $size bytes)\n"
if defined $_[1];
$self->{CompleteTotal} += $size;
$size;
}
sub hashUsage { # hash ref, name
my $self = shift;
my @keys = keys %{$_[0]};
my @values = values %{$_[0]};
my $keys = $self->arrayUsage(\@keys);
my $values = $self->arrayUsage(\@values);
my $len = @keys;
my $total = $keys + $values;
print "\%$_[1] = $len item", ($len > 1 ? "s" : ""),
" (keys: $keys; values: $values; total: $total bytes)\n"
if defined $_[1];
$total;
}
sub globUsage { # glob ref, name
my $self = shift;
local *stab = *{$_[0]};
my $total = 0;
$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"));
$total;
}
1;
=head1 NAME
Dumpvalue - provides screen dump of Perl data.
=head1 SYNOPSIS
use Dumpvalue;
my $dumper = Dumpvalue->new;
$dumper->set(globPrint => 1);
$dumper->dumpValue(\*::);
$dumper->dumpvars('main');
my $dump = $dumper->stringify($some_value);
=head1 DESCRIPTION
=head2 Creation
A new dumper is created by a call
$d = Dumpvalue->new(option1 => value1, option2 => value2)
Recognized options:
=over 4
=item C, C
Print only first N elements of arrays and hashes. If false, prints all the
elements.
=item C, C
Change style of array and hash dump. If true, short array
may be printed on one line.
=item C
Whether to print contents of globs.
=item C
Dump arrays holding contents of debugged files.
=item C
Dump symbol tables of packages.
=item C
Dump contents of "reused" addresses.
=item C, C, C
Change style of string dump. Default value of C is C, 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. If C is set, they will be quoted.
=item C
rudimentally per-package memory usage dump. If set,
C calculates total size of strings in variables in the package.
=item unctrl
Changes the style of printout of strings. Possible values are
C and C.
=item subdump
Whether to try to find the subroutine name given the reference.
=item bareStringify
Whether to write the non-overloaded form of the stringify-overloaded objects.
=item quoteHighBit
Whether to print chars with high bit set in binary or "as is".
=item stopDbSignal
Whether to abort printing if debugger signal flag is raised.
=back
Later in the life of the object the methods may be queries with get()
method and set() method (which accept multiple arguments).
=head2 Methods
=over 4
=item dumpValue
$dumper->dumpValue($value);
$dumper->dumpValue([$value1, $value2]);
Prints a dump to the currently selected filehandle.
=item dumpValues
$dumper->dumpValues($value1, $value2);
Same as C< $dumper->dumpValue([$value1, $value2]); >.
=item stringify
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.
=item dumpvars
$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, and also entries
with names which ends on C, or are shorter than 5 chars.
=item set_quote
$d->set_quote('"');
Sets C and C options to suitable values for printout with the
given quote char. Possible values are C, C<'> and C<">.
=item set_unctrl
$d->set_unctrl('unctrl');
Sets C option with checking for an invalid argument.
Possible values are C and C.
=item compactDump
$d->compactDump(1);
Sets C option. If the value is 1, sets to a reasonable
big number.
=item veryCompact
$d->veryCompact(1);
Sets C and C options simultaneously.
=item set
$d->set(option1 => value1, option2 => value2);
=item get
@values = $d->get('option1', 'option2');
=back
=cut