CGI-Info
5 results

 view release on metacpan or  search on metacpan

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


sub restore_env {
	%ENV = %$original_env;
}

# Test basic parameter parsing
subtest 'Basic parameter parsing' => sub {
	my $info = new_ok('CGI::Info');

	# Test command line mode
	local @ARGV = ('name=John', 'age=30');
	my $params = $info->params();

	is($params->{name}, 'John', 'Command line parameter parsing');
	is($params->{age}, '30', 'Multiple command line parameters');
};

# Test HTTP GET parameter parsing
subtest 'GET request parsing' => sub {
	setup_mock_env(
		GATEWAY_INTERFACE => 'CGI/1.1',

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

	$CGI::Info::stdin_data = undef;
};

# Test allow list validation
subtest 'Allow list validation' => sub {
	my $info = CGI::Info->new();

	delete $ENV{'GATEWAY_INTERFACE'};
	delete $ENV{'REQUEST_METHOD'};
	delete $ENV{'QUERY_STRING'};
	local @ARGV = ('allowed=yes', 'forbidden=no');

	my $params = $info->params(
		allow => {
			allowed => undef,  # Any value allowed
			# forbidden parameter not in allow list
		}
	);

	is($params->{allowed}, 'yes', 'Allowed parameter accepted');
	ok(!exists($params->{forbidden}), 'Forbidden parameter rejected');
	is($info->{status}, 422, 'Correct status code for rejected parameter');
};

# Test regex validation
subtest 'Regex validation' => sub {
	my $info = CGI::Info->new();

	local @ARGV = ('user_id=123', 'invalid_id=abc');

	my $params = $info->params(
		allow => {
			user_id => qr/^\d+$/,	 # Numbers only
			invalid_id => qr/^\d+$/,  # Should fail
		}
	);

	is($params->{user_id}, '123', 'Valid numeric parameter accepted');
	ok(!exists($params->{invalid_id}), 'Invalid parameter rejected');
};

# Test exact match validation
subtest 'Exact match validation' => sub {
	my $info = CGI::Info->new();

	local @ARGV = ('action=login', 'action2=register');

	my $params = $info->params(
		allow => {
			action => 'login',	# Exact match required
			action2 => 'login',   # Should fail
		}
	);

	is($params->{action}, 'login', 'Exact match validation passed');
	ok(!exists($params->{action2}), 'Non-matching parameter rejected');
};

# Test custom validation subroutines
subtest 'Custom validation subroutines' => sub {
	my $info = CGI::Info->new();

	local @ARGV = ('even=4', 'odd=3', 'negative=-5');

	my $params = $info->params(
		allow => {
			even => sub {
				my ($key, $value, $info_obj) = @_;
				return $value % 2 == 0;
			},
			odd => sub {
				my ($key, $value, $info_obj) = @_;
				return $value % 2 == 0;  # Should fail for odd numbers

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

	ok(!exists($params->{negative}), 'Custom validation failed for negative');
};

# Test Params::Validate::Strict integration
subtest 'Strict validation rules' => sub {
	test_needs 'Params::Validate::Strict';

	my @messages;
	my $info = CGI::Info->new(logger => \@messages);

	local @ARGV = ('age=25', 'invalid_age=200');

	my $params = $info->params(
		allow => {
			age => {
				type => 'integer',
				min => 0,
				max => 150
			},
			invalid_age => {
				type => 'integer',

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

	$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()');

	# Test accessing forbidden parameter
	my $warnings = '';
	local $SIG{__WARN__} = sub { $warnings .= $_[0] };

	is($info->param('forbidden'), undef, 'Forbidden parameter returns undef');
	like($warnings, qr/forbidden.*isn't in the allow list/, 'Warning generated 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(

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


# 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();
	local @ARGV = ('--tablet', 'screen=large');
	$params = $info->params();

	ok($info->{is_tablet}, 'Tablet flag sets is_tablet');
};

# Test NUL byte poisoning protection
subtest 'NUL byte poisoning protection' => sub {
	my $info = CGI::Info->new();

	# NUL bytes in parameters should be stripped

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

	delete $ENV{'REQUEST_METHOD'};
	delete $ENV{'QUERY_STRING'};
	my $info = CGI::Info->new();

	# Test with large number of parameters
	my @large_argv;
	for my $i (1..1000) {
		push @large_argv, "param$i=value$i";
	}

	local @ARGV = @large_argv;

	my $start_time = time;
	my $params = $info->params();
	my $end_time = time;

	ok($params, 'Large parameter set processed successfully');
	returns_is($params, { type => 'hashref', 'min' => 1000, 'max' => 1000 }, 'All parameters processed');

	# Should complete reasonably quickly (within 5 seconds)
	ok($end_time - $start_time < 5, 'Performance acceptable for large parameter set');

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

subtest 'Logger integration' => sub {
	my @log_messages;

	# Mock logger that captures messages
	my $mock_logger = sub {
		push @log_messages, @_;
	};

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

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

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

	# Should have debug messages about parameters
	ok(@log_messages > 0, 'Logger received messages');
};

# Test Return::Set integration
subtest 'Return::Set integration' => sub {
	local %ENV;

	delete $ENV{'GATEWAY_INTERFACE'};
	delete $ENV{'REQUEST_METHOD'};
	delete $ENV{'QUERY_STRING'};

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

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

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

	# Test that Return::Set constraints are applied
	returns_is($params, { type => 'hashref', min => 1 }, 'Returns::Set returns what we expect');

	# Test param() return type
	my $single_param = $info->param('param');
	ok(defined($single_param), 'Single parameter returns defined value');
};

t/function.t  view on Meta::CPAN 

    $ENV{REQUEST_METHOD}    = 'POST';
    $ENV{CONTENT_LENGTH}    = 999_999_999;
    my $info = CGI::Info->new(max_upload_size => 100);
    my $p = $info->params();
    ok(!defined $p, 'oversized POST returns undef');
    is($info->status(), 413, 'status 413 on large upload');
};

subtest 'params() - command-line key=value pairs (non-CGI)' => sub {
    reset_env();
    local @ARGV = ('name=Alice', 'age=30');
    my $info = CGI::Info->new();
    my $p = $info->params();
    is($p->{name}, 'Alice', 'name from ARGV');
    is($p->{age},  '30',    'age from ARGV');
};

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

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

subtest 'params() - --search-engine flag from ARGV' => sub {
    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');
};

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

subtest 'params() - caches result on second call' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'k=v';

t/integration.t  view on Meta::CPAN 

    is($info->browser_type(), 'web', 'desktop browser_type is web');
};

# ============================================================
# 10. Stateful: --mobile/--robot/--tablet/--search-engine ARGV flags
#     Each flag sets the appropriate state AND params() still works
# ============================================================

subtest 'ARGV --mobile flag: is_mobile true, params still parsed' => sub {
    reset_env();
    local @ARGV = ('--mobile', 'section=news', 'limit=10');
    my $info = CGI::Info->new();
    $info->params();

    ok($info->is_mobile(), '--mobile sets is_mobile');
    my $p = $info->params();
    is($p->{section}, 'news', 'section param parsed after --mobile');
    is($p->{limit},   '10',   'limit param parsed after --mobile');
};

subtest 'ARGV --robot flag: is_robot true, browser_type robot' => sub {
    reset_env();
    local @ARGV = ('--robot');
    my $info = CGI::Info->new();
    $info->params();

    ok($info->is_robot(),              '--robot sets is_robot');
    is($info->browser_type(), 'robot', 'browser_type robot after --robot');
};

subtest 'ARGV --tablet flag: is_tablet true, is_mobile still works' => sub {
    reset_env();
    local @ARGV = ('--tablet', 'view=grid');
    my $info = CGI::Info->new();
    my $p = $info->params();

    ok($info->is_tablet(), '--tablet sets is_tablet');
    is($p->{view}, 'grid', 'view param parsed after --tablet');
};

subtest 'ARGV --search-engine flag: is_search_engine true' => sub {
    reset_env();
    local @ARGV = ('--search-engine');
    my $info = CGI::Info->new();
    $info->params();

    ok($info->is_search_engine(), '--search-engine sets is_search_engine');
    is($info->browser_type(), 'search', 'browser_type search after flag');
};

# ============================================================
# 11. Site details: host_name, domain_name, cgi_host_url, protocol consistent
# ============================================================

t/unit.t  view on Meta::CPAN 

	$ENV{CONTENT_TYPE}	  = 'text/xml';
	$ENV{CONTENT_LENGTH}	= length($xml);
	$CGI::Info::stdin_data  = $xml;
	my $p = CGI::Info->new()->params();
	ok(defined $p,		 'XML POST returns a hashref');
	is($p->{XML}, $xml,	'XML body stored under the XML key');
};

subtest 'params() - command-line ARGV pairs parsed (non-CGI)' => sub {
	reset_env();
	local @ARGV = ('city=London', 'country=UK');
	my $p = CGI::Info->new()->params();
	is($p->{city},	'London', 'city from ARGV');
	is($p->{country}, 'UK',	 'country from ARGV');
};

subtest 'params() - second call returns same cached hashref' => sub {
	reset_env();
	$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
	$ENV{REQUEST_METHOD}	= 'GET';
	$ENV{QUERY_STRING}	  = 'k=v';

t/waf.t  view on Meta::CPAN 

		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,
		{ param1 => 'value1', param2 => 'value2' },
		'Command line parameters parsed correctly'
	);
	ok($info->is_mobile, 'Mobile flag set from command line');
};



( run in 0.650 second using v1.01-cache-2.11-cpan-5735350b133 )