[Summary view] [Print] [Text view]

   1  use 5.006_001;            # for (defined ref) and $#$v and our
   2  package Dumpvalue;
   3  use strict;
   4  our $VERSION = '1.12';
   5  our(%address, $stab, @stab, %stab, %subs);
   6  
   7  # documentation nits, handle complex data structures better by chromatic
   8  # translate control chars to ^X - Randal Schwartz
   9  # Modifications to print types by Peter Gordon v1.0
  10  
  11  # Ilya Zakharevich -- patches after 5.001 (and some before ;-)
  12  
  13  # Won't dump symbol tables and contents of debugged files by default
  14  
  15  # (IZ) changes for objectification:
  16  #   c) quote() renamed to method set_quote();
  17  #   d) unctrlSet() renamed to method set_unctrl();
  18  #   f) Compiles with `use strict', but in two places no strict refs is needed:
  19  #      maybe more problems are waiting...
  20  
  21  my %defaults = (
  22          globPrint          => 0,
  23          printUndef          => 1,
  24          tick              => "auto",
  25          unctrl              => 'quote',
  26          subdump              => 1,
  27          dumpReused          => 0,
  28          bareStringify          => 1,
  29          hashDepth          => '',
  30          arrayDepth          => '',
  31          dumpDBFiles          => '',
  32          dumpPackages          => '',
  33          quoteHighBit          => '',
  34          usageOnly          => '',
  35          compactDump          => '',
  36          veryCompact          => '',
  37          stopDbSignal          => '',
  38             );
  39  
  40  sub new {
  41    my $class = shift;
  42    my %opt = (%defaults, @_);
  43    bless \%opt, $class;
  44  }
  45  
  46  sub set {
  47    my $self = shift;
  48    my %opt = @_;
  49    @$self{keys %opt} = values %opt;
  50  }
  51  
  52  sub get {
  53    my $self = shift;
  54    wantarray ? @$self{@_} : $$self{pop @_};
  55  }
  56  
  57  sub dumpValue {
  58    my $self = shift;
  59    die "usage: \$dumper->dumpValue(value)" unless @_ == 1;
  60    local %address;
  61    local $^W=0;
  62    (print "undef\n"), return unless defined $_[0];
  63    (print $self->stringify($_[0]), "\n"), return unless ref $_[0];
  64    $self->unwrap($_[0],0);
  65  }
  66  
  67  sub dumpValues {
  68    my $self = shift;
  69    local %address;
  70    local $^W=0;
  71    (print "undef\n"), return unless defined $_[0];
  72    $self->unwrap(\@_,0);
  73  }
  74  
  75  # This one is good for variable names:
  76  
  77  sub unctrl {
  78    local($_) = @_;
  79  
  80    return \$_ if ref \$_ eq "GLOB";
  81    s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
  82    $_;
  83  }
  84  
  85  sub stringify {
  86    my $self = shift;
  87    local $_ = shift;
  88    my $noticks = shift;
  89    my $tick = $self->{tick};
  90  
  91    return 'undef' unless defined $_ or not $self->{printUndef};
  92    return $_ . "" if ref \$_ eq 'GLOB';
  93    { no strict 'refs';
  94      $_ = &{'overload::StrVal'}($_)
  95        if $self->{bareStringify} and ref $_
  96      and %overload:: and defined &{'overload::StrVal'};
  97    }
  98  
  99    if ($tick eq 'auto') {
 100      if (/[\000-\011\013-\037\177]/) {
 101        $tick = '"';
 102      } else {
 103        $tick = "'";
 104      }
 105    }
 106    if ($tick eq "'") {
 107      s/([\'\\])/\\$1/g;
 108    } elsif ($self->{unctrl} eq 'unctrl') {
 109      s/([\"\\])/\\$1/g ;
 110      s/([\000-\037\177])/'^'.pack('c',ord($1)^64)/eg;
 111      s/([\200-\377])/'\\0x'.sprintf('%2X',ord($1))/eg
 112        if $self->{quoteHighBit};
 113    } elsif ($self->{unctrl} eq 'quote') {
 114      s/([\"\\\$\@])/\\$1/g if $tick eq '"';
 115      s/\033/\\e/g;
 116      s/([\000-\037\177])/'\\c'.chr(ord($1)^64)/eg;
 117    }
 118    s/([\200-\377])/'\\'.sprintf('%3o',ord($1))/eg if $self->{quoteHighBit};
 119    ($noticks || /^\d+(\.\d*)?\Z/)
 120      ? $_
 121        : $tick . $_ . $tick;
 122  }
 123  
 124  sub DumpElem {
 125    my ($self, $v) = (shift, shift);
 126    my $short = $self->stringify($v, ref $v);
 127    my $shortmore = '';
 128    if ($self->{veryCompact} && ref $v
 129        && (ref $v eq 'ARRAY' and !grep(ref $_, @$v) )) {
 130      my $depth = $#$v;
 131      ($shortmore, $depth) = (' ...', $self->{arrayDepth} - 1)
 132        if $self->{arrayDepth} and $depth >= $self->{arrayDepth};
 133      my @a = map $self->stringify($_), @$v[0..$depth];
 134      print "0..$#{$v}  @a$shortmore\n";
 135    } elsif ($self->{veryCompact} && ref $v
 136         && (ref $v eq 'HASH') and !grep(ref $_, values %$v)) {
 137      my @a = sort keys %$v;
 138      my $depth = $#a;
 139      ($shortmore, $depth) = (' ...', $self->{hashDepth} - 1)
 140        if $self->{hashDepth} and $depth >= $self->{hashDepth};
 141      my @b = map {$self->stringify($_) . " => " . $self->stringify($$v{$_})}
 142        @a[0..$depth];
 143      local $" = ', ';
 144      print "@b$shortmore\n";
 145    } else {
 146      print "$short\n";
 147      $self->unwrap($v,shift);
 148    }
 149  }
 150  
 151  sub unwrap {
 152    my $self = shift;
 153    return if $DB::signal and $self->{stopDbSignal};
 154    my ($v) = shift ;
 155    my ($s) = shift ;        # extra no of spaces
 156    my $sp;
 157    my (%v,@v,$address,$short,$fileno);
 158  
 159    $sp = " " x $s ;
 160    $s += 3 ;
 161  
 162    # Check for reused addresses
 163    if (ref $v) {
 164      my $val = $v;
 165      { no strict 'refs';
 166        $val = &{'overload::StrVal'}($v)
 167      if %overload:: and defined &{'overload::StrVal'};
 168      }
 169      ($address) = $val =~ /(0x[0-9a-f]+)\)$/ ;
 170      if (!$self->{dumpReused} && defined $address) {
 171        $address{$address}++ ;
 172        if ( $address{$address} > 1 ) {
 173      print "$sp}-> REUSED_ADDRESS\n" ;
 174      return ;
 175        }
 176      }
 177    } elsif (ref \$v eq 'GLOB') {
 178      $address = "$v" . "";    # To avoid a bug with globs
 179      $address{$address}++ ;
 180      if ( $address{$address} > 1 ) {
 181        print "$sp}*DUMPED_GLOB*\n" ;
 182        return ;
 183      }
 184    }
 185  
 186    if (ref $v eq 'Regexp') {
 187      my $re = "$v";
 188      $re =~ s,/,\\/,g;
 189      print "$sp-> qr/$re/\n";
 190      return;
 191    }
 192  
 193    if ( UNIVERSAL::isa($v, 'HASH') ) {
 194      my @sortKeys = sort keys(%$v) ;
 195      my $more;
 196      my $tHashDepth = $#sortKeys ;
 197      $tHashDepth = $#sortKeys < $self->{hashDepth}-1 ? $#sortKeys : $self->{hashDepth}-1
 198        unless $self->{hashDepth} eq '' ;
 199      $more = "....\n" if $tHashDepth < $#sortKeys ;
 200      my $shortmore = "";
 201      $shortmore = ", ..." if $tHashDepth < $#sortKeys ;
 202      $#sortKeys = $tHashDepth ;
 203      if ($self->{compactDump} && !grep(ref $_, values %{$v})) {
 204        $short = $sp;
 205        my @keys;
 206        for (@sortKeys) {
 207      push @keys, $self->stringify($_) . " => " . $self->stringify($v->{$_});
 208        }
 209        $short .= join ', ', @keys;
 210        $short .= $shortmore;
 211        (print "$short\n"), return if length $short <= $self->{compactDump};
 212      }
 213      for my $key (@sortKeys) {
 214        return if $DB::signal and $self->{stopDbSignal};
 215        my $value = $ {$v}{$key} ;
 216        print $sp, $self->stringify($key), " => ";
 217        $self->DumpElem($value, $s);
 218      }
 219      print "$sp  empty hash\n" unless @sortKeys;
 220      print "$sp$more" if defined $more ;
 221    } elsif ( UNIVERSAL::isa($v, 'ARRAY') ) {
 222      my $tArrayDepth = $#{$v} ;
 223      my $more ;
 224      $tArrayDepth = $#$v < $self->{arrayDepth}-1 ? $#$v : $self->{arrayDepth}-1
 225        unless  $self->{arrayDepth} eq '' ;
 226      $more = "....\n" if $tArrayDepth < $#{$v} ;
 227      my $shortmore = "";
 228      $shortmore = " ..." if $tArrayDepth < $#{$v} ;
 229      if ($self->{compactDump} && !grep(ref $_, @{$v})) {
 230        if ($#$v >= 0) {
 231      $short = $sp . "0..$#{$v}  " .
 232        join(" ", 
 233             map {exists $v->[$_] ? $self->stringify($v->[$_]) : "empty"} ($[..$tArrayDepth)
 234            ) . "$shortmore";
 235        } else {
 236      $short = $sp . "empty array";
 237        }
 238        (print "$short\n"), return if length $short <= $self->{compactDump};
 239      }
 240      for my $num ($[ .. $tArrayDepth) {
 241        return if $DB::signal and $self->{stopDbSignal};
 242        print "$sp$num  ";
 243        if (exists $v->[$num]) {
 244          $self->DumpElem($v->[$num], $s);
 245        } else {
 246      print "empty slot\n";
 247        }
 248      }
 249      print "$sp  empty array\n" unless @$v;
 250      print "$sp$more" if defined $more ;
 251    } elsif (  UNIVERSAL::isa($v, 'SCALAR') or ref $v eq 'REF' ) {
 252      print "$sp-> ";
 253      $self->DumpElem($$v, $s);
 254    } elsif ( UNIVERSAL::isa($v, 'CODE') ) {
 255      print "$sp-> ";
 256      $self->dumpsub(0, $v);
 257    } elsif ( UNIVERSAL::isa($v, 'GLOB') ) {
 258      print "$sp-> ",$self->stringify($$v,1),"\n";
 259      if ($self->{globPrint}) {
 260        $s += 3;
 261        $self->dumpglob('', $s, "{$$v}", $$v, 1);
 262      } elsif (defined ($fileno = fileno($v))) {
 263        print( (' ' x ($s+3)) .  "FileHandle({$$v}) => fileno($fileno)\n" );
 264      }
 265    } elsif (ref \$v eq 'GLOB') {
 266      if ($self->{globPrint}) {
 267        $self->dumpglob('', $s, "{$v}", $v, 1);
 268      } elsif (defined ($fileno = fileno(\$v))) {
 269        print( (' ' x $s) .  "FileHandle({$v}) => fileno($fileno)\n" );
 270      }
 271    }
 272  }
 273  
 274  sub matchvar {
 275    $_[0] eq $_[1] or
 276      ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and
 277        ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/});
 278  }
 279  
 280  sub compactDump {
 281    my $self = shift;
 282    $self->{compactDump} = shift if @_;
 283    $self->{compactDump} = 6*80-1 
 284      if $self->{compactDump} and $self->{compactDump} < 2;
 285    $self->{compactDump};
 286  }
 287  
 288  sub veryCompact {
 289    my $self = shift;
 290    $self->{veryCompact} = shift if @_;
 291    $self->compactDump(1) if !$self->{compactDump} and $self->{veryCompact};
 292    $self->{veryCompact};
 293  }
 294  
 295  sub set_unctrl {
 296    my $self = shift;
 297    if (@_) {
 298      my $in = shift;
 299      if ($in eq 'unctrl' or $in eq 'quote') {
 300        $self->{unctrl} = $in;
 301      } else {
 302        print "Unknown value for `unctrl'.\n";
 303      }
 304    }
 305    $self->{unctrl};
 306  }
 307  
 308  sub set_quote {
 309    my $self = shift;
 310    if (@_ and $_[0] eq '"') {
 311      $self->{tick} = '"';
 312      $self->{unctrl} = 'quote';
 313    } elsif (@_ and $_[0] eq 'auto') {
 314      $self->{tick} = 'auto';
 315      $self->{unctrl} = 'quote';
 316    } elsif (@_) {        # Need to set
 317      $self->{tick} = "'";
 318      $self->{unctrl} = 'unctrl';
 319    }
 320    $self->{tick};
 321  }
 322  
 323  sub dumpglob {
 324    my $self = shift;
 325    return if $DB::signal and $self->{stopDbSignal};
 326    my ($package, $off, $key, $val, $all) = @_;
 327    local(*stab) = $val;
 328    my $fileno;
 329    if (($key !~ /^_</ or $self->{dumpDBFiles}) and defined $stab) {
 330      print( (' ' x $off) . "\$", &unctrl($key), " = " );
 331      $self->DumpElem($stab, 3+$off);
 332    }
 333    if (($key !~ /^_</ or $self->{dumpDBFiles}) and @stab) {
 334      print( (' ' x $off) . "\@$key = (\n" );
 335      $self->unwrap(\@stab,3+$off) ;
 336      print( (' ' x $off) .  ")\n" );
 337    }
 338    if ($key ne "main::" && $key ne "DB::" && %stab
 339        && ($self->{dumpPackages} or $key !~ /::$/)
 340        && ($key !~ /^_</ or $self->{dumpDBFiles})
 341        && !($package eq "Dumpvalue" and $key eq "stab")) {
 342      print( (' ' x $off) . "\%$key = (\n" );
 343      $self->unwrap(\%stab,3+$off) ;
 344      print( (' ' x $off) .  ")\n" );
 345    }
 346    if (defined ($fileno = fileno(*stab))) {
 347      print( (' ' x $off) .  "FileHandle($key) => fileno($fileno)\n" );
 348    }
 349    if ($all) {
 350      if (defined &stab) {
 351        $self->dumpsub($off, $key);
 352      }
 353    }
 354  }
 355  
 356  sub CvGV_name {
 357    my $self = shift;
 358    my $in = shift;
 359    return if $self->{skipCvGV};    # Backdoor to avoid problems if XS broken...
 360    $in = \&$in;            # Hard reference...
 361    eval {require Devel::Peek; 1} or return;
 362    my $gv = Devel::Peek::CvGV($in) or return;
 363    *$gv{PACKAGE} . '::' . *$gv{NAME};
 364  }
 365  
 366  sub dumpsub {
 367    my $self = shift;
 368    my ($off,$sub) = @_;
 369    my $ini = $sub;
 370    my $s;
 371    $sub = $1 if $sub =~ /^\{\*(.*)\}$/;
 372    my $subref = defined $1 ? \&$sub : \&$ini;
 373    my $place = $DB::sub{$sub} || (($s = $subs{"$subref"}) && $DB::sub{$s})
 374      || (($s = $self->CvGV_name($subref)) && $DB::sub{$s})
 375      || ($self->{subdump} && ($s = $self->findsubs("$subref"))
 376      && $DB::sub{$s});
 377    $s = $sub unless defined $s;
 378    $place = '???' unless defined $place;
 379    print( (' ' x $off) .  "&$s in $place\n" );
 380  }
 381  
 382  sub findsubs {
 383    my $self = shift;
 384    return undef unless %DB::sub;
 385    my ($addr, $name, $loc);
 386    while (($name, $loc) = each %DB::sub) {
 387      $addr = \&$name;
 388      $subs{"$addr"} = $name;
 389    }
 390    $self->{subdump} = 0;
 391    $subs{ shift() };
 392  }
 393  
 394  sub dumpvars {
 395    my $self = shift;
 396    my ($package,@vars) = @_;
 397    local(%address,$^W);
 398    my ($key,$val);
 399    $package .= "::" unless $package =~ /::$/;
 400    *stab = *main::;
 401  
 402    while ($package =~ /(\w+?::)/g) {
 403      *stab = $ {stab}{$1};
 404    }
 405    $self->{TotalStrings} = 0;
 406    $self->{Strings} = 0;
 407    $self->{CompleteTotal} = 0;
 408    while (($key,$val) = each(%stab)) {
 409      return if $DB::signal and $self->{stopDbSignal};
 410      next if @vars && !grep( matchvar($key, $_), @vars );
 411      if ($self->{usageOnly}) {
 412        $self->globUsage(\$val, $key)
 413      if ($package ne 'Dumpvalue' or $key ne 'stab')
 414         and ref(\$val) eq 'GLOB';
 415      } else {
 416        $self->dumpglob($package, 0,$key, $val);
 417      }
 418    }
 419    if ($self->{usageOnly}) {
 420      print <<EOP;
 421  String space: $self->{TotalStrings} bytes in $self->{Strings} strings.
 422  EOP
 423      $self->{CompleteTotal} += $self->{TotalStrings};
 424      print <<EOP;
 425  Grand total = $self->{CompleteTotal} bytes (1 level deep) + overhead.
 426  EOP
 427    }
 428  }
 429  
 430  sub scalarUsage {
 431    my $self = shift;
 432    my $size;
 433    if (UNIVERSAL::isa($_[0], 'ARRAY')) {
 434      $size = $self->arrayUsage($_[0]);
 435    } elsif (UNIVERSAL::isa($_[0], 'HASH')) {
 436      $size = $self->hashUsage($_[0]);
 437    } elsif (!ref($_[0])) {
 438      $size = length($_[0]);
 439    }
 440    $self->{TotalStrings} += $size;
 441    $self->{Strings}++;
 442    $size;
 443  }
 444  
 445  sub arrayUsage {        # array ref, name
 446    my $self = shift;
 447    my $size = 0;
 448    map {$size += $self->scalarUsage($_)} @{$_[0]};
 449    my $len = @{$_[0]};
 450    print "\@$_[1] = $len item", ($len > 1 ? "s" : ""), " (data: $size bytes)\n"
 451        if defined $_[1];
 452    $self->{CompleteTotal} +=  $size;
 453    $size;
 454  }
 455  
 456  sub hashUsage {            # hash ref, name
 457    my $self = shift;
 458    my @keys = keys %{$_[0]};
 459    my @values = values %{$_[0]};
 460    my $keys = $self->arrayUsage(\@keys);
 461    my $values = $self->arrayUsage(\@values);
 462    my $len = @keys;
 463    my $total = $keys + $values;
 464    print "\%$_[1] = $len item", ($len > 1 ? "s" : ""),
 465      " (keys: $keys; values: $values; total: $total bytes)\n"
 466        if defined $_[1];
 467    $total;
 468  }
 469  
 470  sub globUsage {            # glob ref, name
 471    my $self = shift;
 472    local *stab = *{$_[0]};
 473    my $total = 0;
 474    $total += $self->scalarUsage($stab) if defined $stab;
 475    $total += $self->arrayUsage(\@stab, $_[1]) if @stab;
 476    $total += $self->hashUsage(\%stab, $_[1]) 
 477      if %stab and $_[1] ne "main::" and $_[1] ne "DB::";    
 478    #and !($package eq "Dumpvalue" and $key eq "stab"));
 479    $total;
 480  }
 481  
 482  1;
 483  
 484  =head1 NAME
 485  
 486  Dumpvalue - provides screen dump of Perl data.
 487  
 488  =head1 SYNOPSIS
 489  
 490    use Dumpvalue;
 491    my $dumper = new Dumpvalue;
 492    $dumper->set(globPrint => 1);
 493    $dumper->dumpValue(\*::);
 494    $dumper->dumpvars('main');
 495    my $dump = $dumper->stringify($some_value);
 496  
 497  =head1 DESCRIPTION
 498  
 499  =head2 Creation
 500  
 501  A new dumper is created by a call
 502  
 503    $d = new Dumpvalue(option1 => value1, option2 => value2)
 504  
 505  Recognized options:
 506  
 507  =over 4
 508  
 509  =item C<arrayDepth>, C<hashDepth>
 510  
 511  Print only first N elements of arrays and hashes.  If false, prints all the
 512  elements.
 513  
 514  =item C<compactDump>, C<veryCompact>
 515  
 516  Change style of array and hash dump.  If true, short array
 517  may be printed on one line.
 518  
 519  =item C<globPrint>
 520  
 521  Whether to print contents of globs.
 522  
 523  =item C<dumpDBFiles>
 524  
 525  Dump arrays holding contents of debugged files.
 526  
 527  =item C<dumpPackages>
 528  
 529  Dump symbol tables of packages.
 530  
 531  =item C<dumpReused>
 532  
 533  Dump contents of "reused" addresses.
 534  
 535  =item C<tick>, C<quoteHighBit>, C<printUndef>
 536  
 537  Change style of string dump.  Default value of C<tick> is C<auto>, one
 538  can enable either double-quotish dump, or single-quotish by setting it
 539  to C<"> or C<'>.  By default, characters with high bit set are printed
 540  I<as is>.  If C<quoteHighBit> is set, they will be quoted.
 541  
 542  =item C<usageOnly>
 543  
 544  rudimentally per-package memory usage dump.  If set,
 545  C<dumpvars> calculates total size of strings in variables in the package.
 546  
 547  =item unctrl
 548  
 549  Changes the style of printout of strings.  Possible values are
 550  C<unctrl> and C<quote>.
 551  
 552  =item subdump
 553  
 554  Whether to try to find the subroutine name given the reference.
 555  
 556  =item bareStringify
 557  
 558  Whether to write the non-overloaded form of the stringify-overloaded objects.
 559  
 560  =item quoteHighBit
 561  
 562  Whether to print chars with high bit set in binary or "as is".
 563  
 564  =item stopDbSignal
 565  
 566  Whether to abort printing if debugger signal flag is raised.
 567  
 568  =back
 569  
 570  Later in the life of the object the methods may be queries with get()
 571  method and set() method (which accept multiple arguments).
 572  
 573  =head2 Methods
 574  
 575  =over 4
 576  
 577  =item dumpValue
 578  
 579    $dumper->dumpValue($value);
 580    $dumper->dumpValue([$value1, $value2]);
 581  
 582  Prints a dump to the currently selected filehandle.
 583  
 584  =item dumpValues
 585  
 586    $dumper->dumpValues($value1, $value2);
 587  
 588  Same as C< $dumper->dumpValue([$value1, $value2]); >.
 589  
 590  =item stringify
 591  
 592    my $dump = $dumper->stringify($value [,$noticks] );
 593  
 594  Returns the dump of a single scalar without printing. If the second
 595  argument is true, the return value does not contain enclosing ticks.
 596  Does not handle data structures.
 597  
 598  =item dumpvars
 599  
 600    $dumper->dumpvars('my_package');
 601    $dumper->dumpvars('my_package', 'foo', '~bar$', '!......');
 602  
 603  The optional arguments are considered as literal strings unless they
 604  start with C<~> or C<!>, in which case they are interpreted as regular
 605  expressions (possibly negated).
 606  
 607  The second example prints entries with names C<foo>, and also entries
 608  with names which ends on C<bar>, or are shorter than 5 chars.
 609  
 610  =item set_quote
 611  
 612    $d->set_quote('"');
 613  
 614  Sets C<tick> and C<unctrl> options to suitable values for printout with the
 615  given quote char.  Possible values are C<auto>, C<'> and C<">.
 616  
 617  =item set_unctrl
 618  
 619    $d->set_unctrl('unctrl');
 620  
 621  Sets C<unctrl> option with checking for an invalid argument.
 622  Possible values are C<unctrl> and C<quote>.
 623  
 624  =item compactDump
 625  
 626    $d->compactDump(1);
 627  
 628  Sets C<compactDump> option.  If the value is 1, sets to a reasonable
 629  big number.
 630  
 631  =item veryCompact
 632  
 633    $d->veryCompact(1);
 634  
 635  Sets C<compactDump> and C<veryCompact> options simultaneously.
 636  
 637  =item set
 638  
 639    $d->set(option1 => value1, option2 => value2);
 640  
 641  =item get
 642  
 643    @values = $d->get('option1', 'option2');
 644  
 645  =back
 646  
 647  =cut
 648