1package CGI::Util;
2
3use strict;
4use vars qw($VERSION @EXPORT_OK @ISA $EBCDIC @A2E @E2A);
5require 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
51if ($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   }
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;
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) {
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
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
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
130sub 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
142sub 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
183sub 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
199sub 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  # force bytes while preserving backward compatibility -- dankogai
204  $toencode = pack("C*", unpack("C*", $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.
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')) {
261        $offset = 0;
262    } elsif ($time=~/^\d+/) {
263        return $time;
264    } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) {
265        $offset = ($mult{$2} || 1)*$1;
266    } else {
267        return $time;
268    }
269    return (time+$offset);
270}
271
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
2841;
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
319