extra code in pp_concat, Take 2
[p5sagit/p5-mst-13.2.git] / lib / Dumpvalue.pm
1 use 5.006_001;                  # for (defined ref) and $#$v and our
2 package Dumpvalue;
3 use strict;
4 our $VERSION = '1.11';
5 our(%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
21 my %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
40 sub new {
41   my $class = shift;
42   my %opt = (%defaults, @_);
43   bless \%opt, $class;
44 }
45
46 sub set {
47   my $self = shift;
48   my %opt = @_;
49   @$self{keys %opt} = values %opt;
50 }
51
52 sub get {
53   my $self = shift;
54   wantarray ? @$self{@_} : $$self{pop @_};
55 }
56
57 sub 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
67 sub 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
77 sub unctrl {
78   local($_) = @_;
79
80   return \$_ if ref \$_ eq "GLOB";
81   s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
82   $_;
83 }
84
85 sub 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
124 sub 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
151 sub 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"} ($[..$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 ($[ .. $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
274 sub matchvar {
275   $_[0] eq $_[1] or
276     ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and
277       ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/});
278 }
279
280 sub 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
288 sub 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
295 sub 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
308 sub 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
323 sub 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
356 sub 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
366 sub 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
382 sub 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
394 sub 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;
421 String space: $self->{TotalStrings} bytes in $self->{Strings} strings.
422 EOP
423     $self->{CompleteTotal} += $self->{TotalStrings};
424     print <<EOP;
425 Grand total = $self->{CompleteTotal} bytes (1 level deep) + overhead.
426 EOP
427   }
428 }
429
430 sub 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
445 sub 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
456 sub 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
470 sub 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
482 1;
483
484 =head1 NAME
485
486 Dumpvalue - provides screen dump of Perl data.
487
488 =head1 SYNOPSIS
489
490   use Dumpvalue;
491   my $dumper = new Dumpvalue;
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
501 A new dumper is created by a call
502
503   $d = new Dumpvalue(option1 => value1, option2 => value2)
504
505 Recognized options:
506
507 =over 4
508
509 =item C<arrayDepth>, C<hashDepth>
510
511 Print only first N elements of arrays and hashes.  If false, prints all the
512 elements.
513
514 =item C<compactDump>, C<veryCompact>
515
516 Change style of array and hash dump.  If true, short array
517 may be printed on one line.
518
519 =item C<globPrint>
520
521 Whether to print contents of globs.
522
523 =item C<dumpDBFiles>
524
525 Dump arrays holding contents of debugged files.
526
527 =item C<dumpPackages>
528
529 Dump symbol tables of packages.
530
531 =item C<dumpReused>
532
533 Dump contents of "reused" addresses.
534
535 =item C<tick>, C<quoteHighBit>, C<printUndef>
536
537 Change style of string dump.  Default value of C<tick> is C<auto>, one
538 can enable either double-quotish dump, or single-quotish by setting it
539 to C<"> or C<'>.  By default, characters with high bit set are printed
540 I<as is>.  If C<quoteHighBit> is set, they will be quoted.
541
542 =item C<usageOnly>
543
544 rudimentally per-package memory usage dump.  If set,
545 C<dumpvars> calculates total size of strings in variables in the package.
546
547 =item unctrl
548
549 Changes the style of printout of strings.  Possible values are
550 C<unctrl> and C<quote>.
551
552 =item subdump
553
554 Whether to try to find the subroutine name given the reference.
555
556 =item bareStringify
557
558 Whether to write the non-overloaded form of the stringify-overloaded objects.
559
560 =item quoteHighBit
561
562 Whether to print chars with high bit set in binary or "as is".
563
564 =item stopDbSignal
565
566 Whether to abort printing if debugger signal flag is raised.
567
568 =back
569
570 Later in the life of the object the methods may be queries with get()
571 method 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
582 Prints a dump to the currently selected filehandle.
583
584 =item dumpValues
585
586   $dumper->dumpValues($value1, $value2);
587
588 Same as C< $dumper->dumpValue([$value1, $value2]); >.
589
590 =item stringify
591
592   my $dump = $dumper->stringify($value [,$noticks] );
593
594 Returns the dump of a single scalar without printing. If the second
595 argument is true, the return value does not contain enclosing ticks.
596 Does not handle data structures.
597
598 =item dumpvars
599
600   $dumper->dumpvars('my_package');
601   $dumper->dumpvars('my_package', 'foo', '~bar$', '!......');
602
603 The optional arguments are considered as literal strings unless they
604 start with C<~> or C<!>, in which case they are interpreted as regular
605 expressions (possibly negated).
606
607 The second example prints entries with names C<foo>, and also entries
608 with names which ends on C<bar>, or are shorter than 5 chars.
609
610 =item set_quote
611
612   $d->set_quote('"');
613
614 Sets C<tick> and C<unctrl> options to suitable values for printout with the
615 given quote char.  Possible values are C<auto>, C<'> and C<">.
616
617 =item set_unctrl
618
619   $d->set_unctrl('"');
620
621 Sets C<unctrl> option with checking for an invalid argument.
622 Possible values are C<unctrl> and C<quote>.
623
624 =item compactDump
625
626   $d->compactDump(1);
627
628 Sets C<compactDump> option.  If the value is 1, sets to a reasonable
629 big number.
630
631 =item veryCompact
632
633   $d->veryCompact(1);
634
635 Sets 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