Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | package CGI::Util; |
2 | ||
3 | use strict; | |
4 | use vars qw($VERSION @EXPORT_OK @ISA $EBCDIC @A2E @E2A); | |
5 | require Exporter; | |
6 | @ISA = qw(Exporter); | |
7 | @EXPORT_OK = qw(rearrange make_attributes unescape escape expires); | |
8 | ||
9 | $VERSION = '1.3'; | |
10 | ||
11 | $EBCDIC = "\t" ne "\011"; | |
12 | if ($EBCDIC) { | |
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 | if (ord('^') == 106) { # as in the BS2000 posix-bc coded character set | |
51 | $A2E[91] = 187; $A2E[92] = 188; $A2E[94] = 106; $A2E[96] = 74; | |
52 | $A2E[123] = 251; $A2E[125] = 253; $A2E[126] = 255; $A2E[159] = 95; | |
53 | $A2E[162] = 176; $A2E[166] = 208; $A2E[168] = 121; $A2E[172] = 186; | |
54 | $A2E[175] = 161; $A2E[217] = 224; $A2E[219] = 221; $A2E[221] = 173; | |
55 | $A2E[249] = 192; | |
56 | ||
57 | $E2A[74] = 96; $E2A[95] = 159; $E2A[106] = 94; $E2A[121] = 168; | |
58 | $E2A[161] = 175; $E2A[173] = 221; $E2A[176] = 162; $E2A[186] = 172; | |
59 | $E2A[187] = 91; $E2A[188] = 92; $E2A[192] = 249; $E2A[208] = 166; | |
60 | $E2A[221] = 219; $E2A[224] = 217; $E2A[251] = 123; $E2A[253] = 125; | |
61 | $E2A[255] = 126; | |
62 | } | |
63 | elsif (ord('^') == 176) { # as in codepage 037 on os400 | |
64 | $A2E[10] = 37; $A2E[91] = 186; $A2E[93] = 187; $A2E[94] = 176; | |
65 | $A2E[133] = 21; $A2E[168] = 189; $A2E[172] = 95; $A2E[221] = 173; | |
66 | ||
67 | $E2A[21] = 133; $E2A[37] = 10; $E2A[95] = 172; $E2A[173] = 221; | |
68 | $E2A[176] = 94; $E2A[186] = 91; $E2A[187] = 93; $E2A[189] = 168; | |
69 | } | |
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 | sub rearrange { | |
76 | 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,1)) if %leftover; | |
107 | @result; | |
108 | } | |
109 | ||
110 | sub make_attributes { | |
111 | 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->{$_}; | |
125 | push(@att,defined($attr->{$_}) ? qq/$key="$value"/ : qq/$key/); | |
126 | } | |
127 | return @att; | |
128 | } | |
129 | ||
130 | sub simple_escape { | |
131 | return unless defined(my $toencode = shift); | |
132 | $toencode =~ s{&}{&}gso; | |
133 | $toencode =~ s{<}{<}gso; | |
134 | $toencode =~ s{>}{>}gso; | |
135 | $toencode =~ s{\"}{"}gso; | |
136 | # Doesn't work. Can't work. forget it. | |
137 | # $toencode =~ s{\x8b}{‹}gso; | |
138 | # $toencode =~ s{\x9b}{›}gso; | |
139 | $toencode; | |
140 | } | |
141 | ||
142 | sub utf8_chr ($) { | |
143 | my $c = shift(@_); | |
144 | ||
145 | if ($c < 0x80) { | |
146 | return sprintf("%c", $c); | |
147 | } elsif ($c < 0x800) { | |
148 | return sprintf("%c%c", 0xc0 | ($c >> 6), 0x80 | ($c & 0x3f)); | |
149 | } elsif ($c < 0x10000) { | |
150 | return sprintf("%c%c%c", | |
151 | 0xe0 | ($c >> 12), | |
152 | 0x80 | (($c >> 6) & 0x3f), | |
153 | 0x80 | ( $c & 0x3f)); | |
154 | } elsif ($c < 0x200000) { | |
155 | return sprintf("%c%c%c%c", | |
156 | 0xf0 | ($c >> 18), | |
157 | 0x80 | (($c >> 12) & 0x3f), | |
158 | 0x80 | (($c >> 6) & 0x3f), | |
159 | 0x80 | ( $c & 0x3f)); | |
160 | } elsif ($c < 0x4000000) { | |
161 | return sprintf("%c%c%c%c%c", | |
162 | 0xf8 | ($c >> 24), | |
163 | 0x80 | (($c >> 18) & 0x3f), | |
164 | 0x80 | (($c >> 12) & 0x3f), | |
165 | 0x80 | (($c >> 6) & 0x3f), | |
166 | 0x80 | ( $c & 0x3f)); | |
167 | ||
168 | } elsif ($c < 0x80000000) { | |
169 | return sprintf("%c%c%c%c%c%c", | |
170 | 0xfe | ($c >> 30), | |
171 | 0x80 | (($c >> 24) & 0x3f), | |
172 | 0x80 | (($c >> 18) & 0x3f), | |
173 | 0x80 | (($c >> 12) & 0x3f), | |
174 | 0x80 | (($c >> 6) & 0x3f), | |
175 | 0x80 | ( $c & 0x3f)); | |
176 | } else { | |
177 | return utf8(0xfffd); | |
178 | } | |
179 | } | |
180 | ||
181 | # unescape URL-encoded data | |
182 | sub unescape { | |
183 | shift() if @_ > 1 and (ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass)); | |
184 | my $todecode = shift; | |
185 | return undef unless defined($todecode); | |
186 | $todecode =~ tr/+/ /; # pluses become spaces | |
187 | $EBCDIC = "\t" ne "\011"; | |
188 | if ($EBCDIC) { | |
189 | $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge; | |
190 | } else { | |
191 | $todecode =~ s/%(?:([0-9a-fA-F]{2})|u([0-9a-fA-F]{4}))/ | |
192 | defined($1)? chr hex($1) : utf8_chr(hex($2))/ge; | |
193 | } | |
194 | return $todecode; | |
195 | } | |
196 | ||
197 | # URL-encode data | |
198 | sub escape { | |
199 | shift() if @_ > 1 and ( ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass)); | |
200 | my $toencode = shift; | |
201 | return undef unless defined($toencode); | |
202 | if ($EBCDIC) { | |
203 | $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg; | |
204 | } else { | |
205 | $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg; | |
206 | } | |
207 | return $toencode; | |
208 | } | |
209 | ||
210 | # This internal routine creates date strings suitable for use in | |
211 | # cookies and HTTP headers. (They differ, unfortunately.) | |
212 | # Thanks to Mark Fisher for this. | |
213 | sub expires { | |
214 | my($time,$format) = @_; | |
215 | $format ||= 'http'; | |
216 | ||
217 | my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/; | |
218 | my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/; | |
219 | ||
220 | # pass through preformatted dates for the sake of expire_calc() | |
221 | $time = expire_calc($time); | |
222 | return $time unless $time =~ /^\d+$/; | |
223 | ||
224 | # make HTTP/cookie date string from GMT'ed time | |
225 | # (cookies use '-' as date separator, HTTP uses ' ') | |
226 | my($sc) = ' '; | |
227 | $sc = '-' if $format eq "cookie"; | |
228 | my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time); | |
229 | $year += 1900; | |
230 | return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT", | |
231 | $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec); | |
232 | } | |
233 | ||
234 | # This internal routine creates an expires time exactly some number of | |
235 | # hours from the current time. It incorporates modifications from | |
236 | # Mark Fisher. | |
237 | sub expire_calc { | |
238 | my($time) = @_; | |
239 | my(%mult) = ('s'=>1, | |
240 | 'm'=>60, | |
241 | 'h'=>60*60, | |
242 | 'd'=>60*60*24, | |
243 | 'M'=>60*60*24*30, | |
244 | 'y'=>60*60*24*365); | |
245 | # format for time can be in any of the forms... | |
246 | # "now" -- expire immediately | |
247 | # "+180s" -- in 180 seconds | |
248 | # "+2m" -- in 2 minutes | |
249 | # "+12h" -- in 12 hours | |
250 | # "+1d" -- in 1 day | |
251 | # "+3M" -- in 3 months | |
252 | # "+2y" -- in 2 years | |
253 | # "-3m" -- 3 minutes ago(!) | |
254 | # If you don't supply one of these forms, we assume you are | |
255 | # specifying the date yourself | |
256 | my($offset); | |
257 | if (!$time || (lc($time) eq 'now')) { | |
258 | $offset = 0; | |
259 | } elsif ($time=~/^\d+/) { | |
260 | return $time; | |
261 | } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) { | |
262 | $offset = ($mult{$2} || 1)*$1; | |
263 | } else { | |
264 | return $time; | |
265 | } | |
266 | return (time+$offset); | |
267 | } | |
268 | ||
269 | 1; | |
270 | ||
271 | __END__ | |
272 | ||
273 | =head1 NAME | |
274 | ||
275 | CGI::Util - Internal utilities used by CGI module | |
276 | ||
277 | =head1 SYNOPSIS | |
278 | ||
279 | none | |
280 | ||
281 | =head1 DESCRIPTION | |
282 | ||
283 | no public subroutines | |
284 | ||
285 | =head1 AUTHOR INFORMATION | |
286 | ||
287 | Copyright 1995-1998, Lincoln D. Stein. All rights reserved. | |
288 | ||
289 | This library is free software; you can redistribute it and/or modify | |
290 | it under the same terms as Perl itself. | |
291 | ||
292 | Address bug reports and comments to: lstein@cshl.org. When sending | |
293 | bug reports, please provide the version of CGI.pm, the version of | |
294 | Perl, the name and version of your Web server, and the name and | |
295 | version of the operating system you are using. If the problem is even | |
296 | remotely browser dependent, please provide information about the | |
297 | affected browers as well. | |
298 | ||
299 | =head1 SEE ALSO | |
300 | ||
301 | L<CGI> | |
302 | ||
303 | =cut |