view release on metacpan or  search on metacpan

t/function.t  view on Meta::CPAN

    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'OPTIONS';
    my $info = CGI::Info->new();
    $info->params();
    is($info->status(), 405, 'OPTIONS yields 405');
};

subtest 'status() - DELETE sets 405 implicitly' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'DELETE';
    my $info = CGI::Info->new();
    $info->params();
    is($info->status(), 405, 'DELETE yields 405');
};

# ============================================================
# 4. params()
# ============================================================
subtest 'params() - GET simple query' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'foo=bar&baz=42';
    my $info = CGI::Info->new();
    my $p = $info->params();
    ok(defined $p, 'params() returns defined value');
    is($p->{foo}, 'bar', 'foo=bar parsed');
    is($p->{baz}, '42',  'baz=42 parsed');
};

subtest 'params() - GET no query string returns undef' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = '';
    my $info = CGI::Info->new();
    my $p = $info->params();
    ok(!defined $p, 'empty QUERY_STRING returns undef');
};

subtest 'params() - allow filters unknown keys' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'good=1&evil=2';
    my $info = CGI::Info->new();
    my $p = $info->params(allow => { good => qr/^\d+$/ });
    ok(defined $p->{good}, 'allowed key present');
    ok(!defined $p->{evil}, 'disallowed key absent');
};

subtest 'params() - allow regex mismatch blocks value' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'id=abc';
    my $info = CGI::Info->new();
    my $p = $info->params(allow => { id => qr/^\d+$/ });
    ok(!defined($p), 'regex-blocked key excluded from result');
    is($info->status(), 422, 'status 422 set on validation failure');
};

subtest 'params() - allow exact-string match' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'color=blue&color=red';
    my $info = CGI::Info->new();
    my $p = $info->params(allow => { color => 'blue' });
    # 'blue' matches, but 'red' appears as comma-separated; blue matches first
    ok(defined $p, 'exact-string allow passes matching value');
};

subtest 'params() - allow coderef validator' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'num=4&num2=3';
    my $info = CGI::Info->new();
    my $p = $info->params(allow => {
        num  => sub { ($_[1] % 2) == 0 },   # even => pass
        num2 => sub { ($_[1] % 2) == 0 },   # odd  => fail
    });
    ok(defined $p->{num},  'even number passes coderef validator');
    ok(!defined $p->{num2}, 'odd number blocked by coderef validator');
};

subtest 'params() - SQL injection blocked (GET)' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = "id=1'%20OR%201=1";
    my $info = CGI::Info->new();
    my $p = $info->params();
    ok(!defined $p, 'SQL injection blocked');
    is($info->status(), 403, 'status 403 on SQL injection');
};

subtest 'params() - XSS injection blocked (GET)' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'q=%3Cscript%3Ealert(1)%3C%2Fscript%3E';
    my $info = CGI::Info->new();
    my $p = $info->params();
    ok(!defined $p, 'XSS injection blocked');
    is($info->status(), 403, 'status 403 on XSS');
};

subtest 'params() - directory traversal blocked (GET)' => 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 = $info->params();
    ok(!defined $p, 'directory traversal blocked');
    is($info->status(), 403, 'status 403 on directory traversal');
};

subtest 'params() - mustleak attack blocked (GET)' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'x=mustleak.com/probe';
    my $info = CGI::Info->new();
    my $p = $info->params();
    ok(!defined $p, 'mustleak attack blocked');
    is($info->status(), 403, 'status 403 on mustleak');
};

subtest 'params() - duplicate values comma-joined' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'color=red&color=blue';
    my $info = CGI::Info->new();
    my $p = $info->params();
    like($p->{color}, qr/red.*blue|blue.*red/, 'duplicate values comma-joined');
};

subtest 'params() - POST missing CONTENT_LENGTH => 411' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'POST';
    # no CONTENT_LENGTH
    my $info = CGI::Info->new();
    my $p = $info->params();
    ok(!defined $p, 'POST without CONTENT_LENGTH returns undef');
    is($info->status(), 411, 'status 411');
};

subtest 'params() - POST oversized => 413' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'POST';
    $ENV{CONTENT_LENGTH}    = 999_999_999;
    my $info = CGI::Info->new(max_upload_size => 100);
    my $p = $info->params();
    ok(!defined $p, 'oversized POST returns undef');
    is($info->status(), 413, 'status 413 on large upload');
};

subtest 'params() - command-line key=value pairs (non-CGI)' => sub {
    reset_env();
    local @ARGV = ('name=Alice', 'age=30');
    my $info = CGI::Info->new();
    my $p = $info->params();
    is($p->{name}, 'Alice', 'name from ARGV');
    is($p->{age},  '30',    'age from ARGV');
};

subtest 'params() - --mobile flag from ARGV' => sub {
    reset_env();
    local @ARGV = ('--mobile', 'x=1');
    my $info = CGI::Info->new();
    $info->params();
    ok($info->is_mobile(), '--mobile flag sets is_mobile');
};

subtest 'params() - --robot flag from ARGV' => sub {
    reset_env();
    local @ARGV = ('--robot');
    my $info = CGI::Info->new();
    $info->params();
    ok($info->is_robot(), '--robot flag sets is_robot');
};

t/function.t  view on Meta::CPAN

    $ENV{REQUEST_METHOD}    = 'POST';
    $ENV{CONTENT_TYPE}      = 'application/json';
    $ENV{CONTENT_LENGTH}    = length($json_body);

    # Inject STDIN via the class variable
    $CGI::Info::stdin_data  = $json_body;

    my $info = CGI::Info->new();
    my $p    = $info->params();
    if(defined $p) {
        is($p->{alpha}, 'one', 'JSON POST: alpha=one');
        is($p->{beta},  'two', 'JSON POST: beta=two');
    } else {
        # JSON::MaybeXS may not be installed in all environments
        pass('JSON POST: no result (JSON module unavailable, acceptable)');
    }
};

# ============================================================
# 29. POST with text/xml content type
# ============================================================
subtest 'params() - POST XML stored under XML key' => sub {
    reset_env();
    my $xml_body = '<root><item>test</item></root>';
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'POST';
    $ENV{CONTENT_TYPE}      = 'text/xml';
    $ENV{CONTENT_LENGTH}    = length($xml_body);
    $CGI::Info::stdin_data  = $xml_body;

    my $info = CGI::Info->new();
    my $p    = $info->params();
    ok(defined $p, 'XML POST returns hashref');
    is($p->{XML}, $xml_body, 'XML body stored under XML key');
};

# ============================================================
# 30. Params::Validate::Strict integration via allow hash-schema
# ============================================================
subtest 'params() - Params::Validate::Strict schema passes valid value' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'age=25';
    my $info = CGI::Info->new();
    my $p = $info->params(allow => {
        age => { type => 'integer', min => 0, max => 150 }
    });
    ok(defined $p && defined $p->{age}, 'valid age passes Params::Validate::Strict');
};

subtest 'params() - Params::Validate::Strict schema blocks invalid value' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'age=999';
    my $info = CGI::Info->new();
    my $p = $info->params(allow => {
        age => { type => 'integer', min => 0, max => 150 }
    });
    # Either blocked entirely or age is absent
    my $blocked = (!defined $p) || (!defined $p->{age});
    ok($blocked, 'out-of-range age blocked by Params::Validate::Strict');
};

done_testing();