File Coverage

blib/lib/CGI/Util.pm
Criterion Covered Total %
statement 113 118 95.7
branch 48 56 85.7
condition 16 30 53.3
subroutine 15 15 100.0
pod 0 11 0.0
total 192 230 83.4


line stmt bran cond sub pod time code
1             package CGI::Util;
2 58     58   14546 use base 'Exporter';
  58         62  
  58         5002  
3             require 5.008001;
4 58     58   207 use strict;
  58         66  
  58         1494  
5 58     58   1732 use if $] >= 5.019, 'deprecate';
  58         83  
  58         242  
6             our @EXPORT_OK = qw(rearrange rearrange_header make_attributes unescape escape
7             expires ebcdic2ascii ascii2ebcdic);
8              
9             our $VERSION = '4.35_01';
10              
11             our $_EBCDIC = "\t" ne "\011";
12              
13             my $appease_cpants_kwalitee = q/
14             use strict;
15             use warnings;
16             #/;
17              
18             # (ord('^') == 95) for codepage 1047 as on os390, vmesa
19             our @A2E = (
20             0, 1, 2, 3, 55, 45, 46, 47, 22, 5, 21, 11, 12, 13, 14, 15,
21             16, 17, 18, 19, 60, 61, 50, 38, 24, 25, 63, 39, 28, 29, 30, 31,
22             64, 90,127,123, 91,108, 80,125, 77, 93, 92, 78,107, 96, 75, 97,
23             240,241,242,243,244,245,246,247,248,249,122, 94, 76,126,110,111,
24             124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214,
25             215,216,217,226,227,228,229,230,231,232,233,173,224,189, 95,109,
26             121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150,
27             151,152,153,162,163,164,165,166,167,168,169,192, 79,208,161, 7,
28             32, 33, 34, 35, 36, 37, 6, 23, 40, 41, 42, 43, 44, 9, 10, 27,
29             48, 49, 26, 51, 52, 53, 54, 8, 56, 57, 58, 59, 4, 20, 62,255,
30             65,170, 74,177,159,178,106,181,187,180,154,138,176,202,175,188,
31             144,143,234,250,190,160,182,179,157,218,155,139,183,184,185,171,
32             100,101, 98,102, 99,103,158,104,116,113,114,115,120,117,118,119,
33             172,105,237,238,235,239,236,191,128,253,254,251,252,186,174, 89,
34             68, 69, 66, 70, 67, 71,156, 72, 84, 81, 82, 83, 88, 85, 86, 87,
35             140, 73,205,206,203,207,204,225,112,221,222,219,220,141,142,223
36             );
37             our @E2A = (
38             0, 1, 2, 3,156, 9,134,127,151,141,142, 11, 12, 13, 14, 15,
39             16, 17, 18, 19,157, 10, 8,135, 24, 25,146,143, 28, 29, 30, 31,
40             128,129,130,131,132,133, 23, 27,136,137,138,139,140, 5, 6, 7,
41             144,145, 22,147,148,149,150, 4,152,153,154,155, 20, 21,158, 26,
42             32,160,226,228,224,225,227,229,231,241,162, 46, 60, 40, 43,124,
43             38,233,234,235,232,237,238,239,236,223, 33, 36, 42, 41, 59, 94,
44             45, 47,194,196,192,193,195,197,199,209,166, 44, 37, 95, 62, 63,
45             248,201,202,203,200,205,206,207,204, 96, 58, 35, 64, 39, 61, 34,
46             216, 97, 98, 99,100,101,102,103,104,105,171,187,240,253,254,177,
47             176,106,107,108,109,110,111,112,113,114,170,186,230,184,198,164,
48             181,126,115,116,117,118,119,120,121,122,161,191,208, 91,222,174,
49             172,163,165,183,169,167,182,188,189,190,221,168,175, 93,180,215,
50             123, 65, 66, 67, 68, 69, 70, 71, 72, 73,173,244,246,242,243,245,
51             125, 74, 75, 76, 77, 78, 79, 80, 81, 82,185,251,252,249,250,255,
52             92,247, 83, 84, 85, 86, 87, 88, 89, 90,178,212,214,210,211,213,
53             48, 49, 50, 51, 52, 53, 54, 55, 56, 57,179,219,220,217,218,159
54             );
55              
56             if ($_EBCDIC && ord('^') == 106) { # as in the BS2000 posix-bc coded character set
57             $A2E[91] = 187; $A2E[92] = 188; $A2E[94] = 106; $A2E[96] = 74;
58             $A2E[123] = 251; $A2E[125] = 253; $A2E[126] = 255; $A2E[159] = 95;
59             $A2E[162] = 176; $A2E[166] = 208; $A2E[168] = 121; $A2E[172] = 186;
60             $A2E[175] = 161; $A2E[217] = 224; $A2E[219] = 221; $A2E[221] = 173;
61             $A2E[249] = 192;
62              
63             $E2A[74] = 96; $E2A[95] = 159; $E2A[106] = 94; $E2A[121] = 168;
64             $E2A[161] = 175; $E2A[173] = 221; $E2A[176] = 162; $E2A[186] = 172;
65             $E2A[187] = 91; $E2A[188] = 92; $E2A[192] = 249; $E2A[208] = 166;
66             $E2A[221] = 219; $E2A[224] = 217; $E2A[251] = 123; $E2A[253] = 125;
67             $E2A[255] = 126;
68             }
69             elsif ($_EBCDIC && ord('^') == 176) { # as in codepage 037 on os400
70             $A2E[10] = 37; $A2E[91] = 186; $A2E[93] = 187; $A2E[94] = 176;
71             $A2E[133] = 21; $A2E[168] = 189; $A2E[172] = 95; $A2E[221] = 173;
72              
73             $E2A[21] = 133; $E2A[37] = 10; $E2A[95] = 172; $E2A[173] = 221;
74             $E2A[176] = 94; $E2A[186] = 91; $E2A[187] = 93; $E2A[189] = 168;
75             }
76              
77             # Smart rearrangement of parameters to allow named parameter
78             # calling. We do the rearrangement if:
79             # the first parameter begins with a -
80              
81             sub rearrange {
82 648     648 0 20543 my ($order,@param) = @_;
83 648         985 my ($result, $leftover) = _rearrange_params( $order, @param );
84 648 100       1595 push @$result, make_attributes( $leftover, defined $CGI::Q ? $CGI::Q->{escape} : 1 )
    100          
85             if keys %$leftover;
86 648         2115 @$result;
87             }
88              
89             sub rearrange_header {
90 6     6 0 6 my ($order,@param) = @_;
91              
92 6         9 my ($result,$leftover) = _rearrange_params( $order, @param );
93 6 50       11 push @$result, make_attributes( $leftover, 0, 1 ) if keys %$leftover;
94              
95 6         17 @$result;
96             }
97              
98             sub _rearrange_params {
99 654     654   772 my($order,@param) = @_;
100 654 100       1077 return [] unless @param;
101              
102 627 100       933 if (ref($param[0]) eq 'HASH') {
103 8         10 @param = %{$param[0]};
  8         26  
104             } else {
105             return \@param
106 619 100 66     2536 unless (defined($param[0]) && substr($param[0],0,1) eq '-');
107             }
108              
109             # map parameters into positional indices
110 310         249 my ($i,%pos);
111 310         257 $i = 0;
112 310         400 foreach (@$order) {
113 2253 100       2671 foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{lc($_)} = $i; }
  3083         3410  
114 2253         1526 $i++;
115             }
116              
117 310         721 my %params_as_hash = ( @param );
118              
119 310         236 my (@result,%leftover);
120 310         723 $#result = $#$order; # preextend
121              
122 310         943 foreach my $k (
123             # sort keys alphabetically but favour certain keys before others
124             # specifically for the case where there could be several options
125             # for a param key, but one should be preferred (see GH #155)
126             sort {
127 622 100       1142 if ( $a =~ /content/i ) { return 1 }
  40 100       59  
128 32         38 elsif ( $b =~ /content/i ) { return -1 }
129 550         730 else { $a cmp $b }
130             }
131             keys( %params_as_hash )
132             ) {
133 751         699 my $key = lc($k);
134 751         1617 $key =~ s/^\-//;
135 751 100       991 if (exists $pos{$key}) {
136 708         1007 $result[$pos{$key}] = $params_as_hash{$k};
137             } else {
138 43         83 $leftover{$key} = $params_as_hash{$k};
139             }
140             }
141              
142 310         1097 return \@result, \%leftover;
143             }
144              
145             sub make_attributes {
146 284     284 0 258 my $attr = shift;
147 284 50 33     1351 return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
      33        
148 284   100     443 my $escape = shift || 0;
149 284         217 my $do_not_quote = shift;
150              
151 284 50       349 my $quote = $do_not_quote ? '' : '"';
152              
153 284         789 my @attr_keys= sort keys %$attr;
154 284         235 my(@att);
155 284         380 foreach (@attr_keys) {
156 387         390 my($key) = $_;
157 387         383 $key=~s/^\-//; # get rid of initial - if present
158              
159             # old way: breaks EBCDIC!
160             # $key=~tr/A-Z_/a-z-/; # parameters are lower case, use dashes
161              
162 387         535 ($key="\L$key") =~ tr/_/-/; # parameters are lower case, use dashes
163              
164 387 100       665 my $value = $escape ? simple_escape($attr->{$_}) : $attr->{$_};
165 387 100       1031 push(@att,defined($attr->{$_}) ? qq/$key=$quote$value$quote/ : qq/$key/);
166             }
167 284         670 return sort @att;
168             }
169              
170             sub simple_escape {
171 372 100   372 0 593 return unless defined(my $toencode = shift);
172 369         360 $toencode =~ s{&}{&}gso;
173 369         263 $toencode =~ s{<}{<}gso;
174 369         264 $toencode =~ s{>}{>}gso;
175 369         255 $toencode =~ s{\"}{"}gso;
176             # Doesn't work. Can't work. forget it.
177             # $toencode =~ s{\x8b}{‹}gso;
178             # $toencode =~ s{\x9b}{›}gso;
179 369         357 $toencode;
180             }
181              
182             sub utf8_chr {
183 1     1 0 674 my $c = shift(@_);
184 1         4 my $u = chr($c);
185 1         3 utf8::encode($u); # drop utf8 flag
186 1         4 return $u;
187             }
188              
189             # unescape URL-encoded data
190             sub unescape {
191 392 50 33 392 0 7763 shift() if @_ > 0 and (ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
      33        
192 392         328 my $todecode = shift;
193 392 100       472 return undef unless defined($todecode);
194 390         388 $todecode =~ tr/+/ /; # pluses become spaces
195 390 50       461 if ($_EBCDIC) {
196 0         0 $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
  0         0  
197             } else {
198             # handle surrogate pairs first -- dankogai. Ref: http://unicode.org/faq/utf_bom.html#utf16-2
199 390         315 $todecode =~ s{
200             %u([Dd][89a-bA-B][0-9a-fA-F]{2}) # hi
201             %u([Dd][c-fC-F][0-9a-fA-F]{2}) # lo
202             }{
203 0         0 utf8_chr(
204             0x10000
205             + (hex($1) - 0xD800) * 0x400
206             + (hex($2) - 0xDC00)
207             )
208             }gex;
209 390         409 $todecode =~ s/%(?:([0-9a-fA-F]{2})|u([0-9a-fA-F]{4}))/
210 36 50       128 defined($1)? chr hex($1) : utf8_chr(hex($2))/ge;
211             }
212 390         622 return $todecode;
213             }
214              
215             # URL-encode data
216             #
217             # We cannot use the %u escapes, they were rejected by W3C, so the official
218             # way is %XX-escaped utf-8 encoding.
219             # Naturally, Unicode strings have to be converted to their utf-8 byte
220             # representation.
221             # Byte strings were traditionally used directly as a sequence of octets.
222             # This worked if they actually represented binary data (i.e. in CGI::Compress).
223             # This also worked if these byte strings were actually utf-8 encoded; e.g.,
224             # when the source file used utf-8 without the appropriate "use utf8;".
225             # This fails if the byte string is actually a Latin 1 encoded string, but it
226             # was always so and cannot be fixed without breaking the binary data case.
227             # -- Stepan Kasal
228             #
229              
230             sub escape {
231             # If we being called in an OO-context, discard the first argument.
232 370 50 33 370 0 7489 shift() if @_ > 1 and ( ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
      66        
233 370         296 my $toencode = shift;
234 370 100       449 return undef unless defined($toencode);
235 351 100       585 utf8::encode($toencode) if utf8::is_utf8($toencode);
236 351 50       344 if ($_EBCDIC) {
237 0         0 $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg;
  0         0  
238             } else {
239 351         505 $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",ord($1))/eg;
  90         300  
240             }
241 351         604 return $toencode;
242             }
243              
244             # This internal routine creates date strings suitable for use in
245             # cookies and HTTP headers. (They differ, unfortunately.)
246             # Thanks to Mark Fisher for this.
247             sub expires {
248 23     23 0 25 my($time,$format) = @_;
249 23   50     37 $format ||= 'http';
250              
251 23         60 my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
252 23         36 my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
253              
254             # pass through preformatted dates for the sake of expire_calc()
255 23         39 $time = expire_calc($time);
256 23 100       98 return $time unless $time =~ /^\d+$/;
257              
258             # make HTTP/cookie date string from GMT'ed time
259             # (cookies use '-' as date separator, HTTP uses ' ')
260 22         47 my($sc) = ' ';
261 22 100       45 $sc = '-' if $format eq "cookie";
262 22         145 my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
263 22         34 $year += 1900;
264 22         177 return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
265             $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
266             }
267              
268             # This internal routine creates an expires time exactly some number of
269             # hours from the current time. It incorporates modifications from
270             # Mark Fisher.
271             sub expire_calc {
272 28     28 0 31 my($time) = @_;
273 28         89 my(%mult) = ('s'=>1,
274             'm'=>60,
275             'h'=>60*60,
276             'd'=>60*60*24,
277             'M'=>60*60*24*30,
278             'y'=>60*60*24*365);
279             # format for time can be in any of the forms...
280             # "now" -- expire immediately
281             # "+180s" -- in 180 seconds
282             # "+2m" -- in 2 minutes
283             # "+12h" -- in 12 hours
284             # "+1d" -- in 1 day
285             # "+3M" -- in 3 months
286             # "+2y" -- in 2 years
287             # "-3m" -- 3 minutes ago(!)
288             # If you don't supply one of these forms, we assume you are
289             # specifying the date yourself
290 28         22 my($offset);
291 28 100 100     116 if (!$time || (lc($time) eq 'now')) {
    100          
    100          
292 17         20 $offset = 0;
293             } elsif ($time=~/^\d+/) {
294 1         5 return $time;
295             } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([smhdMy])/) {
296 9   50     29 $offset = ($mult{$2} || 1)*$1;
297             } else {
298 1         3 return $time;
299             }
300 26         52 my $cur_time = time;
301 26         68 return ($cur_time+$offset);
302             }
303              
304             sub ebcdic2ascii {
305 1     1 0 1 my $data = shift;
306 1         4 $data =~ s/(.)/chr $E2A[ord($1)]/ge;
  1         3  
307 1         4 $data;
308             }
309              
310             sub ascii2ebcdic {
311 1     1 0 2 my $data = shift;
312 1         3 $data =~ s/(.)/chr $A2E[ord($1)]/ge;
  1         3  
313 1         4 $data;
314             }
315              
316             1;
317              
318             __END__