CGI-Info
view release on metacpan or search on metacpan
t/edge_cases.t view on Meta::CPAN
# %C3%A9 = UTF-8 for é
$ENV{QUERY_STRING} = 'name=caf%C3%A9';
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on UTF-8 encoded unicode in value');
};
subtest 'URL encoding: plus signs as spaces' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'msg=hello+world&empty=+';
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on plus-encoded spaces');
if(defined $p && defined $p->{msg}) {
is($p->{msg}, 'hello world', 'plus decoded to space');
}
};
# ============================================================
# 3. WAF: boundary and near-miss attack patterns
# ============================================================
subtest 'WAF: SQL keyword in value without injection pattern (should pass)' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
# "SELECT" alone in a value is not a SQL injection
$ENV{QUERY_STRING} = 'action=SELECT_item';
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on SQL keyword in non-attack context');
ok($info->status() != 403, 'status not 403 for benign SQL-like value');
};
subtest 'WAF: Unicode look-alike SQL injection characters' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
# Unicode fullwidth apostrophe U+FF07, not ASCII single-quote
$ENV{QUERY_STRING} = encode('UTF-8', "name=O\x{FF07}Brien");
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on Unicode look-alike apostrophe');
};
subtest 'WAF: deeply nested HTML not treated as XSS (no angle brackets)' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'desc=bold+and+italic+text';
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on HTML-like words without brackets');
ok($info->status() != 403, 'not blocked as XSS without angle brackets');
};
subtest 'WAF: FBCLID with double-dash (mentioned in source comment)' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'fbclid=AQHk--sometoken123';
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on FBCLID with double-dash');
# Facebook FBCLID with "--" should not be blocked per source comment
ok($info->status() != 403, 'FBCLID with -- not blocked as SQL injection');
};
subtest 'WAF: multiline value (CR/LF injection)' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'hdr=value%0D%0AX-Injected%3A+evil';
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on CRLF injection attempt');
if(defined $p && defined $p->{hdr}) {
unlike($p->{hdr}, qr/[\r\n]/, 'CR/LF stripped from injected header');
}
};
subtest 'WAF: SQL injection via User-Agent header' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'x=1';
$ENV{HTTP_USER_AGENT} = 'Mozilla/5.0 SELECT foo AND bar FROM users';
$ENV{REMOTE_ADDR} = '1.2.3.4';
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on SQL injection in User-Agent');
is($info->status(), 403, 'status 403 on SQL injection in User-Agent');
};
subtest 'WAF: maximum length SQL injection attempt' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
# Long SQL injection padded with junk
my $payload = "id=" . ('A' x 1000) . "'%20OR%201=1--";
$ENV{QUERY_STRING} = $payload;
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on long SQL injection attempt');
is($info->status(), 403, 'long SQL injection blocked with 403');
};
# ============================================================
# 4. Pathological HTTP environment variables
# ============================================================
subtest 'env: HTTP_HOST with port number' => sub {
reset_env();
$ENV{HTTP_HOST} = 'example.com:8080';
my $info = CGI::Info->new();
my $host = eval { $info->host_name() };
ok(!$@, 'does not die on HTTP_HOST with port');
ok(defined $host && length $host, 'host_name() returns something');
};
subtest 'env: HTTP_HOST with multiple trailing dots' => sub {
reset_env();
$ENV{HTTP_HOST} = 'example.com...';
my $info = CGI::Info->new();
my $host = eval { $info->host_name() };
ok(!$@, 'does not die on multiple trailing dots');
# NOTE: this test documents a known limitation — the strip regex in
# _find_site_details uses s/(.*)\.+$/$1/ where .* greedily captures
# the trailing dots when URI::Heuristic has prefixed http://, so
# only single trailing dots are reliably stripped.
# We just verify it does not crash and returns something defined.
ok(defined $host && length $host, 'returns a defined non-empty value');
};
subtest 'env: CONTENT_LENGTH of zero for POST' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'POST';
$ENV{CONTENT_LENGTH} = 0;
$ENV{CONTENT_TYPE} = 'application/x-www-form-urlencoded';
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on zero CONTENT_LENGTH POST');
};
subtest 'env: CONTENT_LENGTH non-numeric string' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'POST';
$ENV{CONTENT_LENGTH} = 'evil; rm -rf /';
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on non-numeric CONTENT_LENGTH');
is($info->status(), 411, 'non-numeric CONTENT_LENGTH treated as missing');
};
subtest 'env: negative CONTENT_LENGTH' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'POST';
$ENV{CONTENT_LENGTH} = -1;
my $info = CGI::Info->new();
t/edge_cases.t view on Meta::CPAN
ok(!$@, 'does not die on whitespace-only User-Agent');
};
subtest 'env: empty string User-Agent' => sub {
reset_env();
$ENV{HTTP_USER_AGENT} = '';
$ENV{REMOTE_ADDR} = '1.2.3.4';
my $info = CGI::Info->new();
eval { $info->is_mobile() };
ok(!$@, 'does not die on empty User-Agent');
};
subtest 'env: HTTP_COOKIE with malformed pairs (safe cases)' => sub {
reset_env();
# Avoid '==' which triggers a known CGI::Info bug (odd-element hash from
# split producing 3 elements for '=='). Test other malformations.
$ENV{HTTP_COOKIE} = '=noname; noval=; a=b=c; ;';
my $info = CGI::Info->new();
eval { $info->cookie('a') };
ok(!$@, 'does not die on malformed cookie string (no == case)');
};
subtest 'env: HTTP_COOKIE with == pair (known CGI::Info bug - documents behaviour)' => sub {
reset_env();
# '==' in a cookie string causes split(/=/, '==', 2) to return ('', '')
# but map { split(/=/, $_, 2) } across all pairs yields an odd-element list
# when a bare '==' entry is present, triggering "Odd number of elements"
# This test documents the behaviour — it may warn but must not die fatally.
$ENV{HTTP_COOKIE} = 'good=val; ==; other=x';
my $info = CGI::Info->new();
local $SIG{__WARN__} = sub { }; # suppress the "Odd number" warning
eval { $info->cookie('good') };
ok(!$@, 'cookie() with == in jar does not die (warns only)');
};
subtest 'env: HTTP_COOKIE with very long value' => sub {
reset_env();
$ENV{HTTP_COOKIE} = 'session=' . ('S' x 4096);
my $info = CGI::Info->new();
my $val = eval { $info->cookie('session') };
ok(!$@, 'does not die on very long cookie value');
ok(defined $val && length($val) == 4096, 'long cookie value preserved');
};
# ============================================================
# 5. Boundary values for numeric checks
# ============================================================
subtest 'boundary: max_upload_size = 0 blocks everything' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'POST';
$ENV{CONTENT_LENGTH} = 1;
my $info = CGI::Info->new(max_upload_size => 0);
my $p = eval { $info->params() };
ok(!$@, 'does not die with max_upload_size=0');
is($info->status(), 413, 'any POST body blocked when max_upload_size=0');
};
subtest 'boundary: max_upload_size = -1 means no limit' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'POST';
$ENV{CONTENT_LENGTH} = 999_999_999;
$ENV{CONTENT_TYPE} = 'application/x-www-form-urlencoded';
$CGI::Info::stdin_data = 'x=1';
my $info = CGI::Info->new(max_upload_size => -1);
my $p = eval { $info->params() };
ok(!$@, 'does not die with max_upload_size=-1');
isnt($info->status(), 413, 'max_upload_size=-1 does not block large POST');
};
subtest 'boundary: CONTENT_LENGTH exactly equals max_upload_size (edge, not over)' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'POST';
$ENV{CONTENT_TYPE} = 'application/x-www-form-urlencoded';
my $body = 'x=1';
$ENV{CONTENT_LENGTH} = length($body);
$CGI::Info::stdin_data = $body;
my $info = CGI::Info->new(max_upload_size => length($body));
my $p = eval { $info->params() };
ok(!$@, 'does not die when CONTENT_LENGTH == max_upload_size');
isnt($info->status(), 413,
'CONTENT_LENGTH == max_upload_size not rejected as oversized');
};
subtest 'boundary: CONTENT_LENGTH one byte over max_upload_size' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'POST';
$ENV{CONTENT_LENGTH} = 101;
my $info = CGI::Info->new(max_upload_size => 100);
my $p = eval { $info->params() };
ok(!$@, 'does not die when CONTENT_LENGTH one over max');
is($info->status(), 413, 'one byte over max_upload_size gives 413');
};
# ============================================================
# 6. allow list edge cases
# ============================================================
subtest 'allow: empty hashref blocks all params' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'foo=1&bar=2';
my $info = CGI::Info->new();
my $p = eval { $info->params(allow => {}) };
ok(!$@, 'does not die with empty allow hashref');
ok(!defined($p), 'empty allow blocks all params, returns undef');
};
t/edge_cases.t view on Meta::CPAN
subtest 'is_ai: IS_AI="false" truthy string override forces true' => sub {
reset_env();
local $ENV{IS_AI} = 'false';
$ENV{HTTP_USER_AGENT} = 'Mozilla/5.0 Chrome/120.0';
$ENV{REMOTE_ADDR} = '1.2.3.4';
my $info = CGI::Info->new();
ok($info->is_ai(), 'IS_AI="false" is truthy as a string; forces is_ai true (not false)');
};
# When REMOTE_ADDR is absent, is_ai() returns 0 WITHOUT populating the
# instance cache ($self->{is_ai} stays undef). A subsequent call on the same
# instance after REMOTE_ADDR appears must re-evaluate — not return the stale 0.
subtest 'is_ai: result not cached when REMOTE_ADDR absent on first call' => sub {
reset_env();
$ENV{HTTP_USER_AGENT} = 'ClaudeBot/1.0 (+http://www.anthropic.com)';
# Deliberately omit REMOTE_ADDR
my $info = CGI::Info->new();
ok(!$info->is_ai(), 'first call with no REMOTE_ADDR returns false');
# Now the environment gains a REMOTE_ADDR (e.g. a late-set header)
$ENV{REMOTE_ADDR} = '1.2.3.4';
ok($info->is_ai(), 'second call re-evaluates and correctly detects AI crawler');
};
# Once $self->{is_ai} IS cached (positive detection), a subsequent change to
# IS_AI in the environment must not affect the cached instance result.
subtest 'is_ai: cached positive result survives IS_AI env change' => sub {
reset_env();
$ENV{HTTP_USER_AGENT} = 'ClaudeBot/1.0 (+http://www.anthropic.com)';
$ENV{REMOTE_ADDR} = '1.2.3.4';
my $info = CGI::Info->new();
ok($info->is_ai(), 'baseline: ClaudeBot detected as AI');
# Clobber IS_AI with "off" signal; instance already cached the answer
local $ENV{IS_AI} = 0;
ok($info->is_ai(), 'cached is_ai=1 unaffected by subsequent IS_AI=0 env change');
};
# is_robot() must still honour the invariant even when is_ai returns
# true via the IS_AI env override (not UA matching).
subtest 'is_ai: IS_AI=1 override propagates to is_robot via is_robot internals' => sub {
reset_env();
local $ENV{IS_AI} = 1;
$ENV{HTTP_USER_AGENT} = 'Mozilla/5.0 Firefox/120.0'; # non-AI UA
$ENV{REMOTE_ADDR} = '1.2.3.4';
my $info = CGI::Info->new();
ok($info->is_ai(), 'IS_AI=1 override: is_ai true for non-AI UA');
ok($info->is_robot(), 'IS_AI=1 override: is_robot true via is_ai delegation inside is_robot');
};
# ============================================================
# 19. WAF: additional attack patterns verified
# ============================================================
# The path-traversal guard checks the sanitised $value for `../`.
# Every legitimate URL path would use encoded %2E%2E%2F or absolute refs.
subtest 'WAF: ../ path traversal in GET value blocked (403)' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'file=../../etc/passwd';
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on path traversal attempt');
is($info->status(), 403, 'path traversal (../) in GET value blocked with 403');
};
# The mustleak.com guard is a hard-coded canary domain used in SSRF probes.
subtest 'WAF: mustleak.com/ in GET value blocked (403)' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'url=http://mustleak.com/probe.js';
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on mustleak.com probe URL');
is($info->status(), 403, 'mustleak.com/ in value blocked with 403');
};
# XSS angle-bracket injection: checked on both $value (post-sanitise) and
# $orig_value (pre-sanitise) so HTML-encoding evasion is also caught.
subtest 'WAF: XSS <script> tag in GET value blocked (403)' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'search=<script>alert(1)</script>';
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on XSS script injection');
is($info->status(), 403, 'XSS <script> tag blocked with 403');
};
# Encoded XSS: %3Cscript%3E should also be caught (orig_value is checked).
subtest 'WAF: URL-encoded XSS %3Cscript%3E in GET value blocked (403)' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'q=%3Cscript%3Ealert%281%29%3C%2Fscript%3E';
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on URL-encoded XSS');
is($info->status(), 403, 'URL-encoded XSS blocked with 403');
};
# SQL injection via exec(xp_cmdshell) pattern — a classic MSSQL shell-escape.
# The WAF checks for exec followed by sp/xp stored procedure prefixes.
subtest 'WAF: exec xp_cmdshell stored-procedure injection blocked (403)' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
# + is decoded to space: value becomes "exec xp_cmdshell"
$ENV{QUERY_STRING} = 'cmd=exec+xp_cmdshell';
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on exec xp_cmdshell injection');
is($info->status(), 403, 'exec xp_cmdshell blocked with 403');
};
# SQL injection via exec(sp_executesql) — same pattern with sp_ prefix.
subtest 'WAF: exec sp_executesql stored-procedure injection blocked (403)' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'cmd=exec+sp_executesql';
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on exec sp_executesql injection');
is($info->status(), 403, 'exec sp_executesql blocked with 403');
};
# Tautology injection AND 1=1: a minimal always-true condition.
subtest 'WAF: AND 1=1 tautology injection blocked (403)' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
# + decoded to space: "5 AND 1=1"
$ENV{QUERY_STRING} = 'id=5+AND+1%3D1';
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on AND 1=1 injection');
is($info->status(), 403, 'AND 1=1 tautology injection blocked with 403');
};
# The WAF now inspects both GET and POST. The previous GET-only gate
# was a security gap; it has been removed. This test verifies that
# known-hostile payloads in POST bodies are also blocked with 403.
subtest 'WAF: SQL injection in POST body IS blocked (WAF now covers POST)' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'POST';
$ENV{CONTENT_TYPE} = 'application/x-www-form-urlencoded';
my $body = "id=1'+OR+1%3D1--";
$ENV{CONTENT_LENGTH} = length($body);
$CGI::Info::stdin_data = $body;
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on SQL injection in POST body');
is($info->status(), 403,
'POST body SQL injection is now blocked with 403');
};
# ============================================================
# 20. HTTP method boundary: OPTIONS and DELETE
# ============================================================
subtest 'HTTP OPTIONS returns 405 Method Not Allowed' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'OPTIONS';
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on OPTIONS');
is($info->status(), 405, 'OPTIONS method returns 405');
ok(!defined $p, 'OPTIONS params() returns undef');
};
subtest 'HTTP DELETE returns 405 Method Not Allowed' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'DELETE';
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on DELETE');
is($info->status(), 405, 'DELETE method returns 405');
ok(!defined $p, 'DELETE params() returns undef');
};
# ============================================================
# 21. ARGV mode: --robot / --mobile / --search-engine / --tablet
# These flags are consumed when params() is called without GATEWAY_INTERFACE.
# ============================================================
subtest 'ARGV: --robot flag sets is_robot and consumes the flag' => sub {
reset_env(); # ensures no GATEWAY_INTERFACE
@ARGV = ('--robot', 'action=view', 'id=42');
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die with --robot in ARGV');
ok($info->is_robot(), '--robot ARGV flag sets is_robot true');
# Remaining ARGV entries are parsed as CGI params
ok(defined $p && defined $p->{action}, '--robot: remaining ARGV pairs parsed as params');
};
subtest 'ARGV: --mobile flag sets is_mobile' => sub {
reset_env();
@ARGV = ('--mobile', 'page=home');
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die with --mobile in ARGV');
ok($info->is_mobile(), '--mobile ARGV flag sets is_mobile true');
};
subtest 'ARGV: --search-engine flag sets is_search_engine' => sub {
reset_env();
@ARGV = ('--search-engine', 'q=test');
t/edge_cases.t view on Meta::CPAN
: '/etc/hostname';
my $info = CGI::Info->new();
my $p = eval { $info->params(upload_dir => $file_path) };
ok(!$@, 'does not die on upload_dir pointing to a file');
is($info->status(), 500, 'upload_dir pointing to a file rejected with 500');
};
# ============================================================
# 24. Global variable integrity: $_ and $@ must not be clobbered
# ============================================================
# Perl's $_ is a commonly overused global. The module must not destroy it.
subtest 'global integrity: $_ not clobbered by params()' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'a=1&b=2&c=3';
local $_ = 'sentinel_value';
my $info = CGI::Info->new();
$info->params();
is($_, 'sentinel_value', 'params() did not clobber $_');
};
# $_ must also survive is_mobile() and is_robot() calls that use regex.
subtest 'global integrity: $_ not clobbered by UA-detection methods' => 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';
local $_ = 'still_sentinel';
my $info = CGI::Info->new();
$info->is_mobile();
$info->is_robot();
$info->is_ai();
$info->browser_type();
is($_, 'still_sentinel', '$_ intact after is_mobile/is_robot/is_ai/browser_type');
};
# params() internally uses eval for require calls. A successful eval clears
# $@; we verify that params() does not die when the caller has a non-empty $@.
subtest 'global integrity: params() works when caller has dirty $@' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'x=1';
eval { die "prior caller error\n" }; # set $@
my $pre_err = $@;
ok(length($pre_err), 'precondition: $@ is set before calling params()');
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'params() does not die when called with a dirty $@');
};
# ============================================================
# 25. Referrer-based robot detection: hostile referrer values
# ============================================================
# Spam referrers with a closing parenthesis are blocked.
# The WAF checks for ')' in the referrer string.
subtest 'is_robot: referrer with closing parenthesis blocked as spam' => sub {
reset_env();
$ENV{HTTP_USER_AGENT} = 'Mozilla/5.0 Firefox/120.0';
$ENV{REMOTE_ADDR} = '1.2.3.4';
$ENV{HTTP_REFERER} = 'http://spam-site.example.com/page(with-paren)';
my $info = CGI::Info->new();
ok($info->is_robot(), 'referrer with ) detected as robot/spam');
};
# A referrer that backslash-abuses the URL must be normalised before
# matching — the is_robot() code replaces \ with _ before comparing.
subtest 'is_robot: backslash in referrer normalised before blacklist match' => sub {
reset_env();
$ENV{HTTP_USER_AGENT} = 'Mozilla/5.0 Firefox/120.0';
$ENV{REMOTE_ADDR} = '1.2.3.4';
# Backslash variant of a known spam referrer — should be normalised to _ not crash
$ENV{HTTP_REFERER} = 'http://semalt.com\\hack';
my $info = new_ok('CGI::Info');
eval { $info->is_robot() };
ok(!$@, 'backslash in referrer does not cause is_robot() to die');
};
# A known spam referrer from the embedded blocklist must be flagged.
subtest 'is_robot: known spam referrer (semalt.com) blocked' => sub {
reset_env();
$ENV{HTTP_USER_AGENT} = 'Mozilla/5.0 Firefox/120.0';
$ENV{REMOTE_ADDR} = '1.2.3.4';
$ENV{HTTP_REFERER} = 'http://semalt.com/fake-traffic';
my $info = CGI::Info->new();
ok($info->is_robot(), 'semalt.com in HTTP_REFERER flagged as robot');
};
# ============================================================
# 26. Sec-CH-UA-Mobile header boundary cases
# ============================================================
# '?1' means mobile; anything else (including '?0', '1', '') must not.
subtest 'Sec-CH-UA-Mobile: ?1 triggers is_mobile' => sub {
reset_env();
$ENV{HTTP_SEC_CH_UA_MOBILE} = '?1';
my $info = CGI::Info->new();
ok($info->is_mobile(), 'Sec-CH-UA-Mobile: ?1 sets is_mobile true');
};
subtest 'Sec-CH-UA-Mobile: ?0 does not trigger is_mobile' => sub {
reset_env();
$ENV{HTTP_SEC_CH_UA_MOBILE} = '?0';
my $info = CGI::Info->new();
ok(!$info->is_mobile(), 'Sec-CH-UA-Mobile: ?0 does not set is_mobile');
};
subtest 'Sec-CH-UA-Mobile: bare 1 (no ?) does not trigger is_mobile' => sub {
reset_env();
$ENV{HTTP_SEC_CH_UA_MOBILE} = '1';
my $info = CGI::Info->new();
ok(!$info->is_mobile(), 'Sec-CH-UA-Mobile: bare "1" is not the spec value ?1');
};
subtest 'Sec-CH-UA-Mobile: empty string does not trigger is_mobile' => sub {
reset_env();
$ENV{HTTP_SEC_CH_UA_MOBILE} = '';
my $info = CGI::Info->new();
ok(!$info->is_mobile(), 'Sec-CH-UA-Mobile: empty string does not trigger mobile');
};
done_testing();
( run in 0.807 second using v1.01-cache-2.11-cpan-c221a9de4ec )