4 use vars qw($VERSION @EXPORT_OK @ISA $EBCDIC @A2E @E2A);
7 @EXPORT_OK = qw(rearrange make_attributes unescape escape
8 expires ebcdic2ascii ascii2ebcdic);
12 $EBCDIC = "\t" ne "\011";
14 # (ord('^') == 95) for codepage 1047 as on os390, vmesa
16 0, 1, 2, 3, 55, 45, 46, 47, 22, 5, 21, 11, 12, 13, 14, 15,
17 16, 17, 18, 19, 60, 61, 50, 38, 24, 25, 63, 39, 28, 29, 30, 31,
18 64, 90,127,123, 91,108, 80,125, 77, 93, 92, 78,107, 96, 75, 97,
19 240,241,242,243,244,245,246,247,248,249,122, 94, 76,126,110,111,
20 124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214,
21 215,216,217,226,227,228,229,230,231,232,233,173,224,189, 95,109,
22 121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150,
23 151,152,153,162,163,164,165,166,167,168,169,192, 79,208,161, 7,
24 32, 33, 34, 35, 36, 37, 6, 23, 40, 41, 42, 43, 44, 9, 10, 27,
25 48, 49, 26, 51, 52, 53, 54, 8, 56, 57, 58, 59, 4, 20, 62,255,
26 65,170, 74,177,159,178,106,181,187,180,154,138,176,202,175,188,
27 144,143,234,250,190,160,182,179,157,218,155,139,183,184,185,171,
28 100,101, 98,102, 99,103,158,104,116,113,114,115,120,117,118,119,
29 172,105,237,238,235,239,236,191,128,253,254,251,252,186,174, 89,
30 68, 69, 66, 70, 67, 71,156, 72, 84, 81, 82, 83, 88, 85, 86, 87,
31 140, 73,205,206,203,207,204,225,112,221,222,219,220,141,142,223
34 0, 1, 2, 3,156, 9,134,127,151,141,142, 11, 12, 13, 14, 15,
35 16, 17, 18, 19,157, 10, 8,135, 24, 25,146,143, 28, 29, 30, 31,
36 128,129,130,131,132,133, 23, 27,136,137,138,139,140, 5, 6, 7,
37 144,145, 22,147,148,149,150, 4,152,153,154,155, 20, 21,158, 26,
38 32,160,226,228,224,225,227,229,231,241,162, 46, 60, 40, 43,124,
39 38,233,234,235,232,237,238,239,236,223, 33, 36, 42, 41, 59, 94,
40 45, 47,194,196,192,193,195,197,199,209,166, 44, 37, 95, 62, 63,
41 248,201,202,203,200,205,206,207,204, 96, 58, 35, 64, 39, 61, 34,
42 216, 97, 98, 99,100,101,102,103,104,105,171,187,240,253,254,177,
43 176,106,107,108,109,110,111,112,113,114,170,186,230,184,198,164,
44 181,126,115,116,117,118,119,120,121,122,161,191,208, 91,222,174,
45 172,163,165,183,169,167,182,188,189,190,221,168,175, 93,180,215,
46 123, 65, 66, 67, 68, 69, 70, 71, 72, 73,173,244,246,242,243,245,
47 125, 74, 75, 76, 77, 78, 79, 80, 81, 82,185,251,252,249,250,255,
48 92,247, 83, 84, 85, 86, 87, 88, 89, 90,178,212,214,210,211,213,
49 48, 49, 50, 51, 52, 53, 54, 55, 56, 57,179,219,220,217,218,159
51 if (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 (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;
73 # Smart rearrangement of parameters to allow named parameter
74 # calling. We do the rearangement if:
75 # the first parameter begins with a -
77 my($order,@param) = @_;
78 return () unless @param;
80 if (ref($param[0]) eq 'HASH') {
81 @param = %{$param[0]};
84 unless (defined($param[0]) && substr($param[0],0,1) eq '-');
87 # map parameters into positional indices
91 foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{lc($_)} = $i; }
95 my (@result,%leftover);
96 $#result = $#$order; # preextend
98 my $key = lc(shift(@param));
100 if (exists $pos{$key}) {
101 $result[$pos{$key}] = shift(@param);
103 $leftover{$key} = shift(@param);
107 push (@result,make_attributes(\%leftover,1)) if %leftover;
111 sub make_attributes {
113 return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
114 my $escape = shift || 0;
116 foreach (keys %{$attr}) {
118 $key=~s/^\-//; # get rid of initial - if present
120 # old way: breaks EBCDIC!
121 # $key=~tr/A-Z_/a-z-/; # parameters are lower case, use dashes
123 ($key="\L$key") =~ tr/_/-/; # parameters are lower case, use dashes
125 my $value = $escape ? simple_escape($attr->{$_}) : $attr->{$_};
126 push(@att,defined($attr->{$_}) ? qq/$key="$value"/ : qq/$key/);
132 return unless defined(my $toencode = shift);
133 $toencode =~ s{&}{&}gso;
134 $toencode =~ s{<}{<}gso;
135 $toencode =~ s{>}{>}gso;
136 $toencode =~ s{\"}{"}gso;
137 # Doesn't work. Can't work. forget it.
138 # $toencode =~ s{\x8b}{‹}gso;
139 # $toencode =~ s{\x9b}{›}gso;
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",
153 0x80 | (($c >> 6) & 0x3f),
154 0x80 | ( $c & 0x3f));
155 } elsif ($c < 0x200000) {
156 return sprintf("%c%c%c%c",
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",
164 0x80 | (($c >> 18) & 0x3f),
165 0x80 | (($c >> 12) & 0x3f),
166 0x80 | (($c >> 6) & 0x3f),
167 0x80 | ( $c & 0x3f));
169 } elsif ($c < 0x80000000) {
170 return sprintf("%c%c%c%c%c%c",
172 0x80 | (($c >> 24) & 0x3f),
173 0x80 | (($c >> 18) & 0x3f),
174 0x80 | (($c >> 12) & 0x3f),
175 0x80 | (($c >> 6) & 0x3f),
176 0x80 | ( $c & 0x3f));
182 # unescape URL-encoded data
184 shift() if @_ > 1 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";
190 $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
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;
200 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));
206 $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg;
208 $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
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.
217 my($time,$format) = @_;
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/;
223 # pass through preformatted dates for the sake of expire_calc()
224 $time = expire_calc($time);
225 return $time unless $time =~ /^\d+$/;
227 # make HTTP/cookie date string from GMT'ed time
228 # (cookies use '-' as date separator, HTTP uses ' ')
230 $sc = '-' if $format eq "cookie";
231 my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
233 return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
234 $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
237 # This internal routine creates an expires time exactly some number of
238 # hours from the current time. It incorporates modifications from
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
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
260 if (!$time || (lc($time) eq 'now')) {
262 } elsif ($time=~/^\d+/) {
264 } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) {
265 $offset = ($mult{$2} || 1)*$1;
269 return (time+$offset);
274 $data =~ s/(.)/chr $E2A[ord($1)]/ge;
280 $data =~ s/(.)/chr $A2E[ord($1)]/ge;
290 CGI::Util - Internal utilities used by CGI module
298 no public subroutines
300 =head1 AUTHOR INFORMATION
302 Copyright 1995-1998, Lincoln D. Stein. All rights reserved.
304 This library is free software; you can redistribute it and/or modify
305 it under the same terms as Perl itself.
307 Address bug reports and comments to: lstein@cshl.org. When sending
308 bug reports, please provide the version of CGI.pm, the version of
309 Perl, the name and version of your Web server, and the name and
310 version of the operating system you are using. If the problem is even
311 remotely browser dependent, please provide information about the
312 affected browers as well.