lib/perl5/5.6.1/CGI/Util.pm

   1 package CGI::Util;
   2
   3 use strict;
   4 use vars '$VERSION','@EXPORT_OK','@ISA','$EBCDIC','@A2E','@E2A';
   5 require Exporter;
   6 @ISA = qw(Exporter);
   7 @EXPORT_OK = qw(rearrange make_attributes unescape escape expires);
   8
   9 $VERSION = '1.1';
  10
  11 $EBCDIC = "\t" ne "\011";
  12 if ($EBCDIC) {
  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 if (ord('^') == 106) { # as in the BS2000 posix-bc coded character set
  51     $A2E[91] = 187;   $A2E[92] = 188;  $A2E[94] = 106;  $A2E[96] = 74;
  52     $A2E[123] = 251;  $A2E[125] = 253; $A2E[126] = 255; $A2E[159] = 95;
  53     $A2E[162] = 176;  $A2E[166] = 208; $A2E[168] = 121; $A2E[172] = 186;
  54     $A2E[175] = 161;  $A2E[217] = 224; $A2E[219] = 221; $A2E[221] = 173;
  55     $A2E[249] = 192;
  56
  57     $E2A[74] = 96;   $E2A[95] = 159;  $E2A[106] = 94;  $E2A[121] = 168;
  58     $E2A[161] = 175; $E2A[173] = 221; $E2A[176] = 162; $E2A[186] = 172;
  59     $E2A[187] = 91;  $E2A[188] = 92;  $E2A[192] = 249; $E2A[208] = 166;
  60     $E2A[221] = 219; $E2A[224] = 217; $E2A[251] = 123; $E2A[253] = 125;
  61     $E2A[255] = 126;
  62 }
  63 elsif (ord('^') == 176) { # as in codepage 037 on os400
  64     $A2E[10] = 37;  $A2E[91] = 186;  $A2E[93] = 187; $A2E[94] = 176;
  65     $A2E[133] = 21; $A2E[168] = 189; $A2E[172] = 95; $A2E[221] = 173;
  66
  67     $E2A[21] = 133; $E2A[37] = 10;  $E2A[95] = 172; $E2A[173] = 221;
  68     $E2A[176] = 94; $E2A[186] = 91; $E2A[187] = 93; $E2A[189] = 168;
  69 }
  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,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         $key=~tr/A-Z_/a-z-/; # parameters are lower case, use dashes
 119         my $value = $escape ? simple_escape($attr->{$_}) : $attr->{$_};
 120         push(@att,defined($attr->{$_}) ? qq/$key="$value"/ : qq/$key/);
 121     }
 122     return @att;
 123 }
 124
 125 sub simple_escape {
 126   return unless defined(my $toencode = shift);
 127   $toencode =~ s{&}{&amp;}gso;
 128   $toencode =~ s{<}{&lt;}gso;
 129   $toencode =~ s{>}{&gt;}gso;
 130   $toencode =~ s{\"}{&quot;}gso;
 131 # Doesn't work.  Can't work.  forget it.
 132 #  $toencode =~ s{\x8b}{&#139;}gso;
 133 #  $toencode =~ s{\x9b}{&#155;}gso;
 134   $toencode;
 135 }
 136
 137 # unescape URL-encoded data
 138 sub unescape {
 139   shift() if ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass);
 140   my $todecode = shift;
 141   return undef unless defined($todecode);
 142   $todecode =~ tr/+/ /;       # pluses become spaces
 143     $EBCDIC = "\t" ne "\011";
 144     if ($EBCDIC) {
 145       $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
 146     } else {
 147       $todecode =~ s/%([0-9a-fA-F]{2})/chr hex($1)/ge;
 148     }
 149   return $todecode;
 150 }
 151
 152 # URL-encode data
 153 sub escape {
 154   shift() if ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass);
 155   my $toencode = shift;
 156   return undef unless defined($toencode);
 157     if ($EBCDIC) {
 158       $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg;
 159     } else {
 160       $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
 161     }
 162   return $toencode;
 163 }
 164
 165 # This internal routine creates date strings suitable for use in
 166 # cookies and HTTP headers.  (They differ, unfortunately.)
 167 # Thanks to Mark Fisher for this.
 168 sub expires {
 169     my($time,$format) = @_;
 170     $format ||= 'http';
 171
 172     my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
 173     my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
 174
 175     # pass through preformatted dates for the sake of expire_calc()
 176     $time = expire_calc($time);
 177     return $time unless $time =~ /^\d+$/;
 178
 179     # make HTTP/cookie date string from GMT'ed time
 180     # (cookies use '-' as date separator, HTTP uses ' ')
 181     my($sc) = ' ';
 182     $sc = '-' if $format eq "cookie";
 183     my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
 184     $year += 1900;
 185     return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
 186                    $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
 187 }
 188
 189 # This internal routine creates an expires time exactly some number of
 190 # hours from the current time.  It incorporates modifications from
 191 # Mark Fisher.
 192 sub expire_calc {
 193     my($time) = @_;
 194     my(%mult) = ('s'=>1,
 195                  'm'=>60,
 196                  'h'=>60*60,
 197                  'd'=>60*60*24,
 198                  'M'=>60*60*24*30,
 199                  'y'=>60*60*24*365);
 200     # format for time can be in any of the forms...
 201     # "now" -- expire immediately
 202     # "+180s" -- in 180 seconds
 203     # "+2m" -- in 2 minutes
 204     # "+12h" -- in 12 hours
 205     # "+1d"  -- in 1 day
 206     # "+3M"  -- in 3 months
 207     # "+2y"  -- in 2 years
 208     # "-3m"  -- 3 minutes ago(!)
 209     # If you don't supply one of these forms, we assume you are
 210     # specifying the date yourself
 211     my($offset);
 212     if (!$time || (lc($time) eq 'now')) {
 213         $offset = 0;
 214     } elsif ($time=~/^\d+/) {
 215         return $time;
 216     } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) {
 217         $offset = ($mult{$2} || 1)*$1;
 218     } else {
 219         return $time;
 220     }
 221     return (time+$offset);
 222 }
 223
 224 1;
 225
 226 __END__
 227
 228 =head1 NAME
 229
 230 CGI::Util - Internal utilities used by CGI module
 231
 232 =head1 SYNOPSIS
 233
 234 none
 235
 236 =head1 DESCRIPTION
 237
 238 no public subroutines
 239
 240 =head1 AUTHOR INFORMATION
 241
 242 Copyright 1995-1998, Lincoln D. Stein.  All rights reserved.
 243
 244 This library is free software; you can redistribute it and/or modify
 245 it under the same terms as Perl itself.
 246
 247 Address bug reports and comments to: lstein@cshl.org.  When sending
 248 bug reports, please provide the version of CGI.pm, the version of
 249 Perl, the name and version of your Web server, and the name and
 250 version of the operating system you are using.  If the problem is even
 251 remotely browser dependent, please provide information about the
 252 affected browers as well.
 253
 254 =head1 SEE ALSO
 255
 256 L<CGI>
 257
 258 =cut