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 .= $buffer;
319							}
320
321	3	50				162	unless ($length == length $data) {
322	0					0	$self->cgi_error("500 Bad read on POST! wanted $length, got " . length($data));
323	0					0	return;
324							}
325							}
326							} elsif ($method eq 'GET' or $method eq 'HEAD') {
327	45	50	100			681	$data =
			100
328							$self->{'.mod_perl'}
329							? $self->_mod_perl_request()->args()
330							: $ENV{'QUERY_STRING'}
331							\|\| $ENV{'REDIRECT_QUERY_STRING'}
332							\|\| '';
333							} else {
334	2	50	33			36	unless ($self->{'.globals'}->{'DEBUG'}
335							and $data = $self->read_from_cmdline()) {
336	0					0	$self->cgi_error("400 Unknown method $method");
337	0					0	return;
338							}
339							}
340
341	50	100				2275	unless ($data) {
342							# I liked this reporting but CGI.pm does not behave like this so
343							# out it goes......
344							# $self->cgi_error("400 No data received via method: $method, type: $type");
345	2					652	return;
346							}
347
348	48					733	$self->_parse_params($data);
349							}
350
351							sub _parse_params {
352	107			107		1903	my ($self, $data) = @_;
353	107	50				1062	return () unless defined $data;
354	107	100				1686	unless ($data =~ /[&=;]/) {
355	9					111	$self->{'keywords'} = [$self->_parse_keywordlist($data)];
356	9					104	return;
357							}
358	98					2026	my @pairs = split /[&;]/, $data;
359	98					7965	for my $pair (@pairs) {
360	279					3570	my ($param, $value) = split '=', $pair;
361	279	50				3109	next unless defined $param;
362	279	100				2987	$value = '' unless defined $value;
363	279					3671	$self->_add_param($self->url_decode($param),
364							$self->url_decode($value));
365							}
366							}
367
368							sub _add_param {
369	342			342		3699	my ($self, $param, $value, $overwrite) = @_;
370	342	100	66			4931	return () unless defined $param and defined $value;
371	338	100				4129	$param =~ tr/\000//d if $self->{'.globals'}->{'NO_NULL'};
372	338	100				3511	@{$self->{$param}} = () if $overwrite;
	23					283
373	338	100				3707	@{$self->{$param}} = () unless exists $self->{$param};
	161					2069
374	338	100				4232	my @values = ref $value ? @{$value} : ($value);
	45					640
375	338					21493	for my $value (@values) {
376							next
377	388	100	100			11920	if $value eq ''
378							and $self->{'.globals'}->{'NO_UNDEF_PARAMS'};
379	384	100				5111	$value =~ tr/\000//d if $self->{'.globals'}->{'NO_NULL'};
380	384					3593	push @{$self->{$param}}, $value;
	384					4546
381	384	100				5504	unless ($self->{'.fieldnames'}->{$param}) {
382	165					1403	push @{$self->{'.parameters'}}, $param;
	165					1983
383	165					2467	$self->{'.fieldnames'}->{$param}++;
384							}
385							}
386	338					4487	return scalar @values; # for compatibility with CGI.pm request.t
387							}
388
389							sub _parse_keywordlist {
390	13			13		136	my ($self, $data) = @_;
391	13	50				145	return () unless defined $data;
392	13					137	$data = $self->url_decode($data);
393	13	100				166	$data =~ tr/\000//d if $self->{'.globals'}->{'NO_NULL'};
394	13					172	my @keywords = split /\s+/, $data;
395	13					188	return @keywords;
396							}
397
398							sub _parse_multipart {
399	0			0		0	my $self = shift;
400	0					0	my ($boundary) =
401							$ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/;
402	0	0				0	unless ($boundary) {
403	0					0	$self->cgi_error(
404							'400 No boundary supplied for multipart/form-data');
405	0					0	return 0;
406							}
407
408							# BUG: IE 3.01 on the Macintosh uses just the boundary, forgetting the --
409	0	0				0	$boundary = '--' . $boundary
410							unless $ENV{'HTTP_USER_AGENT'} =~ m/MSIE\s+3\.0[12];\s*Mac/i;
411	0					0	$boundary = quotemeta $boundary;
412	0					0	my $got_data = 0;
413	0					0	my $data = '';
414	0		0			0	my $length = $ENV{'CONTENT_LENGTH'} \|\| 0;
415	0					0	my $CRLF = $self->crlf;
416
417							READ:
418
419	0					0	while ($got_data < $length) {
420	0	0				0	last READ unless sysread(STDIN, my $buffer, 4096);
421	0					0	$data .= $buffer;
422	0					0	$got_data += length $buffer;
423
424							BOUNDARY:
425
426	0					0	while ($data =~ m/^$boundary$CRLF/) {
427							## TAB and high ascii chars are definitivelly allowed in headers.
428							## Not accepting them in the following regex prevents the upload of
429							## files with filenames like "Espa�a.txt".
430							# next READ unless $data =~ m/^([\040-\176$CRLF]+?$CRLF$CRLF)/o;
431							next READ
432	0	0				0	unless $data =~
433							m/^([\x20-\x7E\x80-\xFF\x09$CRLF]+?$CRLF$CRLF)/o;
434	0					0	my $header = $1;
435	0					0	(my $unfold = $1) =~ s/$CRLF\s+/ /og;
436	0					0	my ($param) = $unfold =~ m/form-data;\s+name="?([^\";]*)"?/;
437	0					0	my ($filename) =
438							$unfold =~
439							m/name="?\Q$param\E"?;\s+filename="?([^\"]*)"?/;
440	0	0				0	if (defined $filename) {
441	0					0	my ($mime) = $unfold =~ m/Content-Type:\s+([-\w\/]+)/io;
442	0					0	$data =~ s/^\Q$header\E//;
443	0					0	($got_data, $data, my $fh, my $size) =
444							$self->_save_tmpfile($boundary, $filename,
445							$got_data, $data);
446	0					0	$self->_add_param($param, $filename);
447	0					0	$self->{'.upload_fields'}->{$param} = $filename;
448	0	0				0	$self->{'.filehandles'}->{$filename} = $fh if $fh;
449	0	0				0	$self->{'.tmpfiles'}->{$filename} =
450							{'size' => $size, 'mime' => $mime}
451							if $size;
452	0					0	next BOUNDARY;
453							}
454							next READ
455	0	0				0	unless $data =~
456							s/^\Q$header\E(.*?)$CRLF(?=$boundary)//s;
457	0					0	$self->_add_param($param, $1);
458							}
459	0	0				0	unless ($data =~ m/^$boundary/) {
460							## In a perfect world, $data should always begin with $boundary.
461							## But sometimes, IE5 prepends garbage boundaries into POST(ed) data.
462							## Then, $data does not start with $boundary and the previous block
463							## never gets executed. The following fix attempts to remove those
464							## extra boundaries from readed $data and restart boundary parsing.
465							## Note about performance: with well formed data, previous check is
466							## executed (generally) only once, when $data value is "$boundary--"
467							## at end of parsing.
468	0	0				0	goto BOUNDARY if ($data =~ s/.*?$CRLF(?=$boundary$CRLF)//s);
469							}
470							}
471	0					0	return $got_data;
472							}
473
474							sub _save_tmpfile {
475	0			0		0	my ($self, $boundary, $filename, $got_data, $data) = @_;
476	0					0	my $fh;
477	0					0	my $CRLF = $self->crlf;
478	0		0			0	my $length = $ENV{'CONTENT_LENGTH'} \|\| 0;
479	0					0	my $file_size = 0;
480	0	0				0	if ($self->{'.globals'}->{'DISABLE_UPLOADS'}) {
		0
481	0					0	$self->cgi_error("405 Not Allowed - File uploads are disabled");
482							} elsif ($filename) {
483	0					0	eval { require IO::File };
	0					0
484	0	0				0	$self->cgi_error("500 IO::File is not available $@") if $@;
485	0					0	$fh = new_tmpfile IO::File;
486	0	0				0	$self->cgi_error("500 IO::File can't create new temp_file")
487							unless $fh;
488							}
489
490							# read in data until closing boundary found. buffer to catch split boundary
491							# we do this regardless of whether we save the file or not to read the file
492							# data from STDIN. if either uploads are disabled or no file has been sent
493							# $fh will be undef so only do file stuff if $fh is true using $fh && syntax
494	0	0				0	$fh && binmode $fh;
495	0					0	while ($got_data < $length) {
496
497	0					0	my $buffer = $data;
498	0	0				0	last unless sysread(STDIN, $data, 4096);
499
500							# fixed hanging bug if browser terminates upload part way through
501							# thanks to Brandon Black
502	0	0				0	unless ($data) {
503	0					0	$self->cgi_error(
504							'400 Malformed multipart, no terminating boundary');
505	0					0	undef $fh;
506	0					0	return $got_data;
507							}
508
509	0					0	$got_data += length $data;
510	0	0				0	if ("$buffer$data" =~ m/$boundary/) {
511	0					0	$data = $buffer . $data;
512	0					0	last;
513							}
514
515							# we do not have partial boundary so print to file if valid $fh
516	0	0				0	$fh && print $fh $buffer;
517	0					0	$file_size += length $buffer;
518							}
519	0					0	$data =~ s/^(.*?)$CRLF(?=$boundary)//s;
520	0	0				0	$fh && print $fh $1; # print remainder of file if valid $fh
521	0					0	$file_size += length $1;
522	0					0	return $got_data, $data, $fh, $file_size;
523							}
524
525							# Define the CRLF sequence. You can't use a simple "\r\n" because of system
526							# specific 'features'. On EBCDIC systems "\t" ne "\011" as the don't use ASCII
527							sub crlf {
528	46			46	1	513	my ($self, $CRLF) = @_;
529	46	50				435	$self->{'.crlf'} = $CRLF if $CRLF; # allow value to be set manually
530	46	100				494	unless ($self->{'.crlf'}) {
531							my $OS = $^O
532	11		33			206	\|\| do { require Config; $Config::Config{'osname'} };
	0					0
	0					0
533	11	50				176	$self->{'.crlf'} =
534							($OS =~ m/VMS/i) ? "\n"
535							: ("\t" ne "\011") ? "\r\n"
536							: "\015\012";
537							}
538	46					505	return $self->{'.crlf'};
539							}
540
541							################ The Core Methods ################
542
543							sub param {
544	435			435	1	6407	my ($self, $param, @p) = @_;
545	435	100				4432	unless (defined $param) { # return list of all params
546	115					1374	my @params =
547	125	100				1577	$self->{'.parameters'} ? @{$self->{'.parameters'}} : ();
548	125					1797	return @params;
549							}
550	310	100				3287	unless (@p) { # return values for $param
551	279	100				3583	return () unless exists $self->{$param};
552	267	100				3199	return wantarray ? @{$self->{$param}} : $self->{$param}->[0];
	211					3979
553							}
554	31	100	100			470	if ($param =~ m/^-name$/i and @p == 1) {
555	12	100				156	return () unless exists $self->{$p[0]};
556	8	100				134	return wantarray ? @{$self->{$p[0]}} : $self->{$p[0]}->[0];
	2					34
557							}
558
559							# set values using -name=>'foo',-value=>'bar' syntax.
560							# also allows for $q->param( 'foo', 'some', 'new', 'values' ) syntax
561	19	100				251	($param, undef, @p) = @p
562							if $param =~ m/^-name$/i; # undef represents -value token
563	19	100				393	$self->_add_param($param, (ref $p[0] eq 'ARRAY' ? $p[0] : [@p]),
564							'overwrite');
565	19	100				293	return wantarray ? @{$self->{$param}} : $self->{$param}->[0];
	6					129
566							}
567
568							#1;
569
570							############### The following methods only loaded on demand ###############
571							############### Move commonly used methods above the __DATA__ ###############
572							############### token if you are into recreational optimization ###############
573							############### You can not use Selfloader and the __DATA__ ###############
574							############### token under mod_perl, so comment token out ###############
575
576							#__DATA__
577
578							# a new method that provides access to a new internal routine. Useage:
579							# $q->add_param( $param, $value, $overwrite )
580							# $param must be a plain scalar
581							# $value may be either a scalar or an array ref
582							# if $overwrite is a true value $param will be overwritten with new values.
583							sub add_param {
584	16			16	1	279	_add_param(@_)
585							}
586
587							sub param_fetch {
588	6			6	1	79	my ($self, $param, @p) = @_;
589	6	100	100			90	$param =
590							(defined $param and $param =~ m/^-name$/i) ? $p[0] : $param;
591	6	100				71	return undef unless defined $param;
592	4	50				44	$self->_add_param($param, []) unless exists $self->{$param};
593	4					49	return $self->{$param};
594							}
595
596							# Return a parameter in the QUERY_STRING, regardless of whether a POST or GET
597							sub url_param {
598	14			14	1	3003	my ($self, $param) = @_;
599	14	50				170	return () unless $ENV{'QUERY_STRING'};
600	14					149	$self->{'.url_param'} = {};
601	14					195	bless $self->{'.url_param'}, 'CGI::Simple';
602	14					295	$self->{'.url_param'}->_parse_params($ENV{'QUERY_STRING'});
603	14					178	return $self->{'.url_param'}->param($param);
604							}
605
606							sub keywords {
607	16			16	1	585	my ($self, @values) = @_;
608	16	100				623	$self->{'keywords'} =
		100
609							ref $values[0] eq 'ARRAY' ? $values[0] : [@values]
610							if @values;
611	16					184	my @result =
612	16	50				185	defined($self->{'keywords'}) ? @{$self->{'keywords'}} : ();
613	16					245	return @result;
614							}
615
616							sub Vars {
617	14			14	1	157	my $self = shift;
618	14		100			248	$self->{'.sep'} = shift \|\| $self->{'.sep'} \|\| "\0";
			100
619	14					120	my (%hash, %tied);
620	14					152	for my $param ($self->param) {
621	28					336	$hash{$param} = join $self->{'.sep'}, $self->param($param);
622							}
623	14					184	tie %tied, "CGI::Simple", $self;
624	14	100				314	return wantarray ? %hash : \%tied;
625							}
626
627	14	50		14		152	sub TIEHASH { $_[1] ? $_[1] : new $_[0] }
628							sub STORE {
629	3			3		45	my ($q, $p, $v) = @_;
630	3					87	$q->param($p, split $q->{'.sep'}, $v);
631							}
632
633							sub FETCH {
634	4			4		64	my ($q, $p) = @_;
635	4	50				56	ref $q->{$p} eq "ARRAY" ? join $q->{'.sep'}, @{$q->{$p}} : $q->{$p};
	4					49
636							}
637	0			0		0	sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
	0					0
	0					0
	0					0
638	0			0		0	sub NEXTKEY { each %{$_[0]} }
	0					0
639	0			0		0	sub EXISTS { exists $_[0]->{$_[1]} }
640	0			0		0	sub DELETE { $_[0]->delete($_[1]) }
641	0			0		0	sub CLEAR { %{$_[0]} = () }
	0					0
642
643							sub append {
644	24			24	1	360	my ($self, $param, @p) = @_;
645	24	100				245	return () unless defined $param;
646
647							# set values using $q->append(-name=>'foo',-value=>'bar') syntax
648							# also allows for $q->append( 'foo', 'some', 'new', 'values' ) syntax
649	20	100				234	($param, undef, @p) = @p
650							if $param =~ m/^-name$/i; # undef represents -value token
651	20	100	66			422	$self->_add_param($param,
652							((defined $p[0] and ref $p[0]) ? $p[0] : [@p]));
653	20					219	return $self->param($param);
654							}
655
656							sub delete {
657	12			12	1	154	my ($self, $param) = @_;
658	12	100				409	return () unless defined $param;
659	8	50				136	$param =
660							$param =~ m/^-name$/i
661							? shift
662							: $param; # allow delete(-name=>'foo') syntax
663	8	50				101	return undef unless defined $self->{$param};
664	8					99	delete $self->{$param};
665	8					89	delete $self->{'.fieldnames'}->{$param};
666	26					371	$self->{'.parameters'} =
667	8					75	[grep { $_ ne $param } @{$self->{'.parameters'}}];
	8					105
668							}
669
670	8			8	0	107	sub Delete { CGI::Simple::delete(@_) } # for method style interface
671
672							sub delete_all {
673	6			6	1	84	my $self = shift;
674	6					52	undef %{$self};
	6					112
675	6					186	$self->_store_globals;
676							}
677
678	2			2	0	25	sub Delete_all { $_[0]->delete_all } # as used by CGI.pm
679
680							sub upload {
681	17			17	1	352	my ($self, $filename, $writefile) = @_;
682	17	100				175	unless ($filename) {
683	8	50				104	$self->cgi_error(
684							"No filename submitted for upload to $writefile")
685							if $writefile;
686	4					63	return $self->{'.filehandles'}
687	8	100				106	? keys %{$self->{'.filehandles'}}
688							: ();
689							}
690	9	100				155	unless ($ENV{'CONTENT_TYPE'} =~ m\|^multipart/form-data\|i) {
691	1					14	$self->cgi_error(
692							'Oops! File uploads only work if you specify ENCTYPE="multipart/form-data" in your <FORM> tag'
693							);
694	1					11	return undef;
695							}
696	8					87	my $fh = $self->{'.filehandles'}->{$filename};
697
698							# allow use of upload fieldname to get filehandle
699							# this has limitation that in the event of duplicate
700							# upload field names there can only be one filehandle
701							# which will point to the last upload file
702							# access by filename does not suffer from this issue.
703	8	50	66			298	$fh =
704							$self->{'.filehandles'}
705							->{$self->{'.upload_fields'}->{$filename}}
706							if !$fh and defined $self->{'.upload_fields'}->{$filename};
707
708	8	100				80	if ($fh) {
709	4					65	seek $fh, 0, 0; # get ready for reading
710	4	100				47	return $fh unless $writefile;
711	2					20	my $buffer;
712	2	50				216	unless (open OUT, ">$writefile") {
713	0					0	$self->cgi_error("500 Can't write to $writefile: $!\n");
714	0					0	return undef;
715							}
716	2					24	binmode OUT;
717	2					21	binmode $fh;
718	2					405	print OUT $buffer while read($fh, $buffer, 4096);
719	2					202	close OUT;
720	2					27	$self->{'.filehandles'}->{$filename} = undef;
721	2					23	undef $fh;
722	2					34	return 1;
723							} else {
724	4					62	$self->cgi_error(
725							"No filehandle for '$filename'. Are uploads enabled (\$DISABLE_UPLOADS = 0)? Is \$POST_MAX big enough?"
726							);
727	4					47	return undef;
728							}
729							}
730
731							sub upload_fieldnames {
732	0			0	0	0	my ($self) = @_;
733							return
734							wantarray
735	0					0	? (keys %{$self->{'.upload_fields'}})
	0					0
736	0	0				0	: [keys %{$self->{'.upload_fields'}}];
737							}
738
739							# return the file size of an uploaded file
740							sub upload_info {
741	0			0	1	0	my ($self, $filename, $info) = @_;
742	0	0				0	unless ($ENV{'CONTENT_TYPE'} =~ m\|^multipart/form-data\|i) {
743	0					0	$self->cgi_error(
744							'Oops! File uploads only work if you specify ENCTYPE="multipart/form-data" in your <FORM> tag'
745							);
746	0					0	return undef;
747							}
748	0	0				0	return keys %{$self->{'.tmpfiles'}} unless $filename;
	0					0
749	0	0				0	return $self->{'.tmpfiles'}->{$filename}->{'mime'}
750							if $info =~ /mime/i;
751	0					0	return $self->{'.tmpfiles'}->{$filename}->{'size'};
752							}
753
754	0			0	0	0	sub uploadInfo { &upload_info } # alias for CGI.pm compatibility
755
756							# return all params/values in object as a query string suitable for 'GET'
757							sub query_string {
758	50			50	0	518	my $self = shift;
759	50					434	my @pairs;
760	50					560	for my $param ($self->param) {
761	120					1218	for my $value ($self->param($param)) {
762	196	50				2013	next unless defined $value;
763	196					2059	push @pairs, $self->url_encode($param) . '='
764							. $self->url_encode($value);
765							}
766							}
767							return
768	50	100				1052	join $self->{'.globals'}->{'USE_PARAM_SEMICOLONS'} ? ';' : '&',
769							@pairs;
770							}
771
772							# new method that will add QUERY_STRING data to our CGI::Simple object
773							# if the REQUEST_METHOD was 'POST'
774							sub parse_query_string {
775	2			2	1	21	my $self = shift;
776	2	50	33			44	$self->_parse_params($ENV{'QUERY_STRING'})
777							if defined $ENV{'QUERY_STRING'}
778							and $ENV{'REQUEST_METHOD'} eq 'POST';
779							}
780
781							################ Save and Restore params from file ###############
782
783							sub _init_from_file {
784	7			7		65	my ($self, $fh) = @_;
785	7					90	local $/ = "\n";
786	7					411	while (my $pair = <$fh>) {
787	35					310	chomp $pair;
788	35	100				361	return if $pair eq '=';
789	28					289	$self->_parse_params($pair);
790							}
791							}
792
793							sub save {
794	4			4	1	194	my ($self, $fh) = @_;
795	4					53	local ($,, $\) = ('', '');
796	4	50	33			64	unless ($fh and fileno $fh) {
797	0					0	$self->cgi_error('Invalid filehandle');
798	0					0	return undef;
799							}
800	4					47	for my $param ($self->param) {
801	8					78	for my $value ($self->param($param)) {
802							;
803	16					155	print $fh $self->url_encode($param), '=',
804							$self->url_encode($value), "\n";
805							}
806							}
807	4					66	print $fh "=\n";
808							}
809
810	3			3	0	108	sub save_parameters { save(@_) } # CGI.pm alias for save
811
812							################ Miscellaneous Methods ################
813
814	4			4	1	67	sub parse_keywordlist { _parse_keywordlist(@_) } # CGI.pm compatibility
815
816							sub escapeHTML {
817	18			18	1	702	my ($self, $escape, $newlinestoo) = @_;
818	18					252	require CGI::Simple::Util;
819	18					218	$escape = CGI::Simple::Util::escapeHTML($escape);
820	18	100				194	$escape =~ s/([\012\015])/'&#'.(ord $1).';'/eg if $newlinestoo;
	8					103
821	18					2042	return $escape;
822							}
823
824							sub unescapeHTML {
825	104			104	1	1188	require CGI::Simple::Util;
826	104					1227	return CGI::Simple::Util::unescapeHTML($_[1]);
827							}
828
829	2			2	1	27	sub put { my $self = shift; $self->print(@_) } # send output to browser
	2					25
830
831							sub print {
832	3			3	1	26	shift;
833	3					46	CORE::print(@_);
834							} # print to standard output (for overriding in mod_perl)
835
836							################# Cookie Methods ################
837
838							sub cookie {
839	28			28	1	458	my ($self, @params) = @_;
840	28					388	require CGI::Simple::Cookie;
841	28					312	require CGI::Simple::Util;
842	28					461	my ($name, $value, $path, $domain, $secure, $expires) =
843							CGI::Simple::Util::rearrange([
844							'NAME', ['VALUE', 'VALUES'],
845							'PATH', 'DOMAIN',
846							'SECURE', 'EXPIRES'
847							],
848							@params
849							);
850
851							# retrieve the value of the cookie, if no value is supplied
852	28	100				668	unless (defined($value)) {
853	16	100				184	$self->{'.cookies'} = CGI::Simple::Cookie->fetch
854							unless $self->{'.cookies'};
855	16	50				157	return () unless $self->{'.cookies'};
856
857							# if no name is supplied, then retrieve the names of all our cookies.
858	16	100				149	return keys %{$self->{'.cookies'}} unless $name;
	4					66
859
860							# return the value of the cookie
861							return
862	12	100				176	exists $self->{'.cookies'}->{$name}
863							? $self->{'.cookies'}->{$name}->value
864							: ();
865							}
866
867							# If we get here, we're creating a new cookie
868	12	50				137	return undef unless $name; # this is an error
869	12					117	@params = ();
870	12					180	push @params, '-name' => $name;
871	12					111	push @params, '-value' => $value;
872	12	100				176	push @params, '-domain' => $domain if $domain;
873	12	100				137	push @params, '-path' => $path if $path;
874	12	100				118	push @params, '-expires' => $expires if $expires;
875	12	100				147	push @params, '-secure' => $secure if $secure;
876	12					164	return CGI::Simple::Cookie->new(@params);
877							}
878
879							sub raw_cookie {
880	12			12	1	164	my ($self, $key) = @_;
881	12	100				154	if (defined $key) {
882	8	100				192	unless ($self->{'.raw_cookies'}) {
883	2					64	require CGI::Simple::Cookie;
884	2					33	$self->{'.raw_cookies'} = CGI::Simple::Cookie->raw_fetch;
885							}
886	8		66			133	return $self->{'.raw_cookies'}->{$key} \|\| ();
887							}
888	4		33			78	return $ENV{'HTTP_COOKIE'} \|\| $ENV{'COOKIE'} \|\| '';
			50
889							}
890
891							################# Header Methods ################
892
893							sub header {
894	30			30	1	638	my ($self, @params) = @_;
895	30					410	require CGI::Simple::Util;
896	30					248	my @header;
897							return undef
898	30	50	66			465	if $self->{'.header_printed'}++
899							and $self->{'.globals'}->{'HEADERS_ONCE'};
900							my (
901	30					6812	$type, $status, $cookie, $target, $expires,
902							$nph, $charset, $attachment, $p3p, @other
903							)
904							= CGI::Simple::Util::rearrange([
905							['TYPE', 'CONTENT_TYPE', 'CONTENT-TYPE'], 'STATUS',
906							['COOKIE', 'COOKIES'], 'TARGET',
907							'EXPIRES', 'NPH',
908							'CHARSET', 'ATTACHMENT',
909							'P3P'
910							],
911							@params
912							);
913	30		66			431	$nph \|\|= $self->{'.globals'}->{'NPH'};
914	30					323	$charset =
915							$self->charset($charset)
916							; # get charset (and set new charset if supplied)
917							# rearrange() was designed for the HTML portion, so we need to fix it up a little.
918
919	30					388	for (@other) {
920
921							# Don't use \s because of perl bug 21951
922							next
923	12	50				465	unless my ($header, $value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/;
924							($_ = $header) =~
925	12					186	s/^(\w)(.*)/"\u$1\L$2" . ': '.$self->unescapeHTML($value)/e;
	12					235
926							}
927	30	100	50			416	$type \|\|= 'text/html' unless defined $type;
928	30	100	100			559	$type .= "; charset=$charset"
			66
929							if $type
930							and $type =~ m!^text/!
931							and $type !~ /\bcharset\b/;
932	30		50			401	my $protocol = $ENV{SERVER_PROTOCOL} \|\| 'HTTP/1.0';
933	30	100	100			560	push @header, $protocol . ' ' . ($status \|\| '200 OK') if $nph;
934	30	100				308	push @header, "Server: " . server_software() if $nph;
935	30	100				320	push @header, "Status: $status" if $status;
936	30	50				366	push @header, "Window-Target: $target" if $target;
937
938	30	50				331	if ($p3p) {
939	0	0				0	$p3p = join ' ', @$p3p if ref($p3p) eq 'ARRAY';
940	0					0	push(@header, qq(P3P: policyref="/w3c/p3p.xml", CP="$p3p"));
941							}
942
943							# push all the cookies -- there may be several
944	30	100				323	if ($cookie) {
945	2	50				36	my @cookie = ref $cookie eq 'ARRAY' ? @{$cookie} : $cookie;
	0					0
946	2					23	for my $cookie (@cookie) {
947	2	50				32	my $cs =
948							ref $cookie eq 'CGI::Simple::Cookie'
949							? $cookie->as_string
950							: $cookie;
951	2	50				41	push @header, "Set-Cookie: $cs" if $cs;
952							}
953							}
954
955							# if the user indicates an expiration time, then we need both an Expires
956							# and a Date header (so that the browser is using OUR clock)
957	30	100				324	$expires = 'now'
958							if $self->no_cache; # encourage no caching via expires now
959	30	100				394	push @header,
960							"Expires: " . CGI::Simple::Util::expires($expires, 'http')
961							if $expires;
962	30	100	66			608	push @header, "Date: " . CGI::Simple::Util::expires(0, 'http')
			100
963							if defined $expires \|\| $cookie \|\| $nph;
964	30	100	66			316	push @header, "Pragma: no-cache" if $self->cache or $self->no_cache;
965	30	100				293	push @header,
966							"Content-Disposition: attachment; filename=\"$attachment\""
967							if $attachment;
968	30					264	push @header, @other;
969	30	100				359	push @header, "Content-Type: $type" if $type;
970	30					301	my $CRLF = $self->crlf;
971	30					400	my $header = join $CRLF, @header;
972	30					272	$header .= $CRLF . $CRLF; # add the statutory two CRLFs
973
974	30	50	33			794	if ($self->{'.mod_perl'} and not $nph) {
975	0					0	my $r = $self->_mod_perl_request();
976	0					0	$r->send_cgi_header($header);
977	0					0	return '';
978							}
979	30					6509	return $header;
980							}
981
982							# Control whether header() will produce the no-cache Pragma directive.
983							sub cache {
984	34			34	1	331	my ($self, $value) = @_;
985	34	100				317	$self->{'.cache'} = $value if defined $value;
986	34					419	return $self->{'.cache'};
987							}
988
989							# Control whether header() will produce expires now + the no-cache Pragma.
990							sub no_cache {
991	56			56	1	501	my ($self, $value) = @_;
992	56	100				552	$self->{'.no_cache'} = $value if defined $value;
993	56					707	return $self->{'.no_cache'};
994							}
995
996							sub redirect {
997	10			10	1	131	my ($self, @params) = @_;
998	10					139	require CGI::Simple::Util;
999	10					4421	my ($url, $target, $cookie, $nph, @other) =
1000							CGI::Simple::Util::rearrange([
1001							['LOCATION', 'URI', 'URL'], 'TARGET',
1002							['COOKIE', 'COOKIES'], 'NPH'
1003							],
1004							@params
1005							);
1006	10		33			132	$url \|\|= $self->self_url;
1007	10					86	my @o;
1008	10					100	for (@other) { tr/\"//d; push @o, split "=", $_, 2; }
	4					38
	4					56
1009	10					127	unshift @o,
1010							'-Status' => '302 Moved',
1011							'-Location' => $url,
1012							'-nph' => $nph;
1013	10	50				101	unshift @o, '-Target' => $target if $target;
1014	10	50				97	unshift @o, '-Cookie' => $cookie if $cookie;
1015	10					105	unshift @o, '-Type' => '';
1016	10					86	my @unescaped;
1017	10	50				93	unshift(@unescaped, '-Cookie' => $cookie) if $cookie;
1018	10					125	return $self->header((map { $self->unescapeHTML($_) } @o),
	88					840
1019							@unescaped);
1020							}
1021
1022							################# Server Push Methods #################
1023							# Return a Content-Type: style header for server-push
1024							# This has to be NPH, and it is advisable to set $\| = 1
1025							# Credit to Ed Jordan <ed@fidalgo.net> and
1026							# Andrew Benham <adsb@bigfoot.com> for this section
1027
1028							sub multipart_init {
1029	6			6	1	104	my ($self, @p) = @_;
1030	9			9		2382	use CGI::Simple::Util qw(rearrange);
	9					93
	9					176
1031	6					93	my ($boundary, @other) = rearrange(['BOUNDARY'], @p);
1032	6		100			84	$boundary = $boundary \|\| '------- =_aaaaaaaaaa0';
1033	6					96	my $CRLF = $self->crlf; # get CRLF sequence
1034	6					58	my $warning =
1035							"WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY.";
1036	6					114	$self->{'.separator'} = "$CRLF--$boundary$CRLF";
1037	6					83	$self->{'.final_separator'} =
1038							"$CRLF--$boundary--$CRLF$warning$CRLF";
1039	6					62	my $type = 'multipart/x-mixed-replace;boundary="' . $boundary . '"';
1040	0					0	return $self->header(
1041							-nph => 1,
1042							-type => $type,
1043	6					81	map { split "=", $_, 2 } @other
1044							)
1045							. $warning
1046							. $self->multipart_end;
1047							}
1048
1049							sub multipart_start {
1050	6			6	1	91	my ($self, @p) = @_;
1051	9			9		186	use CGI::Simple::Util qw(rearrange);
	9					85
	9					136
1052	6					84	my ($type, @other) = rearrange(['TYPE'], @p);
1053	6					69	foreach (@other) { # fix return from rearange
1054	0	0				0	next unless my ($header, $value) = /([^\s=]+)=\"?(.+?)\"?$/;
1055	0					0	$_ = ucfirst(lc $header) . ': ' . unescapeHTML(1, $value);
1056							}
1057	6		100			94	$type = $type \|\| 'text/html';
1058	6					63	my @header = ("Content-Type: $type");
1059	6					55	push @header, @other;
1060	6					68	my $CRLF = $self->crlf; # get CRLF sequence
1061	6					121	return (join $CRLF, @header) . $CRLF . $CRLF;
1062							}
1063
1064	8			8	1	203	sub multipart_end { return $_[0]->{'.separator'} }
1065
1066	2			2	1	34	sub multipart_final { return $_[0]->{'.final_separator'} }
1067
1068							################# Debugging Methods ################
1069
1070							sub read_from_cmdline {
1071	2			2	0	19	my @words;
1072	2	50	33			78	if ($_[0]->{'.globals'}->{'DEBUG'} == 1 and @ARGV) {
		0
1073	2					23	@words = @ARGV;
1074							} elsif ($_[0]->{'.globals'}->{'DEBUG'} == 2) {
1075	0					0	require "shellwords.pl";
1076	0					0	print
1077							"(offline mode: enter name=value pairs on standard input)\n";
1078	0					0	chomp(my @lines = <STDIN>);
1079	0					0	@words = &shellwords(join " ", @lines);
1080							} else {
1081	0					0	return '';
1082							}
1083	2					20	@words = map { s/\\=/%3D/g; s/\\&/%26/g; $_ } @words;
	4					46
	4					43
	4					45
1084	2	50				46	return "@words" =~ m/=/ ? join '&', @words : join '+', @words;
1085							}
1086
1087							sub Dump {
1088	10			10	1	185	require Data::Dumper; # short and sweet way of doing it
1089	10					188	(my $dump = Data::Dumper::Dumper(@_)) =~
1090							tr/\000/0/; # remove null bytes cgi-lib.pl
1091	10					139	return '<pre>' . escapeHTML(1, $dump) . '</pre>';
1092							}
1093
1094	2			2	0	42	sub as_string { Dump(@_) } # CGI.pm alias for Dump()
1095
1096							sub cgi_error {
1097	10			10	1	134	my ($self, $err) = @_;
1098	10	100				133	if ($err) {
1099	5					53	$self->{'.cgi_error'} = $err;
1100	5	50				82	$self->{'.globals'}->{'FATAL'} == 1 ? croak $err
		50
1101							: $self->{'.globals'}->{'FATAL'} == 0 ? carp $err
1102							: return $err;
1103							}
1104	5					81	return $self->{'.cgi_error'};
1105							}
1106
1107							################# cgi-lib.pl Compatibility Methods #################
1108							# Lightly GOLFED but the original functionality remains. You can call
1109							# them using either: # $q->MethodName or CGI::Simple::MethodName
1110
1111	17	100		17		302	sub _shift_if_ref { shift if ref $_[0] eq 'CGI::Simple' }
1112
1113							sub ReadParse {
1114	6		66	6	0	82	my $q = &_shift_if_ref \|\| new CGI::Simple;
1115	6					65	my $pkg = caller();
1116	9			9		176	no strict 'refs';
	9					88
	9					131
1117	2					30	*in = @_
1118							? $_[0]
1119	6	100				73	: {"${pkg}::in"}; # set in to passed glob or export *in
1120	6					69	%in = $q->Vars;
1121	6					71	$in{'CGI'} = $q;
1122	6					113	return scalar %in;
1123							}
1124
1125							sub SplitParam {
1126	6			6	0	62	&_shift_if_ref;
1127	6	100				140	defined $_[0]
		50
1128							&& (wantarray ? split "\0", $_[0] : (split "\0", $_[0])[0]);
1129							}
1130
1131	2			2	0	24	sub MethGet { request_method() eq 'GET' }
1132
1133	2			2	0	59	sub MethPost { request_method() eq 'POST' }
1134
1135							sub MyBaseUrl {
1136	10			10	0	102	local $^W = 0;
1137	10	100				102	'http://'
1138							. server_name()
1139							. (server_port() != 80 ? ':' . server_port() : '')
1140							. script_name();
1141							}
1142
1143	2			2	0	23	sub MyURL { MyBaseUrl() }
1144
1145							sub MyFullUrl {
1146	4			4	0	44	local $^W = 0;
1147	4	100				41	MyBaseUrl()
1148							. $ENV{'PATH_INFO'}
1149							. ($ENV{'QUERY_STRING'} ? "?$ENV{'QUERY_STRING'}" : '');
1150							}
1151
1152							sub PrintHeader {
1153	2	50		2	0	34	ref $_[0] ? $_[0]->header() : "Content-Type: text/html\n\n";
1154							}
1155
1156							sub HtmlTop {
1157	3			3	0	33	&_shift_if_ref;
1158	3					52	"<html>\n<head>\n<title>$_[0]</title>\n</head>\n<body>\n<h1>$_[0]</h1>\n";
1159							}
1160
1161	2			2	0	30	sub HtmlBot { "</body>\n</html>\n" }
1162
1163	2			2	0	23	sub PrintVariables { &_shift_if_ref; &Dump }
	2					24
1164
1165	2			2	1	26	sub PrintEnv { &Dump(\%ENV) }
1166
1167	0			0	0	0	sub CgiDie { CgiError(@_); die @_ }
	0					0
1168
1169							sub CgiError {
1170	0			0	0	0	&_shift_if_ref;
1171	0	0				0	@_ = @_
1172							? @_
1173							: (
1174							"Error: script " . MyFullUrl() . " encountered fatal error\n");
1175	0					0	print PrintHeader(), HtmlTop(shift), (map { "<p>$_</p>\n" } @_),
	0					0
1176							HtmlBot();
1177							}
1178
1179							################ Accessor Methods ################
1180
1181	2			2	1	55	sub version { $VERSION }
1182
1183							sub nph {
1184	4	100		4	1	91	$_[0]->{'.globals'}->{'NPH'} = $_[1] if defined $_[1];
1185	4					67	return $_[0]->{'.globals'}->{'NPH'};
1186							}
1187
1188	4			4	1	49	sub all_parameters { $_[0]->param }
1189
1190							sub charset {
1191	36			36	1	471	require CGI::Simple::Util;
1192	36					471	$CGI::Simple::Util::UTIL->charset($_[1]);
1193							}
1194
1195							sub globals {
1196	16			16	1	313	my ($self, $global