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