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