view release on metacpan or  search on metacpan

t/40-more.t  view on Meta::CPAN

	restore_env();
};

# Test XSS injection detection
subtest 'XSS injection detection' => sub {
	setup_mock_env(
		GATEWAY_INTERFACE => 'CGI/1.1',
		REQUEST_METHOD => 'GET',
		QUERY_STRING => 'comment=<script>alert("xss")</script>'
	);

	# Mock STDIN data so that we don't hang on reading
	$CGI::Info::stdin_data = 'username=test&password=secret';

	my $info = CGI::Info->new();
	my $params = $info->params();

	is($info->{status}, 403, 'XSS injection blocked');
	ok(!defined($params), 'No parameters returned for XSS injection');

	restore_env();
	$CGI::Info::stdin_data = undef;
};

# Test directory traversal detection
subtest 'Directory traversal detection' => sub {
	setup_mock_env(
		GATEWAY_INTERFACE => 'CGI/1.1',
		REQUEST_METHOD => 'GET',
		QUERY_STRING => 'file=../../../etc/passwd'
	);

	my $info = CGI::Info->new();
	my $params = $info->params();

	is($info->{status}, 403, 'Directory traversal blocked');
	ok(!defined($params), 'No parameters returned for directory traversal');

	restore_env();
};

# Test User-Agent SQL injection detection
subtest 'User-Agent SQL injection detection' => sub {
	setup_mock_env(
		GATEWAY_INTERFACE => 'CGI/1.1',
		REQUEST_METHOD => 'GET',
		QUERY_STRING => 'q=test',
		HTTP_USER_AGENT => "Mozilla' AND 1=1 ORDER BY 1--"
	);

	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'};
	delete $ENV{'QUERY_STRING'};
	my $info = CGI::Info->new();

	local @ARGV = ('cached=value');

	my $params1 = $info->params();
	my $params2 = $info->params();

	is($params1, $params2, 'Parameters are cached on repeat calls');
	is($params1->{cached}, 'value', 'Cached parameters retain values');
};

# Test param() method
subtest 'param() method' => sub {
	my $info = CGI::Info->new();

	local @ARGV = ('name=John', 'age=30');

	is($info->param('name'), 'John', 'Single parameter retrieval');
	is($info->param('age'), '30', 'Numeric parameter as string');
	is($info->param('missing'), undef, 'Missing parameter returns undef');

	# Test param() without arguments (should call params())
	my $all_params = $info->param();
	is_deeply($all_params, {name => 'John', age => '30'}, 'param() without args returns all');
};

# Test param() with allow list
subtest 'param() with allow list' => sub {
	my $info = CGI::Info->new(carp_on_warn => 1);

	local @ARGV = ('allowed=yes', 'forbidden=no');

	# Set up allow list
	$info->params(allow => { allowed => undef });

	is($info->param('allowed'), 'yes', 'Allowed parameter accessible via param()');

	is($info->param('forbidden'), undef, 'Forbidden parameter returns undef');
	my @warn_msgs = map { $_->{message} }
		grep { $_->{level} eq 'warn' } @{$info->messages() // []};
	like(join("\n", @warn_msgs), qr/forbidden.*isn't in the allow list/, 'Warning recorded for forbidden access');
};

# Test edge cases and error conditions
subtest 'Edge cases and error conditions' => sub {
	my $info = CGI::Info->new();

	# Test empty parameters
	local @ARGV = ();
	my $params = $info->params();
	ok(!defined($params), 'Empty parameters return undef');

	# Test malformed key=value pairs
	local @ARGV = ('=value', 'key=', 'malformed');
	$params = $info->params();

	ok(!exists($params->{''}), 'Empty key ignored');
	is($params->{key}, undef, 'Empty value handled correctly');
	ok(!exists($params->{malformed}), 'Malformed pair without = ignored');
};

# Test URL decoding
subtest 'URL decoding' => sub {
	my $info = CGI::Info->new();

	local @ARGV = ('name=John%20Doe', 'email=test%40example.com', 'plus=a+b');

	my $params = $info->params();

	is($params->{name}, 'John Doe', 'Space decoding from %20');
	is($params->{email}, 'test@example.com', 'At symbol decoding from %40');
	is($params->{plus}, 'a b', 'Plus to space conversion');
};

# Test duplicate parameter handling
subtest 'Duplicate parameter handling' => sub {
	my $info = CGI::Info->new();

	# Simulate duplicate parameters (normally from query string)
	local @ARGV = ('tag=red', 'tag=blue', 'tag=green');

	my $params = $info->params();

	# Should combine with commas
	is($params->{tag}, 'red,blue,green', 'Duplicate parameters combined with commas');
};

# Test content length validation
subtest 'Content length validation' => sub {
	setup_mock_env(
		GATEWAY_INTERFACE => 'CGI/1.1',
		REQUEST_METHOD => 'POST',
		CONTENT_TYPE => 'application/x-www-form-urlencoded'
	);

	my $info = CGI::Info->new();

	# Test missing content length
	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'
	);

	my $info = CGI::Info->new();
	my $params = $info->params();
	is($info->{status}, 405, 'OPTIONS method returns 405');

	# Test DELETE method
	$ENV{REQUEST_METHOD} = 'DELETE';
	$params = $info->params();
	is($info->{status}, 405, 'DELETE method returns 405');

	# Test unsupported method
	$ENV{REQUEST_METHOD} = 'PATCH';
	$params = $info->params();
	is($info->{status}, 501, 'Unsupported method returns 501');

	restore_env();
};

# Test testing flags
subtest 'Testing flags' => sub {
	local %ENV;
	delete $ENV{'GATEWAY_INTERFACE'};
	delete $ENV{'REQUEST_METHOD'};
	delete $ENV{'QUERY_STRING'};
	my $info = CGI::Info->new();

	# Test robot flag
	local @ARGV = ('--robot', 'param=value');
	my $params = $info->params();

	ok($info->{is_robot}, 'Robot flag sets is_robot');
	is($params->{param}, 'value', 'Parameters parsed after flag');

	# Test mobile flag
	$info = CGI::Info->new();
	local @ARGV = ('--mobile', 'device=phone');
	$params = $info->params();

	ok($info->{is_mobile}, 'Mobile flag sets is_mobile');

	# Test search engine flag
	$info = CGI::Info->new();
	local @ARGV = ('--search-engine', 'bot=google');
	$params = $info->params();

	ok($info->{is_search_engine}, 'Search engine flag sets is_search_engine');

	# Test tablet flag
	$info = CGI::Info->new();