view release on metacpan or  search on metacpan

t/edge_cases.t  view on Meta::CPAN

    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{CONTENT_TYPE}      = 'multipart/form-data; boundary=--b';
    $ENV{QUERY_STRING}      = 'x=1';
    $ENV{REMOTE_ADDR}       = '1.2.3.4';

    my $info = CGI::Info->new();
    my $p    = eval { $info->params() };
    ok(!$@, 'does not die on multipart GET');
    # Source says: multipart/form-data not supported for GET
    is($info->status(), 501, 'multipart GET returns 501 Not Implemented');
};

subtest 'POST: unsupported content-type handled without dying' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE}    = 'CGI/1.1';
    $ENV{REQUEST_METHOD}       = 'POST';
    $ENV{CONTENT_TYPE}         = 'application/octet-stream';
    my $body                   = "\x00\x01\x02\x03binary";
    $ENV{CONTENT_LENGTH}       = length($body);
    $CGI::Info::stdin_data     = $body;

    my $info = CGI::Info->new();
    my $p    = eval { $info->params() };
    ok(!$@, 'does not die on unsupported content-type POST');
};

# ============================================================
# 8. Script path edge cases
# ============================================================

subtest 'script_path: SCRIPT_FILENAME with spaces in path' => sub {
    reset_env();
    $ENV{SCRIPT_FILENAME} = '/var/www/my scripts/app.cgi';

    my $info = CGI::Info->new();
    my $path = eval { $info->script_path() };
    ok(!$@, 'does not die on SCRIPT_FILENAME with spaces');
};

subtest 'script_name: called multiple times returns same value' => sub {
    reset_env();
    $ENV{SCRIPT_NAME} = '/cgi-bin/myapp.cgi';

    my $info = CGI::Info->new();
    my $n1   = $info->script_name();
    my $n2   = $info->script_name();
    is($n1, $n2, 'script_name() idempotent across multiple calls');
};

subtest 'script_dir: called multiple times returns same value' => sub {
    reset_env();
    $ENV{SCRIPT_FILENAME} = '/var/www/cgi-bin/app.cgi';

    my $info = CGI::Info->new();
    my $d1   = $info->script_dir();
    my $d2   = $info->script_dir();
    is($d1, $d2, 'script_dir() idempotent across multiple calls');
};

# ============================================================
# 9. Cookie edge cases
# ============================================================

subtest 'cookie: name with all valid RFC6265 token chars' => sub {
    reset_env();
    # RFC6265 token chars: visible ASCII except separators
    $ENV{HTTP_COOKIE} = 'valid-name.ok=value123';

    my $info = CGI::Info->new();
    my $val  = eval { $info->cookie('valid-name.ok') };
    ok(!$@, 'does not die on RFC6265-valid cookie name with dots and hyphens');
};

subtest 'cookie: value with equals sign inside' => sub {
    reset_env();
    $ENV{HTTP_COOKIE} = 'token=base64==pad==';

    my $info = CGI::Info->new();
    my $val  = eval { $info->cookie('token') };
    ok(!$@, 'does not die on cookie value with embedded equals signs');
    # The split is on first = so value should contain the rest
    ok(defined $val, 'cookie with embedded = returns a value');
};

subtest 'cookie: requesting absent cookie from populated jar' => sub {
    reset_env();
    $ENV{HTTP_COOKIE} = 'a=1; b=2; c=3';

    my $info = CGI::Info->new();
    $info->cookie('a');    # populate jar
    my $val = eval { $info->cookie('z') };
    ok(!$@,        'does not die looking up absent key after jar populated');
    ok(!defined $val, 'absent cookie returns undef');
};

subtest 'cookie: empty cookie jar string' => sub {
    reset_env();
    $ENV{HTTP_COOKIE} = '';

    my $info = CGI::Info->new();
    my $val  = eval { $info->cookie('anything') };
    ok(!$@,       'does not die on empty HTTP_COOKIE');
    ok(!defined $val, 'empty cookie jar returns undef');
};

# ============================================================
# 10. as_string edge cases
# ============================================================

subtest 'as_string: value containing semicolons and equals escaped' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'expr=a%3Db%3Bc%3Dd';  # a=b;c=d

    my $info = CGI::Info->new();
    my $p    = eval { $info->params() };
    if(defined $p) {
        my $str = $info->as_string();
        # Escaped mode must escape ; and = in values
        unlike($str, qr/expr=.*[^\\][;=]/,