CGI-Info
view release on metacpan or search on metacpan
Revision history for CGI-Info
1.14 Thu Jul 23 21:29:19 EDT 2026
[ Enhancements ]
- Add is_ai() method: returns true for known AI training/inference crawlers (ClaudeBot, GPTBot, PerplexityBot, CCBot, etc.)
browser_type() now returns 'ai' for these visitors
- More helpful error message on "Multipart/form-data not supported"
- Set status to 501 when attempting to upload to a place that doesn't take uploads
- Log the invalid method type
- Clone path now validates logger and croaks on deprecated expect argument, matching the normal construction path
- Clone path deletes cached paramref so a new allow schema is applied on the first params() call
- Upgrade t/40-more.t from Test::MockModule to Test::Mockingbird; fix three pre-existing test bugs now exposed
- Add use autodie qw(:all) and Readonly constants ($MAX_UPLOAD_SIZE_DEFAULT, $CACHE_TTL_ROBOT, $CACHE_TTL_SEARCH) to eliminate magic numbers
- Fix UNIVERSAL::isa() deprecation warning in _find_paths(): replaced with proper ->isa() call
- Remove dead commented-out expect and interactive debug blocks from params()
- Fix reversed referrer logic in is_robot(): now correctly checks if the HTTP_REFERER starts with a known crawler URL
- Add API SPECIFICATION, MESSAGES and FORMAL SPECIFICATION sections to param() POD
- Add t/locales.t: tests system-locale (POSIX LC_ALL) error-path invariance under en_US.UTF-8, de_DE.UTF-8, and zh_CN.UTF-8; geographic GeoIP subtests skipped unless IP::Country::Fast is installed
- Fix t/00-load.t bail-out: capture load error before use_ok clobbers $@, then BAIL_OUT with the actual reason on failure
- Fix double-colon instantiation validation to correctly croak when params are provided to CGI::Info::new
1.13 Sun Apr 12 08:49:24 EDT 2026
Fixed test failures on Windows, e.g. https://www.cpantesters.org/cpan/report/5bf7930a-7048-1014-8eeb-cabb5837fa32
Bump Test::Mockingbird version, fixes https://www.cpantesters.org/cpan/report/5992cad6-3527-11f1-a62b-8d83cf1a6737
1.12 Sun Apr 5 17:46:12 EDT 2026
as_string should not return undef
Added mutation tests and LCSAJ data to the test dashboard
Say who is trying to upload or using unsupported multipart
Block attacks with var_dump%28md5
Allow the default max_upload_size to be configurable at runtime
Added function.t - white-box tests for all functions, including helper functions
Added unit.t - a set of black-box subtests to test each public function, according to their API documentation in the POD
Added integration.t - a set of subtests to black‑box, end‑to‑end behaviour across multiple routines, including the entire package, according to the POD documentation.
Includes as many stateful tests and tests of integration with other packages as possible.
Added edge_cases.t - a set of destructive, pathological, boundary‑condition subtests
Fixed an issue that edge_cases found in scanning very long parameters for injections - the scan was slow and inefficient
Added extended.t - any other tests
Fix handling double injection NUL via %2500
1.11 Mon Feb 2 12:59:36 EST 2026
0.95 Sun Mar 2 19:52:56 EST 2025
Use Params::Get
0.94 Fri Feb 28 12:24:30 EST 2025
number types can also have min and max values
Now logs all messages in the array messages. The warnings array has been removed.
Use Params::Validate::Strict rather than built in code
0.93 Wed Feb 26 09:47:02 EST 2025
Use facility local0
Improved upload filename generation to prevent overwriting
allow() now supports full rule schemas
Croak rather than carp on expect, and remove all its code
Intercepted arguments that result in 422 now raise LOG_NOTICE rather than LOG_INFO
0.92 Thu Feb 13 15:16:57 EST 2025
Return empty string with warnings_as_string() rather than undef when no warnings
0.91 Mon Feb 10 14:32:57 EST 2025
Added t/waf.t to test the Web Application Firewall
params(): instead of cleaning up XSS, now sets them to 403 and doesn't pass the values back
0.88 Mon Jan 13 09:33:24 EST 2025
Improved arg checking
Merge https://github.com/nigelhorne/CGI-Info/pull/21 (plicease)
Added _get_env()
0.87 Wed Dec 18 11:06:09 EST 2024
Test warnings()
Allow the logger to be a ref to code
Fix is_mobile() default return code
Added t/30-basics.t
upload_dir must now be in, or a subdir of, tmpdir()
0.86 Mon Nov 25 09:17:30 EST 2024
Ensure correct message is logged on SQL injection attempt
Remember warnings in the warnings array - added warnings() method
0.85 Sun Nov 17 09:49:52 EST 2024
Send back HTTP code 422 when argument fails "allow"
Added come comments and small optimisations
new(): Use Scalar::Util to verify it's an object
Refactor AUTOLOAD
Bump minimum version of File::Spec
Use List::MoreUtils instead of grep
0.64 Thu Oct 12 10:30:18 EDT 2017
Added mechanism to speak to setlogsock - useful for Dreamhost customers
Added set_logger
0.63 Wed Jul 5 20:57:31 EDT 2017
When preventing SQL injection or XSS, don't return any parameters, since
it's best to assume everything is poisoned
Added max_upload_size to new()
OPTIONS shouldn't get through to CGI::Info, so disallow it
0.62 Wed 21 Dec 09:28:36 EST 2016
Added status() method
Set maximum file upload size to 512K
0.61 Thu 1 Dec 21:46:44 EST 2016
Missed bin/* from the MANIFEST
0.60 Thu Dec 1 14:42:37 EST 2016
Handle JSON POST data
AUTOLOAD parameters
Added the cookie() method
Added Appveyor support to CI test on Windows
Added tests that the framework to allow CGI scripts to be tested from
Consider Majestic12 to be a search engine
Only load File::Basename when needed
Use String::EscapeCage to taint and grab values
Added param message
0.47 Sun Aug 24 14:56:10 EDT 2014
Support hostnames with dots at the end, e.g. when the URL used to
access a site is http://www.example.com., domain_name() will
return example.com, not example.com..
params() - return nothing when the call is OPTIONS
Added more hardening to file uploads
Added optional cache argument to new() to speed up look-ups
Test that tmpdir works at the class level
0.46 Mon 11 Nov 08:46:26 EST 2013
Corrected some documentation issues on params()
Corrected handling of many cookies
Ensure script_path(), script_name() and tmpdir() are untainted.
0.45 Fri 31 May 16:22:08 EDT 2013
_multipart_data(): Handle missing filename when uploading
Added _syslog and _logger to new()
Added warning if domain information can't be found
Don't load HTTP::BrowserDetect more than once (assume
HTTP_USER_AGENT doesn't change)
Use Test::Most instead of Test::More
Improve XSS prevention by using String::Clean::XSS
Added the allow option. It will replace the expected option
0.44 Wed Apr 10 09:53:31 EDT 2013
Fix t/params.t when the root directory is writable (e.g.
0.43 Sat Feb 16 12:18:50 EST 2013
Warn if reading POST arguments fail
Replaced t/unused.t with t/vars.t
Added extra check to t/script.t to check it returns an
existing file
Used 'PERL5OPT=-MDevel::Cover make test; cover' to add extra
tests
is_mobile(): return true for clients running on Androd
0.42 Sat Oct 13 17:22:38 EDT 2012
Croak rather than carp if upload_dir isn't set
t/params.t no longer runs in tainted mode for File::Spec::Win32
Added t/changes.t, though that doesn't support date(1) output
Added browser_type()
0.41 Thu Sep 13 13:38:43 BST 2012
get_cookie(): added validation, fix unitialized variable if the
requested cookie isn't in the jar
0.40 Mon Sep 10 08:21:31 BST 2012
Fixed t/rootdir.t on Windows
}
my $id = $info->param('id'); # Validated against allow schema
# SUBROUTINES/METHODS
## new
Creates a CGI::Info object.
It takes four optional arguments: allow, logger, expect and upload\_dir,
which are documented in the params() method.
It takes other optional parameters:
- `auto_load`
Enable/disable the AUTOLOAD feature.
The default is to have it enabled.
- `config_dirs`
Points to a configuration file which contains the parameters to `new()`.
The file can be in any common format,
including `YAML`, `XML`, and `INI`.
This allows the parameters to be set at run time.
On non-Windows system,
the class can be configured using environment variables starting with "CGI::Info::".
For example:
export CGI::Info::max_upload_size=65536
It doesn't work on Windows because of the case-insensitive nature of that system.
If the configuration file has a section called `CGI::Info`,
only that section,
and the `global` section,
if any exists,
is used.
- `syslog`
[Sys::Syslog](https://metacpan.org/pod/Sys%3A%3ASyslog).
It can be a boolean to enable/disable logging to syslog, or a reference
to a hash to be given to Sys::Syslog::setlogsock.
- `cache`
An object that is used to cache IP lookups.
This cache object is an object that understands get() and set() messages,
such as a [CHI](https://metacpan.org/pod/CHI) object.
- `max_upload_size`
The maximum file size in bytes you can upload.
Use `-1` for no limit.
The default is 512 KB (524288 bytes).
The class can be configured at runtime using environment variables and configuration
files; for example, setting `$ENV{'CGI__INFO__carp_on_warn'}` causes warnings to
use [Carp](https://metacpan.org/pod/Carp). For more information see [Object::Configure](https://metacpan.org/pod/Object%3A%3AConfigure).
### API SPECIFICATION
#### INPUT
{
allow => { type => 'hashref', optional => 1 },
auto_load => { type => 'boolean', optional => 1 },
cache => { type => 'object', optional => 1 },
carp_on_warn => { type => 'boolean', optional => 1 },
config_dirs => { type => 'arrayref', optional => 1 },
config_file => { type => 'string', optional => 1 },
logger => { type => 'object', optional => 1 },
max_upload_size=> { type => 'integer', optional => 1, min => -1 },
upload_dir => { type => 'string', optional => 1 },
}
#### OUTPUT
{ type => 'object', isa => 'CGI::Info' }
### MESSAGES
- `use ->new() not ::new() to instantiate`
./script.cgi --mobile name=Nigel
Returns undef if the parameters can't be determined or if none were given.
If an argument is given twice or more, then the values are put in a comma
separated string.
The returned hash value can be passed into [CGI::Untaint](https://metacpan.org/pod/CGI%3A%3AUntaint).
Takes four optional parameters: allow, logger and upload\_dir.
The parameters are passed in a hash, or a reference to a hash.
The latter is more efficient since it puts less on the stack.
Allow is a reference to a hash list of CGI parameters that you will allow.
The value for each entry is either a permitted value,
a regular expression of permitted values for
the key,
a code reference,
or a hash of [Params::Validate::Strict](https://metacpan.org/pod/Params%3A%3AValidate%3A%3AStrict) rules.
Subroutine exceptions propagate normally, allowing custom error handling.
This works alongside existing regex and Params::Validate::Strict patterns.
A undef value means that any value will be allowed.
Arguments not in the list are silently ignored.
This is useful to help to block attacks on your site.
Upload\_dir is a string containing a directory where files being uploaded are to
be stored.
It must be a writeable directory in the temporary area.
Takes an optional parameter logger, which is used for warnings and traces.
It can be an object that understands warn() and trace() messages,
such as a [Log::Log4perl](https://metacpan.org/pod/Log%3A%3ALog4perl) or [Log::Any](https://metacpan.org/pod/Log%3A%3AAny) object,
a reference to code,
a reference to an array,
or a filename.
The allow, logger and upload\_dir arguments can also be passed to the
constructor.
use CGI::Info;
use CGI::Untaint;
# ...
my $info = CGI::Info->new();
my %params;
if($info->params()) {
%params = %{$info->params()};
}
### new
-- CGI::Info construction
new : ClassName x Params --> CGIInfo
-- Normal (non-clone) path
new(class, params) ^=
let configured == Object::Configure::configure(class, params)
in CGIInfo {
max_upload_size |-> configured.max_upload_size ?? MAX_UPLOAD_SIZE_DEFAULT,
allow |-> configured.allow ?? null,
upload_dir |-> configured.upload_dir ?? null,
...configured
}
-- Pre-conditions
pre new(class, params) ^=
params.logger = null
v (blessed(params.logger)
^ params.logger.can('warn')
^ params.logger.can('info')
^ params.logger.can('error'))
lib/CGI/Info.pm view on Meta::CPAN
use Params::Validate::Strict 0.35;
use Return::Set;
use Sys::Path;
use Sub::Protected;
use namespace::clean;
# ---------------------------------------------------------------------------
# Module-level constants -- avoids magic numbers scattered through the code
# ---------------------------------------------------------------------------
Readonly my $MAX_UPLOAD_SIZE_DEFAULT => 512 * 1024; # 512 KB default upload cap
Readonly my $CACHE_TTL_ROBOT => '1 day'; # TTL for robot-detection cache entries
Readonly my $CACHE_TTL_SEARCH => '1 day'; # TTL for search-engine cache entries
# Compiled once at module-load time: replaces the 29-element @crawler_lists array
# that was re-allocated on every is_robot() call. Building the alternation with
# quotemeta() is equivalent to the former List::Util::any { /^\Q$_\E/i } loop
# but avoids both per-call array construction and per-element regex compilation.
Readonly my $CRAWLER_REFERER_RE => do {
my @domains = (
'http://fix-website-errors.com',
lib/CGI/Info.pm view on Meta::CPAN
}
my $id = $info->param('id'); # Validated against allow schema
=head1 SUBROUTINES/METHODS
=head2 new
Creates a CGI::Info object.
It takes four optional arguments: allow, logger, expect and upload_dir,
which are documented in the params() method.
It takes other optional parameters:
=over 4
=item * C<auto_load>
Enable/disable the AUTOLOAD feature.
The default is to have it enabled.
lib/CGI/Info.pm view on Meta::CPAN
Points to a configuration file which contains the parameters to C<new()>.
The file can be in any common format,
including C<YAML>, C<XML>, and C<INI>.
This allows the parameters to be set at run time.
On non-Windows system,
the class can be configured using environment variables starting with "CGI::Info::".
For example:
export CGI::Info::max_upload_size=65536
It doesn't work on Windows because of the case-insensitive nature of that system.
If the configuration file has a section called C<CGI::Info>,
only that section,
and the C<global> section,
if any exists,
is used.
=item * C<syslog>
lib/CGI/Info.pm view on Meta::CPAN
L<Sys::Syslog>.
It can be a boolean to enable/disable logging to syslog, or a reference
to a hash to be given to Sys::Syslog::setlogsock.
=item * C<cache>
An object that is used to cache IP lookups.
This cache object is an object that understands get() and set() messages,
such as a L<CHI> object.
=item * C<max_upload_size>
The maximum file size in bytes you can upload.
Use C<-1> for no limit.
The default is 512 KB (524288 bytes).
=back
The class can be configured at runtime using environment variables and configuration
files; for example, setting C<$ENV{'CGI__INFO__carp_on_warn'}> causes warnings to
use L<Carp>. For more information see L<Object::Configure>.
=head3 API SPECIFICATION
lib/CGI/Info.pm view on Meta::CPAN
=head4 INPUT
{
allow => { type => 'hashref', optional => 1 },
auto_load => { type => 'boolean', optional => 1 },
cache => { type => 'object', optional => 1 },
carp_on_warn => { type => 'boolean', optional => 1 },
config_dirs => { type => 'arrayref', optional => 1 },
config_file => { type => 'string', optional => 1 },
logger => { type => 'object', optional => 1 },
max_upload_size=> { type => 'integer', optional => 1, min => -1 },
upload_dir => { type => 'string', optional => 1 },
}
=head4 OUTPUT
{ type => 'object', isa => 'CGI::Info' }
=head3 MESSAGES
=over 4
lib/CGI/Info.pm view on Meta::CPAN
# }
# # warn __PACKAGE__, ': expect is deprecated, use allow instead';
if(my $logger = $params->{'logger'}) {
$logger->error("$class: expect has been deprecated, use allow instead");
}
Carp::croak("$class: expect has been deprecated, use allow instead");
}
# Return the blessed object with sensible defaults
return bless {
max_upload_size => $MAX_UPLOAD_SIZE_DEFAULT,
allow => undef,
upload_dir => undef,
%{$params} # Caller-supplied args override the defaults above
}, $class;
}
=head2 script_name
Retrieves the name of the executing CGI script.
This is useful for POSTing,
thus avoiding hard-coded paths into forms.
lib/CGI/Info.pm view on Meta::CPAN
./script.cgi --mobile name=Nigel
Returns undef if the parameters can't be determined or if none were given.
If an argument is given twice or more, then the values are put in a comma
separated string.
The returned hash value can be passed into L<CGI::Untaint>.
Takes four optional parameters: allow, logger and upload_dir.
The parameters are passed in a hash, or a reference to a hash.
The latter is more efficient since it puts less on the stack.
Allow is a reference to a hash list of CGI parameters that you will allow.
The value for each entry is either a permitted value,
a regular expression of permitted values for
the key,
a code reference,
or a hash of L<Params::Validate::Strict> rules.
Subroutine exceptions propagate normally, allowing custom error handling.
This works alongside existing regex and Params::Validate::Strict patterns.
A undef value means that any value will be allowed.
Arguments not in the list are silently ignored.
This is useful to help to block attacks on your site.
Upload_dir is a string containing a directory where files being uploaded are to
be stored.
It must be a writeable directory in the temporary area.
Takes an optional parameter logger, which is used for warnings and traces.
It can be an object that understands warn() and trace() messages,
such as a L<Log::Log4perl> or L<Log::Any> object,
a reference to code,
a reference to an array,
or a filename.
The allow, logger and upload_dir arguments can also be passed to the
constructor.
use CGI::Info;
use CGI::Untaint;
# ...
my $info = CGI::Info->new();
my %params;
if($info->params()) {
%params = %{$info->params()};
}
lib/CGI/Info.pm view on Meta::CPAN
my $params = Params::Get::get_params(undef, @_);
if((defined($self->{paramref})) && ((!defined($params->{'allow'})) || defined($self->{allow}) && ($params->{'allow'} eq $self->{allow}))) {
return $self->{paramref};
}
if(defined($params->{allow})) {
$self->{allow} = $params->{allow};
}
if(defined($params->{upload_dir})) {
$self->{upload_dir} = $params->{upload_dir};
}
if(defined($params->{'logger'})) {
$self->set_logger($params->{'logger'});
}
$self->_trace('Entering params');
my @pairs;
my $content_type = $ENV{'CONTENT_TYPE'};
my %FORM;
lib/CGI/Info.pm view on Meta::CPAN
@pairs = split(/&/, $query);
} else {
return;
}
} elsif($ENV{'REQUEST_METHOD'} eq 'POST') {
my $content_length = $self->_get_env('CONTENT_LENGTH');
if((!defined($content_length)) || ($content_length =~ /\D/)) {
$self->{status} = 411;
return;
}
if(($self->{max_upload_size} >= 0) && ($content_length > $self->{max_upload_size})) { # Set maximum posts
# TODO: Design a way to tell the caller to send HTTP
# status 413
$self->{status} = 413;
$self->_warn('Large upload prohibited');
return;
}
if((!defined($content_type)) || ($content_type =~ /application\/x-www-form-urlencoded/)) {
my $buffer;
if($stdin_data) {
$buffer = $stdin_data;
} else {
if(read(STDIN, $buffer, $content_length) != $content_length) {
$self->_warn('POST failed: something else may have read STDIN');
}
$stdin_data = $buffer;
}
@pairs = split(/&/, $buffer);
# if($ENV{'QUERY_STRING'}) {
# my @getpairs = split(/&/, $ENV{'QUERY_STRING'});
# push(@pairs, @getpairs);
# }
} elsif($content_type =~ /multipart\/form-data/i) {
if(!defined($self->{upload_dir})) {
if($ENV{'REMOTE_ADDR'}) {
# This could be an attack
$self->_warn({ warning => "$ENV{REMOTE_ADDR}: Attempt to upload a file of $content_length bytes when upload_dir has not been set" });
} else {
$self->_warn({ warning => 'Attempt to upload a file when upload_dir has not been set' });
}
$self->status(501); # Not implemented
return;
}
# Validate 'upload_dir'
# Ensure the upload directory is safe and accessible
# - Check permissions
# - Validate path to prevent directory traversal attacks
# TODO: Consider using a temporary directory for uploads and moving them later
if(!File::Spec->file_name_is_absolute($self->{upload_dir})) {
$self->_warn({
warning => "upload_dir $self->{upload_dir} isn't a full pathname"
});
$self->status(500);
delete $self->{upload_dir};
return;
}
if(!-d $self->{upload_dir}) {
$self->_warn({
warning => "upload_dir $self->{upload_dir} isn't a directory"
});
$self->status(500);
delete $self->{upload_dir};
return;
}
if(!-w $self->{upload_dir}) {
delete $self->{paramref};
$self->_warn({
warning => "upload_dir $self->{upload_dir} isn't writeable"
});
$self->status(500);
delete $self->{upload_dir};
return;
}
my $tmpdir = $self->tmpdir();
if($self->{'upload_dir'} !~ /^\Q$tmpdir\E/) {
$self->_warn({
warning => 'upload_dir ' . $self->{'upload_dir'} . " isn't somewhere in the temporary area $tmpdir"
});
$self->status(500);
delete $self->{upload_dir};
return;
}
if($content_type =~ /boundary=(\S+)$/) {
@pairs = $self->_multipart_data({
length => $content_length,
boundary => $1
});
}
} elsif($content_type =~ /text\/xml/i) {
my $buffer;
lib/CGI/Info.pm view on Meta::CPAN
} elsif($line =~ /^Content-Disposition: (.+)/i) {
my $field = $1;
if($field =~ /name="(.+?)"/) {
$key = $1;
}
# [^"]+ instead of .+ : stops at first '"' without backtracking,
# and cannot accidentally capture across the closing delimiter.
if($field =~ /filename="([^"]+)?"/) {
my $filename = $1;
unless(defined($filename)) {
$self->_warn('No upload filename given');
} elsif($filename =~ /[\\\/\|]/) {
$self->_warn("Disallowing invalid filename: $filename");
} else {
$filename = $self->_create_file_name({
filename => $filename
});
# Don't do this since it taints the string and I can't work out how to untaint it
# my $full_path = Cwd::realpath(File::Spec->catfile($self->{upload_dir}, $filename));
# $full_path =~ m/^(\/[\w\.]+)$/;
my $full_path = File::Spec->catfile($self->{upload_dir}, $filename);
unless(open($fout, '>', $full_path)) {
$self->_warn("Can't open $full_path");
}
$writing_file = 1;
push(@pairs, "$key=$filename");
}
}
}
# TODO: handle Content-Type: text/plain, etc.
} else {
lib/CGI/Info.pm view on Meta::CPAN
close $fout;
}
$self->_trace('Leaving _multipart_data');
return @pairs;
}
# Robust filename generation (preventing overwriting).
# Previously used "! -e $rc" which checked existence in the CURRENT WORKING
# DIRECTORY, not the upload directory — a logic bug and a TOCTOU race.
# Now checks in the actual upload directory and caps iterations to avoid
# an infinite loop if the directory fills up.
sub _create_file_name :Protected {
my ($self, $args) = @_;
my $upload_dir = $self->{upload_dir};
my $filename = $$args{filename} . '_' . time;
my $counter = 0;
my $rc;
do {
$rc = $filename . ($counter ? "_$counter" : '');
$counter++;
# Check in upload_dir when set; otherwise check relative to CWD.
# File::Spec->catfile('', ...) produces an absolute path, so we
# must not pass an empty string as the directory component.
} until(
! -e ($upload_dir ? File::Spec->catfile($upload_dir, $rc) : $rc)
|| $counter > 1000
);
if($counter > 1000) {
Carp::croak('_create_file_name: unable to find a unique filename after 1000 attempts');
}
return $rc;
}
# Untaint a filename. Regex from CGI::Untaint::Filenames
lib/CGI/Info.pm view on Meta::CPAN
=head3 new
-- CGI::Info construction
new : ClassName x Params --> CGIInfo
-- Normal (non-clone) path
new(class, params) ^=
let configured == Object::Configure::configure(class, params)
in CGIInfo {
max_upload_size |-> configured.max_upload_size ?? MAX_UPLOAD_SIZE_DEFAULT,
allow |-> configured.allow ?? null,
upload_dir |-> configured.upload_dir ?? null,
...configured
}
-- Pre-conditions
pre new(class, params) ^=
params.logger = null
v (blessed(params.logger)
^ params.logger.can('warn')
^ params.logger.can('info')
^ params.logger.can('error'))
use Test::Most tests => 7;
BEGIN { use_ok('CGI::Info') }
isa_ok(CGI::Info->new(), 'CGI::Info', 'Creating CGI::Info object');
isa_ok(CGI::Info::new(), 'CGI::Info', 'Creating CGI::Info object');
isa_ok(CGI::Info->new()->new(), 'CGI::Info', 'Cloning CGI::Info object');
# ok(!defined(CGI::Info::new()));
# Create a new object with direct key-value pairs
my $info = CGI::Info->new(max_upload_size => 1024 * 1024, allow => [ 'jpg', 'png' ]);
cmp_ok($info->{max_upload_size}, '==', 1024 * 1024, 'direct key-value pairs');
# Test cloning behaviour by calling new() on an existing object
my $info2 = $info->new({ allow => [ 'gif' ], upload_dir => '/var/uploads' });
cmp_ok($info2->{max_upload_size}, '==', 1024 * 1024, 'clone keeps old args');
cmp_ok($info2->{upload_dir}, 'eq', '/var/uploads', 'clone adds new args');
t/30-basics.t view on Meta::CPAN
}
subtest 'CGI::Info' => sub {
subtest 'Constructor (new)' => sub {
subtest 'should handle invalid parameters gracefully' => sub {
throws_ok { CGI::Info->new('invalid_param', 'value', 'another parm') } qr/^Usage/, 'Dies on invalid args';
};
subtest 'should load config file if provided' => sub {
my ($fh, $config_file) = tempfile(TEMPLATE => 'test_configXXXX', SUFFIX => '.yml', TMPDIR => 1);
print $fh "---\nmax_upload_size: 100\n";
close $fh;
my $info = CGI::Info->new(config_file => $config_file);
is $info->{max_upload_size}, 100, 'Config file loaded correctly';
unlink $config_file;
};
# Expect is deprecated
# subtest 'should reject non-ARRAY expect parameter' => sub {
# throws_ok { CGI::Info->new(expect => {}) } qr/expect must be a reference/, 'Rejects non-array expect';
# };
subtest 'expect has been deprecated' => sub {
throws_ok { CGI::Info->new(expect => {}) } qr/expect has been deprecated/, 'Rejects non-array expect';
};
t/30-basics.t view on Meta::CPAN
REQUEST_METHOD => 'GET',
QUERY_STRING => 'id=1%27%20OR%201=1--'
}, sub {
my $info = CGI::Info->new(allow => { id => qr/^\d+$/ });
my $params = $info->params();
is $info->status, 422, 'Status 422 on SQL injection';
ok !defined $params->{id}, 'Blocked malicious parameter';
});
};
subtest 'should handle multipart form uploads' => sub {
mock_env({
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'POST',
CONTENT_TYPE => 'multipart/form-data; boundary=----boundary',
CONTENT_LENGTH => 1000
}, sub {
local *STDIN;
open STDIN, '<', \"------boundary\nContent-Disposition: form-data; name=\"file\"; filename=\"test.txt\"\n\ncontent\n------boundary--";
my $info = CGI::Info->new(upload_dir => File::Spec->tmpdir());
my $params = $info->params();
like($params->{file}, qr/test\.txt/, 'File upload handled');
unlink $params->{'file'}
});
};
subtest 'should reject oversized uploads' => sub {
mock_env({
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'POST',
CONTENT_TYPE => 'application/x-www-form-urlencoded',
CONTENT_LENGTH => 600 * 1024 # 600KB
}, sub {
my $info = CGI::Info->new(max_upload => 500); # 500KB limit
my $params = $info->params;
is $info->status, 413, 'Status 413 on oversized upload';
ok !defined $params, 'No params returned';
});
};
};
subtest 'Security Checks' => sub {
subtest 'should block XSS attempts' => sub {
mock_env({
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'GET',
t/40-more.t view on Meta::CPAN
my $info = CGI::Info->new();
my $params = $info->params();
is($info->{status}, 403, 'User-Agent SQL injection blocked');
ok(!defined($params), 'No parameters returned for malicious User-Agent');
restore_env();
};
# Test file upload validation
subtest 'File upload validation' => sub {
my $temp_dir = tempdir(CLEANUP => 1);
setup_mock_env(
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'POST',
CONTENT_TYPE => 'multipart/form-data; boundary=test123',
CONTENT_LENGTH => '100'
);
my $info = CGI::Info->new();
# Test without upload_dir
$CGI::Info::stdin_data = '{}';
my $params = $info->params();
ok(!defined($params), 'Upload rejected without upload_dir');
# Test with invalid upload_dir
$params = $info->params(upload_dir => '/invalid/path');
is($info->{status}, 500, 'Invalid upload directory rejected');
# Test with valid upload_dir in temp area
$params = $info->params(upload_dir => $temp_dir);
# Should pass validation (actual multipart parsing would need more setup)
restore_env();
$CGI::Info::stdin_data = undef;
};
# Test parameter caching
subtest 'Parameter caching' => sub {
delete $ENV{'GATEWAY_INTERFACE'};
delete $ENV{'REQUEST_METHOD'};
t/40-more.t view on Meta::CPAN
my $params = $info->params();
is($info->{status}, 411, 'Missing content length returns 411');
# Test invalid content length
$ENV{CONTENT_LENGTH} = 'invalid';
$params = $info->params();
is($info->{status}, 411, 'Invalid content length returns 411');
# Test oversized content
$info = new_ok('CGI::Info');
$info->{max_upload_size} = 100;
$ENV{CONTENT_LENGTH} = '1000';
$params = $info->params();
is($info->{status}, 413, 'Oversized content returns 413');
# Boundary test
$info = new_ok('CGI::Info');
$info->{max_upload_size} = 0;
$ENV{CONTENT_LENGTH} = '1';
$params = $info->params();
is($info->{status}, 413, 'Oversized content returns 413, when max_upload_size set to 0');
$info = CGI::Info->new(max_upload_size => 0);
$params = $info->params();
is($info->{status}, 413, 'Oversized content returns 413, when max_upload_size set to 0 in new');
restore_env();
};
# Test HTTP method validation
subtest 'HTTP method validation' => sub {
# Test OPTIONS method
setup_mock_env(
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'OPTIONS'
-------xyz--
EOF
local $ENV{'CONTENT_LENGTH'} = length($input);
if(-w '/') {
# GitHub actions images run as root
diag('/ is writeable');
ok(1);
ok(1);
} else {
does_carp_that_matches(sub { new_ok('CGI::Info')->params(upload_dir => '/') }, qr/ isn't writeable$/);
}
does_carp_that_matches(sub { new_ok('CGI::Info')->params(upload_dir => 't/carp.t') }, qr/ isn't a full pathname$/);
does_carp_that_matches(sub { new_ok('CGI::Info')->params(upload_dir => '/t/carp.t') }, qr/ isn't a directory$/);
# new_ok('CGI::Info')->params(upload_dir => '/t/carp.t');
}
}
t/cgi_security.t view on Meta::CPAN
# input-handling code.
#
# Purpose: actively try to bypass the WAF and input sanitisation using
# weaponised payloads. Tests that FAIL expose real security gaps.
#
# Attack surface:
# QUERY_STRING / POST body → params() WAF (SQL, XSS, traversal)
# HTTP_USER_AGENT → is_robot() UA-level SQL injection check
# HTTP_REFERER → is_robot() referrer spam/injection check
# HTTP_COOKIE → cookie() jar parser
# PATH_INFO / multipart name → _create_file_name() / upload path
#
# =head1 API SPECIFICATION
#
# =head4 INPUT (HTTP request model under test)
#
# GATEWAY_INTERFACE = 'CGI/1.1'
# REQUEST_METHOD = 'GET' | 'POST'
# REMOTE_ADDR = IPv4 string
# HTTP_USER_AGENT = arbitrary string (attacker-controlled)
# QUERY_STRING = key=value pairs (attacker-controlled)
t/config_file.t view on Meta::CPAN
use_ok('CGI::Info');
# Create a temp config file
my $tempdir = tempdir(CLEANUP => 1);
my $config_file = File::Spec->catdir($tempdir, 'config.yml');
# Write a fake config
my $class_name = 'CGI__Info';
DumpFile($config_file, {
$class_name => { max_upload_size => 2 }
});
# Create object using the config_file
my $obj = CGI::Info->new(config_file => $config_file);
ok($obj, 'Object was created successfully');
isa_ok($obj, 'CGI::Info');
cmp_ok($obj->{'max_upload_size'}, '==', 2, 'read max_upload_size from config');
# Windows gets confused with the case, it seems that it only likes uppercase environment variables
if($^O ne 'MSWin32') {
subtest 'Environment test' => sub {
local $ENV{$class_name . '__max_upload_size'} = 3;
$obj = CGI::Info->new(config_file => $config_file);
ok($obj, 'Object was created successfully');
isa_ok($obj, 'CGI::Info');
cmp_ok($obj->{'max_upload_size'}, '==', 3, 'read max_upload_size from environment');
}
};
# Nonexistent config file is ignored
my $mess = strerror(ENOENT);
throws_ok {
CGI::Info->new(config_file => '/nonexistent/path/to/config.yml');
} qr/\Q$mess\E/, 'Dies with non-existent config file';
# Malformed config file (not a hashref)
t/config_file.t view on Meta::CPAN
# print $badfh "--- Just a list\n- foo\n- bar\n";
# close $badfh;
# throws_ok {
# CGI::Info->new(config_file => $badfile);
# } qr/Can't load configuration from/, 'Throws error if config is not a hashref';
# Config file exists but has no key for the class
my $nofield_file = File::Spec->catdir($tempdir, 'nokey.yml');
DumpFile($nofield_file, {
NotTheClass => { max_upload_size => 4 }
});
$obj = CGI::Info->new(config_file => $nofield_file);
ok($obj, 'Object created with config that lacks class key');
cmp_ok($obj->{'max_upload_size'}, '==', 512 * 1024, 'Falls back to default if class key missing');
# The global section is read
my $global_file = File::Spec->catdir($tempdir, 'global.yml');
DumpFile($global_file, {
global => { max_upload_size => 4 }
});
$obj = CGI::Info->new(config_file => $global_file);
ok($obj, 'Object created with config that includes a global section');
cmp_ok($obj->{'max_upload_size'}, '==', 4, 'The global section is used');
# config_dirs is honoured
DumpFile($global_file, {
global => { max_upload_size => 5 }
});
$obj = CGI::Info->new(config_dirs => [$tempdir], config_file => 'global.yml');
ok($obj, 'Object created with config that includes a global section');
cmp_ok($obj->{'max_upload_size'}, '==', 5, 'The global section is used');
done_testing();
t/edge_cases.t view on Meta::CPAN
my $info = CGI::Info->new();
my $val = eval { $info->cookie('session') };
ok(!$@, 'does not die on very long cookie value');
ok(defined $val && length($val) == 4096, 'long cookie value preserved');
};
# ============================================================
# 5. Boundary values for numeric checks
# ============================================================
subtest 'boundary: max_upload_size = 0 blocks everything' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'POST';
$ENV{CONTENT_LENGTH} = 1;
my $info = CGI::Info->new(max_upload_size => 0);
my $p = eval { $info->params() };
ok(!$@, 'does not die with max_upload_size=0');
is($info->status(), 413, 'any POST body blocked when max_upload_size=0');
};
subtest 'boundary: max_upload_size = -1 means no limit' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'POST';
$ENV{CONTENT_LENGTH} = 999_999_999;
$ENV{CONTENT_TYPE} = 'application/x-www-form-urlencoded';
$CGI::Info::stdin_data = 'x=1';
my $info = CGI::Info->new(max_upload_size => -1);
my $p = eval { $info->params() };
ok(!$@, 'does not die with max_upload_size=-1');
isnt($info->status(), 413, 'max_upload_size=-1 does not block large POST');
};
subtest 'boundary: CONTENT_LENGTH exactly equals max_upload_size (edge, not over)' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'POST';
$ENV{CONTENT_TYPE} = 'application/x-www-form-urlencoded';
my $body = 'x=1';
$ENV{CONTENT_LENGTH} = length($body);
$CGI::Info::stdin_data = $body;
my $info = CGI::Info->new(max_upload_size => length($body));
my $p = eval { $info->params() };
ok(!$@, 'does not die when CONTENT_LENGTH == max_upload_size');
isnt($info->status(), 413,
'CONTENT_LENGTH == max_upload_size not rejected as oversized');
};
subtest 'boundary: CONTENT_LENGTH one byte over max_upload_size' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'POST';
$ENV{CONTENT_LENGTH} = 101;
my $info = CGI::Info->new(max_upload_size => 100);
my $p = eval { $info->params() };
ok(!$@, 'does not die when CONTENT_LENGTH one over max');
is($info->status(), 413, 'one byte over max_upload_size gives 413');
};
# ============================================================
# 6. allow list edge cases
# ============================================================
subtest 'allow: empty hashref blocks all params' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
t/edge_cases.t view on Meta::CPAN
my $body = 'msg=hello';
$ENV{CONTENT_LENGTH} = length($body);
$CGI::Info::stdin_data = $body;
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on content-type with charset');
ok(!defined($p) || defined($p->{msg}), 'params parsed with charset in content-type');
};
subtest 'POST: multipart without upload_dir returns undef gracefully' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'POST';
$ENV{CONTENT_TYPE} = 'multipart/form-data; boundary=----boundary123';
$ENV{CONTENT_LENGTH} = 100;
$ENV{REMOTE_ADDR} = '1.2.3.4';
my $info = CGI::Info->new(); # no upload_dir
my $p = eval { $info->params() };
ok(!$@, 'does not die on multipart POST without upload_dir');
ok(!defined $p, 'multipart without upload_dir returns undef');
};
subtest 'POST: GET-style multipart (should warn and return undef)' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{CONTENT_TYPE} = 'multipart/form-data; boundary=--b';
$ENV{QUERY_STRING} = 'x=1';
$ENV{REMOTE_ADDR} = '1.2.3.4';
t/edge_cases.t view on Meta::CPAN
eval { $info->params() };
# Either dies with a JSON parse error or returns undef — must not silently
# return a corrupted hashref
ok(1, 'malformed JSON POST does not segfault or silently corrupt');
if($@) {
like($@, qr/json|parse|invalid/i, 'JSON parse error propagated to caller');
}
};
# ============================================================
# 23. upload_dir: hostile path validation
# ============================================================
# A relative path fails File::Spec->file_name_is_absolute() and must be
# rejected before any filesystem access.
subtest 'upload_dir: relative path rejected with 500' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'POST';
$ENV{CONTENT_TYPE} = 'multipart/form-data; boundary=----b';
$ENV{CONTENT_LENGTH} = 100;
$ENV{REMOTE_ADDR} = '1.2.3.4';
my $info = CGI::Info->new();
my $p = eval { $info->params(upload_dir => 'relative/dir') };
ok(!$@, 'does not die on relative upload_dir');
is($info->status(), 500, 'relative upload_dir rejected with 500');
};
# An absolute but non-existent path must be rejected after the relativity check.
subtest 'upload_dir: non-existent absolute path rejected with 500' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'POST';
$ENV{CONTENT_TYPE} = 'multipart/form-data; boundary=----b';
$ENV{CONTENT_LENGTH} = 100;
$ENV{REMOTE_ADDR} = '1.2.3.4';
my $info = CGI::Info->new();
my $p = eval { $info->params(upload_dir => '/no/such/path/xyz123abc') };
ok(!$@, 'does not die on non-existent absolute upload_dir');
is($info->status(), 500, 'non-existent absolute upload_dir rejected with 500');
};
# upload_dir pointing to a plain file (not a directory) must be rejected.
subtest 'upload_dir: file path (not a dir) rejected with 500' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'POST';
$ENV{CONTENT_TYPE} = 'multipart/form-data; boundary=----b';
$ENV{CONTENT_LENGTH} = 100;
$ENV{REMOTE_ADDR} = '1.2.3.4';
# Use a file known to exist on any POSIX system
my $file_path = $^O eq 'MSWin32' ? 'C:\\Windows\\system32\\cmd.exe'
: '/etc/hostname';
my $info = CGI::Info->new();
my $p = eval { $info->params(upload_dir => $file_path) };
ok(!$@, 'does not die on upload_dir pointing to a file');
is($info->status(), 500, 'upload_dir pointing to a file rejected with 500');
};
# ============================================================
# 24. Global variable integrity: $_ and $@ must not be clobbered
# ============================================================
# Perl's $_ is a commonly overused global. The module must not destroy it.
subtest 'global integrity: $_ not clobbered by params()' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
t/extended_tests.t view on Meta::CPAN
$ENV{QUERY_STRING} = 'a=1\\u0026b=2';
my $info = CGI::Info->new();
my $p = $info->params();
ok(defined $p, 'params returned with \\u0026 encoded ampersand');
is($p->{a}, '1', 'a=1 parsed after \\u0026 decoded');
is($p->{b}, '2', 'b=2 parsed after \\u0026 decoded');
};
# ============================================================
# 11. params() — upload_dir not absolute => 500
# Branch: !File::Spec->file_name_is_absolute($self->{upload_dir})
# ============================================================
subtest 'params: multipart with relative upload_dir => 500' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'POST';
$ENV{CONTENT_TYPE} = 'multipart/form-data; boundary=----b';
$ENV{CONTENT_LENGTH} = 100;
my $info = CGI::Info->new(upload_dir => 'relative/path');
my $p = eval { $info->params() };
ok(!$@, 'does not die on relative upload_dir');
ok(!defined($p), 'relative upload_dir returns undef');
is($info->status(), 500, 'relative upload_dir sets status 500');
};
# ============================================================
# 12. params() — upload_dir not a directory => 500
# Branch: !-d $self->{upload_dir}
# ============================================================
subtest 'params: multipart with upload_dir pointing to a file => 500' => sub {
reset_env();
my $tmp = File::Temp->new(UNLINK => 1);
my $file = $tmp->filename();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'POST';
$ENV{CONTENT_TYPE} = 'multipart/form-data; boundary=----b';
$ENV{CONTENT_LENGTH} = 100;
my $info = CGI::Info->new(upload_dir => $file);
my $p = eval { $info->params() };
ok(!$@, 'does not die when upload_dir is a file not a dir');
ok(!defined($p), 'file-as-upload_dir returns undef');
is($info->status(), 500, 'file-as-upload_dir sets status 500');
};
# ============================================================
# 13. params() — upload_dir not inside tmpdir => 500
# Branch: upload_dir !~ /^\Q$tmpdir\E/
# ============================================================
subtest 'params: upload_dir outside tmpdir => 500' => sub {
reset_env();
my $outside = tempdir(CLEANUP => 1);
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'POST';
$ENV{CONTENT_TYPE} = 'multipart/form-data; boundary=----b';
$ENV{CONTENT_LENGTH} = 100;
# Make tmpdir() return something different from $outside by mocking
my $guard = mock_scoped 'CGI::Info::tmpdir' => sub { return '/nonexistent/tmpdir/xyz' };
my $info = CGI::Info->new(upload_dir => $outside);
my $p = eval { $info->params() };
ok(!$@, 'does not die when upload_dir outside tmpdir');
ok(!defined($p), 'upload_dir outside tmpdir returns undef');
is($info->status(), 500, 'upload_dir outside tmpdir sets status 500');
};
# ============================================================
# 14. params() — Params::Validate::Strict schema returns empty hash
# Branch: !(scalar keys %{$value}) after validate_strict
# ============================================================
subtest 'params: schema validation returning empty hash blocks param' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
t/function.t view on Meta::CPAN
Readonly my $UA_CBOT => 'ClaudeBot/1.0';
Readonly my $UA_CLAUDE_WEB => 'Claude-Web/1.0';
Readonly my $UA_GPTBOT => 'Mozilla/5.0 AppleWebKit/537.36 (KHTML, like Gecko; compatible; GPTBot/1.2; +https://openai.com/gptbot)';
Readonly my $UA_CHATGPT_USER => 'Mozilla/5.0 AppleWebKit/537.36 (KHTML, like Gecko); ChatGPT-User/1.0; +https://openai.com/bot)';
Readonly my $UA_COHERE_AI => 'cohere-ai/1.0';
# GPTBot UA that also embeds a SQL injection payload: used to verify WAF ordering
Readonly my $UA_GPTBOT_SQL => 'GPTBot/1.0 SELECT foo AND bar FROM baz';
# %config gathers all constants for Object::Configure-style flexibility
my %config = (
upload_small => $UPLOAD_SMALL,
upload_max => $UPLOAD_MAX,
upload_oversized => $UPLOAD_OVERSIZED,
good_ip => $GOOD_IP,
googlebot_ip => $GOOGLEBOT_IP,
port_http => $PORT_HTTP,
port_https => $PORT_HTTPS,
status_ok => $STATUS_OK,
status_forbidden => $STATUS_FORBIDDEN,
status_not_found => $STATUS_NOT_FOUND,
status_method_na => $STATUS_METHOD_NA,
status_length_req => $STATUS_LENGTH_REQ,
status_too_large => $STATUS_TOO_LARGE,
t/function.t view on Meta::CPAN
reset_env();
my $info = CGI::Info->new();
ok(blessed($info), 'new() returns a blessed reference');
isa_ok($info, 'CGI::Info');
};
# Hashref argument style
subtest 'new() - hashref args set internal fields' => sub {
plan tests => 1;
reset_env();
my $info = CGI::Info->new({ max_upload_size => $config{upload_small} });
is($info->{max_upload_size}, $config{upload_small}, 'max_upload_size set via hashref');
};
# Flat hash argument style
subtest 'new() - flat hash args set internal fields' => sub {
plan tests => 1;
reset_env();
my $info = CGI::Info->new(max_upload_size => $config{upload_max});
is($info->{max_upload_size}, $config{upload_max}, 'max_upload_size set via flat hash');
};
# Clone path merges args over parent, parent unchanged
subtest 'new() - clone overrides field without modifying parent' => sub {
plan tests => 2;
reset_env();
my $orig = CGI::Info->new(max_upload_size => 999);
my $clone = $orig->new(max_upload_size => 111);
is($clone->{max_upload_size}, 111, 'clone has overridden field');
is($orig->{max_upload_size}, 999, 'original object is unchanged');
};
# expect parameter was removed; must croak
subtest 'new() - expect deprecated croak' => sub {
plan tests => 1;
reset_env();
throws_ok {
CGI::Info->new(expect => [qw(foo)])
} qr/expect has been deprecated/i, 'expect param causes croak';
};
t/function.t view on Meta::CPAN
my $info = eval { CGI::Info::new() };
ok(!$@, '::new() with no args does not croak');
ok(blessed($info), '::new() with no args still returns an object');
};
# ::new() with undef class and 1+ params croaks with helpful message
subtest 'new() - ::new() with undef class + params croaks' => sub {
plan tests => 1;
reset_env();
throws_ok {
CGI::Info::new(undef, max_upload_size => $config{upload_small})
} qr/use ->new\(\) not ::new\(\)/i, '::new() with undef class + params croaks';
};
# Logger validation: object missing warn/info/error must fail guard
subtest 'new() - logger guard rejects object lacking required methods' => sub {
plan tests => 2;
reset_env();
{
package NoMethodLogger;
sub new { bless {}, shift }
t/function.t view on Meta::CPAN
ok(!defined $p, 'POST without CONTENT_LENGTH returns undef');
is($info->status(), $config{status_length_req}, 'status 411 set on missing CONTENT_LENGTH');
};
# POST with oversized body returns undef and sets 413
subtest 'params() - POST oversized body sets 413' => sub {
plan tests => 2;
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'POST';
$ENV{CONTENT_LENGTH} = $config{upload_oversized};
my $info = CGI::Info->new(max_upload_size => $config{upload_small});
my $p = $info->params();
ok(!defined $p, 'oversized POST returns undef');
is($info->status(), $config{status_too_large}, 'status 413 set on oversized upload');
};
# Non-CGI: ARGV key=value pairs
subtest 'params() - command-line ARGV key=value pairs' => sub {
plan tests => 2;
reset_env();
local @ARGV = ('name=Alice', 'age=30');
my $info = CGI::Info->new();
my $p = $info->params();
is($p->{name}, 'Alice', 'name parsed from ARGV');
t/function.t view on Meta::CPAN
# ============================================================
# 28. Internal helper: _create_file_name (white-box)
# ============================================================
# Returns a timestamped filename that does not yet exist on disk
subtest '_create_file_name - returns non-existent timestamped name' => sub {
plan tests => 3;
reset_env();
my $info = CGI::Info->new();
my $t_before = time();
my $result = $info->_create_file_name({ filename => 'functest_upload' });
my $t_after = time();
# Pattern: 'functest_upload_TIMESTAMP' with optional '_N' collision counter
like($result, qr/^functest_upload_\d+(_\d+)?$/, 'result matches expected pattern');
my ($ts) = $result =~ /^functest_upload_(\d+)/;
ok($ts >= $t_before && $ts <= $t_after + 1, 'embedded timestamp is within current second');
ok(! -e $result, 'returned path does not already exist on disk');
};
# When the base name already exists, a collision counter is appended
subtest '_create_file_name - appends counter when base name exists' => sub {
plan tests => 1;
reset_env();
my $tmp = tempdir(CLEANUP => 1);
t/integration.t view on Meta::CPAN
# ============================================================
# 5. Stateful: clone inherits parent state, overrides work
# ============================================================
subtest 'clone: inherits parent config, override applies independently' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'q=test';
my $orig = CGI::Info->new(max_upload_size => 1024);
my $clone = $orig->new(max_upload_size => 512);
# Both are valid CGI::Info objects
isa_ok($orig, 'CGI::Info', 'original');
isa_ok($clone, 'CGI::Info', 'clone');
# Both can independently parse params from the same environment
my $p_orig = $orig->params();
my $p_clone = $clone->params();
is($p_orig->{q}, 'test', 'original parses q=test');
is($p_clone->{q}, 'test', 'clone parses q=test');
t/integration.t view on Meta::CPAN
subtest 'POST: content_length missing => 411, params undef' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'POST';
my $info = CGI::Info->new();
ok(!defined $info->params(), 'missing content-length returns undef');
is($info->status(), 411, 'status 411 on missing content-length');
};
subtest 'POST: body exceeds max_upload_size => 413, params undef' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'POST';
$ENV{CONTENT_LENGTH} = 1_000_000;
my $info = CGI::Info->new(max_upload_size => 1024);
ok(!defined $info->params(), 'oversized POST returns undef');
is($info->status(), 413, 'status 413 on oversized POST');
};
# ============================================================
# 17. Stateful: AUTOLOAD + allow interact correctly
# ============================================================
subtest 'AUTOLOAD with allow: only permitted params accessible as methods' => sub {
reset_env();
open ($fin, '<', \$input);
local *STDIN = $fin;
CGI::Info->reset(); # Force stdin re-read
my $tmpdir = File::Spec->tmpdir();
if(!-w $tmpdir) {
BAIL_OUT("Your temporary directory ' $tmpdir' isn't writable, fix your configuration and try again");
}
$i = new_ok('CGI::Info' => [
upload_dir => $tmpdir
]);
%p = %{$i->params()};
ok(defined($p{country}));
ok($p{country} eq '44');
ok($p{datafile} =~ /^hello.txt_.+/);
my $filename = File::Spec->catfile($tmpdir, $p{datafile});
ok(-e $filename);
ok(-r $filename);
unlink($filename);
close $fin;
$ENV{'REQUEST_METHOD'} = 'GET';
CGI::Info->reset(); # Force stdin re-read
$i = new_ok('CGI::Info' => [
upload_dir => $tmpdir
]);
$ENV{'QUERY_STRING'} = 'foo=bar';
eval { %p = $i->params() };
ok($@ =~ /Multipart.+ not supported for GET/);
delete $ENV{'QUERY_STRING'};
open ($fin, '<', \$input);
local *STDIN = $fin;
$ENV{'REQUEST_METHOD'} = 'POST';
CGI::Info->reset(); # Force stdin re-read
$i = new_ok('CGI::Info');
%p = %{$i->params(upload_dir => $tmpdir)};
ok(defined($p{country}));
ok($p{country} eq '44');
ok($p{datafile} =~ /^hello.txt_.+/);
$filename = File::Spec->catfile($tmpdir, $p{datafile});
ok(-e $filename) || diag("$filename doesn't exist");
ok(-r $filename);
unlink($filename);
close $fin;
$input = <<'EOF';
-------xyz
Content-Disposition: form-data; name="country"
44
-------xyz
Content-Disposition: form-data; name=".hidden"; filename="/.trojanhorse.js"
Content-Type: text/plain
I would do nasty things, but my upload will be disallowed
-------xyz--
EOF
$ENV{'CONTENT_LENGTH'} = length($input);
open ($fin, '<', \$input);
local *STDIN = $fin;
CGI::Info->reset(); # Force stdin re-read
$i = new_ok('CGI::Info' => [
upload_dir => $tmpdir
]);
eval { %p = %{$i->params()} };
ok(defined($@));
like($@, qr/Disallowing invalid filename/);
ok(defined($p{country}));
ok($p{country} == 44);
ok($p{datafile} =~ /^hello.txt_.+/);
$filename = File::Spec->catfile($tmpdir, $p{datafile});
ok(!-e $filename);
ok(!-r $filename);
-------xyz--
EOF
$ENV{'CONTENT_LENGTH'} = length($input);
open ($fin, '<', \$input);
local *STDIN = $fin;
CGI::Info->reset(); # Force stdin re-read
$i = new_ok('CGI::Info' => [
upload_dir => '/does_not_exist11',
]);
eval { %p = %{$i->params()} };
ok($@ =~ /isn't a directory/);
ok(defined($p{country}));
ok($p{country} == 44);
ok($p{datafile} =~ /^hello.txt_.+/);
$filename = File::Spec->catfile($tmpdir, $p{datafile});
ok(!-e $filename);
ok(!-r $filename);
close $fin;
open ($fin, '<', \$input);
local *STDIN = $fin;
CGI::Info->reset(); # Force stdin re-read
$i = new_ok('CGI::Info' => [
upload_dir => undef,
]);
eval { %p = $i->params() };
ok($@ =~ /Attempt to upload a file when upload_dir has not been set/);
ok(defined($p{country}));
ok($p{country} eq '44');
ok($p{datafile} =~ /^hello.txt_.+/);
$filename = File::Spec->catfile($tmpdir, $p{datafile});
ok(!-e $filename);
ok(!-r $filename);
close $fin;
SKIP: {
# e.g. running as root, or on Windows
skip 'Root directory is writable', 7 if(-w '/');
open ($fin, '<', \$input);
local *STDIN = $fin;
CGI::Info->reset(); # Force stdin re-read
$i = new_ok('CGI::Info' => [
upload_dir => '/',
]);
eval { %p = $i->params() };
ok($@ =~ /isn't writeable/);
ok(defined($p{country}));
ok($p{country} eq '44');
ok($p{datafile} =~ /^hello.txt_.+/);
$filename = File::Spec->catfile($tmpdir, $p{datafile});
ok(!-e $filename);
ok(!-r $filename);
close $fin;
}
open ($fin, '<', \$input);
local *STDIN = $fin;
my $script_path = $i->script_path();
CGI::Info->reset(); # Force stdin re-read
$i = new_ok('CGI::Info' => [
upload_dir => $script_path,
]);
eval { %p = $i->params() };
ok($@ =~ /isn't a directory/);
ok(defined($p{country}));
ok($p{country} eq '44');
ok($p{datafile} =~ /^hello.txt_.+/);
$filename = File::Spec->catfile($tmpdir, $p{datafile});
ok(!-e $filename);
ok(!-r $filename);
close $fin;
open ($fin, '<', \$input);
local *STDIN = $fin;
$script_path = $i->script_path();
CGI::Info->reset(); # Force stdin re-read
$i = new_ok('CGI::Info' => [
upload_dir => '.',
]);
eval { %p = $i->params() };
ok($@ =~ /isn't a full pathname/);
ok(defined($p{country}));
ok($p{country} eq '44');
ok($p{datafile} =~ /^hello.txt_.+/);
$filename = File::Spec->catfile($tmpdir, $p{datafile});
ok(!-e $filename);
ok(!-r $filename);
close $fin;
$ENV{'CONTENT_TYPE'} = 'xyzzy';
open ($fin, '<', \$input);
local *STDIN = $fin;
CGI::Info->reset(); # Force stdin re-read
$i = new_ok('CGI::Info' => [
upload_dir => $tmpdir
]);
eval { %p = $i->params() };
ok($@ =~ /POST: Invalid or unsupported content type: xyzzy/);
ok(defined($p{country}));
ok($p{country} eq '44');
ok($p{datafile} =~ /^hello.txt_.+/);
$filename = File::Spec->catfile($tmpdir, $p{datafile});
ok(!-e $filename);
ok(!-r $filename);
close $fin;
Hello, World
-------xyz--
EOF
open ($fin, '<', \$input);
local *STDIN = $fin;
$script_path = $i->script_path();
CGI::Info->reset(); # Force stdin re-read
$i = new_ok('CGI::Info' => [
upload_dir => $tmpdir
]);
eval { %p = $i->params() };
ok($@ =~ /Disallowing invalid filename/);
ok(defined($p{country}));
ok($p{country} eq '44');
ok($p{datafile} =~ /^hello.txt_.+/);
$filename = File::Spec->catfile($tmpdir, $p{datafile});
ok(!-e $filename);
ok(!-r $filename);
close $fin;
# new()
# ============================================================
subtest 'new() - returns a CGI::Info object' => sub {
reset_env();
my $info = new_ok('CGI::Info');
ok(blessed($info), 'new() returns a blessed object');
isa_ok($info, 'CGI::Info');
};
subtest 'new() - accepts max_upload_size' => sub {
reset_env();
my $info = CGI::Info->new(max_upload_size => 65536);
isa_ok($info, 'CGI::Info', 'constructed with max_upload_size');
};
subtest 'new() - accepts hashref of arguments' => sub {
reset_env();
my $info = CGI::Info->new({ max_upload_size => 65536 });
isa_ok($info, 'CGI::Info', 'constructed with hashref');
};
subtest 'new() - clones existing object' => sub {
reset_env();
my $orig = CGI::Info->new(max_upload_size => 999);
my $clone = $orig->new(max_upload_size => 42);
isa_ok($clone, 'CGI::Info', 'clone is a CGI::Info');
isnt($orig, $clone, 'clone is a different object');
};
subtest 'new() - expect parameter is deprecated and croaks' => sub {
reset_env();
eval { CGI::Info->new(expect => [qw(foo bar)]) };
like($@, qr/expect has been deprecated/i,
'expect parameter causes croak with deprecation message');
};
my $info = CGI::Info->new();
ok(!defined $info->params(), 'POST without CONTENT_LENGTH returns undef');
is($info->status(), 411, 'status 411 on missing CONTENT_LENGTH');
};
subtest 'params() - POST: oversized body => undef + status 413' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'POST';
$ENV{CONTENT_LENGTH} = 999_999_999;
my $info = CGI::Info->new(max_upload_size => 100);
ok(!defined $info->params(), 'oversized POST returns undef');
is($info->status(), 413, 'status 413 on oversized body');
};
subtest 'params() - OPTIONS => undef + status 405' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'OPTIONS';
my $info = CGI::Info->new();
ok(!defined $info->params(), 'OPTIONS returns undef');
#!/usr/bin/env perl
use strict;
use warnings;
use Test::Most;
use File::Spec;
use File::Temp qw(tempdir);
BEGIN { use_ok('CGI::Info') }
# Setup for tests
my $info;
my $upload_dir = tempdir(CLEANUP => 1);
subtest 'SQL Injection Detection' => sub {
local %ENV = (
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'GET',
QUERY_STRING => 'username=nigel%27+OR+%271%27%3D%271',
);
$info = new_ok('CGI::Info');
my $params = $info->params();
ok(!defined($params), 'SQL injection attempt blocked');
ok(!defined $params, 'Directory traversal attempt blocked');
is($info->status(), 403, 'Status set to 403 Forbidden');
};
subtest 'Upload Directory Validation' => sub {
local %ENV = (
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'POST',
CONTENT_TYPE => 'multipart/form-data; boundary=12345',
CONTENT_LENGTH => 100,
C_DOCUMENT_ROOT => $upload_dir,
);
# Invalid upload_dir (not absolute)
$info = CGI::Info->new(upload_dir => 'tmp');
$info->params();
is($info->status(), 500, 'Invalid upload_dir rejected');
# Valid upload_dir
$info = CGI::Info->new(upload_dir => $upload_dir);
local *STDIN;
open STDIN, '<', \"--12345\nContent-Disposition: form-data; name=\"file\"; filename=\"test.txt\"\n\nContent\n--12345--";
my $params = $info->params();
if(defined $params && defined $params->{file}) {
like($params->{file}, qr/test\.txt/, 'File uploaded to valid directory');
my $uploaded = File::Spec->catfile($upload_dir, $params->{file});
unlink $uploaded if -e $uploaded;
unlink $params->{file} if -e $params->{file};
} else {
pass('Upload skipped or params undef on this platform');
}
};
subtest 'Parameter Sanitization' => sub {
local %ENV = (
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'GET',
is($params->{value}, 'valid data', 'Spaces correctly decoded');
};
subtest 'Max Upload Size Enforcement' => sub {
local %ENV = (
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'POST',
CONTENT_TYPE => 'application/x-www-form-urlencoded',
CONTENT_LENGTH => 1024 * 1024 * 600, # 600MB
);
$info = CGI::Info->new(max_upload => 500 * 1024); # 500KB
$info->params();
is($info->status(), 413, 'Status set to 413 Payload Too Large');
};
subtest 'Command Line Parameters' => sub {
local @ARGV = ('--mobile', 'param1=value1', 'param2=value2');
$info = new_ok('CGI::Info');
my $params = $info->params();
is_deeply(
$params,
( run in 2.368 seconds using v1.01-cache-2.11-cpan-b16cb0d3907 )