lib/CGI/Util.pm

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