CGI-Info
view release on metacpan or search on metacpan
t/edge_cases.t view on Meta::CPAN
};
subtest 'env: User-Agent containing only whitespace' => sub {
reset_env();
$ENV{HTTP_USER_AGENT} = ' ';
$ENV{REMOTE_ADDR} = '1.2.3.4';
my $info = CGI::Info->new();
eval { $info->is_mobile() };
ok(!$@, 'does not die on whitespace-only User-Agent');
};
subtest 'env: empty string User-Agent' => sub {
reset_env();
$ENV{HTTP_USER_AGENT} = '';
$ENV{REMOTE_ADDR} = '1.2.3.4';
my $info = CGI::Info->new();
eval { $info->is_mobile() };
ok(!$@, 'does not die on empty User-Agent');
};
subtest 'env: HTTP_COOKIE with malformed pairs (safe cases)' => sub {
reset_env();
# Avoid '==' which triggers a known CGI::Info bug (odd-element hash from
# split producing 3 elements for '=='). Test other malformations.
$ENV{HTTP_COOKIE} = '=noname; noval=; a=b=c; ;';
my $info = CGI::Info->new();
eval { $info->cookie('a') };
ok(!$@, 'does not die on malformed cookie string (no == case)');
};
subtest 'env: HTTP_COOKIE with == pair (known CGI::Info bug - documents behaviour)' => sub {
reset_env();
# '==' in a cookie string causes split(/=/, '==', 2) to return ('', '')
# but map { split(/=/, $_, 2) } across all pairs yields an odd-element list
# when a bare '==' entry is present, triggering "Odd number of elements"
# This test documents the behaviour — it may warn but must not die fatally.
$ENV{HTTP_COOKIE} = 'good=val; ==; other=x';
my $info = CGI::Info->new();
local $SIG{__WARN__} = sub { }; # suppress the "Odd number" warning
eval { $info->cookie('good') };
ok(!$@, 'cookie() with == in jar does not die (warns only)');
};
subtest 'env: HTTP_COOKIE with very long value' => sub {
reset_env();
$ENV{HTTP_COOKIE} = 'session=' . ('S' x 4096);
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';
$ENV{QUERY_STRING} = 'foo=1&bar=2';
my $info = CGI::Info->new();
my $p = eval { $info->params(allow => {}) };
ok(!$@, 'does not die with empty allow hashref');
ok(!defined($p), 'empty allow blocks all params, returns undef');
};
subtest 'allow: key mapped to empty string only allows empty value' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'flag=';
my $info = CGI::Info->new();
# Empty string value should match allow => { flag => '' }
my $p = eval { $info->params(allow => { flag => '' }) };
ok(!$@, 'does not die on allow with empty string schema');
};
subtest 'allow: coderef that always returns false blocks everything' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'x=1&y=2';
my $info = CGI::Info->new();
my $p = eval { $info->params(allow => {
x => sub { 0 },
y => sub { 0 },
}) };
ok(!$@, 'does not die when coderef always returns false');
ok(!defined($p), 'all-false coderef blocks all params');
};
subtest 'allow: coderef that dies is propagated' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'x=1';
my $info = CGI::Info->new();
eval { $info->params(allow => {
x => sub { die "validation exploded\n" }
}) };
like($@, qr/validation exploded/, 'coderef exception propagates to caller');
};
subtest 'allow: very long regex that matches' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'x=hello';
# Build an alternation regex with many alternatives
my $re = qr/^(hello|world|foo|bar|baz|qux|one|two|three|four|five|six|seven|eight|nine|ten)$/;
my $info = CGI::Info->new();
my $p = eval { $info->params(allow => { x => $re }) };
ok(!$@, 'does not die on complex allow regex');
is($p->{x}, 'hello', 'complex regex allow passes correct value');
};
subtest 'allow: undef value in allow permits any string including attack-like' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
# Even with undef allow, WAF still runs on GET
$ENV{QUERY_STRING} = 'note=normalvalue';
my $info = CGI::Info->new();
my $p = eval { $info->params(allow => { note => undef }) };
ok(!$@, 'does not die with undef allow value');
ok(defined $p && defined $p->{note}, 'undef allow passes normal value');
};
# ============================================================
# 7. STDIN / POST edge cases
# ============================================================
subtest 'POST: stdin_data pre-populated (FCGI reuse scenario)' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'POST';
$ENV{CONTENT_TYPE} = 'application/x-www-form-urlencoded';
my $body = 'fcgi=1&req=second';
$ENV{CONTENT_LENGTH} = length($body);
$CGI::Info::stdin_data = $body;
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die when stdin_data pre-populated');
ok(!defined($p) || defined($p->{fcgi}), 'pre-populated stdin_data used');
};
subtest 'POST: content-type with charset parameter' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'POST';
$ENV{CONTENT_TYPE} = 'application/x-www-form-urlencoded; charset=UTF-8';
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';
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on multipart GET');
# Source says: multipart/form-data not supported for GET
is($info->status(), 501, 'multipart GET returns 501 Not Implemented');
};
subtest 'POST: unsupported content-type handled without dying' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'POST';
$ENV{CONTENT_TYPE} = 'application/octet-stream';
my $body = "\x00\x01\x02\x03binary";
$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 unsupported content-type POST');
};
# ============================================================
# 8. Script path edge cases
# ============================================================
subtest 'script_path: SCRIPT_FILENAME with spaces in path' => sub {
reset_env();
$ENV{SCRIPT_FILENAME} = '/var/www/my scripts/app.cgi';
my $info = CGI::Info->new();
my $path = eval { $info->script_path() };
ok(!$@, 'does not die on SCRIPT_FILENAME with spaces');
};
subtest 'script_name: called multiple times returns same value' => sub {
reset_env();
$ENV{SCRIPT_NAME} = '/cgi-bin/myapp.cgi';
my $info = CGI::Info->new();
my $n1 = $info->script_name();
my $n2 = $info->script_name();
is($n1, $n2, 'script_name() idempotent across multiple calls');
};
subtest 'script_dir: called multiple times returns same value' => sub {
reset_env();
$ENV{SCRIPT_FILENAME} = '/var/www/cgi-bin/app.cgi';
my $info = CGI::Info->new();
my $d1 = $info->script_dir();
t/edge_cases.t view on Meta::CPAN
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on zero-length XML POST');
};
# application/json: the module tries to parse via JSON::MaybeXS.
# Gracefully degrade when the module is absent.
subtest 'POST application/json: body parsed into params (or graceful failure)' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'POST';
$ENV{CONTENT_TYPE} = 'application/json';
my $body = '{"name":"alice","score":"99"}';
$ENV{CONTENT_LENGTH} = length($body);
$CGI::Info::stdin_data = $body;
my $info = CGI::Info->new();
my $p = eval { $info->params() };
if($@) {
# JSON::MaybeXS not installed - the module will die inside params()
like($@, qr/JSON|locate/i,
'params() dies with informative error when JSON::MaybeXS absent');
} else {
# JSON available
ok(!defined($p) || (ref($p) eq 'HASH'),
'JSON POST: returns hashref or undef (not a crash)');
if(defined $p) {
is($p->{name}, 'alice', 'JSON name parsed correctly');
is($p->{score}, '99', 'JSON score parsed correctly');
}
}
};
# Malformed JSON should not crash the process.
subtest 'POST application/json: malformed body dies cleanly (not silently corrupts)' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'POST';
$ENV{CONTENT_TYPE} = 'application/json';
my $body = '{broken json:::}';
$ENV{CONTENT_LENGTH} = length($body);
$CGI::Info::stdin_data = $body;
my $json_available = eval { require JSON::MaybeXS; 1 };
unless($json_available) {
pass('JSON::MaybeXS not installed - skipping malformed JSON test');
return;
}
my $info = CGI::Info->new();
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';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'a=1&b=2&c=3';
local $_ = 'sentinel_value';
my $info = CGI::Info->new();
$info->params();
is($_, 'sentinel_value', 'params() did not clobber $_');
};
# $_ must also survive is_mobile() and is_robot() calls that use regex.
subtest 'global integrity: $_ not clobbered by UA-detection methods' => sub {
reset_env();
$ENV{HTTP_USER_AGENT} = 'Mozilla/5.0 (iPhone; CPU iPhone OS 15_0 like Mac OS X)';
$ENV{REMOTE_ADDR} = '1.2.3.4';
local $_ = 'still_sentinel';
my $info = CGI::Info->new();
$info->is_mobile();
$info->is_robot();
$info->is_ai();
$info->browser_type();
is($_, 'still_sentinel', '$_ intact after is_mobile/is_robot/is_ai/browser_type');
};
# params() internally uses eval for require calls. A successful eval clears
# $@; we verify that params() does not die when the caller has a non-empty $@.
subtest 'global integrity: params() works when caller has dirty $@' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'x=1';
eval { die "prior caller error\n" }; # set $@
my $pre_err = $@;
ok(length($pre_err), 'precondition: $@ is set before calling params()');
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'params() does not die when called with a dirty $@');
};
# ============================================================
# 25. Referrer-based robot detection: hostile referrer values
# ============================================================
# Spam referrers with a closing parenthesis are blocked.
# The WAF checks for ')' in the referrer string.
subtest 'is_robot: referrer with closing parenthesis blocked as spam' => sub {
reset_env();
$ENV{HTTP_USER_AGENT} = 'Mozilla/5.0 Firefox/120.0';
( run in 1.548 second using v1.01-cache-2.11-cpan-b16cb0d3907 )