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 rearrange_header 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 rearrangement if:
  74 # the first parameter begins with a -
  75
  76 sub rearrange {
  77     my ($order,@param) = @_;
  78     my ($result, $leftover) = _rearrange_params( $order, @param );
  79     push @$result, make_attributes( $leftover, defined $CGI::Q ? $CGI::Q->{escape} : 1 )
  80         if keys %$leftover;
  81     @$result;
  82 }
  83
  84 sub rearrange_header {
  85     my ($order,@param) = @_;
  86
  87     my ($result,$leftover) = _rearrange_params( $order, @param );
  88     push @$result, make_attributes( $leftover, 0, 1 ) if keys %$leftover;
  89
  90     @$result;
  91 }
  92
  93 sub _rearrange_params {
  94     my($order,@param) = @_;
  95     return [] unless @param;
  96
  97     if (ref($param[0]) eq 'HASH') {
  98         @param = %{$param[0]};
  99     } else {
 100         return \@param
 101             unless (defined($param[0]) && substr($param[0],0,1) eq '-');
 102     }
 103
 104     # map parameters into positional indices
 105     my ($i,%pos);
 106     $i = 0;
 107     foreach (@$order) {
 108         foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{lc($_)} = $i; }
 109         $i++;
 110     }
 111
 112     my (@result,%leftover);
 113     $#result = $#$order;  # preextend
 114     while (@param) {
 115         my $key = lc(shift(@param));
 116         $key =~ s/^\-//;
 117         if (exists $pos{$key}) {
 118             $result[$pos{$key}] = shift(@param);
 119         } else {
 120             $leftover{$key} = shift(@param);
 121         }
 122     }
 123
 124     return \@result, \%leftover;
 125 }
 126
 127 sub make_attributes {
 128     my $attr = shift;
 129     return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
 130     my $escape =  shift || 0;
 131     my $do_not_quote = shift;
 132
 133     my $quote = $do_not_quote ? '' : '"';
 134
 135     my(@att);
 136     foreach (keys %{$attr}) {
 137         my($key) = $_;
 138         $key=~s/^\-//;     # get rid of initial - if present
 139
 140         # old way: breaks EBCDIC!
 141         # $key=~tr/A-Z_/a-z-/; # parameters are lower case, use dashes
 142
 143         ($key="\L$key") =~ tr/_/-/; # parameters are lower case, use dashes
 144
 145         my $value = $escape ? simple_escape($attr->{$_}) : $attr->{$_};
 146         push(@att,defined($attr->{$_}) ? qq/$key=$quote$value$quote/ : qq/$key/);
 147     }
 148     return @att;
 149 }
 150
 151 sub simple_escape {
 152   return unless defined(my $toencode = shift);
 153   $toencode =~ s{&}{&amp;}gso;
 154   $toencode =~ s{<}{&lt;}gso;
 155   $toencode =~ s{>}{&gt;}gso;
 156   $toencode =~ s{\"}{&quot;}gso;
 157 # Doesn't work.  Can't work.  forget it.
 158 #  $toencode =~ s{\x8b}{&#139;}gso;
 159 #  $toencode =~ s{\x9b}{&#155;}gso;
 160   $toencode;
 161 }
 162
 163 sub utf8_chr {
 164         my $c = shift(@_);
 165         if ($] >= 5.006){
 166             require utf8;
 167             my $u = chr($c);
 168             utf8::encode($u); # drop utf8 flag
 169             return $u;
 170         }
 171         if ($c < 0x80) {
 172                 return sprintf("%c", $c);
 173         } elsif ($c < 0x800) {
 174                 return sprintf("%c%c", 0xc0 | ($c >> 6), 0x80 | ($c & 0x3f));
 175         } elsif ($c < 0x10000) {
 176                 return sprintf("%c%c%c",
 177                                            0xe0 |  ($c >> 12),
 178                                            0x80 | (($c >>  6) & 0x3f),
 179                                            0x80 | ( $c          & 0x3f));
 180         } elsif ($c < 0x200000) {
 181                 return sprintf("%c%c%c%c",
 182                                            0xf0 |  ($c >> 18),
 183                                            0x80 | (($c >> 12) & 0x3f),
 184                                            0x80 | (($c >>  6) & 0x3f),
 185                                            0x80 | ( $c          & 0x3f));
 186         } elsif ($c < 0x4000000) {
 187                 return sprintf("%c%c%c%c%c",
 188                                            0xf8 |  ($c >> 24),
 189                                            0x80 | (($c >> 18) & 0x3f),
 190                                            0x80 | (($c >> 12) & 0x3f),
 191                                            0x80 | (($c >>  6) & 0x3f),
 192                                            0x80 | ( $c          & 0x3f));
 193
 194         } elsif ($c < 0x80000000) {
 195                 return sprintf("%c%c%c%c%c%c",
 196                                            0xfc |  ($c >> 30),
 197                                            0x80 | (($c >> 24) & 0x3f),
 198                                            0x80 | (($c >> 18) & 0x3f),
 199                                            0x80 | (($c >> 12) & 0x3f),
 200                                            0x80 | (($c >> 6)  & 0x3f),
 201                                            0x80 | ( $c          & 0x3f));
 202         } else {
 203                 return utf8_chr(0xfffd);
 204         }
 205 }
 206
 207 # unescape URL-encoded data
 208 sub unescape {
 209   shift() if @_ > 0 and (ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
 210   my $todecode = shift;
 211   return undef unless defined($todecode);
 212   $todecode =~ tr/+/ /;       # pluses become spaces
 213     if ($EBCDIC) {
 214       $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
 215     } else {
 216         # handle surrogate pairs first -- dankogai
 217         $todecode =~ s{
 218                         %u([Dd][89a-bA-B][0-9a-fA-F]{2}) # hi
 219                         %u([Dd][c-fC-F][0-9a-fA-F]{2})   # lo
 220                       }{
 221                           utf8_chr(
 222                                    0x10000
 223                                    + (hex($1) - 0xD800) * 0x400
 224                                    + (hex($2) - 0xDC00)
 225                                   )
 226                       }gex;
 227       $todecode =~ s/%(?:([0-9a-fA-F]{2})|u([0-9a-fA-F]{4}))/
 228         defined($1)? chr hex($1) : utf8_chr(hex($2))/ge;
 229     }
 230   return $todecode;
 231 }
 232
 233 # URL-encode data
 234 #
 235 # We cannot use the %u escapes, they were rejected by W3C, so the official
 236 # way is %XX-escaped utf-8 encoding.
 237 # Naturally, Unicode strings have to be converted to their utf-8 byte
 238 # representation.  (No action is required on 5.6.)
 239 # Byte strings were traditionally used directly as a sequence of octets.
 240 # This worked if they actually represented binary data (i.e. in CGI::Compress).
 241 # This also worked if these byte strings were actually utf-8 encoded; e.g.,
 242 # when the source file used utf-8 without the apropriate "use utf8;".
 243 # This fails if the byte string is actually a Latin 1 encoded string, but it
 244 # was always so and cannot be fixed without breaking the binary data case.
 245 # -- Stepan Kasal <skasal@redhat.com>
 246 #
 247 sub escape {
 248   shift() if @_ > 1 and ( ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
 249   my $toencode = shift;
 250   return undef unless defined($toencode);
 251   utf8::encode($toencode) if ($] > 5.007 && utf8::is_utf8($toencode));
 252     if ($EBCDIC) {
 253       $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg;
 254     } else {
 255       $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",ord($1))/eg;
 256     }
 257   return $toencode;
 258 }
 259
 260 # This internal routine creates date strings suitable for use in
 261 # cookies and HTTP headers.  (They differ, unfortunately.)
 262 # Thanks to Mark Fisher for this.
 263 sub expires {
 264     my($time,$format) = @_;
 265     $format ||= 'http';
 266
 267     my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
 268     my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
 269
 270     # pass through preformatted dates for the sake of expire_calc()
 271     $time = expire_calc($time);
 272     return $time unless $time =~ /^\d+$/;
 273
 274     # make HTTP/cookie date string from GMT'ed time
 275     # (cookies use '-' as date separator, HTTP uses ' ')
 276     my($sc) = ' ';
 277     $sc = '-' if $format eq "cookie";
 278     my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
 279     $year += 1900;
 280     return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
 281                    $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
 282 }
 283
 284 # This internal routine creates an expires time exactly some number of
 285 # hours from the current time.  It incorporates modifications from
 286 # Mark Fisher.
 287 sub expire_calc {
 288     my($time) = @_;
 289     my(%mult) = ('s'=>1,
 290                  'm'=>60,
 291                  'h'=>60*60,
 292                  'd'=>60*60*24,
 293                  'M'=>60*60*24*30,
 294                  'y'=>60*60*24*365);
 295     # format for time can be in any of the forms...
 296     # "now" -- expire immediately
 297     # "+180s" -- in 180 seconds
 298     # "+2m" -- in 2 minutes
 299     # "+12h" -- in 12 hours
 300     # "+1d"  -- in 1 day
 301     # "+3M"  -- in 3 months
 302     # "+2y"  -- in 2 years
 303     # "-3m"  -- 3 minutes ago(!)
 304     # If you don't supply one of these forms, we assume you are
 305     # specifying the date yourself
 306     my($offset);
 307     if (!$time || (lc($time) eq 'now')) {
 308       $offset = 0;
 309     } elsif ($time=~/^\d+/) {
 310       return $time;
 311     } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([smhdMy])/) {
 312       $offset = ($mult{$2} || 1)*$1;
 313     } else {
 314       return $time;
 315     }
 316     return (time+$offset);
 317 }
 318
 319 sub ebcdic2ascii {
 320   my $data = shift;
 321   $data =~ s/(.)/chr $E2A[ord($1)]/ge;
 322   $data;
 323 }
 324
 325 sub ascii2ebcdic {
 326   my $data = shift;
 327   $data =~ s/(.)/chr $A2E[ord($1)]/ge;
 328   $data;
 329 }
 330
 331 1;
 332
 333 __END__
 334
 335 =head1 NAME
 336
 337 CGI::Util - Internal utilities used by CGI module
 338
 339 =head1 SYNOPSIS
 340
 341 none
 342
 343 =head1 DESCRIPTION
 344
 345 no public subroutines
 346
 347 =head1 AUTHOR INFORMATION
 348
 349 Copyright 1995-1998, Lincoln D. Stein.  All rights reserved.
 350
 351 This library is free software; you can redistribute it and/or modify
 352 it under the same terms as Perl itself.
 353
 354 Address bug reports and comments to: lstein@cshl.org.  When sending
 355 bug reports, please provide the version of CGI.pm, the version of
 356 Perl, the name and version of your Web server, and the name and
 357 version of the operating system you are using.  If the problem is even
 358 remotely browser dependent, please provide information about the
 359 affected browers as well.
 360
 361 =head1 SEE ALSO
 362
 363 L<CGI>
 364
 365 =cut