This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
off-by-one in malloc.c (from Ilya Zakharevich)
[perl5.git] / lib / dumpvar.pl
CommitLineData
d338d6fe
PP
1require 5.002; # For (defined ref)
2package dumpvar;
3
4# Needed for PrettyPrinter only:
5
6# require 5.001; # Well, it coredumps anyway undef DB in 5.000 (not now)
7
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$winsize = 80 unless defined $winsize;
16
17
18# Defaults
19
20# $globPrint = 1;
21$printUndef = 1 unless defined $printUndef;
54d04a52 22$tick = "auto" unless defined $tick;
d338d6fe 23$unctrl = 'quote' unless defined $unctrl;
54d04a52 24$subdump = 1;
22fae026 25$dumpReused = 0 unless defined $dumpReused;
ee239bfe 26$bareStringify = 1 unless defined $bareStringify;
d338d6fe
PP
27
28sub main::dumpValue {
29 local %address;
b2391ea8 30 local $^W=0;
d338d6fe
PP
31 (print "undef\n"), return unless defined $_[0];
32 (print &stringify($_[0]), "\n"), return unless ref $_[0];
33 dumpvar::unwrap($_[0],0);
34}
35
36# This one is good for variable names:
37
38sub unctrl {
39 local($_) = @_;
40 local($v) ;
41
42 return \$_ if ref \$_ eq "GLOB";
43 s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
44 $_;
45}
46
47sub stringify {
48 local($_,$noticks) = @_;
49 local($v) ;
54d04a52 50 my $tick = $tick;
d338d6fe
PP
51
52 return 'undef' unless defined $_ or not $printUndef;
53 return $_ . "" if ref \$_ eq 'GLOB';
ee239bfe
IZ
54 $_ = &{'overload::StrVal'}($_)
55 if $bareStringify and ref $_
475342a6 56 and %overload:: and defined &{'overload::StrVal'};
ee239bfe 57
54d04a52
IZ
58 if ($tick eq 'auto') {
59 if (/[\000-\011\013-\037\177]/) {
60 $tick = '"';
61 }else {
62 $tick = "'";
63 }
64 }
d338d6fe
PP
65 if ($tick eq "'") {
66 s/([\'\\])/\\$1/g;
67 } elsif ($unctrl eq 'unctrl') {
68 s/([\"\\])/\\$1/g ;
69 s/([\000-\037\177])/'^'.pack('c',ord($1)^64)/eg;
70 s/([\200-\377])/'\\0x'.sprintf('%2X',ord($1))/eg
71 if $quoteHighBit;
72 } elsif ($unctrl eq 'quote') {
73 s/([\"\\\$\@])/\\$1/g if $tick eq '"';
74 s/\033/\\e/g;
75 s/([\000-\037\177])/'\\c'.chr(ord($1)^64)/eg;
76 }
77 s/([\200-\377])/'\\'.sprintf('%3o',ord($1))/eg if $quoteHighBit;
78 ($noticks || /^\d+(\.\d*)?\Z/)
79 ? $_
80 : $tick . $_ . $tick;
81}
82
83sub ShortArray {
84 my $tArrayDepth = $#{$_[0]} ;
85 $tArrayDepth = $#{$_[0]} < $arrayDepth-1 ? $#{$_[0]} : $arrayDepth-1
86 unless $arrayDepth eq '' ;
87 my $shortmore = "";
88 $shortmore = " ..." if $tArrayDepth < $#{$_[0]} ;
89 if (!grep(ref $_, @{$_[0]})) {
90 $short = "0..$#{$_[0]} '" .
91 join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore";
92 return $short if length $short <= $compactDump;
93 }
94 undef;
95}
96
97sub DumpElem {
98 my $short = &stringify($_[0], ref $_[0]);
99 if ($veryCompact && ref $_[0]
100 && (ref $_[0] eq 'ARRAY' and !grep(ref $_, @{$_[0]}) )) {
101 my $end = "0..$#{$v} '" .
102 join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore";
103 } elsif ($veryCompact && ref $_[0]
104 && (ref $_[0] eq 'HASH') and !grep(ref $_, values %{$_[0]})) {
105 my $end = 1;
106 $short = $sp . "0..$#{$v} '" .
107 join("' '", @{$v}[0..$tArrayDepth]) . "'$shortmore";
108 } else {
109 print "$short\n";
110 unwrap($_[0],$_[1]);
111 }
112}
113
114sub unwrap {
115 return if $DB::signal;
116 local($v) = shift ;
117 local($s) = shift ; # extra no of spaces
ee239bfe 118 local(%v,@v,$sp,$value,$key,@sortKeys,$more,$shortmore,$short) ;
d338d6fe
PP
119 local($tHashDepth,$tArrayDepth) ;
120
121 $sp = " " x $s ;
122 $s += 3 ;
123
124 # Check for reused addresses
125 if (ref $v) {
ee239bfe
IZ
126 my $val = $v;
127 $val = &{'overload::StrVal'}($v)
475342a6 128 if %overload:: and defined &{'overload::StrVal'};
ee239bfe 129 ($address) = $val =~ /(0x[0-9a-f]+)\)$/ ;
22fae026 130 if (!$dumpReused && defined $address) {
d338d6fe
PP
131 $address{$address}++ ;
132 if ( $address{$address} > 1 ) {
133 print "${sp}-> REUSED_ADDRESS\n" ;
134 return ;
135 }
136 }
137 } elsif (ref \$v eq 'GLOB') {
138 $address = "$v" . ""; # To avoid a bug with globs
139 $address{$address}++ ;
140 if ( $address{$address} > 1 ) {
141 print "${sp}*DUMPED_GLOB*\n" ;
142 return ;
143 }
144 }
145
7894fbab
GS
146 if (ref $v eq 'Regexp') {
147 my $re = "$v";
148 $re =~ s,/,\\/,g;
149 print "$sp-> qr/$re/\n";
150 return;
151 }
152
74b5f52c 153 if ( UNIVERSAL::isa($v, 'HASH') ) {
d338d6fe
PP
154 @sortKeys = sort keys(%$v) ;
155 undef $more ;
156 $tHashDepth = $#sortKeys ;
157 $tHashDepth = $#sortKeys < $hashDepth-1 ? $#sortKeys : $hashDepth-1
158 unless $hashDepth eq '' ;
159 $more = "....\n" if $tHashDepth < $#sortKeys ;
160 $shortmore = "";
161 $shortmore = ", ..." if $tHashDepth < $#sortKeys ;
162 $#sortKeys = $tHashDepth ;
163 if ($compactDump && !grep(ref $_, values %{$v})) {
164 #$short = $sp .
165 # (join ', ',
166# Next row core dumps during require from DB on 5.000, even with map {"_"}
167 # map {&stringify($_) . " => " . &stringify($v->{$_})}
168 # @sortKeys) . "'$shortmore";
169 $short = $sp;
170 my @keys;
171 for (@sortKeys) {
172 push @keys, &stringify($_) . " => " . &stringify($v->{$_});
173 }
174 $short .= join ', ', @keys;
175 $short .= $shortmore;
176 (print "$short\n"), return if length $short <= $compactDump;
177 }
178 for $key (@sortKeys) {
179 return if $DB::signal;
180 $value = $ {$v}{$key} ;
181 print "$sp", &stringify($key), " => ";
182 DumpElem $value, $s;
183 }
184 print "$sp empty hash\n" unless @sortKeys;
185 print "$sp$more" if defined $more ;
74b5f52c 186 } elsif ( UNIVERSAL::isa($v, 'ARRAY') ) {
d338d6fe
PP
187 $tArrayDepth = $#{$v} ;
188 undef $more ;
189 $tArrayDepth = $#{$v} < $arrayDepth-1 ? $#{$v} : $arrayDepth-1
190 unless $arrayDepth eq '' ;
191 $more = "....\n" if $tArrayDepth < $#{$v} ;
192 $shortmore = "";
193 $shortmore = " ..." if $tArrayDepth < $#{$v} ;
194 if ($compactDump && !grep(ref $_, @{$v})) {
195 if ($#$v >= 0) {
54d04a52
IZ
196 $short = $sp . "0..$#{$v} " .
197 join(" ",
198 map {stringify $_} @{$v}[0..$tArrayDepth])
199 . "$shortmore";
d338d6fe
PP
200 } else {
201 $short = $sp . "empty array";
202 }
203 (print "$short\n"), return if length $short <= $compactDump;
204 }
205 #if ($compactDump && $short = ShortArray($v)) {
206 # print "$short\n";
207 # return;
208 #}
209 for $num ($[ .. $tArrayDepth) {
210 return if $DB::signal;
211 print "$sp$num ";
212 DumpElem $v->[$num], $s;
213 }
214 print "$sp empty array\n" unless @$v;
215 print "$sp$more" if defined $more ;
74b5f52c 216 } elsif ( UNIVERSAL::isa($v, 'SCALAR') or ref $v eq 'REF' ) {
d338d6fe
PP
217 print "$sp-> ";
218 DumpElem $$v, $s;
74b5f52c 219 } elsif ( UNIVERSAL::isa($v, 'CODE') ) {
54d04a52
IZ
220 print "$sp-> ";
221 dumpsub (0, $v);
74b5f52c 222 } elsif ( UNIVERSAL::isa($v, 'GLOB') ) {
d338d6fe
PP
223 print "$sp-> ",&stringify($$v,1),"\n";
224 if ($globPrint) {
225 $s += 3;
226 dumpglob($s, "{$$v}", $$v, 1);
227 } elsif (defined ($fileno = fileno($v))) {
228 print( (' ' x ($s+3)) . "FileHandle({$$v}) => fileno($fileno)\n" );
229 }
230 } elsif (ref \$v eq 'GLOB') {
231 if ($globPrint) {
232 dumpglob($s, "{$v}", $v, 1) if $globPrint;
233 } elsif (defined ($fileno = fileno(\$v))) {
234 print( (' ' x $s) . "FileHandle({$v}) => fileno($fileno)\n" );
235 }
236 }
237}
238
239sub matchvar {
240 $_[0] eq $_[1] or
b2391ea8
PP
241 ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and
242 ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/});
d338d6fe
PP
243}
244
245sub compactDump {
246 $compactDump = shift if @_;
247 $compactDump = 6*80-1 if $compactDump and $compactDump < 2;
248 $compactDump;
249}
250
251sub veryCompact {
252 $veryCompact = shift if @_;
253 compactDump(1) if !$compactDump and $veryCompact;
254 $veryCompact;
255}
256
257sub unctrlSet {
258 if (@_) {
259 my $in = shift;
260 if ($in eq 'unctrl' or $in eq 'quote') {
261 $unctrl = $in;
262 } else {
263 print "Unknown value for `unctrl'.\n";
264 }
265 }
266 $unctrl;
267}
268
269sub quote {
270 if (@_ and $_[0] eq '"') {
271 $tick = '"';
272 $unctrl = 'quote';
54d04a52
IZ
273 } elsif (@_ and $_[0] eq 'auto') {
274 $tick = 'auto';
275 $unctrl = 'quote';
d338d6fe
PP
276 } elsif (@_) { # Need to set
277 $tick = "'";
278 $unctrl = 'unctrl';
279 }
280 $tick;
281}
282
283sub dumpglob {
284 return if $DB::signal;
285 my ($off,$key, $val, $all) = @_;
286 local(*entry) = $val;
287 my $fileno;
54d04a52 288 if (($key !~ /^_</ or $dumpDBFiles) and defined $entry) {
d338d6fe
PP
289 print( (' ' x $off) . "\$", &unctrl($key), " = " );
290 DumpElem $entry, 3+$off;
291 }
475342a6 292 if (($key !~ /^_</ or $dumpDBFiles) and @entry) {
d338d6fe
PP
293 print( (' ' x $off) . "\@$key = (\n" );
294 unwrap(\@entry,3+$off) ;
295 print( (' ' x $off) . ")\n" );
296 }
475342a6 297 if ($key ne "main::" && $key ne "DB::" && %entry
d338d6fe 298 && ($dumpPackages or $key !~ /::$/)
54d04a52 299 && ($key !~ /^_</ or $dumpDBFiles)
d338d6fe
PP
300 && !($package eq "dumpvar" and $key eq "stab")) {
301 print( (' ' x $off) . "\%$key = (\n" );
302 unwrap(\%entry,3+$off) ;
303 print( (' ' x $off) . ")\n" );
304 }
305 if (defined ($fileno = fileno(*entry))) {
306 print( (' ' x $off) . "FileHandle($key) => fileno($fileno)\n" );
307 }
308 if ($all) {
309 if (defined &entry) {
54d04a52 310 dumpsub($off, $key);
d338d6fe
PP
311 }
312 }
313}
314
54d04a52
IZ
315sub dumpsub {
316 my ($off,$sub) = @_;
317 $sub = $1 if $sub =~ /^\{\*(.*)\}$/;
318 my $subref = \&$sub;
319 my $place = $DB::sub{$sub} || (($sub = $subs{"$subref"}) && $DB::sub{$sub})
320 || ($subdump && ($sub = findsubs("$subref")) && $DB::sub{$sub});
321 $place = '???' unless defined $place;
322 print( (' ' x $off) . "&$sub in $place\n" );
323}
324
325sub findsubs {
475342a6 326 return undef unless %DB::sub;
54d04a52
IZ
327 my ($addr, $name, $loc);
328 while (($name, $loc) = each %DB::sub) {
329 $addr = \&$name;
330 $subs{"$addr"} = $name;
331 }
332 $subdump = 0;
333 $subs{ shift() };
334}
335
d338d6fe
PP
336sub main::dumpvar {
337 my ($package,@vars) = @_;
b2391ea8 338 local(%address,$key,$val,$^W);
d338d6fe
PP
339 $package .= "::" unless $package =~ /::$/;
340 *stab = *{"main::"};
341 while ($package =~ /(\w+?::)/g){
342 *stab = $ {stab}{$1};
343 }
344 local $TotalStrings = 0;
345 local $Strings = 0;
346 local $CompleteTotal = 0;
347 while (($key,$val) = each(%stab)) {
348 return if $DB::signal;
349 next if @vars && !grep( matchvar($key, $_), @vars );
350 if ($usageOnly) {
351 globUsage(\$val, $key) unless $package eq 'dumpvar' and $key eq 'stab';
352 } else {
353 dumpglob(0,$key, $val);
354 }
355 }
356 if ($usageOnly) {
357 print "String space: $TotalStrings bytes in $Strings strings.\n";
358 $CompleteTotal += $TotalStrings;
359 print "Grand total = $CompleteTotal bytes (1 level deep) + overhead.\n";
360 }
361}
362
363sub scalarUsage {
364 my $size = length($_[0]);
365 $TotalStrings += $size;
366 $Strings++;
367 $size;
368}
369
370sub arrayUsage { # array ref, name
371 my $size = 0;
372 map {$size += scalarUsage($_)} @{$_[0]};
373 my $len = @{$_[0]};
374 print "\@$_[1] = $len item", ($len > 1 ? "s" : ""),
375 " (data: $size bytes)\n"
376 if defined $_[1];
377 $CompleteTotal += $size;
378 $size;
379}
380
381sub hashUsage { # hash ref, name
382 my @keys = keys %{$_[0]};
383 my @values = values %{$_[0]};
384 my $keys = arrayUsage \@keys;
385 my $values = arrayUsage \@values;
386 my $len = @keys;
387 my $total = $keys + $values;
388 print "\%$_[1] = $len item", ($len > 1 ? "s" : ""),
389 " (keys: $keys; values: $values; total: $total bytes)\n"
390 if defined $_[1];
391 $total;
392}
393
394sub globUsage { # glob ref, name
395 local *name = *{$_[0]};
396 $total = 0;
397 $total += scalarUsage $name if defined $name;
475342a6
GS
398 $total += arrayUsage \@name, $_[1] if @name;
399 $total += hashUsage \%name, $_[1] if %name and $_[1] ne "main::"
d338d6fe
PP
400 and $_[1] ne "DB::"; #and !($package eq "dumpvar" and $key eq "stab"));
401 $total;
402}
403
404sub packageUsage {
405 my ($package,@vars) = @_;
406 $package .= "::" unless $package =~ /::$/;
407 local *stab = *{"main::"};
408 while ($package =~ /(\w+?::)/g){
409 *stab = $ {stab}{$1};
410 }
411 local $TotalStrings = 0;
412 local $CompleteTotal = 0;
413 my ($key,$val);
414 while (($key,$val) = each(%stab)) {
415 next if @vars && !grep($key eq $_,@vars);
416 globUsage \$val, $key unless $package eq 'dumpvar' and $key eq 'stab';
417 }
418 print "String space: $TotalStrings.\n";
419 $CompleteTotal += $TotalStrings;
420 print "\nGrand total = $CompleteTotal bytes\n";
421}
422
4231;
424