home *** CD-ROM | disk | FTP | other *** search
/ BURKS 2 / BURKS_AUG97.ISO / SLAKWARE / D12 / PERL1.TGZ / perl1.tar / usr / lib / perl5 / dumpvar.pl < prev    next >
Perl Script  |  1996-06-28  |  11KB  |  409 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.   (print "undef\n"), return unless defined $_[0];
  29.   (print &stringify($_[0]), "\n"), return unless ref $_[0];
  30.   dumpvar::unwrap($_[0],0);
  31. }
  32.  
  33. # This one is good for variable names:
  34.  
  35. sub unctrl {
  36.     local($_) = @_;
  37.     local($v) ; 
  38.  
  39.     return \$_ if ref \$_ eq "GLOB";
  40.     s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
  41.     $_;
  42. }
  43.  
  44. sub stringify {
  45.     local($_,$noticks) = @_;
  46.     local($v) ; 
  47.     my $tick = $tick;
  48.  
  49.     return 'undef' unless defined $_ or not $printUndef;
  50.     return $_ . "" if ref \$_ eq 'GLOB';
  51.     if ($tick eq 'auto') {
  52.       if (/[\000-\011\013-\037\177]/) {
  53.         $tick = '"';
  54.       }else {
  55.         $tick = "'";
  56.       }
  57.     }
  58.     if ($tick eq "'") {
  59.       s/([\'\\])/\\$1/g;
  60.     } elsif ($unctrl eq 'unctrl') {
  61.       s/([\"\\])/\\$1/g ;
  62.       s/([\000-\037\177])/'^'.pack('c',ord($1)^64)/eg;
  63.       s/([\200-\377])/'\\0x'.sprintf('%2X',ord($1))/eg 
  64.         if $quoteHighBit;
  65.     } elsif ($unctrl eq 'quote') {
  66.       s/([\"\\\$\@])/\\$1/g if $tick eq '"';
  67.       s/\033/\\e/g;
  68.       s/([\000-\037\177])/'\\c'.chr(ord($1)^64)/eg;
  69.     }
  70.     s/([\200-\377])/'\\'.sprintf('%3o',ord($1))/eg if $quoteHighBit;
  71.     ($noticks || /^\d+(\.\d*)?\Z/) 
  72.       ? $_ 
  73.       : $tick . $_ . $tick;
  74. }
  75.  
  76. sub ShortArray {
  77.   my $tArrayDepth = $#{$_[0]} ; 
  78.   $tArrayDepth = $#{$_[0]} < $arrayDepth-1 ? $#{$_[0]} : $arrayDepth-1 
  79.     unless  $arrayDepth eq '' ; 
  80.   my $shortmore = "";
  81.   $shortmore = " ..." if $tArrayDepth < $#{$_[0]} ;
  82.   if (!grep(ref $_, @{$_[0]})) {
  83.     $short = "0..$#{$_[0]}  '" . 
  84.       join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore";
  85.     return $short if length $short <= $compactDump;
  86.   }
  87.   undef;
  88. }
  89.  
  90. sub DumpElem {
  91.   my $short = &stringify($_[0], ref $_[0]);
  92.   if ($veryCompact && ref $_[0]
  93.       && (ref $_[0] eq 'ARRAY' and !grep(ref $_, @{$_[0]}) )) {
  94.     my $end = "0..$#{$v}  '" . 
  95.       join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore";
  96.   } elsif ($veryCompact && ref $_[0]
  97.       && (ref $_[0] eq 'HASH') and !grep(ref $_, values %{$_[0]})) {
  98.     my $end = 1;
  99.       $short = $sp . "0..$#{$v}  '" . 
  100.         join("' '", @{$v}[0..$tArrayDepth]) . "'$shortmore";
  101.   } else {
  102.     print "$short\n";
  103.     unwrap($_[0],$_[1]);
  104.   }
  105. }
  106.  
  107. sub unwrap {
  108.     return if $DB::signal;
  109.     local($v) = shift ; 
  110.     local($s) = shift ; # extra no of spaces
  111.     local(%v,@v,$sp,$value,$key,$type,@sortKeys,$more,$shortmore,$short) ;
  112.     local($tHashDepth,$tArrayDepth) ;
  113.  
  114.     $sp = " " x $s ;
  115.     $s += 3 ; 
  116.  
  117.     # Check for reused addresses
  118.     if (ref $v) { 
  119.       ($address) = $v =~ /(0x[0-9a-f]+)/ ; 
  120.       if (defined $address) { 
  121.     ($type) = $v =~ /=(.*?)\(/ ;
  122.     $address{$address}++ ;
  123.     if ( $address{$address} > 1 ) { 
  124.       print "${sp}-> REUSED_ADDRESS\n" ; 
  125.       return ; 
  126.     } 
  127.       }
  128.     } elsif (ref \$v eq 'GLOB') {
  129.       $address = "$v" . "";    # To avoid a bug with globs
  130.       $address{$address}++ ;
  131.       if ( $address{$address} > 1 ) { 
  132.     print "${sp}*DUMPED_GLOB*\n" ; 
  133.     return ; 
  134.       } 
  135.     }
  136.  
  137.     if ( ref $v eq 'HASH' or $type eq 'HASH') { 
  138.     @sortKeys = sort keys(%$v) ;
  139.     undef $more ; 
  140.     $tHashDepth = $#sortKeys ; 
  141.     $tHashDepth = $#sortKeys < $hashDepth-1 ? $#sortKeys : $hashDepth-1
  142.       unless $hashDepth eq '' ; 
  143.     $more = "....\n" if $tHashDepth < $#sortKeys ; 
  144.     $shortmore = "";
  145.     $shortmore = ", ..." if $tHashDepth < $#sortKeys ; 
  146.     $#sortKeys = $tHashDepth ; 
  147.     if ($compactDump && !grep(ref $_, values %{$v})) {
  148.       #$short = $sp . 
  149.       #  (join ', ', 
  150. # Next row core dumps during require from DB on 5.000, even with map {"_"}
  151.       #   map {&stringify($_) . " => " . &stringify($v->{$_})} 
  152.       #   @sortKeys) . "'$shortmore";
  153.       $short = $sp;
  154.       my @keys;
  155.       for (@sortKeys) {
  156.         push @keys, &stringify($_) . " => " . &stringify($v->{$_});
  157.       }
  158.       $short .= join ', ', @keys;
  159.       $short .= $shortmore;
  160.       (print "$short\n"), return if length $short <= $compactDump;
  161.     }
  162.     for $key (@sortKeys) {
  163.         return if $DB::signal;
  164.         $value = $ {$v}{$key} ;
  165.         print "$sp", &stringify($key), " => ";
  166.         DumpElem $value, $s;
  167.     }
  168.     print "$sp  empty hash\n" unless @sortKeys;
  169.     print "$sp$more" if defined $more ;
  170.     } elsif ( ref $v eq 'ARRAY' or $type eq 'ARRAY') { 
  171.     $tArrayDepth = $#{$v} ; 
  172.     undef $more ; 
  173.     $tArrayDepth = $#{$v} < $arrayDepth-1 ? $#{$v} : $arrayDepth-1 
  174.       unless  $arrayDepth eq '' ; 
  175.     $more = "....\n" if $tArrayDepth < $#{$v} ; 
  176.     $shortmore = "";
  177.     $shortmore = " ..." if $tArrayDepth < $#{$v} ;
  178.     if ($compactDump && !grep(ref $_, @{$v})) {
  179.       if ($#$v >= 0) {
  180.         $short = $sp . "0..$#{$v}  " . 
  181.           join(" ", 
  182.            map {stringify $_} @{$v}[0..$tArrayDepth])
  183.         . "$shortmore";
  184.       } else {
  185.         $short = $sp . "empty array";
  186.       }
  187.       (print "$short\n"), return if length $short <= $compactDump;
  188.     }
  189.     #if ($compactDump && $short = ShortArray($v)) {
  190.     #  print "$short\n";
  191.     #  return;
  192.     #}
  193.     for $num ($[ .. $tArrayDepth) {
  194.         return if $DB::signal;
  195.         print "$sp$num  ";
  196.         DumpElem $v->[$num], $s;
  197.     }
  198.     print "$sp  empty array\n" unless @$v;
  199.     print "$sp$more" if defined $more ;  
  200.     } elsif ( ref $v eq 'SCALAR' or ref $v eq 'REF' or $type eq 'SCALAR' ) { 
  201.         print "$sp-> ";
  202.         DumpElem $$v, $s;
  203.     } elsif ( ref $v eq 'CODE' or $type eq 'CODE' ) { 
  204.         print "$sp-> ";
  205.         dumpsub (0, $v);
  206.     } elsif (ref $v eq 'GLOB') {
  207.       print "$sp-> ",&stringify($$v,1),"\n";
  208.       if ($globPrint) {
  209.     $s += 3;
  210.     dumpglob($s, "{$$v}", $$v, 1);
  211.       } elsif (defined ($fileno = fileno($v))) {
  212.     print( (' ' x ($s+3)) .  "FileHandle({$$v}) => fileno($fileno)\n" );
  213.       }
  214.     } elsif (ref \$v eq 'GLOB') {
  215.       if ($globPrint) {
  216.     dumpglob($s, "{$v}", $v, 1) if $globPrint;
  217.       } elsif (defined ($fileno = fileno(\$v))) {
  218.     print( (' ' x $s) .  "FileHandle({$v}) => fileno($fileno)\n" );
  219.       }
  220.     }
  221. }
  222.  
  223. sub matchvar {
  224.   $_[0] eq $_[1] or 
  225.     ($_[1] =~ /^([!~])(.)/) and 
  226.       ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$'/});
  227. }
  228.  
  229. sub compactDump {
  230.   $compactDump = shift if @_;
  231.   $compactDump = 6*80-1 if $compactDump and $compactDump < 2;
  232.   $compactDump;
  233. }
  234.  
  235. sub veryCompact {
  236.   $veryCompact = shift if @_;
  237.   compactDump(1) if !$compactDump and $veryCompact;
  238.   $veryCompact;
  239. }
  240.  
  241. sub unctrlSet {
  242.   if (@_) {
  243.     my $in = shift;
  244.     if ($in eq 'unctrl' or $in eq 'quote') {
  245.       $unctrl = $in;
  246.     } else {
  247.       print "Unknown value for `unctrl'.\n";
  248.     }
  249.   }
  250.   $unctrl;
  251. }
  252.  
  253. sub quote {
  254.   if (@_ and $_[0] eq '"') {
  255.     $tick = '"';
  256.     $unctrl = 'quote';
  257.   } elsif (@_ and $_[0] eq 'auto') {
  258.     $tick = 'auto';
  259.     $unctrl = 'quote';
  260.   } elsif (@_) {        # Need to set
  261.     $tick = "'";
  262.     $unctrl = 'unctrl';
  263.   }
  264.   $tick;
  265. }
  266.  
  267. sub dumpglob {
  268.     return if $DB::signal;
  269.     my ($off,$key, $val, $all) = @_;
  270.     local(*entry) = $val;
  271.     my $fileno;
  272.     if (($key !~ /^_</ or $dumpDBFiles) and defined $entry) {
  273.       print( (' ' x $off) . "\$", &unctrl($key), " = " );
  274.       DumpElem $entry, 3+$off;
  275.     }
  276.     if (($key !~ /^_</ or $dumpDBFiles) and defined @entry) {
  277.       print( (' ' x $off) . "\@$key = (\n" );
  278.       unwrap(\@entry,3+$off) ;
  279.       print( (' ' x $off) .  ")\n" );
  280.     }
  281.     if ($key ne "main::" && $key ne "DB::" && defined %entry
  282.     && ($dumpPackages or $key !~ /::$/)
  283.     && ($key !~ /^_</ or $dumpDBFiles)
  284.     && !($package eq "dumpvar" and $key eq "stab")) {
  285.       print( (' ' x $off) . "\%$key = (\n" );
  286.       unwrap(\%entry,3+$off) ;
  287.       print( (' ' x $off) .  ")\n" );
  288.     }
  289.     if (defined ($fileno = fileno(*entry))) {
  290.       print( (' ' x $off) .  "FileHandle($key) => fileno($fileno)\n" );
  291.     }
  292.     if ($all) {
  293.       if (defined &entry) {
  294.     dumpsub($off, $key);
  295.       }
  296.     }
  297. }
  298.  
  299. sub dumpsub {
  300.     my ($off,$sub) = @_;
  301.     $sub = $1 if $sub =~ /^\{\*(.*)\}$/;
  302.     my $subref = \&$sub;
  303.     my $place = $DB::sub{$sub} || (($sub = $subs{"$subref"}) && $DB::sub{$su