home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl_mlb.zip / dumpvar.pl < prev    next >
Perl Script  |  1997-11-25  |  11KB  |  410 lines
  1. require 5.002;            # For (defined ref)
  2. package dumpvar;
  3.  
  4. # Needed for PrettyPrinter only:
  5.  
  6. # require 5.001;  # Well, it coredumps anyway undef DB in 5.000 (not now)
  7.  
  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. $winsize = 80 unless defined $winsize;
  16.  
  17.  
  18. # Defaults
  19.  
  20. # $globPrint = 1;
  21. $printUndef = 1 unless defined $printUndef;
  22. $tick = "auto" unless defined $tick;
  23. $unctrl = 'quote' unless defined $unctrl;
  24. $subdump = 1;
  25.  
  26. sub main::dumpValue {
  27.   local %address;
  28.   local $^W=0;
  29.   (print "undef\n"), return unless defined $_[0];
  30.   (print &stringify($_[0]), "\n"), return unless ref $_[0];
  31.   dumpvar::unwrap($_[0],0);
  32. }
  33.  
  34. # This one is good for variable names:
  35.  
  36. sub unctrl {
  37.     local($_) = @_;
  38.     local($v) ; 
  39.  
  40.     return \$_ if ref \$_ eq "GLOB";
  41.     s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
  42.     $_;
  43. }
  44.  
  45. sub stringify {
  46.     local($_,$noticks) = @_;
  47.     local($v) ; 
  48.     my $tick = $tick;
  49.  
  50.     return 'undef' unless defined $_ or not $printUndef;
  51.     return $_ . "" if ref \$_ eq 'GLOB';
  52.     if ($tick eq 'auto') {
  53.       if (/[\000-\011\013-\037\177]/) {
  54.         $tick = '"';
  55.       }else {
  56.         $tick = "'";
  57.       }
  58.     }
  59.     if ($tick eq "'") {
  60.       s/([\'\\])/\\$1/g;
  61.     } elsif ($unctrl eq 'unctrl') {
  62.       s/([\"\\])/\\$1/g ;
  63.       s/([\000-\037\177])/'^'.pack('c',ord($1)^64)/eg;
  64.       s/([\200-\377])/'\\0x'.sprintf('%2X',ord($1))/eg 
  65.         if $quoteHighBit;
  66.     } elsif ($unctrl eq 'quote') {
  67.       s/([\"\\\$\@])/\\$1/g if $tick eq '"';
  68.       s/\033/\\e/g;
  69.       s/([\000-\037\177])/'\\c'.chr(ord($1)^64)/eg;
  70.     }
  71.     s/([\200-\377])/'\\'.sprintf('%3o',ord($1))/eg if $quoteHighBit;
  72.     ($noticks || /^\d+(\.\d*)?\Z/) 
  73.       ? $_ 
  74.       : $tick . $_ . $tick;
  75. }
  76.  
  77. sub ShortArray {
  78.   my $tArrayDepth = $#{$_[0]} ; 
  79.   $tArrayDepth = $#{$_[0]} < $arrayDepth-1 ? $#{$_[0]} : $arrayDepth-1 
  80.     unless  $arrayDepth eq '' ; 
  81.   my $shortmore = "";
  82.   $shortmore = " ..." if $tArrayDepth < $#{$_[0]} ;
  83.   if (!grep(ref $_, @{$_[0]})) {
  84.     $short = "0..$#{$_[0]}  '" . 
  85.       join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore";
  86.     return $short if length $short <= $compactDump;
  87.   }
  88.   undef;
  89. }
  90.  
  91. sub DumpElem {
  92.   my $short = &stringify($_[0], ref $_[0]);
  93.   if ($veryCompact && ref $_[0]
  94.       && (ref $_[0] eq 'ARRAY' and !grep(ref $_, @{$_[0]}) )) {
  95.     my $end = "0..$#{$v}  '" . 
  96.       join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore";
  97.   } elsif ($veryCompact && ref $_[0]
  98.       && (ref $_[0] eq 'HASH') and !grep(ref $_, values %{$_[0]})) {
  99.     my $end = 1;
  100.       $short = $sp . "0..$#{$v}  '" . 
  101.         join("' '", @{$v}[0..$tArrayDepth]) . "'$shortmore";
  102.   } else {
  103.     print "$short\n";
  104.     unwrap($_[0],$_[1]);
  105.   }
  106. }
  107.  
  108. sub unwrap {
  109.     return if $DB::signal;
  110.     local($v) = shift ; 
  111.     local($s) = shift ; # extra no of spaces
  112.     local(%v,@v,$sp,$value,$key,$type,@sortKeys,$more,$shortmore,$short) ;
  113.     local($tHashDepth,$tArrayDepth) ;
  114.  
  115.     $sp = " " x $s ;
  116.     $s += 3 ; 
  117.  
  118.     # Check for reused addresses
  119.     if (ref $v) { 
  120.       ($address) = $v =~ /(0x[0-9a-f]+)\)$/ ; 
  121.       if (defined $address) { 
  122.     ($type) = $v =~ /=(.*?)\([^=]+$/ ;
  123.     $address{$address}++ ;
  124.     if ( $address{$address} > 1 ) { 
  125.       print "${sp}-> REUSED_ADDRESS\n" ; 
  126.       return ; 
  127.     } 
  128.       }
  129.     } elsif (ref \$v eq 'GLOB') {
  130.       $address = "$v" . "";    # To avoid a bug with globs
  131.       $address{$address}++ ;
  132.       if ( $address{$address} > 1 ) { 
  133.     print "${sp}*DUMPED_GLOB*\n" ; 
  134.     return ; 
  135.       } 
  136.     }
  137.  
  138.     if ( UNIVERSAL::isa($v, 'HASH') ) { 
  139.     @sortKeys = sort keys(%$v) ;
  140.     undef $more ; 
  141.     $tHashDepth = $#sortKeys ; 
  142.     $tHashDepth = $#sortKeys < $hashDepth-1 ? $#sortKeys : $hashDepth-1
  143.       unless $hashDepth eq '' ; 
  144.     $more = "....\n" if $tHashDepth < $#sortKeys ; 
  145.     $shortmore = "";
  146.     $shortmore = ", ..." if $tHashDepth < $#sortKeys ; 
  147.     $#sortKeys = $tHashDepth ; 
  148.     if ($compactDump && !grep(ref $_, values %{$v})) {
  149.       #$short = $sp . 
  150.       #  (join ', ', 
  151. # Next row core dumps during require from DB on 5.000, even with map {"_"}
  152.       #   map {&stringify($_) . " => " . &stringify($v->{$_})} 
  153.       #   @sortKeys) . "'$shortmore";
  154.       $short = $sp;
  155.       my @keys;
  156.       for (@sortKeys) {
  157.         push @keys, &stringify($_) . " => " . &stringify($v->{$_});
  158.       }
  159.       $short .= join ', ', @keys;
  160.       $short .= $shortmore;
  161.       (print "$short\n"), return if length $short <= $compactDump;
  162.     }
  163.     for $key (@sortKeys) {
  164.         return if $DB::signal;
  165.         $value = $ {$v}{$key} ;
  166.         print "$sp", &stringify($key), " => ";
  167.         DumpElem $value, $s;
  168.     }
  169.     print "$sp  empty hash\n" unless @sortKeys;
  170.     print "$sp$more" if defined $more ;
  171.     } elsif ( UNIVERSAL::isa($v, 'ARRAY') ) { 
  172.     $tArrayDepth = $#{$v} ; 
  173.     undef $more ; 
  174.     $tArrayDepth = $#{$v} < $arrayDepth-1 ? $#{$v} : $arrayDepth-1 
  175.       unless  $arrayDepth eq '' ; 
  176.     $more = "....\n" if $tArrayDepth < $#{$v} ; 
  177.     $shortmore = "";
  178.     $shortmore = " ..." if $tArrayDepth < $#{$v} ;
  179.     if ($compactDump && !grep(ref $_, @{$v})) {
  180.       if ($#$v >= 0) {
  181.         $short = $sp . "0..$#{$v}  " . 
  182.           join(" ", 
  183.            map {stringify $_} @{$v}[0..$tArrayDepth])
  184.         . "$shortmore";
  185.       } else {
  186.         $short = $sp . "empty array";
  187.       }
  188.       (print "$short\n"), return if length $short <= $compactDump;
  189.     }
  190.     #if ($compactDump && $short = ShortArray($v)) {
  191.     #  print "$short\n";
  192.     #  return;
  193.     #}
  194.     for $num ($[ .. $tArrayDepth) {
  195.         return if $DB::signal;
  196.         print "$sp$num  ";
  197.         DumpElem $v->[$num], $s;
  198.     }
  199.     print "$sp  empty array\n" unless @$v;
  200.     print "$sp$more" if defined $more ;  
  201.     } elsif (  UNIVERSAL::isa($v, 'SCALAR') or ref $v eq 'REF' ) { 
  202.         print "$sp-> ";
  203.         DumpElem $$v, $s;
  204.     } elsif ( UNIVERSAL::isa($v, 'CODE') ) { 
  205.         print "$sp-> ";
  206.         dumpsub (0, $v);
  207.     } elsif ( UNIVERSAL::isa($v, 'GLOB') ) {
  208.       print "$sp-> ",&stringify($$v,1),"\n";
  209.       if ($globPrint) {
  210.     $s += 3;
  211.     dumpglob($s, "{$$v}", $$v, 1);
  212.       } elsif (defined ($fileno = fileno($v))) {
  213.     print( (' ' x ($s+3)) .  "FileHandle({$$v}) => fileno($fileno)\n" );
  214.       }
  215.     } elsif (ref \$v eq 'GLOB') {
  216.       if ($globPrint) {
  217.     dumpglob($s, "{$v}", $v, 1) if $globPrint;
  218.       } elsif (defined ($fileno = fileno(\$v))) {
  219.     print( (' ' x $s) .  "FileHandle({$v}) => fileno($fileno)\n" );
  220.       }
  221.     }
  222. }
  223.  
  224. sub matchvar {
  225.   $_[0] eq $_[1] or 
  226.     ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and 
  227.       ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/});
  228. }
  229.  
  230. sub compactDump {
  231.   $compactDump = shift if @_;
  232.   $compactDump = 6*80-1 if $compactDump and $compactDump < 2;
  233.   $compactDump;
  234. }
  235.  
  236. sub veryCompact {
  237.   $veryCompact = shift if @_;
  238.   compactDump(1) if !$compactDump and $veryCompact;
  239.   $veryCompact;
  240. }
  241.  
  242. sub unctrlSet {
  243.   if (@_) {
  244.     my $in = shift;
  245.     if ($in eq 'unctrl' or $in eq 'quote') {
  246.       $unctrl = $in;
  247.     } else {
  248.       print "Unknown value for `unctrl'.\n";
  249.     }
  250.   }
  251.   $unctrl;
  252. }
  253.  
  254. sub quote {
  255.   if (@_ and $_[0] eq '"') {
  256.     $tick = '"';
  257.     $unctrl = 'quote';
  258.   } elsif (@_ and $_[0] eq 'auto') {
  259.     $tick = 'auto';
  260.     $unctrl = 'quote';
  261.   } elsif (@_) {        # Need to set
  262.     $tick = "'";
  263.     $unctrl = 'unctrl';
  264.   }
  265.   $tick;
  266. }
  267.  
  268. sub dumpglob {
  269.     return if $DB::signal;
  270.     my ($off,$key, $val, $all) = @_;
  271.     local(*entry) = $val;
  272.     my $fileno;
  273.     if (($key !~ /^_</ or $dumpDBFiles) and defined $entry) {
  274.       print( (' ' x $off) . "\$", &unctrl($key), " = " );
  275.       DumpElem $entry, 3+$off;
  276.     }
  277.     if (($key !~ /^_</ or $dumpDBFiles) and defined @entry) {
  278.       print( (' ' x $off) . "\@$key = (\n" );
  279.       unwrap(\@entry,3+$off) ;
  280.       print( (' ' x $off) .  ")\n" );
  281.     }
  282.     if ($key ne "main::" && $key ne "DB::" && defined %entry
  283.     && ($dumpPackages or $key !~ /::$/)
  284.     && ($key !~ /^_</ or $dumpDBFiles)
  285.     && !($package eq "dumpvar" and $key eq "stab")) {
  286.       print( (' ' x $off) . "\%$key = (\n" );
  287.       unwrap(\%entry,3+$off) ;
  288.       print( (' ' x $off) .  ")\n" );
  289.     }
  290.     if (defined ($fileno = fileno(*entry))) {
  291.       print( (' ' x $off) .  "FileHandle($key) => fileno($fileno)\n" );
  292.     }
  293.     if ($all) {
  294.       if (defined &entry) {
  295.     dumpsub($off, $key);
  296.       }
  297.     }
  298. }
  299.  
  300. sub dumpsub {
  301.     my ($off,$sub) = @_;
  302.     $sub = $1 if $sub =~ /^\{\*(.*)\}$/;
  303.     my $subref = \&$sub;
  304.     my $place = $DB::sub{$sub} || (($sub = $subs{"$subref"}) && $DB::sub{$sub})
  305.       || ($subdump && ($sub = findsubs("$subref")) && $DB::sub{$sub});
  306.     $place = '???' unless defined $place;
  307.     print( (' ' x $off) .  "&$sub in $place\n" );
  308. }
  309.  
  310. sub findsubs {
  311.   return undef unless defined %DB::sub;
  312.   my ($addr, $name, $loc);
  313.   while (($name, $loc) = each %DB::sub) {
  314.     $addr = \&$name;
  315.     $subs{"$addr"} = $name;
  316.   }
  317.   $subdump = 0;
  318.   $subs{ shift() };
  319. }
  320.  
  321. sub main::dumpvar {
  322.     my ($package,@vars) = @_;
  323.     local(%address,$key,$val,$^W);
  324.     $package .= "::" unless $package =~ /::$/;
  325.     *stab = *{"main::"};
  326.     while ($package =~ /(\w+?::)/g){
  327.       *stab = $ {stab}{$1};
  328.     }
  329.     local $TotalStrings = 0;
  330.     local $Strings = 0;
  331.     local $CompleteTotal = 0;
  332.     while (($key,$val) = each(%stab)) {
  333.       return if $DB::signal;
  334.       next if @vars && !grep( matchvar($key, $_), @vars );
  335.       if ($usageOnly) {
  336.     globUsage(\$val, $key) unless $package eq 'dumpvar' and $key eq 'stab';
  337.       } else {
  338.     dumpglob(0,$key, $val);
  339.       }
  340.     }
  341.     if ($usageOnly) {
  342.       print "String space: $TotalStrings bytes in $Strings strings.\n";
  343.       $CompleteTotal += $TotalStrings;
  344.       print "Grand total = $CompleteTotal bytes (1 level deep) + overhead.\n";
  345.     }
  346. }
  347.  
  348. sub scalarUsage {
  349.   my $size = length($_[0]);
  350.   $TotalStrings += $size;
  351.   $Strings++;
  352.   $size;
  353. }
  354.  
  355. sub arrayUsage {        # array ref, name
  356.   my $size = 0;
  357.   map {$size += scalarUsage($_)} @{$_[0]};
  358.   my $len = @{$_[0]};
  359.   print "\@$_[1] = $len item", ($len > 1 ? "s" : ""),
  360.     " (data: $size bytes)\n"
  361.       if defined $_[1];
  362.   $CompleteTotal +=  $size;
  363.   $size;
  364. }
  365.  
  366. sub hashUsage {        # hash ref, name
  367.   my @keys = keys %{$_[0]};
  368.   my @values = values %{$_[0]};
  369.   my $keys = arrayUsage \@keys;
  370.   my $values = arrayUsage \@values;
  371.   my $len = @keys;
  372.   my $total = $keys + $values;
  373.   print "\%$_[1] = $len item", ($len > 1 ? "s" : ""),
  374.     " (keys: $keys; values: $values; total: $total bytes)\n"
  375.       if defined $_[1];
  376.   $total;
  377. }
  378.  
  379. sub globUsage {            # glob ref, name
  380.   local *name = *{$_[0]};
  381.   $total = 0;
  382.   $total += scalarUsage $name if defined $name;
  383.   $total += arrayUsage \@name, $_[1] if defined @name;
  384.   $total += hashUsage \%name, $_[1] if defined %name and $_[1] ne "main::" 
  385.     and $_[1] ne "DB::";   #and !($package eq "dumpvar" and $key eq "stab"));
  386.   $total;
  387. }
  388.  
  389. sub packageUsage {
  390.   my ($package,@vars) = @_;
  391.   $package .= "::" unless $package =~ /::$/;
  392.   local *stab = *{"main::"};
  393.   while ($package =~ /(\w+?::)/g){
  394.     *stab = $ {stab}{$1};
  395.   }
  396.   local $TotalStrings = 0;
  397.   local $CompleteTotal = 0;
  398.   my ($key,$val);
  399.   while (($key,$val) = each(%stab)) {
  400.     next if @vars && !grep($key eq $_,@vars);
  401.     globUsage \$val, $key unless $package eq 'dumpvar' and $key eq 'stab';
  402.   }
  403.   print "String space: $TotalStrings.\n";
  404.   $CompleteTotal += $TotalStrings;
  405.   print "\nGrand total = $CompleteTotal bytes\n";
  406. }
  407.  
  408. 1;
  409.  
  410.