summaryrefslogtreecommitdiffstats
path: root/contrib/perl5/lib/Dumpvalue.pm
diff options
context:
space:
mode:
Diffstat (limited to 'contrib/perl5/lib/Dumpvalue.pm')
-rw-r--r--contrib/perl5/lib/Dumpvalue.pm626
1 files changed, 0 insertions, 626 deletions
diff --git a/contrib/perl5/lib/Dumpvalue.pm b/contrib/perl5/lib/Dumpvalue.pm
deleted file mode 100644
index 475f4ff..0000000
--- a/contrib/perl5/lib/Dumpvalue.pm
+++ /dev/null
@@ -1,626 +0,0 @@
-use 5.005_64; # for (defined ref) and $#$v and our
-package Dumpvalue;
-use strict;
-our(%address, $stab, @stab, %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 %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 !~ /^_</ 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" );
- }
- 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 <<EOP;
-String space: $self->{TotalStrings} bytes in $self->{Strings} strings.
-EOP
- $self->{CompleteTotal} += $self->{TotalStrings};
- print <<EOP;
-Grand total = $self->{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 @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 = 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<arrayDepth>, C<hashDepth>
-
-Print only first N elements of arrays and hashes. If false, prints all the
-elements.
-
-=item C<compactDump>, C<veryCompact>
-
-Change style of array and hash dump. If true, short array
-may be printed on one line.
-
-=item C<globPrint>
-
-Whether to print contents of globs.
-
-=item C<DumpDBFiles>
-
-Dump arrays holding contents of debugged files.
-
-=item C<DumpPackages>
-
-Dump symbol tables of packages.
-
-=item C<DumpReused>
-
-Dump contents of "reused" addresses.
-
-=item C<tick>, C<HighBit>, 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>.
-
-=item C<UsageOnly>
-
-I<very> rudimentally per-package memory usage dump. If set,
-C<dumpvars> calculates total size of strings in variables in the package.
-
-=item unctrl
-
-Changes the style of printout of strings. Possible values are
-C<unctrl> and C<quote>.
-
-=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<foo>, and also entries
-with names which ends on C<bar>, or are shorter than 5 chars.
-
-=item set_quote
-
- $d->set_quote('"');
-
-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<">.
-
-=item set_unctrl
-
- $d->set_unctrl('"');
-
-Sets C<unctrl> option with checking for an invalid argument.
-Possible values are C<unctrl> and C<quote>.
-
-=item compactDump
-
- $d->compactDump(1);
-
-Sets C<compactDump> option. If the value is 1, sets to a reasonable
-big number.
-
-=item veryCompact
-
- $d->veryCompact(1);
-
-Sets C<compactDump> and C<veryCompact> options simultaneously.
-
-=item set
-
- $d->set(option1 => value1, option2 => value2);
-
-=item get
-
- @values = $d->get('option1', 'option2');
-
-=back
-
-=cut
-
OpenPOWER on IntegriCloud