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{<}{<}gso; 134 $toencode =~ s{>}{>}gso; 135 $toencode =~ s{\"}{"}gso; 136# Doesn't work. Can't work. forget it. 137# $toencode =~ s{\x8b}{‹}gso; 138# $toencode =~ s{\x9b}{›}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 = eval { pack("C*", unpack("U0C*", $toencode))} || pack("C*", unpack("C*", $toencode)); 205 $toencode = eval { pack("U*", unpack("U0C*", $toencode))} || pack("C*", unpack("C*", $toencode)); 206 if ($EBCDIC) { 207 $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg; 208 } else { 209 $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",ord($1))/eg; 210 } 211 return $toencode; 212} 213 214# This internal routine creates date strings suitable for use in 215# cookies and HTTP headers. (They differ, unfortunately.) 216# Thanks to Mark Fisher for this. 217sub expires { 218 my($time,$format) = @_; 219 $format ||= 'http'; 220 221 my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/; 222 my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/; 223 224 # pass through preformatted dates for the sake of expire_calc() 225 $time = expire_calc($time); 226 return $time unless $time =~ /^\d+$/; 227 228 # make HTTP/cookie date string from GMT'ed time 229 # (cookies use '-' as date separator, HTTP uses ' ') 230 my($sc) = ' '; 231 $sc = '-' if $format eq "cookie"; 232 my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time); 233 $year += 1900; 234 return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT", 235 $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec); 236} 237 238# This internal routine creates an expires time exactly some number of 239# hours from the current time. It incorporates modifications from 240# Mark Fisher. 241sub expire_calc { 242 my($time) = @_; 243 my(%mult) = ('s'=>1, 244 'm'=>60, 245 'h'=>60*60, 246 'd'=>60*60*24, 247 'M'=>60*60*24*30, 248 'y'=>60*60*24*365); 249 # format for time can be in any of the forms... 250 # "now" -- expire immediately 251 # "+180s" -- in 180 seconds 252 # "+2m" -- in 2 minutes 253 # "+12h" -- in 12 hours 254 # "+1d" -- in 1 day 255 # "+3M" -- in 3 months 256 # "+2y" -- in 2 years 257 # "-3m" -- 3 minutes ago(!) 258 # If you don't supply one of these forms, we assume you are 259 # specifying the date yourself 260 my($offset); 261 if (!$time || (lc($time) eq 'now')) { 262 $offset = 0; 263 } elsif ($time=~/^\d+/) { 264 return $time; 265 } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([smhdMy])/) { 266 $offset = ($mult{$2} || 1)*$1; 267 } else { 268 return $time; 269 } 270 return (time+$offset); 271} 272 273sub ebcdic2ascii { 274 my $data = shift; 275 $data =~ s/(.)/chr $E2A[ord($1)]/ge; 276 $data; 277} 278 279sub ascii2ebcdic { 280 my $data = shift; 281 $data =~ s/(.)/chr $A2E[ord($1)]/ge; 282 $data; 283} 284 2851; 286 287__END__ 288 289=head1 NAME 290 291CGI::Util - Internal utilities used by CGI module 292 293=head1 SYNOPSIS 294 295none 296 297=head1 DESCRIPTION 298 299no public subroutines 300 301=head1 AUTHOR INFORMATION 302 303Copyright 1995-1998, Lincoln D. Stein. All rights reserved. 304 305This library is free software; you can redistribute it and/or modify 306it under the same terms as Perl itself. 307 308Address bug reports and comments to: lstein@cshl.org. When sending 309bug reports, please provide the version of CGI.pm, the version of 310Perl, the name and version of your Web server, and the name and 311version of the operating system you are using. If the problem is even 312remotely browser dependent, please provide information about the 313affected browers as well. 314 315=head1 SEE ALSO 316 317L<CGI> 318 319=cut 320