view release on metacpan or  search on metacpan

t/extended_tests.t  view on Meta::CPAN

	ok scalar(grep { /badshamart\.example/ } @hosts),
		'correct hostname extracted from nested HTML part';
	restore_net();
};

subtest 'nested MIME: three levels deep -- URLs still extracted' => sub {
	# Ensure recursion handles arbitrary nesting depth, not just two levels.
	null_net();
	my $b1 = 'boundary_level1';
	my $b2 = 'boundary_level2';
	my $b3 = 'boundary_level3';

	my $level3 = join("\r\n",
		"--$b3",
		'Content-Type: text/html; charset=us-ascii',
		'',
		'<a href="https://deep.nested.example/path">deep link</a>',
		"--${b3}--",
		'',
	);
	my $level2 = join("\r\n",
		"--$b2",
		"Content-Type: multipart/alternative; boundary=\"$b3\"",
		'',
		$level3,
		"--${b2}--",
		'',
	);
	my $level1 = join("\r\n",
		"--$b1",
		"Content-Type: multipart/related; boundary=\"$b2\"",
		'',
		$level2,
		"--${b1}--",
		'',
	);

	my $raw = join("\r\n",
		'Received: from ext (ext [198.51.100.1]) by mx.nigelhorne.com with ESMTP',
		'From: Spammer <spam@spammer.example>',
		'To: <victim@nigelhorne.com>',
		'Subject: Deep nesting test',
		'Date: ' . POSIX::strftime('%a, %d %b %Y %H:%M:%S +0000', gmtime),
		'Message-ID: <deep@test>',
		"Content-Type: multipart/mixed; boundary=\"$b1\"",
		'',
		$level1,
	);

	my $a = new_ok('Email::Abuse::Investigator');
	$a->parse_email($raw);

	my @urls = $a->embedded_urls();
	ok scalar(@urls) > 0,
		'embedded_urls() finds URLs three MIME levels deep';
	ok scalar(grep { $_->{host} eq 'deep.nested.example' } @urls),
		'correct hostname extracted from three-level nested part';
	restore_net();
};

subtest 'nested MIME: non-multipart sibling parts still decoded' => sub {
	# A multipart/mixed with one attachment part and one multipart/alternative
	# part -- the attachment must be skipped cleanly and the alternative decoded.
	null_net();
	my $outer = 'outer_sib_001';
	my $inner = 'inner_sib_001';

	my $body = join("\r\n",
		"--$outer",
		'Content-Type: application/octet-stream',
		'Content-Disposition: attachment; filename="file.bin"',
		'',
		'binarydata',
		"--$outer",
		"Content-Type: multipart/alternative; boundary=\"$inner\"",
		'',
		"--$inner",
		'Content-Type: text/plain',
		'',
		'Plain sibling text.',
		"--$inner",
		'Content-Type: text/html',
		'',
		'<a href="https://sibling.example/link">click</a>',
		"--${inner}--",
		'',
		"--${outer}--",
		'',
	);

	my $raw = join("\r\n",
		'Received: from ext (ext [198.51.100.1]) by mx.nigelhorne.com with ESMTP',
		'From: Spammer <spam@spammer.example>',
		'To: <victim@nigelhorne.com>',
		'Subject: Sibling parts test',
		'Date: ' . POSIX::strftime('%a, %d %b %Y %H:%M:%S +0000', gmtime),
		'Message-ID: <sib@test>',
		"Content-Type: multipart/mixed; boundary=\"$outer\"",
		'',
		$body,
	);

	my $a = new_ok('Email::Abuse::Investigator');
	$a->parse_email($raw);

	my @urls = $a->embedded_urls();
	ok scalar(grep { $_->{host} eq 'sibling.example' } @urls),
		'URL in multipart/alternative sibling of attachment part is found';
	restore_net();
};

# =============================================================================
# 39. Regression: abuse_contacts() role merging (0.04 fix)
#	 Before the fix, duplicate addresses from multiple discovery routes
#	 were silently dropped; now they accumulate into roles/role.
# =============================================================================

subtest 'abuse_contacts role merging -- roles arrayref accumulates all routes' => sub {
	# Arrange a message where the same provider (Google) is found via two
	# distinct routes: as the sending ISP (rDNS match) and as a URL host.
	# Both roles must appear in the merged entry.
	null_net();
	my $a = new_ok('Email::Abuse::Investigator');

t/extended_tests.t  view on Meta::CPAN

		'abuse_report_text() form contact has Form line';
	like $art, qr/Paste\s+:/,
		'abuse_report_text() form contact has Paste line (form_paste set)';
	like $art, qr/Upload\s+:/,
		'abuse_report_text() form contact has Upload line (form_upload set)';
};

subtest 'abuse_report_text() -- with risk flags' => sub {
	# Ensure the RED FLAGS block in abuse_report_text() is exercised. Use a
	# free-webmail From: (gmail) to trigger the free_webmail risk flag.
	no warnings 'redefine';
	local *Email::Abuse::Investigator::_reverse_dns  = sub { undef };
	local *Email::Abuse::Investigator::_resolve_host = sub { undef };
	local *Email::Abuse::Investigator::_whois_ip     = sub { {} };
	local *Email::Abuse::Investigator::_domain_whois = sub { undef };
	local *Email::Abuse::Investigator::_rdap_lookup  = sub { {} };
	local *Email::Abuse::Investigator::_raw_whois    = sub { undef };

	my $a = new_ok('Email::Abuse::Investigator');
	$a->parse_email(make_email(
		from => 'Spammer <spam@gmail.com>',
		to   => '<victim@nigelhorne.com>',
		body => 'Buy now.',
	));
	my $art = $a->abuse_report_text();
	like $art, qr/RED FLAGS IDENTIFIED/,
		'abuse_report_text() RED FLAGS section present when flags exist';
	like $art, qr/RISK LEVEL:/,
		'abuse_report_text() contains RISK LEVEL line';
};

subtest 'abuse_report_text() -- with originating IP and abuse contacts' => sub {
	# Exercises the ORIGINATING IP and ABUSE CONTACTS blocks.
	no warnings 'redefine';
	local *Email::Abuse::Investigator::_reverse_dns  = sub { 'mail.evil.example' };
	local *Email::Abuse::Investigator::_resolve_host = sub { undef };
	local *Email::Abuse::Investigator::_whois_ip     = sub {
		{ org => 'Evil Corp', abuse => 'abuse@evil.example' }
	};
	local *Email::Abuse::Investigator::_domain_whois = sub { undef };
	local *Email::Abuse::Investigator::_rdap_lookup  = sub { {} };
	local *Email::Abuse::Investigator::_raw_whois    = sub { undef };

	my $a = new_ok('Email::Abuse::Investigator');
	$a->parse_email(make_email(
		received => 'from evil.example (evil.example [91.198.174.20])'
		          . ' by mx.nigelhorne.com with ESMTP',
		to       => '<victim@nigelhorne.com>',
		body     => 'Buy now.',
	));
	my $art = $a->abuse_report_text();
	like $art, qr/ORIGINATING IP:\s+91\.198\.174\.20/,
		'abuse_report_text() ORIGINATING IP line present';
	like $art, qr/NETWORK OWNER:\s+Evil Corp/,
		'abuse_report_text() NETWORK OWNER line present';
	like $art, qr/ABUSE CONTACTS:/,
		'abuse_report_text() ABUSE CONTACTS section present';
};

# =============================================================================
# 56. report() -- MIME-encoded subject header: $decoded ne $v branch
#
# When a header value contains RFC 2047 encoded-words, _decode_mime_words()
# returns a different string. The ternary in report() appends
# "  [encoded: $v]" to show the original alongside the decoded value.
# =============================================================================

subtest 'report() -- MIME-encoded Subject shows decoded and original' => sub {
	no warnings 'redefine';
	local *Email::Abuse::Investigator::_reverse_dns  = sub { undef };
	local *Email::Abuse::Investigator::_resolve_host = sub { undef };
	local *Email::Abuse::Investigator::_whois_ip     = sub { {} };
	local *Email::Abuse::Investigator::_domain_whois = sub { undef };
	local *Email::Abuse::Investigator::_rdap_lookup  = sub { {} };
	local *Email::Abuse::Investigator::_raw_whois    = sub { undef };

	# =?UTF-8?B?...?= encodes "Special Offer"
	my $encoded_subj = '=?UTF-8?B?U3BlY2lhbCBPZmZlcg==?=';
	my $a = new_ok('Email::Abuse::Investigator');
	$a->parse_email(make_email(
		to      => '<victim@nigelhorne.com>',
		subject => $encoded_subj,
		body    => 'Buy now.',
	));
	my $rpt = $a->report();
	like $rpt, qr/Special Offer/,
		'report() shows decoded value of MIME-encoded Subject';
	like $rpt, qr/\[encoded:.*=\?UTF-8\?B\?/,
		'report() appends [encoded: original] suffix for encoded Subject';
};

# =============================================================================
# 57. unresolved_contacts() -- all branch paths
#
# Target the branches:
#  a) URL with abuse = "(unknown)" -> covered check false -> appears in result
#  b) URL with real abuse -> covered -> NOT in result
#  c) Duplicate URL bare host -> seen{"url:$bare"}++ fires
#  d) Domain from From:/Return-Path:/Sender: header -> skipped by source filter
#  e) Domain from Reply-To: header -> NOT skipped
#  f) Domain already covered by abuse_contacts() -> not in result
#  g) unless ($dom) -> fires when form_contacts entry has no address / form_domain
# =============================================================================

subtest 'unresolved_contacts() -- URL with unknown abuse appears unresolved' => sub {
	# _whois_ip returning {} means $u->{abuse} is absent (set to '(unknown)' by
	# _extract_and_resolve_urls). The covered-check in unresolved_contacts is
	# false, so the URL host appears in the unresolved list.
	no warnings 'redefine';
	local *Email::Abuse::Investigator::_reverse_dns  = sub { undef };
	local *Email::Abuse::Investigator::_resolve_host = sub { '1.2.3.4' };
	local *Email::Abuse::Investigator::_whois_ip     = sub { {} };
	local *Email::Abuse::Investigator::_domain_whois = sub { undef };
	local *Email::Abuse::Investigator::_rdap_lookup  = sub { {} };
	local *Email::Abuse::Investigator::_raw_whois    = sub { undef };

	my $a = new_ok('Email::Abuse::Investigator');
	$a->parse_email(make_email(
		to   => '<victim@nigelhorne.com>',
		body => 'Visit https://unknown-isp-host.example/offer now',
	));
	my @u = $a->unresolved_contacts();
	my ($entry) = grep { $_->{domain} =~ /unknown-isp-host/ } @u;
	ok defined $entry,
		'URL host with unknown abuse appears in unresolved_contacts()';
	is $entry->{type}, 'url_host',
		'entry type is url_host';
};

subtest 'unresolved_contacts() -- URL with real abuse not in unresolved' => sub {
	# When $u->{abuse} is a real address (not "(unknown)"), covered{$bare} is
	# incremented and the host is suppressed from the unresolved list.
	no warnings 'redefine';
	local *Email::Abuse::Investigator::_reverse_dns  = sub { undef };
	local *Email::Abuse::Investigator::_resolve_host = sub { '5.6.7.8' };
	local *Email::Abuse::Investigator::_whois_ip     = sub {
		{ abuse => 'abuse@known-isp.example' }
	};
	local *Email::Abuse::Investigator::_domain_whois = sub { undef };
	local *Email::Abuse::Investigator::_rdap_lookup  = sub { {} };
	local *Email::Abuse::Investigator::_raw_whois    = sub { undef };

	my $a = new_ok('Email::Abuse::Investigator');
	$a->parse_email(make_email(
		to   => '<victim@nigelhorne.com>',
		body => 'Visit https://covered-host.example/offer now',
	));