view release on metacpan or  search on metacpan

t/extended_tests.t  view on Meta::CPAN

    my $proto = $info->protocol();
    ok(!defined($proto), 'protocol() returns undef when indeterminate');
    my $msgs = $info->messages();
    ok(defined($msgs) && scalar @{$msgs} > 0,
        'undetermined protocol with REMOTE_ADDR logs a warning');
};

# ============================================================
# 8. protocol() — SERVER_PROTOCOL present but not HTTP/ prefix
#    Branch: SERVER_PROTOCOL check fails, falls through to port check
# ============================================================

subtest 'protocol: non-HTTP SERVER_PROTOCOL does not return http' => sub {
    reset_env();
    $ENV{SERVER_PROTOCOL} = 'FTP/1.0';
    {
        my $guard = mock_scoped 'CGI::Info::getservbyport' => sub { return undef };
        my $proto = CGI::Info->new()->protocol();
        ok(!defined($proto) || $proto ne 'http',
            'non-HTTP SERVER_PROTOCOL not returned as http');
    }
};

# ============================================================
# 9. params() — HEAD request handled same as GET
#    Branch: REQUEST_METHOD eq 'HEAD'
# ============================================================

subtest 'params: HEAD request parses QUERY_STRING like GET' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'HEAD';
    $ENV{QUERY_STRING}      = 'x=1&y=2';

    my $info = CGI::Info->new();
    my $p    = $info->params();
    ok(defined $p,        'HEAD request returns params');
    is($p->{x}, '1',     'x=1 parsed from HEAD');
    is($p->{y}, '2',     'y=2 parsed from HEAD');
};

# ============================================================
# 10. params() — \\u0026 Unicode ampersand escape in QUERY_STRING
#     Branch: $query =~ s/\\u0026/\&/g
# ============================================================

subtest 'params: \\u0026 unicode ampersand escape decoded' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'a=1\\u0026b=2';

    my $info = CGI::Info->new();
    my $p    = $info->params();
    ok(defined $p, 'params returned with \\u0026 encoded ampersand');
    is($p->{a}, '1', 'a=1 parsed after \\u0026 decoded');
    is($p->{b}, '2', 'b=2 parsed after \\u0026 decoded');
};

# ============================================================
# 11. params() — upload_dir not absolute => 500
#     Branch: !File::Spec->file_name_is_absolute($self->{upload_dir})
# ============================================================

subtest 'params: multipart with relative upload_dir => 500' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'POST';
    $ENV{CONTENT_TYPE}      = 'multipart/form-data; boundary=----b';
    $ENV{CONTENT_LENGTH}    = 100;

    my $info = CGI::Info->new(upload_dir => 'relative/path');
    my $p    = eval { $info->params() };
    ok(!$@,             'does not die on relative upload_dir');
    ok(!defined($p),    'relative upload_dir returns undef');
    is($info->status(), 500, 'relative upload_dir sets status 500');
};

# ============================================================
# 12. params() — upload_dir not a directory => 500
#     Branch: !-d $self->{upload_dir}
# ============================================================

subtest 'params: multipart with upload_dir pointing to a file => 500' => sub {
    reset_env();
    my $tmp  = File::Temp->new(UNLINK => 1);
    my $file = $tmp->filename();

    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'POST';
    $ENV{CONTENT_TYPE}      = 'multipart/form-data; boundary=----b';
    $ENV{CONTENT_LENGTH}    = 100;

    my $info = CGI::Info->new(upload_dir => $file);
    my $p    = eval { $info->params() };
    ok(!$@,           'does not die when upload_dir is a file not a dir');
    ok(!defined($p),  'file-as-upload_dir returns undef');
    is($info->status(), 500, 'file-as-upload_dir sets status 500');
};

# ============================================================
# 13. params() — upload_dir not inside tmpdir => 500
#     Branch: upload_dir !~ /^\Q$tmpdir\E/
# ============================================================

subtest 'params: upload_dir outside tmpdir => 500' => sub {
    reset_env();
    my $outside = tempdir(CLEANUP => 1);

    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'POST';
    $ENV{CONTENT_TYPE}      = 'multipart/form-data; boundary=----b';
    $ENV{CONTENT_LENGTH}    = 100;

    # Make tmpdir() return something different from $outside by mocking
    my $guard = mock_scoped 'CGI::Info::tmpdir' => sub { return '/nonexistent/tmpdir/xyz' };

    my $info = CGI::Info->new(upload_dir => $outside);
    my $p    = eval { $info->params() };
    ok(!$@,           'does not die when upload_dir outside tmpdir');
    ok(!defined($p),  'upload_dir outside tmpdir returns undef');
    is($info->status(), 500, 'upload_dir outside tmpdir sets status 500');
};

# ============================================================
# 14. params() — Params::Validate::Strict schema returns empty hash
#     Branch: !(scalar keys %{$value}) after validate_strict
# ============================================================

subtest 'params: schema validation returning empty hash blocks param' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'score=999';

    my $info = CGI::Info->new();
    my $p    = $info->params(allow => {
        score => { type => 'integer', min => 0, max => 100 }
    });
    ok(!defined($p) || !defined($p->{score}),
        'out-of-range value blocked by Params::Validate::Strict schema');
    is($info->status(), 422, 'schema block sets status 422');
};

# ============================================================
# 15. param() — in_param recursion guard
#     Branch: $self->{in_param} && $self->{allow} => delete allow temporarily
#     A coderef allow that calls $obj->param() on the same instance
# ============================================================

subtest 'param: recursion guard prevents deep recursion in coderef validator' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'flag=1&score=50';

    my $info = CGI::Info->new();
    my $p = $info->params(allow => {
        flag  => qr/^[01]$/,
        score => sub {
            my ($key, $val, $obj) = @_;
            # This calls param() recursively on the same object
            # The in_param guard must prevent infinite recursion
            my $flag = $obj->param('flag');
            return defined($flag) && $flag && $val >= 0 && $val <= 100;
        },
    });

    ok(!$@, 'recursive param() call in coderef does not cause infinite recursion');
    ok(defined $p && defined $p->{score}, 'score validated via recursive param() call');
};

# ============================================================
# 16. is_mobile() — Sec-CH-UA-Mobile '?0' (not ?1, falls through)
#     Branch: ch_ua_mobile ne '?1'
# ============================================================

subtest 'is_mobile: Sec-CH-UA-Mobile ?0 does not set mobile' => sub {
    reset_env();
    $ENV{HTTP_SEC_CH_UA_MOBILE} = '?0';
    $ENV{HTTP_USER_AGENT}       = 'Mozilla/5.0 (Windows NT 10.0)';
    $ENV{REMOTE_ADDR}           = '1.2.3.4';