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