lib/CGI/Util.pm

   1 package CGI::Util;
   2
   3 use strict;
   4 use vars '$VERSION','@EXPORT_OK','@ISA','$EBCDIC','@A2E';
   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 @A2E = (
  14   0,  1,  2,  3, 55, 45, 46, 47, 22,  5, 21, 11, 12, 13, 14, 15,
  15  16, 17, 18, 19, 60, 61, 50, 38, 24, 25, 63, 39, 28, 29, 30, 31,
  16  64, 90,127,123, 91,108, 80,125, 77, 93, 92, 78,107, 96, 75, 97,
  17 240,241,242,243,244,245,246,247,248,249,122, 94, 76,126,110,111,
  18 124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214,
  19 215,216,217,226,227,228,229,230,231,232,233,173,224,189, 95,109,
  20 121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150,
  21 151,152,153,162,163,164,165,166,167,168,169,192, 79,208,161,  7,
  22  32, 33, 34, 35, 36, 37,  6, 23, 40, 41, 42, 43, 44,  9, 10, 27,
  23  48, 49, 26, 51, 52, 53, 54,  8, 56, 57, 58, 59,  4, 20, 62,255,
  24  65,170, 74,177,159,178,106,181,187,180,154,138,176,202,175,188,
  25 144,143,234,250,190,160,182,179,157,218,155,139,183,184,185,171,
  26 100,101, 98,102, 99,103,158,104,116,113,114,115,120,117,118,119,
  27 172,105,237,238,235,239,236,191,128,253,254,251,252,186,174, 89,
  28  68, 69, 66, 70, 67, 71,156, 72, 84, 81, 82, 83, 88, 85, 86, 87,
  29 140, 73,205,206,203,207,204,225,112,221,222,219,220,141,142,223
  30       );
  31 }
  32
  33 # Smart rearrangement of parameters to allow named parameter
  34 # calling.  We do the rearangement if:
  35 # the first parameter begins with a -
  36 sub rearrange {
  37     my($order,@param) = @_;
  38     return () unless @param;
  39
  40     if (ref($param[0]) eq 'HASH') {
  41         @param = %{$param[0]};
  42     } else {
  43         return @param
  44             unless (defined($param[0]) && substr($param[0],0,1) eq '-');
  45     }
  46
  47     # map parameters into positional indices
  48     my ($i,%pos);
  49     $i = 0;
  50     foreach (@$order) {
  51         foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{lc($_)} = $i; }
  52         $i++;
  53     }
  54
  55     my (@result,%leftover);
  56     $#result = $#$order;  # preextend
  57     while (@param) {
  58         my $key = lc(shift(@param));
  59         $key =~ s/^\-//;
  60         if (exists $pos{$key}) {
  61             $result[$pos{$key}] = shift(@param);
  62         } else {
  63             $leftover{$key} = shift(@param);
  64         }
  65     }
  66
  67     push (@result,make_attributes(\%leftover,1)) if %leftover;
  68     @result;
  69 }
  70
  71 sub make_attributes {
  72     my $attr = shift;
  73     return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
  74     my $escape = shift || 0;
  75     my(@att);
  76     foreach (keys %{$attr}) {
  77         my($key) = $_;
  78         $key=~s/^\-//;     # get rid of initial - if present
  79         $key=~tr/A-Z_/a-z-/; # parameters are lower case, use dashes
  80         my $value = $escape ? simple_escape($attr->{$_}) : $attr->{$_};
  81         push(@att,defined($attr->{$_}) ? qq/$key="$value"/ : qq/$key/);
  82     }
  83     return @att;
  84 }
  85
  86 sub simple_escape {
  87   return unless defined(my $toencode = shift);
  88   $toencode =~ s{&}{&amp;}gso;
  89   $toencode =~ s{<}{&lt;}gso;
  90   $toencode =~ s{>}{&gt;}gso;
  91   $toencode =~ s{\"}{&quot;}gso;
  92 # Doesn't work.  Can't work.  forget it.
  93 #  $toencode =~ s{\x8b}{&#139;}gso;
  94 #  $toencode =~ s{\x9b}{&#155;}gso;
  95   $toencode;
  96 }
  97
  98 # unescape URL-encoded data
  99 sub unescape {
 100   shift() if ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass);
 101   my $todecode = shift;
 102   return undef unless defined($todecode);
 103   $todecode =~ tr/+/ /;       # pluses become spaces
 104     if ($EBCDIC) {
 105       $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
 106     } else {
 107       $todecode =~ s/%([0-9a-fA-F]{2})/chr hex($1)/ge;
 108     }
 109   return $todecode;
 110 }
 111
 112 # URL-encode data
 113 sub escape {
 114   shift() if ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass);
 115   my $toencode = shift;
 116   return undef unless defined($toencode);
 117   $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
 118   return $toencode;
 119 }
 120
 121 # This internal routine creates date strings suitable for use in
 122 # cookies and HTTP headers.  (They differ, unfortunately.)
 123 # Thanks to Mark Fisher for this.
 124 sub expires {
 125     my($time,$format) = @_;
 126     $format ||= 'http';
 127
 128     my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
 129     my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
 130
 131     # pass through preformatted dates for the sake of expire_calc()
 132     $time = expire_calc($time);
 133     return $time unless $time =~ /^\d+$/;
 134
 135     # make HTTP/cookie date string from GMT'ed time
 136     # (cookies use '-' as date separator, HTTP uses ' ')
 137     my($sc) = ' ';
 138     $sc = '-' if $format eq "cookie";
 139     my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
 140     $year += 1900;
 141     return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
 142                    $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
 143 }
 144
 145 # This internal routine creates an expires time exactly some number of
 146 # hours from the current time.  It incorporates modifications from
 147 # Mark Fisher.
 148 sub expire_calc {
 149     my($time) = @_;
 150     my(%mult) = ('s'=>1,
 151                  'm'=>60,
 152                  'h'=>60*60,
 153                  'd'=>60*60*24,
 154                  'M'=>60*60*24*30,
 155                  'y'=>60*60*24*365);
 156     # format for time can be in any of the forms...
 157     # "now" -- expire immediately
 158     # "+180s" -- in 180 seconds
 159     # "+2m" -- in 2 minutes
 160     # "+12h" -- in 12 hours
 161     # "+1d"  -- in 1 day
 162     # "+3M"  -- in 3 months
 163     # "+2y"  -- in 2 years
 164     # "-3m"  -- 3 minutes ago(!)
 165     # If you don't supply one of these forms, we assume you are
 166     # specifying the date yourself
 167     my($offset);
 168     if (!$time || (lc($time) eq 'now')) {
 169         $offset = 0;
 170     } elsif ($time=~/^\d+/) {
 171         return $time;
 172     } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) {
 173         $offset = ($mult{$2} || 1)*$1;
 174     } else {
 175         return $time;
 176     }
 177     return (time+$offset);
 178 }
 179
 180 1;