local-lib5/lib/perl5/CGI/Simple/Standard.pm

   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('&lt;&gt;&quot;&amp;');
 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