[Summary view] [Print] [Text view]

   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  $dumpReused = 0 unless defined $dumpReused;
  26  $bareStringify = 1 unless defined $bareStringify;
  27  
  28  sub main::dumpValue {
  29    local %address;
  30    local $^W=0;
  31    (print "undef\n"), return unless defined $_[0];
  32    (print &stringify($_[0]), "\n"), return unless ref $_[0];
  33    push @_, -1 if @_ == 1;
  34    dumpvar::unwrap($_[0], 0, $_[1]);
  35  }
  36  
  37  # This one is good for variable names:
  38  
  39  sub unctrl {
  40      local($_) = @_;
  41      local($v) ; 
  42  
  43      return \$_ if ref \$_ eq "GLOB";
  44          if (ord('A') == 193) { # EBCDIC.
  45          # EBCDIC has no concept of "\cA" or "A" being related
  46          # to each other by a linear/boolean mapping.
  47      } else {
  48          s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
  49      }
  50      $_;
  51  }
  52  
  53  sub uniescape {
  54      join("",
  55       map { $_ > 255 ? sprintf("\\x{%04X}", $_) : chr($_) }
  56           unpack("U*", $_[0]));
  57  }
  58  
  59  sub stringify {
  60      local($_,$noticks) = @_;
  61      local($v) ; 
  62      my $tick = $tick;
  63  
  64      return 'undef' unless defined $_ or not $printUndef;
  65      return $_ . "" if ref \$_ eq 'GLOB';
  66      $_ = &{'overload::StrVal'}($_) 
  67        if $bareStringify and ref $_ 
  68          and %overload:: and defined &{'overload::StrVal'};
  69      
  70      if ($tick eq 'auto') {
  71          if (ord('A') == 193) {
  72          if (/[\000-\011]/ or /[\013-\024\31-\037\177]/) {
  73              $tick = '"';
  74          } else {
  75              $tick = "'";
  76          }
  77              }  else {
  78          if (/[\000-\011\013-\037\177]/) {
  79              $tick = '"';
  80          } else {
  81              $tick = "'";
  82          }
  83          }
  84      }
  85      if ($tick eq "'") {
  86        s/([\'\\])/\\$1/g;
  87      } elsif ($unctrl eq 'unctrl') {
  88        s/([\"\\])/\\$1/g ;
  89        s/([\000-\037\177])/'^'.pack('c',ord($1)^64)/eg;
  90        # uniescape?
  91        s/([\200-\377])/'\\0x'.sprintf('%2X',ord($1))/eg 
  92          if $quoteHighBit;
  93      } elsif ($unctrl eq 'quote') {
  94        s/([\"\\\$\@])/\\$1/g if $tick eq '"';
  95        s/\033/\\e/g;
  96        if (ord('A') == 193) { # EBCDIC.
  97            s/([\000-\037\177])/'\\c'.chr(193)/eg; # Unfinished.
  98        } else {
  99            s/([\000-\037\177])/'\\c'._escaped_ord($1)/eg;
 100        }
 101      }
 102      $_ = uniescape($_);
 103      s/([\200-\377])/'\\'.sprintf('%3o',ord($1))/eg if $quoteHighBit;
 104      ($noticks || /^\d+(\.\d*)?\Z/) 
 105        ? $_ 
 106        : $tick . $_ . $tick;
 107  }
 108  
 109  # Ensure a resulting \ is escaped to be \\
 110  sub _escaped_ord {
 111      my $chr = shift;
 112      $chr = chr(ord($chr)^64);
 113      $chr =~ s{\\}{\\\\}g;
 114      return $chr;
 115  }
 116  
 117  sub ShortArray {
 118    my $tArrayDepth = $#{$_[0]} ; 
 119    $tArrayDepth = $#{$_[0]} < $arrayDepth-1 ? $#{$_[0]} : $arrayDepth-1 
 120      unless  $arrayDepth eq '' ; 
 121    my $shortmore = "";
 122    $shortmore = " ..." if $tArrayDepth < $#{$_[0]} ;
 123    if (!grep(ref $_, @{$_[0]})) {
 124      $short = "0..$#{$_[0]}  '" . 
 125        join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore";
 126      return $short if length $short <= $compactDump;
 127    }
 128    undef;
 129  }
 130  
 131  sub DumpElem {
 132    my $short = &stringify($_[0], ref $_[0]);
 133    if ($veryCompact && ref $_[0]
 134        && (ref $_[0] eq 'ARRAY' and !grep(ref $_, @{$_[0]}) )) {
 135      my $end = "0..$#{$v}  '" . 
 136        join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore";
 137    } elsif ($veryCompact && ref $_[0]
 138        && (ref $_[0] eq 'HASH') and !grep(ref $_, values %{$_[0]})) {
 139      my $end = 1;
 140        $short = $sp . "0..$#{$v}  '" . 
 141          join("' '", @{$v}[0..$tArrayDepth]) . "'$shortmore";
 142    } else {
 143      print "$short\n";
 144      unwrap($_[0],$_[1],$_[2]) if ref $_[0];
 145    }
 146  }
 147  
 148  sub unwrap {
 149      return if $DB::signal;
 150      local($v) = shift ; 
 151      local($s) = shift ; # extra no of spaces
 152      local($m) = shift ; # maximum recursion depth
 153      return if $m == 0;
 154      local(%v,@v,$sp,$value,$key,@sortKeys,$more,$shortmore,$short) ;
 155      local($tHashDepth,$tArrayDepth) ;
 156  
 157      $sp = " " x $s ;
 158      $s += 3 ; 
 159  
 160      # Check for reused addresses
 161      if (ref $v) { 
 162        my $val = $v;
 163        $val = &{'overload::StrVal'}($v) 
 164      if %overload:: and defined &{'overload::StrVal'};
 165        # Match type and address.                      
 166        # Unblessed references will look like TYPE(0x...)
 167        # Blessed references will look like Class=TYPE(0x...)
 168        ($start_part, $val) = split /=/,$val;
 169        $val = $start_part unless defined $val;
 170        ($item_type, $address) = 
 171          $val =~ /([^\(]+)        # Keep stuff that's     
 172                                   # not an open paren
 173                   \(              # Skip open paren
 174                   (0x[0-9a-f]+)   # Save the address
 175                   \)              # Skip close paren
 176                   $/x;            # Should be at end now
 177  
 178        if (!$dumpReused && defined $address) { 
 179      $address{$address}++ ;
 180      if ( $address{$address} > 1 ) { 
 181        print "$sp}-> REUSED_ADDRESS\n" ; 
 182        return ; 
 183      } 
 184        }
 185      } elsif (ref \$v eq 'GLOB') {
 186        # This is a raw glob. Special handling for that.
 187        $address = "$v" . "";    # To avoid a bug with globs
 188        $address{$address}++ ;
 189        if ( $address{$address} > 1 ) { 
 190      print "$sp}*DUMPED_GLOB*\n" ; 
 191      return ; 
 192        } 
 193      }
 194  
 195      if (ref $v eq 'Regexp') {
 196        # Reformat the regexp to look the standard way.
 197        my $re = "$v";
 198        $re =~ s,/,\\/,g;
 199        print "$sp-> qr/$re/\n";
 200        return;
 201      }
 202  
 203      if ( $item_type eq 'HASH' ) { 
 204          # Hash ref or hash-based object.
 205      my @sortKeys = sort keys(%$v) ;
 206      undef $more ; 
 207      $tHashDepth = $#sortKeys ; 
 208      $tHashDepth = $#sortKeys < $hashDepth-1 ? $#sortKeys : $hashDepth-1
 209        unless $hashDepth eq '' ; 
 210      $more = "....\n" if $tHashDepth < $#sortKeys ; 
 211      $shortmore = "";
 212      $shortmore = ", ..." if $tHashDepth < $#sortKeys ; 
 213      $#sortKeys = $tHashDepth ; 
 214      if ($compactDump && !grep(ref $_, values %{$v})) {
 215        #$short = $sp . 
 216        #  (join ', ', 
 217  # Next row core dumps during require from DB on 5.000, even with map {"_"}
 218        #   map {&stringify($_) . " => " . &stringify($v->{$_})} 
 219        #   @sortKeys) . "'$shortmore";
 220        $short = $sp;
 221        my @keys;
 222        for (@sortKeys) {
 223          push @keys, &stringify($_) . " => " . &stringify($v->{$_});
 224        }
 225        $short .= join ', ', @keys;
 226        $short .= $shortmore;
 227        (print "$short\n"), return if length $short <= $compactDump;
 228      }
 229      for $key (@sortKeys) {
 230          return if $DB::signal;
 231          $value = $ {$v}{$key} ;
 232          print "$sp", &stringify($key), " => ";
 233          DumpElem $value, $s, $m-1;
 234      }
 235      print "$sp  empty hash\n" unless @sortKeys;
 236      print "$sp$more" if defined $more ;
 237      } elsif ( $item_type eq 'ARRAY' ) { 
 238          # Array ref or array-based object. Also: undef.
 239          # See how big the array is.
 240      $tArrayDepth = $#{$v} ; 
 241      undef $more ; 
 242          # Bigger than the max?
 243      $tArrayDepth = $#{$v} < $arrayDepth-1 ? $#{$v} : $arrayDepth-1 
 244        if defined $arrayDepth && $arrayDepth ne '';
 245          # Yep. Don't show it all.
 246      $more = "....\n" if $tArrayDepth < $#{$v} ; 
 247      $shortmore = "";
 248      $shortmore = " ..." if $tArrayDepth < $#{$v} ;
 249  
 250      if ($compactDump && !grep(ref $_, @{$v})) {
 251        if ($#$v >= 0) {
 252          $short = $sp . "0..$#{$v}  " . 
 253            join(" ", 
 254             map {exists $v->[$_] ? stringify $v->[$_] : "empty"} ($[..$tArrayDepth)
 255            ) . "$shortmore";
 256        } else {
 257          $short = $sp . "empty array";
 258        }
 259        (print "$short\n"), return if length $short <= $compactDump;
 260      }
 261      #if ($compactDump && $short = ShortArray($v)) {
 262      #  print "$short\n";
 263      #  return;
 264      #}
 265      for $num ($[ .. $tArrayDepth) {
 266          return if $DB::signal;
 267          print "$sp$num  ";
 268          if (exists $v->[$num]) {
 269                  if (defined $v->[$num]) {
 270                DumpElem $v->[$num], $s, $m-1;
 271                  } 
 272                  else {
 273                    print "undef\n";
 274                  }
 275          } else {
 276              print "empty slot\n";
 277          }
 278      }
 279      print "$sp  empty array\n" unless @$v;
 280      print "$sp$more" if defined $more ;  
 281      } elsif ( $item_type eq 'SCALAR' ) { 
 282              unless (defined $$v) {
 283                print "$sp-> undef\n";
 284                return;
 285              }
 286          print "$sp-> ";
 287          DumpElem $$v, $s, $m-1;
 288      } elsif ( $item_type eq 'REF' ) { 
 289          print "$sp-> $$v\n";
 290              return unless defined $$v;
 291          unwrap($$v, $s+3, $m-1);
 292      } elsif ( $item_type eq 'CODE' ) { 
 293              # Code object or reference.
 294          print "$sp-> ";
 295          dumpsub (0, $v);
 296      } elsif ( $item_type eq 'GLOB' ) {
 297        # Glob object or reference.
 298        print "$sp-> ",&stringify($$v,1),"\n";
 299        if ($globPrint) {
 300      $s += 3;
 301         dumpglob($s, "{$$v}", $$v, 1, $m-1);
 302        } elsif (defined ($fileno = eval {fileno($v)})) {
 303      print( (' ' x ($s+3)) .  "FileHandle({$$v}) => fileno($fileno)\n" );
 304        }
 305      } elsif (ref \$v eq 'GLOB') {
 306        # Raw glob (again?)
 307        if ($globPrint) {
 308         dumpglob($s, "{$v}", $v, 1, $m-1) if $globPrint;
 309        } elsif (defined ($fileno = eval {fileno(\$v)})) {
 310      print( (' ' x $s) .  "FileHandle({$v}) => fileno($fileno)\n" );
 311        }
 312      }
 313  }
 314  
 315  sub matchlex {
 316    (my $var = $_[0]) =~ s/.//;
 317    $var eq $_[1] or 
 318      ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and 
 319        ($1 eq '!') ^ (eval { $var =~ /$2$3/ });
 320  }
 321  
 322  sub matchvar {
 323    $_[0] eq $_[1] or 
 324      ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and 
 325        ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/});
 326  }
 327  
 328  sub compactDump {
 329    $compactDump = shift if @_;
 330    $compactDump = 6*80-1 if $compactDump and $compactDump < 2;
 331    $compactDump;
 332  }
 333  
 334  sub veryCompact {
 335    $veryCompact = shift if @_;
 336    compactDump(1) if !$compactDump and $veryCompact;
 337    $veryCompact;
 338  }
 339  
 340  sub unctrlSet {
 341    if (@_) {
 342      my $in = shift;
 343      if ($in eq 'unctrl' or $in eq 'quote') {
 344        $unctrl = $in;
 345      } else {
 346        print "Unknown value for `unctrl'.\n";
 347      }
 348    }
 349    $unctrl;
 350  }
 351  
 352  sub quote {
 353    if (@_ and $_[0] eq '"') {
 354      $tick = '"';
 355      $unctrl = 'quote';
 356    } elsif (@_ and $_[0] eq 'auto') {
 357      $tick = 'auto';
 358      $unctrl = 'quote';
 359    } elsif (@_) {        # Need to set
 360      $tick = "'";
 361      $unctrl = 'unctrl';
 362    }
 363    $tick;
 364  }
 365  
 366  sub dumpglob {
 367      return if $DB::signal;
 368      my ($off,$key, $val, $all, $m) = @_;
 369      local(*entry) = $val;
 370      my $fileno;
 371      if (($key !~ /^_</ or $dumpDBFiles) and defined $entry) {
 372        print( (' ' x $off) . "\$", &unctrl($key), " = " );
 373        DumpElem $entry, 3+$off, $m;
 374      }
 375      if (($key !~ /^_</ or $dumpDBFiles) and @entry) {
 376        print( (' ' x $off) . "\@$key = (\n" );
 377        unwrap(\@entry,3+$off,$m) ;
 378        print( (' ' x $off) .  ")\n" );
 379      }
 380      if ($key ne "main::" && $key ne "DB::" && %entry
 381      && ($dumpPackages or $key !~ /::$/)
 382      && ($key !~ /^_</ or $dumpDBFiles)
 383      && !($package eq "dumpvar" and $key eq "stab")) {
 384        print( (' ' x $off) . "\%$key = (\n" );
 385        unwrap(\%entry,3+$off,$m) ;
 386        print( (' ' x $off) .  ")\n" );
 387      }
 388      if (defined ($fileno = eval{fileno(*entry)})) {
 389        print( (' ' x $off) .  "FileHandle($key) => fileno($fileno)\n" );
 390      }
 391      if ($all) {
 392        if (defined &entry) {
 393      dumpsub($off, $key);
 394        }
 395      }
 396  }
 397  
 398  sub dumplex {
 399    return if $DB::signal;
 400    my ($key, $val, $m, @vars) = @_;
 401    return if @vars && !grep( matchlex($key, $_), @vars );
 402    local %address;
 403    my $off = 0;  # It reads better this way
 404    my $fileno;
 405    if (UNIVERSAL::isa($val,'ARRAY')) {
 406      print( (' ' x $off) . "$key = (\n" );
 407      unwrap($val,3+$off,$m) ;
 408      print( (' ' x $off) .  ")\n" );
 409    }
 410    elsif (UNIVERSAL::isa($val,'HASH')) {
 411      print( (' ' x $off) . "$key = (\n" );
 412      unwrap($val,3+$off,$m) ;
 413      print( (' ' x $off) .  ")\n" );
 414    }
 415    elsif (UNIVERSAL::isa($val,'IO')) {
 416      print( (' ' x $off) .  "FileHandle($key) => fileno($fileno)\n" );
 417    }
 418    #  No lexical subroutines yet...
 419    #  elsif (UNIVERSAL::isa($val,'CODE')) {
 420    #    dumpsub($off, $$val);
 421    #  }
 422    else {
 423      print( (' ' x $off) . &unctrl($key), " = " );
 424      DumpElem $$val, 3+$off, $m;
 425    }
 426  }
 427  
 428  sub CvGV_name_or_bust {
 429    my $in = shift;
 430    return if $skipCvGV;        # Backdoor to avoid problems if XS broken...
 431    $in = \&$in;            # Hard reference...
 432    eval {require Devel::Peek; 1} or return;
 433    my $gv = Devel::Peek::CvGV($in) or return;
 434    *$gv{PACKAGE} . '::' . *$gv{NAME};
 435  }
 436  
 437  sub dumpsub {
 438      my ($off,$sub) = @_;
 439      my $ini = $sub;
 440      my $s;
 441      $sub = $1 if $sub =~ /^\{\*(.*)\}$/;
 442      my $subref = defined $1 ? \&$sub : \&$ini;
 443      my $place = $DB::sub{$sub} || (($s = $subs{"$subref"}) && $DB::sub{$s})
 444        || (($s = CvGV_name_or_bust($subref)) && $DB::sub{$s})
 445        || ($subdump && ($s = findsubs("$subref")) && $DB::sub{$s});
 446      $place = '???' unless defined $place;
 447      $s = $sub unless defined $s;
 448      print( (' ' x $off) .  "&$s in $place\n" );
 449  }
 450  
 451  sub findsubs {
 452    return undef unless %DB::sub;
 453    my ($addr, $name, $loc);
 454    while (($name, $loc) = each %DB::sub) {
 455      $addr = \&$name;
 456      $subs{"$addr"} = $name;
 457    }
 458    $subdump = 0;
 459    $subs{ shift() };
 460  }
 461  
 462  sub main::dumpvar {
 463      my ($package,$m,@vars) = @_;
 464      local(%address,$key,$val,$^W);
 465      $package .= "::" unless $package =~ /::$/;
 466      *stab = *{"main::"};
 467      while ($package =~ /(\w+?::)/g){
 468        *stab = $ {stab}{$1};
 469      }
 470      local $TotalStrings = 0;
 471      local $Strings = 0;
 472      local $CompleteTotal = 0;
 473      while (($key,$val) = each(%stab)) {
 474        return if $DB::signal;
 475        next if @vars && !grep( matchvar($key, $_), @vars );
 476        if ($usageOnly) {
 477      globUsage(\$val, $key)
 478        if ($package ne 'dumpvar' or $key ne 'stab')
 479           and ref(\$val) eq 'GLOB';
 480        } else {
 481         dumpglob(0,$key, $val, 0, $m);
 482        }
 483      }
 484      if ($usageOnly) {
 485        print "String space: $TotalStrings bytes in $Strings strings.\n";
 486        $CompleteTotal += $TotalStrings;
 487        print "Grand total = $CompleteTotal bytes (1 level deep) + overhead.\n";
 488      }
 489  }
 490  
 491  sub scalarUsage {
 492    my $size = length($_[0]);
 493    $TotalStrings += $size;
 494    $Strings++;
 495    $size;
 496  }
 497  
 498  sub arrayUsage {        # array ref, name
 499    my $size = 0;
 500    map {$size += scalarUsage($_)} @{$_[0]};
 501    my $len = @{$_[0]};
 502    print "\@$_[1] = $len item", ($len > 1 ? "s" : ""),
 503      " (data: $size bytes)\n"
 504        if defined $_[1];
 505    $CompleteTotal +=  $size;
 506    $size;
 507  }
 508  
 509  sub hashUsage {        # hash ref, name
 510    my @keys = keys %{$_[0]};
 511    my @values = values %{$_[0]};
 512    my $keys = arrayUsage \@keys;
 513    my $values = arrayUsage \@values;
 514    my $len = @keys;
 515    my $total = $keys + $values;
 516    print "\%$_[1] = $len item", ($len > 1 ? "s" : ""),
 517      " (keys: $keys; values: $values; total: $total bytes)\n"
 518        if defined $_[1];
 519    $total;
 520  }
 521  
 522  sub globUsage {            # glob ref, name
 523    local *name = *{$_[0]};
 524    $total = 0;
 525    $total += scalarUsage $name if defined $name;
 526    $total += arrayUsage \@name, $_[1] if @name;
 527    $total += hashUsage \%name, $_[1] if %name and $_[1] ne "main::" 
 528      and $_[1] ne "DB::";   #and !($package eq "dumpvar" and $key eq "stab"));
 529    $total;
 530  }
 531  
 532  sub packageUsage {
 533    my ($package,@vars) = @_;
 534    $package .= "::" unless $package =~ /::$/;
 535    local *stab = *{"main::"};
 536    while ($package =~ /(\w+?::)/g){
 537      *stab = $ {stab}{$1};
 538    }
 539    local $TotalStrings = 0;
 540    local $CompleteTotal = 0;
 541    my ($key,$val);
 542    while (($key,$val) = each(%stab)) {
 543      next if @vars && !grep($key eq $_,@vars);
 544      globUsage \$val, $key unless $package eq 'dumpvar' and $key eq 'stab';
 545    }
 546    print "String space: $TotalStrings.\n";
 547    $CompleteTotal += $TotalStrings;
 548    print "\nGrand total = $CompleteTotal bytes\n";
 549  }
 550  
 551  1;
 552