From: Ilya Zakharevich Date: Mon, 7 Dec 1998 10:17:35 +0000 (+0200) Subject: Dumpvar.pm X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=230a5be762e9045befd0597ec6c3153b952f1104;p=p5sagit%2Fp5-mst-13.2.git Dumpvar.pm To: perl5-porters@perl.org (Mailing list Perl5) Message-ID: p4raw-id: //depot/cfgperl@2513 --- diff --git a/MANIFEST b/MANIFEST index 2e2cd74..c0c48db 100644 --- a/MANIFEST +++ b/MANIFEST @@ -511,6 +511,7 @@ lib/Class/Struct.pm Declare struct-like datatypes as Perl classes lib/Cwd.pm Various cwd routines (getcwd, fastcwd, chdir) lib/Devel/SelfStubber.pm Generate stubs for SelfLoader.pm lib/DirHandle.pm like FileHandle only for directories +lib/Dumpvalue.pm Screen dump of perl values lib/English.pm Readable aliases for short variables lib/Env.pm Map environment into ordinary variables lib/Exporter.pm Exporter base class diff --git a/lib/Dumpvalue.pm b/lib/Dumpvalue.pm new file mode 100644 index 0000000..5bcd58f --- /dev/null +++ b/lib/Dumpvalue.pm @@ -0,0 +1,600 @@ +require 5.005; # For (defined ref) and $#$v +package Dumpvalue; +use strict; +use vars qw(%address *stab %subs); + +# 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 defined %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 defined %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 ( 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 {$self->stringify($_)} @{$v}[0..$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 "; + $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' ) { + 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 defined @stab) { + print( (' ' x $off) . "\@$key = (\n" ); + $self->unwrap(\@stab,3+$off) ; + print( (' ' x $off) . ")\n" ); + } + if ($key ne "main::" && $key ne "DB::" && defined %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 dumpsub { + my $self = shift; + my ($off,$sub) = @_; + $sub = $1 if $sub =~ /^\{\*(.*)\}$/; + my $subref = \&$sub; + my $place = $DB::sub{$sub} || (($sub = $subs{"$subref"}) && $DB::sub{$sub}) + || ($self->{subdump} && ($sub = $self->findsubs("$subref")) + && $DB::sub{$sub}); + $place = '???' unless defined $place; + print( (' ' x $off) . "&$sub in $place\n" ); +} + +sub findsubs { + my $self = shift; + return undef unless defined %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) + unless $package eq 'Dumpvalue' and $key eq 'stab'; + } 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 = 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 defined @stab; + $total += $self->hashUsage(\%stab, $_[1]) + if defined %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 SYNOPSYS + + use Dumpvalue; + my $dumper = new Dumpvalue; + $dumper->set(globPrint => 1); + $dumper->dumpValue(\*::); + $dumper->dumpvars('main'); + +=head1 DESCRIPTION + +=head2 Creation + +A new dumper is created by a call + + $d = new Dumpvalue(option1 => value1, option2 => value2) + +Recognized options: + +=over + +=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. + +=item C + +I 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 + +=item dumpValue + + $dumper->dumpValue($value); + $dumper->dumpValue([$value1, $value2]); + +=item dumpValues + + $dumper->dumpValues($value1, $value2); + +=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('"'); + +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 +