view release on metacpan or  search on metacpan

t/integration.t  view on Meta::CPAN

    is($params->{name}, 'Bob',    'valid name accepted');
    ok(!exists $params->{secret}, 'secret silently excluded');

    # param() also reflects the filtered set
    is($info->param('id'),   '42',  'param(id) consistent with params()');
    is($info->param('name'), 'Bob', 'param(name) consistent with params()');

    # as_string() reflects only the accepted params
    my $str = $info->as_string();
    unlike($str, qr/secret/, 'as_string() does not leak excluded param');
};

# ============================================================
# 3. Stateful: params() cached — second call with same allow returns same ref
# ============================================================

subtest 'params() cached: identical allow returns same hashref' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'x=1&y=2';

    my $info = CGI::Info->new();
    my $allow = { x => qr/\d+/, y => qr/\d+/ };

    my $p1 = $info->params(allow => $allow);
    my $p2 = $info->params(allow => $allow);
    is($p1, $p2, 'same allow => same cached hashref returned');
};

# ============================================================
# 4. Stateful: new allow invalidates cache
# ============================================================

subtest 'params() cache: new allow ref triggers re-parse' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'a=1&b=2';

    my $info = CGI::Info->new();

    my $p1 = $info->params(allow => { a => undef, b => undef });
    ok(defined $p1->{a} && defined $p1->{b}, 'both keys present with open allow');

    my $p2 = $info->params(allow => { a => undef });
    ok(defined $p2->{a},    'a still present with restricted allow');
    ok(!defined $p2->{b},   'b excluded with restricted allow');
};

# ============================================================
# 5. Stateful: clone inherits parent state, overrides work
# ============================================================

subtest 'clone: inherits parent config, override applies independently' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'q=test';

    my $orig  = CGI::Info->new(max_upload_size => 1024);
    my $clone = $orig->new(max_upload_size => 512);

    # Both are valid CGI::Info objects
    isa_ok($orig,  'CGI::Info', 'original');
    isa_ok($clone, 'CGI::Info', 'clone');

    # Both can independently parse params from the same environment
    my $p_orig  = $orig->params();
    my $p_clone = $clone->params();
    is($p_orig->{q},  'test', 'original parses q=test');
    is($p_clone->{q}, 'test', 'clone parses q=test');

    # They are distinct objects
    isnt($orig, $clone, 'clone is a different object');
};

# ============================================================
# 6. Stateful: status accumulates across method calls
# ============================================================

subtest 'status: accumulates correctly across multiple interactions' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'id=notanumber';

    my $info = CGI::Info->new();
    is($info->status(), 200, 'initial status 200');

    # Trigger a validation failure
    $info->params(allow => { id => qr/^\d+$/ });
    is($info->status(), 422, 'status 422 after validation failure');

    # Explicitly override status
    $info->status(200);
    is($info->status(), 200, 'status reset to 200 explicitly');

    # Trigger a WAF block
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'x=../../etc/passwd';
    $info = CGI::Info->new();
    $info->params();
    is($info->status(), 403, 'status 403 after WAF block');
};

# ============================================================
# 7. Stateful: messages accumulate from multiple operations
# ============================================================

subtest 'messages: accumulate across validation failures' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'a=bad&b=alsoBad';

    my $info = CGI::Info->new();
    $info->params(allow => {
        a => qr/^\d+$/,
        b => qr/^\d+$/,

t/integration.t  view on Meta::CPAN

    ok(!defined $info->params(), 'traversal returns undef');
    is($info->status(), 403, 'traversal status 403');
};

subtest 'WAF: mustleak blocked with 403' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'probe=mustleak.com/test';

    my $info = CGI::Info->new();
    ok(!defined $info->params(), 'mustleak returns undef');
    is($info->status(), 403, 'mustleak status 403');
};

subtest 'WAF: clean request after previous attack creates fresh object cleanly' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'name=Alice&id=42';

    # Fresh object after reset_env — no state bleed from prior attacks
    my $info = CGI::Info->new();
    my $p    = $info->params();
    ok(defined $p,              'clean request returns params');
    is($info->status(), 200,   'clean request status 200');
    is($p->{name}, 'Alice',    'name parsed correctly');
};

# ============================================================
# 16. POST: content-length enforcement + XML passthrough
# ============================================================

subtest 'POST XML: entire body preserved, status remains 200' => sub {
    reset_env();
    my $xml = '<request><action>search</action><term>perl</term></request>';
    $ENV{GATEWAY_INTERFACE}    = 'CGI/1.1';
    $ENV{REQUEST_METHOD}       = 'POST';
    $ENV{CONTENT_TYPE}         = 'text/xml';
    $ENV{CONTENT_LENGTH}       = length($xml);
    $CGI::Info::stdin_data     = $xml;

    my $info   = CGI::Info->new();
    my $params = $info->params();

    ok(defined $params,          'XML POST returns params hashref');
    is($params->{XML}, $xml,     'full XML body preserved under XML key');
    is($info->status(), 200,     'status 200 for valid XML POST');
};

subtest 'POST: content_length missing => 411, params undef' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'POST';

    my $info = CGI::Info->new();
    ok(!defined $info->params(), 'missing content-length returns undef');
    is($info->status(), 411,     'status 411 on missing content-length');
};

subtest 'POST: body exceeds max_upload_size => 413, params undef' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'POST';
    $ENV{CONTENT_LENGTH}    = 1_000_000;

    my $info = CGI::Info->new(max_upload_size => 1024);
    ok(!defined $info->params(), 'oversized POST returns undef');
    is($info->status(), 413,     'status 413 on oversized POST');
};

# ============================================================
# 17. Stateful: AUTOLOAD + allow interact correctly
# ============================================================

subtest 'AUTOLOAD with allow: only permitted params accessible as methods' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'username=bob&password=secret&role=admin';

    my $info = CGI::Info->new(allow => {
        username => qr/^\w+$/,
        role     => qr/^(admin|user|guest)$/,
    });
    $info->params();

    is($info->username(), 'bob',   'AUTOLOAD: username accessible');
    is($info->role(),     'admin', 'AUTOLOAD: role accessible');
    ok(!defined $info->password(), 'AUTOLOAD: password not in allow list returns undef');
};

# ============================================================
# 18. Stateful: coderef allow with contextual cross-param validation
# ============================================================

subtest 'allow coderef: cross-param validation via $info instance' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'is_adult=1&age=25';

    my $info = CGI::Info->new();
    my $p = $info->params(allow => {
        is_adult => qr/^[01]$/,
        age      => sub {
            my ($key, $value, $obj) = @_;
            # Only allow age if is_adult is set
            my $adult_flag = $obj->param('is_adult');
            return defined($adult_flag) && $adult_flag && $value >= 18;
        },
    });

    ok(defined $p,              'cross-param validation: params returned');
    is($p->{is_adult}, '1',    'is_adult accepted');
    is($p->{age},      '25',   'age accepted when is_adult=1 and age>=18');
};

subtest 'allow coderef: cross-param rejects when condition not met' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'is_adult=0&age=15';

    my $info = CGI::Info->new();
    my $p = $info->params(allow => {
        is_adult => qr/^[01]$/,