This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: Compress::Zlib, pack "C" and utf-8 [PATCH]
[perl5.git] / lib / CGI / Util.pm
CommitLineData
3d1a2ec4
GS
1package CGI::Util;
2
3use strict;
ac734d8b 4use vars qw($VERSION @EXPORT_OK @ISA $EBCDIC @A2E @E2A);
3d1a2ec4
GS
5require Exporter;
6@ISA = qw(Exporter);
2ed511ec
RGS
7@EXPORT_OK = qw(rearrange make_attributes unescape escape
8 expires ebcdic2ascii ascii2ebcdic);
3d1a2ec4 9
13548fdf 10$VERSION = '1.5';
3d1a2ec4
GS
11
12$EBCDIC = "\t" ne "\011";
13548fdf
RGS
13# (ord('^') == 95) for codepage 1047 as on os390, vmesa
14@A2E = (
ac734d8b
JH
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
31 );
13548fdf 32@E2A = (
ac734d8b
JH
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
49 );
13548fdf
RGS
50
51if ($EBCDIC && ord('^') == 106) { # as in the BS2000 posix-bc coded character set
ac734d8b
JH
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;
56 $A2E[249] = 192;
13548fdf 57
ac734d8b
JH
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;
62 $E2A[255] = 126;
ac734d8b 63 }
13548fdf
RGS
64elsif ($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;
67
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;
3d1a2ec4
GS
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
GS
91 $i++;
92 }
93
94 my (@result,%leftover);
95 $#result = $#$order; # preextend
96 while (@param) {
6b4ac661 97 my $key = lc(shift(@param));
3d1a2ec4
GS
98 $key =~ s/^\-//;
99 if (exists $pos{$key}) {
100 $result[$pos{$key}] = shift(@param);
101 } else {
102 $leftover{$key} = shift(@param);
103 }
104 }
105
29ddc2a4 106 push (@result,make_attributes(\%leftover,defined $CGI::Q ? $CGI::Q->{escape} : 1)) if %leftover;
3d1a2ec4
GS
107 @result;
108}
109
110sub make_attributes {
111 my $attr = shift;
112 return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
29ddc2a4 113 my $escape = shift || 0;
3d1a2ec4
GS
114 my(@att);
115 foreach (keys %{$attr}) {
116 my($key) = $_;
117 $key=~s/^\-//; # get rid of initial - if present
69c89ae7
JH
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
GS
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
JH
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
GS
139 $toencode;
140}
141
13548fdf 142sub utf8_chr {
69c89ae7 143 my $c = shift(@_);
29ddc2a4 144 return chr($c) if $] >= 5.006;
69c89ae7
JH
145
146 if ($c < 0x80) {
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",
152 0xe0 | ($c >> 12),
153 0x80 | (($c >> 6) & 0x3f),
154 0x80 | ( $c & 0x3f));
155 } elsif ($c < 0x200000) {
156 return sprintf("%c%c%c%c",
157 0xf0 | ($c >> 18),
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",
163 0xf8 | ($c >> 24),
164 0x80 | (($c >> 18) & 0x3f),
165 0x80 | (($c >> 12) & 0x3f),
166 0x80 | (($c >> 6) & 0x3f),
167 0x80 | ( $c & 0x3f));
168
169 } elsif ($c < 0x80000000) {
170 return sprintf("%c%c%c%c%c%c",
cff99809 171 0xfc | ($c >> 30),
69c89ae7
JH
172 0x80 | (($c >> 24) & 0x3f),
173 0x80 | (($c >> 18) & 0x3f),
174 0x80 | (($c >> 12) & 0x3f),
175 0x80 | (($c >> 6) & 0x3f),
176 0x80 | ( $c & 0x3f));
177 } else {
13548fdf 178 return utf8_chr(0xfffd);
69c89ae7
JH
179 }
180}
181
3d1a2ec4
GS
182# unescape URL-encoded data
183sub unescape {
29ddc2a4 184 shift() if @_ > 0 and (ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
3d1a2ec4
GS
185 my $todecode = shift;
186 return undef unless defined($todecode);
187 $todecode =~ tr/+/ /; # pluses become spaces
ba056755 188 $EBCDIC = "\t" ne "\011";
3d1a2ec4
GS
189 if ($EBCDIC) {
190 $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
191 } else {
69c89ae7
JH
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;
3d1a2ec4
GS
194 }
195 return $todecode;
196}
197
198# URL-encode data
199sub escape {
ac734d8b 200 shift() if @_ > 1 and ( ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
3d1a2ec4
GS
201 my $toencode = shift;
202 return undef unless defined($toencode);
1651fc44
ML
203 # we enforce UTF-8 encoding for URLs for no good reason except UTF-8 being the future
204 utf8::encode $toencode;
92dffb52 205 if ($EBCDIC) {
8869a4b7 206 $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg;
92dffb52 207 } else {
8869a4b7 208 $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",ord($1))/eg;
92dffb52 209 }
3d1a2ec4
GS
210 return $toencode;
211}
212
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.
216sub expires {
217 my($time,$format) = @_;
218 $format ||= 'http';
219
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/;
222
223 # pass through preformatted dates for the sake of expire_calc()
224 $time = expire_calc($time);
225 return $time unless $time =~ /^\d+$/;
226
227 # make HTTP/cookie date string from GMT'ed time
228 # (cookies use '-' as date separator, HTTP uses ' ')
229 my($sc) = ' ';
230 $sc = '-' if $format eq "cookie";
231 my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
232 $year += 1900;
233 return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
234 $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
235}
236
237# This internal routine creates an expires time exactly some number of
238# hours from the current time. It incorporates modifications from
239# Mark Fisher.
240sub expire_calc {
241 my($time) = @_;
242 my(%mult) = ('s'=>1,
243 'm'=>60,
244 'h'=>60*60,
245 'd'=>60*60*24,
246 'M'=>60*60*24*30,
247 'y'=>60*60*24*365);
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
253 # "+1d" -- in 1 day
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
259 my($offset);
260 if (!$time || (lc($time) eq 'now')) {
8869a4b7 261 $offset = 0;
3d1a2ec4 262 } elsif ($time=~/^\d+/) {
8869a4b7
SP
263 return $time;
264 } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([smhdMy])/) {
265 $offset = ($mult{$2} || 1)*$1;
3d1a2ec4 266 } else {
8869a4b7 267 return $time;
3d1a2ec4
GS
268 }
269 return (time+$offset);
270}
271
2ed511ec
RGS
272sub ebcdic2ascii {
273 my $data = shift;
274 $data =~ s/(.)/chr $E2A[ord($1)]/ge;
275 $data;
276}
277
278sub ascii2ebcdic {
279 my $data = shift;
280 $data =~ s/(.)/chr $A2E[ord($1)]/ge;
281 $data;
282}
283
3d1a2ec4 2841;
ba056755
JH
285
286__END__
287
288=head1 NAME
289
290CGI::Util - Internal utilities used by CGI module
291
292=head1 SYNOPSIS
293
294none
295
296=head1 DESCRIPTION
297
298no public subroutines
299
300=head1 AUTHOR INFORMATION
301
302Copyright 1995-1998, Lincoln D. Stein. All rights reserved.
303
304This library is free software; you can redistribute it and/or modify
305it under the same terms as Perl itself.
306
307Address bug reports and comments to: lstein@cshl.org. When sending
308bug reports, please provide the version of CGI.pm, the version of
309Perl, the name and version of your Web server, and the name and
310version of the operating system you are using. If the problem is even
311remotely browser dependent, please provide information about the
312affected browers as well.
313
314=head1 SEE ALSO
315
316L<CGI>
317
318=cut