File Coverage

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

linestmtbrancondsubtimecode
1package Email::Abuse::Investigator;
2
3
22
22
22
11
64
133
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
787262
21
323
19
94
820
3
0
22
2
1
18
2
1
37
1356
1
9
2430
2
13
1465
2
13
912
1
12
use strict;
4
22
22
22
133
34
6
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
39
19
556
122
56
22
2
2
4
2
1
3
1
2
4
495
2
10
1329
1
10
561
2
10
1610
2
13
use warnings;
5
22
22
22
3
20
15
1
1
0
1
1
0
1
1
0
1
1
1
1
1
1
1
1
1
1
1
1
3660
117283
55
359
34
25
102
5
0
114
5
0
120
6
0
1318
1
13
1431
1
9
1372
1
13
862
2
12
use autodie qw(:all);
6
7
22
22
22
18
18
22
1
1
0
1
1
0
1
1
0
1
1
1
1
1
1
1
1
1
139776
28
585
1318
29
30
352
5
0
442
5
0
460
5
0
153
1
18
2554
1
14
1246
1
18
use Carp qw(croak carp);
8
22
22
22
25
25
104
1
1
0
1
1
0
1
1
0
1
1
1
1
1
1
1
1
1
3461
12744
487
1118
50
81
291
4
0
312
4
0
351
4
0
2
0
33
2
1
31
2
1
34
use IO::Select;
9
22
22
22
107
75
75
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
2556
117792
136
1050
55
61
312
2
2
309
2
1
285
2
1
2
1
4
2
1
4
3
1
3
use IO::Socket::INET;
10
22
30
1
1
1
1
1
1
5692
47
1
1
2
2210
2191
2222
BEGIN { $Sub::Private::config{mode} = 'enforce' }
11
22
22
22
390
73
76
1
0
1
1
0
1
1
0
1
1
1
1
1
1
1
1
1
1
4108
640318
97
333
67
1056
4
0
271
4
0
276
3
0
305
2
34
2
1
36
2
1
86
4
use Sub::Private;
12
22
22
22
12
76
8
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
6342
71300
94
21
69
11
2
1
1
1
2
1
2
2
1
0
17
3
1
16
1
1
18
2
use Sub::Protected;
13
22
22
22
76
3
76
1
0
1
1
0
1
1
0
1
1
1
1
1
1
1
1
1
1
5055
5113
577
71
5
993
3
0
804
3
0
264
3
0
273
1
5
230
1
6
216
0
6
235
use MIME::QuotedPrint qw( decode_qp );
14
22
22
22
4
73
292
1
0
1
1
0
1
1
0
1
1
1
1
1
1
1
1
1
1
65
24
325
16
62
18843
5
0
6086
4
0
5055
4
0
6282
2
2
3
2
1
3
7
2
5
use MIME::Base64 qw( decode_base64 );
15
22
22
22
76
76
376
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
4844
552786
405
50
129
5650
1
22
1137
2
27
1705
1
26
1547
117
1
6
133
1
4
131
1
4
use Object::Configure;
16
22
22
22
106
5
5
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
73
35
451
137
64
3572
1
14
2415
1
16
731
1
21
2980
71
1
30
74
2
20
74
1
23
use Params::Get;
17
22
22
22
104
4
4
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
48
232
314
102
52
4661
1
14
2542
1
16
1020
2
20
2958
3
1
14
2
1
13
2
2
13
use Params::Validate::Strict 0.34;
18
22
22
22
4
4
4
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
57
25
383
9
49
4387
1
12
1181
1
17
1815
1
19
860
1
1
8
2
0
11
1
2
11
use Readonly;
19
22
22
22
18
18
75
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
3651
11332
1772
25
178
11412
2
13
3956
1
16
3521
3
16
2988
3
1
16
1
1
17
1
1
23
use Readonly::Values::Months;
20
22
22
22
75
39
43
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
63
20
539
93
74
12858
1
14
3684
1
11
2796
1
16
4135
2
11
13
2
12
16
2
12
16
use Socket qw( inet_aton inet_ntoa AF_INET );
21
22
22
22
43
54
74
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
3760
71549
92
45
103
4790
1
13
2057
1
10
1130
3
16
2054
2
1
15
2
1
15
1
1
18
use Time::Piece;
22
23 - 32
=head1 NAME

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

=head1 VERSION

Version 0.12

=cut
33
34our $VERSION = '0.12';
35
36 - 99
=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
100
101# -----------------------------------------------------------------------
102# Optional modules -- gracefully degraded when absent
103# -----------------------------------------------------------------------
104
105# Net::DNS enables MX, NS, AAAA lookups; falls back to gethostbyname
106my $HAS_NET_DNS;
107
108# LWP::UserAgent enables RDAP queries; falls back to raw WHOIS
109my $HAS_LWP;
110my $HAS_CONN_CACHE;
111
112# HTML::LinkExtor enables structural HTML link extraction
113my $HAS_HTML_LINKEXTOR;
114
115# CHI enables a persistent cross-message cache for IP/domain data
116my $HAS_CHI;
117
118# IO::Socket::IP provides dual-stack (IPv4+IPv6) socket support
119my $HAS_IO_SOCKET_IP;
120
121# Domain::PublicSuffix enables accurate eTLD+1 normalisation
122my $HAS_PUBLIC_SUFFIX;
123
124# AnyEvent::DNS enables parallel DNS queries
125my $HAS_ANYEVENT_DNS;
126
127BEGIN {
128
22
22
0
54
39
16
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
6057
1159
0
98
67
5031
1
13
1426
2
13
981
1
12
1540
2
4
65
1
1
70
1
1
69
        $HAS_NET_DNS       = eval { require Net::DNS;           1 };
129
22
22
0
16
3
6
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
7145
969
0
26
42
3979
2
13
759
2
10
1544
1
14
545
3
0
46
2
1
17
2
1
18
        $HAS_LWP           = eval { require LWP::UserAgent;     1 };
130
22
22
0
6
6
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
5498
917
0
11
43
4950
1
12
1425
2
13
890
1
13
1227
2
1
4
3
1
3
2
1
3
        $HAS_CONN_CACHE    = eval { require LWP::ConnCache;     1 };
131
22
22
22
3
3
6
1
1
1
1
1
1
1
1
1
1
1
0
1
1
0
1
1
0
4899
3813
69631
5
75
3147
2
16
950
2
10
1097
1
14
1064
109
6
0
132
4
0
115
6
0
        $HAS_HTML_LINKEXTOR= eval { require HTML::LinkExtor;    1 };
132
22
22
0
6
3
3
1
1
1
1
1
1
1
1
1
1
1
0
1
1
0
1
1
0
23
1065
0
13
39
3781
2
13
529
1
18
1481
1
13
796
409
5
0
834
5
0
446
5
0
        $HAS_CHI           = eval { require CHI;                1 };
133
22
22
22
3
5
5
1
1
1
1
1
1
1
1
1
1
1
0
1
1
0
1
1
0
5228
3284
37982
4
43
3473
2
11
1137
1
9
1134
2
13
884
302
4
0
738
4
0
313
4
0
        $HAS_IO_SOCKET_IP  = eval { require IO::Socket::IP;     1 };
134
22
22
0
5
5
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
0
1
1
1
26
1032
0
10
57
5247
1
12
968
2
8
2034
1
12
928
304
2
1
730
5
0
275
1
1
        $HAS_PUBLIC_SUFFIX = eval { require Domain::PublicSuffix; 1 };
135
22
22
0
3
3
3
1
1
1
1
1
1
1
1
1
1
1
0
1
1
0
1
1
0
4959
5485
0
7
39
3849
2
12
1106
1
14
1144
1
11
1367
1
4
0
678
4
0
2
4
0
        $HAS_ANYEVENT_DNS  = eval { require AnyEvent::DNS;      1 };
136}
137
138# -----------------------------------------------------------------------
139# Constants -- all magic numbers and strings live here
140# -----------------------------------------------------------------------
141
142# WHOIS protocol port (IANA-assigned)
143Readonly::Scalar my $WHOIS_PORT        => 43;
144
145# Bytes to read per sysread() call from a WHOIS socket
146Readonly::Scalar my $WHOIS_READ_CHUNK  => 4096;
147
148# Maximum WHOIS response bytes stored in whois_raw (keep reports compact)
149Readonly::Scalar my $WHOIS_RAW_MAX     => 2048;
150
151# Maximum multipart nesting depth (recursion guard -- RFC 2046 has no limit
152# but we cap it to prevent stack exhaustion on crafted messages)
153Readonly::Scalar my $MAX_MULTIPART_DEPTH => 20;
154
155# Number of days before registration that triggers recently_registered flag
156Readonly::Scalar my $RECENT_REG_DAYS   => 180;
157
158# Number of days ahead of expiry that triggers domain_expires_soon flag
159Readonly::Scalar my $EXPIRY_WARN_DAYS  => 30;
160
161# Seconds in a day -- used in date arithmetic throughout
162Readonly::Scalar my $SECS_PER_DAY      => 86400;
163
164# Suspicious date window: dates outside +/- 7 days raise a flag
165Readonly::Scalar my $DATE_SKEW_DAYS    => 7;
166
167# Maximum positive timezone offset in minutes (+14:00 = Line Islands)
168Readonly::Scalar my $TZ_MAX_POS_MINS   => 840;
169
170# Maximum negative timezone offset in minutes (-12:00 = Baker Island)
171Readonly::Scalar my $TZ_MAX_NEG_MINS   => 720;
172
173# High-risk score threshold
174Readonly::Scalar my $SCORE_HIGH        => 9;
175
176# Medium-risk score threshold
177Readonly::Scalar my $SCORE_MEDIUM      => 5;
178
179# Low-risk score threshold
180Readonly::Scalar my $SCORE_LOW         => 2;
181
182# Flag severity weights (contribute to the numeric risk score)
183Readonly::Hash my %FLAG_WEIGHT => (
184        HIGH   => 3,
185        MEDIUM => 2,
186        LOW    => 1,
187        INFO   => 0,
188);
189
190# Maximum merged-role display string length before summarisation kicks in
191Readonly::Scalar my $ROLE_MAX_LEN      => 80;
192
193# CHI cache TTL in seconds (1 hour -- IP allocations change slowly)
194Readonly::Scalar my $CACHE_TTL_SECS    => 3600;
195
196# Default constructor timeout for network operations (seconds)
197Readonly::Scalar my $DEFAULT_TIMEOUT   => 10;
198
199# Maximum role string length before truncation
200Readonly::Scalar my $ROLE_WRAP_LEN     => 66;
201
202# Maximum redirect hops to follow when resolving shortener/redirect-cloaker URLs
203Readonly::Scalar my $REDIRECT_MAX_HOPS => 3;
204
205# Brand names checked in lookalike-domain detection.
206# Overridable at runtime via Object::Configure.
207Readonly::Array my @LOOKALIKE_BRANDS => qw(
208        paypal apple google amazon microsoft netflix ebay
209        instagram facebook twitter linkedin bankofamerica
210        wellsfargo chase barclays hsbc lloyds santander
211);
212
213# -----------------------------------------------------------------------
214# Private ranges -- IPs that are never actionable abuse targets
215# -----------------------------------------------------------------------
216
217# Both IPv4 and IPv6 private/reserved ranges.  Each entry is a compiled
218# regex; _is_private() iterates over them and returns true on first match.
219my @PRIVATE_RANGES = (
220        # IPv4 ranges
221        qr/^0\./,                         # 0.0.0.0/8  this-network (RFC 1122)
222        qr/^127\./,                       # 127.0.0.0/8 loopback
223        qr/^10\./,                        # 10.0.0.0/8  RFC 1918
224        qr/^192\.168\./,                  # 192.168.0.0/16 RFC 1918
225        qr/^172\.(?:1[6-9]|2\d|3[01])\./, # 172.16.0.0/12  RFC 1918
226        qr/^169\.254\./,                  # 169.254.0.0/16 link-local
227        qr/^100\.(?:6[4-9]|[7-9]\d|1(?:[01]\d|2[0-7]))\./,  # 100.64.0.0/10 CGN (RFC 6598)
228        qr/^192\.0\.0\./,                 # 192.0.0.0/24  IETF protocol (RFC 6890)
229        qr/^192\.0\.2\./,                 # 192.0.2.0/24  TEST-NET-1 (RFC 5737)
230        qr/^198\.51\.100\./,              # 198.51.100.0/24 TEST-NET-2 (RFC 5737)
231        qr/^203\.0\.113\./,               # 203.0.113.0/24 TEST-NET-3 (RFC 5737)
232        qr/^255\./,                       # 255.0.0.0/8 broadcast
233        # IPv6 ranges
234        qr/^::1$/,                         # IPv6 loopback
235        qr/^fe80:/i,                       # IPv6 link-local (fe80::/10)
236        qr/^fc/i,                          # IPv6 ULA fc00::/7
237        qr/^fd/i,                          # IPv6 ULA fd00::/8
238        qr/^2001:db8:/i,                   # IPv6 documentation range (RFC 3849)
239        qr/^64:ff9b:/i,                    # IPv6 NAT64 well-known prefix
240);
241
242# Priority-ordered patterns for extracting IPs from Received: headers.
243# Covers bracketed IPv4, bracketed IPv6, parenthesised address, and bare dotted-quad.
244my @RECEIVED_IP_RE = (
245        qr/\[\s*([\d.]+)\s*\]/,                          # [1.2.3.4]
246        qr/\[\s*([0-9a-fA-F:]+)\s*\]/,                  # [IPv6 address]
247        qr/\(\s*[\w.-]*\s*\[?\s*([\d.]+)\s*\]?\s*\)/,   # (hostname [1.2.3.4])
248        qr/from\s+[\w.-]+\s+([\d.]+)/,                  # from hostname addr
249        qr/([\d]{1,3}\.[\d]{1,3}\.[\d]{1,3}\.[\d]{1,3})/, # bare dotted-quad fallback
250);
251
252# -----------------------------------------------------------------------
253# Default configuration -- overridable via Object::Configure
254# -----------------------------------------------------------------------
255
256# Object::Configure may overlay
257# values from a file before new() uses them.  Use Readonly for constants
258# that should never be overridden at runtime.
259
260# -----------------------------------------------------------------------
261# Trusted domains (infrastructure -- never report these as abuse targets)
262# Can be overrideen at runtime by Object::Configure
263# -----------------------------------------------------------------------
264
265my %TRUSTED_DOMAINS = map { $_ => 1 } qw(
266        gmail.com googlemail.com yahoo.com outlook.com hotmail.com
267        google.com microsoft.com apple.com amazon.com
268        googlegroups.com groups.google.com
269        fonts.googleapis.com fonts.gstatic.com
270        ajax.googleapis.com maps.googleapis.com
271        w3.org
272        fedex.com ups.com dhl.com usps.com royalmail.com
273);
274
275# -----------------------------------------------------------------------
276# URL shortener domains (real destination is hidden behind these)
277# -----------------------------------------------------------------------
278
279my %URL_SHORTENERS = map { $_ => 1 } qw(
280        bit.ly      bitly.com   tinyurl.com  t.co        ow.ly
281        goo.gl      is.gd       buff.ly      ift.tt       dlvr.it
282        short.link  rebrand.ly  tiny.cc      cutt.ly      rb.gy
283        shorturl.at bl.ink      smarturl.it  yourls.org   clicky.me
284        snip.ly     adf.ly      bc.vc        lnkd.in      fb.me
285        youtu.be
286);
287
288# Cloud object-stores and CDN hosting paths commonly abused to serve redirect
289# pages that hide the real phishing destination (same evasion as a URL shortener
290# but using legitimate cloud infrastructure to pass spam filters).
291# Exact-match hosts; suffix patterns are in @REDIRECT_HOST_SUFFIXES below.
292my %REDIRECT_HOSTS = map { $_ => 1 } qw(
293        storage.googleapis.com
294        blob.core.windows.net
295        pages.dev
296        firebaseapp.com
297        web.app
298);
299
300# Subdomain-suffix patterns for bucket-style hosting (e.g. mybucket.s3.amazonaws.com).
301# Checked by _is_redirect_cloaker() using a suffix match against the bare hostname.
302Readonly::Array my @REDIRECT_HOST_SUFFIXES => qw(
303        .s3.amazonaws.com
304        .s3-website.amazonaws.com
305        .cloudfront.net
306        .github.io
307        .firebaseapp.com
308        .web.app
309);
310
311# -----------------------------------------------------------------------
312# Well-known provider abuse contacts
313# Can be overrideen at runtime by Object::Configure
314# -----------------------------------------------------------------------
315
316# Curated table of provider abuse contacts.  Entries with only a 'form'
317# key (no 'email') require web-form submission; abuse_contacts() suppresses
318# email addresses for those providers and form_contacts() surfaces them.
319my %PROVIDER_ABUSE = (
320        # Google / Gmail
321        'google.com'        => { email => 'abuse@google.com',      note => 'Also report Gmail accounts via https://support.google.com/mail/contact/abuse' },
322        'gmail.com'         => { email => 'abuse@google.com',      note => 'Report Gmail spam via https://support.google.com/mail/contact/abuse' },
323        'googlemail.com'    => { email => 'abuse@google.com',      note => 'Report via https://support.google.com/mail/contact/abuse' },
324        '1e100.net'         => { email => 'abuse@google.com',      note => 'Google infrastructure' },
325        'blogspot.com'      => { email => 'abuse@google.com',      note => 'Blogger/Blogspot -- report via https://support.google.com/blogger/answer/76315' },
326        'blogger.com'       => { email => 'abuse@google.com',      note => 'Blogger platform abuse' },
327        'sites.google.com'        => { email => 'abuse@google.com',               note => 'Google Sites hosted content' },
328        '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' },
329        # Microsoft
330        'microsoft.com'     => { email => 'abuse@microsoft.com',   note => 'Also report via https://www.microsoft.com/en-us/wdsi/support/report-unsafe-site' },
331        'outlook.com'       => { email => 'abuse@microsoft.com',   note => 'Report Outlook spam: https://support.microsoft.com/en-us/office/report-phishing' },
332        'hotmail.com'       => { email => 'abuse@microsoft.com',   note => 'Report via https://support.microsoft.com/en-us/office/report-phishing' },
333        'live.com'          => { email => 'abuse@microsoft.com',   note => 'Microsoft consumer mail' },
334        'office365.com'     => { email => 'abuse@microsoft.com',   note => 'Microsoft 365 infrastructure' },
335        'protection.outlook.com' => { email => 'abuse@microsoft.com', note => 'Microsoft EOP gateway' },
336        # Yahoo
337        'yahoo.com'         => { email => 'abuse@yahoo-inc.com',   note => 'Also use https://io.help.yahoo.com/contact/index' },
338        'yahoo.co.uk'       => { email => 'abuse@yahoo-inc.com',   note => 'Yahoo UK' },
339        # Apple
340        'apple.com'         => { email => 'reportphishing@apple.com', note => 'iCloud / Apple Mail abuse' },
341        'icloud.com'        => { email => 'reportphishing@apple.com', note => 'iCloud abuse' },
342        'me.com'            => { email => 'reportphishing@apple.com', note => 'Apple legacy mail' },
343        # Amazon / AWS
344        'amazon.com'        => { email => 'abuse@amazonaws.com',   note => 'Also https://aws.amazon.com/forms/report-abuse' },
345        'amazonaws.com'     => { email => 'abuse@amazonaws.com',   note => 'AWS abuse form: https://aws.amazon.com/forms/report-abuse' },
346        'amazonses.com'     => { email => 'abuse@amazonaws.com',   note => 'Amazon SES sending infrastructure' },
347        # Cloudflare
348        'cloudflare.com'    => { email => 'abuse@cloudflare.com',  note => 'Report via https://www.cloudflare.com/abuse/' },
349        # Fastly / Akamai
350        'fastly.net'        => { email => 'abuse@fastly.com',      note => 'Fastly CDN' },
351        'akamai.com'        => { email => 'abuse@akamai.com',      note => 'Akamai CDN' },
352        'akamaitechnologies.com' => { email => 'abuse@akamai.com', note => 'Akamai CDN' },
353        # Namecheap
354        'namecheap.com'     => { email => 'abuse@namecheap.com',   note => 'Registrar abuse' },
355        # GoDaddy -- web form only; email bounces
356        'godaddy.com'       => {
357                form        => 'https://supportcenter.godaddy.com/AbuseReport',
358                form_paste  => 'Select the abuse type (spam, phishing, malware etc). '
359                             . 'Enter the domain name in the Domain field. '
360                             . 'Paste the originating IP, risk flags, and the relevant '
361                             . 'Received: headers from the report below.',
362                form_upload => 'Take a screenshot of the report as a .png or .jpg, '
363                             . 'or export it as a .pdf.',
364                note        => 'Registrar/host -- email reports not monitored, use web form',
365        },
366        # SendGrid / Twilio
367        'sendgrid.net'      => { email => 'abuse@sendgrid.com',    note => 'ESP -- include full headers' },
368        'sendgrid.com'      => { email => 'abuse@sendgrid.com',    note => 'ESP -- include full headers' },
369        # Mailchimp / Mandrill
370        'mailchimp.com'     => { email => 'abuse@mailchimp.com',   note => 'ESP abuse' },
371        'mandrillapp.com'   => { email => 'abuse@mailchimp.com',   note => 'Mandrill transactional ESP' },
372        # OVH
373        'ovh.net'           => { email => 'abuse@ovh.net',         note => 'OVH hosting' },
374        'ovh.com'           => { email => 'abuse@ovh.com',         note => 'OVH hosting' },
375        # Hetzner
376        'hetzner.com'       => { email => 'abuse@hetzner.com',     note => 'Hetzner hosting' },
377        # Digital Ocean
378        'digitalocean.com'  => { email => 'abuse@digitalocean.com',note => 'DO abuse form: https://www.digitalocean.com/company/contact/#abuse' },
379        # Linode / Akamai
380        'linode.com'        => { email => 'abuse@linode.com',      note => 'Linode/Akamai Cloud' },
381        # Constant Contact
382        'constantcontact.com' => { email => 'abuse@constantcontact.com', note => 'ESP abuse' },
383        'r.constantcontact.com' => { email => 'abuse@constantcontact.com', note => 'Constant Contact sending infrastructure' },
384        # HubSpot
385        'hubspot.com'         => { email => 'abuse@hubspot.com',       note => 'ESP abuse' },
386        'hs-analytics.net'    => { email => 'abuse@hubspot.com',       note => 'HubSpot analytics infrastructure' },
387        # Campaign Monitor
388        'createsend.com'      => { email => 'abuse@campaignmonitor.com', note => 'Campaign Monitor ESP' },
389        'cmail20.com'         => { email => 'abuse@campaignmonitor.com', note => 'Campaign Monitor sending infrastructure' },
390        # Klaviyo
391        'klaviyo.com'         => { email => 'abuse@klaviyo.com',       note => 'ESP abuse' },
392        # Brevo (formerly Sendinblue)
393        'sendinblue.com'      => { email => 'abuse@sendinblue.com',    note => 'ESP abuse' },
394        'brevo.com'           => { email => 'abuse@brevo.com',         note => 'ESP abuse' },
395        # Mailgun
396        'mailgun.com'         => { email => 'abuse@mailgun.com',       note => 'ESP abuse' },
397        'mailgun.org'         => { email => 'abuse@mailgun.com',       note => 'Mailgun sending infrastructure' },
398        # Postmark
399        'postmarkapp.com'     => { email => 'abuse@postmarkapp.com',   note => 'ESP abuse' },
400        # WordPress.com
401        'wordpress.com'       => { email => 'abuse@wordpress.com',     note => 'WordPress.com hosted blog -- report via https://en.wordpress.com/abuse/' },
402        'wp.com'              => { email => 'abuse@wordpress.com',     note => 'WordPress.com short domain' },
403        # Substack
404        'substack.com'        => { email => 'abuse@substack.com',      note => 'Substack newsletter platform abuse' },
405        # ActiveCampaign
406        'activecampaign.com'  => { email => 'abuse@activecampaign.com', note => 'ActiveCampaign ESP' },
407        'ac-tinker.com'       => { email => 'abuse@activecampaign.com', note => 'ActiveCampaign tracking infrastructure' },
408        # Salesforce Marketing Cloud
409        'salesforce.com'      => { email => 'abuse@salesforce.com',    note => 'Salesforce Marketing Cloud / ExactTarget ESP' },
410        'mc.salesforce.com'   => { email => 'abuse@salesforce.com',    note => 'Salesforce Marketing Cloud sending infrastructure' },
411        'exacttarget.com'     => { email => 'abuse@salesforce.com',    note => 'ExactTarget / Salesforce Marketing Cloud ESP' },
412        'et.exacttarget.com'  => { email => 'abuse@salesforce.com',    note => 'ExactTarget sending infrastructure' },
413        # Vultr
414        'vultr.com'           => { email => 'abuse@vultr.com',         note => 'Vultr hosting' },
415        # Contabo
416        'contabo.com'         => { email => 'abuse@contabo.com',       note => 'Contabo hosting' },
417        # Leaseweb
418        'leaseweb.com'        => { email => 'abuse@leaseweb.com',      note => 'Leaseweb hosting' },
419        # M247
420        'm247.com'            => { email => 'abuse@m247.com',          note => 'M247 hosting' },
421        # MarkMonitor -- web form only
422        'markmonitor.com'       => {
423                form        => 'https://corp.markmonitor.com/domain/ui/abuse-report',
424                form_paste  => 'Complete all fields including the domain name and your '
425                             . 'description of the abuse.  Paste the originating IP, '
426                             . 'risk flags, and the relevant Received: headers from the '
427                             . 'report below.',
428                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.',
429                note        => 'Brand-protection registrar -- email reports not processed',
430        },
431        # URL shortener operators
432        'is.gd'             => { email => 'abuse@is.gd',           note => 'URL shortener -- report via https://is.gd/contact.php' },
433        'bitly.com'         => { email => 'abuse@bitly.com',        note => 'URL shortener abuse' },
434        'bit.ly'            => { email => 'abuse@bitly.com',        note => 'URL shortener abuse' },
435        'tinyurl.com'       => { email => 'abuse@tinyurl.com',      note => 'URL shortener abuse' },
436        'ow.ly'             => { email => 'abuse@hootsuite.com',    note => 'Hootsuite URL shortener' },
437        'buff.ly'           => { email => 'abuse@buffer.com',       note => 'Buffer URL shortener' },
438        'rb.gy'             => { email => 'abuse@rb.gy',            note => 'URL shortener abuse' },
439        'cutt.ly'           => { email => 'abuse@cutt.ly',          note => 'URL shortener abuse' },
440        'shorturl.at'       => { email => 'abuse@shorturl.at',      note => 'URL shortener abuse' },
441        # Dynadot -- web form only
442        'dynadot.com'           => {
443                form        => 'https://www.dynadot.com/report-abuse',
444                form_paste  => 'Complete all fields including the domain name and your '
445                             . 'description of the abuse.  Paste the originating IP, '
446                             . 'risk flags, and the relevant Received: headers from the '
447                             . 'report below.',
448                form_upload => 'Take a screenshot of the report as a .png or .jpg, '
449                             . 'or export it as a .pdf.',
450                note        => 'Registrar -- email reports not monitored, use web form',
451        },
452        # Global Domain Group -- web form only
453        'globaldomaingroup.com' => {
454                form        => 'https://globaldomaingroup.com/report-abuse',
455                form_paste  => 'Complete all fields including the domain name and your '
456                             . 'description of the abuse.  Paste the originating IP, '
457                             . 'risk flags, and the relevant Received: headers from the '
458                             . 'report below.',
459                form_upload => 'Attach the original spam message as an .eml file.',
460                note        => 'Registrar -- email reports explicitly not accepted',
461        },
462        # TPG / Internode (Australia)
463        'tpgi.com.au'       => { email => 'abuse@tpg.com.au',      note => 'TPG Telecom Australia' },
464        'tpg.com.au'        => { email => 'abuse@tpg.com.au',      note => 'TPG Telecom Australia' },
465        'internode.on.net'  => { email => 'abuse@internode.on.net',note => 'Internode Australia' },
466);
467
468# -----------------------------------------------------------------------
469# Constructor
470# -----------------------------------------------------------------------
471
472 - 591
=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
592
593# Class-level cross-message CHI cache (shared across all instances).
594# Populated lazily on first call to new() when CHI is available.
595my $_cache;
596
597sub new {
598
2848
1
1856093
14
        my $class = shift;
599
600        # Accept hash or hashref arguments uniformly
601
2848
1
5697
1
        my $params = Params::Validate::Strict::validate_strict({
602                args => Params::Get::get_params(undef, \@_) || {},
603                schema => {
604                        timeout => {
605                                'type'     => 'integer',
606                                'optional' => 1,
607                                'min'      => 0,
608                        },
609                        trusted_relays => {
610                                'type'         => 'arrayref',
611                                'element_type' => 'string',
612                                'optional'     => 1,
613                        },
614                        verbose => {
615                                'type'     => 'boolean',
616                                'optional' => 1,
617                        },
618                },
619        });
620
621        # Merge in any file-based configuration via Object::Configure
622
1870
1
210771
23
        $params = Object::Configure::configure($class, $params);
623
624        # Initialise the cross-message CHI cache on first construction
625
1870
1
3458696
2
        if ($HAS_CHI && !$_cache) {
626
3
1
3
2
                $_cache = CHI->new(
627                        driver     => 'Memory',
628                        global     => 1,
629                        expires_in => $CACHE_TTL_SECS,
630                );
631        }
632
633        # Build and bless the object with default slot values
634        return bless {
635                timeout        => $DEFAULT_TIMEOUT,
636                trusted_relays => [],
637                verbose        => 0,
638                _raw           => '',
639                _headers       => [],
640                _body_plain    => '',
641                _body_html     => '',
642                _received      => [],
643                _origin        => undef,
644                _urls          => undef,     # lazy-computed by embedded_urls()
645                _mailto_domains=> undef,     # lazy-computed by mailto_domains()
646                _contacts      => undef,     # lazy-computed by abuse_contacts()
647                _domain_info   => {},        # per-message domain analysis cache
648                _sending_sw    => [],        # X-Mailer / X-PHP-Originating-Script etc.
649                _rcvd_tracking => [],        # per-hop tracking IDs from Received: headers
650
1870
1870
1
1
3621
13140
4
140
                %{$params},  # Overlay Object::Configure and caller-supplied values
651        }, $class;
652}
653
654# -----------------------------------------------------------------------
655# Public: parse
656# -----------------------------------------------------------------------
657
658 - 734
=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
735
736# TODO: Allow a Mail::Message object to be passed in
737sub parse_email {
738
673
1
67015
6
        my $self = shift;
739
740        # Accept both positional string and named 'text' argument
741
673
0
1046
0
        my $args = Params::Get::get_params('text', \@_);
742
672
1
13652
455
        my $text = $args->{text};
743
744        # Dereference a scalar-ref in a single clean pass
745
672
1
971
5
        $text = $$text if ref($text) eq 'SCALAR';
746
747        # Any other reference type is a programming error
748
672
0
1048
0
        Carp::croak(__PACKAGE__ . ': parse_email() requires a string or scalar reference') if ref($text);
749
750        # Sanitise: strip control characters that could affect terminal output.
751        # Keep \t (tabs in headers), \n (line endings), \r (CRLF mail format).
752
668
1
2684
322
        $text =~ s/[^\x09\x0A\x0D\x20-\x7E\x80-\xFF]//g if defined $text;
753
754        # Store the sanitised raw text for later reproduction in reports
755
668
1
1835
4
        $self->{_raw} = $text // '';
756
757        # Invalidate all per-message lazy caches
758
668
0
696
0
        $self->{_origin}         = undef;
759
668
1
629
323
        $self->{_urls}           = undef;
760
668
1
641
2
        $self->{_mailto_domains} = undef;
761
668
1
566
1
        $self->{_contacts}       = undef;
762
668
1
1358
1
        $self->{_domain_info}    = {};
763
668
1
709
4
        $self->{_risk}           = undef;
764
668
0
645
0
        $self->{_auth_results}   = undef;
765
668
1
636
275
        $self->{_sending_sw}     = [];
766
668
1
961
2
        $self->{_rcvd_tracking}  = [];
767
768        # Perform synchronous header/body parsing (no network I/O)
769
668
1
2996
1
        $self->_split_message($text) if defined $text && $text =~ /\S/;
770
668
1
1146
1
        return $self;
771}
772
773# -----------------------------------------------------------------------
774# Public: originating host
775# -----------------------------------------------------------------------
776
777 - 838
=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
839
840sub originating_ip {
841
934
1
12390
4
        my $self = $_[0];
842
843        # Return the cached result if we already have it
844
934
0
1675
0
        $self->{_origin} //= $self->_find_origin();
845
934
1
1687
271
        return $self->{_origin};
846}
847
848# -----------------------------------------------------------------------
849# Public: HTTP/HTTPS URLs
850# -----------------------------------------------------------------------
851
852 - 926
=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
927
928sub embedded_urls {
929
1036
1
10556
4
        my $self = $_[0];
930
931
1036
0
1545
0
        $self->{_urls} //= $self->_extract_and_resolve_urls();
932
1036
1036
1
1
1087
1637
6189
2
        return @{ $self->{_urls} };
933}
934
935# -----------------------------------------------------------------------
936# Public: mailto / reply-to / from domains
937# -----------------------------------------------------------------------
938
939 - 997
=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
998
999sub mailto_domains {
1000
944
1
3871
24
        my $self = $_[0];
1001
1002
944
1
1404
1004
        $self->{_mailto_domains} //= $self->_extract_and_analyse_domains();
1003
944
944
1
1
747
1207
1
43
        return @{ $self->{_mailto_domains} };
1004}
1005
1006 - 1050
=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
1051
1052sub all_domains {
1053
76
1
4132
2518
        my $self = $_[0];
1054
76
1
82
2
        my (%seen, @out);
1055
1056        # Collect registrable domains from URL hosts first
1057
76
1
125
15
        for my $u ($self->embedded_urls()) {
1058
71
1
164
2704
                my $dom = _registrable($u->{host});
1059
71
1
122
1
                push @out, $dom if $dom && !$seen{$dom}++;
1060        }
1061
1062        # Then from contact domains (normalise subdomains to registrable parent)
1063
76
1
294
18
        for my $d ($self->mailto_domains()) {
1064
81
1
182
1306
                my $dom = _registrable($d->{domain}) // $d->{domain};
1065
29
1
103
1
                push @out, $dom if $dom && !$seen{$dom}++;
1066        }
1067
24
1
40
16
        return @out;
1068}
1069
1070 - 1123
=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
1124
1125sub unresolved_contacts {
1126
36
1
547
3987
        my $self = $_[0];
1127
1128        # Build a set of domains already covered by email or form contacts
1129
36
1
36
2
        my %covered;
1130
36
1
71
14
        for my $c ($self->abuse_contacts(), $self->form_contacts()) {
1131
15
1
72
5167
                my $dom = $c->{form_domain};
1132
15
1
27
1
                unless ($dom) {
1133                        # Extract domain from abuse email address
1134
15
1
43
15
                        ($dom) = ($c->{address} // '') =~ /\@([\w.-]+)/;
1135                }
1136
15
1
45
3190
                $covered{lc $dom}++ if $dom;
1137        }
1138
1139        # Also mark URL hosts that already have a resolved abuse address
1140
36
1
392
1
        for my $u ($self->embedded_urls()) {
1141
19
1
47
45
                (my $bare = lc $u->{host}) =~ s/^www\.//;
1142
16
1
60
2382
                $covered{$bare}++ if $u->{abuse} && $u->{abuse} ne '(unknown)';
1143        }
1144
1145
36
1
1345
1
        my (@out, %seen);
1146
1147        # Check URL hosts first
1148
36
1
66
15
        for my $u ($self->embedded_urls()) {
1149
16
1
35
975
                (my $bare = lc $u->{host}) =~ s/^www\.//;
1150
19
1
1061
1
                next if $covered{$bare};
1151
15
1
48
11
                next if $seen{"url:$bare"}++;
1152                push @out, {
1153                        domain => $u->{host},
1154
11
1
38
1437
                        type   => 'url_host',
1155                        source => 'URL in body',
1156                };
1157        }
1158
1159        # Then check contact domains, skipping spoofable-header-only sources
1160
36
1
1004
2
        for my $d ($self->mailto_domains()) {
1161
40
1
44
9
                my $dom    = $d->{domain};
1162
40
1
58
934
                my $source = $d->{source} // '';
1163
40
1
94
1
                next if $source =~ /^(?:From:|Return-Path:|Sender:) header$/;
1164
14
1
50
10
                next if $covered{lc $dom};
1165
10
1
28
592
                next if $seen{"dom:$dom"}++;
1166
13
1
976
2
                push @out, {
1167                        domain => $dom,
1168                        type   => 'domain',
1169                        source => $source,
1170                };
1171        }
1172
1173
36
1
129
10
        return @out;
1174}
1175
1176# -----------------------------------------------------------------------
1177# Public: sending software fingerprint
1178# -----------------------------------------------------------------------
1179
1180 - 1234
=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
1235
1236sub sending_software {
1237
97
1
284
994
        my $self = $_[0];
1238
1239
97
97
1
1
96
159
2
12
        return @{ $self->{_sending_sw} };
1240}
1241
1242# -----------------------------------------------------------------------
1243# Public: per-hop tracking IDs
1244# -----------------------------------------------------------------------
1245
1246 - 1302
=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
1303
1304sub received_trail {
1305
93
1
289
1089
        my $self = $_[0];
1306
1307
96
96
1
1
987
185
1
11
        return @{ $self->{_rcvd_tracking} };
1308}
1309
1310# -----------------------------------------------------------------------
1311# Public: risk assessment
1312# -----------------------------------------------------------------------
1313
1314 - 1369
=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
1370
1371sub risk_assessment {
1372
399
1
9137
1240
        my $self = $_[0];
1373
1374
402
1
19253
2
        return $self->{_risk} if $self->{_risk};
1375
1376
376
1
313
12
        my (@flags, $score);
1377
376
1
347
814
        $score = 0;
1378
1379        # Closure to record a flag and accumulate its weight
1380        my $flag = sub {
1381
384
1
454
14
                my ($severity, $name, $detail) = @_;
1382
384
1
948
1440
                $score += $FLAG_WEIGHT{$severity} // 1;
1383
384
1
4813
2
                push @flags, { severity => $severity, flag => $name, detail => $detail };
1384
376
1
5108
1
        };
1385
1386
376
1
652
12
        $self->_risk_check_origin($flag);
1387
376
1
654
1079
        $self->_risk_check_auth($flag);
1388
376
1
4638
2
        $self->_risk_check_date($flag);
1389
376
1
643
12
        $self->_risk_check_identity($flag);
1390
376
1
660
2150
        $self->_risk_check_urls_and_domains($flag);
1391
1392        # Determine overall risk level from accumulated score
1393
376
1
5224
2
        my $level = $score >= $SCORE_HIGH   ? 'HIGH'
1394                  : $score >= $SCORE_MEDIUM ? 'MEDIUM'
1395                  : $score >= $SCORE_LOW    ? 'LOW'
1396                  :                           'INFO';
1397
1398
376
1
750
10
        $self->{_risk} = { level => $level, score => $score, flags => \@flags };
1399
376
1
1258
1814
        return $self->{_risk};
1400}
1401
1402# _risk_check_origin( $flag )
1403#
1404# Purpose:
1405#   Evaluate the originating IP for residential rDNS, absent rDNS,
1406#   low-confidence origin, and high-spam-volume country.
1407#
1408# Entry criteria:
1409#   $flag -- coderef( severity, name, detail ) that accumulates flags.
1410#
1411# Exit status:
1412#   Returns nothing; side effects via $flag closure.
1413
1414sub _risk_check_origin :Private {
1415        my ($self, $flag) = @_;
1416        my $orig = $self->originating_ip();
1417        return unless $orig;
1418
1419        return if(!defined($orig->{ip}));
1420
1421        # Residential / broadband rDNS patterns suggest a compromised host
1422        if ($orig->{rdns} && $orig->{rdns} =~ /
1423                \d+[-_.]\d+[-_.]\d+[-_.]\d+   # dotted-quad in rDNS
1424                | (?:dsl|adsl|cable|broad|dial|dynamic|dhcp|ppp|
1425                     residential|cust|home|pool|client|user|
1426                     static\d|host\d)
1427        /xi) {
1428                $flag->('HIGH', 'residential_sending_ip',
1429                        "Sending IP $orig->{ip} rDNS '$orig->{rdns}' looks like a broadband/residential line, not a legitimate mail server");
1430        }
1431
1432        # Absence of rDNS is a strong spam indicator
1433        if (!$orig->{rdns} || $orig->{rdns} eq '(no reverse DNS)') {
1434                $flag->('HIGH', 'no_reverse_dns',
1435                        "Sending IP $orig->{ip} has no reverse DNS -- legitimate mail servers always have rDNS");
1436        }
1437
1438        # Low-confidence origin means the IP came from an unverifiable header
1439        if ($orig->{confidence} eq 'low') {
1440                $flag->('MEDIUM', 'low_confidence_origin',
1441                        "Originating IP taken from unverified header ($orig->{note})");
1442        }
1443
1444        # Statistically high-volume spam countries (informational only)
1445        if ($orig->{country} && $orig->{country} =~ /^(?:CN|RU|NG|VN|IN|PK|BD)$/) {
1446                $flag->('INFO', 'high_spam_country',
1447                        'Sending IP is in ' . _country_name($orig->{country}) .
1448                        " ($orig->{country}) -- statistically high spam volume country");
1449        }
1450
22
22
22
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
0
1
1
1
48181
23
573
5
31
4789
2
12
983
2
11
2640
2
12
1029
270
2
2
646
3
0
373
3
1
}
1451
1452# _risk_check_auth( $flag )
1453#
1454# Purpose:
1455#   Evaluate SPF, DKIM, DMARC results and DKIM signing domain alignment.
1456#
1457# Entry criteria:
1458#   $flag -- accumulator coderef.
1459#
1460# Exit status:
1461#   Returns nothing; side effects via $flag closure.
1462
1463sub _risk_check_auth :Private {
1464        my ($self, $flag) = @_;
1465        my $auth = $self->_parse_auth_results_cached();
1466
1467        if (defined $auth->{spf}) {
1468                if ($auth->{spf} =~ /^fail/i) {
1469                        $flag->('HIGH', 'spf_fail',
1470                                "SPF result: $auth->{spf} -- sending IP not authorised by domain's SPF record");
1471                } elsif ($auth->{spf} =~ /^softfail/i) {
1472                        $flag->('MEDIUM', 'spf_softfail',
1473                                "SPF result: softfail (~all) -- sending IP not explicitly authorised");
1474                } elsif ($auth->{spf} !~ /^pass/i) {
1475                        $flag->('HIGH', 'spf_fail',
1476                                "SPF result: $auth->{spf} -- sending IP not authorised");
1477                }
1478        }
1479        if (defined $auth->{dkim} && $auth->{dkim} !~ /^pass/i) {
1480                $flag->('HIGH', 'dkim_fail',
1481                        "DKIM result: $auth->{dkim} -- message signature invalid or absent");
1482        }
1483        if (defined $auth->{dmarc} && $auth->{dmarc} !~ /^pass/i) {
1484                $flag->('HIGH', 'dmarc_fail', "DMARC result: $auth->{dmarc}");
1485        }
1486
1487        # DKIM signing domain vs From: domain mismatch check
1488        return unless $auth->{dkim_domain};
1489        my ($from_domain) = ($self->_header_value('from') // '') =~ /\@([\w.-]+)/;
1490        return unless $from_domain;
1491        my $reg_dkim = _registrable($auth->{dkim_domain}) // $auth->{dkim_domain};
1492        my $reg_from = _registrable(lc $from_domain)     // lc $from_domain;
1493        return if $reg_dkim eq $reg_from;
1494
1495        # Passing DKIM with a different domain is normal for ESPs
1496        if ($auth->{dkim} && $auth->{dkim} =~ /^pass/i) {
1497                $flag->('INFO', 'dkim_domain_mismatch',
1498                        "DKIM signed by '$auth->{dkim_domain}' but From: domain is '$from_domain'"
1499                        . ' -- message sent via third-party sender (normal for bulk/ESP mail)');
1500        } else {
1501                # Failing DKIM plus mismatched domain is more suspicious
1502                $flag->('MEDIUM', 'dkim_domain_mismatch',
1503                        "DKIM signed by '$auth->{dkim_domain}' but From: domain is '$from_domain'"
1504                        . ' and DKIM did not pass -- possible impersonation');
1505        }
1506
22
22
22
3
3
3
1
1
1
1
1
1
1
1
1
1
1
0
1
1
0
1
1
0
12209
24
291
4
38
4090
2
15
1403
2
11
1549
2
14
1379
2
3
0
682
4
0
2
5
0
}
1507
1508# _risk_check_date( $flag )
1509#
1510# Purpose:
1511#   Validate the Date: header for presence, plausible timezone, and
1512#   date not too far in the past or future.
1513#
1514# Entry criteria:
1515#   $flag -- accumulator coderef.
1516#
1517# Exit status:
1518#   Returns nothing; side effects via $flag closure.
1519
1520sub _risk_check_date :Private {
1521        my ($self, $flag) = @_;
1522        my $date_raw = $self->_header_value('date');
1523
1524        if (!$date_raw || $date_raw !~ /\S/) {
1525                $flag->('MEDIUM', 'missing_date',
1526                        'No Date: header -- violates RFC 5322; common in spam');
1527                return;
1528        }
1529
1530        # Check for an implausible timezone offset (outside real-world bounds)
1531        if ($date_raw =~ /([+-])(\d{2})(\d{2})\s*$/) {
1532                my ($sign, $hh, $mm) = ($1, $2, $3);
1533                my $offset_mins = $hh * 60 + $mm;
1534                my $implausible = $mm >= 60
1535                        || ($sign eq '+' && $offset_mins > $TZ_MAX_POS_MINS)
1536                        || ($sign eq '-' && $offset_mins > $TZ_MAX_NEG_MINS);
1537                if ($implausible) {
1538                        $flag->('MEDIUM', 'implausible_timezone',
1539                                "Date: '$date_raw' contains an implausible timezone offset "
1540                                . "($sign$hh$mm) -- header is likely forged");
1541                }
1542        }
1543
1544        # Check for dates more than DATE_SKEW_DAYS outside the analysis window
1545        my $date_epoch = _parse_rfc2822_date($date_raw);
1546        return unless defined $date_epoch;
1547        my $delta = time() - $date_epoch;
1548        if ($delta > $DATE_SKEW_DAYS * $SECS_PER_DAY) {
1549                $flag->('LOW', 'suspicious_date',
1550                        "Date: '$date_raw' is more than $DATE_SKEW_DAYS days in the past");
1551        } elsif ($delta < -($DATE_SKEW_DAYS * $SECS_PER_DAY)) {
1552                $flag->('LOW', 'suspicious_date',
1553                        "Date: '$date_raw' is more than $DATE_SKEW_DAYS days in the future");
1554        }
1555
22
22
22
3
3
3
1
1
1
1
1
1
1
1
1
1
1
0
1
1
0
1
1
0
8133
23
228
3
32
4502
1
12
1231
2
13
1958
1
12
1294
260
3
0
671
3
0
419
6
0
}
1556
1557# _risk_check_identity( $flag )
1558#
1559# Purpose:
1560#   Check From: display-name spoofing, free webmail, Reply-To mismatch,
1561#   undisclosed recipients, and MIME-encoded Subject.
1562#
1563# Entry criteria:
1564#   $flag -- accumulator coderef.
1565#
1566# Exit status:
1567#   Returns nothing; side effects via $flag closure.
1568
1569sub _risk_check_identity :Private {
1570        my ($self, $flag) = @_;
1571        my $from_raw     = $self->_header_value('from') // '';
1572        my $from_decoded = $self->_decode_mime_words($from_raw);
1573
1574        # Display-name domain spoofing: "PayPal paypal.com" <phish@evil.example>
1575        if ($from_decoded =~ /^"?([^"<]+?)"?\s*<([^>]+)>/) {
1576                my ($display, $addr) = ($1, $2);
1577                while ($display =~ /\b([\w-]+\.(?:com|net|org|io|co|uk|au|gov|edu))\b/gi) {
1578                        my $disp_domain = lc $1;
1579                        my ($addr_domain) = $addr =~ /\@([\w.-]+)/;
1580                        $addr_domain = lc($addr_domain // '');
1581                        my $reg_disp = _registrable($disp_domain);
1582                        my $reg_addr = _registrable($addr_domain);
1583                        if ($reg_disp && $reg_addr && $reg_disp ne $reg_addr) {
1584                                $flag->('HIGH', 'display_name_domain_spoof',
1585                                        "From: display name mentions '$disp_domain' but actual address is <$addr>");
1586                        }
1587                }
1588        }
1589
1590        # Free webmail sender flag (no corporate infrastructure)
1591        if ($from_raw =~ /\@(gmail|yahoo|hotmail|outlook|live|aol|protonmail|yandex)\./i
1592         || $from_raw =~ /\@mail\.ru(?:[\s>]|$)/i) {
1593                $flag->('MEDIUM', 'free_webmail_sender',
1594                        "Message sent from free webmail address ($from_raw)");
1595        }
1596
1597        # Reply-To differs from From: -- replies harvested by different address
1598        my $reply_to = $self->_header_value('reply-to');
1599        if ($reply_to) {
1600                my ($from_addr)  = $from_raw =~ /([\w.+%-]+\@[\w.-]+)/;
1601                my ($reply_addr) = $reply_to =~ /([\w.+%-]+\@[\w.-]+)/;
1602                if ($from_addr && $reply_addr && lc($from_addr) ne lc($reply_addr)) {
1603                        $flag->('MEDIUM', 'reply_to_differs_from_from',
1604                                "Reply-To ($reply_addr) differs from From: ($from_addr)");
1605                }
1606        }
1607
1608        # Undisclosed or absent To: header
1609        my $to = $self->_header_value('to') // '';
1610        if ($to =~ /undisclosed|:;/ || $to eq '') {
1611                $flag->('MEDIUM', 'undisclosed_recipients',
1612                        "To: header is '$to' -- message was bulk-sent with hidden recipient list");
1613        }
1614
1615        # MIME-encoded Subject (potential filter evasion)
1616        my $subj_raw = $self->_header_value('subject') // '';
1617        if ($subj_raw =~ /=\?[^?]+\?[BQ]\?/i) {
1618                $flag->('LOW', 'encoded_subject',
1619                        "Subject line is MIME-encoded: '$subj_raw' (decoded: '"
1620                        . $self->_decode_mime_words($subj_raw) . "')");
1621        }
1622
22
22
22
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
15340
22
254
4
42
4150
1
13
2110
1
11
1494
1
13
1949
6083
2
27
5782
5
24
6562
1
29
}
1623
1624# _risk_check_urls_and_domains( $flag )
1625#
1626# Purpose:
1627#   Check embedded URLs for shorteners and plain HTTP, and contact domains
1628#   for recent registration, imminent expiry, and lookalike brand names.
1629#
1630# Entry criteria:
1631#   $flag -- accumulator coderef.
1632#
1633# Exit status:
1634#   Returns nothing; side effects via $flag closure.
1635
1636sub _risk_check_urls_and_domains :Private {
1637        my ($self, $flag) = @_;
1638        my (%shortener_seen, %cloaker_seen, %url_host_seen);
1639
1640        for my $u ($self->embedded_urls()) {
1641                # Skip trusted infrastructure -- these are not spam indicators
1642                next unless($u->{host});
1643                my $bare = lc $u->{host};
1644                next unless defined($bare);
1645                $bare =~ s/^www\.//;
1646                next if $self->{trusted_domains}->{$bare};
1647                next if $TRUSTED_DOMAINS{$bare};
1648
1649                # URL shortener hides real destination
1650                if(($URL_SHORTENERS{$bare} || $self->{url_shorteners}->{$bare}) && !$shortener_seen{$bare}++) {
1651                        $flag->('MEDIUM', 'url_shortener',
1652                                "$u->{host} is a URL shortener -- the real destination is hidden");
1653                }
1654                # Cloud object-store / CDN used as a redirect cloaker
1655                if ($self->_is_redirect_cloaker($bare) && !$cloaker_seen{$bare}++) {
1656                        $flag->('MEDIUM', 'redirect_cloaker',
1657                                "$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");
1658                }
1659                # Plain HTTP provides no encryption
1660                if ($u->{url} =~ m{^http://}i && !$url_host_seen{ $u->{host} }++) {
1661                        $flag->('LOW', 'http_not_https',
1662                                "$u->{host} linked over plain HTTP -- no encryption");
1663                }
1664        }
1665
1666        # Domain-level checks against contact/reply domains
1667        for my $d ($self->mailto_domains()) {
1668                # Recently registered domain is a common phishing indicator
1669                if ($d->{recently_registered}) {
1670                        $flag->('HIGH', 'recently_registered_domain',
1671                                "$d->{domain} was registered $d->{registered} (less than ${\$RECENT_REG_DAYS} days ago)");
1672                }
1673
1674                # Domain expiry checks
1675                if ($d->{expires}) {
1676                        if(my $exp = $self->_parse_date_to_epoch($d->{expires})) {
1677                                my $now      = time();
1678                                my $remaining = $exp - $now;
1679                                if ($remaining > 0 && $remaining < $EXPIRY_WARN_DAYS * $SECS_PER_DAY) {
1680                                        $flag->('HIGH', 'domain_expires_soon',
1681                                                "$d->{domain} expires $d->{expires} -- may be a throwaway domain");
1682                                } elsif ($remaining <= 0) {
1683                                        $flag->('HIGH', 'domain_expired',
1684                                                "$d->{domain} expired $d->{expires} -- domain has lapsed");
1685                                }
1686                        }
1687                }
1688
1689                # Lookalike domain check (brand name in a non-brand domain)
1690                for my $brand (@LOOKALIKE_BRANDS) {
1691                        next if(!defined($d->{domain}));
1692                        if ($d->{domain} =~ /\Q$brand\E/i &&
1693                            $d->{domain} !~ /^\Q$brand\E\.(?:com|co\.uk|net|org)$/) {
1694                                $flag->('HIGH', 'lookalike_domain',
1695                                        "$d->{domain} contains brand name '$brand' but is not the real domain -- possible phishing");
1696                                last;
1697                        }
1698                }
1699        }
1700
22
22
22
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
9766
29
217
4
62
4054
2
13
1754
2
11
1181
1
12
1720
1501
2
19
880
2
21
1936
2
18
}
1701
1702# -----------------------------------------------------------------------
1703# Public: abuse report text
1704# -----------------------------------------------------------------------
1705
1706 - 1753
=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
1754
1755sub abuse_report_text {
1756
22
1
9779
1
        my $self = $_[0];
1757
22
1
26
13
        my @out;
1758
1759
22
1
95
1593
        push @out, 'This is an automated abuse report generated by Email::Abuse::Investigator.',
1760                 'Please investigate the following spam/phishing message.',
1761                '';
1762
1763
22
1
10544
1
        my $risk = $self->risk_assessment();
1764
22
1
47
14
        push @out, "RISK LEVEL: $risk->{level} (score: $risk->{score})",
1765                '';
1766
1767        # List each red flag with its severity prefix
1768
22
22
1
1
51
4750
694
2
        if (@{ $risk->{flags} }) {
1769
13
1
17
11
                push @out, 'RED FLAGS IDENTIFIED:';
1770
13
13
1
1
52
4749
669
1
                for my $f (@{ $risk->{flags} }) {
1771
19
1
39
12
                        push @out, "  [$f->{severity}] " . _sanitise_output($f->{detail});
1772                }
1773
13
1
51
1252
                push @out, '';
1774        }
1775
1776        # Originating IP summary block
1777
22
1
3599
1
        my $orig = $self->originating_ip();
1778
22
1
30
14
        if ($orig) {
1779                push @out, 'ORIGINATING IP: ' . _sanitise_output("$orig->{ip} ($orig->{rdns})"),
1780
15
1
61
1315
                        'NETWORK OWNER:  ' . _sanitise_output($orig->{org}),
1781                        '';
1782        }
1783
1784        # List every reported URL so the receiving abuse desk knows exactly
1785        # which resources to investigate or suspend.
1786
22
1
4397
1
        my @urls = $self->embedded_urls();
1787
22
1
34
12
        if (@urls) {
1788
7
1
65
1357
                push @out, 'REPORTED URLs:';
1789
7
1
2901
2
                for my $u (@urls) {
1790
7
1
11
13
                        push @out, '  ' . _sanitise_output($u->{url});
1791
7
1
39
1726
                        my @meta;
1792
7
1
3136
1
                        push @meta, "host: $u->{host}"   if $u->{host};
1793
7
1
18
12
                        push @meta, "IP: $u->{ip}"       if $u->{ip} && $u->{ip} ne '(unresolved)';
1794
7
1
56
1235
                        push @meta, "org: $u->{org}"     if $u->{org} && $u->{org} ne '(unknown)';
1795
7
1
3086
1
                        push @out, '    (' . join('  ', @meta) . ')' if @meta;
1796                }
1797
7
1
8
12
                push @out, '';
1798        }
1799
1800        # Email abuse contacts
1801
22
1
75
946
        my @contacts = $self->abuse_contacts();
1802
22
1
4510
1
        if (@contacts) {
1803
17
1
18
15
                push @out, 'ABUSE CONTACTS:';
1804
17
1
70
1753
                push @out, '  ' . _sanitise_output("$_->{address} ($_->{role})") for @contacts;
1805
17
1
3020
2
                push @out, '';
1806        }
1807
1808        # Web-form contacts (providers that reject email)
1809
22
1
35
15
        if(my @form_cs = $self->form_contacts()) {
1810
4
1
33
1029
                push @out, 'WEB-FORM REPORTS REQUIRED:',
1811                        '  The following parties do not accept email -- submit manually:';
1812
4
1
4700
1
                for my $c (@form_cs) {
1813                        push @out, "  [$c->{role}]",
1814
4
1
7
12
                                '    Form   : ' . _sanitise_output($c->{form});
1815
4
1
38
1460
                        push @out, '    Domain : ' . _sanitise_output($c->{form_domain}) if $c->{form_domain};
1816
4
1
4730
1
                        push @out, '    Paste  : ' . _sanitise_output($c->{form_paste})  if $c->{form_paste};
1817
4
1
6
11
                        push @out, '    Upload : ' . _sanitise_output($c->{form_upload}) if $c->{form_upload};
1818                }
1819
4
1
42
599
                push @out, '';
1820        }
1821
1822        # Separator and raw headers (body excluded for brevity)
1823
22
1
3840
2
        push @out, '-' x 72,
1824                'ORIGINAL MESSAGE HEADERS:',
1825                '-' x 72;
1826
1827
22
22
1
1
25
58
12
753
        for my $h (@{ $self->{_headers} }) {
1828
133
1
4993
2
                push @out, _sanitise_output("$h->{name}: $h->{value}");
1829        }
1830
22
1
26
12
        push @out, '';
1831
1832
22
1
113
1151
        return join("\n", @out);
1833}
1834
1835# -----------------------------------------------------------------------
1836# Public: abuse contacts
1837# -----------------------------------------------------------------------
1838
1839 - 1898
=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
1899
1900sub abuse_contacts {
1901
188
1
9702
1
        my $self = $_[0];
1902
188
1
549
13
        $self->{_contacts} //= [ $self->_compute_abuse_contacts() ];
1903
188
188
1
1
183
5664
1023
2
        return @{ $self->{_contacts} };
1904}
1905
1906# _compute_abuse_contacts() -> list of contact hashrefs
1907#
1908# Purpose:
1909#   Actual implementation of abuse_contacts(). Separated so the public
1910#   method can cache without duplicating logic.
1911#
1912# Entry criteria:
1913#   parse_email() must have been called.
1914#
1915# Exit status:
1916#   Returns list of deduplicated contact hashrefs.
1917
1918sub _compute_abuse_contacts :Private {
1919        my $self = $_[0];
1920
1921        my (@contacts, %seen_idx);
1922
1923        # Inner closure: add one contact entry, merging roles for duplicate addresses
1924        my $add = sub {
1925                my (%args) = @_;
1926                my $addr = lc($args{address} // '');
1927                return unless $addr && $addr =~ /\@/;
1928
1929                # Suppress addresses belonging to form-only providers (no email accepted)
1930                if ($addr =~ /\@([\w.-]+)$/) {
1931                        my $dom = $1;
1932                        my $pa  = $self->_provider_abuse_for_host($dom);
1933                        return if $pa && $pa->{form} && !$pa->{email};
1934                }
1935
1936                if (exists $seen_idx{$addr}) {
1937                        # Merge the new role into the existing entry
1938                        my $entry = $contacts[ $seen_idx{$addr} ];
1939                        push @{ $entry->{roles} }, $args{role};
1940
1941                        # Collapse repeated role labels to avoid unreadable strings
1942                        my (%role_counts, @ordered_roles);
1943                        for my $r (@{ $entry->{roles} }) {
1944                                push @ordered_roles, $r unless $role_counts{$r}++;
1945                        }
1946                        my @display = map {
1947                                $role_counts{$_} > 1 ? "$_ (x$role_counts{$_})" : $_
1948                        } @ordered_roles;
1949                        my $joined = join(' and ', @display);
1950
1951                        # Summarise if the merged string is too long to read.
1952                        # "URL host: hostname" entries are grouped by listing the actual
1953                        # hostnames so the summary is actionable (e.g. "URL host: a.example,
1954                        # b.example" rather than the unhelpful "URL host, URL host").
1955                        # All other role types fall back to stripping at the first [:(\d]
1956                        # boundary to produce a compact type label.
1957                        if (length($joined) > $ROLE_MAX_LEN) {
1958                                my (@url_hosts, %seen_short, @short);
1959                                for my $r (@display) {
1960                                        if ($r =~ /^URL host:\s*(.+)$/) {
1961                                                push @url_hosts, $1;
1962                                        } else {
1963                                                (my $s = $r) =~ s/[:(\d].*//;
1964                                                $s =~ s/\s+$//;
1965                                                push @short, $s unless $seen_short{$s}++;
1966                                        }
1967                                }
1968                                my @parts;
1969                                if (@url_hosts) {
1970                                        my $extra = @url_hosts > 3
1971                                                ? ' and ' . (@url_hosts - 3) . ' more' : '';
1972                                        my @shown = @url_hosts > 3 ? @url_hosts[0..2] : @url_hosts;
1973                                        push @parts, 'URL host: ' . join(', ', @shown) . $extra;
1974                                }
1975                                push @parts, @short;
1976                                $joined = scalar(@display) . ' routes: ' . join(', ', @parts);
1977                        }
1978                        $entry->{role} = $joined;
1979                        return;
1980                }
1981
1982                # First time seeing this address -- record and store
1983                $seen_idx{$addr} = scalar @contacts;
1984                $args{roles} = [ $args{role} ];
1985                push @contacts, \%args;
1986        };
1987
1988        # Route 1 -- Sending ISP (originating IP)
1989        my $orig = $self->originating_ip();
1990        if ($orig) {
1991                my $pa = $self->_provider_abuse_for_ip($orig->{ip}, $orig->{rdns});
1992                if ($pa) {
1993                        $add->(
1994                                role    => 'Sending ISP',
1995                                address => $pa->{email},
1996                                note    => "$orig->{ip} ($orig->{rdns}) -- $pa->{note}",
1997                                via     => 'provider-table',
1998                        );
1999                }
2000                if ($orig->{abuse} && $orig->{abuse} ne '(unknown)') {
2001                        $add->(
2002                                role    => 'Sending ISP',
2003                                address => $orig->{abuse},
2004                                note    => "Network owner of originating IP $orig->{ip} ($orig->{org})",
2005                                via     => 'ip-whois',
2006                        );
2007                }
2008        }
2009
2010        # Route 2 -- URL hosts
2011        my %url_host_seen;
2012        for my $u ($self->embedded_urls()) {
2013                next if $url_host_seen{ $u->{host} }++;
2014                my $bare_host = lc $u->{host};
2015                $bare_host =~ s/^www\.//;
2016                # Skip trusted infrastructure (Google, W3C, etc.)
2017                next if $self->{trusted_domains}->{$bare_host};
2018                next if $TRUSTED_DOMAINS{$bare_host};
2019                my $pa = $self->_provider_abuse_for_host($u->{host});
2020                if ($pa) {
2021                        $add->(
2022                                role    => "URL host: $u->{host}",
2023                                address => $pa->{email},
2024                                note    => "$u->{host} -- $pa->{note}",
2025                                via     => 'provider-table',
2026                        );
2027                }
2028                if ($u->{abuse} && $u->{abuse} ne '(unknown)') {
2029                        $add->(
2030                                role    => "URL host: $u->{host}",
2031                                address => $u->{abuse},
2032                                note    => "Hosting $u->{host} ($u->{ip}, $u->{org})",
2033                                via     => 'ip-whois',
2034                        );
2035                }
2036        }
2037
2038        # Route 3 -- Contact domain hosting and registration
2039        for my $d ($self->mailto_domains()) {
2040                my $dom = $d->{domain};
2041
2042                # Web host contact
2043                if ($d->{web_abuse}) {
2044                        my $pa = $self->_provider_abuse_for_host($dom);
2045                        if ($pa) {
2046                                $add->(role => "Web host of $dom", address => $pa->{email},
2047                                       note => $pa->{note}, via => 'provider-table');
2048                        }
2049                        $add->(
2050                                role    => "Web host of $dom",
2051                                address => $d->{web_abuse},
2052                                note    => sprintf('Hosting %s (%s, %s)',
2053                                             $dom             // '(unknown domain)',
2054                                             $d->{web_ip}     // '(unknown IP)',
2055                                             $d->{web_org}    // '(unknown org)'),
2056                                via     => 'ip-whois',
2057                        );
2058                }
2059
2060                # MX (mail host) contact
2061                if ($d->{mx_abuse}) {
2062                        $add->(
2063                                role    => "Mail host (MX) for $dom",
2064                                address => $d->{mx_abuse},
2065                                note    => sprintf('MX %s (%s, %s)',
2066                                             $d->{mx_host} // '(unknown host)',
2067                                             $d->{mx_ip}   // '(unknown IP)',
2068                                             $d->{mx_org}  // '(unknown org)'),
2069                                via     => 'ip-whois',
2070                        );
2071                }
2072
2073                # NS (DNS host) contact
2074                if ($d->{ns_abuse}) {
2075                        $add->(
2076                                role    => "DNS host (NS) for $dom",
2077                                address => $d->{ns_abuse},
2078                                note    => sprintf('NS %s (%s, %s)',
2079                                             $d->{ns_host} // '(unknown host)',
2080                                             $d->{ns_ip}   // '(unknown IP)',
2081                                             $d->{ns_org}  // '(unknown org)'),
2082                                via     => 'ip-whois',
2083                        );
2084                }
2085
2086                # Domain registrar (skip if domain only seen in spoofable headers)
2087                if ($d->{registrar_abuse}) {
2088                        my $spoofable_only =
2089                                $d->{source} =~ /^(?:From:|Return-Path:|Sender:) header$/ &&
2090                                !scalar(grep {
2091                                        $_->{host} &&
2092                                        _registrable($_->{host}) eq (_registrable($dom) // $dom)
2093                                } $self->embedded_urls());
2094                        unless ($spoofable_only) {
2095                                $add->(
2096                                        role    => "Domain registrar for $dom",
2097                                        address => $d->{registrar_abuse},
2098                                        note    => 'Registrar: ' . ($d->{registrar} // '(unknown)'),
2099                                        via     => 'domain-whois',
2100                                );
2101                        }
2102                }
2103        }
2104
2105        # Route 4 -- From:/Reply-To:/Return-Path:/Sender: account provider
2106        for my $hname (qw(from reply-to return-path sender)) {
2107                my $val = $self->_header_value($hname) // next;
2108
2109                # Extract addr-spec from angle-bracket form to avoid display-name @-signs
2110                my $addr_spec = ($val =~ /<([^>]*)>\s*$/) ? $1 : $val;
2111                my ($addr_domain) = $addr_spec =~ /\@([\w.-]+)/;
2112                next unless $addr_domain;
2113
2114                # Skip SRS-rewritten forwarder addresses (not the real sender)
2115                next if $addr_spec =~ /\+SRS[0-9]?=/i;
2116
2117                my $pa = $self->_provider_abuse_for_host($addr_domain);
2118                if ($pa) {
2119                        my $role_addr = $addr_spec =~ /\@/ ? $addr_spec : $val;
2120                        $role_addr =~ s/^\s+|\s+$//g;
2121                        $add->(
2122                                role    => "Account provider ($hname: $role_addr)",
2123                                address => $pa->{email},
2124                                note    => $pa->{note},
2125                                via     => 'provider-table',
2126                        );
2127                }
2128        }
2129
2130        # Route 5 -- DKIM signing organisation
2131        my $auth = $self->_parse_auth_results_cached();
2132        if ($auth->{dkim_domain}) {
2133                my $pa = $self->_provider_abuse_for_host($auth->{dkim_domain});
2134                if ($pa) {
2135                        $add->(
2136                                role    => "DKIM signer: $auth->{dkim_domain}",
2137                                address => $pa->{email},
2138                                note    => $pa->{note},
2139                                via     => 'provider-table',
2140                        );
2141                }
2142        }
2143
2144        # Route 6 -- List-Unsubscribe ESP domain
2145        my $unsub = $self->_header_value('list-unsubscribe');
2146        if ($unsub) {
2147                my @unsub_domains;
2148                while ($unsub =~ m{https?://([^/:?\s>]+)}gi) {
2149                        push @unsub_domains, lc $1;
2150                }
2151                while ($unsub =~ m{mailto:[^@\s>]+\@([\w.-]+)}gi) {
2152                        push @unsub_domains, lc $1;
2153                }
2154                my %unsub_seen;
2155                for my $dom (grep { !$unsub_seen{$_}++ } @unsub_domains) {
2156                        my $pa = $self->_provider_abuse_for_host($dom);
2157                        if ($pa) {
2158                                $add->(
2159                                        role    => "ESP / bulk sender (List-Unsubscribe: $dom)",
2160                                        address => $pa->{email},
2161                                        note    => "$pa->{note} -- responsible for this bulk delivery",
2162                                        via     => 'provider-table',
2163                                );
2164                        }
2165                }
2166        }
2167
2168        # Route 7 -- Reply addresses embedded in the message body
2169        my %body_addr_seen;
2170        my $combined_body = $self->{_body_plain} . "\n" . $self->{_body_html};
2171        for my $addr_dom ($self->_domains_from_text($combined_body)) {
2172                next if $body_addr_seen{$addr_dom}++;
2173                my $pa = $self->_provider_abuse_for_host($addr_dom);
2174                next unless $pa && $pa->{email};
2175                my ($example_addr) = $combined_body =~ /(\S+\@\Q$addr_dom\E)/i;
2176                $example_addr //= "\@$addr_dom";
2177                $add->(
2178                        role    => "Reply address in body ($example_addr)",
2179                        address => $pa->{email},
2180                        note    => $pa->{note},
2181                        via     => 'provider-table',
2182                );
2183        }
2184
2185        return @contacts;
2186
22
22
22
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
37795
32
226
11
42
5727
1
13
1665
1
11
2546
2
12
1392
1471
2
18
1633
2
16
758
1
17
}
2187
2188# -----------------------------------------------------------------------
2189# Public: form contacts (providers that require web-form submission)
2190# -----------------------------------------------------------------------
2191
2192 - 2248
=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
2249
2250sub form_contacts {
2251
216
1
5212
12
        my $self = $_[0];
2252
2253
216
1
322
1070
        my (@contacts, %seen);
2254
2255        # Inner closure: add one form-contact entry, deduplicating by form URL
2256        my $add = sub {
2257
96
1
223
38
                my (%args) = @_;
2258
63
1
123
1008
                my $form = $args{form} // '';
2259
63
1
3923
1
                return unless $form;
2260
66
1
124
12
                return if $seen{$form}++;
2261
52
1
104
1363
                push @contacts, \%args;
2262
216
1
4257
1
        };
2263
2264        # Route 1 -- Sending ISP
2265
189
1
4488
1
        my $orig = $self->originating_ip();
2266
189
1
262
13
        if ($orig) {
2267
121
1
276
1343
                my $pa = $self->_provider_abuse_for_ip($orig->{ip}, $orig->{rdns});
2268
110
1
3319
1
                if ($pa && $pa->{form}) {
2269                        $add->(
2270                                role        => 'Sending ISP',
2271                                form        => $pa->{form},
2272                                note        => $pa->{note} // '',
2273                                form_paste  => $pa->{form_paste}  // '',
2274
16
1
15
13
                                form_upload => $pa->{form_upload} // '',
2275                                via         => 'provider-table',
2276                        );
2277                }
2278        }
2279
2280        # Route 2 -- URL hosts
2281
176
1
190
534
        my %url_host_seen;
2282
176
1
3591
2
        for my $u ($self->embedded_urls()) {
2283
82
1
147
10
                next if $url_host_seen{ $u->{host} }++;
2284
71
1
126
1319
                my $pa = $self->_provider_abuse_for_host($u->{host});
2285
94
1
4358
2
                if ($pa && $pa->{form}) {
2286                        $add->(
2287                                role        => "URL host: $u->{host}",
2288                                form        => $pa->{form},
2289                                form_domain => $u->{host},
2290                                note        => $pa->{note} // '',
2291                                form_paste  => $pa->{form_paste}  // '',
2292
17
1
38
12
                                form_upload => $pa->{form_upload} // '',
2293                                via         => 'provider-table',
2294                        );
2295                }
2296        }
2297
2298        # Route 3 -- Contact domains (web host + registrar)
2299
191
1
271
3597
        for my $d ($self->mailto_domains()) {
2300
176
1
3476
2
                my $dom = $d->{domain};
2301
176
1
204
15
                my $pa  = $self->_provider_abuse_for_host($dom);
2302
173
1
239
2
                if ($pa && $pa->{form}) {
2303                        $add->(
2304                                role        => "Web host of $dom",
2305                                form        => $pa->{form},
2306                                form_domain => $dom,
2307                                note        => $pa->{note} // '',
2308                                form_paste  => $pa->{form_paste}  // '',
2309
18
1
4461
1
                                form_upload => $pa->{form_upload} // '',
2310                                via         => 'provider-table',
2311                        );
2312                }
2313
2314                # Registrar identified via WHOIS -- check for form-only registrar
2315
185
1
353
42
                if ($d->{registrar_abuse} && $d->{registrar_abuse} =~ /\@([\w.-]+)/) {
2316
43
1
97
3
                        my $reg_domain = lc $1;
2317
34
1
3974
1
                        my $rpa = $self->_provider_abuse_for_host($reg_domain);
2318
34
1
71
4
                        if ($rpa && $rpa->{form}) {
2319                                $add->(
2320                                        role        => "Domain registrar for $dom (web form only)",
2321                                        form        => $rpa->{form},
2322                                        form_domain => $dom,
2323                                        note        => $rpa->{note} // '',
2324                                        form_paste  => $rpa->{form_paste}  // '',
2325
22
1
126
3715
                                        form_upload => $rpa->{form_upload} // '',
2326                                        via         => 'provider-table',
2327                                );
2328                        }
2329                }
2330        }
2331
2332        # Route 4 -- Account provider headers
2333
169
1
3183
1
        for my $hname (qw(from reply-to return-path sender)) {
2334
655
1
628
42
                my $val = $self->_header_value($hname) // next;
2335
281
1
613
3
                my $addr_spec = ($val =~ /<([^>]*)>\s*$/) ? $1 : $val;
2336
281
1
3737
2
                my ($addr_domain) = $addr_spec =~ /\@([\w.-]+)/;
2337
281
1
280
21
                next unless $addr_domain;
2338                # Skip SRS forwarder rewrite addresses
2339
281
1
384
2
                next if $addr_spec =~ /\+SRS[0-9]?=/i;
2340
285
1
4432
1
                my $pa = $self->_provider_abuse_for_host($addr_domain);
2341
290
1
392
6
                if ($pa && $pa->{form}) {
2342
27
1
87
356
                        my $role_addr = $addr_spec =~ /@/ ? $addr_spec : $val;
2343
71
1
3237
3
                        $role_addr =~ s/^\s+|\s+$//g;
2344                        $add->(
2345                                role        => "Account provider ($hname: $role_addr)",
2346                                form        => $pa->{form},
2347                                note        => $pa->{note} // '',
2348                                form_paste  => $pa->{form_paste}  // '',
2349
30
1
122
2
                                form_upload => $pa->{form_upload} // '',
2350                                via         => 'provider-table',
2351                        );
2352                }
2353        }
2354
2355        # Route 5 -- DKIM signer
2356
181
1
327
4
        my $auth = $self->_parse_auth_results_cached();
2357
178
1
4860
182
        if ($auth->{dkim_domain}) {
2358
18
1
19
2
                my $pa = $self->_provider_abuse_for_host($auth->{dkim_domain});
2359
17
1
61
5
                if ($pa && $pa->{form}) {
2360                        $add->(
2361                                role        => "DKIM signer: $auth->{dkim_domain}",
2362                                form        => $pa->{form},
2363                                note        => $pa->{note} // '',
2364                                form_paste  => $pa->{form_paste}  // '',
2365
16
1
3297
136
                                form_upload => $pa->{form_upload} // '',
2366                                via         => 'provider-table',
2367                        );
2368                }
2369        }
2370
2371        # Route 6 -- List-Unsubscribe ESP domains
2372
168
1
220
2
        my $unsub = $self->_header_value('list-unsubscribe');
2373
177
1
259
38
        if ($unsub) {
2374
13
1
2589
3
                my @unsub_domains;
2375
18
17
1
1
21
44
2
33
                while ($unsub =~ m{https?://([^/:?\s>]+)}gi) { push @unsub_domains, lc $1 }
2376
11
10
1
1
3433
11
3
2
                while ($unsub =~ m{mailto:[^@\s>]+\@([\w.-]+)}gi) { push @unsub_domains, lc $1 }
2377
11
1
37
13
                my %useen;
2378
11
11
1
1
4737
14
3
1
                for my $dom (grep { !$useen{$_}++ } @unsub_domains) {
2379
11
1
51
37
                        my $pa = $self->_provider_abuse_for_host($dom);
2380
11
1
4246
3
                        if ($pa && $pa->{form}) {
2381                                $add->(
2382                                        role        => "ESP / bulk sender (List-Unsubscribe: $dom)",
2383                                        form        => $pa->{form},
2384                                        note        => $pa->{note} // '',
2385                                        form_paste  => $pa->{form_paste}  // '',
2386
5
1
11
17
                                        form_upload => $pa->{form_upload} // '',
2387                                        via         => 'provider-table',
2388                                );
2389                        }
2390                }
2391        }
2392
2393
171
1
643
66
        return @contacts;
2394}
2395
2396# -----------------------------------------------------------------------
2397# Public: full analyst report
2398# -----------------------------------------------------------------------
2399
2400 - 2447
=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
2448
2449sub report {
2450
69
1
5164
4
        my $self = $_[0];
2451
2452
76
1
68
2
        my @out;
2453
2454        # Banner header
2455
65
1
131
48
        push @out, '=' x 72;
2456
65
1
4052
3
        push @out, "  Email::Abuse::Investigator Report  (v$VERSION)";
2457
64
1
74
1
        push @out, '=' x 72;
2458
64
1
106
111
        push @out, '';
2459
2460        # Envelope summary -- decode MIME encoded-words for readability
2461
63
1
7445
4
        for my $f (qw(from reply-to return-path subject date message-id)) {
2462
364
1
336
1
                my $v = $self->_header_value($f);
2463
365
1
407
31
                next unless defined $v;
2464
250
1
250
2
                my $decoded = $self->_decode_mime_words($v);
2465
251
1
198
2
                my $label   = ucfirst($f);
2466
249
1
408
5
                push @out, sprintf('  %-14s : %s', $label,
2467                        _sanitise_output($decoded ne $v ? "$decoded  [encoded: $v]" : $v));
2468        }
2469
65
1
71
161
        push @out, '';
2470
2471        # Risk assessment section
2472
63
1
105
6
        my $risk = $self->risk_assessment();
2473
63
0
145
0
        push @out, "[ RISK ASSESSMENT: $risk->{level} (score: $risk->{score}) ]";
2474
63
76
1
1
6511
106
1665
8
        if (@{ $risk->{flags} }) {
2475
87
48
0
1
177
71
0
1377
                for my $f (@{ $risk->{flags} }) {
2476
73
1
120
6
                        push @out, "  [$f->{severity}] " . _sanitise_output($f->{detail});
2477                }
2478        } else {
2479
44
0
87
0
                push @out, '  (no specific red flags detected)';
2480        }
2481
76
1
94
1402
        push @out, '';
2482
2483        # Originating host section
2484
76
1
74
4
        push @out, '[ ORIGINATING HOST ]';
2485
76
1
125
2
        if(my $orig = $self->originating_ip()) {
2486
34
1
719
2
                push @out, '  IP           : ' . _sanitise_output($orig->{ip});
2487
34
1
75
6
                push @out, '  Reverse DNS  : ' . _sanitise_output($orig->{rdns})    if $orig->{rdns};
2488
34
0
51
0
                push @out, '  Country      : ' . _sanitise_output($orig->{country}) if $orig->{country};
2489
47
1
90
569
                push @out, '  Organisation : ' . _sanitise_output($orig->{org})     if $orig->{org};
2490
47
1
505
4
                push @out, '  Abuse addr   : ' . _sanitise_output($orig->{abuse})   if $orig->{abuse};
2491
34
1
50
2
                push @out, "  Confidence   : $orig->{confidence}";
2492
34
1
66
1
                push @out, '  Note         : ' . _sanitise_output($orig->{note})    if $orig->{note};
2493        } else {
2494
32
1
272
5
                push @out, '  (could not determine originating IP)';
2495        }
2496
76
0
74
0
        push @out, '';
2497
2498        # Sending software section (omitted if none found)
2499
76
1
177
493
        my @sw = $self->sending_software();
2500
63
1
79
7
        if (@sw) {
2501
5
0
5
0
                push @out, '[ SENDING SOFTWARE / INFRASTRUCTURE CLUES ]';
2502
5
1
49
6331
                for my $s (@sw) {
2503
5
1
8
1
                        push @out, sprintf('  %-14s : %s', $s->{header}, _sanitise_output($s->{value}));
2504
5
1
5
28
                        push @out, "  Note           : $s->{note}";
2505
5
1
33
757
                        push @out, '';
2506                }
2507        }
2508
2509        # Received chain tracking IDs (only hops with id or for are shown)
2510
63
52
1
1
132
126
2
18
        my @trail = grep { defined $_->{id} || defined $_->{for} }
2511                    $self->received_trail();
2512
63
1
139
1655
        if (@trail) {
2513
4
1
7
2
                push @out, '[ RECEIVED CHAIN TRACKING IDs ]';
2514
4
1
36
16
                push @out, '  (Supply these to the relevant ISP abuse team to trace the session)';
2515
17
1
80
2029
                push @out, '';
2516
17
1
20
2
                for my $hop (@trail) {
2517
17
1
19
14
                        push @out, '  IP           : ' . (_sanitise_output($hop->{ip}) // '(unknown)');
2518
4
1
49
1011
                        push @out, '  Envelope for : ' . _sanitise_output($hop->{for}) if $hop->{for};
2519
4
1
8
2
                        push @out, '  Server ID    : ' . _sanitise_output($hop->{id})  if $hop->{id};
2520
4
1
4
13
                        push @out, '';
2521                }
2522        }
2523
2524        # Embedded URLs section -- grouped by hostname
2525
63
1
285
3041
        push @out, '[ EMBEDDED HTTP/HTTPS URLs ]';
2526
63
1
98
2
        my @urls = $self->embedded_urls();
2527
63
1
78
16
        if (@urls) {
2528
34
1
203
3682
                my (%host_order, %host_meta, %host_paths);
2529
21
1
24
1
                my $seq = 0;
2530
21
1
23
11
                for my $u (@urls) {
2531
30
1
60
2060
                        my $h = $u->{host};
2532
30
1
389
2
                        unless (exists $host_order{$h}) {
2533
22
1
41
14
                                $host_order{$h} = $seq++;
2534                                $host_meta{$h}  = {
2535                                        ip      => $u->{ip},
2536                                        org     => $u->{org},
2537                                        abuse   => $u->{abuse},
2538                                        country => $u->{country},
2539
19
1
68
1488
                                };
2540                        }
2541
30
30
1
1
1175
61
1
14
                        push @{ $host_paths{$h} }, $u->{url};
2542                }
2543
2544                # Output each host group in first-seen order
2545
18
4
1
1
38
1006
696
1
                for my $h (sort { $host_order{$a} <=> $host_order{$b} } keys %host_order) {
2546
22
1
35
12
                        my $m    = $host_meta{$h};
2547
19
22
1
1
22
1017
1446
1
                        my $bare = lc $h; $bare =~ s/^www\.//;
2548                        push @out, '  Host         : ' . _sanitise_output($h) .
2549
22
1
31
19
                                   (($URL_SHORTENERS{$bare} || $self->{url_shorteners}->{$bare})
2550                                    ? '  *** URL SHORTENER -- real destination hidden ***' : '');
2551
21
1
39
940
                        push @out, '  IP           : ' . _sanitise_output($m->{ip})      if $m->{ip};
2552
22
1
832
1
                        push @out, '  Country      : ' . _sanitise_output($m->{country}) if $m->{country};
2553
22
1
55
13
                        push @out, '  Organisation : ' . _sanitise_output($m->{org})     if $m->{org};
2554
19
1
54
559
                        push @out, '  Abuse addr   : ' . _sanitise_output($m->{abuse})   if $m->{abuse};
2555
22
22
1
1
1438
29
1
8
                        my @paths = @{ $host_paths{$h} };
2556
22
1
34
967
                        if (@paths == 1) {
2557
16
1
20
1
                                push @out, '  URL          : ' . _sanitise_output($paths[0]);
2558                        } else {
2559
9
1
26
12
                                push @out, '  URLs (' . scalar(@paths) . ')     :';
2560
6
1
13
1094
                                push @out, '    ' . _sanitise_output($_) for @paths;
2561                        }
2562
22
1
963
1
                        push @out, '';
2563                }
2564        } else {
2565
45
1
81
15
                push @out, '  (none found)';
2566
42
1
41
1286
                push @out, '';
2567        }
2568
2569        # Contact / reply-to domains section
2570
63
1
17813
1
        push @out, '[ CONTACT / REPLY-TO DOMAINS ]';
2571
63
1
85
16
        my @mdoms = $self->mailto_domains();
2572
63
1
157
814
        if (@mdoms) {
2573
50
1
4259
1
                for my $d (@mdoms) {
2574
54
1
82
13
                        push @out, '  Domain       : ' . _sanitise_output($d->{domain});
2575
54
1
145
1394
                        push @out, '  Found in     : ' . _sanitise_output($d->{source});
2576
54
1
4846
1
                        if ($d->{recently_registered}) {
2577
5
1
9
16
                                push @out, '  *** WARNING: RECENTLY REGISTERED - possible phishing domain ***';
2578                        }
2579
54
1
118
1100
                        push @out, '  Registered   : ' . $d->{registered}       if $d->{registered};
2580
54
1
6455
1
                        push @out, '  Expires      : ' . $d->{expires}           if $d->{expires};
2581
54
1
108
18
                        push @out, '  Registrar    : ' . _sanitise_output($d->{registrar})       if $d->{registrar};
2582
54
1
110
2097
                        push @out, '  Reg. abuse   : ' . _sanitise_output($d->{registrar_abuse}) if $d->{registrar_abuse};
2583
54
1
3774
2
                        if ($d->{web_ip}) {
2584
19
1
31
12
                                push @out, '  Web host IP  : ' . _sanitise_output($d->{web_ip});
2585
19
1
80
1830
                                push @out, '  Web host org : ' . _sanitise_output($d->{web_org})   if $d->{web_org};
2586
19
1
9830
1
                                push @out, '  Web abuse    : ' . _sanitise_output($d->{web_abuse}) if $d->{web_abuse};
2587                        } else {
2588
38
1
43
17
                                push @out, '  Web host     : (no A record / unreachable)';
2589                        }
2590
54
1
96
2207
                        if ($d->{mx_host}) {
2591
6
1
12950
2
                                push @out, '  MX host      : ' . _sanitise_output($d->{mx_host});
2592
6
1
29
13
                                push @out, '  MX IP        : ' . _sanitise_output($d->{mx_ip})    if $d->{mx_ip};
2593
6
1
52
976
                                push @out, '  MX org       : ' . _sanitise_output($d->{mx_org})   if $d->{mx_org};
2594
6
1
6500
1
                                push @out, '  MX abuse     : ' . _sanitise_output($d->{mx_abuse}) if $d->{mx_abuse};
2595                        } else {
2596
51
1
52
13
                                push @out, '  MX host      : (none found)';
2597                        }
2598
54
1
136
926
                        if ($d->{ns_host}) {
2599
5
1
7032
2
                                push @out, '  NS host      : ' . _sanitise_output($d->{ns_host});
2600
5
1
10
12
                                push @out, '  NS IP        : ' . _sanitise_output($d->{ns_ip})    if $d->{ns_ip};
2601
5
1
47
1938
                                push @out, '  NS org       : ' . _sanitise_output($d->{ns_org})   if $d->{ns_org};
2602
5
1
4387
1
                                push @out, '  NS abuse     : ' . _sanitise_output($d->{ns_abuse}) if $d->{ns_abuse};
2603                        }
2604
54
1
64
13
                        push @out, '';
2605                }
2606        } else {
2607
16
1
51
1739
                push @out, '  (none found)';
2608
16
1
5039
1
                push @out, '';
2609        }
2610
2611        # Abuse contacts summary
2612
63
1
61
9
        push @out, '[ WHERE TO SEND ABUSE REPORTS ]';
2613
63
1
139
1638
        my @contacts = $self->abuse_contacts();
2614
63
1
4451
1
        if (@contacts) {
2615
36
1
36
9
                for my $c (@contacts) {
2616
51
1
109
2038
                        push @out, '  Role         : ' . _sanitise_output($c->{role});
2617
51
1
3987
1
                        push @out, '  Send to      : ' . _sanitise_output($c->{address});
2618
51
1
90
9
                        push @out, '  Note         : ' . _sanitise_output($c->{note}) if $c->{note};
2619
51
1
91
1482
                        push @out, "  Discovered   : $c->{via}";
2620
51
1
4746
1
                        push @out, '';
2621                }
2622        } else {
2623
30
1
35
9
                push @out, '  (no abuse contacts could be determined)';
2624
30
1
64
1207
                push @out, '';
2625        }
2626
2627        # Web-form contacts (providers that require manual form submission)
2628
63
1
4832
1
        my @form_cs = $self->form_contacts();
2629
63
1
75
10
        if (@form_cs) {
2630
6
1
44
2035
                push @out, '[ WHERE TO FILE WEB-FORM REPORTS ]';
2631
6
1
6039
1
                push @out, '  The following parties require manual submission via a web form.';
2632
6
1
8
15
                push @out, '  Open each URL in a browser, then follow the instructions below it.';
2633
6
1
41
1334
                push @out, '';
2634
6
1
5200
1
                for my $c (@form_cs) {
2635
6
1
9
9
                        push @out, '  Role         : ' . _sanitise_output($c->{role});
2636
6
1
42
1731
                        push @out, '  Form URL     : ' . _sanitise_output($c->{form});
2637
6
1
4047
1
                        push @out, '  Domain/URL   : ' . _sanitise_output($c->{form_domain}) if $c->{form_domain};
2638
6
1
11
46
                        push @out, '  Note         : ' . _sanitise_output($c->{note})        if $c->{note};
2639
6
1
46
740
                        if ($c->{form_paste}) {
2640                                # Word-wrap the paste hint at ROLE_WRAP_LEN characters
2641
6
1
4032
2
                                my $hint  = $c->{form_paste};
2642
6
1
17
10
                                my @words = split /\s+/, $hint;
2643
6
1
42
941
                                my (@lines, $line);
2644
6
1
5765
2
                                for my $w (@words) {
2645
93
1
103
10
                                        if (defined $line && length("$line $w") > $ROLE_WRAP_LEN) {
2646
9
1
43
1507
                                                push @lines, $line;
2647
9
1
4037
1
                                                $line = $w;
2648                                        } else {
2649
87
1
74
12
                                                $line = defined $line ? "$line $w" : $w;
2650                                        }
2651                                }
2652
6
1
53
1139
                                push @lines, $line if defined $line;
2653
6
1
4310
1
                                push @out, '  Paste        : ' . shift @lines if @lines;
2654
6
1
15
11
                                push @out, '                 ' . $_ for @lines;
2655                        }
2656
6
1
44
1063
                        push @out, '  Upload       : ' . _sanitise_output($c->{form_upload}) if $c->{form_upload};
2657
6
1
3823
1
                        push @out, '';
2658                }
2659        }
2660
2661
63
1
68
8
        push @out, '=' x 72;
2662
63
1
455
1028
        return join("\n", @out) . "\n";
2663}
2664
2665# -----------------------------------------------------------------------
2666# Private: output sanitisation
2667# -----------------------------------------------------------------------
2668
2669# _sanitise_output( $str ) -> $str
2670#
2671# Purpose:
2672#   Strip control characters that could affect terminal rendering or HTML
2673#   injection from any string that will appear in a report or abuse email.
2674#   Preserves printable ASCII, high-bytes (for UTF-8 content), tabs, and
2675#   line endings.
2676#
2677# Entry criteria:
2678#   $str -- a defined or undef scalar.
2679#
2680# Exit status:
2681#   Returns the sanitised string, or the empty string if $str is undef.
2682#
2683# Notes:
2684#   Only strips C0 control characters below 0x20 (except \t) and the DEL
2685#   character (0x7F).  High bytes (0x80-0xFF) are preserved because they
2686#   form valid UTF-8 multi-byte sequences in headers and body text.
2687
2688sub _sanitise_output :Private {
2689        my $str = $_[0];
2690        return '' unless defined $str;
2691        # Remove C0 controls (except tab) and DEL
2692        $str =~ s/[\x00-\x08\x0B\x0C\x0E-\x1F\x7F]//g;
2693        return $str;
2694
22
22
22
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
40482
24
232
5
37
4962
2
12
743
1
12
2102
1
14
779
1789
2
15
2014
2
14
1029
2
14
}
2695
2696# -----------------------------------------------------------------------
2697# Private: message parsing
2698# -----------------------------------------------------------------------
2699
2700# _split_message( $text )
2701#
2702# Purpose:
2703#   Split a raw RFC 2822 email into headers and body, parse all headers,
2704#   decode the body (including multipart), extract sending-software
2705#   fingerprints, and populate per-hop tracking data.
2706#
2707# Entry criteria:
2708#   $text -- defined scalar, already dereferenced by parse_email().
2709#   $self->{_sending_sw} and $self->{_rcvd_tracking} reset to [] by caller.
2710#
2711# Exit status:
2712#   Returns undef silently if the header block is empty/whitespace-only.
2713#   Otherwise all results are communicated via side effects on $self.
2714#
2715# Side effects:
2716#   Populates _headers, _received, _body_plain, _body_html, _sending_sw,
2717#   and _rcvd_tracking.
2718#
2719# Notes:
2720#   Delegates to _decode_multipart() for multipart/* content types.
2721#   Lines not matching the header pattern are silently discarded.
2722#   Boundary extraction uses a simple regex; missing boundary causes the
2723#   body to be skipped silently.
2724
2725sub _split_message :Private {
2726        my ($self, $text) = @_;
2727
2728        # Split at the first blank line (RFC 2822 header/body separator)
2729        my ($header_block, $body_raw) = split /\r?\n\r?\n/, $text, 2;
2730
2731        return unless defined $header_block && $header_block =~ /\S/;
2732        $body_raw //= '';
2733
2734        # Unfold RFC 2822 continuation lines (s2.2.3)
2735        $header_block =~ s/\r?\n([ \t]+)/ $1/g;
2736
2737        # Parse each header line into a { name, value } pair
2738        my @headers;
2739        for my $line (split /\r?\n/, $header_block) {
2740                if ($line =~ /^([\w-]+)\s*:\s*(.*)/) {
2741                        push @headers, { name => lc($1), value => $2 };
2742                }
2743        }
2744        $self->{_headers}  = \@headers;
2745
2746        # Collect all Received: header values (most-recent first, as in message)
2747        $self->{_received} = [
2748                map  { $_->{value} }
2749                grep { $_->{name} eq 'received' } @headers
2750        ];
2751
2752        # Determine content type and transfer encoding from top-level headers
2753        my ($ct_h)  = grep { $_->{name} eq 'content-type' }              @headers;
2754        my ($cte_h) = grep { $_->{name} eq 'content-transfer-encoding' } @headers;
2755        my $ct  = defined $ct_h  ? $ct_h->{value}  : '';
2756        my $cte = defined $cte_h ? $cte_h->{value} : '';
2757
2758        # Decode multipart or single-part body as appropriate
2759        if ($ct =~ /multipart/i) {
2760                my ($boundary) = $ct =~ /boundary="?([^";]+)"?/i;
2761                # Pass depth=0 to enforce the MAX_MULTIPART_DEPTH recursion guard
2762                $self->_decode_multipart($body_raw, $boundary, 0) if $boundary;
2763        } else {
2764                my $decoded = $self->_decode_body($body_raw, $cte);
2765                if ($ct =~ /html/i) { $self->{_body_html}  = $decoded }
2766                else                 { $self->{_body_plain} = $decoded }
2767        }
2768
2769        $self->_debug(sprintf 'Parsed %d headers, %d Received lines',
2770                scalar @headers, scalar @{ $self->{_received} });
2771
2772        # --- Sending software fingerprints ---
2773        # These headers identify the mailer or shared-hosting script that sent
2774        # the message; invaluable for shared-hosting abuse reports.
2775        my %sw_notes = (
2776                'x-php-originating-script' => 'PHP script on shared hosting -- report to hosting abuse team',
2777                'x-source'                 => 'Source file on shared hosting -- report to hosting abuse team',
2778                'x-source-host'            => 'Sending hostname injected by shared hosting provider',
2779                'x-source-args'            => 'Command-line args injected by shared hosting provider',
2780                'x-mailer'                 => 'Email client or bulk-mailer identifier',
2781                'user-agent'               => 'Email client identifier',
2782        );
2783        for my $sw_hdr (sort keys %sw_notes) {
2784                my ($h) = grep { $_->{name} eq $sw_hdr } @headers;
2785                next unless $h;
2786                push @{ $self->{_sending_sw} }, {
2787                        header => $sw_hdr,
2788                        value  => $h->{value},
2789                        note   => $sw_notes{$sw_hdr},
2790                };
2791        }
2792
2793        # --- Per-hop tracking IDs from Received: chain ---
2794        # Walk oldest-first (reverse) so _rcvd_tracking is oldest-first
2795        for my $rcvd (reverse @{ $self->{_received} }) {
2796                my $ip = $self->_extract_ip_from_received($rcvd);
2797                my ($for_addr) = $rcvd =~ /\bfor\s+<?([^\s>]+\@[\w.-]+\.[\w]+)>?/i;
2798                my ($srv_id)   = $rcvd =~ /\bid\s+([\w.-]+)/i;
2799                # Skip hops with no actionable tracking data
2800                next unless defined $ip || defined $for_addr || defined $srv_id;
2801                push @{ $self->{_rcvd_tracking} }, {
2802                        received => $rcvd,
2803                        ip       => $ip,
2804                        for      => $for_addr,
2805                        id       => $srv_id,
2806                };
2807        }
2808
22
22
22
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
15555
24
225
5
36
4809
2
12
556
1
19
1560
2
12
820
1068
2
12
962
1
18
1510
2
14
}
2809
2810# _decode_multipart( $body, $boundary, $depth )
2811#
2812# Purpose:
2813#   Recursively split a MIME multipart body on its boundary and decode each
2814#   text/plain and text/html part.  Nested multipart/* containers are
2815#   recursed into up to MAX_MULTIPART_DEPTH levels deep.
2816#
2817# Entry criteria:
2818#   $body     -- the raw body text of the multipart container.
2819#   $boundary -- the boundary string from the Content-Type header.
2820#   $depth    -- current recursion depth (starts at 0 from _split_message).
2821#
2822# Exit status:
2823#   Returns undef if $depth >= MAX_MULTIPART_DEPTH (recursion guard).
2824#   Otherwise all results via side effects.
2825#
2826# Side effects:
2827#   Appends decoded text to $self->{_body_plain} and $self->{_body_html}.
2828#
2829# Notes:
2830#   Whitespace-only MIME segments between boundaries are silently skipped.
2831#   Decoding errors are silenced; raw bytes are used as fallback.
2832
2833sub _decode_multipart :Private {
2834        my ($self, $body, $boundary, $depth) = @_;
2835        $depth //= 0;
2836
2837        # Enforce the recursion depth limit to prevent stack exhaustion on
2838        # pathological crafted messages with deeply nested multipart structures.
2839        if ($depth >= $MAX_MULTIPART_DEPTH) {
2840                Carp::carp 'Email::Abuse::Investigator: multipart nesting depth limit',
2841                        "($MAX_MULTIPART_DEPTH) exceeded; stopping recursion";
2842                return;
2843        }
2844
2845        # Split on the boundary marker; the (?:--)? suffix handles closing boundary
2846        my @parts = split /--\Q$boundary\E(?:--)?/, $body;
2847
2848        for my $part (@parts) {
2849                # Skip whitespace-only segments between boundaries
2850                next unless $part =~ /\S/;
2851
2852                $part =~ s/^\r?\n//;
2853
2854                # Each MIME part has its own headers separated from body by a blank line
2855                my ($phdr_block, $pbody) = split /\r?\n\r?\n/, $part, 2;
2856                next unless defined $pbody;
2857
2858                # Unfold continuation header lines within this part
2859                $phdr_block =~ s/\r?\n([ \t]+)/ $1/g;
2860
2861                # Parse this part's headers into a simple hash
2862                my %phdr;
2863                for my $line (split /\r?\n/, $phdr_block) {
2864                        $phdr{ lc($1) } = $2 if $line =~ /^([\w-]+)\s*:\s*(.*)/;
2865                }
2866
2867                my $pct  = $phdr{'content-type'}              // '';
2868                my $pcte = $phdr{'content-transfer-encoding'} // '';
2869
2870                # Nested multipart/* must be recursed into; without this URLs in
2871                # multipart/alternative inside multipart/mixed would be missed.
2872                if ($pct =~ /multipart/i) {
2873                        my ($inner_boundary) = $pct =~ /boundary\s*=\s*"?([^";]+)"?/i;
2874                        if ($inner_boundary) {
2875                                $inner_boundary =~ s/\s+$//;
2876                                # Increment depth counter for the recursion guard
2877                                $self->_decode_multipart($pbody, $inner_boundary, $depth + 1);
2878                        }
2879                        next;
2880                }
2881
2882                # Decode transfer encoding and accumulate by content type
2883                my $decoded = $self->_decode_body($pbody, $pcte);
2884                if    ($pct =~ /text\/html/i)    { $self->{_body_html}  .= $decoded }
2885                elsif ($pct =~ /text/i || !$pct) { $self->{_body_plain} .= $decoded }
2886        }
2887
22
22
22
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
11409
20
204
251
42
5651
2
12
1359
2
18
864
2
12
1420
2563
1
11
3218
1
14
3079
2
11
}
2888
2889# _decode_body( $body, $cte ) -> string
2890#
2891# Purpose:
2892#   Decode a MIME body part according to its Content-Transfer-Encoding.
2893#
2894# Entry criteria:
2895#   $body -- raw body string (may be undef).
2896#   $cte  -- Content-Transfer-Encoding value string (may be undef).
2897#
2898# Exit status:
2899#   Returns the decoded string, or the original string if the encoding is
2900#   7bit/8bit/binary or unrecognised.
2901#
2902# Notes:
2903#   decode_qp and decode_base64 are imported from MIME:: modules; errors
2904#   from malformed content are silenced by the eval wrappers they provide.
2905
2906sub _decode_body :Private {
2907        my ($self, $body, $cte) = @_;
2908        $cte //= '';
2909        return decode_qp($body)     if $cte =~ /quoted-printable/i;
2910        return decode_base64($body) if $cte =~ /base64/i;
2911        return $body // '';
2912
22
22
22
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
5376
20
188
3
41
3725
2
12
1464
1
10
1013
1
12
1243
3488
2
9
3763
2
16
2714
1
10
}
2913
2914# -----------------------------------------------------------------------
2915# Private: Received-chain -> originating IP
2916# -----------------------------------------------------------------------
2917
2918# _find_origin()
2919#
2920# Purpose:
2921#   Walk the Received: chain (oldest-first) to find the first external IP,
2922#   or fall back to X-Originating-IP.  Enrich with rDNS and WHOIS.
2923#
2924# Entry criteria:
2925#   $self->{_received} populated by _split_message().
2926#   $self->{trusted_relays} set by new().
2927#
2928# Exit status:
2929#   Returns { ip, rdns, org, abuse, country, confidence, note } on success.
2930#   Returns undef if no usable IP can be identified.
2931#
2932# Side effects:
2933#   Network I/O via _enrich_ip(): one PTR lookup, one RDAP/WHOIS query.
2934#   Results are also stored in the CHI cross-message cache if available.
2935#
2936# Notes:
2937#   confidence 'high' = 2+ distinct external IPs;
2938#   'medium' = exactly one external IP;
2939#   'low' = taken from X-Originating-IP.
2940
2941sub _find_origin :Private {
2942        my $self = $_[0];
2943
2944        my @candidates;
2945
2946        # Walk oldest-first (reverse) to collect external IPs
2947        for my $hdr (reverse @{ $self->{_received} }) {
2948                my $ip = $self->_extract_ip_from_received($hdr) // next;
2949                next if $self->_is_private($ip);
2950                next if $self->_is_trusted($ip);
2951                push @candidates, $ip;
2952        }
2953
2954        # Fall back to X-Originating-IP if no external IPs in Received: chain
2955        unless (@candidates) {
2956                my $xoip = $self->_header_value('x-originating-ip');
2957                if ($xoip) {
2958                        $xoip =~ s/[\[\]\s]//g;
2959                        return $self->_enrich_ip($xoip, 'low',
2960                                'Taken from X-Originating-IP (webmail, unverified)')
2961                                unless $self->_is_private($xoip);
2962                }
2963                return;
2964        }
2965
2966        # Report the oldest (first) external IP; confidence depends on count
2967        return $self->_enrich_ip(
2968                $candidates[0],
2969                @candidates > 1 ? 'high' : 'medium',
2970                'First external hop in Received: chain',
2971        );
2972
22
22
22
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
7651
20
189
4
30
4605
4
15
1232
1
11
1331
2
15
1563
1643
1
12
2078
2
13
896
1
11
}
2973
2974# _extract_ip_from_received( $hdr ) -> ipv4_or_ipv6_string | undef
2975#
2976# Purpose:
2977#   Extract the most-significant IP address from a raw Received: header
2978#   value, trying patterns in priority order.  Supports both IPv4 dotted-
2979#   quad and IPv6 bracket notation.
2980#
2981# Entry criteria:
2982#   $hdr -- a defined Received: header value string.
2983#
2984# Exit status:
2985#   Returns the IP string on success, undef if no IP can be extracted.
2986#
2987# Notes:
2988#   IPv4 addresses are validated (all octets <= 255).
2989#   IPv6 addresses are returned as-is if they contain colons.
2990
2991sub _extract_ip_from_received :Private {
2992        my ($self, $hdr) = @_;
2993        for my $re (@RECEIVED_IP_RE) {
2994                if ($hdr =~ $re) {
2995                        my $ip = $1;
2996
2997                        # Accept IPv6 addresses (contain colons) without further validation
2998                        return $ip if $ip =~ /:/;
2999
3000                        # Validate IPv4 format and octet range
3001                        next unless $ip =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/;
3002                        next if grep { $_ > 255 } split /\./, $ip;
3003                        return $ip;
3004                }
3005        }
3006        return;
3007
22
22
22
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
6645
23
185
3
36
4508
1
13
1915
1
12
1197
1
12
1694
1726
1
13
1618
2
15
1141
2
10
}
3008
3009# _is_private( $ip ) -> bool
3010#
3011# Purpose:
3012#   Test whether an IP address falls in any private, reserved, or special-
3013#   use range (IPv4 or IPv6) that should never be reported as a spam origin.
3014#
3015# Entry criteria:
3016#   $ip -- a scalar IP string (IPv4 or IPv6); may be undef.
3017#
3018# Exit status:
3019#   Returns 1 (true) if the IP is private/reserved, 0 (false) otherwise.
3020#   Returns 1 for undef or empty strings.
3021#
3022# Notes:
3023#   Uses the module-level @PRIVATE_RANGES array of pre-compiled regexes.
3024#   Covers all ranges listed in RFC 1122, 1918, 5737, 6598, and RFC 4193.
3025
3026sub _is_private :Private {
3027        my ($self, $ip) = @_;
3028        return 1 if !defined($ip) || $ip eq '';
3029        for my $re (@PRIVATE_RANGES) { return 1 if $ip =~ $re }
3030        return 0;
3031
22
22
22
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
5329
25
194
6
34
3125
1
15
1133
1
11
2049
1
14
1016
753
2
9
800
2
15
1374
2
9
}
3032
3033# _is_trusted( $ip ) -> bool
3034#
3035# Purpose:
3036#   Test whether an IP address matches any entry in the caller-supplied
3037#   trusted_relays list (exact IP or CIDR block).
3038#
3039# Entry criteria:
3040#   $ip -- a defined IPv4 address string.
3041#   $self->{trusted_relays} -- arrayref of exact IPs or CIDR strings.
3042#
3043# Exit status:
3044#   Returns 1 (true) if the IP matches any trusted relay, 0 otherwise.
3045
3046sub _is_trusted :Private {
3047        my ($self, $ip) = @_;
3048        for my $cidr (@{ $self->{trusted_relays} }) {
3049                return 1 if $self->_ip_in_cidr($ip, $cidr);
3050        }
3051        return 0;
3052
22
22
22
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
4985
24
198
5
35
5254
2
13
970
2
11
2302
2
12
883
1393
1
17
1465
2
13
780
0
9
}
3053
3054# -----------------------------------------------------------------------
3055# Private: HTTP/HTTPS URL extraction and resolution
3056# -----------------------------------------------------------------------
3057
3058# _extract_and_resolve_urls() -> arrayref of url hashrefs
3059#
3060# Purpose:
3061#   Extract all HTTP/HTTPS URLs from the decoded body, resolve each unique
3062#   hostname to an IP, and enrich with WHOIS/RDAP data.  Optionally uses
3063#   AnyEvent::DNS to parallelise the DNS resolution step.
3064#
3065# Entry criteria:
3066#   $self->{_body_plain} and $self->{_body_html} populated by _split_message().
3067#
3068# Exit status:
3069#   Returns an arrayref of url hashrefs (possibly empty).
3070#
3071# Side effects:
3072#   Network I/O per unique hostname: one A/AAAA lookup, one RDAP/WHOIS.
3073#   Results stored in the CHI cross-message cache if available.
3074
3075sub _extract_and_resolve_urls :Private {
3076        my $self = $_[0];
3077        my (%url_seen, %host_cache);
3078        my @results;
3079        my $combined = $self->{_body_plain} . "\n" . $self->{_body_html};
3080
3081        # Collect unique URLs from body
3082        my @urls = grep { !$url_seen{$_}++ } $self->_extract_http_urls($combined);
3083
3084        # For URL-shortener and redirect-cloaker hosts, follow the redirect chain to
3085        # discover the real destination (e.g. GCS bucket → phishing landing page).
3086        # Done before DNS resolution so that destination hostnames can be parallelised.
3087        # _follow_redirect_chain() is a :Protected seam that handles LWP availability
3088        # internally — do not guard this block with $HAS_LWP so the seam can be
3089        # stubbed unconditionally in tests regardless of whether LWP is installed.
3090        for my $url (@urls) {
3091                my ($host) = $url =~ m{https?://([^/:?\s#]+)}i;
3092                next unless $host;
3093                my $bare = lc $host;
3094                $bare =~ s/^www\.//;
3095                next unless $URL_SHORTENERS{$bare}
3096                         || ($self->{url_shorteners} && $self->{url_shorteners}{$bare})
3097                         || $self->_is_redirect_cloaker($bare);
3098                my $dest = $self->_follow_redirect_chain($url);
3099                next unless defined $dest && !$url_seen{$dest}++;
3100                push @urls, $dest;
3101        }
3102
3103        # Extract unique hostnames for parallel DNS resolution (including redirect destinations)
3104        my %hostname_needed;
3105        for my $url (@urls) {
3106                my ($host) = $url =~ m{https?://([^/:?\s#]+)}i;
3107                $hostname_needed{$host}++ if $host;
3108        }
3109
3110        # Parallelise DNS lookups if AnyEvent::DNS is available
3111        if ($HAS_ANYEVENT_DNS && scalar(keys %hostname_needed) > 1) {
3112                $self->_parallel_resolve_hosts(\%hostname_needed, \%host_cache);
3113        }
3114
3115        # Process each URL: resolve hostname and WHOIS-enrich
3116        for my $url (@urls) {
3117                my ($host) = $url =~ m{https?://([^/:?\s#]+)}i;
3118                next unless $host;
3119
3120                # Resolve and WHOIS once per unique hostname, then cache the result
3121                unless (exists $host_cache{$host}) {
3122                        # Check the cross-message CHI cache first
3123                        my $cached = $_cache ? $_cache->get("url:$host") : undef;
3124                        if ($cached) {
3125                                $host_cache{$host} = $cached;
3126                        } else {
3127                                my $ip    = $self->_resolve_host($host) // '(unresolved)';
3128                                my $whois = $ip ne '(unresolved)'
3129                                          ? $self->_whois_ip($ip)
3130                                          : {};
3131
3132                                # Fall back to domain WHOIS if IP lookup returned nothing
3133                                if (!$whois->{abuse}) {
3134                                        my $reg = _registrable($host) // $host;
3135                                        my $dw  = $self->_parse_domain_whois_abuse($reg);
3136                                        $whois  = $dw if $dw->{abuse};
3137                                }
3138
3139                                my $entry = {
3140                                        ip      => $ip,
3141                                        org     => $whois->{org}     // '(unknown)',
3142                                        abuse   => $whois->{abuse}   // '(unknown)',
3143                                        country => $whois->{country} // undef,
3144                                };
3145                                $host_cache{$host} = $entry;
3146
3147                                # Store in cross-message cache for reuse across messages
3148                                $_cache->set("url:$host", $entry) if $_cache;
3149                        }
3150                }
3151
3152                push @results, { url => $url, host => $host, %{ $host_cache{$host} } };
3153        }
3154        return \@results;
3155
22
22
22
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
11883
33
217
5
40
4498
2
11
1912
7
18
870
1
13
1660
690
1
15
1020
1
12
1243
1
9
}
3156
3157# _is_redirect_cloaker( $bare_host ) -> bool
3158#
3159# Purpose:
3160#   Return true if $bare_host is a known cloud-storage or CDN host that is
3161#   commonly abused to serve client-side redirect pages hiding the real
3162#   phishing destination.  Checks the exact-match %REDIRECT_HOSTS table and
3163#   the suffix patterns in @REDIRECT_HOST_SUFFIXES.
3164#
3165# Entry criteria:
3166#   $bare_host -- lowercase hostname with any leading "www." already stripped.
3167#
3168# Exit status:
3169#   Returns 1 (true) or empty string (false).
3170
3171sub _is_redirect_cloaker :Private {
3172        my (undef, $host) = @_;
3173        return 1 if $REDIRECT_HOSTS{$host};
3174        for my $suffix (@REDIRECT_HOST_SUFFIXES) {
3175                return 1 if length($host) > length($suffix)
3176                         && substr($host, -length($suffix)) eq $suffix;
3177        }
3178        return '';
3179
22
22
22
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
6350
40
188
4
41
3868
1
14
1126
2
12
1260
1202
14
813
1066
1
9
490
1
13
1599
1
9
}
3180
3181# _follow_redirect_chain( $url ) -> $final_url | undef
3182#
3183# Purpose:
3184#   Follow up to $REDIRECT_MAX_HOPS HTTP hops for a given URL and return the
3185#   final destination.  Detects HTTP 3xx Location: redirects, HTML
3186#   <meta http-equiv="refresh" content="...url=..."> tags, and
3187#   window.location.replace() / window.location.href JavaScript patterns.
3188#   Used to expose the real phishing landing page hidden behind a cloud
3189#   object-store redirect page (e.g. a GCS bucket containing only a
3190#   meta-refresh pointing to the attacker-controlled domain).
3191#
3192# Entry criteria:
3193#   $url  -- an https?:// URL string whose host has already been identified
3194#             as a URL shortener or redirect cloaker.
3195#   LWP::UserAgent must be installed ($HAS_LWP must be true).
3196#
3197# Exit status:
3198#   Returns the first URL that differs from the input after following the
3199#   chain, or undef if no redirect was found or LWP is unavailable.
3200#   Never returns the input $url unchanged.
3201#
3202# Side effects:
3203#   Up to $REDIRECT_MAX_HOPS HTTP GET requests.
3204#   Successful result cached in the cross-message CHI cache keyed
3205#   "redirect:<url>" to avoid re-fetching across messages.
3206
3207sub _follow_redirect_chain :Protected {
3208        my ($self, $url) = @_;
3209        return undef unless $HAS_LWP;
3210
3211        # Serve from cache when available
3212        if ($_cache) {
3213                my $cached = $_cache->get("redirect:$url");
3214                return $cached if defined $cached;
3215        }
3216
3217        # Dedicated no-follow UA so we can inspect each redirect hop manually.
3218        # Stored separately from the RDAP UA ($self->{ua}) which needs auto-follow.
3219        unless (defined $self->{_ua_nofollow}) {
3220                my $ua = LWP::UserAgent->new(
3221                        timeout      => $self->{timeout},
3222                        agent        => "Email-Abuse-Investigator/$VERSION",
3223                        max_redirect => 0,
3224                );
3225                if ($HAS_CONN_CACHE) {
3226                        my $cc = LWP::ConnCache->new();
3227                        $cc->total_capacity(4);
3228                        $ua->conn_cache($cc);
3229                }
3230                $ua->env_proxy(1);
3231                $self->{_ua_nofollow} = $ua;
3232        }
3233        my $ua = $self->{_ua_nofollow};
3234
3235        my $current = $url;
3236        my $final;
3237        for my $hop (1 .. $REDIRECT_MAX_HOPS) {
3238                my $res = eval { $ua->get($current) };
3239                last unless $res;
3240
3241                if ($res->is_redirect()) {
3242                        # HTTP 3xx: extract Location header
3243                        my $loc = $res->header('Location');
3244                        last unless defined $loc;
3245
3246                        # Resolve relative Location URLs against the current base
3247                        if ($loc !~ m{^https?://}i) {
3248                                require URI;
3249                                $loc = URI->new_abs($loc, $current)->as_string();
3250                        }
3251                        $final   = $loc;
3252                        $current = $loc;
3253                } elsif ($res->is_success()) {
3254                        # 2xx: inspect body for client-side redirect patterns
3255                        my $body = $res->decoded_content() // '';
3256                        my $dest;
3257
3258                        # <meta http-equiv="refresh" content="N; url=https://...">
3259                        if ($body =~ m{<meta[^>]+http-equiv\s*=\s*["']?refresh["']?[^>]+
3260                                        content\s*=\s*["'][^"']*url\s*=\s*(https?://[^"'\s>]+)}xi) {
3261                                $dest = $1;
3262                        }
3263                        # window.location.replace("...") or window.location.href = "..."
3264                        elsif ($body =~ m{window\.location(?:\.replace\s*\(\s*|\.href\s*=\s*)
3265                                           ["'](https?://[^"']+)["']}xi) {
3266                                $dest = $1;
3267                        }
3268
3269                        last unless defined $dest;
3270                        $final   = $dest;
3271                        $current = $dest;
3272                } else {
3273                        last;
3274                }
3275        }
3276
3277        # Cache for reuse across messages in this session
3278        $_cache->set("redirect:$url", $final) if $_cache && defined $final;
3279
3280        return $final;
3281
22
22
22
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
11716
22
244
5
40
4326
2
12
1487
1
14
455
1
12
1544
484
1
9
1073
1
12
1106
1
9
}
3282
3283# _parallel_resolve_hosts( \%hostnames, \%cache )
3284#
3285# Purpose:
3286#   Resolve multiple hostnames to IPs in parallel using AnyEvent::DNS.
3287#   Populates the cache with resolved IPs so the sequential loop in
3288#   _extract_and_resolve_urls() can skip the DNS step for pre-resolved hosts.
3289#
3290# Entry criteria:
3291#   $hostnames_ref -- hashref keyed by hostname (values ignored).
3292#   $cache_ref     -- hashref to populate with { ip => '...' } results.
3293#   AnyEvent::DNS must be installed ($HAS_ANYEVENT_DNS is true).
3294#
3295# Exit status:
3296#   Returns undef; all results written to %$cache_ref via side effects.
3297#
3298# Notes:
3299#   Errors (NXDOMAIN, timeout) are silently swallowed; the sequential
3300#   resolution loop will return '(unresolved)' for those hosts.
3301
3302sub _parallel_resolve_hosts :Private {
3303        my ($self, $hostnames_ref, $cache_ref) = @_;
3304        # Guard both conditions together: an empty hash must never reach condvar
3305        # creation because $cv->recv would block forever with $pending == 0.
3306        return unless $HAS_ANYEVENT_DNS && %$hostnames_ref;
3307
3308        # Build an AnyEvent condvar to wait for all lookups to complete
3309        my $cv      = AnyEvent->condvar;
3310        my $pending = scalar keys %$hostnames_ref;
3311
3312        # AnyEvent::DNS::resolve is a method, not a standalone function.
3313        # Use the global resolver singleton; passing a bare string as the
3314        # first arg would make Perl treat the hostname as the invocant.
3315        my $resolver = AnyEvent::DNS::resolver();
3316
3317        for my $host (keys %$hostnames_ref) {
3318                # Fire an async A query for each hostname
3319                $resolver->resolve(
3320                        $host, 'a',
3321                        sub {
3322                                my @answers = @_;
3323                                if (@answers) {
3324                                        # Cache the first A record result
3325                                        $cache_ref->{$host} = { ip => $answers[0][4] };
3326                                }
3327                                # Decrement the pending counter; signal when all done
3328                                $cv->send if --$pending <= 0;
3329                        },
3330                );
3331        }
3332
3333        # Block until all DNS queries complete (subject to AnyEvent's own timeouts)
3334        $cv->recv;
3335
22
22
22
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
6818
19
193
3
27
4899
2
11
719
1
8
1472
1
12
835
1148
2
13
987
2
10
1650
1
13
}
3336
3337# _extract_http_urls( $body ) -> list of url strings
3338#
3339# Purpose:
3340#   Extract all HTTP and HTTPS URLs from a body string, using both
3341#   structural HTML parsing (if HTML::LinkExtor is available) and a
3342#   plain-text regex pass.  Deduplicates and strips trailing punctuation.
3343#
3344# Entry criteria:
3345#   $body -- combined plain+HTML body string.
3346#
3347# Exit status:
3348#   Returns a list of URL strings (possibly empty), deduplicated.
3349
3350sub _extract_http_urls :Private {
3351        my ($self, $body) = @_;
3352        my @urls;
3353
3354        # Structural HTML link extraction (handles quoted attributes correctly)
3355        if ($HAS_HTML_LINKEXTOR) {
3356                my $p = HTML::LinkExtor->new(sub {
3357                        my ($tag, %attrs) = @_;
3358                        for my $attr (qw(href src action)) {
3359                                my $val = $attrs{$attr} // '';
3360                                if ($val =~ m{^https?://}i) {
3361                                        push @urls, $val;
3362                                } elsif ($val =~ m{^//[\w.-]}) {
3363                                        # Protocol-relative -- assume https
3364                                        push @urls, 'https:' . $val;
3365                                }
3366                        }
3367                });
3368                $p->parse($body);
3369        }
3370
3371        # Plain-text regex pass for bare URLs not in HTML attributes
3372        while ($body =~ m{(https?://[^\s<>"'\)\]]+)}gi) {
3373                push @urls, $1;
3374        }
3375
3376        # Protocol-relative URLs not caught above
3377        while ($body =~ m{(?:^|[\s"'=])(//[\w.-][^\s<>"'\)\]]*)}gim) {
3378                push @urls, 'https:' . $1;
3379        }
3380
3381        # Deduplicate and strip trailing punctuation
3382        my %seen;
3383        my @all = grep { !$seen{$_}++ } @urls;
3384        s/[.,;:!?\)>\]]+$// for @all;
3385        return @all;
3386
22
22
22
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
10784
20
318
3
36
3617
1
12
784
2
13
1522
1
13
645
1585
1
9
1173
1
12
832
1
9
}
3387
3388# -----------------------------------------------------------------------
3389# Private: domain extraction and full analysis
3390# -----------------------------------------------------------------------
3391
3392# _extract_and_analyse_domains() -> arrayref of domain hashrefs
3393#
3394# Purpose:
3395#   Collect all non-infrastructure contact domains from headers and body,
3396#   run the full domain intelligence pipeline on each, and return an arrayref
3397#   suitable for storage in $self->{_mailto_domains}.
3398#
3399# Entry criteria:
3400#   _split_message() must have been called.
3401#
3402# Exit status:
3403#   Always returns an arrayref; never undef.
3404#
3405# Side effects:
3406#   Network I/O per domain via _analyse_domain().
3407#   Results stored in $self->{_domain_info} and CHI cache.
3408
3409sub _extract_and_analyse_domains :Private {
3410        my $self = $_[0];
3411        my (%seen, @domains_with_source);
3412
3413        # Build a set of recipient domains to exclude (victims, not senders)
3414        my %recipient_domains;
3415        for my $hname (qw(to cc)) {
3416                my $val = $self->_header_value($hname) // next;
3417                for my $dom ($self->_domains_from_text($val)) {
3418                        my $reg = _registrable($dom) // $dom;
3419                        $recipient_domains{$dom}++;
3420                        $recipient_domains{$reg}++;
3421                }
3422        }
3423
3424        # Also exclude domains from Received: "for" envelope recipients
3425        for my $hop (@{ $self->{_rcvd_tracking} }) {
3426                next unless $hop->{for} && $hop->{for} =~ /\@([\w.-]+)/;
3427                my $dom = lc $1;
3428                my $reg = _registrable($dom) // $dom;
3429                $recipient_domains{$dom}++;
3430                $recipient_domains{$reg}++;
3431        }
3432
3433        # Inner closure: record a domain if it passes all filters
3434        my $record = sub {
3435                my ($dom, $source) = @_;
3436                $dom = lc $dom;
3437                $dom =~ s/\.$//;
3438                next if $self->{trusted_domains}->{$dom};
3439                return if $TRUSTED_DOMAINS{$dom};
3440                return if $recipient_domains{$dom};
3441                return if $recipient_domains{ _registrable($dom) // $dom };
3442                # Discard non-routable hostnames (single-label, pseudo-TLDs, etc.)
3443                return unless $dom =~ /\.[a-zA-Z]{2,}$/;
3444                return if $dom =~ /\.(?:local|internal|lan|localdomain|arpa)$/i;
3445                return if $seen{$dom}++;
3446                push @domains_with_source, { domain => $dom, source => $source };
3447        };
3448
3449        # Collect from standard sender/reply headers
3450        my %header_sources = (
3451                'from'        => 'From: header',
3452                'reply-to'    => 'Reply-To: header',
3453                'return-path' => 'Return-Path: header',
3454                'sender'      => 'Sender: header',
3455        );
3456        for my $hname (sort keys %header_sources) {
3457                my $val = $self->_header_value($hname) // next;
3458                $record->($_, $header_sources{$hname})
3459                        for $self->_domains_from_text($val);
3460        }
3461
3462        # Message-ID domain often reveals the real bulk-sending platform
3463        my $mid = $self->_header_value('message-id');
3464        if ($mid && $mid =~ /\@([\w.-]+)/) {
3465                my $mid_dom = lc $1;
3466                my $mid_reg = _registrable($mid_dom) // $mid_dom;
3467                $record->($mid_dom, 'Message-ID: header')
3468                        unless $TRUSTED_DOMAINS{$mid_dom} || $TRUSTED_DOMAINS{$mid_reg} || $self->{trusted_domains}->{$mid_dom} || $self->{trusted_domains}->{$mid_reg};
3469        }
3470
3471        # DKIM signing domain(s) -- the organisation that vouches for the message
3472        my $auth = $self->_parse_auth_results_cached();
3473        for my $dkim_d (@{ $auth->{dkim_domains} // [] }) {
3474                $record->($dkim_d, 'DKIM-Signature: d= (signing domain)');
3475        }
3476
3477        # List-Unsubscribe identifies the ESP or bulk sender
3478        my $unsub = $self->_header_value('list-unsubscribe');
3479        if ($unsub) {
3480                while ($unsub =~ m{https?://([^/:?\s>]+)}gi) {
3481                        $record->(lc $1, 'List-Unsubscribe: header');
3482                }
3483                while ($unsub =~ m{mailto:[^@\s>]+\@([\w.-]+)}gi) {
3484                        $record->(lc $1, 'List-Unsubscribe: header');
3485                }
3486        }
3487
3488        # Body email addresses (mailto: and bare user@domain forms)
3489        my $combined = $self->{_body_plain} . "\n" . $self->{_body_html};
3490        $record->($_, 'email address / mailto in body')
3491                for $self->_domains_from_text($combined);
3492
3493        # Run the full intelligence pipeline on each collected domain
3494        my @results;
3495        for my $entry (@domains_with_source) {
3496                my $info = $self->_analyse_domain($entry->{domain});
3497                push @results, { %$entry, %$info };
3498        }
3499        return \@results;
3500
22
22
22
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
14716
22
214
4
32
5467
1
13
1099
1
15
1993
2
13
1341
1326
2
13
889
2
12
1907
5
14
}
3501
3502# _domains_from_text( $text ) -> list of domain strings
3503#
3504# Purpose:
3505#   Extract unique domain names from mailto: links and bare user@domain
3506#   addresses in a block of text.
3507#
3508# Entry criteria:
3509#   $text -- a defined scalar of decoded body or header text.
3510#
3511# Exit status:
3512#   Returns a list of lower-cased domain strings (possibly empty).
3513
3514sub _domains_from_text :Private {
3515        my ($self, $text) = @_;
3516        my (%seen, @out);
3517
3518        # mailto: links (including HTML-entity-encoded @ signs from QP)
3519        while ($text =~ /mailto:(?:[^@\s<>"]+)@([\w.-]+)/gi) {
3520                my $dom = lc $1; $dom =~ s/\.$//;
3521                push @out, $dom unless $seen{$dom}++;
3522        }
3523
3524        # Bare user@domain patterns
3525        while ($text =~ /\b[\w.+%-]+@([\w.-]+\.[a-zA-Z]{2,})\b/g) {
3526                my $dom = lc $1; $dom =~ s/\.$//;
3527                push @out, $dom unless $seen{$dom}++;
3528        }
3529        return @out;
3530
22
22
22
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
10118
21
195
4
34
4139
3
12
914
1
10
1065
1
14
1378
1520
1
16
1324
1
11
769
2
8
}
3531
3532# _analyse_domain( $domain ) -> hashref
3533#
3534# Purpose:
3535#   Run the complete intelligence pipeline for a single domain: A record
3536#   (web hosting), MX record (mail hosting), NS record (DNS hosting),
3537#   and WHOIS (registrar, creation/expiry dates, abuse contact).
3538#   Each IP is enriched via RDAP/WHOIS.  Results are cached per domain
3539#   in $self->{_domain_info} and in the CHI cross-message cache.
3540#
3541# Entry criteria:
3542#   $domain -- lower-cased, no trailing dot, not in TRUSTED_DOMAINS.
3543#   $self->{timeout} used for all network operations.
3544#
3545# Exit status:
3546#   Always returns a hashref reference; never undef; may be empty ({}).
3547#   Possible keys: web_ip, web_org, web_abuse, mx_host, mx_ip, mx_org,
3548#   mx_abuse, ns_host, ns_ip, ns_org, ns_abuse, registrar,
3549#   registrar_abuse, registered, expires, recently_registered, whois_raw.
3550#
3551# Side effects:
3552#   Network I/O; writes result to $self->{_domain_info}{$domain} and CHI.
3553#
3554# Notes:
3555#   MX/NS lookups require Net::DNS; absent without it.
3556#   recently_registered is set to 1 (not 0) when the threshold is met.
3557#   whois_raw is truncated to WHOIS_RAW_MAX bytes.
3558
3559sub _analyse_domain :Private {
3560        my ($self, $domain) = @_;
3561
3562        # Return the per-message cached result if already analysed
3563        return $self->{_domain_info}{$domain}
3564                if $self->{_domain_info}{$domain};
3565
3566        # Check the cross-message CHI cache before hitting the network
3567        if ($_cache) {
3568                my $cached = $_cache->get("dom:$domain");
3569                if ($cached) {
3570                        $self->{_domain_info}{$domain} = $cached;
3571                        return $cached;
3572                }
3573        }
3574
3575        $self->_debug("Analysing domain: $domain");
3576        my %info;
3577
3578        # --- A record -> web hosting IP ---
3579        my $web_ip = $self->_resolve_host($domain);
3580        if ($web_ip) {
3581                $info{web_ip} = $web_ip;
3582                my $w = $self->_whois_ip($web_ip);
3583                $info{web_org}   = $w->{org}   if $w->{org};
3584                $info{web_abuse} = $w->{abuse} if $w->{abuse};
3585        }
3586
3587        # MX and NS lookups require Net::DNS
3588        if ($HAS_NET_DNS) {
3589                my $res = Net::DNS::Resolver->new(
3590                        tcp_timeout => $self->{timeout},
3591                        udp_timeout => $self->{timeout},
3592                );
3593
3594                # --- MX record -> mail hosting ---
3595                if(my $mxq = $res->search($domain, 'MX')) {
3596                        my ($best) = sort { $a->preference <=> $b->preference }
3597                                     grep { $_->type eq 'MX' } $mxq->answer;
3598                        if ($best) {
3599                                (my $mx_host = lc $best->exchange) =~ s/\.$//;
3600                                $info{mx_host} = $mx_host;
3601                                my $mx_ip = $self->_resolve_host($mx_host);
3602                                if ($mx_ip) {
3603                                        $info{mx_ip} = $mx_ip;
3604                                        my $mw = $self->_whois_ip($mx_ip);
3605                                        $info{mx_org}   = $mw->{org}   if $mw->{org};
3606                                        $info{mx_abuse} = $mw->{abuse} if $mw->{abuse};
3607                                }
3608                        }
3609                }
3610
3611                # --- NS record -> DNS hosting ---
3612                if(my $nsq = $res->search($domain, 'NS')) {
3613                        # Sort alphabetically so DNS round-robin ordering never changes which
3614                        # nameserver we record -- both runs of the same domain always agree.
3615                        my ($first) = sort { $a->nsdname cmp $b->nsdname } grep { $_->type eq 'NS' } $nsq->answer;
3616                        if ($first) {
3617                                (my $ns_host = lc $first->nsdname) =~ s/\.$//;
3618                                $info{ns_host} = $ns_host;
3619                                my $ns_ip = $self->_resolve_host($ns_host);
3620                                if ($ns_ip) {
3621                                        $info{ns_ip} = $ns_ip;
3622                                        my $nw = $self->_whois_ip($ns_ip);
3623                                        $info{ns_org}   = $nw->{org}   if $nw->{org};
3624                                        $info{ns_abuse} = $nw->{abuse} if $nw->{abuse};
3625                                }
3626                        }
3627                }
3628        }
3629
3630        # --- Domain WHOIS -> registrar + dates ---
3631        if(my $domain_whois = $self->_domain_whois($domain)) {
3632                # Truncate raw WHOIS for storage but parse structured fields from full text
3633                $info{whois_raw} = substr($domain_whois, 0, $WHOIS_RAW_MAX);
3634
3635                # Registrar name
3636                if ($domain_whois =~ /Registrar:\s*(.+)/i) {
3637                        ($info{registrar} = $1) =~ s/\s+$//;
3638                }
3639
3640                # Registrar abuse contact email (try multiple field names)
3641                for my $pat (
3642                        qr/Registrar Abuse Contact Email:\s*(\S+@\S+)/i,
3643                        qr/Abuse Contact Email:\s*(\S+@\S+)/i,
3644                        qr/abuse-contact:\s*(\S+@\S+)/i,
3645                ) {
3646                        if (!$info{registrar_abuse} && $domain_whois =~ $pat) {
3647                                ($info{registrar_abuse} = $1) =~ s/\s+$//;
3648                        }
3649                }
3650
3651                # Domain creation date (multiple registrar field name variations)
3652                for my $pat (
3653                        qr/Creation Date:\s*(\S+)/i,
3654                        qr/Created(?:\s+On)?:\s*(\S+)/i,
3655                        qr/Registration Time:\s*(\S+)/i,
3656                        qr/^registered:\s*(\S+)/im,
3657                ) {
3658                        if (!$info{registered} && $domain_whois =~ $pat) {
3659                                ($info{registered} = $1) =~ s/[TZ].*//;
3660                        }
3661                }
3662
3663                # Domain expiry date
3664                for my $pat (
3665                        qr/Registry Expiry Date:\s*(\S+)/i,
3666                        qr/Expir(?:y|ation)(?: Date)?:\s*(\S+)/i,
3667                        qr/paid-till:\s*(\S+)/i,
3668                ) {
3669                        if (!$info{expires} && $domain_whois =~ $pat) {
3670                                ($info{expires} = $1) =~ s/[TZ].*//;
3671                        }
3672                }
3673
3674                # Flag recently-registered domains (< RECENT_REG_DAYS old)
3675                if ($info{registered}) {
3676                        my $epoch = $self->_parse_date_to_epoch($info{registered});
3677                        $info{recently_registered} = 1
3678                                if $epoch && (time() - $epoch) < $RECENT_REG_DAYS * $SECS_PER_DAY;
3679                }
3680        }
3681
3682        # Store in per-message and cross-message caches
3683        $self->{_domain_info}{$domain} = \%info;
3684        $_cache->set("dom:$domain", \%info) if $_cache;
3685
3686        return \%info;
3687
22
22
22
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
18110
23
217
6
38
2659
1
13
1050
1
16
1296
1
10
1249
964
1
18
1121
1
14
1707
2
8
}
3688
3689# -----------------------------------------------------------------------
3690# Private: DNS helpers
3691# -----------------------------------------------------------------------
3692
3693# _resolve_host( $host ) -> ip_string | undef
3694#
3695# Purpose:
3696#   Resolve a hostname to an IPv4 (or IPv6) address.  Uses Net::DNS for
3697#   both A and AAAA queries when available; falls back to inet_aton for
3698#   pure IPv4 resolution.
3699#
3700# Entry criteria:
3701#   $host -- hostname string or already-numeric IP.
3702#
3703# Exit status:
3704#   Returns the first resolved IP string, or undef on failure.
3705#
3706# Notes:
3707#   When the input is already a dotted-quad IPv4 it is returned immediately.
3708#   AAAA records are tried if the A query fails and Net::DNS is available.
3709
3710sub _resolve_host :Protected {
3711
575
894
        my ($self, $host) = @_;
3712
575
5310
        return $host if $host =~ /^\d{1,3}(?:\.\d{1,3}){3}$/;
3713
3714        # Check the CHI cache before hitting DNS
3715
649
527
        if ($_cache) {
3716
1938
1862
                my $cached_ip = $_cache->get("resolve:$host");
3717
361
5486
                return $cached_ip if defined $cached_ip;
3718        }
3719
3720
159
276
        my $ip;
3721
3722
523
785
        if ($HAS_NET_DNS) {
3723                my $res = Net::DNS::Resolver->new(
3724                        tcp_timeout => $self->{timeout},
3725                        udp_timeout => $self->{timeout},
3726
399
5487
                );
3727
3728                # Try A record first, then AAAA for IPv6
3729
153
186
                for my $type (qw(A AAAA)) {
3730
94
148
                        my $query = $res->search($host, $type);
3731
152
3892
                        if ($query) {
3732
399
356
                                for my $rr ($query->answer) {
3733
149
164
                                        if ($rr->type eq 'A') {
3734
517
3477
                                                $ip = $rr->address;
3735
219
202
                                                last;
3736                                        } elsif ($rr->type eq 'AAAA') {
3737
459
373
                                                $ip = $rr->address;
3738
100
4482
                                                last;
3739                                        }
3740                                }
3741                        }
3742
159
134
                        last if defined $ip;
3743                }
3744        } else {
3745                # Fallback: gethostbyname (IPv4 only)
3746
101
87
133
72205
                my $packed = eval { inet_aton($host) };
3747
29
94
                $ip = $packed ? inet_ntoa($packed) : undef;
3748        }
3749
3750        # Cache the result (including undef as '' to avoid repeated failed lookups)
3751
162
234
        if ($_cache) {
3752
94
3948
                $_cache->set("resolve:$host", $ip // '');
3753        }
3754
3755
85
104
        return $ip;
3756
22
22
22
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
8658
26
196
3
30
5861
2
11
1139
1
10
1215
1
21
1138
1593
2
14
2130
2
12
1032
2
13
}
3757
3758# _reverse_dns( $ip ) -> hostname | undef
3759#
3760# Purpose:
3761#   Perform a PTR (reverse DNS) lookup for an IP address.  Supports both
3762#   IPv4 and IPv6 via Net::DNS when available; falls back to gethostbyaddr.
3763#
3764# Entry criteria:
3765#   $ip -- a defined IPv4 or IPv6 address string.
3766#
3767# Exit status:
3768#   Returns the PTR hostname string, or undef if no record exists.
3769
3770sub _reverse_dns :Protected {
3771
112
154
        my ($self, $ip) = @_;
3772
113
2705
        return unless $ip;
3773
3774
98
217
        if ($HAS_NET_DNS) {
3775
96
259
                my $res   = Net::DNS::Resolver->new(tcp_timeout => $self->{timeout});
3776
96
3280
                my $query = $res->search($ip, 'PTR');
3777
468
334
                if ($query) {
3778
2284
1617
                        for my $rr ($query->answer) {
3779
454
4951
                                return $rr->ptrdname if $rr->type eq 'PTR';
3780                        }
3781                }
3782
66
60
                return;
3783        }
3784
3785        # Fallback for IPv4 only
3786
86
380520
        return scalar gethostbyaddr(inet_aton($ip), AF_INET);
3787
22
22
22
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
6914
17
833
4
34
6395
2
16
1542
1
10
957
1
10
1796
1302
1
16
1750
1
12
617
1
9
}
3788
3789# -----------------------------------------------------------------------
3790# Private: WHOIS / RDAP
3791# -----------------------------------------------------------------------
3792
3793# _whois_ip( $ip ) -> hashref
3794#
3795# Purpose:
3796#   Enrich an IP address with organisation name, abuse contact, and country
3797#   code.  Tries RDAP first (if LWP is available), then falls back to raw
3798#   WHOIS via IANA referral.  Results are cached in CHI if available.
3799#
3800# Entry criteria:
3801#   $ip -- a defined IPv4 or IPv6 address string.
3802#
3803# Exit status:
3804#   Returns { org, abuse, country } hashref; keys absent when unknown.
3805
3806sub _whois_ip :Protected {
3807
161
3214
        my ($self, $ip) = @_;
3808
3809        # Check CHI cache before going to the network
3810
114
155
        if ($_cache) {
3811
93
166
                my $cached = $_cache->get("whois_ip:$ip");
3812
152
4014
                return $cached if $cached;
3813        }
3814
3815
158
296
        my $result = $HAS_LWP ? $self->_rdap_lookup($ip) : {};
3816
3817        # Fall back to raw WHOIS if RDAP returned no organisation
3818
158
261
        unless ($result->{org}) {
3819
158
3301
                my $raw = $self->_raw_whois($ip, 'whois.iana.org');
3820
158
528
                if ($raw) {
3821
27
162
                        my ($ref) = $raw =~ /whois:\s*([\w.-]+)/i;
3822
84
5163
                        my $detail = $ref ? $self->_raw_whois($ip, $ref) : $raw;
3823
81
1148
                        $result = $self->_parse_whois_text($detail) if $detail;
3824                }
3825        }
3826
3827        # Cache the enrichment result
3828
141
210
        $_cache->set("whois_ip:$ip", $result) if $_cache && $result;
3829
3830
155
4728
        return $result;
3831
22
22
22
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
8995
23
203
5
34
5271
2
12
1924
2
13
988
2
9
1538
1015
1
10
1673
1
14
1590
2
11
}
3832
3833# _domain_whois( $domain ) -> raw_whois_string | undef
3834#
3835# Purpose:
3836#   Perform a two-step WHOIS lookup for a domain: first ask IANA for the
3837#   TLD's authoritative WHOIS server, then query that server.
3838#
3839# Entry criteria:
3840#   $domain -- a lower-cased domain name string.
3841#
3842# Exit status:
3843#   Returns the raw WHOIS response string, or undef on failure.
3844
3845sub _domain_whois :Protected {
3846
85
159
        my ($self, $domain) = @_;
3847
85
220
        my $iana = $self->_raw_whois($domain, 'whois.iana.org') // return;
3848
137
3492
        my ($server) = $iana =~ /whois:\s*([\w.-]+)/i;
3849
137
138
        return unless $server;
3850
131
262
        return $self->_raw_whois($domain, $server);
3851
22
22
22
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
5975
21
214
4
27
4592
1
14
895
0
10
1384
1
10
946
1083
2
13
732
1
11
1670
2
17
}
3852
3853# _parse_domain_whois_abuse( $domain ) -> hashref
3854#
3855# Purpose:
3856#   Lightweight domain WHOIS lookup to extract only registrar name and
3857#   abuse contact.  Used as a fallback in _extract_and_resolve_urls() when
3858#   a URL host cannot be resolved to an IP.
3859#
3860# Entry criteria:
3861#   $domain -- a registrable domain name string.
3862#
3863# Exit status:
3864#   Returns { org, abuse } hashref; empty hashref on failure.
3865
3866sub _parse_domain_whois_abuse :Private {
3867        my ($self, $domain) = @_;
3868        my $raw = $self->_domain_whois($domain) // return {};
3869        my %info;
3870        if ($raw =~ /Registrar:\s*(.+)/i) {
3871                ($info{org} = $1) =~ s/\s+$//;
3872        }
3873        # Try multiple field name patterns for the abuse email
3874        for my $pat (
3875                qr/Registrar Abuse Contact Email:\s*(\S+\@\S+)/i,
3876                qr/Abuse Contact Email:\s*(\S+\@\S+)/i,
3877                qr/abuse-contact:\s*(\S+\@\S+)/i,
3878        ) {
3879                if (!$info{abuse} && $raw =~ $pat) {
3880                        ($info{abuse} = $1) =~ s/\s+$//;
3881                }
3882        }
3883        return \%info;
3884
22
22
22
3
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
7176
25
231
5
28
4491
2
11
2233
1
9
941
1
12
1452
1089
3
14
530
2
12
1538
1
9
}
3885
3886# _rdap_lookup( $ip ) -> hashref
3887#
3888# Purpose:
3889#   Query the ARIN RDAP API for IP block ownership information.  RDAP is
3890#   preferred over raw WHOIS because it returns structured JSON.
3891#
3892# Entry criteria:
3893#   $ip     -- a defined IPv4 or IPv6 address string.
3894#   LWP::UserAgent must be installed.
3895#
3896# Exit status:
3897#   Returns { org, abuse, country } hashref; empty hashref on failure.
3898
3899sub _rdap_lookup :Protected {
3900
134
4156
        my ($self, $ip) = @_;
3901
75
52
        return {} unless $HAS_LWP;
3902
3903
73
173
        my $ua = $self->{ua};
3904
12
2731
        if(!defined($ua)) {
3905                $ua = LWP::UserAgent->new(
3906                        timeout => $self->{timeout},
3907
15
17
                        agent   => "Email-Abuse-Investigator/$VERSION",
3908                );
3909
3910
15
91
                if($HAS_CONN_CACHE) {
3911
12
23
                        my $conn_cache = LWP::ConnCache->new();
3912
80
74
                        $conn_cache->total_capacity(10);
3913
87
228
                        $ua->conn_cache($conn_cache);
3914                }
3915
3916
12
17
                $ua->env_proxy(1);
3917
72
151
                $self->{ua} = $ua;
3918        }
3919
3920        # Use the ARIN RDAP endpoint; it covers the ARIN region and redirects
3921        # for RIPE/APNIC/LACNIC/AfriNIC allocations.
3922
15
72
28
6522
        my $res = eval { $ua->get("https://rdap.arin.net/registry/ip/$ip") };
3923
72
68
        return {} unless $res && $res->is_success();
3924
3925
12
124
        my $j = $res->decoded_content();
3926
12
23
        my %info;
3927
3928        # Extract organisation name from the JSON response
3929
12
87
16
121
        if ($j =~ /"name"\s*:\s*"([^"]+)"/)   { $info{org}    = $1 }
3930
147
146
136
196
        if ($j =~ /"handle"\s*:\s*"([^"]+)"/) { $info{handle} = $1 }
3931
3932        # Extract abuse email from the vcardArray contact block
3933
80
76
        if ($j =~ /"abuse".*?"email"\s*:\s*"([^"]+)"/s) {
3934
140
811
                $info{abuse} = $1;
3935        } elsif ($j =~ /"email"\s*:\s*"([^@"]+@[^"]+)"/) {
3936
78
109
                $info{abuse} = $1;
3937        }
3938
3939        # Country code from the network's country field
3940
19
78
21
65
        if ($j =~ /"country"\s*:\s*"([A-Z]{2})"/) { $info{country} = $1 }
3941
3942
85
435
        return \%info;
3943
22
22
22
3
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
9784
24
234
3
29
2304
2
12
721
1
15
2220
1
9
2435
1648
2
17
1321
2
13
1072
1
9
}
3944
3945# _raw_whois( $query, $server ) -> string | undef
3946#
3947# Purpose:
3948#   Open a TCP connection to a WHOIS server on port 43, send the query,
3949#   and return the full response as a string.  Uses IO::Select for read
3950#   timeouts so that alarm() is never needed (alarm() is unreliable on
3951#   Windows and in threaded Perl).  Supports IPv6 WHOIS servers via
3952#   IO::Socket::IP when that module is available.
3953#
3954# Entry criteria:
3955#   $query   -- the domain name or IP to query (defined, non-empty).
3956#   $server  -- the WHOIS server hostname (default: 'whois.iana.org').
3957#   $self->{timeout} -- seconds used for connect and per-read waits.
3958#
3959# Exit status:
3960#   Returns the raw WHOIS response string, or undef on connection/write failure.
3961#
3962# Notes:
3963#   Uses IO::Socket::IP (dual-stack) when available, falling back to
3964#   IO::Socket::INET (IPv4 only) otherwise.  The IO::Select loop reads
3965#   until the server closes the connection or the per-read timeout expires.
3966
3967sub _raw_whois :Protected {
3968
123
397
        my ($self, $query, $server) = @_;
3969
66
127
        $server //= 'whois.iana.org';
3970
62
490
        $self->_debug("WHOIS $server -> $query");
3971
3972        # Choose the socket class based on what is installed.
3973        # IO::Socket::IP supports both IPv4 and IPv6 WHOIS servers.
3974
75
160
        my $sock_class = $HAS_IO_SOCKET_IP ? 'IO::Socket::IP' : 'IO::Socket::INET';
3975
3976        # Attempt TCP connection to port 43 on the WHOIS server
3977
79
157
        my $sock = eval {
3978                $sock_class->new(
3979                        PeerAddr => $server,
3980                        PeerPort => $WHOIS_PORT,
3981                        Proto    => 'tcp',
3982                        Timeout  => $self->{timeout},
3983
77
363
                );
3984        };
3985
51
4218226
        return unless $sock;
3986
3987        # Send the WHOIS query in wire format (CRLF-terminated per RFC 3912)
3988
73
32
39
382
37
42
        $sock->print("$query\r\n") or do { $sock->close(); return };
3989
3990        # Use IO::Select to implement per-read timeouts without alarm()
3991
71
2137
        my $sel      = IO::Select->new($sock);
3992
153
2152
        my $response = '';
3993
132
167
        my $buf      = '';
3994
3995        # Read until EOF (server closes) or timeout
3996
191
550
        while ($sel->can_read($self->{timeout})) {
3997                # Wrap in eval to catch 'Connection reset by peer' thrown by Fatal/autodie
3998
268
272
3457647
562
                my $n = eval { sysread($sock, $buf, $WHOIS_READ_CHUNK) };
3999
4000
281
9754
                if ($@ || !defined $n || $n <= 0) {
4001
130
192
                        $self->_debug("WHOIS read failed: $@") if $@;
4002
365
357
                        last;
4003                }
4004
217
510
                last if !defined($n) || $n <= 0;
4005
137
423
                $response .= $buf;
4006        }
4007
4008
77
251
        $sock->close();
4009
76
2822
        return $response || undef;
4010
22
22
22
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
7484
23
188
1
12
1
1
12
2
2
11
2
1
13
2
1427
2
10
1389
2
11
836
1
9
}
4011
4012# _parse_whois_text( $text ) -> hashref
4013#
4014# Purpose:
4015#   Parse a raw WHOIS IP block response to extract organisation name,
4016#   abuse contact email, and country code.
4017#
4018# Entry criteria:
4019#   $text -- a defined WHOIS response string.
4020#
4021# Exit status:
4022#   Returns { org, abuse, country } hashref; keys absent when not found.
4023
4024sub _parse_whois_text :Private {
4025        my ($self, $text) = @_;
4026        return {} unless $text;
4027        my %info;
4028
4029        # Try multiple field names for the organisation name
4030        for my $pat (
4031                qr/^OrgName:\s*(.+)/mi,    qr/^org-name:\s*(.+)/mi,
4032                qr/^owner:\s*(.+)/mi,      qr/^descr:\s*(.+)/mi,
4033        ) {
4034                if (!$info{org} && $text =~ $pat) {
4035                        ($info{org} = $1) =~ s/\s+$//;
4036                }
4037        }
4038
4039        # Try multiple field names for the abuse email
4040        for my $pat (
4041                qr/OrgAbuseEmail:\s*(\S+@\S+)/mi,
4042                qr/abuse-mailbox:\s*(\S+@\S+)/mi,
4043        ) {
4044                if (!$info{abuse} && $text =~ $pat) {
4045                        ($info{abuse} = $1) =~ s/\s+$//;
4046                }
4047        }
4048
4049        # Last-resort: any abuse@ address in the response
4050        if (!$info{abuse} && $text =~ /(abuse\@[\w.-]+)/i) { $info{abuse} = $1 }
4051
4052        # Country code (case-insensitive match, normalised to uppercase)
4053        if ($text =~ /^country:\s*([A-Za-z]{2})\s*$/m) {
4054                $info{country} = uc $1;
4055        }
4056        return \%info;
4057
22
22
22
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
10647
20
186
2
34
2
1
31
2
1
31
2
1
53
3
1679
1
15
1245
1
13
867
1
9
}
4058
4059# -----------------------------------------------------------------------
4060# Private: authentication results parsing
4061# -----------------------------------------------------------------------
4062
4063# _parse_auth_results_cached() -> hashref
4064#
4065# Purpose:
4066#   Parse the Authentication-Results: header(s) from the message once,
4067#   cache the result, and return it.  Extracts SPF, DKIM, DMARC, ARC
4068#   results and the DKIM signing domain(s).
4069#
4070# Entry criteria:
4071#   $self->{_headers} populated by _split_message().
4072#
4073# Exit status:
4074#   Returns { spf, dkim, dmarc, arc, dkim_domain, dkim_domains } hashref.
4075#   Keys absent when the corresponding header or field is not present.
4076
4077sub _parse_auth_results_cached :Private {
4078        my $self = $_[0];
4079        return $self->{_auth_results} if $self->{_auth_results};
4080
4081        my %auth;
4082
4083        # Concatenate all Authentication-Results: header values
4084        my $raw = join('; ',
4085                map  { $_->{value} }
4086                grep { $_->{name} eq 'authentication-results' }
4087                @{ $self->{_headers} }
4088        );
4089
4090        # Extract individual authentication mechanism results
4091        if ($raw =~ /\bspf=(\S+)/i)   { $auth{spf}   = $1 }
4092        if ($raw =~ /\bdkim=(\S+)/i)  { $auth{dkim}  = $1 }
4093        if ($raw =~ /\bdmarc=(\S+)/i) { $auth{dmarc} = $1 }
4094        if ($raw =~ /\barc=(\S+)/i)   { $auth{arc}   = $1 }
4095
4096        # Strip trailing punctuation captured by the greedy \S+
4097        for my $k (qw(spf dkim dmarc arc)) {
4098                $auth{$k} =~ s/[;,\s]+$// if defined $auth{$k};
4099        }
4100
4101        # Extract DKIM signing domains from all DKIM-Signature: d= tags.
4102        # Prefer the first domain that matches the provider table (identifies ESP).
4103        my @dkim_domains;
4104        for my $h (grep { $_->{name} eq 'dkim-signature' } @{ $self->{_headers} }) {
4105                if ($h->{value} =~ /\bd=([^;,\s]+)/) {
4106                        push @dkim_domains, lc $1;
4107                }
4108        }
4109
4110        if (@dkim_domains) {
4111                # Check if any signing domain matches a known provider
4112                my $preferred;
4113                for my $d (@dkim_domains) {
4114                        if ($self->_provider_abuse_for_host($d)) {
4115                                $preferred = $d;
4116                                last;
4117                        }
4118                }
4119                $auth{dkim_domain}  = $preferred // $dkim_domains[0];
4120                $auth{dkim_domains} = \@dkim_domains;
4121        }
4122
4123        $self->{_auth_results} = \%auth;
4124        return \%auth;
4125
22
22
22
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
9639
23
196
1
3
2286
1
3
2215
1
4
2199
0
4
2283
1289
2
13
1887
2
14
781
2
11
}
4126
4127# -----------------------------------------------------------------------
4128# Private: provider-table lookups
4129# -----------------------------------------------------------------------
4130
4131# _provider_abuse_for_host( $host ) -> hashref | undef
4132#
4133# Purpose:
4134#   Look up a hostname (and each of its parent domains, stripping one label
4135#   at a time from the left) in the %PROVIDER_ABUSE table.
4136#
4137# Entry criteria:
4138#   $host -- a defined hostname or domain string.
4139#
4140# Exit status:
4141#   Returns the %PROVIDER_ABUSE entry hashref on match, undef otherwise.
4142
4143sub _provider_abuse_for_host :Private {
4144        my ($self, $host) = @_;
4145        $host = lc $host;
4146        # Strip successive subdomains until we find a match or exhaust labels
4147        while ($host =~ /\./) {
4148                return $self->{provider_abuse}->{$host} if $self->{provider_abuse}->{$host};
4149                return $PROVIDER_ABUSE{$host} if $PROVIDER_ABUSE{$host};
4150                $host =~ s/^[^.]+\.//;
4151        }
4152        return;
4153
22
22
22
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
5666
22
227
1
33
3
1
36
2
1
36
3
1
38
2
657
1
12
1110
2
12
1094
2
12
}
4154
4155# _provider_abuse_for_ip( $ip, $rdns ) -> hashref | undef
4156#
4157# Purpose:
4158#   Look up an IP's reverse-DNS hostname in the %PROVIDER_ABUSE table to
4159#   identify well-known provider networks by rDNS pattern.
4160#
4161# Entry criteria:
4162#   $ip   -- IPv4 or IPv6 address string (used as fallback if $rdns absent).
4163#   $rdns -- optional rDNS hostname string.
4164#
4165# Exit status:
4166#   Returns the %PROVIDER_ABUSE entry on match, undef otherwise.
4167
4168sub _provider_abuse_for_ip :Private {
4169        my ($self, $ip, $rdns) = @_;
4170        return $self->_provider_abuse_for_host($rdns) if $rdns;
4171        return;
4172
22
22
22
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
5678
57
174
1
13
2
0
16
1
1
15
2
1
15
2
1163
1
17
888
2
11
1614
2
12
}
4173
4174# -----------------------------------------------------------------------
4175# Private: eTLD+1 normalisation
4176# -----------------------------------------------------------------------
4177
4178# _registrable( $host ) -> string | undef
4179#
4180# Purpose:
4181#   Return the registrable eTLD+1 form of a hostname.  Uses
4182#   Domain::PublicSuffix when installed for accurate results; falls back
4183#   to a built-in heuristic for the common two-letter ccTLD+2 pattern.
4184#
4185# Entry criteria:
4186#   $host -- a hostname string (may include subdomains).
4187#
4188# Exit status:
4189#   Returns the registrable domain string, or undef for single-label
4190#   hostnames (e.g. 'localhost').
4191#
4192# Notes:
4193#   The heuristic handles co.uk, com.au, net.jp, org.nz etc. but not
4194#   uncommon second-level delegations like ltd.uk or plc.uk.
4195
4196sub _registrable :Private {
4197        my $host = $_[0];
4198        return unless $host && $host =~ /\./;
4199
4200        # Use Domain::PublicSuffix for accurate PSL-based normalisation
4201        if ($HAS_PUBLIC_SUFFIX) {
4202                my $psl = Domain::PublicSuffix->new();
4203                my $root = $psl->get_root_domain(lc $host);
4204                return $root if $root;
4205        }
4206
4207        # Built-in heuristic fallback
4208        my @labels = split /\./, lc $host;
4209        return $host if @labels <= 2;
4210
4211        # Detect common ccTLD second-level patterns (e.g. co.uk, com.au)
4212        if ($labels[-1] =~ /^[a-z]{2}$/ &&
4213            $labels[-2] =~ /^(?:co|com|net|org|gov|edu|ac|me)$/) {
4214                return join('.', @labels[-3..-1]);
4215        }
4216        return join('.', @labels[-2..-1]);
4217
22
22
22
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
7245
85
182
1
5
217
1
4
235
1
6
276
1
5
265
1324
1
14
1873
1
13
768
1
9
}
4218
4219# -----------------------------------------------------------------------
4220# Private: utilities
4221# -----------------------------------------------------------------------
4222
4223# _enrich_ip( $ip, $confidence, $note ) -> origin hashref
4224#
4225# Purpose:
4226#   Perform rDNS and WHOIS/RDAP for a single IP and package the results
4227#   into the standard origin hashref returned by originating_ip().
4228#
4229# Entry criteria:
4230#   $ip         -- a defined, non-private IPv4 or IPv6 address string.
4231#   $confidence -- 'high', 'medium', or 'low'.
4232#   $note       -- human-readable explanation of why this IP was chosen.
4233#
4234# Exit status:
4235#   Returns { ip, rdns, org, abuse, country, confidence, note } hashref.
4236
4237sub _enrich_ip :Private {
4238        my ($self, $ip, $confidence, $note) = @_;
4239        my $rdns  = $self->_reverse_dns($ip);
4240        my $whois = $self->_whois_ip($ip);
4241        return {
4242                ip         => $ip,
4243                rdns       => $rdns  // '(no reverse DNS)',
4244                org        => $whois->{org}     // '(unknown)',
4245                abuse      => $whois->{abuse}   // '(unknown)',
4246                country    => $whois->{country} // undef,
4247                confidence => $confidence,
4248                note       => $note,
4249        };
4250
22
22
22
14
14
14
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
4973
25
173
15
9
20
1
1
2
2
1
5
2
2
4
541
1
9
1787
2
12
1124
1
11
}
4251
4252# _header_value( $name ) -> value_string | undef
4253#
4254# Purpose:
4255#   Return the value of the first header matching the given lower-cased
4256#   header name.
4257 - 4311
=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
4312
4313sub header_value {
4314
94
1
13513
1
        my $self = shift;
4315
4316
94
1
120
10
        my $params = Params::Validate::Strict::validate_strict({
4317                args => Params::Get::get_params('name', \@_) || {},
4318                schema => {
4319                        name => {
4320                                'type'     => 'string',
4321                                'optional' => 0,
4322                        }
4323                }
4324        });
4325
4326
94
1
2899
1317
        return if((!defined($params)) || !defined($params->{name}));
4327
94
1
5290
1
        return if ref($params->{name});
4328
130
1
146
10
        return $self->_header_value($params->{name});
4329}
4330
4331#
4332# _header_value( $name ) -> string | undef
4333#
4334# Purpose:
4335#   Internal implementation for header_value().  Walks _headers list and
4336#   returns the value of the first matching header.
4337#
4338# Entry criteria:
4339#   $name -- a lower-cased header name string.
4340#   $self->{_headers} populated by _split_message().
4341#
4342# Exit status:
4343#   Returns the value string, or undef if the header is not present.
4344
4345sub _header_value :Private {
4346        my ($self, $name) = @_;
4347        for my $h (@{ $self->{_headers} }) {
4348                return $h->{value} if $h->{name} eq lc($name);
4349        }
4350        return;
4351
22
22
22
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
7564
174
177
130
2
3
120
1
4
183
1
5
140
1
5
1159
1
9
1469
1
9
658
2
12
}
4352
4353# _ip_in_cidr( $ip, $cidr ) -> bool
4354#
4355# Purpose:
4356#   Test whether an IPv4 address falls within a CIDR block or is an exact
4357#   match (when $cidr contains no '/' separator).
4358#
4359# Entry criteria:
4360#   $ip   -- a defined dotted-quad IPv4 address string.
4361#   $cidr -- a CIDR string like '10.0.0.0/8' or an exact IP.
4362#
4363# Exit status:
4364#   Returns 1 (true) if the IP is within the CIDR block, 0 otherwise.
4365
4366sub _ip_in_cidr :Private {
4367        my ($self, $ip, $cidr) = @_;
4368        return $ip eq $cidr unless $cidr =~ m{/};
4369        my ($net_addr, $prefix) = split m{/}, $cidr;
4370        return 0 if !defined($prefix) || $prefix !~ /^\d+$/ || $prefix > 32;
4371
4372        # Compute the network mask and compare masked network addresses
4373        my $mask  = ~0 << (32 - $prefix);
4374        my $net_n = unpack 'N', (inet_aton($net_addr) // return 0);
4375        my $ip_n  = unpack 'N', (inet_aton($ip)       // return 0);
4376        return ($ip_n & $mask) == ($net_n & $mask);
4377
22
22
22
14
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
6341
23
179
85
1
23
72
0
26
86
1
28
75
1
27
1102
2
13
706
1
13
1630
2
12
}
4378
4379# _decode_mime_words( $str ) -> decoded_string
4380#
4381# Purpose:
4382#   Decode MIME encoded-words (=?charset?B/Q?...?=) in a header value
4383#   string for human-readable display in reports.
4384#
4385# Entry criteria:
4386#   $str -- a defined header value string; may be undef.
4387#
4388# Exit status:
4389#   Returns the decoded string, or '' if $str is undef.
4390
4391sub _decode_mime_words :Private {
4392        my ($self, $str) = @_;
4393        return '' unless defined $str;
4394        # Replace each encoded-word with its decoded equivalent
4395        $str =~ s/=\?([^?]+)\?([BbQq])\?([^?]*)\?=/_decode_ew($1,$2,$3)/ge;
4396        return $str;
4397
22
22
22
1
14
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
4933
18
171
2
16
13
2
0
17
4
2
19
2
2
13
822
1
14
769
1
13
1547
1
11
}
4398
4399# _decode_ew( $charset, $enc, $text ) -> decoded_bytes
4400#
4401# Purpose:
4402#   Decode a single MIME encoded-word component (base64 or quoted-printable).
4403#
4404# Notes:
4405#   Non-UTF-8 charsets return raw bytes; good enough for display-name spoof
4406#   detection which only needs ASCII matching.
4407
4408sub _decode_ew :Private {
4409        my ($charset, $enc, $text) = @_;
4410        my $raw;
4411        if (uc($enc) eq 'B') {
4412                $raw = decode_base64($text);
4413        } else {
4414                # Quoted-printable encoded-word uses underscore for space
4415                $text =~ s/_/ /g;
4416                $raw  = decode_qp($text);
4417        }
4418        return $raw;
4419
22
22
22
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
5648
17
169
2
1
10
1
1
10
2
1
9
2
1
12
1259
1
10
1031
1
13
1804
3
11
}
4420
4421# _parse_date_to_epoch( $str ) -> epoch_int | undef
4422#
4423# Purpose:
4424#   Parse common WHOIS date strings to a Unix epoch integer.
4425#   Handles YYYY-MM-DD, YYYY-MM-DDThh:mm:ssZ, and DD-Mon-YYYY formats.
4426#
4427# Entry criteria:
4428#   $str -- a defined date string; may be undef.
4429#
4430# Exit status:
4431#   Returns epoch integer on success, undef if the string cannot be parsed.
4432
4433sub _parse_date_to_epoch :Private {
4434        my ($self, $str) = @_;
4435        return unless $str;
4436
4437        # Clean the string of trailing whitespace/newlines
4438        $str =~ s/^\s+|\s+$//g;
4439
4440        # Guard Regex: Validates the strict YYYY-MM-DDThh:mm:ssZ format
4441        if ($str =~ /^(\d{4}-\d{2}-\d{2}T\d{2}:\d{2}:\d{2})(?:\.\d+)?Z$/) {
4442                # Parse the string
4443                # We use 'strptime' to create a Time::Piece object.
4444                # The 'Z' indicates UTC (Zulu time).
4445                my $epoch = eval {
4446                        my $t = Time::Piece->strptime($1, '%Y-%m-%dT%H:%M:%S');
4447
4448                        # Return seconds since the epoch
4449                        # Time::Piece handles the timezone offset internally when calling ->epoch
4450
4451                        # strptime returns a local time object.
4452                        # We must subtract the local timezone offset to get the true UTC epoch.
4453                        return $t->epoch - $t->tzoffset->seconds;
4454                };
4455                return $epoch if defined $epoch;
4456        }
4457        my ($y, $m, $d);
4458
4459        if    ($str =~ /^(\d{4})-(\d{2})-(\d{2})/)         { ($y,$m,$d)=($1,$2,$3) }
4460        elsif ($str =~ /^(\d{2})-([A-Za-z]{3})-(\d{4})/)   { ($d,$m,$y)=($1,$Readonly::Values::Months::months{lc$2}//0,$3) }
4461        elsif ($str =~ /^(\d{2})\/(\d{2})\/(\d{4})/)        { ($m,$d,$y)=($1,$2,$3) }
4462
4463        return unless $y && $m && $d;
4464
4465        if (eval { require Time::Local; 1 }) {
4466                return eval { Time::Local::timegm(0,0,0,$d,$m-1,$y-1900) };
4467        }
4468        # Approximate fallback without Time::Local
4469        return ($y-1970)*365.25*$SECS_PER_DAY + ($m-1)*30.5*$SECS_PER_DAY + ($d-1)*$SECS_PER_DAY;
4470
22
22
22
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
9610
22
782
2
1
16
2
1
18
1
1
23
1
1
18
680
1
8
955
1
13
1287
2
12
}
4471
4472# _parse_rfc2822_date( $str ) -> epoch_int | undef
4473#
4474# Purpose:
4475#   Parse an RFC 2822 Date: header value to a Unix epoch integer.
4476#   Timezone offsets are intentionally ignored; the function returns a
4477#   UTC-equivalent value.  For the 7-day suspicious_date window the
4478#   maximum error is ~14 hours, well within the tolerance.
4479#
4480# Entry criteria:
4481#   $str -- a defined Date: header value string.
4482#
4483# Exit status:
4484#   Returns epoch integer on success, undef if the string cannot be parsed.
4485
4486sub _parse_rfc2822_date :Private {
4487        my $str = $_[0];
4488        return unless $str;
4489
4490        # Match: DD Mon YYYY HH:MM:SS (timezone offset ignored)
4491        if ($str =~ /(\d{1,2})\s+([A-Za-z]{3})\s+(\d{4})\s+(\d{2}):(\d{2}):(\d{2})/) {
4492                my ($d, $m, $y, $H, $M, $S) =
4493                        ($1, $Readonly::Values::Months::months{ lc $2 } // 0, $3, $4, $5, $6);
4494                return unless $m;
4495                if (eval { require Time::Local; 1 }) {
4496                        return eval { Time::Local::timegm($S, $M, $H, $d, $m - 1, $y - 1900) };
4497                }
4498        }
4499        return;
4500
22
22
22
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
6987
22
187
2
12
14
2
12
14
2
13
14
2
13
18
574
1
8
982
2
11
1096
2
10
}
4501
4502# _country_name( $cc ) -> country_name_string
4503#
4504# Purpose:
4505#   Return a human-readable country name for a two-letter ISO 3166-1
4506#   alpha-2 country code.  Only the small set of statistically high-volume
4507#   spam-originating countries is covered; other codes are returned as-is.
4508#
4509# Entry criteria:
4510#   $cc -- a two-letter uppercase country code string.
4511#
4512# Exit status:
4513#   Returns the country name string, or the code itself if not in the table.
4514
4515sub _country_name :Private {
4516        my $cc = $_[0];
4517        my %names = (
4518                CN => 'China',       RU => 'Russia',    NG => 'Nigeria',
4519                VN => 'Vietnam',     IN => 'India',      PK => 'Pakistan',
4520                BD => 'Bangladesh',
4521        );
4522        return $names{$cc} // $cc;
4523
22
22
22
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
5397
24
167
2
1
98
1
1
18
2
1
15
2
0
16
497
1
8
1094
1
12
1156
2
10
}
4524
4525# _debug( $msg )
4526#
4527# Purpose:
4528#   Write a diagnostic message to STDERR when verbose mode is enabled.
4529#
4530# Entry criteria:
4531#   $msg -- a defined message string.
4532#
4533# Notes:
4534#   Messages are prefixed with the class name for easy grepping.
4535
4536sub _debug :Private {
4537        my ($self, $msg) = @_;
4538
4539        if($self->{verbose}) {
4540                if (my $logger = $self->{logger}) { # Set via Object::Configure
4541                        $logger->debug("[Email::Abuse::Investigator] $msg");
4542                } else {
4543                        print STDERR "[Email::Abuse::Investigator] $msg\n";
4544                }
4545        }
4546
22
22
22
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
5725
22
169
2
1
104
1
1
70
2
1
79
2
1
74
2286
1
13
1372
1
12
1153
2
12
}
4547
45481;
4549