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