view release on metacpan or  search on metacpan

t/integration.t  view on Meta::CPAN

        sub warn  { push @CapturingLogger::msgs, $_[1] }
        sub info  { push @CapturingLogger::msgs, $_[1] }
        sub error { push @CapturingLogger::msgs, $_[1] }
        sub debug { }
        sub trace { }
    }
    @CapturingLogger::msgs = ();
    my $logger = CapturingLogger->new();

    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'id=notanumber';

    my $info = CGI::Info->new(logger => $logger);
    $info->params(allow => { id => qr/^\d+$/ });

    # Regardless of how the logger routes output, messages() must be populated
    my $msgs = $info->messages();
    ok(defined $msgs && scalar @{$msgs} > 0,
        'validation failure logged: messages() populated');
    is($info->status(), 422, 'status 422 set when logger present');
};

# ============================================================
# 9. Browser detection + params in same session
# ============================================================

subtest 'mobile browser: browser_type, is_mobile, params all consistent' => sub {
    reset_env();
    $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{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'view=compact&page=1';

    my $info = CGI::Info->new();

    ok($info->is_mobile(),               'is_mobile() true for iPhone');
    ok(!$info->is_tablet(),              'is_tablet() false for iPhone');
    is($info->browser_type(), 'mobile',  'browser_type() is mobile');
    ok(!$info->is_robot(),               'is_robot() false for real user');
    ok(!$info->is_search_engine(),       'is_search_engine() false for iPhone');

    my $params = $info->params();
    is($params->{view}, 'compact', 'params parsed correctly alongside mobile detection');
    is($params->{page}, '1',       'page param parsed');
};

subtest 'tablet browser: is_tablet, is_mobile, browser_type consistent' => sub {
    reset_env();
    $ENV{HTTP_USER_AGENT} = 'Mozilla/5.0 (iPad; CPU OS 15_0 like Mac OS X)';
    $ENV{REMOTE_ADDR}     = '1.2.3.4';

    my $info = CGI::Info->new();

    ok($info->is_tablet(),              'is_tablet() true for iPad');
    ok($info->is_mobile(),              'is_mobile() true for iPad (tablets are mobile)');
    is($info->browser_type(), 'mobile', 'browser_type() mobile for tablet');
};

subtest 'robot browser: is_robot, browser_type, params blocked on SQL UA' => sub {
    reset_env();
    $ENV{HTTP_USER_AGENT}   = 'ClaudeBot/1.0 (+http://www.anthropic.com)';
    $ENV{REMOTE_ADDR}       = '1.2.3.4';
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'q=test';

    my $info = CGI::Info->new();

    ok($info->is_robot(),           'is_robot() true for ClaudeBot');
    ok($info->is_ai(),              'is_ai() true for ClaudeBot');
    is($info->browser_type(), 'ai', 'browser_type() is ai for AI crawler');
    ok(!$info->is_mobile(),         'is_mobile() false for robot');
    ok(!$info->is_tablet(),         'is_tablet() false for robot');

    # params() should still work for a robot (it only blocks on bad content)
    my $params = $info->params();
    ok(!defined($params) || defined($params->{q}),
        'params accessible for robot with clean query');
};

subtest 'desktop browser: browser_type web, not mobile/tablet/robot' => 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();

    ok(!$info->is_mobile(),          'desktop is not mobile');
    ok(!$info->is_tablet(),          'desktop is not tablet');
    ok(!$info->is_robot(),           'desktop is not robot');
    is($info->browser_type(), 'web', 'desktop browser_type is web');
};

# ============================================================
# 10. Stateful: --mobile/--robot/--tablet/--search-engine ARGV flags
#     Each flag sets the appropriate state AND params() still works
# ============================================================

subtest 'ARGV --mobile flag: is_mobile true, params still parsed' => sub {
    reset_env();
    local @ARGV = ('--mobile', 'section=news', 'limit=10');
    my $info = CGI::Info->new();
    $info->params();

    ok($info->is_mobile(), '--mobile sets is_mobile');
    my $p = $info->params();
    is($p->{section}, 'news', 'section param parsed after --mobile');
    is($p->{limit},   '10',   'limit param parsed after --mobile');
};

subtest 'ARGV --robot flag: is_robot true, browser_type robot' => sub {
    reset_env();
    local @ARGV = ('--robot');
    my $info = CGI::Info->new();
    $info->params();

    ok($info->is_robot(),              '--robot sets is_robot');
    is($info->browser_type(), 'robot', 'browser_type robot after --robot');
};

t/integration.t  view on Meta::CPAN

    is($params->{page}, '2',    'page param parsed');
    is($params->{sort}, 'date', 'sort param parsed');

    is($info->cookie('session'), 'abc123', 'session cookie read');
    is($info->cookie('theme'),   'dark',   'theme cookie read');

    # Cookie lookup doesn't disturb params
    is($info->param('page'), '2',    'param still intact after cookie lookup');
    is($info->param('sort'), 'date', 'sort param still intact');
};

subtest 'cookie: repeated lookups return same value (stateful jar)' => sub {
    reset_env();
    $ENV{HTTP_COOKIE} = 'user=nigel; prefs=verbose';

    my $info = CGI::Info->new();
    my $first  = $info->cookie('user');
    my $second = $info->cookie('user');
    is($first, $second, 'repeated cookie() calls return same value');
    is($first, 'nigel', 'cookie value is correct');
};

# ============================================================
# 14. tmpdir, logdir, rootdir: directory methods cross-check
# ============================================================

subtest 'directory methods: all return valid directories' => sub {
    reset_env();
    my $tmp = tempdir(CLEANUP => 1);
    $ENV{C_DOCUMENT_ROOT} = $tmp;

    my $info = CGI::Info->new();

    my $tmpdir  = $info->tmpdir();
    my $rootdir = $info->rootdir();
    my $logdir  = $info->logdir();

    ok(-d $tmpdir,  'tmpdir() is a directory');
    ok(-d $rootdir, 'rootdir() is a directory');
    ok(-d $logdir,  'logdir() is a directory');

    ok(-w $tmpdir, 'tmpdir() is writable');
    ok(-w $logdir, 'logdir() is writable');

    is($rootdir, $tmp, 'rootdir() returns C_DOCUMENT_ROOT');
};

subtest 'logdir: set then get returns same value' => sub {
    reset_env();
    my $tmp  = tempdir(CLEANUP => 1);
    my $info = CGI::Info->new();

    $info->logdir($tmp);
    is($info->logdir(), $tmp, 'logdir() returns previously set directory');
};

# ============================================================
# 15. WAF: multiple attack types in sequence, each gets correct status
# ============================================================

subtest 'WAF: SQL injection blocked with 403' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = "id=1'%20OR%201=1";

    my $info = CGI::Info->new();
    ok(!defined $info->params(), 'SQL injection returns undef');
    is($info->status(), 403, 'SQL injection status 403');
    ok(defined $info->messages(), 'SQL injection logged to messages');
};

subtest 'WAF: XSS injection blocked with 403' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'q=%3Cscript%3Ealert(1)%3C%2Fscript%3E';

    my $info = CGI::Info->new();
    ok(!defined $info->params(), 'XSS returns undef');
    is($info->status(), 403, 'XSS status 403');
};

subtest 'WAF: directory traversal blocked with 403' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'file=../../etc/shadow';

    my $info = CGI::Info->new();
    ok(!defined $info->params(), 'traversal returns undef');
    is($info->status(), 403, 'traversal status 403');
};

subtest 'WAF: mustleak blocked with 403' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'probe=mustleak.com/test';

    my $info = CGI::Info->new();
    ok(!defined $info->params(), 'mustleak returns undef');
    is($info->status(), 403, 'mustleak status 403');
};

subtest 'WAF: clean request after previous attack creates fresh object cleanly' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'name=Alice&id=42';

    # Fresh object after reset_env — no state bleed from prior attacks
    my $info = CGI::Info->new();
    my $p    = $info->params();
    ok(defined $p,              'clean request returns params');
    is($info->status(), 200,   'clean request status 200');
    is($p->{name}, 'Alice',    'name parsed correctly');
};

# ============================================================
# 16. POST: content-length enforcement + XML passthrough
# ============================================================

subtest 'POST XML: entire body preserved, status remains 200' => sub {
    reset_env();
    my $xml = '<request><action>search</action><term>perl</term></request>';
    $ENV{GATEWAY_INTERFACE}    = 'CGI/1.1';
    $ENV{REQUEST_METHOD}       = 'POST';
    $ENV{CONTENT_TYPE}         = 'text/xml';
    $ENV{CONTENT_LENGTH}       = length($xml);
    $CGI::Info::stdin_data     = $xml;

    my $info   = CGI::Info->new();
    my $params = $info->params();

    ok(defined $params,          'XML POST returns params hashref');
    is($params->{XML}, $xml,     'full XML body preserved under XML key');
    is($info->status(), 200,     'status 200 for valid XML POST');
};

subtest 'POST: content_length missing => 411, params undef' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'POST';

    my $info = CGI::Info->new();
    ok(!defined $info->params(), 'missing content-length returns undef');
    is($info->status(), 411,     'status 411 on missing content-length');
};

subtest 'POST: body exceeds max_upload_size => 413, params undef' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'POST';
    $ENV{CONTENT_LENGTH}    = 1_000_000;