upload results from the CPAN

upload

CGI-Info

view release on metacpan or search on metacpan

#!/usr/bin/env perl

# White-box function-level tests for CGI::Info.
# One subtest per public method; separate subtests cover each internal helper.
# Uses Test::Mockingbird to isolate the unit under test from its dependencies.

use strict;
use warnings;

use Test::Most;
use Test::Returns;
use Test::Memory::Cycle;
use Readonly;
use Cwd qw(getcwd);
use File::Temp qw(tempdir);
use File::Spec;
use Scalar::Util qw(blessed);
use Test::Mockingbird 0.08 qw(mock mock_scoped mock_return spy restore_all);

# CGI::Info must load cleanly before any mocking
BEGIN { use_ok('CGI::Info') or BAIL_OUT('CGI::Info failed to load') }

# Silence Log::Abstraction's _high_priority stderr for the entire run.
# WAF blocks and validation failures generate expected log output that
# would otherwise pollute harness output; we assert on return values.
mock 'Log::Abstraction::_high_priority' => sub { };

# ============================================================
# Configuration constants -- no magic literals anywhere below
# ============================================================
Readonly my $UPLOAD_SMALL      => 100;
Readonly my $UPLOAD_MAX        => 2048;
Readonly my $UPLOAD_OVERSIZED  => 999_999_999;
Readonly my $GOOD_IP           => '1.2.3.4';
Readonly my $GOOGLEBOT_IP      => '66.249.66.1';
Readonly my $PORT_HTTP         => 80;
Readonly my $PORT_HTTPS        => 443;
Readonly my $STATUS_OK         => 200;
Readonly my $STATUS_FORBIDDEN  => 403;
Readonly my $STATUS_NOT_FOUND  => 404;
Readonly my $STATUS_METHOD_NA  => 405;
Readonly my $STATUS_LENGTH_REQ => 411;
Readonly my $STATUS_TOO_LARGE  => 413;
Readonly my $STATUS_UNPROC     => 422;
Readonly my $UA_IPHONE  => 'Mozilla/5.0 (iPhone; CPU iPhone OS 14_0 like Mac OS X)';
Readonly my $UA_ANDROID => 'Mozilla/5.0 (Linux; Android 10; Pixel 3)';
Readonly my $UA_IPAD    => 'Mozilla/5.0 (iPad; CPU OS 14_0 like Mac OS X)';
Readonly my $UA_DESKTOP => 'Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 Chrome/120';
Readonly my $UA_GBOT         => 'Googlebot/2.1 (+http://www.google.com/bot.html)';
Readonly my $UA_CBOT         => 'ClaudeBot/1.0';
Readonly my $UA_CLAUDE_WEB   => 'Claude-Web/1.0';
Readonly my $UA_GPTBOT       => 'Mozilla/5.0 AppleWebKit/537.36 (KHTML, like Gecko; compatible; GPTBot/1.2; +https://openai.com/gptbot)';
Readonly my $UA_CHATGPT_USER => 'Mozilla/5.0 AppleWebKit/537.36 (KHTML, like Gecko); ChatGPT-User/1.0; +https://openai.com/bot)';
Readonly my $UA_COHERE_AI    => 'cohere-ai/1.0';
# GPTBot UA that also embeds a SQL injection payload: used to verify WAF ordering
Readonly my $UA_GPTBOT_SQL   => 'GPTBot/1.0 SELECT foo AND bar FROM baz';

# %config gathers all constants for Object::Configure-style flexibility
my %config = (
	upload_small      => $UPLOAD_SMALL,
	upload_max        => $UPLOAD_MAX,
	upload_oversized  => $UPLOAD_OVERSIZED,
	good_ip           => $GOOD_IP,
	googlebot_ip      => $GOOGLEBOT_IP,
	port_http         => $PORT_HTTP,
	port_https        => $PORT_HTTPS,
	status_ok         => $STATUS_OK,
	status_forbidden  => $STATUS_FORBIDDEN,
	status_not_found  => $STATUS_NOT_FOUND,
	status_method_na  => $STATUS_METHOD_NA,
	status_length_req => $STATUS_LENGTH_REQ,
	status_too_large  => $STATUS_TOO_LARGE,
	status_unproc     => $STATUS_UNPROC,
	ua_iphone         => $UA_IPHONE,
	ua_android        => $UA_ANDROID,
	ua_ipad           => $UA_IPAD,
	ua_desktop        => $UA_DESKTOP,
	ua_gbot           => $UA_GBOT,
	ua_cbot           => $UA_CBOT,
	ua_claude_web     => $UA_CLAUDE_WEB,
	ua_gptbot         => $UA_GPTBOT,
	ua_chatgpt_user   => $UA_CHATGPT_USER,
	ua_cohere_ai      => $UA_COHERE_AI,
	ua_gptbot_sql     => $UA_GPTBOT_SQL,
);

# ---------------------------------------------------------------------------
# Helper: wipe CGI environment variables and 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();
}

# ============================================================
# 1. new()
# ============================================================

# Basic object construction
subtest 'new() - basic instantiation returns blessed object' => sub {
	plan tests => 2;
	reset_env();
	my $info = CGI::Info->new();
	ok(blessed($info), 'new() returns a blessed reference');
	isa_ok($info, 'CGI::Info');
};

# Hashref argument style
subtest 'new() - hashref args set internal fields' => sub {
	plan tests => 1;
	reset_env();
	my $info = CGI::Info->new({ max_upload_size => $config{upload_small} });
	is($info->{max_upload_size}, $config{upload_small}, 'max_upload_size set via hashref');
};

# Flat hash argument style
subtest 'new() - flat hash args set internal fields' => sub {
	plan tests => 1;
	reset_env();
	my $info = CGI::Info->new(max_upload_size => $config{upload_max});
	is($info->{max_upload_size}, $config{upload_max}, 'max_upload_size set via flat hash');
};

# Clone path merges args over parent, parent unchanged
subtest 'new() - clone overrides field without modifying parent' => sub {
	plan tests => 2;
	reset_env();
	my $orig  = CGI::Info->new(max_upload_size => 999);
	my $clone = $orig->new(max_upload_size => 111);
	is($clone->{max_upload_size}, 111, 'clone has overridden field');
	is($orig->{max_upload_size},  999, 'original object is unchanged');
};

# expect parameter was removed; must croak
subtest 'new() - expect deprecated croak' => sub {
	plan tests => 1;
	reset_env();
	throws_ok {
		CGI::Info->new(expect => [qw(foo)])
	} qr/expect has been deprecated/i, 'expect param causes croak';
};

# CGI::Info::new() (double-colon, undef $class) with 0 params should NOT croak
subtest 'new() - ::new() with 0 params does not croak' => sub {
	plan tests => 2;
	reset_env();
	my $info = eval { CGI::Info::new() };
	ok(!$@, '::new() with no args does not croak');
	ok(blessed($info), '::new() with no args still returns an object');
};

# ::new() with undef class and 1+ params croaks with helpful message
subtest 'new() - ::new() with undef class + params croaks' => sub {
	plan tests => 1;
	reset_env();
	throws_ok {
		CGI::Info::new(undef, max_upload_size => $config{upload_small})
	} qr/use ->new\(\) not ::new\(\)/i, '::new() with undef class + params croaks';
};

# Logger validation: object missing warn/info/error must fail guard
subtest 'new() - logger guard rejects object lacking required methods' => sub {
	plan tests => 2;
	reset_env();
	{
		package NoMethodLogger;
		sub new { bless {}, shift }
		# Deliberately no warn/info/error methods
	}
	my $bad        = NoMethodLogger->new();
	my $would_fail = blessed($bad) && !($bad->can('warn') && $bad->can('info') && $bad->can('error'));
	ok($would_fail, 'object lacking warn/info/error fails logger guard predicate');

	{
		package GoodLogger;
		sub new   { bless {}, shift }
		sub warn  { }
		sub info  { }
		sub error { }
	}
	my $good      = GoodLogger->new();
	my $would_ok  = blessed($good) && $good->can('warn') && $good->can('info') && $good->can('error');
	ok($would_ok, 'object with warn/info/error passes logger guard predicate');
};

# ============================================================
# 2. reset()
# ============================================================

# Class-method reset clears stdin_data
subtest 'reset() - clears stdin_data class variable' => sub {
	plan tests => 1;
	reset_env();
	$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
	$ENV{REQUEST_METHOD}    = 'GET';
	$ENV{QUERY_STRING}      = 'a=1';
	my $info = CGI::Info->new();
	$info->params();
	CGI::Info->reset();
	ok(!defined $CGI::Info::stdin_data, 'reset() clears stdin_data');
};

# Calling reset as object method should not die (it carps)
subtest 'reset() - object-method call does not die' => sub {
	plan tests => 1;
	reset_env();
	my $info = CGI::Info->new();
	local $SIG{__WARN__} = sub { };   # suppress expected carp noise
	lives_ok { $info->reset() } 'reset() called as object method does not die';
};

# ============================================================
# 3. status()
# ============================================================

# Default status is 200 when nothing is set
subtest 'status() - defaults to 200' => sub {

t/function.t view on Meta::CPAN

	ok(!defined $p, 'XSS injection blocked');
	is($info->status(), $config{status_forbidden}, 'status 403 set on XSS');
};

# Directory traversal must be blocked with 403
subtest 'params() - directory traversal blocked with 403' => sub {
	plan tests => 2;
	reset_env();
	$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
	$ENV{REQUEST_METHOD}    = 'GET';
	$ENV{QUERY_STRING}      = 'file=../../etc/passwd';
	my $info = CGI::Info->new();
	my $p = $info->params();
	ok(!defined $p, 'directory traversal blocked');
	is($info->status(), $config{status_forbidden}, 'status 403 set on traversal');
};

# mustleak probe must be blocked with 403
subtest 'params() - mustleak probe blocked with 403' => sub {
	plan tests => 2;
	reset_env();
	$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
	$ENV{REQUEST_METHOD}    = 'GET';
	$ENV{QUERY_STRING}      = 'x=mustleak.com/probe';
	my $info = CGI::Info->new();
	my $p = $info->params();
	ok(!defined $p, 'mustleak probe blocked');
	is($info->status(), $config{status_forbidden}, 'status 403 set on mustleak');
};

# Duplicate keys should be comma-joined
subtest 'params() - duplicate keys comma-joined' => sub {
	plan tests => 1;
	reset_env();
	$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
	$ENV{REQUEST_METHOD}    = 'GET';
	$ENV{QUERY_STRING}      = 'color=red&color=blue';
	my $info = CGI::Info->new();
	my $p = $info->params();
	like($p->{color}, qr/red.*blue|blue.*red/, 'duplicate values are comma-joined');
};

# POST without CONTENT_LENGTH returns undef and sets 411
subtest 'params() - POST missing CONTENT_LENGTH sets 411' => sub {
	plan tests => 2;
	reset_env();
	$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
	$ENV{REQUEST_METHOD}    = 'POST';
	my $info = CGI::Info->new();
	my $p = $info->params();
	ok(!defined $p, 'POST without CONTENT_LENGTH returns undef');
	is($info->status(), $config{status_length_req}, 'status 411 set on missing CONTENT_LENGTH');
};

# POST with oversized body returns undef and sets 413
subtest 'params() - POST oversized body sets 413' => sub {
	plan tests => 2;
	reset_env();
	$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
	$ENV{REQUEST_METHOD}    = 'POST';
	$ENV{CONTENT_LENGTH}    = $config{upload_oversized};
	my $info = CGI::Info->new(max_upload_size => $config{upload_small});
	my $p = $info->params();
	ok(!defined $p, 'oversized POST returns undef');
	is($info->status(), $config{status_too_large}, 'status 413 set on oversized upload');
};

# Non-CGI: ARGV key=value pairs
subtest 'params() - command-line ARGV key=value pairs' => sub {
	plan tests => 2;
	reset_env();
	local @ARGV = ('name=Alice', 'age=30');
	my $info = CGI::Info->new();
	my $p = $info->params();
	is($p->{name}, 'Alice', 'name parsed from ARGV');
	is($p->{age},  '30',    'age parsed from ARGV');
};

# --mobile ARGV flag sets is_mobile
subtest 'params() - --mobile ARGV flag sets is_mobile' => sub {
	plan tests => 1;
	reset_env();
	local @ARGV = ('--mobile', 'x=1');
	my $info = CGI::Info->new();
	$info->params();
	ok($info->is_mobile(), '--mobile flag sets is_mobile');
};

# --robot ARGV flag
subtest 'params() - --robot ARGV flag sets is_robot' => sub {
	plan tests => 1;
	reset_env();
	local @ARGV = ('--robot');
	my $info = CGI::Info->new();
	$info->params();
	ok($info->is_robot(), '--robot flag sets is_robot');
};

# --search-engine ARGV flag
subtest 'params() - --search-engine ARGV flag sets is_search_engine' => sub {
	plan tests => 1;
	reset_env();
	local @ARGV = ('--search-engine');
	my $info = CGI::Info->new();
	$info->params();
	ok($info->is_search_engine(), '--search-engine flag sets is_search_engine');
};

# --tablet ARGV flag
subtest 'params() - --tablet ARGV flag sets is_tablet' => sub {
	plan tests => 1;
	reset_env();
	local @ARGV = ('--tablet');
	my $info = CGI::Info->new();
	$info->params();
	ok($info->is_tablet(), '--tablet flag sets is_tablet');
};

# Second params() call returns the same cached hashref
subtest 'params() - result is cached on second call' => sub {
	plan tests => 1;
	reset_env();
	$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
	$ENV{REQUEST_METHOD}    = 'GET';
	$ENV{QUERY_STRING}      = 'k=v';

t/function.t view on Meta::CPAN


# Falls back to system hostname when no HTTP_HOST
subtest '_find_site_details - falls back to system hostname' => sub {
	plan tests => 2;
	reset_env();
	my $host = CGI::Info->new()->host_name();
	ok(defined $host,  '_find_site_details: host_name defined without env');
	ok(length($host),  '_find_site_details: host_name non-empty without env');
};

# Trailing dot removed from HTTP_HOST
subtest '_find_site_details - strips trailing dot from HTTP_HOST' => sub {
	plan tests => 1;
	reset_env();
	$ENV{HTTP_HOST} = 'example.com.';
	unlike(CGI::Info->new()->host_name(), qr/\.$/, 'trailing dot removed from HTTP_HOST');
};

# ============================================================
# 27. Internal helper: _untaint_filename (white-box)
# ============================================================

# A clean filename with common safe characters is returned
subtest '_untaint_filename - valid filename returned' => sub {
	plan tests => 2;
	reset_env();
	my $info   = CGI::Info->new();
	my $result = $info->_untaint_filename({ filename => 'report_2025-01.pdf' });
	ok(defined $result, '_untaint_filename returns defined for valid filename');
	is($result, 'report_2025-01.pdf', '_untaint_filename returns filename unchanged');
};

# A filename containing a pipe (forbidden) returns undef
subtest '_untaint_filename - pipe character returns undef' => sub {
	plan tests => 1;
	reset_env();
	my $info   = CGI::Info->new();
	my $result = $info->_untaint_filename({ filename => 'bad|file.txt' });
	ok(!defined $result, '_untaint_filename returns undef for filename with pipe');
};

# A filename with a double-quote returns undef
subtest '_untaint_filename - double-quote returns undef' => sub {
	plan tests => 1;
	reset_env();
	my $info   = CGI::Info->new();
	my $result = $info->_untaint_filename({ filename => 'bad"file.txt' });
	ok(!defined $result, '_untaint_filename returns undef for filename with double-quote');
};

# ============================================================
# 28. Internal helper: _create_file_name (white-box)
# ============================================================

# Returns a timestamped filename that does not yet exist on disk
subtest '_create_file_name - returns non-existent timestamped name' => sub {
	plan tests => 3;
	reset_env();
	my $info     = CGI::Info->new();
	my $t_before = time();
	my $result   = $info->_create_file_name({ filename => 'functest_upload' });
	my $t_after  = time();

	# Pattern: 'functest_upload_TIMESTAMP' with optional '_N' collision counter
	like($result, qr/^functest_upload_\d+(_\d+)?$/, 'result matches expected pattern');

	my ($ts) = $result =~ /^functest_upload_(\d+)/;
	ok($ts >= $t_before && $ts <= $t_after + 1, 'embedded timestamp is within current second');
	ok(! -e $result, 'returned path does not already exist on disk');
};

# When the base name already exists, a collision counter is appended
subtest '_create_file_name - appends counter when base name exists' => sub {
	plan tests => 1;
	reset_env();

	my $tmp  = tempdir(CLEANUP => 1);
	my $info = CGI::Info->new();
	my $cwd  = getcwd();

	# Untaint paths: tempdir()/getcwd() return tainted values under -T
	my ($safe_tmp) = $tmp =~ /^(.+)$/;
	my ($safe_cwd) = $cwd =~ /^(.+)$/;

	chdir $safe_tmp or die "Can't chdir to $safe_tmp: $!";

	# Discover the name the function would generate now
	my $first = $info->_create_file_name({ filename => 'coll' });

	# Create that file to force a collision on the next call
	open(my $fh, '>', $first) or die "Can't create $first: $!";
	close($fh);

	# The next call must return a different path
	my $second = $info->_create_file_name({ filename => 'coll' });

	chdir $safe_cwd or die "Can't restore cwd: $!";

	isnt($second, $first, '_create_file_name returns different path when base name exists');
};

# ============================================================
# 29. Internal helpers: _log, _debug, _info, _notice, _trace,
#     _warn, _error  (white-box)
# ============================================================

# _log populates messages array with correct level and message
subtest '_log - populates messages() with correct level' => sub {
	plan tests => 3;
	reset_env();
	my $info = CGI::Info->new();

	$info->_log('warn', 'test warning message');

	my $msgs = $info->messages();
	ok(defined $msgs && scalar @$msgs, '_log adds entry to messages()');
	is($msgs->[-1]->{level},   'warn',                '_log records correct level');
	is($msgs->[-1]->{message}, 'test warning message', '_log records correct message text');
};

# _log with multiple message parts joins them with a space
subtest '_log - multiple parts joined with space' => sub {
	plan tests => 1;
	reset_env();
	my $info = CGI::Info->new();
	$info->_log('info', 'part one', 'part two');
	my $msgs = $info->messages();

( run in 1.549 second using v1.01-cache-2.11-cpan-b16cb0d3907 )