@@ -1,6 +1,40 @@
-* v2.05 - 23rd October 2014
+* v3.00 - 21st May 2015
-Documentation improvements, Makefile.PL tweaks.
+No changes from v2.99_04.
+
+* v2.99_04 (pre-release for 3.0) - 18th May 2015
+
+Uploaded files with duplicate field names are treated in the
+same ways as other data with duplicate field names.
+
+* v2.99_03 (pre-release for 3.0) - 5th April 2015
+
+BUG FIX: Additional change to forms.t to prevent MS Windows systems
+ hanging. (issue 103315)
+
+* v2.99_02 (pre-release for 3.0) - 4th April 2015
+
+Added force_unique_cookies method and equivalent parsing code and tests.
+
+Improved test suite: better coverage, skipped failling tests for
+Microsoft systems which don't use/honour normal permissions, silenced
+noisy tests on older perls.
+
+* v2.99_01 (pre-release for 3.0) - 31st March 2015
+
+Source amended to pass perlcritic. String evals removed or replaced.
+Strictures added to module and examples. All filehandles are now
+lexicals. Consistent source formatting applied to module (perltidy).
+
+deny_uploads and set_size_limit added.
+
+All active public subroutines are now methods.
+
+print_cookie_data and print_form_data have been removed. They had been
+deprecated for well over a decade.
+
+escape_dangerous_chars has been removed. It has been considered a
+security risk since version 2.0.
* v2.04_05 - 11th October 2014
@@ -60,7 +94,7 @@ Microsoft users.
The documentation has been amended to reflect the change of maintainer.
-* v2.03 - May 25, 2014
+* v2.03 - 25th May 2014
Maintainer change: Pete Houston has taken over maintenance from Smylers.
@@ -15,8 +15,14 @@ t/basic.t
t/cookie.t
t/forms.t
t/good_upload.txt
+t/large_file_upload.txt
t/mime_upload.txt
+t/post_stdin.txt
t/post_text.txt
+t/upload_no_files.txt
+t/upload_no_trailing_files.txt
t/uploads.t
TODO Future work?
-META.yml Module meta-data (added by MakeMaker)
+xt/release/kwalitee.t
+META.yml Module YAML meta-data (added by MakeMaker)
+META.json Module JSON meta-data (added by MakeMaker)
@@ -0,0 +1,51 @@
+{
+ "abstract" : "Process and decode WWW forms and cookies",
+ "author" : [
+ "Pete Houston (cpan@openstrike.co.uk)"
+ ],
+ "dynamic_config" : 1,
+ "generated_by" : "ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.143240",
+ "license" : [
+ "perl_5"
+ ],
+ "meta-spec" : {
+ "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
+ "version" : "2"
+ },
+ "name" : "CGI-Lite",
+ "no_index" : {
+ "directory" : [
+ "t",
+ "inc"
+ ]
+ },
+ "prereqs" : {
+ "build" : {
+ "requires" : {
+ "ExtUtils::MakeMaker" : "0",
+ "Test::More" : "0"
+ }
+ },
+ "configure" : {
+ "requires" : {
+ "ExtUtils::MakeMaker" : "0"
+ }
+ },
+ "runtime" : {
+ "requires" : {
+ "Symbol" : "0",
+ "perl" : "5.006000"
+ }
+ }
+ },
+ "release_status" : "stable",
+ "resources" : {
+ "bugtracker" : {
+ "web" : "http://rt.cpan.org/Public/Dist/Display.html?Name=CGI-Lite"
+ },
+ "repository" : {
+ "url" : "https://github.com/openstrike/perl-CGI-Lite"
+ }
+ },
+ "version" : "3.00"
+}
@@ -1,25 +1,27 @@
---- #YAML:1.0
-name: CGI-Lite
-version: 2.05
-abstract: Process and decode WWW forms and cookies
+---
+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
+ - 'Pete Houston (cpan@openstrike.co.uk)'
build_requires:
- Test::More: 0
+ ExtUtils::MakeMaker: '0'
+ Test::More: '0'
+configure_requires:
+ ExtUtils::MakeMaker: '0'
+dynamic_config: 1
+generated_by: 'ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.143240'
+license: perl
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: '1.4'
+name: CGI-Lite
+no_index:
+ directory:
+ - t
+ - inc
requires:
- perl: 5.002000
+ Symbol: '0'
+ perl: '5.006000'
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
+ bugtracker: http://rt.cpan.org/Public/Dist/Display.html?Name=CGI-Lite
+ repository: https://github.com/openstrike/perl-CGI-Lite
+version: '3.00'
@@ -1,25 +1,16 @@
use ExtUtils::MakeMaker;
use strict;
-require 5.002;
+use warnings;
+require 5.6.0;
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'
- },
+ 'meta-spec' => { version => 1.4 },
resources => {
bugtracker => 'http://rt.cpan.org/Public/Dist/Display.html?Name=CGI-Lite',
repository => 'https://github.com/openstrike/perl-CGI-Lite',
@@ -33,7 +24,13 @@ my %MF = (
# }
}
},
- MIN_PERL_VERSION => '5.2.0',
+ MIN_PERL_VERSION => '5.6.0',
+ PREREQ_PM => {
+ 'Symbol' => '0',
+ },
+ TEST_REQUIRES => {
+ 'Test::More' => '0',
+ },
VERSION_FROM => 'lib/CGI/Lite.pm',
'dist' => {
COMPRESS => 'gzip -9f',
@@ -41,10 +38,16 @@ my %MF = (
}
);
-if ($ExtUtils::MakeMaker::VERSION lt 6.55) { delete $MF{BUILD_REQUIRES}; }
+if ($ExtUtils::MakeMaker::VERSION lt 6.64) {
+ if ($ExtUtils::MakeMaker::VERSION ge 6.55) {
+ $MF{BUILD_REQUIRES} = $MF{TEST_REQUIRES};
+ }
+ delete $MF{TEST_REQUIRES};
+}
+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}; }
+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;
@@ -1,48 +1,52 @@
-CGI::Lite v2.05
-----------------
+CGI::Lite v3.00
+---------------
-Released: 23rd Oct 2014
+Released: 21st May 2015
+
+This is the first public release of the
+new 3.0 branch. Please be aware of the API changes with particular
+reference to the deprecated and obsolete subroutines and methods.
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.
+This module can be used to decode CGI form data, query strings, file
+uploads and cookies in a very simple manner.
+
+It has no dependencies and is therefore relatively fast to instantiate.
+This makes it well suited to a non-persistent CGI scenario.
NEW IN THIS VERSION
-------------------
-Documentation improvements, Makefile.PL tweaks.
-
-Changes since last stable release:
+These are the changes since the last public release (2.05).
-binmode forced on all file writes to avoid corruption when converting
-EOLs on MSWin32.
+Uploaded files with duplicate field names are treated in the
+same ways as other data with duplicate field names.
-Upload tests fixed again to solve problems for MSWin32 users:
-binmode had been erroneously left off the inputs.
+BUG FIX: Additional change to forms.t to prevent MS Windows systems
+ hanging. (issue 103315)
-Fixed generation of MYMETA/META files as spec 2.0 not yet supported
-in the local build environment.
+Added force_unique_cookies method and equivalent parsing code and tests.
-Upload tests fixed to solve two problems for MSWin32 users:
-permissions-based tests skipped and coversion algorithms for text MIME
-types improved.
+Improved test suite: better coverage, skipped failling tests for
+Microsoft systems which don't use/honour normal permissions, silenced
+noisy tests on older perls.
-Full test coverage of non-deprecated features.
+Source amended to pass perlcritic. String evals removed or replaced.
+Strictures added to module and examples. All filehandles are now
+lexicals. Consistent source formatting applied to module (perltidy).
-BUG FIX: Multi-file uploads could break if the buffer end occured in the
- headers of one of the files. (issue 99294)
+deny_uploads and set_size_limit added.
-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.
+All active public subroutines are now methods.
-Version control moved to git.
+print_cookie_data and print_form_data have been removed. They had been
+deprecated for well over a decade.
-Makefile.PL extended to include resources (where available).
+escape_dangerous_chars has been removed. It has been considered a
+security risk since version 2.0.
See the CHANGES file for full history.
@@ -1,47 +1,5 @@
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.
+Consider adding a routine to set cookies and possibly other common
+headers. Perhaps put such optional extras into a separate module.
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.
-
-Before making any changes to the functionality of CGI::Lite, I want to get the
-distribution into better shape. This include clarifying the licence and
-creating some tests. I'm also thinking updating it to use Module::Build for
-creating the distribution.
-
-Any changes I make will have tickets opened for them in CPAN Request Tracker,
-where comments can be made:
-
- http://rt.cpan.org/NoAuth/Bugs.html?Dist=CGI-Lite
-
-And of course all users are welcome to submit feature requests and bug reports
-through this interface.
-
-Smylers
-
-* Saving and re-loading form data
-* Convenient way to output HTTP headers (including cookies)
-* Creating HTML tables from arrays
-* Support for ISINDEX. Does anyone still use this?
-
@@ -1,11 +1,14 @@
-#!/usr/local/bin/perl5
+#!/usr/bin/perl
# Simple example to dump all the cookies :-)
+use strict;
+use warnings;
+
use CGI::Lite;
-$cgi = new CGI::Lite;
-%cookies = $cgi->parse_cookies;
+my $cgi = CGI::Lite->new;
+my %cookies = $cgi->parse_cookies;
print "Content-type: text/plain", "\n\n";
@@ -15,10 +18,8 @@ print "Content-type: text/plain", "\n\n";
#
# instead of manually iterating through the data.
-while (($key, $value) = each %cookies) {
+while (my ($key, $value) = each %cookies) {
print "$key = $value\n";
}
-exit (0);
-
-
+exit;
@@ -1,4 +1,4 @@
-#!/usr/local/bin/perl5
+#!/usr/bin/perl
# Simply displays the key/value pairs. Here is how the output
# would look for multipart/form-data forms:
@@ -10,18 +10,18 @@
# As of v1.8, CGI::Lite no longer returns the entire path name for
# uploaded files.
-use CGI::Lite;
+use strict;
+use warnings;
-$cgi = new CGI::Lite;
+use CGI::Lite;
-$cgi->set_directory ("/usr/shishir") || die "Directory doesn't exist.\n";
+my $cgi = CGI::Lite->new;
+my $dir = '/var/tmp';
+$cgi->set_directory ($dir) or die "Cannot use directory $dir.\n";
# We're ignoring the returned value.
-
$cgi->parse_form_data;
-
print "Content-type: text/plain", "\n\n";
-
$cgi->print_data;
-exit (0);
+exit;
@@ -1,17 +1,20 @@
-#!/usr/local/bin/perl5
+#!/usr/bin/perl
# Very much like the reference.pl example, except for the fact
# that we're calling the parse_form_data in a different context;
# the method returns a hash, so we don't need to dereference.
+use strict;
+use warnings;
use CGI::Lite;
-$cgi = new CGI::Lite;
-%data = $cgi->parse_form_data;
+my $cgi = CGI::Lite->new;
+my %data = $cgi->parse_form_data;
+my @all_values = ();
print "Content-type: text/plain", "\n\n";
-while (($key, $value) = each %data) {
+while (my ($key, $value) = each %data) {
# Let's check to see if a value is a reference to an array,
# which indicates multiple values for the field.
@@ -27,8 +30,8 @@ while (($key, $value) = each %data) {
print "\nHere are the same key/value pairs in order:\n";
-foreach $key ($cgi->get_ordered_keys) {
- $value = $data{$key};
+foreach my $key ($cgi->get_ordered_keys) {
+ my $value = $data{$key};
if (ref $value) {
@all_values = $cgi->get_multiple_values ($value);
@@ -39,4 +42,4 @@ foreach $key ($cgi->get_ordered_keys) {
}
}
-exit (0);
+exit;
@@ -1,11 +1,14 @@
-#!/usr/local/bin/perl5
+#!/usr/bin/perl
# Very much like the get_post.pl, except we're passing a request
# method to parse_form_data.
+use strict;
+use warnings;
use CGI::Lite;
-$cgi = new CGI::Lite;
+my $cgi = CGI::Lite->new;
+my @all_values = ();
# We specifically instruct CGI::Lite to read POSTed form data. Why
# is this useful, you may ask? This forces the user to fill out
@@ -14,11 +17,11 @@ $cgi = new CGI::Lite;
#
# http://www.some.com/cgi-bin/program.pl?name=john&age=45
-%data = $cgi->parse_form_data ('POST');
+my %data = $cgi->parse_form_data ('POST');
print "Content-type: text/plain", "\n\n";
-while (($key, $value) = each %data) {
+while (my ($key, $value) = each %data) {
# Let's check to see if a value is a reference to an array,
# which indicates multiple values for the field.
@@ -34,8 +37,8 @@ while (($key, $value) = each %data) {
print "\nHere are the same key/value pairs in order:\n";
-foreach $key ($cgi->get_ordered_keys) {
- $value = $data{$key};
+foreach my $key ($cgi->get_ordered_keys) {
+ my $value = $data{$key};
if (ref $value) {
@all_values = $cgi->get_multiple_values ($value);
@@ -46,4 +49,4 @@ foreach $key ($cgi->get_ordered_keys) {
}
}
-exit (0);
+exit;
@@ -1,45 +1,32 @@
-#!/usr/local/bin/perl5
+#!/usr/bin/perl
-# Example that shows the effect of wrap_textarea and create_variables.
+# Example that shows the effect of wrap_textarea.
# Let's assume we're getting three fields: name, bio, skills.
+use strict;
+use warnings;
use CGI::Lite;
-$cgi = new CGI::Lite;
-%form = $cgi->parse_form_data;
+my $cgi = CGI::Lite->new;
+my %form = $cgi->parse_form_data;
+my @all_skills = ();
print "Content-type: text/plain\n\n";
-# The create_variables method needs a reference to a hash. We could
-# call this method in the following manner as well:
-#
-# $form = $cgi->parse_form_data;
-# $cgi->create_variables ($form);
-#
-# Because we have three fields, the create_variables creates three
-# variables for us: $name, $bio and $skills.
-
-$cgi->create_variables (\%form);
-
-if (ref $skills) {
- @all_skills = $cgi->get_multiple_values ($skills);
+if (ref $form{skills}) {
+ @all_skills = $cgi->get_multiple_values ($form{skills});
}
-$nice_bio = $cgi->wrap_textarea ($bio);
+my $nice_bio = $cgi->wrap_textarea ($form{bio});
print <<End_of_Display;
-Name: $name
-Skills: $skills
+Name: $form{name}
+Skills: @all_skills
Bio:
$nice_bio
End_of_Display
-exit (0);
-
-
-
-
-
+exit;
@@ -1,11 +1,13 @@
-#!/usr/local/bin/perl5
+#!/usr/bin/perl
# Simple example that performs the same function as the
# print_data method.
+use strict;
+use warnings;
use CGI::Lite;
-$cgi = new CGI::Lite;
+my $cgi = CGI::Lite->new;
# The return value is stored in $data, which contains a
# reference to the hash. In order to access an element, you
@@ -15,12 +17,12 @@ $cgi = new CGI::Lite;
# $$data{readme}
# %$data
-$data = $cgi->parse_form_data;
+my $data = $cgi->parse_form_data;
print "Content-type: text/plain", "\n\n";
-while (($key, $value) = each %$data) {
+while (my ($key, $value) = each %$data) {
print "$key = $value\n";
}
-exit (0);
+exit;
@@ -1,16 +1,18 @@
-#!/usr/local/bin/perl5
+#!/usr/bin/perl
# Simple example that displays the data associated with
# the "readme" file field in a multiform/form-data request.
+use strict;
+use warnings;
use CGI::Lite;
-$cgi = new CGI::Lite;
+my $cgi = CGI::Lite->new;
# Die if the directory is invalid (i.e doesn't exist, can't
# read or write to it, or is not a directory).
-$cgi->set_directory ("/tmp") || die "Directory doesn't exist.\n";
+$cgi->set_directory ("/tmp") or die "Directory doesn't exist.\n";
# Set the platform. "Unix" is the default. The method accepts
# platforms in a case insensitive manner, so you can pass
@@ -46,12 +48,12 @@ $cgi->remove_mime_type ('text/html');
# Let's go ahead and parse the data!
-$data = $cgi->parse_form_data;
+my $data = $cgi->parse_form_data;
print "Content-type: text/plain", "\n\n";
if ($cgi->is_error) {
- $error_message = $cgi->get_error_message;
+ my $error_message = $cgi->get_error_message;
print <<End_of_Error;
@@ -72,7 +74,7 @@ End_of_Error
#
# NOTE: $readme also contains the name of the file.
- $readme = $data->{readme};
+ my $readme = $data->{readme};
print <<End_of_Header;
@@ -1,6 +1,9 @@
##++
-## CGI Lite v2.05
-## Last modified: 23 Oct 2014 (see CHANGES)
+## CGI Lite v3.00
+##
+## see separate CHANGES file for detailed history
+##
+## Changes in versions 2.03 and newer copyright (c) 2014-2015 Pete Houston
##
## Copyright (c) 1995, 1996, 1997 by Shishir Gundavaram
## All Rights Reserved
@@ -8,8 +11,6 @@
## 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
##--
###############################################################################
@@ -20,99 +21,51 @@ 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;
+ use CGI::Lite ();
- $form = $cgi->parse_form_data;
- %form = $cgi->parse_form_data;
+ my $cgi = CGI::Lite->new ();
- # or
+ $cgi->set_directory ('/some/dir') or die "Directory cannot be set.\n";
+ $cgi->add_mime_type ('text/csv');
- $form = $cgi->parse_form_data ('GET', 'HEAD' or 'POST');
+ my $cookies = $cgi->parse_cookies;
+ my $form = $cgi->parse_new_form_data;
- $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***
+ my $status = $cgi->is_error;
+ if ($status) {
+ my $message = $cgi->get_error_message;
+ die $message;
+ }
=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.
+This module can be used to decode form data, query strings, file uploads
+and cookies in a very simple manner.
+
+It has no dependencies and is therefore relatively fast to
+instantiate. This makes it well suited to a non-persistent CGI scenario.
=head1 METHODS
-Here are the methods you can use to process your forms and cookies:
+Here are the methods used to process the forms and cookies:
=over 4
+=item B<new>
+
+The constructor takes no arguments and returns a new CGI::Lite object.
+
=item B<parse_form_data>
-This will handle the following types of requests: GET, HEAD and POST.
+This handles 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
+decoded. However, it may also be passed a valid request
+method as a scalar string to force CGI::Lite to decode the information in
a specific manner.
+ my $params = $cgi->parse_form_data ('GET');
+
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:
@@ -122,11 +75,9 @@ B<add_timestamp>), the files are named in the following format:
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
+However, this can be achieved 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
@@ -135,55 +86,56 @@ the value contains either the path to the file, or the filehandle
=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 request. This is useful in persistent applications (e.g. FCGI), where
the CGI object is reused for multiple requests. e.g.
- $CGI = new CGI::Lite;
+ my $CGI = CGI::Lite->new ();
while (FCGI::accept > 0)
{
- $Query = $CGI->parse_new_form_data();
+ my $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>.
+much the same manner as B<parse_form_data>. As these two data sources
+are treated the same internally, users who wish to extract form and
+cookie data separately might find it easiest to call
+parse_cookies first and then parse_new_form_data in order to retrieve
+two distinct hashes (or hashrefs).
=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>.
+This method is used to check for any potential errors after calling
+either B<parse_form_data> or B<parse_cookies>.
-I<Return Value>
+ my $form = $cgi->parse_form_data ();
+ my $went_wrong = $cgi->is_error ();
- 0 Success
- 1 Failure
+Returns 0 if there is no error, 1 otherwise.
=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.
+If an error occurs when parsing form/query information or cookies, this
+method may be used to retrieve the error message. Remember, the presence
+of any errors can be checked by calling the B<is_error> method.
-=item B<return_error>
+ my $msg = $cgi->get_error_message ();
-You can use this method to return errors to the browser and exit.
+Returns the error message as a plain text string.
=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
+This method is used to set the platform on which the 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.
+B<remove_mime_type> methods) so that they are accounted for properly on
+that platform.
-You can specify either (case insensitive):
+ $cgi->set_platform ($platform);
+
+$platform can be any of (case insensitive):
Unix EOL: \012 = \n
Windows, Windows95, DOS, NT, PC EOL: \015\012 = \r\n
@@ -191,83 +143,155 @@ You can specify either (case insensitive):
"Unix" is the default.
+Returns undef.
+
+=item B<set_size_limit>
+
+To set a specific limit on the total size of the request (in bytes) call
+this method with that size as the sole argument. A size of zero
+effectively disables POST requests. To specify an unlimited size (the
+default) use an argument of -1.
+
+ my $size_limit = $cgi->set_size_limit (10_000_000);
+
+Returns the new value if provided, otherwise the existing value.
+
+=item B<deny_uploads>
+
+To prevent any file uploads simply call this method with an argument of
+1. To enable them again, use an argument of zero.
+
+ my $deny_uploads = $cgi->deny_uploads (1);
+
+Returns the new value if provided, otherwise the existing value.
+
+=item B<force_unique_cookies>
+
+It is generally considered a mistake to send an HTTP request with
+multiple cookies of the same name. However, the RFC is somewhat vague
+regarding how servers are expected to handle such an eventuality.
+CGI::Lite has always allowed such multiple values and returned them as
+an arrayref to be entirely consistent with the same treatment of
+form/query data.
+
+To override the default behaviour this method may be called with a
+single integer argument before the call to B<parse_cookies>. An argument
+of 1 means that the first cookie value will be used and the others
+discarded. An argument of 2 means that the last cookie value will be
+used and the others discarded. An argument of 3 means that an arrayref
+will be returned as usual but an error raised to indicate the situation.
+An argument of 0 (or any other value) sets it back to the default.
+
+ $cgi->force_unique_cookies (1);
+ $cgi->parse_cookies;
+
+Note that if there is already an item of data in the CGI::Lite object
+which matches the name of a cookie then the subsequent B<parse_cookies>
+call will treat the new cookie value as another data item and the resulting
+behaviour will be affected by this method. This is another reason to
+call B<parse_cookies> before B<parse_form_data>.
+
+Returns the new value if provided, otherwise the existing value.
+
=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>,
+ my $tmpdir = '/some/dir';
+ $cgi->set_directory ($tmpdir) or
+ die "Directory $tmpdir cannot be used.\n";
+
+This function should be called I<before> 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
+Returns 0 on error, 1 otherwise.
=item B<close_all_files>
+ $cgi->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.
+method which takes no arguments and returns undef.
=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,
+with specific MIME types (i.e. text/plain, text/html, etc.).
+This method can be used 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');
+Returns 1 if this mime type is newly added, 0 otherwise.
+
=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>,
+This method is the converse of B<add_mime_type>. It allows for the
+removal of a particular MIME type. For example, if you do not want
+CGI::Lite to translate EOL characters for uploaded files of type I<text/html>,
then you would do this:
$cgi->remove_mime_type ('text/html');
-I<Return Value>
-
- 0 Failure
- 1 Success
+Returns 1 if this mime type is newly deleted, 0 otherwise.
=item B<get_mime_types>
-Returns the list, either as a reference or an actual list, of the
+Returns the list of the
MIME types for which EOL translation is performed.
+ my @mimelist = $cgi->get_mime_types ();
+
+=item B<get_upload_type>
+
+Returns the MIME type of uploaded data. Takes the field name as a scalar
+argument. This previously undocumented function was named print_mime_type
+prior to version 3.0.
+
+ my $this_type = $cgi->get_upload_type ($field);
+
+Returns the MIME type as a scalar string if single valued, an arrayref
+if multi-valued or undef if the argument does not exist or has no type.
+
=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.
+The I<names> of uploaded files are returned by default when
+the B<parse_form_data> method is called . But if this method is passed the string "handle" as its argument beforehand then
+the I<handles> to the files are returned instead. However, the name
+of each handle still corresponds to the filename.
+
+ # $fh has been set to one of 'handle' or 'file'
+ $cgi->set_file_type ($fh);
-This function should be called I<before> you call B<parse_form_data>, or
-else it will not work.
+This function should be called I<before> any call to B<parse_form_data>, or
+else it will have no effect.
=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
+However, there is the option of completely turning off timestamp mode
(value 0), or adding a timestamp only for existing files (value 2).
+ $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
+
=item B<filter_filename>
-You can use this method to change the manner in which uploaded
+This method is used 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
{
@@ -277,181 +301,221 @@ to be all upper case, you can use the following code:
return $file;
}
+This method is perhaps best used to sanitise filenames for a specific
+O/S or filesystem e.g. by removing spaces or leading hyphens, etc.
+
=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.
+This method allows fine-grained control of the buffer size used internally
+when dealing with multipart form data. However, the I<actual> buffer
+size that the algorithm uses I<can> be up to 3x the value specified
+as the argument. 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.
+ my $size = $cgi->set_buffer_size (4096);
-I<Return Value>
+The buffer size may not be set below 256 bytes nor above the total amount
+of multipart form data. The default value is 1024 bytes.
-The buffer size.
+Returns 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.
+ my $keys = $cgi->get_ordered_keys;
+ my @keys = $cgi->get_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.
+in an ordered fashion to standard output. It is mainly useful for
+debugging. There are no arguments and no return values.
-=item B<print_form_data>
+=item B<wrap_textarea>
-Deprecated as of v1.8, see B<print_data>.
+This is a method to wrap a long string into one that is separated by EOL
+characters (see B<set_platform>) at fixed lengths. The two arguments
+to be passed to this method are the string and the length at which the
+line separator is to be added.
-=item B<print_cookie_data> (deprecated as of v1.8)
+ my $new_string = $cgi->wrap_textarea ($string, $length);
-Deprecated as of v1.8, see B<print_data>.
+Returns the modified string.
-=item B<wrap_textarea>
+=item B<get_multiple_values>
-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.
+The values returned by the parsing methods in this module for multiple
+fields with the same name are given as array references. This utility
+method exists to convert either a scalar value or an array reference
+into a list thus removing the need for the user to determine whether the
+returned value for any field is a reference or a scalar.
-I<Return Value>
+ @all_values = $cgi->get_multiple_values ($reference);
-The modified string.
+It is only provided as a convenience to the user and is not used
+internally by the module itself.
-=item B<get_multiple_values>
+Returns a list consisting of the 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.
+=item B<browser_escape>
-There was no way I could make this backward compatible with versions
-older than 1.7. I apologize!
+Certain characters have special significance within HTML. These
+characters are: <, >, &, ", # and %. To display these "special"
+characters, they can be escaped using the following notation "&#NNN;"
+where NNN is their ASCII code. This utility method does just that.
-I<Return Value>
+ $escaped_string = $cgi->browser_escape ($string);
-Array consisting of the multiple values.
+Returns the escaped string.
-=item B<create_variables>
+=item B<url_encode>
-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:
+This method will URL-encode a string passed as its argument. It may be
+used to encode any data to be passed as a query string to a CGI
+application, for example.
- %form = ('name' => 'alan wells',
- 'sport' => 'track and field',
- 'events' => '100m');
+ $encoded_string = $cgi->url_encode ($string);
-If you call this method in the following manner:
+Returns the URL-encoded string.
- $cgi->create_variables (\%hash);
+=item B<url_decode>
-it will create three scalar variables: $name, $sport and $events.
-Convenient, huh?
+This method is used to URL-decode a string.
-=item B<browser_escape>
+ $decoded_string = $cgi->url_decode ($string);
-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:
+Returns the URL-decoded string.
- &#ascii;
+=item B<is_dangerous>
-This method does just that.
+This method checks for the existence of dangerous meta-characters.
-I<Return Value>
+ $status = $cgi->is_dangerous ($string);
-Escaped string.
+Returns 1 if such characters are found, 0 otherwise.
-=item B<url_encode>
+=back
-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.
+=head2 Deprecated methods
-I<Return Value>
+The following methods and subroutines are deprecated. Please do not use
+them in new code and consider excising them from old code. They will be
+removed in a future release.
-URL encoded string.
+=over 4
-=item B<url_decode>
+=item B<return_error>
-You can use this method to URL decode a string.
+ $cgi->return_error ('error 1', 'error 2', 'error 3');
-I<Return Value>
+You can use this method to print errors to standard output (ie. as part of
+the HTTP response) and exit. B<This method is deprecated as of version 3.0.>
+The same functionality can be achieved with:
-URL decoded string.
+ print ('error 1', 'error 2', 'error 3');
+ exit 1;
-=item B<is_dangerous>
+=item B<create_variables>
-This method checks for the existence of dangerous meta-characters.
+B<This method is deprecated as of version 3.0.> It runs contrary to the
+principles of structured programming and has really nothing to do with
+CGI form or cookie handling. It is retained here for backwards
+compatibility but will be removed entirely in later versions.
-I<Return Value>
+ %form = ('name' => 'alan wells',
+ 'sport' => 'track and field',
+ 'events' => '100m');
+
+ $cgi->create_variables (\%hash);
+
+This converts a hash ref into scalars named for its keys and this
+example will create three scalar variables: $name, $sport and $events.
+
+=back
- 0 Safe
- 1 Dangerous
+=head2 Obsolete methods/subroutines
+
+The following methods and subroutines were deprecated in the 2.x branch
+and have now been removed entirely from the module.
+
+=over 4
=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
+The use of this subroutine had been strongly discouraged for more than a
+decade (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.
+advisory by Ronald F. Guilmette.) It has been removed as of version 3.0.
+
+=item B<print_form_data>
+
+Use B<print_data> instead.
-I<Return Value>
+=item B<print_cookie_data>
-Escaped string.
+Use B<print_data> instead.
=back
+Compatibility note: in 2.x and older versions the following were to be used as
+subroutines rather than methods:
+
+=over 4
+
+=item browser_escape
+
+=item url_encode
+
+=item url_decode
+
+=item is_dangerous
+
+=back
+
+They will still work as such and are still exported
+by default. Users are encouraged to migrate to the new method calls
+instead as both the export and subroutine interface may be retired in
+future. Non-method use will trigger a warning.
+
=head1 VERSIONS
-This module has maintained backwards compatibility with versions of
+This module 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
+With this in mind, there are 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 legacy branch
+will be bug fixes only. The new 3.x branch will be the main release and
+will require a more modern perl (5.6.0 is now the bare minimum). The
+3.x branch has new features and has removed some of the legacy code
+including some methods which had been deprecated for more than a decade.
+The attention of users wishing to upgrade from 2.x to 3.x is drawn to
+the L</Deprecated methods> and L</Obsolete methods/subroutines> sections of this
+document.
+
+Requests for new features in the 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.
+the CGI::* modules or L<CGI.pm|CGI>.
-L<CGI::Lite::Request> uses similar method names to CGI.pm thus allowing
-easy transition between them. It uses this module as a
-dependency.
+L<CGI::Lite::Request> uses some similar method names to CGI.pm thus allowing
+easy transition between the two. It uses CGI::Lite as a dependency.
+
+L<CGI::Simple>, L<CGI::Minimal> and L<CGI::Thin> are alternative
+lightweight CGI implementations.
=head1 REPOSITORY
-L<https://github.com/openstrike/perl-CGI-Lite/tree/legacy-master>
+L<https://github.com/openstrike/perl-CGI-Lite>
=head1 MAINTAINER
@@ -498,7 +562,7 @@ Smylers, Andreas, Ben and Shishir.
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
+ Changes in versions 2.03 onwards are copyright 2014, 2015 by Pete Houston
=head1 LICENCE
@@ -510,21 +574,24 @@ under the same terms as Perl itself.
###############################################################################
package CGI::Lite;
-require 5.002;
-require Exporter;
-@ISA = (Exporter);
-@EXPORT = qw (browser_escape
- url_encode
- url_decode
- is_dangerous
- escape_dangerous_chars);
+use strict;
+use warnings;
+
+require 5.6.0;
+
+use Symbol; # For _create_handles and create_variables
##++
## Global Variables
##--
-$CGI::Lite::VERSION = '2.05';
+BEGIN {
+ our @ISA = 'Exporter';
+ our @EXPORT = qw/browser_escape url_encode url_decode is_dangerous/;
+}
+
+our $VERSION = '3.00';
##++
## Start
@@ -532,218 +599,261 @@ $CGI::Lite::VERSION = '2.05';
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;
+ my $class = shift;
+
+ my $self = {
+ multipart_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, # Unused as yet
+ size_limit => -1,
+ deny_uploads => 0,
+ unique_cookies => 0,
+ };
+
+ $self->{convert} = {
+ 'text/html' => 1,
+ 'text/plain' => 1
+ };
+
+ $self->{file} = {Unix => '/', Mac => ':', PC => '\\'};
+ $self->{eol} = {Unix => "\012", Mac => "\015", PC => "\015\012"};
+
+ bless ($self, $class);
+ return $self;
}
-sub Version
-{
- return $VERSION;
+sub Version
+{
+ return $VERSION;
+}
+
+sub deny_uploads
+{
+ my ($self, $newval) = @_;
+ if (defined $newval) {
+ $self->{deny_uploads} = $newval ? 1 : 0;
+ }
+ return $self->{deny_uploads};
+}
+
+sub set_size_limit
+{
+ my ($self, $limit) = @_;
+ return unless defined $limit;
+ if ($limit =~ /^[0-9]+$/) {
+ $self->{size_limit} = $limit;
+ } else {
+ $self->{size_limit} = -1;
+ }
+ return $self->{size_limit};
}
sub set_directory
{
- my ($self, $directory) = @_;
+ my ($self, $directory) = @_;
- stat ($directory);
+ return 0 unless $directory;
+ stat ($directory);
- if ( (-d _) && (-e _) && (-r _) && (-w _) ) {
- $self->{multipart_dir} = $directory;
- return (1);
+ if ((-d _) && (-r _) && (-w _)) {
+ $self->{multipart_dir} = $directory;
+ return (1);
- } else {
- return (0);
- }
+ } else {
+ return (0);
+ }
}
sub add_mime_type
{
- my ($self, $mime_type) = @_;
+ my ($self, $mime_type) = @_;
- $self->{convert}->{$mime_type} = 1 if ($mime_type);
+ if ($mime_type and not exists $self->{convert}->{$mime_type}) {
+ return $self->{convert}->{$mime_type} = 1;
+ }
+ return 0;
}
sub remove_mime_type
{
- my ($self, $mime_type) = @_;
+ my ($self, $mime_type) = @_;
- if ($self->{convert}->{$mime_type}) {
- delete $self->{convert}->{$mime_type};
- return (1);
+ if ($self->{convert}->{$mime_type}) {
+ delete $self->{convert}->{$mime_type};
+ return (1);
- } else {
- return (0);
- }
+ } else {
+ return (0);
+ }
}
sub get_mime_types
{
- my $self = shift;
+ my $self = shift;
- return (sort keys %{ $self->{convert} });
+ return (sort keys %{$self->{convert}});
}
sub set_platform
{
- my ($self, $platform) = @_;
-
- if ($platform =~ /^(?:PC|NT|Windows(?:95)?|DOS)/i) {
- $self->{platform} = 'PC';
+ my ($self, $platform) = @_;
- } elsif ($platform =~ /^Mac(?:intosh)?/i) {
-
- ## Should I check for NeXT here :-)
-
- $self->{platform} = 'Mac';
-
- } else {
- $self->{platform} = 'Unix';
- }
+ return unless defined $platform;
+ if ($platform =~ /^(?:PC|NT|Windows(?:95)?|DOS)/i) {
+ $self->{platform} = 'PC';
+ } elsif ($platform =~ /^Mac(?:intosh)?/i) {
+ $self->{platform} = 'Mac';
+ } else {
+ $self->{platform} = 'Unix';
+ }
}
sub set_file_type
{
- my ($self, $type) = @_;
+ my ($self, $type) = @_;
- if ($type =~ /^handle$/i) {
- $self->{file_type} = 'handle';
- } else {
- $self->{file_type} = 'name';
- }
+ if ($type =~ /^handle$/i) {
+ $self->{file_type} = 'handle';
+ } else {
+ $self->{file_type} = 'name';
+ }
}
sub add_timestamp
{
- my ($self, $value) = @_;
+ my ($self, $value) = @_;
- if ( ($value < 0) || ($value > 2) ) {
- $self->{timestamp} = 1;
- } else {
- $self->{timestamp} = $value;
- }
+ unless ($value == 0 or $value == 1 or $value == 2) {
+ $self->{timestamp} = 1;
+ } else {
+ $self->{timestamp} = $value;
+ }
+}
+
+sub force_unique_cookies
+{
+ my ($self, $value) = @_;
+
+ if (defined $value) {
+ if ($value =~ /^[1-3]$/) {
+ $self->{unique_cookies} = $value;
+ } else {
+ $self->{unique_cookies} = 0;
+ }
+ }
+ return $self->{unique_cookies};
}
sub filter_filename
{
- my ($self, $subroutine) = @_;
+ my ($self, $subroutine) = @_;
- $self->{filter} = $subroutine;
+ $self->{filter} = $subroutine;
}
sub set_buffer_size
{
- my ($self, $buffer_size) = @_;
- my $content_length;
+ my ($self, $buffer_size) = @_;
+ my $content_length;
- $content_length = $ENV{CONTENT_LENGTH} || return (0);
+ $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;
- }
+ 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});
+ return ($self->{buffer_size});
}
sub parse_new_form_data
-# Reset state before parsing (for persistant CGI objects, e.g. under FastCGI)
+
+# 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->close_all_files ();
- $self->{web_data} = {};
- $self->{ordered_keys} = [];
- $self->{all_handles} = [];
- $self->{error_status} = 0;
- $self->{error_message} = undef;
+ $self->{web_data} = {};
+ $self->{ordered_keys} = [];
+ $self->{all_handles} = [];
+ $self->{error_status} = 0;
+ $self->{error_message} = undef;
- $self->parse_form_data(@param);
+ $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};
+ my ($self, $user_request) = @_;
+ my ($request_method, $content_length, $content_type, $query_string,
+ $boundary, $post_data, @query_input);
+
+ # Force into object method
+ unless (ref ($self)) { $self = $self->new; }
+ $request_method = $user_request || $ENV{REQUEST_METHOD} || '';
+ $content_length = $ENV{CONTENT_LENGTH} || 0;
+ $content_type = $ENV{CONTENT_TYPE};
+
+ # If we've set a size limit, check that it has not been exceeded
+ if ($self->{size_limit} > -1 and $content_length > $self->{size_limit}) {
+ $self->_error ("Content lenth $content_length exceeds limit of "
+ . $self->{size_limit});
+ return;
+ }
- if ($request_method =~ /^(get|head)$/i) {
+ 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};
+ return wantarray ? %{$self->{web_data}} : $self->{web_data};
- } elsif ($request_method =~ /^post$/i) {
+ } elsif ($request_method =~ /^post$/i) {
- if (!$content_type ||
- ($content_type =~ /^application\/x-www-form-urlencoded/)) {
+ 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');
- read (STDIN, $post_data, $content_length);
- $self->_decode_url_encoded_data (\$post_data, 'form');
-
- return wantarray ?
- %{ $self->{web_data} } : $self->{web_data};
+ 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};
+ if ($self->{deny_uploads}) {
+ $self->_error ("multipart/form-data unacceptable when "
+ . "deny_uploads is set");
+ return;
+ }
+ ($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!');
+ $self->_error ('Invalid content type!');
}
- } else {
+ } else {
##++
## Got the idea of interactive debugging from CGI.pm, though it's
- ## handled a bit differently here. Thanks Lincoln!
+ ## handled a bit differently here. Thanks Lincoln!
##--
print "[ Reading query from standard input. Press ^D to stop! ]\n";
@@ -753,176 +863,188 @@ sub parse_form_data
$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};
- }
+ return wantarray ? %{$self->{web_data}} : $self->{web_data};
+ }
}
sub parse_cookies
{
- my $self = shift;
- my $cookies;
+ my $self = shift;
+ my $cookies;
- $cookies = $ENV{HTTP_COOKIE} || return;
+ $cookies = $ENV{HTTP_COOKIE} || return;
- $self->_decode_url_encoded_data (\$cookies, 'cookies');
+ $self->_decode_url_encoded_data (\$cookies, 'cookies');
- return wantarray ?
- %{ $self->{web_data} } : $self->{web_data};
+ return wantarray ? %{$self->{web_data}} : $self->{web_data};
}
sub get_ordered_keys
{
- my $self = shift;
+ my $self = shift;
- return wantarray ?
- @{ $self->{ordered_keys} } : $self->{ordered_keys};
+ return wantarray ? @{$self->{ordered_keys}} : $self->{ordered_keys};
}
sub print_data
{
- my $self = shift;
- my ($key, $value, $eol);
+ my $self = shift;
- $eol = $self->{eol}->{$self->{platform}};
+ my $eol = $self->{eol}->{$self->{platform}};
- foreach $key (@{ $self->{ordered_keys} }) {
- $value = $self->{web_data}->{$key};
+ foreach my $key (@{$self->{ordered_keys}}) {
+ my $value = $self->{web_data}->{$key};
- if (ref $value) {
- print "$key = @$value$eol";
- } else {
- print "$key = $value$eol";
+ if (ref $value) {
+ print "$key = @$value$eol";
+ } else {
+ print "$key = $value$eol";
+ }
}
- }
}
-sub print_mime_type
+sub get_upload_type
{
- my ($self, $field) = @_;
+ my ($self, $field) = @_;
- return($self->{'mime_types'}->{$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;
+ 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) = @_;
+ my ($self, $array) = @_;
- return (ref $array) ? (@$array) : $array;
+ return (ref $array) ? (@$array) : $array;
}
sub create_variables
{
- my ($self, $hash) = @_;
- my ($package, $key, $value);
-
- $package = $self->_determine_package;
+ my ($self, $hash) = @_;
+ my ($package, $key, $value);
- while (($key, $value) = each %$hash) {
- ${"$package\:\:$key"} = $value;
- }
+ $package = $self->_determine_package;
+
+ while (($key, $value) = each %$hash) {
+ my $this = Symbol::qualify_to_ref ($key, $package);
+ $$$this = $value;
+ }
}
sub is_error
{
- my $self = shift;
+ my $self = shift;
- if ($self->{error_status}) {
- return (1);
- } else {
- return (0);
- }
+ if ($self->{error_status}) {
+ return (1);
+ } else {
+ return (0);
+ }
}
sub get_error_message
{
- my $self = shift;
+ my $self = shift;
- return $self->{error_message} if ($self->{error_message});
+ return $self->{error_message} if ($self->{error_message});
}
sub return_error
{
- my ($self, @messages) = @_;
+ my ($self, @messages) = @_;
- print "@messages\n";
+ print "@messages\n";
- exit (1);
+ exit (1);
}
##++
-## Exported Subroutines
+## Exported Subroutines and Methods
##--
sub browser_escape
{
- my $string = shift;
+ my ($self, $string) = @_;
- $string =~ s/([<&"#%>])/sprintf ('&#%d;', ord ($1))/ge;
+ unless (ref ($self) eq 'CGI::Lite') {
+ my @rep = caller;
+ warn "Non-method use of browser_escape is deprecated "
+ . "in $rep[0] at line $rep[2] of $rep[1]\n";
+ $string = $self;
+ }
+ $string =~ s/([<&"#%>])/sprintf ('&#%d;', ord ($1))/ge;
- return $string;
+ return $string;
}
sub url_encode
{
- my $string = shift;
+ my ($self, $string) = @_;
- $string =~ s/([^-.\w ])/sprintf('%%%02X', ord $1)/ge;
- $string =~ tr/ /+/;
+ unless (ref ($self) eq 'CGI::Lite') {
+ my @rep = caller;
+ warn "Non-method use of url_encode is deprecated "
+ . "in $rep[0] at line $rep[2] of $rep[1]\n";
+ $string = $self;
+ }
+
+ $string =~ s/([^-.\w ])/sprintf('%%%02X', ord $1)/ge;
+ $string =~ tr/ /+/;
- return $string;
+ return $string;
}
sub url_decode
{
- my $string = shift;
+ my ($self, $string) = @_;
- $string =~ tr/+/ /;
- $string =~ s/%([\da-fA-F]{2})/chr (hex ($1))/eg;
-
- return $string;
-}
+ unless (ref ($self) eq 'CGI::Lite') {
+ my @rep = caller;
+ warn "Non-method use of url_decode is deprecated "
+ . "in $rep[0] at line $rep[2] of $rep[1]\n";
+ $string = $self;
+ }
-sub is_dangerous
-{
- my $string = shift;
+ $string =~ tr/+/ /;
+ $string =~ s/%([\da-fA-F]{2})/chr (hex ($1))/eg;
- if ($string =~ /[;<>\*\|`&\$!#\(\)\[\]\{\}:'"]/) {
- return (1);
- } else {
- return (0);
- }
+ return $string;
}
-sub escape_dangerous_chars
+sub is_dangerous
{
- my $string = shift;
+ my ($self, $string) = @_;
- warn "escape_dangerous_chars() possibly dangerous. Its use is discouraged";
- $string =~ s/([;<>\*\|`&\$!#\(\)\[\]\{\}:'"\\\?\~\^\r\n])/\\$1/g;
+ unless (ref ($self) eq 'CGI::Lite') {
+ my @rep = caller;
+ warn "Non-method use of is_dangerous is deprecated "
+ . "in $rep[0] at line $rep[2] of $rep[1]\n";
+ $string = $self;
+ }
- return $string;
+ if ($string =~ /[;<>\*\|`&\$!#\(\)\[\]\{\}:'"]/) {
+ return (1);
+ } else {
+ return (0);
+ }
}
##++
@@ -931,29 +1053,26 @@ sub escape_dangerous_chars
sub _error
{
- my ($self, $message) = @_;
+ 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;
+ $self->{error_status} = 1;
+ $self->{error_message} = $message;
}
sub _determine_package
{
- my $self = shift;
- my ($frame, $this_package, $find_package);
+ my $self = shift;
+ my ($frame, $this_package, $find_package);
- $frame = -1;
- ($this_package) = split (/=/, $self);
+ $frame = -1;
+ ($this_package) = split (/=/, $self);
- do {
- $find_package = caller (++$frame);
- } until ($find_package !~ /^$this_package/);
+ do {
+ $find_package = caller (++$frame);
+ } until ($find_package !~ /^$this_package/);
- return ($find_package);
-}
+ return ($find_package);
+}
##++
## Decode URL encoded data
@@ -961,55 +1080,64 @@ sub _determine_package
sub _decode_url_encoded_data
{
- my ($self, $reference_data, $type) = @_;
- my $code;
+ my ($self, $reference_data, $type) = @_;
+ return unless ($$reference_data);
- $code = <<'End_of_URL_Decode';
+ my (@key_value_pairs, $delimiter);
- my (@key_value_pairs, $delimiter, $key_value, $key, $value);
+ @key_value_pairs = ();
- @key_value_pairs = ();
+ if ($type eq 'cookies') {
+ $delimiter = qr/[;,]\s*/;
+ } else {
- return unless ($$reference_data);
+ # Only other option is form data
+ $delimiter = qr/[;&]/;
+ }
- if ($type eq 'cookies') {
- $delimiter = '[;,]\s*';
- } else {
- $delimiter = '[;&]';
- }
+ @key_value_pairs = split ($delimiter, $$reference_data);
- @key_value_pairs = split (/$delimiter/, $$reference_data);
-
- foreach $key_value (@key_value_pairs) {
- ($key, $value) = split (/=/, $key_value, 2);
+ foreach my $key_value (@key_value_pairs) {
+ my ($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;
- }
+ # avoid 'undef' warnings for "key=" BDL Jan/99
+ $value = '' unless defined $value;
- $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} );
+ # avoid 'undef' warnings for bogus URLs like 'foobar.cgi?&foo=bar'
+ next unless defined $key;
- push (@{ $self->{web_data}->{$key} }, $value);
- } else {
- $self->{web_data}->{$key} = $value;
- push (@{ $self->{ordered_keys} }, $key);
- }
- }
+ if ($type eq 'cookies') {
-End_of_URL_Decode
+ # Strip leading/trailling whitespace as per RFC 2965
+ $key =~ s/^\s+|\s+$//g;
+ $value =~ s/^\s+|\s+$//g;
+ }
- eval ($code);
- $self->_error ($@) if $@;
+ $key = $self->url_decode ($key);
+ $value = $self->url_decode ($value);
+
+ if (defined ($self->{web_data}->{$key})) {
+ if ($type eq 'cookies' and $self->{unique_cookies} > 0) {
+ if ($self->{unique_cookies} == 1) {
+ next;
+ } elsif ($self->{unique_cookies} == 2) {
+ $self->{web_data}->{$key} = $value;
+ next;
+ } else {
+ $self->_error ("Multiple instances of cookie $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);
+ }
+ }
+
+ return;
}
##++
@@ -1018,164 +1146,176 @@ End_of_URL_Decode
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);
+ my ($self, $total_bytes, $boundary) = @_;
+ my $files = {};
+ $boundary = quotemeta ($boundary);
+
+ eval {
+
+ 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};
+ $directory = $self->{multipart_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;
- 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);
+ } else {
+ last;
+ }
- $byte_count += $buffer_size;
+ $changed = 0;
- if ($old_data) {
- $current_buffer = join ('', $old_data, $new_data);
- } else {
- $current_buffer = $new_data;
- }
+ ##++
+ ## 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.
+ ##--
- } elsif ($old_data) {
- $current_buffer = $old_data;
- $old_data = undef;
+ if ($current_buffer =~
+ /(.*?)((?:\015?\012)?-*$boundary-*[\015\012]*)(?=(.*))/os) {
- } else {
- last;
- }
+ ($store, $this_boundary, $old_data) = ($1, $2, $3);
- $changed = 0;
+ if ($current_buffer =~
+ /[Cc]ontent-[Dd]isposition: ([^\015\012]+)\015?\012 # Disposition
+ (?:([A-Za-z].*?)(?:\015?\012))? # Headers
+ (?:\015?\012) # End
+ (?=(.*)) # Other Data
+ /xs
+ ) {
- ##++
- ## 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.
- ##--
+ ($disposition, $headers, $current_buffer) = ($1, $2, $3);
+ $old_data = $current_buffer;
- if ($current_buffer =~
- /(.*?)((?:\015?\012)?-*$boundary-*[\015\012]*)(?=(.*))/os) {
+ ($mime_type) = $headers =~ /[Cc]ontent-[Tt]ype: (\S+)/;
- ($store, $this_boundary, $old_data) = ($1, $2, $3);
+ $self->_store ($platform, $file, $convert, $handle, $eol,
+ $field, \$store, $seen);
- if ($current_buffer =~
- /[Cc]ontent-[Dd]isposition: ([^\015\012]+)\015?\012 # Disposition
- (?:([A-Za-z].*?)(?:\015?\012))? # Headers
- (?:\015?\012) # End
- (?=(.*)) # Other Data
- /xs) {
+ close ($handle) if (ref ($handle) and fileno ($handle));
- ($disposition, $headers, $current_buffer) = ($1, $2, $3);
- $old_data = $current_buffer;
+ if ($mime_type && $self->{convert}->{$mime_type}) {
+ $convert = 1;
+ } else {
+ $convert = 0;
+ }
- ($mime_type) = $headers =~ /[Cc]ontent-[Tt]ype: (\S+)/;
+ $changed = 1;
- $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;
- }
+ ($field) = $disposition =~ /name="([^"]+)"/;
+ ++$seen->{$field};
- $changed = 1;
+ unless ($self->{'mime_types'}->{$field}) {
+ $self->{'mime_types'}->{$field} = $mime_type;
+ } elsif (ref $self->{'mime_types'}->{$field}) {
+ push @{$self->{'mime_types'}->{$field}}, $mime_type;
+ } else {
+ $self->{'mime_types'}->{$field} =
+ [$self->{'mime_types'}->{$field}, $mime_type];
+ }
- ($field) = $disposition =~ /name="([^"]+)"/;
- ++$seen->{$field};
+ if ($seen->{$field} > 1) {
+ $self->{web_data}->{$field} =
+ [$self->{web_data}->{$field}]
+ unless (ref $self->{web_data}->{$field});
+ } else {
+ push (@{$self->{ordered_keys}}, $field);
+ }
- $self->{'mime_types'}->{$field} = $mime_type;
+ if (($file) = $disposition =~ /filename="(.*)"/) {
+ $file =~ s|.*[:/\\](.*)|$1|;
- if ($seen->{$field} > 1) {
- $self->{web_data}->{$field} = [$self->{web_data}->{$field}]
- unless (ref $self->{web_data}->{$field});
- } else {
- push (@{ $self->{ordered_keys} }, $field);
- }
+ $new_name =
+ $self->_get_file_name ($platform, $directory, $file);
- if (($file) = $disposition =~ /filename="(.*)"/) {
- $file =~ s|.*[:/\\](.*)|$1|;
+ if (ref $self->{web_data}->{$field}) {
+ push @{$self->{web_data}->{$field}}, $new_name
+ } else {
+ $self->{web_data}->{$field} = $new_name;
+ }
- $new_name = $self->_get_file_name ($platform,
- $directory, $file);
+ $full_path =
+ join ($self->{file}->{$platform}, $directory,
+ $new_name);
- $self->{web_data}->{$field} = $new_name;
+ open ($handle, '>', $full_path)
+ or $self->_error ("Can't create file: $full_path!");
- $full_path = join ($self->{file}->{$platform},
- $directory, $new_name);
+ $files->{$new_name} = $full_path;
+ }
+ } elsif ($byte_count < $total_bytes) {
+ $old_data = $this_boundary . $old_data;
+ }
- open (++$handle, ">$full_path")
- || $self->_error ("Can't create file: $full_path!");
+ } elsif ($old_data) {
+ $store = $old_data;
+ $old_data = $new_data;
- $files->{$new_name} = $full_path;
- }
- } elsif ($byte_count < $total_bytes) {
- $old_data = $this_boundary . $old_data;
+ } else {
+ $store = $current_buffer;
+ $current_buffer = $new_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);
- }
- }
+ unless ($changed) {
+ $self->_store ($platform, $file, $convert, $handle, $eol,
+ $field, \$store, $seen);
+ }
+ }
- close ($handle) if (fileno ($handle));
+ close ($handle) if ($handle and fileno ($handle));
-End_of_Multipart
+ }; # End of eval
- eval ($code);
- $self->_error ($@) if $@;
+ $self->_error ($@) if $@;
- $self->_create_handles ($files) if ($self->{file_type} eq 'handle');
+ $self->_create_handles ($files) if ($self->{file_type} eq 'handle');
}
sub _store
{
- my ($self, $platform, $file, $convert, $handle, $eol, $field,
- $info, $seen) = @_;
+ my ($self, $platform, $file, $convert, $handle, $eol, $field, $info, $seen)
+ = @_;
- if ($file) {
+ 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');
+ $$info =~ s/\015\012/$eol/og;
+ $$info =~ s/\015/$eol/og if ($platform ne 'Mac');
+ $$info =~ s/\012/$eol/og if ($platform ne 'Unix');
}
}
@@ -1184,7 +1324,7 @@ sub _store
} elsif ($field) {
if ($seen->{$field} > 1) {
- $self->{web_data}->{$field}->[$seen->{$field}-1] .= $$info;
+ $self->{web_data}->{$field}->[$seen->{$field} - 1] .= $$info;
} else {
$self->{web_data}->{$field} .= $$info;
}
@@ -1193,52 +1333,51 @@ sub _store
sub _get_file_name
{
- my ($self, $platform, $directory, $file) = @_;
- my ($filtered_name, $filename, $timestamp, $path);
+ my ($self, $platform, $directory, $file) = @_;
+ my ($filtered_name, $filename, $timestamp, $path);
- $filtered_name = &{ $self->{filter} }($file)
- if (ref ($self->{filter}) eq 'CODE');
+ $filtered_name = &{$self->{filter}}($file)
+ if (ref ($self->{filter}) eq 'CODE');
- $filename = $filtered_name || $file;
- $timestamp = time . '__' . $filename;
+ $filename = $filtered_name || $file;
+ $timestamp = time . '__' . $filename;
- if (!$self->{timestamp}) {
- return $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;
- }
+ } elsif ($self->{timestamp} == 1) {
+ return $timestamp;
+
+ } else { # $self->{timestamp} must be 2
+ $path = join ($self->{file}->{$platform}, $directory, $filename);
+
+ return (-e $path) ? $timestamp : $filename;
+ }
}
sub _create_handles
{
- my ($self, $files) = @_;
- my ($package, $handle, $name, $path);
+ my ($self, $files) = @_;
+ my ($package, $handle, $name, $path);
- $package = $self->_determine_package;
+ $package = $self->_determine_package;
- while (($name, $path) = each %$files) {
- $handle = "$package\:\:$name";
- open ($handle, "<$path")
- || $self->_error ("Can't read file: $path!");
+ while (($name, $path) = each %$files) {
+ $handle = Symbol::qualify_to_ref ($name, $package);
+ open ($handle, '<', $path)
+ or $self->_error ("Can't read file: $path! $!");
- push (@{ $self->{all_handles} }, $handle);
- }
+ push (@{$self->{all_handles}}, $handle);
+ }
}
sub close_all_files
{
- my $self = shift;
- my $handle;
+ my $self = shift;
- foreach $handle (@{ $self->{all_handles} }) {
- close $handle;
- }
+ foreach my $handle (@{$self->{all_handles}}) {
+ close $handle;
+ }
}
1;
@@ -18,29 +18,44 @@
#===============================================================================
use strict;
+use warnings;
-use Test::More tests => 306; # last test to print
+use Test::More tests => 318;
use lib './lib';
+# Test exits and outputs;
+my $have_test_trap;
+our $trap; # Imported
+BEGIN {
+ eval {
+ require Test::Trap;
+ Test::Trap->import (qw/trap $trap :flow
+ :stderr(systemsafe)
+ :stdout(systemsafe)
+ :warn/);
+ $have_test_trap = 1;
+ };
+}
+
BEGIN { use_ok ('CGI::Lite') }
-is ($CGI::Lite::VERSION, '2.05', 'Version test');
+is ($CGI::Lite::VERSION, '3.00', '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');
+is ($cgi->browser_escape ('<&>'), '<&>', 'browser_escape');
{
- my @from = qw/! " # $ % ^ & * ( ) _ + - =/;
+ my @from = split (/ /, q/! " # $ % ^ & * ( ) _ + - =/);
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]");
+ is ($cgi->url_encode($from[$i]), $to[$i], "url_encode $from[$i]");
+ is ($cgi->url_decode($to[$i]), $from[$i], "url_decode $to[$i]");
}
}
@@ -50,9 +65,9 @@ for my $i(0..255) {
my $chr = chr($i);
if (index ($dangerous, $chr) eq -1) {
# Not
- is (is_dangerous ($chr), 0, "Dangerous $i (not)");
+ is ($cgi->is_dangerous ($chr), 0, "Dangerous $i (not)");
} else {
- is (is_dangerous ($chr), 1, "Dangerous $i");
+ is ($cgi->is_dangerous ($chr), 1, "Dangerous $i");
}
}
@@ -64,10 +79,15 @@ for my $platform (qw/mac MacIntosh/) {
$cgi->set_platform ($platform);
is ($cgi->{platform}, 'Mac', "Set platform ($platform)");
}
+
+is ($cgi->set_platform(), undef, 'Set platform (undef) returns undef');
+is ($cgi->{platform}, 'Mac', "Set platform (undef) - platform unchanged");
+
# Unix is default
$cgi->set_platform ('foo');
is ($cgi->{platform}, 'Unix', "Set default platform");
+is ($cgi->wrap_textarea (), undef, 'No text to wrap');
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");
@@ -90,3 +110,39 @@ is ($cgi->get_multiple_values ('foo', 'bar'), 'foo',
my $foobar = ['foo', 'bar'];
my @res = $cgi->get_multiple_values ($foobar);
is_deeply (\@res, $foobar, 'get_multiple_values (array ref argument)');
+
+like ($cgi->_get_file_name ('Unix', '/tmp', ''), qr/^\d+__/,
+ 'Missing filename');
+
+{
+ no strict 'vars'; # Makes the whole thing pointless
+ no warnings 'once';
+ $cgi->create_variables ({foo => 'bar', boing => 'quux'});
+ is ($foo, 'bar', 'Create variables 1');
+ is ($boing, 'quux', 'Create variables 2');
+}
+
+# Use Test::Trap where available to test wanrings and terminating
+# functions.
+SKIP: {
+ skip "Test::Trap not available", 6 unless $have_test_trap;
+ my @r = trap { browser_escape ('a') };
+ like ($trap->stderr,
+ qr/Non-method use of browser_escape is deprecated/,
+ 'Warning calling browser_escape as non-method');
+ @r = trap { url_encode ('a') };
+ like ($trap->stderr,
+ qr/Non-method use of url_encode is deprecated/,
+ 'Warning calling url_encode as non-method');
+ @r = trap { url_decode ('a') };
+ like ($trap->stderr,
+ qr/Non-method use of url_decode is deprecated/,
+ 'Warning calling url_decode as non-method');
+ @r = trap { is_dangerous ('a') };
+ like ($trap->stderr,
+ qr/Non-method use of is_dangerous is deprecated/,
+ 'Warning calling is_dangerous as non-method');
+ @r = trap { $cgi->return_error ('Hello', 'World!') };
+ is ($trap->exit, 1, 'return_error exits');
+ is ($trap->stdout, "Hello World!\n", 'return_error prints');
+}
@@ -17,8 +17,9 @@
#===============================================================================
use strict;
+use warnings;
-use Test::More tests => 235; # last test to print
+use Test::More tests => 264; # last test to print
use lib './lib';
@@ -34,9 +35,14 @@ $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;
+is ($cgi->is_error, 0, 'Cookie parse: no cookies, no error');
+is ($cookies, undef, 'Cookie parse: no cookies');
+
+$ENV{HTTP_COOKIE} = 'foo=bar; baz=quux';
+$cgi = CGI::Lite->new ();
+$cookies = $cgi->parse_cookies;
my $testname = 'simple';
is ($cgi->is_error, 0, "Cookie parse ($testname)");
@@ -46,6 +52,17 @@ is ($cookies->{foo}, 'bar', "First cookie value ($testname)");
ok (exists $cookies->{baz}, "Second cookie name ($testname)");
is ($cookies->{baz}, 'quux', "Second cookie value ($testname)");
+# And again but with a hash
+$cgi = CGI::Lite->new ();
+$testname = 'simple, return hash';
+my %cookies = $cgi->parse_cookies;
+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 ';
@@ -92,12 +109,13 @@ 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');
+ skip "No file created for stdout", 2 unless open my $tmp, '>', 'tmpout';
select $tmp;
$cgi->print_data;
close $tmp;
- open $tmp, '<tmpout';
+ open $tmp, '<', 'tmpout';
chomp (my $printed = <$tmp>);
is ($printed, q# foo = bar #, 'print_data first cookie');
chomp ($printed = <$tmp>);
@@ -183,3 +201,44 @@ is ($cookies->{'foo'}, '=bar', "First cookie value ($testname)");
# RFC?
#ok (exists $cookies->{'b a z'}, "Second cookie name ($testname)");
#is ($cookies->{'b a z'}, 'qu ux', "Second cookie value ($testname)");
+
+$ENV{HTTP_COOKIE} = 'foo=bar;foo=baz;foo=quux';
+$cgi = CGI::Lite->new ();
+$cookies = $cgi->parse_cookies;
+$testname = 'triple value';
+
+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}->[0], 'bar', "First cookie value ($testname)");
+is ($cookies->{foo}->[1], 'baz', "First cookie value ($testname)");
+is ($cookies->{foo}->[2], 'quux', "First cookie value ($testname)");
+
+
+$cgi = CGI::Lite->new ();
+is ($cgi->force_unique_cookies(), 0, "force_unique_cookies undef arg");
+is ($cgi->force_unique_cookies('foo'), 0, "force_unique_cookies string arg");
+is ($cgi->force_unique_cookies(100), 0, "force_unique_cookies arg > 3");
+is ($cgi->force_unique_cookies(1), 1, "force_unique_cookies arg == 1");
+$cookies = $cgi->parse_cookies;
+$testname = 'unique, take first';
+is ($cgi->is_error, 0, "Cookie parse ($testname)");
+is (scalar keys %$cookies, 1, "Cookie count ($testname)");
+ok (exists $cookies->{foo}, "Cookie name ($testname)");
+is ($cookies->{foo}, 'bar', "Cookie value ($testname)");
+
+$cgi = CGI::Lite->new ();
+is ($cgi->force_unique_cookies(2), 2, "force_unique_cookies arg == 2");
+$cookies = $cgi->parse_cookies;
+$testname = 'unique, take last';
+is ($cgi->is_error, 0, "Cookie parse ($testname)");
+is (scalar keys %$cookies, 1, "Cookie count ($testname)");
+ok (exists $cookies->{foo}, "Cookie name ($testname)");
+is ($cookies->{foo}, 'quux', "Cookie value ($testname)");
+
+$cgi = CGI::Lite->new ();
+is ($cgi->force_unique_cookies(3), 3, "force_unique_cookies arg == 3");
+$cookies = $cgi->parse_cookies;
+$testname = 'unique, raise error';
+is ($cgi->is_error, 1, "Cookie parse ($testname)");
+
@@ -17,8 +17,9 @@
#===============================================================================
use strict;
+use warnings;
-use Test::More tests => 27; # last test to print
+use Test::More tests => 49; # last test to print
use lib './lib';
@@ -34,8 +35,6 @@ $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;
@@ -44,6 +43,20 @@ 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');
+# Return the hash
+my %form = $cgi->parse_new_form_data;
+is ($cgi->is_error, 0, 'Parsing data into hash with GET');
+is ($form{weather}, 'dull', 'Parsing scalar param into hash with GET');
+is (ref $form{game}, 'ARRAY', 'Parsing array param into hash with GET');
+is ($form{game}[1], 'checkers', 'Extracting array param value into hash with GET');
+
+$form = CGI::Lite->parse_form_data;
+is ($cgi->is_error, 0, 'Parsing data via class method with GET');
+is ($form->{weather}, 'dull', 'Parsing scalar param via class method with GET');
+is (ref $form->{game}, 'ARRAY', 'Parsing array param via class method with GET');
+is ($form->{game}->[1], 'checkers', 'Extracting array param value via class method with GET');
+
+
$ENV{QUERY_STRING} =~ s/\&/;/g;
$form = $cgi->parse_new_form_data;
@@ -58,15 +71,28 @@ $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');
+delete $ENV{REQUEST_METHOD};
+{
+ @ARGV = ("t/post_stdin.txt");
+ $form = $cgi->parse_new_form_data;
+ is ($cgi->is_error, 0, 'No request method specified');
+ # Only try a dir if not windows eg:
+ # http://www.cpantesters.org/cpan/report/26444196-6bfa-1014-8bfa-d971bd707852
+ @ARGV = ($^O eq 'MSWin32' ? "t/post_stdin.txt" : "/");
+ my %form = $cgi->parse_new_form_data;
+ is ($cgi->is_error, 0, 'No request method specified, hash returned');
+}
+
# 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?
-#
+# Tests without CONTENT_LENGTH
+($cgi, $form) = post_data ($datafile);
+is ($cgi->is_error (), 0, 'Data posted without CONTENT_LENGTH');
+$ENV{CONTENT_LENGTH} = (stat ($datafile))[7];
($cgi, $form) = post_data ($datafile);
is ($cgi->is_error, 0, 'Parsing data with POST');
@@ -74,6 +100,12 @@ 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');
+($cgi, %form) = post_data ($datafile, undef, 1);
+is ($cgi->is_error, 0, 'Parsing data as hash with POST');
+is ($form{bar}, 'quux', 'Parsing scalar param as hash with POST');
+is (ref $form{foo}, 'ARRAY', 'Parsing array param as hash with POST');
+is ($form{foo}[1], 'baz', 'Extracting array param value as hash with POST');
+
$ENV{CONTENT_TYPE} = 'baz';
($cgi, $form) = post_data ($datafile);
is ($cgi->is_error, 1, 'Invalid content type with POST');
@@ -99,11 +131,11 @@ 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');
+ skip "No file created for stdout", 3 unless open my $tmp, '>', 'tmpout';
select $tmp;
$cgi->print_data;
close $tmp;
- open $tmp, '<tmpout';
+ open $tmp, '<', 'tmpout';
chomp (my $printed = <$tmp>);
is ($printed, q#foo = bar baz#, 'print_data double value');
chomp ($printed = <$tmp>);
@@ -113,13 +145,31 @@ SKIP: {
close $tmp and unlink 'tmpout';
}
+($cgi, $form) = post_data ($datafile, 20);
+is ($cgi->is_error, 1, 'Posted data larger than specified limit');
+
+($cgi, $form) = post_data ($datafile, 20000);
+is ($cgi->is_error, 0, 'Posted data smaller than specified limit');
+
+is ($cgi->set_size_limit (), undef, 'Undefined size limit trapped');
+is ($cgi->set_size_limit ('alpha'), -1, 'Non-numeric size limit trapped');
+is ($cgi->set_size_limit (10.537), -1, 'Non-integer size limit trapped');
+is ($cgi->set_size_limit (-500), -1, 'Non-integer size limit trapped');
+is ($cgi->set_size_limit (0), 0, 'Zero size limit accepted');
+
sub post_data {
- my $datafile = shift;
+ my ($datafile, $size_limit, $array) = @_;
local *STDIN;
- open STDIN, "<$datafile"
+ open STDIN, '<', $datafile
or die "Cannot open test file $datafile: $!";
binmode STDIN;
my $cgi = CGI::Lite->new;
+ $cgi->set_size_limit($size_limit) if defined $size_limit;
+ if ($array) {
+ my %form = $cgi->parse_form_data;
+ close STDIN;
+ return ($cgi, %form);
+ }
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-3.00/CGI-Lite-3.00/t/good_upload.txt
index 23e81d95..bbf7e7eb 100644
Binary files a/var/tmp/source/HOUSTON/CGI-Lite-2.05/CGI-Lite-2.05/t/good_upload.txt and b/var/tmp/source/HOUSTON/CGI-Lite-3.00/CGI-Lite-3.00/t/good_upload.txt differ
@@ -0,0 +1,30 @@
+--`!"$%^&*()-+[]{}'@.?~#|aaa
+Content-Disposition: form-data; name="plain_txt"; filename="test2.txt"
+Content-Length: 1037
+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 larger documents
+are handled by CGI::Lite.
+It is not intended for any other purpose.
+
+There has to be a lot of text in here because we need it to be several
+times the size of the buffer in order to test all the possible
+situations which the upload handler will encounter.
+The smallest buffer size is 256 of your puny Earth bytes and therefore
+this file ought to be somewhat in excess of three times that just to be
+sure. That's a lot of text when you stop to think about it and, as it
+turns out, even more when you have to come up with it.
+
+Why on earth are you reading this in the first place? It's really just
+placeholder text. I could have welched out and used Lorem Ipsum instead
+but how dull and uninspiring would that be? Designers, somewhat
+surprisiingly, appear to have little creativity when it comes to such
+placeholder text. Perhaps their programmer friends could help them out
+with that.
+
+OK, that's enough now.
+
+--`!"$%^&*()-+[]{}'@.?~#|aaa--
+
@@ -46,5 +46,17 @@ are handled by CGI::Lite.
</p>
<p><b>It is not intended for any other purpose.</b></p>
+--`!"$%^&*()-+[]{}'@.?~#|aaa
+Content-Disposition: form-data; name="html_notype"; filename="notype.html"
+Content-Length: 212
+
+<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,3 @@
+foo=bar
+baz=quux
+score=Man\ Utd\ nil\,\ Newcastle\ Utd\ five
@@ -0,0 +1,17 @@
+--`!"$%^&*()-+[]{}'@.?~#|aaa
+Content-Disposition: form-data; name="foolots"
+Content-Type: application/octet-stream
+
+bar
+--`!"$%^&*()-+[]{}'@.?~#|aaa
+Content-Disposition: form-data; name="foolots"
+Content-Type: application/octet-stream
+
+baz
+--`!"$%^&*()-+[]{}'@.?~#|aaa
+Content-Disposition: form-data; name="foolots"
+Content-Type: application/octet-stream
+
+quux
+--`!"$%^&*()-+[]{}'@.?~#|aaa--
+
diff --git a/var/tmp/source/HOUSTON/CGI-Lite-3.00/CGI-Lite-3.00/t/upload_no_trailing_files.txt b/var/tmp/source/HOUSTON/CGI-Lite-3.00/CGI-Lite-3.00/t/upload_no_trailing_files.txt
new file mode 100644
index 00000000..da008927
Binary files /dev/null and b/var/tmp/source/HOUSTON/CGI-Lite-3.00/CGI-Lite-3.00/t/upload_no_trailing_files.txt differ
@@ -14,8 +14,9 @@
#===============================================================================
use strict;
+use warnings;
-use Test::More tests => 11254; # last test to print
+use Test::More tests => 11278;
use lib './lib';
@@ -35,20 +36,42 @@ $ENV{CONTENT_LENGTH} = (stat ($datafile))[7];
$ENV{CONTENT_TYPE} = q#multipart/form-data; boundary=`!"$%^&*()-+[]{}'@.?~\#|aaa#;
my $uploaddir = 'tmpcgilite';
-mkdir ($uploaddir, 0700) unless -d $uploaddir;
+mkdir $uploaddir 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/;
+like ($form->{'does_not_exist_gif'}, qr/[0-9]+__does_not_exist\.gif/, 'Second file');
+like ($form->{'100;100_gif'}, qr/[0-9]+__100;100\.gif/, 'Third file');
+like ($form->{'300x300_gif'}, qr/[0-9]+__300x300\.gif/, 'Fourth file');
+is ($cgi->get_upload_type ('300x300_gif'), 'image/gif', 'MIME Type');
+
+# Same, but check it can also return as a hash
+($cgi, $form) = post_data ($datafile, $uploaddir, undef, 1);
+is ($cgi->is_error, 0, 'Parsing data with POST into hash');
+like ($form->{'does_not_exist_gif'}, qr/[0-9]+__does_not_exist\.gif/,
+ 'Second file from hash');
+like ($form->{'100;100_gif'}, qr/[0-9]+__100;100\.gif/,
+ 'Third file from hash');
+like ($form->{'300x300_gif'}, qr/[0-9]+__300x300\.gif/,
+ 'Fourth file from hash');
+
+my @files = (0, 0);
+
+is (ref $form->{'hello_world'}, 'ARRAY',
+ 'Duplicate file fieldnames become array') and
+ @files = @{$form->{'hello_world'}};
+like ($files[0], qr/[0-9]+__goodbye_world\.txt/,
+ 'First duplicate file has correct name');
+like ($files[1], qr/[0-9]+__hello_world\.txt/,
+ 'Second duplicate file has correct name');
+my $res = $cgi->get_upload_type ('hello_world');
+ok (defined $res, 'Duplicate fields have upload type set');
+is (ref $res, 'ARRAY', 'Duplicate fields have array ref of upload types');
+is ($res->[0], 'text/plain', 'Duplicate fields have correct upload types');
+
+@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]}";
@@ -59,16 +82,22 @@ for my $i (0..2) {
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";
+ skip "subdir '$testdir' could not be created", 3 unless (-d $testdir);
+
+ # See http://www.perlmonks.org/?node_id=587550 for a discussion of
+ # the futility of chmod and friends on MS Windows systems.
+ SKIP: {
+ skip "Not available on $^O", 2 if ($^O eq 'MSWin32' or $^O eq 'cygwin');
+ skip "Running as privileged user: $ENV{USER}", 2 unless $>;
+ 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)');
@@ -84,10 +113,13 @@ ok ($#mimetypes > 0, 'get_mime_types returns array');
is_deeply (\@mimetypes, [ 'text/html', 'text/plain' ],
'default mime types');
+is ($cgi->add_mime_type (), 0, 'Undefined mime type');
+
$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->add_mime_type ('application/json'), 0, 'added mime type again');
is ($cgi->remove_mime_type ('foo/bar'), 0,
'removed non-existant mime type');
@@ -99,14 +131,18 @@ is_deeply (\@mimetypes, [ 'application/json', 'text/plain' ],
'Correct mime types after removal');
# Filename tests
+$cgi->add_timestamp (-1);
+is ($cgi->{timestamp}, 1, 'Timestamp < 0');
+$cgi->add_timestamp (3);
+is ($cgi->{timestamp}, 1, 'Timestamp > 3');
$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');
+like ($form->{'does_not_exist_gif'}, qr/^does_not_exist\.gif/, 'Second file');
+like ($form->{'100;100_gif'}, qr/^100;100\.gif/, 'Third file');
+like ($form->{'300x300_gif'}, qr/^300x300\.gif/, 'Fourth file');
unlink ("$uploaddir/300x300.gif");
@@ -114,9 +150,9 @@ $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');
+like ($form->{'does_not_exist_gif'}, qr/[0-9]+__does_not_exist\.gif/, 'Second file');
+like ($form->{'100;100_gif'}, qr/[0-9]+__100;100\.gif/, 'Third file');
+like ($form->{'300x300_gif'}, qr/^300x300\.gif/, 'Fourth file');
sub cleanfile {
my $name = shift;
@@ -130,15 +166,21 @@ $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');
+like ($form->{'does_not_exist_gif'}, qr/^[0-9]+__does_not_exist\.gif/, 'Second file');
+like ($form->{'100;100_gif'}, qr/^100_100\.gif/, 'Third file');
+like ($form->{'300x300_gif'}, qr/^[0-9]+__300x300\.gif/, 'Fourth file');
-# Buffer size setting tests
+# 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');
+# Tests without CONTENT_LENGTH
+my $tmpcl = $ENV{CONTENT_LENGTH};
+$ENV{CONTENT_LENGTH} = 0;
+is ($cgi->set_buffer_size(1), 0, 'Buffer size unset without CONTENT_LENGTH');
+$ENV{CONTENT_LENGTH} = $tmpcl;
+
# File type tests
unlink "$uploaddir/100_100.gif" if -e "$uploaddir/100_100.gif";
@@ -149,9 +191,9 @@ 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');
+like ($form->{'does_not_exist_gif'}, qr/^[0-9]+__does_not_exist\.gif/, 'Second file');
+like ($form->{'100;100_gif'}, qr/^100_100\.gif/, 'Third file');
+like ($form->{'300x300_gif'}, qr/^[0-9]+__300x300\.gif/, 'Fourth file');
# Check the handles
my $imgdata = '';
my $handle = $form->{'100;100_gif'};
@@ -192,15 +234,58 @@ for my $buf_size (256 .. 1500) {
}
}
+is ($cgi->deny_uploads (), 0, 'Set deny_uploads undef');
+is ($cgi->deny_uploads (0), 0, 'Set deny_uploads false');
+
+is ($cgi->deny_uploads (1), 1, 'Set deny_uploads true');
+($cgi, $form) = post_data ($datafile, $uploaddir, $cgi);
+is ($cgi->is_error, 1, "Upload successfully denied");
+
+#$datafile = 't/post_text.txt';
+#$ENV{CONTENT_LENGTH} = (stat ($datafile))[7];
+#($cgi, $form) = post_data ($datafile);
+#is ($cgi->is_error, 1, 'Parsing bad data with POST');
+#warn $cgi->get_error_message if $cgi->is_error;
+##use Data::Dumper;
+##warn Dumper ($form);
+
+# Upload but no files
+$datafile = 't/upload_no_files.txt';
+$ENV{CONTENT_LENGTH} = (stat ($datafile))[7];
+($cgi, $form) = post_data ($datafile);
+is ($cgi->is_error, 0, 'Parsing upload data with no files');
+
+# Special case where the file uploads appear not last
+$datafile = 't/upload_no_trailing_files.txt';
+$ENV{CONTENT_LENGTH} = (stat ($datafile))[7];
+($cgi, $form) = post_data ($datafile, $uploaddir);
+is ($cgi->is_error, 0, 'Parsing upload data with no trailling files');
+
+$datafile = 't/large_file_upload.txt';
+$ENV{CONTENT_LENGTH} = (stat ($datafile))[7];
+$cgi->set_buffer_size (256);
+($cgi, $form) = post_data ($datafile, $uploaddir, $cgi);
+is ($cgi->is_error, 0, 'Parsing upload data with a large file');
+
+$ENV{CONTENT_LENGTH} += 500;
+($cgi, $form) = post_data ($datafile, $uploaddir, $cgi);
+is ($cgi->is_error, 1, 'Parsing upload data with over large content length');
+
+# Special case where the file uploads appear not last
sub post_data {
- my ($datafile, $dir, $cgi) = @_;
+ my ($datafile, $dir, $cgi, $as_array) = @_;
local *STDIN;
- open STDIN, "<$datafile"
+ 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);
+ if ($as_array) {
+ my %form = $cgi->parse_new_form_data;
+ close STDIN;
+ return ($cgi, \%form);
+ }
my $form = $cgi->parse_new_form_data;
close STDIN;
return ($cgi, $form);
@@ -211,7 +296,7 @@ sub warn_tail {
# 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. $!";
+ open (my $in, '<', $file) or return warn "Cannot open $file for reading. $!";
binmode $in;
local $/ = undef;
my $contents = <$in>;
@@ -0,0 +1,23 @@
+#!/usr/bin/perl
+#
+#===============================================================================
+#
+# FILE: kwalitee.t
+#
+# DESCRIPTION: Test Kwalitee
+#
+# FILES: ---
+# BUGS: ---
+# NOTES: ---
+# AUTHOR: Pete Houston (cpan@openstrike.co.uk)
+# COMPANY: Openstrike
+# CREATED: 26/02/15 17:45:01
+#===============================================================================
+
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Kwalitee 'kwalitee_ok';
+kwalitee_ok();
+done_testing();