[Summary view] [Print] [Text view]

   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{&}{&}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("U0C*", $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*))([smhdMy])/) {
 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