source: trunk/third/perl/lib/dumpvar.pl @ 18450

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