Re: Copious warnings from Sys::Syslog
[p5sagit/p5-mst-13.2.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 expires);
8
9 $VERSION = '1.3';
10
11 $EBCDIC = "\t" ne "\011";
12 if ($EBCDIC) {
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   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;
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  }
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;
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    }
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,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
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
181 # unescape URL-encoded data
182 sub unescape {
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";
188     if ($EBCDIC) {
189       $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
190     } else {
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;
193     }
194   return $todecode;
195 }
196
197 # URL-encode data
198 sub escape {
199   shift() if @_ > 1 and ( ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
200   my $toencode = shift;
201   return undef unless defined($toencode);
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     }
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.
213 sub 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.
237 sub 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
269 1;
270
271 __END__
272
273 =head1 NAME
274
275 CGI::Util - Internal utilities used by CGI module
276
277 =head1 SYNOPSIS
278
279 none
280
281 =head1 DESCRIPTION
282
283 no public subroutines
284
285 =head1 AUTHOR INFORMATION
286
287 Copyright 1995-1998, Lincoln D. Stein.  All rights reserved.  
288
289 This library is free software; you can redistribute it and/or modify
290 it under the same terms as Perl itself.
291
292 Address bug reports and comments to: lstein@cshl.org.  When sending
293 bug reports, please provide the version of CGI.pm, the version of
294 Perl, the name and version of your Web server, and the name and
295 version of the operating system you are using.  If the problem is even
296 remotely browser dependent, please provide information about the
297 affected browers as well.
298
299 =head1 SEE ALSO
300
301 L<CGI>
302
303 =cut