lib/perl5/5.6.1/Dumpvalue.pm

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