xref: /openbsd-src/gnu/usr.bin/perl/dist/Dumpvalue/lib/Dumpvalue.pm (revision f2da64fbbbf1b03f09f390ab01267c93dfd77c4c) 
1use 5.006_001;			# for (defined ref) and $#$v and our
2package Dumpvalue;
3use strict;
4our $VERSION = '1.17';
5our(%address, $stab, @stab, %stab, %subs);
6
7# documentation nits, handle complex data structures better by chromatic
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# (IZ) changes for objectification:
16#   c) quote() renamed to method set_quote();
17#   d) unctrlSet() renamed to method set_unctrl();
18#   f) Compiles with 'use strict', but in two places no strict refs is needed:
19#      maybe more problems are waiting...
20
21my %defaults = (
22		globPrint	      => 0,
23		printUndef	      => 1,
24		tick		      => "auto",
25		unctrl		      => 'quote',
26		subdump		      => 1,
27		dumpReused	      => 0,
28		bareStringify	      => 1,
29		hashDepth	      => '',
30		arrayDepth	      => '',
31		dumpDBFiles	      => '',
32		dumpPackages	      => '',
33		quoteHighBit	      => '',
34		usageOnly	      => '',
35		compactDump	      => '',
36		veryCompact	      => '',
37		stopDbSignal	      => '',
38	       );
39
40sub new {
41  my $class = shift;
42  my %opt = (%defaults, @_);
43  bless \%opt, $class;
44}
45
46sub set {
47  my $self = shift;
48  my %opt = @_;
49  @$self{keys %opt} = values %opt;
50}
51
52sub get {
53  my $self = shift;
54  wantarray ? @$self{@_} : $$self{pop @_};
55}
56
57sub dumpValue {
58  my $self = shift;
59  die "usage: \$dumper->dumpValue(value)" unless @_ == 1;
60  local %address;
61  local $^W=0;
62  (print "undef\n"), return unless defined $_[0];
63  (print $self->stringify($_[0]), "\n"), return unless ref $_[0];
64  $self->unwrap($_[0],0);
65}
66
67sub dumpValues {
68  my $self = shift;
69  local %address;
70  local $^W=0;
71  (print "undef\n"), return unless defined $_[0];
72  $self->unwrap(\@_,0);
73}
74
75# This one is good for variable names:
76
77sub unctrl {
78  local($_) = @_;
79
80  return \$_ if ref \$_ eq "GLOB";
81  s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
82  $_;
83}
84
85sub stringify {
86  my $self = shift;
87  local $_ = shift;
88  my $noticks = shift;
89  my $tick = $self->{tick};
90
91  return 'undef' unless defined $_ or not $self->{printUndef};
92  return $_ . "" if ref \$_ eq 'GLOB';
93  { no strict 'refs';
94    $_ = &{'overload::StrVal'}($_)
95      if $self->{bareStringify} and ref $_
96	and %overload:: and defined &{'overload::StrVal'};
97  }
98
99  if ($tick eq 'auto') {
100    if (/[\000-\011\013-\037\177]/) {
101      $tick = '"';
102    } else {
103      $tick = "'";
104    }
105  }
106  if ($tick eq "'") {
107    s/([\'\\])/\\$1/g;
108  } elsif ($self->{unctrl} eq 'unctrl') {
109    s/([\"\\])/\\$1/g ;
110    s/([\000-\037\177])/'^'.pack('c',ord($1)^64)/eg;
111    s/([\200-\377])/'\\0x'.sprintf('%2X',ord($1))/eg
112      if $self->{quoteHighBit};
113  } elsif ($self->{unctrl} eq 'quote') {
114    s/([\"\\\$\@])/\\$1/g if $tick eq '"';
115    s/\033/\\e/g;
116    s/([\000-\037\177])/'\\c'.chr(ord($1)^64)/eg;
117  }
118  s/([\200-\377])/'\\'.sprintf('%3o',ord($1))/eg if $self->{quoteHighBit};
119  ($noticks || /^\d+(\.\d*)?\Z/)
120    ? $_
121      : $tick . $_ . $tick;
122}
123
124sub DumpElem {
125  my ($self, $v) = (shift, shift);
126  my $short = $self->stringify($v, ref $v);
127  my $shortmore = '';
128  if ($self->{veryCompact} && ref $v
129      && (ref $v eq 'ARRAY' and !grep(ref $_, @$v) )) {
130    my $depth = $#$v;
131    ($shortmore, $depth) = (' ...', $self->{arrayDepth} - 1)
132      if $self->{arrayDepth} and $depth >= $self->{arrayDepth};
133    my @a = map $self->stringify($_), @$v[0..$depth];
134    print "0..$#{$v}  @a$shortmore\n";
135  } elsif ($self->{veryCompact} && ref $v
136	   && (ref $v eq 'HASH') and !grep(ref $_, values %$v)) {
137    my @a = sort keys %$v;
138    my $depth = $#a;
139    ($shortmore, $depth) = (' ...', $self->{hashDepth} - 1)
140      if $self->{hashDepth} and $depth >= $self->{hashDepth};
141    my @b = map {$self->stringify($_) . " => " . $self->stringify($$v{$_})}
142      @a[0..$depth];
143    local $" = ', ';
144    print "@b$shortmore\n";
145  } else {
146    print "$short\n";
147    $self->unwrap($v,shift);
148  }
149}
150
151sub unwrap {
152  my $self = shift;
153  return if $DB::signal and $self->{stopDbSignal};
154  my ($v) = shift ;
155  my ($s) = shift ;		# extra no of spaces
156  my $sp;
157  my (%v,@v,$address,$short,$fileno);
158
159  $sp = " " x $s ;
160  $s += 3 ;
161
162  # Check for reused addresses
163  if (ref $v) {
164    my $val = $v;
165    { no strict 'refs';
166      $val = &{'overload::StrVal'}($v)
167	if %overload:: and defined &{'overload::StrVal'};
168    }
169    ($address) = $val =~ /(0x[0-9a-f]+)\)$/ ;
170    if (!$self->{dumpReused} && defined $address) {
171      $address{$address}++ ;
172      if ( $address{$address} > 1 ) {
173	print "${sp}-> REUSED_ADDRESS\n" ;
174	return ;
175      }
176    }
177  } elsif (ref \$v eq 'GLOB') {
178    $address = "$v" . "";	# To avoid a bug with globs
179    $address{$address}++ ;
180    if ( $address{$address} > 1 ) {
181      print "${sp}*DUMPED_GLOB*\n" ;
182      return ;
183    }
184  }
185
186  if (ref $v eq 'Regexp') {
187    my $re = "$v";
188    $re =~ s,/,\\/,g;
189    print "$sp-> qr/$re/\n";
190    return;
191  }
192
193  if ( UNIVERSAL::isa($v, 'HASH') ) {
194    my @sortKeys = sort keys(%$v) ;
195    my $more;
196    my $tHashDepth = $#sortKeys ;
197    $tHashDepth = $#sortKeys < $self->{hashDepth}-1 ? $#sortKeys : $self->{hashDepth}-1
198      unless $self->{hashDepth} eq '' ;
199    $more = "....\n" if $tHashDepth < $#sortKeys ;
200    my $shortmore = "";
201    $shortmore = ", ..." if $tHashDepth < $#sortKeys ;
202    $#sortKeys = $tHashDepth ;
203    if ($self->{compactDump} && !grep(ref $_, values %{$v})) {
204      $short = $sp;
205      my @keys;
206      for (@sortKeys) {
207	push @keys, $self->stringify($_) . " => " . $self->stringify($v->{$_});
208      }
209      $short .= join ', ', @keys;
210      $short .= $shortmore;
211      (print "$short\n"), return if length $short <= $self->{compactDump};
212    }
213    for my $key (@sortKeys) {
214      return if $DB::signal and $self->{stopDbSignal};
215      my $value = $ {$v}{$key} ;
216      print $sp, $self->stringify($key), " => ";
217      $self->DumpElem($value, $s);
218    }
219    print "$sp  empty hash\n" unless @sortKeys;
220    print "$sp$more" if defined $more ;
221  } elsif ( UNIVERSAL::isa($v, 'ARRAY') ) {
222    my $tArrayDepth = $#{$v} ;
223    my $more ;
224    $tArrayDepth = $#$v < $self->{arrayDepth}-1 ? $#$v : $self->{arrayDepth}-1
225      unless  $self->{arrayDepth} eq '' ;
226    $more = "....\n" if $tArrayDepth < $#{$v} ;
227    my $shortmore = "";
228    $shortmore = " ..." if $tArrayDepth < $#{$v} ;
229    if ($self->{compactDump} && !grep(ref $_, @{$v})) {
230      if ($#$v >= 0) {
231	$short = $sp . "0..$#{$v}  " .
232	  join(" ",
233	       map {exists $v->[$_] ? $self->stringify($v->[$_]) : "empty"} (0..$tArrayDepth)
234	      ) . "$shortmore";
235      } else {
236	$short = $sp . "empty array";
237      }
238      (print "$short\n"), return if length $short <= $self->{compactDump};
239    }
240    for my $num (0 .. $tArrayDepth) {
241      return if $DB::signal and $self->{stopDbSignal};
242      print "$sp$num  ";
243      if (exists $v->[$num]) {
244        $self->DumpElem($v->[$num], $s);
245      } else {
246	print "empty slot\n";
247      }
248    }
249    print "$sp  empty array\n" unless @$v;
250    print "$sp$more" if defined $more ;
251  } elsif (  UNIVERSAL::isa($v, 'SCALAR') or ref $v eq 'REF' ) {
252    print "$sp-> ";
253    $self->DumpElem($$v, $s);
254  } elsif ( UNIVERSAL::isa($v, 'CODE') ) {
255    print "$sp-> ";
256    $self->dumpsub(0, $v);
257  } elsif ( UNIVERSAL::isa($v, 'GLOB') ) {
258    print "$sp-> ",$self->stringify($$v,1),"\n";
259    if ($self->{globPrint}) {
260      $s += 3;
261      $self->dumpglob('', $s, "{$$v}", $$v, 1);
262    } elsif (defined ($fileno = fileno($v))) {
263      print( (' ' x ($s+3)) .  "FileHandle({$$v}) => fileno($fileno)\n" );
264    }
265  } elsif (ref \$v eq 'GLOB') {
266    if ($self->{globPrint}) {
267      $self->dumpglob('', $s, "{$v}", $v, 1);
268    } elsif (defined ($fileno = fileno(\$v))) {
269      print( (' ' x $s) .  "FileHandle({$v}) => fileno($fileno)\n" );
270    }
271  }
272}
273
274sub matchvar {
275  $_[0] eq $_[1] or
276    ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and
277      ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/});
278}
279
280sub compactDump {
281  my $self = shift;
282  $self->{compactDump} = shift if @_;
283  $self->{compactDump} = 6*80-1
284    if $self->{compactDump} and $self->{compactDump} < 2;
285  $self->{compactDump};
286}
287
288sub veryCompact {
289  my $self = shift;
290  $self->{veryCompact} = shift if @_;
291  $self->compactDump(1) if !$self->{compactDump} and $self->{veryCompact};
292  $self->{veryCompact};
293}
294
295sub set_unctrl {
296  my $self = shift;
297  if (@_) {
298    my $in = shift;
299    if ($in eq 'unctrl' or $in eq 'quote') {
300      $self->{unctrl} = $in;
301    } else {
302      print "Unknown value for 'unctrl'.\n";
303    }
304  }
305  $self->{unctrl};
306}
307
308sub set_quote {
309  my $self = shift;
310  if (@_ and $_[0] eq '"') {
311    $self->{tick} = '"';
312    $self->{unctrl} = 'quote';
313  } elsif (@_ and $_[0] eq 'auto') {
314    $self->{tick} = 'auto';
315    $self->{unctrl} = 'quote';
316  } elsif (@_) {		# Need to set
317    $self->{tick} = "'";
318    $self->{unctrl} = 'unctrl';
319  }
320  $self->{tick};
321}
322
323sub dumpglob {
324  my $self = shift;
325  return if $DB::signal and $self->{stopDbSignal};
326  my ($package, $off, $key, $val, $all) = @_;
327  local(*stab) = $val;
328  my $fileno;
329  if (($key !~ /^_</ or $self->{dumpDBFiles}) and defined $stab) {
330    print( (' ' x $off) . "\$", &unctrl($key), " = " );
331    $self->DumpElem($stab, 3+$off);
332  }
333  if (($key !~ /^_</ or $self->{dumpDBFiles}) and @stab) {
334    print( (' ' x $off) . "\@$key = (\n" );
335    $self->unwrap(\@stab,3+$off) ;
336    print( (' ' x $off) .  ")\n" );
337  }
338  if ($key ne "main::" && $key ne "DB::" && %stab
339      && ($self->{dumpPackages} or $key !~ /::$/)
340      && ($key !~ /^_</ or $self->{dumpDBFiles})
341      && !($package eq "Dumpvalue" and $key eq "stab")) {
342    print( (' ' x $off) . "\%$key = (\n" );
343    $self->unwrap(\%stab,3+$off) ;
344    print( (' ' x $off) .  ")\n" );
345  }
346  if (defined ($fileno = fileno(*stab))) {
347    print( (' ' x $off) .  "FileHandle($key) => fileno($fileno)\n" );
348  }
349  if ($all) {
350    if (defined &stab) {
351      $self->dumpsub($off, $key);
352    }
353  }
354}
355
356sub CvGV_name {
357  my $self = shift;
358  my $in = shift;
359  return if $self->{skipCvGV};	# Backdoor to avoid problems if XS broken...
360  $in = \&$in;			# Hard reference...
361  eval {require Devel::Peek; 1} or return;
362  my $gv = Devel::Peek::CvGV($in) or return;
363  *$gv{PACKAGE} . '::' . *$gv{NAME};
364}
365
366sub dumpsub {
367  my $self = shift;
368  my ($off,$sub) = @_;
369  my $ini = $sub;
370  my $s;
371  $sub = $1 if $sub =~ /^\{\*(.*)\}$/;
372  my $subref = defined $1 ? \&$sub : \&$ini;
373  my $place = $DB::sub{$sub} || (($s = $subs{"$subref"}) && $DB::sub{$s})
374    || (($s = $self->CvGV_name($subref)) && $DB::sub{$s})
375    || ($self->{subdump} && ($s = $self->findsubs("$subref"))
376	&& $DB::sub{$s});
377  $s = $sub unless defined $s;
378  $place = '???' unless defined $place;
379  print( (' ' x $off) .  "&$s in $place\n" );
380}
381
382sub findsubs {
383  my $self = shift;
384  return undef unless %DB::sub;
385  my ($addr, $name, $loc);
386  while (($name, $loc) = each %DB::sub) {
387    $addr = \&$name;
388    $subs{"$addr"} = $name;
389  }
390  $self->{subdump} = 0;
391  $subs{ shift() };
392}
393
394sub dumpvars {
395  my $self = shift;
396  my ($package,@vars) = @_;
397  local(%address,$^W);
398  my ($key,$val);
399  $package .= "::" unless $package =~ /::$/;
400  *stab = *main::;
401
402  while ($package =~ /(\w+?::)/g) {
403    *stab = $ {stab}{$1};
404  }
405  $self->{TotalStrings} = 0;
406  $self->{Strings} = 0;
407  $self->{CompleteTotal} = 0;
408  while (($key,$val) = each(%stab)) {
409    return if $DB::signal and $self->{stopDbSignal};
410    next if @vars && !grep( matchvar($key, $_), @vars );
411    if ($self->{usageOnly}) {
412      $self->globUsage(\$val, $key)
413	if ($package ne 'Dumpvalue' or $key ne 'stab')
414	   and ref(\$val) eq 'GLOB';
415    } else {
416      $self->dumpglob($package, 0,$key, $val);
417    }
418  }
419  if ($self->{usageOnly}) {
420    print <<EOP;
421String space: $self->{TotalStrings} bytes in $self->{Strings} strings.
422EOP
423    $self->{CompleteTotal} += $self->{TotalStrings};
424    print <<EOP;
425Grand total = $self->{CompleteTotal} bytes (1 level deep) + overhead.
426EOP
427  }
428}
429
430sub scalarUsage {
431  my $self = shift;
432  my $size;
433  if (UNIVERSAL::isa($_[0], 'ARRAY')) {
434	$size = $self->arrayUsage($_[0]);
435  } elsif (UNIVERSAL::isa($_[0], 'HASH')) {
436	$size = $self->hashUsage($_[0]);
437  } elsif (!ref($_[0])) {
438	$size = length($_[0]);
439  }
440  $self->{TotalStrings} += $size;
441  $self->{Strings}++;
442  $size;
443}
444
445sub arrayUsage {		# array ref, name
446  my $self = shift;
447  my $size = 0;
448  map {$size += $self->scalarUsage($_)} @{$_[0]};
449  my $len = @{$_[0]};
450  print "\@$_[1] = $len item", ($len > 1 ? "s" : ""), " (data: $size bytes)\n"
451      if defined $_[1];
452  $self->{CompleteTotal} +=  $size;
453  $size;
454}
455
456sub hashUsage {			# hash ref, name
457  my $self = shift;
458  my @keys = keys %{$_[0]};
459  my @values = values %{$_[0]};
460  my $keys = $self->arrayUsage(\@keys);
461  my $values = $self->arrayUsage(\@values);
462  my $len = @keys;
463  my $total = $keys + $values;
464  print "\%$_[1] = $len item", ($len > 1 ? "s" : ""),
465    " (keys: $keys; values: $values; total: $total bytes)\n"
466      if defined $_[1];
467  $total;
468}
469
470sub globUsage {			# glob ref, name
471  my $self = shift;
472  local *stab = *{$_[0]};
473  my $total = 0;
474  $total += $self->scalarUsage($stab) if defined $stab;
475  $total += $self->arrayUsage(\@stab, $_[1]) if @stab;
476  $total += $self->hashUsage(\%stab, $_[1])
477    if %stab and $_[1] ne "main::" and $_[1] ne "DB::";
478  #and !($package eq "Dumpvalue" and $key eq "stab"));
479  $total;
480}
481
4821;
483
484=head1 NAME
485
486Dumpvalue - provides screen dump of Perl data.
487
488=head1 SYNOPSIS
489
490  use Dumpvalue;
491  my $dumper = Dumpvalue->new;
492  $dumper->set(globPrint => 1);
493  $dumper->dumpValue(\*::);
494  $dumper->dumpvars('main');
495  my $dump = $dumper->stringify($some_value);
496
497=head1 DESCRIPTION
498
499=head2 Creation
500
501A new dumper is created by a call
502
503  $d = Dumpvalue->new(option1 => value1, option2 => value2)
504
505Recognized options:
506
507=over 4
508
509=item C<arrayDepth>, C<hashDepth>
510
511Print only first N elements of arrays and hashes.  If false, prints all the
512elements.
513
514=item C<compactDump>, C<veryCompact>
515
516Change style of array and hash dump.  If true, short array
517may be printed on one line.
518
519=item C<globPrint>
520
521Whether to print contents of globs.
522
523=item C<dumpDBFiles>
524
525Dump arrays holding contents of debugged files.
526
527=item C<dumpPackages>
528
529Dump symbol tables of packages.
530
531=item C<dumpReused>
532
533Dump contents of "reused" addresses.
534
535=item C<tick>, C<quoteHighBit>, C<printUndef>
536
537Change style of string dump.  Default value of C<tick> is C<auto>, one
538can enable either double-quotish dump, or single-quotish by setting it
539to C<"> or C<'>.  By default, characters with high bit set are printed
540I<as is>.  If C<quoteHighBit> is set, they will be quoted.
541
542=item C<usageOnly>
543
544rudimentary per-package memory usage dump.  If set,
545C<dumpvars> calculates total size of strings in variables in the package.
546
547=item unctrl
548
549Changes the style of printout of strings.  Possible values are
550C<unctrl> and C<quote>.
551
552=item subdump
553
554Whether to try to find the subroutine name given the reference.
555
556=item bareStringify
557
558Whether to write the non-overloaded form of the stringify-overloaded objects.
559
560=item quoteHighBit
561
562Whether to print chars with high bit set in binary or "as is".
563
564=item stopDbSignal
565
566Whether to abort printing if debugger signal flag is raised.
567
568=back
569
570Later in the life of the object the methods may be queries with get()
571method and set() method (which accept multiple arguments).
572
573=head2 Methods
574
575=over 4
576
577=item dumpValue
578
579  $dumper->dumpValue($value);
580  $dumper->dumpValue([$value1, $value2]);
581
582Prints a dump to the currently selected filehandle.
583
584=item dumpValues
585
586  $dumper->dumpValues($value1, $value2);
587
588Same as C<< $dumper->dumpValue([$value1, $value2]); >>.
589
590=item stringify
591
592  my $dump = $dumper->stringify($value [,$noticks] );
593
594Returns the dump of a single scalar without printing. If the second
595argument is true, the return value does not contain enclosing ticks.
596Does not handle data structures.
597
598=item dumpvars
599
600  $dumper->dumpvars('my_package');
601  $dumper->dumpvars('my_package', 'foo', '~bar$', '!......');
602
603The optional arguments are considered as literal strings unless they
604start with C<~> or C<!>, in which case they are interpreted as regular
605expressions (possibly negated).
606
607The second example prints entries with names C<foo>, and also entries
608with names which ends on C<bar>, or are shorter than 5 chars.
609
610=item set_quote
611
612  $d->set_quote('"');
613
614Sets C<tick> and C<unctrl> options to suitable values for printout with the
615given quote char.  Possible values are C<auto>, C<'> and C<">.
616
617=item set_unctrl
618
619  $d->set_unctrl('unctrl');
620
621Sets C<unctrl> option with checking for an invalid argument.
622Possible values are C<unctrl> and C<quote>.
623
624=item compactDump
625
626  $d->compactDump(1);
627
628Sets C<compactDump> option.  If the value is 1, sets to a reasonable
629big number.
630
631=item veryCompact
632
633  $d->veryCompact(1);
634
635Sets C<compactDump> and C<veryCompact> options simultaneously.
636
637=item set
638
639  $d->set(option1 => value1, option2 => value2);
640
641=item get
642
643  @values = $d->get('option1', 'option2');
644
645=back
646
647=cut
648
649