lib/Dumpvalue.pm

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