"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/lib/dumpvar.pl" (5 Apr 2016, 15555 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

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