File Coverage

lib/CGI/Minimal.pm
Criterion Covered Total %
statement 194 223 87.0
branch 70 102 68.6
condition 9 18 50.0
subroutine 24 26 92.3
pod 18 18 100.0
total 315 387 81.4


line stmt bran cond sub pod time code
1             package CGI::Minimal;
2              
3 9     9   17431 use strict;
  9         61  
  9         27798  
4              
5             # I don't 'use warnings;' here because it pulls in ~ 40Kbytes of code and
6             # interferes with 5.005 and earlier versions of Perl.
7             #
8             # I don't use vars qw ($_query $VERSION $form_initial_read $_BUFFER); for
9             # because it also pulls in warnings under later versions of perl.
10             # The code is clean - but the pragmas cause performance issues.
11              
12             $CGI::Minimal::_query = undef;
13             $CGI::Minimal::form_initial_read = undef;
14             $CGI::Minimal::_BUFFER = undef;
15             $CGI::Minimal::_allow_hybrid_post_get = 0;
16             $CGI::Minimal::_mod_perl = 0;
17             $CGI::Minimal::_no_subprocess_env = 0;
18              
19             $CGI::Minimal::VERSION = "1.30";
20              
21             if (exists ($ENV{'MOD_PERL'}) && (0 == $CGI::Minimal::_mod_perl)) {
22             $| = 1;
23             my $env_mod_perl = $ENV{'MOD_PERL'};
24             if ($env_mod_perl =~ m#^mod_perl/1.99#) { # Redhat's almost-but-not-quite ModPerl2....
25             require Apache::compat;
26             require CGI::Minimal::Misc;
27             require CGI::Minimal::Multipart;
28             $CGI::Minimal::_mod_perl = 1;
29              
30             } elsif (exists ($ENV{MOD_PERL_API_VERSION}) && ($ENV{MOD_PERL_API_VERSION} == 2)) {
31             require Apache2::RequestUtil;
32             require Apache2::RequestIO;
33             require APR::Pool;
34             require CGI::Minimal::Misc;
35             require CGI::Minimal::Multipart;
36             $CGI::Minimal::_mod_perl = 2;
37              
38             } else {
39             require Apache;
40             require CGI::Minimal::Misc;
41             require CGI::Minimal::Multipart;
42             $CGI::Minimal::_mod_perl = 1;
43             }
44             }
45             binmode STDIN;
46             reset_globals();
47              
48             ####
49              
50             sub import {
51 9     9   146 my $class = shift;
52 9         20 my %flags = map { $_ => 1 } @_;
  1         4  
53 9 100       39 if ($flags{':preload'}) {
54 1         355 require CGI::Minimal::Misc;
55 1         350 require CGI::Minimal::Multipart;
56             }
57 9         29244 $CGI::Minimal::_no_subprocess_env = $flags{':no_subprocess_env'};
58             }
59              
60             ####
61              
62             sub new {
63 1304     1304 1 41222 my $proto = shift;
64 1304         1556 my $pkg = __PACKAGE__;
65              
66 1304 100       2778 if ($CGI::Minimal::form_initial_read) {
67 1303         2355 binmode STDIN;
68 1303         2780 $CGI::Minimal::_query->_read_form;
69 1303         1739 $CGI::Minimal::form_initial_read = 0;
70             }
71 1304 100       2806 if (1 == $CGI::Minimal::_mod_perl) {
    50          
72 6         14 Apache->request->register_cleanup(\&CGI::Minimal::reset_globals);
73              
74             } elsif (2 == $CGI::Minimal::_mod_perl) {
75 0         0 Apache2::RequestUtil->request->pool->cleanup_register(\&CGI::Minimal::reset_globals);
76             }
77              
78 1304         2818 return $CGI::Minimal::_query;
79             }
80              
81             ####
82              
83             sub reset_globals {
84 1314     1314 1 317873 $CGI::Minimal::form_initial_read = 1;
85 1314         1675 $CGI::Minimal::_allow_hybrid_post_get = 0;
86 1314         11880 $CGI::Minimal::_query = {};
87 1314         2023 bless $CGI::Minimal::_query;
88 1314         1720 my $pkg = __PACKAGE__;
89              
90 1314         1804 $CGI::Minimal::_BUFFER = undef;
91 1314         2788 max_read_size(1000000);
92 1314         2280 $CGI::Minimal::_query->{$pkg}->{'field_names'} = [];
93 1314         2128 $CGI::Minimal::_query->{$pkg}->{'field'} = {};
94 1314         1796 $CGI::Minimal::_query->{$pkg}->{'form_truncated'} = undef;
95              
96 1314         2151 return 1; # Keeps mod_perl from complaining
97             }
98              
99             # For backward compatibility
100 1     1   88 sub _reset_globals { reset_globals; }
101              
102             ###
103              
104             sub subprocess_env {
105 0 0   0 1 0 if (2 == $CGI::Minimal::_mod_perl) {
106 0         0 Apache2::RequestUtil->request->subprocess_env;
107             }
108             }
109              
110             ###
111              
112             sub allow_hybrid_post_get {
113 526 50   526 1 2048 if (@_ > 0) {
114 526         808 $CGI::Minimal::_allow_hybrid_post_get = $_[0];
115             } else {
116 0         0 return $CGI::Minimal::_allow_hybrid_post_get;
117             }
118             }
119              
120             ###
121              
122             sub delete_all {
123 127     127 1 569 my $self = shift;
124 127         137 my $pkg = __PACKAGE__;
125 127         220 $CGI::Minimal::_query->{$pkg}->{'field_names'} = [];
126 127         263 $CGI::Minimal::_query->{$pkg}->{'field'} = {};
127 127         178 return;
128             }
129              
130             ####
131              
132             sub delete {
133 127     127 1 455 my $self = shift;
134 127         203 my $pkg = __PACKAGE__;
135 127         144 my $vars = $self->{$pkg};
136            
137 127         273 my @names_list = @_;
138 127         232 my %tagged_names = map { $_ => 1 } @names_list;
  254         596  
139 127         187 my @parm_names = @{$vars->{'field_names'}};
  127         262  
140 127         198 my $fields = [];
141 127         148 my $data = $vars->{'field'};
142 127         194 foreach my $parm (@parm_names) {
143 381 100       582 if ($tagged_names{$parm}) {
144 254         668 delete $data->{$parm};
145             } else {
146 127         265 push (@$fields, $parm);
147             }
148             }
149 127         200 $vars->{'field_names'} = $fields;
150 127         320 return;
151             }
152              
153             ####
154              
155             sub param {
156 6166     6166 1 56365 my $self = shift;
157 6166         6402 my $pkg = __PACKAGE__;
158              
159 6166 100 100     20371 if (1 < @_) {
    100          
160 129         147 my $n_parms = @_;
161 129 100       320 if (($n_parms % 2) == 1) {
162 1         3 require Carp;
163 1         273 Carp::confess("${pkg}::param() - Odd number of parameters (other than 1) passed");
164             }
165              
166 128         349 my $parms = { @_ };
167 128         1015 require CGI::Minimal::Misc;
168 128         355 $self->_internal_set($parms);
169 127         321 return;
170              
171             } elsif ((1 == @_) and (ref ($_[0]) eq 'HASH')) {
172 1         1 my $parms = shift;
173 1         5 require CGI::Minimal::Misc;
174 1         4 $self->_internal_set($parms);
175 1         2 return;
176             }
177              
178             # Requesting parameter values
179              
180 6036         6951 my $vars = $self->{$pkg};
181 6036         6498 my @result = ();
182 6036 100       8879 if ($#_ == -1) {
183 1412         1504 @result = @{$vars->{'field_names'}};
  1412         3313  
184              
185             } else {
186 4624         6617 my ($fname) = @_;
187 4624 100       8017 if (defined($vars->{'field'}->{$fname})) {
188 4620         4486 @result = @{$vars->{'field'}->{$fname}->{'value'}};
  4620         8824  
189             }
190             }
191              
192 6036 100       11261 if (wantarray) { return @result; }
  1416 100       4687  
193 4616         9339 elsif ($#result > -1) { return $result[0]; }
194 4         16 return;
195             }
196              
197             ####
198              
199             sub raw {
200 8 100   8 1 39 return if (! defined $CGI::Minimal::_BUFFER);
201 4         10 return $$CGI::Minimal::_BUFFER;
202             }
203              
204             ####
205              
206             sub truncated {
207 1263     1263 1 79449 my $pkg = __PACKAGE__;
208 1263         3877 shift->{$pkg}->{'form_truncated'};
209             }
210              
211             ####
212              
213             sub max_read_size {
214 1326     1326 1 1486 my $pkg = __PACKAGE__;
215 1326         4067 $CGI::Minimal::_query->{$pkg}->{'max_buffer'} = $_[0];
216             }
217              
218             ####
219             # Wrapper for form reading for GET, HEAD and POST methods
220              
221             sub _read_form {
222 1303     1303   1499 my $self = shift;
223              
224 1303         1504 my $pkg = __PACKAGE__;
225 1303         1823 my $vars = $self->{$pkg};
226              
227 1303         2572 $vars->{'field'} = {};
228 1303         2066 $vars->{'field_names'} = [];
229              
230 1303         2466 my $req_method=$ENV{"REQUEST_METHOD"};
231 1303 50 33     2804 if ((2 == $CGI::Minimal::_mod_perl) and (not defined $req_method)) {
232 0         0 $req_method = Apache2::RequestUtil->request->method;
233             }
234              
235 1303 100       2306 if (! defined $req_method) {
236 1         19 my $input = ;
237 1 50       5 $input = '' if (! defined $input);
238 1         13 $ENV{'QUERY_STRING'} = $input;
239 1         4 chomp $ENV{'QUERY_STRING'};
240 1         3 $self->_read_get;
241 1         2 return;
242             }
243 1302 100 66     2663 if ($req_method eq 'POST') {
    50          
244 1270         2510 $self->_read_post;
245 1270 100       2604 if ($CGI::Minimal::_allow_hybrid_post_get) {
246 512         1017 $self->_read_get;
247             }
248             } elsif (($req_method eq 'GET') || ($req_method eq 'HEAD')) {
249 32         62 $self->_read_get;
250             } else {
251 0         0 my $package = __PACKAGE__;
252 0         0 require Carp;
253 0         0 Carp::carp($package . " - Unsupported HTTP request method of '$req_method'. Treating as 'GET'");
254 0         0 $self->_read_get;
255             }
256             }
257              
258             ####
259             # Performs form reading for POST method
260              
261             sub _read_post {
262 1270     1270   1467 my $self = shift;
263 1270         1433 my $pkg = __PACKAGE__;
264 1270         1437 my $vars = $self->{$pkg};
265              
266 1270         1242 my $r;
267 1270 50       1893 if (2 == $CGI::Minimal::_mod_perl) {
268 0         0 $r = Apache2::RequestUtil->request;
269             }
270              
271 1270         1692 my $read_length = $vars->{'max_buffer'};
272 1270         1739 my $clen = $ENV{'CONTENT_LENGTH'};
273 1270 50 33     2331 if ((2 == $CGI::Minimal::_mod_perl) and (not defined $clen)) {
274 0         0 $clen = $r->headers_in->get('Content-Length');
275             }
276 1270 100       3079 if ($clen < $read_length) {
277 1258         1577 $read_length = $clen;
278             }
279              
280 1270         1582 my $buffer = '';
281 1270         1433 my $read_bytes = 0;
282 1270 100       1921 if ($read_length) {
283 1264 50       1884 if (2 == $CGI::Minimal::_mod_perl) {
284 0         0 $read_bytes = $r->read($buffer,$read_length,0);
285             } else {
286 1264         17604 $read_bytes = read(STDIN, $buffer, $read_length,0);
287             }
288             }
289 1270         3170 $CGI::Minimal::_BUFFER = \$buffer;
290 1270 100       3183 $vars->{'form_truncated'} = ($read_bytes < $clen) ? 1 : 0;
291              
292 1270 100       2968 my $content_type = defined($ENV{'CONTENT_TYPE'}) ? $ENV{'CONTENT_TYPE'} : '';
293 1270 50 66     2471 if ((!$content_type) and (2 == $CGI::Minimal::_mod_perl)) {
294 0         0 $content_type = $r->headers_in->get('Content-Type');
295             }
296              
297             # Boundaries are supposed to consist of only the following
298             # (1-70 of them, not ending in ' ') A-Za-z0-9 '()+,_-./:=?
299              
300 1270 100       7013 if ($content_type =~ m/^multipart\/form-data; boundary=(.*)$/i) {
301 1252         3318 my $bdry = $1;
302 1252         8415 require CGI::Minimal::Multipart;
303 1252         3652 $self->_burst_multipart_buffer ($buffer,$bdry);
304              
305             } else {
306 18         47 $self->_burst_URL_encoded_buffer($buffer,'[;&]');
307             }
308             }
309              
310             ####
311             # GET and HEAD
312              
313             sub _read_get {
314 545     545   706 my $self = shift;
315              
316 545         636 my $buffer = '';
317 545         849 my $req_method = $ENV{'REQUEST_METHOD'};
318 545 100       1189 if (1 == $CGI::Minimal::_mod_perl) {
    50          
319 5         15 $buffer = Apache->request->args;
320             } elsif (2 == $CGI::Minimal::_mod_perl) {
321 0         0 my $r = Apache2::RequestUtil->request;
322 0         0 $buffer = $r->args;
323 0         0 $r->discard_request_body();
324 0 0 0     0 unless (exists($ENV{'REQUEST_METHOD'}) || $CGI::Minimal::_no_subprocess_env) {
325 0         0 $r->subprocess_env;
326             }
327 0 0       0 $req_method = $r->method unless ($req_method);
328             } else {
329 540 100       1218 $buffer = $ENV{'QUERY_STRING'} if (defined $ENV{'QUERY_STRING'});
330             }
331 545 100       980 if ($req_method ne 'POST') {
332 33         54 $CGI::Minimal::_BUFFER = \$buffer;
333             }
334 545         1063 $self->_burst_URL_encoded_buffer($buffer,'[;&]');
335             }
336              
337             ####
338             # Bursts URL encoded buffers
339             # $buffer - data to be burst
340             # $spliton - split pattern
341              
342             sub _burst_URL_encoded_buffer {
343 563     563   642 my $self = shift;
344 563         607 my $pkg = __PACKAGE__;
345 563         709 my $vars = $self->{$pkg};
346              
347 563         970 my ($buffer,$spliton)=@_;
348              
349 563         748 my ($mime_type) = "text/plain";
350 563         614 my ($filename) = "";
351              
352 563 100       2091 my @pairs = $buffer ? split(/$spliton/, $buffer) : ();
353              
354 563         1207 foreach my $pair (@pairs) {
355 667         1398 my ($name, $data) = split(/=/,$pair,2);
356              
357 667 100       1159 $name = '' unless (defined $name);
358 667         984 $name =~ s/\+/ /gs;
359 667         746 $name =~ s/%(?:([0-9a-fA-F]{2})|u([0-9a-fA-F]{4}))/
360 12 50       63 defined($1)? chr hex($1) : _utf8_chr(hex($2))/ge;
361 667 100       876 $data = '' unless (defined $data);
362 667         819 $data =~ s/\+/ /gs;
363 667         792 $data =~ s/%(?:([0-9a-fA-F]{2})|u([0-9a-fA-F]{4}))/
364 12 50       91 defined($1)? chr hex($1) : _utf8_chr(hex($2))/ge;
365              
366 667 100       1409 if (! defined ($vars->{'field'}->{$name}->{'count'})) {
367 381         432 push (@{$vars->{'field_names'}},$name);
  381         724  
368 381         646 $vars->{'field'}->{$name}->{'count'} = 0;
369             }
370 667         907 my $record = $vars->{'field'}->{$name};
371 667         696 my $f_count = $record->{'count'};
372 667         665 $record->{'count'}++;
373 667         1113 $record->{'value'}->[$f_count] = $data;
374 667         1008 $record->{'filename'}->[$f_count] = $filename;
375 667         1639 $record->{'mime_type'}->[$f_count] = $mime_type;
376             }
377             }
378              
379             ####
380             #
381             # _utf8_chr() taken from CGI::Util
382             # Copyright 1995-1998, Lincoln D. Stein. All rights reserved.
383             sub _utf8_chr {
384 0     0   0 my $c = shift(@_);
385 0 0       0 return chr($c) if $] >= 5.006;
386              
387 0 0       0 if ($c < 0x80) {
    0          
    0          
    0          
    0          
    0          
388 0         0 return sprintf("%c", $c);
389             } elsif ($c < 0x800) {
390 0         0 return sprintf("%c%c", 0xc0 | ($c >> 6), 0x80 | ($c & 0x3f));
391             } elsif ($c < 0x10000) {
392 0         0 return sprintf("%c%c%c",
393             0xe0 | ($c >> 12),
394             0x80 | (($c >> 6) & 0x3f),
395             0x80 | ( $c & 0x3f));
396             } elsif ($c < 0x200000) {
397 0         0 return sprintf("%c%c%c%c",
398             0xf0 | ($c >> 18),
399             0x80 | (($c >> 12) & 0x3f),
400             0x80 | (($c >> 6) & 0x3f),
401             0x80 | ( $c & 0x3f));
402             } elsif ($c < 0x4000000) {
403 0         0 return sprintf("%c%c%c%c%c",
404             0xf8 | ($c >> 24),
405             0x80 | (($c >> 18) & 0x3f),
406             0x80 | (($c >> 12) & 0x3f),
407             0x80 | (($c >> 6) & 0x3f),
408             0x80 | ( $c & 0x3f));
409              
410             } elsif ($c < 0x80000000) {
411 0         0 return sprintf("%c%c%c%c%c%c",
412             0xfc | ($c >> 30),
413             0x80 | (($c >> 24) & 0x3f),
414             0x80 | (($c >> 18) & 0x3f),
415             0x80 | (($c >> 12) & 0x3f),
416             0x80 | (($c >> 6) & 0x3f),
417             0x80 | ( $c & 0x3f));
418             } else {
419 0         0 return _utf8_chr(0xfffd);
420             }
421             }
422              
423             ####
424              
425             sub htmlize {
426 101     101 1 240 my $self = shift;
427              
428 101         134 my ($s)=@_;
429 101 100       153 return ('') if (! defined($s));
430 100         169 $s =~ s/\&/\&/gs;
431 100         103 $s =~ s/>/\>/gs;
432 100         100 $s =~ s/
433 100         123 $s =~ s/"/\"/gs;
434 100         227 $s;
435             }
436              
437             ####
438              
439             sub url_encode {
440 257     257 1 3726 my $self = shift;
441 257         323 my ($s)=@_;
442 257 100       363 return '' if (! defined ($s));
443 256         407 $s= pack("C*", unpack("C*", $s));
444 256         605 $s=~s/([^-_.a-zA-Z0-9])/sprintf("%%%02x",ord($1))/eg;
  191         867  
445 256         524 $s;
446             }
447              
448             ####
449              
450 7750     7750 1 206500 sub param_mime { require CGI::Minimal::Multipart; &_internal_param_mime(@_); }
  7750         13676  
451 7750     7750 1 56525 sub param_filename { require CGI::Minimal::Multipart; &_internal_param_filename(@_); }
  7750         12669  
452 1     1 1 10 sub date_rfc1123 { require CGI::Minimal::Misc; &_internal_date_rfc1123(@_); }
  1         4  
453 2     2 1 420 sub dehtmlize { require CGI::Minimal::Misc; &_internal_dehtmlize(@_); }
  2         7  
454 258     258 1 1691 sub url_decode { require CGI::Minimal::Misc; &_internal_url_decode(@_); }
  258         396  
455 3     3 1 467 sub calling_parms_table { require CGI::Minimal::Misc; &_internal_calling_parms_table(@_); }
  3         20  
456              
457             ####
458              
459             1;
460