1 require 5.005; # For (defined ref) and $#$v
4 use vars qw(%address *stab %subs);
6 # translate control chars to ^X - Randal Schwartz
7 # Modifications to print types by Peter Gordon v1.0
9 # Ilya Zakharevich -- patches after 5.001 (and some before ;-)
11 # Won't dump symbol tables and contents of debugged files by default
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...
40 my %opt = (%defaults, @_);
47 @$self{keys %opt} = values %opt;
52 wantarray ? @$self{@_} : $$self{pop @_};
57 die "usage: \$dumper->dumpValue(value)" unless @_ == 1;
60 (print "undef\n"), return unless defined $_[0];
61 (print $self->stringify($_[0]), "\n"), return unless ref $_[0];
62 $self->unwrap($_[0],0);
69 (print "undef\n"), return unless defined $_[0];
73 # This one is good for variable names:
78 return \$_ if ref \$_ eq "GLOB";
79 s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
87 my $tick = $self->{tick};
89 return 'undef' unless defined $_ or not $self->{printUndef};
90 return $_ . "" if ref \$_ eq 'GLOB';
92 $_ = &{'overload::StrVal'}($_)
93 if $self->{bareStringify} and ref $_
94 and %overload:: and defined &{'overload::StrVal'};
97 if ($tick eq 'auto') {
98 if (/[\000-\011\013-\037\177]/) {
106 } elsif ($self->{unctrl} eq 'unctrl') {
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 '"';
114 s/([\000-\037\177])/'\\c'.chr(ord($1)^64)/eg;
116 s/([\200-\377])/'\\'.sprintf('%3o',ord($1))/eg if $self->{quoteHighBit};
117 ($noticks || /^\d+(\.\d*)?\Z/)
119 : $tick . $_ . $tick;
123 my ($self, $v) = (shift, shift);
124 my $short = $self->stringify($v, ref $v);
126 if ($self->{veryCompact} && ref $v
127 && (ref $v eq 'ARRAY' and !grep(ref $_, @$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;
137 ($shortmore, $depth) = (' ...', $self->{hashDepth} - 1)
138 if $self->{hashDepth} and $depth >= $self->{hashDepth};
139 my @b = map {$self->stringify($_) . " => " . $self->stringify($$v{$_})}
142 print "@b$shortmore\n";
145 $self->unwrap($v,shift);
151 return if $DB::signal and $self->{stopDbSignal};
153 my ($s) = shift ; # extra no of spaces
155 my (%v,@v,$address,$short,$fileno);
160 # Check for reused addresses
164 $val = &{'overload::StrVal'}($v)
165 if %overload:: and defined &{'overload::StrVal'};
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" ;
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" ;
184 if (ref $v eq 'Regexp') {
187 print "$sp-> qr/$re/\n";
191 if ( UNIVERSAL::isa($v, 'HASH') ) {
192 my @sortKeys = sort keys(%$v) ;
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 ;
199 $shortmore = ", ..." if $tHashDepth < $#sortKeys ;
200 $#sortKeys = $tHashDepth ;
201 if ($self->{compactDump} && !grep(ref $_, values %{$v})) {
205 push @keys, $self->stringify($_) . " => " . $self->stringify($v->{$_});
207 $short .= join ', ', @keys;
208 $short .= $shortmore;
209 (print "$short\n"), return if length $short <= $self->{compactDump};
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);
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} ;
222 $tArrayDepth = $#$v < $self->{arrayDepth}-1 ? $#$v : $self->{arrayDepth}-1
223 unless $self->{arrayDepth} eq '' ;
224 $more = "....\n" if $tArrayDepth < $#{$v} ;
226 $shortmore = " ..." if $tArrayDepth < $#{$v} ;
227 if ($self->{compactDump} && !grep(ref $_, @{$v})) {
229 $short = $sp . "0..$#{$v} " .
231 map {$self->stringify($_)} @{$v}[0..$tArrayDepth])
234 $short = $sp . "empty array";
236 (print "$short\n"), return if length $short <= $self->{compactDump};
238 for my $num ($[ .. $tArrayDepth) {
239 return if $DB::signal and $self->{stopDbSignal};
241 $self->DumpElem($v->[$num], $s);
243 print "$sp empty array\n" unless @$v;
244 print "$sp$more" if defined $more ;
245 } elsif ( UNIVERSAL::isa($v, 'SCALAR') or ref $v eq 'REF' ) {
247 $self->DumpElem($$v, $s);
248 } elsif ( UNIVERSAL::isa($v, 'CODE') ) {
250 $self->dumpsub(0, $v);
251 } elsif ( UNIVERSAL::isa($v, 'GLOB') ) {
252 print "$sp-> ",$self->stringify($$v,1),"\n";
253 if ($self->{globPrint}) {
255 $self->dumpglob('', $s, "{$$v}", $$v, 1);
256 } elsif (defined ($fileno = fileno($v))) {
257 print( (' ' x ($s+3)) . "FileHandle({$$v}) => fileno($fileno)\n" );
259 } elsif (ref \$v eq 'GLOB') {
260 if ($self->{globPrint}) {
261 $self->dumpglob('', $s, "{$v}", $v, 1);
262 } elsif (defined ($fileno = fileno(\$v))) {
263 print( (' ' x $s) . "FileHandle({$v}) => fileno($fileno)\n" );
270 ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and
271 ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/});
276 $self->{compactDump} = shift if @_;
277 $self->{compactDump} = 6*80-1
278 if $self->{compactDump} and $self->{compactDump} < 2;
279 $self->{compactDump};
284 $self->{veryCompact} = shift if @_;
285 $self->compactDump(1) if !$self->{compactDump} and $self->{veryCompact};
286 $self->{veryCompact};
293 if ($in eq 'unctrl' or $in eq 'quote') {
294 $self->{unctrl} = $in;
296 print "Unknown value for `unctrl'.\n";
304 if (@_ and $_[0] eq '"') {
306 $self->{unctrl} = 'quote';
307 } elsif (@_ and $_[0] eq 'auto') {
308 $self->{tick} = 'auto';
309 $self->{unctrl} = 'quote';
310 } elsif (@_) { # Need to set
312 $self->{unctrl} = 'unctrl';
319 return if $DB::signal and $self->{stopDbSignal};
320 my ($package, $off, $key, $val, $all) = @_;
323 if (($key !~ /^_</ or $self->{dumpDBFiles}) and defined $stab) {
324 print( (' ' x $off) . "\$", &unctrl($key), " = " );
325 $self->DumpElem($stab, 3+$off);
327 if (($key !~ /^_</ or $self->{dumpDBFiles}) and @stab) {
328 print( (' ' x $off) . "\@$key = (\n" );
329 $self->unwrap(\@stab,3+$off) ;
330 print( (' ' x $off) . ")\n" );
332 if ($key ne "main::" && $key ne "DB::" && %stab
333 && ($self->{dumpPackages} or $key !~ /::$/)
334 && ($key !~ /^_</ or $self->{dumpDBFiles})
335 && !($package eq "Dumpvalue" and $key eq "stab")) {
336 print( (' ' x $off) . "\%$key = (\n" );
337 $self->unwrap(\%stab,3+$off) ;
338 print( (' ' x $off) . ")\n" );
340 if (defined ($fileno = fileno(*stab))) {
341 print( (' ' x $off) . "FileHandle($key) => fileno($fileno)\n" );
345 $self->dumpsub($off, $key);
353 $sub = $1 if $sub =~ /^\{\*(.*)\}$/;
355 my $place = $DB::sub{$sub} || (($sub = $subs{"$subref"}) && $DB::sub{$sub})
356 || ($self->{subdump} && ($sub = $self->findsubs("$subref"))
358 $place = '???' unless defined $place;
359 print( (' ' x $off) . "&$sub in $place\n" );
364 return undef unless %DB::sub;
365 my ($addr, $name, $loc);
366 while (($name, $loc) = each %DB::sub) {
368 $subs{"$addr"} = $name;
370 $self->{subdump} = 0;
376 my ($package,@vars) = @_;
379 $package .= "::" unless $package =~ /::$/;
382 while ($package =~ /(\w+?::)/g) {
383 *stab = $ {stab}{$1};
385 $self->{TotalStrings} = 0;
386 $self->{Strings} = 0;
387 $self->{CompleteTotal} = 0;
388 while (($key,$val) = each(%stab)) {
389 return if $DB::signal and $self->{stopDbSignal};
390 next if @vars && !grep( matchvar($key, $_), @vars );
391 if ($self->{usageOnly}) {
392 $self->globUsage(\$val, $key)
393 unless $package eq 'Dumpvalue' and $key eq 'stab';
395 $self->dumpglob($package, 0,$key, $val);
398 if ($self->{usageOnly}) {
400 String space: $self->{TotalStrings} bytes in $self->{Strings} strings.
402 $self->{CompleteTotal} += $self->{TotalStrings};
404 Grand total = $self->{CompleteTotal} bytes (1 level deep) + overhead.
411 my $size = length($_[0]);
412 $self->{TotalStrings} += $size;
417 sub arrayUsage { # array ref, name
420 map {$size += $self->scalarUsage($_)} @{$_[0]};
422 print "\@$_[1] = $len item", ($len > 1 ? "s" : ""), " (data: $size bytes)\n"
424 $self->{CompleteTotal} += $size;
428 sub hashUsage { # hash ref, name
430 my @keys = keys %{$_[0]};
431 my @values = values %{$_[0]};
432 my $keys = $self->arrayUsage(\@keys);
433 my $values = $self->arrayUsage(\@values);
435 my $total = $keys + $values;
436 print "\%$_[1] = $len item", ($len > 1 ? "s" : ""),
437 " (keys: $keys; values: $values; total: $total bytes)\n"
442 sub globUsage { # glob ref, name
444 local *stab = *{$_[0]};
446 $total += $self->scalarUsage($stab) if defined $stab;
447 $total += $self->arrayUsage(\@stab, $_[1]) if @stab;
448 $total += $self->hashUsage(\%stab, $_[1])
449 if %stab and $_[1] ne "main::" and $_[1] ne "DB::";
450 #and !($package eq "Dumpvalue" and $key eq "stab"));
458 Dumpvalue - provides screen dump of Perl data.
463 my $dumper = new Dumpvalue;
464 $dumper->set(globPrint => 1);
465 $dumper->dumpValue(\*::);
466 $dumper->dumpvars('main');
472 A new dumper is created by a call
474 $d = new Dumpvalue(option1 => value1, option2 => value2)
480 =item C<arrayDepth>, C<hashDepth>
482 Print only first N elements of arrays and hashes. If false, prints all the
485 =item C<compactDump>, C<veryCompact>
487 Change style of array and hash dump. If true, short array
488 may be printed on one line.
492 Whether to print contents of globs.
496 Dump arrays holding contents of debugged files.
498 =item C<DumpPackages>
500 Dump symbol tables of packages.
504 Dump contents of "reused" addresses.
506 =item C<tick>, C<HighBit>, C<printUndef>
508 Change style of string dump. Default value of C<tick> is C<auto>, one
509 can enable either double-quotish dump, or single-quotish by setting it
510 to C<"> or C<'>. By default, characters with high bit set are printed
515 I<very> rudimentally per-package memory usage dump. If set,
516 C<dumpvars> calculates total size of strings in variables in the package.
520 Changes the style of printout of strings. Possible values are
521 C<unctrl> and C<quote>.
525 Whether to try to find the subroutine name given the reference.
529 Whether to write the non-overloaded form of the stringify-overloaded objects.
533 Whether to print chars with high bit set in binary or "as is".
537 Whether to abort printing if debugger signal flag is raised.
541 Later in the life of the object the methods may be queries with get()
542 method and set() method (which accept multiple arguments).
550 $dumper->dumpValue($value);
551 $dumper->dumpValue([$value1, $value2]);
555 $dumper->dumpValues($value1, $value2);
559 $dumper->dumpvars('my_package');
560 $dumper->dumpvars('my_package', 'foo', '~bar$', '!......');
562 The optional arguments are considered as literal strings unless they
563 start with C<~> or C<!>, in which case they are interpreted as regular
564 expressions (possibly negated).
566 The second example prints entries with names C<foo>, and also entries
567 with names which ends on C<bar>, or are shorter than 5 chars.
573 Sets C<tick> and C<unctrl> options to suitable values for printout with the
574 given quote char. Possible values are C<auto>, C<'> and C<">.
580 Sets C<unctrl> option with checking for an invalid argument.
581 Possible values are C<unctrl> and C<quote>.
587 Sets C<compactDump> option. If the value is 1, sets to a reasonable
594 Sets C<compactDump> and C<veryCompact> options simultaneously.
598 $d->set(option1 => value1, option2 => value2);
602 @values = $d->get('option1', 'option2');