view release on metacpan or  search on metacpan

t/integration.t  view on Meta::CPAN

subtest 'Scenario 25: deeply nested multipart message does not die' => sub {
	restore_stubs();
	install_stubs(
		rdns	 => 'mail.deep.example',
		whois_ip => { org => 'Deep ISP', abuse => 'abuse@deep.example' },
		domain_whois => undef,
	);

	# Build a 25-deep multipart/alternative nest
	my $depth = 25;
	my $inner = "Content-Type: text/plain\r\n\r\nDeep text content.\r\n";
	for my $i (1..$depth) {
		my $bnd = "DEEP_BND_$i";
		$inner  = "Content-Type: multipart/alternative; boundary=\"$bnd\"\r\n\r\n"
				. "--$bnd\r\n"
				. $inner
				. "--$bnd--\r\n";
	}

	my $raw = "Received: from deep (deep [91.198.174.1]) by mx.test\n"
			. "From: deep\@deep.example\n"
			. "To: victim\@test.example\n"
			. "Subject: Deep nesting test\n"
			. "Date: Mon, 01 Jan 2024 00:00:00 +0000\n"
			. "Message-ID: <deep\@deep.example>\n"
			. "Content-Type: multipart/alternative; boundary=\"DEEP_BND_0\"\n"
			. "\n"
			. "--DEEP_BND_0\r\n"
			. $inner
			. "--DEEP_BND_0--\r\n";

	my $a = Email::Abuse::Investigator->new();

	# Silence the expected depth-limit carp() messages during this subtest.
	# carp() is a plain function; replacing it locally with a no-op suppresses
	# the 20 "nesting depth limit exceeded" warnings that would otherwise clutter
	# the test output.  The local() unwinds automatically at the end of the block.
	{
		no warnings 'redefine';
		local *Carp::carp = sub {};   # no-op: swallow expected carp output

		# The module must not die on a deeply nested message
		eval { $a->parse_email($raw) };
		is $@, '', 'parse_email() does not die on deeply nested multipart';
	}

	# Public methods must still work and return safe values
	my @urls  = eval { $a->embedded_urls() };
	my @doms  = eval { $a->mailto_domains() };
	my $risk  = eval { $a->risk_assessment() };
	is $@, '', 'public methods work after deeply nested parse';
	ok defined $risk, 'risk_assessment() returns a defined value';

	restore_stubs();
};

# ---------------------------------------------------------------------------
# Scenario 26 — Object::Configure integration
#
# new() calls Object::Configure::configure($class, $params) and applies any
# values it returns as overlays.  These tests stub configure() to confirm the
# call is made with the correct arguments and that overlaid values take effect.
# ---------------------------------------------------------------------------
subtest 'Scenario 26a: Object::Configure — configure() called with correct args' => sub {
	restore_stubs();

	my @calls;
	{
		no warnings 'redefine';
		local *Object::Configure::configure = sub {
			push @calls, { class => $_[0], params => $_[1] };
			return $_[1];   # pass through unchanged
		};

		Email::Abuse::Investigator->new(timeout => 15);
		ok scalar @calls > 0,
			'Object::Configure::configure() called during new()';
		is $calls[0]{class}, 'Email::Abuse::Investigator',
			'configure() receives the correct class name';
		is ref($calls[0]{params}), 'HASH',
			'configure() receives a hashref of constructor params';
		is $calls[0]{params}{timeout}, 15,
			'constructor param timeout=15 passed through to configure()';
	}

	restore_stubs();
};

subtest 'Scenario 26b: Object::Configure — overlaid values applied by new()' => sub {
	restore_stubs();

	{
		no warnings 'redefine';
		local *Object::Configure::configure = sub {
			# Simulate a config file that overrides timeout to 99
			return { %{ $_[1] }, timeout => 99 };
		};

		my $a = Email::Abuse::Investigator->new();
		is $a->{timeout}, 99,
			'timeout overlaid to 99 by Object::Configure::configure()';
	}

	restore_stubs();
};

subtest 'Scenario 26c: Object::Configure — passthrough preserves constructor defaults' => sub {
	restore_stubs();

	{
		no warnings 'redefine';
		local *Object::Configure::configure = sub { return $_[1] };

		my $a = Email::Abuse::Investigator->new();
		is $a->{timeout}, 10,  'default timeout 10 preserved with passthrough configure';
		is $a->{verbose},  0,  'default verbose 0 preserved with passthrough configure';
		is_deeply $a->{trusted_relays}, [], 'default trusted_relays [] preserved';
	}

	restore_stubs();
};

# =============================================================================
# Object::Configure integration contract
# =============================================================================
subtest 'new() — Object::Configure::configure() is called' => sub {
	my @calls;
	{
		no warnings 'redefine';
		local *Object::Configure::configure = sub {
			push @calls, { class => $_[0], params => $_[1] };
			return $_[1];
		};
		my $a = Email::Abuse::Investigator->new(timeout => 7);
		ok scalar @calls > 0, 'Object::Configure::configure() called during new()';
		is $calls[0]{class}, 'Email::Abuse::Investigator',
			'configure() receives correct class name';
		is ref($calls[0]{params}), 'HASH', 'configure() receives hashref';
	}
};

subtest 'new() — Object::Configure overlay takes effect' => sub {
	{
		no warnings 'redefine';
		local *Object::Configure::configure = sub {
			return { %{ $_[1] }, timeout => 42, verbose => 1 };
		};
		my $a = Email::Abuse::Investigator->new();
		is $a->{timeout}, 42, 'configure() overlay applied to timeout';
		is $a->{verbose},  1, 'configure() overlay applied to verbose';
	}
};


# ---------------------------------------------------------------------------
# Scenario 27 — CHI cross-message cache: WHOIS not repeated across objects
#
# When CHI is installed, the second object analysing the same IP should hit
# the class-level cache and not repeat the WHOIS lookup.
# ---------------------------------------------------------------------------
subtest 'Scenario 27: CHI cross-message cache — WHOIS result shared between objects' => sub {
	restore_stubs();

	# Only meaningful when CHI is available
	my $cache_available = defined $Email::Abuse::Investigator::_cache;
	if (!$cache_available) {
		pass 'CHI not installed — skipping cross-object cache scenario';
		return;
	}

	# Use a unique IP that cannot already be in the cache from other subtests
	my $unique_ip = '91.198.174.' . (50 + ($$ % 100));
	my $whois_calls = 0;

	install_stubs(
		rdns	 => 'mail.chi-test.example',
		resolve  => sub { $unique_ip },
		whois_ip => sub { $whois_calls++; { org => 'CHI Test', abuse => 'abuse@chi.example' } },
		domain_whois => undef,
	);

	# First object: populates the CHI cache for $unique_ip
	my $a = Email::Abuse::Investigator->new();
	$a->parse_email(make_raw_email(
		received => "from h (h [$unique_ip]) by mx.test",
		body	 => "https://chi-test-$$.example/page",
	));
	$a->originating_ip();	# triggers WHOIS
	my $calls_after_first = $whois_calls;

	# Second object on the same IP: should hit the CHI cache
	my $b = Email::Abuse::Investigator->new();
	$b->parse_email(make_raw_email(
		received => "from h (h [$unique_ip]) by mx.test",
		body	 => "https://chi-test-$$.example/page",
	));
	$b->originating_ip();

	ok $whois_calls <= $calls_after_first + 1,
		'second object WHOIS call count does not increase (CHI cache hit)';

	restore_stubs();
};

# ---------------------------------------------------------------------------
# Scenario 28 — _resolve_host AAAA fallback (IPv6 DNS)
#
# When A query fails, _resolve_host should return an IPv6 address from AAAA.
# We stub the method to simulate the A-fail / AAAA-success path.
# ---------------------------------------------------------------------------