@@ -1,3 +1,96 @@
+* v2.05 - 23rd October 2014
+
+Documentation improvements, Makefile.PL tweaks.
+
+* v2.04_05 - 11th October 2014
+
+binmode forced on all file writes to avoid corruption when converting
+EOLs on MSWin32.
+
+* v2.04_04 - 8th October 2014
+
+Conversion section of _store() replaced to remove dependence on \K
+escape which was only introduced in perl 5.10.
+
+* v2.04_03 - Not released
+
+Upload tests fixed again to solve problems for MSWin32 users:
+binmode had been erroneously left off the inputs.
+
+Fixed generation of MYMETA/META files as spec 2.0 not yet supported
+in the local build environment.
+
+* v2.04_02 - 7th October 2014
+
+Upload tests fixed to solve two problems for MSWin32 users:
+permissions-based tests skipped and coversion algorithms for text MIME
+types improved.
+
+* v2.04_01 - 6th October 2014
+
+Full test coverage of non-deprecated features.
+
+BUG FIX: Multi-file uploads could break if the buffer end occured in the
+ headers of one of the files. (issue 99294)
+
+BUG FIX: $cgi->set_platform ('macintosh') erroneously set platform to
+ 'PC' because the regex was not anchored to the start. 'macintosh'
+ now results in platform 'Mac' as it should.
+
+Version control moved to git.
+
+Makefile.PL extended to include resources (where available).
+
+* v2.04 - 4th July 2014
+
+Minor documentation fixes and explanation of the proposed split into
+legacy/trunk branches. No code changes from 2.03_02.
+
+* v2.03_02 - 17th June 2014
+
+The uploads have had a minor change which may solve the windows size
+difference failures. More diagnostics were added to the failures if it
+does not.
+
+* v2.03_01 - 13th June 2014
+
+The test multi-part upload data in the test suite has been fixed to have
+the correct (CRLF) line terminators. These tests should now pass for
+Microsoft users.
+
+The documentation has been amended to reflect the change of maintainer.
+
+* v2.03 - May 25, 2014
+
+Maintainer change: Pete Houston has taken over maintenance from Smylers.
+
+A test suite has been created.
+
+BUG FIX: Cleared up some uninitialised value warnings emitted when query
+ strings are missing an entire key-value pair eg: "&foo=bar" (issue
+ 38448).
+
+BUG FIX: If the user calls parse_form_data as a class method without a
+ query string, the method now gives up early and silently
+ (issue 6180).
+
+BUG FIX: In form-data uploads, the boundary string was not properly
+ escaped and therefore would not match when it contained
+ metacharacters (issue 29053).
+
+BUG FIX: The content type for url-encoded forms now matches on the MIME
+ type only, so additional charset fields are allowed (issues 16236,
+ 34827 and 41666).
+
+BUG FIX: Leading/trailling whitespace is now stripped from cookie names
+ and values.
+
+BUG FIX: Cookies now no longer need to be separated by whitespace.
+ Commas can now be used as separators too. (issue 32329).
+
+BUG FIX: The semicolon is now a permitted delimiter in the query string
+ along with the ampersand (issue 8212).
+
* v2.02 - May 18, 2003
I've taken over CGI::Lite. Thanks to Andreas for making the security release,
@@ -0,0 +1,201 @@
+The Artistic License 2.0
+
+ Copyright (c) 2000-2006, The Perl Foundation.
+
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+Preamble
+
+This license establishes the terms under which a given free software
+Package may be copied, modified, distributed, and/or redistributed.
+The intent is that the Copyright Holder maintains some artistic
+control over the development of that Package while still keeping the
+Package available as open source and free software.
+
+You are always permitted to make arrangements wholly outside of this
+license directly with the Copyright Holder of a given Package. If the
+terms of this license do not permit the full use that you propose to
+make of the Package, you should contact the Copyright Holder and seek
+a different licensing arrangement.
+
+Definitions
+
+ "Copyright Holder" means the individual(s) or organization(s)
+ named in the copyright notice for the entire Package.
+
+ "Contributor" means any party that has contributed code or other
+ material to the Package, in accordance with the Copyright Holder's
+ procedures.
+
+ "You" and "your" means any person who would like to copy,
+ distribute, or modify the Package.
+
+ "Package" means the collection of files distributed by the
+ Copyright Holder, and derivatives of that collection and/or of
+ those files. A given Package may consist of either the Standard
+ Version, or a Modified Version.
+
+ "Distribute" means providing a copy of the Package or making it
+ accessible to anyone else, or in the case of a company or
+ organization, to others outside of your company or organization.
+
+ "Distributor Fee" means any fee that you charge for Distributing
+ this Package or providing support for this Package to another
+ party. It does not mean licensing fees.
+
+ "Standard Version" refers to the Package if it has not been
+ modified, or has been modified only in ways explicitly requested
+ by the Copyright Holder.
+
+ "Modified Version" means the Package, if it has been changed, and
+ such changes were not explicitly requested by the Copyright
+ Holder.
+
+ "Original License" means this Artistic License as Distributed with
+ the Standard Version of the Package, in its current version or as
+ it may be modified by The Perl Foundation in the future.
+
+ "Source" form means the source code, documentation source, and
+ configuration files for the Package.
+
+ "Compiled" form means the compiled bytecode, object code, binary,
+ or any other form resulting from mechanical transformation or
+ translation of the Source form.
+
+
+Permission for Use and Modification Without Distribution
+
+(1) You are permitted to use the Standard Version and create and use
+Modified Versions for any purpose without restriction, provided that
+you do not Distribute the Modified Version.
+
+
+Permissions for Redistribution of the Standard Version
+
+(2) You may Distribute verbatim copies of the Source form of the
+Standard Version of this Package in any medium without restriction,
+either gratis or for a Distributor Fee, provided that you duplicate
+all of the original copyright notices and associated disclaimers. At
+your discretion, such verbatim copies may or may not include a
+Compiled form of the Package.
+
+(3) You may apply any bug fixes, portability changes, and other
+modifications made available from the Copyright Holder. The resulting
+Package will still be considered the Standard Version, and as such
+will be subject to the Original License.
+
+
+Distribution of Modified Versions of the Package as Source
+
+(4) You may Distribute your Modified Version as Source (either gratis
+or for a Distributor Fee, and with or without a Compiled form of the
+Modified Version) provided that you clearly document how it differs
+from the Standard Version, including, but not limited to, documenting
+any non-standard features, executables, or modules, and provided that
+you do at least ONE of the following:
+
+ (a) make the Modified Version available to the Copyright Holder
+ of the Standard Version, under the Original License, so that the
+ Copyright Holder may include your modifications in the Standard
+ Version.
+
+ (b) ensure that installation of your Modified Version does not
+ prevent the user installing or running the Standard Version. In
+ addition, the Modified Version must bear a name that is different
+ from the name of the Standard Version.
+
+ (c) allow anyone who receives a copy of the Modified Version to
+ make the Source form of the Modified Version available to others
+ under
+
+ (i) the Original License or
+
+ (ii) a license that permits the licensee to freely copy,
+ modify and redistribute the Modified Version using the same
+ licensing terms that apply to the copy that the licensee
+ received, and requires that the Source form of the Modified
+ Version, and of any works derived from it, be made freely
+ available in that license fees are prohibited but Distributor
+ Fees are allowed.
+
+
+Distribution of Compiled Forms of the Standard Version
+or Modified Versions without the Source
+
+(5) You may Distribute Compiled forms of the Standard Version without
+the Source, provided that you include complete instructions on how to
+get the Source of the Standard Version. Such instructions must be
+valid at the time of your distribution. If these instructions, at any
+time while you are carrying out such distribution, become invalid, you
+must provide new instructions on demand or cease further distribution.
+If you provide valid instructions or cease distribution within thirty
+days after you become aware that the instructions are invalid, then
+you do not forfeit any of your rights under this license.
+
+(6) You may Distribute a Modified Version in Compiled form without
+the Source, provided that you comply with Section 4 with respect to
+the Source of the Modified Version.
+
+
+Aggregating or Linking the Package
+
+(7) You may aggregate the Package (either the Standard Version or
+Modified Version) with other packages and Distribute the resulting
+aggregation provided that you do not charge a licensing fee for the
+Package. Distributor Fees are permitted, and licensing fees for other
+components in the aggregation are permitted. The terms of this license
+apply to the use and Distribution of the Standard or Modified Versions
+as included in the aggregation.
+
+(8) You are permitted to link Modified and Standard Versions with
+other works, to embed the Package in a larger work of your own, or to
+build stand-alone binary or bytecode versions of applications that
+include the Package, and Distribute the result without restriction,
+provided the result does not expose a direct interface to the Package.
+
+
+Items That are Not Considered Part of a Modified Version
+
+(9) Works (including, but not limited to, modules and scripts) that
+merely extend or make use of the Package, do not, by themselves, cause
+the Package to be a Modified Version. In addition, such works are not
+considered parts of the Package itself, and are not subject to the
+terms of this license.
+
+
+General Provisions
+
+(10) Any use, modification, and distribution of the Standard or
+Modified Versions is governed by this Artistic License. By using,
+modifying or distributing the Package, you accept this license. Do not
+use, modify, or distribute the Package, if you do not accept this
+license.
+
+(11) If your Modified Version has been derived from a Modified
+Version made by someone other than you, you are nevertheless required
+to ensure that your Modified Version complies with the requirements of
+this license.
+
+(12) This license does not grant you the right to use any trademark,
+service mark, tradename, or logo of the Copyright Holder.
+
+(13) This license includes the non-exclusive, worldwide,
+free-of-charge patent license to make, have made, use, offer to sell,
+sell, import and otherwise transfer the Package with respect to any
+patent claims licensable by the Copyright Holder that are necessarily
+infringed by the Package. If you institute patent litigation
+(including a cross-claim or counterclaim) against any party alleging
+that the Package constitutes direct or contributory patent
+infringement, then this Artistic License to you shall terminate on the
+date that such litigation is filed.
+
+(14) Disclaimer of Warranty:
+THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS
+IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED
+WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR
+NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL
+LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL
+BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL
+DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF
+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
@@ -1,1182 +0,0 @@
-#!/usr/bin/perl
-
-##++
-## CGI Lite v2.02
-## Last modified: 18 Aug 2003 (Smylers - see CHANGES)
-##
-## Copyright (c) 1995, 1996, 1997 by Shishir Gundavaram
-## All Rights Reserved
-##
-## Permission to use, copy, and distribute is hereby granted,
-## providing that the above copyright notice and this permission
-## appear in all copies and in supporting documentation.
-##--
-
-###############################################################################
-
-=head1 NAME
-
-CGI::Lite - Process and decode WWW forms and cookies
-
-=head1 SYNOPSIS
-
- use CGI::Lite;
-
- $cgi = new CGI::Lite;
-
- $cgi->set_platform ($platform);
-
- where $platform can be one of (case insensitive):
- Unix, Windows, Windows95, DOS, NT, PC, Mac or Macintosh
-
- $cgi->set_file_type ('handle' or 'file');
- $cgi->add_timestamp (0, 1 or 2);
-
- where 0 = no timestamp
- 1 = timestamp all files (default)
- 2 = timestamp only if file exists
-
- $cgi->filter_filename (\&subroutine);
-
- $size = $cgi->set_buffer_size ($some_buffer_size);
-
- $status = $cgi->set_directory ('/some/dir');
- $cgi->set_directory ('/some/dir') || die "Directory doesn't exist.\n";
-
- $cgi->close_all_files;
-
- $cgi->add_mime_type ('application/mac-binhex40');
- $status = $cgi->remove_mime_type ('application/mac-binhex40');
- @list = $cgi->get_mime_types;
-
- $form = $cgi->parse_form_data;
- %form = $cgi->parse_form_data;
-
- or
-
- $form = $cgi->parse_form_data ('GET', 'HEAD' or 'POST');
-
- $cookies = $cgi->parse_cookies;
- %cookies = $cgi->parse_cookies;
-
- $status = $cgi->is_error;
- $message = $cgi->get_error_message;
-
- $cgi->return_error ('error 1', 'error 2', ...);
-
- $keys = $cgi->get_ordered_keys;
- @keys = $cgi->get_ordered_keys;
-
- $cgi->print_data;
-
- $cgi->print_form_data; (deprecated as of v1.8)
- $cgi->print_cookie_data; (deprecated as of v1.8)
-
- $new_string = $cgi->wrap_textarea ($string, $length);
-
- @all_values = $cgi->get_multiple_values ($reference);
-
- $cgi->create_variables (\%form);
- $cgi->create_variables ($form);
-
- $escaped_string = browser_escape ($string);
-
- $encoded_string = url_encode ($string);
- $decoded_string = url_decode ($string);
-
- $status = is_dangerous ($string);
- $safe_string = escape_dangerous_chars ($string); # ***use is discouraged***
-
-=head1 DESCRIPTION
-
-You can use this module to decode form and query information,
-including file uploads, as well as cookies in a very simple
-manner; you need not concern yourself with the actual details
-behind the decoding process.
-
-=head1 METHODS
-
-Here are the methods you can use to process your forms and cookies:
-
-=over 4
-
-=item B<parse_form_data>
-
-This will handle the following types of requests: GET, HEAD and POST.
-By default, CGI::Lite uses the environment variable REQUEST_METHOD to
-determine the manner in which the query/form information should be
-decoded. However, as of v1.8, you are allowed to pass a valid request
-method to this function to force CGI::Lite to decode the information in
-a specific manner.
-
-For multipart/form-data, uploaded files are stored in the user selected
-directory (see B<set_directory>). If timestamp mode is on (see
-B<add_timestamp>), the files are named in the following format:
-
- timestamp__filename
-
-where the filename is specified in the "Content-disposition" header.
-I<NOTE:>, the browser URL encodes the name of the file. This module
-makes I<no> effort to decode the information for security reasons.
-However, you can do so by creating a subroutine and then using
-the B<filter_filename> method.
-
-I<Return Value>
-
-Returns either a hash or a reference to the hash, which contains
-all of the key/value pairs. For fields that contain file information,
-the value contains either the path to the file, or the filehandle
-(see the B<set_file_type> method).
-
-=item B<parse_new_form_data>
-
-As for parse_form_data, but clears the CGI object state before processing
-the request. This is useful in persistant application (e.g. FCGI), where
-the CGI object is reused for multiple requests. e.g.
-
- $CGI = new CGI::Lite;
- while (FCGI::accept > 0)
- {
- $Query = $CGI->parse_new_form_data();
- <process query>
- }
-
-=item B<parse_cookies>
-
-Decodes and parses cookies passed by the browser. This method works in
-much the same manner as B<parse_form_data>.
-
-=item B<is_error>
-
-As of v1.8, errors in parsing are handled differently. You can use this
-method to check for any potential errors after you've called either
-B<parse_form_data> or B<parse_cookies>.
-
-I<Return Value>
-
- 0 Success
- 1 Failure
-
-=item B<get_error_message>
-
-If an error occurs when parsing form/query information or cookies, you
-can use this method to retrieve the error message. Remember, you can
-check for errors by calling the B<is_error> method.
-
-I<Return Value>
-
-The error message.
-
-=item B<return_error>
-
-You can use this method to return errors to the browser and exit.
-
-=item B<set_platform>
-
-You can use this method to set the platform on which your Web server
-is running. CGI::Lite uses this information to translate end-of-line
-(EOL) characters for uploaded files (see the B<add_mime_type> and
-B<remove_mime_type> methods) so that they display properly on that
-platform.
-
-You can specify either (case insensitive):
-
- Unix EOL: \012 = \n
- Windows, Windows95, DOS, NT, PC EOL: \015\012 = \r\n
- Mac or Macintosh EOL: \015 = \r
-
-"Unix" is the default.
-
-=item B<set_directory>
-
-Used to set the directory where the uploaded files will be stored
-(only applies to the I<multipart/form-data> encoding scheme).
-
-This function should be called I<before> you call B<parse_form_data>,
-or else the directory defaults to "/tmp". If the application cannot
-write to the directory for whatever reason, an error status is returned.
-
-I<Return Value>
-
- 0 Failure
- 1 Success
-
-=item B<close_all_files>
-
-All uploaded files that are opened as a result of calling B<set_file_type>
-with the "handle" argument can be closed in one shot by calling this
-method.
-
-=item B<add_mime_type>
-
-By default, EOL characters are translated for all uploaded files
-with specific MIME types (i.e text/plain, text/html, etc.). You
-can use this method to add to the list of MIME types. For example,
-if you want CGI::Lite to translate EOL characters for uploaded
-files of I<application/mac-binhex40>, then you would do this:
-
- $cgi->add_mime_type ('application/mac-binhex40');
-
-=item B<remove_mime_type>
-
-This method is the converse of B<add_mime_type>. It allows you to
-remove a particular MIME type. For example, if you do not want
-CGI::Lite to translate EOL characters for uploaded files of I<text/html>,
-then you would do this:
-
- $cgi->remove_mime_type ('text/html');
-
-I<Return Value>
-
- 0 Failure
- 1 Success
-
-=item B<get_mime_types>
-
-Returns the list, either as a reference or an actual list, of the
-MIME types for which EOL translation is performed.
-
-=item B<set_file_type>
-
-The I<names> of uploaded files are returned by default, when you call
-the B<parse_form_data> method. But, if pass the string "handle" to this
-method, the I<handles> to the files are returned. However, the name
-of the handle corresponds to the filename.
-
-This function should be called I<before> you call B<parse_form_data>, or
-else it will not work.
-
-=item B<add_timestamp>
-
-By default, a timestamp is added to the front of uploaded files.
-However, you have the option of completely turning off timestamp mode
-(value 0), or adding a timestamp only for existing files (value 2).
-
-=item B<filter_filename>
-
-You can use this method to change the manner in which uploaded
-files are named. For example, if you want uploaded filenames
-to be all upper case, you can use the following code:
-
- $cgi->filter_filename (\&make_uppercase);
- $cgi->parse_form_data;
-
- .
- .
- .
-
- sub make_uppercase
- {
- my $file = shift;
-
- $file =~ tr/a-z/A-Z/;
- return $file;
- }
-
-=item B<set_buffer_size>
-
-This method allows you to set the buffer size when dealing with multipart
-form data. However, the I<actual> buffer size that the algorithm uses
-I<can> be up to 3x the value you specify. This ensures that boundary
-strings are not "split" between multiple reads. So, take this into
-consideration when setting the buffer size.
-
-You cannot set a buffer size below 256 bytes and above the total amount
-of multipart form data. The default value is 1024 bytes.
-
-I<Return Value>
-
-The buffer size.
-
-=item B<get_ordered_keys>
-
-Returns either a reference to an array or an array itself consisting
-of the form fields/cookies in the order they were parsed.
-
-I<Return Value>
-
-Ordered keys.
-
-=item B<print_data>
-
-Displays all the key/value pairs (either form data or cookie information)
-in a ordered fashion. The methods B<print_form_data> and B<print_cookie_data>
-are deprecated as of version v1.8, and will be removed in future versions.
-
-=item B<print_form_data>
-
-Deprecated as of v1.8, see B<print_data>.
-
-=item B<print_cookie_data> (deprecated as of v1.8)
-
-Deprecated as of v1.8, see B<print_data>.
-
-=item B<wrap_textarea>
-
-You can use this function to "wrap" a long string into one that is
-separated by a combination of carriage return and newline (see
-B<set_platform>) at fixed lengths. The two arguments that you need to
-pass to this method are the string and the length at which you want the
-line separator added.
-
-I<Return Value>
-
-The modified string.
-
-=item B<get_multiple_values>
-
-One of the major changes to this module as of v1.7 is that multiple
-values for a single key are returned as an reference to an array, and
-I<not> as a string delimited by the null character ("\0"). You can use
-this function to return the actual array. And if you pass a scalar
-value to this method, it will simply return that value.
-
-There was no way I could make this backward compatible with versions
-older than 1.7. I apologize!
-
-I<Return Value>
-
-Array consisting of the multiple values.
-
-=item B<create_variables>
-
-Sometimes, it is convenient to have scalar variables that represent
-the various keys in a hash. You can use this method to do just that.
-Say you have a hash like the following:
-
- %form = ('name' => 'shishir gundavaram',
- 'sport' => 'track and field',
- 'events' => '100m');
-
-If you call this method in the following manner:
-
- $cgi->create_variables (\%hash);
-
-it will create three scalar variables: $name, $sport and $events.
-Convenient, huh?
-
-=item B<browser_escape>
-
-Certain characters have special significance to the browser. These
-characters include: "<" and ">". If you want to display these "special"
-characters, you need to escape them using the following notation:
-
- &#ascii;
-
-This method does just that.
-
-I<Return Value>
-
-Escaped string.
-
-=item B<url_encode>
-
-This method will URL encode a string that you pass it. You can use this
-to encode any data that you wish to pass as a query string to a CGI
-application.
-
-I<Return Value>
-
-URL encoded string.
-
-=item B<url_decode>
-
-You can use this method to URL decode a string.
-
-I<Return Value>
-
-URL decoded string.
-
-=item B<is_dangerous>
-
-This method checks for the existence of dangerous meta-characters.
-
-I<Return Value>
-
- 0 Safe
- 1 Dangerous
-
-=item B<escape_dangerous_chars>
-
-You can use this method to "escape" any dangerous meta-characters. The
-use of this function is strongly discouraged. See
-http://use.perl.org/~cbrooks/journal/10542 and
-http://msgs.securepoint.com/cgi-bin/get/bugtraq0302/94.html for an
-advisory by Ronald F. Guilmette. Ronald's patch to make this function
-more safe is applied, but as has been pointed out on the bugtraq
-mailing list, it is still much better to run no external shell at all
-when executing commands. Please read the advisory and the WWW security
-FAQ.
-
-I<Return Value>
-
-Escaped string.
-
-=back
-
-=head1 SEE ALSO
-
-If you're looking for more comprehensive CGI modules, you can either
-use the CGI::* modules or CGI.pm. Both are maintained by Dr. Lincoln
-Stein I<(lstein@genome.wi.mit.edu)> and can be found at your local
-CPAN mirror and at his Web site:
-
-I<http://www-genome.wi.mit.edu/WWW/tools/scripting>
-
-=head1 MAINTAINER
-
-Maintenance of this module has now been taken over by Smylers
-<smylers@cpan.org>.
-
-=head1 ACKNOWLEDGMENTS
-
-The author thanks the following for finding bugs and offering suggestions:
-
-=over 4
-
-=item Eric D. Friedman (friedman@uci.edu)
-
-=item Thomas Winzig (tsw@pvo.com)
-
-=item Len Charest (len@cogent.net)
-
-=item Achim Bohnet (ach@rosat.mpe-garching.mpg.de)
-
-=item John E. Townsend (John.E.Townsend@BST.BLS.com)
-
-=item Andrew McRae (mcrae@internet.com)
-
-=item Dennis Grant (dg50@chrysler.com)
-
-=item Scott Neufeld (scott.neufeld@mis.ussurg.com)
-
-=item Raul Almquist (imrs@ShadowMAC.org)
-
-=item and many others!
-
-=back
-
-=head1 COPYRIGHT INFORMATION
-
- Copyright (c) 1995, 1996, 1997 by Shishir Gundavaram
- All Rights Reserved
-
- Permission to use, copy, and distribute is hereby granted,
- providing that the above copyright notice and this permission
- appear in all copies and in supporting documentation.
-
-=cut
-
-###############################################################################
-
-package CGI::Lite;
-require 5.002;
-require Exporter;
-
-@ISA = (Exporter);
-@EXPORT = qw (browser_escape
- url_encode
- url_decode
- is_dangerous
- escape_dangerous_chars);
-
-##++
-## Global Variables
-##--
-
-$CGI::Lite::VERSION = '2.02';
-
-##++
-## Start
-##--
-
-sub new
-{
- my $self;
-
- $self = {
- multipart_dir => undef,
- default_dir => '/tmp',
- file_type => 'name',
- platform => 'Unix',
- buffer_size => 1024,
- timestamp => 1,
- filter => undef,
- web_data => {},
- ordered_keys => [],
- all_handles => [],
- error_status => 0,
- error_message => undef,
- file_size_limit => 2097152,
- };
-
- $self->{convert} = {
- 'text/html' => 1,
- 'text/plain' => 1
- };
-
- $self->{file} = { Unix => '/', Mac => ':', PC => '\\' };
- $self->{eol} = { Unix => "\012", Mac => "\015", PC => "\015\012" };
-
- bless $self;
- return $self;
-}
-
-sub Version
-{
- return $VERSION;
-}
-
-sub set_directory
-{
- my ($self, $directory) = @_;
-
- stat ($directory);
-
- if ( (-d _) && (-e _) && (-r _) && (-w _) ) {
- $self->{multipart_dir} = $directory;
- return (1);
-
- } else {
- return (0);
- }
-}
-
-sub add_mime_type
-{
- my ($self, $mime_type) = @_;
-
- $self->{convert}->{$mime_type} = 1 if ($mime_type);
-}
-
-sub remove_mime_type
-{
- my ($self, $mime_type) = @_;
-
- if ($self->{convert}->{$mime_type}) {
- delete $self->{convert}->{$mime_type};
- return (1);
-
- } else {
- return (0);
- }
-}
-
-sub get_mime_types
-{
- my $self = shift;
-
- return (sort keys %{ $self->{convert} });
-}
-
-sub set_platform
-{
- my ($self, $platform) = @_;
-
- if ($platform =~ /(?:PC|NT|Windows(?:95)?|DOS)/i) {
- $self->{platform} = 'PC';
-
- } elsif ($platform =~ /Mac(?:intosh)?/i) {
-
- ## Should I check for NeXT here :-)
-
- $self->{platform} = 'Mac';
-
- } else {
- $self->{platform} = 'Unix';
- }
-}
-
-sub set_file_type
-{
- my ($self, $type) = @_;
-
- if ($type =~ /^handle$/i) {
- $self->{file_type} = 'handle';
- } else {
- $self->{file_type} = 'name';
- }
-}
-
-sub add_timestamp
-{
- my ($self, $value) = @_;
-
- if ( ($value < 0) || ($value > 2) ) {
- $self->{timestamp} = 1;
- } else {
- $self->{timestamp} = $value;
- }
-}
-
-sub filter_filename
-{
- my ($self, $subroutine) = @_;
-
- $self->{filter} = $subroutine;
-}
-
-sub set_buffer_size
-{
- my ($self, $buffer_size) = @_;
- my $content_length;
-
- $content_length = $ENV{CONTENT_LENGTH} || return (0);
-
- if ($buffer_size < 256) {
- $self->{buffer_size} = 256;
- } elsif ($buffer_size > $content_length) {
- $self->{buffer_size} = $content_length;
- } else {
- $self->{buffer_size} = $buffer_size;
- }
-
- return ($self->{buffer_size});
-}
-
-sub parse_new_form_data
-# Reset state before parsing (for persistant CGI objects, e.g. under FastCGI)
-# BDL
-{
- my ($self, @param) = @_;
-
- # close files (should happen anyway when 'all_handles' is cleared...)
- $self->close_all_files();
-
- $self->{web_data} = {};
- $self->{ordered_keys} = [];
- $self->{all_handles} = [];
- $self->{error_status} = 0;
- $self->{error_message} = undef;
-
- $self->parse_form_data(@param);
-}
-
-sub parse_form_data
-{
- my ($self, $user_request) = @_;
- my ($request_method, $content_length, $content_type, $query_string,
- $boundary, $post_data, @query_input);
-
- $request_method = $user_request || $ENV{REQUEST_METHOD} || '';
- $content_length = $ENV{CONTENT_LENGTH};
- $content_type = $ENV{CONTENT_TYPE};
-
- if ($request_method =~ /^(get|head)$/i) {
-
- $query_string = $ENV{QUERY_STRING};
- $self->_decode_url_encoded_data (\$query_string, 'form');
-
- return wantarray ?
- %{ $self->{web_data} } : $self->{web_data};
-
- } elsif ($request_method =~ /^post$/i) {
-
- if (!$content_type ||
- ($content_type eq 'application/x-www-form-urlencoded')) {
-
- local $^W = 0;
-
- read (STDIN, $post_data, $content_length);
- $self->_decode_url_encoded_data (\$post_data, 'form');
-
- return wantarray ?
- %{ $self->{web_data} } : $self->{web_data};
-
- } elsif ($content_type =~ /multipart\/form-data/) {
- ($boundary) = $content_type =~ /boundary=(\S+)$/;
- $self->_parse_multipart_data ($content_length, $boundary);
-
- return wantarray ?
- %{ $self->{web_data} } : $self->{web_data};
-
- } else {
- $self->_error ('Invalid content type!');
- }
-
- } else {
-
- ##++
- ## Got the idea of interactive debugging from CGI.pm, though it's
- ## handled a bit differently here. Thanks Lincoln!
- ##--
-
- print "[ Reading query from standard input. Press ^D to stop! ]\n";
-
- @query_input = <>;
- chomp (@query_input);
-
- $query_string = join ('&', @query_input);
- $query_string =~ s/\\(.)/sprintf ('%%%02X', ord ($1))/eg;
-
- $self->_decode_url_encoded_data (\$query_string, 'form');
-
- return wantarray ?
- %{ $self->{web_data} } : $self->{web_data};
- }
-}
-
-sub parse_cookies
-{
- my $self = shift;
- my $cookies;
-
- $cookies = $ENV{HTTP_COOKIE} || return;
-
- $self->_decode_url_encoded_data (\$cookies, 'cookies');
-
- return wantarray ?
- %{ $self->{web_data} } : $self->{web_data};
-}
-
-sub get_ordered_keys
-{
- my $self = shift;
-
- return wantarray ?
- @{ $self->{ordered_keys} } : $self->{ordered_keys};
-}
-
-sub print_data
-{
- my $self = shift;
- my ($key, $value, $eol);
-
- $eol = $self->{eol}->{$self->{platform}};
-
- foreach $key (@{ $self->{ordered_keys} }) {
- $value = $self->{web_data}->{$key};
-
- if (ref $value) {
- print "$key = @$value$eol";
- } else {
- print "$key = $value$eol";
- }
- }
-}
-
-sub print_mime_type
-{
- my ($self, $field) = @_;
-
- return($self->{'mime_types'}->{$field});
-}
-
-*print_form_data = *print_cookie_data = \&print_data;
-
-sub wrap_textarea
-{
- my ($self, $string, $length) = @_;
- my ($new_string, $platform, $eol);
-
- $length = 70 unless ($length);
- $platform = $self->{platform};
- $eol = $self->{eol}->{$platform};
- $new_string = $string || return;
-
- $new_string =~ s/[\0\r]\n?/ /sg;
- $new_string =~ s/(.{0,$length})\s/$1$eol/sg;
-
- return $new_string;
-}
-
-sub get_multiple_values
-{
- my ($self, $array) = @_;
-
- return (ref $array) ? (@$array) : $array;
-}
-
-sub create_variables
-{
- my ($self, $hash) = @_;
- my ($package, $key, $value);
-
- $package = $self->_determine_package;
-
- while (($key, $value) = each %$hash) {
- ${"$package\:\:$key"} = $value;
- }
-}
-
-sub is_error
-{
- my $self = shift;
-
- if ($self->{error_status}) {
- return (1);
- } else {
- return (0);
- }
-}
-
-sub get_error_message
-{
- my $self = shift;
-
- return $self->{error_message} if ($self->{error_message});
-}
-
-sub return_error
-{
- my ($self, @messages) = @_;
-
- print "@messages\n";
-
- exit (1);
-}
-
-##++
-## Exported Subroutines
-##--
-
-sub browser_escape
-{
- my $string = shift;
-
- $string =~ s/([<&"#%>])/sprintf ('&#%d;', ord ($1))/ge;
-
- return $string;
-}
-
-sub url_encode
-{
- my $string = shift;
-
- $string =~ s/([^-.\w ])/sprintf('%%%02X', ord $1)/ge;
- $string =~ tr/ /+/;
-
- return $string;
-}
-
-sub url_decode
-{
- my $string = shift;
-
- $string =~ tr/+/ /;
- $string =~ s/%([\da-fA-F]{2})/chr (hex ($1))/eg;
-
- return $string;
-}
-
-sub is_dangerous
-{
- my $string = shift;
-
- if ($string =~ /[;<>\*\|`&\$!#\(\)\[\]\{\}:'"]/) {
- return (1);
- } else {
- return (0);
- }
-}
-
-sub escape_dangerous_chars
-{
- my $string = shift;
-
- warn "escape_dangerous_chars() possibly dangerous. Its use is discouraged";
- $string =~ s/([;<>\*\|`&\$!#\(\)\[\]\{\}:'"\\\?\~\^\r\n])/\\$1/g;
-
- return $string;
-}
-
-##++
-## Internal Methods
-##--
-
-sub _error
-{
- my ($self, $message) = @_;
-
- $self->{error_status} = 1;
- $self->{error_message} = $message;
-}
-
-sub _determine_package
-{
- my $self = shift;
- my ($frame, $this_package, $find_package);
-
- $frame = -1;
- ($this_package) = split (/=/, $self);
-
- do {
- $find_package = caller (++$frame);
- } until ($find_package !~ /^$this_package/);
-
- return ($find_package);
-}
-
-##++
-## Decode URL encoded data
-##--
-
-sub _decode_url_encoded_data
-{
- my ($self, $reference_data, $type) = @_;
- my $code;
-
- $code = <<'End_of_URL_Decode';
-
- my (@key_value_pairs, $delimiter, $key_value, $key, $value);
-
- @key_value_pairs = ();
-
- return unless ($$reference_data);
-
- if ($type eq 'cookies') {
- $delimiter = ';\s+';
- } else {
- $delimiter = '&';
- }
-
- @key_value_pairs = split (/$delimiter/, $$reference_data);
-
- foreach $key_value (@key_value_pairs) {
- ($key, $value) = split (/=/, $key_value, 2);
-
- $value = '' unless defined $value; # avoid 'undef' warnings for "key=" BDL Jan/99
-
- $key = url_decode($key);
- $value = url_decode($value);
-
- if ( defined ($self->{web_data}->{$key}) ) {
- $self->{web_data}->{$key} = [$self->{web_data}->{$key}]
- unless ( ref $self->{web_data}->{$key} );
-
- push (@{ $self->{web_data}->{$key} }, $value);
- } else {
- $self->{web_data}->{$key} = $value;
- push (@{ $self->{ordered_keys} }, $key);
- }
- }
-
-End_of_URL_Decode
-
- eval ($code);
- $self->_error ($@) if $@;
-}
-
-##++
-## Methods dealing with multipart data
-##--
-
-sub _parse_multipart_data
-{
- my ($self, $total_bytes, $boundary) = @_;
- my ($code, $files);
-
- local $^W = 0;
- $files = {};
-
- $code = <<'End_of_Multipart';
-
- my ($seen, $buffer_size, $byte_count, $platform, $eol, $handle,
- $directory, $bytes_left, $buffer_size, $new_data, $old_data,
- $current_buffer, $changed, $store, $disposition, $headers,
- $mime_type, $convert, $field, $file, $new_name, $full_path);
-
- $seen = {};
- $buffer_size = $self->{buffer_size};
- $byte_count = 0;
- $platform = $self->{platform};
- $eol = $self->{eol}->{$platform};
- $handle = 'CL00';
- $directory = $self->{multipart_dir} || $self->{default_dir};
-
- while (1) {
- if ( ($byte_count < $total_bytes) &&
- (length ($current_buffer) < ($buffer_size * 2)) ) {
-
- $bytes_left = $total_bytes - $byte_count;
- $buffer_size = $bytes_left if ($bytes_left < $buffer_size);
-
- read (STDIN, $new_data, $buffer_size);
- $self->_error ("Oh, Oh! I'm upset! Can't read what I want.")
- if (length ($new_data) != $buffer_size);
-
- $byte_count += $buffer_size;
-
- if ($old_data) {
- $current_buffer = join ('', $old_data, $new_data);
- } else {
- $current_buffer = $new_data;
- }
-
- } elsif ($old_data) {
- $current_buffer = $old_data;
- $old_data = undef;
-
- } else {
- last;
- }
-
- $changed = 0;
-
- ##++
- ## When Netscape Navigator creates a random boundary string, you
- ## would expect it to pass that _same_ value in the environment
- ## variable CONTENT_TYPE, but it does not! Instead, it passes a
- ## value that has the first two characters ("--") missing.
- ##--
-
- if ($current_buffer =~
- /(.*?)(?:\015?\012)?-*$boundary-*[\015\012]*(?=(.*))/os) {
-
- ($store, $old_data) = ($1, $2);
-
- if ($current_buffer =~
- /[Cc]ontent-[Dd]isposition: ([^\015\012]+)\015?\012 # Disposition
- (?:([A-Za-z].*?)(?:\015?\012){2})? # Headers
- (?:\015?\012)? # End
- (?=(.*)) # Other Data
- /xs) {
-
- ($disposition, $headers, $current_buffer) = ($1, $2, $3);
- $old_data = $current_buffer;
-
- ($mime_type) = $headers =~ /[Cc]ontent-[Tt]ype: (\S+)/;
-
- $self->_store ($platform, $file, $convert, $handle, $eol,
- $field, \$store, $seen);
-
- close ($handle) if (fileno ($handle));
-
- if ($mime_type && $self->{convert}->{$mime_type}) {
- $convert = 1;
- } else {
- $convert = 0;
- }
-
- $changed = 1;
-
- ($field) = $disposition =~ /name="([^"]+)"/;
- ++$seen->{$field};
-
- $self->{'mime_types'}->{$field} = $mime_type;
-
- if ($seen->{$field} > 1) {
- $self->{web_data}->{$field} = [$self->{web_data}->{$field}]
- unless (ref $self->{web_data}->{$field});
- } else {
- push (@{ $self->{ordered_keys} }, $field);
- }
-
- if (($file) = $disposition =~ /filename="(.*)"/) {
- $file =~ s|.*[:/\\](.*)|$1|;
-
- $new_name = $self->_get_file_name ($platform,
- $directory, $file);
-
- $self->{web_data}->{$field} = $new_name;
-
- $full_path = join ($self->{file}->{$platform},
- $directory, $new_name);
-
- open (++$handle, ">$full_path")
- || $self->_error ("Can't create file: $full_path!");
-
- $files->{$new_name} = $full_path;
- }
- }
-
- } elsif ($old_data) {
- $store = $old_data;
- $old_data = $new_data;
-
- } else {
- $store = $current_buffer;
- $current_buffer = $new_data;
- }
-
- unless ($changed) {
- $self->_store ($platform, $file, $convert, $handle, $eol,
- $field, \$store, $seen);
- }
- }
-
- close ($handle) if (fileno ($handle));
-
-End_of_Multipart
-
- eval ($code);
- $self->_error ($@) if $@;
-
- $self->_create_handles ($files) if ($self->{file_type} eq 'handle');
-}
-
-sub _store
-{
- my ($self, $platform, $file, $convert, $handle, $eol, $field,
- $info, $seen) = @_;
-
- if ($file) {
- if ($convert) {
- $$info =~ s/\015\012/$eol/og if ($platform ne 'PC');
- $$info =~ s/\015/$eol/og if ($platform ne 'Mac');
- $$info =~ s/\012/$eol/og if ($platform ne 'Unix');
- }
-
- print $handle $$info;
-
- } elsif ($field) {
- if ($seen->{$field} > 1) {
- $self->{web_data}->{$field}->[$seen->{$field}-1] .= $$info;
- } else {
- $self->{web_data}->{$field} .= $$info;
- }
- }
-}
-
-sub _get_file_name
-{
- my ($self, $platform, $directory, $file) = @_;
- my ($filtered_name, $filename, $timestamp, $path);
-
- $filtered_name = &{ $self->{filter} }($file)
- if (ref ($self->{filter}) eq 'CODE');
-
- $filename = $filtered_name || $file;
- $timestamp = time . '__' . $filename;
-
- if (!$self->{timestamp}) {
- return $filename;
-
- } elsif ($self->{timestamp} == 1) {
- return $timestamp;
-
- } elsif ($self->{timestamp} == 2) {
- $path = join ($self->{file}->{$platform}, $directory, $filename);
-
- return (-e $path) ? $timestamp : $filename;
- }
-}
-
-sub _create_handles
-{
- my ($self, $files) = @_;
- my ($package, $handle, $name, $path);
-
- $package = $self->_determine_package;
-
- while (($name, $path) = each %$files) {
- $handle = "$package\:\:$name";
- open ($handle, "<$path")
- || $self->_error ("Can't read file: $path!");
-
- push (@{ $self->{all_handles} }, $handle);
- }
-}
-
-sub close_all_files
-{
- my $self = shift;
- my $handle;
-
- foreach $handle (@{ $self->{all_handles} }) {
- close $handle;
- }
-}
-
-1;
-
@@ -1,9 +1,4 @@
-MANIFEST This File
-CHANGES Revision History
-README Readme File
-Lite.pm CGI::Lite Module
-Makefile.PL Makefile Generator
-TODO Future work?
+CHANGES Revision History
examples/cookies Example 1
examples/file Example 2
examples/get_post Example 3
@@ -11,3 +6,17 @@ examples/post Example 4
examples/print Example 5
examples/reference Example 6
examples/upload Example 7
+lib/CGI/Lite.pm CGI::Lite Module
+LICENSE Licence details
+Makefile.PL Makefile Generator
+MANIFEST This File
+README Readme File
+t/basic.t
+t/cookie.t
+t/forms.t
+t/good_upload.txt
+t/mime_upload.txt
+t/post_text.txt
+t/uploads.t
+TODO Future work?
+META.yml Module meta-data (added by MakeMaker)
@@ -0,0 +1,25 @@
+--- #YAML:1.0
+name: CGI-Lite
+version: 2.05
+abstract: Process and decode WWW forms and cookies
+author:
+ - Pete Houston (cpan@openstrike.co.uk)
+license: perl
+distribution_type: module
+configure_requires:
+ ExtUtils::MakeMaker: 0
+build_requires:
+ Test::More: 0
+requires:
+ perl: 5.002000
+resources:
+ bugtracker: http://rt.cpan.org/Public/Dist/Display.html?Name=CGI-Lite
+ repository: https://github.com/openstrike/perl-CGI-Lite
+no_index:
+ directory:
+ - t
+ - inc
+generated_by: ExtUtils::MakeMaker version 6.57_05
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
@@ -1,24 +1,58 @@
use ExtUtils::MakeMaker;
+use strict;
require 5.002;
-$VERSION = "2.02";
-print "\nWelcome to the installation of CGI::Lite $VERSION...\n\n";
+my %MF = (
+ NAME => "CGI::Lite",
+ ABSTRACT => "Process and decode WWW forms and cookies",
+ AUTHOR => 'Pete Houston (cpan@openstrike.co.uk)',
+ BUILD_REQUIRES => {
+ 'Test::More' => '0',
+ },
+ LICENSE => 'perl',
+# META_MERGE cannot be made to work with spec version 2.0 and
+# my old ExtUtils::MakeMaker.
+# Restrict it to 1.4 for now
+ META_MERGE => {
+ 'meta-spec' => {
+ version => 1.4,
+# version => 2,
+# url => 'https://metacpan.org/pod/CPAN::Meta::Spec'
+ },
+ resources => {
+ bugtracker => 'http://rt.cpan.org/Public/Dist/Display.html?Name=CGI-Lite',
+ repository => 'https://github.com/openstrike/perl-CGI-Lite',
+# bugtracker => {
+# web => 'http://rt.cpan.org/Public/Dist/Display.html?Name=CGI-Lite'
+# },
+# repository => {
+# type => 'git',
+# url => 'git://github.com/openstrike/perl-CGI-Lite.git',
+# web => 'https://github.com/openstrike/perl-CGI-Lite',
+# }
+ }
+ },
+ MIN_PERL_VERSION => '5.2.0',
+ VERSION_FROM => 'lib/CGI/Lite.pm',
+ 'dist' => {
+ COMPRESS => 'gzip -9f',
+ SUFFIX => 'gz'
+ }
+);
-WriteMakefile (
- NAME => "CGI::Lite",
- VERSION => "$VERSION",
- 'dist' => {
- COMPRESS => 'gzip -9f',
- SUFFIX => 'gz'
- }
- );
+if ($ExtUtils::MakeMaker::VERSION lt 6.55) { delete $MF{BUILD_REQUIRES}; }
+if ($ExtUtils::MakeMaker::VERSION lt 6.48) { delete $MF{MIN_PERL_VERSION}; }
+if ($ExtUtils::MakeMaker::VERSION lt 6.46) { delete $MF{META_MERGE}; }
+if ($ExtUtils::MakeMaker::VERSION lt 6.31) { delete $MF{LICENSE}; }
+WriteMakefile (%MF);
print <<End_of_Text;
-Now do the following to install CGI::Lite $VERSION:
+Now do the following to install CGI::Lite:
- % make
+ % make
+ % make test
% make install
End_of_Text
@@ -1,17 +1,48 @@
-CGI::Lite v2.02
+CGI::Lite v2.05
----------------
+Released: 23rd Oct 2014
+
+
+DESCRIPTION
+-----------
+
You can use this module to decode form and query information, including file
uploads, as well as cookies in a very simple manner; you need not concern
yourself with the actual details behind the decoding process.
-Here are the changes for this version:
-Bugs in url_encode and url_decode have been fixed: they now correctly encode
-and decode data that was previously treated incorrectly.
+NEW IN THIS VERSION
+-------------------
+
+Documentation improvements, Makefile.PL tweaks.
+
+Changes since last stable release:
+
+binmode forced on all file writes to avoid corruption when converting
+EOLs on MSWin32.
+
+Upload tests fixed again to solve problems for MSWin32 users:
+binmode had been erroneously left off the inputs.
+
+Fixed generation of MYMETA/META files as spec 2.0 not yet supported
+in the local build environment.
+
+Upload tests fixed to solve two problems for MSWin32 users:
+permissions-based tests skipped and coversion algorithms for text MIME
+types improved.
+
+Full test coverage of non-deprecated features.
+
+BUG FIX: Multi-file uploads could break if the buffer end occured in the
+ headers of one of the files. (issue 99294)
+
+BUG FIX: $cgi->set_platform ('macintosh') erroneously set platform to
+ 'PC' because the regex was not anchored to the start. 'macintosh'
+ now results in platform 'Mac' as it should.
-Here are the changes for the previous version, 2.001:
+Version control moved to git.
-This is just an emergency release that fixes the most urgent security need.
+Makefile.PL extended to include resources (where available).
See the CHANGES file for full history.
@@ -1,3 +1,26 @@
+Tasks to perform:
+
+Create a legacy branch which will be 2.x and maintain backwards
+compatibility.
+Start a 3.x branch (trunk, really) which will be a code clean-up and
+removal of deprecated features. It will require at least 5.6.0 (for
+lexical filehandles)
+Consider adding a routine to set cookies.
+Decide whether to tighten validation of cookie names.
+Decide on the appropriate action to take when presented with multiple
+cookies with the same name and document it.
+
+Write tests for:
+ EOL processing for the different mime types
+ Fix the upload bug (RT 99294)
+ create_variables (no, just deprecate this one)
+
+Pete
+
+Below is Smyler's todo list from 2003.
+
+================================================================================
+
The list at the bottom is what I found in this TODO file when I took over this
module in 2003 August, presumably dating from 2000 or earlier. I haven't yet
decided whether I will actually do any of these things.
@@ -0,0 +1,1245 @@
+##++
+## CGI Lite v2.05
+## Last modified: 23 Oct 2014 (see CHANGES)
+##
+## Copyright (c) 1995, 1996, 1997 by Shishir Gundavaram
+## All Rights Reserved
+##
+## Permission to use, copy, and distribute is hereby granted,
+## providing that the above copyright notice and this permission
+## appear in all copies and in supporting documentation.
+##
+## Changes in versions 2.03 and newer copyright (c) 2014 Pete Houston
+##--
+
+###############################################################################
+
+=head1 NAME
+
+CGI::Lite - Process and decode WWW forms and cookies
+
+=head1 SYNOPSIS
+
+ use CGI::Lite;
+
+ $cgi = CGI::Lite->new ();
+
+ $cgi->set_platform ($platform);
+
+ # where $platform can be one of (case insensitive):
+ # Unix, Windows, Windows95, DOS, NT, PC, Mac or Macintosh
+
+ $cgi->set_file_type ($fh);
+
+ # where $fh is one of 'handle' or 'file'
+
+ $cgi->add_timestamp ($tsflag);
+
+ # where $tsflag takes one of these values
+ # 0 = no timestamp
+ # 1 = timestamp all files (default)
+ # 2 = timestamp only if file exists
+
+ $cgi->filter_filename (\&subroutine);
+
+ $size = $cgi->set_buffer_size ($some_buffer_size);
+
+ $status = $cgi->set_directory ('/some/dir');
+ $cgi->set_directory ('/some/dir') or die "Directory doesn't exist.\n";
+
+ $cgi->close_all_files;
+
+ $cgi->add_mime_type ('application/mac-binhex40');
+ $status = $cgi->remove_mime_type ('application/mac-binhex40');
+ @list = $cgi->get_mime_types;
+
+ $form = $cgi->parse_form_data;
+ %form = $cgi->parse_form_data;
+
+ # or
+
+ $form = $cgi->parse_form_data ('GET', 'HEAD' or 'POST');
+
+ $cookies = $cgi->parse_cookies;
+ %cookies = $cgi->parse_cookies;
+
+ $status = $cgi->is_error;
+ $message = $cgi->get_error_message;
+
+ $cgi->return_error ('error 1', 'error 2', ...);
+
+ $keys = $cgi->get_ordered_keys;
+ @keys = $cgi->get_ordered_keys;
+
+ $cgi->print_data;
+
+ $cgi->print_form_data; # (deprecated as of v1.8)
+ $cgi->print_cookie_data; # (deprecated as of v1.8)
+
+ $new_string = $cgi->wrap_textarea ($string, $length);
+
+ @all_values = $cgi->get_multiple_values ($reference);
+
+ $cgi->create_variables (\%form);
+ $cgi->create_variables ($form);
+
+ $escaped_string = browser_escape ($string);
+
+ $encoded_string = url_encode ($string);
+ $decoded_string = url_decode ($string);
+
+ $status = is_dangerous ($string);
+ $safe_string = escape_dangerous_chars ($string); # ***use is discouraged***
+
+=head1 DESCRIPTION
+
+You can use this module to decode form and query information,
+including file uploads, as well as cookies in a very simple
+manner; you need not concern yourself with the actual details
+behind the decoding process.
+
+=head1 METHODS
+
+Here are the methods you can use to process your forms and cookies:
+
+=over 4
+
+=item B<parse_form_data>
+
+This will handle the following types of requests: GET, HEAD and POST.
+By default, CGI::Lite uses the environment variable REQUEST_METHOD to
+determine the manner in which the query/form information should be
+decoded. However, as of v1.8, you are allowed to pass a valid request
+method to this function to force CGI::Lite to decode the information in
+a specific manner.
+
+For multipart/form-data, uploaded files are stored in the user selected
+directory (see B<set_directory>). If timestamp mode is on (see
+B<add_timestamp>), the files are named in the following format:
+
+ timestamp__filename
+
+where the filename is specified in the "Content-disposition" header.
+I<NOTE:>, the browser URL encodes the name of the file. This module
+makes I<no> effort to decode the information for security reasons.
+However, you can do so by creating a subroutine and then using
+the B<filter_filename> method.
+
+I<Return Value>
+
+Returns either a hash or a reference to the hash, which contains
+all of the key/value pairs. For fields that contain file information,
+the value contains either the path to the file, or the filehandle
+(see the B<set_file_type> method).
+
+=item B<parse_new_form_data>
+
+As for parse_form_data, but clears the CGI object state before processing
+the request. This is useful in persistant application (e.g. FCGI), where
+the CGI object is reused for multiple requests. e.g.
+
+ $CGI = new CGI::Lite;
+ while (FCGI::accept > 0)
+ {
+ $Query = $CGI->parse_new_form_data();
+ # process query
+ }
+
+=item B<parse_cookies>
+
+Decodes and parses cookies passed by the browser. This method works in
+much the same manner as B<parse_form_data>.
+
+=item B<is_error>
+
+As of v1.8, errors in parsing are handled differently. You can use this
+method to check for any potential errors after you've called either
+B<parse_form_data> or B<parse_cookies>.
+
+I<Return Value>
+
+ 0 Success
+ 1 Failure
+
+=item B<get_error_message>
+
+If an error occurs when parsing form/query information or cookies, you
+can use this method to retrieve the error message. Remember, you can
+check for errors by calling the B<is_error> method.
+
+I<Return Value>
+
+The error message.
+
+=item B<return_error>
+
+You can use this method to return errors to the browser and exit.
+
+=item B<set_platform>
+
+You can use this method to set the platform on which your Web server
+is running. CGI::Lite uses this information to translate end-of-line
+(EOL) characters for uploaded files (see the B<add_mime_type> and
+B<remove_mime_type> methods) so that they display properly on that
+platform.
+
+You can specify either (case insensitive):
+
+ Unix EOL: \012 = \n
+ Windows, Windows95, DOS, NT, PC EOL: \015\012 = \r\n
+ Mac or Macintosh EOL: \015 = \r
+
+"Unix" is the default.
+
+=item B<set_directory>
+
+Used to set the directory where the uploaded files will be stored
+(only applies to the I<multipart/form-data> encoding scheme).
+
+This function should be called I<before> you call B<parse_form_data>,
+or else the directory defaults to "/tmp". If the application cannot
+write to the directory for whatever reason, an error status is returned.
+
+I<Return Value>
+
+ 0 Failure
+ 1 Success
+
+=item B<close_all_files>
+
+All uploaded files that are opened as a result of calling B<set_file_type>
+with the "handle" argument can be closed in one shot by calling this
+method.
+
+=item B<add_mime_type>
+
+By default, EOL characters are translated for all uploaded files
+with specific MIME types (i.e text/plain, text/html, etc.). You
+can use this method to add to the list of MIME types. For example,
+if you want CGI::Lite to translate EOL characters for uploaded
+files of I<application/mac-binhex40>, then you would do this:
+
+ $cgi->add_mime_type ('application/mac-binhex40');
+
+=item B<remove_mime_type>
+
+This method is the converse of B<add_mime_type>. It allows you to
+remove a particular MIME type. For example, if you do not want
+CGI::Lite to translate EOL characters for uploaded files of I<text/html>,
+then you would do this:
+
+ $cgi->remove_mime_type ('text/html');
+
+I<Return Value>
+
+ 0 Failure
+ 1 Success
+
+=item B<get_mime_types>
+
+Returns the list, either as a reference or an actual list, of the
+MIME types for which EOL translation is performed.
+
+=item B<set_file_type>
+
+The I<names> of uploaded files are returned by default, when you call
+the B<parse_form_data> method. But, if pass the string "handle" to this
+method, the I<handles> to the files are returned. However, the name
+of the handle corresponds to the filename.
+
+This function should be called I<before> you call B<parse_form_data>, or
+else it will not work.
+
+=item B<add_timestamp>
+
+By default, a timestamp is added to the front of uploaded files.
+However, you have the option of completely turning off timestamp mode
+(value 0), or adding a timestamp only for existing files (value 2).
+
+=item B<filter_filename>
+
+You can use this method to change the manner in which uploaded
+files are named. For example, if you want uploaded filenames
+to be all upper case, you can use the following code:
+
+ $cgi->filter_filename (\&make_uppercase);
+ $cgi->parse_form_data;
+
+ .
+ .
+ .
+
+ sub make_uppercase
+ {
+ my $file = shift;
+
+ $file =~ tr/a-z/A-Z/;
+ return $file;
+ }
+
+=item B<set_buffer_size>
+
+This method allows you to set the buffer size when dealing with multipart
+form data. However, the I<actual> buffer size that the algorithm uses
+I<can> be up to 3x the value you specify. This ensures that boundary
+strings are not "split" between multiple reads. So, take this into
+consideration when setting the buffer size.
+
+You cannot set a buffer size below 256 bytes and above the total amount
+of multipart form data. The default value is 1024 bytes.
+
+I<Return Value>
+
+The buffer size.
+
+=item B<get_ordered_keys>
+
+Returns either a reference to an array or an array itself consisting
+of the form fields/cookies in the order they were parsed.
+
+I<Return Value>
+
+Ordered keys.
+
+=item B<print_data>
+
+Displays all the key/value pairs (either form data or cookie information)
+in a ordered fashion. The methods B<print_form_data> and B<print_cookie_data>
+are deprecated as of version v1.8, and will be removed in future versions.
+
+=item B<print_form_data>
+
+Deprecated as of v1.8, see B<print_data>.
+
+=item B<print_cookie_data> (deprecated as of v1.8)
+
+Deprecated as of v1.8, see B<print_data>.
+
+=item B<wrap_textarea>
+
+You can use this function to "wrap" a long string into one that is
+separated by a combination of carriage return and newline (see
+B<set_platform>) at fixed lengths. The two arguments that you need to
+pass to this method are the string and the length at which you want the
+line separator added.
+
+I<Return Value>
+
+The modified string.
+
+=item B<get_multiple_values>
+
+One of the major changes to this module as of v1.7 is that multiple
+values for a single key are returned as an reference to an array, and
+I<not> as a string delimited by the null character ("\0"). You can use
+this function to return the actual array. And if you pass a scalar
+value to this method, it will simply return that value.
+
+There was no way I could make this backward compatible with versions
+older than 1.7. I apologize!
+
+I<Return Value>
+
+Array consisting of the multiple values.
+
+=item B<create_variables>
+
+Sometimes, it is convenient to have scalar variables that represent
+the various keys in a hash. You can use this method to do just that.
+Say you have a hash like the following:
+
+ %form = ('name' => 'alan wells',
+ 'sport' => 'track and field',
+ 'events' => '100m');
+
+If you call this method in the following manner:
+
+ $cgi->create_variables (\%hash);
+
+it will create three scalar variables: $name, $sport and $events.
+Convenient, huh?
+
+=item B<browser_escape>
+
+Certain characters have special significance to the browser. These
+characters include: "<" and ">". If you want to display these "special"
+characters, you need to escape them using the following notation:
+
+ &#ascii;
+
+This method does just that.
+
+I<Return Value>
+
+Escaped string.
+
+=item B<url_encode>
+
+This method will URL encode a string that you pass it. You can use this
+to encode any data that you wish to pass as a query string to a CGI
+application.
+
+I<Return Value>
+
+URL encoded string.
+
+=item B<url_decode>
+
+You can use this method to URL decode a string.
+
+I<Return Value>
+
+URL decoded string.
+
+=item B<is_dangerous>
+
+This method checks for the existence of dangerous meta-characters.
+
+I<Return Value>
+
+ 0 Safe
+ 1 Dangerous
+
+=item B<escape_dangerous_chars>
+
+You can use this method to "escape" any dangerous meta-characters. B<The
+use of this function is strongly discouraged.> See
+L<https://web.archive.org/web/20100627014535/http://use.perl.org/~cbrooks/journal/10542>
+and L<http://www.securityfocus.com/archive/1/311414> for an
+advisory by Ronald F. Guilmette. Ronald's patch to make this function
+more safe is applied, but as has been pointed out on the bugtraq
+mailing list, it is still much better to run no external shell at all
+when executing commands. Please read the advisory and the WWW security
+FAQ.
+
+I<Return Value>
+
+Escaped string.
+
+=back
+
+=head1 VERSIONS
+
+This module has maintained backwards compatibility with versions of
+Perl back to 5.002 for a very long time. Such stability is a welcome
+attribute but it restricts the code by disallowing access to features
+introduced into the language since 1996.
+
+With this in mind, there will be two maintained branches of this module
+going forwards. The 2.x branch will retain the backwards compatibility
+but will not have any new features introduced. Changes to this branch
+will be bug fixes only. The new 3.x branch (unreleased as of October 2014)
+will be the main release and will require a more modern perl (version
+still to be determined but 5.6.0 would be the bare minumum). That 3.x
+branch will have new features and will remove some of the legacy code
+such as the B<print_form_data> method which has been deprecated for more
+than a decade.
+
+Requests for new features in the proposed 3.x branch should be made via
+the request tracker at L<https://rt.cpan.org/Public/Dist/Display.html?Name=CGI-Lite>
+
+=head1 SEE ALSO
+
+If you're looking for more comprehensive CGI modules, you can either use
+the CGI::* modules or L<CGI.pm|CGI>. Both are maintained by
+L<Dr. Lincoln Stein|http://search.cpan.org/CPAN/authors/id/L/LD/LDS/>
+and can be found at your local CPAN mirror.
+
+L<CGI::Lite::Request> uses similar method names to CGI.pm thus allowing
+easy transition between them. It uses this module as a
+dependency.
+
+=head1 REPOSITORY
+
+L<https://github.com/openstrike/perl-CGI-Lite/tree/legacy-master>
+
+=head1 MAINTAINER
+
+Maintenance of this module as of May 2014 has been taken over by Pete Houston
+<cpan@openstrike.co.uk>.
+
+=head1 ACKNOWLEDGMENTS
+
+The author thanks the following for finding bugs and offering suggestions:
+
+=over 4
+
+=item Eric D. Friedman (friedman@uci.edu)
+
+=item Thomas Winzig (tsw@pvo.com)
+
+=item Len Charest (len@cogent.net)
+
+=item Achim Bohnet (ach@rosat.mpe-garching.mpg.de)
+
+=item John E. Townsend (John.E.Townsend@BST.BLS.com)
+
+=item Andrew McRae (mcrae@internet.com)
+
+=item Dennis Grant (dg50@chrysler.com)
+
+=item Scott Neufeld (scott.neufeld@mis.ussurg.com)
+
+=item Raul Almquist (imrs@ShadowMAC.org)
+
+=item and many others!
+
+=back
+
+The present maintainer wishes to thank the previous maintainers:
+Smylers, Andreas, Ben and Shishir.
+
+=head1 COPYRIGHT INFORMATION
+
+ Copyright (c) 1995, 1996, 1997 by Shishir Gundavaram
+ All Rights Reserved
+
+ Permission to use, copy, and distribute is hereby granted,
+ providing that the above copyright notice and this permission
+ appear in all copies and in supporting documentation.
+
+ Changes in versions 2.03 - present copyright 2014 by Pete Houston
+
+=head1 LICENCE
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+###############################################################################
+
+package CGI::Lite;
+require 5.002;
+require Exporter;
+
+@ISA = (Exporter);
+@EXPORT = qw (browser_escape
+ url_encode
+ url_decode
+ is_dangerous
+ escape_dangerous_chars);
+
+##++
+## Global Variables
+##--
+
+$CGI::Lite::VERSION = '2.05';
+
+##++
+## Start
+##--
+
+sub new
+{
+ my $self;
+
+ $self = {
+ multipart_dir => undef,
+ default_dir => '/tmp',
+ file_type => 'name',
+ platform => 'Unix',
+ buffer_size => 1024,
+ timestamp => 1,
+ filter => undef,
+ web_data => {},
+ ordered_keys => [],
+ all_handles => [],
+ error_status => 0,
+ error_message => undef,
+ file_size_limit => 2097152,
+ };
+
+ $self->{convert} = {
+ 'text/html' => 1,
+ 'text/plain' => 1
+ };
+
+ $self->{file} = { Unix => '/', Mac => ':', PC => '\\' };
+ $self->{eol} = { Unix => "\012", Mac => "\015", PC => "\015\012" };
+
+ bless $self;
+ return $self;
+}
+
+sub Version
+{
+ return $VERSION;
+}
+
+sub set_directory
+{
+ my ($self, $directory) = @_;
+
+ stat ($directory);
+
+ if ( (-d _) && (-e _) && (-r _) && (-w _) ) {
+ $self->{multipart_dir} = $directory;
+ return (1);
+
+ } else {
+ return (0);
+ }
+}
+
+sub add_mime_type
+{
+ my ($self, $mime_type) = @_;
+
+ $self->{convert}->{$mime_type} = 1 if ($mime_type);
+}
+
+sub remove_mime_type
+{
+ my ($self, $mime_type) = @_;
+
+ if ($self->{convert}->{$mime_type}) {
+ delete $self->{convert}->{$mime_type};
+ return (1);
+
+ } else {
+ return (0);
+ }
+}
+
+sub get_mime_types
+{
+ my $self = shift;
+
+ return (sort keys %{ $self->{convert} });
+}
+
+sub set_platform
+{
+ my ($self, $platform) = @_;
+
+ if ($platform =~ /^(?:PC|NT|Windows(?:95)?|DOS)/i) {
+ $self->{platform} = 'PC';
+
+ } elsif ($platform =~ /^Mac(?:intosh)?/i) {
+
+ ## Should I check for NeXT here :-)
+
+ $self->{platform} = 'Mac';
+
+ } else {
+ $self->{platform} = 'Unix';
+ }
+}
+
+sub set_file_type
+{
+ my ($self, $type) = @_;
+
+ if ($type =~ /^handle$/i) {
+ $self->{file_type} = 'handle';
+ } else {
+ $self->{file_type} = 'name';
+ }
+}
+
+sub add_timestamp
+{
+ my ($self, $value) = @_;
+
+ if ( ($value < 0) || ($value > 2) ) {
+ $self->{timestamp} = 1;
+ } else {
+ $self->{timestamp} = $value;
+ }
+}
+
+sub filter_filename
+{
+ my ($self, $subroutine) = @_;
+
+ $self->{filter} = $subroutine;
+}
+
+sub set_buffer_size
+{
+ my ($self, $buffer_size) = @_;
+ my $content_length;
+
+ $content_length = $ENV{CONTENT_LENGTH} || return (0);
+
+ if ($buffer_size < 256) {
+ $self->{buffer_size} = 256;
+ } elsif ($buffer_size > $content_length) {
+ $self->{buffer_size} = $content_length;
+ } else {
+ $self->{buffer_size} = $buffer_size;
+ }
+
+ return ($self->{buffer_size});
+}
+
+sub parse_new_form_data
+# Reset state before parsing (for persistant CGI objects, e.g. under FastCGI)
+# BDL
+{
+ my ($self, @param) = @_;
+
+ # close files (should happen anyway when 'all_handles' is cleared...)
+ $self->close_all_files();
+
+ $self->{web_data} = {};
+ $self->{ordered_keys} = [];
+ $self->{all_handles} = [];
+ $self->{error_status} = 0;
+ $self->{error_message} = undef;
+
+ $self->parse_form_data(@param);
+}
+
+sub parse_form_data
+{
+ my ($self, $user_request) = @_;
+ my ($request_method, $content_length, $content_type, $query_string,
+ $boundary, $post_data, @query_input);
+
+ $request_method = $user_request || $ENV{REQUEST_METHOD} || '';
+ $content_length = $ENV{CONTENT_LENGTH};
+ $content_type = $ENV{CONTENT_TYPE};
+
+ if ($request_method =~ /^(get|head)$/i) {
+
+ $query_string = $ENV{QUERY_STRING};
+
+ # If for some reason this has been called as a class method instead
+ # of an object method and there's no query string, then give up now.
+ return unless ($query_string or ref $self);
+
+ $self->_decode_url_encoded_data (\$query_string, 'form');
+
+ return wantarray ?
+ %{ $self->{web_data} } : $self->{web_data};
+
+ } elsif ($request_method =~ /^post$/i) {
+
+ if (!$content_type ||
+ ($content_type =~ /^application\/x-www-form-urlencoded/)) {
+
+ local $^W = 0;
+
+ read (STDIN, $post_data, $content_length);
+ $self->_decode_url_encoded_data (\$post_data, 'form');
+
+ return wantarray ?
+ %{ $self->{web_data} } : $self->{web_data};
+
+ } elsif ($content_type =~ /multipart\/form-data/) {
+ ($boundary) = $content_type =~ /boundary=(\S+)$/;
+ $self->_parse_multipart_data ($content_length, $boundary);
+
+ return wantarray ?
+ %{ $self->{web_data} } : $self->{web_data};
+
+ } else {
+ $self->_error ('Invalid content type!');
+ }
+
+ } else {
+
+ ##++
+ ## Got the idea of interactive debugging from CGI.pm, though it's
+ ## handled a bit differently here. Thanks Lincoln!
+ ##--
+
+ print "[ Reading query from standard input. Press ^D to stop! ]\n";
+
+ @query_input = <>;
+ chomp (@query_input);
+
+ $query_string = join ('&', @query_input);
+ $query_string =~ s/\\(.)/sprintf ('%%%02X', ord ($1))/eg;
+
+ $self->_decode_url_encoded_data (\$query_string, 'form');
+
+ return wantarray ?
+ %{ $self->{web_data} } : $self->{web_data};
+ }
+}
+
+sub parse_cookies
+{
+ my $self = shift;
+ my $cookies;
+
+ $cookies = $ENV{HTTP_COOKIE} || return;
+
+ $self->_decode_url_encoded_data (\$cookies, 'cookies');
+
+ return wantarray ?
+ %{ $self->{web_data} } : $self->{web_data};
+}
+
+sub get_ordered_keys
+{
+ my $self = shift;
+
+ return wantarray ?
+ @{ $self->{ordered_keys} } : $self->{ordered_keys};
+}
+
+sub print_data
+{
+ my $self = shift;
+ my ($key, $value, $eol);
+
+ $eol = $self->{eol}->{$self->{platform}};
+
+ foreach $key (@{ $self->{ordered_keys} }) {
+ $value = $self->{web_data}->{$key};
+
+ if (ref $value) {
+ print "$key = @$value$eol";
+ } else {
+ print "$key = $value$eol";
+ }
+ }
+}
+
+sub print_mime_type
+{
+ my ($self, $field) = @_;
+
+ return($self->{'mime_types'}->{$field});
+}
+
+*print_form_data = *print_cookie_data = \&print_data;
+
+sub wrap_textarea
+{
+ my ($self, $string, $length) = @_;
+ my ($new_string, $platform, $eol);
+
+ $length = 70 unless ($length);
+ $platform = $self->{platform};
+ $eol = $self->{eol}->{$platform};
+ $new_string = $string || return;
+
+ $new_string =~ s/[\0\r]\n?/ /sg;
+ $new_string =~ s/(.{0,$length})\s/$1$eol/sg;
+
+ return $new_string;
+}
+
+sub get_multiple_values
+{
+ my ($self, $array) = @_;
+
+ return (ref $array) ? (@$array) : $array;
+}
+
+sub create_variables
+{
+ my ($self, $hash) = @_;
+ my ($package, $key, $value);
+
+ $package = $self->_determine_package;
+
+ while (($key, $value) = each %$hash) {
+ ${"$package\:\:$key"} = $value;
+ }
+}
+
+sub is_error
+{
+ my $self = shift;
+
+ if ($self->{error_status}) {
+ return (1);
+ } else {
+ return (0);
+ }
+}
+
+sub get_error_message
+{
+ my $self = shift;
+
+ return $self->{error_message} if ($self->{error_message});
+}
+
+sub return_error
+{
+ my ($self, @messages) = @_;
+
+ print "@messages\n";
+
+ exit (1);
+}
+
+##++
+## Exported Subroutines
+##--
+
+sub browser_escape
+{
+ my $string = shift;
+
+ $string =~ s/([<&"#%>])/sprintf ('&#%d;', ord ($1))/ge;
+
+ return $string;
+}
+
+sub url_encode
+{
+ my $string = shift;
+
+ $string =~ s/([^-.\w ])/sprintf('%%%02X', ord $1)/ge;
+ $string =~ tr/ /+/;
+
+ return $string;
+}
+
+sub url_decode
+{
+ my $string = shift;
+
+ $string =~ tr/+/ /;
+ $string =~ s/%([\da-fA-F]{2})/chr (hex ($1))/eg;
+
+ return $string;
+}
+
+sub is_dangerous
+{
+ my $string = shift;
+
+ if ($string =~ /[;<>\*\|`&\$!#\(\)\[\]\{\}:'"]/) {
+ return (1);
+ } else {
+ return (0);
+ }
+}
+
+sub escape_dangerous_chars
+{
+ my $string = shift;
+
+ warn "escape_dangerous_chars() possibly dangerous. Its use is discouraged";
+ $string =~ s/([;<>\*\|`&\$!#\(\)\[\]\{\}:'"\\\?\~\^\r\n])/\\$1/g;
+
+ return $string;
+}
+
+##++
+## Internal Methods
+##--
+
+sub _error
+{
+ my ($self, $message) = @_;
+
+ # Skip if we've been called as a class method
+ # because $self is not a hashref in such cases
+ return unless ref $self;
+ $self->{error_status} = 1;
+ $self->{error_message} = $message;
+}
+
+sub _determine_package
+{
+ my $self = shift;
+ my ($frame, $this_package, $find_package);
+
+ $frame = -1;
+ ($this_package) = split (/=/, $self);
+
+ do {
+ $find_package = caller (++$frame);
+ } until ($find_package !~ /^$this_package/);
+
+ return ($find_package);
+}
+
+##++
+## Decode URL encoded data
+##--
+
+sub _decode_url_encoded_data
+{
+ my ($self, $reference_data, $type) = @_;
+ my $code;
+
+ $code = <<'End_of_URL_Decode';
+
+ my (@key_value_pairs, $delimiter, $key_value, $key, $value);
+
+ @key_value_pairs = ();
+
+ return unless ($$reference_data);
+
+ if ($type eq 'cookies') {
+ $delimiter = '[;,]\s*';
+ } else {
+ $delimiter = '[;&]';
+ }
+
+ @key_value_pairs = split (/$delimiter/, $$reference_data);
+
+ foreach $key_value (@key_value_pairs) {
+ ($key, $value) = split (/=/, $key_value, 2);
+
+ $value = '' unless defined $value; # avoid 'undef' warnings for "key=" BDL Jan/99
+ next unless defined $key; # avoid 'undef' warnings for bogus URLs like 'foobar.cgi?&foo=bar'
+
+ if ($type eq 'cookies') {
+ # Strip leading/trailling whitespace as per RFC 2965
+ $key =~ s/^\s+|\s+$//g;
+ $value =~ s/^\s+|\s+$//g;
+ }
+
+ $key = url_decode($key);
+ $value = url_decode($value);
+
+ if ( defined ($self->{web_data}->{$key}) ) {
+ $self->{web_data}->{$key} = [$self->{web_data}->{$key}]
+ unless ( ref $self->{web_data}->{$key} );
+
+ push (@{ $self->{web_data}->{$key} }, $value);
+ } else {
+ $self->{web_data}->{$key} = $value;
+ push (@{ $self->{ordered_keys} }, $key);
+ }
+ }
+
+End_of_URL_Decode
+
+ eval ($code);
+ $self->_error ($@) if $@;
+}
+
+##++
+## Methods dealing with multipart data
+##--
+
+sub _parse_multipart_data
+{
+ my ($self, $total_bytes, $boundary) = @_;
+ my ($code, $files);
+
+ local $^W = 0;
+ $files = {};
+ $boundary = quotemeta ($boundary);
+
+ $code = <<'End_of_Multipart';
+
+ my ($seen, $buffer_size, $byte_count, $platform, $eol, $handle,
+ $directory, $bytes_left, $new_data, $old_data, $this_boundary,
+ $current_buffer, $changed, $store, $disposition, $headers,
+ $mime_type, $convert, $field, $file, $new_name, $full_path);
+
+ $seen = {};
+ $buffer_size = $self->{buffer_size};
+ $byte_count = 0;
+ $platform = $self->{platform};
+ $eol = $self->{eol}->{$platform};
+ $handle = 'CL00';
+ $directory = $self->{multipart_dir} || $self->{default_dir};
+
+ while (1) {
+ if ( ($byte_count < $total_bytes) &&
+ (length ($current_buffer) < ($buffer_size * 2)) ) {
+
+ $bytes_left = $total_bytes - $byte_count;
+ $buffer_size = $bytes_left if ($bytes_left < $buffer_size);
+
+ read (STDIN, $new_data, $buffer_size);
+ $self->_error ("Oh, Oh! I'm upset! Can't read what I want.")
+ if (length ($new_data) != $buffer_size);
+
+ $byte_count += $buffer_size;
+
+ if ($old_data) {
+ $current_buffer = join ('', $old_data, $new_data);
+ } else {
+ $current_buffer = $new_data;
+ }
+
+ } elsif ($old_data) {
+ $current_buffer = $old_data;
+ $old_data = undef;
+
+ } else {
+ last;
+ }
+
+ $changed = 0;
+
+ ##++
+ ## When Netscape Navigator creates a random boundary string, you
+ ## would expect it to pass that _same_ value in the environment
+ ## variable CONTENT_TYPE, but it does not! Instead, it passes a
+ ## value that has the first two characters ("--") missing.
+ ##--
+
+ if ($current_buffer =~
+ /(.*?)((?:\015?\012)?-*$boundary-*[\015\012]*)(?=(.*))/os) {
+
+ ($store, $this_boundary, $old_data) = ($1, $2, $3);
+
+ if ($current_buffer =~
+ /[Cc]ontent-[Dd]isposition: ([^\015\012]+)\015?\012 # Disposition
+ (?:([A-Za-z].*?)(?:\015?\012))? # Headers
+ (?:\015?\012) # End
+ (?=(.*)) # Other Data
+ /xs) {
+
+ ($disposition, $headers, $current_buffer) = ($1, $2, $3);
+ $old_data = $current_buffer;
+
+ ($mime_type) = $headers =~ /[Cc]ontent-[Tt]ype: (\S+)/;
+
+ $self->_store ($platform, $file, $convert, $handle, $eol,
+ $field, \$store, $seen);
+
+ close ($handle) if (fileno ($handle));
+
+ if ($mime_type && $self->{convert}->{$mime_type}) {
+ $convert = 1;
+ } else {
+ $convert = 0;
+ }
+
+ $changed = 1;
+
+ ($field) = $disposition =~ /name="([^"]+)"/;
+ ++$seen->{$field};
+
+ $self->{'mime_types'}->{$field} = $mime_type;
+
+ if ($seen->{$field} > 1) {
+ $self->{web_data}->{$field} = [$self->{web_data}->{$field}]
+ unless (ref $self->{web_data}->{$field});
+ } else {
+ push (@{ $self->{ordered_keys} }, $field);
+ }
+
+ if (($file) = $disposition =~ /filename="(.*)"/) {
+ $file =~ s|.*[:/\\](.*)|$1|;
+
+ $new_name = $self->_get_file_name ($platform,
+ $directory, $file);
+
+ $self->{web_data}->{$field} = $new_name;
+
+ $full_path = join ($self->{file}->{$platform},
+ $directory, $new_name);
+
+ open (++$handle, ">$full_path")
+ || $self->_error ("Can't create file: $full_path!");
+
+ $files->{$new_name} = $full_path;
+ }
+ } elsif ($byte_count < $total_bytes) {
+ $old_data = $this_boundary . $old_data;
+ }
+
+ } elsif ($old_data) {
+ $store = $old_data;
+ $old_data = $new_data;
+
+ } else {
+ $store = $current_buffer;
+ $current_buffer = $new_data;
+ }
+
+ unless ($changed) {
+ $self->_store ($platform, $file, $convert, $handle, $eol,
+ $field, \$store, $seen);
+ }
+ }
+
+ close ($handle) if (fileno ($handle));
+
+End_of_Multipart
+
+ eval ($code);
+ $self->_error ($@) if $@;
+
+ $self->_create_handles ($files) if ($self->{file_type} eq 'handle');
+}
+
+sub _store
+{
+ my ($self, $platform, $file, $convert, $handle, $eol, $field,
+ $info, $seen) = @_;
+
+ if ($file) {
+ if ($convert) {
+ if ($platform eq 'PC') {
+ $$info =~ s/\015(?=[^\012])|(?<=[^\015])\012/$eol/og;
+ } else {
+ $$info =~ s/\015\012/$eol/og;
+ $$info =~ s/\015/$eol/og if ($platform ne 'Mac');
+ $$info =~ s/\012/$eol/og if ($platform ne 'Unix');
+ }
+ }
+
+ binmode $handle;
+ print $handle $$info;
+
+ } elsif ($field) {
+ if ($seen->{$field} > 1) {
+ $self->{web_data}->{$field}->[$seen->{$field}-1] .= $$info;
+ } else {
+ $self->{web_data}->{$field} .= $$info;
+ }
+ }
+}
+
+sub _get_file_name
+{
+ my ($self, $platform, $directory, $file) = @_;
+ my ($filtered_name, $filename, $timestamp, $path);
+
+ $filtered_name = &{ $self->{filter} }($file)
+ if (ref ($self->{filter}) eq 'CODE');
+
+ $filename = $filtered_name || $file;
+ $timestamp = time . '__' . $filename;
+
+ if (!$self->{timestamp}) {
+ return $filename;
+
+ } elsif ($self->{timestamp} == 1) {
+ return $timestamp;
+
+ } elsif ($self->{timestamp} == 2) {
+ $path = join ($self->{file}->{$platform}, $directory, $filename);
+
+ return (-e $path) ? $timestamp : $filename;
+ }
+}
+
+sub _create_handles
+{
+ my ($self, $files) = @_;
+ my ($package, $handle, $name, $path);
+
+ $package = $self->_determine_package;
+
+ while (($name, $path) = each %$files) {
+ $handle = "$package\:\:$name";
+ open ($handle, "<$path")
+ || $self->_error ("Can't read file: $path!");
+
+ push (@{ $self->{all_handles} }, $handle);
+ }
+}
+
+sub close_all_files
+{
+ my $self = shift;
+ my $handle;
+
+ foreach $handle (@{ $self->{all_handles} }) {
+ close $handle;
+ }
+}
+
+1;
+
@@ -0,0 +1,92 @@
+#
+#===============================================================================
+#
+# FILE: basic.t
+#
+# DESCRIPTION: Test of the most basic functionality
+#
+# FILES: ---
+# BUGS: ---
+# NOTES: ---
+# AUTHOR: Pete Houston (cpan@openstrike.co.uk)
+# COMPANY: Openstrike
+# CREATED: 13/05/14 21:36:53
+#
+# Updates:
+# 21/08/2014 Now tests set_platform, wrap_textarea and get_error_message.
+# 25/08/2014 Now tests get_multiple values.
+#===============================================================================
+
+use strict;
+
+use Test::More tests => 306; # last test to print
+
+use lib './lib';
+
+BEGIN { use_ok ('CGI::Lite') }
+
+is ($CGI::Lite::VERSION, '2.05', 'Version test');
+is (CGI::Lite::Version (), $CGI::Lite::VERSION, 'Version subroutine test');
+
+my $cgi = CGI::Lite->new ();
+
+is (ref $cgi, 'CGI::Lite', 'New');
+
+is (browser_escape ('<&>'), '<&>', 'browser_escape');
+
+{
+ my @from = qw/! " # $ % ^ & * ( ) _ + - =/;
+ my @to = qw/%21 %22 %23 %24 %25 %5E %26 %2A %28 %29 _ %2B - %3D/;
+
+ for my $i (0..$#from) {
+ is (url_encode($from[$i]), $to[$i], "url_encode $from[$i]");
+ is (url_decode($to[$i]), $from[$i], "url_decode $to[$i]");
+ }
+}
+
+my $dangerous = ';<>*|`&$!#()[]{}:\'"';
+
+for my $i(0..255) {
+ my $chr = chr($i);
+ if (index ($dangerous, $chr) eq -1) {
+ # Not
+ is (is_dangerous ($chr), 0, "Dangerous $i (not)");
+ } else {
+ is (is_dangerous ($chr), 1, "Dangerous $i");
+ }
+}
+
+for my $platform (qw/WINdows WINdows95 dos nt pc/) {
+ $cgi->set_platform ($platform);
+ is ($cgi->{platform}, 'PC', "Set platform ($platform)");
+}
+for my $platform (qw/mac MacIntosh/) {
+ $cgi->set_platform ($platform);
+ is ($cgi->{platform}, 'Mac', "Set platform ($platform)");
+}
+# Unix is default
+$cgi->set_platform ('foo');
+is ($cgi->{platform}, 'Unix', "Set default platform");
+
+my $longstr = '123 456 789 0123456 7 89 0';
+is ($cgi->wrap_textarea ($longstr, 5), "123\n456\n789\n0123456\n7 89\n0",
+ "wrap_textarea Unix");
+$cgi->set_platform ("DOS");
+is ($cgi->wrap_textarea ($longstr, 5), "123\r\n456\r\n789\r\n0123456\r\n7 89\r\n0",
+ "wrap_textarea DOS");
+$cgi->set_platform ("Mac");
+is ($cgi->wrap_textarea ($longstr, 5), "123\r456\r789\r0123456\r7 89\r0",
+ "wrap_textarea Mac");
+
+is ($cgi->is_error(), 0, 'No errors');
+is ($cgi->get_error_message, undef, 'No error message');
+
+is ($cgi->get_multiple_values (), undef,
+ 'get_multiple_values (no argument)');
+is ($cgi->get_multiple_values ('foo'), 'foo',
+ 'get_multiple_values (scalar argument)');
+is ($cgi->get_multiple_values ('foo', 'bar'), 'foo',
+ 'get_multiple_values (array argument)');
+my $foobar = ['foo', 'bar'];
+my @res = $cgi->get_multiple_values ($foobar);
+is_deeply (\@res, $foobar, 'get_multiple_values (array ref argument)');
@@ -0,0 +1,185 @@
+#
+#===============================================================================
+#
+# FILE: cookie.t
+#
+# DESCRIPTION: Test of cookie parsing
+#
+# FILES: ---
+# BUGS: ---
+# NOTES: ---
+# AUTHOR: Pete Houston (cpan@openstrike.co.uk)
+# COMPANY: Openstrike
+# CREATED: 20/05/14 16:12:33
+#
+# Updates:
+# 25/08/2014 Now tests get_ordered_keys and print_data.
+#===============================================================================
+
+use strict;
+
+use Test::More tests => 235; # last test to print
+
+use lib './lib';
+
+BEGIN { use_ok ('CGI::Lite') }
+
+# Set up a CGI environment
+$ENV{REQUEST_METHOD} = 'GET';
+$ENV{PATH_INFO} = '/somewhere/else';
+$ENV{PATH_TRANSLATED} = '/usr/local/somewhere/else';
+$ENV{SCRIPT_NAME} ='/cgi-bin/foo.cgi';
+$ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
+$ENV{SERVER_PORT} = 8080;
+$ENV{SERVER_NAME} = 'there.is.no.try.com';
+$ENV{QUERY_STRING} = '';
+
+$ENV{HTTP_COOKIE} = 'foo=bar; baz=quux';
+my $cgi = CGI::Lite->new ();
+my $cookies = $cgi->parse_cookies;
+my $testname = 'simple';
+
+is ($cgi->is_error, 0, "Cookie parse ($testname)");
+is (scalar keys %$cookies, 2, "Cookie count ($testname)");
+ok (exists $cookies->{foo}, "First cookie name ($testname)");
+is ($cookies->{foo}, 'bar', "First cookie value ($testname)");
+ok (exists $cookies->{baz}, "Second cookie name ($testname)");
+is ($cookies->{baz}, 'quux', "Second cookie value ($testname)");
+
+
+
+$ENV{HTTP_COOKIE} = ' foo=bar ; baz = quux ';
+$cgi = CGI::Lite->new ();
+$cookies = $cgi->parse_cookies;
+$testname = 'extra space';
+
+is ($cgi->is_error, 0, "Cookie parse ($testname)");
+is (scalar keys %$cookies, 2, "Cookie count ($testname)");
+ok (exists $cookies->{foo}, "First cookie name ($testname)");
+is ($cookies->{foo}, 'bar', "First cookie value ($testname)");
+ok (exists $cookies->{baz}, "Second cookie name ($testname)");
+is ($cookies->{baz}, 'quux', "Second cookie value ($testname)");
+
+$ENV{HTTP_COOKIE} = 'foo=bar;baz=quux';
+$cgi = CGI::Lite->new ();
+$cookies = $cgi->parse_cookies;
+$testname = 'zero space';
+
+is ($cgi->is_error, 0, "Cookie parse ($testname)");
+is (scalar keys %$cookies, 2, "Cookie count ($testname)");
+ok (exists $cookies->{foo}, "First cookie name ($testname)");
+is ($cookies->{foo}, 'bar', "First cookie value ($testname)");
+ok (exists $cookies->{baz}, "Second cookie name ($testname)");
+is ($cookies->{baz}, 'quux', "Second cookie value ($testname)");
+
+$ENV{HTTP_COOKIE} = '%20foo%20=%20bar%20;b%20a%20z=qu%20ux';
+$cgi = CGI::Lite->new ();
+$cookies = $cgi->parse_cookies;
+$testname = 'interstitial space';
+
+is ($cgi->is_error, 0, "Cookie parse ($testname)");
+is (scalar keys %$cookies, 2, "Cookie count ($testname)");
+ok (exists $cookies->{' foo '}, "First cookie name ($testname)");
+is ($cookies->{' foo '}, ' bar ', "First cookie value ($testname)");
+ok (exists $cookies->{'b a z'}, "Second cookie name ($testname)");
+is ($cookies->{'b a z'}, 'qu ux', "Second cookie value ($testname)");
+
+my $ref = [];
+$ref = $cgi->get_ordered_keys;
+is_deeply ($ref, [' foo ', 'b a z'],
+ 'get_ordered_keys arrayref for cookie data');
+my @ref = $cgi->get_ordered_keys;
+is_deeply (\@ref, [' foo ', 'b a z'],
+ 'get_ordered_keys array for cookie data');
+
+SKIP: {
+ skip ("No file created for stdout", 2) unless open (my $tmp, '>tmpout');
+ select $tmp;
+ $cgi->print_data;
+ close $tmp;
+ open $tmp, '<tmpout';
+ chomp (my $printed = <$tmp>);
+ is ($printed, q# foo = bar #, 'print_data first cookie');
+ chomp ($printed = <$tmp>);
+ is ($printed, q#b a z = qu ux#, 'print_data second cookie');
+ close $tmp and unlink 'tmpout';
+}
+
+# Other url-escaped chars here
+
+for my $special (33 .. 47, 58 .. 64, 91 .. 96, 123 .. 126) {
+ $ENV{HTTP_COOKIE} = sprintf 'a=%%%X;%%%X=1', $special, $special;
+ $cgi = CGI::Lite->new ();
+ $cookies = $cgi->parse_cookies;
+ $testname = "Special value ($ENV{HTTP_COOKIE})";
+ is ($cgi->is_error, 0, "Cookie parse ($testname)");
+ is (scalar keys %$cookies, 2, "Cookie count ($testname)");
+ ok (exists $cookies->{'a'}, "First cookie name ($testname)");
+ is ($cookies->{'a'}, chr($special), "First cookie value ($testname)");
+ ok (exists $cookies->{chr($special)}, "Second cookie name ($testname)");
+ is ($cookies->{chr($special)}, 1, "Second cookie value ($testname)");
+}
+
+$ENV{HTTP_COOKIE} = '=bar';
+$cgi = CGI::Lite->new ();
+$cookies = $cgi->parse_cookies;
+$testname = 'Missing key';
+
+is ($cgi->is_error, 0, "Cookie parse ($testname)");
+is (scalar keys %$cookies, 1, "Cookie count ($testname)");
+ok (exists $cookies->{''}, "First cookie name ($testname)");
+is ($cookies->{''}, 'bar', "First cookie value ($testname)");
+
+# Bad cookies!
+
+$ENV{HTTP_COOKIE} = 'f;o;o=b;a;r';
+$cgi = CGI::Lite->new ();
+$cookies = $cgi->parse_cookies;
+$testname = 'Extra semicolons';
+
+is ($cgi->is_error, 0, "Cookie parse ($testname)");
+is (scalar keys %$cookies, 4, "Cookie count ($testname)");
+ok (exists $cookies->{'o'}, "First cookie name ($testname)");
+is (ref $cookies->{'o'}, 'ARRAY', "First cookie ref ($testname)");
+is ($cookies->{'o'}->[0], '', "First cookie first elem ($testname)");
+is ($cookies->{'o'}->[1], 'b', "First cookie second elem ($testname)");
+
+$ENV{HTTP_COOKIE} = 'foo==bar';
+$cgi = CGI::Lite->new ();
+$cookies = $cgi->parse_cookies;
+$testname = 'Extra equals';
+
+is ($cgi->is_error, 0, "Cookie parse ($testname)");
+is (scalar keys %$cookies, 1, "Cookie count ($testname)");
+ok (exists $cookies->{'foo'}, "First cookie name ($testname)");
+is ($cookies->{'foo'}, '=bar', "First cookie value ($testname)");
+
+# Need to decide how strict the cookie validation should be. If strict,
+# then these tests could be used. Leaving it lax for now.
+# See eg. http://bugs.python.org/issue2193
+#
+#for my $char (split (//, '()<>@:\"/[]?={} ')) {
+#
+# $ENV{HTTP_COOKIE} = "f${char}o=bar";
+# $cgi = CGI::Lite->new ();
+# $cookies = $cgi->parse_cookies;
+# $testname = qq#Bad key char: "$char"#;
+#
+# is ($cgi->is_error, 1, "Cookie parse ($testname)");
+# is (scalar keys %$cookies, 0, "Cookie count ($testname)");
+#
+# $ENV{HTTP_COOKIE} = "foo=b${char}r";
+# $cgi = CGI::Lite->new ();
+# $cookies = $cgi->parse_cookies;
+# $testname = qq#Bad value char: "$char"#;
+#
+# is ($cgi->is_error, 1, "Cookie parse ($testname)");
+# is (scalar keys %$cookies, 0, "Cookie count ($testname)");
+#
+#}
+#
+# What about multiple cookies with the same name?
+# cookie o is actually an arrayref, which is neat, but does it match the
+# RFC?
+#ok (exists $cookies->{'b a z'}, "Second cookie name ($testname)");
+#is ($cookies->{'b a z'}, 'qu ux', "Second cookie value ($testname)");
@@ -0,0 +1,126 @@
+#
+#===============================================================================
+#
+# FILE: forms.t
+#
+# DESCRIPTION: Test form-handling
+#
+# FILES: post_text.txt
+# BUGS: ---
+# NOTES: ---
+# AUTHOR: Pete Houston (cpan@openstrike.co.uk)
+# COMPANY: Openstrike
+# CREATED: 14/05/14 12:27:26
+#
+# Updates:
+# 25/08/2014 Now tests get_ordered_keys and print_data.
+#===============================================================================
+
+use strict;
+
+use Test::More tests => 27; # last test to print
+
+use lib './lib';
+
+BEGIN { use_ok ('CGI::Lite') }
+
+# Set up a CGI environment
+$ENV{REQUEST_METHOD} = 'GET';
+$ENV{QUERY_STRING} = 'game=chess&game=checkers&weather=dull';
+$ENV{PATH_INFO} = '/somewhere/else';
+$ENV{PATH_TRANSLATED} = '/usr/local/somewhere/else';
+$ENV{SCRIPT_NAME} = '/cgi-bin/foo.cgi';
+$ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
+$ENV{SERVER_PORT} = 8080;
+$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com';
+
+CGI::Lite->parse_form_data;
+
+my $cgi = CGI::Lite->new;
+my $form = $cgi->parse_form_data;
+
+is ($cgi->is_error, 0, 'Parsing data with GET');
+is ($form->{weather}, 'dull', 'Parsing scalar param with GET');
+is (ref $form->{game}, 'ARRAY', 'Parsing array param with GET');
+is ($form->{game}->[1], 'checkers', 'Extracting array param value with GET');
+
+$ENV{QUERY_STRING} =~ s/\&/;/g;
+$form = $cgi->parse_new_form_data;
+
+is ($cgi->is_error, 0, 'Parsing semicolon data with GET');
+is ($form->{weather}, 'dull', 'Parsing semicolon scalar param with GET');
+is (ref $form->{game}, 'ARRAY', 'Parsing semicolon array param with GET');
+is ($form->{game}->[1], 'checkers', 'Extracting semicolon array param value with GET');
+
+$ENV{QUERY_STRING} = '&=&&foo=bar';
+$form = $cgi->parse_new_form_data;
+
+is ($cgi->is_error, 0, 'GET with missing kv pair');
+is ($form->{foo}, 'bar', 'Value after GET with missing kv pair');
+
+# Now with POSTed application/x-www-form-urlencoded
+$ENV{REQUEST_METHOD} = 'POST';
+$ENV{QUERY_STRING} = '';
+my $datafile = 't/post_text.txt';
+
+$ENV{CONTENT_LENGTH} = (stat ($datafile))[7];
+# Now what? Print to STDIN?
+#
+
+($cgi, $form) = post_data ($datafile);
+
+is ($cgi->is_error, 0, 'Parsing data with POST');
+is ($form->{bar}, 'quux', 'Parsing scalar param with POST');
+is (ref $form->{foo}, 'ARRAY', 'Parsing array param with POST');
+is ($form->{foo}->[1], 'baz', 'Extracting array param value with POST');
+
+$ENV{CONTENT_TYPE} = 'baz';
+($cgi, $form) = post_data ($datafile);
+is ($cgi->is_error, 1, 'Invalid content type with POST');
+is ($cgi->get_error_message, 'Invalid content type!', 'Invalid content type message with POST');
+
+$ENV{CONTENT_TYPE} = 'application/x-www-form-urlencoded';
+($cgi, $form) = post_data ($datafile);
+is ($cgi->is_error, 0, 'Content type x-www-form-urlencoded with POST');
+
+$ENV{CONTENT_TYPE} = 'application/x-www-form-urlencoded; charset=UTF-8';
+($cgi, $form) = post_data ($datafile);
+is ($cgi->is_error, 0, 'Content type x-www-form-urlencoded and charset with POST');
+is ($form->{bar}, 'quux', 'Scalar param with POST as x-www-form-urlencoded');
+is (ref $form->{foo}, 'ARRAY', 'Parsing array param with POST as x-www-form-urlencoded');
+is ($form->{foo}->[1], 'baz', 'Extracting array param value with POST as x-www-form-urlencoded');
+
+my $ref = [];
+$ref = $cgi->get_ordered_keys;
+is_deeply ($ref, ['foo', 'bar', 'notused'],
+ 'get_ordered_keys arrayref for form data');
+my @ref = $cgi->get_ordered_keys;
+is_deeply (\@ref, ['foo', 'bar', 'notused'],
+ 'get_ordered_keys array for form data');
+
+SKIP: {
+ skip ("No file created for stdout", 3) unless open (my $tmp, '>tmpout');
+ select $tmp;
+ $cgi->print_data;
+ close $tmp;
+ open $tmp, '<tmpout';
+ chomp (my $printed = <$tmp>);
+ is ($printed, q#foo = bar baz#, 'print_data double value');
+ chomp ($printed = <$tmp>);
+ is ($printed, q#bar = quux#, 'print_data single value');
+ chomp ($printed = <$tmp>);
+ is ($printed, q#notused = #, 'print_data no value');
+ close $tmp and unlink 'tmpout';
+}
+
+sub post_data {
+ my $datafile = shift;
+ local *STDIN;
+ open STDIN, "<$datafile"
+ or die "Cannot open test file $datafile: $!";
+ binmode STDIN;
+ my $cgi = CGI::Lite->new;
+ my $form = $cgi->parse_form_data;
+ close STDIN;
+ return ($cgi, $form);
+}
diff --git a/var/tmp/source/HOUSTON/CGI-Lite-2.05/CGI-Lite-2.05/t/good_upload.txt b/var/tmp/source/HOUSTON/CGI-Lite-2.05/CGI-Lite-2.05/t/good_upload.txt
new file mode 100644
index 00000000..23e81d95
Binary files /dev/null and b/var/tmp/source/HOUSTON/CGI-Lite-2.05/CGI-Lite-2.05/t/good_upload.txt differ
@@ -0,0 +1,50 @@
+--`!"$%^&*()-+[]{}'@.?~#|aaa
+Content-Disposition: form-data; name="plain_txt"; filename="test0.txt"
+Content-Length: 186
+Content-Type: text/plain
+
+This is a test of a plain text document.
+It has several lines of text,
+and can be used to test how the EOL characters
+are handled by CGI::Lite.
+It is not intended for any other purpose.
+
+--`!"$%^&*()-+[]{}'@.?~#|aaa
+Content-Disposition: form-data; name="html_txt"; filename="test0.html"
+Content-Length: 212
+Content-Type: text/html
+
+<h1>This is a test of an HTML document</h1>
+<p>
+It has several lines of text,
+and can be used to test how the EOL characters
+are handled by CGI::Lite.
+</p>
+<p><b>It is not intended for any other purpose.</b></p>
+
+--`!"$%^&*()-+[]{}'@.?~#|aaa
+Content-Disposition: form-data; name="plain_win_txt"; filename="test1.txt"
+Content-Length: 191
+Content-Type: text/plain
+
+This is a test of a plain text document.
+It has several lines of text,
+and can be used to test how the EOL characters
+are handled by CGI::Lite.
+It is not intended for any other purpose.
+
+--`!"$%^&*()-+[]{}'@.?~#|aaa
+Content-Disposition: form-data; name="html_win_txt"; filename="test1.html"
+Content-Length: 219
+Content-Type: text/html
+
+<h1>This is a test of an HTML document</h1>
+<p>
+It has several lines of text,
+and can be used to test how the EOL characters
+are handled by CGI::Lite.
+</p>
+<p><b>It is not intended for any other purpose.</b></p>
+
+--`!"$%^&*()-+[]{}'@.?~#|aaa--
+
@@ -0,0 +1 @@
+foo=bar&foo=baz&bar=quux¬used=
@@ -0,0 +1,223 @@
+#
+#===============================================================================
+#
+# FILE: uploads.t
+#
+# DESCRIPTION: Test of multipart/form-data uploads
+#
+# FILES: good_upload.txt
+# BUGS: ---
+# NOTES: This borrows very heavily from upload.t in CGI.pm
+# AUTHOR: Pete Houston (cpan@openstrike.co.uk)
+# COMPANY: Openstrike
+# CREATED: 20/05/14 14:01:34
+#===============================================================================
+
+use strict;
+
+use Test::More tests => 11254; # last test to print
+
+use lib './lib';
+
+BEGIN { use_ok ('CGI::Lite') }
+
+# Set up a CGI environment
+$ENV{REQUEST_METHOD} = 'POST';
+$ENV{PATH_INFO} = '/somewhere/else';
+$ENV{PATH_TRANSLATED} = '/usr/local/somewhere/else';
+$ENV{SCRIPT_NAME} ='/cgi-bin/foo.cgi';
+$ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
+$ENV{SERVER_PORT} = 8080;
+$ENV{SERVER_NAME} = 'there.is.no.try.com';
+$ENV{QUERY_STRING} = '';
+my $datafile = 't/good_upload.txt';
+$ENV{CONTENT_LENGTH} = (stat ($datafile))[7];
+$ENV{CONTENT_TYPE} = q#multipart/form-data; boundary=`!"$%^&*()-+[]{}'@.?~\#|aaa#;
+
+my $uploaddir = 'tmpcgilite';
+mkdir ($uploaddir, 0700) unless -d $uploaddir;
+
+
+my ($cgi, $form) = post_data ($datafile, $uploaddir);
+
+is ($cgi->is_error, 0, 'Parsing data with POST');
+like ($form->{'does_not_exist_gif'}, '/[0-9]+__does_not_exist\.gif/', 'Second file');
+like ($form->{'100;100_gif'}, '/[0-9]+__100;100\.gif/', 'Third file');
+like ($form->{'300x300_gif'}, '/[0-9]+__300x300\.gif/', 'Fourth file');
+
+# XXX Duplicate field names for files do NOT work currently. Fix this
+# and then implement some tests.
+
+my @files = qw/does_not_exist_gif 100;100_gif 300x300_gif/;
+my @sizes = qw/0 896 1656/;
+for my $i (0..2) {
+ my $file = "$uploaddir/$form->{$files[$i]}";
+ ok (-e "$file", "Uploaded file exists ($i)") or warn "Name = '$file'\n" . $cgi->get_error_message;
+ is ((stat($file))[7], $sizes[$i], "File size check ($i)") or
+ warn_tail ($file);
+}
+
+is ($cgi->set_directory ('/srhslgvsgnlsenhglsgslvngh'), 0,
+ 'Set directory (non-existant)');
+my $testdir = 'testperms';
+mkdir $testdir, 0400;
+SKIP: {
+ skip "subdir '$testdir' could not be created", 3
+ unless (-d $testdir and not -w $testdir);
+
+ is ($cgi->set_directory ($testdir), 0, 'Set directory (unwriteable)');
+ chmod 0200, $testdir;
+ is ($cgi->set_directory ($testdir), 0, 'Set directory (unreadable)');
+ rmdir $testdir and open my $td, ">$testdir";
+ print $td "Test\n";
+ close $td;
+ is ($cgi->set_directory ($testdir), 0, 'Set directory (non-directory)');
+ unlink $testdir;
+}
+
+# Mime type tests
+# Documentation says get_mime_types can return an arrayref, but
+# that seems not to be the case.
+
+my @mimetypes = $cgi->get_mime_types ();
+ok ($#mimetypes > 0, 'get_mime_types returns array');
+is_deeply (\@mimetypes, [ 'text/html', 'text/plain' ],
+ 'default mime types');
+
+$cgi->add_mime_type ('application/json');
+@mimetypes = $cgi->get_mime_types ();
+is ($#mimetypes, 2, 'added a mime type');
+is ($mimetypes[0], 'application/json', 'added mime type is correct');
+
+is ($cgi->remove_mime_type ('foo/bar'), 0,
+ 'removed non-existant mime type');
+is ($cgi->remove_mime_type ('text/html'), 1,
+ 'removed existant mime type');
+@mimetypes = $cgi->get_mime_types ();
+is ($#mimetypes, 1, 'Count of mime types after removal');
+is_deeply (\@mimetypes, [ 'application/json', 'text/plain' ],
+ 'Correct mime types after removal');
+
+# Filename tests
+
+$cgi->add_timestamp (0);
+is ($cgi->{timestamp}, 0, 'timestamp is zero');
+($cgi, $form) = post_data ($datafile, $uploaddir, $cgi);
+is ($cgi->is_error, 0, 'Parsing data with POST');
+like ($form->{'does_not_exist_gif'}, '/^does_not_exist\.gif/', 'Second file');
+like ($form->{'100;100_gif'}, '/^100;100\.gif/', 'Third file');
+like ($form->{'300x300_gif'}, '/^300x300\.gif/', 'Fourth file');
+
+unlink ("$uploaddir/300x300.gif");
+
+$cgi->add_timestamp (2);
+is ($cgi->{timestamp}, 2, 'timestamp is 2');
+($cgi, $form) = post_data ($datafile, $uploaddir, $cgi);
+is ($cgi->is_error, 0, 'Parsing data with POST');
+like ($form->{'does_not_exist_gif'}, '/[0-9]+__does_not_exist\.gif/', 'Second file');
+like ($form->{'100;100_gif'}, '/[0-9]+__100;100\.gif/', 'Third file');
+like ($form->{'300x300_gif'}, '/^300x300\.gif/', 'Fourth file');
+
+sub cleanfile {
+ my $name = shift;
+ $name =~ s/[^a-z0-9\._-]+/_/ig;
+ return $name
+}
+
+unlink "$uploaddir/100_100.gif" if -e "$uploaddir/100_100.gif";
+
+$cgi->filter_filename (\&cleanfile);
+ok (defined $cgi->{filter}, 'Filename filter set');
+($cgi, $form) = post_data ($datafile, $uploaddir, $cgi);
+is ($cgi->is_error, 0, 'Parsing data with POST');
+like ($form->{'does_not_exist_gif'}, '/^[0-9]+__does_not_exist\.gif/', 'Second file');
+like ($form->{'100;100_gif'}, '/^100_100\.gif/', 'Third file');
+like ($form->{'300x300_gif'}, '/^[0-9]+__300x300\.gif/', 'Fourth file');
+
+# Buffer size setting tests
+
+is ($cgi->set_buffer_size(1), 256, 'Buffer size too low');
+is ($cgi->set_buffer_size(1000000), $ENV{CONTENT_LENGTH}, 'Buffer size too high');
+
+# File type tests
+
+unlink "$uploaddir/100_100.gif" if -e "$uploaddir/100_100.gif";
+$cgi->set_file_type ('jibber');
+is ($cgi->{file_type}, 'name', 'File type defaults to name');
+$cgi->set_file_type ('handle');
+is ($cgi->{file_type}, 'handle', 'File type set to handle');
+
+($cgi, $form) = post_data ($datafile, $uploaddir, $cgi);
+is ($cgi->is_error, 0, 'Parsing data with POST');
+like ($form->{'does_not_exist_gif'}, '/^[0-9]+__does_not_exist\.gif/', 'Second file');
+like ($form->{'100;100_gif'}, '/^100_100\.gif/', 'Third file');
+like ($form->{'300x300_gif'}, '/^[0-9]+__300x300\.gif/', 'Fourth file');
+# Check the handles
+my $imgdata = '';
+my $handle = $form->{'100;100_gif'};
+while (<$handle>) {
+ $imgdata .= $_;
+}
+is (length ($imgdata), 896, 'File handle upload');
+
+is (eof ($form->{'300x300_gif'}), '', 'File open');
+$cgi->close_all_files;
+is (eof ($form->{'300x300_gif'}), 1, 'File closed');
+
+# Tests required for these:
+# check mime types are honoured on upload
+# The text/plain should be altered, but the text/html should not.
+# Run this with a wide window of buffer sizes to ensure there are no
+# edge cases.
+$datafile = 't/mime_upload.txt';
+$ENV{CONTENT_LENGTH} = (stat ($datafile))[7];
+$cgi->add_timestamp (0);
+$cgi->set_file_type ('name');
+@files = qw/plain_txt html_txt plain_win_txt html_win_txt/;
+@sizes = qw/186 212 186 219/;
+@sizes = qw/191 212 191 219/ if $^O eq 'MSWin32';
+for my $buf_size (256 .. 1500) {
+ $cgi->set_buffer_size($buf_size);
+ ($cgi, $form) = post_data ($datafile, $uploaddir, $cgi);
+ is ($cgi->is_error, 0, "Parsing data with POST (buffer size $buf_size)");
+
+ for my $i (0..3) {
+ my $file = "$uploaddir/$form->{$files[$i]}";
+ ok (-e "$file", "Uploaded file exists ($i - buffer size $buf_size") or
+ warn "Name = '$file'\n" . $cgi->get_error_message;
+ is ((stat($file))[7], $sizes[$i],
+ "File size check ($i - buffer size $buf_size)") or
+ warn_tail ($file);
+ unlink ($file);
+ }
+}
+
+sub post_data {
+ my ($datafile, $dir, $cgi) = @_;
+ local *STDIN;
+ open STDIN, "<$datafile"
+ or die "Cannot open test file $datafile: $!";
+ binmode STDIN;
+ $cgi ||= CGI::Lite->new;
+ $cgi->set_platform ('DOS') if $^O eq 'MSWin32';
+ $cgi->set_directory ($dir);
+ my $form = $cgi->parse_new_form_data;
+ close STDIN;
+ return ($cgi, $form);
+}
+
+sub warn_tail {
+ # If there's a size mismatch on the uploaded files, dump the end of
+ # the file here. Ideally this should never be called.
+ my $file = shift;
+ my $n = 32;
+ open (my $in, "<$file") or return warn "Cannot open $file for reading. $!";
+ binmode $in;
+ local $/ = undef;
+ my $contents = <$in>;
+ close $file;
+ my $lastn = substr ($contents, 0 - $n);
+ foreach (split (//, $lastn, $n)) {
+ print $n-- . " chars from the end: " . ord ($_) . "\n";
+ }
+}