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