view release on metacpan or  search on metacpan

t/function.t  view on Meta::CPAN

	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');
};

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

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

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

# Second params() call returns the same cached hashref
subtest 'params() - result is cached on second call' => sub {
	plan tests => 1;
	reset_env();
	$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
	$ENV{REQUEST_METHOD}    = 'GET';
	$ENV{QUERY_STRING}      = 'k=v';
	my $info = CGI::Info->new();
	my $p1 = $info->params();
	my $p2 = $info->params();
	is($p1, $p2, 'second params() call returns the same hashref (cached)');
};

# ============================================================
# 5. param($field)
# ============================================================

# Single param value retrieval
subtest 'param() - returns single value for known key' => sub {
	plan tests => 1;
	reset_env();
	$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
	$ENV{REQUEST_METHOD}    = 'GET';
	$ENV{QUERY_STRING}      = 'foo=hello';
	my $info = CGI::Info->new();
	is($info->param('foo'), 'hello', 'param() returns correct value');
};

# Missing key returns undef
subtest 'param() - unknown key returns undef' => sub {
	plan tests => 1;
	reset_env();
	$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
	$ENV{REQUEST_METHOD}    = 'GET';
	$ENV{QUERY_STRING}      = 'foo=hello';
	my $info = CGI::Info->new();
	ok(!defined $info->param('bar'), 'missing param returns undef');
};

# param() with no arg delegates to params() and returns hashref
subtest 'param() - no arg delegates to params()' => sub {
	plan tests => 1;
	reset_env();
	$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
	$ENV{REQUEST_METHOD}    = 'GET';
	$ENV{QUERY_STRING}      = 'x=1';
	my $info = CGI::Info->new();
	my $p = $info->param();
	is(ref $p, 'HASH', 'param() with no arg returns hashref');
};

# param() for key outside allow list should warn and return undef
subtest 'param() - warns and returns undef for key outside allow list' => sub {
	plan tests => 2;
	reset_env();