4 use vars qw($VERSION @EXPORT_OK @ISA $EBCDIC @A2E @E2A);
7 @EXPORT_OK = qw(rearrange make_attributes unescape escape expires);
11 $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
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;
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;
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;
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;
72 # Smart rearrangement of parameters to allow named parameter
73 # calling. We do the rearangement if:
74 # the first parameter begins with a -
76 my($order,@param) = @_;
77 return () unless @param;
79 if (ref($param[0]) eq 'HASH') {
80 @param = %{$param[0]};
83 unless (defined($param[0]) && substr($param[0],0,1) eq '-');
86 # map parameters into positional indices
90 foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{lc($_)} = $i; }
94 my (@result,%leftover);
95 $#result = $#$order; # preextend
97 my $key = lc(shift(@param));
99 if (exists $pos{$key}) {
100 $result[$pos{$key}] = shift(@param);
102 $leftover{$key} = shift(@param);
106 push (@result,make_attributes(\%leftover,1)) if %leftover;
110 sub make_attributes {
112 return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
113 my $escape = shift || 0;
115 foreach (keys %{$attr}) {
117 $key=~s/^\-//; # get rid of initial - if present
119 # old way: breaks EBCDIC!
120 # $key=~tr/A-Z_/a-z-/; # parameters are lower case, use dashes
122 ($key="\L$key") =~ tr/_/-/; # parameters are lower case, use dashes
124 my $value = $escape ? simple_escape($attr->{$_}) : $attr->{$_};
125 push(@att,defined($attr->{$_}) ? qq/$key="$value"/ : qq/$key/);
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;
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",
152 0x80 | (($c >> 6) & 0x3f),
153 0x80 | ( $c & 0x3f));
154 } elsif ($c < 0x200000) {
155 return sprintf("%c%c%c%c",
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",
163 0x80 | (($c >> 18) & 0x3f),
164 0x80 | (($c >> 12) & 0x3f),
165 0x80 | (($c >> 6) & 0x3f),
166 0x80 | ( $c & 0x3f));
168 } elsif ($c < 0x80000000) {
169 return sprintf("%c%c%c%c%c%c",
171 0x80 | (($c >> 24) & 0x3f),
172 0x80 | (($c >> 18) & 0x3f),
173 0x80 | (($c >> 12) & 0x3f),
174 0x80 | (($c >> 6) & 0x3f),
175 0x80 | ( $c & 0x3f));
181 # unescape URL-encoded data
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";
189 $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
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;
199 shift() if @_ > 1 and ( ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
200 my $toencode = shift;
201 return undef unless defined($toencode);
202 # force bytes while preserving backward compatibility -- dankogai
203 $toencode = pack("C*", unpack("C*", $toencode));
205 $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg;
207 $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
212 # This internal routine creates date strings suitable for use in
213 # cookies and HTTP headers. (They differ, unfortunately.)
214 # Thanks to Mark Fisher for this.
216 my($time,$format) = @_;
219 my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
220 my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
222 # pass through preformatted dates for the sake of expire_calc()
223 $time = expire_calc($time);
224 return $time unless $time =~ /^\d+$/;
226 # make HTTP/cookie date string from GMT'ed time
227 # (cookies use '-' as date separator, HTTP uses ' ')
229 $sc = '-' if $format eq "cookie";
230 my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
232 return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
233 $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
236 # This internal routine creates an expires time exactly some number of
237 # hours from the current time. It incorporates modifications from
247 # format for time can be in any of the forms...
248 # "now" -- expire immediately
249 # "+180s" -- in 180 seconds
250 # "+2m" -- in 2 minutes
251 # "+12h" -- in 12 hours
253 # "+3M" -- in 3 months
254 # "+2y" -- in 2 years
255 # "-3m" -- 3 minutes ago(!)
256 # If you don't supply one of these forms, we assume you are
257 # specifying the date yourself
259 if (!$time || (lc($time) eq 'now')) {
261 } elsif ($time=~/^\d+/) {
263 } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) {
264 $offset = ($mult{$2} || 1)*$1;
268 return (time+$offset);
277 CGI::Util - Internal utilities used by CGI module
285 no public subroutines
287 =head1 AUTHOR INFORMATION
289 Copyright 1995-1998, Lincoln D. Stein. All rights reserved.
291 This library is free software; you can redistribute it and/or modify
292 it under the same terms as Perl itself.
294 Address bug reports and comments to: lstein@cshl.org. When sending
295 bug reports, please provide the version of CGI.pm, the version of
296 Perl, the name and version of your Web server, and the name and
297 version of the operating system you are using. If the problem is even
298 remotely browser dependent, please provide information about the
299 affected browers as well.