view release on metacpan or  search on metacpan

t/function.t  view on Meta::CPAN

	$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
	$ENV{REQUEST_METHOD}    = 'DELETE';
	my $info = CGI::Info->new();
	$info->params();
	is($info->status(), $config{status_method_na}, 'DELETE yields 405');
};

# ============================================================
# 4. params()
# ============================================================

# Simple GET with two parameters
subtest 'params() - GET simple query' => sub {
	plan tests => 3;
	reset_env();
	$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
	$ENV{REQUEST_METHOD}    = 'GET';
	$ENV{QUERY_STRING}      = 'foo=bar&baz=42';
	my $info = CGI::Info->new();
	my $p = $info->params();
	ok(defined $p, 'params() returns defined value');
	is($p->{foo}, 'bar', 'foo=bar parsed correctly');
	is($p->{baz}, '42',  'baz=42 parsed correctly');
};

diag("Testing params() edge cases") if $ENV{TEST_VERBOSE};

# Empty QUERY_STRING returns undef
subtest 'params() - empty QUERY_STRING returns undef' => sub {
	plan tests => 1;
	reset_env();
	$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
	$ENV{REQUEST_METHOD}    = 'GET';
	$ENV{QUERY_STRING}      = '';
	my $info = CGI::Info->new();
	ok(!defined $info->params(), 'empty QUERY_STRING returns undef');
};

# allow hashref filters out unlisted keys
subtest 'params() - allow filters unknown keys' => sub {
	plan tests => 2;
	reset_env();
	$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
	$ENV{REQUEST_METHOD}    = 'GET';
	$ENV{QUERY_STRING}      = 'good=1&evil=2';
	my $info = CGI::Info->new();
	my $p = $info->params(allow => { good => qr/^\d+$/ });
	ok(defined $p->{good}, 'allowed key is present in result');
	ok(!defined $p->{evil}, 'disallowed key is absent from result');
};

# allow regex mismatch removes value and sets 422
subtest 'params() - allow regex mismatch blocks value and sets 422' => sub {
	plan tests => 2;
	reset_env();
	$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
	$ENV{REQUEST_METHOD}    = 'GET';
	$ENV{QUERY_STRING}      = 'id=abc';
	my $info = CGI::Info->new();
	my $p = $info->params(allow => { id => qr/^\d+$/ });
	ok(!defined $p, 'regex-blocked parameter excluded from result');
	is($info->status(), $config{status_unproc}, 'status 422 set on validation failure');
};

# allow exact-string comparison
subtest 'params() - allow exact-string match passes valid value' => sub {
	plan tests => 1;
	reset_env();
	$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
	$ENV{REQUEST_METHOD}    = 'GET';
	$ENV{QUERY_STRING}      = 'color=blue';
	my $info = CGI::Info->new();
	my $p = $info->params(allow => { color => 'blue' });
	ok(defined $p, 'exact-string allow passes matching value');
};

# allow coderef validator
subtest 'params() - allow coderef validator' => sub {
	plan tests => 2;
	reset_env();
	$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
	$ENV{REQUEST_METHOD}    = 'GET';
	$ENV{QUERY_STRING}      = 'num=4&num2=3';
	my $info = CGI::Info->new();
	my $p = $info->params(allow => {
		num  => sub { ($_[1] % 2) == 0 },   # even => accept
		num2 => sub { ($_[1] % 2) == 0 },   # odd  => reject
	});
	ok(defined  $p->{num},  'even number passes coderef validator');
	ok(!defined $p->{num2}, 'odd number blocked by coderef validator');
};

# SQL injection in query string must be blocked with 403
subtest 'params() - SQL injection blocked with 403' => sub {
	plan tests => 2;
	reset_env();
	$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
	$ENV{REQUEST_METHOD}    = 'GET';
	$ENV{QUERY_STRING}      = "id=1'%20OR%201=1";
	my $info = CGI::Info->new();
	my $p = $info->params();
	ok(!defined $p, 'SQL injection blocked');
	is($info->status(), $config{status_forbidden}, 'status 403 set on SQL injection');
};

# XSS in query string must be blocked with 403
subtest 'params() - XSS injection blocked with 403' => sub {
	plan tests => 2;
	reset_env();
	$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
	$ENV{REQUEST_METHOD}    = 'GET';
	$ENV{QUERY_STRING}      = 'q=%3Cscript%3Ealert(1)%3C%2Fscript%3E';
	my $info = CGI::Info->new();
	my $p = $info->params();
	ok(!defined $p, 'XSS injection blocked');
	is($info->status(), $config{status_forbidden}, 'status 403 set on XSS');
};

# Directory traversal must be blocked with 403
subtest 'params() - directory traversal blocked with 403' => sub {
	plan tests => 2;
	reset_env();
	$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
	$ENV{REQUEST_METHOD}    = 'GET';
	$ENV{QUERY_STRING}      = 'file=../../etc/passwd';
	my $info = CGI::Info->new();
	my $p = $info->params();
	ok(!defined $p, 'directory traversal blocked');
	is($info->status(), $config{status_forbidden}, 'status 403 set on traversal');
};

# mustleak probe must be blocked with 403
subtest 'params() - mustleak probe blocked with 403' => sub {
	plan tests => 2;
	reset_env();
	$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
	$ENV{REQUEST_METHOD}    = 'GET';
	$ENV{QUERY_STRING}      = 'x=mustleak.com/probe';
	my $info = CGI::Info->new();
	my $p = $info->params();
	ok(!defined $p, 'mustleak probe blocked');
	is($info->status(), $config{status_forbidden}, 'status 403 set on mustleak');
};

# Duplicate keys should be comma-joined
subtest 'params() - duplicate keys comma-joined' => sub {
	plan tests => 1;
	reset_env();
	$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
	$ENV{REQUEST_METHOD}    = 'GET';
	$ENV{QUERY_STRING}      = 'color=red&color=blue';
	my $info = CGI::Info->new();
	my $p = $info->params();
	like($p->{color}, qr/red.*blue|blue.*red/, 'duplicate values are comma-joined');
};

# POST without CONTENT_LENGTH returns undef and sets 411
subtest 'params() - POST missing CONTENT_LENGTH sets 411' => sub {
	plan tests => 2;
	reset_env();
	$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
	$ENV{REQUEST_METHOD}    = 'POST';
	my $info = CGI::Info->new();
	my $p = $info->params();
	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');
	is($p->{age},  '30',    'age parsed from ARGV');
};

# --mobile ARGV flag sets is_mobile
subtest 'params() - --mobile ARGV flag sets is_mobile' => sub {
	plan tests => 1;
	reset_env();
	local @ARGV = ('--mobile', 'x=1');
	my $info = CGI::Info->new();
	$info->params();
	ok($info->is_mobile(), '--mobile flag sets is_mobile');
};