| 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{<}{<}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 |
|
|---|
| 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 | # 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.
|
|---|
| 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*))([mhdMy]?)/) {
|
|---|
| 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: [email protected]. 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
|
|---|
