4 use vars qw($VERSION @EXPORT_OK @ISA $EBCDIC @A2E @E2A);
7 @EXPORT_OK = qw(rearrange rearrange_header make_attributes unescape escape
8 expires ebcdic2ascii ascii2ebcdic);
12 $EBCDIC = "\t" ne "\011";
13 # (ord('^') == 95) for codepage 1047 as on os390, vmesa
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
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
51 if ($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;
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;
64 elsif ($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;
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;
72 # Smart rearrangement of parameters to allow named parameter
73 # calling. We do the rearrangement if:
74 # the first parameter begins with a -
77 my ($order,@param) = @_;
78 my ($result, $leftover) = _rearrange_params( $order, @param );
79 push @$result, make_attributes( $leftover, defined $CGI::Q ? $CGI::Q->{escape} : 1 )
84 sub rearrange_header {
85 my ($order,@param) = @_;
87 my ($result,$leftover) = _rearrange_params( $order, @param );
88 push @$result, make_attributes( $leftover, 0, 1 ) if keys %$leftover;
93 sub _rearrange_params {
94 my($order,@param) = @_;
95 return [] unless @param;
97 if (ref($param[0]) eq 'HASH') {
98 @param = %{$param[0]};
101 unless (defined($param[0]) && substr($param[0],0,1) eq '-');
104 # map parameters into positional indices
108 foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{lc($_)} = $i; }
112 my (@result,%leftover);
113 $#result = $#$order; # preextend
115 my $key = lc(shift(@param));
117 if (exists $pos{$key}) {
118 $result[$pos{$key}] = shift(@param);
120 $leftover{$key} = shift(@param);
124 return \@result, \%leftover;
127 sub make_attributes {
129 return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
130 my $escape = shift || 0;
131 my $do_not_quote = shift;
133 my $quote = $do_not_quote ? '' : '"';
136 foreach (keys %{$attr}) {
138 $key=~s/^\-//; # get rid of initial - if present
140 # old way: breaks EBCDIC!
141 # $key=~tr/A-Z_/a-z-/; # parameters are lower case, use dashes
143 ($key="\L$key") =~ tr/_/-/; # parameters are lower case, use dashes
145 my $value = $escape ? simple_escape($attr->{$_}) : $attr->{$_};
146 push(@att,defined($attr->{$_}) ? qq/$key=$quote$value$quote/ : qq/$key/);
152 return unless defined(my $toencode = shift);
153 $toencode =~ s{&}{&}gso;
154 $toencode =~ s{<}{<}gso;
155 $toencode =~ s{>}{>}gso;
156 $toencode =~ s{\"}{"}gso;
157 # Doesn't work. Can't work. forget it.
158 # $toencode =~ s{\x8b}{‹}gso;
159 # $toencode =~ s{\x9b}{›}gso;
168 utf8::encode($u); # drop utf8 flag
172 return sprintf("%c", $c);
173 } elsif ($c < 0x800) {
174 return sprintf("%c%c", 0xc0 | ($c >> 6), 0x80 | ($c & 0x3f));
175 } elsif ($c < 0x10000) {
176 return sprintf("%c%c%c",
178 0x80 | (($c >> 6) & 0x3f),
179 0x80 | ( $c & 0x3f));
180 } elsif ($c < 0x200000) {
181 return sprintf("%c%c%c%c",
183 0x80 | (($c >> 12) & 0x3f),
184 0x80 | (($c >> 6) & 0x3f),
185 0x80 | ( $c & 0x3f));
186 } elsif ($c < 0x4000000) {
187 return sprintf("%c%c%c%c%c",
189 0x80 | (($c >> 18) & 0x3f),
190 0x80 | (($c >> 12) & 0x3f),
191 0x80 | (($c >> 6) & 0x3f),
192 0x80 | ( $c & 0x3f));
194 } elsif ($c < 0x80000000) {
195 return sprintf("%c%c%c%c%c%c",
197 0x80 | (($c >> 24) & 0x3f),
198 0x80 | (($c >> 18) & 0x3f),
199 0x80 | (($c >> 12) & 0x3f),
200 0x80 | (($c >> 6) & 0x3f),
201 0x80 | ( $c & 0x3f));
203 return utf8_chr(0xfffd);
207 # unescape URL-encoded data
209 shift() if @_ > 0 and (ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
210 my $todecode = shift;
211 return undef unless defined($todecode);
212 $todecode =~ tr/+/ /; # pluses become spaces
214 $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
216 # handle surrogate pairs first -- dankogai
218 %u([Dd][89a-bA-B][0-9a-fA-F]{2}) # hi
219 %u([Dd][c-fC-F][0-9a-fA-F]{2}) # lo
223 + (hex($1) - 0xD800) * 0x400
227 $todecode =~ s/%(?:([0-9a-fA-F]{2})|u([0-9a-fA-F]{4}))/
228 defined($1)? chr hex($1) : utf8_chr(hex($2))/ge;
235 # We cannot use the %u escapes, they were rejected by W3C, so the official
236 # way is %XX-escaped utf-8 encoding.
237 # Naturally, Unicode strings have to be converted to their utf-8 byte
238 # representation. (No action is required on 5.6.)
239 # Byte strings were traditionally used directly as a sequence of octets.
240 # This worked if they actually represented binary data (i.e. in CGI::Compress).
241 # This also worked if these byte strings were actually utf-8 encoded; e.g.,
242 # when the source file used utf-8 without the apropriate "use utf8;".
243 # This fails if the byte string is actually a Latin 1 encoded string, but it
244 # was always so and cannot be fixed without breaking the binary data case.
245 # -- Stepan Kasal <skasal@redhat.com>
248 shift() if @_ > 1 and ( ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
249 my $toencode = shift;
250 return undef unless defined($toencode);
251 utf8::encode($toencode) if ($] > 5.007 && utf8::is_utf8($toencode));
253 $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg;
255 $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",ord($1))/eg;
260 # This internal routine creates date strings suitable for use in
261 # cookies and HTTP headers. (They differ, unfortunately.)
262 # Thanks to Mark Fisher for this.
264 my($time,$format) = @_;
267 my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
268 my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
270 # pass through preformatted dates for the sake of expire_calc()
271 $time = expire_calc($time);
272 return $time unless $time =~ /^\d+$/;
274 # make HTTP/cookie date string from GMT'ed time
275 # (cookies use '-' as date separator, HTTP uses ' ')
277 $sc = '-' if $format eq "cookie";
278 my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
280 return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
281 $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
284 # This internal routine creates an expires time exactly some number of
285 # hours from the current time. It incorporates modifications from
295 # format for time can be in any of the forms...
296 # "now" -- expire immediately
297 # "+180s" -- in 180 seconds
298 # "+2m" -- in 2 minutes
299 # "+12h" -- in 12 hours
301 # "+3M" -- in 3 months
302 # "+2y" -- in 2 years
303 # "-3m" -- 3 minutes ago(!)
304 # If you don't supply one of these forms, we assume you are
305 # specifying the date yourself
307 if (!$time || (lc($time) eq 'now')) {
309 } elsif ($time=~/^\d+/) {
311 } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([smhdMy])/) {
312 $offset = ($mult{$2} || 1)*$1;
316 return (time+$offset);
321 $data =~ s/(.)/chr $E2A[ord($1)]/ge;
327 $data =~ s/(.)/chr $A2E[ord($1)]/ge;
337 CGI::Util - Internal utilities used by CGI module
345 no public subroutines
347 =head1 AUTHOR INFORMATION
349 Copyright 1995-1998, Lincoln D. Stein. All rights reserved.
351 This library is free software; you can redistribute it and/or modify
352 it under the same terms as Perl itself.
354 Address bug reports and comments to: lstein@cshl.org. When sending
355 bug reports, please provide the version of CGI.pm, the version of
356 Perl, the name and version of your Web server, and the name and
357 version of the operating system you are using. If the problem is even
358 remotely browser dependent, please provide information about the
359 affected browers as well.