Filename | /usr/local/lib64/perl5/5.16.0/Data/Dump/PHP.pm |
Statements | Executed 24 statements in 18.8ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 1.20ms | 1.30ms | BEGIN@7 | Data::Dump::PHP::
1 | 1 | 1 | 96µs | 190µs | BEGIN@5 | Data::Dump::PHP::
1 | 1 | 1 | 54µs | 664µs | BEGIN@23 | Data::Dump::PHP::
1 | 1 | 1 | 54µs | 54µs | BEGIN@2 | Data::Dump::PHP::
1 | 1 | 1 | 51µs | 365µs | BEGIN@6 | Data::Dump::PHP::
1 | 1 | 1 | 30µs | 30µs | BEGIN@22 | Data::Dump::PHP::
0 | 0 | 0 | 0s | 0s | _dump | Data::Dump::PHP::
0 | 0 | 0 | 0s | 0s | dd_php | Data::Dump::PHP::
0 | 0 | 0 | 0s | 0s | ddx_php | Data::Dump::PHP::
0 | 0 | 0 | 0s | 0s | dump | Data::Dump::PHP::
0 | 0 | 0 | 0s | 0s | format_list | Data::Dump::PHP::
0 | 0 | 0 | 0s | 0s | fullname | Data::Dump::PHP::
0 | 0 | 0 | 0s | 0s | quote | Data::Dump::PHP::
0 | 0 | 0 | 0s | 0s | str | Data::Dump::PHP::
0 | 0 | 0 | 0s | 0s | tied_str | Data::Dump::PHP::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package 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 | ||||
3 | 1 | 39µs | $Data::Dump::PHP::VERSION = '0.07'; | ||
4 | 1 | 112µs | 1 | 54µs | } # spent 54µs making 1 call to Data::Dump::PHP::BEGIN@2 |
5 | 2 | 169µs | 2 | 285µ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 # spent 190µs making 1 call to Data::Dump::PHP::BEGIN@5
# spent 95µs making 1 call to strict::import |
6 | 2 | 180µs | 2 | 679µ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 # spent 365µs making 1 call to Data::Dump::PHP::BEGIN@6
# spent 314µs making 1 call to vars::import |
7 | 2 | 1.43ms | 2 | 1.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 # 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 | |||||
15 | 1 | 6µs | require Exporter; | ||
16 | 1 | 10µs | *import = \&Exporter::import; | ||
17 | 1 | 10µs | @EXPORT = qw(dd_php ddx_php); | ||
18 | 1 | 6µs | @EXPORT_OK = qw(dump_php pp_php quote_php); | ||
19 | |||||
20 | 1 | 2µs | $DEBUG = 0; | ||
21 | |||||
22 | 2 | 148µs | 1 | 30µ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 # spent 30µs making 1 call to Data::Dump::PHP::BEGIN@22 |
23 | 2 | 15.7ms | 2 | 1.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 # spent 664µs making 1 call to Data::Dump::PHP::BEGIN@23
# spent 610µs making 1 call to vars::import |
24 | |||||
25 | 1 | 1µs | $USE_LAMBDA = 0; | ||
26 | 1 | 2µs | $TRY_BASE64 = 50 unless defined $TRY_BASE64; | ||
27 | |||||
28 | 1 | 809µs | my %is_perl_keyword = map { $_ => 1 } | ||
29 | qw( __FILE__ __LINE__ __PACKAGE__ __DATA__ __END__ AUTOLOAD BEGIN CORE | ||||
30 | DESTROY END EQ GE GT INIT LE LT NE abs accept alarm and atan2 bind | ||||
31 | binmode bless caller chdir chmod chomp chop chown chr chroot close | ||||
32 | closedir cmp connect continue cos crypt dbmclose dbmopen defined | ||||
33 | delete die do dump each else elsif endgrent endhostent endnetent | ||||
34 | endprotoent endpwent endservent eof eq eval exec exists exit exp fcntl | ||||
35 | fileno flock for foreach fork format formline ge getc getgrent | ||||
36 | getgrgid getgrnam gethostbyaddr gethostbyname gethostent getlogin | ||||
37 | getnetbyaddr getnetbyname getnetent getpeername getpgrp getppid | ||||
38 | getpriority getprotobyname getprotobynumber getprotoent getpwent | ||||
39 | getpwnam getpwuid getservbyname getservbyport getservent getsockname | ||||
40 | getsockopt glob gmtime goto grep gt hex if index int ioctl join keys | ||||
41 | kill last lc lcfirst le length link listen local localtime lock log | ||||
42 | lstat lt m map mkdir msgctl msgget msgrcv msgsnd my ne next no not oct | ||||
43 | open opendir or ord pack package pipe pop pos print printf prototype | ||||
44 | push q qq qr quotemeta qw qx rand read readdir readline readlink | ||||
45 | readpipe recv redo ref rename require reset return reverse rewinddir | ||||
46 | rindex rmdir s scalar seek seekdir select semctl semget semop send | ||||
47 | setgrent sethostent setnetent setpgrp setpriority setprotoent setpwent | ||||
48 | setservent setsockopt shift shmctl shmget shmread shmwrite shutdown | ||||
49 | sin sleep socket socketpair sort splice split sprintf sqrt srand stat | ||||
50 | study sub substr symlink syscall sysopen sysread sysseek system | ||||
51 | syswrite tell telldir tie tied time times tr truncate uc ucfirst umask | ||||
52 | undef unless unlink unpack unshift untie until use utime values vec | ||||
53 | wait waitpid wantarray warn while write x xor y); | ||||
54 | |||||
55 | |||||
56 | sub 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 | |||||
119 | 1 | 7µs | *dump_php = \&dump; | ||
120 | 1 | 4µs | *pp_php = \&dump; | ||
121 | |||||
122 | sub dd_php { | ||||
123 | print dump(@_), "\n"; | ||||
124 | } | ||||
125 | |||||
126 | sub 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 | |||||
134 | sub _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 | |||||
364 | sub 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 | |||||
377 | sub 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 | |||||
411 | sub 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 | |||||
427 | sub 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 $_ = "e; | ||||
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 | |||||
471 | 1 | 14µs | my %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 | ||||
480 | sub 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 | |||||
497 | 1 | 4µs | *quote_php = \"e; | ||
498 | |||||
499 | 1 | 201µs | 1; | ||
500 | |||||
501 | __END__ |