view release on metacpan or  search on metacpan

t/extended_tests.t  view on Meta::CPAN

    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'a=bad&b=alsoBad&c=stillBad';

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

    my $str = $info->messages_as_string();
    if($str && $str =~ /;/) {
        like($str, qr/;\s/, 'multiple messages joined by "; "');
    } else {
        ok(defined $str, 'messages_as_string returns a string');
    }
};

# ============================================================
# 42. params() — stdin_data reused by second object (FCGI pattern)
#     Branch: if($stdin_data) { $buffer = $stdin_data } in POST handler
# ============================================================

subtest 'params: second POST object reuses stdin_data class variable' => sub {
    reset_env();
    my $body = 'shared=yes&count=1';
    $ENV{GATEWAY_INTERFACE}    = 'CGI/1.1';
    $ENV{REQUEST_METHOD}       = 'POST';
    $ENV{CONTENT_TYPE}         = 'application/x-www-form-urlencoded';
    $ENV{CONTENT_LENGTH}       = length($body);
    $CGI::Info::stdin_data     = $body;

    my $info1 = CGI::Info->new();
    my $p1    = $info1->params();
    ok(defined $p1 && $p1->{shared} eq 'yes', 'first object parses stdin_data');

    # Second object with same env should reuse $stdin_data
    my $info2 = CGI::Info->new();
    my $p2    = $info2->params();
    ok(defined $p2 && $p2->{shared} eq 'yes',
        'second object reuses stdin_data class variable');
};

# ============================================================
# 43. domain_name() — site with no www prefix returned as-is
#     Branch: $site !~ /^www\./ => $domain = $site
# ============================================================

subtest 'domain_name: non-www host returned unchanged' => sub {
    reset_env();
    $ENV{HTTP_HOST} = 'api.example.com';

    my $domain = CGI::Info->new()->domain_name();
    is($domain, 'api.example.com',
        'domain_name() returns non-www host unchanged');
};

# ============================================================
# 44. browser_type() — priority order: mobile > search > robot > web
#     Verify the cascade: mobile wins over everything
# ============================================================

subtest 'browser_type: mobile takes priority over robot detection' => sub {
    reset_env();
    # iPhone UA — would be classified as both mobile and potentially robot
    # by some detectors; mobile must win
    $ENV{HTTP_USER_AGENT} = 'Mozilla/5.0 (iPhone; CPU iPhone OS 15_0 like Mac OS X)';
    $ENV{REMOTE_ADDR}     = '1.2.3.4';
    $ENV{IS_MOBILE}       = 1;

    my $info = CGI::Info->new();
    is($info->browser_type(), 'mobile',
        'mobile takes priority in browser_type() cascade');
};

# ============================================================
# 45. is_tablet() — TabletPC user agent
#     Branch: $agent =~ /.+(iPad|TabletPC).+/
# ============================================================

subtest 'is_tablet: TabletPC user agent detected as tablet' => sub {
    reset_env();
    $ENV{HTTP_USER_AGENT} = 'Mozilla/5.0 (Windows NT 10.0; TabletPC; ARM)';

    ok(CGI::Info->new()->is_tablet(), 'TabletPC UA detected as tablet');
};

# ============================================================
# 46. params() — POST with application/x-www-form-urlencoded + QUERY_STRING
#     Both POST body and query string in same request
# ============================================================

subtest 'params: POST urlencoded body parsed correctly' => sub {
    reset_env();
    my $body                   = 'postkey=postval&other=data';
    $ENV{GATEWAY_INTERFACE}    = 'CGI/1.1';
    $ENV{REQUEST_METHOD}       = 'POST';
    $ENV{CONTENT_TYPE}         = 'application/x-www-form-urlencoded';
    $ENV{CONTENT_LENGTH}       = length($body);
    $CGI::Info::stdin_data     = $body;

    my $info = CGI::Info->new();
    my $p    = $info->params();
    ok(defined $p,                'POST urlencoded params returned');
    is($p->{postkey}, 'postval', 'postkey from POST body');
    is($p->{other},   'data',    'other from POST body');
};

# ============================================================
# 47. _untaint_filename() — filename with chars outside allowed set
#     Branch: filename !~ allowed pattern => returns undef
# ============================================================

subtest '_untaint_filename: filename with shell metacharacter returns undef' => sub {
    reset_env();
    # SCRIPT_FILENAME containing a backtick — _untaint_filename should reject it
    $ENV{SCRIPT_FILENAME} = '/var/www/cgi-bin/`evil`.cgi';

    my $info = CGI::Info->new();
    my $path = $info->script_path();
    # Either returns undef (untaint failed) or a sanitised path — must not crash
    ok(!$@, 'does not die on script_filename with shell metacharacter');
    ok(!defined($path) || $path !~ /`/,
        'backtick not present in returned script_path');
};

# ============================================================
# 48. new() — auto_load enabled by default (auto_load not specified)
#     Branch: !exists($self->{auto_load}) => AUTOLOAD works normally
# ============================================================

subtest 'new: AUTOLOAD enabled by default when auto_load not specified' => sub {
    reset_env();