← Index
NYTProf Performance Profile   « line view »
For webmerge/scripts/webmerge.pl
  Run on Mon Oct 7 02:42:42 2013
Reported on Mon Oct 7 03:03:23 2013

Filename/usr/local/lib64/perl5/5.16.0/Data/Dump/PHP.pm
StatementsExecuted 24 statements in 18.8ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
1111.20ms1.30msData::Dump::PHP::::BEGIN@7Data::Dump::PHP::BEGIN@7
11196µs190µsData::Dump::PHP::::BEGIN@5Data::Dump::PHP::BEGIN@5
11154µs664µsData::Dump::PHP::::BEGIN@23Data::Dump::PHP::BEGIN@23
11154µs54µsData::Dump::PHP::::BEGIN@2Data::Dump::PHP::BEGIN@2
11151µs365µsData::Dump::PHP::::BEGIN@6Data::Dump::PHP::BEGIN@6
11130µs30µsData::Dump::PHP::::BEGIN@22Data::Dump::PHP::BEGIN@22
0000s0sData::Dump::PHP::::_dumpData::Dump::PHP::_dump
0000s0sData::Dump::PHP::::dd_phpData::Dump::PHP::dd_php
0000s0sData::Dump::PHP::::ddx_phpData::Dump::PHP::ddx_php
0000s0sData::Dump::PHP::::dumpData::Dump::PHP::dump
0000s0sData::Dump::PHP::::format_listData::Dump::PHP::format_list
0000s0sData::Dump::PHP::::fullnameData::Dump::PHP::fullname
0000s0sData::Dump::PHP::::quoteData::Dump::PHP::quote
0000s0sData::Dump::PHP::::strData::Dump::PHP::str
0000s0sData::Dump::PHP::::tied_strData::Dump::PHP::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::PHP;
2
# spent 54µs within Data::Dump::PHP::BEGIN@2 which was called: # once (54µs+0s) by RTP::Webmerge::Embedder::PHP::BEGIN@20 at line 4
BEGIN {
3139µs $Data::Dump::PHP::VERSION = '0.07';
41112µs154µs}
# spent 54µs making 1 call to Data::Dump::PHP::BEGIN@2
52169µs2285µs
# spent 190µs (96+95) within Data::Dump::PHP::BEGIN@5 which was called: # once (96µs+95µs) by RTP::Webmerge::Embedder::PHP::BEGIN@20 at line 5
use strict;
# spent 190µs making 1 call to Data::Dump::PHP::BEGIN@5 # spent 95µs making 1 call to strict::import
62180µs2679µs
# spent 365µs (51+314) within Data::Dump::PHP::BEGIN@6 which was called: # once (51µs+314µs) by RTP::Webmerge::Embedder::PHP::BEGIN@20 at line 6
use vars qw(@EXPORT @EXPORT_OK $DEBUG);
# spent 365µs making 1 call to Data::Dump::PHP::BEGIN@6 # spent 314µs making 1 call to vars::import
721.43ms21.40ms
# spent 1.30ms (1.20+96µs) within Data::Dump::PHP::BEGIN@7 which was called: # once (1.20ms+96µs) by RTP::Webmerge::Embedder::PHP::BEGIN@20 at line 7
use subs qq(dump);
# spent 1.30ms making 1 call to Data::Dump::PHP::BEGIN@7 # spent 96µs making 1 call to subs::import
8
9# to make Test::Pod::Coverage happy
10
11=for Pod::Coverage .*
12
13=cut
14
1516µsrequire Exporter;
16110µs*import = \&Exporter::import;
17110µs@EXPORT = qw(dd_php ddx_php);
1816µs@EXPORT_OK = qw(dump_php pp_php quote_php);
19
2012µs$DEBUG = 0;
21
222148µs130µs
# spent 30µs within Data::Dump::PHP::BEGIN@22 which was called: # once (30µs+0s) by RTP::Webmerge::Embedder::PHP::BEGIN@20 at line 22
use overload ();
# spent 30µs making 1 call to Data::Dump::PHP::BEGIN@22
23215.7ms21.27ms
# spent 664µs (54+610) within Data::Dump::PHP::BEGIN@23 which was called: # once (54µs+610µs) by RTP::Webmerge::Embedder::PHP::BEGIN@20 at line 23
use vars qw(%seen %refcnt @dump @fixup %require $TRY_BASE64 $USE_LAMBDA);
# spent 664µs making 1 call to Data::Dump::PHP::BEGIN@23 # spent 610µs making 1 call to vars::import
24
2511µs$USE_LAMBDA = 0;
2612µs$TRY_BASE64 = 50 unless defined $TRY_BASE64;
27
281809µsmy %is_perl_keyword = map { $_ => 1 }
29qw( __FILE__ __LINE__ __PACKAGE__ __DATA__ __END__ AUTOLOAD BEGIN CORE
30DESTROY END EQ GE GT INIT LE LT NE abs accept alarm and atan2 bind
31binmode bless caller chdir chmod chomp chop chown chr chroot close
32closedir cmp connect continue cos crypt dbmclose dbmopen defined
33delete die do dump each else elsif endgrent endhostent endnetent
34endprotoent endpwent endservent eof eq eval exec exists exit exp fcntl
35fileno flock for foreach fork format formline ge getc getgrent
36getgrgid getgrnam gethostbyaddr gethostbyname gethostent getlogin
37getnetbyaddr getnetbyname getnetent getpeername getpgrp getppid
38getpriority getprotobyname getprotobynumber getprotoent getpwent
39getpwnam getpwuid getservbyname getservbyport getservent getsockname
40getsockopt glob gmtime goto grep gt hex if index int ioctl join keys
41kill last lc lcfirst le length link listen local localtime lock log
42lstat lt m map mkdir msgctl msgget msgrcv msgsnd my ne next no not oct
43open opendir or ord pack package pipe pop pos print printf prototype
44push q qq qr quotemeta qw qx rand read readdir readline readlink
45readpipe recv redo ref rename require reset return reverse rewinddir
46rindex rmdir s scalar seek seekdir select semctl semget semop send
47setgrent sethostent setnetent setpgrp setpriority setprotoent setpwent
48setservent setsockopt shift shmctl shmget shmread shmwrite shutdown
49sin sleep socket socketpair sort splice split sprintf sqrt srand stat
50study sub substr symlink syscall sysopen sysread sysseek system
51syswrite tell telldir tie tied time times tr truncate uc ucfirst umask
52undef unless unlink unpack unshift untie until use utime values vec
53wait waitpid wantarray warn while write x xor y);
54
55
56sub dump
57{
58 local %seen;
59 local %refcnt;
60 local %require;
61 local @fixup;
62
63 my $name = "a";
64 my @dump;
65
66 for my $v (@_) {
67 my $val = _dump($v, $name, [], tied($v));
68 push(@dump, [$name, $val]);
69 } continue {
70 $name++;
71 }
72
73 my $out = "";
74 if (%require) {
75 die "BUG: should not require() for PHP";
76 for (sort keys %require) {
77 $out .= "require $_;\n";
78 }
79 }
80 if (%refcnt) {
81 # output all those with refcounts first
82 for (@dump) {
83 my $name = $_->[0];
84 if ($refcnt{$name}) {
85 $out .= "\$$name = $_->[1];\n";
86 undef $_->[1];
87 }
88 }
89 for (@fixup) {
90 $out .= "$_;\n";
91 }
92 }
93
94 my $paren = (@dump != 1);
95 $out .= (@fixup ? "return ":"")."array(" if $paren;
96 $out .= format_list($paren, undef,
97 map {defined($dump[$_][1]) ? $dump[$_][1] : (!$paren && $_ == @dump-1 ? "return ":"")."\$".$dump[$_][0]}
98 0..$#dump
99 );
100 $out .= ")" if $paren;
101
102 if (%refcnt || %require) {
103 $out .= ";\n";
104 $out =~ s/^/ /gm; # indent
105 if ($USE_LAMBDA) {
106 $out = "call_user_func(function() { ".$out." })";
107 } else {
108 $out = "call_user_func(create_function('', ".quote($out)."))";
109 }
110 }
111
112 #use Data::Dumper; print Dumper(\%refcnt);
113 #use Data::Dumper; print Dumper(\%seen);
114
115 print STDERR "$out\n" unless defined wantarray;
116 $out;
117}
118
11917µs*dump_php = \&dump;
12014µs*pp_php = \&dump;
121
122sub dd_php {
123 print dump(@_), "\n";
124}
125
126sub ddx_php {
127 my(undef, $file, $line) = caller;
128 $file =~ s,.*[\\/],,;
129 my $out = "$file:$line: " . dump(@_) . "\n";
130 $out =~ s/^/# /gm;
131 print $out;
132}
133
134sub _dump
135{
136 my $ref = ref $_[0];
137 my $rval = $ref ? $_[0] : \$_[0];
138 shift;
139
140 my($name, $idx, $dont_remember) = @_;
141
142 my($class, $type, $id);
143 if (overload::StrVal($rval) =~ /^(?:([^=]+)=)?([A-Z]+)\(0x([^\)]+)\)$/) {
144 $class = $1;
145 $type = $2;
146 $id = $3;
147 } else {
148 die "Can't parse " . overload::StrVal($rval);
149 }
150 if ($] < 5.008 && $type eq "SCALAR") {
151 $type = "REF" if $ref eq "REF";
152 }
153 warn "\$$name(@$idx) $class $type $id ($ref)" if $DEBUG;
154
155 unless ($dont_remember) {
156 if (my $s = $seen{$id}) {
157 my($sname, $sidx) = @$s;
158 $refcnt{$sname}++;
159 my $sref = fullname($sname, $sidx,
160 ($ref && $type eq "SCALAR"));
161 warn "SEEN: [\$$name(@$idx)] => [\$$sname(@$sidx)] ($ref,$sref)" if $DEBUG;
162 return $sref unless $sname eq $name;
163 $refcnt{$name}++;
164 push(@fixup, fullname($name,$idx) . " =& " . $sref);
165 die "Can't handle returning references for PHP yet" if @$idx && $idx->[-1] eq '$';
166 #return "do{my \$fix}" if @$idx && $idx->[-1] eq '$';
167 return "'fix'";
168 }
169 $seen{$id} = [$name, $idx];
170 }
171
172 my $out;
173 if ($type eq "SCALAR" || $type eq "REF" || $type eq "REGEXP") {
174 if ($ref) {
175 if ($class && $class eq "Regexp") {
176 my $v = "$rval";
177
178 my $mod = "";
179 if ($v =~ /^\(\?\^?([msix-]*):([\x00-\xFF]*)\)\z/) {
180 $mod = $1;
181 $v = $2;
182 $mod =~ s/-.*//;
183 }
184
185 my $sep = '/';
186 my $sep_count = ($v =~ tr/\///);
187 if ($sep_count) {
188 # see if we can find a better one
189 for ('|', ',', ':', '#') {
190 my $c = eval "\$v =~ tr/\Q$_\E//";
191 #print "SEP $_ $c $sep_count\n";
192 if ($c < $sep_count) {
193 $sep = $_;
194 $sep_count = $c;
195 last if $sep_count == 0;
196 }
197 }
198 }
199 $v =~ s/\Q$sep\E/\\$sep/g;
200
201 $out = quote("$sep$v$sep$mod");
202 undef($class);
203 }
204 else {
205 die "Can't handle non-Regexp builtin object (class $class) for PHP yet";
206 delete $seen{$id} if $type eq "SCALAR"; # will be seen again shortly
207 my $val = _dump($$rval, $name, [@$idx, "\$"]);
208 $out = $class ? "do{\\(my \$o = $val)}" : "\\$val";
209 }
210 } else {
211 if (!defined $$rval) {
212 $out = "null";
213 }
214 elsif ($$rval =~ /^-?[1-9]\d{0,9}\z/ || $$rval eq "0") {
215 $out = $$rval;
216 }
217 else {
218 $out = str($$rval);
219 }
220 if ($class && !@$idx) {
221 die "Can't handle nonref, class, nonidx for PHP yet";
222 # Top is an object, not a reference to one as perl needs
223 $refcnt{$name}++;
224 my $obj = fullname($name, $idx);
225 my $cl = quote($class);
226 push(@fixup, "bless \\$obj, $cl");
227 }
228 }
229 }
230 elsif ($type eq "GLOB") {
231 die "Can't handle glob for PHP yet";
232 if ($ref) {
233 delete $seen{$id};
234 my $val = _dump($$rval, $name, [@$idx, "*"]);
235 $out = "\\$val";
236 if ($out =~ /^\\\*Symbol::/) {
237 $require{Symbol}++;
238 $out = "Symbol::gensym()";
239 }
240 } else {
241 my $val = "$$rval";
242 $out = "$$rval";
243
244 for my $k (qw(SCALAR ARRAY HASH)) {
245 my $gval = *$$rval{$k};
246 next unless defined $gval;
247 next if $k eq "SCALAR" && ! defined $$gval; # always there
248 my $f = scalar @fixup;
249 push(@fixup, "RESERVED"); # overwritten after _dump() below
250 $gval = _dump($gval, $name, [@$idx, "*{$k}"]);
251 $refcnt{$name}++;
252 my $gname = fullname($name, $idx);
253 $fixup[$f] = "$gname = $gval"; #XXX indent $gval
254 }
255 }
256 }
257 elsif ($type eq "ARRAY") {
258 my @vals;
259 my $tied = tied_str(tied(@$rval));
260 die "Can't handle tied arrayref for PHP yet" if $tied;
261 my $i = 0;
262 for my $v (@$rval) {
263 push(@vals, _dump($v, $name, [@$idx, "[$i]"], $tied));
264 $i++;
265 }
266 $out = "array(" . format_list(1, $tied, @vals) . ")";
267 }
268 elsif ($type eq "HASH") {
269 my(@keys, @vals);
270 my $tied = tied_str(tied(%$rval));
271 die "Can't handle tied hashref for PHP yet" if $tied;
272
273 # statistics to determine variation in key lengths
274 my $kstat_max = 0;
275 my $kstat_sum = 0;
276 my $kstat_sum2 = 0;
277
278 my @orig_keys = keys %$rval;
279 my $text_keys = 0;
280 for (@orig_keys) {
281 $text_keys++, last unless /^[-+]?(?:0|[1-9]\d*)(?:\.\d+)?\z/;
282 }
283
284 if ($text_keys) {
285 @orig_keys = sort @orig_keys;
286 }
287 else {
288 @orig_keys = sort { $a <=> $b } @orig_keys;
289 }
290
291 for my $key (@orig_keys) {
292 my $val = \$rval->{$key};
293 $key = quote($key) if #$is_perl_keyword{$key} ||
294 !(#$key =~ /^[a-zA-Z_]\w{0,19}\z/ ||
295 $key =~ /^-?[1-9]\d{0,8}\z/
296 );
297
298 $kstat_max = length($key) if length($key) > $kstat_max;
299 $kstat_sum += length($key);
300 $kstat_sum2 += length($key)*length($key);
301
302 push(@keys, $key);
303 push(@vals, _dump($$val, $name, [@$idx, "[$key]"], $tied));
304 }
305 my $nl = "";
306 my $klen_pad = 0;
307 my $tmp = "@keys @vals";
308 if (length($tmp) > 60 || $tmp =~ /\n/ || $tied) {
309 $nl = "\n";
310
311 # Determine what padding to add
312 if ($kstat_max < 4) {
313 $klen_pad = $kstat_max;
314 }
315 elsif (@keys >= 2) {
316 my $n = @keys;
317 my $avg = $kstat_sum/$n;
318 my $stddev = sqrt(($kstat_sum2 - $n * $avg * $avg) / ($n - 1));
319
320 # I am not actually very happy with this heuristics
321 if ($stddev / $kstat_max < 0.25) {
322 $klen_pad = $kstat_max;
323 }
324 if ($DEBUG) {
325 push(@keys, "__S");
326 push(@vals, sprintf("%.2f (%d/%.1f/%.1f)",
327 $stddev / $kstat_max,
328 $kstat_max, $avg, $stddev));
329 }
330 }
331 }
332 $out = "array($nl";
333 $out .= " # $tied$nl" if $tied;
334 while (@keys) {
335 my $key = shift @keys;
336 my $val = shift @vals;
337 my $pad = " " x ($klen_pad + 6);
338 $val =~ s/\n/\n$pad/gm;
339 $key = " $key" . " " x ($klen_pad - length($key)) if $nl;
340 $out .= " $key => $val,$nl";
341 }
342 $out =~ s/,$/ / unless $nl;
343 $out .= ")";
344 }
345 elsif ($type eq "CODE") {
346 if ($USE_LAMBDA) {
347 $out = "function() {}";
348 } else {
349 $out = "create_function('', '')";
350 }
351 }
352 else {
353 warn "Can't handle $type data";
354 $out = "'#$type#'";
355 }
356
357 if ($class && $ref) {
358 die "Can't handle object (class $class) for PHP yet";
359 $out = "bless($out, " . quote($class) . ")";
360 }
361 return $out;
362}
363
364sub tied_str {
365 my $tied = shift;
366 if ($tied) {
367 if (my $tied_ref = ref($tied)) {
368 $tied = "tied $tied_ref";
369 }
370 else {
371 $tied = "tied";
372 }
373 }
374 return $tied;
375}
376
377sub fullname
378{
379 my($name, $idx, $ref) = @_;
380 substr($name, 0, 0) = "\$";
381
382 my @i = @$idx; # need copy in order to not modify @$idx
383 my @ci = @i;
384 if ($ref && @i && $i[0] eq "\$") {
385 shift(@i); # remove one deref
386 $ref = 0;
387 }
388 while (@i && $i[0] eq "\$") {
389 shift @i;
390 $name = "\$$name";
391 }
392
393 my $last_was_index;
394 for my $i (@i) {
395 if ($i eq "*" || $i eq "\$") {
396 $last_was_index = 0;
397 $name = "$i\{$name}";
398 } elsif ($i =~ s/^\*//) {
399 $name .= $i;
400 $last_was_index++;
401 } else {
402 #$name .= "->" unless $last_was_index++;
403 $name .= $i;
404 }
405 }
406 $name = "\\$name" if $ref;
407 "*".join("", map {"<$_>"} @ci)."*$name*"; #X#
408 $name;
409}
410
411sub format_list
412{
413 my $paren = shift;
414 my $comment = shift;
415 my $indent_lim = $paren ? 0 : 1;
416 my $tmp = "@_";
417 if ($comment || (@_ > $indent_lim && (length($tmp) > 60 || $tmp =~ /\n/))) {
418 my @elem = @_;
419 for (@elem) { s/^/ /gm; } # indent
420 return "\n" . ($comment ? " # $comment\n" : "") .
421 join(",\n", @elem, "");
422 } else {
423 return join(", ", @_);
424 }
425}
426
427sub str {
428 if (length($_[0]) > 30) {
429 for ($_[0]) {
430 # Check for repeated string
431 if (/^(.)\1\1\1/s) {
432 # seems to be a repating sequence, let's check if it really is
433 # without backtracking
434 unless (/[^\Q$1\E]/) {
435 my $base = quote($1);
436 my $repeat = length;
437 return "str_repeat($base, $repeat)"
438 }
439 }
440 # Length protection because the RE engine will blow the stack [RT#33520]
441 if (length($_) < 16 * 1024 && /^(.{2,5}?)\1*\z/s) {
442 my $base = quote($1);
443 my $repeat = length($_)/length($1);
444 return "str_repeat($base, $repeat)";
445 }
446 }
447 }
448
449 local $_ = &quote;
450
451 if (length($_) > 40 && !/\\x\{/ && length($_) > (length($_[0]) * 2)) {
452 # too much binary data, better to represent as a hex/base64 string
453
454 # Base64 is more compact than hex when string is longer than
455 # 17 bytes (not counting any require statement needed).
456 # But on the other hand, hex is much more readable.
457 if ($TRY_BASE64 && length($_[0]) > $TRY_BASE64 &&
458 eval { require MIME::Base64 })
459 {
460 #$require{"MIME::Base64"}++;
461 return "base64_decode(\"" .
462 MIME::Base64::encode($_[0],"") .
463 "\")";
464 }
465 return "pack(\"H*\",\"" . unpack("H*", $_[0]) . "\")";
466 }
467
468 return $_;
469}
470
471114µsmy %esc = (
472 "\t" => "\\t",
473 "\n" => "\\n",
474 "\f" => "\\f",
475 "\r" => "\\r",
476 "\x0b" => "\\v",
477);
478
479# put a string value in double quotes
480sub quote {
481 local($_) = $_[0];
482 # If there are many '"' we might want to use qq() instead
483 s/([\\\"\@\$])/\\$1/g;
484 return qq("$_") unless /[^\040-\176]/; # fast exit
485
486 s/([\t\n\f\r\x0b])/$esc{$1}/g;
487
488 # no need for 3 digits in escape for these
489 s/([\0-\037])(?!\d)/sprintf('\\%o',ord($1))/eg;
490
491 s/([\0-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg;
492 s/([^\040-\176])/sprintf('\\x{%X}',ord($1))/eg;
493
494 return qq("$_");
495}
496
49714µs*quote_php = \&quote;
498
4991201µs1;
500
501__END__
Report produced by the NYTProf 5.05 Perl profiler, developed by Tim Bunce and Adam Kaplan.