view release on metacpan or  search on metacpan

t/edge_cases.t  view on Meta::CPAN

    my $info = CGI::Info->new();
    my $p    = eval { $info->params() };
    ok(!$@, 'does not die on truncated percent sequence');
};

subtest 'URL encoding: NUL byte poison attempts' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'key%00=value&other=val%00ue';

    my $info = CGI::Info->new();
    my $p    = eval { $info->params() };
    ok(!$@, 'does not die on NUL byte poison in query string');
    # If parsed, NUL bytes must not appear in keys or values
    if(defined $p) {
        for my $k (keys %{$p}) {
            unlike($k,       qr/\x00/, "NUL stripped from key '$k'");
            unlike($p->{$k}, qr/\x00/, "NUL stripped from value of '$k'");
        }
    }
};

subtest 'URL encoding: %00 encoded NUL in key name' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'ke%00y=value';

    my $info = CGI::Info->new();
    my $p    = eval { $info->params() };
    ok(!$@, 'does not die on NUL in key');
    # key with embedded NUL should either be dropped or have NUL removed
    if(defined $p) {
        ok(!exists $p->{"ke\x00y"}, 'key with NUL byte not stored raw');
    }
};

subtest 'URL encoding: Unicode sequences via percent encoding' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    # %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';

t/edge_cases.t  view on Meta::CPAN

# 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.
# ============================================================