desktop results from the CPAN

CGI-Info

view release on metacpan or search on metacpan

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

# ============================================================
# is_ai()
# POD: returns boolean; true when visitor is a known AI training or
#      inference crawler; is_robot() is also true when is_ai() is true
#      (documented invariant); overridden by the IS_AI env variable.
# ============================================================

# Readonly constants used throughout the is_ai() tests.
Readonly my $AI_REMOTE => '1.2.3.4';

t/unit.t view on Meta::CPAN


# Exhaustive API ledger: every documented return state, invariant, and
# override.  Each key is deleted when a subtest exercises that state.
# The empty-ledger assertion at the end of this section catches any
# POD-documented behaviour that was accidentally left untested.
my %is_ai_ledger = (
	'returns 0 outside CGI environment'        => 1,
	'returns 1 for AI crawler UA'              => 1,
	'returns 0 for non-AI UA'                  => 1,
	'returns 0 when REMOTE_ADDR absent'        => 1,
	'IS_AI=1 env override forces true'         => 1,
	'IS_AI=0 env override forces false'        => 1,
	'is_robot() true when is_ai() true'        => 1,
	'invariant holds with is_robot() first'    => 1,
	'browser_type returns ai when is_ai true'  => 1,
);

# No CGI environment at all: both REMOTE_ADDR and HTTP_USER_AGENT absent.
subtest 'is_ai() - false when no CGI environment' => sub {
	reset_env();
	is(CGI::Info->new()->is_ai(), 0,
		'is_ai() returns 0 outside CGI environment');
	delete $is_ai_ledger{'returns 0 outside CGI environment'};
};

# ClaudeBot is a canonical Anthropic training crawler.
subtest 'is_ai() - true for ClaudeBot UA' => sub {
	reset_env();
	$ENV{HTTP_USER_AGENT} = $UA_CLAUDE_BOT;
	$ENV{REMOTE_ADDR}	 = $AI_REMOTE;
	ok(CGI::Info->new()->is_ai(), 'ClaudeBot UA => is_ai true');
	delete $is_ai_ledger{'returns 1 for AI crawler UA'};
};

# GPTBot (OpenAI training crawler) confirms coverage beyond ClaudeBot.
subtest 'is_ai() - true for GPTBot UA' => sub {
	reset_env();
	$ENV{HTTP_USER_AGENT} = $UA_GPTBOT;
	$ENV{REMOTE_ADDR}	 = $AI_REMOTE;
	ok(CGI::Info->new()->is_ai(), 'GPTBot UA => is_ai true');
};

# ChatGPT-User contains no "bot" or "spider" token; this exercises the
# regex branches for unusual UA formats and also proves is_robot() is
# reached via the is_ai() delegation path in is_robot().
subtest 'is_ai() - true for ChatGPT-User (no bot/spider token in UA)' => sub {
	reset_env();
	$ENV{HTTP_USER_AGENT} = $UA_CHATGPT;
	$ENV{REMOTE_ADDR}	 = $AI_REMOTE;
	ok(CGI::Info->new()->is_ai(), 'ChatGPT-User UA => is_ai true');
};

# cohere-ai is another non-standard UA with no "bot" or "spider" component.
subtest 'is_ai() - true for cohere-ai UA' => sub {
	reset_env();
	$ENV{HTTP_USER_AGENT} = $UA_COHERE;
	$ENV{REMOTE_ADDR}	 = $AI_REMOTE;
	ok(CGI::Info->new()->is_ai(), 'cohere-ai UA => is_ai true');
};

# An ordinary desktop browser must not trigger is_ai().
subtest 'is_ai() - false for desktop browser UA' => sub {
	reset_env();
	$ENV{HTTP_USER_AGENT} = $UA_DESKTOP_WIN;
	$ENV{REMOTE_ADDR}	 = $AI_REMOTE;
	ok(!CGI::Info->new()->is_ai(), 'desktop UA => is_ai false');
	delete $is_ai_ledger{'returns 0 for non-AI UA'};
};

# REMOTE_ADDR absent: the CGI environment is incomplete; method returns 0.
# This is consistent with is_robot() and is_search_engine() behaviour.
subtest 'is_ai() - false when REMOTE_ADDR absent' => sub {
	reset_env();
	$ENV{HTTP_USER_AGENT} = $UA_CLAUDE_BOT;
	# No REMOTE_ADDR
	ok(!CGI::Info->new()->is_ai(), 'absent REMOTE_ADDR => is_ai false');
	delete $is_ai_ledger{'returns 0 when REMOTE_ADDR absent'};
};

# IS_AI=1 must force true even for a non-AI UA (env override is authoritative).
# Use local so the override does not leak into subsequent tests.
subtest 'is_ai() - IS_AI=1 env override forces true' => sub {
	reset_env();
	local $ENV{IS_AI}	 = 1;
	$ENV{HTTP_USER_AGENT} = $UA_DESKTOP_WIN;
	$ENV{REMOTE_ADDR}	 = $AI_REMOTE;
	ok(CGI::Info->new()->is_ai(), 'IS_AI=1 forces true for non-AI UA');
	delete $is_ai_ledger{'IS_AI=1 env override forces true'};
};

# IS_AI=0 must force false even for a known AI crawler UA.
subtest 'is_ai() - IS_AI=0 env override forces false' => sub {
	reset_env();
	local $ENV{IS_AI}	 = 0;
	$ENV{HTTP_USER_AGENT} = $UA_CLAUDE_BOT;
	$ENV{REMOTE_ADDR}	 = $AI_REMOTE;
	ok(!CGI::Info->new()->is_ai(), 'IS_AI=0 forces false for AI UA');
	delete $is_ai_ledger{'IS_AI=0 env override forces false'};
};

# Invariant (documented in POD): is_ai() true implies is_robot() true,
# regardless of which method is called first.
subtest 'is_ai() - is_robot() also true when is_ai() is true' => sub {
	reset_env();
	$ENV{HTTP_USER_AGENT} = $UA_CLAUDE_BOT;
	$ENV{REMOTE_ADDR}	 = $AI_REMOTE;
	my $info = CGI::Info->new();
	ok($info->is_ai(),    'ClaudeBot => is_ai true');
	ok($info->is_robot(), 'ClaudeBot => is_robot also true (invariant)');
	delete $is_ai_ledger{'is_robot() true when is_ai() true'};
};

# Call-order variant: is_robot() called FIRST.  ChatGPT-User has no
# "bot"/"spider" token so is_robot()'s own regex would miss it; the
# invariant is enforced by is_robot() delegating to is_ai() internally.
subtest 'is_ai() - invariant holds when is_robot() called before is_ai()' => sub {
	reset_env();
	$ENV{HTTP_USER_AGENT} = $UA_CHATGPT;
	$ENV{REMOTE_ADDR}	 = $AI_REMOTE;
	my $info = CGI::Info->new();
	ok($info->is_robot(), 'ChatGPT-User: is_robot() true when called first');
	ok($info->is_ai(),    'ChatGPT-User: is_ai()   true after is_robot()');
	delete $is_ai_ledger{'invariant holds with is_robot() first'};
};

# browser_type() must return 'ai' for AI crawlers (POD documents this as
# the second priority after 'mobile', before 'search', 'robot', 'web').
subtest 'is_ai() - browser_type() returns ai' => sub {
	reset_env();
	$ENV{HTTP_USER_AGENT} = $UA_CLAUDE_BOT;
	$ENV{REMOTE_ADDR}	 = $AI_REMOTE;
	is(CGI::Info->new()->browser_type(), 'ai',
		'ClaudeBot => browser_type returns ai');
	delete $is_ai_ledger{'browser_type returns ai when is_ai true'};
};

# Ledger must be empty -- every documented state was exercised above.
ok(!%is_ai_ledger, 'is_ai() ledger empty: all documented states covered')
	or diag('Untested is_ai() states: ' . join(', ', sort keys %is_ai_ledger));

# ============================================================
# browser_type()
# POD: returns one of 'mobile', 'ai', 'search', 'robot', 'web'
#      in that priority order
# ============================================================

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 ai for known AI crawler' => sub {
	reset_env();
	$ENV{HTTP_USER_AGENT} = 'ClaudeBot/1.0';
	$ENV{REMOTE_ADDR}	 = '1.2.3.4';
	is(CGI::Info->new()->browser_type(), 'ai', 'bot => ai');
};

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

subtest 'browser_type() - return value is one of the five 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 ai)),
		"browser_type() returns one of the five 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');
};

( run in 0.642 second using v1.01-cache-2.11-cpan-9789f410c06 )