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