CGI-Info
view release on metacpan or search on metacpan
{
cookie_name => {
'type' => 'string',
'min' => 1,
'matches' => qr/^[!#-'*+\-.\^_`|~0-9A-Za-z]+$/ # RFC6265
}
}
#### OUTPUT
Cookie not set: `undef`
Cookie set:
{
type => 'string',
optional => 1,
matches => qr/ # RFC6265
^
(?:
"[\x21\x23-\x2B\x2D-\x3A\x3C-\x5B\x5D-\x7E]*" # quoted
| [\x21\x23-\x2B\x2D-\x3A\x3C-\x5B\x5D-\x7E]* # unquoted
)
bin/info.pl view on Meta::CPAN
if($info->params()) {
my %FORM = %{$info->params()};
for my $key (sort keys %FORM) {
print "$key => $FORM{$key}\n";
}
}
if($ENV{'HTTP_COOKIE'}) {
print 'HTTP_COOKIE: ', $ENV{'HTTP_COOKIE'}, "\n",
"Cookies:\n";
foreach my $cookie(split (/\s*;\s*/, $ENV{'HTTP_COOKIE'})) {
my ($key, $value) = split(/=/, $cookie);
print "Cookie $key:\n";
my $c = $info->cookie(cookie_name => $key);
if(!defined($c)) {
print "ERROR: Expected $value, got undef\n";
} elsif($c eq $value) {
print "$c\n";
} else {
print "ERROR: Expected $value, got $c\n";
}
}
}
lib/CGI/Info.pm view on Meta::CPAN
{
cookie_name => {
'type' => 'string',
'min' => 1,
'matches' => qr/^[!#-'*+\-.\^_`|~0-9A-Za-z]+$/ # RFC6265
}
}
=head4 OUTPUT
Cookie not set: C<undef>
Cookie set:
{
type => 'string',
optional => 1,
matches => qr/ # RFC6265
^
(?:
"[\x21\x23-\x2B\x2D-\x3A\x3C-\x5B\x5D-\x7E]*" # quoted
| [\x21\x23-\x2B\x2D-\x3A\x3C-\x5B\x5D-\x7E]* # unquoted
)
lib/CGI/Info.pm view on Meta::CPAN
my $field = $params->{'cookie_name'};
# Validate field argument
if(!defined($field)) {
$self->_error('what cookie do you want?');
Carp::croak('what cookie do you want?');
return;
}
if(ref($field)) {
$self->_error('Cookie name should be a string');
Carp::croak('Cookie name should be a string');
return;
}
# Load cookies if not already loaded
unless($self->{jar}) {
if(defined $ENV{'HTTP_COOKIE'}) {
# Truncate at the first CR or LF before parsing.
# HTTP header values cannot span lines; anything after a newline is
# injected content (e.g. "session=abc\r\nSet-Cookie: admin=1").
# Stripping rather than truncating would leave the injected text
# concatenated onto a legitimate value, so we discard from \r/\n onward.
(my $raw_cookie = $ENV{'HTTP_COOKIE'}) =~ s/[\r\n].*$//s;
# grep { /=/ } filters out malformed tokens (empty strings, bare
# semicolons, entries with no name=value separator) that would
# otherwise cause split(/=/, $_, 2) to return a single-element list
# and make the flattened list odd-length, corrupting the hash.
$self->{jar} = {
map { split(/=/, $_, 2) }
t/cgi_security.t view on Meta::CPAN
Readonly my $XSS_SVG_ONLOAD => '<svg onload=alert(1)>';
Readonly my $XSS_DOUBLE_ENCODED => '%253Cscript%253Ealert(1)%253C%252Fscript%253E';
# Path traversal payloads
Readonly my $TRAV_CLASSIC => '../../../etc/passwd';
Readonly my $TRAV_URL_ENCODED => '..%2Fetc%2Fpasswd';
Readonly my $TRAV_DOUBLE_ENCODED => '..%252Fetc%252Fpasswd';
Readonly my $TRAV_NULL_BYTE => "../etc/passwd\0.jpg";
Readonly my $TRAV_WINDOWS => '..\..\..\windows\system32\drivers\etc\hosts';
# Cookie injection payloads
Readonly my $COOKIE_CRLF => "session=abc\r\nSet-Cookie: admin=1";
Readonly my $COOKIE_NOSEP => 'malformed-cookie-no-equals';
Readonly my $COOKIE_OVERFLOW => 'x=' . ('A' x 65536);
# ---------------------------------------------------------------------------
# Helpers: build CGI environment for GET and POST requests
# ---------------------------------------------------------------------------
sub reset_env {
delete $ENV{$_} for qw(
GATEWAY_INTERFACE REQUEST_METHOD QUERY_STRING CONTENT_TYPE
t/cgi_security.t view on Meta::CPAN
$ENV{REQUEST_METHOD} = 'GET';
$ENV{REMOTE_ADDR} = $REMOTE;
$ENV{HTTP_USER_AGENT} = $BENIGN_UA;
$ENV{HTTP_REFERER} = 'http://partner.semalt.com/x';
my $info = CGI::Info->new();
ok($info->is_robot(), 'semalt.com referer classified as robot');
};
# ---------------------------------------------------------------------------
# Section 8: Cookie jar parsing — boundary and hostile inputs
# ---------------------------------------------------------------------------
subtest 'Cookie: missing = separator does not crash cookie()' => sub {
# A bare token with no = in HTTP_COOKIE should be silently filtered by
# the grep { /=/ } guard and not corrupt the jar hash.
reset_env();
$ENV{HTTP_COOKIE} = $COOKIE_NOSEP;
my $info = CGI::Info->new();
my $val;
eval { $val = $info->cookie(cookie_name => 'malformed-cookie-no-equals') };
ok(!$@, 'malformed cookie (no =) does not throw an exception');
ok(!defined $val, 'no value returned for cookie without = separator');
};
subtest 'Cookie: multiple cookies parsed correctly despite edge-case spacing' => sub {
reset_env();
$ENV{HTTP_COOKIE} = 'session=abc123; token=xyz; flag=1';
my $info = CGI::Info->new();
is($info->cookie(cookie_name => 'session'), 'abc123',
'session cookie parsed correctly');
is($info->cookie(cookie_name => 'token'), 'xyz',
'token cookie parsed correctly');
is($info->cookie(cookie_name => 'flag'), '1',
'flag cookie parsed correctly');
};
subtest 'Cookie: cookie with = in value uses split limit=2 (value preserved)' => sub {
# split(/=/, $_, 2) — the limit-2 form ensures a cookie value containing
# embedded = signs is not truncated.
reset_env();
$ENV{HTTP_COOKIE} = 'data=base64+encoded==; other=val';
my $info = CGI::Info->new();
is($info->cookie(cookie_name => 'data'), 'base64+encoded==',
'cookie value with embedded = is preserved by split limit=2');
};
subtest 'Cookie: CRLF in cookie environment does not inject response headers' => sub {
# The HTTP server normally strips CRLF from incoming headers, but test
# that cookie() does not reflect unescaped CRLF into any output.
# We verify the module does not crash and that the injected portion is
# not returned as the named cookie's value.
reset_env();
$ENV{HTTP_COOKIE} = $COOKIE_CRLF;
my $info = CGI::Info->new();
# The attacker wants $info->cookie(cookie_name => 'session') to return
# "abc\r\nSet-Cookie: admin=1" so they can inject a response header.
my $val = eval { $info->cookie(cookie_name => 'session') };
ok(!$@, 'CRLF-bearing HTTP_COOKIE does not throw an exception');
if(defined $val) {
unlike($val, qr/\r\n/,
'returned cookie value does not contain CRLF sequence');
unlike($val, qr/Set-Cookie/i,
'returned cookie value does not contain injected header name');
}
};
# ---------------------------------------------------------------------------
# Section 9: HTTP method enforcement
# ---------------------------------------------------------------------------
subtest 'Method: DELETE not allowed — returns 405' => sub {
reset_env();
t/cgi_security.t view on Meta::CPAN
$ENV{HTTP_SEC_CH_UA_MOBILE} = '?1';
ok(CGI::Info->new()->is_mobile(), 'HTTP_SEC_CH_UA_MOBILE=?1 triggers is_mobile');
};
subtest 'Sec-CH-UA-Mobile: ?0 does not trigger is_mobile' => sub {
reset_env();
$ENV{HTTP_SEC_CH_UA_MOBILE} = '?0';
ok(!CGI::Info->new()->is_mobile(), 'HTTP_SEC_CH_UA_MOBILE=?0 does not trigger is_mobile');
};
subtest 'Sec-CH-UA-Mobile: injected value "; Set-Cookie: admin=1" does not trigger is_mobile' => sub {
# Attacker tries to use the Sec-CH-UA-Mobile value as a header injection
# vector. The module checks exact string equality ('?1') so anything
# else simply falls through without becoming mobile.
reset_env();
$ENV{HTTP_SEC_CH_UA_MOBILE} = "?1\r\nSet-Cookie: admin=1";
ok(!CGI::Info->new()->is_mobile(),
'CRLF-bearing Sec-CH-UA-Mobile header does not trigger is_mobile');
};
# ---------------------------------------------------------------------------
# Section 14: Benign inputs must not be false-positived by the WAF
# Confirm the WAF does not break legitimate use-cases.
# ---------------------------------------------------------------------------
subtest 'WAF: safe alphanumeric params not blocked' => sub {
t/cookies.t view on Meta::CPAN
$i->get_cookie();
};
ok($@ =~ /^Usage: /);
$ENV{'HTTP_COOKIE'} = 'phpbb3_ljj67_k=3dba1f0d50e51f76; style_cookie=printonly; __utma=249501332.293603655.1368565227.1380805951.1380808408.13; __utmz=249501332.1368565227.1.1.utmccn=(direct)|utmcsr=(direct)|utmcmd=(none); phpbb3_ljj67_u=2; phpbb3_l...
$i = new_ok('CGI::Info');
ok($i->get_cookie(cookie_name => 'cart') eq 'tubabb:1');
ok($i->cookie('cart') eq 'tubabb:1');
}
# Cookie not set, should warn about missing field
{
local $ENV{'HTTP_COOKIE'} = 'user=JohnDoe; session=abc123'; # Example cookie
my $obj = new_ok('CGI::Info');
# Check for missing field
diag('Ignore message about what cookie would you like');
throws_ok { $obj->cookie() } qr/^Usage/ , 'undef if no cookie field is provided';
cmp_ok($obj->cookie('user'), 'eq', 'JohnDoe');
}
# Cookie jar is populated correctly with valid cookies
{
local $ENV{'HTTP_COOKIE'} = 'user=JohnDoe; session=abc123'; # Example cookie
my $obj = new_ok('CGI::Info');
# Test retrieving cookies from jar
is($obj->cookie('user'), 'JohnDoe', 'Correctly retrieves "user" cookie');
is($obj->cookie('session'), 'abc123', 'Correctly retrieves "session" cookie');
}
# Cookie field not found in the jar
{
local $ENV{'HTTP_COOKIE'} = 'user=JohnDoe; session=abc123'; # Example cookie
my $obj = new_ok('CGI::Info');
# Test non-existent cookie field
is($obj->cookie('nonexistent'), undef, 'Returns undef for non-existent cookie');
}
# Cookie field provided but no cookies in the header (edge case)
{
local $ENV{'HTTP_COOKIE'} = ''; # No cookies set
my $obj = new_ok('CGI::Info');
# Test with no cookies available
is($obj->cookie('user'), undef, 'Returns undef when no cookies are available');
}
# Ensure loading of the cookie jar
{
t/edge_cases.t view on Meta::CPAN
reset_env();
$ENV{SCRIPT_FILENAME} = '/var/www/cgi-bin/app.cgi';
my $info = CGI::Info->new();
my $d1 = $info->script_dir();
my $d2 = $info->script_dir();
is($d1, $d2, 'script_dir() idempotent across multiple calls');
};
# ============================================================
# 9. Cookie edge cases
# ============================================================
subtest 'cookie: name with all valid RFC6265 token chars' => sub {
reset_env();
# RFC6265 token chars: visible ASCII except separators
$ENV{HTTP_COOKIE} = 'valid-name.ok=value123';
my $info = CGI::Info->new();
my $val = eval { $info->cookie('valid-name.ok') };
ok(!$@, 'does not die on RFC6265-valid cookie name with dots and hyphens');
t/integration.t view on Meta::CPAN
my $info = CGI::Info->new();
my $params = $info->params();
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');
t/integration.t view on Meta::CPAN
# Form params
my $p = $info->params();
ok(defined $p, 'params returned');
is($p->{action}, 'save', 'action param correct');
is($p->{category}, 'tech', 'category param correct');
# Individual param access
is($info->param('action'), 'save', 'param(action) correct');
# Cookie access
is($info->cookie('sessionid'), 's3cr3t', 'session cookie read');
is($info->cookie('csrf'), 'tok3n', 'csrf cookie read');
# as_string for cache key
my $key = $info->as_string();
like($key, qr/action=save/, 'as_string usable as cache key');
# Clean status throughout
is($info->status(), 200, 'status 200 for authenticated form submission');
};
( run in 1.037 second using v1.01-cache-2.11-cpan-ad19def0cd9 )