1 use 5.005_64; # for (defined ref) and $#$v and our
5 our(%address, $stab, @stab, %stab, %subs);
7 # translate control chars to ^X - Randal Schwartz
8 # Modifications to print types by Peter Gordon v1.0
10 # Ilya Zakharevich -- patches after 5.001 (and some before ;-)
12 # Won't dump symbol tables and contents of debugged files by default
14 # (IZ) changes for objectification:
15 # c) quote() renamed to method set_quote();
16 # d) unctrlSet() renamed to method set_unctrl();
17 # f) Compiles with `use strict', but in two places no strict refs is needed:
18 # maybe more problems are waiting...
41 my %opt = (%defaults, @_);
48 @$self{keys %opt} = values %opt;
53 wantarray ? @$self{@_} : $$self{pop @_};
58 die "usage: \$dumper->dumpValue(value)" unless @_ == 1;
61 (print "undef\n"), return unless defined $_[0];
62 (print $self->stringify($_[0]), "\n"), return unless ref $_[0];
63 $self->unwrap($_[0],0);
70 (print "undef\n"), return unless defined $_[0];
74 # This one is good for variable names:
79 return \$_ if ref \$_ eq "GLOB";
80 s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
88 my $tick = $self->{tick};
90 return 'undef' unless defined $_ or not $self->{printUndef};
91 return $_ . "" if ref \$_ eq 'GLOB';
93 $_ = &{'overload::StrVal'}($_)
94 if $self->{bareStringify} and ref $_
95 and %overload:: and defined &{'overload::StrVal'};
98 if ($tick eq 'auto') {
99 if (/[\000-\011\013-\037\177]/) {
107 } elsif ($self->{unctrl} eq 'unctrl') {
109 s/([\000-\037\177])/'^'.pack('c',ord($1)^64)/eg;
110 s/([\200-\377])/'\\0x'.sprintf('%2X',ord($1))/eg
111 if $self->{quoteHighBit};
112 } elsif ($self->{unctrl} eq 'quote') {
113 s/([\"\\\$\@])/\\$1/g if $tick eq '"';
115 s/([\000-\037\177])/'\\c'.chr(ord($1)^64)/eg;
117 s/([\200-\377])/'\\'.sprintf('%3o',ord($1))/eg if $self->{quoteHighBit};
118 ($noticks || /^\d+(\.\d*)?\Z/)
120 : $tick . $_ . $tick;
124 my ($self, $v) = (shift, shift);
125 my $short = $self->stringify($v, ref $v);
127 if ($self->{veryCompact} && ref $v
128 && (ref $v eq 'ARRAY' and !grep(ref $_, @$v) )) {
130 ($shortmore, $depth) = (' ...', $self->{arrayDepth} - 1)
131 if $self->{arrayDepth} and $depth >= $self->{arrayDepth};
132 my @a = map $self->stringify($_), @$v[0..$depth];
133 print "0..$#{$v} @a$shortmore\n";
134 } elsif ($self->{veryCompact} && ref $v
135 && (ref $v eq 'HASH') and !grep(ref $_, values %$v)) {
136 my @a = sort keys %$v;
138 ($shortmore, $depth) = (' ...', $self->{hashDepth} - 1)
139 if $self->{hashDepth} and $depth >= $self->{hashDepth};
140 my @b = map {$self->stringify($_) . " => " . $self->stringify($$v{$_})}
143 print "@b$shortmore\n";
146 $self->unwrap($v,shift);
152 return if $DB::signal and $self->{stopDbSignal};
154 my ($s) = shift ; # extra no of spaces
156 my (%v,@v,$address,$short,$fileno);
161 # Check for reused addresses
165 $val = &{'overload::StrVal'}($v)
166 if %overload:: and defined &{'overload::StrVal'};
168 ($address) = $val =~ /(0x[0-9a-f]+)\)$/ ;
169 if (!$self->{dumpReused} && defined $address) {
170 $address{$address}++ ;
171 if ( $address{$address} > 1 ) {
172 print "${sp}-> REUSED_ADDRESS\n" ;
176 } elsif (ref \$v eq 'GLOB') {
177 $address = "$v" . ""; # To avoid a bug with globs
178 $address{$address}++ ;
179 if ( $address{$address} > 1 ) {
180 print "${sp}*DUMPED_GLOB*\n" ;
185 if (ref $v eq 'Regexp') {
188 print "$sp-> qr/$re/\n";
192 if ( UNIVERSAL::isa($v, 'HASH') ) {
193 my @sortKeys = sort keys(%$v) ;
195 my $tHashDepth = $#sortKeys ;
196 $tHashDepth = $#sortKeys < $self->{hashDepth}-1 ? $#sortKeys : $self->{hashDepth}-1
197 unless $self->{hashDepth} eq '' ;
198 $more = "....\n" if $tHashDepth < $#sortKeys ;
200 $shortmore = ", ..." if $tHashDepth < $#sortKeys ;
201 $#sortKeys = $tHashDepth ;
202 if ($self->{compactDump} && !grep(ref $_, values %{$v})) {
206 push @keys, $self->stringify($_) . " => " . $self->stringify($v->{$_});
208 $short .= join ', ', @keys;
209 $short .= $shortmore;
210 (print "$short\n"), return if length $short <= $self->{compactDump};
212 for my $key (@sortKeys) {
213 return if $DB::signal and $self->{stopDbSignal};
214 my $value = $ {$v}{$key} ;
215 print $sp, $self->stringify($key), " => ";
216 $self->DumpElem($value, $s);
218 print "$sp empty hash\n" unless @sortKeys;
219 print "$sp$more" if defined $more ;
220 } elsif ( UNIVERSAL::isa($v, 'ARRAY') ) {
221 my $tArrayDepth = $#{$v} ;
223 $tArrayDepth = $#$v < $self->{arrayDepth}-1 ? $#$v : $self->{arrayDepth}-1
224 unless $self->{arrayDepth} eq '' ;
225 $more = "....\n" if $tArrayDepth < $#{$v} ;
227 $shortmore = " ..." if $tArrayDepth < $#{$v} ;
228 if ($self->{compactDump} && !grep(ref $_, @{$v})) {
230 $short = $sp . "0..$#{$v} " .
232 map {exists $v->[$_] ? $self->stringify($v->[$_]) : "empty"} ($[..$tArrayDepth)
235 $short = $sp . "empty array";
237 (print "$short\n"), return if length $short <= $self->{compactDump};
239 for my $num ($[ .. $tArrayDepth) {
240 return if $DB::signal and $self->{stopDbSignal};
242 if (exists $v->[$num]) {
243 $self->DumpElem($v->[$num], $s);
245 print "empty slot\n";
248 print "$sp empty array\n" unless @$v;
249 print "$sp$more" if defined $more ;
250 } elsif ( UNIVERSAL::isa($v, 'SCALAR') or ref $v eq 'REF' ) {
252 $self->DumpElem($$v, $s);
253 } elsif ( UNIVERSAL::isa($v, 'CODE') ) {
255 $self->dumpsub(0, $v);
256 } elsif ( UNIVERSAL::isa($v, 'GLOB') ) {
257 print "$sp-> ",$self->stringify($$v,1),"\n";
258 if ($self->{globPrint}) {
260 $self->dumpglob('', $s, "{$$v}", $$v, 1);
261 } elsif (defined ($fileno = fileno($v))) {
262 print( (' ' x ($s+3)) . "FileHandle({$$v}) => fileno($fileno)\n" );
264 } elsif (ref \$v eq 'GLOB') {
265 if ($self->{globPrint}) {
266 $self->dumpglob('', $s, "{$v}", $v, 1);
267 } elsif (defined ($fileno = fileno(\$v))) {
268 print( (' ' x $s) . "FileHandle({$v}) => fileno($fileno)\n" );
275 ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and
276 ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/});
281 $self->{compactDump} = shift if @_;
282 $self->{compactDump} = 6*80-1
283 if $self->{compactDump} and $self->{compactDump} < 2;
284 $self->{compactDump};
289 $self->{veryCompact} = shift if @_;
290 $self->compactDump(1) if !$self->{compactDump} and $self->{veryCompact};
291 $self->{veryCompact};
298 if ($in eq 'unctrl' or $in eq 'quote') {
299 $self->{unctrl} = $in;
301 print "Unknown value for `unctrl'.\n";
309 if (@_ and $_[0] eq '"') {
311 $self->{unctrl} = 'quote';
312 } elsif (@_ and $_[0] eq 'auto') {
313 $self->{tick} = 'auto';
314 $self->{unctrl} = 'quote';
315 } elsif (@_) { # Need to set
317 $self->{unctrl} = 'unctrl';
324 return if $DB::signal and $self->{stopDbSignal};
325 my ($package, $off, $key, $val, $all) = @_;
328 if (($key !~ /^_</ or $self->{dumpDBFiles}) and defined $stab) {
329 print( (' ' x $off) . "\$", &unctrl($key), " = " );
330 $self->DumpElem($stab, 3+$off);
332 if (($key !~ /^_</ or $self->{dumpDBFiles}) and @stab) {
333 print( (' ' x $off) . "\@$key = (\n" );
334 $self->unwrap(\@stab,3+$off) ;
335 print( (' ' x $off) . ")\n" );
337 if ($key ne "main::" && $key ne "DB::" && %stab
338 && ($self->{dumpPackages} or $key !~ /::$/)
339 && ($key !~ /^_</ or $self->{dumpDBFiles})
340 && !($package eq "Dumpvalue" and $key eq "stab")) {
341 print( (' ' x $off) . "\%$key = (\n" );
342 $self->unwrap(\%stab,3+$off) ;
343 print( (' ' x $off) . ")\n" );
345 if (defined ($fileno = fileno(*stab))) {
346 print( (' ' x $off) . "FileHandle($key) => fileno($fileno)\n" );
350 $self->dumpsub($off, $key);
358 return if $self->{skipCvGV}; # Backdoor to avoid problems if XS broken...
359 $in = \&$in; # Hard reference...
360 eval {require Devel::Peek; 1} or return;
361 my $gv = Devel::Peek::CvGV($in) or return;
362 *$gv{PACKAGE} . '::' . *$gv{NAME};
370 $sub = $1 if $sub =~ /^\{\*(.*)\}$/;
371 my $subref = defined $1 ? \&$sub : \&$ini;
372 my $place = $DB::sub{$sub} || (($s = $subs{"$subref"}) && $DB::sub{$s})
373 || (($s = $self->CvGV_name($subref)) && $DB::sub{$s})
374 || ($self->{subdump} && ($s = $self->findsubs("$subref"))
376 $s = $sub unless defined $s;
377 $place = '???' unless defined $place;
378 print( (' ' x $off) . "&$s in $place\n" );
383 return undef unless %DB::sub;
384 my ($addr, $name, $loc);
385 while (($name, $loc) = each %DB::sub) {
387 $subs{"$addr"} = $name;
389 $self->{subdump} = 0;
395 my ($package,@vars) = @_;
398 $package .= "::" unless $package =~ /::$/;
401 while ($package =~ /(\w+?::)/g) {
402 *stab = $ {stab}{$1};
404 $self->{TotalStrings} = 0;
405 $self->{Strings} = 0;
406 $self->{CompleteTotal} = 0;
407 while (($key,$val) = each(%stab)) {
408 return if $DB::signal and $self->{stopDbSignal};
409 next if @vars && !grep( matchvar($key, $_), @vars );
410 if ($self->{usageOnly}) {
411 $self->globUsage(\$val, $key)
412 if ($package ne 'Dumpvalue' or $key ne 'stab')
413 and ref(\$val) eq 'GLOB';
415 $self->dumpglob($package, 0,$key, $val);
418 if ($self->{usageOnly}) {
420 String space: $self->{TotalStrings} bytes in $self->{Strings} strings.
422 $self->{CompleteTotal} += $self->{TotalStrings};
424 Grand total = $self->{CompleteTotal} bytes (1 level deep) + overhead.
431 my $size = length($_[0]);
432 $self->{TotalStrings} += $size;
437 sub arrayUsage { # array ref, name
440 map {$size += $self->scalarUsage($_)} @{$_[0]};
442 print "\@$_[1] = $len item", ($len > 1 ? "s" : ""), " (data: $size bytes)\n"
444 $self->{CompleteTotal} += $size;
448 sub hashUsage { # hash ref, name
450 my @keys = keys %{$_[0]};
451 my @values = values %{$_[0]};
452 my $keys = $self->arrayUsage(\@keys);
453 my $values = $self->arrayUsage(\@values);
455 my $total = $keys + $values;
456 print "\%$_[1] = $len item", ($len > 1 ? "s" : ""),
457 " (keys: $keys; values: $values; total: $total bytes)\n"
462 sub globUsage { # glob ref, name
464 local *stab = *{$_[0]};
466 $total += $self->scalarUsage($stab) if defined $stab;
467 $total += $self->arrayUsage(\@stab, $_[1]) if @stab;
468 $total += $self->hashUsage(\%stab, $_[1])
469 if %stab and $_[1] ne "main::" and $_[1] ne "DB::";
470 #and !($package eq "Dumpvalue" and $key eq "stab"));
478 Dumpvalue - provides screen dump of Perl data.
483 my $dumper = new Dumpvalue;
484 $dumper->set(globPrint => 1);
485 $dumper->dumpValue(\*::);
486 $dumper->dumpvars('main');
492 A new dumper is created by a call
494 $d = new Dumpvalue(option1 => value1, option2 => value2)
500 =item C<arrayDepth>, C<hashDepth>
502 Print only first N elements of arrays and hashes. If false, prints all the
505 =item C<compactDump>, C<veryCompact>
507 Change style of array and hash dump. If true, short array
508 may be printed on one line.
512 Whether to print contents of globs.
516 Dump arrays holding contents of debugged files.
518 =item C<DumpPackages>
520 Dump symbol tables of packages.
524 Dump contents of "reused" addresses.
526 =item C<tick>, C<HighBit>, C<printUndef>
528 Change style of string dump. Default value of C<tick> is C<auto>, one
529 can enable either double-quotish dump, or single-quotish by setting it
530 to C<"> or C<'>. By default, characters with high bit set are printed
535 I<very> rudimentally per-package memory usage dump. If set,
536 C<dumpvars> calculates total size of strings in variables in the package.
540 Changes the style of printout of strings. Possible values are
541 C<unctrl> and C<quote>.
545 Whether to try to find the subroutine name given the reference.
549 Whether to write the non-overloaded form of the stringify-overloaded objects.
553 Whether to print chars with high bit set in binary or "as is".
557 Whether to abort printing if debugger signal flag is raised.
561 Later in the life of the object the methods may be queries with get()
562 method and set() method (which accept multiple arguments).
570 $dumper->dumpValue($value);
571 $dumper->dumpValue([$value1, $value2]);
575 $dumper->dumpValues($value1, $value2);
579 $dumper->dumpvars('my_package');
580 $dumper->dumpvars('my_package', 'foo', '~bar$', '!......');
582 The optional arguments are considered as literal strings unless they
583 start with C<~> or C<!>, in which case they are interpreted as regular
584 expressions (possibly negated).
586 The second example prints entries with names C<foo>, and also entries
587 with names which ends on C<bar>, or are shorter than 5 chars.
593 Sets C<tick> and C<unctrl> options to suitable values for printout with the
594 given quote char. Possible values are C<auto>, C<'> and C<">.
600 Sets C<unctrl> option with checking for an invalid argument.
601 Possible values are C<unctrl> and C<quote>.
607 Sets C<compactDump> option. If the value is 1, sets to a reasonable
614 Sets C<compactDump> and C<veryCompact> options simultaneously.
618 $d->set(option1 => value1, option2 => value2);
622 @values = $d->get('option1', 'option2');