CGI-Info
view release on metacpan or search on metacpan
bin/testjson.pl view on Meta::CPAN
use LWP::UserAgent;
my $ua = LWP::UserAgent->new();
my $req = HTTP::Request->new(POST => 'https://localhost/cgi-bin/info.pl');
$req->header('content-type' => 'application/json');
$req->content('{ "first": "Nigel", "last": "Horne" }');
my $resp = $ua->request($req);
if($resp->is_success()) {
print "Reply:\n\t", $resp->decoded_content, "\n";
} else {
print STDERR $resp->code(), "\n", $resp->message(), "\n";
}
t/cgi_security.t view on Meta::CPAN
};
subtest 'XSS: <img onerror> blocked in GET' => sub {
my $info = make_get("q=$XSS_IMG_ONERROR");
$info->params();
is($info->status(), $STATUS_FORBIDDEN,
'<img onerror=...> triggers 403');
};
subtest 'XSS: URL-encoded <script> blocked in GET' => sub {
# %3Cscript%3E decoded to <script> by URL-decode pass, then caught.
my $info = make_get("q=$XSS_URL_ENCODED");
$info->params();
is($info->status(), $STATUS_FORBIDDEN,
'URL-encoded <script> tag triggers 403');
};
subtest 'XSS: <svg onload=> blocked in GET' => sub {
my $info = make_get("q=$XSS_SVG_ONLOAD");
$info->params();
is($info->status(), $STATUS_FORBIDDEN,
t/cgi_security.t view on Meta::CPAN
# ---------------------------------------------------------------------------
subtest 'Traversal: classic ../ blocked in GET' => sub {
my $info = make_get("file=$TRAV_CLASSIC");
$info->params();
is($info->status(), $STATUS_FORBIDDEN,
'../../../etc/passwd triggers 403');
};
subtest 'Traversal: URL-encoded ..%2F blocked in GET' => sub {
# ..%2F is decoded to ../ in a single pass, then caught.
my $info = make_get("file=$TRAV_URL_ENCODED");
$info->params();
is($info->status(), $STATUS_FORBIDDEN,
'..%2Fetc%2Fpasswd triggers 403');
};
subtest 'Traversal: double-encoded ..%252F blocked' => sub {
# Fixed: second URL-decode pass normalises %252F -> %2F -> / so
# the resulting ../ is caught by the traversal check.
my $info = make_get("file=$TRAV_DOUBLE_ENCODED");
t/edge_cases.t view on Meta::CPAN
subtest 'URL encoding: plus signs as spaces' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'msg=hello+world&empty=+';
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on plus-encoded spaces');
if(defined $p && defined $p->{msg}) {
is($p->{msg}, 'hello world', 'plus decoded to space');
}
};
# ============================================================
# 3. WAF: boundary and near-miss attack patterns
# ============================================================
subtest 'WAF: SQL keyword in value without injection pattern (should pass)' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
t/edge_cases.t view on Meta::CPAN
ok(!$@, 'does not die on URL-encoded XSS');
is($info->status(), 403, 'URL-encoded XSS blocked with 403');
};
# SQL injection via exec(xp_cmdshell) pattern — a classic MSSQL shell-escape.
# The WAF checks for exec followed by sp/xp stored procedure prefixes.
subtest 'WAF: exec xp_cmdshell stored-procedure injection blocked (403)' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
# + is decoded to space: value becomes "exec xp_cmdshell"
$ENV{QUERY_STRING} = 'cmd=exec+xp_cmdshell';
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on exec xp_cmdshell injection');
is($info->status(), 403, 'exec xp_cmdshell blocked with 403');
};
# SQL injection via exec(sp_executesql) — same pattern with sp_ prefix.
subtest 'WAF: exec sp_executesql stored-procedure injection blocked (403)' => sub {
t/edge_cases.t view on Meta::CPAN
my $p = eval { $info->params() };
ok(!$@, 'does not die on exec sp_executesql injection');
is($info->status(), 403, 'exec sp_executesql blocked with 403');
};
# Tautology injection AND 1=1: a minimal always-true condition.
subtest 'WAF: AND 1=1 tautology injection blocked (403)' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
# + decoded to space: "5 AND 1=1"
$ENV{QUERY_STRING} = 'id=5+AND+1%3D1';
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on AND 1=1 injection');
is($info->status(), 403, 'AND 1=1 tautology injection blocked with 403');
};
# The WAF now inspects both GET and POST. The previous GET-only gate
# was a security gap; it has been removed. This test verifies that
t/extended_tests.t view on Meta::CPAN
ok(defined $p, 'HEAD request returns params');
is($p->{x}, '1', 'x=1 parsed from HEAD');
is($p->{y}, '2', 'y=2 parsed from HEAD');
};
# ============================================================
# 10. params() — \\u0026 Unicode ampersand escape in QUERY_STRING
# Branch: $query =~ s/\\u0026/\&/g
# ============================================================
subtest 'params: \\u0026 unicode ampersand escape decoded' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'a=1\\u0026b=2';
my $info = CGI::Info->new();
my $p = $info->params();
ok(defined $p, 'params returned with \\u0026 encoded ampersand');
is($p->{a}, '1', 'a=1 parsed after \\u0026 decoded');
is($p->{b}, '2', 'b=2 parsed after \\u0026 decoded');
};
# ============================================================
# 11. params() — upload_dir not absolute => 500
# Branch: !File::Spec->file_name_is_absolute($self->{upload_dir})
# ============================================================
subtest 'params: multipart with relative upload_dir => 500' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
t/function.t view on Meta::CPAN
my $info = CGI::Info->new();
# Object::Configure has injected a logger; _error must not croak
lives_ok { $info->_error('logged error') }
'_error does not croak when a logger is present';
};
# ============================================================
# 30. POST with application/json content type
# ============================================================
subtest 'params() - POST JSON body decoded to hash' => sub {
plan tests => 1;
reset_env();
my $json_body = '{"alpha":"one","beta":"two"}';
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'POST';
$ENV{CONTENT_TYPE} = 'application/json';
$ENV{CONTENT_LENGTH} = length($json_body);
$CGI::Info::stdin_data = $json_body;
my $info = CGI::Info->new();
subtest 'Parameter Sanitization' => sub {
local %ENV = (
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'GET',
QUERY_STRING => 'key%00=evil%00data&value=valid+data',
);
$info = new_ok('CGI::Info');
my $params = $info->params();
is($params->{key}, 'evildata', 'NUL bytes in key removed');
is($params->{value}, 'valid data', 'Spaces correctly decoded');
};
subtest 'Max Upload Size Enforcement' => sub {
local %ENV = (
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'POST',
CONTENT_TYPE => 'application/x-www-form-urlencoded',
CONTENT_LENGTH => 1024 * 1024 * 600, # 600MB
);
$info = CGI::Info->new(max_upload => 500 * 1024); # 500KB
( run in 0.626 second using v1.01-cache-2.11-cpan-ad19def0cd9 )