← Index
Performance Profile   « block view • line view • sub view »
For opac/opac-main.pl
  Run on Thu Jul 17 22:22:09 2008
Reported on Thu Jul 17 22:22:22 2008

File/usr/share/perl/5.8/CGI/Util.pm
Statements Executed234
Total Time0.000379 seconds

Subroutines — ordered by inclusive time then name
CallsInclusive
Time		Subroutine
80.00038CGI::Util::rearrange
100.00018CGI::Util::escape
10.00007CGI::Util::make_attributes
10.00006CGI::Util::expires
20.00002CGI::Util::simple_escape
10.00002CGI::Util::expire_calc
00CGI::Util::BEGIN
00CGI::Util::ascii2ebcdic
00CGI::Util::ebcdic2ascii
00CGI::Util::unescape
00CGI::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';
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 0.00038s within CGI::Util::rearrange which was called 8 times, avg 0.00005s/call: # 4 times (0.00006s) by CGI::cookie at line 3 of /usr/share/perl/5.8/CGI.pm, avg 0.00001s/call # 2 times (0.00003s) by CGI::delete at line 6 of /usr/share/perl/5.8/CGI.pm, avg 0.00002s/call # 1 times (0.00021s) by CGI::header at line 7 of /usr/share/perl/5.8/CGI.pm # 1 times (0.00009s) by CGI::Cookie::new at line 115 of /usr/share/perl/5.8/CGI/Cookie.pm
sub rearrange {
761200.000182e-06 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 0.00007s making 1 calls to CGI::Util::make_attributes
107 @result;
108}
109
110
# spent 0.00007s within CGI::Util::make_attributes which was called: # 1 times (0.00007s) by CGI::Util::rearrange at line 106 of /usr/share/perl/5.8/CGI/Util.pm
sub make_attributes {
111160.000042e-06 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 0.00002s making 2 calls to CGI::Util::simple_escape, avg 0.00001s/call
125 push(@att,defined($attr->{$_}) ? qq/$key="$value"/ : qq/$key/);
126 }
127 return @att;
128}
129
130
# spent 0.00002s within CGI::Util::simple_escape which was called 2 times, avg 0.00001s/call: # 2 times (0.00002s) by CGI::Util::make_attributes at line 124 of /usr/share/perl/5.8/CGI/Util.pm, avg 0.00001s/call
sub simple_escape {
131126e-065e-07 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
183sub unescape {
184 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 0.00018s within CGI::Util::escape which was called 10 times, avg 0.00002s/call: # 5 times (0.00010s) by CGI::Cookie::as_string at line 161 of /usr/share/perl/5.8/CGI/Cookie.pm, avg 0.00002s/call # 5 times (0.00009s) by CGI::Cookie::as_string at line 162 of /usr/share/perl/5.8/CGI/Cookie.pm, avg 0.00002s/call
sub escape {
200700.000112e-06 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("C*", $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 0.00006s within CGI::Util::expires which was called: # 1 times (0.00006s) by CGI::header at line 55 of /usr/share/perl/5.8/CGI.pm
sub expires {
217110.000033e-06 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 0.00002s making 1 calls 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 0.00002s within CGI::Util::expire_calc which was called: # 1 times (0.00002s) by CGI::Util::expires at line 224 of /usr/share/perl/5.8/CGI/Util.pm
sub expire_calc {
24150.000012e-06 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*))([mhdMy]?)/) {
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.01 Perl profiler, developed by Tim Bunce and Adam Kaplan.