view release on metacpan or  search on metacpan

t/path.t  view on Meta::CPAN

	my $orig  = CGI::Info->new(logger => Test::Log::Abstraction->new());
	my $clone = $orig->new();
	isa_ok($clone, 'CGI::Info', 'clone is CGI::Info');
	isnt($orig,  $clone, 'clone is different reference');
	ok(!exists($clone->{paramref}), 'clone has no cached paramref');
};

subtest 'new N8: clone has a logger after construction' => sub {
	plan tests => 1;
	local %ENV;
	my $orig  = CGI::Info->new(logger => Test::Log::Abstraction->new());
	my $clone = $orig->new();
	ok(defined($clone->{logger}), 'clone has a logger');
};

subtest 'new N9: clone with expect → croak' => sub {
	plan tests => 1;
	local %ENV;
	my $orig = CGI::Info->new(logger => Test::Log::Abstraction->new());
	throws_ok { $orig->new(expect => ['x']) }
		qr/expect has been deprecated/,
		'clone with expect croaks';
};

subtest 'new N10: clone drops cached paramref so new allow schema is applied' => sub {
	plan tests => 2;
	local %ENV = (
		GATEWAY_INTERFACE => 'CGI/1.1',
		REQUEST_METHOD    => 'GET',
		QUERY_STRING      => 'foo=1',
	);
	CGI::Info->reset();
	my $orig = CGI::Info->new(logger => Test::Log::Abstraction->new());
	$orig->params();
	ok($orig->{paramref}, 'original has paramref after params()');
	my $clone = $orig->new(allow => { foo => qr/^\d+$/ });
	ok(!exists($clone->{paramref}), 'paramref absent in clone');
};

# ===========================================================================
# params() — request-method dispatch paths
# ===========================================================================

subtest 'params P1: cache hit returns same ref' => sub {
	plan tests => 1;
	local %ENV = (
		GATEWAY_INTERFACE => 'CGI/1.1',
		REQUEST_METHOD    => 'GET',
		QUERY_STRING      => 'a=1',
	);
	CGI::Info->reset();
	my $info = CGI::Info->new(logger => Test::Log::Abstraction->new());
	my $r1 = $info->params();
	my $r2 = $info->params();
	is($r1, $r2, 'second params() call returns same cached ref');
};

subtest 'params P2: no CGI env, no ARGV, no stdin → undef' => sub {
	plan tests => 1;
	local %ENV;
	local @ARGV = ();
	CGI::Info->reset();
	my $info = CGI::Info->new(logger => Test::Log::Abstraction->new());
	is($info->params(), undef, 'no CGI env → undef');
};

subtest 'params P3: no CGI env, ARGV --robot sets is_robot' => sub {
	plan tests => 1;
	local %ENV;
	local @ARGV = ('--robot', 'k=v');
	CGI::Info->reset();
	my $info = CGI::Info->new(logger => Test::Log::Abstraction->new());
	$info->params();
	ok($info->{is_robot}, '--robot flag sets is_robot');
};

subtest 'params P4: no CGI env, ARGV --mobile sets is_mobile' => sub {
	plan tests => 1;
	local %ENV;
	local @ARGV = ('--mobile', 'k=v');
	CGI::Info->reset();
	my $info = CGI::Info->new(logger => Test::Log::Abstraction->new());
	$info->params();
	ok($info->{is_mobile}, '--mobile flag sets is_mobile');
};

subtest 'params P5: no CGI env, ARGV --search-engine sets is_search_engine' => sub {
	plan tests => 1;
	local %ENV;
	local @ARGV = ('--search-engine', 'k=v');
	CGI::Info->reset();
	my $info = CGI::Info->new(logger => Test::Log::Abstraction->new());
	$info->params();
	ok($info->{is_search_engine}, '--search-engine flag sets is_search_engine');
};

subtest 'params P6: no CGI env, ARGV --tablet sets is_tablet' => sub {
	plan tests => 1;
	local %ENV;
	local @ARGV = ('--tablet', 'k=v');
	CGI::Info->reset();
	my $info = CGI::Info->new(logger => Test::Log::Abstraction->new());
	$info->params();
	ok($info->{is_tablet}, '--tablet flag sets is_tablet');
};

subtest 'params P7: GET with no QUERY_STRING → undef' => sub {
	plan tests => 1;
	local %ENV = (
		GATEWAY_INTERFACE => 'CGI/1.1',
		REQUEST_METHOD    => 'GET',
	);
	CGI::Info->reset();
	my $info = CGI::Info->new(logger => Test::Log::Abstraction->new());
	is($info->params(), undef, 'GET with no QUERY_STRING → undef');
};

subtest 'params P8: GET + multipart (no REMOTE_ADDR) → 501 + undef' => sub {
	plan tests => 2;
	local %ENV = (
		GATEWAY_INTERFACE => 'CGI/1.1',
		REQUEST_METHOD    => 'GET',
		QUERY_STRING      => 'x=1',
		CONTENT_TYPE      => 'multipart/form-data',
	);
	CGI::Info->reset();
	my $info = CGI::Info->new(logger => Test::Log::Abstraction->new());
	is($info->params(), undef, 'multipart GET → undef');
	is($info->status(), 501,   'status 501 set');
};

subtest 'params P9: GET + multipart + REMOTE_ADDR → IP in warning' => sub {
	plan tests => 1;
	local %ENV = (
		GATEWAY_INTERFACE => 'CGI/1.1',
		REQUEST_METHOD    => 'GET',
		QUERY_STRING      => 'x=1',
		CONTENT_TYPE      => 'multipart/form-data',
		REMOTE_ADDR       => $REMOTE_IP,
	);
	CGI::Info->reset();
	my $info = CGI::Info->new(logger => Test::Log::Abstraction->new());
	$info->params();
	my @w = warns_from($info);
	like($w[0]{message}, qr/$REMOTE_IP/, 'IP present in warning when REMOTE_ADDR set');
};

subtest 'params P10: POST missing CONTENT_LENGTH → 411' => sub {
	plan tests => 2;
	local %ENV = (
		GATEWAY_INTERFACE => 'CGI/1.1',
		REQUEST_METHOD    => 'POST',
		CONTENT_TYPE      => 'application/x-www-form-urlencoded',
	);
	CGI::Info->reset();
	my $info = CGI::Info->new(logger => Test::Log::Abstraction->new());
	is($info->params(), undef, 'missing CONTENT_LENGTH → undef');
	is($info->status(), 411,   'status 411');
};