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"