File Coverage

blib/lib/CGI/Simple/Standard.pm

Criterion	Covered	Total	%
statement	69	76	90.8
branch	19	26	73.1
condition	5	6	83.3
subroutine	11	12	91.7
pod	0	1	0.0
total	104	121	86.0

line	stmt	bran	cond	sub	pod	time	code
1							package CGI::Simple::Standard;
2
3	3			3		41	use strict;
	3					26
	3					44
4	3			3		76	use CGI::Simple;
	3					30
	3					51
5	3			3		53	use Carp;
	3					27
	3					56
6	3					44	use vars qw( $VERSION $USE_CGI_PM_DEFAULTS $DISABLE_UPLOADS $POST_MAX
7							$NO_UNDEF_PARAMS $USE_PARAM_SEMICOLONS $HEADERS_ONCE
8	3			3		53	$NPH $DEBUG $NO_NULL $FATAL *in %EXPORT_TAGS $AUTOLOAD );
	3					30
9
10							%EXPORT_TAGS = (
11							':html' => [qw(:misc)],
12							':standard' => [qw(:core :access)],
13							':cgi' => [qw(:core :access)],
14							':all' => [
15							qw(:core :misc :cookie :header :push :debug :cgi-lib
16							:access :internal)
17							],
18							':core' => [
19							qw(param add_param param_fetch url_param keywords
20							append Delete delete_all Delete_all upload
21							query_string parse_query_string parse_keywordlist
22							Vars save_parameters restore_parameters)
23							],
24							':misc' => [qw(url_decode url_encode escapeHTML unescapeHTML put)],
25							':cookie' => [qw(cookie raw_cookie)],
26							':header' => [qw(header cache no_cache redirect)],
27							':push' => [
28							qw(multipart_init multipart_start multipart_end
29							multipart_final)
30							],
31							':debug' => [qw(Dump as_string cgi_error _cgi_object)],
32							':cgi-lib' => [
33							qw(ReadParse SplitParam MethGet MethPost MyBaseUrl MyURL
34							MyFullUrl PrintHeader HtmlTop HtmlBot PrintVariables
35							PrintEnv CgiDie CgiError Vars)
36							],
37							':ssl' => [qw(https)],
38							':access' => [
39							qw(version nph all_parameters charset crlf globals
40							auth_type content_length content_type document_root
41							gateway_interface path_translated referer remote_addr
42							remote_host remote_ident remote_user request_method
43							script_name server_name server_port server_protocol
44							server_software user_name user_agent virtual_host
45							path_info Accept http https protocol url self_url
46							state)
47							],
48							':internal' => [
49							qw(_initialize_globals _use_cgi_pm_global_settings
50							_store_globals _reset_globals)
51							]
52							);
53
54							BEGIN {
55	0					0	$SIG{__DIE__} = sub { croak "Undefined Method : @_\n" }
56	3			3		274	}
57
58							sub import {
59	3			3		94	my ($self, @args) = @_;
60	3					38	my $package = caller();
61	3					31	my (%exports, %pragmas);
62	3					35	for my $arg (@args) {
63	5	50				83	$exports{$arg}++, next if $arg =~ m/^\w+$/;
64	5	100				68	$pragmas{$arg}++, next if $arg =~ m/^-\w+$/;
65	3	50				62	if ($arg =~ m/^:[-\w]+$/) {
66	3	50				41	if (exists $EXPORT_TAGS{$arg}) {
67	3					27	my @tags = @{$EXPORT_TAGS{$arg}};
	3					48
68	3					30	for my $tag (@tags) {
69	27					395	my @expanded =
70							exists $EXPORT_TAGS{$tag}
71	27	50				1939	? @{$EXPORT_TAGS{$tag}}
72							: ($tag);
73	27					221	$exports{$_}++ for @expanded;
	27					642
74							}
75							} else {
76	0					0	croak
77							"No '$arg' tag set available for export from CGI::Simple::Standard!\n";
78							}
79							}
80							}
81	3					322	my @exports = keys %exports;
82	3					62	my %valid_exports;
83	3					30	for my $tag (@{$EXPORT_TAGS{':all'}}) {
	3					35
84	27					214	$valid_exports{$_}++ for @{$EXPORT_TAGS{$tag}};
	27					207
	27					647
85							}
86	3					31	for (@exports) {
87	261	50				2599	croak
88							"'$_' is not an available export method from CGI::Simple::Standard!\n"
89							unless exists $valid_exports{$_};
90							}
91	3			3		55	no strict 'refs';
	3					29
	3					47
92	3	50				47	if (exists $pragmas{'-autoload'}) {
93
94							# hack symbol table to export our AUTOLOAD sub
95	0					0	*{"${package}::AUTOLOAD"} = sub {
96	0			0		0	my ($caller, $sub) = $AUTOLOAD =~ m/(.*)::(\w+)$/;
97	0					0	&CGI::Simple::Standard::loader($caller, $sub, @_);
98	0					0	};
99	0					0	delete $pragmas{'-autoload'};
100							}
101	3					39	my @pragmas = keys %pragmas;
102	3	100				83	CGI::Simple->import(@pragmas) if @pragmas;
103
104							# export subroutine stubs for all the desired export functions
105							# we will replace them in the symbol table with the real thing
106							# if and when they are first called
107	3					44	for my $i (0 .. $#exports) {
108	261					8533	*{"${package}::$exports[$i]"} = sub {
109	136			136		3352	my $caller = caller;
110	136					2252	&CGI::Simple::Standard::loader($caller, $exports[$i], @_);
111							}
112	261					4367	}
113							}
114
115							# loader() may be called either via our exported AUTOLOAD sub or by the
116							# subroutine stubs we exported on request. It has three functions:
117							# 1) to initialize and store (via a closure) our CGI::Simple object
118							# 2) to overwrite the exported subroutine stubs with calls to the real ones
119							# 3) to provide two 'virtual' methods - _cgi_object() and restore_parameters()
120							# restore_parameters effectively functions like new() for the OO interface.
121							{
122							my $q;
123
124							sub loader {
125	136			136	0	1365	my $package = shift;
126	136					1817	my $sub = shift;
127	136	100				1677	if ($sub eq '_cgi_object') { # for debugging get at the object
128	3	50				32	$q = new CGI::Simple(@_) unless $q;
129	3					44	return $q;
130							}
131	133	100	100			3733	if (!$q or $sub eq 'restore_parameters') {
132	30	100				317	if ($sub eq 'restore_parameters') {
133	28					596	$q = new CGI::Simple(@_);
134	28					437	return;
135							} else {
136	2					32	$q = new CGI::Simple;
137							}
138							}
139
140							# hack the symbol table and insert the sub so we only use loader once
141							# get strict to look the other way while we use sym refs
142	3			3		51	no strict 'refs';
	3					29
	3					41
143
144							# stop warnings screaming about redefined subs
145	105					3506	local $^W = 0;
146
147							# hack to ensure %in ends in right package when exported by ReadParse
148	105	100	66			1237	@_ = (*{"${package}::in"}) if $sub eq 'ReadParse' and !@_;
	1					18
149
150							# write the required sub to the callers symbol table
151	105			312		1756	*{"${package}::$sub"} = sub { $q->$sub(@_) };
	105					1557
	312					7293
152
153							# now we have inserted the sub let's call it and return the results :-)
154	105					964	return &{"${package}::$sub"};
	105					1491
155							}
156							}
157
158							1;
159
160							=head1 NAME
161
162							CGI::Simple::Standard - a wrapper module for CGI::Simple that provides a
163							function style interface
164
165							=head1 SYNOPSIS
166
167							use CGI::Simple::Standard qw( -autoload );
168							use CGI::Simple::Standard qw( :core :cookie :header :misc );
169							use CGI::Simple::Standard qw( param upload );
170
171							$CGI::Simple::Standard::POST_MAX = 1024; # max upload via post 1kB
172							$CGI::Simple::Standard::DISABLE_UPLOADS = 0; # enable uploads
173
174							@params = param(); # return all param names as a list
175							$value = param('foo'); # return the first value supplied for 'foo'
176							@values = param('foo'); # return all values supplied for foo
177
178							%fields = Vars(); # returns untied key value pair hash
179							$hash_ref = Vars(); # or as a hash ref
180							%fields = Vars("\|"); # packs multiple values with "\|" rather than "\0";
181
182							@keywords = keywords(); # return all keywords as a list
183
184							param( 'foo', 'some', 'new', 'values' ); # set new 'foo' values
185							param( -name=>'foo', -value=>'bar' );
186							param( -name=>'foo', -value=>['bar','baz'] );
187
188							append( -name=>'foo', -value=>'bar' ); # append values to 'foo'
189							append( -name=>'foo', -value=>['some', 'new', 'values'] );
190
191							Delete('foo'); # delete param 'foo' and all its values
192							Delete_all(); # delete everything
193
194							<INPUT TYPE="file" NAME="upload_file" SIZE="42">
195
196							$files = upload() # number of files uploaded
197							@files = upload(); # names of all uploaded files
198							$filename = param('upload_file') # filename of 'upload_file' field
199							$mime = upload_info($filename,'mime'); # MIME type of uploaded file
200							$size = upload_info($filename,'size'); # size of uploaded file
201
202							my $fh = $q->upload($filename); # open filehandle to read from
203							while ( read( $fh, $buffer, 1024 ) ) { ... }
204
205							# short and sweet upload
206							$ok = upload( param('upload_file'), '/path/to/write/file.name' );
207							print "Uploaded ".param('upload_file')." and wrote it OK!" if $ok;
208
209							$decoded = url_decode($encoded);
210							$encoded = url_encode($unencoded);
211							$escaped = escapeHTML('<>"&');
212							$unescaped = unescapeHTML('<>"&');
213
214							$qs = query_string(); # get all data in $q as a query string OK for GET
215
216							no_cache(1); # set Pragma: no-cache + expires
217							print header(); # print a simple header
218							# get a complex header
219							$header = header( -type => 'image/gif'
220							-nph => 1,
221							-status => '402 Payment required',
222							-expires =>'+24h',
223							-cookie => $cookie,
224							-charset => 'utf-7',
225							-attachment => 'foo.gif',
226							-Cost => '$2.00');
227
228							@cookies = cookie(); # get names of all available cookies
229							$value = cookie('foo') # get first value of cookie 'foo'
230							@value = cookie('foo') # get all values of cookie 'foo'
231							# get a cookie formatted for header() method
232							$cookie = cookie( -name => 'Password',
233							-values => ['superuser','god','my dog woofie'],
234							-expires => '+3d',
235							-domain => '.nowhere.com',
236							-path => '/cgi-bin/database',
237							-secure => 1 );
238							print header( -cookie=>$cookie ); # set cookie
239
240							print redirect('http://go.away.now'); # print a redirect header
241
242							dienice( cgi_error() ) if cgi_error();
243
244							=head1 DESCRIPTION
245
246							This module is a wrapper for the completely object oriented CGI::Simple
247							module and provides a simple functional style interface. It provides two
248							different methods to import function names into your namespace.
249
250							=head2 Autoloading
251
252							If you specify the '-autoload' pragma like this:
253
254							use CGI::Simple::Standard qw( -autoload );
255
256							Then it will use AUTOLOAD and a symbol table trick to export only those subs
257							you actually call into your namespace. When you specify the '-autoload' pragma
258							this module exports a single AUTOLOAD subroutine into you namespace. This will
259							clash with any AUTOLOAD sub that exists in the calling namespace so if you are
260							using AUTOLOAD for something else don't use this pragma.
261
262							Anyway, when you call a subroutine that is not defined in your script this
263							AUTOLOAD sub will be called. The first time this happens it
264							will initialize a CGI::Simple object and then apply the requested method
265							(if it exists) to it. A fatal exception will be thrown if you try to use an
266							undefined method (function).
267
268							=head2 Specified Export
269
270							Alternatively you can specify the functions you wish to import. You can do
271							this on a per function basis like this:
272
273							use CGI::Simple::Standard qw( param upload query_string Dump );
274
275							or utilize the %EXPORT_TAGS that group functions into related groups.
276							Here are the groupings:
277
278							%EXPORT_TAGS = (
279							':html' => [ qw(:misc) ],
280							':standard' => [ qw(:core :access) ],
281							':cgi' => [ qw(:core :access) ],
282							':all' => [ qw(:core :misc :cookie :header :push :debug :cgi-lib
283							:access :internal) ],
284							':core' => [ qw(param add_param param_fetch url_param keywords
285							append Delete delete_all Delete_all upload
286							query_string parse_query_string parse_keywordlist
287							Vars save_parameters restore_parameters) ],
288							':misc' => [ qw(url_decode url_encode escapeHTML unescapeHTML put) ],
289							':cookie' => [ qw(cookie raw_cookie) ],
290							':header' => [ qw(header cache no_cache redirect) ],
291							':push' => [ qw(multipart_init multipart_start multipart_end
292							multipart_final) ],
293							':debug' => [ qw(Dump as_string cgi_error _cgi_object) ],
294							':cgi-lib' => [ qw(ReadParse SplitParam MethGet MethPost MyBaseUrl MyURL
295							MyFullUrl PrintHeader HtmlTop HtmlBot PrintVariables
296							PrintEnv CgiDie CgiError Vars) ],
297							':ssl' => [ qw(https) ],
298							':access' => [ qw(version nph all_parameters charset crlf globals
299							auth_type content_length content_type document_root
300							gateway_interface path_translated referer remote_addr
301							remote_host remote_ident remote_user request_method
302							script_name server_name server_port server_protocol
303							server_software user_name user_agent virtual_host
304							path_info Accept http https protocol url self_url
305							state) ],
306							':internal' => [ qw(_initialize_globals _use_cgi_pm_global_settings
307							_store_globals _reset_globals) ]
308							);
309
310
311							The familiar CGI.pm tags are available but do not include the HTML
312							functionality. You specify the import of some function groups like this:
313
314							use CGI::Simple::Standard qw( :core :cookie :header );
315
316							Note that the function groups all start with a : char.
317
318							=head2 Mix and Match
319
320							You can use the '-autoload' pragma, specifically named function imports and
321							tag group imports together if you desire.
322
323							=head1 $POST_MAX and $DISABLE_UPLOADS
324
325							If you wish to set $POST_MAX or $DISABLE_UPLOADS you must do this after the
326							use statement and before the first function call as shown in the synopsis.
327
328							Unlike CGI.pm uploads are disabled by default and the maximum acceptable
329							data via post is capped at 102_400kB rather than infinity. This is specifically
330							to avoid denial of service attacks by default. To enable uploads and to
331							allow them to be of infinite size you simply:
332
333							$CGI::Simple::Standard::POST_MAX = -1; # infinite size upload
334							$CGI::Simple::Standard::$DISABLE_UPLOADS = 0; # enable uploads
335
336							Alternatively you can specify the CGI.pm default values as shown above by
337							specifying the '-default' pragma in your use statement.
338
339							use CGI::Simple::Standard qw( -default ..... );
340
341							=head1 EXPORT
342
343							Nothing by default.
344
345							Under the '-autoload' pragma the AUTOLOAD subroutine is
346							exported into the calling namespace. Additional subroutines are only imported
347							into this namespace if you physically call them. They are installed in the
348							symbol table the first time you use them to save repeated calls to AUTOLOAD.
349
350							If you specifically request a function or group of functions via an EXPORT_TAG
351							then stubs of these functions are exported into the calling namespace. These
352							stub functions will be replaced with the real functions only if you actually
353							call them saving wasted compilation effort.
354
355							=head1 FUNCTION DETAILS
356
357							This is a wrapper module for CGI::Simple. Virtually all the methods available
358							in the OO interface are available via the functional interface. Several
359							method names are aliased to prevent namespace conflicts:
360
361							$q->delete('foo') => Delete('foo')
362							$q->delete_all => Delete_all() or delete_all()
363							$q->save(\FH) => save_parameters(\FH)
364							$q->accept() => Accept()
365
366							Although you could use the new() function to genrate new OO CGI::Simple
367							objects the restore_parameters() function is a better choice as it operates
368							like new but on the correct underlying CGI::Simple object for the functional
369							interface.
370
371							restore_parameters() can be used exactly as you might use new() in that
372							you can supply arguments to it such as query strings, hashes and file handles
373							to re-initialize your underlying object.
374
375							$q->new CGI::Simple() => restore_parameters()
376							$q->new CGI::Simple({foo=>'bar'}) => restore_parameters({foo=>'bar'})
377							$q->new CGI::Simple($query_string) => restore_parameters($query_string)
378							$q->new CGI::Simple(\FH) => restore_parameters(\FH)
379
380							For full details of the available functions see the CGI::Simple docs. Just
381							remove the $q-> part and use the method name directly.
382
383							=head1 BUGS
384						&nb