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 = 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: lstein@cshl.org.  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