4 use vars '$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
118 $key=~tr/A-Z_/a-z-/; # parameters are lower case, use dashes
119 my $value = $escape ? simple_escape($attr->{$_}) : $attr->{$_};
120 push(@att,defined($attr->{$_}) ? qq/$key="$value"/ : qq/$key/);
126 return unless defined(my $toencode = shift);
127 $toencode =~ s{&}{&}gso;
128 $toencode =~ s{<}{<}gso;
129 $toencode =~ s{>}{>}gso;
130 $toencode =~ s{\"}{"}gso;
131 # Doesn't work. Can't work. forget it.
132 # $toencode =~ s{\x8b}{‹}gso;
133 # $toencode =~ s{\x9b}{›}gso;
137 # unescape URL-encoded data
139 shift() if ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass);
140 my $todecode = shift;
141 return undef unless defined($todecode);
142 $todecode =~ tr/+/ /; # pluses become spaces
144 $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
146 $todecode =~ s/%([0-9a-fA-F]{2})/chr hex($1)/ge;
153 shift() if ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass);
154 my $toencode = shift;
155 return undef unless defined($toencode);
157 $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg;
159 $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
164 # This internal routine creates date strings suitable for use in
165 # cookies and HTTP headers. (They differ, unfortunately.)
166 # Thanks to Mark Fisher for this.
168 my($time,$format) = @_;
171 my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
172 my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
174 # pass through preformatted dates for the sake of expire_calc()
175 $time = expire_calc($time);
176 return $time unless $time =~ /^\d+$/;
178 # make HTTP/cookie date string from GMT'ed time
179 # (cookies use '-' as date separator, HTTP uses ' ')
181 $sc = '-' if $format eq "cookie";
182 my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
184 return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
185 $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
188 # This internal routine creates an expires time exactly some number of
189 # hours from the current time. It incorporates modifications from
199 # format for time can be in any of the forms...
200 # "now" -- expire immediately
201 # "+180s" -- in 180 seconds
202 # "+2m" -- in 2 minutes
203 # "+12h" -- in 12 hours
205 # "+3M" -- in 3 months
206 # "+2y" -- in 2 years
207 # "-3m" -- 3 minutes ago(!)
208 # If you don't supply one of these forms, we assume you are
209 # specifying the date yourself
211 if (!$time || (lc($time) eq 'now')) {
213 } elsif ($time=~/^\d+/) {
215 } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) {
216 $offset = ($mult{$2} || 1)*$1;
220 return (time+$offset);