"Fossies" - the Fresh Open Source Software Archive

Member "CGI-Lite-3.02/lib/CGI/Lite.pm" (19 May 2018, 35376 Bytes) of package /linux/www/CGI-Lite-3.02.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "Lite.pm" see the Fossies "Dox" file reference documentation and the latest Fossies "Diffs" side-by-side code changes report: 3.01_vs_3.02.

    1 ##++
    2 ##     CGI Lite v3.02
    3 ##
    4 ##     see separate CHANGES file for detailed history
    5 ##
    6 ##     Changes in versions 2.03 and newer copyright (c) 2014-2015 Pete Houston
    7 ##
    8 ##     Copyright (c) 1995, 1996, 1997 by Shishir Gundavaram
    9 ##     All Rights Reserved
   10 ##
   11 ##     Permission  to  use,  copy, and distribute is hereby granted,
   12 ##     providing that the above copyright notice and this permission
   13 ##     appear in all copies and in supporting documentation.
   14 ##--
   15 
   16 ###############################################################################
   17 
   18 =head1 NAME
   19 
   20 CGI::Lite - Process and decode WWW forms and cookies
   21 
   22 =head1 SYNOPSIS
   23 
   24     use CGI::Lite ();
   25 
   26     my $cgi = CGI::Lite->new ();
   27 
   28     $cgi->set_directory ('/some/dir') or die "Directory cannot be set.\n";
   29     $cgi->add_mime_type ('text/csv');
   30 
   31     my $cookies = $cgi->parse_cookies;
   32     my $form    = $cgi->parse_new_form_data;
   33 
   34     my $status  = $cgi->is_error;
   35     if ($status) {
   36         my $message = $cgi->get_error_message;
   37         die $message;
   38     }
   39 
   40 =head1 DESCRIPTION
   41 
   42 This module can be used to decode form data, query strings, file uploads
   43 and cookies in a very simple manner.
   44 
   45 It has only one dependency and is therefore relatively fast to
   46 instantiate. This makes it well suited to a non-persistent CGI scenario.
   47 
   48 =head1 METHODS
   49 
   50 Here are the methods used to process the forms and cookies:
   51 
   52 
   53 
   54 =head2 new
   55 
   56 The constructor takes no arguments and returns a new CGI::Lite object.
   57 
   58 =head2 parse_form_data
   59 
   60 This handles the following types of requests: GET, HEAD and POST.
   61 By default, CGI::Lite uses the environment variable REQUEST_METHOD to 
   62 determine the manner in which the query/form information should be 
   63 decoded. However, it may also be passed a valid request 
   64 method as a scalar string to force CGI::Lite to decode the information in 
   65 a specific manner. 
   66 
   67     my $params = $cgi->parse_form_data ('GET');
   68 
   69 For multipart/form-data, uploaded files are stored in the user selected 
   70 directory (see L<set_directory|/set_directory>). If timestamp mode is on (see 
   71 L<add_timestamp|/add_timestamp>), the files are named in the following format:
   72 
   73     timestamp__filename
   74 
   75 where the filename is specified in the "Content-disposition" header.
   76 I<NOTE:>, the browser URL encodes the name of the file. This module
   77 makes I<no> effort to decode the information for security reasons.
   78 However, this can be achieved by creating a subroutine and then using
   79 the L<filter_filename|/filter_filename> method.
   80 
   81 Returns either a hash or a reference to the hash, which contains
   82 all of the key/value pairs. For fields that contain file information,
   83 the value contains either the path to the file, or the filehandle 
   84 (see the L<set_file_type|/set_file_type> method).
   85 
   86 =head2 parse_new_form_data
   87 
   88 As for parse_form_data, but clears the CGI object state before processing 
   89 the request. This is useful in persistent applications (e.g. FCGI), where
   90 the CGI object is reused for multiple requests. e.g.
   91 
   92     my $CGI = CGI::Lite->new ();
   93     while (FCGI::accept > 0)
   94     {
   95         my $query = $CGI->parse_new_form_data ();
   96         # process query
   97     }
   98 
   99 =head2 parse_cookies
  100 
  101 Decodes and parses cookies passed by the browser. This method works in 
  102 much the same manner as L<parse_form_data|/parse_form_data>. As these two data sources
  103 are treated the same internally, users who wish to extract form and
  104 cookie data separately might find it easiest to call
  105 parse_cookies first and then parse_new_form_data in order to retrieve
  106 two distinct hashes (or hashrefs).
  107 
  108 =head2 is_error
  109 
  110 This method is used to check for any potential errors after calling
  111 either L<parse_form_data|/parse_form_data> or L<parse_cookies|/parse_cookies>.
  112 
  113     my $form = $cgi->parse_form_data ();
  114     my $went_wrong = $cgi->is_error ();
  115 
  116 Returns 0 if there is no error, 1 otherwise.
  117 
  118 =head2 get_error_message
  119 
  120 If an error occurs when parsing form/query information or cookies, this
  121 method may be used to retrieve the error message. Remember, the presence
  122 of any errors can be checked by calling the L<is_error|/is_error> method.
  123 
  124     my $msg = $cgi->get_error_message ();
  125 
  126 Returns the error message as a plain text string.
  127 
  128 =head2 set_platform
  129 
  130 This method is used to set the platform on which the web server is
  131 running. CGI::Lite uses this information to translate end-of-line
  132 (EOL) characters for uploaded files (see the L<add_mime_type|/add_mime_type> and
  133 L<remove_mime_type|/remove_mime_type> methods) so that they are accounted for properly on
  134 that platform.
  135 
  136     $cgi->set_platform ($platform);
  137 
  138 $platform can be any of (case insensitive):
  139 
  140     Unix                                  EOL: \012      = \n
  141     Windows, Windows95, DOS, NT, PC       EOL: \015\012  = \r\n
  142     Mac or Macintosh                      EOL: \015      = \r
  143 
  144 "Unix" is the default.
  145 
  146 Returns undef.
  147 
  148 =head2 set_size_limit
  149 
  150 To set a specific limit on the total size of the request (in bytes) call
  151 this method with that size as the sole argument. A size of zero
  152 effectively disables POST requests. To specify an unlimited size (the
  153 default) use an argument of -1.
  154 
  155     my $size_limit = $cgi->set_size_limit (10_000_000);
  156 
  157 Returns the new value if provided, otherwise the existing value.
  158 
  159 =head2 deny_uploads
  160 
  161 To prevent any file uploads simply call this method with an argument of
  162 1. To enable them again, use an argument of zero.
  163 
  164     my $deny_uploads = $cgi->deny_uploads (1);
  165 
  166 Returns the new value if provided, otherwise the existing value.
  167 
  168 =head2 force_unique_cookies
  169 
  170 It is generally considered a mistake to send an HTTP request with
  171 multiple cookies of the same name. However, the RFC is somewhat vague
  172 regarding how servers are expected to handle such an eventuality.
  173 CGI::Lite has always allowed such multiple values and returned them as
  174 an arrayref to be entirely consistent with the same treatment of
  175 form/query data.
  176 
  177 To override the default behaviour this method may be called with a
  178 single integer argument before the call to L<parse_cookies|/parse_cookies>. An argument
  179 of 1 means that the first cookie value will be used and the others
  180 discarded. An argument of 2 means that the last cookie value will be
  181 used and the others discarded. An argument of 3 means that an arrayref
  182 will be returned as usual but an error raised to indicate the situation.
  183 An argument of 0 (or any other value) sets it back to the default.
  184 
  185     $cgi->force_unique_cookies (1);
  186     $cgi->parse_cookies;
  187 
  188 Note that if there is already an item of data in the CGI::Lite object
  189 which matches the name of a cookie then the subsequent L<parse_cookies|/parse_cookies>
  190 call will treat the new cookie value as another data item and the resulting
  191 behaviour will be affected by this method. This is another reason to
  192 call L<parse_cookies|/parse_cookies> before L<parse_form_data|/parse_form_data>.
  193 
  194 Returns the new value if provided, otherwise the existing value.
  195 
  196 =head2 set_directory
  197 
  198 Used to set the directory where the uploaded files will be stored 
  199 (only applies to the I<multipart/form-data> encoding scheme).
  200 
  201     my $tmpdir = '/some/dir';
  202     $cgi->set_directory ($tmpdir) or
  203         die "Directory $tmpdir cannot be used.\n";
  204 
  205 This function should be called I<before> L<parse_form_data|/parse_form_data>, 
  206 or else the directory defaults to "/tmp". If the application cannot 
  207 write to the directory for whatever reason, an error status is returned.
  208 
  209 Returns 0 on error, 1 otherwise.
  210 
  211 =head2 close_all_files
  212 
  213     $cgi->close_all_files;
  214 
  215 All uploaded files that are opened as a result of calling L<set_file_type|/set_file_type>
  216 with the "handle" argument can be closed in one shot by calling this
  217 method which takes no arguments and returns undef.
  218 
  219 =head2 add_mime_type
  220 
  221 By default, EOL characters are translated for all uploaded files
  222 with specific MIME types (i.e. text/plain, text/html, etc.).
  223 This method can be used to add to the list of MIME types. For example,
  224 if you want CGI::Lite to translate EOL characters for uploaded
  225 files of I<application/mac-binhex40>, then you would do this:
  226 
  227     $cgi->add_mime_type ('application/mac-binhex40');
  228 
  229 Returns 1 if this MIME type is newly added, 0 otherwise.
  230 
  231 =head2 remove_mime_type
  232 
  233 This method is the converse of L<add_mime_type|/add_mime_type>. It allows for the
  234 removal of a particular MIME type. For example, if you do not want 
  235 CGI::Lite to translate EOL characters for uploaded files of type I<text/html>, 
  236 then you would do this:
  237 
  238     $cgi->remove_mime_type ('text/html');
  239 
  240 Returns 1 if this MIME type is newly deleted, 0 otherwise.
  241 
  242 =head2 get_mime_types
  243 
  244 Returns the list of the 
  245 MIME types for which EOL translation is performed.
  246 
  247     my @mimelist = $cgi->get_mime_types ();
  248 
  249 =head2 get_upload_type
  250 
  251 Returns the MIME type of uploaded data. Takes the field name as a scalar
  252 argument. This previously undocumented function was named print_mime_type
  253 prior to version 3.0.
  254 
  255     my $this_type = $cgi->get_upload_type ($field);
  256 
  257 Returns the MIME type as a scalar string if single valued, an arrayref
  258 if multi-valued or undef if the argument does not exist or has no type.
  259 
  260 =head2 set_file_type
  261 
  262 The I<names> of uploaded files are returned by default when
  263 the L<parse_form_data|/parse_form_data> method is called . But if this method is passed the string "handle" as its argument beforehand then
  264 the I<handles> to the files are returned instead. However, the name
  265 of each handle still corresponds to the filename.
  266 
  267     # $fh has been set to one of 'handle' or 'file'
  268     $cgi->set_file_type ($fh);
  269 
  270 This function should be called I<before> any call to L<parse_form_data|/parse_form_data>, or 
  271 else it will have no effect.
  272 
  273 =head2 add_timestamp
  274 
  275 By default, a timestamp is added to the front of uploaded files. 
  276 However, there is the option of completely turning off timestamp mode
  277 (value 0), or adding a timestamp only for existing files (value 2).
  278 
  279     $cgi->add_timestamp ($tsflag);  
  280     # where $tsflag takes one of these values
  281     #       0 = no timestamp
  282     #       1 = timestamp all files (default)
  283     #       2 = timestamp only if file exists
  284 
  285 =head2 filter_filename
  286 
  287 This method is used to change the manner in which uploaded
  288 files are named. For example, if you want uploaded filenames
  289 to be all upper case, you can use the following code:
  290 
  291     $cgi->filter_filename (\&make_uppercase);
  292     $cgi->parse_form_data;
  293 
  294     # ...
  295 
  296     sub make_uppercase
  297     {
  298         my $file = shift;
  299 
  300         $file =~ tr/a-z/A-Z/;
  301         return $file;
  302     }
  303 
  304 This method is perhaps best used to sanitise filenames for a specific
  305 O/S or filesystem e.g. by removing spaces or leading hyphens, etc.
  306 
  307 =head2 set_buffer_size
  308 
  309 This method allows fine-grained control of the buffer size used internally
  310 when dealing with multipart form data. However, the I<actual> buffer
  311 size that the algorithm uses I<can> be up to 3x the value specified
  312 as the argument. This ensures that boundary strings are not "split"
  313 between multiple reads. So, take this into consideration when setting
  314 the buffer size.
  315 
  316     my $size = $cgi->set_buffer_size (4096);
  317 
  318 The buffer size may not be set below 256 bytes nor above the total amount 
  319 of multipart form data. The default value is 1024 bytes. 
  320 
  321 Returns the buffer size.
  322 
  323 =head2 get_ordered_keys
  324 
  325 Returns either a reference to an array or an array itself consisting
  326 of the form fields/cookies in the order they were parsed.
  327 
  328     my $keys = $cgi->get_ordered_keys;
  329     my @keys = $cgi->get_ordered_keys;
  330 
  331 =head2 print_data
  332 
  333 Displays all the key/value pairs (either form data or cookie information)
  334 in an ordered fashion to standard output. It is mainly useful for
  335 debugging. There are no arguments and no return values.
  336 
  337 =head2 wrap_textarea
  338 
  339 This is a method to wrap a long string into one that is separated by EOL
  340 characters (see L<set_platform|/set_platform>) at fixed lengths.  The two arguments
  341 to be passed to this method are the string and the length at which the
  342 line separator is to be added.
  343 
  344     my $new_string = $cgi->wrap_textarea ($string, $length);
  345 
  346 Returns the modified string.
  347 
  348 =head2 get_multiple_values
  349 
  350 The values returned by the parsing methods in this module for multiple
  351 fields with the same name are given as array references. This utility
  352 method exists to convert either a scalar value or an array reference
  353 into a list thus removing the need for the user to determine whether the
  354 returned value for any field is a reference or a scalar.
  355 
  356     @all_values = $cgi->get_multiple_values ($reference);
  357 
  358 It is only provided as a convenience to the user and is not used
  359 internally by the module itself.
  360 
  361 Returns a list consisting of the multiple values.
  362 
  363 =head2 browser_escape
  364 
  365 Certain characters have special significance within HTML. These
  366 characters are: <, >, &, ", # and %. To display these "special"
  367 characters, they can be escaped using the following notation "&#NNN;"
  368 where NNN is their ASCII code.  This utility method does just that.
  369 
  370     $escaped_string = $cgi->browser_escape ($string);
  371 
  372 Returns the escaped string.
  373 
  374 =head2 url_encode
  375 
  376 This method will URL-encode a string passed as its argument. It may be
  377 used to encode any data to be passed as a query string to a CGI
  378 application, for example.
  379 
  380     $encoded_string = $cgi->url_encode ($string);
  381 
  382 Returns the URL-encoded string.
  383 
  384 =head2 url_decode
  385 
  386 This method is used to URL-decode a string. 
  387 
  388     $decoded_string = $cgi->url_decode ($string);
  389 
  390 Returns the URL-decoded string.
  391 
  392 =head2 is_dangerous
  393 
  394 This method checks for the existence of dangerous meta-characters.
  395 
  396     $status = $cgi->is_dangerous ($string);
  397 
  398 Returns 1 if such characters are found, 0 otherwise.
  399 
  400 
  401 
  402 =head1 DEPRECATED METHODS
  403 
  404 The following methods and subroutines are deprecated. Please do not use
  405 them in new code and consider excising them from old code. They will be
  406 removed in a future release.
  407 
  408 =over 4
  409 
  410 =item B<return_error>
  411 
  412     $cgi->return_error ('error 1', 'error 2', 'error 3');
  413 
  414 You can use this method to print errors to standard output (ie. as part of
  415 the HTTP response) and exit. B<This method is deprecated as of version 3.0.>
  416 The same functionality can be achieved with:
  417 
  418     print ('error 1', 'error 2', 'error 3');
  419     exit 1;
  420 
  421 =item B<create_variables>
  422 
  423 B<This method is deprecated as of version 3.0.> It runs contrary to the
  424 principles of structured programming and has really nothing to do with
  425 CGI form or cookie handling. It is retained here for backwards
  426 compatibility but will be removed entirely in later versions.
  427 
  428     %form = ('name'   => 'alan wells',
  429              'sport'  => 'track and field',
  430              'events' => '100m');
  431 
  432     $cgi->create_variables (\%hash);
  433 
  434 This converts a hash ref into scalars named for its keys and this
  435 example will create three scalar variables: $name, $sport and $events. 
  436 
  437 =back
  438 
  439 =head1 OBSOLETE METHODS/SUBROUTINES
  440 
  441 The following methods and subroutines were deprecated in the 2.x branch
  442 and have now been removed entirely from the module.
  443 
  444 =over 4
  445 
  446 =item B<escape_dangerous_chars>
  447 
  448 The use of this subroutine had been strongly discouraged for more than a
  449 decade (See
  450 L<https://web.archive.org/web/20100627014535/http://use.perl.org/~cbrooks/journal/10542>
  451 and L<http://www.securityfocus.com/archive/1/311414> for an
  452 advisory by Ronald F. Guilmette.) It has been removed as of version 3.0.
  453 
  454 =item B<print_form_data>
  455 
  456 Use L<print_data|/print_data> instead.
  457 
  458 =item B<print_cookie_data>
  459 
  460 Use L<print_data|/print_data> instead.
  461 
  462 =back
  463 
  464 Compatibility note: in 2.x and older versions the following were to be used as
  465 subroutines rather than methods:
  466 
  467 =over 4
  468 
  469 =item browser_escape
  470 
  471 =item url_encode
  472 
  473 =item url_decode
  474 
  475 =item is_dangerous
  476 
  477 =back
  478 
  479 They will still work as such and are still exported
  480 by default. Users are encouraged to migrate to the new method calls
  481 instead as both the export and subroutine interface will be retired in
  482 future. Non-method use currently triggers a warning.
  483 
  484 =head1 VERSIONS
  485 
  486 This module maintained backwards compatibility with versions of
  487 Perl back to 5.002 for a very long time. Such stability is a welcome
  488 attribute but it restricts the code by disallowing access to features
  489 introduced into the language since 1996.
  490 
  491 With this in mind, there are two maintained branches of this module going
  492 forwards. The 2.x branch will retain the backwards compatibility but
  493 will not have any new features introduced. Changes to this legacy branch
  494 will be bug fixes only. The new 3.x branch will be the main release and
  495 will require a more modern perl (5.6.0 is now the bare minimum). The
  496 3.x branch has new features and has removed some of the legacy code
  497 including some methods which had been deprecated for more than a decade.
  498 The attention of users wishing to upgrade from 2.x to 3.x is drawn to
  499 the L</DEPRECATED METHODS> and L</OBSOLETE METHODS/SUBROUTINES> sections of this
  500 document.
  501 
  502 Requests for new features in the 3.x branch should be made via
  503 the request tracker at L<https://rt.cpan.org/Public/Dist/Display.html?Name=CGI-Lite>
  504 
  505 =head1 SEE ALSO
  506 
  507 If you're looking for more comprehensive CGI modules, you can either use
  508 the CGI::* modules or L<CGI.pm|CGI>. 
  509 
  510 L<CGI::Lite::Request> uses some similar method names to CGI.pm thus allowing
  511 easy transition between the two. It uses CGI::Lite as a dependency.
  512 
  513 L<CGI::Simple>, L<CGI::Minimal> and L<CGI::Thin> are alternative
  514 lightweight CGI implementations.
  515 
  516 =head1 REPOSITORY
  517 
  518 L<https://github.com/openstrike/perl-CGI-Lite>
  519 
  520 =head1 MAINTAINER
  521 
  522 Maintenance of this module as of May 2014 has been taken over by Pete Houston
  523 <cpan@openstrike.co.uk>.
  524 
  525 =head1 ACKNOWLEDGMENTS
  526 
  527 The author (Shishir) thanks the following for finding bugs
  528 and offering suggestions:
  529 
  530 =over 4
  531 
  532 =item Eric D. Friedman (friedman@uci.edu)   
  533 
  534 =item Thomas Winzig (tsw@pvo.com)
  535 
  536 =item Len Charest (len@cogent.net)
  537 
  538 =item Achim Bohnet (ach@rosat.mpe-garching.mpg.de)
  539 
  540 =item John E. Townsend (John.E.Townsend@BST.BLS.com)
  541 
  542 =item Andrew McRae (mcrae@internet.com)
  543 
  544 =item Dennis Grant (dg50@chrysler.com)
  545 
  546 =item Scott Neufeld (scott.neufeld@mis.ussurg.com)
  547 
  548 =item Raul Almquist (imrs@ShadowMAC.org)
  549 
  550 =item and many others!
  551 
  552 =back
  553 
  554 The present maintainer wishes to thank the previous maintainers:
  555 Smylers, Andreas, Ben and Shishir.
  556 
  557 =head1 COPYRIGHT INFORMATION
  558     
  559 Copyright (c) 1995, 1996, 1997 by Shishir Gundavaram.
  560 All Rights Reserved.
  561 
  562 Changes in versions 2.03 onwards are copyright 2014, 2015 by Pete Houston.
  563 
  564 Permission to use, copy, and  distribute  is  hereby granted,
  565 providing that the above copyright notice and this permission
  566 appear in all copies and in supporting documentation.
  567 
  568 =head1 LICENCE
  569 
  570 This program is free software; you can redistribute it and/or modify it
  571 under the same terms as Perl itself.
  572 
  573 =cut
  574 
  575 ###############################################################################
  576 
  577 package CGI::Lite;
  578 
  579 use strict;
  580 use warnings;
  581 
  582 require 5.6.0;
  583 
  584 use Symbol;    # For _create_handles and create_variables
  585 
  586 ##++
  587 ## Global Variables
  588 ##--
  589 
  590 BEGIN {
  591     our @ISA    = 'Exporter';
  592     our @EXPORT = qw/browser_escape url_encode url_decode is_dangerous/;
  593 }
  594 
  595 our $VERSION = '3.02';
  596 
  597 ##++
  598 ##  Start
  599 ##--
  600 
  601 sub new
  602 {
  603     my $class = shift;
  604 
  605     my $self = {
  606         multipart_dir   => '/tmp',
  607         file_type       => 'name',
  608         platform        => 'Unix',
  609         buffer_size     => 1024,
  610         timestamp       => 1,
  611         filter          => undef,
  612         web_data        => {},
  613         ordered_keys    => [],
  614         all_handles     => [],
  615         error_status    => 0,
  616         error_message   => undef,
  617         file_size_limit => 2097152,    # Unused as yet
  618         size_limit      => -1,
  619         deny_uploads    => 0,
  620         unique_cookies  => 0,
  621     };
  622 
  623     $self->{convert} = {
  624         'text/html'  => 1,
  625         'text/plain' => 1
  626     };
  627 
  628     $self->{file} = {Unix => '/',    Mac => ':',    PC => '\\'};
  629     $self->{eol}  = {Unix => "\012", Mac => "\015", PC => "\015\012"};
  630 
  631     bless ($self, $class);
  632     return $self;
  633 }
  634 
  635 sub Version
  636 {
  637     return $VERSION;
  638 }
  639 
  640 sub deny_uploads
  641 {
  642     my ($self, $newval) = @_;
  643     if (defined $newval) {
  644         $self->{deny_uploads} = $newval ? 1 : 0;
  645     }
  646     return $self->{deny_uploads};
  647 }
  648 
  649 sub set_size_limit
  650 {
  651     my ($self, $limit) = @_;
  652     return unless defined $limit;
  653     if ($limit =~ /^[0-9]+$/) {
  654         $self->{size_limit} = $limit;
  655     } else {
  656         $self->{size_limit} = -1;
  657     }
  658     return $self->{size_limit};
  659 }
  660 
  661 sub set_directory
  662 {
  663     my ($self, $directory) = @_;
  664 
  665     return 0 unless $directory;
  666     stat ($directory);
  667 
  668     if ((-d _) && (-r _) && (-w _)) {
  669         $self->{multipart_dir} = $directory;
  670         return (1);
  671 
  672     } else {
  673         return (0);
  674     }
  675 }
  676 
  677 sub add_mime_type
  678 {
  679     my ($self, $mime_type) = @_;
  680 
  681     if ($mime_type and not exists $self->{convert}->{$mime_type}) {
  682         return $self->{convert}->{$mime_type} = 1;
  683     }
  684     return 0;
  685 }
  686 
  687 sub remove_mime_type
  688 {
  689     my ($self, $mime_type) = @_;
  690 
  691     if ($self->{convert}->{$mime_type}) {
  692         delete $self->{convert}->{$mime_type};
  693         return (1);
  694 
  695     } else {
  696         return (0);
  697     }
  698 }
  699 
  700 sub get_mime_types
  701 {
  702     my $self = shift;
  703 
  704     return (sort keys %{$self->{convert}});
  705 }
  706 
  707 sub set_platform
  708 {
  709     my ($self, $platform) = @_;
  710 
  711     return unless defined $platform;
  712     if ($platform =~ /^(?:PC|NT|Windows(?:95)?|DOS)/i) {
  713         $self->{platform} = 'PC';
  714     } elsif ($platform =~ /^Mac(?:intosh)?/i) {
  715         $self->{platform} = 'Mac';
  716     } else {
  717         $self->{platform} = 'Unix';
  718     }
  719 }
  720 
  721 sub set_file_type
  722 {
  723     my ($self, $type) = @_;
  724 
  725     if ($type =~ /^handle$/i) {
  726         $self->{file_type} = 'handle';
  727     } else {
  728         $self->{file_type} = 'name';
  729     }
  730 }
  731 
  732 sub add_timestamp
  733 {
  734     my ($self, $value) = @_;
  735 
  736     unless ($value == 0 or $value == 1 or $value == 2) {
  737         $self->{timestamp} = 1;
  738     } else {
  739         $self->{timestamp} = $value;
  740     }
  741 }
  742 
  743 sub force_unique_cookies
  744 {
  745     my ($self, $value) = @_;
  746 
  747     if (defined $value) {
  748         if ($value =~ /^[1-3]$/) {
  749             $self->{unique_cookies} = $value;
  750         } else {
  751             $self->{unique_cookies} = 0;
  752         }
  753     }
  754     return $self->{unique_cookies};
  755 }
  756 
  757 sub filter_filename
  758 {
  759     my ($self, $subroutine) = @_;
  760 
  761     $self->{filter} = $subroutine;
  762 }
  763 
  764 sub set_buffer_size
  765 {
  766     my ($self, $buffer_size) = @_;
  767     my $content_length;
  768 
  769     $content_length = $ENV{CONTENT_LENGTH} || return (0);
  770 
  771     if ($buffer_size < 256) {
  772         $self->{buffer_size} = 256;
  773     } elsif ($buffer_size > $content_length) {
  774         $self->{buffer_size} = $content_length;
  775     } else {
  776         $self->{buffer_size} = $buffer_size;
  777     }
  778 
  779     return ($self->{buffer_size});
  780 }
  781 
  782 sub parse_new_form_data
  783 
  784 # Reset state before parsing (for persistant CGI objects, e.g. under FastCGI)
  785 # BDL
  786 {
  787     my ($self, @param) = @_;
  788 
  789     # close files (should happen anyway when 'all_handles' is cleared...)
  790     $self->close_all_files ();
  791 
  792     $self->{web_data}      = {};
  793     $self->{ordered_keys}  = [];
  794     $self->{all_handles}   = [];
  795     $self->{error_status}  = 0;
  796     $self->{error_message} = undef;
  797 
  798     $self->parse_form_data (@param);
  799 }
  800 
  801 sub parse_form_data
  802 {
  803     my ($self, $user_request) = @_;
  804     my ($request_method, $content_length, $content_type, $query_string,
  805         $boundary, $post_data, @query_input);
  806 
  807     # Force into object method
  808     unless (ref ($self)) { $self = $self->new; }
  809     $request_method = $user_request        || $ENV{REQUEST_METHOD} || '';
  810     $content_length = $ENV{CONTENT_LENGTH} || 0;
  811     $content_type   = $ENV{CONTENT_TYPE};
  812 
  813     # If we've set a size limit, check that it has not been exceeded
  814     if ($self->{size_limit} > -1 and $content_length > $self->{size_limit}) {
  815         $self->_error ("Content lenth $content_length exceeds limit of "
  816               . $self->{size_limit});
  817         return;
  818     }
  819 
  820     if ($request_method =~ /^(get|head)$/i) {
  821 
  822         $query_string = $ENV{QUERY_STRING};
  823         $self->_decode_url_encoded_data (\$query_string, 'form');
  824 
  825         return wantarray ? %{$self->{web_data}} : $self->{web_data};
  826 
  827     } elsif ($request_method =~ /^post$/i) {
  828 
  829         if (!$content_type
  830             || ($content_type =~ /^application\/x-www-form-urlencoded/)) {
  831 
  832             read (STDIN, $post_data, $content_length);
  833             $self->_decode_url_encoded_data (\$post_data, 'form');
  834 
  835             return wantarray ? %{$self->{web_data}} : $self->{web_data};
  836 
  837         } elsif ($content_type =~ /multipart\/form-data/) {
  838 
  839             if ($self->{deny_uploads}) {
  840                 $self->_error ("multipart/form-data unacceptable when "
  841                       . "deny_uploads is set");
  842                 return;
  843             }
  844             ($boundary) = $content_type =~ /boundary=(\S+)$/;
  845             $self->_parse_multipart_data ($content_length, $boundary);
  846 
  847             return wantarray ? %{$self->{web_data}} : $self->{web_data};
  848 
  849         } else {
  850             $self->_error ('Invalid content type!');
  851         }
  852 
  853     } else {
  854 
  855         ##++
  856         ##  Got the idea of interactive debugging from CGI.pm, though it's
  857         ##  handled a bit differently here. Thanks Lincoln!
  858         ##--
  859 
  860         print "[ Reading query from standard input. Press ^D to stop! ]\n";
  861 
  862         @query_input = <>;
  863         chomp (@query_input);
  864 
  865         $query_string = join ('&', @query_input);
  866         $query_string =~ s/\\(.)/sprintf ('%%%02X', ord ($1))/eg;
  867 
  868         $self->_decode_url_encoded_data (\$query_string, 'form');
  869 
  870         return wantarray ? %{$self->{web_data}} : $self->{web_data};
  871     }
  872 }
  873 
  874 sub parse_cookies
  875 {
  876     my $self = shift;
  877     my $cookies;
  878 
  879     $cookies = $ENV{HTTP_COOKIE} || return;
  880 
  881     $self->_decode_url_encoded_data (\$cookies, 'cookies');
  882 
  883     return wantarray ? %{$self->{web_data}} : $self->{web_data};
  884 }
  885 
  886 sub get_ordered_keys
  887 {
  888     my $self = shift;
  889 
  890     return wantarray ? @{$self->{ordered_keys}} : $self->{ordered_keys};
  891 }
  892 
  893 sub print_data
  894 {
  895     my $self = shift;
  896 
  897     my $eol = $self->{eol}->{$self->{platform}};
  898 
  899     foreach my $key (@{$self->{ordered_keys}}) {
  900         my $value = $self->{web_data}->{$key};
  901 
  902         if (ref $value) {
  903             print "$key = @$value$eol";
  904         } else {
  905             print "$key = $value$eol";
  906         }
  907     }
  908 }
  909 
  910 sub get_upload_type
  911 {
  912     my ($self, $field) = @_;
  913 
  914     return ($self->{'mime_types'}->{$field});
  915 }
  916 
  917 sub wrap_textarea
  918 {
  919     my ($self, $string, $length) = @_;
  920     my ($new_string, $platform, $eol);
  921 
  922     $length     = 70 unless ($length);
  923     $platform   = $self->{platform};
  924     $eol        = $self->{eol}->{$platform};
  925     $new_string = $string || return;
  926 
  927     $new_string =~ s/[\0\r]\n?/ /sg;
  928     $new_string =~ s/(.{0,$length})\s/$1$eol/sg;
  929 
  930     return $new_string;
  931 }
  932 
  933 sub get_multiple_values
  934 {
  935     my ($self, $array) = @_;
  936 
  937     return (ref $array) ? (@$array) : $array;
  938 }
  939 
  940 sub create_variables
  941 {
  942     my ($self, $hash) = @_;
  943     my ($package, $key, $value);
  944 
  945     $package = $self->_determine_package;
  946 
  947     while (($key, $value) = each %$hash) {
  948         my $this = Symbol::qualify_to_ref ($key, $package);
  949         $$$this = $value;
  950     }
  951 }
  952 
  953 sub is_error
  954 {
  955     my $self = shift;
  956 
  957     if ($self->{error_status}) {
  958         return (1);
  959     } else {
  960         return (0);
  961     }
  962 }
  963 
  964 sub get_error_message
  965 {
  966     my $self = shift;
  967 
  968     return $self->{error_message} if ($self->{error_message});
  969 }
  970 
  971 sub return_error
  972 {
  973     my ($self, @messages) = @_;
  974 
  975     print "@messages\n";
  976 
  977     exit (1);
  978 }
  979 
  980 ##++
  981 ##  Exported Subroutines and Methods
  982 ##--
  983 
  984 sub browser_escape
  985 {
  986     my ($self, $string) = @_;
  987 
  988     unless (eval { $self->isa ('CGI::Lite'); }) {
  989         my @rep = caller;
  990         warn "Non-method use of browser_escape is deprecated "
  991           . "in $rep[0] at line $rep[2] of $rep[1]\n";
  992         $string = $self;
  993     }
  994     $string =~ s/([<&"#%>])/sprintf ('&#%d;', ord ($1))/ge;
  995 
  996     return $string;
  997 }
  998 
  999 sub url_encode
 1000 {
 1001     my ($self, $string) = @_;
 1002 
 1003     unless (eval { $self->isa ('CGI::Lite'); }) {
 1004         my @rep = caller;
 1005         warn "Non-method use of url_encode is deprecated "
 1006           . "in $rep[0] at line $rep[2] of $rep[1]\n";
 1007         $string = $self;
 1008     }
 1009 
 1010     $string =~ s/([^-.\w ])/sprintf('%%%02X', ord $1)/ge;
 1011     $string =~ tr/ /+/;
 1012 
 1013     return $string;
 1014 }
 1015 
 1016 sub url_decode
 1017 {
 1018     my ($self, $string) = @_;
 1019 
 1020     unless (eval { $self->isa ('CGI::Lite'); }) {
 1021         my @rep = caller;
 1022         warn "Non-method use of url_decode is deprecated "
 1023           . "in $rep[0] at line $rep[2] of $rep[1]\n";
 1024         $string = $self;
 1025     }
 1026 
 1027     $string =~ tr/+/ /;
 1028     $string =~ s/%([\da-fA-F]{2})/chr (hex ($1))/eg;
 1029 
 1030     return $string;
 1031 }
 1032 
 1033 sub is_dangerous
 1034 {
 1035     my ($self, $string) = @_;
 1036 
 1037     unless (eval { $self->isa ('CGI::Lite'); }) {
 1038         my @rep = caller;
 1039         warn "Non-method use of is_dangerous is deprecated "
 1040           . "in $rep[0] at line $rep[2] of $rep[1]\n";
 1041         $string = $self;
 1042     }
 1043 
 1044     if ($string =~ /[;<>\*\|`&\$!#\(\)\[\]\{\}:'"]/) {
 1045         return (1);
 1046     } else {
 1047         return (0);
 1048     }
 1049 }
 1050 
 1051 ##++
 1052 ##  Internal Methods
 1053 ##--
 1054 
 1055 sub _error
 1056 {
 1057     my ($self, $message) = @_;
 1058 
 1059     $self->{error_status}  = 1;
 1060     $self->{error_message} = $message;
 1061 }
 1062 
 1063 sub _determine_package
 1064 {
 1065     my $self = shift;
 1066     my ($frame, $this_package, $find_package);
 1067 
 1068     $frame = -1;
 1069     ($this_package) = split (/=/, $self);
 1070 
 1071     do {
 1072         $find_package = caller (++$frame);
 1073     } until ($find_package !~ /^$this_package/);
 1074 
 1075     return ($find_package);
 1076 }
 1077 
 1078 ##++
 1079 ##  Decode URL encoded data
 1080 ##--
 1081 
 1082 sub _decode_url_encoded_data
 1083 {
 1084     my ($self, $reference_data, $type) = @_;
 1085     return unless ($$reference_data);
 1086 
 1087     my (@key_value_pairs, $delimiter);
 1088 
 1089     @key_value_pairs = ();
 1090 
 1091     if ($type eq 'cookies') {
 1092         $delimiter = qr/[;,]\s*/;
 1093     } else {
 1094 
 1095         # Only other option is form data
 1096         $delimiter = qr/[;&]/;
 1097     }
 1098 
 1099     @key_value_pairs = split ($delimiter, $$reference_data);
 1100 
 1101     foreach my $key_value (@key_value_pairs) {
 1102         my ($key, $value) = split (/=/, $key_value, 2);
 1103 
 1104         # avoid 'undef' warnings for "key=" BDL Jan/99
 1105         $value = '' unless defined $value;
 1106 
 1107         # avoid 'undef' warnings for bogus URLs like 'foobar.cgi?&foo=bar'
 1108         next unless defined $key;
 1109 
 1110         if ($type eq 'cookies') {
 1111 
 1112             # Strip leading/trailling whitespace as per RFC 2965
 1113             $key   =~ s/^\s+|\s+$//g;
 1114             $value =~ s/^\s+|\s+$//g;
 1115         }
 1116 
 1117         $key   = $self->url_decode ($key);
 1118         $value = $self->url_decode ($value);
 1119 
 1120         if (defined ($self->{web_data}->{$key})) {
 1121             if ($type eq 'cookies' and $self->{unique_cookies} > 0) {
 1122                 if ($self->{unique_cookies} == 1) {
 1123                     next;
 1124                 } elsif ($self->{unique_cookies} == 2) {
 1125                     $self->{web_data}->{$key} = $value;
 1126                     next;
 1127                 } else {
 1128                     $self->_error ("Multiple instances of cookie $key");
 1129                 }
 1130             }
 1131             $self->{web_data}->{$key} = [$self->{web_data}->{$key}]
 1132               unless (ref $self->{web_data}->{$key});
 1133 
 1134             push (@{$self->{web_data}->{$key}}, $value);
 1135         } else {
 1136             $self->{web_data}->{$key} = $value;
 1137             push (@{$self->{ordered_keys}}, $key);
 1138         }
 1139     }
 1140 
 1141     return;
 1142 }
 1143 
 1144 ##++
 1145 ##  Methods dealing with multipart data
 1146 ##--
 1147 
 1148 sub _parse_multipart_data
 1149 {
 1150     my ($self, $total_bytes, $boundary) = @_;
 1151     my $files = {};
 1152     my $boundary_re = qr/(.*?)((?:\015?\012)?-*
 1153         \Q$boundary\E
 1154         -*[\015\012]*)(?=(.*))/xs;
 1155 
 1156     eval {
 1157 
 1158         my ($seen,      $buffer_size, $byte_count,    $platform,
 1159             $eol,       $handle,      $directory,     $bytes_left,
 1160             $new_data,  $old_data,    $this_boundary, $current_buffer,
 1161             $changed,   $store,       $disposition,   $headers,
 1162             $mime_type, $convert,     $field,         $file,
 1163             $new_name,  $full_path
 1164         );
 1165 
 1166         $seen        = {};
 1167         $buffer_size = $self->{buffer_size};
 1168         $byte_count  = 0;
 1169         $platform    = $self->{platform};
 1170         $eol         = $self->{eol}->{$platform};
 1171         $directory   = $self->{multipart_dir};
 1172         $bytes_left  = $total_bytes;
 1173 
 1174         while ($bytes_left) {
 1175             if ($byte_count < $total_bytes) {
 1176 
 1177                 $bytes_left = $total_bytes - $byte_count;
 1178                 $buffer_size = $bytes_left if ($bytes_left < $buffer_size);
 1179 
 1180                 read (STDIN, $new_data, $buffer_size);
 1181                 $self->_error ("Oh, Oh! I'm upset! Can't read what I want.")
 1182                   if (length ($new_data) != $buffer_size);
 1183 
 1184                 $byte_count += $buffer_size;
 1185 
 1186                 if ($old_data) {
 1187                     $current_buffer = join ('', $old_data, $new_data);
 1188                 } else {
 1189                     $current_buffer = $new_data;
 1190                 }
 1191 
 1192             } elsif ($old_data) {
 1193                 $current_buffer = $old_data;
 1194                 $old_data       = undef;
 1195 
 1196             } else {
 1197                 last;
 1198             }
 1199 
 1200             $changed = 0;
 1201 
 1202             ##++
 1203             ##  When Netscape Navigator creates a random boundary string, you
 1204             ##  would expect it to pass that _same_ value in the environment
 1205             ##  variable CONTENT_TYPE, but it does not! Instead, it passes a
 1206             ##  value that has the first two characters ("--") missing.
 1207             ##--
 1208 
 1209             if ($current_buffer =~ $boundary_re) {
 1210 
 1211                 ($store, $this_boundary, $old_data) = ($1, $2, $3);
 1212 
 1213                 if ($current_buffer =~
 1214                     /[Cc]ontent-[Dd]isposition: ([^\015\012]+)\015?\012  # Disposition
 1215                     (?:([A-Za-z].*?)(?:\015?\012))?                     # Headers
 1216                     (?:\015?\012)                                       # End
 1217                     (?=(.*))                                            # Other Data
 1218                     /xs
 1219                   ) {
 1220 
 1221                     ($disposition, $headers, $current_buffer) = ($1, $2, $3);
 1222                     $old_data = $current_buffer;
 1223 
 1224                     $headers ||= '';
 1225                     ($mime_type) = $headers =~ /[Cc]ontent-[Tt]ype: (\S+)/;
 1226 
 1227                     $self->_store ($platform, $file, $convert, $handle, $eol,
 1228                         $field, \$store, $seen);
 1229 
 1230                     close ($handle) if (ref ($handle) and fileno ($handle));
 1231 
 1232                     if ($mime_type && $self->{convert}->{$mime_type}) {
 1233                         $convert = 1;
 1234                     } else {
 1235                         $convert = 0;
 1236                     }
 1237 
 1238                     $changed = 1;
 1239 
 1240                     ($field) = $disposition =~ /name="([^"]+)"/;
 1241                     ++$seen->{$field};
 1242 
 1243                     unless ($self->{'mime_types'}->{$field}) {
 1244                         $self->{'mime_types'}->{$field} = $mime_type;
 1245                     } elsif (ref $self->{'mime_types'}->{$field}) {
 1246                         push @{$self->{'mime_types'}->{$field}}, $mime_type;
 1247                     } else {
 1248                         $self->{'mime_types'}->{$field} = 
 1249                             [$self->{'mime_types'}->{$field}, $mime_type];
 1250                     }
 1251 
 1252                     if ($seen->{$field} > 1) {
 1253                         $self->{web_data}->{$field} =
 1254                           [$self->{web_data}->{$field}]
 1255                           unless (ref $self->{web_data}->{$field});
 1256                     } else {
 1257                         push (@{$self->{ordered_keys}}, $field);
 1258                     }
 1259 
 1260                     if (($file) = $disposition =~ /filename="(.*)"/) {
 1261                         $file =~ s|.*[:/\\](.*)|$1|;
 1262 
 1263                         $new_name =
 1264                           $self->_get_file_name ($platform, $directory, $file);
 1265 
 1266                         if (ref $self->{web_data}->{$field}) {
 1267                             push @{$self->{web_data}->{$field}}, $new_name
 1268                         } else {
 1269                             $self->{web_data}->{$field} = $new_name;
 1270                         }
 1271 
 1272                         $full_path =
 1273                           join ($self->{file}->{$platform}, $directory,
 1274                             $new_name);
 1275 
 1276                         open ($handle, '>', $full_path)
 1277                           or $self->_error ("Can't create file: $full_path!");
 1278 
 1279                         $files->{$new_name} = $full_path;
 1280                     }
 1281                 } elsif ($byte_count < $total_bytes) {
 1282                     $old_data = $this_boundary . $old_data;
 1283                 }
 1284 
 1285             } elsif ($old_data) {
 1286                 $store    = $old_data;
 1287                 $old_data = $new_data;
 1288             }
 1289 
 1290             unless ($changed) {
 1291                 $self->_store ($platform, $file, $convert, $handle, $eol,
 1292                     $field, \$store, $seen);
 1293             }
 1294         }
 1295 
 1296         close ($handle) if ($handle and fileno ($handle));
 1297 
 1298     };    # End of eval
 1299 
 1300     $self->_error ($@) if $@;
 1301 
 1302     $self->_create_handles ($files) if ($self->{file_type} eq 'handle');
 1303 }
 1304 
 1305 sub _store
 1306 {
 1307     my ($self, $platform, $file, $convert, $handle, $eol, $field, $info, $seen)
 1308       = @_;
 1309 
 1310     if ($file) {
 1311         if ($convert) {
 1312             if ($platform eq 'PC') {
 1313                 $$info =~ s/\015(?!\012)|(?<!\015)\012/$eol/og;
 1314             } else {
 1315                 $$info =~ s/\015\012/$eol/og;
 1316                 $$info =~ s/\015/$eol/og if ($platform ne 'Mac');
 1317                 $$info =~ s/\012/$eol/og if ($platform ne 'Unix');
 1318             }
 1319         }
 1320 
 1321         binmode $handle;
 1322         print $handle $$info;
 1323 
 1324     } elsif ($field) {
 1325         if ($seen->{$field} > 1) {
 1326             $self->{web_data}->{$field}->[$seen->{$field} - 1] .= $$info;
 1327         } else {
 1328             $self->{web_data}->{$field} .= $$info;
 1329         }
 1330     }
 1331 }
 1332 
 1333 sub _get_file_name
 1334 {
 1335     my ($self, $platform, $directory, $file) = @_;
 1336     my ($filtered_name, $filename, $timestamp, $path);
 1337 
 1338     $filtered_name = &{$self->{filter}}($file)
 1339       if (ref ($self->{filter}) eq 'CODE');
 1340 
 1341     $filename = $filtered_name || $file;
 1342     $timestamp = time . '__' . $filename;
 1343 
 1344     if (!$self->{timestamp}) {
 1345         return $filename;
 1346 
 1347     } elsif ($self->{timestamp} == 1) {
 1348         return $timestamp;
 1349 
 1350     } else {    # $self->{timestamp} must be 2
 1351         $path = join ($self->{file}->{$platform}, $directory, $filename);
 1352 
 1353         return (-e $path) ? $timestamp : $filename;
 1354     }
 1355 }
 1356 
 1357 sub _create_handles
 1358 {
 1359     my ($self, $files) = @_;
 1360     my ($package, $handle, $name, $path);
 1361 
 1362     $package = $self->_determine_package;
 1363 
 1364     while (($name, $path) = each %$files) {
 1365         $handle = Symbol::qualify_to_ref ($name, $package);
 1366         open ($handle, '<', $path)
 1367           or $self->_error ("Can't read file: $path! $!");
 1368 
 1369         push (@{$self->{all_handles}}, $handle);
 1370     }
 1371 }
 1372 
 1373 sub close_all_files
 1374 {
 1375     my $self = shift;
 1376 
 1377     foreach my $handle (@{$self->{all_handles}}) {
 1378         close $handle;
 1379     }
 1380 }
 1381 
 1382 1;
 1383