home *** CD-ROM | disk | FTP | other *** search
/ Acorn User 10 / AU_CD10.iso / Updates / Perl / Non-RPC / !Perl / lib / zip / Dumpvalue.pm < prev    next >
Text File  |  1999-01-16  |  16KB  |  601 lines
  1. require 5.005;            # For (defined ref) and $#$v
  2. package Dumpvalue;
  3. use strict;
  4. use vars qw(%address *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 defined %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 defined %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 ( UNIVERSAL::isa($v, 'HASH') ) {
  185.     my @sortKeys = sort keys(%$v) ;
  186.     my $more;
  187.     my $tHashDepth = $#sortKeys ;
  188.     $tHashDepth = $#sortKeys < $self->{hashDepth}-1 ? $#sortKeys : $self->{hashDepth}-1
  189.       unless $self->{hashDepth} eq '' ;
  190.     $more = "....\n" if $tHashDepth < $#sortKeys ;
  191.     my $shortmore = "";
  192.     $shortmore = ", ..." if $tHashDepth < $#sortKeys ;
  193.     $#sortKeys = $tHashDepth ;
  194.     if ($self->{compactDump} && !grep(ref $_, values %{$v})) {
  195.       $short = $sp;
  196.       my @keys;
  197.       for (@sortKeys) {
  198.     push @keys, $self->stringify($_) . " => " . $self->stringify($v->{$_});
  199.       }
  200.       $short .= join ', ', @keys;
  201.       $short .= $shortmore;
  202.       (print "$short\n"), return if length $short <= $self->{compactDump};
  203.     }
  204.     for my $key (@sortKeys) {
  205.       return if $DB::signal and $self->{stopDbSignal};
  206.       my $value = $ {$v}{$key} ;
  207.       print $sp, $self->stringify($key), " => ";
  208.       $self->DumpElem($value, $s);
  209.     }
  210.     print "$sp  empty hash\n" unless @sortKeys;
  211.     print "$sp$more" if defined $more ;
  212.   } elsif ( UNIVERSAL::isa($v, 'ARRAY') ) {
  213.     my $tArrayDepth = $#{$v} ;
  214.     my $more ;
  215.     $tArrayDepth = $#$v < $self->{arrayDepth}-1 ? $#$v : $self->{arrayDepth}-1
  216.       unless  $self->{arrayDepth} eq '' ;
  217.     $more = "....\n" if $tArrayDepth < $#{$v} ;
  218.     my $shortmore = "";
  219.     $shortmore = " ..." if $tArrayDepth < $#{$v} ;
  220.     if ($self->{compactDump} && !grep(ref $_, @{$v})) {
  221.       if ($#$v >= 0) {
  222.     $short = $sp . "0..$#{$v}  " .
  223.       join(" ",
  224.            map {$self->stringify($_)} @{$v}[0..$tArrayDepth])
  225.         . "$shortmore";
  226.       } else {
  227.     $short = $sp . "empty array";
  228.       }
  229.       (print "$short\n"), return if length $short <= $self->{compactDump};
  230.     }
  231.     for my $num ($[ .. $tArrayDepth) {
  232.       return if $DB::signal and $self->{stopDbSignal};
  233.       print "$sp$num  ";
  234.       $self->DumpElem($v->[$num], $s);
  235.     }
  236.     print "$sp  empty array\n" unless @$v;
  237.     print "$sp$more" if defined $more ;
  238.   } elsif (  UNIVERSAL::isa($v, 'SCALAR') or ref $v eq 'REF' ) {
  239.     print "$sp-> ";
  240.     $self->DumpElem($$v, $s);
  241.   } elsif ( UNIVERSAL::isa($v, 'CODE') ) {
  242.     print "$sp-> ";
  243.     $self->dumpsub(0, $v);
  244.   } elsif ( UNIVERSAL::isa($v, 'GLOB') ) {
  245.     print "$sp-> ",$self->stringify($$v,1),"\n";
  246.     if ($self->{globPrint}) {
  247.       $s += 3;
  248.       $self->dumpglob('', $s, "{$$v}", $$v, 1);
  249.     } elsif (defined ($fileno = fileno($v))) {
  250.       print( (' ' x ($s+3)) .  "FileHandle({$$v}) => fileno($fileno)\n" );
  251.     }
  252.   } elsif (ref \$v eq 'GLOB') {
  253.     if ($self->{globPrint}) {
  254.       $self->dumpglob('', $s, "{$v}", $v, 1);
  255.     } elsif (defined ($fileno = fileno(\$v))) {
  256.       print( (' ' x $s) .  "FileHandle({$v}) => fileno($fileno)\n" );
  257.     }
  258.   }
  259. }
  260.  
  261. sub matchvar {
  262.   $_[0] eq $_[1] or
  263.     ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and
  264.       ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/});
  265. }
  266.  
  267. sub compactDump {
  268.   my $self = shift;
  269.   $self->{compactDump} = shift if @_;
  270.   $self->{compactDump} = 6*80-1 
  271.     if $self->{compactDump} and $self->{compactDump} < 2;
  272.   $self->{compactDump};
  273. }
  274.  
  275. sub veryCompact {
  276.   my $self = shift;
  277.   $self->{veryCompact} = shift if @_;
  278.   $self->compactDump(1) if !$self->{compactDump} and $self->{veryCompact};
  279.   $self->{veryCompact};
  280. }
  281.  
  282. sub set_unctrl {
  283.   my $self = shift;
  284.   if (@_) {
  285.     my $in = shift;
  286.     if ($in eq 'unctrl' or $in eq 'quote') {
  287.       $self->{unctrl} = $in;
  288.     } else {
  289.       print "Unknown value for `unctrl'.\n";
  290.     }
  291.   }
  292.   $self->{unctrl};
  293. }
  294.  
  295. sub set_quote {
  296.   my $self = shift;
  297.   if (@_ and $_[0] eq '"') {
  298.     $self->{tick} = '"';
  299.     $self->{unctrl} = 'quote';
  300.   } elsif (@_ and $_[0] eq 'auto') {
  301.     $self->{tick} = 'auto';
  302.     $self->{unctrl} = 'quote';
  303.   } elsif (@_) {        # Need to set
  304.     $self->{tick} = "'";
  305.     $self->{unctrl} = 'unctrl';
  306.   }
  307.   $self->{tick};
  308. }
  309.  
  310. sub dumpglob {
  311.   my $self = shift;
  312.   return if $DB::signal and $self->{stopDbSignal};
  313.   my ($package, $off, $key, $val, $all) = @_;
  314.   local(*stab) = $val;
  315.   my $fileno;
  316.   if (($key !~ /^_</ or $self->{dumpDBFiles}) and defined $stab) {
  317.     print( (' ' x $off) . "\$", &unctrl($key), " = " );
  318.     $self->DumpElem($stab, 3+$off);
  319.   }
  320.   if (($key !~ /^_</ or $self->{dumpDBFiles}) and defined @stab) {
  321.     print( (' ' x $off) . "\@$key = (\n" );
  322.     $self->unwrap(\@stab,3+$off) ;
  323.     print( (' ' x $off) .  ")\n" );
  324.   }
  325.   if ($key ne "main::" && $key ne "DB::" && defined %stab
  326.       && ($self->{dumpPackages} or $key !~ /::$/)
  327.       && ($key !~ /^_</ or $self->{dumpDBFiles})
  328.       && !($package eq "Dumpvalue" and $key eq "stab")) {
  329.     print( (' ' x $off) . "\%$key = (\n" );
  330.     $self->unwrap(\%stab,3+$off) ;
  331.     print( (' ' x $off) .  ")\n" );
  332.   }
  333.   if (defined ($fileno = fileno(*stab))) {
  334.     print( (' ' x $off) .  "FileHandle($key) => fileno($fileno)\n" );
  335.   }
  336.   if ($all) {
  337.     if (defined &stab) {
  338.       $self->dumpsub($off, $key);
  339.     }
  340.   }
  341. }
  342.  
  343. sub dumpsub {
  344.   my $self = shift;
  345.   my ($off,$sub) = @_;
  346.   $sub = $1 if $sub =~ /^\{\*(.*)\}$/;
  347.   my $subref = \&$sub;
  348.   my $place = $DB::sub{$sub} || (($sub = $subs{"$subref"}) && $DB::sub{$sub})
  349.     || ($self->{subdump} && ($sub = $self->findsubs("$subref"))
  350.     && $DB::sub{$sub});
  351.   $place = '???' unless defined $place;
  352.   print( (' ' x $off) .  "&$sub in $place\n" );
  353. }
  354.  
  355. sub findsubs {
  356.   my $self = shift;
  357.   return undef unless defined %DB::sub;
  358.   my ($addr, $name, $loc);
  359.   while (($name, $loc) = each %DB::sub) {
  360.     $addr = \&$name;
  361.     $subs{"$addr"} = $name;
  362.   }
  363.   $self->{subdump} = 0;
  364.   $subs{ shift() };
  365. }
  366.  
  367. sub dumpvars {
  368.   my $self = shift;
  369.   my ($package,@vars) = @_;
  370.   local(%address,$^W);
  371.   my ($key,$val);
  372.   $package .= "::" unless $package =~ /::$/;
  373.   *stab = *main::;
  374.  
  375.   while ($package =~ /(\w+?::)/g) {
  376.     *stab = $ {stab}{$1};
  377.   }
  378.   $self->{TotalStrings} = 0;
  379.   $self->{Strings} = 0;
  380.   $self->{CompleteTotal} = 0;
  381.   while (($key,$val) = each(%stab)) {
  382.     return if $DB::signal and $self->{stopDbSignal};
  383.     next if @vars && !grep( matchvar($key, $_), @vars );
  384.     if ($self->{usageOnly}) {
  385.       $self->globUsage(\$val, $key)
  386.     unless $package eq 'Dumpvalue' and $key eq 'stab';
  387.     } else {
  388.       $self->dumpglob($package, 0,$key, $val);
  389.     }
  390.   }
  391.   if ($self->{usageOnly}) {
  392.     print <<EOP;
  393. String space: $self->{TotalStrings} bytes in $self->{Strings} strings.
  394. EOP
  395.     $self->{CompleteTotal} += $self->{TotalStrings};
  396.     print <<EOP;
  397. Grand total = $self->{CompleteTotal} bytes (1 level deep) + overhead.
  398. EOP
  399.   }
  400. }
  401.  
  402. sub scalarUsage {
  403.   my $self = shift;
  404.   my $size = length($_[0]);
  405.   $self->{TotalStrings} += $size;
  406.   $self->{Strings}++;
  407.   $size;
  408. }
  409.  
  410. sub arrayUsage {        # array ref, name
  411.   my $self = shift;
  412.   my $size = 0;
  413.   map {$size += $self->scalarUsage($_)} @{$_[0]};
  414.   my $len = @{$_[0]};
  415.   print "\@$_[1] = $len item", ($len > 1 ? "s" : ""), " (data: $size bytes)\n"
  416.       if defined $_[1];
  417.   $self->{CompleteTotal} +=  $size;
  418.   $size;
  419. }
  420.  
  421. sub hashUsage {            # hash ref, name
  422.   my $self = shift;
  423.   my @keys = keys %{$_[0]};
  424.   my @values = values %{$_[0]};
  425.   my $keys = $self->arrayUsage(\@keys);
  426.   my $values = $self->arrayUsage(\@values);
  427.   my $len = @keys;
  428.   my $total = $keys + $values;
  429.   print "\%$_[1] = $len item", ($len > 1 ? "s" : ""),
  430.     " (keys: $keys; values: $values; total: $total bytes)\n"
  431.       if defined $_[1];
  432.   $total;
  433. }
  434.  
  435. sub globUsage {            # glob ref, name
  436.   my $self = shift;
  437.   local *stab = *{$_[0]};
  438.   my $total = 0;
  439.   $total += $self->scalarUsage($stab) if defined $stab;
  440.   $total += $self->arrayUsage(\@stab, $_[1]) if defined @stab;
  441.   $total += $self->hashUsage(\%stab, $_[1]) 
  442.     if defined %stab and $_[1] ne "main::" and $_[1] ne "DB::";    
  443.   #and !($package eq "Dumpvalue" and $key eq "stab"));
  444.   $total;
  445. }
  446.  
  447. 1;
  448.  
  449. =head1 NAME
  450.  
  451. Dumpvalue - provides screen dump of Perl data.
  452.  
  453. =head1 SYNOPSYS
  454.  
  455.   use Dumpvalue;
  456.   my $dumper = new Dumpvalue;
  457.   $dumper->set(globPrint => 1);
  458.   $dumper->dumpValue(\*::);
  459.   $dumper->dumpvars('main');
  460.  
  461. =head1 DESCRIPTION
  462.  
  463. =head2 Creation
  464.  
  465. A new dumper is created by a call
  466.  
  467.   $d = new Dumpvalue(option1 => value1, option2 => value2)
  468.  
  469. Recognized options:
  470.  
  471. =over
  472.  
  473. =item C<arrayDepth>, C<hashDepth>
  474.  
  475. Print only first N elements of arrays and hashes.  If false, prints all the
  476. elements.
  477.  
  478. =item C<compactDump>, C<veryCompact>
  479.  
  480. Change style of array and hash dump.  If true, short array
  481. may be printed on one line.
  482.  
  483. =item C<globPrint>
  484.  
  485. Whether to print contents of globs.
  486.  
  487. =item C<DumpDBFiles>
  488.  
  489. Dump arrays holding contents of debugged files.
  490.  
  491. =item C<DumpPackages>
  492.  
  493. Dump symbol tables of packages.
  494.  
  495. =item C<DumpReused>
  496.  
  497. Dump contents of "reused" addresses.
  498.  
  499. =item C<tick>, C<HighBit>, C<printUndef>
  500.  
  501. Change style of string dump.  Default value of C<tick> is C<auto>, one
  502. can enable either double-quotish dump, or single-quotish by setting it
  503. to C<"> or C<'>.  By default, characters with high bit set are printed
  504. I<as is>.
  505.  
  506. =item C<UsageOnly>
  507.  
  508. I<very> rudimentally per-package memory usage dump.  If set,
  509. C<dumpvars> calculates total size of strings in variables in the package.
  510.  
  511. =item unctrl
  512.  
  513. Changes the style of printout of strings.  Possible values are
  514. C<unctrl> and C<quote>.
  515.  
  516. =item subdump
  517.  
  518. Whether to try to find the subroutine name given the reference.
  519.  
  520. =item bareStringify
  521.  
  522. Whether to write the non-overloaded form of the stringify-overloaded objects.
  523.  
  524. =item quoteHighBit
  525.  
  526. Whether to print chars with high bit set in binary or "as is".
  527.  
  528. =item stopDbSignal
  529.  
  530. Whether to abort printing if debugger signal flag is raised.
  531.  
  532. =back
  533.  
  534. Later in the life of the object the methods may be queries with get()
  535. method and set() method (which accept multiple arguments).
  536.  
  537. =head2 Methods
  538.  
  539. =over
  540.  
  541. =item dumpValue
  542.  
  543.   $dumper->dumpValue($value);
  544.   $dumper->dumpValue([$value1, $value2]);
  545.  
  546. =item dumpValues
  547.  
  548.   $dumper->dumpValues($value1, $value2);
  549.  
  550. =item dumpvars
  551.  
  552.   $dumper->dumpvars('my_package');
  553.   $dumper->dumpvars('my_package', 'foo', '~bar$', '!......');
  554.  
  555. The optional arguments are considered as literal strings unless they
  556. start with C<~> or C<!>, in which case they are interpreted as regular
  557. expressions (possibly negated).
  558.  
  559. The second example prints entries with names C<foo>, and also entries
  560. with names which ends on C<bar>, or are shorter than 5 chars.
  561.  
  562. =item set_quote
  563.  
  564.   $d->set_quote('"');
  565.  
  566. Sets C<tick> and C<unctrl> options to suitable values for printout with the
  567. given quote char.  Possible values are C<auto>, C<'> and C<">.
  568.  
  569. =item set_unctrl
  570.  
  571.   $d->set_unctrl('"');
  572.  
  573. Sets C<unctrl> option with checking for an invalid argument.
  574. Possible values are C<unctrl> and C<quote>.
  575.  
  576. =item compactDump
  577.  
  578.   $d->compactDump(1);
  579.  
  580. Sets C<compactDump> option.  If the value is 1, sets to a reasonable
  581. big number.
  582.  
  583. =item veryCompact
  584.  
  585.   $d->veryCompact(1);
  586.  
  587. Sets C<compactDump> and C<veryCompact> options simultaneously.
  588.  
  589. =item set
  590.  
  591.   $d->set(option1 => value1, option2 => value2);
  592.  
  593. =item get
  594.  
  595.   @values = $d->get('option1', 'option2');
  596.  
  597. =back
  598.  
  599. =cut
  600.  
  601.