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