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