File Coverage

blib/lib/CGI/Simple.pm
Criterion Covered Total %
statement 541 697 77.6
branch 323 468 69.0
condition 100 160 62.5
subroutine 111 125 88.8
pod 69 90 76.7
total 1144 1540 74.3


line stmt bran cond sub pod time code
1             package CGI::Simple;
2              
3             require 5.004;
4              
5             # this module is both strict (and warnings) compliant, but they are only used
6             # in testing as they add an unnecessary compile time overhead in production.
7 9     9   117 use strict;
  9         85  
  9         120  
8 9     9   198 use warnings;
  9         81  
  9         147  
9 9     9   149 use Carp;
  9         78  
  9         353  
10              
11 9         221 use vars qw(
12             $VERSION $USE_CGI_PM_DEFAULTS $DISABLE_UPLOADS $POST_MAX
13             $NO_UNDEF_PARAMS $USE_PARAM_SEMICOLONS $HEADERS_ONCE
14             $NPH $DEBUG $NO_NULL $FATAL *in
15 9     9   258 );
  9         362  
16              
17             $VERSION = "0.079";
18              
19             # you can hard code the global variable settings here if you want.
20             # warning - do not delete the unless defined $VAR part unless you
21             # want to permanently remove the ability to change the variable.
22             sub _initialize_globals {
23              
24             # set this to 1 to use CGI.pm default global settings
25 80 100   80   959     $USE_CGI_PM_DEFAULTS = 0
26                     unless defined $USE_CGI_PM_DEFAULTS;
27              
28             # see if user wants old CGI.pm defaults
29 80 100       1084     if ($USE_CGI_PM_DEFAULTS) {
30 15         195         _use_cgi_pm_global_settings();
31 15         179         return;
32                 }
33              
34             # no file uploads by default, set to 0 to enable uploads
35 65 100       635     $DISABLE_UPLOADS = 1
36                     unless defined $DISABLE_UPLOADS;
37              
38             # use a post max of 100K, set to -1 for no limits
39 65 100       700     $POST_MAX = 102_400
40                     unless defined $POST_MAX;
41              
42             # set to 1 to not include undefined params parsed from query string
43 65 100       636     $NO_UNDEF_PARAMS = 0
44                     unless defined $NO_UNDEF_PARAMS;
45              
46             # separate the name=value pairs with ; rather than &
47 65 100       680     $USE_PARAM_SEMICOLONS = 0
48                     unless defined $USE_PARAM_SEMICOLONS;
49              
50             # only print headers once
51 65 100       662     $HEADERS_ONCE = 0
52                     unless defined $HEADERS_ONCE;
53              
54             # Set this to 1 to enable NPH scripts
55 65 100       653     $NPH = 0
56                     unless defined $NPH;
57              
58             # 0 => no debug, 1 => from @ARGV, 2 => from STDIN
59 65 100       670     $DEBUG = 0
60                     unless defined $DEBUG;
61              
62             # filter out null bytes in param - value pairs
63 65 100       679     $NO_NULL = 1
64                     unless defined $NO_NULL;
65              
66             # set behavior when cgi_err() called -1 => silent, 0 => carp, 1 => croak
67 65 100       746     $FATAL = -1
68                     unless defined $FATAL;
69             }
70              
71             # I happen to disagree with many of the default global settings in CGI.pm
72             # This sub is called if you set $CGI::Simple::USE_CGI_PM_GLOBALS = 1; or
73             # invoke the '-default' pragma via a use CGI::Simple qw(-default);
74             sub _use_cgi_pm_global_settings {
75 23     23   267     $USE_CGI_PM_DEFAULTS = 1;
76 23 100       331     $DISABLE_UPLOADS = 0 unless defined $DISABLE_UPLOADS;
77 23 100       282     $POST_MAX = -1 unless defined $POST_MAX;
78 23 100       344     $NO_UNDEF_PARAMS = 0 unless defined $NO_UNDEF_PARAMS;
79 23 100       561     $USE_PARAM_SEMICOLONS = 1 unless defined $USE_PARAM_SEMICOLONS;
80 23 100       448     $HEADERS_ONCE = 0 unless defined $HEADERS_ONCE;
81 23 100       254     $NPH = 0 unless defined $NPH;
82 23 100       235     $DEBUG = 1 unless defined $DEBUG;
83 23 100       384     $NO_NULL = 0 unless defined $NO_NULL;
84 23 100       317     $FATAL = -1 unless defined $FATAL;
85             }
86              
87             # this is called by new, we will never directly reference the globals again
88             sub _store_globals {
89 86     86   863     my $self = shift;
90              
91 86         1428     $self->{'.globals'}->{'DISABLE_UPLOADS'} = $DISABLE_UPLOADS;
92 86         1019     $self->{'.globals'}->{'POST_MAX'} = $POST_MAX;
93 86         960     $self->{'.globals'}->{'NO_UNDEF_PARAMS'} = $NO_UNDEF_PARAMS;
94 86         1029     $self->{'.globals'}->{'USE_PARAM_SEMICOLONS'} = $USE_PARAM_SEMICOLONS;
95 86         833     $self->{'.globals'}->{'HEADERS_ONCE'} = $HEADERS_ONCE;
96 86         873     $self->{'.globals'}->{'NPH'} = $NPH;
97 86         1166     $self->{'.globals'}->{'DEBUG'} = $DEBUG;
98 86         983     $self->{'.globals'}->{'NO_NULL'} = $NO_NULL;
99 86         1164     $self->{'.globals'}->{'FATAL'} = $FATAL;
100 86         1166     $self->{'.globals'}->{'USE_CGI_PM_DEFAULTS'} = $USE_CGI_PM_DEFAULTS;
101             }
102              
103             # use the automatic calling of the import sub to set our pragmas. CGI.pm compat
104             sub import {
105 15     15   295     my ($self, @args) = @_;
106              
107             # arguments supplied in the 'use CGI::Simple [ARGS];' will now be in @args
108 15         179     foreach (@args) {
109 27 100       316         $USE_CGI_PM_DEFAULTS = 1, next if m/^-default/i;
110 20 100       205         $DISABLE_UPLOADS = 1, next if m/^-no.?upload/i;
111 18 100       168         $DISABLE_UPLOADS = 0, next if m/^-upload/i;
112 16 100       154         $HEADERS_ONCE = 1, next if m/^-unique.?header/i;
113 14 100       136         $NPH = 1, next if m/^-nph/i;
114 11 100       109         $DEBUG = 0, next if m/^-no.?debug/i;
115 9 50       1836         $DEBUG = defined $1 ? $1 : 2, next if m/^-debug(\d)?/i;
    100          
116 7 100       101         $USE_PARAM_SEMICOLONS = 1, next if m/^-newstyle.?url/i;
117 5 100       62         $USE_PARAM_SEMICOLONS = 0, next if m/^-oldstyle.?url/i;
118 3 50       56         $NO_UNDEF_PARAMS = 1, next if m/^-no.?undef.?param/i;
119 0 0       0         $FATAL = 0, next if m/^-carp/i;
120 0 0       0         $FATAL = 1, next if m/^-croak/i;
121 0         0         croak "Pragma '$_' is not defined in CGI::Simple\n";
122                 }
123             }
124              
125             # used in CGI.pm .t files
126             sub _reset_globals {
127 6     6   1705     _use_cgi_pm_global_settings();
128             }    
129              
130             binmode STDIN;
131             binmode STDOUT;
132              
133             # use correct encoding conversion to handle non ASCII char sets.
134             # we import and install the complex routines only if we have to.
135             BEGIN {
136              
137                 sub url_decode {
138 577     577 1 7812         my ($self, $decode) = @_;
139 577 100       7818         return () unless defined $decode;
140 575         6627         $decode =~ tr/+/ /;
141 575         6161         $decode =~ s/%([a-fA-F0-9]{2})/ pack "C", hex $1 /eg;
  812         10441  
142 575         7845         return $decode;
143                 }
144              
145                 sub url_encode {
146 430     430 1 3958         my ($self, $encode) = @_;
147 430 100       3976         return () unless defined $encode;
148 428         3781         $encode =~ s/([^A-Za-z0-9\-_.!~*'() ])/ uc sprintf "%%%02x",ord $1 /eg;
  632         7519  
149 428         3860         $encode =~ tr/ /+/;
150 428         6404         return $encode;
151                 }
152              
153 9     9   253     if ("\t" ne "\011") {
154                     eval { require CGI::Simple::Util };
155                     if ($@) {
156                         croak "Your server is using not using ASCII, you must install CGI::Simple::Util, error: $@";
157                     }
158              
159             # hack the symbol table and replace simple encode/decode subs
160                     *CGI::Simple::url_encode =
161                         sub { CGI::Simple::Util::escape($_[1]) };
162                     *CGI::Simple::url_decode =
163                         sub { CGI::Simple::Util::unescape($_[1]) };
164                 }
165             }
166              
167             ################ The Guts ################
168              
169             sub new {
170 78     78 1 3603     my ($class, $init) = @_;
171 78   33     2113     $class = ref($class) || $class;
172 78         10492     my $self = {};
173 78         2085     bless $self, $class;
174 78 50       1129     $self->_initialize_mod_perl($init) if $self->_mod_perl;
175 78         1125     $self->_initialize_globals;
176 78         1093     $self->_store_globals;
177 78         1281     $self->_initialize($init);
178 78         2039     return $self;
179             }
180              
181             sub _mod_perl {
182                 return (
183 78   66 78   4801         exists $ENV{MOD_PERL}
      33        
184                         or ($ENV{GATEWAY_INTERFACE}
185                         and $ENV{GATEWAY_INTERFACE} =~ m{^CGI-Perl/})
186                 );
187             }
188              
189             # Return the global request object under mod_perl. For this to work on mod_perl 2
190             # PerlOptions +GlobalRequest must be specified.
191             sub _mod_perl_request {
192 0     0   0     my $self = shift;
193                 
194 0         0     my $mp = $self->{'.mod_perl'};
195              
196 0 0       0     return unless $mp;
197              
198 0 0       0     if ($mp == 2) {
199 0         0         return Apache2::RequestUtil->request;
200                 } else {
201 0         0         return Apache->request;
202                 }
203             }
204              
205             sub _initialize_mod_perl {
206 0     0   0     my ($self, $init) = @_;
207              
208 0         0     eval "require mod_perl";
209              
210 0 0       0     if (defined $mod_perl::VERSION) {
211              
212 0 0       0         if ($mod_perl::VERSION >= 2.00) {
213 0         0             $self->{'.mod_perl'} = 2;
214              
215 0         0             require Apache2::RequestRec;
216 0         0             require Apache2::RequestUtil;
217 0         0             require APR::Pool;
218              
219 0         0             my $r = $self->_mod_perl_request();
220              
221 0 0       0             if (defined $r) {
222 0 0       0                 $r->subprocess_env unless exists $ENV{REQUEST_METHOD};
223 0         0                 $r->pool->cleanup_register(
224                                 \&CGI::Simple::_initialize_globals);
225                         }
226                     } else {
227 0         0             $self->{'.mod_perl'} = 1;
228              
229 0         0             require Apache;
230              
231 0         0             my $r = $self->_mod_perl_request();
232              
233 0 0       0             if (defined $r) {
234 0         0                 $r->register_cleanup(\&CGI::Simple::_initialize_globals);
235                         }
236                     }
237                 }
238             }
239              
240             # Do we need this?
241             sub DESTROY {
242 85     85   1057     my $self = shift;
243 85         741     undef $self;
244             }
245              
246             sub _initialize {
247 78     78   769     my ($self, $init) = @_;
248              
249 78 100       1213     if (!defined $init) {
    100          
    100          
    100          
250             # initialize from QUERY_STRING, STDIN or @ARGV
251 50         823         $self->_read_parse();
252                 } elsif ((ref $init) =~ m/HASH/i) {
253             # initialize from param hash
254 5         45         for my $param (keys %{$init}) {
  5         66  
255 8         92             $self->_add_param($param, $init->{$param});
256                     }
257                 }
258              
259             # chromatic's blessed GLOB patch
260             # elsif ( (ref $init) =~ m/GLOB/i ) { # initialize from a file
261                 elsif (UNIVERSAL::isa($init, 'GLOB')) { # initialize from a file
262 7         81         $self->_init_from_file($init);
263                 } elsif ((ref $init) eq 'CGI::Simple') {
264             # initialize from a CGI::Simple object
265 1         46         require Data::Dumper;
266             # avoid problems with strict when Data::Dumper returns $VAR1
267 1         11         my $VAR1;
268 1         13         my $clone = eval(Data::Dumper::Dumper($init));
269 1 50       11         if ($@) {
270 0         0             $self->cgi_error("Can't clone CGI::Simple object: $@");
271                     } else {
272 1         11             $_[0] = $clone;
273                     }
274                 } else {
275 15         170         $self->_parse_params($init); # initialize from a query string
276                 }
277             }
278              
279             sub _read_parse {
280 50     50   521     my $self = shift;
281 50         547     my $data = '';
282 50   100     2186     my $type = $ENV{'CONTENT_TYPE'} || 'No CONTENT_TYPE received';
283 50   100     784     my $length = $ENV{'CONTENT_LENGTH'} || 0;
284 50   100     941     my $method = $ENV{'REQUEST_METHOD'} || 'No REQUEST_METHOD received';
285              
286             # first check POST_MAX Steve Purkis pointed out the previous bug
287 50 50 66     1269     if ( $method eq 'POST'
      33        
288                     and $self->{'.globals'}->{'POST_MAX'} != -1
289                     and $length > $self->{'.globals'}->{'POST_MAX'}) {
290 0         0         $self->cgi_error(
291                         "413 Request entity too large: $length bytes on STDIN exceeds \$POST_MAX!"
292                     );
293              
294             # silently discard data ??? better to just close the socket ???
295 0         0         while ($length > 0) {
296 0 0       0             last unless sysread(STDIN, my $buffer, 4096);
297 0         0             $length -= length($buffer);
298                     }
299                     
300 0         0         return;
301                 }
302              
303 50 50 66     2485     if ($length and $type =~ m|^multipart/form-data|i) {
    100 100        
    100          
304 0         0         my $got_length = $self->_parse_multipart;
305 0 0       0         if ($length != $got_length) {
306 0         0             $self->cgi_error("500 Bad read on multipart/form-data! wanted $length, got $got_length");
307                     }
308                     
309 0         0         return;
310                 } elsif ($method eq 'POST') {
311 3 50       252         if ($length) {
312             # we may not get all the data we want with a single read on large
313             # POSTs as it may not be here yet! Credit Jason Luther for patch
314             # CGI.pm < 2.99 suffers from same bug
315 3         4025515             sysread(STDIN, $data, $length);
316 3         238             while (length($data) < $length) {
317 2 50       6024288                 last unless sysread(STDIN, my $buffer, 4096);
318 2         74                 $data