File Coverage

blib/lib/CGI/Util.pm
Criterion Covered Total %
statement 82 105 78.1
branch 40 60 66.7
condition 16 36 44.4
subroutine 9 12 75.0
pod 0 10 0.0
total 147 223 65.9


line stmt bran cond sub pod time code
1             package CGI::Util;
2              
3 19     19   341 use strict;
  19         227  
  19         440  
4 19     19   290 use vars qw($VERSION @EXPORT_OK @ISA $EBCDIC @A2E @E2A);
  19         192  
  19         506  
5             require Exporter;
6             @ISA = qw(Exporter);
7             @EXPORT_OK = qw(rearrange make_attributes unescape escape
8             expires ebcdic2ascii ascii2ebcdic);
9              
10             $VERSION = '1.5';
11              
12             $EBCDIC = "\t" ne "\011";
13             # (ord('^') == 95) for codepage 1047 as on os390, vmesa
14             @A2E = (
15                0, 1, 2, 3, 55, 45, 46, 47, 22, 5, 21, 11, 12, 13, 14, 15,
16               16, 17, 18, 19, 60, 61, 50, 38, 24, 25, 63, 39, 28, 29, 30, 31,
17               64, 90,127,123, 91,108, 80,125, 77, 93, 92, 78,107, 96, 75, 97,
18              240,241,242,243,244,245,246,247,248,249,122, 94, 76,126,110,111,
19              124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214,
20              215,216,217,226,227,228,229,230,231,232,233,173,224,189, 95,109,
21              121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150,
22              151,152,153,162,163,164,165,166,167,168,169,192, 79,208,161, 7,
23               32, 33, 34, 35, 36, 37, 6, 23, 40, 41, 42, 43, 44, 9, 10, 27,
24               48, 49, 26, 51, 52, 53, 54, 8, 56, 57, 58, 59, 4, 20, 62,255,
25               65,170, 74,177,159,178,106,181,187,180,154,138,176,202,175,188,
26              144,143,234,250,190,160,182,179,157,218,155,139,183,184,185,171,
27              100,101, 98,102, 99,103,158,104,116,113,114,115,120,117,118,119,
28              172,105,237,238,235,239,236,191,128,253,254,251,252,186,174, 89,
29               68, 69, 66, 70, 67, 71,156, 72, 84, 81, 82, 83, 88, 85, 86, 87,
30              140, 73,205,206,203,207,204,225,112,221,222,219,220,141,142,223
31             );
32             @E2A = (
33                0, 1, 2, 3,156, 9,134,127,151,141,142, 11, 12, 13, 14, 15,
34               16, 17, 18, 19,157, 10, 8,135, 24, 25,146,143, 28, 29, 30, 31,
35              128,129,130,131,132,133, 23, 27,136,137,138,139,140, 5, 6, 7,
36              144,145, 22,147,148,149,150, 4,152,153,154,155, 20, 21,158, 26,
37               32,160,226,228,224,225,227,229,231,241,162, 46, 60, 40, 43,124,
38               38,233,234,235,232,237,238,239,236,223, 33, 36, 42, 41, 59, 94,
39               45, 47,194,196,192,193,195,197,199,209,166, 44, 37, 95, 62, 63,
40              248,201,202,203,200,205,206,207,204, 96, 58, 35, 64, 39, 61, 34,
41              216, 97, 98, 99,100,101,102,103,104,105,171,187,240,253,254,177,
42              176,106,107,108,109,110,111,112,113,114,170,186,230,184,198,164,
43              181,126,115,116,117,118,119,120,121,122,161,191,208, 91,222,174,
44              172,163,165,183,169,167,182,188,189,190,221,168,175, 93,180,215,
45              123, 65, 66, 67, 68, 69, 70, 71, 72, 73,173,244,246,242,243,245,
46              125, 74, 75, 76, 77, 78, 79, 80, 81, 82,185,251,252,249,250,255,
47               92,247, 83, 84, 85, 86, 87, 88, 89, 90,178,212,214,210,211,213,
48               48, 49, 50, 51, 52, 53, 54, 55, 56, 57,179,219,220,217,218,159
49             );
50              
51             if ($EBCDIC && ord('^') == 106) { # as in the BS2000 posix-bc coded character set
52                  $A2E[91] = 187; $A2E[92] = 188; $A2E[94] = 106; $A2E[96] = 74;
53                  $A2E[123] = 251; $A2E[125] = 253; $A2E[126] = 255; $A2E[159] = 95;
54                  $A2E[162] = 176; $A2E[166] = 208; $A2E[168] = 121; $A2E[172] = 186;
55                  $A2E[175] = 161; $A2E[217] = 224; $A2E[219] = 221; $A2E[221] = 173;
56                  $A2E[249] = 192;
57              
58                  $E2A[74] = 96; $E2A[95] = 159; $E2A[106] = 94; $E2A[121] = 168;
59                  $E2A[161] = 175; $E2A[173] = 221; $E2A[176] = 162; $E2A[186] = 172;
60                  $E2A[187] = 91; $E2A[188] = 92; $E2A[192] = 249; $E2A[208] = 166;
61                  $E2A[221] = 219; $E2A[224] = 217; $E2A[251] = 123; $E2A[253] = 125;
62                  $E2A[255] = 126;
63                }
64             elsif ($EBCDIC && ord('^') == 176) { # as in codepage 037 on os400
65               $A2E[10] = 37; $A2E[91] = 186; $A2E[93] = 187; $A2E[94] = 176;
66               $A2E[133] = 21; $A2E[168] = 189; $A2E[172] = 95; $A2E[221] = 173;
67              
68               $E2A[21] = 133; $E2A[37] = 10; $E2A[95] = 172; $E2A[173] = 221;
69               $E2A[176] = 94; $E2A[186] = 91; $E2A[187] = 93; $E2A[189] = 168;
70             }
71              
72             # Smart rearrangement of parameters to allow named parameter
73             # calling. We do the rearangement if:
74             # the first parameter begins with a -
75             sub rearrange {
76 185     185 0 2325     my($order,@param) = @_;
77 185 100       2102     return () unless @param;
78              
79 175 100       1692     if (ref($param[0]) eq 'HASH') {
80 2         18 @param = %{$param[0]};
  2         33  
81                 } else {
82             return @param
83 173 100 66     3089 unless (defined($param[0]) && substr($param[0],0,1) eq '-');
84                 }
85              
86             # map parameters into positional indices
87 121         988     my ($i,%pos);
88 121         1120     $i = 0;
89 121         1267     foreach (@$order) {
90 840 100       10955 foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{lc($_)} = $i; }
  1100         16084  
91 840         8538 $i++;
92                 }
93              
94 121         1222     my (@result,%leftover);
95 121         1468     $#result = $#$order; # preextend
96 121         1285     while (@param) {
97 298         2818 my $key = lc(shift(@param));
98 298         3064 $key =~ s/^\-//;
99 298 100       2865 if (exists $pos{$key}) {
100 287         5343 $result[$pos{$key}] = shift(@param);
101             } else {
102 11         138 $leftover{$key} = shift(@param);
103             }
104                 }
105              
106 121 100       1309     push (@result,make_attributes(\%leftover,defined $CGI::Q ? $CGI::Q->{escape} : 1)) if %leftover;
    100          
107 121         2931     @result;
108             }
109              
110             sub make_attributes {
111 70     70 0 641     my $attr = shift;
112 70 50 33     3232     return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
      33        
113 70   100     957     my $escape = shift || 0;
114 70         698     my(@att);
115 70         579     foreach (keys %{$attr}) {
  70         1875  
116 71         919 my($key) = $_;
117 71         656 $key=~s/^\-//;     # get rid of initial - if present
118              
119             # old way: breaks EBCDIC!
120             # $key=~tr/A-Z_/a-z-/; # parameters are lower case, use dashes
121              
122 71         757 ($key="\L$key") =~ tr/_/-/; # parameters are lower case, use dashes
123              
124 71 100       829 my $value = $escape ? simple_escape($attr->{$_}) : $attr->{$_};
125 71 100       1074 push(@att,defined($attr->{$_}) ? qq/$key="$value"/ : qq/$key/);
126                 }
127 70         1083     return @att;
128             }
129              
130             sub simple_escape {
131 70 100   70 0 2460   return unless defined(my $toencode = shift);
132 66         666   $toencode =~ s{&}{&}gso;
133 66         610   $toencode =~ s{<}{&lt;}gso;
134 66         551   $toencode =~ s{>}{&gt;}gso;
135 66         689   $toencode =~ s{\"}{&quot;}gso;
136             # Doesn't work. Can't work. forget it.
137             # $toencode =~ s{\x8b}{&#139;}gso;
138             # $toencode =~ s{\x9b}{&#155;}gso;
139 66         678   $toencode;
140             }
141              
142             sub utf8_chr {
143 0     0 0 0         my $c = shift(@_);
144 0 0       0 return chr($c) if $] >= 5.006;
145              
146 0 0       0         if ($c < 0x80) {
    0          
    0          
    0          
    0          
    0          
147 0         0                 return sprintf("%c", $c);
148                     } elsif ($c < 0x800) {
149 0         0                 return sprintf("%c%c", 0xc0 | ($c >> 6), 0x80 | ($c & 0x3f));
150                     } elsif ($c < 0x10000) {
151 0         0                 return sprintf("%c%c%c",
152                                                        0xe0 | ($c >> 12),
153                                                        0x80 | (($c >> 6) & 0x3f),
154                                                        0x80 | ( $c & 0x3f));
155                     } elsif ($c < 0x200000) {
156 0         0                 return sprintf("%c%c%c%c",
157                                                        0xf0 | ($c >> 18),
158                                                        0x80 | (($c >> 12) & 0x3f),
159                                                        0x80 | (($c >> 6) & 0x3f),
160                                                        0x80 | ( $c & 0x3f));
161                     } elsif ($c < 0x4000000) {
162 0         0                 return sprintf("%c%c%c%c%c",
163                                                        0xf8 | ($c >> 24),
164                                                        0x80 | (($c >> 18) & 0x3f),
165                                                        0x80 | (($c >> 12) & 0x3f),
166                                                        0x80 | (($c >> 6) & 0x3f),
167                                                        0x80 | ( $c & 0x3f));
168              
169                     } elsif ($c < 0x80000000) {
170 0         0                 return sprintf("%c%c%c%c%c%c",
171                                                        0xfc | ($c >> 30),
172                                                        0x80 | (($c >> 24) & 0x3f),
173                                                        0x80 | (($c >> 18) & 0x3f),
174                                                        0x80 | (($c >> 12) & 0x3f),
175                                                        0x80 | (($c >> 6) & 0x3f),
176                                                        0x80 | ( $c & 0x3f));
177                     } else {
178 0         0                 return utf8_chr(0xfffd);
179                     }
180             }
181              
182             # unescape URL-encoded data
183             sub unescape {
184 197 50 33 197 0 4798   shift() if @_ > 0 and (ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
      33        
      33        
185 197         2008   my $todecode = shift;
186 197 100       2147   return undef unless defined($todecode);
187 181         1946   $todecode =~ tr/+/ /; # pluses become spaces
188 181         1735     $EBCDIC = "\t" ne "\011";
189 181 50       1553     if ($EBCDIC) {
190 0         0       $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
  0         0  
191                 } else {
192 181         1836       $todecode =~ s/%(?:([0-9a-fA-F]{2})|u([0-9a-fA-F]{4}))/
193 34 50       476 defined($1)? chr hex($1) : utf8_chr(hex($2))/ge;
194                 }
195 181         2006   return $todecode;
196             }
197              
198             # URL-encode data
199             sub escape {
200 356 100 0 356 0 5079   shift() if @_ > 1 and ( ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
      33        
      66        
201 356         3458   my $toencode = shift;
202 356 100       8942   return undef unless defined($toencode);
203             # force bytes while preserving backward compatibility -- dankogai
204 352         4545   $toencode = pack("C*", unpack("C*", $toencode));
205 352 50       3365     if ($EBCDIC) {
206 0         0       $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg;
  0         0  
207                 } else {
208 352         3423       $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",ord($1))/eg;
  83         1813  
209                 }
210 352         4258   return $toencode;
211             }
212              
213             # This internal routine creates date strings suitable for use in
214             # cookies and HTTP headers. (They differ, unfortunately.)
215             # Thanks to Mark Fisher for this.
216             sub expires {
217 11     11 0 112     my($time,$format) = @_;
218 11   50     106     $format ||= 'http';
219              
220 11         184     my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
221 11         176     my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
222              
223             # pass through preformatted dates for the sake of expire_calc()
224 11         179     $time = expire_calc($time);
225 11 100       160     return $time unless $time =~ /^\d+$/;
226              
227             # make HTTP/cookie date string from GMT'ed time
228             # (cookies use '-' as date separator, HTTP uses ' ')
229 10         118     my($sc) = ' ';
230 10 100       174     $sc = '-' if $format eq "cookie";
231 10         1351     my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
232 10         118     $year += 1900;
233 10         318     return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
234                                $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
235             }
236              
237             # This internal routine creates an expires time exactly some number of
238             # hours from the current time. It incorporates modifications from
239             # Mark Fisher.
240             sub expire_calc {
241 11     11 0 102     my($time) = @_;
242 11         167     my(%mult) = ('s'=>1,
243                              'm'=>60,
244                              'h'=>60*60,
245                              'd'=>60*60*24,
246                              'M'=>60*60*24*30,
247                              'y'=>60*60*24*365);
248             # format for time can be in any of the forms...
249             # "now" -- expire immediately
250             # "+180s" -- in 180 seconds
251             # "+2m" -- in 2 minutes
252             # "+12h" -- in 12 hours
253             # "+1d" -- in 1 day
254             # "+3M" -- in 3 months
255             # "+2y" -- in 2 years
256             # "-3m" -- 3 minutes ago(!)
257             # If you don't supply one of these forms, we assume you are
258             # specifying the date yourself
259 11         89     my($offset);
260 11 100 66     284     if (!$time || (lc($time) eq 'now')) {
    50          
    100          
261 5         44       $offset = 0;
262                 } elsif ($time=~/^\d+/) {
263 0         0       return $time;
264                 } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([smhdMy])/) {
265 5   50     87       $offset = ($mult{$2} || 1)*$1;
266                 } else {
267 1         14       return $time;
268                 }
269 10         392     return (time+$offset);
270             }
271              
272             sub ebcdic2ascii {
273 0     0 0     my $data = shift;
274 0             $data =~ s/(.)/chr $E2A[ord($1)]/ge;
  0            
275 0             $data;
276             }
277              
278             sub ascii2ebcdic {
279 0     0 0     my $data = shift;
280 0             $data =~ s/(.)/chr $A2E[ord($1)]/ge;
  0            
281 0             $data;
282             }
283              
284             1;
285              
286             __END__
287            
288             =head1 NAME
289            
290             CGI::Util - Internal utilities used by CGI module
291            
292             =head1 SYNOPSIS
293            
294             none
295            
296             =head1 DESCRIPTION
297            
298             no public subroutines
299            
300             =head1 AUTHOR INFORMATION
301            
302             Copyright 1995-1998, Lincoln D. Stein. All rights reserved.
303            
304             This library is free software; you can redistribute it and/or modify
305             it under the same terms as Perl itself.
306            
307             Address bug reports and comments to: lstein@cshl.org. When sending
308             bug reports, please provide the version of CGI.pm, the version of
309             Perl, the name and version of your Web server, and the name and
310             version of the operating system you are using. If the problem is even
311             remotely browser dependent, please provide information about the
312             affected browers as well.
313            
314             =head1 SEE ALSO
315            
316             L<CGI>
317            
318             =cut
319