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
1 package CGI::Util;
2
3 use strict;
4 use vars qw($VERSION @EXPORT_OK @ISA $EBCDIC @A2E @E2A);
5 require Exporter;
6 @ISA = qw(Exporter);
7 @EXPORT_OK = qw(rearrange make_attributes unescape escape 
8                 expires ebcdic2ascii ascii2ebcdic);
9
10 $VERSION = '1.5';
11
12 $EBCDIC = "\t" ne "\011";
13 # (ord('^') == 95) for codepage 1047 as on os390, vmesa
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,
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          );
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,
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          );
50
51 if ($EBCDIC && 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;
56      $A2E[249] = 192;
57
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;
63    }
64 elsif ($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;
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 -
75 sub 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) {
90         foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{lc($_)} = $i; }
91         $i++;
92     }
93
94     my (@result,%leftover);
95     $#result = $#$order;  # preextend
96     while (@param) {
97         my $key = lc(shift(@param));
98         $key =~ s/^\-//;
99         if (exists $pos{$key}) {
100             $result[$pos{$key}] = shift(@param);
101         } else {
102             $leftover{$key} = shift(@param);
103         }
104     }
105
106     push (@result,make_attributes(\%leftover,defined $CGI::Q ? $CGI::Q->{escape} : 1)) if %leftover;
107     @result;
108 }
109
110 sub 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
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
124         my $value = $escape ? simple_escape($attr->{$_}) : $attr->{$_};
125         push(@att,defined($attr->{$_}) ? qq/$key="$value"/ : qq/$key/);
126     }
127     return @att;
128 }
129
130 sub simple_escape {
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;
139   $toencode;
140 }
141
142 sub utf8_chr {
143         my $c = shift(@_);
144         return chr($c) if $] >= 5.006;
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",
171                                            0xfc |  ($c >> 30),
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 {
178                 return utf8_chr(0xfffd);
179         }
180 }
181
182 # unescape URL-encoded data
183 sub unescape {
184   shift() if @_ > 0 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";
189     if ($EBCDIC) {
190       $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
191     } else {
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;
194     }
195   return $todecode;
196 }
197
198 # URL-encode data
199 sub escape {
200   shift() if @_ > 1 and ( ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
201   my $toencode = shift;
202   return undef unless defined($toencode);
203   # we enforce UTF-8 encoding for URLs for no good reason except UTF-8 being the future
204   utf8::encode $toencode;
205     if ($EBCDIC) {
206       $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg;
207     } else {
208       $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",ord($1))/eg;
209     }
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.
216 sub 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.
240 sub 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')) {
261       $offset = 0;
262     } elsif ($time=~/^\d+/) {
263       return $time;
264     } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([smhdMy])/) {
265       $offset = ($mult{$2} || 1)*$1;
266     } else {
267       return $time;
268     }
269     return (time+$offset);
270 }
271
272 sub ebcdic2ascii {
273   my $data = shift;
274   $data =~ s/(.)/chr $E2A[ord($1)]/ge;
275   $data;
276 }
277
278 sub ascii2ebcdic {
279   my $data = shift;
280   $data =~ s/(.)/chr $A2E[ord($1)]/ge;
281   $data;
282 }
283
284 1;
285
286 __END__
287
288 =head1 NAME
289
290 CGI::Util - Internal utilities used by CGI module
291
292 =head1 SYNOPSIS
293
294 none
295
296 =head1 DESCRIPTION
297
298 no public subroutines
299
300 =head1 AUTHOR INFORMATION
301
302 Copyright 1995-1998, Lincoln D. Stein.  All rights reserved.  
303
304 This library is free software; you can redistribute it and/or modify
305 it under the same terms as Perl itself.
306
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.
313
314 =head1 SEE ALSO
315
316 L<CGI>
317
318 =cut