1 use 5.005_64; # for (defined ref) and $#$v and our
4 our(%address, $stab, @stab, %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 return if $self->{skipCvGV}; # Backdoor to avoid problems if XS broken...
354 $in = \&$in; # Hard reference...
355 eval {require Devel::Peek; 1} or return;
356 my $gv = Devel::Peek::CvGV($in) or return;
357 *$gv{PACKAGE} . '::' . *$gv{NAME};
365 $sub = $1 if $sub =~ /^\{\*(.*)\}$/;
366 my $subref = defined $1 ? \&$sub : \&$ini;
367 my $place = $DB::sub{$sub} || (($s = $subs{"$subref"}) && $DB::sub{$s})
368 || (($s = $self->CvGV_name($subref)) && $DB::sub{$s})
369 || ($self->{subdump} && ($s = $self->findsubs("$subref"))
371 $s = $sub unless defined $s;
372 $place = '???' unless defined $place;
373 print( (' ' x $off) . "&$s in $place\n" );
378 return undef unless %DB::sub;
379 my ($addr, $name, $loc);
380 while (($name, $loc) = each %DB::sub) {
382 $subs{"$addr"} = $name;
384 $self->{subdump} = 0;
390 my ($package,@vars) = @_;
393 $package .= "::" unless $package =~ /::$/;
396 while ($package =~ /(\w+?::)/g) {
397 *stab = $ {stab}{$1};
399 $self->{TotalStrings} = 0;
400 $self->{Strings} = 0;
401 $self->{CompleteTotal} = 0;
402 while (($key,$val) = each(%stab)) {
403 return if $DB::signal and $self->{stopDbSignal};
404 next if @vars && !grep( matchvar($key, $_), @vars );
405 if ($self->{usageOnly}) {
406 $self->globUsage(\$val, $key)
407 if ($package ne 'Dumpvalue' or $key ne 'stab')
408 and ref(\$val) eq 'GLOB';
410 $self->dumpglob($package, 0,$key, $val);
413 if ($self->{usageOnly}) {
415 String space: $self->{TotalStrings} bytes in $self->{Strings} strings.
417 $self->{CompleteTotal} += $self->{TotalStrings};
419 Grand total = $self->{CompleteTotal} bytes (1 level deep) + overhead.
426 my $size = length($_[0]);
427 $self->{TotalStrings} += $size;
432 sub arrayUsage { # array ref, name
435 map {$size += $self->scalarUsage($_)} @{$_[0]};
437 print "\@$_[1] = $len item", ($len > 1 ? "s" : ""), " (data: $size bytes)\n"
439 $self->{CompleteTotal} += $size;
443 sub hashUsage { # hash ref, name
445 my @keys = keys %{$_[0]};
446 my @values = values %{$_[0]};
447 my $keys = $self->arrayUsage(\@keys);
448 my $values = $self->arrayUsage(\@values);
450 my $total = $keys + $values;
451 print "\%$_[1] = $len item", ($len > 1 ? "s" : ""),
452 " (keys: $keys; values: $values; total: $total bytes)\n"
457 sub globUsage { # glob ref, name
459 local *stab = *{$_[0]};
461 $total += $self->scalarUsage($stab) if defined $stab;
462 $total += $self->arrayUsage(\@stab, $_[1]) if @stab;
463 $total += $self->hashUsage(\%stab, $_[1])
464 if %stab and $_[1] ne "main::" and $_[1] ne "DB::";
465 #and !($package eq "Dumpvalue" and $key eq "stab"));
473 Dumpvalue - provides screen dump of Perl data.
478 my $dumper = new Dumpvalue;
479 $dumper->set(globPrint => 1);
480 $dumper->dumpValue(\*::);
481 $dumper->dumpvars('main');
487 A new dumper is created by a call
489 $d = new Dumpvalue(option1 => value1, option2 => value2)
495 =item C<arrayDepth>, C<hashDepth>
497 Print only first N elements of arrays and hashes. If false, prints all the
500 =item C<compactDump>, C<veryCompact>
502 Change style of array and hash dump. If true, short array
503 may be printed on one line.
507 Whether to print contents of globs.
511 Dump arrays holding contents of debugged files.
513 =item C<DumpPackages>
515 Dump symbol tables of packages.
519 Dump contents of "reused" addresses.
521 =item C<tick>, C<HighBit>, C<printUndef>
523 Change style of string dump. Default value of C<tick> is C<auto>, one
524 can enable either double-quotish dump, or single-quotish by setting it
525 to C<"> or C<'>. By default, characters with high bit set are printed
530 I<very> rudimentally per-package memory usage dump. If set,
531 C<dumpvars> calculates total size of strings in variables in the package.
535 Changes the style of printout of strings. Possible values are
536 C<unctrl> and C<quote>.
540 Whether to try to find the subroutine name given the reference.
544 Whether to write the non-overloaded form of the stringify-overloaded objects.
548 Whether to print chars with high bit set in binary or "as is".
552 Whether to abort printing if debugger signal flag is raised.
556 Later in the life of the object the methods may be queries with get()
557 method and set() method (which accept multiple arguments).
565 $dumper->dumpValue($value);
566 $dumper->dumpValue([$value1, $value2]);
570 $dumper->dumpValues($value1, $value2);
574 $dumper->dumpvars('my_package');
575 $dumper->dumpvars('my_package', 'foo', '~bar$', '!......');
577 The optional arguments are considered as literal strings unless they
578 start with C<~> or C<!>, in which case they are interpreted as regular
579 expressions (possibly negated).
581 The second example prints entries with names C<foo>, and also entries
582 with names which ends on C<bar>, or are shorter than 5 chars.
588 Sets C<tick> and C<unctrl> options to suitable values for printout with the
589 given quote char. Possible values are C<auto>, C<'> and C<">.
595 Sets C<unctrl> option with checking for an invalid argument.
596 Possible values are C<unctrl> and C<quote>.
602 Sets C<compactDump> option. If the value is 1, sets to a reasonable
609 Sets C<compactDump> and C<veryCompact> options simultaneously.
613 $d->set(option1 => value1, option2 => value2);
617 @values = $d->get('option1', 'option2');