← Index
NYTProf Performance Profile   « block view • line view • sub view »
For conv.pl
  Run on Sun Nov 14 22:50:31 2010
Reported on Sun Nov 14 22:51:20 2010

Filename/usr/lib/perl/5.10/Data/Dumper.pm
StatementsExecuted 40 statements in 6.30ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
111316µs321µsData::Dumper::::BEGIN@683Data::Dumper::BEGIN@683
11174µs74µsData::Dumper::::BEGIN@16Data::Dumper::BEGIN@16
11126µs26µsData::Dumper::::BEGIN@22Data::Dumper::BEGIN@22
11116µs98µsData::Dumper::::BEGIN@20Data::Dumper::BEGIN@20
0000s0sData::Dumper::::BlessData::Dumper::Bless
0000s0sData::Dumper::::DESTROYData::Dumper::DESTROY
0000s0sData::Dumper::::DeepcopyData::Dumper::Deepcopy
0000s0sData::Dumper::::DeparseData::Dumper::Deparse
0000s0sData::Dumper::::DumpData::Dumper::Dump
0000s0sData::Dumper::::DumperData::Dumper::Dumper
0000s0sData::Dumper::::DumperXData::Dumper::DumperX
0000s0sData::Dumper::::DumpfData::Dumper::Dumpf
0000s0sData::Dumper::::DumppData::Dumper::Dumpp
0000s0sData::Dumper::::DumpperlData::Dumper::Dumpperl
0000s0sData::Dumper::::FreezerData::Dumper::Freezer
0000s0sData::Dumper::::IndentData::Dumper::Indent
0000s0sData::Dumper::::MaxdepthData::Dumper::Maxdepth
0000s0sData::Dumper::::NamesData::Dumper::Names
0000s0sData::Dumper::::PadData::Dumper::Pad
0000s0sData::Dumper::::PairData::Dumper::Pair
0000s0sData::Dumper::::PurityData::Dumper::Purity
0000s0sData::Dumper::::QuotekeysData::Dumper::Quotekeys
0000s0sData::Dumper::::ResetData::Dumper::Reset
0000s0sData::Dumper::::SeenData::Dumper::Seen
0000s0sData::Dumper::::SortkeysData::Dumper::Sortkeys
0000s0sData::Dumper::::TerseData::Dumper::Terse
0000s0sData::Dumper::::ToasterData::Dumper::Toaster
0000s0sData::Dumper::::UseperlData::Dumper::Useperl
0000s0sData::Dumper::::UseqqData::Dumper::Useqq
0000s0sData::Dumper::::ValuesData::Dumper::Values
0000s0sData::Dumper::::VarnameData::Dumper::Varname
0000s0sData::Dumper::::__ANON__[:106]Data::Dumper::__ANON__[:106]
0000s0sData::Dumper::::__ANON__[:111]Data::Dumper::__ANON__[:111]
0000s0sData::Dumper::::__ANON__[:118]Data::Dumper::__ANON__[:118]
0000s0sData::Dumper::::__ANON__[:123]Data::Dumper::__ANON__[:123]
0000s0sData::Dumper::::_dumpData::Dumper::_dump
0000s0sData::Dumper::::_quoteData::Dumper::_quote
0000s0sData::Dumper::::_sortkeysData::Dumper::_sortkeys
0000s0sData::Dumper::::newData::Dumper::new
0000s0sData::Dumper::::qquoteData::Dumper::qquote
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1#
2# Data/Dumper.pm
3#
4# convert perl data structures into perl syntax suitable for both printing
5# and eval
6#
7# Documentation at the __END__
8#
9
10package Data::Dumper;
11
1212µs$VERSION = '2.124'; # Don't forget to set version and release date in POD!
13
14#$| = 1;
15
163110µs174µs
# spent 74µs within Data::Dumper::BEGIN@16 which was called: # once (74µs+0s) by XML::LibXML::Error::BEGIN@225 at line 16
use 5.006_001;
# spent 74µs making 1 call to Data::Dumper::BEGIN@16
1712µsrequire Exporter;
1811µsrequire overload;
19
203101µs2180µs
# spent 98µs (16+82) within Data::Dumper::BEGIN@20 which was called: # once (16µs+82µs) by XML::LibXML::Error::BEGIN@225 at line 20
use Carp;
# spent 98µs making 1 call to Data::Dumper::BEGIN@20 # spent 82µs making 1 call to Exporter::import
21
22
# spent 26µs within Data::Dumper::BEGIN@22 which was called: # once (26µs+0s) by XML::LibXML::Error::BEGIN@225 at line 34
BEGIN {
23625µs @ISA = qw(Exporter);
24 @EXPORT = qw(Dumper);
25 @EXPORT_OK = qw(DumperX);
26
27 # if run under miniperl, or otherwise lacking dynamic loading,
28 # XSLoader should be attempted to load, or the pure perl flag
29 # toggled on load failure.
30 eval {
31 require XSLoader;
32 };
33 $Useperl = 1 if $@;
3414.97ms126µs}
# spent 26µs making 1 call to Data::Dumper::BEGIN@22
35
361221µs1213µsXSLoader::load( 'Data::Dumper' ) unless $Useperl;
# spent 213µs making 1 call to XSLoader::load
37
38# module vars and their defaults
3911µs$Indent = 2 unless defined $Indent;
4011µs$Purity = 0 unless defined $Purity;
4111µs$Pad = "" unless defined $Pad;
4212µs$Varname = "VAR" unless defined $Varname;
4311µs$Useqq = 0 unless defined $Useqq;
4411µs$Terse = 0 unless defined $Terse;
4511µs$Freezer = "" unless defined $Freezer;
4611µs$Toaster = "" unless defined $Toaster;
4711µs$Deepcopy = 0 unless defined $Deepcopy;
4811µs$Quotekeys = 1 unless defined $Quotekeys;
4911µs$Bless = "bless" unless defined $Bless;
50#$Expdepth = 0 unless defined $Expdepth;
5111µs$Maxdepth = 0 unless defined $Maxdepth;
5211µs$Pair = ' => ' unless defined $Pair;
5310s$Useperl = 0 unless defined $Useperl;
5411µs$Sortkeys = 0 unless defined $Sortkeys;
5511µs$Deparse = 0 unless defined $Deparse;
56
57#
58# expects an arrayref of values to be dumped.
59# can optionally pass an arrayref of names for the values.
60# names must have leading $ sign stripped. begin the name with *
61# to cause output of arrays and hashes rather than refs.
62#
63sub new {
64 my($c, $v, $n) = @_;
65
66 croak "Usage: PACKAGE->new(ARRAYREF, [ARRAYREF])"
67 unless (defined($v) && (ref($v) eq 'ARRAY'));
68 $n = [] unless (defined($n) && (ref($n) eq 'ARRAY'));
69
70 my($s) = {
71 level => 0, # current recursive depth
72 indent => $Indent, # various styles of indenting
73 pad => $Pad, # all lines prefixed by this string
74 xpad => "", # padding-per-level
75 apad => "", # added padding for hash keys n such
76 sep => "", # list separator
77 pair => $Pair, # hash key/value separator: defaults to ' => '
78 seen => {}, # local (nested) refs (id => [name, val])
79 todump => $v, # values to dump []
80 names => $n, # optional names for values []
81 varname => $Varname, # prefix to use for tagging nameless ones
82 purity => $Purity, # degree to which output is evalable
83 useqq => $Useqq, # use "" for strings (backslashitis ensues)
84 terse => $Terse, # avoid name output (where feasible)
85 freezer => $Freezer, # name of Freezer method for objects
86 toaster => $Toaster, # name of method to revive objects
87 deepcopy => $Deepcopy, # dont cross-ref, except to stop recursion
88 quotekeys => $Quotekeys, # quote hash keys
89 'bless' => $Bless, # keyword to use for "bless"
90# expdepth => $Expdepth, # cutoff depth for explicit dumping
91 maxdepth => $Maxdepth, # depth beyond which we give up
92 useperl => $Useperl, # use the pure Perl implementation
93 sortkeys => $Sortkeys, # flag or filter for sorting hash keys
94 deparse => $Deparse, # use B::Deparse for coderefs
95 };
96
97 if ($Indent > 0) {
98 $s->{xpad} = " ";
99 $s->{sep} = "\n";
100 }
101 return bless($s, $c);
102}
103
10414µsif ($] >= 5.008) {
105 # Packed numeric addresses take less memory. Plus pack is faster than sprintf
10615µs *init_refaddr_format = sub {};
107
108 *format_refaddr = sub {
109 require Scalar::Util;
110 pack "J", Scalar::Util::refaddr(shift);
11114µs };
112} else {
113 *init_refaddr_format = sub {
114 require Config;
115 my $f = $Config::Config{uvxformat};
116 $f =~ tr/"//d;
117 our $refaddr_format = "0x%" . $f;
118 };
119
120 *format_refaddr = sub {
121 require Scalar::Util;
122 sprintf our $refaddr_format, Scalar::Util::refaddr(shift);
123 }
124}
125
126#
127# add-to or query the table of already seen references
128#
129sub Seen {
130 my($s, $g) = @_;
131 if (defined($g) && (ref($g) eq 'HASH')) {
132 init_refaddr_format();
133 my($k, $v, $id);
134 while (($k, $v) = each %$g) {
135 if (defined $v and ref $v) {
136 $id = format_refaddr($v);
137 if ($k =~ /^[*](.*)$/) {
138 $k = (ref $v eq 'ARRAY') ? ( "\\\@" . $1 ) :
139 (ref $v eq 'HASH') ? ( "\\\%" . $1 ) :
140 (ref $v eq 'CODE') ? ( "\\\&" . $1 ) :
141 ( "\$" . $1 ) ;
142 }
143 elsif ($k !~ /^\$/) {
144 $k = "\$" . $k;
145 }
146 $s->{seen}{$id} = [$k, $v];
147 }
148 else {
149 carp "Only refs supported, ignoring non-ref item \$$k";
150 }
151 }
152 return $s;
153 }
154 else {
155 return map { @$_ } values %{$s->{seen}};
156 }
157}
158
159#
160# set or query the values to be dumped
161#
162sub Values {
163 my($s, $v) = @_;
164 if (defined($v) && (ref($v) eq 'ARRAY')) {
165 $s->{todump} = [@$v]; # make a copy
166 return $s;
167 }
168 else {
169 return @{$s->{todump}};
170 }
171}
172
173#
174# set or query the names of the values to be dumped
175#
176sub Names {
177 my($s, $n) = @_;
178 if (defined($n) && (ref($n) eq 'ARRAY')) {
179 $s->{names} = [@$n]; # make a copy
180 return $s;
181 }
182 else {
183 return @{$s->{names}};
184 }
185}
186
187sub DESTROY {}
188
189sub Dump {
190 return &Dumpxs
191 unless $Data::Dumper::Useperl || (ref($_[0]) && $_[0]->{useperl}) ||
192 $Data::Dumper::Useqq || (ref($_[0]) && $_[0]->{useqq}) ||
193 $Data::Dumper::Deparse || (ref($_[0]) && $_[0]->{deparse});
194 return &Dumpperl;
195}
196
197#
198# dump the refs in the current dumper object.
199# expects same args as new() if called via package name.
200#
201sub Dumpperl {
202 my($s) = shift;
203 my(@out, $val, $name);
204 my($i) = 0;
205 local(@post);
206 init_refaddr_format();
207
208 $s = $s->new(@_) unless ref $s;
209
210 for $val (@{$s->{todump}}) {
211 my $out = "";
212 @post = ();
213 $name = $s->{names}[$i++];
214 if (defined $name) {
215 if ($name =~ /^[*](.*)$/) {
216 if (defined $val) {
217 $name = (ref $val eq 'ARRAY') ? ( "\@" . $1 ) :
218 (ref $val eq 'HASH') ? ( "\%" . $1 ) :
219 (ref $val eq 'CODE') ? ( "\*" . $1 ) :
220 ( "\$" . $1 ) ;
221 }
222 else {
223 $name = "\$" . $1;
224 }
225 }
226 elsif ($name !~ /^\$/) {
227 $name = "\$" . $name;
228 }
229 }
230 else {
231 $name = "\$" . $s->{varname} . $i;
232 }
233
234 my $valstr;
235 {
236 local($s->{apad}) = $s->{apad};
237 $s->{apad} .= ' ' x (length($name) + 3) if $s->{indent} >= 2;
238 $valstr = $s->_dump($val, $name);
239 }
240
241 $valstr = "$name = " . $valstr . ';' if @post or !$s->{terse};
242 $out .= $s->{pad} . $valstr . $s->{sep};
243 $out .= $s->{pad} . join(';' . $s->{sep} . $s->{pad}, @post)
244 . ';' . $s->{sep} if @post;
245
246 push @out, $out;
247 }
248 return wantarray ? @out : join('', @out);
249}
250
251# wrap string in single quotes (escaping if needed)
252sub _quote {
253 my $val = shift;
254 $val =~ s/([\\\'])/\\$1/g;
255 return "'" . $val . "'";
256}
257
258#
259# twist, toil and turn;
260# and recurse, of course.
261# sometimes sordidly;
262# and curse if no recourse.
263#
264sub _dump {
265 my($s, $val, $name) = @_;
266 my($sname);
267 my($out, $realpack, $realtype, $type, $ipad, $id, $blesspad);
268
269 $type = ref $val;
270 $out = "";
271
272 if ($type) {
273
274 # Call the freezer method if it's specified and the object has the
275 # method. Trap errors and warn() instead of die()ing, like the XS
276 # implementation.
277 my $freezer = $s->{freezer};
278 if ($freezer and UNIVERSAL::can($val, $freezer)) {
279 eval { $val->$freezer() };
280 warn "WARNING(Freezer method call failed): $@" if $@;
281 }
282
283 require Scalar::Util;
284 $realpack = Scalar::Util::blessed($val);
285 $realtype = $realpack ? Scalar::Util::reftype($val) : ref $val;
286 $id = format_refaddr($val);
287
288 # if it has a name, we need to either look it up, or keep a tab
289 # on it so we know when we hit it later
290 if (defined($name) and length($name)) {
291 # keep a tab on it so that we dont fall into recursive pit
292 if (exists $s->{seen}{$id}) {
293# if ($s->{expdepth} < $s->{level}) {
294 if ($s->{purity} and $s->{level} > 0) {
295 $out = ($realtype eq 'HASH') ? '{}' :
296 ($realtype eq 'ARRAY') ? '[]' :
297 'do{my $o}' ;
298 push @post, $name . " = " . $s->{seen}{$id}[0];
299 }
300 else {
301 $out = $s->{seen}{$id}[0];
302 if ($name =~ /^([\@\%])/) {
303 my $start = $1;
304 if ($out =~ /^\\$start/) {
305 $out = substr($out, 1);
306 }
307 else {
308 $out = $start . '{' . $out . '}';
309 }
310 }
311 }
312 return $out;
313# }
314 }
315 else {
316 # store our name
317 $s->{seen}{$id} = [ (($name =~ /^[@%]/) ? ('\\' . $name ) :
318 ($realtype eq 'CODE' and
319 $name =~ /^[*](.*)$/) ? ('\\&' . $1 ) :
320 $name ),
321 $val ];
322 }
323 }
324 my $no_bless = 0;
325 my $is_regex = 0;
326 if ( $realpack and ($] >= 5.009005 ? re::is_regexp($val) : $realpack eq 'Regexp') ) {
327 $is_regex = 1;
328 $no_bless = $realpack eq 'Regexp';
329 }
330
331 # If purity is not set and maxdepth is set, then check depth:
332 # if we have reached maximum depth, return the string
333 # representation of the thing we are currently examining
334 # at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)').
335 if (!$s->{purity}
336 and $s->{maxdepth} > 0
337 and $s->{level} >= $s->{maxdepth})
338 {
339 return qq['$val'];
340 }
341
342 # we have a blessed ref
343 if ($realpack and !$no_bless) {
344 $out = $s->{'bless'} . '( ';
345 $blesspad = $s->{apad};
346 $s->{apad} .= ' ' if ($s->{indent} >= 2);
347 }
348
349 $s->{level}++;
350 $ipad = $s->{xpad} x $s->{level};
351
352 if ($is_regex) {
353 my $pat;
354 # This really sucks, re:regexp_pattern is in ext/re/re.xs and not in
355 # universal.c, and even worse we cant just require that re to be loaded
356 # we *have* to use() it.
357 # We should probably move it to universal.c for 5.10.1 and fix this.
358 # Currently we only use re::regexp_pattern when the re is blessed into another
359 # package. This has the disadvantage of meaning that a DD dump won't round trip
360 # as the pattern will be repeatedly wrapped with the same modifiers.
361 # This is an aesthetic issue so we will leave it for now, but we could use
362 # regexp_pattern() in list context to get the modifiers separately.
363 # But since this means loading the full debugging engine in process we wont
364 # bother unless its necessary for accuracy.
365 if (($realpack ne 'Regexp') && defined(*re::regexp_pattern{CODE})) {
366 $pat = re::regexp_pattern($val);
367 } else {
368 $pat = "$val";
369 }
370 $pat =~ s,/,\\/,g;
371 $out .= "qr/$pat/";
372 }
373 elsif ($realtype eq 'SCALAR' || $realtype eq 'REF') {
374 if ($realpack) {
375 $out .= 'do{\\(my $o = ' . $s->_dump($$val, "\${$name}") . ')}';
376 }
377 else {
378 $out .= '\\' . $s->_dump($$val, "\${$name}");
379 }
380 }
381 elsif ($realtype eq 'GLOB') {
382 $out .= '\\' . $s->_dump($$val, "*{$name}");
383 }
384 elsif ($realtype eq 'ARRAY') {
385 my($v, $pad, $mname);
386 my($i) = 0;
387 $out .= ($name =~ /^\@/) ? '(' : '[';
388 $pad = $s->{sep} . $s->{pad} . $s->{apad};
389 ($name =~ /^\@(.*)$/) ? ($mname = "\$" . $1) :
390 # omit -> if $foo->[0]->{bar}, but not ${$foo->[0]}->{bar}
391 ($name =~ /^\\?[\%\@\*\$][^{].*[]}]$/) ? ($mname = $name) :
392 ($mname = $name . '->');
393 $mname .= '->' if $mname =~ /^\*.+\{[A-Z]+\}$/;
394 for $v (@$val) {
395 $sname = $mname . '[' . $i . ']';
396 $out .= $pad . $ipad . '#' . $i if $s->{indent} >= 3;
397 $out .= $pad . $ipad . $s->_dump($v, $sname);
398 $out .= "," if $i++ < $#$val;
399 }
400 $out .= $pad . ($s->{xpad} x ($s->{level} - 1)) if $i;
401 $out .= ($name =~ /^\@/) ? ')' : ']';
402 }
403 elsif ($realtype eq 'HASH') {
404 my($k, $v, $pad, $lpad, $mname, $pair);
405 $out .= ($name =~ /^\%/) ? '(' : '{';
406 $pad = $s->{sep} . $s->{pad} . $s->{apad};
407 $lpad = $s->{apad};
408 $pair = $s->{pair};
409 ($name =~ /^\%(.*)$/) ? ($mname = "\$" . $1) :
410 # omit -> if $foo->[0]->{bar}, but not ${$foo->[0]}->{bar}
411 ($name =~ /^\\?[\%\@\*\$][^{].*[]}]$/) ? ($mname = $name) :
412 ($mname = $name . '->');
413 $mname .= '->' if $mname =~ /^\*.+\{[A-Z]+\}$/;
414 my ($sortkeys, $keys, $key) = ("$s->{sortkeys}");
415 if ($sortkeys) {
416 if (ref($s->{sortkeys}) eq 'CODE') {
417 $keys = $s->{sortkeys}($val);
418 unless (ref($keys) eq 'ARRAY') {
419 carp "Sortkeys subroutine did not return ARRAYREF";
420 $keys = [];
421 }
422 }
423 else {
424 $keys = [ sort keys %$val ];
425 }
426 }
427
428 # Ensure hash iterator is reset
429 keys(%$val);
430
431 while (($k, $v) = ! $sortkeys ? (each %$val) :
432 @$keys ? ($key = shift(@$keys), $val->{$key}) :
433 () )
434 {
435 my $nk = $s->_dump($k, "");
436 $nk = $1 if !$s->{quotekeys} and $nk =~ /^[\"\']([A-Za-z_]\w*)[\"\']$/;
437 $sname = $mname . '{' . $nk . '}';
438 $out .= $pad . $ipad . $nk . $pair;
439
440 # temporarily alter apad
441 $s->{apad} .= (" " x (length($nk) + 4)) if $s->{indent} >= 2;
442 $out .= $s->_dump($val->{$k}, $sname) . ",";
443 $s->{apad} = $lpad if $s->{indent} >= 2;
444 }
445 if (substr($out, -1) eq ',') {
446 chop $out;
447 $out .= $pad . ($s->{xpad} x ($s->{level} - 1));
448 }
449 $out .= ($name =~ /^\%/) ? ')' : '}';
450 }
451 elsif ($realtype eq 'CODE') {
452 if ($s->{deparse}) {
453 require B::Deparse;
454 my $sub = 'sub ' . (B::Deparse->new)->coderef2text($val);
455 $pad = $s->{sep} . $s->{pad} . $s->{apad} . $s->{xpad} x ($s->{level} - 1);
456 $sub =~ s/\n/$pad/gse;
457 $out .= $sub;
458 } else {
459 $out .= 'sub { "DUMMY" }';
460 carp "Encountered CODE ref, using dummy placeholder" if $s->{purity};
461 }
462 }
463 else {
464 croak "Can\'t handle $realtype type.";
465 }
466
467 if ($realpack and !$no_bless) { # we have a blessed ref
468 $out .= ', ' . _quote($realpack) . ' )';
469 $out .= '->' . $s->{toaster} . '()' if $s->{toaster} ne '';
470 $s->{apad} = $blesspad;
471 }
472 $s->{level}--;
473
474 }
475 else { # simple scalar
476
477 my $ref = \$_[1];
478 # first, catalog the scalar
479 if ($name ne '') {
480 $id = format_refaddr($ref);
481 if (exists $s->{seen}{$id}) {
482 if ($s->{seen}{$id}[2]) {
483 $out = $s->{seen}{$id}[0];
484 #warn "[<$out]\n";
485 return "\${$out}";
486 }
487 }
488 else {
489 #warn "[>\\$name]\n";
490 $s->{seen}{$id} = ["\\$name", $ref];
491 }
492 }
493 if (ref($ref) eq 'GLOB' or "$ref" =~ /=GLOB\([^()]+\)$/) { # glob
494 my $name = substr($val, 1);
495 if ($name =~ /^[A-Za-z_][\w:]*$/) {
496 $name =~ s/^main::/::/;
497 $sname = $name;
498 }
499 else {
500 $sname = $s->_dump($name, "");
501 $sname = '{' . $sname . '}';
502 }
503 if ($s->{purity}) {
504 my $k;
505 local ($s->{level}) = 0;
506 for $k (qw(SCALAR ARRAY HASH)) {
507 my $gval = *$val{$k};
508 next unless defined $gval;
509 next if $k eq "SCALAR" && ! defined $$gval; # always there
510
511 # _dump can push into @post, so we hold our place using $postlen
512 my $postlen = scalar @post;
513 $post[$postlen] = "\*$sname = ";
514 local ($s->{apad}) = " " x length($post[$postlen]) if $s->{indent} >= 2;
515 $post[$postlen] .= $s->_dump($gval, "\*$sname\{$k\}");
516 }
517 }
518 $out .= '*' . $sname;
519 }
520 elsif (!defined($val)) {
521 $out .= "undef";
522 }
523 elsif ($val =~ /^(?:0|-?[1-9]\d{0,8})\z/) { # safe decimal number
524 $out .= $val;
525 }
526 else { # string
527 if ($s->{useqq} or $val =~ tr/\0-\377//c) {
528 # Fall back to qq if there's Unicode
529 $out .= qquote($val, $s->{useqq});
530 }
531 else {
532 $out .= _quote($val);
533 }
534 }
535 }
536 if ($id) {
537 # if we made it this far, $id was added to seen list at current
538 # level, so remove it to get deep copies
539 if ($s->{deepcopy}) {
540 delete($s->{seen}{$id});
541 }
542 elsif ($name) {
543 $s->{seen}{$id}[2] = 1;
544 }
545 }
546 return $out;
547}
548
549#
550# non-OO style of earlier version
551#
552sub Dumper {
553 return Data::Dumper->Dump([@_]);
554}
555
556# compat stub
557sub DumperX {
558 return Data::Dumper->Dumpxs([@_], []);
559}
560
561sub Dumpf { return Data::Dumper->Dump(@_) }
562
563sub Dumpp { print Data::Dumper->Dump(@_) }
564
565#
566# reset the "seen" cache
567#
568sub Reset {
569 my($s) = shift;
570 $s->{seen} = {};
571 return $s;
572}
573
574sub Indent {
575 my($s, $v) = @_;
576 if (defined($v)) {
577 if ($v == 0) {
578 $s->{xpad} = "";
579 $s->{sep} = "";
580 }
581 else {
582 $s->{xpad} = " ";
583 $s->{sep} = "\n";
584 }
585 $s->{indent} = $v;
586 return $s;
587 }
588 else {
589 return $s->{indent};
590 }
591}
592
593sub Pair {
594 my($s, $v) = @_;
595 defined($v) ? (($s->{pair} = $v), return $s) : $s->{pair};
596}
597
598sub Pad {
599 my($s, $v) = @_;
600 defined($v) ? (($s->{pad} = $v), return $s) : $s->{pad};
601}
602
603sub Varname {
604 my($s, $v) = @_;
605 defined($v) ? (($s->{varname} = $v), return $s) : $s->{varname};
606}
607
608sub Purity {
609 my($s, $v) = @_;
610 defined($v) ? (($s->{purity} = $v), return $s) : $s->{purity};
611}
612
613sub Useqq {
614 my($s, $v) = @_;
615 defined($v) ? (($s->{useqq} = $v), return $s) : $s->{useqq};
616}
617
618sub Terse {
619 my($s, $v) = @_;
620 defined($v) ? (($s->{terse} = $v), return $s) : $s->{terse};
621}
622
623sub Freezer {
624 my($s, $v) = @_;
625 defined($v) ? (($s->{freezer} = $v), return $s) : $s->{freezer};
626}
627
628sub Toaster {
629 my($s, $v) = @_;
630 defined($v) ? (($s->{toaster} = $v), return $s) : $s->{toaster};
631}
632
633sub Deepcopy {
634 my($s, $v) = @_;
635 defined($v) ? (($s->{deepcopy} = $v), return $s) : $s->{deepcopy};
636}
637
638sub Quotekeys {
639 my($s, $v) = @_;
640 defined($v) ? (($s->{quotekeys} = $v), return $s) : $s->{quotekeys};
641}
642
643sub Bless {
644 my($s, $v) = @_;
645 defined($v) ? (($s->{'bless'} = $v), return $s) : $s->{'bless'};
646}
647
648sub Maxdepth {
649 my($s, $v) = @_;
650 defined($v) ? (($s->{'maxdepth'} = $v), return $s) : $s->{'maxdepth'};
651}
652
653sub Useperl {
654 my($s, $v) = @_;
655 defined($v) ? (($s->{'useperl'} = $v), return $s) : $s->{'useperl'};
656}
657
658sub Sortkeys {
659 my($s, $v) = @_;
660 defined($v) ? (($s->{'sortkeys'} = $v), return $s) : $s->{'sortkeys'};
661}
662
663sub Deparse {
664 my($s, $v) = @_;
665 defined($v) ? (($s->{'deparse'} = $v), return $s) : $s->{'deparse'};
666}
667
668# used by qquote below
66915µsmy %esc = (
670 "\a" => "\\a",
671 "\b" => "\\b",
672 "\t" => "\\t",
673 "\n" => "\\n",
674 "\f" => "\\f",
675 "\r" => "\\r",
676 "\e" => "\\e",
677);
678
679# put a string value in double quotes
680sub qquote {
681 local($_) = shift;
682 s/([\\\"\@\$])/\\$1/g;
6833807µs2326µs
# spent 321µs (316+5) within Data::Dumper::BEGIN@683 which was called: # once (316µs+5µs) by XML::LibXML::Error::BEGIN@225 at line 683
my $bytes; { use bytes; $bytes = length }
# spent 321µs making 1 call to Data::Dumper::BEGIN@683 # spent 5µs making 1 call to bytes::import
684 s/([^\x00-\x7f])/'\x{'.sprintf("%x",ord($1)).'}'/ge if $bytes > length;
685 return qq("$_") unless
686 /[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~]/; # fast exit
687
688 my $high = shift || "";
689 s/([\a\b\t\n\f\r\e])/$esc{$1}/g;
690
691 if (ord('^')==94) { # ascii
692 # no need for 3 digits in escape for these
693 s/([\0-\037])(?!\d)/'\\'.sprintf('%o',ord($1))/eg;
694 s/([\0-\037\177])/'\\'.sprintf('%03o',ord($1))/eg;
695 # all but last branch below not supported --BEHAVIOR SUBJECT TO CHANGE--
696 if ($high eq "iso8859") {
697 s/([\200-\240])/'\\'.sprintf('%o',ord($1))/eg;
698 } elsif ($high eq "utf8") {
699# use utf8;
700# $str =~ s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge;
701 } elsif ($high eq "8bit") {
702 # leave it as it is
703 } else {
704 s/([\200-\377])/'\\'.sprintf('%03o',ord($1))/eg;
705 s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge;
706 }
707 }
708 else { # ebcdic
709 s{([^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])(?!\d)}
710 {my $v = ord($1); '\\'.sprintf(($v <= 037 ? '%o' : '%03o'), $v)}eg;
711 s{([^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])}
712 {'\\'.sprintf('%03o',ord($1))}eg;
713 }
714
715 return qq("$_");
716}
717
718# helper sub to sort hash keys in Perl < 5.8.0 where we don't have
719# access to sortsv() from XS
720sub _sortkeys { [ sort keys %{$_[0]} ] }
721
722126µs1;
723__END__
Report produced by the NYTProf 4.04 Perl profiler, developed by Tim Bunce and Adam Kaplan.