Email-Abuse-Investigator
view release on metacpan or search on metacpan
- report() URL metadata block with IP/country/org/abuse fields.
- report() domain block with all WHOIS/MX/NS metadata fields, recently-
registered warning, and no-A-record/no-MX fallback lines.
- report() abuse contact note field (ip-whois route).
- report() web-form section with form_paste word-wrap (>ROLE_WRAP_LEN),
form_domain, form_upload, and note fields.
- report() SENDING SOFTWARE section via X-Mailer and X-PHP-Originating-Script.
- report() RECEIVED CHAIN TRACKING IDs section with for/id fields.
- abuse_report_text() with risk flags, originating IP, abuse contacts,
and form contacts with form_domain/form_paste/form_upload.
- report() MIME-encoded Subject header ($decoded ne $v branch).
- unresolved_contacts(): URL with unknown abuse, URL with real abuse,
duplicate URL host, From:/Return-Path:/Sender: filter, Reply-To: not
filtered, already-covered domain, and duplicate domain deduplication.
- form_contacts() DKIM signer and List-Unsubscribe form-only providers
(both https and mailto: variants); Route 3 preemption documented.
- form_contacts() Route 4 bare address (no angle-brackets) in From:.
- abuse_contacts() From: with display-name only (no email addr) skip path.
- risk_assessment() cached-result path (second call returns same hashref).
- form_contacts() Route 3 registrar form-only (markmonitor.com via WHOIS).
- abuse_contacts() Route 3 form-only registrar suppressed from email list.
reference without requiring them to read the full report headers.
3. Stripped the display name from Account provider roles. The role
previously included the full From: header value including the
spammer's chosen display name (e.g. "Account provider (from: Evil
Spammer <spam@gmail.com>)"). The display name is irrelevant to the
abuse report, may contain non-ASCII characters, and makes the merged
role string much longer than necessary. The role now shows only the
email address: "Account provider (from: spam@gmail.com)".
- Fixed Wide character in syswrite error when submitting reports for
messages whose decoded subject line contains non-ASCII characters (e.g.
emoji). submit_abuse_report uses "use utf8" and
"use open qw(:std :encoding(UTF-8))", which causes all string operations
to produce Unicode-flagged strings. Net::SMTP->datasend() calls
syswrite() on a raw socket and cannot handle wide characters.
_build_mime_message() now calls Encode::encode('UTF-8', ...) on the
report body and original message after CRLF normalisation, converting
the internal Unicode strings to raw byte strings before transmission.
Encode is a core module since Perl 5.8 so no new dependency is added.
0.05 Sat Mar 28 11:52:05 EDT 2026
### Arguments
- `$name` (string, required)
The header field name, e.g. `'Subject'`, `'From'`, `'X-Mailer'`.
Comparison is case-insensitive.
### Returns
The raw header value string (not decoded), or `undef` if the named header
is not present. When the same header appears more than once, only the value
of the first occurrence is returned.
### Side Effects
None. Header data is pre-parsed during `parse_email()`.
### Notes
Header values are returned verbatim, including any MIME encoded-word sequences
CHI -- enables cross-message IP/domain result caching
IO::Socket::IP -- enables IPv6 WHOIS connections
Domain::PublicSuffix -- enables accurate eTLD+1 domain normalisation
AnyEvent::DNS -- enables parallel DNS resolution for multiple URL hosts
# LIMITATIONS
- No charset conversion
Body text is stored as raw bytes. Non-ASCII content (UTF-8, Latin-1,
ISO-2022-JP, etc.) is not decoded to Perl's internal Unicode representation.
URL and domain extraction from non-ASCII bodies may miss or misparse content.
Use `Email::MIME` if full charset support is needed.
- Hand-rolled MIME parser
The built-in MIME parser handles common cases but is not a conforming
implementation of RFC 2045/2046. It silently drops parts it cannot decode,
does not handle `message/rfc822` attachments, and does not parse
`Content-Disposition` filenames. Replace with `Email::MIME` or
`MIME::Entity` for production use with untrusted input.
bin/submit_abuse_report view on Meta::CPAN
sub _build_mime_message {
my (%a) = @_;
# Boundary unique per message; must not appear in any part body
my $boundary = sprintf 'arf_report_%s_%d',
strftime('%Y%m%d%H%M%S', gmtime), $$;
# Normalise line endings to CRLF throughout, then encode to raw UTF-8
# bytes. Net::SMTP->datasend() calls syswrite() on a raw socket and
# cannot handle Perl strings with the Unicode flag set (wide characters).
# The body may contain non-ASCII characters (e.g. emoji in decoded subject
# lines) so we must encode explicitly rather than rely on the socket layer.
(my $body_crlf = $a{body}) =~ s/\r?\n/\r\n/g;
my $original_crlf = '';
if (defined $a{original} && length ${ $a{original} }) {
($original_crlf = ${ $a{original} }) =~ s/\r?\n/\r\n/g;
}
my $feedback_report = _build_feedback_report($a{inv});
# ---- Outer envelope headers ----
my @msg;
lib/Email/Abuse/Investigator.pm view on Meta::CPAN
#
# Entry criteria:
# $flag -- accumulator coderef.
#
# Exit status:
# Returns nothing; side effects via $flag closure.
sub _risk_check_identity :Private {
my ($self, $flag) = @_;
my $from_raw = $self->_header_value('from') // '';
my $from_decoded = $self->_decode_mime_words($from_raw);
# Display-name domain spoofing: "PayPal paypal.com" <phish@evil.example>
if ($from_decoded =~ /^"?([^"<]+?)"?\s*<([^>]+)>/) {
my ($display, $addr) = ($1, $2);
while ($display =~ /\b([\w-]+\.(?:com|net|org|io|co|uk|au|gov|edu))\b/gi) {
my $disp_domain = lc $1;
my ($addr_domain) = $addr =~ /\@([\w.-]+)/;
$addr_domain = lc($addr_domain // '');
my $reg_disp = _registrable($disp_domain);
my $reg_addr = _registrable($addr_domain);
if ($reg_disp && $reg_addr && $reg_disp ne $reg_addr) {
$flag->('HIGH', 'display_name_domain_spoof',
"From: display name mentions '$disp_domain' but actual address is <$addr>");
lib/Email/Abuse/Investigator.pm view on Meta::CPAN
my $to = $self->_header_value('to') // '';
if ($to =~ /undisclosed|:;/ || $to eq '') {
$flag->('MEDIUM', 'undisclosed_recipients',
"To: header is '$to' -- message was bulk-sent with hidden recipient list");
}
# MIME-encoded Subject (potential filter evasion)
my $subj_raw = $self->_header_value('subject') // '';
if ($subj_raw =~ /=\?[^?]+\?[BQ]\?/i) {
$flag->('LOW', 'encoded_subject',
"Subject line is MIME-encoded: '$subj_raw' (decoded: '"
. $self->_decode_mime_words($subj_raw) . "')");
}
}
# _risk_check_urls_and_domains( $flag )
#
# Purpose:
# Check embedded URLs for shorteners and plain HTTP, and contact domains
# for recent registration, imminent expiry, and lookalike brand names.
#
lib/Email/Abuse/Investigator.pm view on Meta::CPAN
# Banner header
push @out, '=' x 72;
push @out, " Email::Abuse::Investigator Report (v$VERSION)";
push @out, '=' x 72;
push @out, '';
# Envelope summary -- decode MIME encoded-words for readability
for my $f (qw(from reply-to return-path subject date message-id)) {
my $v = $self->_header_value($f);
next unless defined $v;
my $decoded = $self->_decode_mime_words($v);
my $label = ucfirst($f);
push @out, sprintf(' %-14s : %s', $label,
_sanitise_output($decoded ne $v ? "$decoded [encoded: $v]" : $v));
}
push @out, '';
# Risk assessment section
my $risk = $self->risk_assessment();
push @out, "[ RISK ASSESSMENT: $risk->{level} (score: $risk->{score}) ]";
if (@{ $risk->{flags} }) {
for my $f (@{ $risk->{flags} }) {
push @out, " [$f->{severity}] " . _sanitise_output($f->{detail});
}
lib/Email/Abuse/Investigator.pm view on Meta::CPAN
my ($cte_h) = grep { $_->{name} eq 'content-transfer-encoding' } @headers;
my $ct = defined $ct_h ? $ct_h->{value} : '';
my $cte = defined $cte_h ? $cte_h->{value} : '';
# Decode multipart or single-part body as appropriate
if ($ct =~ /multipart/i) {
my ($boundary) = $ct =~ /boundary="?([^";]+)"?/i;
# Pass depth=0 to enforce the MAX_MULTIPART_DEPTH recursion guard
$self->_decode_multipart($body_raw, $boundary, 0) if $boundary;
} else {
my $decoded = $self->_decode_body($body_raw, $cte);
if ($ct =~ /html/i) { $self->{_body_html} = $decoded }
else { $self->{_body_plain} = $decoded }
}
$self->_debug(sprintf 'Parsed %d headers, %d Received lines',
scalar @headers, scalar @{ $self->{_received} });
# --- Sending software fingerprints ---
# These headers identify the mailer or shared-hosting script that sent
# the message; invaluable for shared-hosting abuse reports.
my %sw_notes = (
'x-php-originating-script' => 'PHP script on shared hosting -- report to hosting abuse team',
lib/Email/Abuse/Investigator.pm view on Meta::CPAN
# Entry criteria:
# $body -- the raw body text of the multipart container.
# $boundary -- the boundary string from the Content-Type header.
# $depth -- current recursion depth (starts at 0 from _split_message).
#
# Exit status:
# Returns undef if $depth >= MAX_MULTIPART_DEPTH (recursion guard).
# Otherwise all results via side effects.
#
# Side effects:
# Appends decoded text to $self->{_body_plain} and $self->{_body_html}.
#
# Notes:
# Whitespace-only MIME segments between boundaries are silently skipped.
# Decoding errors are silenced; raw bytes are used as fallback.
sub _decode_multipart :Private {
my ($self, $body, $boundary, $depth) = @_;
$depth //= 0;
# Enforce the recursion depth limit to prevent stack exhaustion on
lib/Email/Abuse/Investigator.pm view on Meta::CPAN
my ($inner_boundary) = $pct =~ /boundary\s*=\s*"?([^";]+)"?/i;
if ($inner_boundary) {
$inner_boundary =~ s/\s+$//;
# Increment depth counter for the recursion guard
$self->_decode_multipart($pbody, $inner_boundary, $depth + 1);
}
next;
}
# Decode transfer encoding and accumulate by content type
my $decoded = $self->_decode_body($pbody, $pcte);
if ($pct =~ /text\/html/i) { $self->{_body_html} .= $decoded }
elsif ($pct =~ /text/i || !$pct) { $self->{_body_plain} .= $decoded }
}
}
# _decode_body( $body, $cte ) -> string
#
# Purpose:
# Decode a MIME body part according to its Content-Transfer-Encoding.
#
# Entry criteria:
# $body -- raw body string (may be undef).
# $cte -- Content-Transfer-Encoding value string (may be undef).
#
# Exit status:
# Returns the decoded string, or the original string if the encoding is
# 7bit/8bit/binary or unrecognised.
#
# Notes:
# decode_qp and decode_base64 are imported from MIME:: modules; errors
# from malformed content are silenced by the eval wrappers they provide.
sub _decode_body :Private {
my ($self, $body, $cte) = @_;
$cte //= '';
return decode_qp($body) if $cte =~ /quoted-printable/i;
lib/Email/Abuse/Investigator.pm view on Meta::CPAN
return 0;
}
# -----------------------------------------------------------------------
# Private: HTTP/HTTPS URL extraction and resolution
# -----------------------------------------------------------------------
# _extract_and_resolve_urls() -> arrayref of url hashrefs
#
# Purpose:
# Extract all HTTP/HTTPS URLs from the decoded body, resolve each unique
# hostname to an IP, and enrich with WHOIS/RDAP data. Optionally uses
# AnyEvent::DNS to parallelise the DNS resolution step.
#
# Entry criteria:
# $self->{_body_plain} and $self->{_body_html} populated by _split_message().
#
# Exit status:
# Returns an arrayref of url hashrefs (possibly empty).
#
# Side effects:
lib/Email/Abuse/Investigator.pm view on Meta::CPAN
# Resolve relative Location URLs against the current base
if ($loc !~ m{^https?://}i) {
require URI;
$loc = URI->new_abs($loc, $current)->as_string();
}
$final = $loc;
$current = $loc;
} elsif ($res->is_success()) {
# 2xx: inspect body for client-side redirect patterns
my $body = $res->decoded_content() // '';
my $dest;
# <meta http-equiv="refresh" content="N; url=https://...">
if ($body =~ m{<meta[^>]+http-equiv\s*=\s*["']?refresh["']?[^>]+
content\s*=\s*["'][^"']*url\s*=\s*(https?://[^"'\s>]+)}xi) {
$dest = $1;
}
# window.location.replace("...") or window.location.href = "..."
elsif ($body =~ m{window\.location(?:\.replace\s*\(\s*|\.href\s*=\s*)
["'](https?://[^"']+)["']}xi) {
lib/Email/Abuse/Investigator.pm view on Meta::CPAN
return \@results;
}
# _domains_from_text( $text ) -> list of domain strings
#
# Purpose:
# Extract unique domain names from mailto: links and bare user@domain
# addresses in a block of text.
#
# Entry criteria:
# $text -- a defined scalar of decoded body or header text.
#
# Exit status:
# Returns a list of lower-cased domain strings (possibly empty).
sub _domains_from_text :Private {
my ($self, $text) = @_;
my (%seen, @out);
# mailto: links (including HTML-entity-encoded @ signs from QP)
while ($text =~ /mailto:(?:[^@\s<>"]+)@([\w.-]+)/gi) {
lib/Email/Abuse/Investigator.pm view on Meta::CPAN
|| $safe_ip =~ /\A[0-9a-fA-F:]+\z/) {
$self->_debug("_rdap_lookup: malformed IP '$ip' -- skipping");
return {};
}
# Use the ARIN RDAP endpoint; it covers the ARIN region and redirects
# for RIPE/APNIC/LACNIC/AfriNIC allocations.
my $res = eval { $ua->get("https://rdap.arin.net/registry/ip/$safe_ip") };
return {} unless $res && $res->is_success();
my $j = $res->decoded_content();
my %info;
# Extract organisation name from the JSON response
if ($j =~ /"name"\s*:\s*"([^"]+)"/) { $info{org} = $1 }
if ($j =~ /"handle"\s*:\s*"([^"]+)"/) { $info{handle} = $1 }
# Extract abuse email from the vcardArray contact block
if ($j =~ /"abuse".*?"email"\s*:\s*"([^"]+)"/s) {
$info{abuse} = $1;
} elsif ($j =~ /"email"\s*:\s*"([^@"]+@[^"]+)"/) {
lib/Email/Abuse/Investigator.pm view on Meta::CPAN
=item C<$name> (string, required)
The header field name, e.g. C<'Subject'>, C<'From'>, C<'X-Mailer'>.
Comparison is case-insensitive.
=back
=head3 Returns
The raw header value string (not decoded), or C<undef> if the named header
is not present. When the same header appears more than once, only the value
of the first occurrence is returned.
=head3 Side Effects
None. Header data is pre-parsed during C<parse_email()>.
=head3 Notes
Header values are returned verbatim, including any MIME encoded-word sequences
lib/Email/Abuse/Investigator.pm view on Meta::CPAN
my ($net_addr, $prefix) = split m{/}, $cidr;
return 0 if !defined($prefix) || $prefix !~ /^\d+$/ || $prefix > 32;
# Compute the network mask and compare masked network addresses
my $mask = ~0 << (32 - $prefix);
my $net_n = unpack 'N', (inet_aton($net_addr) // return 0);
my $ip_n = unpack 'N', (inet_aton($ip) // return 0);
return ($ip_n & $mask) == ($net_n & $mask);
}
# _decode_mime_words( $str ) -> decoded_string
#
# Purpose:
# Decode MIME encoded-words (=?charset?B/Q?...?=) in a header value
# string for human-readable display in reports.
#
# Entry criteria:
# $str -- a defined header value string; may be undef.
#
# Exit status:
# Returns the decoded string, or '' if $str is undef.
sub _decode_mime_words :Private {
my ($self, $str) = @_;
return '' unless defined $str;
# Replace each encoded-word with its decoded equivalent
$str =~ s/=\?([^?]+)\?([BbQq])\?([^?]*)\?=/_decode_ew($1,$2,$3)/ge;
return $str;
}
# _decode_ew( $charset, $enc, $text ) -> decoded_bytes
#
# Purpose:
# Decode a single MIME encoded-word component (base64 or quoted-printable).
#
# Notes:
# Non-UTF-8 charsets return raw bytes; good enough for display-name spoof
# detection which only needs ASCII matching.
sub _decode_ew :Private {
my ($charset, $enc, $text) = @_;
lib/Email/Abuse/Investigator.pm view on Meta::CPAN
Domain::PublicSuffix -- enables accurate eTLD+1 domain normalisation
AnyEvent::DNS -- enables parallel DNS resolution for multiple URL hosts
=head1 LIMITATIONS
=over 4
=item No charset conversion
Body text is stored as raw bytes. Non-ASCII content (UTF-8, Latin-1,
ISO-2022-JP, etc.) is not decoded to Perl's internal Unicode representation.
URL and domain extraction from non-ASCII bodies may miss or misparse content.
Use C<Email::MIME> if full charset support is needed.
=item Hand-rolled MIME parser
The built-in MIME parser handles common cases but is not a conforming
implementation of RFC 2045/2046. It silently drops parts it cannot decode,
does not handle C<message/rfc822> attachments, and does not parse
C<Content-Disposition> filenames. Replace with C<Email::MIME> or
C<MIME::Entity> for production use with untrusted input.
t/edge_cases.t view on Meta::CPAN
$r = $a->_decode_mime_words(
'=?X-NONEXISTENT-12345?B?' . encode_base64('test','') . '?=')
} 'unknown charset does not die';
ok defined $r, 'unknown charset returns defined value';
};
subtest '_decode_mime_words -- multiple encoded-words in one string' => sub {
my $a = new_ok('Email::Abuse::Investigator');
my $s = '=?UTF-8?B?' . encode_base64('Hello', '') . '?= '
. '=?UTF-8?B?' . encode_base64('World', '') . '?=';
is $a->_decode_mime_words($s), 'Hello World', 'multiple words decoded';
};
# =============================================================================
# 8. MULTIPART -- DEGENERATE STRUCTURES
# =============================================================================
subtest 'multipart -- boundary in Content-Type but absent from body' => sub {
null_net();
my $a = new_ok('Email::Abuse::Investigator');
lives_ok {
t/extended_tests.t view on Meta::CPAN
$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',
t/extended_tests.t view on Meta::CPAN
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
t/function.t view on Meta::CPAN
my $b = Email::Abuse::Investigator->new();
$b->parse_email(make_email(ct => 'text/html', body => '<b>Hi</b>'));
is $b->{_body_html}, '<b>Hi</b>', 'html body stored';
is $b->{_body_plain}, '', 'plain empty for html email';
# QP decode
my $qp = encode_qp("Caf\xE9 menu");
my $c = Email::Abuse::Investigator->new();
$c->parse_email(make_email(ct => 'text/plain', cte => 'quoted-printable',
body => $qp));
like $c->{_body_plain}, qr/Caf/, 'QP decoded body';
# Base64 decode
my $b64 = encode_base64("Base64 content here");
my $d = Email::Abuse::Investigator->new();
$d->parse_email(make_email(ct => 'text/plain', cte => 'base64',
body => $b64));
like $d->{_body_plain}, qr/Base64 content/, 'base64 decoded body';
# multipart/alternative
my $bnd = 'BNDXYZ';
my $mp = "--$bnd\r\nContent-Type: text/plain\r\n\r\nPlain part\r\n"
. "--$bnd\r\nContent-Type: text/html\r\n\r\n<p>HTML part</p>\r\n"
. "--$bnd--\r\n";
my $e = Email::Abuse::Investigator->new();
$e->parse_email(make_email(ct => qq{multipart/alternative; boundary="$bnd"},
cte => '', body => $mp));
like $e->{_body_plain}, qr/Plain part/, 'multipart plain extracted';
t/function.t view on Meta::CPAN
like $g->{_body_plain}, qr/untyped text/, 'untyped part goes to plain';
# multipart with QP sub-part
my $qp_part = encode_qp("QP in multipart");
my $mp_qp = "--$bnd\r\nContent-Type: text/plain\r\n"
. "Content-Transfer-Encoding: quoted-printable\r\n\r\n"
. "${qp_part}--$bnd--\r\n";
my $h = Email::Abuse::Investigator->new();
$h->parse_email(make_email(ct => qq{multipart/alternative; boundary="$bnd"},
body => $mp_qp));
like $h->{_body_plain}, qr/QP in multipart/, 'QP multipart sub-part decoded';
# Header unfolding
my $folded = "From: First\n Last\nSubject: Test\n\nBody";
my $i = Email::Abuse::Investigator->new();
$i->parse_email($folded);
my ($fh) = grep { $_->{name} eq 'from' } @{ $i->{_headers} };
like $fh->{value}, qr/First\s+Last/, 'folded header unfolded';
# No Content-Type header at all
my $j = Email::Abuse::Investigator->new();
t/function.t view on Meta::CPAN
# ===========================================================================
# 4. _decode_body — three branches
# ===========================================================================
note '=== 4. _decode_body ===';
{
my $a = Email::Abuse::Investigator->new();
is $a->_decode_body('plain', '7bit'), 'plain', '7bit passthrough';
is $a->_decode_body('raw', undef), 'raw', 'undef cte passthrough';
like $a->_decode_body('Hello=20world', 'quoted-printable'), qr/Hello world/, 'QP decode';
my $b64 = encode_base64('decoded text');
like $a->_decode_body($b64, 'base64'), qr/decoded text/, 'base64 decode';
}
# ===========================================================================
# 5. _header_value
# ===========================================================================
note '=== 5. _header_value ===';
{
my $a = Email::Abuse::Investigator->new();
$a->parse_email(make_email(subject => 'My Subject'));
is $a->_header_value('subject'), 'My Subject', 'header found';
t/function.t view on Meta::CPAN
}
# ===========================================================================
# 11. _decode_mime_words — B and Q encoding
# ===========================================================================
note '=== 11. _decode_mime_words ===';
{
my $a = Email::Abuse::Investigator->new();
my $b64_word = '=?UTF-8?B?' . encode_base64('eharmony Partner', '') . '?=';
is $a->_decode_mime_words($b64_word), 'eharmony Partner', 'Base64 encoded-word decoded';
my $qp_word = '=?UTF-8?Q?Ready_to_Find_Someone_Special=3F?=';
is $a->_decode_mime_words($qp_word),
'Ready to Find Someone Special?', 'QP encoded-word decoded';
is $a->_decode_mime_words('plain text'), 'plain text', 'plain string unchanged';
is $a->_decode_mime_words(undef), '', 'undef -> empty string';
# Multiple encoded-words
my $multi = '=?UTF-8?B?' . encode_base64('Hello', '') . '?= '
. '=?UTF-8?B?' . encode_base64('World', '') . '?=';
is $a->_decode_mime_words($multi), 'Hello World', 'multiple encoded-words';
# Lowercase specifier
t/function.t view on Meta::CPAN
my $report = $a->report();
like $report, qr/Email::Abuse::Investigator Report/, 'report title';
like $report, qr/RISK ASSESSMENT/, 'risk section';
like $report, qr/ORIGINATING HOST/, 'originating host section';
like $report, qr/120\.88\.161\.249/, 'originating IP';
like $report, qr/EMBEDDED HTTP\/HTTPS URLs/, 'url section';
like $report, qr/URL SHORTENER/, 'shortener warning';
like $report, qr/CONTACT \/ REPLY-TO DOMAINS/, 'domains section';
like $report, qr/WHERE TO SEND ABUSE REPORTS/, 'contacts section';
like $report, qr/Ready to Find Love/, 'encoded subject decoded';
# No-origin path
my $b = Email::Abuse::Investigator->new();
$b->parse_email("From: x\@y.com\nSubject: s\n\nbody");
$b->{_origin} = undef;
$b->{_urls} = [];
$b->{_mailto_domains} = [];
my $r2 = $b->report();
like $r2, qr/could not determine originating IP/, 'no-origin message';
like $r2, qr/none found/, 'no-urls message';
t/function.t view on Meta::CPAN
'firmluminary: all URLs on www.firmluminary.com';
# firmluminary.com in contact domains
my @mdoms = $a->mailto_domains();
my @names = map { $_->{domain} } @mdoms;
ok scalar(grep { $_ eq 'firmluminary.com' } @names),
'firmluminary: firmluminary.com found as domain';
# Decoded From/Subject
my $dfrom = $a->_decode_mime_words($a->_header_value('from') // '');
like $dfrom, qr/eharmony Partner/, 'firmluminary: From decoded';
my $dsubj = $a->_decode_mime_words($a->_header_value('subject') // '');
like $dsubj, qr/Ready to Find Someone Special/, 'firmluminary: Subject decoded';
# Risk: residential IP
my $risk = $a->risk_assessment();
ok any_flag($risk->{flags}, 'residential_sending_ip'),
'firmluminary: residential_sending_ip flagged';
# Abuse contacts: TPG and Cloudflare
my @contacts = $a->abuse_contacts();
ok any_addr(\@contacts, 'abuse@tpg.com.au'), 'firmluminary: TPG abuse contact';
ok any_addr(\@contacts, 'abuse@cloudflare.com'), 'firmluminary: Cloudflare abuse contact';
# Full report
my $report = $a->report();
like $report, qr/eharmony Partner/, 'firmluminary: decoded From in report';
like $report, qr/120\.88\.161\.249/, 'firmluminary: IP in report';
}
# ===========================================================================
# 35. header_value() — public accessor delegates to _header_value()
# ===========================================================================
note '=== 35. header_value() public accessor ===';
{
# Verify the public method is reachable from outside the package and that
# it behaves identically to the private _header_value() it wraps.
t/function.t view on Meta::CPAN
# ===========================================================================
# 43. _decode_ew() — single encoded-word component (B and Q)
# ===========================================================================
note '=== 43. _decode_ew() direct ===';
{
# _decode_ew is a package-level helper, not a method
my $b_payload = encode_base64('Hello World', '');
is Email::Abuse::Investigator::_decode_ew('UTF-8', 'B', $b_payload),
'Hello World', 'B encoding decoded correctly';
# Q encoding: underscore substitutes for space, =HH for other specials
is Email::Abuse::Investigator::_decode_ew('UTF-8', 'Q', 'Hello_World=21'),
'Hello World!', 'Q encoding decoded with _->space and =HH';
# Specifier is case-insensitive per RFC 2047
is Email::Abuse::Investigator::_decode_ew('UTF-8', 'b', $b_payload),
'Hello World', 'lowercase b treated as base64';
is Email::Abuse::Investigator::_decode_ew('UTF-8', 'q', 'test_value'),
'test value', 'lowercase q treated as QP with underscore substitution';
}
# ===========================================================================
t/integration.t view on Meta::CPAN
# Abuse contact for the attacker's IP present
my @contacts = $a->abuse_contacts();
ok scalar(grep { lc($_->{address}) eq 'abuse@attacker-isp.example' } @contacts),
'attacker ISP abuse contact in contacts';
restore_stubs();
};
# ---------------------------------------------------------------------------
# Scenario 9 — MIME-encoded headers decoded in report()
#
# POD synopsis: the full pipeline with MIME-encoded From: and Subject:.
# Verifies that report() shows decoded text, not raw encoded-word strings.
# ---------------------------------------------------------------------------
subtest 'Scenario 9: MIME-encoded From: and Subject: decoded in report' => sub {
restore_stubs();
install_stubs(
rdns => 'mail.sender.example',
resolve => undef,
whois_ip => { org => 'Sender ISP', abuse => 'abuse@sender-isp.example' },
domain_whois => undef,
);
my $enc_from = '=?UTF-8?B?' . encode_base64('eharmony Partner', '') . '?=';
my $enc_subj = '=?UTF-8?B?' . encode_base64('Ready to Find Someone Special?', '') . '?=';
t/integration.t view on Meta::CPAN
$a->parse_email(make_raw_email(
received => 'from sender (sender [91.198.174.1]) by mx.test',
from => qq{"$enc_from" <peacelight\@firmluminary.example>},
subject => $enc_subj,
body => 'Find the joy of real love today.',
));
my $report = $a->report();
# Decoded display name appears in report
like $report, qr/eharmony Partner/, 'decoded From: display name in report';
like $report, qr/Ready to Find Someone Special/, 'decoded Subject in report';
# The decoded form leads; raw encoding appears in brackets after
like $report, qr/eharmony Partner.*\[encoded:/s,
'decoded form appears before the bracketed raw encoded value';
restore_stubs();
};
# ---------------------------------------------------------------------------
# Scenario 10 — Domain intelligence pipeline (POD Algorithm section)
#
# POD: "For each unique non-infrastructure domain … A record → web hosting,
# MX record → mail hosting, NS record → DNS hosting, WHOIS → registrar"
# Simulates a domain whose web host, MX host, and NS host are all different
t/integration.t view on Meta::CPAN
my $risk = $a->risk_assessment();
my @flag_names = map { $_->{flag} } @{ $risk->{flags} };
ok scalar(grep { $_ eq 'encoded_subject' } @flag_names),
'encoded_subject flag raised for MIME-encoded Subject';
my ($es_flag) = grep { $_->{flag} eq 'encoded_subject' } @{ $risk->{flags} };
is $es_flag->{severity}, 'LOW', 'encoded_subject has LOW severity';
like $es_flag->{detail}, qr/Win a free prize today!/,
'flag detail contains the decoded subject text';
# The report should decode and display the subject
my $report = $a->report();
like $report, qr/Win a free prize today!/, 'decoded Subject appears in report';
restore_stubs();
};
# ---------------------------------------------------------------------------
# Scenario 41 — unresolved_contacts() in full pipeline integration
#
# Exercises the unresolved_contacts() method as part of a real end-to-end
# pipeline: no internal state injection, all data flows from parse_email().
# Verifies that a domain with no WHOIS abuse contact surfaces as unresolved
t/integration.t view on Meta::CPAN
my $report = $a->report();
ok defined $report && length($report), 'report() completes without Net::DNS';
restore_stubs();
});
};
# ---------------------------------------------------------------------------
# OD-2: Without HTML::LinkExtor
#
# HTML::LinkExtor parses HTML attributes and returns decoded URLs (e.g.
# & → &). Without it only the plain-text regex pass runs, which matches
# the raw attribute value including HTML entities.
#
# Observable differences:
# • With LinkExtor: 2 URL entries for the same host (decoded + raw entity)
# • Without LinkExtor: 1 URL entry (raw entity form only)
# • The URL string found without LinkExtor contains the literal '&'
# ---------------------------------------------------------------------------
subtest 'OD-2: Without HTML::LinkExtor — HTML entity URLs not decoded; count differs' => sub {
without_optionals(['HTML::LinkExtor'], sub {
install_stubs(
rdns => 'mail.test.example',
resolve => { 'example.com' => '91.198.174.51' },
whois_ip => { org => 'Some ISP', abuse => 'abuse@someisp.example' },
domain_whois => undef,
);
# HTML-only email: the href contains HTML-entity-encoded parameters.
# The plain-text regex finds the raw attribute value (with &).
# HTML::LinkExtor would also find the entity-decoded form (&).
my $html_body = '<a href="https://example.com/page?ref=1&src=email">click</a>';
my $a = Email::Abuse::Investigator->new();
$a->parse_email(make_raw_email(
received => 'from bad (bad [91.198.174.51]) by mx.test',
ct => 'text/html; charset=us-ascii',
body => $html_body,
));
my @urls = $a->embedded_urls();
diag('URLs found: ' . join(', ', map { $_->{url} } @urls)) if $ENV{TEST_VERBOSE};
# Without LinkExtor only the plain-text-regex result is present
is scalar(@urls), 1,
'without HTML::LinkExtor: only plain-text regex result (raw entity form)';
like $urls[0]->{url}, qr/&/,
'URL contains raw HTML entity & (not decoded by LinkExtor)';
unlike $urls[0]->{url}, qr/ref=1&src=/,
'decoded form absent without HTML::LinkExtor';
is $urls[0]->{host}, 'example.com', 'host correctly extracted despite entity';
restore_stubs();
});
};
# With HTML::LinkExtor present the decoded form is ALSO found, giving 2 entries.
# This subtest only runs when LinkExtor IS available.
SKIP: {
skip 'HTML::LinkExtor not installed', 1 unless eval { require HTML::LinkExtor; 1 };
subtest 'OD-2b: With HTML::LinkExtor — entity-decoded AND raw-entity URLs both found' => sub {
restore_stubs();
install_stubs(
rdns => 'mail.test.example',
resolve => { 'example.com' => '91.198.174.51' },
whois_ip => { org => 'Some ISP', abuse => 'abuse@someisp.example' },
domain_whois => undef,
);
my $html_body = '<a href="https://example.com/page?ref=1&src=email">click</a>';
my $a = Email::Abuse::Investigator->new();
$a->parse_email(make_raw_email(
received => 'from bad (bad [91.198.174.51]) by mx.test',
ct => 'text/html; charset=us-ascii',
body => $html_body,
));
my @urls = $a->embedded_urls();
diag('URLs with LinkExtor: ' . join(', ', map { $_->{url} } @urls)) if $ENV{TEST_VERBOSE};
is scalar(@urls), 2,
'with HTML::LinkExtor: 2 URL entries — decoded and raw-entity forms';
my @decoded = grep { $_->{url} =~ /ref=1&src=/ } @urls;
my @raw = grep { $_->{url} =~ /&/ } @urls;
ok scalar(@decoded), 'decoded URL (& not &) present with LinkExtor';
ok scalar(@raw), 'raw entity URL (&) also present from plain-text regex';
restore_stubs();
};
}
# ---------------------------------------------------------------------------
# OD-3: Without LWP::UserAgent (and LWP::ConnCache)
#
# LWP::UserAgent is required by _follow_redirect_chain() (redirect cloaker
t/mutation_survivors.t view on Meta::CPAN
# undef: returns '' exactly
my $r_undef = $a->_decode_mime_words(undef);
is $r_undef, '', '_decode_mime_words(undef) returns empty string exactly';
isnt $r_undef, 1, 'not 1 (negation of empty string)';
# plain string: returned unchanged
my $r_plain = $a->_decode_mime_words('plain text');
is $r_plain, 'plain text', '_decode_mime_words returns plain string unchanged';
# encoded word: returns decoded string
my $enc = '=?UTF-8?B?' . encode_base64('decoded', '') . '?=';
my $r_enc = $a->_decode_mime_words($enc);
is $r_enc, 'decoded', '_decode_mime_words returns decoded string exactly';
isnt $r_enc, '', 'decoded string is not empty (negation)';
};
# =============================================================================
# 41. unresolved_contacts() conditions [COND_INV_1176_3, BOOL_NEGATE_1217_2]
# =============================================================================
subtest 'COND_INV_1176_3 + BOOL_NEGATE_1217_2 -- unresolved_contacts() branches' => sub {
null_net();
no warnings 'redefine';
local *Email::Abuse::Investigator::_domain_whois = sub { undef };
local *Email::Abuse::Investigator::_resolve_host = sub { undef };
is_deeply $b->{_headers}, $a->{_headers},
'scalar and scalar-ref inputs produce same result';
};
subtest 'parse_email() — handles multipart, quoted-printable, base64 bodies' => sub {
my $qp_body = "Caf=C3=A9 au lait";
my $a = Email::Abuse::Investigator->new();
$a->parse_email(make_email(ct => 'text/plain', cte => 'quoted-printable',
body => $qp_body));
like $a->{_body_plain}, qr/Caf/, 'QP body decoded';
my $b64_body = encode_base64("Base64 encoded content here");
my $b = Email::Abuse::Investigator->new();
$b->parse_email(make_email(ct => 'text/plain', cte => 'base64',
body => $b64_body));
like $b->{_body_plain}, qr/Base64 encoded content/, 'base64 body decoded';
my $bnd = 'UNIT_BOUNDARY';
my $mp = "--$bnd\r\nContent-Type: text/plain\r\n\r\nplain text here\r\n"
. "--$bnd\r\nContent-Type: text/html\r\n\r\n<b>html here</b>\r\n"
. "--$bnd--\r\n";
my $c = Email::Abuse::Investigator->new();
$c->parse_email(make_email(
ct => qq{multipart/alternative; boundary="$bnd"},
body => $mp,
));
like $c->{_body_plain}, qr/plain text here/, 'multipart plain part decoded';
like $c->{_body_html}, qr/html here/, 'multipart html part decoded';
};
subtest 'parse_email() — re-parse resets all lazy caches' => sub {
my $a = Email::Abuse::Investigator->new();
$a->parse_email(make_email());
$a->{_origin} = { ip => '0.0.0.0' };
$a->{_urls} = [ { url => 'stale' } ];
$a->{_mailto_domains} = [ { domain => 'stale.example' } ];
$a->{_domain_info} = { 'stale.example' => {} };
$a->{_risk} = { level => 'STALE', score => 99, flags => [] };
no warnings 'redefine';
local *Email::Abuse::Investigator::_domain_whois = sub { undef };
my $a = Email::Abuse::Investigator->new();
$a->parse_email(make_email());
my $r1 = $a->report();
my $r2 = $a->report();
is $r2, $r1, 'report() returns same string on second call';
restore_net();
};
subtest 'report() — envelope headers are decoded and displayed' => sub {
stub_net();
no warnings 'redefine';
local *Email::Abuse::Investigator::_domain_whois = sub { undef };
local *Email::Abuse::Investigator::_resolve_host = sub { undef };
# Use a base64-encoded From: display name (as in the firmluminary spam)
my $enc_from = '=?UTF-8?B?' . encode_base64('eharmony Partner', '') . '?=';
my $enc_subj = '=?UTF-8?B?' . encode_base64('Ready to Find Love', '') . '?=';
my $a = Email::Abuse::Investigator->new();
$a->parse_email(make_email(
from => qq{"$enc_from" <peacelight\@firmluminary.com>},
subject => $enc_subj,
));
my $r = $a->report();
like $r, qr/eharmony Partner/, 'encoded From: display name decoded in report';
like $r, qr/Ready to Find Love/, 'encoded Subject decoded in report';
restore_net();
};
# =============================================================================
# Cross-method: lazy evaluation and re-parse
# =============================================================================
subtest 'parse_email() re-invocation clears all public-method caches' => sub {
stub_net(resolve => '1.2.3.4');
no warnings 'redefine';
( run in 1.030 second using v1.01-cache-2.11-cpan-9169edd2b0e )