← Index
Performance Profile   « block view • line view • sub view »
For /home/chris/git/koha.git/cataloguing/addbiblio.pl
  Run on Tue Aug 25 11:37:23 2009
Reported on Tue Aug 25 11:37:54 2009

File /usr/share/perl/5.10/CGI/Util.pm
Statements Executed 784
Total Time 0.0012243 seconds
Subroutines — ordered by exclusive time
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
1366741µs1.08msCGI::Util::::rearrangeCGI::Util::rearrange
1421327µs327µsCGI::Util::::escapeCGI::Util::escape
1042188µs312µsCGI::Util::::unescapeCGI::Util::unescape
411175µs343µsCGI::Util::::make_attributesCGI::Util::make_attributes
1011168µs168µsCGI::Util::::simple_escapeCGI::Util::simple_escape
11152µs76µsCGI::Util::::expiresCGI::Util::expires
11124µs24µsCGI::Util::::expire_calcCGI::Util::expire_calc
0000s0sCGI::Util::::BEGINCGI::Util::BEGIN
0000s0sCGI::Util::::ascii2ebcdicCGI::Util::ascii2ebcdic
0000s0sCGI::Util::::ebcdic2asciiCGI::Util::ebcdic2ascii
0000s0sCGI::Util::::utf8_chrCGI::Util::utf8_chr
LineStmts.Exclusive
Time		Avg.Code
1package CGI::Util;
2
3use strict;
4use vars qw($VERSION @EXPORT_OK @ISA $EBCDIC @A2E @E2A);
5require Exporter;
6@ISA = qw(Exporter);
7@EXPORT_OK = qw(rearrange make_attributes unescape escape
8 expires ebcdic2ascii ascii2ebcdic);
9
10$VERSION = '1.5_01';
11
12$EBCDIC = "\t" ne "\011";
13# (ord('^') == 95) for codepage 1047 as on os390, vmesa
14@A2E = (
15 0, 1, 2, 3, 55, 45, 46, 47, 22, 5, 21, 11, 12, 13, 14, 15,
16 16, 17, 18, 19, 60, 61, 50, 38, 24, 25, 63, 39, 28, 29, 30, 31,
17 64, 90,127,123, 91,108, 80,125, 77, 93, 92, 78,107, 96, 75, 97,
18 240,241,242,243,244,245,246,247,248,249,122, 94, 76,126,110,111,
19 124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214,
20 215,216,217,226,227,228,229,230,231,232,233,173,224,189, 95,109,
21 121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150,
22 151,152,153,162,163,164,165,166,167,168,169,192, 79,208,161, 7,
23 32, 33, 34, 35, 36, 37, 6, 23, 40, 41, 42, 43, 44, 9, 10, 27,
24 48, 49, 26, 51, 52, 53, 54, 8, 56, 57, 58, 59, 4, 20, 62,255,
25 65,170, 74,177,159,178,106,181,187,180,154,138,176,202,175,188,
26 144,143,234,250,190,160,182,179,157,218,155,139,183,184,185,171,
27 100,101, 98,102, 99,103,158,104,116,113,114,115,120,117,118,119,
28 172,105,237,238,235,239,236,191,128,253,254,251,252,186,174, 89,
29 68, 69, 66, 70, 67, 71,156, 72, 84, 81, 82, 83, 88, 85, 86, 87,
30 140, 73,205,206,203,207,204,225,112,221,222,219,220,141,142,223
31 );
32@E2A = (
33 0, 1, 2, 3,156, 9,134,127,151,141,142, 11, 12, 13, 14, 15,
34 16, 17, 18, 19,157, 10, 8,135, 24, 25,146,143, 28, 29, 30, 31,
35 128,129,130,131,132,133, 23, 27,136,137,138,139,140, 5, 6, 7,
36 144,145, 22,147,148,149,150, 4,152,153,154,155, 20, 21,158, 26,
37 32,160,226,228,224,225,227,229,231,241,162, 46, 60, 40, 43,124,
38 38,233,234,235,232,237,238,239,236,223, 33, 36, 42, 41, 59, 94,
39 45, 47,194,196,192,193,195,197,199,209,166, 44, 37, 95, 62, 63,
40 248,201,202,203,200,205,206,207,204, 96, 58, 35, 64, 39, 61, 34,
41 216, 97, 98, 99,100,101,102,103,104,105,171,187,240,253,254,177,
42 176,106,107,108,109,110,111,112,113,114,170,186,230,184,198,164,
43 181,126,115,116,117,118,119,120,121,122,161,191,208, 91,222,174,
44 172,163,165,183,169,167,182,188,189,190,221,168,175, 93,180,215,
45 123, 65, 66, 67, 68, 69, 70, 71, 72, 73,173,244,246,242,243,245,
46 125, 74, 75, 76, 77, 78, 79, 80, 81, 82,185,251,252,249,250,255,
47 92,247, 83, 84, 85, 86, 87, 88, 89, 90,178,212,214,210,211,213,
48 48, 49, 50, 51, 52, 53, 54, 55, 56, 57,179,219,220,217,218,159
49 );
50
51if ($EBCDIC && ord('^') == 106) { # as in the BS2000 posix-bc coded character set
52 $A2E[91] = 187; $A2E[92] = 188; $A2E[94] = 106; $A2E[96] = 74;
53 $A2E[123] = 251; $A2E[125] = 253; $A2E[126] = 255; $A2E[159] = 95;
54 $A2E[162] = 176; $A2E[166] = 208; $A2E[168] = 121; $A2E[172] = 186;
55 $A2E[175] = 161; $A2E[217] = 224; $A2E[219] = 221; $A2E[221] = 173;
56 $A2E[249] = 192;
57
58 $E2A[74] = 96; $E2A[95] = 159; $E2A[106] = 94; $E2A[121] = 168;
59 $E2A[161] = 175; $E2A[173] = 221; $E2A[176] = 162; $E2A[186] = 172;
60 $E2A[187] = 91; $E2A[188] = 92; $E2A[192] = 249; $E2A[208] = 166;
61 $E2A[221] = 219; $E2A[224] = 217; $E2A[251] = 123; $E2A[253] = 125;
62 $E2A[255] = 126;
63 }
64elsif ($EBCDIC && ord('^') == 176) { # as in codepage 037 on os400
65 $A2E[10] = 37; $A2E[91] = 186; $A2E[93] = 187; $A2E[94] = 176;
66 $A2E[133] = 21; $A2E[168] = 189; $A2E[172] = 95; $A2E[221] = 173;
67
68 $E2A[21] = 133; $E2A[37] = 10; $E2A[95] = 172; $E2A[173] = 221;
69 $E2A[176] = 94; $E2A[186] = 91; $E2A[187] = 93; $E2A[189] = 168;
70}
71
72# Smart rearrangement of parameters to allow named parameter
73# calling. We do the rearangement if:
74# the first parameter begins with a -
75
# spent 1.08ms (741µs+343µs) within CGI::Util::rearrange which was called 13 times, avg 83µs/call: # 3 times (304µs+230µs) by CGI::scrolling_list at line 3 of (eval 0)[/usr/share/perl/5.10/CGI.pm:867] at line 867 of /usr/share/perl/5.10/CGI.pm, avg 178µs/call # 3 times (184µs+0s) by CGI::Cookie::new at line 119 of /usr/share/perl/5.10/CGI/Cookie.pm, avg 61µs/call # 3 times (58µs+0s) by CGI::cookie at line 3 of (eval 0)[/usr/share/perl/5.10/CGI.pm:867] at line 867 of /usr/share/perl/5.10/CGI.pm, avg 19µs/call # 2 times (34µs+0s) by CGI::delete at line 6 of (eval 0)[/usr/share/perl/5.10/CGI.pm:867] at line 867 of /usr/share/perl/5.10/CGI.pm, avg 17µs/call # once (103µs+113µs) by CGI::header at line 7 of (eval 0)[/usr/share/perl/5.10/CGI.pm:867] at line 867 of /usr/share/perl/5.10/CGI.pm # once (57µs+0s) by CGI::param at line 427 of /usr/share/perl/5.10/CGI.pm
sub rearrange {
761359µs5µs my($order,@param) = @_;
77137µs508ns return () unless @param;
78
791326µs2µs if (ref($param[0]) eq 'HASH') {
80 @param = %{$param[0]};
81 } else {
82 return @param
831230µs3µs unless (defined($param[0]) && substr($param[0],0,1) eq '-');
84 }
85
86 # map parameters into positional indices
8783µs375ns my ($i,%pos);
8883µs362ns $i = 0;
89813µs2µs foreach (@$order) {
90135157µs1µs foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{lc($_)} = $i; }
915925µs422ns $i++;
92 }
93
9483µs388ns my (@result,%leftover);
95828µs3µs $#result = $#$order; # preextend
9687µs850ns while (@param) {
974627µs593ns my $key = lc(shift(@param));
984653µs1µs $key =~ s/^\-//;
994668µs1µs if (exists $pos{$key}) {
100 $result[$pos{$key}] = shift(@param);
101 } else {
1021012µs1µs $leftover{$key} = shift(@param);
103 }
104 }
105
106882µs10µs push (@result,make_attributes(\%leftover,defined $CGI::Q ? $CGI::Q->{escape} : 1)) if %leftover;
# spent 343µs making 4 calls to CGI::Util::make_attributes, avg 86µs/call
107844µs6µs @result;
108}
109
110
# spent 343µs (175+168) within CGI::Util::make_attributes which was called 4 times, avg 86µs/call: # 4 times (175µs+168µs) by CGI::Util::rearrange at line 106, avg 86µs/call
sub make_attributes {
11144µs975ns my $attr = shift;
11248µs2µs return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
11342µs525ns my $escape = shift || 0;
11442µs375ns my(@att);
115412µs3µs foreach (keys %{$attr}) {
1161010µs1µs my($key) = $_;
117109µs920ns $key=~s/^\-//; # get rid of initial - if present
118
119 # old way: breaks EBCDIC!
120 # $key=~tr/A-Z_/a-z-/; # parameters are lower case, use dashes
121
1221012µs1µs ($key="\L$key") =~ tr/_/-/; # parameters are lower case, use dashes
123
12410141µs14µs my $value = $escape ? simple_escape($attr->{$_}) : $attr->{$_};
# spent 168µs making 10 calls to CGI::Util::simple_escape, avg 17µs/call
1251027µs3µs push(@att,defined($attr->{$_}) ? qq/$key="$value"/ : qq/$key/);
126 }
12749µs2µs return @att;
128}
129
130
# spent 168µs within CGI::Util::simple_escape which was called 10 times, avg 17µs/call: # 10 times (168µs+0s) by CGI::Util::make_attributes at line 124, avg 17µs/call
sub simple_escape {
1311011µs1µs return unless defined(my $toencode = shift);
132108µs840ns $toencode =~ s{&}{&}gso;
133104µs380ns $toencode =~ s{<}{&lt;}gso;
134103µs310ns $toencode =~ s{>}{&gt;}gso;
135103µs330ns $toencode =~ s{\"}{&quot;}gso;
136# Doesn't work. Can't work. forget it.
137# $toencode =~ s{\x8b}{&#139;}gso;
138# $toencode =~ s{\x9b}{&#155;}gso;
1391018µs2µs $toencode;
140}
141
142sub utf8_chr {
143 my $c = shift(@_);
144 return chr($c) if $] >= 5.006;
145
146 if ($c < 0x80) {
147 return sprintf("%c", $c);
148 } elsif ($c < 0x800) {
149 return sprintf("%c%c", 0xc0 | ($c >> 6), 0x80 | ($c & 0x3f));
150 } elsif ($c < 0x10000) {
151 return sprintf("%c%c%c",
152 0xe0 | ($c >> 12),
153 0x80 | (($c >> 6) & 0x3f),
154 0x80 | ( $c & 0x3f));
155 } elsif ($c < 0x200000) {
156 return sprintf("%c%c%c%c",
157 0xf0 | ($c >> 18),
158 0x80 | (($c >> 12) & 0x3f),
159 0x80 | (($c >> 6) & 0x3f),
160 0x80 | ( $c & 0x3f));
161 } elsif ($c < 0x4000000) {
162 return sprintf("%c%c%c%c%c",
163 0xf8 | ($c >> 24),
164 0x80 | (($c >> 18) & 0x3f),
165 0x80 | (($c >> 12) & 0x3f),
166 0x80 | (($c >> 6) & 0x3f),
167 0x80 | ( $c & 0x3f));
168
169 } elsif ($c < 0x80000000) {
170 return sprintf("%c%c%c%c%c%c",
171 0xfc | ($c >> 30),
172 0x80 | (($c >> 24) & 0x3f),
173 0x80 | (($c >> 18) & 0x3f),
174 0x80 | (($c >> 12) & 0x3f),
175 0x80 | (($c >> 6) & 0x3f),
176 0x80 | ( $c & 0x3f));
177 } else {
178 return utf8_chr(0xfffd);
179 }
180}
181
182# unescape URL-encoded data
183
# spent 312µs (188+124) within CGI::Util::unescape which was called 10 times, avg 31µs/call: # 6 times (89µs+0s) by CGI::Cookie::parse at line 101 of /usr/share/perl/5.10/CGI/Cookie.pm, avg 15µs/call # 2 times (32µs+0s) by CGI::Cookie::parse at line 104 of /usr/share/perl/5.10/CGI/Cookie.pm, avg 16µs/call # once (52µs+124µs) by CGI::parse_params at line 771 of /usr/share/perl/5.10/CGI.pm # once (15µs+0s) by CGI::parse_params at line 772 of /usr/share/perl/5.10/CGI.pm
sub unescape {
184911µs1µs shift() if @_ > 0 and (ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
185108µs760ns my $todecode = shift;
186102µs250ns return undef unless defined($todecode);
187108µs810ns $todecode =~ tr/+/ /; # pluses become spaces
188104µs380ns $EBCDIC = "\t" ne "\011";
189105µs540ns if ($EBCDIC) {
190 $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
191 } else {
192108µs820ns $todecode =~ s/%(?:([0-9a-fA-F]{2})|u([0-9a-fA-F]{4}))/
193 defined($1)? chr hex($1) : utf8_chr(hex($2))/ge;
194 }
1951015µs1µs return $todecode;
196}
197
198# URL-encode data
199
# spent 327µs within CGI::Util::escape which was called 14 times, avg 23µs/call: # 7 times (177µs+0s) by CGI::Cookie::as_string at line 167 of /usr/share/perl/5.10/CGI/Cookie.pm, avg 25µs/call # 7 times (150µs+0s) by CGI::Cookie::as_string at line 168 of /usr/share/perl/5.10/CGI/Cookie.pm, avg 21µs/call
sub escape {
2001413µs914ns shift() if @_ > 1 and ( ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
2011412µs829ns my $toencode = shift;
202145µs371ns return undef unless defined($toencode);
203 # force bytes while preserving backward compatibility -- dankogai
2041483µs6µs $toencode = pack("C*", unpack("U0C*", $toencode));
205149µs679ns if ($EBCDIC) {
206 $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg;
207 } else {
2081430µs2µs $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",ord($1))/eg;
209 }
2101423µs2µs return $toencode;
211}
212
213# This internal routine creates date strings suitable for use in
214# cookies and HTTP headers. (They differ, unfortunately.)
215# Thanks to Mark Fisher for this.
216
# spent 76µs (52+24) within CGI::Util::expires which was called # once (52µs+24µs) by CGI::header at line 62 of (eval 0)[/usr/share/perl/5.10/CGI.pm:867] at line 867 of /usr/share/perl/5.10/CGI.pm
sub expires {
21713µs3µs my($time,$format) = @_;
2181400ns400ns $format ||= 'http';
219
22015µs5µs my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
22112µs2µs my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
222
223 # pass through preformatted dates for the sake of expire_calc()
224114µs14µs $time = expire_calc($time);
# spent 24µs making 1 call to CGI::Util::expire_calc
22519µs9µs return $time unless $time =~ /^\d+$/;
226
227 # make HTTP/cookie date string from GMT'ed time
228 # (cookies use '-' as date separator, HTTP uses ' ')
2291900ns900ns my($sc) = ' ';
2301900ns900ns $sc = '-' if $format eq "cookie";
23114µs4µs my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
2321500ns500ns $year += 1900;
23319µs9µs return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
234 $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
235}
236
237# This internal routine creates an expires time exactly some number of
238# hours from the current time. It incorporates modifications from
239# Mark Fisher.
240
# spent 24µs within CGI::Util::expire_calc which was called # once (24µs+0s) by CGI::Util::expires at line 224
sub expire_calc {
24111µs1µs my($time) = @_;
24215µs5µs my(%mult) = ('s'=>1,
243 'm'=>60,
244 'h'=>60*60,
245 'd'=>60*60*24,
246 'M'=>60*60*24*30,
247 'y'=>60*60*24*365);
248 # format for time can be in any of the forms...
249 # "now" -- expire immediately
250 # "+180s" -- in 180 seconds
251 # "+2m" -- in 2 minutes
252 # "+12h" -- in 12 hours
253 # "+1d" -- in 1 day
254 # "+3M" -- in 3 months
255 # "+2y" -- in 2 years
256 # "-3m" -- 3 minutes ago(!)
257 # If you don't supply one of these forms, we assume you are
258 # specifying the date yourself
2591200ns200ns my($offset);
2601900ns900ns if (!$time || (lc($time) eq 'now')) {
261 $offset = 0;
262 } elsif ($time=~/^\d+/) {
263 return $time;
264 } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([smhdMy])/) {
265 $offset = ($mult{$2} || 1)*$1;
266 } else {
267 return $time;
268 }
26914µs4µs return (time+$offset);
270}
271
272sub ebcdic2ascii {
273 my $data = shift;
274 $data =~ s/(.)/chr $E2A[ord($1)]/ge;
275 $data;
276}
277
278sub ascii2ebcdic {
279 my $data = shift;
280 $data =~ s/(.)/chr $A2E[ord($1)]/ge;
281 $data;
282}
283
2841;
285
286__END__
287
288=head1 NAME
289
290CGI::Util - Internal utilities used by CGI module
291
292=head1 SYNOPSIS
293
294none
295
296=head1 DESCRIPTION
297
298no public subroutines
299
300=head1 AUTHOR INFORMATION
301
302Copyright 1995-1998, Lincoln D. Stein. All rights reserved.
303
304This library is free software; you can redistribute it and/or modify
305it under the same terms as Perl itself.
306
307Address bug reports and comments to: lstein@cshl.org. When sending
308bug reports, please provide the version of CGI.pm, the version of
309Perl, the name and version of your Web server, and the name and
310version of the operating system you are using. If the problem is even
311remotely browser dependent, please provide information about the
312affected browers as well.
313
314=head1 SEE ALSO
315
316L<CGI>
317
318=cut
Report produced by the NYTProf 2.10 Perl profiler, developed by Tim Bunce and Adam Kaplan.