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