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 defined %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 defined %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 ( UNIVERSAL::isa($v, 'HASH') ) {
185 my @sortKeys = sort keys(%$v) ;
187 my $tHashDepth = $#sortKeys ;
188 $tHashDepth = $#sortKeys < $self->{hashDepth}-1 ? $#sortKeys : $self->{hashDepth}-1
189 unless $self->{hashDepth} eq '' ;
190 $more = "....\n" if $tHashDepth < $#sortKeys ;
192 $shortmore = ", ..." if $tHashDepth < $#sortKeys ;
193 $#sortKeys = $tHashDepth ;
194 if ($self->{compactDump} && !grep(ref $_, values %{$v})) {
198 push @keys, $self->stringify($_) . " => " . $self->stringify($v->{$_});
200 $short .= join ', ', @keys;
201 $short .= $shortmore;
202 (print "$short\n"), return if length $short <= $self->{compactDump};
204 for my $key (@sortKeys) {
205 return if $DB::signal and $self->{stopDbSignal};
206 my $value = $ {$v}{$key} ;
207 print $sp, $self->stringify($key), " => ";
208 $self->DumpElem($value, $s);
210 print "$sp empty hash\n" unless @sortKeys;
211 print "$sp$more" if defined $more ;
212 } elsif ( UNIVERSAL::isa($v, 'ARRAY') ) {
213 my $tArrayDepth = $#{$v} ;
215 $tArrayDepth = $#$v < $self->{arrayDepth}-1 ? $#$v : $self->{arrayDepth}-1
216 unless $self->{arrayDepth} eq '' ;
217 $more = "....\n" if $tArrayDepth < $#{$v} ;
219 $shortmore = " ..." if $tArrayDepth < $#{$v} ;
220 if ($self->{compactDump} && !grep(ref $_, @{$v})) {
222 $short = $sp . "0..$#{$v} " .
224 map {$self->stringify($_)} @{$v}[0..$tArrayDepth])
227 $short = $sp . "empty array";
229 (print "$short\n"), return if length $short <= $self->{compactDump};
231 for my $num ($[ .. $tArrayDepth) {
232 return if $DB::signal and $self->{stopDbSignal};
234 $self->DumpElem($v->[$num], $s);
236 print "$sp empty array\n" unless @$v;
237 print "$sp$more" if defined $more ;
238 } elsif ( UNIVERSAL::isa($v, 'SCALAR') or ref $v eq 'REF' ) {
240 $self->DumpElem($$v, $s);
241 } elsif ( UNIVERSAL::isa($v, 'CODE') ) {
243 $self->dumpsub(0, $v);
244 } elsif ( UNIVERSAL::isa($v, 'GLOB') ) {
245 print "$sp-> ",$self->stringify($$v,1),"\n";
246 if ($self->{globPrint}) {
248 $self->dumpglob('', $s, "{$$v}", $$v, 1);
249 } elsif (defined ($fileno = fileno($v))) {
250 print( (' ' x ($s+3)) . "FileHandle({$$v}) => fileno($fileno)\n" );
252 } elsif (ref \$v eq 'GLOB') {
253 if ($self->{globPrint}) {
254 $self->dumpglob('', $s, "{$v}", $v, 1);
255 } elsif (defined ($fileno = fileno(\$v))) {
256 print( (' ' x $s) . "FileHandle({$v}) => fileno($fileno)\n" );
263 ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and
264 ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/});
269 $self->{compactDump} = shift if @_;
270 $self->{compactDump} = 6*80-1
271 if $self->{compactDump} and $self->{compactDump} < 2;
272 $self->{compactDump};
277 $self->{veryCompact} = shift if @_;
278 $self->compactDump(1) if !$self->{compactDump} and $self->{veryCompact};
279 $self->{veryCompact};
286 if ($in eq 'unctrl' or $in eq 'quote') {
287 $self->{unctrl} = $in;
289 print "Unknown value for `unctrl'.\n";
297 if (@_ and $_[0] eq '"') {
299 $self->{unctrl} = 'quote';
300 } elsif (@_ and $_[0] eq 'auto') {
301 $self->{tick} = 'auto';
302 $self->{unctrl} = 'quote';
303 } elsif (@_) { # Need to set
305 $self->{unctrl} = 'unctrl';
312 return if $DB::signal and $self->{stopDbSignal};
313 my ($package, $off, $key, $val, $all) = @_;
316 if (($key !~ /^_</ or $self->{dumpDBFiles}) and defined $stab) {
317 print( (' ' x $off) . "\$", &unctrl($key), " = " );
318 $self->DumpElem($stab, 3+$off);
320 if (($key !~ /^_</ or $self->{dumpDBFiles}) and defined @stab) {
321 print( (' ' x $off) . "\@$key = (\n" );
322 $self->unwrap(\@stab,3+$off) ;
323 print( (' ' x $off) . ")\n" );
325 if ($key ne "main::" && $key ne "DB::" && defined %stab
326 && ($self->{dumpPackages} or $key !~ /::$/)
327 && ($key !~ /^_</ or $self->{dumpDBFiles})
328 && !($package eq "Dumpvalue" and $key eq "stab")) {
329 print( (' ' x $off) . "\%$key = (\n" );
330 $self->unwrap(\%stab,3+$off) ;
331 print( (' ' x $off) . ")\n" );
333 if (defined ($fileno = fileno(*stab))) {
334 print( (' ' x $off) . "FileHandle($key) => fileno($fileno)\n" );
338 $self->dumpsub($off, $key);
346 $sub = $1 if $sub =~ /^\{\*(.*)\}$/;
348 my $place = $DB::sub{$sub} || (($sub = $subs{"$subref"}) && $DB::sub{$sub})
349 || ($self->{subdump} && ($sub = $self->findsubs("$subref"))
351 $place = '???' unless defined $place;
352 print( (' ' x $off) . "&$sub in $place\n" );
357 return undef unless defined %DB::sub;
358 my ($addr, $name, $loc);
359 while (($name, $loc) = each %DB::sub) {
361 $subs{"$addr"} = $name;
363 $self->{subdump} = 0;
369 my ($package,@vars) = @_;
372 $package .= "::" unless $package =~ /::$/;
375 while ($package =~ /(\w+?::)/g) {
376 *stab = $ {stab}{$1};
378 $self->{TotalStrings} = 0;
379 $self->{Strings} = 0;
380 $self->{CompleteTotal} = 0;
381 while (($key,$val) = each(%stab)) {
382 return if $DB::signal and $self->{stopDbSignal};
383 next if @vars && !grep( matchvar($key, $_), @vars );
384 if ($self->{usageOnly}) {
385 $self->globUsage(\$val, $key)
386 unless $package eq 'Dumpvalue' and $key eq 'stab';
388 $self->dumpglob($package, 0,$key, $val);
391 if ($self->{usageOnly}) {
393 String space: $self->{TotalStrings} bytes in $self->{Strings} strings.
395 $self->{CompleteTotal} += $self->{TotalStrings};
397 Grand total = $self->{CompleteTotal} bytes (1 level deep) + overhead.
404 my $size = length($_[0]);
405 $self->{TotalStrings} += $size;
410 sub arrayUsage { # array ref, name
413 map {$size += $self->scalarUsage($_)} @{$_[0]};
415 print "\@$_[1] = $len item", ($len > 1 ? "s" : ""), " (data: $size bytes)\n"
417 $self->{CompleteTotal} += $size;
421 sub hashUsage { # hash ref, name
423 my @keys = keys %{$_[0]};
424 my @values = values %{$_[0]};
425 my $keys = $self->arrayUsage(\@keys);
426 my $values = $self->arrayUsage(\@values);
428 my $total = $keys + $values;
429 print "\%$_[1] = $len item", ($len > 1 ? "s" : ""),
430 " (keys: $keys; values: $values; total: $total bytes)\n"
435 sub globUsage { # glob ref, name
437 local *stab = *{$_[0]};
439 $total += $self->scalarUsage($stab) if defined $stab;
440 $total += $self->arrayUsage(\@stab, $_[1]) if defined @stab;
441 $total += $self->hashUsage(\%stab, $_[1])
442 if defined %stab and $_[1] ne "main::" and $_[1] ne "DB::";
443 #and !($package eq "Dumpvalue" and $key eq "stab"));
451 Dumpvalue - provides screen dump of Perl data.
456 my $dumper = new Dumpvalue;
457 $dumper->set(globPrint => 1);
458 $dumper->dumpValue(\*::);
459 $dumper->dumpvars('main');
465 A new dumper is created by a call
467 $d = new Dumpvalue(option1 => value1, option2 => value2)
473 =item C<arrayDepth>, C<hashDepth>
475 Print only first N elements of arrays and hashes. If false, prints all the
478 =item C<compactDump>, C<veryCompact>
480 Change style of array and hash dump. If true, short array
481 may be printed on one line.
485 Whether to print contents of globs.
489 Dump arrays holding contents of debugged files.
491 =item C<DumpPackages>
493 Dump symbol tables of packages.
497 Dump contents of "reused" addresses.
499 =item C<tick>, C<HighBit>, C<printUndef>
501 Change style of string dump. Default value of C<tick> is C<auto>, one
502 can enable either double-quotish dump, or single-quotish by setting it
503 to C<"> or C<'>. By default, characters with high bit set are printed
508 I<very> rudimentally per-package memory usage dump. If set,
509 C<dumpvars> calculates total size of strings in variables in the package.
513 Changes the style of printout of strings. Possible values are
514 C<unctrl> and C<quote>.
518 Whether to try to find the subroutine name given the reference.
522 Whether to write the non-overloaded form of the stringify-overloaded objects.
526 Whether to print chars with high bit set in binary or "as is".
530 Whether to abort printing if debugger signal flag is raised.
534 Later in the life of the object the methods may be queries with get()
535 method and set() method (which accept multiple arguments).
543 $dumper->dumpValue($value);
544 $dumper->dumpValue([$value1, $value2]);
548 $dumper->dumpValues($value1, $value2);
552 $dumper->dumpvars('my_package');
553 $dumper->dumpvars('my_package', 'foo', '~bar$', '!......');
555 The optional arguments are considered as literal strings unless they
556 start with C<~> or C<!>, in which case they are interpreted as regular
557 expressions (possibly negated).
559 The second example prints entries with names C<foo>, and also entries
560 with names which ends on C<bar>, or are shorter than 5 chars.
566 Sets C<tick> and C<unctrl> options to suitable values for printout with the
567 given quote char. Possible values are C<auto>, C<'> and C<">.
573 Sets C<unctrl> option with checking for an invalid argument.
574 Possible values are C<unctrl> and C<quote>.
580 Sets C<compactDump> option. If the value is 1, sets to a reasonable
587 Sets C<compactDump> and C<veryCompact> options simultaneously.
591 $d->set(option1 => value1, option2 => value2);
595 @values = $d->get('option1', 'option2');