view release on metacpan or  search on metacpan

t/function.t  view on Meta::CPAN

# (no SCRIPT_URI, no SERVER_PROTOCOL) and that getservbyport() returns undef
# so execution falls through to the explicit == 80 / == 443 comparisons on
# lines 1449-1451.  This is what the mutant-test survivor was flagging.
subtest 'protocol() - SERVER_PORT 443 boundary (line 1451)' => sub {
    reset_env();
    my $guard = mock_scoped 'Socket::getservbyport' => sub { return undef };

    # Exact boundary: port 443 must return 'https'
    $ENV{SERVER_PORT} = 443;
    is(CGI::Info->new()->protocol(), 'https', 'port 443 => https');

    # One below boundary: port 442 must NOT return 'https' via this branch
    $ENV{SERVER_PORT} = 442;
    my $p = CGI::Info->new()->protocol();
    ok(!defined($p) || $p ne 'https', 'port 442 does not return https');

    # One above boundary: port 444 must NOT return 'https' via this branch
    $ENV{SERVER_PORT} = 444;
    $p = CGI::Info->new()->protocol();
    ok(!defined($p) || $p ne 'https', 'port 444 does not return https');
};

subtest 'protocol() - SERVER_PORT 80 boundary (line 1449)' => sub {
    reset_env();
    my $guard = mock_scoped 'Socket::getservbyport' => sub { return undef };

    # Exact boundary: port 80 must return 'http'
    $ENV{SERVER_PORT} = 80;
    is(CGI::Info->new()->protocol(), 'http', 'port 80 => http');

    # One below: port 79 must NOT return 'http' via this branch
    $ENV{SERVER_PORT} = 79;
    my $p = CGI::Info->new()->protocol();
    ok(!defined($p) || $p ne 'http', 'port 79 does not return http');

    # One above: port 81 must NOT return 'http' via this branch
    $ENV{SERVER_PORT} = 81;
    $p = CGI::Info->new()->protocol();
    ok(!defined($p) || $p ne 'http', 'port 81 does not return http');
};

# ============================================================
# 10. is_mobile()
# ============================================================
subtest 'is_mobile() - iPhone user agent' => sub {
    reset_env();
    $ENV{HTTP_USER_AGENT} = 'Mozilla/5.0 (iPhone; CPU iPhone OS 14_0 like Mac OS X)';
    $ENV{REMOTE_ADDR}     = '1.2.3.4';
    my $info = CGI::Info->new();
    ok($info->is_mobile(), 'iPhone UA detected as mobile');
};

subtest 'is_mobile() - Android user agent' => sub {
    reset_env();
    $ENV{HTTP_USER_AGENT} = 'Mozilla/5.0 (Linux; Android 10; Pixel 3)';
    $ENV{REMOTE_ADDR}     = '1.2.3.4';
    my $info = CGI::Info->new();
    ok($info->is_mobile(), 'Android UA detected as mobile');
};

subtest 'is_mobile() - desktop user agent' => sub {
    reset_env();
    $ENV{HTTP_USER_AGENT} = 'Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36';
    $ENV{REMOTE_ADDR}     = '1.2.3.4';
    my $info = CGI::Info->new();
    ok(!$info->is_mobile(), 'desktop UA not detected as mobile');
};

subtest 'is_mobile() - Sec-CH-UA-Mobile hint' => sub {
    reset_env();
    $ENV{HTTP_SEC_CH_UA_MOBILE} = '?1';
    my $info = CGI::Info->new();
    ok($info->is_mobile(), 'Sec-CH-UA-Mobile ?1 detected as mobile');
};

subtest 'is_mobile() - HTTP_X_WAP_PROFILE' => sub {
    reset_env();
    $ENV{HTTP_X_WAP_PROFILE} = 'http://wap.example.com/profile';
    my $info = CGI::Info->new();
    ok($info->is_mobile(), 'WAP profile header detected as mobile');
};

subtest 'is_mobile() - IS_MOBILE env override' => sub {
    reset_env();
    $ENV{IS_MOBILE} = 1;
    my $info = CGI::Info->new();
    ok($info->is_mobile(), 'IS_MOBILE env override works');
};

# ============================================================
# 11. is_tablet()
# ============================================================
subtest 'is_tablet() - iPad user agent' => sub {
    reset_env();
    $ENV{HTTP_USER_AGENT} = 'Mozilla/5.0 (iPad; CPU OS 14_0 like Mac OS X)';
    my $info = CGI::Info->new();
    ok($info->is_tablet(), 'iPad UA detected as tablet');
};

subtest 'is_tablet() - non-tablet user agent' => sub {
    reset_env();
    $ENV{HTTP_USER_AGENT} = 'Mozilla/5.0 (Windows NT 10.0)';
    my $info = CGI::Info->new();
    ok(!$info->is_tablet(), 'desktop UA not a tablet');
};

# ============================================================
# 12. is_robot()
# ============================================================
subtest 'is_robot() - known bot UA' => sub {
    reset_env();
    $ENV{HTTP_USER_AGENT} = 'Googlebot/2.1 (+http://www.google.com/bot.html)';
    $ENV{REMOTE_ADDR}     = '66.249.66.1';
    my $info = CGI::Info->new();
    # Googlebot may be classed as search engine not robot; either is acceptable
    my $result = $info->is_robot() || $info->is_search_engine();
    ok($result, 'Googlebot classified as robot or search engine');
};

subtest 'is_robot() - ClaudeBot' => sub {
    reset_env();
    $ENV{HTTP_USER_AGENT} = 'ClaudeBot/1.0';
    $ENV{REMOTE_ADDR}     = '1.2.3.4';
    my $info = CGI::Info->new();
    ok($info->is_robot(), 'ClaudeBot detected as robot');
};

subtest 'is_robot() - SQL injection UA => 403 + robot' => sub {
    reset_env();
    $ENV{HTTP_USER_AGENT} = "Mozilla SELECT foo AND bar FROM baz";
    $ENV{REMOTE_ADDR}     = '1.2.3.4';
    my $info = CGI::Info->new();
    ok($info->is_robot(), 'SQL injection UA flagged as robot');
    is($info->status(), 403, 'status 403 on SQL UA');
};

subtest 'is_robot() - no CGI env => 0' => sub {
    reset_env();
    my $info = CGI::Info->new();
    is($info->is_robot(), 0, 'no CGI env returns 0 (assume real person)');
};

# ============================================================
# 13. is_search_engine()
# ============================================================
subtest 'is_search_engine() - IS_SEARCH_ENGINE env' => sub {
    reset_env();
    $ENV{IS_SEARCH_ENGINE} = 1;
    $ENV{REMOTE_ADDR}      = '1.2.3.4';
    $ENV{HTTP_USER_AGENT}  = 'SomeBot';
    my $info = CGI::Info->new();
    ok($info->is_search_engine(), 'IS_SEARCH_ENGINE env override works');
};

subtest 'is_search_engine() - no CGI env => 0' => sub {
    reset_env();
    my $info = CGI::Info->new();
    is($info->is_search_engine(), 0, 'no CGI env returns 0');
};

# ============================================================
# 14. browser_type()
# ============================================================
subtest 'browser_type() - mobile' => sub {
    reset_env();
    $ENV{HTTP_USER_AGENT} = 'Mozilla/5.0 (iPhone; CPU iPhone OS 14_0 like Mac OS X)';
    $ENV{REMOTE_ADDR}     = '1.2.3.4';
    my $info = CGI::Info->new();
    is($info->browser_type(), 'mobile', 'mobile browser_type');
};

subtest 'browser_type() - web (desktop)' => sub {
    reset_env();
    $ENV{HTTP_USER_AGENT} = 'Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 Chrome/120';
    $ENV{REMOTE_ADDR}     = '1.2.3.4';
    my $info = CGI::Info->new();
    is($info->browser_type(), 'web', 'desktop browser_type is web');
};

# ============================================================
# 15. cookie() / get_cookie()
# ============================================================
subtest 'cookie() - returns value for existing cookie' => sub {
    reset_env();
    $ENV{HTTP_COOKIE} = 'session=abc123; user=bob';
    my $info = CGI::Info->new();
    is($info->cookie('session'), 'abc123', 'cookie() returns session value');
    is($info->cookie('user'),    'bob',    'cookie() returns user value');
};

subtest 'cookie() - returns undef for missing cookie' => sub {
    reset_env();
    $ENV{HTTP_COOKIE} = 'a=1';
    my $info = CGI::Info->new();
    ok(!defined $info->cookie('nosuchcookie'), 'missing cookie returns undef');
};

subtest 'get_cookie() - alias for cookie()' => sub {
    reset_env();
    $ENV{HTTP_COOKIE} = 'token=xyz';
    my $info = CGI::Info->new();
    is($info->get_cookie(cookie_name => 'token'), 'xyz', 'get_cookie() alias works');
};

subtest 'cookie() - no cookie env returns undef' => sub {
    reset_env();
    my $info = CGI::Info->new();
    ok(!defined $info->cookie('x'), 'no HTTP_COOKIE returns undef');
};

# ============================================================
# 16. tmpdir()
# ============================================================
subtest 'tmpdir() - returns a writable directory' => sub {
    reset_env();
    my $info = CGI::Info->new();
    my $dir  = $info->tmpdir();
    ok(defined $dir,   'tmpdir() returns defined value');
    ok(-d $dir,        'tmpdir() is a directory');
    ok(-w $dir,        'tmpdir() is writable');
};

subtest 'tmpdir() - default param honoured when nothing better' => sub {
    reset_env();
    my $tmp   = tempdir(CLEANUP => 1);
    my $info  = CGI::Info->new();
    my $dir   = $info->tmpdir(default => $tmp);
    # Either it found a system tmp or used the default
    ok(defined $dir, 'tmpdir() with default returns defined value');
};

subtest 'tmpdir() - class method' => sub {
    reset_env();
    my $dir = CGI::Info->tmpdir();
    ok(defined $dir, 'tmpdir() as class method works');
};