view release on metacpan or  search on metacpan

t/extended_tests.t  view on Meta::CPAN

    }
};

# ============================================================
# 7. protocol() — REMOTE_ADDR set but protocol undetermined
#    Branch: _warn("Can't determine the calling protocol")
# ============================================================

subtest 'protocol: REMOTE_ADDR set but no protocol determinable triggers warn' => sub {
    reset_env();
    $ENV{REMOTE_ADDR} = '1.2.3.4';
    # No SCRIPT_URI, SERVER_PROTOCOL, or SERVER_PORT

    my $info  = CGI::Info->new();
    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' };