view release on metacpan or  search on metacpan

t/cgi_security.t  view on Meta::CPAN

	my $result;
	my @warnings;
	{
		local $SIG{__WARN__} = sub { push @warnings, @_ };
		$result = $WRAPPER_CLASS->new(
			cache  => {},
			object => $ENV{HTTP_HOST},
		);
	}

	is($result, undef,
		'scalar object from HTTP_HOST returns undef -- no wrapper created');
	ok(scalar(@warnings) > 0 && $warnings[0] =~ /must be a reference/,
		'carp warning mentions "must be a reference"');
};

# ===========================================================================
# VECTOR 12 -- Undef Argument Collapse (Parameter-Omission Attack)
#
# Exploit: undefined CGI parameters (e.g. optional fields absent from
# QUERY_STRING) are dropped from the cache key:
#   foo(undef) and foo() both produce key ...::foo::
# If an authenticated call uses undef as a meaningful sentinel parameter
# and an unauthenticated caller simply omits the parameter, they receive
# the same cached result -- a cross-user data access without any error.
# This is a documented limitation; validate and reject undef arguments at
# the application layer before they reach the cached method.
# ===========================================================================
subtest 'undef arg collapse: foo(undef) and foo() share the same cache slot' => sub {
	local %ENV = (%ENV, QUERY_STRING => '');    # no query params -- undef args

	my $cache  = {};
	my $object = $INNER_CLASS->new();
	my $cached = $WRAPPER_CLASS->new(cache => $cache, object => $object);

	# Prime the cache with an undef argument.
	$cached->echo(undef);

	# The zero-arg key (no defined args appended).
	my $collapsed_key = $WRAPPER_CLASS . '::echo::';

	ok(exists $cache->{$collapsed_key},
		'undef arg collapses: key is ...::echo:: (same as the zero-arg key)');

	# Now call with NO argument at all -- should be a false hit.
	$cached->echo();

	my $state = $cached->state();

	TODO: {
		local $TODO = 'DOCUMENTED LIMITATION: foo(undef) and foo() share the same cache entry (see LIMITATIONS in POD)';
		is($state->{misses}{$collapsed_key}, 1,
			'foo() should be a miss when only foo(undef) has been called');
	}
};

# ===========================================================================
# VECTOR 13 -- can() with Hostile Method Name from CGI Input
#
# Exploit: a CGI introspection endpoint might call
#   $cached->can($ENV{QUERY_STRING})
# A hostile method name containing shell chars, XSS, or path segments must not
# be executed -- can() delegates to UNIVERSAL::can which does a simple symbol-
# table lookup, returning undef for any name not defined in the package.
# No eval, no exec, no dynamic dispatch occurs inside can().
# ===========================================================================
subtest 'can() with hostile CGI method names returns undef without side effects' => sub {
	local %ENV = (%ENV, QUERY_STRING => "method=$CMD_INJECT");

	my $cached = _wrapped();

	is($cached->can($CMD_INJECT), undef,
		'can() with shell-injection method name returns undef (no code executed)');
	is($cached->can($XSS_PAYLOAD), undef,
		'can() with XSS method name returns undef');
	is($cached->can($PATH_TRAVERSAL), undef,
		'can() with path-traversal method name returns undef');

	# Sanity: can() on a real method still returns a coderef.
	returns_is($cached->can('new'), { type => 'coderef' },
		'can("new") returns a coderef (positive control)');
};

# ===========================================================================
# VECTOR 14 -- isa() with Hostile Class Name from CGI Input
#
# Exploit: same pattern as can() -- a hostile class name string passed to
# isa() must not trigger eval, file I/O, or AUTOLOAD on the inner object.
# isa() compares with eq/SUPER::isa only.
# ===========================================================================
subtest 'isa() with hostile CGI class names returns false without side effects' => sub {
	local %ENV = (%ENV, HTTP_USER_AGENT => 'EVIL/1.0');

	my $cached = _wrapped();

	ok(!$cached->isa($CMD_INJECT),
		'isa() with shell-injection class name returns false (no code executed)');
	ok(!$cached->isa($XSS_PAYLOAD),
		'isa() with XSS class name returns false');
	ok(!$cached->isa($PATH_TRAVERSAL),
		'isa() with path-traversal class name returns false');

	# Sanity: isa() on the real class name still returns true.
	ok($cached->isa($WRAPPER_CLASS),
		'isa() for the actual wrapper class returns true (positive control)');
};

# ===========================================================================
# VECTOR 15 -- Clone Path: _hits/_misses Stats Bleed Between Requests
#
# Exploit: calling $wrapper->new() (object invocation) shallow-copies all
# hash fields from the original, including the _hits and _misses hash refs.
# The clone and the original share the SAME stats hashes, so a hit or miss
# recorded through one is immediately visible in the other's state().
#
# Under mod_perl or Plack (persistent-process CGI), if two concurrent or
# sequential requests each obtain a clone of the same long-lived wrapper,
# their hit/miss statistics bleed into each other -- an information leak that
# could corrupt rate-limiting, quota enforcement, or observability dashboards.
# ===========================================================================