lib/Dumpvalue.pm

   1 use 5.006_001;                  # for (defined ref) and $#$v and our
   2 package Dumpvalue;
   3 use strict;
   4 our $VERSION = '1.11';
   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('"');
 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