File Coverage

File:blib/lib/Email/Abuse/Investigator.pm
Coverage:93.0%

linestmtbrancondsubtimecode
1package Email::Abuse::Investigator;
2
3
26
26
26
0
5
3
0
1
1
0
1
1
0
1
1
1
1
1
1
1
1
1
1
1
770469
26
386
0
218
10
0
60
3
0
65
2
0
59
3
1
15
4
1
11
2
1
14
1
use strict;
4
26
26
26
0
3
3
0
1
1
0
1
1
0
1
1
1
1
1
1
1
1
1
1
1
45
21
541
0
139
7
0
47
1
0
46
3
0
49
3
1
33
3
1
31
2
1
31
2
use warnings;
5
26
26
26
0
3
3
0
1
1
0
1
1
0
1
1
1
1
1
1
1
1
1
1
1
3117
100628
65
0
125
5
0
67
2
0
45
1
0
43
2
1
3
2214
1
3
2174
0
4
2228
use autodie qw(:all);
6
7# TODO: phishing spam pretending to be from Fidelity Investments, should be
8# forwarded to phishing@fidelity.com
9
10
26
26
26
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
133866
37
644
3
3
8
2
1
3
1
1
2
1
1
2
1
32
2
1
33
2
2
34
3
use Carp qw(croak carp);
11
26
26
26
0
3
85
0
1
1
0
1
1
0
1
1
1
1
1
1
1
1
1
1
1
4164
15047
594
0
137
73
0
44
2
0
45
1
0
43
2
1
15
1
1
14
2
1
16
2
use IO::Select;
12
26
26
26
85
75
75
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
3058
137957
120
83
58
64
1
1
3
1
1
2
1
1
2
1
5
220
1
6
234
1
6
238
use IO::Socket::INET;
13
26
12
0
0
0
1
1
1
6005
19
0
0
0
2
2
2
BEGIN { $Sub::Private::config{mode} = 'enforce' }
14
26
26
26
375
75
72
1
1
0
1
1
0
1
1
0
1
1
1
1
1
1
1
1
1
4817
721524
82
450
96
94
109
3
0
44
2
0
44
2
0
1
2
98
1
3
127
1
2
108
use Sub::Private;
15
26
26
26
11
75
7
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
7537
82302
71
5271
76
49
1738
1
16
1792
1
15
1819
1
12
0
4
74
1
3
69
1
4
75
use Sub::Protected;
16
26
26
26
75
5
75
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
5841
6729
635
2624
7
100
1287
1
10
1555
1
10
1125
2
10
1
41
3
2
21
1
1
18
2
use MIME::QuotedPrint qw( decode_qp );
17
26
26
26
3
75
291
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
63
31
426
2933
69
271
912
2
9
1080
1
9
1301
2
9
1
20
2
1
15
2
1
15
2
use MIME::Base64 qw( decode_base64 );
18
26
26
26
75
75
375
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
5919
764689
509
4063
55
316
1701
1
10
1569
1
10
1391
1
10
1
7
4
1
8
1
1
8
1
use Object::Configure;
19
26
26
26
75
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
80
28
468
3237
2
29
1275
1
10
1429
1
10
1056
1
9
1
15
2
2
15
2
1
18
2
use Params::Get;
20
26
26
26
75
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
49
244
348
6454
3
30
1656
1
10
1695
1
10
1850
1
9
10
15
1
11
12
2
13
14
2
use Params::Validate::Strict 0.34;
21
26
26
26
3
3
7
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
57
22
434
6512
4
35
1922
1
11
1782
0
10
2274
1
10
1
14
2
1
13
1
1
15
1
use Readonly;
22
26
26
26
7
7
103
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
4363
13153
1973
3543
12
206
994
2
10
1019
1
10
646
1
9
1
64
3
2
63
2
1
61
2
use Readonly::Values::Months;
23
26
26
26
79
41
41
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
74
23
568
2577
38
63
934
2
10
710
1
10
572
1
10
1
31
2
1
16
2
1
17
2
use Socket qw( inet_aton inet_ntoa AF_INET );
24
26
26
26
41
52
52
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
4570
90228
73
2194
51
72
494
2
9
693
1
9
288
1
8
1
5
102
0
4
105
6
4
114
use Time::Piece;
25
26 - 35
=head1 NAME

Email::Abuse::Investigator - Analyse spam email to identify originating hosts,
hosted URLs, and suspicious domains

=head1 VERSION

Version 0.14

=cut
36
37our $VERSION = '0.14';
38
39 - 102
=head1 SYNOPSIS

    use Email::Abuse::Investigator;

    my $analyser = Email::Abuse::Investigator->new( verbose => 1 );
    $analyser->parse_email($raw_email_text);

    # Originating IP and its network owner
    my $origin = $analyser->originating_ip();

    # All HTTP/HTTPS URLs found in the body
    my @urls  = $analyser->embedded_urls();

    # All domains extracted from mailto: links and bare addresses in the body
    my @mdoms = $analyser->mailto_domains();

    # All domains mentioned anywhere (union of the above)
    my @adoms = $analyser->all_domains();

    # Full printable report
    print $analyser->report();

=head1 DESCRIPTION

C<Email::Abuse::Investigator> examines the raw source of a spam/phishing e-mail
and answers the questions manual abuse investigators ask:

=over 4

=item 1. Where did the message really come from?

Walks the C<Received:> chain, skips private/trusted IPs, and identifies the
first external hop.  Enriches with rDNS, WHOIS/RDAP org name and abuse
contact.  Both IPv4 and IPv6 addresses are supported.

=item 2. Who hosts the advertised web sites?

Extracts every C<http://> and C<https://> URL from both plain-text and HTML
parts, resolves each hostname to an IP, and looks up the network owner.

=item 3. Who owns the reply-to / contact domains?

Extracts domains from C<mailto:> links, bare e-mail addresses in the body,
the C<From:>/C<Reply-To:>/C<Sender:>/C<Return-Path:> headers, C<DKIM-Signature: d=>
(the signing domain), C<List-Unsubscribe:> (the ESP or bulk-sender domain), and the
C<Message-ID:> domain.  For each unique domain it gathers:

=over 8

=item * Domain registrar and registrant (WHOIS)

=item * Web-hosting IP and network owner (A record -> RDAP)

=item * Mail-hosting IP and network owner (MX record -> RDAP)

=item * DNS nameserver operator (NS record -> RDAP)

=item * Whether the domain was recently registered (potential flag)

=back

=back

=cut
103
104# -----------------------------------------------------------------------
105# Optional modules -- gracefully degraded when absent
106# -----------------------------------------------------------------------
107
108# Net::DNS enables MX, NS, AAAA lookups; falls back to gethostbyname
109my $HAS_NET_DNS;
110
111# LWP::UserAgent enables RDAP queries; falls back to raw WHOIS
112my $HAS_LWP;
113my $HAS_CONN_CACHE;
114
115# HTML::LinkExtor enables structural HTML link extraction
116my $HAS_HTML_LINKEXTOR;
117
118# CHI enables a persistent cross-message cache for IP/domain data
119my $HAS_CHI;
120
121# IO::Socket::IP provides dual-stack (IPv4+IPv6) socket support
122my $HAS_IO_SOCKET_IP;
123
124# Domain::PublicSuffix enables accurate eTLD+1 normalisation
125my $HAS_PUBLIC_SUFFIX;
126
127# AnyEvent::DNS enables parallel DNS queries
128my $HAS_ANYEVENT_DNS;
129
130BEGIN {
131
26
26
0
52
41
16
1
1
1
1
1
1
1
1
1
1
0
1
1
0
1
1
0
1
3101
1321
0
2531
39
44
678
1
9
589
1
9
430
1
8
4
0
65
4
0
97
5
0
82
        $HAS_NET_DNS       = eval { require Net::DNS;           1 };
132
26
26
0
16
3
6
1
1
1
1
1
1
1
1
1
1
0
1
1
0
1
1
0
1
248
1090
0
2614
2
29
814
2
10
1023
1
9
1269
1
10
3
0
47
3
0
50
3
0
48
        $HAS_LWP           = eval { require LWP::UserAgent;     1 };
133
26
26
0
6
6
3
1
1
1
1
1
1
1
1
1
1
0
1
1
0
1
1
0
1
230
971
0
2308
9
22
793
2
9
929
1
8
1120
1
8
2
0
44
2
0
40
3
0
44
        $HAS_CONN_CACHE    = eval { require LWP::ConnCache;     1 };
134
26
26
26
3
3
6
1
1
1
1
1
1
1
1
1
1
1
1
1
0
1
1
1
1
152
4378
85004
1931
3
30
839
1
9
897
1
8
1102
1
8
1
1
1
2
0
37
1
1
1
        $HAS_HTML_LINKEXTOR= eval { require HTML::LinkExtor;    1 };
135
26
26
0
6
3
3
1
1
1
1
1
1
1
1
1
1
0
1
1
0
1
1
0
1
50
1238
0
3613
6
29
1461
2
10
1350
0
10
1259
1
9
2
0
45
3
0
36
2
0
46
        $HAS_CHI           = eval { require CHI;                1 };
136
26
26
26
3
5
5
1
1
1
1
1
1
1
1
1
1
1
1
1
0
1
1
1
1
182
4027
45649
2496
31
30
1261
1
9
1205
1
29
1005
1
9
2
1
1
2
0
36
1
1
2
        $HAS_IO_SOCKET_IP  = eval { require IO::Socket::IP;     1 };
137
26
26
0
5
5
3
1
1
1
1
1
1
1
1
1
1
0
1
1
0
1
1
0
1
27
1142
0
3715
30
30
1287
1
10
1586
1
9
1204
1
10
2
0
46
3
0
35
2
0
46
        $HAS_PUBLIC_SUFFIX = eval { require Domain::PublicSuffix; 1 };
138
26
26
0
3
3
3
1
1
1
1
1
1
1
1
1
1
0
1
1
0
1
1
0
1
160
37006
0
2535
4
26
1206
2
9
1256
2
8
895
1
10
2
0
1773
2
0
1792
2
0
1815
        $HAS_ANYEVENT_DNS  = eval { require AnyEvent::DNS;      1 };
139}
140
141# -----------------------------------------------------------------------
142# Constants -- all magic numbers and strings live here
143# -----------------------------------------------------------------------
144
145# WHOIS protocol port (IANA-assigned)
146Readonly::Scalar my $WHOIS_PORT        => 43;
147
148# Bytes to read per sysread() call from a WHOIS socket
149Readonly::Scalar my $WHOIS_READ_CHUNK  => 4096;
150
151# Maximum WHOIS response bytes stored in whois_raw (keep reports compact)
152Readonly::Scalar my $WHOIS_RAW_MAX     => 2048;
153
154# Maximum multipart nesting depth (recursion guard -- RFC 2046 has no limit
155# but we cap it to prevent stack exhaustion on crafted messages)
156Readonly::Scalar my $MAX_MULTIPART_DEPTH => 20;
157
158# Number of days before registration that triggers recently_registered flag
159Readonly::Scalar my $RECENT_REG_DAYS   => 180;
160
161# Number of days ahead of expiry that triggers domain_expires_soon flag
162Readonly::Scalar my $EXPIRY_WARN_DAYS  => 30;
163
164# Seconds in a day -- used in date arithmetic throughout
165Readonly::Scalar my $SECS_PER_DAY      => 86400;
166
167# Suspicious date window: dates outside +/- 7 days raise a flag
168Readonly::Scalar my $DATE_SKEW_DAYS    => 7;
169
170# Maximum positive timezone offset in minutes (+14:00 = Line Islands)
171Readonly::Scalar my $TZ_MAX_POS_MINS   => 840;
172
173# Maximum negative timezone offset in minutes (-12:00 = Baker Island)
174Readonly::Scalar my $TZ_MAX_NEG_MINS   => 720;
175
176# High-risk score threshold
177Readonly::Scalar my $SCORE_HIGH        => 9;
178
179# Medium-risk score threshold
180Readonly::Scalar my $SCORE_MEDIUM      => 5;
181
182# Low-risk score threshold
183Readonly::Scalar my $SCORE_LOW         => 2;
184
185# Flag severity weights (contribute to the numeric risk score)
186Readonly::Hash my %FLAG_WEIGHT => (
187        HIGH   => 3,
188        MEDIUM => 2,
189        LOW    => 1,
190        INFO   => 0,
191);
192
193# Maximum merged-role display string length before summarisation kicks in
194Readonly::Scalar my $ROLE_MAX_LEN      => 80;
195
196# CHI cache TTL in seconds (1 hour -- IP allocations change slowly)
197Readonly::Scalar my $CACHE_TTL_SECS    => 3600;
198
199# Default constructor timeout for network operations (seconds)
200Readonly::Scalar my $DEFAULT_TIMEOUT   => 10;
201
202# Maximum role string length before truncation
203Readonly::Scalar my $ROLE_WRAP_LEN     => 66;
204
205# Maximum redirect hops to follow when resolving shortener/redirect-cloaker URLs
206Readonly::Scalar my $REDIRECT_MAX_HOPS => 3;
207
208# Brand names checked in lookalike-domain detection.
209# Overridable at runtime via Object::Configure.
210Readonly::Array my @LOOKALIKE_BRANDS => qw(
211        paypal apple google amazon microsoft netflix ebay
212        instagram facebook twitter linkedin bankofamerica
213        wellsfargo chase barclays hsbc lloyds santander
214);
215
216# -----------------------------------------------------------------------
217# Private ranges -- IPs that are never actionable abuse targets
218# -----------------------------------------------------------------------
219
220# Both IPv4 and IPv6 private/reserved ranges.  Each entry is a compiled
221# regex; _is_private() iterates over them and returns true on first match.
222my @PRIVATE_RANGES = (
223        # IPv4 ranges
224        qr/^0\./,                         # 0.0.0.0/8  this-network (RFC 1122)
225        qr/^127\./,                       # 127.0.0.0/8 loopback
226        qr/^10\./,                        # 10.0.0.0/8  RFC 1918
227        qr/^192\.168\./,                  # 192.168.0.0/16 RFC 1918
228        qr/^172\.(?:1[6-9]|2\d|3[01])\./, # 172.16.0.0/12  RFC 1918
229        qr/^169\.254\./,                  # 169.254.0.0/16 link-local
230        qr/^100\.(?:6[4-9]|[7-9]\d|1(?:[01]\d|2[0-7]))\./,  # 100.64.0.0/10 CGN (RFC 6598)
231        qr/^192\.0\.0\./,                 # 192.0.0.0/24  IETF protocol (RFC 6890)
232        qr/^192\.0\.2\./,                 # 192.0.2.0/24  TEST-NET-1 (RFC 5737)
233        qr/^198\.51\.100\./,              # 198.51.100.0/24 TEST-NET-2 (RFC 5737)
234        qr/^203\.0\.113\./,               # 203.0.113.0/24 TEST-NET-3 (RFC 5737)
235        qr/^255\./,                       # 255.0.0.0/8 broadcast
236        # IPv6 ranges
237        qr/^::1$/,                         # IPv6 loopback
238        qr/^fe80:/i,                       # IPv6 link-local (fe80::/10)
239        qr/^fc/i,                          # IPv6 ULA fc00::/7
240        qr/^fd/i,                          # IPv6 ULA fd00::/8
241        qr/^2001:db8:/i,                   # IPv6 documentation range (RFC 3849)
242        qr/^64:ff9b:/i,                    # IPv6 NAT64 well-known prefix
243);
244
245# Priority-ordered patterns for extracting IPs from Received: headers.
246# Covers bracketed IPv4, bracketed IPv6, parenthesised address, and bare dotted-quad.
247my @RECEIVED_IP_RE = (
248        qr/\[\s*([\d.]+)\s*\]/,                          # [1.2.3.4]
249        qr/\[\s*([0-9a-fA-F:]+)\s*\]/,                  # [IPv6 address]
250        qr/\(\s*[\w.-]*\s*\[?\s*([\d.]+)\s*\]?\s*\)/,   # (hostname [1.2.3.4])
251        qr/from\s+[\w.-]+\s+([\d.]+)/,                  # from hostname addr
252        qr/([\d]{1,3}\.[\d]{1,3}\.[\d]{1,3}\.[\d]{1,3})/, # bare dotted-quad fallback
253);
254
255# -----------------------------------------------------------------------
256# Default configuration -- overridable via Object::Configure
257# -----------------------------------------------------------------------
258
259# Object::Configure may overlay
260# values from a file before new() uses them.  Use Readonly for constants
261# that should never be overridden at runtime.
262
263# -----------------------------------------------------------------------
264# Trusted domains (infrastructure -- never report these as abuse targets)
265# Can be overrideen at runtime by Object::Configure
266# -----------------------------------------------------------------------
267
268my %TRUSTED_DOMAINS = map { $_ => 1 } qw(
269        gmail.com googlemail.com yahoo.com outlook.com hotmail.com
270        google.com microsoft.com apple.com amazon.com
271        googlegroups.com groups.google.com
272        fonts.googleapis.com fonts.gstatic.com
273        ajax.googleapis.com maps.googleapis.com
274        w3.org
275        fedex.com ups.com dhl.com usps.com royalmail.com
276);
277
278# -----------------------------------------------------------------------
279# URL shortener domains (real destination is hidden behind these)
280# -----------------------------------------------------------------------
281
282my %URL_SHORTENERS = map { $_ => 1 } qw(
283        bit.ly      bitly.com   tinyurl.com  t.co        ow.ly
284        goo.gl      is.gd       buff.ly      ift.tt       dlvr.it
285        short.link  rebrand.ly  tiny.cc      cutt.ly      rb.gy
286        shorturl.at bl.ink      smarturl.it  yourls.org   clicky.me
287        snip.ly     adf.ly      bc.vc        lnkd.in      fb.me
288        youtu.be
289);
290
291# Cloud object-stores and CDN hosting paths commonly abused to serve redirect
292# pages that hide the real phishing destination (same evasion as a URL shortener
293# but using legitimate cloud infrastructure to pass spam filters).
294# Exact-match hosts; suffix patterns are in @REDIRECT_HOST_SUFFIXES below.
295my %REDIRECT_HOSTS = map { $_ => 1 } qw(
296        storage.googleapis.com
297        blob.core.windows.net
298        pages.dev
299        firebaseapp.com
300        web.app
301);
302
303# Subdomain-suffix patterns for bucket-style hosting (e.g. mybucket.s3.amazonaws.com).
304# Checked by _is_redirect_cloaker() using a suffix match against the bare hostname.
305Readonly::Array my @REDIRECT_HOST_SUFFIXES => qw(
306        .s3.amazonaws.com
307        .s3-website.amazonaws.com
308        .cloudfront.net
309        .github.io
310        .firebaseapp.com
311        .web.app
312        .translate.goog
313);
314
315# -----------------------------------------------------------------------
316# Well-known provider abuse contacts
317# Can be overrideen at runtime by Object::Configure
318# -----------------------------------------------------------------------
319
320# Curated table of provider abuse contacts.  Entries with only a 'form'
321# key (no 'email') require web-form submission; abuse_contacts() suppresses
322# email addresses for those providers and form_contacts() surfaces them.
323my %PROVIDER_ABUSE = (
324        # Google / Gmail
325        'google.com'        => { email => 'abuse@google.com',      note => 'Also report Gmail accounts via https://support.google.com/mail/contact/abuse' },
326        'gmail.com'         => { email => 'abuse@google.com',      note => 'Report Gmail spam via https://support.google.com/mail/contact/abuse' },
327        'googlemail.com'    => { email => 'abuse@google.com',      note => 'Report via https://support.google.com/mail/contact/abuse' },
328        '1e100.net'         => { email => 'abuse@google.com',      note => 'Google infrastructure' },
329        'blogspot.com'      => { email => 'abuse@google.com',      note => 'Blogger/Blogspot -- report via https://support.google.com/blogger/answer/76315' },
330        'blogger.com'       => { email => 'abuse@google.com',      note => 'Blogger platform abuse' },
331        'sites.google.com'        => { email => 'abuse@google.com',               note => 'Google Sites hosted content' },
332        'storage.googleapis.com'  => { email => 'google-cloud-compliance@google.com', note => 'Google Cloud Storage bucket abuse -- also report via https://support.google.com/code/go/gce_abuse_report' },
333        'gappssmtp.com'           => { email => 'abuse@google.com',               note => 'Google Workspace SMTP signing service -- report account abuse' },
334        'translate.goog'          => { email => 'abuse@google.com',               note => 'Google Translate URL proxy used to cloak phishing URLs -- report via https://support.google.com/translate/answer/4431190' },
335        'googleusercontent.com'   => { email => 'abuse@google.com',               note => 'Google user content hosting (Docs, Drive, Sites) -- also report via https://support.google.com/drive/answer/2408000' },
336        # Microsoft
337        'microsoft.com'     => { email => 'abuse@microsoft.com',   note => 'Also report via https://www.microsoft.com/en-us/wdsi/support/report-unsafe-site' },
338        'outlook.com'       => { email => 'abuse@microsoft.com',   note => 'Report Outlook spam: https://support.microsoft.com/en-us/office/report-phishing' },
339        'hotmail.com'       => { email => 'abuse@microsoft.com',   note => 'Report via https://support.microsoft.com/en-us/office/report-phishing' },
340        'live.com'          => { email => 'abuse@microsoft.com',   note => 'Microsoft consumer mail' },
341        'office365.com'     => { email => 'abuse@microsoft.com',   note => 'Microsoft 365 infrastructure' },
342        'protection.outlook.com' => { email => 'abuse@microsoft.com', note => 'Microsoft EOP gateway' },
343        # Yahoo
344        'yahoo.com'         => { email => 'abuse@yahoo-inc.com',   note => 'Also use https://io.help.yahoo.com/contact/index' },
345        'yahoo.co.uk'       => { email => 'abuse@yahoo-inc.com',   note => 'Yahoo UK' },
346        # Apple
347        'apple.com'         => { email => 'reportphishing@apple.com', note => 'iCloud / Apple Mail abuse' },
348        'icloud.com'        => { email => 'reportphishing@apple.com', note => 'iCloud abuse' },
349        'me.com'            => { email => 'reportphishing@apple.com', note => 'Apple legacy mail' },
350        # Amazon / AWS
351        'amazon.com'        => { email => 'abuse@amazonaws.com',   note => 'Also https://aws.amazon.com/forms/report-abuse' },
352        'amazonaws.com'     => { email => 'abuse@amazonaws.com',   note => 'AWS abuse form: https://aws.amazon.com/forms/report-abuse' },
353        'amazonses.com'     => { email => 'abuse@amazonaws.com',   note => 'Amazon SES sending infrastructure' },
354        # Cloudflare
355        'cloudflare.com'    => { email => 'abuse@cloudflare.com',  note => 'Report via https://www.cloudflare.com/abuse/' },
356        # Fastly / Akamai
357        'fastly.net'        => { email => 'abuse@fastly.com',      note => 'Fastly CDN' },
358        'akamai.com'        => { email => 'abuse@akamai.com',      note => 'Akamai CDN' },
359        'akamaitechnologies.com' => { email => 'abuse@akamai.com', note => 'Akamai CDN' },
360        # Namecheap
361        'namecheap.com'     => { email => 'abuse@namecheap.com',   note => 'Registrar abuse' },
362        # GoDaddy -- web form only; email bounces
363        'godaddy.com'       => {
364                form        => 'https://supportcenter.godaddy.com/AbuseReport',
365                form_paste  => 'Select the abuse type (spam, phishing, malware etc). '
366                             . 'Enter the domain name in the Domain field. '
367                             . 'Paste the originating IP, risk flags, and the relevant '
368                             . 'Received: headers from the report below.',
369                form_upload => 'Take a screenshot of the report as a .png or .jpg, '
370                             . 'or export it as a .pdf.',
371                note        => 'Registrar/host -- email reports not monitored, use web form',
372        },
373        # SendGrid / Twilio
374        'sendgrid.net'      => { email => 'abuse@sendgrid.com',    note => 'ESP -- include full headers' },
375        'sendgrid.com'      => { email => 'abuse@sendgrid.com',    note => 'ESP -- include full headers' },
376        # Mailchimp / Mandrill
377        'mailchimp.com'     => { email => 'abuse@mailchimp.com',   note => 'ESP abuse' },
378        'mandrillapp.com'   => { email => 'abuse@mailchimp.com',   note => 'Mandrill transactional ESP' },
379        # OVH
380        'ovh.net'           => { email => 'abuse@ovh.net',         note => 'OVH hosting' },
381        'ovh.com'           => { email => 'abuse@ovh.com',         note => 'OVH hosting' },
382        # Hetzner
383        'hetzner.com'       => { email => 'abuse@hetzner.com',     note => 'Hetzner hosting' },
384        # Digital Ocean
385        'digitalocean.com'  => { email => 'abuse@digitalocean.com',note => 'DO abuse form: https://www.digitalocean.com/company/contact/#abuse' },
386        # Linode / Akamai
387        'linode.com'        => { email => 'abuse@linode.com',      note => 'Linode/Akamai Cloud' },
388        # Constant Contact
389        'constantcontact.com' => { email => 'abuse@constantcontact.com', note => 'ESP abuse' },
390        'r.constantcontact.com' => { email => 'abuse@constantcontact.com', note => 'Constant Contact sending infrastructure' },
391        # HubSpot
392        'hubspot.com'         => { email => 'abuse@hubspot.com',       note => 'ESP abuse' },
393        'hs-analytics.net'    => { email => 'abuse@hubspot.com',       note => 'HubSpot analytics infrastructure' },
394        # Campaign Monitor
395        'createsend.com'      => { email => 'abuse@campaignmonitor.com', note => 'Campaign Monitor ESP' },
396        'cmail20.com'         => { email => 'abuse@campaignmonitor.com', note => 'Campaign Monitor sending infrastructure' },
397        # Klaviyo
398        'klaviyo.com'         => { email => 'abuse@klaviyo.com',       note => 'ESP abuse' },
399        # Brevo (formerly Sendinblue)
400        'sendinblue.com'      => { email => 'abuse@sendinblue.com',    note => 'ESP abuse' },
401        'brevo.com'           => { email => 'abuse@brevo.com',         note => 'ESP abuse' },
402        # Mailgun
403        'mailgun.com'         => { email => 'abuse@mailgun.com',       note => 'ESP abuse' },
404        'mailgun.org'         => { email => 'abuse@mailgun.com',       note => 'Mailgun sending infrastructure' },
405        # Postmark
406        'postmarkapp.com'     => { email => 'abuse@postmarkapp.com',   note => 'ESP abuse' },
407        # WordPress.com
408        'wordpress.com'       => { email => 'abuse@wordpress.com',     note => 'WordPress.com hosted blog -- report via https://en.wordpress.com/abuse/' },
409        'wp.com'              => { email => 'abuse@wordpress.com',     note => 'WordPress.com short domain' },
410        # Wix -- wixsite.com is the subdomain used for all user-hosted Wix sites
411        'wix.com'             => { email => 'abuse@wix.com',           note => 'Wix platform abuse -- report via https://support.wix.com/en/article/reporting-abusive-wix-sites' },
412        'wixsite.com'         => { email => 'abuse@wix.com',           note => 'Wix user-hosted site (e.g. exitfed.wixsite.com) -- report the site URL to abuse@wix.com' },
413        # Substack
414        'substack.com'        => { email => 'abuse@substack.com',      note => 'Substack newsletter platform abuse' },
415        # Change.org -- petition platform used by spammers as a redirect destination
416        'change.org'          => { email => 'abuse@change.org',        note => 'Change.org petition platform -- report abuse via https://www.change.org/policies/abuse' },
417        # ActiveCampaign
418        'activecampaign.com'  => { email => 'abuse@activecampaign.com', note => 'ActiveCampaign ESP' },
419        'ac-tinker.com'       => { email => 'abuse@activecampaign.com', note => 'ActiveCampaign tracking infrastructure' },
420        # Salesforce Marketing Cloud
421        'salesforce.com'      => { email => 'abuse@salesforce.com',    note => 'Salesforce Marketing Cloud / ExactTarget ESP' },
422        'mc.salesforce.com'   => { email => 'abuse@salesforce.com',    note => 'Salesforce Marketing Cloud sending infrastructure' },
423        'exacttarget.com'     => { email => 'abuse@salesforce.com',    note => 'ExactTarget / Salesforce Marketing Cloud ESP' },
424        'et.exacttarget.com'  => { email => 'abuse@salesforce.com',    note => 'ExactTarget sending infrastructure' },
425        # Vultr
426        'vultr.com'           => { email => 'abuse@vultr.com',         note => 'Vultr hosting' },
427        # Contabo
428        'contabo.com'         => { email => 'abuse@contabo.com',       note => 'Contabo hosting' },
429        # Leaseweb
430        'leaseweb.com'        => { email => 'abuse@leaseweb.com',      note => 'Leaseweb hosting' },
431        # M247
432        'm247.com'            => { email => 'abuse@m247.com',          note => 'M247 hosting' },
433        # MarkMonitor -- web form only
434        'markmonitor.com'       => {
435                form        => 'https://corp.markmonitor.com/domain/ui/abuse-report',
436                form_paste  => 'Complete all fields including the domain name and your '
437                             . 'description of the abuse.  Paste the originating IP, '
438                             . 'risk flags, and the relevant Received: headers from the '
439                             . 'report below.',
440                form_upload => 'Take a screenshot of the report as a .png or .jpg, or export it as a .pdf.  MarkMonitor does not accept .eml files.',
441                note        => 'Brand-protection registrar -- email reports not processed',
442        },
443        # URL shortener operators
444        'is.gd'             => { email => 'abuse@is.gd',           note => 'URL shortener -- report via https://is.gd/contact.php' },
445        'bitly.com'         => { email => 'abuse@bitly.com',        note => 'URL shortener abuse' },
446        'bit.ly'            => { email => 'abuse@bitly.com',        note => 'URL shortener abuse' },
447        'tinyurl.com'       => { email => 'abuse@tinyurl.com',      note => 'URL shortener abuse' },
448        'ow.ly'             => { email => 'abuse@hootsuite.com',    note => 'Hootsuite URL shortener' },
449        'buff.ly'           => { email => 'abuse@buffer.com',       note => 'Buffer URL shortener' },
450        'rb.gy'             => { email => 'abuse@rb.gy',            note => 'URL shortener abuse' },
451        'cutt.ly'           => { email => 'abuse@cutt.ly',          note => 'URL shortener abuse' },
452        'shorturl.at'       => { email => 'abuse@shorturl.at',      note => 'URL shortener abuse' },
453        # Dynadot -- web form only
454        'dynadot.com'           => {
455                form        => 'https://www.dynadot.com/report-abuse',
456                form_paste  => 'Complete all fields including the domain name and your '
457                             . 'description of the abuse.  Paste the originating IP, '
458                             . 'risk flags, and the relevant Received: headers from the '
459                             . 'report below.',
460                form_upload => 'Take a screenshot of the report as a .png or .jpg, '
461                             . 'or export it as a .pdf.',
462                note        => 'Registrar -- email reports not monitored, use web form',
463        },
464        # Global Domain Group -- web form only
465        'globaldomaingroup.com' => {
466                form        => 'https://globaldomaingroup.com/report-abuse',
467                form_paste  => 'Complete all fields including the domain name and your '
468                             . 'description of the abuse.  Paste the originating IP, '
469                             . 'risk flags, and the relevant Received: headers from the '
470                             . 'report below.',
471                form_upload => 'Attach the original spam message as an .eml file.',
472                note        => 'Registrar -- email reports explicitly not accepted',
473        },
474        # TPG / Internode (Australia)
475        'tpgi.com.au'       => { email => 'abuse@tpg.com.au',      note => 'TPG Telecom Australia' },
476        'tpg.com.au'        => { email => 'abuse@tpg.com.au',      note => 'TPG Telecom Australia' },
477        'internode.on.net'  => { email => 'abuse@internode.on.net',note => 'Internode Australia' },
478);
479
480# -----------------------------------------------------------------------
481# Constructor
482# -----------------------------------------------------------------------
483
484 - 603
=head1 METHODS

=head2 new( %options )

Constructs and returns a new C<Email::Abuse::Investigator> analyser object.  The
object is stateless until C<parse_email()> is called; all analysis results
are stored on the object and retrieved via the public accessor methods
documented below.

A single object may be reused for multiple emails by calling C<parse_email()>
again: all per-message cached state from the previous message is discarded
automatically.  Cross-message IP and domain lookup results are retained
in a shared CHI cache (if C<CHI> is installed) to avoid redundant network
queries across messages processed in the same process.

=head3 Usage

    # Minimal -- all options take safe defaults
    my $analyser = Email::Abuse::Investigator->new();

    # With options
    my $analyser = Email::Abuse::Investigator->new(
        timeout        => 15,
        trusted_relays => ['203.0.113.0/24', '10.0.0.0/8'],
        verbose        => 0,
    );

    $analyser->parse_email($raw_rfc2822_text);
    my $origin   = $analyser->originating_ip();
    my @urls     = $analyser->embedded_urls();
    my @domains  = $analyser->mailto_domains();
    my $risk     = $analyser->risk_assessment();
    my @contacts = $analyser->abuse_contacts();
    print $analyser->report();

=head3 Arguments

All arguments are optional named parameters passed as a flat key-value list.

=over 4

=item C<timeout> (integer, default 10)

Maximum seconds to wait for any single network operation.  Set to 0 to
disable timeouts (not recommended for production use).

=item C<trusted_relays> (arrayref of strings, default [])

IP addresses or CIDR blocks to skip during Received: chain analysis.
Each element may be an exact IPv4 address (C<'192.0.2.1'>) or a CIDR
block (C<'192.0.2.0/24'>).

=item C<verbose> (boolean, default 0)

When true, diagnostic messages are written to STDERR.

=back

=head3 Returns

A blessed C<Email::Abuse::Investigator> object.  No network I/O is performed
during construction.

=head3 Side Effects

If C<CHI> is installed, a shared in-memory cache is initialised (or
re-used if a cache was already created by a prior call to C<new()>).
This cache persists for the lifetime of the process.

=head3 Notes

=over 4

=item *

Unknown option keys are silently ignored.

=item *

The object is not thread-safe.  Use a separate object per thread.

=item *

WHOIS read timeouts use C<IO::Select> rather than C<alarm()>, so they
work correctly on Windows and in threaded Perl interpreters.

=back

=head3 API Specification

=head4 Input

    {
        timeout => {
            type     => 'integer',
            optional => 1,
            min      => 0,
            default  => 10,
        },
        trusted_relays => {
            type          => 'arrayref',
            element_type  => 'string',
            optional      => 1,
            default       => [],
        },
        verbose => {
            type     => 'boolean',
            optional => 1,
            default  => 0,
        },
    }

=head4 Output

    {
        type => 'object',
        isa  => 'Email::Abuse::Investigator',
    }

=cut
604
605# Class-level cross-message CHI cache (shared across all instances).
606# Populated lazily on first call to new() when CHI is available.
607my $_cache;
608
609sub new {
610
2852
0
1812674
0
        my $class = shift;
611
612        # Accept hash or hashref arguments uniformly
613
2852
1
4692
67
        my $params = Params::Validate::Strict::validate_strict({
614                args => Params::Get::get_params(undef, \@_) || {},
615                schema => {
616                        timeout => {
617                                'type'     => 'integer',
618                                'optional' => 1,
619                                'min'      => 0,
620                        },
621                        trusted_relays => {
622                                'type'         => 'arrayref',
623                                'element_type' => 'string',
624                                'optional'     => 1,
625                        },
626                        verbose => {
627                                'type'     => 'boolean',
628                                'optional' => 1,
629                        },
630                },
631        });
632
633        # Merge in any file-based configuration via Object::Configure
634
1874
1
205386
3
        $params = Object::Configure::configure($class, $params);
635
636        # Initialise the cross-message CHI cache on first construction
637
1874
0
3470498
0
        if ($HAS_CHI && !$_cache) {
638
3
1
1
47
                $_cache = CHI->new(
639                        driver     => 'Memory',
640                        global     => 1,
641                        expires_in => $CACHE_TTL_SECS,
642                );
643        }
644
645        # Build and bless the object with default slot values
646        return bless {
647                timeout        => $DEFAULT_TIMEOUT,
648                trusted_relays => [],
649                verbose        => 0,
650                _raw           => '',
651                _headers       => [],
652                _body_plain    => '',
653                _body_html     => '',
654                _received      => [],
655                _origin        => undef,
656                _urls          => undef,     # lazy-computed by embedded_urls()
657                _mailto_domains=> undef,     # lazy-computed by mailto_domains()
658                _contacts      => undef,     # lazy-computed by abuse_contacts()
659                _domain_info   => {},        # per-message domain analysis cache
660                _sending_sw    => [],        # X-Mailer / X-PHP-Originating-Script etc.
661                _rcvd_tracking => [],        # per-hop tracking IDs from Received: headers
662
1874
1874
1
0
2906
10973
2
0
                %{$params},  # Overlay Object::Configure and caller-supplied values
663        }, $class;
664}
665
666# -----------------------------------------------------------------------
667# Public: parse
668# -----------------------------------------------------------------------
669
670 - 746
=head2 parse_email( $text )

Feeds a raw RFC 2822 email message to the analyser and prepares it for
subsequent interrogation.  This is the only method that must be called
before any other public method.

If the same object is used for a second message, calling C<parse_email()>
again completely replaces all per-message state from the first message.
The cross-message CHI cache is B<not> flushed; IP and domain lookups
cached from prior messages are retained.

=head3 Usage

    my $raw = do { local $/; <STDIN> };
    $analyser->parse_email($raw);

    # Scalar reference (avoids copying large messages)
    $analyser->parse_email(\$raw);

    # Chained
    my $analyser = Email::Abuse::Investigator->new()->parse_email($raw);

=head3 Arguments

=over 4

=item C<$text> (string or string reference, required)

Complete raw RFC 2822 email message, including all headers and the body.
Both LF-only and CRLF line endings are accepted.

=back

=head3 Returns

The object itself (C<$self>), enabling method chaining.

=head3 Side Effects

Parses headers, decodes the body (quoted-printable, base64, multipart),
extracts sending-software fingerprints, and populates per-hop tracking
data.  All previously computed lazy results are discarded.

=head3 Notes

=over 4

=item *

If C<$text> is empty or contains no header/body separator, all public
methods will return empty/safe values.

=item *

Decoding errors in base64 or quoted-printable payloads are silenced; raw
bytes are used in place of correct output to prevent exceptions.

=back

=head3 API Specification

=head4 Input

    [
        {
            type => [ 'string', 'stringref' ]
        },
    ]

=head4 Output

    {
        type => 'object',
        isa  => 'Email::Abuse::Investigator',
    }

=cut
747
748# TODO: Allow a Mail::Message object to be passed in
749sub parse_email {
750
726
1
70846
43
        my $self = shift;
751
752        # Accept both positional string and named 'text' argument
753
726
1
1034
2
        my $args = Params::Get::get_params('text', \@_);
754
725
1
16010
1
        my $text = $args->{text};
755
756        # Dereference a scalar-ref in a single clean pass
757
724
1
3058
1
        $text = $$text if ref($text) eq 'SCALAR';
758
759        # Any other reference type is a programming error
760
723
1
978
2
        Carp::croak(__PACKAGE__ . ': parse_email() requires a string or scalar reference') if ref($text);
761
762        # Sanitise: strip control characters that could affect terminal output.
763        # Keep \t (tabs in headers), \n (line endings), \r (CRLF mail format).
764
721
0
2766
0
        $text =~ s/[^\x09\x0A\x0D\x20-\x7E\x80-\xFF]//g if defined $text;
765
766        # Store the sanitised raw text for later reproduction in reports
767
721
1
1833
46
        $self->{_raw} = $text // '';
768
769        # Invalidate all per-message lazy caches
770
720
1
680
2
        $self->{_origin}         = undef;
771
720
1
596
0
        $self->{_urls}           = undef;
772
720
1
583
1
        $self->{_mailto_domains} = undef;
773
720
1
581
2
        $self->{_contacts}       = undef;
774
720
0
1391
0
        $self->{_domain_info}    = {};
775
720
1
667
45
        $self->{_risk}           = undef;
776
720
1
633
3
        $self->{_auth_results}   = undef;
777
720
0
627
0
        $self->{_sending_sw}     = [];
778
720
1
905
1803
        $self->{_rcvd_tracking}  = [];
779
780        # Perform synchronous header/body parsing (no network I/O)
781
720
1
2934
2
        $self->_split_message($text) if defined $text && $text =~ /\S/;
782
720
1
1129
17
        return $self;
783}
784
785# -----------------------------------------------------------------------
786# Public: originating host
787# -----------------------------------------------------------------------
788
789 - 850
=head2 originating_ip()

Identifies the IP address of the machine that originally injected the
message into the mail system by walking the C<Received:> chain, skipping
private/trusted hops, and enriching the first external hop with rDNS,
WHOIS/RDAP organisation name, abuse contact, and country code.

Both IPv4 and IPv6 addresses are extracted and evaluated.

The result is cached; subsequent calls return the same hashref without
repeating network I/O.

=head3 Usage

    my $orig = $analyser->originating_ip();
    if (defined $orig) {
        printf "Origin: %s (%s)\n", $orig->{ip}, $orig->{rdns};
        printf "Owner:  %s\n",      $orig->{org};
    }

=head3 Arguments

None.  C<parse_email()> must have been called first.

=head3 Returns

A hashref with keys C<ip>, C<rdns>, C<org>, C<abuse>, C<confidence>,
C<note>, and C<country> (may be undef).  Returns C<undef> if no suitable
originating IP can be determined.

=head3 Side Effects

On first call: one PTR lookup and one RDAP/WHOIS query.  Results are cached
in the object and in the cross-message CHI cache (if available).

=head3 Notes

Only the first (oldest) external IP in the chain is reported.  See
C<received_trail()> for the full chain.

=head3 API Specification

=head4 Input

    []

=head4 Output

    {
        type => [ 'hashref', 'undef' ],
        keys => {
            ip         => { type => 'string', regex => qr/[\d.:a-fA-F]/ },
            rdns       => { type => 'string' },
            org        => { type => 'string' },
            abuse      => { type => 'string' },
            confidence => { type => 'string', memberof => [ 'high', 'medium', 'low' ] },
            note       => { type => 'string' },
            country    => { type => 'string', optional => 1 },
        },
    }

=cut
851
852sub originating_ip {
853
770
1
5110
827
        my $self = $_[0];
854
855        # Return the cached result if we already have it
856
770
1
1231
1
        $self->{_origin} //= $self->_find_origin();
857
770
1
920
10
        return $self->{_origin};
858}
859
860# -----------------------------------------------------------------------
861# Public: HTTP/HTTPS URLs
862# -----------------------------------------------------------------------
863
864 - 938
=head2 embedded_urls()

Extracts every HTTP and HTTPS URL from the message body and enriches each
one with the hosting IP address, network organisation name, abuse contact,
and country code.  Both IPv4 and IPv6 host addresses are supported.

URL extraction runs across both plain-text and HTML body parts.  DNS
lookups for each unique hostname are optionally parallelised via
C<AnyEvent::DNS> if that module is installed.

The result is cached; subsequent calls return the same list without
repeating network I/O.

=head3 Usage

    my @urls = $analyser->embedded_urls();
    for my $u (@urls) {
        printf "URL: %s  host: %s  org: %s\n",
            $u->{url}, $u->{host}, $u->{org};
    }

=head3 Arguments

None.  C<parse_email()> must have been called first.

=head3 Returns

A list of hashrefs, one per unique URL, in first-seen order.  Returns an
empty list if no HTTP/HTTPS URLs are present.  Each hashref has keys
C<url>, C<host>, C<ip>, C<org>, C<abuse>, C<country>.

=head3 Side Effects

Per unique hostname: one A/AAAA lookup and one RDAP/WHOIS query.  Results
are cached in the object and in the cross-message CHI cache.

=head3 Notes

Only C<http://> and C<https://> URLs are extracted.  URL shortener hosts
are included in the returned list (they are flagged by C<risk_assessment()>).

When L<LWP::UserAgent> is available, URLs whose host is a known URL shortener
or cloud-storage redirect cloaker (Google Cloud Storage C<storage.googleapis.com>,
Azure Blob Storage C<blob.core.windows.net>, Cloudflare Pages C<pages.dev>,
S3 buckets, CloudFront distributions, etc.) are automatically resolved by
following HTTP 3xx redirects and HTML C<meta http-equiv="refresh"> or
C<window.location> patterns up to C<$REDIRECT_MAX_HOPS> hops.  The resolved
destination URL is added to the returned list alongside the original, so abuse
contacts for the real phishing target are always reported even when the email
body contains only an object-store redirect URL.

=head3 API Specification

=head4 Input

    []

=head4 Output

    (
        {
            type => 'hashref',
            keys => {
                url     => { type => 'string', regex => qr{^https?://}i },
                host    => { type => 'string' },
                ip      => { type => 'string' },
                org     => { type => 'string' },
                abuse   => { type => 'string' },
                country => { type => 'string', optional => 1 },
            },
        },
        ...
    )

=cut
939
940sub embedded_urls {
941
1100
1
12583
396
        my $self = $_[0];
942
943
1100
1
1597
1
        $self->{_urls} //= $self->_extract_and_resolve_urls();
944
1100
985
1
1
856
1286
8
1103
        return @{ $self->{_urls} };
945}
946
947# -----------------------------------------------------------------------
948# Public: mailto / reply-to / from domains
949# -----------------------------------------------------------------------
950
951 - 1009
=head2 mailto_domains()

Identifies every domain associated with the message as a contact, reply,
or delivery address, then runs a full intelligence pipeline on each one
(A record, MX, NS, WHOIS) to determine hosting and registration details.

The result is cached; subsequent calls return the same list without
repeating network I/O.

=head3 Usage

    my @domains = $analyser->mailto_domains();
    for my $d (@domains) {
        printf "Domain: %s  registrar: %s\n",
            $d->{domain}, $d->{registrar} // 'unknown';
    }

=head3 Arguments

None.  C<parse_email()> must have been called first.

=head3 Returns

A list of hashrefs, one per unique domain.  See the main POD for the full
set of possible keys.  Returns an empty list if no qualifying domains are
found.

=head3 Side Effects

Per unique domain: up to three A lookups, one MX lookup, one NS lookup,
and two WHOIS queries.  Results are cached in the object and in the
cross-message CHI cache.

=head3 Notes

MX and NS lookups require C<Net::DNS>.  Without it those keys are absent
from every returned hashref.

=head3 API Specification

=head4 Input

    []

=head4 Output

    (
        {
            type => 'hashref',
            keys => {
                domain  => { type => 'string' },
                source  => { type => 'string' },
                # All other keys optional -- see main POD
            },
        },
        ...
    )

=cut
1010
1011sub mailto_domains {
1012
789
1
1456
2
        my $self = $_[0];
1013
1014
789
1
1108
9
        $self->{_mailto_domains} //= $self->_extract_and_analyse_domains();
1015
789
789
1
1
521
1002
763
0
        return @{ $self->{_mailto_domains} };
1016}
1017
1018 - 1062
=head2 all_domains()

Returns the deduplicated union of every registrable domain seen anywhere
in the message -- URL hosts from C<embedded_urls()> and contact domains
from C<mailto_domains()> -- normalised to eTLD+1 form.

Triggers C<embedded_urls()> and C<mailto_domains()> lazily.

=head3 Usage

    my @domains = $analyser->all_domains();
    print "$_\n" for @domains;

=head3 Arguments

None.

=head3 Returns

A list of plain strings (registrable domain names), lower-cased, no
duplicates, in first-seen order.

=head3 Side Effects

Triggers C<embedded_urls()> and C<mailto_domains()> if not already cached.

=head3 Notes

Normalisation to eTLD+1 uses C<Domain::PublicSuffix> if installed, falling
back to a built-in heuristic otherwise.

=head3 API Specification

=head4 Input

    []

=head4 Output

    (
        { type => 'string', regex => qr/^[a-z0-9][a-z0-9.-]*\.[a-z]{2,}$/ },
        ...
    )

=cut
1063
1064sub all_domains {
1065
136
1
6042
9
        my $self = $_[0];
1066
136
1
190
2208
        my (%seen, @out);
1067
1068        # Collect registrable domains from URL hosts first
1069
136
1
149
1
        for my $u ($self->embedded_urls()) {
1070
131
1
245
10
                my $dom = _registrable($u->{host});
1071
20
1
66
2528
                push @out, $dom if $dom && !$seen{$dom}++;
1072        }
1073
1074        # Then from contact domains (normalise subdomains to registrable parent)
1075
25
1
42
2
        for my $d ($self->mailto_domains()) {
1076
30
1
85
9
                my $dom = _registrable($d->{domain}) // $d->{domain};
1077
29
1
70
1565
                push @out, $dom if $dom && !$seen{$dom}++;
1078        }
1079
24
1
38
1
        return @out;
1080}
1081
1082 - 1135
=head2 unresolved_contacts()

Returns a list of domains and URL hosts found in the message for which no
abuse contact could be determined.  Useful for surfacing parties that may
warrant manual investigation.

=head3 Usage

    my @unresolved = $analyser->unresolved_contacts();
    for my $u (@unresolved) {
        printf "Unresolved: %s (%s) via %s\n",
            $u->{domain}, $u->{type}, $u->{source};
    }

=head3 Arguments

None.

=head3 Returns

A list of hashrefs, each with keys C<domain>, C<type> (C<'url_host'> or
C<'domain'>), and C<source> (where the domain was found).

=head3 Side Effects

Triggers C<embedded_urls()>, C<mailto_domains()>, C<abuse_contacts()>,
and C<form_contacts()> if not already cached.

=head3 Notes

Domains sourced only from spoofable sending headers (C<From:>,
C<Return-Path:>, C<Sender:>) are excluded.

=head3 API Specification

=head4 Input

    []

=head4 Output

    (
        {
            type => 'hashref',
            keys => {
                domain => { type => 'string' },
                type   => { type => 'string', memberof => [ 'url_host', 'domain' ] },
                source => { type => 'string' },
            },
        },
        ...
    )

=cut
1136
1137sub unresolved_contacts {
1138
35
1
956
13
        my $self = $_[0];
1139
1140        # Build a set of domains already covered by email or form contacts
1141
35
1
32
1491
        my %covered;
1142
35
1
70
1
        for my $c ($self->abuse_contacts(), $self->form_contacts()) {
1143
16
1
67
10
                my $dom = $c->{form_domain};
1144
16
1
29
1135
                unless ($dom) {
1145                        # Extract domain from abuse email address
1146
16
1
74
2
                        ($dom) = ($c->{address} // '') =~ /\@([\w.-]+)/;
1147                }
1148
16
1
46
9
                $covered{lc $dom}++ if $dom;
1149        }
1150
1151        # Also mark URL hosts that already have a resolved abuse address
1152
35
1
385
1347
        for my $u ($self->embedded_urls()) {
1153
18
1
45
1
                (my $bare = lc $u->{host}) =~ s/^www\.//;
1154
15
1
62
8
                $covered{$bare}++ if $u->{abuse} && $u->{abuse} ne '(unknown)';
1155        }
1156
1157
35
1
286
305
        my (@out, %seen);
1158
1159        # Check URL hosts first
1160
35
1
53
1
        for my $u ($self->embedded_urls()) {
1161
15
1
24
8
                (my $bare = lc $u->{host}) =~ s/^www\.//;
1162
18
1
194
293
                next if $covered{$bare};
1163
14
1
29
1
                next if $self->_provider_abuse_for_host($bare);
1164
10
1
25
8
                next if $seen{"url:$bare"}++;
1165                push @out, {
1166                        domain => $u->{host},
1167
12
1
153
219
                        type   => 'url_host',
1168                        source => 'URL in body',
1169                };
1170        }
1171
1172        # Then check contact domains, skipping spoofable-header-only sources
1173
35
1
60
1
        for my $d ($self->mailto_domains()) {
1174
38
1
38
8
                my $dom    = $d->{domain};
1175
38
1
55
974
                my $source = $d->{source} // '';
1176
38
1
81
2
                next if $source =~ /^(?:From:|Return-Path:|Sender:) header$/;
1177
11
1
27
12
                next if $covered{lc $dom};
1178
13
1
176
779
                next if $self->_provider_abuse_for_host($dom);
1179
13
1
34
2
                next if $seen{"dom:$dom"}++;
1180
13
1
26
8
                push @out, {
1181                        domain => $dom,
1182                        type   => 'domain',
1183                        source => $source,
1184                };
1185        }
1186
1187
35
1
79
857
        return @out;
1188}
1189
1190# -----------------------------------------------------------------------
1191# Public: sending software fingerprint
1192# -----------------------------------------------------------------------
1193
1194 - 1248
=head2 sending_software()

Returns information extracted from headers that identify the software or
server-side infrastructure used to compose or inject the message.  Headers
such as C<X-PHP-Originating-Script> reveal the exact PHP script and Unix
account responsible on shared-hosting platforms.

Data is extracted during C<parse_email()> with no network I/O.

=head3 Usage

    my @sw = $analyser->sending_software();
    for my $s (@sw) {
        printf "%-30s : %s\n", $s->{header}, $s->{value};
    }

=head3 Arguments

None.  C<parse_email()> must have been called first.

=head3 Returns

A list of hashrefs in alphabetical header-name order.  Returns an empty
list if none of the watched headers are present.  Each hashref has keys
C<header>, C<value>, and C<note>.

=head3 Side Effects

None.  Data is pre-collected during C<parse_email()>.

=head3 Notes

Header names are lower-cased.  Header values are stored verbatim.

=head3 API Specification

=head4 Input

    []

=head4 Output

    (
        {
            type => 'hashref',
            keys => {
                header => { type => 'string' },
                value  => { type => 'string' },
                note   => { type => 'string' },
            },
        },
        ...
    )

=cut
1249
1250sub sending_software {
1251
99
1
282
1
        my $self = $_[0];
1252
1253
96
99
1
1
63
279
9
593
        return @{ $self->{_sending_sw} };
1254}
1255
1256# -----------------------------------------------------------------------
1257# Public: per-hop tracking IDs
1258# -----------------------------------------------------------------------
1259
1260 - 1316
=head2 received_trail()

Returns per-hop tracking data extracted from the C<Received:> header chain:
the IP address, envelope recipient address, and server session ID for each
relay.  ISP postmasters use these identifiers to locate the SMTP session in
their logs.

=head3 Usage

    my @trail = $analyser->received_trail();
    for my $hop (@trail) {
        printf "IP: %s  ID: %s\n",
            $hop->{ip} // '?', $hop->{id} // '?';
    }

=head3 Arguments

None.  C<parse_email()> must have been called first.

=head3 Returns

A list of hashrefs in oldest-first order.  Returns an empty list if no
C<Received:> headers are present or none yielded extractable data.  Each
hashref has keys C<received>, C<ip> (may be undef), C<for> (may be undef),
C<id> (may be undef).

=head3 Side Effects

None.  Data is pre-collected during C<parse_email()>.

=head3 Notes

Private IPs are NOT filtered here; all IPs including RFC 1918 addresses
are returned as found.  Filtering is applied only by C<originating_ip()>.

=head3 API Specification

=head4 Input

    []

=head4 Output

    (
        {
            type => 'hashref',
            keys => {
                received => { type => 'string' },
                ip       => { type => 'string', optional => 1 },
                for      => { type => 'string', optional => 1 },
                id       => { type => 'string', optional => 1 },
            },
        },
        ...
    )

=cut
1317
1318sub received_trail {
1319
97
1
269
1
        my $self = $_[0];
1320
1321
94
97
1
1
70
5462
9
1460
        return @{ $self->{_rcvd_tracking} };
1322}
1323
1324# -----------------------------------------------------------------------
1325# Public: risk assessment
1326# -----------------------------------------------------------------------
1327
1328 - 1383
=head2 risk_assessment()

Evaluates the message against heuristic checks and returns an overall risk
level, a weighted numeric score, and a list of every specific red flag.

The assessment covers five categories: originating IP, email authentication,
Date: header validity, identity/header consistency, and URL/domain properties.

The result is cached; subsequent calls return the same hashref without
repeating any analysis.

=head3 Usage

    my $risk = $analyser->risk_assessment();
    printf "Risk: %s (score: %d)\n", $risk->{level}, $risk->{score};
    for my $f (@{ $risk->{flags} }) {
        printf "  [%s] %s\n", $f->{severity}, $f->{detail};
    }

=head3 Arguments

None.  C<parse_email()> must have been called first.

=head3 Returns

A hashref with keys C<level> (HIGH/MEDIUM/LOW/INFO), C<score> (integer),
and C<flags> (arrayref of hashrefs with C<severity>, C<flag>, C<detail>).

=head3 Side Effects

Triggers C<originating_ip()>, C<embedded_urls()>, and C<mailto_domains()>
if not already cached.

=head3 Notes

Scores: HIGH >= 9, MEDIUM >= 5, LOW >= 2, INFO < 2.
Flag weights: HIGH=3, MEDIUM=2, LOW=1, INFO=0.

=head3 API Specification

=head4 Input

    []

=head4 Output

    {
        type => 'hashref',
        keys => {
            level => { type => 'string', memberof => ['HIGH', 'MEDIUM', 'LOW', 'INFO'] },
            score => { type => 'integer' },
            flags => { type => 'arrayref' },
        },
    }

=cut
1384
1385sub risk_assessment {
1386
403
1
8556
1
        my $self = $_[0];
1387
1388
404
1
585
9
        return $self->{_risk} if $self->{_risk};
1389
1390
379
1
3333
1372
        my (@flags, $score);
1391
379
1
289
1
        $score = 0;
1392
1393        # Closure to record a flag and accumulate its weight
1394        my $flag = sub {
1395
386
1
3871
502
                my ($severity, $name, $detail) = @_;
1396
387
1
810
1
                $score += $FLAG_WEIGHT{$severity} // 1;
1397
387
1
1785
8
                push @flags, { severity => $severity, flag => $name, detail => $detail };
1398
378
1
743
9
        };
1399
1400
378
1
4940
898
        $self->_risk_check_origin($flag);
1401
378
1
607
1
        $self->_risk_check_auth($flag);
1402
378
1
616
9
        $self->_risk_check_date($flag);
1403
378
1
4079
503
        $self->_risk_check_identity($flag);
1404
380
1
594
2
        $self->_risk_check_urls_and_domains($flag);
1405
1406        # Determine overall risk level from accumulated score
1407
380
1
1431
9
        my $level = $score >= $SCORE_HIGH   ? 'HIGH'
1408                  : $score >= $SCORE_MEDIUM ? 'MEDIUM'
1409                  : $score >= $SCORE_LOW    ? 'LOW'
1410                  :                           'INFO';
1411
1412
380
1
7070
1101
        $self->{_risk} = { level => $level, score => $score, flags => \@flags };
1413
376
1
1191
1
        return $self->{_risk};
1414}
1415
1416# _risk_check_origin( $flag )
1417#
1418# Purpose:
1419#   Evaluate the originating IP for residential rDNS, absent rDNS,
1420#   low-confidence origin, and high-spam-volume country.
1421#
1422# Entry criteria:
1423#   $flag -- coderef( severity, name, detail ) that accumulates flags.
1424#
1425# Exit status:
1426#   Returns nothing; side effects via $flag closure.
1427
1428sub _risk_check_origin :Private {
1429        my ($self, $flag) = @_;
1430        my $orig = $self->originating_ip();
1431        return unless $orig;
1432
1433        return if(!defined($orig->{ip}));
1434
1435        # Residential / broadband rDNS patterns suggest a compromised host
1436        if ($orig->{rdns} && $orig->{rdns} =~ /
1437                \d+[-_.]\d+[-_.]\d+[-_.]\d+   # dotted-quad in rDNS
1438                | (?:dsl|adsl|cable|broad|dial|dynamic|dhcp|ppp|
1439                     residential|cust|home|pool|client|user|
1440                     static\d|host\d)
1441        /xi) {
1442                $flag->('HIGH', 'residential_sending_ip',
1443                        "Sending IP $orig->{ip} rDNS '$orig->{rdns}' looks like a broadband/residential line, not a legitimate mail server");
1444        }
1445
1446        # Absence of rDNS is a strong spam indicator
1447        if (!$orig->{rdns} || $orig->{rdns} eq '(no reverse DNS)') {
1448                $flag->('HIGH', 'no_reverse_dns',
1449                        "Sending IP $orig->{ip} has no reverse DNS -- legitimate mail servers always have rDNS");
1450        }
1451
1452        # Low-confidence origin means the IP came from an unverifiable header
1453        if ($orig->{confidence} eq 'low') {
1454                $flag->('MEDIUM', 'low_confidence_origin',
1455                        "Originating IP taken from unverified header ($orig->{note})");
1456        }
1457
1458        # Statistically high-volume spam countries (informational only)
1459        if ($orig->{country} && $orig->{country} =~ /^(?:CN|RU|NG|VN|IN|PK|BD)$/) {
1460                $flag->('INFO', 'high_spam_country',
1461                        'Sending IP is in ' . _country_name($orig->{country}) .
1462                        " ($orig->{country}) -- statistically high spam volume country");
1463        }
1464
26
26
26
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
5362
26
518
2656
3
26
870
1
10
868
1
10
742
1
10
1
14
1317
2
12
563
1
20
1385
}
1465
1466# _risk_check_auth( $flag )
1467#
1468# Purpose:
1469#   Evaluate SPF, DKIM, DMARC results and DKIM signing domain alignment.
1470#
1471# Entry criteria:
1472#   $flag -- accumulator coderef.
1473#
1474# Exit status:
1475#   Returns nothing; side effects via $flag closure.
1476
1477sub _risk_check_auth :Private {
1478        my ($self, $flag) = @_;
1479        my $auth = $self->_parse_auth_results_cached();
1480
1481        if (defined $auth->{spf}) {
1482                if ($auth->{spf} =~ /^fail/i) {
1483                        $flag->('HIGH', 'spf_fail',
1484                                "SPF result: $auth->{spf} -- sending IP not authorised by domain's SPF record");
1485                } elsif ($auth->{spf} =~ /^softfail/i) {
1486                        $flag->('MEDIUM', 'spf_softfail',
1487                                "SPF result: softfail (~all) -- sending IP not explicitly authorised");
1488                } elsif ($auth->{spf} !~ /^pass/i) {
1489                        $flag->('HIGH', 'spf_fail',
1490                                "SPF result: $auth->{spf} -- sending IP not authorised");
1491                }
1492        }
1493        if (defined $auth->{dkim} && $auth->{dkim} !~ /^pass/i) {
1494                $flag->('HIGH', 'dkim_fail',
1495                        "DKIM result: $auth->{dkim} -- message signature invalid or absent");
1496        }
1497        if (defined $auth->{dmarc} && $auth->{dmarc} !~ /^pass/i) {
1498                $flag->('HIGH', 'dmarc_fail', "DMARC result: $auth->{dmarc}");
1499        }
1500
1501        # DKIM signing domain vs From: domain mismatch check
1502        return unless $auth->{dkim_domain};
1503        my ($from_domain) = ($self->_header_value('from') // '') =~ /\@([\w.-]+)/;
1504        return unless $from_domain;
1505        my $reg_dkim = _registrable($auth->{dkim_domain}) // $auth->{dkim_domain};
1506        my $reg_from = _registrable(lc $from_domain)     // lc $from_domain;
1507        return if $reg_dkim eq $reg_from;
1508
1509        # Passing DKIM with a different domain is normal for ESPs
1510        if ($auth->{dkim} && $auth->{dkim} =~ /^pass/i) {
1511                $flag->('INFO', 'dkim_domain_mismatch',
1512                        "DKIM signed by '$auth->{dkim_domain}' but From: domain is '$from_domain'"
1513                        . ' -- message sent via third-party sender (normal for bulk/ESP mail)');
1514        } else {
1515                # Failing DKIM plus mismatched domain is more suspicious
1516                $flag->('MEDIUM', 'dkim_domain_mismatch',
1517                        "DKIM signed by '$auth->{dkim_domain}' but From: domain is '$from_domain'"
1518                        . ' and DKIM did not pass -- possible impersonation');
1519        }
1520
26
26
26
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
11223
23
231
3340
3
30
847
1
11
651
1
9
1086
1
10
1
10
975
2
9
683
2
9
999
}
1521
1522# _risk_check_date( $flag )
1523#
1524# Purpose:
1525#   Validate the Date: header for presence, plausible timezone, and
1526#   date not too far in the past or future.
1527#
1528# Entry criteria:
1529#   $flag -- accumulator coderef.
1530#
1531# Exit status:
1532#   Returns nothing; side effects via $flag closure.
1533
1534sub _risk_check_date :Private {
1535        my ($self, $flag) = @_;
1536        my $date_raw = $self->_header_value('date');
1537
1538        if (!$date_raw || $date_raw !~ /\S/) {
1539                $flag->('MEDIUM', 'missing_date',
1540                        'No Date: header -- violates RFC 5322; common in spam');
1541                return;
1542        }
1543
1544        # Check for an implausible timezone offset (outside real-world bounds)
1545        if ($date_raw =~ /([+-])(\d{2})(\d{2})\s*$/) {
1546                my ($sign, $hh, $mm) = ($1, $2, $3);
1547                my $offset_mins = $hh * 60 + $mm;
1548                my $implausible = $mm >= 60
1549                        || ($sign eq '+' && $offset_mins > $TZ_MAX_POS_MINS)
1550                        || ($sign eq '-' && $offset_mins > $TZ_MAX_NEG_MINS);
1551                if ($implausible) {
1552                        $flag->('MEDIUM', 'implausible_timezone',
1553                                "Date: '$date_raw' contains an implausible timezone offset "
1554                                . "($sign$hh$mm) -- header is likely forged");
1555                }
1556        }
1557
1558        # Check for dates more than DATE_SKEW_DAYS outside the analysis window
1559        my $date_epoch = _parse_rfc2822_date($date_raw);
1560        return unless defined $date_epoch;
1561        my $delta = time() - $date_epoch;
1562        if ($delta > $DATE_SKEW_DAYS * $SECS_PER_DAY) {
1563                $flag->('LOW', 'suspicious_date',
1564                        "Date: '$date_raw' is more than $DATE_SKEW_DAYS days in the past");
1565        } elsif ($delta < -($DATE_SKEW_DAYS * $SECS_PER_DAY)) {
1566                $flag->('LOW', 'suspicious_date',
1567                        "Date: '$date_raw' is more than $DATE_SKEW_DAYS days in the future");
1568        }
1569
26
26
26
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
7599
22
248
2647
3
28
1157
2
9
939
2
9
1416
2
30
1
10
1721
1
9
863
1
9
1687
}
1570
1571# _risk_check_identity( $flag )
1572#
1573# Purpose:
1574#   Check From: display-name spoofing, free webmail, Reply-To mismatch,
1575#   undisclosed recipients, and MIME-encoded Subject.
1576#
1577# Entry criteria:
1578#   $flag -- accumulator coderef.
1579#
1580# Exit status:
1581#   Returns nothing; side effects via $flag closure.
1582
1583sub _risk_check_identity :Private {
1584        my ($self, $flag) = @_;
1585        my $from_raw     = $self->_header_value('from') // '';
1586        my $from_decoded = $self->_decode_mime_words($from_raw);
1587
1588        # Display-name domain spoofing: "PayPal paypal.com" <phish@evil.example>
1589        if ($from_decoded =~ /^"?([^"<]+?)"?\s*<([^>]+)>/) {
1590                my ($display, $addr) = ($1, $2);
1591                while ($display =~ /\b([\w-]+\.(?:com|net|org|io|co|uk|au|gov|edu))\b/gi) {
1592                        my $disp_domain = lc $1;
1593                        my ($addr_domain) = $addr =~ /\@([\w.-]+)/;
1594                        $addr_domain = lc($addr_domain // '');
1595                        my $reg_disp = _registrable($disp_domain);
1596                        my $reg_addr = _registrable($addr_domain);
1597                        if ($reg_disp && $reg_addr && $reg_disp ne $reg_addr) {
1598                                $flag->('HIGH', 'display_name_domain_spoof',
1599                                        "From: display name mentions '$disp_domain' but actual address is <$addr>");
1600                        }
1601                }
1602        }
1603
1604        # Free webmail sender flag (no corporate infrastructure)
1605        if ($from_raw =~ /\@(gmail|yahoo|hotmail|outlook|live|aol|protonmail|yandex)\./i
1606         || $from_raw =~ /\@mail\.ru(?:[\s>]|$)/i) {
1607                $flag->('MEDIUM', 'free_webmail_sender',
1608                        "Message sent from free webmail address ($from_raw)");
1609        }
1610
1611        # Reply-To differs from From: -- replies harvested by different address
1612        my $reply_to = $self->_header_value('reply-to');
1613        if ($reply_to) {
1614                my ($from_addr)  = $from_raw =~ /([\w.+%-]+\@[\w.-]+)/;
1615                my ($reply_addr) = $reply_to =~ /([\w.+%-]+\@[\w.-]+)/;
1616                if ($from_addr && $reply_addr && lc($from_addr) ne lc($reply_addr)) {
1617                        $flag->('MEDIUM', 'reply_to_differs_from_from',
1618                                "Reply-To ($reply_addr) differs from From: ($from_addr)");
1619                }
1620        }
1621
1622        # Undisclosed or absent To: header
1623        my $to = $self->_header_value('to') // '';
1624        if ($to =~ /undisclosed|:;/ || $to eq '') {
1625                $flag->('MEDIUM', 'undisclosed_recipients',
1626                        "To: header is '$to' -- message was bulk-sent with hidden recipient list");
1627        }
1628
1629        # MIME-encoded Subject (potential filter evasion)
1630        my $subj_raw = $self->_header_value('subject') // '';
1631        if ($subj_raw =~ /=\?[^?]+\?[BQ]\?/i) {
1632                $flag->('LOW', 'encoded_subject',
1633                        "Subject line is MIME-encoded: '$subj_raw' (decoded: '"
1634                        . $self->_decode_mime_words($subj_raw) . "')");
1635        }
1636
26
26
26
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
16557
23
241
4351
5
29
1395
1
10
1314
2
9
1778
1
10
1
10
1297
1
9
564
1
10
1368
}
1637
1638# _risk_check_urls_and_domains( $flag )
1639#
1640# Purpose:
1641#   Check embedded URLs for shorteners and plain HTTP, and contact domains
1642#   for recent registration, imminent expiry, and lookalike brand names.
1643#
1644# Entry criteria:
1645#   $flag -- accumulator coderef.
1646#
1647# Exit status:
1648#   Returns nothing; side effects via $flag closure.
1649
1650sub _risk_check_urls_and_domains :Private {
1651        my ($self, $flag) = @_;
1652        my (%shortener_seen, %cloaker_seen, %url_host_seen);
1653
1654        for my $u ($self->embedded_urls()) {
1655                # Skip trusted infrastructure -- these are not spam indicators
1656                next unless($u->{host});
1657                my $bare = lc $u->{host};
1658                next unless defined($bare);
1659                $bare =~ s/^www\.//;
1660                next if $self->{trusted_domains}->{$bare};
1661                next if $TRUSTED_DOMAINS{$bare};
1662
1663                # URL shortener hides real destination
1664                if(($URL_SHORTENERS{$bare} || $self->{url_shorteners}->{$bare}) && !$shortener_seen{$bare}++) {
1665                        $flag->('MEDIUM', 'url_shortener',
1666                                "$u->{host} is a URL shortener -- the real destination is hidden");
1667                }
1668                # Cloud object-store / CDN used as a redirect cloaker
1669                if ($self->_is_redirect_cloaker($bare) && !$cloaker_seen{$bare}++) {
1670                        $flag->('MEDIUM', 'redirect_cloaker',
1671                                "$u->{host} is a cloud storage or CDN host used as a redirect cloaker -- the real phishing destination is hidden behind a client-side redirect");
1672                }
1673                # Plain HTTP provides no encryption
1674                if ($u->{url} =~ m{^http://}i && !$url_host_seen{ $u->{host} }++) {
1675                        $flag->('LOW', 'http_not_https',
1676                                "$u->{host} linked over plain HTTP -- no encryption");
1677                }
1678        }
1679
1680        # Domain-level checks against contact/reply domains
1681        for my $d ($self->mailto_domains()) {
1682                # Recently registered domain is a common phishing indicator
1683                if ($d->{recently_registered}) {
1684                        $flag->('HIGH', 'recently_registered_domain',
1685                                "$d->{domain} was registered $d->{registered} (less than ${\$RECENT_REG_DAYS} days ago)");
1686                }
1687
1688                # Domain expiry checks
1689                if ($d->{expires}) {
1690                        if(my $exp = $self->_parse_date_to_epoch($d->{expires})) {
1691                                my $now      = time();
1692                                my $remaining = $exp - $now;
1693                                if ($remaining > 0 && $remaining < $EXPIRY_WARN_DAYS * $SECS_PER_DAY) {
1694                                        $flag->('HIGH', 'domain_expires_soon',
1695                                                "$d->{domain} expires $d->{expires} -- may be a throwaway domain");
1696                                } elsif ($remaining <= 0) {
1697                                        $flag->('HIGH', 'domain_expired',
1698                                                "$d->{domain} expired $d->{expires} -- domain has lapsed");
1699                                }
1700                        }
1701                }
1702
1703                # Lookalike domain check (brand name in a non-brand domain)
1704                for my $brand (@LOOKALIKE_BRANDS) {
1705                        next if(!defined($d->{domain}));
1706                        if ($d->{domain} =~ /\Q$brand\E/i &&
1707                            $d->{domain} !~ /^\Q$brand\E\.(?:com|co\.uk|net|org)$/) {
1708                                $flag->('HIGH', 'lookalike_domain',
1709                                        "$d->{domain} contains brand name '$brand' but is not the real domain -- possible phishing");
1710                                last;
1711                        }
1712                }
1713        }
1714
26
26
26
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
10522
29
233
3118
4
28
1129
1
9
883
1
10
1385
1
10
1
10
1687
1
9
2448
1
12
1710
}
1715
1716# -----------------------------------------------------------------------
1717# Public: abuse report text
1718# -----------------------------------------------------------------------
1719
1720 - 1767
=head2 abuse_report_text()

Produces a compact, plain-text string suitable for sending as the body of
an abuse report email.  It summarises risk level, red flags, originating IP,
abuse contacts, and original message headers.  The message body is omitted
to keep the report concise.

Use C<abuse_contacts()> to get the recipient addresses and this method for
the body text.

=head3 Usage

    my $text     = $analyser->abuse_report_text();
    my @contacts = $analyser->abuse_contacts();
    for my $c (@contacts) {
        send_email(to => $c->{address}, body => $text);
    }

=head3 Arguments

None.  C<parse_email()> must have been called first.

=head3 Returns

A plain scalar string, newline-terminated, Unix line endings.  Never empty
or undef.

=head3 Side Effects

Calls C<risk_assessment()>, C<originating_ip()>, and C<abuse_contacts()>
if not already cached.

=head3 Notes

Output text is sanitised: control characters that could affect terminal or
HTML rendering are stripped from all user-derived content before inclusion.

=head3 API Specification

=head4 Input

    []

=head4 Output

    { type => 'string' }

=cut
1768
1769sub abuse_report_text {
1770
22
1
341
8
        my $self = $_[0];
1771
22
1
6717
859
        my @out;
1772
1773
22
1
30
1
        push @out, 'This is an automated abuse report generated by Email::Abuse::Investigator.',
1774                 'Please investigate the following spam/phishing message.',
1775                '';
1776
1777
24
1
64
8
        my $risk = $self->risk_assessment();
1778
22
1
3184
915
        push @out, "RISK LEVEL: $risk->{level} (score: $risk->{score})",
1779                '';
1780
1781        # List each red flag with its severity prefix
1782
22
22
1
1
18
58
1
35
        if (@{ $risk->{flags} }) {
1783
13
1
2108
763
                push @out, 'RED FLAGS IDENTIFIED:';
1784
13
13
1
1
13
44
1
8
                for my $f (@{ $risk->{flags} }) {
1785
19
1
925
845
                        push @out, "  [$f->{severity}] " . _sanitise_output($f->{detail});
1786                }
1787
13
1
16
0
                push @out, '';
1788        }
1789
1790        # Originating IP summary block
1791
22
1
47
9
        my $orig = $self->originating_ip();
1792
22
1
2061
963
        if ($orig) {
1793                push @out, 'ORIGINATING IP: ' . _sanitise_output("$orig->{ip} ($orig->{rdns})"),
1794
15
1
28
1
                        'NETWORK OWNER:  ' . _sanitise_output($orig->{org}),
1795                        '';
1796        }
1797
1798        # List every reported URL so the receiving abuse desk knows exactly
1799        # which resources to investigate or suspend.
1800
22
1
50
8
        my @urls = $self->embedded_urls();
1801
22
1
3674
1326
        if (@urls) {
1802
7
1
9
1
                push @out, 'REPORTED URLs:';
1803
7
1
30
10
                for my $u (@urls) {
1804
7
1
3417
1302
                        push @out, '  ' . _sanitise_output($u->{url});
1805
7
1
8
1
                        my @meta;
1806
7
1
32
9
                        push @meta, "host: $u->{host}"   if $u->{host};
1807
7
1
2427
902
                        push @meta, "IP: $u->{ip}"       if $u->{ip} && $u->{ip} ne '(unresolved)';
1808
7
1
14
1
                        push @meta, "org: $u->{org}"     if $u->{org} && $u->{org} ne '(unknown)';
1809
7
1
47
8
                        push @out, '    (' . join('  ', @meta) . ')' if @meta;
1810                }
1811
7
1
3843
604
                push @out, '';
1812        }
1813
1814        # Email abuse contacts
1815
22
1
33
1
        my @contacts = $self->abuse_contacts();
1816
22
1
55
9
        if (@contacts) {
1817
17
1
3247
434
                push @out, 'ABUSE CONTACTS:';
1818
17
1
38
1
                push @out, '  ' . _sanitise_output("$_->{address} ($_->{role})") for @contacts;
1819
17
1
38
9
                push @out, '';
1820        }
1821
1822        # Web-form contacts (providers that reject email)
1823
22
1
3523
633
        if(my @form_cs = $self->form_contacts()) {
1824
4
1
5
2
                push @out, 'WEB-FORM REPORTS REQUIRED:',
1825                        '  The following parties do not accept email -- submit manually:';
1826
4
1
31
7
                for my $c (@form_cs) {
1827                        push @out, "  [$c->{role}]",
1828
4
1
3004
849
                                '    Form   : ' . _sanitise_output($c->{form});
1829
4
1
6
1
                        push @out, '    Domain : ' . _sanitise_output($c->{form_domain}) if $c->{form_domain};
1830
4
1
30
9
                        push @out, '    Paste  : ' . _sanitise_output($c->{form_paste})  if $c->{form_paste};
1831
4
1
2306
794
                        push @out, '    Upload : ' . _sanitise_output($c->{form_upload}) if $c->{form_upload};
1832                }
1833
4
1
5
2
                push @out, '';
1834        }
1835
1836        # Separator and raw headers (body excluded for brevity)
1837
22
1
83
9
        push @out, '-' x 72,
1838                'ORIGINAL MESSAGE HEADERS:',
1839                '-' x 72;
1840
1841
22
22
1
1
3036
27
733
1
        for my $h (@{ $self->{_headers} }) {
1842
133
1
165
9
                push @out, _sanitise_output("$h->{name}: $h->{value}");
1843        }
1844
22
1
3435
1029
        push @out, '';
1845
1846
22
1
102
2
        return join("\n", @out);
1847}
1848
1849# -----------------------------------------------------------------------
1850# Public: abuse contacts
1851# -----------------------------------------------------------------------
1852
1853 - 1912
=head2 abuse_contacts()

Collates the complete set of parties that should receive an abuse report:
the sending ISP, URL host operators, contact domain web/mail/DNS/registrar
contacts, account providers identified from key headers, the DKIM signer,
and the ESP identified via List-Unsubscribe.

Addresses are deduplicated globally; if the same address is found via
multiple routes, a single entry is kept and role strings are merged.

=head3 Usage

    my @contacts = $analyser->abuse_contacts();
    my @addrs    = map { $_->{address} } @contacts;

=head3 Arguments

None.  C<parse_email()> must have been called first.

=head3 Returns

A list of hashrefs, one per unique abuse address, in discovery order.
Each hashref has keys C<role>, C<roles> (arrayref), C<address>, C<note>,
C<via>.  Returns an empty list if no contacts can be determined.

=head3 Side Effects

Triggers C<originating_ip()>, C<embedded_urls()>, and C<mailto_domains()>
if not already cached.

=head3 Notes

The result is cached on the object; subsequent calls return the same list
without repeating the contact-collection logic.  The underlying per-IP and
per-domain lookups are themselves cached by C<originating_ip()>,
C<embedded_urls()>, and C<mailto_domains()>.

=head3 API Specification

=head4 Input

    []

=head4 Output

    (
        {
            type => 'hashref',
            keys => {
                role    => { type => 'string' },
                roles   => { type => 'arrayref' },
                address => { type => 'string', regex => qr/\@/ },
                note    => { type => 'string' },
                via     => { type => 'string', memberof => [ 'provider-table', 'ip-whois', 'domain-whois' ] }
            },
        },
        ...
    )

=cut
1913
1914sub abuse_contacts {
1915
190
1
5555
8
        my $self = $_[0];
1916
190
1
5562
1232
        $self->{_contacts} //= [ $self->_compute_abuse_contacts() ];
1917
190
190
1
1
150
322
1
9
        return @{ $self->{_contacts} };
1918}
1919
1920# _compute_abuse_contacts() -> list of contact hashrefs
1921#
1922# Purpose:
1923#   Actual implementation of abuse_contacts(). Separated so the public
1924#   method can cache without duplicating logic.
1925#
1926# Entry criteria:
1927#   parse_email() must have been called.
1928#
1929# Exit status:
1930#   Returns list of deduplicated contact hashrefs.
1931
1932sub _compute_abuse_contacts :Private {
1933        my $self = $_[0];
1934
1935        my (@contacts, %seen_idx);
1936
1937        # Inner closure: add one contact entry, merging roles for duplicate addresses
1938        my $add = sub {
1939                my (%args) = @_;
1940                my $addr = lc($args{address} // '');
1941                return unless $addr && $addr =~ /\@/;
1942
1943                # Suppress addresses belonging to form-only providers (no email accepted)
1944                if ($addr =~ /\@([\w.-]+)$/) {
1945                        my $dom = $1;
1946                        my $pa  = $self->_provider_abuse_for_host($dom);
1947                        return if $pa && $pa->{form} && !$pa->{email};
1948                }
1949
1950                if (exists $seen_idx{$addr}) {
1951                        # Merge the new role into the existing entry
1952                        my $entry = $contacts[ $seen_idx{$addr} ];
1953                        push @{ $entry->{roles} }, $args{role};
1954
1955                        # Collapse repeated role labels to avoid unreadable strings
1956                        my (%role_counts, @ordered_roles);
1957                        for my $r (@{ $entry->{roles} }) {
1958                                push @ordered_roles, $r unless $role_counts{$r}++;
1959                        }
1960                        my @display = map {
1961                                $role_counts{$_} > 1 ? "$_ (x$role_counts{$_})" : $_
1962                        } @ordered_roles;
1963                        my $joined = join(' and ', @display);
1964
1965                        # Summarise if the merged string is too long to read.
1966                        # "URL host: hostname" entries are grouped by listing the actual
1967                        # hostnames so the summary is actionable (e.g. "URL host: a.example,
1968                        # b.example" rather than the unhelpful "URL host, URL host").
1969                        # All other role types fall back to stripping at the first [:(\d]
1970                        # boundary to produce a compact type label.
1971                        if (length($joined) > $ROLE_MAX_LEN) {
1972                                my (@url_hosts, %seen_short, @short);
1973                                for my $r (@display) {
1974                                        if ($r =~ /^URL host:\s*(.+)$/) {
1975                                                push @url_hosts, $1;
1976                                        } else {
1977                                                (my $s = $r) =~ s/[:(\d].*//;
1978                                                $s =~ s/\s+$//;
1979                                                push @short, $s unless $seen_short{$s}++;
1980                                        }
1981                                }
1982                                my @parts;
1983                                if (@url_hosts) {
1984                                        my $extra = @url_hosts > 3
1985                                                ? ' and ' . (@url_hosts - 3) . ' more' : '';
1986                                        my @shown = @url_hosts > 3 ? @url_hosts[0..2] : @url_hosts;
1987                                        push @parts, 'URL host: ' . join(', ', @shown) . $extra;
1988                                }
1989                                push @parts, @short;
1990                                $joined = scalar(@display) . ' routes: ' . join(', ', @parts);
1991                        }
1992                        $entry->{role} = $joined;
1993                        return;
1994                }
1995
1996                # First time seeing this address -- record and store
1997                $seen_idx{$addr} = scalar @contacts;
1998                $args{roles} = [ $args{role} ];
1999                push @contacts, \%args;
2000        };
2001
2002        # Route 1 -- Sending ISP (originating IP)
2003        my $orig = $self->originating_ip();
2004        if ($orig) {
2005                my $pa = $self->_provider_abuse_for_ip($orig->{ip}, $orig->{rdns});
2006                if ($pa) {
2007                        $add->(
2008                                role    => 'Sending ISP',
2009                                address => $pa->{email},
2010                                note    => "$orig->{ip} ($orig->{rdns}) -- $pa->{note}",
2011                                via     => 'provider-table',
2012                        );
2013                }
2014                if ($orig->{abuse} && $orig->{abuse} ne '(unknown)') {
2015                        $add->(
2016                                role    => 'Sending ISP',
2017                                address => $orig->{abuse},
2018                                note    => "Network owner of originating IP $orig->{ip} ($orig->{org})",
2019                                via     => 'ip-whois',
2020                        );
2021                }
2022        }
2023
2024        # Route 2 -- URL hosts
2025        my %url_host_seen;
2026        for my $u ($self->embedded_urls()) {
2027                next if $url_host_seen{ $u->{host} }++;
2028                my $bare_host = lc $u->{host};
2029                $bare_host =~ s/^www\.//;
2030                # Skip trusted infrastructure (Google, W3C, etc.)
2031                next if $self->{trusted_domains}->{$bare_host};
2032                next if $TRUSTED_DOMAINS{$bare_host};
2033                my $pa = $self->_provider_abuse_for_host($u->{host});
2034                if ($pa) {
2035                        $add->(
2036                                role    => "URL host: $u->{host}",
2037                                address => $pa->{email},
2038                                note    => "$u->{host} -- $pa->{note}",
2039                                via     => 'provider-table',
2040                        );
2041                }
2042                if ($u->{abuse} && $u->{abuse} ne '(unknown)') {
2043                        $add->(
2044                                role    => "URL host: $u->{host}",
2045                                address => $u->{abuse},
2046                                note    => "Hosting $u->{host} ($u->{ip}, $u->{org})",
2047                                via     => 'ip-whois',
2048                        );
2049                }
2050        }
2051
2052        # Route 3 -- Contact domain hosting and registration
2053        for my $d ($self->mailto_domains()) {
2054                my $dom = $d->{domain};
2055
2056                # Web host contact
2057                if ($d->{web_abuse}) {
2058                        my $pa = $self->_provider_abuse_for_host($dom);
2059                        if ($pa) {
2060                                $add->(role => "Web host of $dom", address => $pa->{email},
2061                                       note => $pa->{note}, via => 'provider-table');
2062                        }
2063                        $add->(
2064                                role    => "Web host of $dom",
2065                                address => $d->{web_abuse},
2066                                note    => sprintf('Hosting %s (%s, %s)',
2067                                             $dom             // '(unknown domain)',
2068                                             $d->{web_ip}     // '(unknown IP)',
2069                                             $d->{web_org}    // '(unknown org)'),
2070                                via     => 'ip-whois',
2071                        );
2072                }
2073
2074                # MX (mail host) contact
2075                if ($d->{mx_abuse}) {
2076                        $add->(
2077                                role    => "Mail host (MX) for $dom",
2078                                address => $d->{mx_abuse},
2079                                note    => sprintf('MX %s (%s, %s)',
2080                                             $d->{mx_host} // '(unknown host)',
2081                                             $d->{mx_ip}   // '(unknown IP)',
2082                                             $d->{mx_org}  // '(unknown org)'),
2083                                via     => 'ip-whois',
2084                        );
2085                }
2086
2087                # NS (DNS host) contact
2088                if ($d->{ns_abuse}) {
2089                        $add->(
2090                                role    => "DNS host (NS) for $dom",
2091                                address => $d->{ns_abuse},
2092                                note    => sprintf('NS %s (%s, %s)',
2093                                             $d->{ns_host} // '(unknown host)',
2094                                             $d->{ns_ip}   // '(unknown IP)',
2095                                             $d->{ns_org}  // '(unknown org)'),
2096                                via     => 'ip-whois',
2097                        );
2098                }
2099
2100                # Domain registrar (skip if domain only seen in spoofable headers)
2101                if ($d->{registrar_abuse}) {
2102                        my $spoofable_only =
2103                                $d->{source} =~ /^(?:From:|Return-Path:|Sender:) header$/ &&
2104                                !scalar(grep {
2105                                        $_->{host} &&
2106                                        _registrable($_->{host}) eq (_registrable($dom) // $dom)
2107                                } $self->embedded_urls());
2108                        unless ($spoofable_only) {
2109                                $add->(
2110                                        role    => "Domain registrar for $dom",
2111                                        address => $d->{registrar_abuse},
2112                                        note    => 'Registrar: ' . ($d->{registrar} // '(unknown)'),
2113                                        via     => 'domain-whois',
2114                                );
2115                        }
2116                }
2117        }
2118
2119        # Route 4 -- From:/Reply-To:/Return-Path:/Sender: account provider
2120        for my $hname (qw(from reply-to return-path sender)) {
2121                my $val = $self->_header_value($hname) // next;
2122
2123                # Extract addr-spec from angle-bracket form to avoid display-name @-signs
2124                my $addr_spec = ($val =~ /<([^>]*)>\s*$/) ? $1 : $val;
2125                my ($addr_domain) = $addr_spec =~ /\@([\w.-]+)/;
2126                next unless $addr_domain;
2127
2128                # Skip SRS-rewritten forwarder addresses (not the real sender)
2129                next if $addr_spec =~ /\+SRS[0-9]?=/i;
2130
2131                my $pa = $self->_provider_abuse_for_host($addr_domain);
2132                if ($pa) {
2133                        my $role_addr = $addr_spec =~ /\@/ ? $addr_spec : $val;
2134                        $role_addr =~ s/^\s+|\s+$//g;
2135                        $add->(
2136                                role    => "Account provider ($hname: $role_addr)",
2137                                address => $pa->{email},
2138                                note    => $pa->{note},
2139                                via     => 'provider-table',
2140                        );
2141                }
2142        }
2143
2144        # Route 5 -- DKIM signing organisation
2145        my $auth = $self->_parse_auth_results_cached();
2146        if ($auth->{dkim_domain}) {
2147                my $pa = $self->_provider_abuse_for_host($auth->{dkim_domain});
2148                if ($pa) {
2149                        $add->(
2150                                role    => "DKIM signer: $auth->{dkim_domain}",
2151                                address => $pa->{email},
2152                                note    => $pa->{note},
2153                                via     => 'provider-table',
2154                        );
2155                }
2156        }
2157
2158        # Route 6 -- List-Unsubscribe ESP domain
2159        my $unsub = $self->_header_value('list-unsubscribe');
2160        if ($unsub) {
2161                my @unsub_domains;
2162                while ($unsub =~ m{https?://([^/:?\s>]+)}gi) {
2163                        push @unsub_domains, lc $1;
2164                }
2165                while ($unsub =~ m{mailto:[^@\s>]+\@([\w.-]+)}gi) {
2166                        push @unsub_domains, lc $1;
2167                }
2168                my %unsub_seen;
2169                for my $dom (grep { !$unsub_seen{$_}++ } @unsub_domains) {
2170                        my $pa = $self->_provider_abuse_for_host($dom);
2171                        if ($pa) {
2172                                $add->(
2173                                        role    => "ESP / bulk sender (List-Unsubscribe: $dom)",
2174                                        address => $pa->{email},
2175                                        note    => "$pa->{note} -- responsible for this bulk delivery",
2176                                        via     => 'provider-table',
2177                                );
2178                        }
2179                }
2180        }
2181
2182        # Route 7 -- Reply addresses embedded in the message body
2183        my %body_addr_seen;
2184        my $combined_body = $self->{_body_plain} . "\n" . $self->{_body_html};
2185        for my $addr_dom ($self->_domains_from_text($combined_body)) {
2186                next if $body_addr_seen{$addr_dom}++;
2187                my $pa = $self->_provider_abuse_for_host($addr_dom);
2188                next unless $pa && $pa->{email};
2189                my ($example_addr) = $combined_body =~ /(\S+\@\Q$addr_dom\E)/i;
2190                $example_addr //= "\@$addr_dom";
2191                $add->(
2192                        role    => "Reply address in body ($example_addr)",
2193                        address => $pa->{email},
2194                        note    => $pa->{note},
2195                        via     => 'provider-table',
2196                );
2197        }
2198
2199        return @contacts;
2200
26
26
26
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
40625
28
263
1979
3
27
579
1
9
609
1
9
195
1
8
1
10
1929
1
9
2856
1
11
2003
}
2201
2202# -----------------------------------------------------------------------
2203# Public: form contacts (providers that require web-form submission)
2204# -----------------------------------------------------------------------
2205
2206 - 2262
=head2 form_contacts()

Returns the list of parties that require abuse reports via a web form
rather than email.  These are providers whose C<%PROVIDER_ABUSE> entry
has a C<form> key.  Each hashref includes the form URL, paste
instructions, upload instructions, and the discovery role.

=head3 Usage

    my @forms = $analyser->form_contacts();
    for my $c (@forms) {
        printf "Open: %s\n", $c->{form};
    }

=head3 Arguments

None.  C<parse_email()> must have been called first.

=head3 Returns

A list of hashrefs, one per unique form contact.  Each hashref has keys
C<form>, C<role>, C<note>, C<form_paste> (optional), C<form_upload>
(optional), and C<via>.  Returns an empty list if no form contacts are found.

=head3 Side Effects

Triggers C<originating_ip()>, C<embedded_urls()>, and C<mailto_domains()>
if not already cached.

=head3 Notes

Deduplication is by form URL.

=head3 API Specification

=head4 Input

    []

=head4 Output

    (
        {
            type => 'hashref',
            keys => {
                form        => { type => 'string', regex => qr{^https?://} },
                role        => { type => 'string' },
                note        => { type => 'string' },
                form_paste  => { type => 'string', optional => 1 },
                form_upload => { type => 'string', optional => 1 },
                via         => { type => 'string' },
            },
        },
        ...
    )

=cut
2263
2264sub form_contacts {
2265
191
1
7851
944
        my $self = $_[0];
2266
2267
191
1
192
1
        my (@contacts, %seen);
2268
2269        # Inner closure: add one form-contact entry, deduplicating by form URL
2270        my $add = sub {
2271
89
1
1393
949
                my (%args) = @_;
2272
56
1
74
1
                my $form = $args{form} // '';
2273
56
1
94
7
                return unless $form;
2274
59
1
2779
924
                return if $seen{$form}++;
2275
46
1
61
1
                push @contacts, \%args;
2276
191
1
440
10
        };
2277
2278        # Route 1 -- Sending ISP
2279
164
1
301
8
        my $orig = $self->originating_ip();
2280
164
1
2200
1957
        if ($orig) {
2281
96
1
245
2
                my $pa = $self->_provider_abuse_for_ip($orig->{ip}, $orig->{rdns});
2282
85
1
163
11
                if ($pa && $pa->{form}) {
2283                        $add->(
2284                                role        => 'Sending ISP',
2285                                form        => $pa->{form},
2286                                note        => $pa->{note} // '',
2287                                form_paste  => $pa->{form_paste}  // '',
2288
16
1
2994
2
                                form_upload => $pa->{form_upload} // '',
2289                                via         => 'provider-table',
2290                        );
2291                }
2292        }
2293
2294        # Route 2 -- URL hosts
2295
151
1
132
0
        my %url_host_seen;
2296
151
1
227
31
        for my $u ($self->embedded_urls()) {
2297
67
1
3225
1
                next if $url_host_seen{ $u->{host} }++;
2298
58
1
80
1
                my $pa = $self->_provider_abuse_for_host($u->{host});
2299
81
1
144
4
                if ($pa && $pa->{form}) {
2300                        $add->(
2301                                role        => "URL host: $u->{host}",
2302                                form        => $pa->{form},
2303                                form_domain => $u->{host},
2304                                note        => $pa->{note} // '',
2305                                form_paste  => $pa->{form_paste}  // '',
2306
16
1
2064
2138
                                form_upload => $pa->{form_upload} // '',
2307                                via         => 'provider-table',
2308                        );
2309                }
2310        }
2311
2312        # Route 3 -- Contact domains (web host + registrar)
2313
166
1
209
1
        for my $d ($self->mailto_domains()) {
2314
132
1
185
36
                my $dom = $d->{domain};
2315
132
1
1636
2
                my $pa  = $self->_provider_abuse_for_host($dom);
2316
129
1
151
1
                if ($pa && $pa->{form}) {
2317                        $add->(
2318                                role        => "Web host of $dom",
2319                                form        => $pa->{form},
2320                                form_domain => $dom,
2321                                note        => $pa->{note} // '',
2322                                form_paste  => $pa->{form_paste}  // '',
2323
18
1
52
14
                                form_upload => $pa->{form_upload} // '',
2324                                via         => 'provider-table',
2325                        );
2326                }
2327
2328                # Registrar identified via WHOIS -- check for form-only registrar
2329
141
1
1862
2
                if ($d->{registrar_abuse} && $d->{registrar_abuse} =~ /\@([\w.-]+)/) {
2330
36
1
46
1
                        my $reg_domain = lc $1;
2331
27
1
59
5
                        my $rpa = $self->_provider_abuse_for_host($reg_domain);
2332
27
1
1457
222
                        if ($rpa && $rpa->{form}) {
2333                                $add->(
2334                                        role        => "Domain registrar for $dom (web form only)",
2335                                        form        => $rpa->{form},
2336                                        form_domain => $dom,
2337                                        note        => $rpa->{note} // '',
2338                                        form_paste  => $rpa->{form_paste}  // '',
2339
18
1
48
2
                                        form_upload => $rpa->{form_upload} // '',
2340                                        via         => 'provider-table',
2341                                );
2342                        }
2343                }
2344        }
2345
2346        # Route 4 -- Account provider headers
2347
144
1
200
1
        for my $hname (qw(from reply-to return-path sender)) {
2348
555
1
3374
3
                my $val = $self->_header_value($hname) // next;
2349
232
1
485
151
                my $addr_spec = ($val =~ /<([^>]*)>\s*$/) ? $1 : $val;
2350
232
1
364
1
                my ($addr_domain) = $addr_spec =~ /\@([\w.-]+)/;
2351
232
1
3287
3
                next unless $addr_domain;
2352                # Skip SRS forwarder rewrite addresses
2353
232
1
232
77
                next if $addr_spec =~ /\+SRS[0-9]?=/i;
2354
236
1
260
1
                my $pa = $self->_provider_abuse_for_host($addr_domain);
2355
241
1
2761
17
                if ($pa && $pa->{form}) {
2356
25
1
43
2
                        my $role_addr = $addr_spec =~ /@/ ? $addr_spec : $val;
2357
69
1
113
1
                        $role_addr =~ s/^\s+|\s+$//g;
2358                        $add->(
2359                                role        => "Account provider ($hname: $role_addr)",
2360                                form        => $pa->{form},
2361                                note        => $pa->{note} // '',
2362                                form_paste  => $pa->{form_paste}  // '',
2363
28
1
2037
15
                                form_upload => $pa->{form_upload} // '',
2364                                via         => 'provider-table',
2365                        );
2366                }
2367        }
2368
2369        # Route 5 -- DKIM signer
2370
156
1
221
2
        my $auth = $self->_parse_auth_results_cached();
2371
153
1
251
1
        if ($auth->{dkim_domain}) {
2372
18
1
2209
7
                my $pa = $self->_provider_abuse_for_host($auth->{dkim_domain});
2373
17
1
25
2
                if ($pa && $pa->{form}) {
2374                        $add->(
2375                                role        => "DKIM signer: $auth->{dkim_domain}",
2376                                form        => $pa->{form},
2377                                note        => $pa->{note} // '',
2378                                form_paste  => $pa->{form_paste}  // '',
2379
16
1
49
1
                                form_upload => $pa->{form_upload} // '',
2380                                via         => 'provider-table',
2381                        );
2382                }
2383        }
2384
2385        # Route 6 -- List-Unsubscribe ESP domains
2386
143
1
3064
14
        my $unsub = $self->_header_value('list-unsubscribe');
2387
152
1
175
2
        if ($unsub) {
2388
13
1
44
11
                my @unsub_domains;
2389
18
17
1
1
954
23
14
2
                while ($unsub =~ m{https?://([^/:?\s>]+)}gi) { push @unsub_domains, lc $1 }
2390
11
10
1
1
34
2001
1
14
                while ($unsub =~ m{mailto:[^@\s>]+\@([\w.-]+)}gi) { push @unsub_domains, lc $1 }
2391
11
1
9
1
                my %useen;
2392
11
11
1
1
36
2360
1
61
                for my $dom (grep { !$useen{$_}++ } @unsub_domains) {
2393
11
1
10
2
                        my $pa = $self->_provider_abuse_for_host($dom);
2394
11
1
40
1
                        if ($pa && $pa->{form}) {
2395                                $add->(
2396                                        role        => "ESP / bulk sender (List-Unsubscribe: $dom)",
2397                                        form        => $pa->{form},
2398                                        note        => $pa->{note} // '',
2399                                        form_paste  => $pa->{form_paste}  // '',
2400
5
1
1730
17
                                        form_upload => $pa->{form_upload} // '',
2401                                        via         => 'provider-table',
2402                                );
2403                        }
2404                }
2405        }
2406
2407
146
1
522
2
        return @contacts;
2408}
2409
2410# -----------------------------------------------------------------------
2411# Public: full analyst report
2412# -----------------------------------------------------------------------
2413
2414 - 2461
=head2 report()

Produces a comprehensive, analyst-facing plain-text report covering all
findings: envelope fields, risk assessment, originating host, sending
software, received chain tracking IDs, embedded URLs, contact domain
intelligence, and recommended abuse contacts.

Use C<report()> for human review or ticketing systems.  Use
C<abuse_report_text()> for sending to ISP abuse desks.

=head3 Usage

    print $analyser->report();

    open my $fh, '>', 'report.txt' or croak "Cannot open: $!";
    print $fh $analyser->report();
    close $fh;

=head3 Arguments

None.  C<parse_email()> must have been called first.

=head3 Returns

A plain scalar string, newline-terminated, Unix line endings.  Never empty
or undef.

=head3 Side Effects

Triggers all analysis methods if not already cached.

=head3 Notes

The report is idempotent: calling it multiple times on the same object
always returns an identical string.  All user-derived content is sanitised
before output.

=head3 API Specification

=head4 Input

    []

=head4 Output

    { type => 'string' }

=cut
2462
2463sub report {
2464
110
1
9851
1
        my $self = $_[0];
2465
2466
117
1
1492
4
        my @out;
2467
2468        # Banner header
2469
106
1
141
106
        push @out, '=' x 72;
2470
87
1
156
5
        push @out, "  Email::Abuse::Investigator Report  (v$VERSION)";
2471
86
0
6087
0
        push @out, '=' x 72;
2472
86
1
81
93
        push @out, '';
2473
2474        # Envelope summary -- decode MIME encoded-words for readability
2475
85
1
136
3
        for my $f (qw(from reply-to return-path subject date message-id)) {
2476
460
0
452
0
                my $v = $self->_header_value($f);
2477
481
1
460
50
                next unless defined $v;
2478
350
1
471
3
                my $decoded = $self->_decode_mime_words($v);
2479
351
0
293
0
                my $label   = ucfirst($f);
2480
349
1
422
40
                push @out, sprintf('  %-14s : %s', $label,
2481                        _sanitise_output($decoded ne $v ? "$decoded  [encoded: $v]" : $v));
2482        }
2483
80
1
93
1
        push @out, '';
2484
2485        # Risk assessment section
2486
104
1
6487
2
        my $risk = $self->risk_assessment();
2487
104
1
184
0
        push @out, "[ RISK ASSESSMENT: $risk->{level} (score: $risk->{score}) ]";
2488
95
106
1
0
184
214
3
0
        if (@{ $risk->{flags} }) {
2489
112
59
1
1
107
121
49
2
                for my $f (@{ $risk->{flags} }) {
2490
116
1
177
1
                        push @out, "  [$f->{severity}] " . _sanitise_output($f->{detail});
2491                }
2492        } else {
2493
95
1
88
0
                push @out, '  (no specific red flags detected)';
2494        }
2495
137
1
153
3
        push @out, '';
2496
2497        # Originating host section
2498
137
0
824
0
        push @out, '[ ORIGINATING HOST ]';
2499
91
1
111
46
        if(my $orig = $self->originating_ip()) {
2500
95
1
135
2
                push @out, '  IP           : ' . _sanitise_output($orig->{ip});
2501
56
0
112
0
                push @out, '  Reverse DNS  : ' . _sanitise_output($orig->{rdns})    if $orig->{rdns};
2502
56
1
479
1786
                push @out, '  Country      : ' . _sanitise_output($orig->{country}) if $orig->{country};
2503
69
1
118
1
                push @out, '  Organisation : ' . _sanitise_output($orig->{org})     if $orig->{org};
2504
66
1
131
12
                push @out, '  Abuse addr   : ' . _sanitise_output($orig->{abuse})   if $orig->{abuse};
2505
75
1
328
660
                push @out, "  Confidence   : $orig->{confidence}";
2506
153
1
178
1
                push @out, '  Note         : ' . _sanitise_output($orig->{note})    if $orig->{note};
2507        } else {
2508
83
1
198
10
                push @out, '  (could not determine originating IP)';
2509        }
2510
142
1
168
719
        push @out, '';
2511
2512        # Sending software section (omitted if none found)
2513
142
1
176
1
        my @sw = $self->sending_software();
2514
129
1
194
9
        if (@sw) {
2515
57
1
57
673
                push @out, '[ SENDING SOFTWARE / INFRASTRUCTURE CLUES ]';
2516
57
1
61
1
                for my $s (@sw) {
2517
9
1
32
10
                        push @out, sprintf('  %-14s : %s', $s->{header}, _sanitise_output($s->{value}));
2518
9
1
16
558
                        push @out, "  Note           : $s->{note}";
2519
9
1
17
1
                        push @out, '';
2520                }
2521        }
2522
2523        # Received chain tracking IDs (only hops with id or for are shown)
2524
104
93
1
1
194
193
11
2674
        my @trail = grep { defined $_->{id} || defined $_->{for} }
2525                    $self->received_trail();
2526
78
1
127
1
        if (@trail) {
2527
5
1
56
10
                push @out, '[ RECEIVED CHAIN TRACKING IDs ]';
2528
5
1
8
2661
                push @out, '  (Supply these to the relevant ISP abuse team to trace the session)';
2529
44
1
41
1
                push @out, '';
2530
44
1
105
11
                for my $hop (@trail) {
2531
18
1
26
1489
                        push @out, '  IP           : ' . (_sanitise_output($hop->{ip}) // '(unknown)');
2532
5
1
7
1
                        push @out, '  Envelope for : ' . _sanitise_output($hop->{for}) if $hop->{for};
2533
5
1
212
10
                        push @out, '  Server ID    : ' . _sanitise_output($hop->{id})  if $hop->{id};
2534
5
1
10
1098
                        push @out, '';
2535                }
2536        }
2537
2538        # Embedded URLs section -- grouped by hostname
2539
78
1
72
2
        push @out, '[ EMBEDDED HTTP/HTTPS URLs ]';
2540
78
1
138
8
        my @urls = $self->embedded_urls();
2541
78
1
83
916
        if (@urls) {
2542
41
1
143
1
                my (%host_order, %host_meta, %host_paths);
2543
28
1
34
9
                my $seq = 0;
2544
28
1
353
834
                for my $u (@urls) {
2545
40
1
50
1
                        my $h = $u->{host};
2546
63
1
136
9
                        unless (exists $host_order{$h}) {
2547
30
1
233
656
                                $host_order{$h} = $seq++;
2548                                $host_meta{$h}  = {
2549                                        ip      => $u->{ip},
2550                                        org     => $u->{org},
2551                                        abuse   => $u->{abuse},
2552                                        country => $u->{country},
2553
30
1
70
1
                                };
2554                        }
2555
37
40
1
1
29
185
9
666
                        push @{ $host_paths{$h} }, $u->{url};
2556                }
2557
2558                # Output each host group in first-seen order
2559
28
2
1
1
55
6
1
8
                for my $h (sort { $host_order{$a} <=> $host_order{$b} } keys %host_order) {
2560
30
1
158
655
                        my $m    = $host_meta{$h};
2561
30
29
1
1
35
30
1
8
                        my $bare = lc $h; $bare =~ s/^www\.//;
2562                        push @out, '  Host         : ' . _sanitise_output($h) .
2563
30
1
150
451
                                   (($URL_SHORTENERS{$bare} || $self->{url_shorteners}->{$bare})
2564                                    ? '  *** URL SHORTENER -- real destination hidden ***' : '');
2565
30
1
66
1
                        push @out, '  IP           : ' . _sanitise_output($m->{ip})      if $m->{ip};
2566
27
1
43
9
                        push @out, '  Country      : ' . _sanitise_output($m->{country}) if $m->{country};
2567
30
1
315
226
                        push @out, '  Organisation : ' . _sanitise_output($m->{org})     if $m->{org};
2568
30
1
55
1
                        push @out, '  Abuse addr   : ' . _sanitise_output($m->{abuse})   if $m->{abuse};
2569
30
30
1
1
31
35
8
603
                        my @paths = @{ $host_paths{$h} };
2570
30
1
45
1
                        if (@paths == 1) {
2571
20
1
24
9
                                push @out, '  URL          : ' . _sanitise_output($paths[0]);
2572                        } else {
2573
10
1
148
464
                                push @out, '  URLs (' . scalar(@paths) . ')     :';
2574
10
1
20
1
                                push @out, '    ' . _sanitise_output($_) for @paths;
2575                        }
2576
27
1
63
9
                        push @out, '';
2577                }
2578        } else {
2579
53
1
5472
1020
                push @out, '  (none found)';
2580
53
1
57
2
                push @out, '';
2581        }
2582
2583        # Contact / reply-to domains section
2584
78
1
118
9
        push @out, '[ CONTACT / REPLY-TO DOMAINS ]';
2585
78
1
2976
1610
        my @mdoms = $self->mailto_domains();
2586
78
1
80
2
        if (@mdoms) {
2587
65
1
88
10
                for my $d (@mdoms) {
2588
82
1
1825
719
                        push @out, '  Domain       : ' . _sanitise_output($d->{domain});
2589
82
1
96
1
                        push @out, '  Found in     : ' . _sanitise_output($d->{source});
2590
82
1
120
9
                        if ($d->{recently_registered}) {
2591
7
1
2368
974
                                push @out, '  *** WARNING: RECENTLY REGISTERED - possible phishing domain ***';
2592                        }
2593
82
1
130
1
                        push @out, '  Registered   : ' . $d->{registered}       if $d->{registered};
2594
82
1
114
9
                        push @out, '  Expires      : ' . $d->{expires}           if $d->{expires};
2595
82
1
2191
662
                        push @out, '  Registrar    : ' . _sanitise_output($d->{registrar})       if $d->{registrar};
2596
82
1
95
1
                        push @out, '  Reg. abuse   : ' . _sanitise_output($d->{registrar_abuse}) if $d->{registrar_abuse};
2597
82
1
105
9
                        if ($d->{web_ip}) {
2598
28
1
7161
1084
                                push @out, '  Web host IP  : ' . _sanitise_output($d->{web_ip});
2599
28
1
51
1
                                push @out, '  Web host org : ' . _sanitise_output($d->{web_org})   if $d->{web_org};
2600
28
1
77
9
                                push @out, '  Web abuse    : ' . _sanitise_output($d->{web_abuse}) if $d->{web_abuse};
2601                        } else {
2602
57
1
8057
1406
                                push @out, '  Web host     : (no A record / unreachable)';
2603                        }
2604
82
1
83
1
                        if ($d->{mx_host}) {
2605
7
1
40
9
                                push @out, '  MX host      : ' . _sanitise_output($d->{mx_host});
2606
7
1
4155
1160
                                push @out, '  MX IP        : ' . _sanitise_output($d->{mx_ip})    if $d->{mx_ip};
2607
7
1
16
1
                                push @out, '  MX org       : ' . _sanitise_output($d->{mx_org})   if $d->{mx_org};
2608
7
1
39
9
                                push @out, '  MX abuse     : ' . _sanitise_output($d->{mx_abuse}) if $d->{mx_abuse};
2609                        } else {
2610
78
1
3978
361
                                push @out, '  MX host      : (none found)';
2611                        }
2612
82
1
98
1
                        if ($d->{ns_host}) {
2613
6
1
34
8
                                push @out, '  NS host      : ' . _sanitise_output($d->{ns_host});
2614
6
1
2936
453
                                push @out, '  NS IP        : ' . _sanitise_output($d->{ns_ip})    if $d->{ns_ip};
2615
6
1
11
1
                                push @out, '  NS org       : ' . _sanitise_output($d->{ns_org})   if $d->{ns_org};
2616
6
1
31
9
                                push @out, '  NS abuse     : ' . _sanitise_output($d->{ns_abuse}) if $d->{ns_abuse};
2617                        }
2618
82
1
2800
1334
                        push @out, '';
2619                }
2620        } else {
2621
16
1
17
1
                push @out, '  (none found)';
2622
16
1
43
9
                push @out, '';
2623        }
2624
2625        # Abuse contacts summary
2626
78
1
1575
1106
        push @out, '[ WHERE TO SEND ABUSE REPORTS ]';
2627
78
1
114
1
        my @contacts = $self->abuse_contacts();
2628
78
1
111
9
        if (@contacts) {
2629
51
1
1577
1206
                for my $c (@contacts) {
2630
73
1
89
1
                        push @out, '  Role         : ' . _sanitise_output($c->{role});
2631
73
1
114
9
                        push @out, '  Send to      : ' . _sanitise_output($c->{address});
2632
73
1
2123
1298
                        push @out, '  Note         : ' . _sanitise_output($c->{note}) if $c->{note};
2633
73
1
74
1
                        push @out, "  Discovered   : $c->{via}";
2634
73
1
139
10
                        push @out, '';
2635                }
2636        } else {
2637
30
1
1659
213
                push @out, '  (no abuse contacts could be determined)';
2638
30
1
26
1
                push @out, '';
2639        }
2640
2641        # Web-form contacts (providers that require manual form submission)
2642
78
1
146
7
        my @form_cs = $self->form_contacts();
2643
78
1
1355
625
        if (@form_cs) {
2644
7
1
4
1
                push @out, '[ WHERE TO FILE WEB-FORM REPORTS ]';
2645
7
1
28
8
                push @out, '  The following parties require manual submission via a web form.';
2646
7
1
2016
251
                push @out, '  Open each URL in a browser, then follow the instructions below it.';
2647
7
1
10
2
                push @out, '';
2648
7
1
32
8
                for my $c (@form_cs) {
2649
7
1
1839
1314
                        push @out, '  Role         : ' . _sanitise_output($c->{role});
2650
7
1
10
1
                        push @out, '  Form URL     : ' . _sanitise_output($c->{form});
2651
7
1
37
9
                        push @out, '  Domain/URL   : ' . _sanitise_output($c->{form_domain}) if $c->{form_domain};
2652
7
1
3701
1292
                        push @out, '  Note         : ' . _sanitise_output($c->{note})        if $c->{note};
2653
7
1
9
1
                        if ($c->{form_paste}) {
2654                                # Word-wrap the paste hint at ROLE_WRAP_LEN characters
2655
7
1
33
28
                                my $hint  = $c->{form_paste};
2656
7
1
4308
210
                                my @words = split /\s+/, $hint;
2657
7
1
5
1
                                my (@lines, $line);
2658
7
1
36
8
                                for my $w (@words) {
2659
124
1
2248
956
                                        if (defined $line && length("$line $w") > $ROLE_WRAP_LEN) {
2660
11
1
11
1
                                                push @lines, $line;
2661
11
1
33
8
                                                $line = $w;
2662                                        } else {
2663
116
1
2517
1136
                                                $line = defined $line ? "$line $w" : $w;
2664                                        }
2665                                }
2666
7
1
10
1
                                push @lines, $line if defined $line;
2667
7
1
36
8
                                push @out, '  Paste        : ' . shift @lines if @lines;
2668
7
1
1566
1276
                                push @out, '                 ' . $_ for @lines;
2669                        }
2670
7
1
14
1
                        push @out, '  Upload       : ' . _sanitise_output($c->{form_upload}) if $c->{form_upload};
2671
7
1
30
9
                        push @out, '';
2672                }
2673        }
2674
2675
78
1
3551
1042
        push @out, '=' x 72;
2676
78
1
492
1
        return join("\n", @out) . "\n";
2677}
2678
2679# -----------------------------------------------------------------------
2680# Private: output sanitisation
2681# -----------------------------------------------------------------------
2682
2683# _sanitise_output( $str ) -> $str
2684#
2685# Purpose:
2686#   Strip control characters that could affect terminal rendering or HTML
2687#   injection from any string that will appear in a report or abuse email.
2688#   Preserves printable ASCII, high-bytes (for UTF-8 content), tabs, and
2689#   line endings.
2690#
2691# Entry criteria:
2692#   $str -- a defined or undef scalar.
2693#
2694# Exit status:
2695#   Returns the sanitised string, or the empty string if $str is undef.
2696#
2697# Notes:
2698#   Only strips C0 control characters below 0x20 (except \t) and the DEL
2699#   character (0x7F).  High bytes (0x80-0xFF) are preserved because they
2700#   form valid UTF-8 multi-byte sequences in headers and body text.
2701
2702sub _sanitise_output :Private {
2703        my $str = $_[0];
2704        return '' unless defined $str;
2705        # Remove C0 controls (except tab) and DEL
2706        $str =~ s/[\x00-\x08\x0B\x0C\x0E-\x1F\x7F]//g;
2707        return $str;
2708
26
26
26
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
41724
27
255
2745
3
26
376
1
9
435
2
9
636
2
8
1
11
978
1
11
1166
1
10
952
}
2709
2710# -----------------------------------------------------------------------
2711# Private: message parsing
2712# -----------------------------------------------------------------------
2713
2714# _split_message( $text )
2715#
2716# Purpose:
2717#   Split a raw RFC 2822 email into headers and body, parse all headers,
2718#   decode the body (including multipart), extract sending-software
2719#   fingerprints, and populate per-hop tracking data.
2720#
2721# Entry criteria:
2722#   $text -- defined scalar, already dereferenced by parse_email().
2723#   $self->{_sending_sw} and $self->{_rcvd_tracking} reset to [] by caller.
2724#
2725# Exit status:
2726#   Returns undef silently if the header block is empty/whitespace-only.
2727#   Otherwise all results are communicated via side effects on $self.
2728#
2729# Side effects:
2730#   Populates _headers, _received, _body_plain, _body_html, _sending_sw,
2731#   and _rcvd_tracking.
2732#
2733# Notes:
2734#   Delegates to _decode_multipart() for multipart/* content types.
2735#   Lines not matching the header pattern are silently discarded.
2736#   Boundary extraction uses a simple regex; missing boundary causes the
2737#   body to be skipped silently.
2738
2739sub _split_message :Private {
2740        my ($self, $text) = @_;
2741
2742        # Split at the first blank line (RFC 2822 header/body separator)
2743        my ($header_block, $body_raw) = split /\r?\n\r?\n/, $text, 2;
2744
2745        return unless defined $header_block && $header_block =~ /\S/;
2746        $body_raw //= '';
2747
2748        # Unfold RFC 2822 continuation lines (s2.2.3)
2749        $header_block =~ s/\r?\n([ \t]+)/ $1/g;
2750
2751        # Parse each header line into a { name, value } pair
2752        my @headers;
2753        for my $line (split /\r?\n/, $header_block) {
2754                if ($line =~ /^([\w-]+)\s*:\s*(.*)/) {
2755                        push @headers, { name => lc($1), value => $2 };
2756                }
2757        }
2758        $self->{_headers}  = \@headers;
2759
2760        # Collect all Received: header values (most-recent first, as in message)
2761        $self->{_received} = [
2762                map  { $_->{value} }
2763                grep { $_->{name} eq 'received' } @headers
2764        ];
2765
2766        # Determine content type and transfer encoding from top-level headers
2767        my ($ct_h)  = grep { $_->{name} eq 'content-type' }              @headers;
2768        my ($cte_h) = grep { $_->{name} eq 'content-transfer-encoding' } @headers;
2769        my $ct  = defined $ct_h  ? $ct_h->{value}  : '';
2770        my $cte = defined $cte_h ? $cte_h->{value} : '';
2771
2772        # Decode multipart or single-part body as appropriate
2773        if ($ct =~ /multipart/i) {
2774                my ($boundary) = $ct =~ /boundary="?([^";]+)"?/i;
2775                # Pass depth=0 to enforce the MAX_MULTIPART_DEPTH recursion guard
2776                $self->_decode_multipart($body_raw, $boundary, 0) if $boundary;
2777        } else {
2778                my $decoded = $self->_decode_body($body_raw, $cte);
2779                if ($ct =~ /html/i) { $self->{_body_html}  = $decoded }
2780                else                 { $self->{_body_plain} = $decoded }
2781        }
2782
2783        $self->_debug(sprintf 'Parsed %d headers, %d Received lines',
2784                scalar @headers, scalar @{ $self->{_received} });
2785
2786        # --- Sending software fingerprints ---
2787        # These headers identify the mailer or shared-hosting script that sent
2788        # the message; invaluable for shared-hosting abuse reports.
2789        my %sw_notes = (
2790                'x-php-originating-script' => 'PHP script on shared hosting -- report to hosting abuse team',
2791                'x-source'                 => 'Source file on shared hosting -- report to hosting abuse team',
2792                'x-source-host'            => 'Sending hostname injected by shared hosting provider',
2793                'x-source-args'            => 'Command-line args injected by shared hosting provider',
2794                'x-mailer'                 => 'Email client or bulk-mailer identifier',
2795                'user-agent'               => 'Email client identifier',
2796        );
2797        for my $sw_hdr (sort keys %sw_notes) {
2798                my ($h) = grep { $_->{name} eq $sw_hdr } @headers;
2799                next unless $h;
2800                push @{ $self->{_sending_sw} }, {
2801                        header => $sw_hdr,
2802                        value  => $h->{value},
2803                        note   => $sw_notes{$sw_hdr},
2804                };
2805        }
2806
2807        # --- Per-hop tracking IDs from Received: chain ---
2808        # Walk oldest-first (reverse) so _rcvd_tracking is oldest-first
2809        for my $rcvd (reverse @{ $self->{_received} }) {
2810                my $ip = $self->_extract_ip_from_received($rcvd);
2811                my ($for_addr) = $rcvd =~ /\bfor\s+<?([^\s>]+\@[\w.-]+\.[\w]+)>?/i;
2812                my ($srv_id)   = $rcvd =~ /\bid\s+([\w.-]+)/i;
2813                # Skip hops with no actionable tracking data
2814                next unless defined $ip || defined $for_addr || defined $srv_id;
2815                push @{ $self->{_rcvd_tracking} }, {
2816                        received => $rcvd,
2817                        ip       => $ip,
2818                        for      => $for_addr,
2819                        id       => $srv_id,
2820                };
2821        }
2822
26
26
26
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
17307
22
275
1912
3
27
424
1
8
227
1
9
666
1
8
1
10
963
2
9
1189
1
9
883
}
2823
2824# _decode_multipart( $body, $boundary, $depth )
2825#
2826# Purpose:
2827#   Recursively split a MIME multipart body on its boundary and decode each
2828#   text/plain and text/html part.  Nested multipart/* containers are
2829#   recursed into up to MAX_MULTIPART_DEPTH levels deep.
2830#
2831# Entry criteria:
2832#   $body     -- the raw body text of the multipart container.
2833#   $boundary -- the boundary string from the Content-Type header.
2834#   $depth    -- current recursion depth (starts at 0 from _split_message).
2835#
2836# Exit status:
2837#   Returns undef if $depth >= MAX_MULTIPART_DEPTH (recursion guard).
2838#   Otherwise all results via side effects.
2839#
2840# Side effects:
2841#   Appends decoded text to $self->{_body_plain} and $self->{_body_html}.
2842#
2843# Notes:
2844#   Whitespace-only MIME segments between boundaries are silently skipped.
2845#   Decoding errors are silenced; raw bytes are used as fallback.
2846
2847sub _decode_multipart :Private {
2848        my ($self, $body, $boundary, $depth) = @_;
2849        $depth //= 0;
2850
2851        # Enforce the recursion depth limit to prevent stack exhaustion on
2852        # pathological crafted messages with deeply nested multipart structures.
2853        if ($depth >= $MAX_MULTIPART_DEPTH) {
2854                Carp::carp 'Email::Abuse::Investigator: multipart nesting depth limit',
2855                        "($MAX_MULTIPART_DEPTH) exceeded; stopping recursion";
2856                return;
2857        }
2858
2859        # Split on the boundary marker; the (?:--)? suffix handles closing boundary
2860        my @parts = split /--\Q$boundary\E(?:--)?/, $body;
2861
2862        for my $part (@parts) {
2863                # Skip whitespace-only segments between boundaries
2864                next unless $part =~ /\S/;
2865
2866                $part =~ s/^\r?\n//;
2867
2868                # Each MIME part has its own headers separated from body by a blank line
2869                my ($phdr_block, $pbody) = split /\r?\n\r?\n/, $part, 2;
2870                next unless defined $pbody;
2871
2872                # Unfold continuation header lines within this part
2873                $phdr_block =~ s/\r?\n([ \t]+)/ $1/g;
2874
2875                # Parse this part's headers into a simple hash
2876                my %phdr;
2877                for my $line (split /\r?\n/, $phdr_block) {
2878                        $phdr{ lc($1) } = $2 if $line =~ /^([\w-]+)\s*:\s*(.*)/;
2879                }
2880
2881                my $pct  = $phdr{'content-type'}              // '';
2882                my $pcte = $phdr{'content-transfer-encoding'} // '';
2883
2884                # Nested multipart/* must be recursed into; without this URLs in
2885                # multipart/alternative inside multipart/mixed would be missed.
2886                if ($pct =~ /multipart/i) {
2887                        my ($inner_boundary) = $pct =~ /boundary\s*=\s*"?([^";]+)"?/i;
2888                        if ($inner_boundary) {
2889                                $inner_boundary =~ s/\s+$//;
2890                                # Increment depth counter for the recursion guard
2891                                $self->_decode_multipart($pbody, $inner_boundary, $depth + 1);
2892                        }
2893                        next;
2894                }
2895
2896                # Decode transfer encoding and accumulate by content type
2897                my $decoded = $self->_decode_body($pbody, $pcte);
2898                if    ($pct =~ /text\/html/i)    { $self->{_body_html}  .= $decoded }
2899                elsif ($pct =~ /text/i || !$pct) { $self->{_body_plain} .= $decoded }
2900        }
2901
26
26
26
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
11409
21
230
2736
5
25
1397
1
9
1147
2
10
1029
1
9
2
9
441
1
9
862
1
11
542
}
2902
2903# _decode_body( $body, $cte ) -> string
2904#
2905# Purpose:
2906#   Decode a MIME body part according to its Content-Transfer-Encoding.
2907#
2908# Entry criteria:
2909#   $body -- raw body string (may be undef).
2910#   $cte  -- Content-Transfer-Encoding value string (may be undef).
2911#
2912# Exit status:
2913#   Returns the decoded string, or the original string if the encoding is
2914#   7bit/8bit/binary or unrecognised.
2915#
2916# Notes:
2917#   decode_qp and decode_base64 are imported from MIME:: modules; errors
2918#   from malformed content are silenced by the eval wrappers they provide.
2919
2920sub _decode_body :Private {
2921        my ($self, $body, $cte) = @_;
2922        $cte //= '';
2923        return decode_qp($body)     if $cte =~ /quoted-printable/i;
2924        return decode_base64($body) if $cte =~ /base64/i;
2925        return $body // '';
2926
26
26
26
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
4476
22
196
2399
3
27
1483
1
10
1237
1
9
1162
1
9
1
9
745
1
9
1132
2
9
830
}
2927
2928# -----------------------------------------------------------------------
2929# Private: Received-chain -> originating IP
2930# -----------------------------------------------------------------------
2931
2932# _find_origin()
2933#
2934# Purpose:
2935#   Walk the Received: chain (oldest-first) to find the first external IP,
2936#   or fall back to X-Originating-IP.  Enrich with rDNS and WHOIS.
2937#
2938# Entry criteria:
2939#   $self->{_received} populated by _split_message().
2940#   $self->{trusted_relays} set by new().
2941#
2942# Exit status:
2943#   Returns { ip, rdns, org, abuse, country, confidence, note } on success.
2944#   Returns undef if no usable IP can be identified.
2945#
2946# Side effects:
2947#   Network I/O via _enrich_ip(): one PTR lookup, one RDAP/WHOIS query.
2948#   Results are also stored in the CHI cross-message cache if available.
2949#
2950# Notes:
2951#   confidence 'high' = 2+ distinct external IPs;
2952#   'medium' = exactly one external IP;
2953#   'low' = taken from X-Originating-IP.
2954
2955sub _find_origin :Private {
2956        my $self = $_[0];
2957
2958        my @candidates;
2959
2960        # Walk oldest-first (reverse) to collect external IPs
2961        for my $hdr (reverse @{ $self->{_received} }) {
2962                my $ip = $self->_extract_ip_from_received($hdr) // next;
2963                next if $self->_is_private($ip);
2964                next if $self->_is_trusted($ip);
2965                push @candidates, $ip;
2966        }
2967
2968        # Fall back to X-Originating-IP if no external IPs in Received: chain
2969        unless (@candidates) {
2970                my $xoip = $self->_header_value('x-originating-ip');
2971                if ($xoip) {
2972                        $xoip =~ s/[\[\]\s]//g;
2973                        return $self->_enrich_ip($xoip, 'low',
2974                                'Taken from X-Originating-IP (webmail, unverified)')
2975                                unless $self->_is_private($xoip);
2976                }
2977                return;
2978        }
2979
2980        # Report the oldest (first) external IP; confidence depends on count
2981        return $self->_enrich_ip(
2982                $candidates[0],
2983                @candidates > 1 ? 'high' : 'medium',
2984                'First external hop in Received: chain',
2985        );
2986
26
26
26
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
7289
25
212
2173
4
27
289
1
9
521
1
10
725
1
9
1
9
788
1
8
649
1
9
890
}
2987
2988# _extract_ip_from_received( $hdr ) -> ipv4_or_ipv6_string | undef
2989#
2990# Purpose:
2991#   Extract the most-significant IP address from a raw Received: header
2992#   value, trying patterns in priority order.  Supports both IPv4 dotted-
2993#   quad and IPv6 bracket notation.
2994#
2995# Entry criteria:
2996#   $hdr -- a defined Received: header value string.
2997#
2998# Exit status:
2999#   Returns the IP string on success, undef if no IP can be extracted.
3000#
3001# Notes:
3002#   IPv4 addresses are validated (all octets <= 255).
3003#   IPv6 addresses are returned as-is if they contain colons.
3004
3005sub _extract_ip_from_received :Private {
3006        my ($self, $hdr) = @_;
3007        for my $re (@RECEIVED_IP_RE) {
3008                if ($hdr =~ $re) {
3009                        my $ip = $1;
3010
3011                        # Accept IPv6 addresses (contain colons) without further validation
3012                        return $ip if $ip =~ /:/;
3013
3014                        # Validate IPv4 format and octet range
3015                        next unless $ip =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/;
3016                        next if grep { $_ > 255 } split /\./, $ip;
3017                        return $ip;
3018                }
3019        }
3020        return;
3021
26
26
26
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
5682
27
775
2666
2
27
673
1
9
915
2
9
530
2
15
2
8
813
1
8
621
1
8
850
}
3022
3023# _is_private( $ip ) -> bool
3024#
3025# Purpose:
3026#   Test whether an IP address falls in any private, reserved, or special-
3027#   use range (IPv4 or IPv6) that should never be reported as a spam origin.
3028#
3029# Entry criteria:
3030#   $ip -- a scalar IP string (IPv4 or IPv6); may be undef.
3031#
3032# Exit status:
3033#   Returns 1 (true) if the IP is private/reserved, 0 (false) otherwise.
3034#   Returns 1 for undef or empty strings.
3035#
3036# Notes:
3037#   Uses the module-level @PRIVATE_RANGES array of pre-compiled regexes.
3038#   Covers all ranges listed in RFC 1122, 1918, 5737, 6598, and RFC 4193.
3039
3040sub _is_private :Private {
3041        my ($self, $ip) = @_;
3042        return 1 if !defined($ip) || $ip eq '';
3043        for my $re (@PRIVATE_RANGES) { return 1 if $ip =~ $re }
3044        return 0;
3045
26
26
26
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
4563
26
210
2297
3
26
761
1
11
785
1
9
354
1
9
1
9
820
2
7
492
1
8
780
}
3046
3047# _is_trusted( $ip ) -> bool
3048#
3049# Purpose:
3050#   Test whether an IP address matches any entry in the caller-supplied
3051#   trusted_relays list (exact IP or CIDR block).
3052#
3053# Entry criteria:
3054#   $ip -- a defined IPv4 address string.
3055#   $self->{trusted_relays} -- arrayref of exact IPs or CIDR strings.
3056#
3057# Exit status:
3058#   Returns 1 (true) if the IP matches any trusted relay, 0 otherwise.
3059
3060sub _is_trusted :Private {
3061        my ($self, $ip) = @_;
3062        for my $cidr (@{ $self->{trusted_relays} }) {
3063                return 1 if $self->_ip_in_cidr($ip, $cidr);
3064        }
3065        return 0;
3066
26
26
26
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
3521
20
182
1980
5
26
238
1
8
390
1
9
580
1
8
1
28
1458
1
7
782
1
9
1552
}
3067
3068# -----------------------------------------------------------------------
3069# Private: HTTP/HTTPS URL extraction and resolution
3070# -----------------------------------------------------------------------
3071
3072# _extract_and_resolve_urls() -> arrayref of url hashrefs
3073#
3074# Purpose:
3075#   Extract all HTTP/HTTPS URLs from the decoded body, resolve each unique
3076#   hostname to an IP, and enrich with WHOIS/RDAP data.  Optionally uses
3077#   AnyEvent::DNS to parallelise the DNS resolution step.
3078#
3079# Entry criteria:
3080#   $self->{_body_plain} and $self->{_body_html} populated by _split_message().
3081#
3082# Exit status:
3083#   Returns an arrayref of url hashrefs (possibly empty).
3084#
3085# Side effects:
3086#   Network I/O per unique hostname: one A/AAAA lookup, one RDAP/WHOIS.
3087#   Results stored in the CHI cross-message cache if available.
3088
3089sub _extract_and_resolve_urls :Private {
3090        my $self = $_[0];
3091        my (%url_seen, %host_cache);
3092        my @results;
3093        my $combined = $self->{_body_plain} . "\n" . $self->{_body_html};
3094
3095        # Collect unique URLs from body
3096        my @urls = grep { !$url_seen{$_}++ } $self->_extract_http_urls($combined);
3097
3098        # For URL-shortener and redirect-cloaker hosts, follow the redirect chain to
3099        # discover the real destination (e.g. GCS bucket → phishing landing page).
3100        # Done before DNS resolution so that destination hostnames can be parallelised.
3101        # _follow_redirect_chain() is a :Protected seam that handles LWP availability
3102        # internally — do not guard this block with $HAS_LWP so the seam can be
3103        # stubbed unconditionally in tests regardless of whether LWP is installed.
3104        for my $url (@urls) {
3105                my ($host) = $url =~ m{https?://([^/:?\s#]+)}i;
3106                next unless $host;
3107                my $bare = lc $host;
3108                $bare =~ s/^www\.//;
3109                next unless $URL_SHORTENERS{$bare}
3110                         || ($self->{url_shorteners} && $self->{url_shorteners}{$bare})
3111                         || $self->_is_redirect_cloaker($bare);
3112                my $dest = $self->_follow_redirect_chain($url);
3113                next unless defined $dest && !$url_seen{$dest}++;
3114                push @urls, $dest;
3115        }
3116
3117        # Extract unique hostnames for parallel DNS resolution (including redirect destinations)
3118        my %hostname_needed;
3119        for my $url (@urls) {
3120                my ($host) = $url =~ m{https?://([^/:?\s#]+)}i;
3121                $hostname_needed{$host}++ if $host;
3122        }
3123
3124        # Parallelise DNS lookups if AnyEvent::DNS is available
3125        if ($HAS_ANYEVENT_DNS && scalar(keys %hostname_needed) > 1) {
3126                $self->_parallel_resolve_hosts(\%hostname_needed, \%host_cache);
3127        }
3128
3129        # Process each URL: resolve hostname and WHOIS-enrich
3130        for my $url (@urls) {
3131                my ($host) = $url =~ m{https?://([^/:?\s#]+)}i;
3132                next unless $host;
3133
3134                # Resolve and WHOIS once per unique hostname, then cache the result
3135                unless (exists $host_cache{$host}) {
3136                        # Check the cross-message CHI cache first
3137                        my $cached = $_cache ? $_cache->get("url:$host") : undef;
3138                        if ($cached) {
3139                                $host_cache{$host} = $cached;
3140                        } else {
3141                                my $ip    = $self->_resolve_host($host) // '(unresolved)';
3142                                my $whois = $ip ne '(unresolved)'
3143                                          ? $self->_whois_ip($ip)
3144                                          : {};
3145
3146                                # Fall back to domain WHOIS if IP lookup returned nothing
3147                                if (!$whois->{abuse}) {
3148                                        my $reg = _registrable($host) // $host;
3149                                        my $dw  = $self->_parse_domain_whois_abuse($reg);
3150                                        $whois  = $dw if $dw->{abuse};
3151                                }
3152
3153                                my $entry = {
3154                                        ip      => $ip,
3155                                        org     => $whois->{org}     // '(unknown)',
3156                                        abuse   => $whois->{abuse}   // '(unknown)',
3157                                        country => $whois->{country} // undef,
3158                                };
3159                                $host_cache{$host} = $entry;
3160
3161                                # Store in cross-message cache for reuse across messages
3162                                $_cache->set("url:$host", $entry) if $_cache;
3163                        }
3164                }
3165
3166                push @results, { url => $url, host => $host, %{ $host_cache{$host} } };
3167        }
3168        return \@results;
3169
26
26
26
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
11986
41
244
2696
4
24
1243
2
8
1036
1
9
950
1
8
1
11
1251
1
9
484
1
11
1319
}
3170
3171# _is_redirect_cloaker( $bare_host ) -> bool
3172#
3173# Purpose:
3174#   Return true if $bare_host is a known cloud-storage or CDN host that is
3175#   commonly abused to serve client-side redirect pages hiding the real
3176#   phishing destination.  Checks the exact-match %REDIRECT_HOSTS table and
3177#   the suffix patterns in @REDIRECT_HOST_SUFFIXES.
3178#
3179# Entry criteria:
3180#   $bare_host -- lowercase hostname with any leading "www." already stripped.
3181#
3182# Exit status:
3183#   Returns 1 (true) or empty string (false).
3184
3185sub _is_redirect_cloaker :Private {
3186        my (undef, $host) = @_;
3187        return 1 if $REDIRECT_HOSTS{$host};
3188        for my $suffix (@REDIRECT_HOST_SUFFIXES) {
3189                return 1 if length($host) > length($suffix)
3190                         && substr($host, -length($suffix)) eq $suffix;
3191        }
3192        return '';
3193
26
26
26
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
5813
35
210
2218
5
28
1034
1
9
835
1
9
1305
2
9
1
9
1370
1
9
600
1
9
1442
}
3194
3195# _follow_redirect_chain( $url ) -> $final_url | undef
3196#
3197# Purpose:
3198#   Follow up to $REDIRECT_MAX_HOPS HTTP hops for a given URL and return the
3199#   final destination.  Detects HTTP 3xx Location: redirects, HTML
3200#   <meta http-equiv="refresh" content="...url=..."> tags, and
3201#   window.location.replace() / window.location.href JavaScript patterns.
3202#   Used to expose the real phishing landing page hidden behind a cloud
3203#   object-store redirect page (e.g. a GCS bucket containing only a
3204#   meta-refresh pointing to the attacker-controlled domain).
3205#
3206# Entry criteria:
3207#   $url  -- an https?:// URL string whose host has already been identified
3208#             as a URL shortener or redirect cloaker.
3209#   LWP::UserAgent must be installed ($HAS_LWP must be true).
3210#
3211# Exit status:
3212#   Returns the first URL that differs from the input after following the
3213#   chain, or undef if no redirect was found or LWP is unavailable.
3214#   Never returns the input $url unchanged.
3215#
3216# Side effects:
3217#   Up to $REDIRECT_MAX_HOPS HTTP GET requests.
3218#   Successful result cached in the cross-message CHI cache keyed
3219#   "redirect:<url>" to avoid re-fetching across messages.
3220
3221sub _follow_redirect_chain :Protected {
3222        my ($self, $url) = @_;
3223        return undef unless $HAS_LWP;
3224
3225        # Serve from cache when available
3226        if ($_cache) {
3227                my $cached = $_cache->get("redirect:$url");
3228                return $cached if defined $cached;
3229        }
3230
3231        # Dedicated no-follow UA so we can inspect each redirect hop manually.
3232        # Stored separately from the RDAP UA ($self->{ua}) which needs auto-follow.
3233        unless (defined $self->{_ua_nofollow}) {
3234                my $ua = LWP::UserAgent->new(
3235                        timeout      => $self->{timeout},
3236                        agent        => "Email-Abuse-Investigator/$VERSION",
3237                        max_redirect => 0,
3238                );
3239                if ($HAS_CONN_CACHE) {
3240                        my $cc = LWP::ConnCache->new();
3241                        $cc->total_capacity(4);
3242                        $ua->conn_cache($cc);
3243                }
3244                $ua->env_proxy(1);
3245                $self->{_ua_nofollow} = $ua;
3246        }
3247        my $ua = $self->{_ua_nofollow};
3248
3249        my $current = $url;
3250        my $final;
3251        for my $hop (1 .. $REDIRECT_MAX_HOPS) {
3252                my $res = eval { $ua->get($current) };
3253                last unless $res;
3254
3255                if ($res->is_redirect()) {
3256                        # HTTP 3xx: extract Location header
3257                        my $loc = $res->header('Location');
3258                        last unless defined $loc;
3259
3260                        # Resolve relative Location URLs against the current base
3261                        if ($loc !~ m{^https?://}i) {
3262                                require URI;
3263                                $loc = URI->new_abs($loc, $current)->as_string();
3264                        }
3265                        $final   = $loc;
3266                        $current = $loc;
3267                } elsif ($res->is_success()) {
3268                        # 2xx: inspect body for client-side redirect patterns
3269                        my $body = $res->decoded_content() // '';
3270                        my $dest;
3271
3272                        # <meta http-equiv="refresh" content="N; url=https://...">
3273                        if ($body =~ m{<meta[^>]+http-equiv\s*=\s*["']?refresh["']?[^>]+
3274                                        content\s*=\s*["'][^"']*url\s*=\s*(https?://[^"'\s>]+)}xi) {
3275                                $dest = $1;
3276                        }
3277                        # window.location.replace("...") or window.location.href = "..."
3278                        elsif ($body =~ m{window\.location(?:\.replace\s*\(\s*|\.href\s*=\s*)
3279                                           ["'](https?://[^"']+)["']}xi) {
3280                                $dest = $1;
3281                        }
3282
3283                        last unless defined $dest;
3284                        $final   = $dest;
3285                        $current = $dest;
3286                } else {
3287                        last;
3288                }
3289        }
3290
3291        # Cache for reuse across messages in this session
3292        $_cache->set("redirect:$url", $final) if $_cache && defined $final;
3293
3294        return $final;
3295
26
26
26
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
12200
21
232
1689
3
24
1270
1
26
1018
0
8
955
1
9
1
11
1156
1
9
300
1
10
1180
}
3296
3297# _parallel_resolve_hosts( \%hostnames, \%cache )
3298#
3299# Purpose:
3300#   Resolve multiple hostnames to IPs in parallel using AnyEvent::DNS.
3301#   Populates the cache with resolved IPs so the sequential loop in
3302#   _extract_and_resolve_urls() can skip the DNS step for pre-resolved hosts.
3303#
3304# Entry criteria:
3305#   $hostnames_ref -- hashref keyed by hostname (values ignored).
3306#   $cache_ref     -- hashref to populate with { ip => '...' } results.
3307#   AnyEvent::DNS must be installed ($HAS_ANYEVENT_DNS is true).
3308#
3309# Exit status:
3310#   Returns undef; all results written to %$cache_ref via side effects.
3311#
3312# Notes:
3313#   Errors (NXDOMAIN, timeout) are silently swallowed; the sequential
3314#   resolution loop will return '(unresolved)' for those hosts.
3315
3316sub _parallel_resolve_hosts :Private {
3317        my ($self, $hostnames_ref, $cache_ref) = @_;
3318        # Guard both conditions together: an empty hash must never reach condvar
3319        # creation because $cv->recv would block forever with $pending == 0.
3320        return unless $HAS_ANYEVENT_DNS && %$hostnames_ref;
3321
3322        # Build an AnyEvent condvar to wait for all lookups to complete
3323        my $cv      = AnyEvent->condvar;
3324        my $pending = scalar keys %$hostnames_ref;
3325
3326        # AnyEvent::DNS::resolve is a method, not a standalone function.
3327        # Use the global resolver singleton; passing a bare string as the
3328        # first arg would make Perl treat the hostname as the invocant.
3329        my $resolver = AnyEvent::DNS::resolver();
3330
3331        for my $host (keys %$hostnames_ref) {
3332                # Fire an async A query for each hostname
3333                $resolver->resolve(
3334                        $host, 'a',
3335                        sub {
3336                                my @answers = @_;
3337                                if (@answers) {
3338                                        # Cache the first A record result
3339                                        $cache_ref->{$host} = { ip => $answers[0][4] };
3340                                }
3341                                # Decrement the pending counter; signal when all done
3342                                $cv->send if --$pending <= 0;
3343                        },
3344                );
3345        }
3346
3347        # Block until all DNS queries complete (subject to AnyEvent's own timeouts)
3348        $cv->recv;
3349
26
26
26
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
6456
101
216
2086
4
25
311
1
9
412
1
8
547
1
9
1
9
872
1
10
1268
1
12
980
}
3350
3351# _extract_http_urls( $body ) -> list of url strings
3352#
3353# Purpose:
3354#   Extract all HTTP and HTTPS URLs from a body string, using both
3355#   structural HTML parsing (if HTML::LinkExtor is available) and a
3356#   plain-text regex pass.  Deduplicates and strips trailing punctuation.
3357#
3358# Entry criteria:
3359#   $body -- combined plain+HTML body string.
3360#
3361# Exit status:
3362#   Returns a list of URL strings (possibly empty), deduplicated.
3363
3364sub _extract_http_urls :Private {
3365        my ($self, $body) = @_;
3366        my @urls;
3367
3368        # Structural HTML link extraction (handles quoted attributes correctly)
3369        if ($HAS_HTML_LINKEXTOR) {
3370                my $p = HTML::LinkExtor->new(sub {
3371                        my ($tag, %attrs) = @_;
3372                        for my $attr (qw(href src action)) {
3373                                my $val = $attrs{$attr} // '';
3374                                if ($val =~ m{^https?://}i) {
3375                                        push @urls, $val;
3376                                } elsif ($val =~ m{^//[\w.-]}) {
3377                                        # Protocol-relative -- assume https
3378                                        push @urls, 'https:' . $val;
3379                                }
3380                        }
3381                });
3382                $p->parse($body);
3383        }
3384
3385        # Plain-text regex pass for bare URLs not in HTML attributes
3386        while ($body =~ m{(https?://[^\s<>"'\)\]]+)}gi) {
3387                push @urls, $1;
3388        }
3389
3390        # Protocol-relative URLs not caught above
3391        while ($body =~ m{(?:^|[\s"'=])(//[\w.-][^\s<>"'\)\]]*)}gim) {
3392                push @urls, 'https:' . $1;
3393        }
3394
3395        # Deduplicate and strip trailing punctuation
3396        my %seen;
3397        my @all = grep { !$seen{$_}++ } @urls;
3398        s/[.,;:!?\)>\]]+$// for @all;
3399        return @all;
3400
26
26
26
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
11058
24
225
2943
4
26
293
1
11
388
1
9
566
2
8
1
9
957
1
10
1711
1
10
789
}
3401
3402# -----------------------------------------------------------------------
3403# Private: domain extraction and full analysis
3404# -----------------------------------------------------------------------
3405
3406# _extract_and_analyse_domains() -> arrayref of domain hashrefs
3407#
3408# Purpose:
3409#   Collect all non-infrastructure contact domains from headers and body,
3410#   run the full domain intelligence pipeline on each, and return an arrayref
3411#   suitable for storage in $self->{_mailto_domains}.
3412#
3413# Entry criteria:
3414#   _split_message() must have been called.
3415#
3416# Exit status:
3417#   Always returns an arrayref; never undef.
3418#
3419# Side effects:
3420#   Network I/O per domain via _analyse_domain().
3421#   Results stored in $self->{_domain_info} and CHI cache.
3422
3423sub _extract_and_analyse_domains :Private {
3424        my $self = $_[0];
3425        my (%seen, @domains_with_source);
3426
3427        # Build a set of recipient domains to exclude (victims, not senders)
3428        my %recipient_domains;
3429        for my $hname (qw(to cc)) {
3430                my $val = $self->_header_value($hname) // next;
3431                for my $dom ($self->_domains_from_text($val)) {
3432                        my $reg = _registrable($dom) // $dom;
3433                        $recipient_domains{$dom}++;
3434                        $recipient_domains{$reg}++;
3435                }
3436        }
3437
3438        # Also exclude domains from Received: "for" envelope recipients
3439        for my $hop (@{ $self->{_rcvd_tracking} }) {
3440                next unless $hop->{for} && $hop->{for} =~ /\@([\w.-]+)/;
3441                my $dom = lc $1;
3442                my $reg = _registrable($dom) // $dom;
3443                $recipient_domains{$dom}++;
3444                $recipient_domains{$reg}++;
3445        }
3446
3447        # Inner closure: record a domain if it passes all filters
3448        my $record = sub {
3449                my ($dom, $source) = @_;
3450                $dom = lc $dom;
3451                $dom =~ s/\.$//;
3452                next if $self->{trusted_domains}->{$dom};
3453                return if $TRUSTED_DOMAINS{$dom};
3454                return if $recipient_domains{$dom};
3455                return if $recipient_domains{ _registrable($dom) // $dom };
3456                # Discard non-routable hostnames (single-label, pseudo-TLDs, etc.)
3457                return unless $dom =~ /\.[a-zA-Z]{2,}$/;
3458                return if $dom =~ /\.(?:local|internal|lan|localdomain|arpa)$/i;
3459                return if $seen{$dom}++;
3460                push @domains_with_source, { domain => $dom, source => $source };
3461        };
3462
3463        # Collect from standard sender/reply headers
3464        my %header_sources = (
3465                'from'        => 'From: header',
3466                'reply-to'    => 'Reply-To: header',
3467                'return-path' => 'Return-Path: header',
3468                'sender'      => 'Sender: header',
3469        );
3470        for my $hname (sort keys %header_sources) {
3471                my $val = $self->_header_value($hname) // next;
3472                $record->($_, $header_sources{$hname})
3473                        for $self->_domains_from_text($val);
3474        }
3475
3476        # Message-ID domain often reveals the real bulk-sending platform
3477        my $mid = $self->_header_value('message-id');
3478        if ($mid && $mid =~ /\@([\w.-]+)/) {
3479                my $mid_dom = lc $1;
3480                my $mid_reg = _registrable($mid_dom) // $mid_dom;
3481                $record->($mid_dom, 'Message-ID: header')
3482                        unless $TRUSTED_DOMAINS{$mid_dom} || $TRUSTED_DOMAINS{$mid_reg} || $self->{trusted_domains}->{$mid_dom} || $self->{trusted_domains}->{$mid_reg};
3483        }
3484
3485        # DKIM signing domain(s) -- the organisation that vouches for the message
3486        my $auth = $self->_parse_auth_results_cached();
3487        for my $dkim_d (@{ $auth->{dkim_domains} // [] }) {
3488                $record->($dkim_d, 'DKIM-Signature: d= (signing domain)');
3489        }
3490
3491        # List-Unsubscribe identifies the ESP or bulk sender
3492        my $unsub = $self->_header_value('list-unsubscribe');
3493        if ($unsub) {
3494                while ($unsub =~ m{https?://([^/:?\s>]+)}gi) {
3495                        $record->(lc $1, 'List-Unsubscribe: header');
3496                }
3497                while ($unsub =~ m{mailto:[^@\s>]+\@([\w.-]+)}gi) {
3498                        $record->(lc $1, 'List-Unsubscribe: header');
3499                }
3500        }
3501
3502        # Body email addresses (mailto: and bare user@domain forms)
3503        my $combined = $self->{_body_plain} . "\n" . $self->{_body_html};
3504        $record->($_, 'email address / mailto in body')
3505                for $self->_domains_from_text($combined);
3506
3507        # Run the full intelligence pipeline on each collected domain
3508        my @results;
3509        for my $entry (@domains_with_source) {
3510                my $info = $self->_analyse_domain($entry->{domain});
3511                push @results, { %$entry, %$info };
3512        }
3513        return \@results;
3514
26
26
26
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
15653
25
270
2699
3
27
1240
2
9
1129
1
9
1047
1
9
2
9
1105
1
10
807
1
10
1120
}
3515
3516# _domains_from_text( $text ) -> list of domain strings
3517#
3518# Purpose:
3519#   Extract unique domain names from mailto: links and bare user@domain
3520#   addresses in a block of text.
3521#
3522# Entry criteria:
3523#   $text -- a defined scalar of decoded body or header text.
3524#
3525# Exit status:
3526#   Returns a list of lower-cased domain strings (possibly empty).
3527
3528sub _domains_from_text :Private {
3529        my ($self, $text) = @_;
3530        my (%seen, @out);
3531
3532        # mailto: links (including HTML-entity-encoded @ signs from QP)
3533        while ($text =~ /mailto:(?:[^@\s<>"]+)@([\w.-]+)/gi) {
3534                my $dom = lc $1; $dom =~ s/\.$//;
3535                push @out, $dom unless $seen{$dom}++;
3536        }
3537
3538        # Bare user@domain patterns
3539        while ($text =~ /\b[\w.+%-]+@([\w.-]+\.[a-zA-Z]{2,})\b/g) {
3540                my $dom = lc $1; $dom =~ s/\.$//;
3541                push @out, $dom unless $seen{$dom}++;
3542        }
3543        return @out;
3544
26
26
26
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
7939
31
213
2124
3
23
565
1
11
649
1
10
239
1
9
1
9
1397
2
10
1259
2
11
1513
}
3545
3546# _analyse_domain( $domain ) -> hashref
3547#
3548# Purpose:
3549#   Run the complete intelligence pipeline for a single domain: A record
3550#   (web hosting), MX record (mail hosting), NS record (DNS hosting),
3551#   and WHOIS (registrar, creation/expiry dates, abuse contact).
3552#   Each IP is enriched via RDAP/WHOIS.  Results are cached per domain
3553#   in $self->{_domain_info} and in the CHI cross-message cache.
3554#
3555# Entry criteria:
3556#   $domain -- lower-cased, no trailing dot, not in TRUSTED_DOMAINS.
3557#   $self->{timeout} used for all network operations.
3558#
3559# Exit status:
3560#   Always returns a hashref reference; never undef; may be empty ({}).
3561#   Possible keys: web_ip, web_org, web_abuse, mx_host, mx_ip, mx_org,
3562#   mx_abuse, ns_host, ns_ip, ns_org, ns_abuse, registrar,
3563#   registrar_abuse, registered, expires, recently_registered, whois_raw.
3564#
3565# Side effects:
3566#   Network I/O; writes result to $self->{_domain_info}{$domain} and CHI.
3567#
3568# Notes:
3569#   MX/NS lookups require Net::DNS; absent without it.
3570#   recently_registered is set to 1 (not 0) when the threshold is met.
3571#   whois_raw is truncated to WHOIS_RAW_MAX bytes.
3572
3573sub _analyse_domain :Private {
3574        my ($self, $domain) = @_;
3575
3576        # Return the per-message cached result if already analysed
3577        return $self->{_domain_info}{$domain}
3578                if $self->{_domain_info}{$domain};
3579
3580        # Check the cross-message CHI cache before hitting the network
3581        if ($_cache) {
3582                my $cached = $_cache->get("dom:$domain");
3583                if ($cached) {
3584                        $self->{_domain_info}{$domain} = $cached;
3585                        return $cached;
3586                }
3587        }
3588
3589        $self->_debug("Analysing domain: $domain");
3590        my %info;
3591
3592        # --- A record -> web hosting IP ---
3593        my $web_ip = $self->_resolve_host($domain);
3594        if ($web_ip) {
3595                $info{web_ip} = $web_ip;
3596                my $w = $self->_whois_ip($web_ip);
3597                $info{web_org}   = $w->{org}   if $w->{org};
3598                $info{web_abuse} = $w->{abuse} if $w->{abuse};
3599        }
3600
3601        # MX and NS lookups require Net::DNS
3602        if ($HAS_NET_DNS) {
3603                my $res = Net::DNS::Resolver->new(
3604                        tcp_timeout => $self->{timeout},
3605                        udp_timeout => $self->{timeout},
3606                );
3607
3608                # --- MX record -> mail hosting ---
3609                if(my $mxq = $res->search($domain, 'MX')) {
3610                        my ($best) = sort { $a->preference <=> $b->preference }
3611                                     grep { $_->type eq 'MX' } $mxq->answer;
3612                        if ($best) {
3613                                (my $mx_host = lc $best->exchange) =~ s/\.$//;
3614                                $info{mx_host} = $mx_host;
3615                                my $mx_ip = $self->_resolve_host($mx_host);
3616                                if ($mx_ip) {
3617                                        $info{mx_ip} = $mx_ip;
3618                                        my $mw = $self->_whois_ip($mx_ip);
3619                                        $info{mx_org}   = $mw->{org}   if $mw->{org};
3620                                        $info{mx_abuse} = $mw->{abuse} if $mw->{abuse};
3621                                }
3622                        }
3623                }
3624
3625                # --- NS record -> DNS hosting ---
3626                if(my $nsq = $res->search($domain, 'NS')) {
3627                        # Sort alphabetically so DNS round-robin ordering never changes which
3628                        # nameserver we record -- both runs of the same domain always agree.
3629                        my ($first) = sort { $a->nsdname cmp $b->nsdname } grep { $_->type eq 'NS' } $nsq->answer;
3630                        if ($first) {
3631                                (my $ns_host = lc $first->nsdname) =~ s/\.$//;
3632                                $info{ns_host} = $ns_host;
3633                                my $ns_ip = $self->_resolve_host($ns_host);
3634                                if ($ns_ip) {
3635                                        $info{ns_ip} = $ns_ip;
3636                                        my $nw = $self->_whois_ip($ns_ip);
3637                                        $info{ns_org}   = $nw->{org}   if $nw->{org};
3638                                        $info{ns_abuse} = $nw->{abuse} if $nw->{abuse};
3639                                }
3640                        }
3641                }
3642        }
3643
3644        # --- Domain WHOIS -> registrar + dates ---
3645        if(my $domain_whois = $self->_domain_whois($domain)) {
3646                # Truncate raw WHOIS for storage but parse structured fields from full text
3647                $info{whois_raw} = substr($domain_whois, 0, $WHOIS_RAW_MAX);
3648
3649                # Registrar name
3650                if ($domain_whois =~ /Registrar:\s*(.+)/i) {
3651                        ($info{registrar} = $1) =~ s/\s+$//;
3652                }
3653
3654                # Registrar abuse contact email (try multiple field names)
3655                for my $pat (
3656                        qr/Registrar Abuse Contact Email:\s*(\S+@\S+)/i,
3657                        qr/Abuse Contact Email:\s*(\S+@\S+)/i,
3658                        qr/abuse-contact:\s*(\S+@\S+)/i,
3659                ) {
3660                        if (!$info{registrar_abuse} && $domain_whois =~ $pat) {
3661                                ($info{registrar_abuse} = $1) =~ s/\s+$//;
3662                        }
3663                }
3664
3665                # Domain creation date (multiple registrar field name variations)
3666                for my $pat (
3667                        qr/Creation Date:\s*(\S+)/i,
3668                        qr/Created(?:\s+On)?:\s*(\S+)/i,
3669                        qr/Registration Time:\s*(\S+)/i,
3670                        qr/^registered:\s*(\S+)/im,
3671                ) {
3672                        if (!$info{registered} && $domain_whois =~ $pat) {
3673                                ($info{registered} = $1) =~ s/[TZ].*//;
3674                        }
3675                }
3676
3677                # Domain expiry date
3678                for my $pat (
3679                        qr/Registry Expiry Date:\s*(\S+)/i,
3680                        qr/Expir(?:y|ation)(?: Date)?:\s*(\S+)/i,
3681                        qr/paid-till:\s*(\S+)/i,
3682                ) {
3683                        if (!$info{expires} && $domain_whois =~ $pat) {
3684                                ($info{expires} = $1) =~ s/[TZ].*//;
3685                        }
3686                }
3687
3688                # Flag recently-registered domains (< RECENT_REG_DAYS old)
3689                if ($info{registered}) {
3690                        my $epoch = $self->_parse_date_to_epoch($info{registered});
3691                        $info{recently_registered} = 1
3692                                if $epoch && (time() - $epoch) < $RECENT_REG_DAYS * $SECS_PER_DAY;
3693                }
3694        }
3695
3696        # Store in per-message and cross-message caches
3697        $self->{_domain_info}{$domain} = \%info;
3698        $_cache->set("dom:$domain", \%info) if $_cache;
3699
3700        return \%info;
3701
26
26
26
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
17589
29
246
2795
3
26
740
2
9
823
1
10
420
1
9
1
10
1120
1
9
839
2
11
1055
}
3702
3703# -----------------------------------------------------------------------
3704# Private: DNS helpers
3705# -----------------------------------------------------------------------
3706
3707# _resolve_host( $host ) -> ip_string | undef
3708#
3709# Purpose:
3710#   Resolve a hostname to an IPv4 (or IPv6) address.  Uses Net::DNS for
3711#   both A and AAAA queries when available; falls back to inet_aton for
3712#   pure IPv4 resolution.
3713#
3714# Entry criteria:
3715#   $host -- hostname string or already-numeric IP.
3716#
3717# Exit status:
3718#   Returns the first resolved IP string, or undef on failure.
3719#
3720# Notes:
3721#   When the input is already a dotted-quad IPv4 it is returned immediately.
3722#   AAAA records are tried if the A query fails and Net::DNS is available.
3723
3724sub _resolve_host :Protected {
3725
562
2127
        my ($self, $host) = @_;
3726
562
515
        return $host if $host =~ /^\d{1,3}(?:\.\d{1,3}){3}$/;
3727
3728        # Check the CHI cache before hitting DNS
3729
561
2078
        if ($_cache) {
3730
1850
1791
                my $cached_ip = $_cache->get("resolve:$host");
3731
289
471
                return $cached_ip if defined $cached_ip;
3732        }
3733
3734
85
2923
        my $ip;
3735
3736
449
662
        if ($HAS_NET_DNS) {
3737                my $res = Net::DNS::Resolver->new(
3738                        tcp_timeout => $self->{timeout},
3739                        udp_timeout => $self->{timeout},
3740
384
636
                );
3741
3742                # Try A record first, then AAAA for IPv6
3743
138
3788
                for my $type (qw(A AAAA)) {
3744
79
85
                        my $query = $res->search($host, $type);
3745
137
225
                        if ($query) {
3746
384
4059
                                for my $rr ($query->answer) {
3747
139
129
                                        if ($rr->type eq 'A') {
3748
507
493
                                                $ip = $rr->address;
3749
202
4208
                                                last;
3750                                        } elsif ($rr->type eq 'AAAA') {
3751
454
376
                                                $ip = $rr->address;
3752
85
126
                                                last;
3753                                        }
3754                                }
3755                        }
3756
144
3451
                        last if defined $ip;
3757                }
3758        } else {
3759                # Fallback: gethostbyname (IPv4 only)
3760
86
72
79
68046
                my $packed = eval { inet_aton($host) };
3761
14
907
                $ip = $packed ? inet_ntoa($packed) : undef;
3762        }
3763
3764        # Cache the result (including undef as '' to avoid repeated failed lookups)
3765
147
198
        if ($_cache) {
3766
79
103
                $_cache->set("resolve:$host", $ip // '');
3767        }
3768
3769
70
2167
        return $ip;
3770
26
26
26
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
8141
21
213
2438
4
26
281
2
9
423
1
9
598
1
9
1
9
694
1
10
798
1
10
511
}
3771
3772# _reverse_dns( $ip ) -> hostname | undef
3773#
3774# Purpose:
3775#   Perform a PTR (reverse DNS) lookup for an IP address.  Supports both
3776#   IPv4 and IPv6 via Net::DNS when available; falls back to gethostbyaddr.
3777#
3778# Entry criteria:
3779#   $ip -- a defined IPv4 or IPv6 address string.
3780#
3781# Exit status:
3782#   Returns the PTR hostname string, or undef if no record exists.
3783
3784sub _reverse_dns :Protected {
3785
98
100
        my ($self, $ip) = @_;
3786
99
121
        return unless $ip;
3787
3788
99
2427
        if ($HAS_NET_DNS) {
3789
81
194
                my $res   = Net::DNS::Resolver->new(tcp_timeout => $self->{timeout});
3790
81
203
                my $query = $res->search($ip, 'PTR');
3791
453
3830
                if ($query) {
3792
2283
1620
                        for my $rr ($query->answer) {
3793
453
421
                                return $rr->ptrdname if $rr->type eq 'PTR';
3794                        }
3795                }
3796
64
2608
                return;
3797        }
3798
3799        # Fallback for IPv4 only
3800
85
647790
        return scalar gethostbyaddr(inet_aton($ip), AF_INET);
3801
26
26
26
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
5473
23
196
2089
3
27
295
1
8
238
1
29
713
1
9
1
10
363
1
8
1299
1
8
287
}
3802
3803# -----------------------------------------------------------------------
3804# Private: WHOIS / RDAP
3805# -----------------------------------------------------------------------
3806
3807# _whois_ip( $ip ) -> hashref
3808#
3809# Purpose:
3810#   Enrich an IP address with organisation name, abuse contact, and country
3811#   code.  Tries RDAP first (if LWP is available), then falls back to raw
3812#   WHOIS via IANA referral.  Results are cached in CHI if available.
3813#
3814# Entry criteria:
3815#   $ip -- a defined IPv4 or IPv6 address string.
3816#
3817# Exit status:
3818#   Returns { org, abuse, country } hashref; keys absent when unknown.
3819
3820sub _whois_ip :Protected {
3821
160
272
        my ($self, $ip) = @_;
3822
3823        # Check CHI cache before going to the network
3824
100
1165
        if ($_cache) {
3825
78
106
                my $cached = $_cache->get("whois_ip:$ip");
3826
137
227
                return $cached if $cached;
3827        }
3828
3829
158
3328
        my $result = $HAS_LWP ? $self->_rdap_lookup($ip) : {};
3830
3831        # Fall back to raw WHOIS if RDAP returned no organisation
3832
158
236
        unless ($result->{org}) {
3833
158
319
                my $raw = $self->_raw_whois($ip, 'whois.iana.org');
3834
158
4019
                if ($raw) {
3835
27
132
                        my ($ref) = $raw =~ /whois:\s*([\w.-]+)/i;
3836
84
183
                        my $detail = $ref ? $self->_raw_whois($ip, $ref) : $raw;
3837
81
4316
                        $result = $self->_parse_whois_text($detail) if $detail;
3838                }
3839        }
3840
3841        # Cache the enrichment result
3842
141
136
        $_cache->set("whois_ip:$ip", $result) if $_cache && $result;
3843
3844
141
201
        return $result;
3845
26
26
26
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
7389
26
265
1945
5
25
233
1
8
380
1
8
575
1
8
1
8
493
1
9
1252
1
8
381
}
3846
3847# _domain_whois( $domain ) -> raw_whois_string | undef
3848#
3849# Purpose:
3850#   Perform a two-step WHOIS lookup for a domain: first ask IANA for the
3851#   TLD's authoritative WHOIS server, then query that server.
3852#
3853# Entry criteria:
3854#   $domain -- a lower-cased domain name string.
3855#
3856# Exit status:
3857#   Returns the raw WHOIS response string, or undef on failure.
3858
3859sub _domain_whois :Protected {
3860
70
2775
        my ($self, $domain) = @_;
3861
70
209
        my $iana = $self->_raw_whois($domain, 'whois.iana.org') // return;
3862
130
427
        my ($server) = $iana =~ /whois:\s*([\w.-]+)/i;
3863
130
3276
        return unless $server;
3864
124
233
        return $self->_raw_whois($domain, $server);
3865
26
26
26
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
5361
23
203
1941
2
12
688
1
10
1907
1
11
2405
1
12
1
10
1368
1
8
430
1
8
1365
}
3866
3867# _parse_domain_whois_abuse( $domain ) -> hashref
3868#
3869# Purpose:
3870#   Lightweight domain WHOIS lookup to extract only registrar name and
3871#   abuse contact.  Used as a fallback in _extract_and_resolve_urls() when
3872#   a URL host cannot be resolved to an IP.
3873#
3874# Entry criteria:
3875#   $domain -- a registrable domain name string.
3876#
3877# Exit status:
3878#   Returns { org, abuse } hashref; empty hashref on failure.
3879
3880sub _parse_domain_whois_abuse :Private {
3881        my ($self, $domain) = @_;
3882        my $raw = $self->_domain_whois($domain) // return {};
3883        my %info;
3884        if ($raw =~ /Registrar:\s*(.+)/i) {
3885                ($info{org} = $1) =~ s/\s+$//;
3886        }
3887        # Try multiple field name patterns for the abuse email
3888        for my $pat (
3889                qr/Registrar Abuse Contact Email:\s*(\S+\@\S+)/i,
3890                qr/Abuse Contact Email:\s*(\S+\@\S+)/i,
3891                qr/abuse-contact:\s*(\S+\@\S+)/i,
3892        ) {
3893                if (!$info{abuse} && $raw =~ $pat) {
3894                        ($info{abuse} = $1) =~ s/\s+$//;
3895                }
3896        }
3897        return \%info;
3898
26
26
26
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
7471
34
200
2
1
30
2
1
31
2
0
32
2
0
36
1
9
1505
1
8
638
2
10
1434
}
3899
3900# _rdap_lookup( $ip ) -> hashref
3901#
3902# Purpose:
3903#   Query the ARIN RDAP API for IP block ownership information.  RDAP is
3904#   preferred over raw WHOIS because it returns structured JSON.
3905#
3906# Entry criteria:
3907#   $ip     -- a defined IPv4 or IPv6 address string.  RFC 4007 zone
3908#              identifiers (e.g. %eth0 appended to link-local addresses)
3909#              are stripped before validation.  The remaining value must
3910#              match dotted-quad IPv4 or bare hex-colon IPv6; malformed
3911#              inputs return {} immediately without a network call.
3912#   LWP::UserAgent must be installed.
3913#
3914# Exit status:
3915#   Returns { org, abuse, country } hashref; empty hashref on failure or
3916#   when $ip does not pass format validation.
3917#
3918# Security:
3919#   $ip is validated before being interpolated into the RDAP URL path to
3920#   prevent URL path manipulation.  Zone IDs are stripped first because
3921#   a literal '%' in the path would corrupt the URL.
3922
3923sub _rdap_lookup :Protected {
3924
126
215
        my ($self, $ip) = @_;
3925
67
2279
        return {} unless $HAS_LWP;
3926
3927
65
145
        my $ua = $self->{ua};
3928
4
35
        if(!defined($ua)) {
3929                $ua = LWP::UserAgent->new(
3930                        timeout => $self->{timeout},
3931
5
10
                        agent   => "Email-Abuse-Investigator/$VERSION",
3932                );
3933
3934
5
9
                if($HAS_CONN_CACHE) {
3935
5
122
                        my $conn_cache = LWP::ConnCache->new();
3936
79
80
                        $conn_cache->total_capacity(10);
3937
79
114
                        $ua->conn_cache($conn_cache);
3938                }
3939
3940
4
12
                $ua->env_proxy(1);
3941
64
6650
                $self->{ua} = $ua;
3942        }
3943
3944        # Validate and normalise the IP before interpolating into the URL path.
3945        # Strip RFC 4007 IPv6 zone IDs (%eth0 suffix) which would corrupt the URL,
3946        # then assert the result is a valid dotted-quad IPv4 or bare hex IPv6.
3947
7
12
        (my $safe_ip = $ip) =~ s/%.*\z//;
3948
64
146
        unless ($safe_ip =~ /\A\d{1,3}(?:\.\d{1,3}){3}\z/
3949             || $safe_ip =~ /\A[0-9a-fA-F:]+\z/) {
3950
64
61
                $self->_debug("_rdap_lookup: malformed IP '$ip' -- skipping");
3951
4
6
                return {};
3952        }
3953
3954        # Use the ARIN RDAP endpoint; it covers the ARIN region and redirects
3955        # for RIPE/APNIC/LACNIC/AfriNIC allocations.
3956
4
4
42
14
        my $res = eval { $ua->get("https://rdap.arin.net/registry/ip/$safe_ip") };
3957
79
89
        return {} unless $res && $res->is_success();
3958
3959
139
134
        my $j = $res->decoded_content();
3960
139
881
        my %info;
3961
3962        # Extract organisation name from the JSON response
3963
79
139
75
148
        if ($j =~ /"name"\s*:\s*"([^"]+)"/)   { $info{org}    = $1 }
3964
70
11
101
275
        if ($j =~ /"handle"\s*:\s*"([^"]+)"/) { $info{handle} = $1 }
3965
3966        # Extract abuse email from the vcardArray contact block
3967
70
59
        if ($j =~ /"abuse".*?"email"\s*:\s*"([^"]+)"/s) {
3968
70
66
                $info{abuse} = $1;
3969        } elsif ($j =~ /"email"\s*:\s*"([^@"]+@[^"]+)"/) {
3970
70
294
                $info{abuse} = $1;
3971        }
3972
3973        # Country code from the network's country field
3974
13
9
17
86
        if ($j =~ /"country"\s*:\s*"([A-Z]{2})"/) { $info{country} = $1 }
3975
3976
9
16
        return \%info;
3977
26
26
26
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
10282
25
221
2
0
4
2
1
3
2
1
4
2
1
3
1
9
335
1
10
1281
0
10
417
}
3978
3979# _raw_whois( $query, $server ) -> string | undef
3980#
3981# Purpose:
3982#   Open a TCP connection to a WHOIS server on port 43, send the query,
3983#   and return the full response as a string.  Uses IO::Select for read
3984#   timeouts so that alarm() is never needed (alarm() is unreliable on
3985#   Windows and in threaded Perl).  Supports IPv6 WHOIS servers via
3986#   IO::Socket::IP when that module is available.
3987#
3988# Entry criteria:
3989#   $query   -- the domain name or IP to query (defined, non-empty after
3990#               stripping control characters; croaks if it becomes empty).
3991#   $server  -- the WHOIS server hostname (default: 'whois.iana.org').
3992#   $self->{timeout} -- seconds used for connect and per-read waits.
3993#
3994# Exit status:
3995#   Returns the raw WHOIS response string, or undef on connection/write failure.
3996#   Croaks if $query is empty or contains only control characters.
3997#
3998# Security:
3999#   All ASCII control characters (C0 range 0x00-0x1F and DEL 0x7F) are
4000#   stripped from $query before it is sent to the socket.  This prevents
4001#   WHOIS protocol injection via CRLF sequences that could smuggle a second
4002#   query into the same TCP stream.  The guard is enforced at this
4003#   :Protected boundary so subclass callers are also protected.
4004#
4005# Notes:
4006#   Uses IO::Socket::IP (dual-stack) when available, falling back to
4007#   IO::Socket::INET (IPv4 only) otherwise.  The IO::Select loop reads
4008#   until the server closes the connection or the per-read timeout expires.
4009
4010sub _raw_whois :Protected {
4011
56
404
        my ($self, $query, $server) = @_;
4012
54
156
        $server //= 'whois.iana.org';
4013
4014        # Strip all C0/C1 control characters to prevent WHOIS protocol injection.
4015        # Legitimate domain names and IP addresses never contain CR, LF, NUL, or
4016        # any other control character; their presence indicates either a caller bug
4017        # or hostile input embedded in a malicious email.  This guard is placed at
4018        # the :Protected boundary so subclass callers are also protected.
4019
54
188
        (my $safe_query = $query) =~ s/[\x00-\x1F\x7F]+//g;
4020
50
122
        Carp::croak(__PACKAGE__ . '::_raw_whois: empty query after stripping control characters')
4021                unless length $safe_query;
4022
4023
46
253
        $self->_debug("WHOIS $server -> $safe_query");
4024
4025        # Choose the socket class based on what is installed.
4026        # IO::Socket::IP supports both IPv4 and IPv6 WHOIS servers.
4027
53
121
        my $sock_class = $HAS_IO_SOCKET_IP ? 'IO::Socket::IP' : 'IO::Socket::INET';
4028
4029        # Attempt TCP connection to port 43 on the WHOIS server
4030
47
72
        my $sock = eval {
4031                $sock_class->new(
4032                        PeerAddr => $server,
4033                        PeerPort => $WHOIS_PORT,
4034                        Proto    => 'tcp',
4035                        Timeout  => $self->{timeout},
4036
129
533
                );
4037        };
4038
127
4250734
        return unless $sock;
4039
4040        # Send the WHOIS query in wire format (CRLF-terminated per RFC 3912)
4041
184
91
85
665
150
100
        $sock->print("$safe_query\r\n") or do { $sock->close(); return };
4042
4043        # Use IO::Select to implement per-read timeouts without alarm()
4044
125
2398
        my $sel      = IO::Select->new($sock);
4045
131
2560
        my $response = '';
4046
366
394
        my $buf      = '';
4047
4048        # Read until EOF (server closes) or timeout
4049
126
354
        while ($sel->can_read($self->{timeout})) {
4050                # Wrap in eval to catch 'Connection reset by peer' thrown by Fatal/autodie
4051
182
188
4337512
425
                my $n = eval { sysread($sock, $buf, $WHOIS_READ_CHUNK) };
4052
4053
186
10714
                if ($@ || !defined $n || $n <= 0) {
4054
50
131
                        $self->_debug("WHOIS read failed: $@") if $@;
4055
103
168
                        last;
4056                }
4057
268
1052
                last if !defined($n) || $n <= 0;
4058
268
611
                $response .= $buf;
4059        }
4060
4061
46
672
        $sock->close();
4062
46
2605
        return $response || undef;
4063
26
26
26
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
7193
27
213
2162
1
35
2205
1
34
2144
1
32
2199
1
36
0
10
759
1
9
1144
1
11
778
}
4064
4065# _parse_whois_text( $text ) -> hashref
4066#
4067# Purpose:
4068#   Parse a raw WHOIS IP block response to extract organisation name,
4069#   abuse contact email, and country code.
4070#
4071# Entry criteria:
4072#   $text -- a defined WHOIS response string.
4073#
4074# Exit status:
4075#   Returns { org, abuse, country } hashref; keys absent when not found.
4076
4077sub _parse_whois_text :Private {
4078        my ($self, $text) = @_;
4079        return {} unless $text;
4080        my %info;
4081
4082        # Try multiple field names for the organisation name
4083        for my $pat (
4084                qr/^OrgName:\s*(.+)/mi,    qr/^org-name:\s*(.+)/mi,
4085                qr/^owner:\s*(.+)/mi,      qr/^descr:\s*(.+)/mi,
4086        ) {
4087                if (!$info{org} && $text =~ $pat) {
4088                        ($info{org} = $1) =~ s/\s+$//;
4089                }
4090        }
4091
4092        # Try multiple field names for the abuse email
4093        for my $pat (
4094                qr/OrgAbuseEmail:\s*(\S+@\S+)/mi,
4095                qr/abuse-mailbox:\s*(\S+@\S+)/mi,
4096        ) {
4097                if (!$info{abuse} && $text =~ $pat) {
4098                        ($info{abuse} = $1) =~ s/\s+$//;
4099                }
4100        }
4101
4102        # Last-resort: any abuse@ address in the response
4103        if (!$info{abuse} && $text =~ /(abuse\@[\w.-]+)/i) { $info{abuse} = $1 }
4104
4105        # Country code (case-insensitive match, normalised to uppercase)
4106        if ($text =~ /^country:\s*([A-Za-z]{2})\s*$/m) {
4107                $info{country} = uc $1;
4108        }
4109        return \%info;
4110
26
26
26
1
14
14
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
10112
20
236
2
13
25
2
1
15
2
1
13
2
1
13
1
9
755
1
9
989
1
11
727
}
4111
4112# -----------------------------------------------------------------------
4113# Private: authentication results parsing
4114# -----------------------------------------------------------------------
4115
4116# _parse_auth_results_cached() -> hashref
4117#
4118# Purpose:
4119#   Parse the Authentication-Results: header(s) from the message once,
4120#   cache the result, and return it.  Extracts SPF, DKIM, DMARC, ARC
4121#   results and the DKIM signing domain(s).
4122#
4123# Entry criteria:
4124#   $self->{_headers} populated by _split_message().
4125#
4126# Exit status:
4127#   Returns { spf, dkim, dmarc, arc, dkim_domain, dkim_domains } hashref.
4128#   Keys absent when the corresponding header or field is not present.
4129
4130sub _parse_auth_results_cached :Private {
4131        my $self = $_[0];
4132        return $self->{_auth_results} if $self->{_auth_results};
4133
4134        my %auth;
4135
4136        # Concatenate all Authentication-Results: header values
4137        my $raw = join('; ',
4138                map  { $_->{value} }
4139                grep { $_->{name} eq 'authentication-results' }
4140                @{ $self->{_headers} }
4141        );
4142
4143        # Extract individual authentication mechanism results
4144        if ($raw =~ /\bspf=(\S+)/i)   { $auth{spf}   = $1 }
4145        if ($raw =~ /\bdkim=(\S+)/i)  { $auth{dkim}  = $1 }
4146        if ($raw =~ /\bdmarc=(\S+)/i) { $auth{dmarc} = $1 }
4147        if ($raw =~ /\barc=(\S+)/i)   { $auth{arc}   = $1 }
4148
4149        # Strip trailing punctuation captured by the greedy \S+
4150        for my $k (qw(spf dkim dmarc arc)) {
4151                $auth{$k} =~ s/[;,\s]+$// if defined $auth{$k};
4152        }
4153
4154        # Extract DKIM signing domains from all DKIM-Signature: d= tags.
4155        # Prefer the first domain that matches the provider table (identifies ESP).
4156        my @dkim_domains;
4157        for my $h (grep { $_->{name} eq 'dkim-signature' } @{ $self->{_headers} }) {
4158                if ($h->{value} =~ /\bd=([^;,\s]+)/) {
4159                        push @dkim_domains, lc $1;
4160                }
4161        }
4162
4163        if (@dkim_domains) {
4164                # Check if any signing domain matches a known provider
4165                my $preferred;
4166                for my $d (@dkim_domains) {
4167                        if ($self->_provider_abuse_for_host($d)) {
4168                                $preferred = $d;
4169                                last;
4170                        }
4171                }
4172                $auth{dkim_domain}  = $preferred // $dkim_domains[0];
4173                $auth{dkim_domains} = \@dkim_domains;
4174        }
4175
4176        $self->{_auth_results} = \%auth;
4177        return \%auth;
4178
26
26
26
14
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
9350
23
216
16
1
24
1
1
5
2
1
5
2
1
5
1
9
244
1
8
1222
2
11
330
}
4179
4180# -----------------------------------------------------------------------
4181# Private: provider-table lookups
4182# -----------------------------------------------------------------------
4183
4184# _provider_abuse_for_host( $host ) -> hashref | undef
4185#
4186# Purpose:
4187#   Look up a hostname (and each of its parent domains, stripping one label
4188#   at a time from the left) in the %PROVIDER_ABUSE table.
4189#
4190# Entry criteria:
4191#   $host -- a defined hostname or domain string.
4192#
4193# Exit status:
4194#   Returns the %PROVIDER_ABUSE entry hashref on match, undef otherwise.
4195
4196sub _provider_abuse_for_host :Private {
4197        my ($self, $host) = @_;
4198        $host = lc $host;
4199        # Strip successive subdomains until we find a match or exhaust labels
4200        while ($host =~ /\./) {
4201                return $self->{provider_abuse}->{$host} if $self->{provider_abuse}->{$host};
4202                return $PROVIDER_ABUSE{$host} if $PROVIDER_ABUSE{$host};
4203                $host =~ s/^[^.]+\.//;
4204        }
4205        return;
4206
26
26
26
1
14
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
4537
25
201
233
17
0
222
2
1
247
2
1
258
3
1
1
8
1255
1
9
367
1
10
1200
}
4207
4208# _provider_abuse_for_ip( $ip, $rdns ) -> hashref | undef
4209#
4210# Purpose:
4211#   Look up an IP's reverse-DNS hostname in the %PROVIDER_ABUSE table to
4212#   identify well-known provider networks by rDNS pattern.
4213#
4214# Entry criteria:
4215#   $ip   -- IPv4 or IPv6 address string (used as fallback if $rdns absent).
4216#   $rdns -- optional rDNS hostname string.
4217#
4218# Exit status:
4219#   Returns the %PROVIDER_ABUSE entry on match, undef otherwise.
4220
4221sub _provider_abuse_for_ip :Private {
4222        my ($self, $ip, $rdns) = @_;
4223        return $self->_provider_abuse_for_host($rdns) if $rdns;
4224        return;
4225
26
26
26
1
1
14
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
4598
29
189
4
126
15
3
93
1
3
131
1
3
113
1
2
8
1068
1
9
818
1
9
1013
}
4226
4227# -----------------------------------------------------------------------
4228# Private: eTLD+1 normalisation
4229# -----------------------------------------------------------------------
4230
4231# _registrable( $host ) -> string | undef
4232#
4233# Purpose:
4234#   Return the registrable eTLD+1 form of a hostname.  Uses
4235#   Domain::PublicSuffix when installed for accurate results; falls back
4236#   to a built-in heuristic for the common two-letter ccTLD+2 pattern.
4237#
4238# Entry criteria:
4239#   $host -- a hostname string (may include subdomains).
4240#
4241# Exit status:
4242#   Returns the registrable domain string, or undef for single-label
4243#   hostnames (e.g. 'localhost').
4244#
4245# Notes:
4246#   The heuristic handles co.uk, com.au, net.jp, org.nz etc. but not
4247#   uncommon second-level delegations like ltd.uk or plc.uk.
4248
4249sub _registrable :Private {
4250        my $host = $_[0];
4251        return unless $host && $host =~ /\./;
4252
4253        # Use Domain::PublicSuffix for accurate PSL-based normalisation
4254        if ($HAS_PUBLIC_SUFFIX) {
4255                my $psl = Domain::PublicSuffix->new();
4256                my $root = $psl->get_root_domain(lc $host);
4257                return $root if $root;
4258        }
4259
4260        # Built-in heuristic fallback
4261        my @labels = split /\./, lc $host;
4262        return $host if @labels <= 2;
4263
4264        # Detect common ccTLD second-level patterns (e.g. co.uk, com.au)
4265        if ($labels[-1] =~ /^[a-z]{2}$/ &&
4266            $labels[-2] =~ /^(?:co|com|net|org|gov|edu|ac|me)$/) {
4267                return join('.', @labels[-3..-1]);
4268        }
4269        return join('.', @labels[-2..-1]);
4270
26
26
26
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
6357
54
227
4
73
2
3
75
1
3
72
1
4
72
1
1
9
1363
1
8
369
1
9
1269
}
4271
4272# -----------------------------------------------------------------------
4273# Private: utilities
4274# -----------------------------------------------------------------------
4275
4276# _enrich_ip( $ip, $confidence, $note ) -> origin hashref
4277#
4278# Purpose:
4279#   Perform rDNS and WHOIS/RDAP for a single IP and package the results
4280#   into the standard origin hashref returned by originating_ip().
4281#
4282# Entry criteria:
4283#   $ip         -- a defined, non-private IPv4 or IPv6 address string.
4284#   $confidence -- 'high', 'medium', or 'low'.
4285#   $note       -- human-readable explanation of why this IP was chosen.
4286#
4287# Exit status:
4288#   Returns { ip, rdns, org, abuse, country, confidence, note } hashref.
4289
4290sub _enrich_ip :Private {
4291        my ($self, $ip, $confidence, $note) = @_;
4292        my $rdns  = $self->_reverse_dns($ip);
4293        my $whois = $self->_whois_ip($ip);
4294        return {
4295                ip         => $ip,
4296                rdns       => $rdns  // '(no reverse DNS)',
4297                org        => $whois->{org}     // '(unknown)',
4298                abuse      => $whois->{abuse}   // '(unknown)',
4299                country    => $whois->{country} // undef,
4300                confidence => $confidence,
4301                note       => $note,
4302        };
4303
26
26
26
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
5288
95
191
18
2
1
17
1
1
17
2
1
27
3
0
1
11
311
1
9
1231
1
11
268
}
4304
4305# _header_value( $name ) -> value_string | undef
4306#
4307# Purpose:
4308#   Return the value of the first header matching the given lower-cased
4309#   header name.
4310 - 4364
=head2 header_value( $name )

Returns the value of the first occurrence of a named header field, or
C<undef> if the header is absent.  The name comparison is case-insensitive.

=head3 Usage

    my $subj = $analyser->header_value('Subject');
    my $from  = $analyser->header_value('From');
    my $msgid = $analyser->header_value('Message-ID');

=head3 Arguments

=over 4

=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
(C<=?charset?B/Q?...?=>).  Pass the result through C<_decode_mime_words()>
internally if human-readable output is needed.

=head3 API Specification

=head4 Input

    {
        name => { type => 'string', required => 1 },
    }

=head4 Output

    { type => [ 'string', 'undef' ] }

=head3 Messages

None -- returns C<undef> on a missing header, never throws.

=cut
4365
4366sub header_value {
4367
77
1
643
8
        my $self = shift;
4368
4369
77
1
3196
1227
        my $params = Params::Validate::Strict::validate_strict({
4370                args => Params::Get::get_params('name', \@_) || {},
4371                schema => {
4372                        name => {
4373                                'type'     => 'string',
4374                                'optional' => 0,
4375                        }
4376                }
4377        });
4378
4379
77
1
2699
1
        return if((!defined($params)) || !defined($params->{name}));
4380
77
1
117
19
        return if ref($params->{name});
4381
113
1
3387
122
        return $self->_header_value($params->{name});
4382}
4383
4384#
4385# _header_value( $name ) -> string | undef
4386#
4387# Purpose:
4388#   Internal implementation for header_value().  Walks _headers list and
4389#   returns the value of the first matching header.
4390#
4391# Entry criteria:
4392#   $name -- a lower-cased header name string.
4393#   $self->{_headers} populated by _split_message().
4394#
4395# Exit status:
4396#   Returns the value string, or undef if the header is not present.
4397
4398sub _header_value :Private {
4399        my ($self, $name) = @_;
4400        for my $h (@{ $self->{_headers} }) {
4401                return $h->{value} if $h->{name} eq lc($name);
4402        }
4403        return;
4404
26
26
26
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
5231
51
219
15
1
1
15
2
0
16
2
1
14
1
1
1
8
281
1
10
1155
1
9
211
}
4405
4406# _ip_in_cidr( $ip, $cidr ) -> bool
4407#
4408# Purpose:
4409#   Test whether an IPv4 address falls within a CIDR block or is an exact
4410#   match (when $cidr contains no '/' separator).
4411#
4412# Entry criteria:
4413#   $ip   -- a defined dotted-quad IPv4 address string.
4414#   $cidr -- a CIDR string like '10.0.0.0/8' or an exact IP.
4415#
4416# Exit status:
4417#   Returns 1 (true) if the IP is within the CIDR block, 0 otherwise.
4418
4419sub _ip_in_cidr :Private {
4420        my ($self, $ip, $cidr) = @_;
4421        return $ip eq $cidr unless $cidr =~ m{/};
4422        my ($net_addr, $prefix) = split m{/}, $cidr;
4423        return 0 if !defined($prefix) || $prefix !~ /^\d+$/ || $prefix > 32;
4424
4425        # Compute the network mask and compare masked network addresses
4426        my $mask  = ~0 << (32 - $prefix);
4427        my $net_n = unpack 'N', (inet_aton($net_addr) // return 0);
4428        my $ip_n  = unpack 'N', (inet_aton($ip)       // return 0);
4429        return ($ip_n & $mask) == ($net_n & $mask);
4430
26
26
26
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
5289
22
216
8
2
1
7
2
2
8
2
0
9
2
1
1
8
1211
1
8
443
2
8
1417
}
4431
4432# _decode_mime_words( $str ) -> decoded_string
4433#
4434# Purpose:
4435#   Decode MIME encoded-words (=?charset?B/Q?...?=) in a header value
4436#   string for human-readable display in reports.
4437#
4438# Entry criteria:
4439#   $str -- a defined header value string; may be undef.
4440#
4441# Exit status:
4442#   Returns the decoded string, or '' if $str is undef.
4443
4444sub _decode_mime_words :Private {
4445        my ($self, $str) = @_;
4446        return '' unless defined $str;
4447        # Replace each encoded-word with its decoded equivalent
4448        $str =~ s/=\?([^?]+)\?([BbQq])\?([^?]*)\?=/_decode_ew($1,$2,$3)/ge;
4449        return $str;
4450
26
26
26
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
5458
19
205
16
2
93
15
2
11
17
2
12
15
2
12
0
9
556
2
8
890
1
11
498
}
4451
4452# _decode_ew( $charset, $enc, $text ) -> decoded_bytes
4453#
4454# Purpose:
4455#   Decode a single MIME encoded-word component (base64 or quoted-printable).
4456#
4457# Notes:
4458#   Non-UTF-8 charsets return raw bytes; good enough for display-name spoof
4459#   detection which only needs ASCII matching.
4460
4461sub _decode_ew :Private {
4462        my ($charset, $enc, $text) = @_;
4463        my $raw;
4464        if (uc($enc) eq 'B') {
4465                $raw = decode_base64($text);
4466        } else {
4467                # Quoted-printable encoded-word uses underscore for space
4468                $text =~ s/_/ /g;
4469                $raw  = decode_qp($text);
4470        }
4471        return $raw;
4472
26
26
26
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
4428
39
184
16
2
1
41
2
1
12
2
0
15
1
2
1
8
712
1
8
987
1
9
649
}
4473
4474# _parse_date_to_epoch( $str ) -> epoch_int | undef
4475#
4476# Purpose:
4477#   Parse common WHOIS date strings to a Unix epoch integer.
4478#   Handles YYYY-MM-DD, YYYY-MM-DDThh:mm:ssZ, and DD-Mon-YYYY formats.
4479#
4480# Entry criteria:
4481#   $str -- a defined date string; may be undef.
4482#
4483# Exit status:
4484#   Returns epoch integer on success, undef if the string cannot be parsed.
4485
4486sub _parse_date_to_epoch :Private {
4487        my ($self, $str) = @_;
4488        return unless $str;
4489
4490        # Clean the string of trailing whitespace/newlines
4491        $str =~ s/^\s+|\s+$//g;
4492
4493        # Guard Regex: Validates the strict YYYY-MM-DDThh:mm:ssZ format
4494        if ($str =~ /^(\d{4}-\d{2}-\d{2}T\d{2}:\d{2}:\d{2})(?:\.\d+)?Z$/) {
4495                # Parse the string
4496                # We use 'strptime' to create a Time::Piece object.
4497                # The 'Z' indicates UTC (Zulu time).
4498                my $epoch = eval {
4499                        my $t = Time::Piece->strptime($1, '%Y-%m-%dT%H:%M:%S');
4500
4501                        # Return seconds since the epoch
4502                        # Time::Piece handles the timezone offset internally when calling ->epoch
4503
4504                        # strptime returns a local time object.
4505                        # We must subtract the local timezone offset to get the true UTC epoch.
4506                        return $t->epoch - $t->tzoffset->seconds;
4507                };
4508                return $epoch if defined $epoch;
4509        }
4510        my ($y, $m, $d);
4511
4512        if    ($str =~ /^(\d{4})-(\d{2})-(\d{2})/)         { ($y,$m,$d)=($1,$2,$3) }
4513        elsif ($str =~ /^(\d{2})-([A-Za-z]{3})-(\d{4})/)   { ($d,$m,$y)=($1,$Readonly::Values::Months::months{lc$2}//0,$3) }
4514        elsif ($str =~ /^(\d{2})\/(\d{2})\/(\d{4})/)        { ($m,$d,$y)=($1,$2,$3) }
4515
4516        return unless $y && $m && $d;
4517
4518        if (eval { require Time::Local; 1 }) {
4519                return eval { Time::Local::timegm(0,0,0,$d,$m-1,$y-1900) };
4520        }
4521        # Approximate fallback without Time::Local
4522        return ($y-1970)*365.25*$SECS_PER_DAY + ($m-1)*30.5*$SECS_PER_DAY + ($d-1)*$SECS_PER_DAY;
4523
26
26
26
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
9493
24
210
15
2
1
19
2
1
16
1
1
13
3
1
1
10
296
1
9
1211
1
10
367
}
4524
4525# _parse_rfc2822_date( $str ) -> epoch_int | undef
4526#
4527# Purpose:
4528#   Parse an RFC 2822 Date: header value to a Unix epoch integer.
4529#   Timezone offsets are intentionally ignored; the function returns a
4530#   UTC-equivalent value.  For the 7-day suspicious_date window the
4531#   maximum error is ~14 hours, well within the tolerance.
4532#
4533# Entry criteria:
4534#   $str -- a defined Date: header value string.
4535#
4536# Exit status:
4537#   Returns epoch integer on success, undef if the string cannot be parsed.
4538
4539sub _parse_rfc2822_date :Private {
4540        my $str = $_[0];
4541        return unless $str;
4542
4543        # Match: DD Mon YYYY HH:MM:SS (timezone offset ignored)
4544        if ($str =~ /(\d{1,2})\s+([A-Za-z]{3})\s+(\d{4})\s+(\d{2}):(\d{2}):(\d{2})/) {
4545                my ($d, $m, $y, $H, $M, $S) =
4546                        ($1, $Readonly::Values::Months::months{ lc $2 } // 0, $3, $4, $5, $6);
4547                return unless $m;
4548                if (eval { require Time::Local; 1 }) {
4549                        return eval { Time::Local::timegm($S, $M, $H, $d, $m - 1, $y - 1900) };
4550                }
4551        }
4552        return;
4553
26
26
26
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
6469
23
199
58
2
1
62
3
0
62
2
1
64
3
1
2
9
315
1
9
1342
1
9
353
}
4554
4555# _country_name( $cc ) -> country_name_string
4556#
4557# Purpose:
4558#   Return a human-readable country name for a two-letter ISO 3166-1
4559#   alpha-2 country code.  Only the small set of statistically high-volume
4560#   spam-originating countries is covered; other codes are returned as-is.
4561#
4562# Entry criteria:
4563#   $cc -- a two-letter uppercase country code string.
4564#
4565# Exit status:
4566#   Returns the country name string, or the code itself if not in the table.
4567
4568sub _country_name :Private {
4569        my $cc = $_[0];
4570        my %names = (
4571                CN => 'China',       RU => 'Russia',    NG => 'Nigeria',
4572                VN => 'Vietnam',     IN => 'India',      PK => 'Pakistan',
4573                BD => 'Bangladesh',
4574        );
4575        return $names{$cc} // $cc;
4576
26
26
26
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
3782
24
196
15
2
1
17
2
1
15
1
1
23
2
1
1
8
253
1
10
1140
1
8
357
}
4577
4578# _debug( $msg )
4579#
4580# Purpose:
4581#   Write a diagnostic message to STDERR when verbose mode is enabled.
4582#
4583# Entry criteria:
4584#   $msg -- a defined message string.
4585#
4586# Notes:
4587#   Messages are prefixed with the class name for easy grepping.
4588
4589sub _debug :Private {
4590        my ($self, $msg) = @_;
4591
4592        if($self->{verbose}) {
4593                if (my $logger = $self->{logger}) { # Set via Object::Configure
4594                        $logger->debug("[Email::Abuse::Investigator] $msg");
4595                } else {
4596                        print STDERR "[Email::Abuse::Investigator] $msg\n";
4597                }
4598        }
4599
26
26
26
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
4277
21
186
5
103
5
4
108
4
4
103
4
3
110
4
1
8
2014
1
9
1025
1
8
}
4600
46011;
4602