File Coverage

blib/lib/Dumpvalue.pm

Criterion	Covered	Total	%
statement	297	309	96.1
branch	158	204	77.4
condition	82	141	58.1
subroutine	27	27	100.0
pod	11	23	47.8
total	575	704	81.6

use 5.006_001;			# for (defined ref) and $#$v and our
package Dumpvalue;
use strict;
our $VERSION = '1.17';
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"} (0..$tArrayDepth)
	      ) . "$shortmore";
      } else {
	$short = $sp . "empty array";
      }
      (print "$short\n"), return if length $short <= $self->{compactDump};
    }
    for my $num (0 .. $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 <
String space: $self->{TotalStrings} bytes in $self->{Strings} strings.
EOP
    $self->{CompleteTotal} += $self->{TotalStrings};
    print <
Grand total = $self->{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

rudimentary 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