Only 21 tests, skipping or not.
[p5sagit/p5-mst-13.2.git] / lib / CGI / Util.pm
CommitLineData
3d1a2ec4 1package CGI::Util;
2
3use strict;
92dffb52 4use vars '$VERSION','@EXPORT_OK','@ISA','$EBCDIC','@A2E','@E2A';
3d1a2ec4 5require Exporter;
6@ISA = qw(Exporter);
7@EXPORT_OK = qw(rearrange make_attributes unescape escape expires);
8
9$VERSION = '1.1';
10
11$EBCDIC = "\t" ne "\011";
12if ($EBCDIC) {
92dffb52 13# (ord('^') == 95) for codepage 1047 as on os390, vmesa
3d1a2ec4 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,
18240,241,242,243,244,245,246,247,248,249,122, 94, 76,126,110,111,
19124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214,
20215,216,217,226,227,228,229,230,231,232,233,173,224,189, 95,109,
21121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150,
22151,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,
26144,143,234,250,190,160,182,179,157,218,155,139,183,184,185,171,
27100,101, 98,102, 99,103,158,104,116,113,114,115,120,117,118,119,
28172,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,
30140, 73,205,206,203,207,204,225,112,221,222,219,220,141,142,223
31 );
92dffb52 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,
35128,129,130,131,132,133, 23, 27,136,137,138,139,140, 5, 6, 7,
36144,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,
40248,201,202,203,200,205,206,207,204, 96, 58, 35, 64, 39, 61, 34,
41216, 97, 98, 99,100,101,102,103,104,105,171,187,240,253,254,177,
42176,106,107,108,109,110,111,112,113,114,170,186,230,184,198,164,
43181,126,115,116,117,118,119,120,121,122,161,191,208, 91,222,174,
44172,163,165,183,169,167,182,188,189,190,221,168,175, 93,180,215,
45123, 65, 66, 67, 68, 69, 70, 71, 72, 73,173,244,246,242,243,245,
46125, 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 );
50if (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}
63elsif (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}
3d1a2ec4 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 -
75sub 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) {
6b4ac661 90 foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{lc($_)} = $i; }
3d1a2ec4 91 $i++;
92 }
93
94 my (@result,%leftover);
95 $#result = $#$order; # preextend
96 while (@param) {
6b4ac661 97 my $key = lc(shift(@param));
3d1a2ec4 98 $key =~ s/^\-//;
99 if (exists $pos{$key}) {
100 $result[$pos{$key}] = shift(@param);
101 } else {
102 $leftover{$key} = shift(@param);
103 }
104 }
105
6b4ac661 106 push (@result,make_attributes(\%leftover,1)) if %leftover;
3d1a2ec4 107 @result;
108}
109
110sub 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
69c89ae7 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
3d1a2ec4 124 my $value = $escape ? simple_escape($attr->{$_}) : $attr->{$_};
125 push(@att,defined($attr->{$_}) ? qq/$key="$value"/ : qq/$key/);
126 }
127 return @att;
128}
129
130sub simple_escape {
6b4ac661 131 return unless defined(my $toencode = shift);
132 $toencode =~ s{&}{&}gso;
133 $toencode =~ s{<}{&lt;}gso;
134 $toencode =~ s{>}{&gt;}gso;
135 $toencode =~ s{\"}{&quot;}gso;
136# Doesn't work. Can't work. forget it.
137# $toencode =~ s{\x8b}{&#139;}gso;
138# $toencode =~ s{\x9b}{&#155;}gso;
3d1a2ec4 139 $toencode;
140}
141
69c89ae7 142sub 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
3d1a2ec4 181# unescape URL-encoded data
182sub unescape {
183 shift() if ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass);
184 my $todecode = shift;
185 return undef unless defined($todecode);
186 $todecode =~ tr/+/ /; # pluses become spaces
ba056755 187 $EBCDIC = "\t" ne "\011";
3d1a2ec4 188 if ($EBCDIC) {
189 $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
190 } else {
69c89ae7 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;
3d1a2ec4 193 }
194 return $todecode;
195}
196
197# URL-encode data
198sub escape {
199 shift() if ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass);
200 my $toencode = shift;
201 return undef unless defined($toencode);
92dffb52 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 }
3d1a2ec4 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.
213sub 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.
237sub 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
2691;
ba056755 270
271__END__
272
273=head1 NAME
274
275CGI::Util - Internal utilities used by CGI module
276
277=head1 SYNOPSIS
278
279none
280
281=head1 DESCRIPTION
282
283no public subroutines
284
285=head1 AUTHOR INFORMATION
286
287Copyright 1995-1998, Lincoln D. Stein. All rights reserved.
288
289This library is free software; you can redistribute it and/or modify
290it under the same terms as Perl itself.
291
292Address bug reports and comments to: lstein@cshl.org. When sending
293bug reports, please provide the version of CGI.pm, the version of
294Perl, the name and version of your Web server, and the name and
295version of the operating system you are using. If the problem is even
296remotely browser dependent, please provide information about the
297affected browers as well.
298
299=head1 SEE ALSO
300
301L<CGI>
302
303=cut