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_01';
  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         if ($] >= 5.006){
 145             require utf8;
 146             my $u = chr($c);
 147             utf8::encode($u); # drop utf8 flag
 148             return $u;
 149         }
 150         if ($c < 0x80) {
 151                 return sprintf("%c", $c);
 152         } elsif ($c < 0x800) {
 153                 return sprintf("%c%c", 0xc0 | ($c >> 6), 0x80 | ($c & 0x3f));
 154         } elsif ($c < 0x10000) {
 155                 return sprintf("%c%c%c",
 156                                            0xe0 |  ($c >> 12),
 157                                            0x80 | (($c >>  6) & 0x3f),
 158                                            0x80 | ( $c          & 0x3f));
 159         } elsif ($c < 0x200000) {
 160                 return sprintf("%c%c%c%c",
 161                                            0xf0 |  ($c >> 18),
 162                                            0x80 | (($c >> 12) & 0x3f),
 163                                            0x80 | (($c >>  6) & 0x3f),
 164                                            0x80 | ( $c          & 0x3f));
 165         } elsif ($c < 0x4000000) {
 166                 return sprintf("%c%c%c%c%c",
 167                                            0xf8 |  ($c >> 24),
 168                                            0x80 | (($c >> 18) & 0x3f),
 169                                            0x80 | (($c >> 12) & 0x3f),
 170                                            0x80 | (($c >>  6) & 0x3f),
 171                                            0x80 | ( $c          & 0x3f));
 172
 173         } elsif ($c < 0x80000000) {
 174                 return sprintf("%c%c%c%c%c%c",
 175                                            0xfc |  ($c >> 30),
 176                                            0x80 | (($c >> 24) & 0x3f),
 177                                            0x80 | (($c >> 18) & 0x3f),
 178                                            0x80 | (($c >> 12) & 0x3f),
 179                                            0x80 | (($c >> 6)  & 0x3f),
 180                                            0x80 | ( $c          & 0x3f));
 181         } else {
 182                 return utf8_chr(0xfffd);
 183         }
 184 }
 185
 186 # unescape URL-encoded data
 187 sub unescape {
 188   shift() if @_ > 0 and (ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
 189   my $todecode = shift;
 190   return undef unless defined($todecode);
 191   $todecode =~ tr/+/ /;       # pluses become spaces
 192     $EBCDIC = "\t" ne "\011";
 193     if ($EBCDIC) {
 194       $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
 195     } else {
 196         # handle surrogate pairs first -- dankogai
 197         $todecode =~ s{
 198                         %u([Dd][89a-bA-B][0-9a-fA-F]{2}) # hi
 199                         %u([Dd][c-fC-F][0-9a-fA-F]{2})   # lo
 200                       }{
 201                           utf8_chr(
 202                                    0x10000
 203                                    + (hex($1) - 0xD800) * 0x400
 204                                    + (hex($2) - 0xDC00)
 205                                   )
 206                       }gex;
 207       $todecode =~ s/%(?:([0-9a-fA-F]{2})|u([0-9a-fA-F]{4}))/
 208         defined($1)? chr hex($1) : utf8_chr(hex($2))/ge;
 209     }
 210   return $todecode;
 211 }
 212
 213 # URL-encode data
 214 sub escape {
 215   shift() if @_ > 1 and ( ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
 216   my $toencode = shift;
 217   return undef unless defined($toencode);
 218   $toencode = eval { pack("C*", unpack("U0C*", $toencode))} || pack("C*", unpack("C*", $toencode));
 219
 220   # force bytes while preserving backward compatibility -- dankogai
 221   # but commented out because it was breaking CGI::Compress -- lstein
 222   # $toencode = eval { pack("U*", unpack("U0C*", $toencode))} || pack("C*", unpack("C*", $toencode));
 223
 224     if ($EBCDIC) {
 225       $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg;
 226     } else {
 227       $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",ord($1))/eg;
 228     }
 229   return $toencode;
 230 }
 231
 232 # This internal routine creates date strings suitable for use in
 233 # cookies and HTTP headers.  (They differ, unfortunately.)
 234 # Thanks to Mark Fisher for this.
 235 sub expires {
 236     my($time,$format) = @_;
 237     $format ||= 'http';
 238
 239     my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
 240     my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
 241
 242     # pass through preformatted dates for the sake of expire_calc()
 243     $time = expire_calc($time);
 244     return $time unless $time =~ /^\d+$/;
 245
 246     # make HTTP/cookie date string from GMT'ed time
 247     # (cookies use '-' as date separator, HTTP uses ' ')
 248     my($sc) = ' ';
 249     $sc = '-' if $format eq "cookie";
 250     my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
 251     $year += 1900;
 252     return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
 253                    $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
 254 }
 255
 256 # This internal routine creates an expires time exactly some number of
 257 # hours from the current time.  It incorporates modifications from
 258 # Mark Fisher.
 259 sub expire_calc {
 260     my($time) = @_;
 261     my(%mult) = ('s'=>1,
 262                  'm'=>60,
 263                  'h'=>60*60,
 264                  'd'=>60*60*24,
 265                  'M'=>60*60*24*30,
 266                  'y'=>60*60*24*365);
 267     # format for time can be in any of the forms...
 268     # "now" -- expire immediately
 269     # "+180s" -- in 180 seconds
 270     # "+2m" -- in 2 minutes
 271     # "+12h" -- in 12 hours
 272     # "+1d"  -- in 1 day
 273     # "+3M"  -- in 3 months
 274     # "+2y"  -- in 2 years
 275     # "-3m"  -- 3 minutes ago(!)
 276     # If you don't supply one of these forms, we assume you are
 277     # specifying the date yourself
 278     my($offset);
 279     if (!$time || (lc($time) eq 'now')) {
 280       $offset = 0;
 281     } elsif ($time=~/^\d+/) {
 282       return $time;
 283     } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([smhdMy])/) {
 284       $offset = ($mult{$2} || 1)*$1;
 285     } else {
 286       return $time;
 287     }
 288     return (time+$offset);
 289 }
 290
 291 sub ebcdic2ascii {
 292   my $data = shift;
 293   $data =~ s/(.)/chr $E2A[ord($1)]/ge;
 294   $data;
 295 }
 296
 297 sub ascii2ebcdic {
 298   my $data = shift;
 299   $data =~ s/(.)/chr $A2E[ord($1)]/ge;
 300   $data;
 301 }
 302
 303 1;
 304
 305 __END__
 306
 307 =head1 NAME
 308
 309 CGI::Util - Internal utilities used by CGI module
 310
 311 =head1 SYNOPSIS
 312
 313 none
 314
 315 =head1 DESCRIPTION
 316
 317 no public subroutines
 318
 319 =head1 AUTHOR INFORMATION
 320
 321 Copyright 1995-1998, Lincoln D. Stein.  All rights reserved.
 322
 323 This library is free software; you can redistribute it and/or modify
 324 it under the same terms as Perl itself.
 325
 326 Address bug reports and comments to: lstein@cshl.org.  When sending
 327 bug reports, please provide the version of CGI.pm, the version of
 328 Perl, the name and version of your Web server, and the name and
 329 version of the operating system you are using.  If the problem is even
 330 remotely browser dependent, please provide information about the
 331 affected browers as well.
 332
 333 =head1 SEE ALSO
 334
 335 L<CGI>
 336
 337 =cut