buggy modulus on UVs introduced by change#3378 (resulted in
[p5sagit/p5-mst-13.2.git] / lib / CGI / Util.pm
CommitLineData
3d1a2ec4 1package CGI::Util;
2
3use strict;
4use vars '$VERSION','@EXPORT_OK','@ISA','$EBCDIC','@A2E';
5require 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";
12if ($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,
17240,241,242,243,244,245,246,247,248,249,122, 94, 76,126,110,111,
18124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214,
19215,216,217,226,227,228,229,230,231,232,233,173,224,189, 95,109,
20121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150,
21151,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,
25144,143,234,250,190,160,182,179,157,218,155,139,183,184,185,171,
26100,101, 98,102, 99,103,158,104,116,113,114,115,120,117,118,119,
27172,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,
29140, 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 -
36sub 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{$_} = $i; }
52 $i++;
53 }
54
55 my (@result,%leftover);
56 $#result = $#$order; # preextend
57 while (@param) {
58 my $key = uc(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)) if %leftover;
68 @result;
69}
70
71sub 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 upper 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
86sub simple_escape {
87 return unless defined (my $toencode = shift);
88 $toencode =~ s{(.)}{
89 if ($1 eq '<') { '&lt;' }
90 elsif ($1 eq '>') { '&gt;' }
91 elsif ($1 eq '&') { '&amp;' }
92 elsif ($1 eq '"') { '&quot;' }
93 elsif ($1 eq "\x8b") { '&#139;' }
94 elsif ($1 eq "\x9b") { '&#155;' }
95 else { $1 }
96 }gsex;
97 $toencode;
98}
99
100# unescape URL-encoded data
101sub unescape {
102 shift() if ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass);
103 my $todecode = shift;
104 return undef unless defined($todecode);
105 $todecode =~ tr/+/ /; # pluses become spaces
106 if ($EBCDIC) {
107 $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
108 } else {
109 $todecode =~ s/%([0-9a-fA-F]{2})/chr hex($1)/ge;
110 }
111 return $todecode;
112}
113
114# URL-encode data
115sub escape {
116 shift() if ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass);
117 my $toencode = shift;
118 return undef unless defined($toencode);
119 $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
120 return $toencode;
121}
122
123# This internal routine creates date strings suitable for use in
124# cookies and HTTP headers. (They differ, unfortunately.)
125# Thanks to Mark Fisher for this.
126sub expires {
127 my($time,$format) = @_;
128 $format ||= 'http';
129
130 my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
131 my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
132
133 # pass through preformatted dates for the sake of expire_calc()
134 $time = expire_calc($time);
135 return $time unless $time =~ /^\d+$/;
136
137 # make HTTP/cookie date string from GMT'ed time
138 # (cookies use '-' as date separator, HTTP uses ' ')
139 my($sc) = ' ';
140 $sc = '-' if $format eq "cookie";
141 my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
142 $year += 1900;
143 return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
144 $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
145}
146
147# This internal routine creates an expires time exactly some number of
148# hours from the current time. It incorporates modifications from
149# Mark Fisher.
150sub expire_calc {
151 my($time) = @_;
152 my(%mult) = ('s'=>1,
153 'm'=>60,
154 'h'=>60*60,
155 'd'=>60*60*24,
156 'M'=>60*60*24*30,
157 'y'=>60*60*24*365);
158 # format for time can be in any of the forms...
159 # "now" -- expire immediately
160 # "+180s" -- in 180 seconds
161 # "+2m" -- in 2 minutes
162 # "+12h" -- in 12 hours
163 # "+1d" -- in 1 day
164 # "+3M" -- in 3 months
165 # "+2y" -- in 2 years
166 # "-3m" -- 3 minutes ago(!)
167 # If you don't supply one of these forms, we assume you are
168 # specifying the date yourself
169 my($offset);
170 if (!$time || (lc($time) eq 'now')) {
171 $offset = 0;
172 } elsif ($time=~/^\d+/) {
173 return $time;
174 } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) {
175 $offset = ($mult{$2} || 1)*$1;
176 } else {
177 return $time;
178 }
179 return (time+$offset);
180}
181
1821;