lib/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     if ($EBCDIC) {
 144       $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
 145     } else {
 146       $todecode =~ s/%([0-9a-fA-F]{2})/chr hex($1)/ge;
 147     }
 148   return $todecode;
 149 }
 150
 151 # URL-encode data
 152 sub escape {
 153   shift() if ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass);
 154   my $toencode = shift;
 155   return undef unless defined($toencode);
 156     if ($EBCDIC) {
 157       $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg;
 158     } else {
 159       $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
 160     }
 161   return $toencode;
 162 }
 163
 164 # This internal routine creates date strings suitable for use in
 165 # cookies and HTTP headers.  (They differ, unfortunately.)
 166 # Thanks to Mark Fisher for this.
 167 sub expires {
 168     my($time,$format) = @_;
 169     $format ||= 'http';
 170
 171     my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
 172     my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
 173
 174     # pass through preformatted dates for the sake of expire_calc()
 175     $time = expire_calc($time);
 176     return $time unless $time =~ /^\d+$/;
 177
 178     # make HTTP/cookie date string from GMT'ed time
 179     # (cookies use '-' as date separator, HTTP uses ' ')
 180     my($sc) = ' ';
 181     $sc = '-' if $format eq "cookie";
 182     my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
 183     $year += 1900;
 184     return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
 185                    $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
 186 }
 187
 188 # This internal routine creates an expires time exactly some number of
 189 # hours from the current time.  It incorporates modifications from
 190 # Mark Fisher.
 191 sub expire_calc {
 192     my($time) = @_;
 193     my(%mult) = ('s'=>1,
 194                  'm'=>60,
 195                  'h'=>60*60,
 196                  'd'=>60*60*24,
 197                  'M'=>60*60*24*30,
 198                  'y'=>60*60*24*365);
 199     # format for time can be in any of the forms...
 200     # "now" -- expire immediately
 201     # "+180s" -- in 180 seconds
 202     # "+2m" -- in 2 minutes
 203     # "+12h" -- in 12 hours
 204     # "+1d"  -- in 1 day
 205     # "+3M"  -- in 3 months
 206     # "+2y"  -- in 2 years
 207     # "-3m"  -- 3 minutes ago(!)
 208     # If you don't supply one of these forms, we assume you are
 209     # specifying the date yourself
 210     my($offset);
 211     if (!$time || (lc($time) eq 'now')) {
 212         $offset = 0;
 213     } elsif ($time=~/^\d+/) {
 214         return $time;
 215     } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) {
 216         $offset = ($mult{$2} || 1)*$1;
 217     } else {
 218         return $time;
 219     }
 220     return (time+$offset);
 221 }
 222
 223 1;