view release on metacpan or  search on metacpan

t/unit.t  view on Meta::CPAN

	my $info = CGI::Info->new();
	is($info->as_string(), '', 'as_string() with no params returns empty string');
};

subtest 'as_string() - input: raw is boolean, optional' => sub {
	reset_env();
	$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
	$ENV{REQUEST_METHOD}	= 'GET';
	$ENV{QUERY_STRING}	  = 'z=9';
	my $info = CGI::Info->new();
	$info->params();
	# raw => 0 should not croak
	my $str = eval { $info->as_string({ raw => 0 }) };
	ok(!$@, 'as_string(raw => 0) does not croak');
	ok(defined $str, 'as_string(raw => 0) returns a value');
};

# ============================================================
# protocol()
# POD: returns 'http' or 'https', or undef if undetermined
# ============================================================

subtest 'protocol() - returns http from SERVER_PROTOCOL' => sub {
	reset_env();
	$ENV{SERVER_PROTOCOL} = 'HTTP/1.1';
	is(CGI::Info->new()->protocol(), 'http', 'protocol() returns http');
};

subtest 'protocol() - returns https from SCRIPT_URI' => sub {
	reset_env();
	$ENV{SCRIPT_URI} = 'https://example.com/cgi-bin/foo.cgi';
	is(CGI::Info->new()->protocol(), 'https', 'protocol() returns https from SCRIPT_URI');
};

subtest 'protocol() - returns undef when undetermined' => sub {
	reset_env();
	ok(!defined CGI::Info->new()->protocol(),
		'protocol() returns undef when no env set');
};

# ============================================================
# is_mobile()
# POD: returns boolean; true for smartphones and tablets;
#	  can be overridden by IS_MOBILE environment variable
# ============================================================

subtest 'is_mobile() - true for iPhone user agent' => 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';
	ok(CGI::Info->new()->is_mobile(), 'iPhone UA is mobile');
};

subtest 'is_mobile() - true for Android user agent' => sub {
	reset_env();
	$ENV{HTTP_USER_AGENT} = 'Mozilla/5.0 (Linux; Android 11; Pixel 5)';
	$ENV{REMOTE_ADDR}	 = '1.2.3.4';
	ok(CGI::Info->new()->is_mobile(), 'Android UA is mobile');
};

subtest 'is_mobile() - false for desktop user agent' => sub {
	reset_env();
	$ENV{HTTP_USER_AGENT} = 'Mozilla/5.0 (Windows NT 10.0; Win64; x64) Chrome/120';
	$ENV{REMOTE_ADDR}	 = '1.2.3.4';
	ok(!CGI::Info->new()->is_mobile(), 'desktop UA is not mobile');
};

subtest 'is_mobile() - overridden by IS_MOBILE=1' => sub {
	reset_env();
	$ENV{IS_MOBILE}	   = 1;
	$ENV{HTTP_USER_AGENT} = 'Mozilla/5.0 (Windows NT 10.0)';
	ok(CGI::Info->new()->is_mobile(), 'IS_MOBILE=1 overrides UA detection');
};

subtest 'is_mobile() - true via Sec-CH-UA-Mobile hint' => sub {
	reset_env();
	$ENV{HTTP_SEC_CH_UA_MOBILE} = '?1';
	ok(CGI::Info->new()->is_mobile(), 'Sec-CH-UA-Mobile: ?1 is mobile');
};

subtest 'is_mobile() - true via HTTP_X_WAP_PROFILE' => sub {
	reset_env();
	$ENV{HTTP_X_WAP_PROFILE} = 'http://wap.example.com/uaprof.xml';
	ok(CGI::Info->new()->is_mobile(), 'WAP profile header indicates mobile');
};

subtest 'is_mobile() - all tablets are mobile' => sub {
	reset_env();
	$ENV{HTTP_USER_AGENT} = 'Mozilla/5.0 (iPad; CPU OS 15_0 like Mac OS X)';
	$ENV{REMOTE_ADDR}	 = '1.2.3.4';
	ok(CGI::Info->new()->is_mobile(), 'tablet (iPad) counts as mobile');
};

# ============================================================
# is_tablet()
# POD: returns boolean; true for tablets such as iPad
# ============================================================

subtest 'is_tablet() - true for iPad user agent' => sub {
	reset_env();
	$ENV{HTTP_USER_AGENT} = 'Mozilla/5.0 (iPad; CPU OS 15_0 like Mac OS X)';
	ok(CGI::Info->new()->is_tablet(), 'iPad UA is tablet');
};

subtest 'is_tablet() - false for iPhone user agent' => sub {
	reset_env();
	$ENV{HTTP_USER_AGENT} = 'Mozilla/5.0 (iPhone; CPU iPhone OS 15_0 like Mac OS X)';
	ok(!CGI::Info->new()->is_tablet(), 'iPhone UA is not a tablet');
};

subtest 'is_tablet() - false for desktop user agent' => sub {
	reset_env();
	$ENV{HTTP_USER_AGENT} = 'Mozilla/5.0 (Windows NT 10.0; Win64; x64)';
	ok(!CGI::Info->new()->is_tablet(), 'desktop UA is not a tablet');
};

# ============================================================
# is_robot()
# POD: returns boolean; true for robots/crawlers;
#	  SQL injection in UA sets status 403 and returns true
# ============================================================

subtest 'is_robot() - false when no CGI environment' => sub {
	reset_env();
	is(CGI::Info->new()->is_robot(), 0,
		'is_robot() returns 0 outside CGI environment');
};

subtest 'is_robot() - true for known bot UA' => sub {
	reset_env();
	$ENV{HTTP_USER_AGENT} = 'ClaudeBot/1.0 (+http://www.anthropic.com)';
	$ENV{REMOTE_ADDR}	 = '1.2.3.4';
	ok(CGI::Info->new()->is_robot(), 'ClaudeBot detected as robot');
};

subtest 'is_robot() - SQL injection in UA returns true + status 403' => sub {
	reset_env();
	$ENV{HTTP_USER_AGENT} = 'Mozilla SELECT foo AND bar FROM baz';
	$ENV{REMOTE_ADDR}	 = '1.2.3.4';
	my $info = CGI::Info->new();
	ok($info->is_robot(), 'SQL injection UA flagged as robot');
	is($info->status(), 403, 'status 403 set on SQL injection UA');
};

# ============================================================
# is_search_engine()
# POD: returns boolean;
#	  can be overridden by IS_SEARCH_ENGINE environment variable
# ============================================================

subtest 'is_search_engine() - false when no CGI environment' => sub {
	reset_env();
	is(CGI::Info->new()->is_search_engine(), 0,
		'is_search_engine() returns 0 outside CGI environment');
};

subtest 'is_search_engine() - overridden by IS_SEARCH_ENGINE=1' => sub {
	reset_env();
	$ENV{IS_SEARCH_ENGINE} = 1;
	$ENV{REMOTE_ADDR}	  = '1.2.3.4';
	$ENV{HTTP_USER_AGENT}  = 'SomeBot/1.0';
	ok(CGI::Info->new()->is_search_engine(),
		'IS_SEARCH_ENGINE=1 override works');
};

# ============================================================
# browser_type()
# POD: returns one of 'web', 'search', 'robot', 'mobile'
# ============================================================

subtest 'browser_type() - returns mobile for smartphone UA' => 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';
	is(CGI::Info->new()->browser_type(), 'mobile', 'smartphone => mobile');
};

subtest 'browser_type() - returns web for desktop browser' => sub {
	reset_env();
	$ENV{HTTP_USER_AGENT} = 'Mozilla/5.0 (Windows NT 10.0; Win64; x64) Chrome/120';
	$ENV{REMOTE_ADDR}	 = '1.2.3.4';
	is(CGI::Info->new()->browser_type(), 'web', 'desktop => web');
};

subtest 'browser_type() - returns robot for known bot' => sub {
	reset_env();
	$ENV{HTTP_USER_AGENT} = 'ClaudeBot/1.0';
	$ENV{REMOTE_ADDR}	 = '1.2.3.4';
	is(CGI::Info->new()->browser_type(), 'robot', 'bot => robot');
};

subtest 'browser_type() - return value is one of the four valid strings' => sub {
	reset_env();
	$ENV{HTTP_USER_AGENT} = 'Mozilla/5.0 (Windows NT 10.0)';
	$ENV{REMOTE_ADDR}	 = '1.2.3.4';
	my $type = CGI::Info->new()->browser_type();
	ok((grep { $type eq $_ } qw(web search robot mobile)),
		"browser_type() returns one of the four valid values (got '$type')");
};

# ============================================================
# cookie() / get_cookie()
# POD: returns cookie value or undef;
#	  API: cookie_name must be a non-empty string matching RFC6265 token chars;
#		   output is undef or a string matching RFC6265 cookie-value chars
# ============================================================

subtest 'cookie() - returns value for existing cookie' => sub {
	reset_env();
	$ENV{HTTP_COOKIE} = 'session=abc123; user=bob';
	my $info = CGI::Info->new();
	is($info->cookie('session'), 'abc123', 'cookie() returns session value');
	is($info->cookie('user'),	'bob',	'cookie() returns user value');
};

subtest 'cookie() - returns undef for absent cookie' => sub {
	reset_env();
	$ENV{HTTP_COOKIE} = 'a=1';
	ok(!defined CGI::Info->new()->cookie('nosuch'),
		'cookie() returns undef for absent cookie');
};

subtest 'cookie() - returns undef when no HTTP_COOKIE set' => sub {
	reset_env();
	ok(!defined CGI::Info->new()->cookie('anything'),
		'cookie() returns undef with no HTTP_COOKIE env');
};

subtest 'cookie() - positional string argument accepted' => sub {
	reset_env();
	$ENV{HTTP_COOKIE} = 'token=xyz';
	is(CGI::Info->new()->cookie('token'), 'xyz',
		'cookie() accepts bare string argument');
};

subtest 'get_cookie() - deprecated alias behaves identically to cookie()' => sub {
	reset_env();
	$ENV{HTTP_COOKIE} = 'sid=12345';
	my $info = CGI::Info->new();
	is($info->get_cookie(cookie_name => 'sid'),
	   $info->cookie('sid'),
	   'get_cookie() returns same value as cookie()');