← Index
NYTProf Performance Profile   « line view »
For rbm/rbm
  Run on Wed Feb 12 20:36:06 2020
Reported on Wed Feb 12 21:42:25 2020

Filename/usr/share/perl5/Data/Dump.pm
StatementsExecuted 23 statements in 3.79ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
111178µs185µsData::Dump::::BEGIN@5Data::Dump::BEGIN@5
11111µs40µsData::Dump::::BEGIN@232Data::Dump::BEGIN@232
11110µs13µsData::Dump::::BEGIN@3Data::Dump::BEGIN@3
1119µs44µsData::Dump::::BEGIN@4Data::Dump::BEGIN@4
1116µs64µsData::Dump::::BEGIN@16Data::Dump::BEGIN@16
1115µs5µsData::Dump::::BEGIN@15Data::Dump::BEGIN@15
0000s0sData::Dump::::__ANON__[:156]Data::Dump::__ANON__[:156]
0000s0sData::Dump::::_dumpData::Dump::_dump
0000s0sData::Dump::::ddData::Dump::dd
0000s0sData::Dump::::ddxData::Dump::ddx
0000s0sData::Dump::::dumpData::Dump::dump
0000s0sData::Dump::::dumpfData::Dump::dumpf
0000s0sData::Dump::::format_listData::Dump::format_list
0000s0sData::Dump::::fullnameData::Dump::fullname
0000s0sData::Dump::::quoteData::Dump::quote
0000s0sData::Dump::::strData::Dump::str
0000s0sData::Dump::::tied_strData::Dump::tied_str
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package Data::Dump;
2
3224µs215µs
# spent 13µs (10+2) within Data::Dump::BEGIN@3 which was called: # once (10µs+2µs) by RBM::BEGIN@23 at line 3
use strict;
# spent 13µs making 1 call to Data::Dump::BEGIN@3 # spent 2µs making 1 call to strict::import
4228µs279µs
# spent 44µs (9+35) within Data::Dump::BEGIN@4 which was called: # once (9µs+35µs) by RBM::BEGIN@23 at line 4
use vars qw(@EXPORT @EXPORT_OK $VERSION $DEBUG);
# spent 44µs making 1 call to Data::Dump::BEGIN@4 # spent 35µs making 1 call to vars::import
52230µs2193µs
# spent 185µs (178+7) within Data::Dump::BEGIN@5 which was called: # once (178µs+7µs) by RBM::BEGIN@23 at line 5
use subs qq(dump);
# spent 185µs making 1 call to Data::Dump::BEGIN@5 # spent 8µs making 1 call to subs::import
6
71600nsrequire Exporter;
811µs*import = \&Exporter::import;
91900ns@EXPORT = qw(dd ddx);
101500ns@EXPORT_OK = qw(dump pp dumpf quote);
11
121100ns$VERSION = "1.23";
131100ns$DEBUG = 0;
14
15225µs15µs
# spent 5µs within Data::Dump::BEGIN@15 which was called: # once (5µs+0s) by RBM::BEGIN@23 at line 15
use overload ();
# spent 5µs making 1 call to Data::Dump::BEGIN@15
1621.30ms2123µs
# spent 64µs (6+59) within Data::Dump::BEGIN@16 which was called: # once (6µs+59µs) by RBM::BEGIN@23 at line 16
use vars qw(%seen %refcnt @dump @fixup %require $TRY_BASE64 @FILTERS $INDENT);
# spent 64µs making 1 call to Data::Dump::BEGIN@16 # spent 59µs making 1 call to vars::import
17
181200ns$TRY_BASE64 = 50 unless defined $TRY_BASE64;
191200ns$INDENT = " " unless defined $INDENT;
20
21sub dump
22{
23 local %seen;
24 local %refcnt;
25 local %require;
26 local @fixup;
27
28 require Data::Dump::FilterContext if @FILTERS;
29
30 my $name = "a";
31 my @dump;
32
33 for my $v (@_) {
34 my $val = _dump($v, $name, [], tied($v));
35 push(@dump, [$name, $val]);
36 } continue {
37 $name++;
38 }
39
40 my $out = "";
41 if (%require) {
42 for (sort keys %require) {
43 $out .= "require $_;\n";
44 }
45 }
46 if (%refcnt) {
47 # output all those with refcounts first
48 for (@dump) {
49 my $name = $_->[0];
50 if ($refcnt{$name}) {
51 $out .= "my \$$name = $_->[1];\n";
52 undef $_->[1];
53 }
54 }
55 for (@fixup) {
56 $out .= "$_;\n";
57 }
58 }
59
60 my $paren = (@dump != 1);
61 $out .= "(" if $paren;
62 $out .= format_list($paren, undef,
63 map {defined($_->[1]) ? $_->[1] : "\$".$_->[0]}
64 @dump
65 );
66 $out .= ")" if $paren;
67
68 if (%refcnt || %require) {
69 $out .= ";\n";
70 $out =~ s/^/$INDENT/gm;
71 $out = "do {\n$out}";
72 }
73
74 print STDERR "$out\n" unless defined wantarray;
75 $out;
76}
77
781400ns*pp = \&dump;
79
80sub dd {
81 print dump(@_), "\n";
82}
83
84sub ddx {
85 my(undef, $file, $line) = caller;
86 $file =~ s,.*[\\/],,;
87 my $out = "$file:$line: " . dump(@_) . "\n";
88 $out =~ s/^/# /gm;
89 print $out;
90}
91
92sub dumpf {
93 require Data::Dump::Filtered;
94 goto &Data::Dump::Filtered::dump_filtered;
95}
96
97sub _dump
98{
99 my $ref = ref $_[0];
100 my $rval = $ref ? $_[0] : \$_[0];
101 shift;
102
103 my($name, $idx, $dont_remember, $pclass, $pidx) = @_;
104
105 my($class, $type, $id);
106 my $strval = overload::StrVal($rval);
107 # Parse $strval without using regexps, in order not to clobber $1, $2,...
108 if ((my $i = rindex($strval, "=")) >= 0) {
109 $class = substr($strval, 0, $i);
110 $strval = substr($strval, $i+1);
111 }
112 if ((my $i = index($strval, "(0x")) >= 0) {
113 $type = substr($strval, 0, $i);
114 $id = substr($strval, $i + 2, -1);
115 }
116 else {
117 die "Can't parse " . overload::StrVal($rval);
118 }
119 if ($] < 5.008 && $type eq "SCALAR") {
120 $type = "REF" if $ref eq "REF";
121 }
122 warn "\$$name(@$idx) $class $type $id ($ref)" if $DEBUG;
123
124 my $out;
125 my $comment;
126 my $hide_keys;
127 if (@FILTERS) {
128 my $pself = "";
129 $pself = fullname("self", [@$idx[$pidx..(@$idx - 1)]]) if $pclass;
130 my $ctx = Data::Dump::FilterContext->new($rval, $class, $type, $ref, $pclass, $pidx, $idx);
131 my @bless;
132 for my $filter (@FILTERS) {
133 if (my $f = $filter->($ctx, $rval)) {
134 if (my $v = $f->{object}) {
135 local @FILTERS;
136 $out = _dump($v, $name, $idx, 1);
137 $dont_remember++;
138 }
139 if (defined(my $c = $f->{bless})) {
140 push(@bless, $c);
141 }
142 if (my $c = $f->{comment}) {
143 $comment = $c;
144 }
145 if (defined(my $c = $f->{dump})) {
146 $out = $c;
147 $dont_remember++;
148 }
149 if (my $h = $f->{hide_keys}) {
150 if (ref($h) eq "ARRAY") {
151 $hide_keys = sub {
152 for my $k (@$h) {
153 return 1 if $k eq $_[0];
154 }
155 return 0;
156 };
157 }
158 }
159 }
160 }
161 push(@bless, "") if defined($out) && !@bless;
162 if (@bless) {
163 $class = shift(@bless);
164 warn "More than one filter callback tried to bless object" if @bless;
165 }
166 }
167
168 unless ($dont_remember) {
169 if (my $s = $seen{$id}) {
170 my($sname, $sidx) = @$s;
171 $refcnt{$sname}++;
172 my $sref = fullname($sname, $sidx,
173 ($ref && $type eq "SCALAR"));
174 warn "SEEN: [\$$name(@$idx)] => [\$$sname(@$sidx)] ($ref,$sref)" if $DEBUG;
175 return $sref unless $sname eq $name;
176 $refcnt{$name}++;
177 push(@fixup, fullname($name,$idx)." = $sref");
178 return "do{my \$fix}" if @$idx && $idx->[-1] eq '$';
179 return "'fix'";
180 }
181 $seen{$id} = [$name, $idx];
182 }
183
184 if ($class) {
185 $pclass = $class;
186 $pidx = @$idx;
187 }
188
189 if (defined $out) {
190 # keep it
191 }
192 elsif ($type eq "SCALAR" || $type eq "REF" || $type eq "REGEXP") {
193 if ($ref) {
194 if ($class && $class eq "Regexp") {
195 my $v = "$rval";
196
197 my $mod = "";
198 if ($v =~ /^\(\?\^?([msix-]*):([\x00-\xFF]*)\)\z/) {
199 $mod = $1;
200 $v = $2;
201 $mod =~ s/-.*//;
202 }
203
204 my $sep = '/';
205 my $sep_count = ($v =~ tr/\///);
206 if ($sep_count) {
207 # see if we can find a better one
208 for ('|', ',', ':', '#') {
209 my $c = eval "\$v =~ tr/\Q$_\E//";
210 #print "SEP $_ $c $sep_count\n";
211 if ($c < $sep_count) {
212 $sep = $_;
213 $sep_count = $c;
214 last if $sep_count == 0;
215 }
216 }
217 }
218 $v =~ s/\Q$sep\E/\\$sep/g;
219
220 $out = "qr$sep$v$sep$mod";
221 undef($class);
222 }
223 else {
224 delete $seen{$id} if $type eq "SCALAR"; # will be seen again shortly
225 my $val = _dump($$rval, $name, [@$idx, "\$"], 0, $pclass, $pidx);
226 $out = $class ? "do{\\(my \$o = $val)}" : "\\$val";
227 }
228 } else {
229 if (!defined $$rval) {
230 $out = "undef";
231 }
23222.17ms270µs
# spent 40µs (11+29) within Data::Dump::BEGIN@232 which was called: # once (11µs+29µs) by RBM::BEGIN@23 at line 232
elsif (do {no warnings 'numeric'; $$rval + 0 eq $$rval}) {
# spent 40µs making 1 call to Data::Dump::BEGIN@232 # spent 29µs making 1 call to warnings::unimport
233 $out = $$rval;
234 }
235 else {
236 $out = str($$rval);
237 }
238 if ($class && !@$idx) {
239 # Top is an object, not a reference to one as perl needs
240 $refcnt{$name}++;
241 my $obj = fullname($name, $idx);
242 my $cl = quote($class);
243 push(@fixup, "bless \\$obj, $cl");
244 }
245 }
246 }
247 elsif ($type eq "GLOB") {
248 if ($ref) {
249 delete $seen{$id};
250 my $val = _dump($$rval, $name, [@$idx, "*"], 0, $pclass, $pidx);
251 $out = "\\$val";
252 if ($out =~ /^\\\*Symbol::/) {
253 $require{Symbol}++;
254 $out = "Symbol::gensym()";
255 }
256 } else {
257 my $val = "$$rval";
258 $out = "$$rval";
259
260 for my $k (qw(SCALAR ARRAY HASH)) {
261 my $gval = *$$rval{$k};
262 next unless defined $gval;
263 next if $k eq "SCALAR" && ! defined $$gval; # always there
264 my $f = scalar @fixup;
265 push(@fixup, "RESERVED"); # overwritten after _dump() below
266 $gval = _dump($gval, $name, [@$idx, "*{$k}"], 0, $pclass, $pidx);
267 $refcnt{$name}++;
268 my $gname = fullname($name, $idx);
269 $fixup[$f] = "$gname = $gval"; #XXX indent $gval
270 }
271 }
272 }
273 elsif ($type eq "ARRAY") {
274 my @vals;
275 my $tied = tied_str(tied(@$rval));
276 my $i = 0;
277 for my $v (@$rval) {
278 push(@vals, _dump($v, $name, [@$idx, "[$i]"], $tied, $pclass, $pidx));
279 $i++;
280 }
281 $out = "[" . format_list(1, $tied, @vals) . "]";
282 }
283 elsif ($type eq "HASH") {
284 my(@keys, @vals);
285 my $tied = tied_str(tied(%$rval));
286
287 # statistics to determine variation in key lengths
288 my $kstat_max = 0;
289 my $kstat_sum = 0;
290 my $kstat_sum2 = 0;
291
292 my @orig_keys = keys %$rval;
293 if ($hide_keys) {
294 @orig_keys = grep !$hide_keys->($_), @orig_keys;
295 }
296 my $text_keys = 0;
297 for (@orig_keys) {
298 $text_keys++, last unless /^[-+]?(?:0|[1-9]\d*)(?:\.\d+)?\z/;
299 }
300
301 if ($text_keys) {
302 @orig_keys = sort { lc($a) cmp lc($b) } @orig_keys;
303 }
304 else {
305 @orig_keys = sort { $a <=> $b } @orig_keys;
306 }
307
308 my $quote;
309 for my $key (@orig_keys) {
310 next if $key =~ /^-?[a-zA-Z_]\w*\z/;
311 next if $key =~ /^-?[1-9]\d{0,8}\z/;
312 $quote++;
313 last;
314 }
315
316 for my $key (@orig_keys) {
317 my $val = \$rval->{$key}; # capture value before we modify $key
318 $key = quote($key) if $quote;
319 $kstat_max = length($key) if length($key) > $kstat_max;
320 $kstat_sum += length($key);
321 $kstat_sum2 += length($key)*length($key);
322
323 push(@keys, $key);
324 push(@vals, _dump($$val, $name, [@$idx, "{$key}"], $tied, $pclass, $pidx));
325 }
326 my $nl = "";
327 my $klen_pad = 0;
328 my $tmp = "@keys @vals";
329 if (length($tmp) > 60 || $tmp =~ /\n/ || $tied) {
330 $nl = "\n";
331
332 # Determine what padding to add
333 if ($kstat_max < 4) {
334 $klen_pad = $kstat_max;
335 }
336 elsif (@keys >= 2) {
337 my $n = @keys;
338 my $avg = $kstat_sum/$n;
339 my $stddev = sqrt(($kstat_sum2 - $n * $avg * $avg) / ($n - 1));
340
341 # I am not actually very happy with this heuristics
342 if ($stddev / $kstat_max < 0.25) {
343 $klen_pad = $kstat_max;
344 }
345 if ($DEBUG) {
346 push(@keys, "__S");
347 push(@vals, sprintf("%.2f (%d/%.1f/%.1f)",
348 $stddev / $kstat_max,
349 $kstat_max, $avg, $stddev));
350 }
351 }
352 }
353 $out = "{$nl";
354 $out .= "$INDENT# $tied$nl" if $tied;
355 while (@keys) {
356 my $key = shift @keys;
357 my $val = shift @vals;
358 my $vpad = $INDENT . (" " x ($klen_pad ? $klen_pad + 4 : 0));
359 $val =~ s/\n/\n$vpad/gm;
360 my $kpad = $nl ? $INDENT : " ";
361 $key .= " " x ($klen_pad - length($key)) if $nl && $klen_pad > length($key);
362 $out .= "$kpad$key => $val,$nl";
363 }
364 $out =~ s/,$/ / unless $nl;
365 $out .= "}";
366 }
367 elsif ($type eq "CODE") {
368 $out = 'sub { ... }';
369 }
370 elsif ($type eq "VSTRING") {
371 $out = sprintf +($ref ? '\v%vd' : 'v%vd'), $$rval;
372 }
373 else {
374 warn "Can't handle $type data";
375 $out = "'#$type#'";
376 }
377
378 if ($class && $ref) {
379 $out = "bless($out, " . quote($class) . ")";
380 }
381 if ($comment) {
382 $comment =~ s/^/# /gm;
383 $comment .= "\n" unless $comment =~ /\n\z/;
384 $comment =~ s/^#[ \t]+\n/\n/;
385 $out = "$comment$out";
386 }
387 return $out;
388}
389
390sub tied_str {
391 my $tied = shift;
392 if ($tied) {
393 if (my $tied_ref = ref($tied)) {
394 $tied = "tied $tied_ref";
395 }
396 else {
397 $tied = "tied";
398 }
399 }
400 return $tied;
401}
402
403sub fullname
404{
405 my($name, $idx, $ref) = @_;
406 substr($name, 0, 0) = "\$";
407
408 my @i = @$idx; # need copy in order to not modify @$idx
409 if ($ref && @i && $i[0] eq "\$") {
410 shift(@i); # remove one deref
411 $ref = 0;
412 }
413 while (@i && $i[0] eq "\$") {
414 shift @i;
415 $name = "\$$name";
416 }
417
418 my $last_was_index;
419 for my $i (@i) {
420 if ($i eq "*" || $i eq "\$") {
421 $last_was_index = 0;
422 $name = "$i\{$name}";
423 } elsif ($i =~ s/^\*//) {
424 $name .= $i;
425 $last_was_index++;
426 } else {
427 $name .= "->" unless $last_was_index++;
428 $name .= $i;
429 }
430 }
431 $name = "\\$name" if $ref;
432 $name;
433}
434
435sub format_list
436{
437 my $paren = shift;
438 my $comment = shift;
439 my $indent_lim = $paren ? 0 : 1;
440 if (@_ > 3) {
441 # can we use range operator to shorten the list?
442 my $i = 0;
443 while ($i < @_) {
444 my $j = $i + 1;
445 my $v = $_[$i];
446 while ($j < @_) {
447 # XXX allow string increment too?
448 if ($v eq "0" || $v =~ /^-?[1-9]\d{0,9}\z/) {
449 $v++;
450 }
451 elsif ($v =~ /^"([A-Za-z]{1,3}\d*)"\z/) {
452 $v = $1;
453 $v++;
454 $v = qq("$v");
455 }
456 else {
457 last;
458 }
459 last if $_[$j] ne $v;
460 $j++;
461 }
462 if ($j - $i > 3) {
463 splice(@_, $i, $j - $i, "$_[$i] .. $_[$j-1]");
464 }
465 $i++;
466 }
467 }
468 my $tmp = "@_";
469 if ($comment || (@_ > $indent_lim && (length($tmp) > 60 || $tmp =~ /\n/))) {
470 my @elem = @_;
471 for (@elem) { s/^/$INDENT/gm; }
472 return "\n" . ($comment ? "$INDENT# $comment\n" : "") .
473 join(",\n", @elem, "");
474 } else {
475 return join(", ", @_);
476 }
477}
478
479sub str {
480 if (length($_[0]) > 20) {
481 for ($_[0]) {
482 # Check for repeated string
483 if (/^(.)\1\1\1/s) {
484 # seems to be a repeating sequence, let's check if it really is
485 # without backtracking
486 unless (/[^\Q$1\E]/) {
487 my $base = quote($1);
488 my $repeat = length;
489 return "($base x $repeat)"
490 }
491 }
492 # Length protection because the RE engine will blow the stack [RT#33520]
493 if (length($_) < 16 * 1024 && /^(.{2,5}?)\1*\z/s) {
494 my $base = quote($1);
495 my $repeat = length($_)/length($1);
496 return "($base x $repeat)";
497 }
498 }
499 }
500
501 local $_ = &quote;
502
503 if (length($_) > 40 && !/\\x\{/ && length($_) > (length($_[0]) * 2)) {
504 # too much binary data, better to represent as a hex/base64 string
505
506 # Base64 is more compact than hex when string is longer than
507 # 17 bytes (not counting any require statement needed).
508 # But on the other hand, hex is much more readable.
509 if ($TRY_BASE64 && length($_[0]) > $TRY_BASE64 &&
510 (defined &utf8::is_utf8 && !utf8::is_utf8($_[0])) &&
511 eval { require MIME::Base64 })
512 {
513 $require{"MIME::Base64"}++;
514 return "MIME::Base64::decode(\"" .
515 MIME::Base64::encode($_[0],"") .
516 "\")";
517 }
518 return "pack(\"H*\",\"" . unpack("H*", $_[0]) . "\")";
519 }
520
521 return $_;
522}
523
52414µsmy %esc = (
525 "\a" => "\\a",
526 "\b" => "\\b",
527 "\t" => "\\t",
528 "\n" => "\\n",
529 "\f" => "\\f",
530 "\r" => "\\r",
531 "\e" => "\\e",
532);
533
534# put a string value in double quotes
535sub quote {
536 local($_) = $_[0];
537 # If there are many '"' we might want to use qq() instead
538 s/([\\\"\@\$])/\\$1/g;
539 return qq("$_") unless /[^\040-\176]/; # fast exit
540
541 s/([\a\b\t\n\f\r\e])/$esc{$1}/g;
542
543 # no need for 3 digits in escape for these
544 s/([\0-\037])(?!\d)/sprintf('\\%o',ord($1))/eg;
545
546 s/([\0-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg;
547 s/([^\040-\176])/sprintf('\\x{%X}',ord($1))/eg;
548
549 return qq("$_");
550}
551
55219µs1;
553
554__END__
Report produced by the NYTProf 6.06 Perl profiler, developed by Tim Bunce based on work by Adam Kaplan and Salvador Fandiño García.