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