xref: /openbsd/gnu/usr.bin/perl/lib/dumpvar.pl (revision d89ec533) 
1require 5.014;			# For more reliable $@ after eval
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
17sub 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
30my $APC = chr utf8::unicode_to_native(0x9F);
31my $backslash_c_question = (ASCII) ? '\177' : $APC;
32
33sub 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
44sub 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
55sub uniescape {
56    join("",
57	 map { $_ > 255 ? sprintf("\\x{%04X}", $_) : chr($_) }
58	     unpack("W*", $_[0]));
59}
60
61sub stringify {
62  my $string;
63  if (eval { $string = _stringify(@_); 1 }) {
64    return $string;
65  }
66
67  return "<< value could not be dumped: $@ >>";
68}
69
70sub _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 \\
111sub _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
123sub 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
137sub 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
154sub 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
327sub 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
334sub matchvar {
335  $_[0] eq $_[1] or
336    ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and
337      ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/});
338}
339
340sub compactDump {
341  $compactDump = shift if @_;
342  $compactDump = 6*80-1 if $compactDump and $compactDump < 2;
343  $compactDump;
344}
345
346sub veryCompact {
347  $veryCompact = shift if @_;
348  compactDump(1) if !$compactDump and $veryCompact;
349  $veryCompact;
350}
351
352sub 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
364sub 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
378sub 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
410sub 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
440sub 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
449sub 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
463sub 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
474sub 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
503sub scalarUsage {
504  my $size = length($_[0]);
505  $TotalStrings += $size;
506  $Strings++;
507  $size;
508}
509
510sub 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
521sub 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
534sub 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
544sub 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
5631;
564
565