← Index
NYTProf Performance Profile   « line view »
For svc/members/upsert
  Run on Tue Jan 13 11:50:22 2015
Reported on Tue Jan 13 12:09:51 2015

Filename/usr/share/perl5/CGI/Util.pm
StatementsExecuted 454 statements in 3.25ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
711189µs212µsCGI::Util::::_rearrange_paramsCGI::Util::_rearrange_params
74463µs311µsCGI::Util::::rearrangeCGI::Util::rearrange
134252µs56µsCGI::Util::::unescapeCGI::Util::unescape
82138µs51µsCGI::Util::::escapeCGI::Util::escape
589138µs38µsCGI::Util::::CORE:substCGI::Util::CORE:subst (opcode)
11124µs35µsCGI::Util::::expiresCGI::Util::expires
11120µs36µsCGI::Util::::make_attributesCGI::Util::make_attributes
11120µs130µsCGI::Util::::BEGIN@2CGI::Util::BEGIN@2
11119µs153µsCGI::Util::::BEGIN@5CGI::Util::BEGIN@5
11116µs79µsCGI::Util::::BEGIN@11CGI::Util::BEGIN@11
21113µs14µsCGI::Util::::simple_escapeCGI::Util::simple_escape
1119µs9µsCGI::Util::::expire_calcCGI::Util::expire_calc
1117µs20µsCGI::Util::::BEGIN@4CGI::Util::BEGIN@4
1112µs2µsCGI::Util::::CORE:matchCGI::Util::CORE:match (opcode)
0000s0sCGI::Util::::ascii2ebcdicCGI::Util::ascii2ebcdic
0000s0sCGI::Util::::ebcdic2asciiCGI::Util::ebcdic2ascii
0000s0sCGI::Util::::rearrange_headerCGI::Util::rearrange_header
0000s0sCGI::Util::::utf8_chrCGI::Util::utf8_chr
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package CGI::Util;
2242µs2239µs
# spent 130µs (20+109) within CGI::Util::BEGIN@2 which was called: # once (20µs+109µs) by CGI::BEGIN@9 at line 2
use base 'Exporter';
# spent 130µs making 1 call to CGI::Util::BEGIN@2 # spent 109µs making 1 call to base::import
3116µsrequire 5.008001;
4234µs234µs
# spent 20µs (7+13) within CGI::Util::BEGIN@4 which was called: # once (7µs+13µs) by CGI::BEGIN@9 at line 4
use strict;
# spent 20µs making 1 call to CGI::Util::BEGIN@4 # spent 13µs making 1 call to strict::import
52104µs2158µs
# spent 153µs (19+134) within CGI::Util::BEGIN@5 which was called: # once (19µs+134µs) by CGI::BEGIN@9 at line 5
use if $] >= 5.019, 'deprecate';
# spent 153µs making 1 call to CGI::Util::BEGIN@5 # spent 4µs making 1 call to if::import
612µsour @EXPORT_OK = qw(rearrange rearrange_header make_attributes unescape escape
7 expires ebcdic2ascii ascii2ebcdic);
8
91200nsour $VERSION = '4.09';
10
1122.52ms2142µs
# spent 79µs (16+63) within CGI::Util::BEGIN@11 which was called: # once (16µs+63µs) by CGI::BEGIN@9 at line 11
use constant EBCDIC => "\t" ne "\011";
# spent 79µs making 1 call to CGI::Util::BEGIN@11 # spent 63µs making 1 call to constant::import
12
13# This option is not documented and may change or go away.
14# The HTML spec does not require attributes to be sorted,
15# but it's useful for testing to get a predictable order back.
161100nsour $SORT_ATTRIBUTES;
17
18# (ord('^') == 95) for codepage 1047 as on os390, vmesa
19113µsour @A2E = (
20 0, 1, 2, 3, 55, 45, 46, 47, 22, 5, 21, 11, 12, 13, 14, 15,
21 16, 17, 18, 19, 60, 61, 50, 38, 24, 25, 63, 39, 28, 29, 30, 31,
22 64, 90,127,123, 91,108, 80,125, 77, 93, 92, 78,107, 96, 75, 97,
23 240,241,242,243,244,245,246,247,248,249,122, 94, 76,126,110,111,
24 124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214,
25 215,216,217,226,227,228,229,230,231,232,233,173,224,189, 95,109,
26 121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150,
27 151,152,153,162,163,164,165,166,167,168,169,192, 79,208,161, 7,
28 32, 33, 34, 35, 36, 37, 6, 23, 40, 41, 42, 43, 44, 9, 10, 27,
29 48, 49, 26, 51, 52, 53, 54, 8, 56, 57, 58, 59, 4, 20, 62,255,
30 65,170, 74,177,159,178,106,181,187,180,154,138,176,202,175,188,
31 144,143,234,250,190,160,182,179,157,218,155,139,183,184,185,171,
32 100,101, 98,102, 99,103,158,104,116,113,114,115,120,117,118,119,
33 172,105,237,238,235,239,236,191,128,253,254,251,252,186,174, 89,
34 68, 69, 66, 70, 67, 71,156, 72, 84, 81, 82, 83, 88, 85, 86, 87,
35 140, 73,205,206,203,207,204,225,112,221,222,219,220,141,142,223
36 );
37113µsour @E2A = (
38 0, 1, 2, 3,156, 9,134,127,151,141,142, 11, 12, 13, 14, 15,
39 16, 17, 18, 19,157, 10, 8,135, 24, 25,146,143, 28, 29, 30, 31,
40 128,129,130,131,132,133, 23, 27,136,137,138,139,140, 5, 6, 7,
41 144,145, 22,147,148,149,150, 4,152,153,154,155, 20, 21,158, 26,
42 32,160,226,228,224,225,227,229,231,241,162, 46, 60, 40, 43,124,
43 38,233,234,235,232,237,238,239,236,223, 33, 36, 42, 41, 59, 94,
44 45, 47,194,196,192,193,195,197,199,209,166, 44, 37, 95, 62, 63,
45 248,201,202,203,200,205,206,207,204, 96, 58, 35, 64, 39, 61, 34,
46 216, 97, 98, 99,100,101,102,103,104,105,171,187,240,253,254,177,
47 176,106,107,108,109,110,111,112,113,114,170,186,230,184,198,164,
48 181,126,115,116,117,118,119,120,121,122,161,191,208, 91,222,174,
49 172,163,165,183,169,167,182,188,189,190,221,168,175, 93,180,215,
50 123, 65, 66, 67, 68, 69, 70, 71, 72, 73,173,244,246,242,243,245,
51 125, 74, 75, 76, 77, 78, 79, 80, 81, 82,185,251,252,249,250,255,
52 92,247, 83, 84, 85, 86, 87, 88, 89, 90,178,212,214,210,211,213,
53 48, 49, 50, 51, 52, 53, 54, 55, 56, 57,179,219,220,217,218,159
54 );
55
56if (EBCDIC && ord('^') == 106) { # as in the BS2000 posix-bc coded character set
57 $A2E[91] = 187; $A2E[92] = 188; $A2E[94] = 106; $A2E[96] = 74;
58 $A2E[123] = 251; $A2E[125] = 253; $A2E[126] = 255; $A2E[159] = 95;
59 $A2E[162] = 176; $A2E[166] = 208; $A2E[168] = 121; $A2E[172] = 186;
60 $A2E[175] = 161; $A2E[217] = 224; $A2E[219] = 221; $A2E[221] = 173;
61 $A2E[249] = 192;
62
63 $E2A[74] = 96; $E2A[95] = 159; $E2A[106] = 94; $E2A[121] = 168;
64 $E2A[161] = 175; $E2A[173] = 221; $E2A[176] = 162; $E2A[186] = 172;
65 $E2A[187] = 91; $E2A[188] = 92; $E2A[192] = 249; $E2A[208] = 166;
66 $E2A[221] = 219; $E2A[224] = 217; $E2A[251] = 123; $E2A[253] = 125;
67 $E2A[255] = 126;
68 }
69elsif (EBCDIC && ord('^') == 176) { # as in codepage 037 on os400
70 $A2E[10] = 37; $A2E[91] = 186; $A2E[93] = 187; $A2E[94] = 176;
71 $A2E[133] = 21; $A2E[168] = 189; $A2E[172] = 95; $A2E[221] = 173;
72
73 $E2A[21] = 133; $E2A[37] = 10; $E2A[95] = 172; $E2A[173] = 221;
74 $E2A[176] = 94; $E2A[186] = 91; $E2A[187] = 93; $E2A[189] = 168;
75}
76
77# Smart rearrangement of parameters to allow named parameter
78# calling. We do the rearrangement if:
79# the first parameter begins with a -
80
81
# spent 311µs (63+248) within CGI::Util::rearrange which was called 7 times, avg 44µs/call: # 2 times (17µs+88µs) by CGI::Cookie::new at line 109 of CGI/Cookie.pm, avg 52µs/call # 2 times (21µs+75µs) by CGI::cookie at line 3 of (eval 75)[CGI.pm:932], avg 48µs/call # 2 times (12µs+7µs) by CGI::delete at line 6 of (eval 74)[CGI.pm:932], avg 10µs/call # once (12µs+77µs) by CGI::header at line 7 of (eval 81)[CGI.pm:932]
sub rearrange {
8277µs my ($order,@param) = @_;
83713µs7212µs my ($result, $leftover) = _rearrange_params( $order, @param );
# spent 212µs making 7 calls to CGI::Util::_rearrange_params, avg 30µs/call
8478µs136µs push @$result, make_attributes( $leftover, defined $CGI::Q ? $CGI::Q->{escape} : 1 )
# spent 36µs making 1 call to CGI::Util::make_attributes
85 if keys %$leftover;
86730µs @$result;
87}
88
89sub rearrange_header {
90 my ($order,@param) = @_;
91
92 my ($result,$leftover) = _rearrange_params( $order, @param );
93 push @$result, make_attributes( $leftover, 0, 1 ) if keys %$leftover;
94
95 @$result;
96}
97
98
# spent 212µs (189+23) within CGI::Util::_rearrange_params which was called 7 times, avg 30µs/call: # 7 times (189µs+23µs) by CGI::Util::rearrange at line 83, avg 30µs/call
sub _rearrange_params {
9975µs my($order,@param) = @_;
10073µs return [] unless @param;
101
10279µs if (ref($param[0]) eq 'HASH') {
103 @param = %{$param[0]};
104 } else {
105 return \@param
106616µs unless (defined($param[0]) && substr($param[0],0,1) eq '-');
107 }
108
109 # map parameters into positional indices
11041µs my ($i,%pos);
11142µs $i = 0;
11244µs foreach (@$order) {
1137157µs foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{lc($_)} = $i; }
114327µs $i++;
115 }
116
1174900ns my (@result,%leftover);
118412µs $#result = $#$order; # preextend
11943µs while (@param) {
1201410µs my $key = lc(shift(@param));
1211453µs1423µs $key =~ s/^\-//;
# spent 23µs making 14 calls to CGI::Util::CORE:subst, avg 2µs/call
1221419µs if (exists $pos{$key}) {
123 $result[$pos{$key}] = shift(@param);
124 } else {
12522µs $leftover{$key} = shift(@param);
126 }
127 }
128
129420µs return \@result, \%leftover;
130}
131
132
# spent 36µs (20+15) within CGI::Util::make_attributes which was called: # once (20µs+15µs) by CGI::Util::rearrange at line 84
sub make_attributes {
1331300ns my $attr = shift;
13411µs return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
1351300ns my $escape = shift || 0;
1361200ns my $do_not_quote = shift;
137
1381300ns my $quote = $do_not_quote ? '' : '"';
139
14011µs my @attr_keys= keys %$attr;
1411700ns if ($SORT_ATTRIBUTES) {
142 @attr_keys= sort @attr_keys;
143 }
1441200ns my(@att);
1451600ns foreach (@attr_keys) {
1462500ns my($key) = $_;
14724µs2500ns $key=~s/^\-//; # get rid of initial - if present
# spent 500ns making 2 calls to CGI::Util::CORE:subst, avg 250ns/call
148
149 # old way: breaks EBCDIC!
150 # $key=~tr/A-Z_/a-z-/; # parameters are lower case, use dashes
151
15222µs ($key="\L$key") =~ tr/_/-/; # parameters are lower case, use dashes
153
15423µs214µs my $value = $escape ? simple_escape($attr->{$_}) : $attr->{$_};
# spent 14µs making 2 calls to CGI::Util::simple_escape, avg 7µs/call
15523µs push(@att,defined($attr->{$_}) ? qq/$key=$quote$value$quote/ : qq/$key/);
156 }
15714µs return @att;
158}
159
160
# spent 14µs (13+2) within CGI::Util::simple_escape which was called 2 times, avg 7µs/call: # 2 times (13µs+2µs) by CGI::Util::make_attributes at line 154, avg 7µs/call
sub simple_escape {
1612800ns return unless defined(my $toencode = shift);
16223µs2600ns $toencode =~ s{&}{&}gso;
# spent 600ns making 2 calls to CGI::Util::CORE:subst, avg 300ns/call
16323µs2400ns $toencode =~ s{<}{&lt;}gso;
# spent 400ns making 2 calls to CGI::Util::CORE:subst, avg 200ns/call
16423µs2400ns $toencode =~ s{>}{&gt;}gso;
# spent 400ns making 2 calls to CGI::Util::CORE:subst, avg 200ns/call
16522µs2300ns $toencode =~ s{\"}{&quot;}gso;
# spent 300ns making 2 calls to CGI::Util::CORE:subst, avg 150ns/call
166# Doesn't work. Can't work. forget it.
167# $toencode =~ s{\x8b}{&#139;}gso;
168# $toencode =~ s{\x9b}{&#155;}gso;
16924µs $toencode;
170}
171
172sub utf8_chr {
173 my $c = shift(@_);
174 my $u = chr($c);
175 utf8::encode($u); # drop utf8 flag
176 return $u;
177}
178
179# unescape URL-encoded data
180
# spent 56µs (52+4) within CGI::Util::unescape which was called 13 times, avg 4µs/call: # 5 times (25µs+2µs) by CGI::parse_params at line 836 of CGI.pm, avg 5µs/call # 5 times (15µs+1µs) by CGI::parse_params at line 837 of CGI.pm, avg 3µs/call # 2 times (9µs+900ns) by CGI::Cookie::parse at line 92 of CGI/Cookie.pm, avg 5µs/call # once (3µs+200ns) by CGI::Cookie::parse at line 95 of CGI/Cookie.pm
sub unescape {
181134µs shift() if @_ > 0 and (ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
182132µs my $todecode = shift;
183131µs return undef unless defined($todecode);
184135µs $todecode =~ tr/+/ /; # pluses become spaces
185132µs if (EBCDIC) {
186 $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
187 } else {
188 # handle surrogate pairs first -- dankogai. Ref: http://unicode.org/faq/utf_bom.html#utf16-2
1891318µs132µs $todecode =~ s{
# spent 2µs making 13 calls to CGI::Util::CORE:subst, avg 154ns/call
190 utf8_chr(
191 0x10000
192 + (hex($1) - 0xD800) * 0x400
193 + (hex($2) - 0xDC00)
194 )
195 }gex;
196
- -
1991314µs132µs $todecode =~ s/%(?:([0-9a-fA-F]{2})|u([0-9a-fA-F]{4}))/
# spent 2µs making 13 calls to CGI::Util::CORE:subst, avg 162ns/call
200 defined($1)? chr hex($1) : utf8_chr(hex($2))/ge;
201 }
2021317µs return $todecode;
203}
204
205# URL-encode data
206#
207# We cannot use the %u escapes, they were rejected by W3C, so the official
208# way is %XX-escaped utf-8 encoding.
209# Naturally, Unicode strings have to be converted to their utf-8 byte
210# representation.
211# Byte strings were traditionally used directly as a sequence of octets.
212# This worked if they actually represented binary data (i.e. in CGI::Compress).
213# This also worked if these byte strings were actually utf-8 encoded; e.g.,
214# when the source file used utf-8 without the appropriate "use utf8;".
215# This fails if the byte string is actually a Latin 1 encoded string, but it
216# was always so and cannot be fixed without breaking the binary data case.
217# -- Stepan Kasal <skasal@redhat.com>
218#
219
220
# spent 51µs (38+13) within CGI::Util::escape which was called 8 times, avg 6µs/call: # 4 times (27µs+9µs) by CGI::Cookie::as_string at line 140 of CGI/Cookie.pm, avg 9µs/call # 4 times (12µs+4µs) by CGI::Cookie::as_string at line 141 of CGI/Cookie.pm, avg 4µs/call
sub escape {
221 # If we being called in an OO-context, discard the first argument.
22282µs shift() if @_ > 1 and ( ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
22382µs my $toencode = shift;
22481µs return undef unless defined($toencode);
225817µs84µs utf8::encode($toencode) if utf8::is_utf8($toencode);
# spent 4µs making 8 calls to utf8::is_utf8, avg 562ns/call
22682µs if (EBCDIC) {
227 $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg;
228 } else {
229818µs88µs $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",ord($1))/eg;
# spent 8µs making 8 calls to CGI::Util::CORE:subst, avg 1µs/call
230 }
231814µs return $toencode;
232}
233
234# This internal routine creates date strings suitable for use in
235# cookies and HTTP headers. (They differ, unfortunately.)
236# Thanks to Mark Fisher for this.
237
# spent 35µs (24+11) within CGI::Util::expires which was called: # once (24µs+11µs) by CGI::header at line 75 of (eval 81)[CGI.pm:932]
sub expires {
2381500ns my($time,$format) = @_;
2391300ns $format ||= 'http';
240
24112µs my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
24211µs my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
243
244 # pass through preformatted dates for the sake of expire_calc()
24512µs19µs $time = expire_calc($time);
# spent 9µs making 1 call to CGI::Util::expire_calc
24616µs12µs return $time unless $time =~ /^\d+$/;
# spent 2µs making 1 call to CGI::Util::CORE:match
247
248 # make HTTP/cookie date string from GMT'ed time
249 # (cookies use '-' as date separator, HTTP uses ' ')
2501700ns my($sc) = ' ';
2511500ns $sc = '-' if $format eq "cookie";
25215µs my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
2531400ns $year += 1900;
25417µs return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
255 $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
256}
257
258# This internal routine creates an expires time exactly some number of
259# hours from the current time. It incorporates modifications from
260# Mark Fisher.
261
# spent 9µs within CGI::Util::expire_calc which was called: # once (9µs+0s) by CGI::Util::expires at line 245
sub expire_calc {
2621300ns my($time) = @_;
26315µs my(%mult) = ('s'=>1,
264 'm'=>60,
265 'h'=>60*60,
266 'd'=>60*60*24,
267 'M'=>60*60*24*30,
268 'y'=>60*60*24*365);
269 # format for time can be in any of the forms...
270 # "now" -- expire immediately
271 # "+180s" -- in 180 seconds
272 # "+2m" -- in 2 minutes
273 # "+12h" -- in 12 hours
274 # "+1d" -- in 1 day
275 # "+3M" -- in 3 months
276 # "+2y" -- in 2 years
277 # "-3m" -- 3 minutes ago(!)
278 # If you don't supply one of these forms, we assume you are
279 # specifying the date yourself
2801200ns my($offset);
2811500ns if (!$time || (lc($time) eq 'now')) {
282 $offset = 0;
283 } elsif ($time=~/^\d+/) {
284 return $time;
285 } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([smhdMy])/) {
286 $offset = ($mult{$2} || 1)*$1;
287 } else {
288 return $time;
289 }
2901500ns my $cur_time = time;
29114µs return ($cur_time+$offset);
292}
293
294sub ebcdic2ascii {
295 my $data = shift;
296 $data =~ s/(.)/chr $E2A[ord($1)]/ge;
297 $data;
298}
299
300sub ascii2ebcdic {
301 my $data = shift;
302 $data =~ s/(.)/chr $A2E[ord($1)]/ge;
303 $data;
304}
305
306126µs1;
307
308__END__
 
# spent 2µs within CGI::Util::CORE:match which was called: # once (2µs+0s) by CGI::Util::expires at line 246
sub CGI::Util::CORE:match; # opcode
# spent 38µs within CGI::Util::CORE:subst which was called 58 times, avg 650ns/call: # 14 times (23µs+0s) by CGI::Util::_rearrange_params at line 121, avg 2µs/call # 13 times (2µs+0s) by CGI::Util::unescape at line 199, avg 162ns/call # 13 times (2µs+0s) by CGI::Util::unescape at line 189, avg 154ns/call # 8 times (8µs+0s) by CGI::Util::escape at line 229, avg 1µs/call # 2 times (600ns+0s) by CGI::Util::simple_escape at line 162, avg 300ns/call # 2 times (500ns+0s) by CGI::Util::make_attributes at line 147, avg 250ns/call # 2 times (400ns+0s) by CGI::Util::simple_escape at line 163, avg 200ns/call # 2 times (400ns+0s) by CGI::Util::simple_escape at line 164, avg 200ns/call # 2 times (300ns+0s) by CGI::Util::simple_escape at line 165, avg 150ns/call
sub CGI::Util::CORE:subst; # opcode
Report produced by the NYTProf 5.06 Perl profiler, developed by Tim Bunce and Adam Kaplan.