Email-Abuse-Investigator
view release on metacpan or search on metacpan
t/function.t view on Meta::CPAN
timeout => 30,
verbose => 1,
trusted_relays => ['10.0.0.0/8'],
);
is $b->{timeout}, 30, 'custom timeout stored';
is $b->{verbose}, 1, 'custom verbose stored';
is_deeply $b->{trusted_relays}, ['10.0.0.0/8'], 'custom trusted_relays stored';
}
# ===========================================================================
# 2. parse_email — scalar / scalar-ref / cache reset
# ===========================================================================
note '=== 2. parse_email ===';
{
my $raw = make_email();
my $a = new_ok('Email::Abuse::Investigator');
my $ret = $a->parse_email($raw);
is $ret, $a, 'parse_email returns $self';
is $a->{_raw}, $raw, '_raw stored';
ok @{ $a->{_headers} } > 0, 'headers parsed';
# scalar-ref input
my $b = Email::Abuse::Investigator->new();
$b->parse_email(\$raw);
is_deeply $b->{_headers}, $a->{_headers}, 'scalar-ref gives same headers';
# re-parse clears caches
$a->{_origin} = { ip => '1.2.3.4' };
$a->{_urls} = [{ url => 'old' }];
$a->{_mailto_domains} = [{ domain => 'old.example' }];
$a->{_domain_info} = { 'old.example' => {} };
$a->parse_email(text => $raw);
is $a->{_origin}, undef, 're-parse clears _origin';
is $a->{_urls}, undef, 're-parse clears _urls';
is $a->{_mailto_domains}, undef, 're-parse clears _mailto_domains';
is_deeply $a->{_domain_info}, {}, 're-parse clears _domain_info';
}
# ===========================================================================
# 3. _split_message — all body-type branches
# ===========================================================================
note '=== 3. _split_message ===';
{
# Plain text
my $a = Email::Abuse::Investigator->new();
$a->parse_email(make_email(body => "Hello\nworld"));
is $a->{_body_plain}, "Hello\nworld", 'plain text stored';
is $a->{_body_html}, '', 'html empty for plain email';
# HTML content-type
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';
like $e->{_body_html}, qr/HTML part/, 'multipart html extracted';
# multipart part with no body (skip branch)
my $mp_nobody = "--$bnd\r\n\r\n--$bnd--\r\n";
my $f = Email::Abuse::Investigator->new();
$f->parse_email(make_email(ct => qq{multipart/alternative; boundary="$bnd"},
body => $mp_nobody));
pass 'multipart with bodyless part does not die';
# multipart part with no Content-Type -> plain fallback
my $mp_notype = "--$bnd\r\nX-Foo: bar\r\n\r\nuntyped text\r\n--$bnd--\r\n";
my $g = Email::Abuse::Investigator->new();
$g->parse_email(make_email(ct => qq{multipart/alternative; boundary="$bnd"},
body => $mp_notype));
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();
$j->parse_email("From: x\@y.com\nSubject: s\n\nbody text");
is $j->{_body_plain}, 'body text', 'absent Content-Type defaults to plain';
}
# ===========================================================================
# 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';
is $a->_header_value('Subject'), 'My Subject', 'case-insensitive lookup';
is $a->_header_value('x-none'), undef, 'missing header -> undef';
}
# ===========================================================================
# 6. _is_private — every range + edge cases
# ===========================================================================
note '=== 6. _is_private ===';
{
my $a = Email::Abuse::Investigator->new();
ok $a->_is_private('127.0.0.1'), 'loopback';
ok $a->_is_private('10.0.0.1'), '10/8 low';
ok $a->_is_private('10.255.255.255'), '10/8 high';
ok $a->_is_private('192.168.1.1'), '192.168/16';
ok $a->_is_private('172.16.0.1'), '172.16/12 low';
ok $a->_is_private('172.31.255.255'), '172.31/12 high';
ok !$a->_is_private('172.15.0.1'), '172.15 not private';
ok !$a->_is_private('172.32.0.1'), '172.32 not private';
ok $a->_is_private('169.254.1.1'), 'link-local';
ok $a->_is_private('::1'), 'IPv6 loopback';
ok $a->_is_private('fc00::1'), 'IPv6 ULA fc';
ok $a->_is_private('fd12::1'), 'IPv6 ULA fd';
ok !$a->_is_private('91.198.174.1'), 'public IP';
ok $a->_is_private(undef), 'undef treated private';
ok $a->_is_private(''), 'empty string treated private';
}
# ===========================================================================
# 7. _is_trusted — CIDR and exact-match
# ===========================================================================
note '=== 7. _is_trusted ===';
{
my $a = Email::Abuse::Investigator->new(
trusted_relays => ['62.105.128.0/24', '91.198.174.5']
);
ok $a->_is_trusted('62.105.128.1'), 'CIDR match';
ok $a->_is_trusted('62.105.128.254'), 'CIDR edge';
ok !$a->_is_trusted('62.105.129.1'), 'outside CIDR';
ok $a->_is_trusted('91.198.174.5'), 'exact match';
ok !$a->_is_trusted('91.198.174.6'), 'near exact not trusted';
ok !$a->_is_trusted('8.8.8.8'), 'unrelated IP';
}
# ===========================================================================
# 8. _ip_in_cidr — all branches
# ===========================================================================
note '=== 8. _ip_in_cidr ===';
{
my $a = Email::Abuse::Investigator->new();
ok $a->_ip_in_cidr('10.0.0.1', '10.0.0.0/8'), '/8 match';
t/function.t view on Meta::CPAN
# XOIP is private -> undef
{
my $a = Email::Abuse::Investigator->new();
$a->parse_email(make_email(
received => 'from localhost [127.0.0.1] by mx',
xoip => '192.168.0.1',
));
is $a->originating_ip(), undef, 'private XOIP -> undef';
}
# no Received, no XOIP -> undef
{
my $a = Email::Abuse::Investigator->new();
$a->parse_email("From: x\@y.com\nSubject: s\n\nbody");
is $a->originating_ip(), undef, 'no received + no XOIP -> undef';
}
# trusted relay skipped -> undef
{
my $a = Email::Abuse::Investigator->new(trusted_relays => ['62.105.128.0/24']);
$a->parse_email(make_email(
received => 'from trusted (trusted [62.105.128.1]) by mx'));
is $a->originating_ip(), undef, 'trusted relay -> undef';
}
# result is cached
{
my $a = Email::Abuse::Investigator->new();
$a->parse_email(make_email());
no warnings 'redefine';
local *Email::Abuse::Investigator::_reverse_dns = sub { 'r.example' };
local *Email::Abuse::Investigator::_whois_ip = sub { {} };
my $first = $a->originating_ip();
my $second = $a->originating_ip();
is $first, $second, 'originating_ip cached';
}
# XOIP with brackets stripped
{
my $a = Email::Abuse::Investigator->new();
$a->parse_email(make_email(
received => 'from localhost [127.0.0.1] by mx',
xoip => '[62.105.128.77]',
));
no warnings 'redefine';
local *Email::Abuse::Investigator::_reverse_dns = sub { 'webmail.example' };
local *Email::Abuse::Investigator::_whois_ip = sub { {} };
my $orig = $a->originating_ip();
is $orig->{ip}, '62.105.128.77', 'brackets stripped from XOIP';
}
}
# ===========================================================================
# 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
my $lc_b = '=?utf-8?b?' . encode_base64('lower', '') . '?=';
is $a->_decode_mime_words($lc_b), 'lower', 'lowercase b specifier';
# non-UTF-8 charset: should not die
my $latin = '=?iso-8859-1?B?' . encode_base64('caf', '') . '?=';
ok defined $a->_decode_mime_words($latin), 'non-UTF-8 charset does not die';
}
# ===========================================================================
# 12. _registrable — eTLD+1 heuristic
# ===========================================================================
note '=== 12. _registrable ===';
{
# Called as package function (not a method)
is Email::Abuse::Investigator::_registrable('www.example.com'), 'example.com', 'strip one subdomain';
is Email::Abuse::Investigator::_registrable('example.com'), 'example.com', 'already registrable';
is Email::Abuse::Investigator::_registrable('foo.example.co.uk'), 'example.co.uk', 'two-part ccTLD';
is Email::Abuse::Investigator::_registrable('a.b.foo.co.uk'), 'foo.co.uk', 'deeper two-part ccTLD';
is Email::Abuse::Investigator::_registrable('sub.example.com'), 'example.com', 'three-label .com';
is Email::Abuse::Investigator::_registrable('no-dot'), undef, 'no dot -> undef';
is Email::Abuse::Investigator::_registrable(''), undef, 'empty -> undef';
is Email::Abuse::Investigator::_registrable(undef), undef, 'undef -> undef';
}
# ===========================================================================
# 13. _country_name
# ===========================================================================
note '=== 13. _country_name ===';
{
is Email::Abuse::Investigator::_country_name('CN'), 'China', 'CN';
is Email::Abuse::Investigator::_country_name('RU'), 'Russia', 'RU';
is Email::Abuse::Investigator::_country_name('NG'), 'Nigeria', 'NG';
is Email::Abuse::Investigator::_country_name('VN'), 'Vietnam', 'VN';
is Email::Abuse::Investigator::_country_name('IN'), 'India', 'IN';
is Email::Abuse::Investigator::_country_name('PK'), 'Pakistan', 'PK';
is Email::Abuse::Investigator::_country_name('BD'), 'Bangladesh', 'BD';
is Email::Abuse::Investigator::_country_name('AU'), 'AU', 'unknown cc returned verbatim';
}
# ===========================================================================
# 14. _parse_whois_text — all field branches
# ===========================================================================
note '=== 14. _parse_whois_text ===';
{
my $a = Email::Abuse::Investigator->new();
my $r;
$r = $a->_parse_whois_text("OrgName: ACME Corp\n");
is $r->{org}, 'ACME Corp', 'OrgName parsed';
t/function.t view on Meta::CPAN
confidence => 'high', note => 'First hop', country => 'NG',
};
no warnings 'redefine';
local *Email::Abuse::Investigator::_resolve_host = sub { '1.2.3.4' };
local *Email::Abuse::Investigator::_whois_ip = sub { { org=>'Spam Host', abuse=>'abuse@spam.example' } };
local *Email::Abuse::Investigator::_domain_whois = sub { undef };
my $text = $a->abuse_report_text();
like $text, qr/automated abuse report/i, 'report intro present';
like $text, qr/RISK LEVEL/, 'RISK LEVEL present';
like $text, qr/ORIGINATING IP.*91\.198\.174\.42/s,'originating IP present';
like $text, qr/ORIGINAL MESSAGE HEADERS/, 'headers section present';
like $text, qr/from:/i, 'from header included';
# No contacts branch (all unknown)
my $b = Email::Abuse::Investigator->new();
$b->parse_email(make_email());
$b->{_origin} = { ip=>'1.2.3.4', rdns=>'mail.ok',
confidence=>'high', org=>'X', abuse=>'(unknown)',
note=>'', country=>undef };
$b->{_urls} = [];
$b->{_mailto_domains} = [];
my $text2 = $b->abuse_report_text();
like $text2, qr/RISK LEVEL/, 'report generated even without contacts';
}
# ===========================================================================
# 27. report() — all sections and branches
# ===========================================================================
note '=== 27. report() ===';
{
# Full report with encoded headers, shortener, multiple URLs
my $enc_subj = '=?UTF-8?B?' . encode_base64('Ready to Find Love', '') . '?=';
my $a = Email::Abuse::Investigator->new();
$a->parse_email(make_email(
from => 'Spammer <spammer@gmail.com>',
subject => $enc_subj,
body => 'https://bit.ly/spam and http://spamsite.example/buy',
received => 'from spammer (spammer [120.88.161.249]) by mx',
auth => 'mx; spf=fail; dkim=fail',
));
$a->{_origin} = {
ip => '120.88.161.249', rdns => '120-88-161-249.tpgi.com.au',
org => 'TPG Internet', abuse => 'abuse@tpg.com.au',
confidence => 'medium', note => 'First hop', country => 'AU',
};
no warnings 'redefine';
local *Email::Abuse::Investigator::_resolve_host = sub { '1.2.3.4' };
local *Email::Abuse::Investigator::_whois_ip = sub { { org=>'Test Org', abuse=>'abuse@testorg.example', country=>'US' } };
local *Email::Abuse::Investigator::_domain_whois = sub { undef };
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';
# Multiple URLs same host -> grouped
my $c = Email::Abuse::Investigator->new();
$c->parse_email(make_email(body => 'https://multi.example/a and https://multi.example/b'));
$c->{_origin} = { ip=>'1.2.3.4', rdns=>'mail.ok',
confidence=>'high', org=>'X', abuse=>'a@b',
note=>'', country=>undef };
no warnings 'redefine';
local *Email::Abuse::Investigator::_resolve_host = sub { '1.2.3.4' };
local *Email::Abuse::Investigator::_whois_ip = sub { { org=>'T', abuse=>'a@b' } };
local *Email::Abuse::Investigator::_domain_whois = sub { undef };
my $r3 = $c->report();
like $r3, qr/URLs \(2\)/, 'multiple URLs grouped under host';
# Contact domain with all sub-sections present
my $d = Email::Abuse::Investigator->new();
$d->parse_email(make_email(from => 'x@example-domain.tld'));
$d->{_origin} = { ip=>'1.2.3.4', rdns=>'mail.ok',
confidence=>'high', org=>'X', abuse=>'a@b',
note=>'', country=>undef };
$d->{_urls} = [];
$d->{_mailto_domains} = [{
domain => 'example-domain.tld',
source => 'From: header',
recently_registered => 1,
registered => '2025-12-01',
expires => '2026-12-01',
registrar => 'NameCheap',
registrar_abuse => 'abuse@namecheap.com',
web_ip => '5.5.5.5',
web_org => 'Host Co',
web_abuse => 'abuse@hostco.example',
mx_host => 'mail.example-domain.tld',
mx_ip => '6.6.6.6',
mx_org => 'Mail Co',
mx_abuse => 'abuse@mailco.example',
ns_host => 'ns1.example-domain.tld',
ns_ip => '7.7.7.7',
ns_org => 'NS Co',
ns_abuse => 'abuse@nsco.example',
}];
no warnings 'redefine';
local *Email::Abuse::Investigator::_resolve_host = sub { undef };
local *Email::Abuse::Investigator::_domain_whois = sub { undef };
my $r4 = $d->report();
like $r4, qr/RECENTLY REGISTERED/, 'recently_registered warning present';
like $r4, qr/Web host IP.*5\.5\.5\.5/s, 'web host IP present';
like $r4, qr/MX host.*mail\.example/s, 'MX host present';
like $r4, qr/NS host.*ns1\.example/s, 'NS host present';
like $r4, qr/Reg\. abuse.*namecheap/si, 'registrar abuse present';
t/function.t view on Meta::CPAN
my $risk = $a->risk_assessment();
ok any_flag($risk->{flags}, 'undisclosed_recipients'),
'SM Investments: undisclosed_recipients flagged';
}
# ===========================================================================
# 34. Real-world email: firmluminary.com spam
# ===========================================================================
note '=== 34. firmluminary.com spam ===';
{
my $enc_from = '=?UTF-8?B?' . encode_base64('eharmony Partner', '') . '?=';
my $enc_subj = '=?UTF-8?B?' . encode_base64('Ready to Find Someone Special?', '') . '?=';
my $firm = <<"EMAIL";
Received: from 120-88-161-249.tpgi.com.au (120.88.161.249) by SJ1PEPF000023CB
Authentication-Results: spf=pass smtp.mailfrom=firmluminary.com; dkim=pass header.d=firmluminary.com; dmarc=pass
DKIM-Signature: v=1; d=firmluminary.com; s=default; b=xxx
From: "$enc_from" <peacelight\@firmluminary.com>
Subject: $enc_subj
To: victim\@test.example
Return-Path: peacelight\@firmluminary.com
Content-Type: text/html; charset="utf-8"
Content-Transfer-Encoding: quoted-printable
Message-ID: <firm001\@firmluminary.com>
Date: Mon, 23 Mar 2026 00:12:04 +0000
<a href=3D"https://www.firmluminary.com/c/link1">Click</a>
<a href=3D"https://www.firmluminary.com/u/unsub">Unsubscribe</a>
<img src=3D"https://www.firmluminary.com/o/track">
EMAIL
my $a = Email::Abuse::Investigator->new();
$a->parse_email($firm);
no warnings 'redefine';
local *Email::Abuse::Investigator::_reverse_dns = sub { '120-88-161-249.tpgi.com.au' };
local *Email::Abuse::Investigator::_resolve_host = sub { '104.21.13.60' };
local *Email::Abuse::Investigator::_whois_ip = sub { { org=>'CLOUDFLARENET', abuse=>'abuse@cloudflare.com', country=>'US' } };
local *Email::Abuse::Investigator::_domain_whois = sub { undef };
# Origin
my $orig = $a->originating_ip();
is $orig->{ip}, '120.88.161.249', 'firmluminary: origin IP';
like $orig->{rdns}, qr/tpgi\.com\.au/, 'firmluminary: rDNS';
# URLs on single host
my @urls = $a->embedded_urls();
ok @urls >= 2, 'firmluminary: multiple URLs found';
ok !scalar(grep { $_->{host} ne 'www.firmluminary.com' } @urls),
'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.
my $a = Email::Abuse::Investigator->new();
$a->parse_email(make_email(subject => 'Public Accessor Test'));
is $a->header_value('subject'), 'Public Accessor Test', 'header_value() finds header';
is $a->header_value('Subject'), 'Public Accessor Test', 'header_value() is case-insensitive';
is $a->header_value('x-absent'), undef, 'missing header returns undef';
# can_ok proves the method exists on the public interface
can_ok $a, 'header_value';
}
# ===========================================================================
# 36. sending_software() and received_trail()
# ===========================================================================
note '=== 36. sending_software() and received_trail() ===';
{
# X-PHP-Originating-Script and X-Mailer reveal shared-hosting injection
my $sw_email = make_email(
extra_hdrs => "X-PHP-Originating-Script: 100-PHPMailer.php\n"
. "X-Mailer: PHPMailer 6.0\n",
received => 'from web.example.com (web.example.com [91.198.174.42])'
. ' by mx id MSGID42; Mon, 01 Jan 2024 00:00:00 +0000',
);
my $sw_obj = Email::Abuse::Investigator->new();
$sw_obj->parse_email($sw_email);
my @sw = $sw_obj->sending_software();
ok @sw > 0, 'sending_software() returns entries';
my ($php) = grep { $_->{header} eq 'x-php-originating-script' } @sw;
ok defined $php, 'x-php-originating-script captured';
is $php->{value}, '100-PHPMailer.php', 'PHP script value correct';
like $php->{note}, qr/shared hosting/i,'PHP note mentions shared hosting';
my ($mailer) = grep { $_->{header} eq 'x-mailer' } @sw;
ok defined $mailer, 'x-mailer captured';
is $mailer->{value}, 'PHPMailer 6.0', 'x-mailer value correct';
# Results are sorted alphabetically by header name (per %sw_notes sort).
# Do not use $a/$$b as variable names anywhere in this scope: Perl 5.36+
# raises a fatal "Can't use 'my $a' in sort comparison" if $a or $b are
# declared with my in the same lexical scope as a sort block that uses them.
my @sorted = sort { ($a->{header} // '') cmp ($b->{header} // '') } @sw;
is_deeply \@sw, \@sorted, 'sending_software() sorted by header name';
# No software headers -> empty list
my $no_sw = Email::Abuse::Investigator->new();
$no_sw->parse_email(make_email());
is scalar($no_sw->sending_software()), 0, 'no software headers -> empty list';
t/function.t view on Meta::CPAN
from => 'Sender <sender@brand.com>',
auth => 'mx; spf=pass; dkim=pass header.d=esp-service.net; dmarc=pass',
extra_hdrs => "DKIM-Signature: v=1; d=esp-service.net; s=s1; b=xxx\n",
));
$a->{_origin} = { ip=>'1.2.3.4', rdns=>'mail.ok', confidence=>'high',
org=>'X', abuse=>'a@b', note=>'', country=>undef };
$a->{_urls} = [];
$a->{_mailto_domains} = [];
my $risk = $a->risk_assessment();
ok any_flag($risk->{flags}, 'dkim_domain_mismatch'),
'dkim_domain_mismatch flagged when signed by different registrable domain';
my ($f) = grep { $_->{flag} eq 'dkim_domain_mismatch' } @{ $risk->{flags} };
is $f->{severity}, 'INFO',
'passing-DKIM mismatch is INFO (normal for ESPs)';
}
# DKIM signed by different domain AND DKIM fails -> MEDIUM (possible forgery)
{
my $a = Email::Abuse::Investigator->new();
$a->parse_email(make_email(
from => 'Sender <sender@brand.com>',
auth => 'mx; spf=pass; dkim=fail header.d=forgery.net; dmarc=fail',
extra_hdrs => "DKIM-Signature: v=1; d=forgery.net; s=s1; b=xxx\n",
));
$a->{_origin} = { ip=>'1.2.3.4', rdns=>'mail.ok', confidence=>'high',
org=>'X', abuse=>'a@b', note=>'', country=>undef };
$a->{_urls} = [];
$a->{_mailto_domains} = [];
my $risk = $a->risk_assessment();
my ($f) = grep { $_->{flag} eq 'dkim_domain_mismatch' } @{ $risk->{flags} };
ok defined $f, 'dkim_domain_mismatch flagged for fail+different domain';
is $f->{severity}, 'MEDIUM', 'fail+mismatch is MEDIUM severity';
}
# Same registrable domain (sub.brand.com signing brand.com) -> no mismatch
{
my $a = Email::Abuse::Investigator->new();
$a->parse_email(make_email(
from => 'Sender <sender@brand.com>',
auth => 'mx; spf=pass; dkim=pass header.d=mta.brand.com; dmarc=pass',
extra_hdrs => "DKIM-Signature: v=1; d=mta.brand.com; s=s1; b=xxx\n",
));
$a->{_origin} = { ip=>'1.2.3.4', rdns=>'mail.ok', confidence=>'high',
org=>'X', abuse=>'a@b', note=>'', country=>undef };
$a->{_urls} = [];
$a->{_mailto_domains} = [];
ok !any_flag($a->risk_assessment()->{flags}, 'dkim_domain_mismatch'),
'same registrable domain (subdomain signing) does not flag mismatch';
}
}
# ===========================================================================
# 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';
}
# ===========================================================================
# 44. _parse_domain_whois_abuse() — WHOIS registrar contact extraction
# ===========================================================================
note '=== 44. _parse_domain_whois_abuse() ===';
{
my $a = Email::Abuse::Investigator->new();
# Standard "Registrar Abuse Contact Email:" format (ICANN-mandated field)
my $whois1 = "Registrar: Super Registrar Ltd\n"
. "Registrar Abuse Contact Email: abuse\@superreg.example\n";
no warnings 'redefine';
local *Email::Abuse::Investigator::_domain_whois = sub { $whois1 };
my $r1 = $a->_parse_domain_whois_abuse('example.com');
is $r1->{org}, 'Super Registrar Ltd', 'registrar name extracted';
is $r1->{abuse}, 'abuse@superreg.example', 'ICANN abuse email extracted';
# Alternative "Abuse Contact Email:" pattern used by some registrars
my $whois2 = "Registrar: Alt Reg\nAbuse Contact Email: abuse\@altreg.example\n";
no warnings 'redefine';
local *Email::Abuse::Investigator::_domain_whois = sub { $whois2 };
my $r2 = $a->_parse_domain_whois_abuse('alt.example');
is $r2->{abuse}, 'abuse@altreg.example', 'Abuse Contact Email: alternative pattern';
# No WHOIS data available -> empty hashref (caller must handle gracefully)
no warnings 'redefine';
local *Email::Abuse::Investigator::_domain_whois = sub { undef };
my $r3 = $a->_parse_domain_whois_abuse('nope.example');
is_deeply $r3, {}, 'no WHOIS response -> empty hashref returned';
}
# ===========================================================================
# 45. abuse_contacts() caching and _contacts invalidation on parse_email()
# ===========================================================================
note '=== 45. abuse_contacts() caching ===';
{
my $a = Email::Abuse::Investigator->new();
$a->parse_email(make_email(from => 'x@gmail.com'));
$a->{_origin} = {
ip => '209.85.218.67',
rdns => 'mail-ej1-f67.google.com',
org => 'Google LLC',
abuse => 'abuse@google.com',
confidence => 'medium',
note => '',
country => undef,
};
$a->{_urls} = [];
$a->{_mailto_domains} = [];
# First call should populate the _contacts lazy cache
my @first = $a->abuse_contacts();
( run in 1.081 second using v1.01-cache-2.11-cpan-a9496e3eb41 )