view release on metacpan or  search on metacpan

t/extended_tests.t  view on Meta::CPAN

#     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';

    ok(!CGI::Info->new()->is_mobile(),
        'Sec-CH-UA-Mobile: ?0 does not trigger mobile detection');
};

# ============================================================
# 17. is_mobile() — cache hit returning 'mobile'
#     Branch: cache->get returns 'mobile' => return 1
# ============================================================

subtest 'is_mobile: cache hit for mobile type short-circuits detection' => sub {
    reset_env();
    {
        package MobileCache;
        our %store = ( '1.2.3.4/TestBrowser/1.0' => 'mobile' );
        sub new { bless {}, shift }
        sub get { $MobileCache::store{$_[1]} }
        sub set { $MobileCache::store{$_[1]} = $_[2] }
    }

    $ENV{HTTP_USER_AGENT} = 'TestBrowser/1.0';
    $ENV{REMOTE_ADDR}     = '1.2.3.4';

    my $info = CGI::Info->new(cache => MobileCache->new());
    ok($info->is_mobile(), 'cache hit for mobile type returns true');
};

# ============================================================
# 18. is_mobile() — cache hit returning non-mobile
#     Branch: cache->get returns something other than 'mobile' => return 0
# ============================================================

subtest 'is_mobile: cache hit for non-mobile type returns false' => sub {
    reset_env();
    {
        package DesktopCache;
        our %store = ( '5.6.7.8/DesktopBrowser/1.0' => 'web' );
        sub new { bless {}, shift }
        sub get { $DesktopCache::store{$_[1]} }
        sub set { $DesktopCache::store{$_[1]} = $_[2] }
    }

    $ENV{HTTP_USER_AGENT} = 'DesktopBrowser/1.0';
    $ENV{REMOTE_ADDR}     = '5.6.7.8';

    my $info = CGI::Info->new(cache => DesktopCache->new());
    ok(!$info->is_mobile(), 'cache hit for non-mobile type returns false');
};

# ============================================================
# 19. is_robot() — HTTP_REFERER with closing paren => blocked trawler
#     Branch: $referrer =~ /\)/
# ============================================================

subtest 'is_robot: HTTP_REFERER with closing paren triggers trawler block' => sub {
    reset_env();
    $ENV{HTTP_USER_AGENT} = 'Mozilla/5.0 (compatible)';
    $ENV{REMOTE_ADDR}     = '1.2.3.4';
    $ENV{HTTP_REFERER}    = 'http://evil.example.com/page)';

    my $info = CGI::Info->new();
    ok($info->is_robot(), 'referrer with ) triggers trawler block => robot');
};

# ============================================================
# 20. is_robot() — HTTP_REFERER matching crawler list
#     Branch: List::Util::any crawler_list match
# ============================================================

subtest 'is_robot: HTTP_REFERER matching known crawler list entry' => sub {
    reset_env();
    # The check is: any { $_ =~ /^$referrer/ } @crawler_list
    # meaning the list entry must START WITH the referrer string.
    # Use a referrer that exactly matches a list entry prefix.
    $ENV{HTTP_USER_AGENT} = 'Mozilla/5.0';
    $ENV{REMOTE_ADDR}     = '1.2.3.4';
    $ENV{HTTP_REFERER}    = 'http://semalt.com';

    my $info = CGI::Info->new();
    ok($info->is_robot(), 'referrer matching crawler list => robot');
};

# ============================================================
# 21. is_robot() — majestic12 / facebookexternal UA => NOT a robot
#     Branch: $agent =~ /majestic12|facebookexternal/ => return 0
# ============================================================

subtest 'is_robot: majestic12 UA not classified as search engine' => sub {
    reset_env();
    # The majestic12/facebookexternal guard in is_robot() returns 0 (not robot)
    # BUT HTTP::BrowserDetect may classify MJ12bot as a robot first.
    # The important contract is that is_search_engine() returns true for it.
    $ENV{HTTP_USER_AGENT} = 'MJ12bot/v1.4.8 (http://www.majestic12.co.uk/bot.php)';
    $ENV{REMOTE_ADDR}     = '1.2.3.4';

    my $info = CGI::Info->new();
    # Either is_search_engine OR (not is_robot and is_search_engine via is_search_engine())
    my $is_search = $info->is_search_engine();
    ok($is_search, 'majestic12 UA classified as search engine');
};

subtest 'is_robot: facebookexternal UA classified as search, not robot' => sub {
    reset_env();
    $ENV{HTTP_USER_AGENT} = 'facebookexternalhit/1.1';
    $ENV{REMOTE_ADDR}     = '1.2.3.4';

    my $info = CGI::Info->new();
    is($info->is_robot(), 0, 'facebookexternal UA returns 0 from is_robot()');
};

# ============================================================