view release on metacpan or  search on metacpan

t/unit.t  view on Meta::CPAN

#!/usr/bin/env perl

# Black-box tests for CGI::Info public API.
# Each subtest exercises only the published contract described in the POD;
# no knowledge of internal implementation is assumed or used.

use strict;
use warnings;

use Test::Most;
use Readonly;
use Test::Mockingbird 0.08 qw(mock mock_scoped);
use File::Temp qw(tempdir);
use File::Spec;
use Scalar::Util qw(blessed);

BEGIN { use_ok('CGI::Info') }

# Silence Log::Abstraction stderr noise from expected WAF/validation log calls.
mock 'Log::Abstraction::_high_priority' => sub { };

# ---------------------------------------------------------------------------
# Helper: wipe CGI environment and reset class state between subtests
# ---------------------------------------------------------------------------
sub reset_env {
	delete $ENV{$_} for qw(
		GATEWAY_INTERFACE REQUEST_METHOD QUERY_STRING CONTENT_TYPE
		CONTENT_LENGTH SCRIPT_NAME SCRIPT_FILENAME DOCUMENT_ROOT
		C_DOCUMENT_ROOT HTTP_HOST SERVER_NAME SSL_TLS_SNI SERVER_PROTOCOL
		SERVER_PORT SCRIPT_URI REMOTE_ADDR HTTP_USER_AGENT HTTP_COOKIE
		HTTP_X_WAP_PROFILE HTTP_SEC_CH_UA_MOBILE HTTP_REFERER IS_MOBILE
		IS_SEARCH_ENGINE IS_AI LOGDIR
	);
	CGI::Info->reset();
	@ARGV = ();
}

# ============================================================
# new()
# ============================================================

subtest 'new() - returns a CGI::Info object' => sub {
	reset_env();
	my $info = new_ok('CGI::Info');
	ok(blessed($info), 'new() returns a blessed object');
	isa_ok($info, 'CGI::Info');
};

subtest 'new() - accepts max_upload_size' => sub {
	reset_env();
	my $info = CGI::Info->new(max_upload_size => 65536);
	isa_ok($info, 'CGI::Info', 'constructed with max_upload_size');
};

subtest 'new() - accepts hashref of arguments' => sub {
	reset_env();
	my $info = CGI::Info->new({ max_upload_size => 65536 });
	isa_ok($info, 'CGI::Info', 'constructed with hashref');
};

subtest 'new() - clones existing object' => sub {
	reset_env();
	my $orig  = CGI::Info->new(max_upload_size => 999);
	my $clone = $orig->new(max_upload_size => 42);
	isa_ok($clone, 'CGI::Info', 'clone is a CGI::Info');
	isnt($orig, $clone, 'clone is a different object');
};

subtest 'new() - expect parameter is deprecated and croaks' => sub {
	reset_env();
	eval { CGI::Info->new(expect => [qw(foo bar)]) };
	like($@, qr/expect has been deprecated/i,
		'expect parameter causes croak with deprecation message');
};

subtest 'new() - auto_load option accepted' => sub {
	reset_env();
	my $info = CGI::Info->new(auto_load => 1);
	isa_ok($info, 'CGI::Info', 'auto_load => 1 accepted');
};

# ============================================================
# reset()
# ============================================================

subtest 'reset() - class method clears cached stdin data' => sub {
	reset_env();
	$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
	$ENV{REQUEST_METHOD}	= 'GET';
	$ENV{QUERY_STRING}	  = 'x=1';
	CGI::Info->new()->params();
	CGI::Info->reset();
	ok(!defined $CGI::Info::stdin_data, 'reset() clears stdin_data');
};

# ============================================================
# script_name()
# POD: returns basename of executing script; not an absolute path
# ============================================================

subtest 'script_name() - returns a non-empty string' => sub {
	reset_env();
	$ENV{SCRIPT_NAME} = '/cgi-bin/myapp.cgi';
	my $name = CGI::Info->new()->script_name();
	ok(defined $name && length $name, 'script_name() returns non-empty string');
};

subtest 'script_name() - does not return an absolute path' => sub {
	reset_env();
	$ENV{SCRIPT_NAME} = '/cgi-bin/myapp.cgi';
	my $name = CGI::Info->new()->script_name();
	unlike($name, qr{^[/\\]}, 'script_name() does not start with path separator');
};

subtest 'script_name() - returns basename only' => sub {
	reset_env();
	$ENV{SCRIPT_NAME} = '/cgi-bin/myapp.cgi';
	my $name = CGI::Info->new()->script_name();
	is($name, 'myapp.cgi', 'script_name() returns basename');
};

# ============================================================
# script_path()
# POD: returns full path name of the script

t/unit.t  view on Meta::CPAN

		age => { type => 'integer', min => 0, max => 150 }
	});
	ok(!defined($p) || !defined($p->{age}),
		'out-of-range value blocked by schema');
};

subtest 'params() - blocks SQL injection, returns undef, status 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 attempt returns undef');
	is($info->status(), 403, 'status 403 on SQL injection');
};

subtest 'params() - blocks XSS injection, returns undef, status 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 attempt returns undef');
	is($info->status(), 403, 'status 403 on XSS');
};

subtest 'params() - blocks directory traversal, status 403' => sub {
	reset_env();
	$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
	$ENV{REQUEST_METHOD}	= 'GET';
	$ENV{QUERY_STRING}	  = 'file=../../etc/passwd';
	my $info = CGI::Info->new();
	ok(!defined $info->params(), 'directory traversal returns undef');
	is($info->status(), 403, 'status 403 on directory traversal');
};

subtest 'params() - blocks mustleak attack, status 403' => sub {
	reset_env();
	$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
	$ENV{REQUEST_METHOD}	= 'GET';
	$ENV{QUERY_STRING}	  = 'x=mustleak.com/probe';
	my $info = CGI::Info->new();
	ok(!defined $info->params(), 'mustleak attack returns undef');
	is($info->status(), 403, 'status 403 on mustleak');
};

subtest 'params() - POST: missing CONTENT_LENGTH => undef + status 411' => sub {
	reset_env();
	$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
	$ENV{REQUEST_METHOD}	= 'POST';
	my $info = CGI::Info->new();
	ok(!defined $info->params(), 'POST without CONTENT_LENGTH returns undef');
	is($info->status(), 411, 'status 411 on missing CONTENT_LENGTH');
};

subtest 'params() - POST: oversized body => undef + status 413' => sub {
	reset_env();
	$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
	$ENV{REQUEST_METHOD}	= 'POST';
	$ENV{CONTENT_LENGTH}	= 999_999_999;
	my $info = CGI::Info->new(max_upload_size => 100);
	ok(!defined $info->params(), 'oversized POST returns undef');
	is($info->status(), 413, 'status 413 on oversized body');
};

subtest 'params() - OPTIONS => undef + status 405' => sub {
	reset_env();
	$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
	$ENV{REQUEST_METHOD}	= 'OPTIONS';
	my $info = CGI::Info->new();
	ok(!defined $info->params(), 'OPTIONS returns undef');
	is($info->status(), 405, 'status 405 on OPTIONS');
};

subtest 'params() - DELETE => undef + status 405' => sub {
	reset_env();
	$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
	$ENV{REQUEST_METHOD}	= 'DELETE';
	my $info = CGI::Info->new();
	ok(!defined $info->params(), 'DELETE returns undef');
	is($info->status(), 405, 'status 405 on DELETE');
};

subtest 'params() - POST XML: body stored under XML key' => sub {
	reset_env();
	my $xml = '<root><item>test</item></root>';
	$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 $p = CGI::Info->new()->params();
	ok(defined $p,		 'XML POST returns a hashref');
	is($p->{XML}, $xml,	'XML body stored under the XML key');
};

subtest 'params() - command-line ARGV pairs parsed (non-CGI)' => sub {
	reset_env();
	local @ARGV = ('city=London', 'country=UK');
	my $p = CGI::Info->new()->params();
	is($p->{city},	'London', 'city from ARGV');
	is($p->{country}, 'UK',	 'country from ARGV');
};

subtest 'params() - second call returns same cached hashref' => sub {
	reset_env();
	$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
	$ENV{REQUEST_METHOD}	= 'GET';
	$ENV{QUERY_STRING}	  = 'k=v';
	my $info = CGI::Info->new();
	my $p1   = $info->params();
	my $p2   = $info->params();
	is($p1, $p2, 'repeated call returns cached hashref');
};

# ============================================================
# param($field)
# POD: returns single parameter value; undef if not present;
#	  warns if field not in allow list;
#	  no arg => delegates to params()
# ============================================================