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