Commit | Line | Data |
3d1a2ec4 |
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) { |
6b4ac661 |
51 | foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{lc($_)} = $i; } |
3d1a2ec4 |
52 | $i++; |
53 | } |
54 | |
55 | my (@result,%leftover); |
56 | $#result = $#$order; # preextend |
57 | while (@param) { |
6b4ac661 |
58 | my $key = lc(shift(@param)); |
3d1a2ec4 |
59 | $key =~ s/^\-//; |
60 | if (exists $pos{$key}) { |
61 | $result[$pos{$key}] = shift(@param); |
62 | } else { |
63 | $leftover{$key} = shift(@param); |
64 | } |
65 | } |
66 | |
6b4ac661 |
67 | push (@result,make_attributes(\%leftover,1)) if %leftover; |
3d1a2ec4 |
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 |
6b4ac661 |
79 | $key=~tr/A-Z_/a-z-/; # parameters are lower case, use dashes |
3d1a2ec4 |
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 { |
6b4ac661 |
87 | return unless defined(my $toencode = shift); |
88 | $toencode =~ s{&}{&}gso; |
89 | $toencode =~ s{<}{<}gso; |
90 | $toencode =~ s{>}{>}gso; |
91 | $toencode =~ s{\"}{"}gso; |
92 | # Doesn't work. Can't work. forget it. |
93 | # $toencode =~ s{\x8b}{‹}gso; |
94 | # $toencode =~ s{\x9b}{›}gso; |
3d1a2ec4 |
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; |