← 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:51 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 {
76457647µs1µs my($order,@param) = @_;
77 return () unless @param;
78
79 if (ref($param[0]) eq 'HASH') {
80 @param = %{$param[0]};
81 } else {
82 return @param
83 unless (defined($param[0]) && substr($param[0],0,1) eq '-');
84 }
85
86 # map parameters into positional indices
87 my ($i,%pos);
88 $i = 0;
89 foreach (@$order) {
90 foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{lc($_)} = $i; }
91 $i++;
92 }
93
94 my (@result,%leftover);
95 $#result = $#$order; # preextend
96 while (@param) {
97 my $key = lc(shift(@param));
98 $key =~ s/^\-//;
99 if (exists $pos{$key}) {
100 $result[$pos{$key}] = shift(@param);
101 } else {
102 $leftover{$key} = shift(@param);
103 }
104 }
105
106 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
107 @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 {
11174235µs3µs my $attr = shift;
112 return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
113 my $escape = shift || 0;
114 my(@att);
115 foreach (keys %{$attr}) {
116 my($key) = $_;
117 $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
122 ($key="\L$key") =~ tr/_/-/; # parameters are lower case, use dashes
123
124 my $value = $escape ? simple_escape($attr->{$_}) : $attr->{$_};
# spent 168µs making 10 calls to CGI::Util::simple_escape, avg 17µs/call
125 push(@att,defined($attr->{$_}) ? qq/$key="$value"/ : qq/$key/);
126 }
127 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 {
1316047µs792ns return unless defined(my $toencode = shift);
132 $toencode =~ s{&}{&}gso;
133 $toencode =~ s{<}{&lt;}gso;
134 $toencode =~ s{>}{&gt;}gso;
135 $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;
139 $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 {
1847962µs780ns shift() if @_ > 0 and (ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
185 my $todecode = shift;
186 return undef unless defined($todecode);
187 $todecode =~ tr/+/ /; # pluses become spaces
188 $EBCDIC = "\t" ne "\011";
189 if ($EBCDIC) {
190 $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
191 } else {
192 $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 }
195 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 {
20098175µs2µs shift() if @_ > 1 and ( ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
201 my $toencode = shift;
202 return undef unless defined($toencode);
203 # force bytes while preserving backward compatibility -- dankogai
204 $toencode = pack("C*", unpack("U0C*", $toencode));
205 if ($EBCDIC) {
206 $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg;
207 } else {
208 $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",ord($1))/eg;
209 }
210 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 {
2171147µs4µs my($time,$format) = @_;
218 $format ||= 'http';
219
220 my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
221 my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
222
223 # pass through preformatted dates for the sake of expire_calc()
224 $time = expire_calc($time);
# spent 24µs making 1 call to CGI::Util::expire_calc
225 return $time unless $time =~ /^\d+$/;
226
227 # make HTTP/cookie date string from GMT'ed time
228 # (cookies use '-' as date separator, HTTP uses ' ')
229 my($sc) = ' ';
230 $sc = '-' if $format eq "cookie";
231 my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
232 $year += 1900;
233 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 {
241512µs2µs my($time) = @_;
242 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
259 my($offset);
260 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 }
269 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.