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