File Coverage

blib/lib/CGI/Simple/Util.pm
Criterion Covered Total %
statement 111 144 77.1
branch 55 96 57.3
condition 11 29 37.9
subroutine 16 17 94.1
pod 0 13 0.0
total 193 299 64.5


line stmt bran cond sub pod time code
1             package CGI::Simple::Util;
2 11     11   158 use strict;
  11         104  
  11         236  
3 11     11   161 use vars qw( $VERSION @EXPORT_OK @ISA $UTIL );
  11         99  
  11         188  
4             $VERSION = '0.03';
5             require Exporter;
6             @ISA       = qw( Exporter );
7             @EXPORT_OK = qw(
8             rearrange make_attributes expires
9             escapeHTML unescapeHTML escape unescape
10             );
11              
12             sub rearrange {
13 170     170 0 2316     my ($order, @params) = @_;
14 170         1538     my (%pos, @result, %leftover);
15 170 100       1800     return () unless @params;
16 146 50       1526     if (ref $params[0] eq 'HASH') {
17 0         0         @params = %{$params[0]};
  0         0  
18                 } else {
19 146 100       1877         return @params unless $params[0] =~ m/^-/;
20                 }
21              
22             # map parameters into positional indices
23 124         1249     my $i = 0;
24 124         2021     for (@$order) {
25 766 100       7778         for (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{lc($_)} = $i; }
  970         13106  
26 766         10011         $i++;
27                 }
28 124         1516     $#result = $#$order; # preextend
29 124         3469     while (@params) {
30 371         3553         my $key = lc(shift(@params));
31 371         3497         $key =~ s/^\-//;
32 371 100       3520         if (exists $pos{$key}) {
33 355         4347             $result[$pos{$key}] = shift(@params);
34                     } else {
35 16         191             $leftover{$key} = shift(@params);
36                     }
37                 }
38 124 100       1391     push @result, make_attributes(\%leftover, 1) if %leftover;
39 124         2344     return @result;
40             }
41              
42             sub make_attributes {
43 16     16 0 143     my $attref = shift;
44 16   50     269     my $escape = shift || 0;
45 16 50 33     304     return () unless $attref && ref $attref eq 'HASH';
46 16         130     my @attrib;
47 16         135     for my $key (keys %{$attref}) {
  16         193  
48 16         176         (my $mod_key = $key) =~
49                         s/^-//; # get rid of initial - if present
50 16         137         $mod_key = lc $mod_key; # parameters are lower case
51 16         146         $mod_key =~ tr/_/-/; # use dashes
52 16 50       194         my $value =
53                         $escape ? escapeHTML($attref->{$key}) : $attref->{$key};
54 16 50       228         push @attrib, defined $value ? qq/$mod_key="$value"/ : $mod_key;
55                 }
56 16         195     return @attrib;
57             }
58              
59             # This internal routine creates date strings suitable for use in
60             # cookies and HTTP headers. (They differ, unfortunately.)
61             # Thanks to Mark Fisher for this.
62             sub expires {
63 36     36 0 338     my ($time, $format) = @_;
64 36   50     1047     $format ||= 'http';
65 36         511     my @MON = qw( Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
66 36         400     my @WDAY = qw( Sun Mon Tue Wed Thu Fri Sat );
67              
68             # pass through preformatted dates for the sake of expire_calc()
69 36         333     $time = _expire_calc($time);
70 36 100       607     return $time unless $time =~ /^\d+$/;
71              
72             # make HTTP/cookie date string from GMT'ed time
73             # (cookies use '-' as date separator, HTTP uses ' ')
74 25 100       252     my $sc = $format eq 'cookie' ? '-' : ' ';
75 25         1543     my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($time);
76 25         244     $year += 1900;
77 25         645     return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
78                     $WDAY[$wday], $mday, $MON[$mon], $year, $hour, $min, $sec);
79             }
80              
81             # This internal routine creates an expires time exactly some number of
82             # hours from the current time. It incorporates modifications from Mark Fisher.
83             # format for time can be in any of the forms...
84             # "now" -- expire immediately
85             # "+180s" -- in 180 seconds
86             # "+2m" -- in 2 minutes
87             # "+12h" -- in 12 hours
88             # "+1d" -- in 1 day
89             # "+3M" -- in 3 months
90             # "+2y" -- in 2 years
91             # "-3m" -- 3 minutes ago(!)
92             # If you don't supply one of these forms, we assume you are specifying
93             # the date yourself
94             sub _expire_calc {
95 36     36   313     my ($time) = @_;
96 36         628     my %mult = (
97                     's' => 1,
98                     'm' => 60,
99                     'h' => 60 * 60,
100                     'd' => 60 * 60 * 24,
101                     'M' => 60 * 60 * 24 * 30,
102                     'y' => 60 * 60 * 24 * 365
103                 );
104 36         431     my $offset;
105 36 100 100     1001     if (!$time or lc $time eq 'now') {
    50          
    100          
106 20         300         $offset = 0;
107                 } elsif ($time =~ /^\d+/) {
108 0         0         return $time;
109                 } elsif ($time =~ /^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) {
110 5   50     84         $offset = ($mult{$2} || 1) * $1;
111                 } else {
112 11         139         return $time;
113                 }
114 25         770     return (time + $offset);
115             }
116              
117             sub escapeHTML {
118 34     34 0 470     my ($escape, $text) = @_;
119 34 100       335     return undef unless defined $escape;
120 32         613     $escape =~ s/&/&/g;
121 32         331     $escape =~ s/"/"/g;
122 32         321     $escape =~ s/</&lt;/g;
123 32         847     $escape =~ s/>/&gt;/g;
124              
125             # these next optional escapes make text look the same when rendered in HTML
126 32 50       308     if ($text) {
127 0         0         $escape =~ s/\t/ /g; # tabs to 4 spaces
128                     $escape =~
129 0         0             s/( {2,})/"&nbsp;" x length $1/eg; # whitespace escapes
  0         0  
130 0         0         $escape =~ s/\n/<br>\n/g; # newlines to <br>
131                 }
132 32         425     return $escape;
133             }
134              
135             sub unescapeHTML {
136 104     104 0 955     my ($unescape) = @_;
137 104 100       18149     return undef unless defined($unescape);
138 94         989     my $latin = $UTIL->{'charset'} =~ /^(?:ISO-8859-1|WINDOWS-1252)$/i;
139 94         803     my $ebcdic = $UTIL->{'ebcdic'};
140              
141             # credit to Randal Schwartz for original version of this
142 94         873     $unescape =~ s[&(.*?);]{
143 26         1122 local $_ = $1;
144 26 0 33     516 /^amp$/i ? "&" :
    0 0        
    0 0        
    50 0        
    100          
    100          
    100          
    100          
145             /^quot$/i ? '"' :
146             /^gt$/i ? ">" :
147             /^lt$/i ? "<" :
148             /^#(\d+)$/ && $latin ? chr($1) :
149             /^#(\d+)$/ && $ebcdic ? chr($UTIL->{'a2e'}->[$1]) :
150             /^#x([0-9a-f]+)$/i && $latin ? chr(hex($1)) :
151             /^#x([0-9a-f]+)$/i && $ebcdic ? chr($UTIL->{'a2e'}->[hex $1]) :
152             $_
153             }gex;
154 94         2145     return $unescape;
155             }
156              
157             # URL-encode data
158             sub escape {
159 151     151 0 1385     my ($toencode) = @_;
160 151 50       2043     return undef unless defined $toencode;
161 151 50       6033     if ($UTIL->{'ebcdic'}) {
162                     $toencode =~
163 0         0             s/([^a-zA-Z0-9_.-])/uc sprintf "%%%02x", $UTIL->{'e2a'}->[ord $1]/eg;
  0         0  
164                 } else {
165                     $toencode =~
166 151         1709             s/([^a-zA-Z0-9_.-])/uc sprintf "%%%02x", ord $1 /eg;
  57         1118  
167                 }
168 151         1909     return $toencode;
169             }
170              
171             # unescape URL-encoded data
172             sub unescape {
173 85     85 0 771     my ($todecode) = @_;
174 85 50       880     return undef unless defined $todecode;
175 85         917     $todecode =~ tr/+/ /;
176 85 50       919     if ($UTIL->{'ebcdic'}) {
177                     $todecode =~
178 0         0             s/%([0-9a-fA-F]{2})/chr $UTIL->{'a2e'}->[hex $1]/ge;
  0         0  
179                 } else {
180 85         1067         $todecode =~ s/%(?:([0-9a-fA-F]{2})|u([0-9a-fA-F]{4}))/
181 45 50       1478 defined($1)? chr hex($1) : utf8_chr(hex($2))/ge;
182                 }
183 85         1085     return $todecode;
184             }
185              
186             sub utf8_chr ($) {
187 0     0 0 0     my $c = shift;
188 0 0       0     if ($c < 0x80) {
    0          
    0          
    0          
    0          
    0          
189 0         0         return sprintf("%c", $c);
190                 } elsif ($c < 0x800) {
191 0         0         return sprintf("%c%c", 0xc0 | ($c >> 6), 0x80 | ($c & 0x3f));
192                 } elsif ($c < 0x10000) {
193 0         0         return sprintf("%c%c%c",
194                         0xe0 | ($c >> 12),
195                         0x80 | (($c >> 6) & 0x3f),
196                         0x80 | ($c & 0x3f));
197                 } elsif ($c < 0x200000) {
198 0         0         return sprintf("%c%c%c%c",
199                         0xf0 | ($c >> 18),
200                         0x80 | (($c >> 12) & 0x3f),
201                         0x80 | (($c >> 6) & 0x3f),
202                         0x80 | ($c & 0x3f));
203                 } elsif ($c < 0x4000000) {
204 0         0         return sprintf("%c%c%c%c%c",
205                         0xf8 | ($c >> 24),
206                         0x80 | (($c >> 18) & 0x3f),
207                         0x80 | (($c >> 12) & 0x3f),
208                         0x80 | (($c >> 6) & 0x3f),
209                         0x80 | ($c & 0x3f));
210              
211                 } elsif ($c < 0x80000000) {
212 0         0         return sprintf(
213                         "%c%c%c%c%c%c",
214                         0xfc | ($c >> 30), # was 0xfe patch Thomas L. Shinnick
215                         0x80 | (($c >> 24) & 0x3f),
216                         0x80 | (($c >> 18) & 0x3f),
217                         0x80 | (($c >> 12) & 0x3f),
218                         0x80 | (($c >> 6) & 0x3f),
219                         0x80 | ($c & 0x3f)
220                     );
221                 } else {
222 0         0         return utf8(0xfffd);
223                 }
224             }
225              
226             # We need to define a number of things about the operating environment so
227             # we do this on first initialization and store the results in in an object
228             BEGIN {
229              
230 11     11   432     $UTIL = new CGI::Simple::Util; # initialize our $UTIL object
231              
232                 sub new {
233 11     11 0 136         my $class = shift;
234 11   33     185         $class = ref($class) || $class;
235 11         126         my $self = {};
236 11         152         bless $self, $class;
237 11         157         $self->init;
238 11         111         return $self;
239                 }
240              
241                 sub init {
242 11     11 0 104         my $self = shift;
243 11         169         $self->charset;
244 11         120         $self->os;
245 11         188         $self->ebcdic;
246                 }
247              
248                 sub charset {
249 47     47 0 921         my ($self, $charset) = @_;
250 47 100       546         $self->{'charset'} = $charset if $charset;
251 47   100     602         $self->{'charset'} ||=
252                         'ISO-8859-1'; # set to the safe ISO-8859-1 if not defined
253 47         933         return $self->{'charset'};
254                 }
255              
256                 sub os {
257 11     11 0 109         my ($self, $OS) = @_;
258 11 50       180         $self->{'os'} = $OS if $OS; # allow value to be set manually
259 11         111         $OS = $self->{'os'};
260 11 50       132         unless ($OS) {
261 11 50       166             unless ($OS = $^O) {
262 0         0                 require Config;
263 0         0                 $OS = $Config::Config{'osname'};
264                         }
265 11 50       301             if ($OS =~ /Win/i) {
    50          
    50          
    50          
    50          
    50          
266 0         0                 $OS = 'WINDOWS';
267                         } elsif ($OS =~ /vms/i) {
268 0         0                 $OS = 'VMS';
269                         } elsif ($OS =~ /bsdos/i) {
270 0         0                 $OS = 'UNIX';
271                         } elsif ($OS =~ /dos/i) {
272 0         0                 $OS = 'DOS';
273                         } elsif ($OS =~ /^MacOS$/i) {
274 0         0                 $OS = 'MACINTOSH';
275                         } elsif ($OS =~ /os2/i) {
276 0         0                 $OS = 'OS2';
277                         } else {
278 11         108                 $OS = 'UNIX';
279                         }
280                     }
281 11         126         return $self->{'os'} = $OS;
282                 }
283              
284                 sub ebcdic {
285 11     11 0 737         my $self = shift;
286 11 50       135         return $self->{'ebcdic'} if exists $self->{'ebcdic'};
287 11         104         $self->{'ebcdic'} = "\t" ne "\011" ? 1 : 0;
288 11 50       179         if ($self->{'ebcdic'}) {
289              
290             # (ord('^') == 95) for codepage 1047 as on os390, vmesa
291 0                       my @A2E = (
292                             0, 1, 2, 3, 55, 45, 46, 47, 22, 5,
293                             21, 11, 12, 13, 14, 15, 16, 17, 18, 19,
294                             60, 61, 50, 38, 24, 25, 63, 39, 28, 29,
295                             30, 31, 64, 90, 127, 123, 91, 108, 80, 125,
296                             77, 93, 92, 78, 107, 96, 75, 97, 240, 241,
297                             242, 243, 244, 245, 246, 247, 248, 249, 122, 94,
298                             76, 126, 110, 111, 124, 193, 194, 195, 196, 197,
299                             198, 199, 200, 201, 209, 210, 211, 212, 213, 214,
300                             215, 216, 217, 226, 227, 228, 229, 230, 231, 232,
301                             233, 173, 224, 189, 95, 109, 121, 129, 130, 131,
302                             132, 133, 134, 135, 136, 137, 145, 146, 147, 148,
303                             149, 150, 151, 152, 153, 162, 163, 164, 165, 166,
304                             167, 168, 169, 192, 79, 208, 161, 7, 32, 33,
305                             34, 35, 36, 37, 6, 23, 40, 41, 42, 43,
306                             44, 9, 10, 27, 48, 49, 26, 51, 52, 53,
307                             54, 8, 56, 57, 58, 59, 4, 20, 62, 255,
308                             65, 170, 74, 177, 159, 178, 106, 181, 187, 180,
309                             154, 138, 176, 202, 175, 188, 144, 143, 234, 250,
310                             190, 160, 182, 179, 157, 218, 155, 139, 183, 184,
311                             185, 171, 100, 101, 98, 102, 99, 103, 158, 104,
312                             116, 113, 114, 115, 120, 117, 118, 119, 172, 105,
313                             237, 238, 235, 239, 236, 191, 128, 253, 254, 251,
314                             252, 186, 174, 89, 68, 69, 66, 70, 67, 71,
315                             156, 72, 84, 81, 82, 83, 88, 85, 86, 87,
316                             140, 73, 205, 206, 203, 207, 204, 225, 112, 221,
317                             222, 219, 220, 141, 142, 223
318                         );
319 0                       my @E2A = (
320                             0, 1, 2, 3, 156, 9, 134, 127, 151, 141,
321                             142, 11, 12, 13, 14, 15, 16, 17, 18, 19,
322                             157, 10, 8, 135, 24, 25, 146, 143, 28, 29,
323                             30, 31, 128, 129, 130, 131, 132, 133, 23, 27,
324                             136, 137, 138, 139, 140, 5, 6, 7, 144, 145,
325                             22, 147, 148, 149, 150, 4, 152, 153, 154, 155,
326                             20, 21, 158, 26, 32, 160, 226, 228, 224, 225,
327                             227, 229, 231, 241, 162, 46, 60, 40, 43, 124,
328                             38, 233, 234, 235, 232, 237, 238, 239, 236, 223,
329                             33, 36, 42, 41, 59, 94, 45, 47, 194, 196,
330                             192, 193, 195, 197, 199, 209, 166, 44, 37, 95,
331                             62, 63, 248, 201, 202, 203, 200, 205, 206, 207,
332                             204, 96, 58, 35, 64, 39, 61, 34, 216, 97,
333                             98, 99, 100, 101, 102, 103, 104, 105, 171, 187,
334                             240, 253, 254, 177, 176, 106, 107, 108, 109, 110,
335                             111, 112, 113, 114, 170, 186, 230, 184, 198, 164,
336                             181, 126, 115, 116, 117, 118, 119, 120, 121, 122,
337                             161, 191, 208, 91, 222, 174, 172, 163, 165, 183,
338                             169, 167, 182, 188, 189, 190, 221, 168, 175, 93,
339                             180, 215, 123, 65, 66, 67, 68, 69, 70, 71,
340                             72, 73, 173, 244, 246, 242, 243, 245, 125, 74,
341                             75, 76, 77, 78, 79, 80, 81, 82, 185, 251,
342                             252, 249, 250, 255, 92, 247, 83, 84, 85, 86,
343                             87, 88, 89, 90, 178, 212, 214, 210, 211, 213,
344                             48, 49, 50, 51, 52, 53, 54, 55, 56, 57,
345                             179, 219, 220, 217, 218, 159
346                         );
347 0                       if (ord('^') == 106)
348                         { # as in the BS2000 posix-bc coded character set
349                             $A2E[91] = 187;
350                             $A2E[92] = 188;
351                             $A2E[94] = 106;
352                             $A2E[96] = 74;
353                             $A2E[123] = 251;
354                             $A2E[125] = 253;
355                             $A2E[126] = 255;
356                             $A2E[159] = 95;
357                             $A2E[162] = 176;
358                             $A2E[166] = 208;
359                             $A2E[168] = 121;
360                             $A2E[172] = 186;
361                             $A2E[175] = 161;
362                             $A2E[217] = 224;
363                             $A2E[219] = 221;
364                             $A2E[221] = 173;
365                             $A2E[249] = 192;
366              
367                             $E2A[74] = 96;
368                             $E2A[95] = 159;
369                             $E2A[106] = 94;
370                             $E2A[121] = 168;
371                             $E2A[161] = 175;
372                             $E2A[173] = 221;
373                             $E2A[176] = 162;
374                             $E2A[186] = 172;
375                             $E2A[187] = 91;
376                             $E2A[188] = 92;
377                             $E2A[192] = 249;
378                             $E2A[208] = 166;
379                             $E2A[221] = 219;
380                             $E2A[224] = 217;
381                             $E2A[251] = 123;
382                             $E2A[253] = 125;
383                             $E2A[255] = 126;
384                         } elsif (ord('^') == 176) { # as in codepage 037 on os400
385                             $A2E[10] = 37;
386                             $A2E[91] = 186;
387                             $A2E[93] = 187;
388                             $A2E[94] = 176;
389                             $A2E[133] = 21;
390                             $A2E[168] = 189;
391                             $A2E[172] = 95;
392                             $A2E[221] = 173;
393              
394                             $E2A[21] = 133;
395                             $E2A[37] = 10;
396                             $E2A[95] = 172;
397                             $E2A[173] = 221;
398                             $E2A[176] = 94;
399                             $E2A[186] = 91;
400                             $E2A[187] = 93;
401                             $E2A[189] = 168;
402                         }
403 0                       $self->{'a2e'} = \@A2E;
404 0                       $self->{'e2a'} = \@E2A;
405                     }
406                 }
407             }
408              
409             1;
410              
411             __END__
412            
413             =head1 NAME
414            
415             CGI::Util - Internal utilities used by CGI::Simple module
416            
417             =head1 SYNOPSIS
418            
419             $escaped = escapeHTML('In HTML you need to escape < > " and & chars');
420             $unescaped = unescapeHTML('&lt;&gt;&quot;&amp;');
421             $url_encoded = escape($string);
422             $decoded = unescape($url_encoded);
423            
424             =head1 DESCRIPTION
425            
426             CGI::Simple::Util contains essentially non public subroutines used by
427             CGI::Simple. There are HTML and URL escape and unescape routines that may
428             be of some use.
429            
430             An internal object is used to store a number of system specific details to
431             enable the escape routines to be accurate.
432            
433             =head1 AUTHOR INFORMATION
434            
435             Original version copyright 1995-1998, Lincoln D. Stein. All rights reserved.
436            
437             This version copyright 2001, Dr James Freeman.
438            
439             This library is free software; you can redistribute it and/or modify
440             it under the same terms as Perl itself.
441            
442             Address bug reports and comments to: jfreeman@tassie.net.au
443            
444             =head1 SEE ALSO
445            
446             L<CGI::Simple>
447            
448             =cut
449