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{&}{&amp;}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   # 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.
 217 sub 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.
 241 sub 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
 273 sub ebcdic2ascii {
 274   my $data = shift;
 275   $data =~ s/(.)/chr $E2A[ord($1)]/ge;
 276   $data;
 277 }
 278
 279 sub ascii2ebcdic {
 280   my $data = shift;
 281   $data =~ s/(.)/chr $A2E[ord($1)]/ge;
 282   $data;
 283 }
 284
 285 1;
 286
 287 __END__
 288
 289 =head1 NAME
 290
 291 CGI::Util - Internal utilities used by CGI module
 292
 293 =head1 SYNOPSIS
 294
 295 none
 296
 297 =head1 DESCRIPTION
 298
 299 no public subroutines
 300
 301 =head1 AUTHOR INFORMATION
 302
 303 Copyright 1995-1998, Lincoln D. Stein.  All rights reserved.
 304
 305 This library is free software; you can redistribute it and/or modify
 306 it under the same terms as Perl itself.
 307
 308 Address bug reports and comments to: lstein@cshl.org.  When sending
 309 bug reports, please provide the version of CGI.pm, the version of
 310 Perl, the name and version of your Web server, and the name and
 311 version of the operating system you are using.  If the problem is even
 312 remotely browser dependent, please provide information about the
 313 affected browers as well.
 314
 315 =head1 SEE ALSO
 316
 317 L<CGI>
 318
 319 =cut