lib/Email/Abuse/Investigator.pm

Index
Structural Coverage (Approximate)

TER1 (Statement): 97.72%
TER2 (Branch): 68.05%
TER3 (LCSAJ): 94.4% (117/124)
Approximate LCSAJ segments: 411

LCSAJ Legend

● Covered — this LCSAJ path was executed during testing.

● Not covered — this LCSAJ path was never executed. These are the paths to focus on.

Multiple dots on a line indicate that multiple control-flow paths begin at that line. Hovering over any dot shows: 

        start → end → jump

Uncovered paths show [NOT COVERED] in the tooltip.

Mutant Testing Legend

Survived (tests missed this) Killed (tests detected this) No mutation 
    1: package Email::Abuse::Investigator;
    2: 
    3: use strict;
    4: use warnings;
    5: use autodie qw(:all);
    6: 
    7: use Carp qw(croak carp);
    8: use IO::Select;
    9: use IO::Socket::INET;
   10: BEGIN { $Sub::Private::config{mode} = 'enforce' }
   11: use Sub::Private;
   12: use Sub::Protected;
   13: use MIME::QuotedPrint qw( decode_qp );
   14: use MIME::Base64 qw( decode_base64 );
   15: use Object::Configure;
   16: use Params::Get;
   17: use Params::Validate::Strict 0.34;
   18: use Readonly;
   19: use Readonly::Values::Months;
   20: use Socket qw( inet_aton inet_ntoa AF_INET );
   21: use Time::Piece;
   22: 
   23: =head1 NAME
   24: 
   25: Email::Abuse::Investigator - Analyse spam email to identify originating hosts,
   26: hosted URLs, and suspicious domains
   27: 
   28: =head1 VERSION
   29: 
   30: Version 0.12
   31: 
   32: =cut
   33: 
   34: our $VERSION = '0.12';
   35: 
   36: =head1 SYNOPSIS
   37: 
   38:     use Email::Abuse::Investigator;
   39: 
   40:     my $analyser = Email::Abuse::Investigator->new( verbose => 1 );
   41:     $analyser->parse_email($raw_email_text);
   42: 
   43:     # Originating IP and its network owner
   44:     my $origin = $analyser->originating_ip();
   45: 
   46:     # All HTTP/HTTPS URLs found in the body
   47:     my @urls  = $analyser->embedded_urls();
   48: 
   49:     # All domains extracted from mailto: links and bare addresses in the body
   50:     my @mdoms = $analyser->mailto_domains();
   51: 
   52:     # All domains mentioned anywhere (union of the above)
   53:     my @adoms = $analyser->all_domains();
   54: 
   55:     # Full printable report
   56:     print $analyser->report();
   57: 
   58: =head1 DESCRIPTION
   59: 
   60: C<Email::Abuse::Investigator> examines the raw source of a spam/phishing e-mail
   61: and answers the questions manual abuse investigators ask:
   62: 
   63: =over 4
   64: 
   65: =item 1. Where did the message really come from?
   66: 
   67: Walks the C<Received:> chain, skips private/trusted IPs, and identifies the
   68: first external hop.  Enriches with rDNS, WHOIS/RDAP org name and abuse
   69: contact.  Both IPv4 and IPv6 addresses are supported.
   70: 
   71: =item 2. Who hosts the advertised web sites?
   72: 
   73: Extracts every C<http://> and C<https://> URL from both plain-text and HTML
   74: parts, resolves each hostname to an IP, and looks up the network owner.
   75: 
   76: =item 3. Who owns the reply-to / contact domains?
   77: 
   78: Extracts domains from C<mailto:> links, bare e-mail addresses in the body,
   79: the C<From:>/C<Reply-To:>/C<Sender:>/C<Return-Path:> headers, C<DKIM-Signature: d=>
   80: (the signing domain), C<List-Unsubscribe:> (the ESP or bulk-sender domain), and the
   81: C<Message-ID:> domain.  For each unique domain it gathers:
   82: 
   83: =over 8
   84: 
   85: =item * Domain registrar and registrant (WHOIS)
   86: 
   87: =item * Web-hosting IP and network owner (A record -> RDAP)
   88: 
   89: =item * Mail-hosting IP and network owner (MX record -> RDAP)
   90: 
   91: =item * DNS nameserver operator (NS record -> RDAP)
   92: 
   93: =item * Whether the domain was recently registered (potential flag)
   94: 
   95: =back
   96: 
   97: =back
   98: 
   99: =cut
  100: 
  101: # -----------------------------------------------------------------------
  102: # Optional modules -- gracefully degraded when absent
  103: # -----------------------------------------------------------------------
  104: 
  105: # Net::DNS enables MX, NS, AAAA lookups; falls back to gethostbyname
  106: my $HAS_NET_DNS;
  107: 
  108: # LWP::UserAgent enables RDAP queries; falls back to raw WHOIS
  109: my $HAS_LWP;
  110: my $HAS_CONN_CACHE;
  111: 
  112: # HTML::LinkExtor enables structural HTML link extraction
  113: my $HAS_HTML_LINKEXTOR;
  114: 
  115: # CHI enables a persistent cross-message cache for IP/domain data
  116: my $HAS_CHI;
  117: 
  118: # IO::Socket::IP provides dual-stack (IPv4+IPv6) socket support
  119: my $HAS_IO_SOCKET_IP;
  120: 
  121: # Domain::PublicSuffix enables accurate eTLD+1 normalisation
  122: my $HAS_PUBLIC_SUFFIX;
  123: 
  124: # AnyEvent::DNS enables parallel DNS queries
  125: my $HAS_ANYEVENT_DNS;
  126: 
  127: BEGIN {
  128: 	$HAS_NET_DNS       = eval { require Net::DNS;           1 };
  129: 	$HAS_LWP           = eval { require LWP::UserAgent;     1 };
  130: 	$HAS_CONN_CACHE    = eval { require LWP::ConnCache;     1 };
  131: 	$HAS_HTML_LINKEXTOR= eval { require HTML::LinkExtor;    1 };
  132: 	$HAS_CHI           = eval { require CHI;                1 };
  133: 	$HAS_IO_SOCKET_IP  = eval { require IO::Socket::IP;     1 };
  134: 	$HAS_PUBLIC_SUFFIX = eval { require Domain::PublicSuffix; 1 };
  135: 	$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)
  143: Readonly::Scalar my $WHOIS_PORT        => 43;
  144: 
  145: # Bytes to read per sysread() call from a WHOIS socket
  146: Readonly::Scalar my $WHOIS_READ_CHUNK  => 4096;
  147: 
  148: # Maximum WHOIS response bytes stored in whois_raw (keep reports compact)
  149: Readonly::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)
  153: Readonly::Scalar my $MAX_MULTIPART_DEPTH => 20;
  154: 
  155: # Number of days before registration that triggers recently_registered flag
  156: Readonly::Scalar my $RECENT_REG_DAYS   => 180;
  157: 
  158: # Number of days ahead of expiry that triggers domain_expires_soon flag
  159: Readonly::Scalar my $EXPIRY_WARN_DAYS  => 30;
  160: 
  161: # Seconds in a day -- used in date arithmetic throughout
  162: Readonly::Scalar my $SECS_PER_DAY      => 86400;
  163: 
  164: # Suspicious date window: dates outside +/- 7 days raise a flag
  165: Readonly::Scalar my $DATE_SKEW_DAYS    => 7;
  166: 
  167: # Maximum positive timezone offset in minutes (+14:00 = Line Islands)
  168: Readonly::Scalar my $TZ_MAX_POS_MINS   => 840;
  169: 
  170: # Maximum negative timezone offset in minutes (-12:00 = Baker Island)
  171: Readonly::Scalar my $TZ_MAX_NEG_MINS   => 720;
  172: 
  173: # High-risk score threshold
  174: Readonly::Scalar my $SCORE_HIGH        => 9;
  175: 
  176: # Medium-risk score threshold
  177: Readonly::Scalar my $SCORE_MEDIUM      => 5;
  178: 
  179: # Low-risk score threshold
  180: Readonly::Scalar my $SCORE_LOW         => 2;
  181: 
  182: # Flag severity weights (contribute to the numeric risk score)
  183: Readonly::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
  191: Readonly::Scalar my $ROLE_MAX_LEN      => 80;
  192: 
  193: # CHI cache TTL in seconds (1 hour -- IP allocations change slowly)
  194: Readonly::Scalar my $CACHE_TTL_SECS    => 3600;
  195: 
  196: # Default constructor timeout for network operations (seconds)
  197: Readonly::Scalar my $DEFAULT_TIMEOUT   => 10;
  198: 
  199: # Maximum role string length before truncation
  200: Readonly::Scalar my $ROLE_WRAP_LEN     => 66;
  201: 
  202: # Maximum redirect hops to follow when resolving shortener/redirect-cloaker URLs
  203: Readonly::Scalar my $REDIRECT_MAX_HOPS => 3;
  204: 
  205: # Brand names checked in lookalike-domain detection.
  206: # Overridable at runtime via Object::Configure.
  207: Readonly::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.
  219: my @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.
  244: my @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: 
  265: my %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: 
  279: my %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.
  292: my %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.
  302: Readonly::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.
  319: my %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: =head1 METHODS
  473: 
  474: =head2 new( %options )
  475: 
  476: Constructs and returns a new C<Email::Abuse::Investigator> analyser object.  The
  477: object is stateless until C<parse_email()> is called; all analysis results
  478: are stored on the object and retrieved via the public accessor methods
  479: documented below.
  480: 
  481: A single object may be reused for multiple emails by calling C<parse_email()>
  482: again: all per-message cached state from the previous message is discarded
  483: automatically.  Cross-message IP and domain lookup results are retained
  484: in a shared CHI cache (if C<CHI> is installed) to avoid redundant network
  485: queries across messages processed in the same process.
  486: 
  487: =head3 Usage
  488: 
  489:     # Minimal -- all options take safe defaults
  490:     my $analyser = Email::Abuse::Investigator->new();
  491: 
  492:     # With options
  493:     my $analyser = Email::Abuse::Investigator->new(
  494:         timeout        => 15,
  495:         trusted_relays => ['203.0.113.0/24', '10.0.0.0/8'],
  496:         verbose        => 0,
  497:     );
  498: 
  499:     $analyser->parse_email($raw_rfc2822_text);
  500:     my $origin   = $analyser->originating_ip();
  501:     my @urls     = $analyser->embedded_urls();
  502:     my @domains  = $analyser->mailto_domains();
  503:     my $risk     = $analyser->risk_assessment();
  504:     my @contacts = $analyser->abuse_contacts();
  505:     print $analyser->report();
  506: 
  507: =head3 Arguments
  508: 
  509: All arguments are optional named parameters passed as a flat key-value list.
  510: 
  511: =over 4
  512: 
  513: =item C<timeout> (integer, default 10)
  514: 
  515: Maximum seconds to wait for any single network operation.  Set to 0 to
  516: disable timeouts (not recommended for production use).
  517: 
  518: =item C<trusted_relays> (arrayref of strings, default [])
  519: 
  520: IP addresses or CIDR blocks to skip during Received: chain analysis.
  521: Each element may be an exact IPv4 address (C<'192.0.2.1'>) or a CIDR
  522: block (C<'192.0.2.0/24'>).
  523: 
  524: =item C<verbose> (boolean, default 0)
  525: 
  526: When true, diagnostic messages are written to STDERR.
  527: 
  528: =back
  529: 
  530: =head3 Returns
  531: 
  532: A blessed C<Email::Abuse::Investigator> object.  No network I/O is performed
  533: during construction.
  534: 
  535: =head3 Side Effects
  536: 
  537: If C<CHI> is installed, a shared in-memory cache is initialised (or
  538: re-used if a cache was already created by a prior call to C<new()>).
  539: This cache persists for the lifetime of the process.
  540: 
  541: =head3 Notes
  542: 
  543: =over 4
  544: 
  545: =item *
  546: 
  547: Unknown option keys are silently ignored.
  548: 
  549: =item *
  550: 
  551: The object is not thread-safe.  Use a separate object per thread.
  552: 
  553: =item *
  554: 
  555: WHOIS read timeouts use C<IO::Select> rather than C<alarm()>, so they
  556: work correctly on Windows and in threaded Perl interpreters.
  557: 
  558: =back
  559: 
  560: =head3 API Specification
  561: 
  562: =head4 Input
  563: 
  564:     {
  565:         timeout => {
  566:             type     => 'integer',
  567:             optional => 1,
  568:             min      => 0,
  569:             default  => 10,
  570:         },
  571:         trusted_relays => {
  572:             type          => 'arrayref',
  573:             element_type  => 'string',
  574:             optional      => 1,
  575:             default       => [],
  576:         },
  577:         verbose => {
  578:             type     => 'boolean',
  579:             optional => 1,
  580:             default  => 0,
  581:         },
  582:     }
  583: 
  584: =head4 Output
  585: 
  586:     {
  587:         type => 'object',
  588:         isa  => 'Email::Abuse::Investigator',
  589:     }
  590: 
  591: =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.
  595: my $_cache;
  596: 
  597: sub new {
●598 → 625 → 634  598: 	my $class = shift;
  599: 
  600: 	# Accept hash or hashref arguments uniformly
  601: 	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: 	$params = Object::Configure::configure($class, $params);
  623: 
  624: 	# Initialise the cross-message CHI cache on first construction
  625: 	if ($HAS_CHI && !$_cache) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

  626: 		$_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 {

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

  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: 		%{$params},  # Overlay Object::Configure and caller-supplied values
  651: 	}, $class;
  652: }
  653: 
  654: # -----------------------------------------------------------------------
  655: # Public: parse
  656: # -----------------------------------------------------------------------
  657: 
  658: =head2 parse_email( $text )
  659: 
  660: Feeds a raw RFC 2822 email message to the analyser and prepares it for
  661: subsequent interrogation.  This is the only method that must be called
  662: before any other public method.
  663: 
  664: If the same object is used for a second message, calling C<parse_email()>
  665: again completely replaces all per-message state from the first message.
  666: The cross-message CHI cache is B<not> flushed; IP and domain lookups
  667: cached from prior messages are retained.
  668: 
  669: =head3 Usage
  670: 
  671:     my $raw = do { local $/; <STDIN> };
  672:     $analyser->parse_email($raw);
  673: 
  674:     # Scalar reference (avoids copying large messages)
  675:     $analyser->parse_email(\$raw);
  676: 
  677:     # Chained
  678:     my $analyser = Email::Abuse::Investigator->new()->parse_email($raw);
  679: 
  680: =head3 Arguments
  681: 
  682: =over 4
  683: 
  684: =item C<$text> (string or string reference, required)
  685: 
  686: Complete raw RFC 2822 email message, including all headers and the body.
  687: Both LF-only and CRLF line endings are accepted.
  688: 
  689: =back
  690: 
  691: =head3 Returns
  692: 
  693: The object itself (C<$self>), enabling method chaining.
  694: 
  695: =head3 Side Effects
  696: 
  697: Parses headers, decodes the body (quoted-printable, base64, multipart),
  698: extracts sending-software fingerprints, and populates per-hop tracking
  699: data.  All previously computed lazy results are discarded.
  700: 
  701: =head3 Notes
  702: 
  703: =over 4
  704: 
  705: =item *
  706: 
  707: If C<$text> is empty or contains no header/body separator, all public
  708: methods will return empty/safe values.
  709: 
  710: =item *
  711: 
  712: Decoding errors in base64 or quoted-printable payloads are silenced; raw
  713: bytes are used in place of correct output to prevent exceptions.
  714: 
  715: =back
  716: 
  717: =head3 API Specification
  718: 
  719: =head4 Input
  720: 
  721:     [
  722:         {
  723:             type => [ 'string', 'stringref' ]
  724:         },
  725:     ]
  726: 
  727: =head4 Output
  728: 
  729:     {
  730:         type => 'object',
  731:         isa  => 'Email::Abuse::Investigator',
  732:     }
  733: 
  734: =cut
  735: 
  736: # TODO: Allow a Mail::Message object to be passed in
  737: sub parse_email {
  738: 	my $self = shift;
  739: 
  740: 	# Accept both positional string and named 'text' argument
  741: 	my $args = Params::Get::get_params('text', \@_);
  742: 	my $text = $args->{text};
  743: 
  744: 	# Dereference a scalar-ref in a single clean pass
  745: 	$text = $$text if ref($text) eq 'SCALAR';
  746: 
  747: 	# Any other reference type is a programming error
  748: 	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: 	$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: 	$self->{_raw} = $text // '';
  756: 
  757: 	# Invalidate all per-message lazy caches
  758: 	$self->{_origin}         = undef;
  759: 	$self->{_urls}           = undef;
  760: 	$self->{_mailto_domains} = undef;
  761: 	$self->{_contacts}       = undef;
  762: 	$self->{_domain_info}    = {};
  763: 	$self->{_risk}           = undef;
  764: 	$self->{_auth_results}   = undef;
  765: 	$self->{_sending_sw}     = [];
  766: 	$self->{_rcvd_tracking}  = [];
  767: 
  768: 	# Perform synchronous header/body parsing (no network I/O)
  769: 	$self->_split_message($text) if defined $text && $text =~ /\S/;
  770: 	return $self;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

  771: }
  772: 
  773: # -----------------------------------------------------------------------
  774: # Public: originating host
  775: # -----------------------------------------------------------------------
  776: 
  777: =head2 originating_ip()
  778: 
  779: Identifies the IP address of the machine that originally injected the
  780: message into the mail system by walking the C<Received:> chain, skipping
  781: private/trusted hops, and enriching the first external hop with rDNS,
  782: WHOIS/RDAP organisation name, abuse contact, and country code.
  783: 
  784: Both IPv4 and IPv6 addresses are extracted and evaluated.
  785: 
  786: The result is cached; subsequent calls return the same hashref without
  787: repeating network I/O.
  788: 
  789: =head3 Usage
  790: 
  791:     my $orig = $analyser->originating_ip();
  792:     if (defined $orig) {
  793:         printf "Origin: %s (%s)\n", $orig->{ip}, $orig->{rdns};
  794:         printf "Owner:  %s\n",      $orig->{org};
  795:     }
  796: 
  797: =head3 Arguments
  798: 
  799: None.  C<parse_email()> must have been called first.
  800: 
  801: =head3 Returns
  802: 
  803: A hashref with keys C<ip>, C<rdns>, C<org>, C<abuse>, C<confidence>,
  804: C<note>, and C<country> (may be undef).  Returns C<undef> if no suitable
  805: originating IP can be determined.
  806: 
  807: =head3 Side Effects
  808: 
  809: On first call: one PTR lookup and one RDAP/WHOIS query.  Results are cached
  810: in the object and in the cross-message CHI cache (if available).
  811: 
  812: =head3 Notes
  813: 
  814: Only the first (oldest) external IP in the chain is reported.  See
  815: C<received_trail()> for the full chain.
  816: 
  817: =head3 API Specification
  818: 
  819: =head4 Input
  820: 
  821:     []
  822: 
  823: =head4 Output
  824: 
  825:     {
  826:         type => [ 'hashref', 'undef' ],
  827:         keys => {
  828:             ip         => { type => 'string', regex => qr/[\d.:a-fA-F]/ },
  829:             rdns       => { type => 'string' },
  830:             org        => { type => 'string' },
  831:             abuse      => { type => 'string' },
  832:             confidence => { type => 'string', memberof => [ 'high', 'medium', 'low' ] },
  833:             note       => { type => 'string' },
  834:             country    => { type => 'string', optional => 1 },
  835:         },
  836:     }
  837: 
  838: =cut
  839: 
  840: sub originating_ip {
  841: 	my $self = $_[0];
  842: 
  843: 	# Return the cached result if we already have it
  844: 	$self->{_origin} //= $self->_find_origin();
  845: 	return $self->{_origin};

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

  846: }
  847: 
  848: # -----------------------------------------------------------------------
  849: # Public: HTTP/HTTPS URLs
  850: # -----------------------------------------------------------------------
  851: 
  852: =head2 embedded_urls()
  853: 
  854: Extracts every HTTP and HTTPS URL from the message body and enriches each
  855: one with the hosting IP address, network organisation name, abuse contact,
  856: and country code.  Both IPv4 and IPv6 host addresses are supported.
  857: 
  858: URL extraction runs across both plain-text and HTML body parts.  DNS
  859: lookups for each unique hostname are optionally parallelised via
  860: C<AnyEvent::DNS> if that module is installed.
  861: 
  862: The result is cached; subsequent calls return the same list without
  863: repeating network I/O.
  864: 
  865: =head3 Usage
  866: 
  867:     my @urls = $analyser->embedded_urls();
  868:     for my $u (@urls) {
  869:         printf "URL: %s  host: %s  org: %s\n",
  870:             $u->{url}, $u->{host}, $u->{org};
  871:     }
  872: 
  873: =head3 Arguments
  874: 
  875: None.  C<parse_email()> must have been called first.
  876: 
  877: =head3 Returns
  878: 
  879: A list of hashrefs, one per unique URL, in first-seen order.  Returns an
  880: empty list if no HTTP/HTTPS URLs are present.  Each hashref has keys
  881: C<url>, C<host>, C<ip>, C<org>, C<abuse>, C<country>.
  882: 
  883: =head3 Side Effects
  884: 
  885: Per unique hostname: one A/AAAA lookup and one RDAP/WHOIS query.  Results
  886: are cached in the object and in the cross-message CHI cache.
  887: 
  888: =head3 Notes
  889: 
  890: Only C<http://> and C<https://> URLs are extracted.  URL shortener hosts
  891: are included in the returned list (they are flagged by C<risk_assessment()>).
  892: 
  893: When L<LWP::UserAgent> is available, URLs whose host is a known URL shortener
  894: or cloud-storage redirect cloaker (Google Cloud Storage C<storage.googleapis.com>,
  895: Azure Blob Storage C<blob.core.windows.net>, Cloudflare Pages C<pages.dev>,
  896: S3 buckets, CloudFront distributions, etc.) are automatically resolved by
  897: following HTTP 3xx redirects and HTML C<meta http-equiv="refresh"> or
  898: C<window.location> patterns up to C<$REDIRECT_MAX_HOPS> hops.  The resolved
  899: destination URL is added to the returned list alongside the original, so abuse
  900: contacts for the real phishing target are always reported even when the email
  901: body contains only an object-store redirect URL.
  902: 
  903: =head3 API Specification
  904: 
  905: =head4 Input
  906: 
  907:     []
  908: 
  909: =head4 Output
  910: 
  911:     (
  912:         {
  913:             type => 'hashref',
  914:             keys => {
  915:                 url     => { type => 'string', regex => qr{^https?://}i },
  916:                 host    => { type => 'string' },
  917:                 ip      => { type => 'string' },
  918:                 org     => { type => 'string' },
  919:                 abuse   => { type => 'string' },
  920:                 country => { type => 'string', optional => 1 },
  921:             },
  922:         },
  923:         ...
  924:     )
  925: 
  926: =cut
  927: 
  928: sub embedded_urls {
  929: 	my $self = $_[0];
  930: 
  931: 	$self->{_urls} //= $self->_extract_and_resolve_urls();
  932: 	return @{ $self->{_urls} };

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

  933: }
  934: 
  935: # -----------------------------------------------------------------------
  936: # Public: mailto / reply-to / from domains
  937: # -----------------------------------------------------------------------
  938: 
  939: =head2 mailto_domains()
  940: 
  941: Identifies every domain associated with the message as a contact, reply,
  942: or delivery address, then runs a full intelligence pipeline on each one
  943: (A record, MX, NS, WHOIS) to determine hosting and registration details.
  944: 
  945: The result is cached; subsequent calls return the same list without
  946: repeating network I/O.
  947: 
  948: =head3 Usage
  949: 
  950:     my @domains = $analyser->mailto_domains();
  951:     for my $d (@domains) {
  952:         printf "Domain: %s  registrar: %s\n",
  953:             $d->{domain}, $d->{registrar} // 'unknown';
  954:     }
  955: 
  956: =head3 Arguments
  957: 
  958: None.  C<parse_email()> must have been called first.
  959: 
  960: =head3 Returns
  961: 
  962: A list of hashrefs, one per unique domain.  See the main POD for the full
  963: set of possible keys.  Returns an empty list if no qualifying domains are
  964: found.
  965: 
  966: =head3 Side Effects
  967: 
  968: Per unique domain: up to three A lookups, one MX lookup, one NS lookup,
  969: and two WHOIS queries.  Results are cached in the object and in the
  970: cross-message CHI cache.
  971: 
  972: =head3 Notes
  973: 
  974: MX and NS lookups require C<Net::DNS>.  Without it those keys are absent
  975: from every returned hashref.
  976: 
  977: =head3 API Specification
  978: 
  979: =head4 Input
  980: 
  981:     []
  982: 
  983: =head4 Output
  984: 
  985:     (
  986:         {
  987:             type => 'hashref',
  988:             keys => {
  989:                 domain  => { type => 'string' },
  990:                 source  => { type => 'string' },
  991:                 # All other keys optional -- see main POD
  992:             },
  993:         },
  994:         ...
  995:     )
  996: 
  997: =cut
  998: 
  999: sub mailto_domains {
 1000: 	my $self = $_[0];
 1001: 
 1002: 	$self->{_mailto_domains} //= $self->_extract_and_analyse_domains();
 1003: 	return @{ $self->{_mailto_domains} };

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 1004: }
 1005: 
 1006: =head2 all_domains()
 1007: 
 1008: Returns the deduplicated union of every registrable domain seen anywhere
 1009: in the message -- URL hosts from C<embedded_urls()> and contact domains
 1010: from C<mailto_domains()> -- normalised to eTLD+1 form.
 1011: 
 1012: Triggers C<embedded_urls()> and C<mailto_domains()> lazily.
 1013: 
 1014: =head3 Usage
 1015: 
 1016:     my @domains = $analyser->all_domains();
 1017:     print "$_\n" for @domains;
 1018: 
 1019: =head3 Arguments
 1020: 
 1021: None.
 1022: 
 1023: =head3 Returns
 1024: 
 1025: A list of plain strings (registrable domain names), lower-cased, no
 1026: duplicates, in first-seen order.
 1027: 
 1028: =head3 Side Effects
 1029: 
 1030: Triggers C<embedded_urls()> and C<mailto_domains()> if not already cached.
 1031: 
 1032: =head3 Notes
 1033: 
 1034: Normalisation to eTLD+1 uses C<Domain::PublicSuffix> if installed, falling
 1035: back to a built-in heuristic otherwise.
 1036: 
 1037: =head3 API Specification
 1038: 
 1039: =head4 Input
 1040: 
 1041:     []
 1042: 
 1043: =head4 Output
 1044: 
 1045:     (
 1046:         { type => 'string', regex => qr/^[a-z0-9][a-z0-9.-]*\.[a-z]{2,}$/ },
 1047:         ...
 1048:     )
 1049: 
 1050: =cut
 1051: 
 1052: sub all_domains {
●1053 → 1057 → 1063 1053: 	my $self = $_[0];
 1054: 	my (%seen, @out);
 1055: 
 1056: 	# Collect registrable domains from URL hosts first
 1057: 	for my $u ($self->embedded_urls()) {
 1058: 		my $dom = _registrable($u->{host});
 1059: 		push @out, $dom if $dom && !$seen{$dom}++;
 1060: 	}
 1061: 
 1062: 	# Then from contact domains (normalise subdomains to registrable parent)
●1063 → 1063 → 1067 1063: 	for my $d ($self->mailto_domains()) {
 1064: 		my $dom = _registrable($d->{domain}) // $d->{domain};
 1065: 		push @out, $dom if $dom && !$seen{$dom}++;
 1066: 	}
 1067: 	return @out;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 1068: }
 1069: 
 1070: =head2 unresolved_contacts()
 1071: 
 1072: Returns a list of domains and URL hosts found in the message for which no
 1073: abuse contact could be determined.  Useful for surfacing parties that may
 1074: warrant manual investigation.
 1075: 
 1076: =head3 Usage
 1077: 
 1078:     my @unresolved = $analyser->unresolved_contacts();
 1079:     for my $u (@unresolved) {
 1080:         printf "Unresolved: %s (%s) via %s\n",
 1081:             $u->{domain}, $u->{type}, $u->{source};
 1082:     }
 1083: 
 1084: =head3 Arguments
 1085: 
 1086: None.
 1087: 
 1088: =head3 Returns
 1089: 
 1090: A list of hashrefs, each with keys C<domain>, C<type> (C<'url_host'> or
 1091: C<'domain'>), and C<source> (where the domain was found).
 1092: 
 1093: =head3 Side Effects
 1094: 
 1095: Triggers C<embedded_urls()>, C<mailto_domains()>, C<abuse_contacts()>,
 1096: and C<form_contacts()> if not already cached.
 1097: 
 1098: =head3 Notes
 1099: 
 1100: Domains sourced only from spoofable sending headers (C<From:>,
 1101: C<Return-Path:>, C<Sender:>) are excluded.
 1102: 
 1103: =head3 API Specification
 1104: 
 1105: =head4 Input
 1106: 
 1107:     []
 1108: 
 1109: =head4 Output
 1110: 
 1111:     (
 1112:         {
 1113:             type => 'hashref',
 1114:             keys => {
 1115:                 domain => { type => 'string' },
 1116:                 type   => { type => 'string', memberof => [ 'url_host', 'domain' ] },
 1117:                 source => { type => 'string' },
 1118:             },
 1119:         },
 1120:         ...
 1121:     )
 1122: 
 1123: =cut
 1124: 
 1125: sub unresolved_contacts {
●1126 → 1130 → 1140 1126: 	my $self = $_[0];
 1127: 
 1128: 	# Build a set of domains already covered by email or form contacts
 1129: 	my %covered;
 1130: 	for my $c ($self->abuse_contacts(), $self->form_contacts()) {
 1131: 		my $dom = $c->{form_domain};
 1132: 		unless ($dom) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 1133: 			# Extract domain from abuse email address
 1134: 			($dom) = ($c->{address} // '') =~ /\@([\w.-]+)/;
 1135: 		}
 1136: 		$covered{lc $dom}++ if $dom;
 1137: 	}
 1138: 
 1139: 	# Also mark URL hosts that already have a resolved abuse address
●1140 → 1140 → 1145 1140: 	for my $u ($self->embedded_urls()) {
 1141: 		(my $bare = lc $u->{host}) =~ s/^www\.//;
 1142: 		$covered{$bare}++ if $u->{abuse} && $u->{abuse} ne '(unknown)';
 1143: 	}
 1144: 
●1145 → 1148 → 1160 1145: 	my (@out, %seen);
 1146: 
 1147: 	# Check URL hosts first
 1148: 	for my $u ($self->embedded_urls()) {
 1149: 		(my $bare = lc $u->{host}) =~ s/^www\.//;
 1150: 		next if $covered{$bare};
 1151: 		next if $seen{"url:$bare"}++;
 1152: 		push @out, {
 1153: 			domain => $u->{host},
 1154: 			type   => 'url_host',
 1155: 			source => 'URL in body',
 1156: 		};
 1157: 	}
 1158: 
 1159: 	# Then check contact domains, skipping spoofable-header-only sources
●1160 → 1160 → 1173 1160: 	for my $d ($self->mailto_domains()) {
 1161: 		my $dom    = $d->{domain};
 1162: 		my $source = $d->{source} // '';
 1163: 		next if $source =~ /^(?:From:|Return-Path:|Sender:) header$/;
 1164: 		next if $covered{lc $dom};
 1165: 		next if $seen{"dom:$dom"}++;
 1166: 		push @out, {
 1167: 			domain => $dom,
 1168: 			type   => 'domain',
 1169: 			source => $source,
 1170: 		};
 1171: 	}
 1172: 
 1173: 	return @out;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 1174: }
 1175: 
 1176: # -----------------------------------------------------------------------
 1177: # Public: sending software fingerprint
 1178: # -----------------------------------------------------------------------
 1179: 
 1180: =head2 sending_software()
 1181: 
 1182: Returns information extracted from headers that identify the software or
 1183: server-side infrastructure used to compose or inject the message.  Headers
 1184: such as C<X-PHP-Originating-Script> reveal the exact PHP script and Unix
 1185: account responsible on shared-hosting platforms.
 1186: 
 1187: Data is extracted during C<parse_email()> with no network I/O.
 1188: 
 1189: =head3 Usage
 1190: 
 1191:     my @sw = $analyser->sending_software();
 1192:     for my $s (@sw) {
 1193:         printf "%-30s : %s\n", $s->{header}, $s->{value};
 1194:     }
 1195: 
 1196: =head3 Arguments
 1197: 
 1198: None.  C<parse_email()> must have been called first.
 1199: 
 1200: =head3 Returns
 1201: 
 1202: A list of hashrefs in alphabetical header-name order.  Returns an empty
 1203: list if none of the watched headers are present.  Each hashref has keys
 1204: C<header>, C<value>, and C<note>.
 1205: 
 1206: =head3 Side Effects
 1207: 
 1208: None.  Data is pre-collected during C<parse_email()>.
 1209: 
 1210: =head3 Notes
 1211: 
 1212: Header names are lower-cased.  Header values are stored verbatim.
 1213: 
 1214: =head3 API Specification
 1215: 
 1216: =head4 Input
 1217: 
 1218:     []
 1219: 
 1220: =head4 Output
 1221: 
 1222:     (
 1223:         {
 1224:             type => 'hashref',
 1225:             keys => {
 1226:                 header => { type => 'string' },
 1227:                 value  => { type => 'string' },
 1228:                 note   => { type => 'string' },
 1229:             },
 1230:         },
 1231:         ...
 1232:     )
 1233: 
 1234: =cut
 1235: 
 1236: sub sending_software {
 1237: 	my $self = $_[0];
 1238: 
 1239: 	return @{ $self->{_sending_sw} };

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 1240: }
 1241: 
 1242: # -----------------------------------------------------------------------
 1243: # Public: per-hop tracking IDs
 1244: # -----------------------------------------------------------------------
 1245: 
 1246: =head2 received_trail()
 1247: 
 1248: Returns per-hop tracking data extracted from the C<Received:> header chain:
 1249: the IP address, envelope recipient address, and server session ID for each
 1250: relay.  ISP postmasters use these identifiers to locate the SMTP session in
 1251: their logs.
 1252: 
 1253: =head3 Usage
 1254: 
 1255:     my @trail = $analyser->received_trail();
 1256:     for my $hop (@trail) {
 1257:         printf "IP: %s  ID: %s\n",
 1258:             $hop->{ip} // '?', $hop->{id} // '?';
 1259:     }
 1260: 
 1261: =head3 Arguments
 1262: 
 1263: None.  C<parse_email()> must have been called first.
 1264: 
 1265: =head3 Returns
 1266: 
 1267: A list of hashrefs in oldest-first order.  Returns an empty list if no
 1268: C<Received:> headers are present or none yielded extractable data.  Each
 1269: hashref has keys C<received>, C<ip> (may be undef), C<for> (may be undef),
 1270: C<id> (may be undef).
 1271: 
 1272: =head3 Side Effects
 1273: 
 1274: None.  Data is pre-collected during C<parse_email()>.
 1275: 
 1276: =head3 Notes
 1277: 
 1278: Private IPs are NOT filtered here; all IPs including RFC 1918 addresses
 1279: are returned as found.  Filtering is applied only by C<originating_ip()>.
 1280: 
 1281: =head3 API Specification
 1282: 
 1283: =head4 Input
 1284: 
 1285:     []
 1286: 
 1287: =head4 Output
 1288: 
 1289:     (
 1290:         {
 1291:             type => 'hashref',
 1292:             keys => {
 1293:                 received => { type => 'string' },
 1294:                 ip       => { type => 'string', optional => 1 },
 1295:                 for      => { type => 'string', optional => 1 },
 1296:                 id       => { type => 'string', optional => 1 },
 1297:             },
 1298:         },
 1299:         ...
 1300:     )
 1301: 
 1302: =cut
 1303: 
 1304: sub received_trail {
 1305: 	my $self = $_[0];
 1306: 
 1307: 	return @{ $self->{_rcvd_tracking} };

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 1308: }
 1309: 
 1310: # -----------------------------------------------------------------------
 1311: # Public: risk assessment
 1312: # -----------------------------------------------------------------------
 1313: 
 1314: =head2 risk_assessment()
 1315: 
 1316: Evaluates the message against heuristic checks and returns an overall risk
 1317: level, a weighted numeric score, and a list of every specific red flag.
 1318: 
 1319: The assessment covers five categories: originating IP, email authentication,
 1320: Date: header validity, identity/header consistency, and URL/domain properties.
 1321: 
 1322: The result is cached; subsequent calls return the same hashref without
 1323: repeating any analysis.
 1324: 
 1325: =head3 Usage
 1326: 
 1327:     my $risk = $analyser->risk_assessment();
 1328:     printf "Risk: %s (score: %d)\n", $risk->{level}, $risk->{score};
 1329:     for my $f (@{ $risk->{flags} }) {
 1330:         printf "  [%s] %s\n", $f->{severity}, $f->{detail};
 1331:     }
 1332: 
 1333: =head3 Arguments
 1334: 
 1335: None.  C<parse_email()> must have been called first.
 1336: 
 1337: =head3 Returns
 1338: 
 1339: A hashref with keys C<level> (HIGH/MEDIUM/LOW/INFO), C<score> (integer),
 1340: and C<flags> (arrayref of hashrefs with C<severity>, C<flag>, C<detail>).
 1341: 
 1342: =head3 Side Effects
 1343: 
 1344: Triggers C<originating_ip()>, C<embedded_urls()>, and C<mailto_domains()>
 1345: if not already cached.
 1346: 
 1347: =head3 Notes
 1348: 
 1349: Scores: HIGH >= 9, MEDIUM >= 5, LOW >= 2, INFO < 2.
 1350: Flag weights: HIGH=3, MEDIUM=2, LOW=1, INFO=0.
 1351: 
 1352: =head3 API Specification
 1353: 
 1354: =head4 Input
 1355: 
 1356:     []
 1357: 
 1358: =head4 Output
 1359: 
 1360:     {
 1361:         type => 'hashref',
 1362:         keys => {
 1363:             level => { type => 'string', memberof => ['HIGH', 'MEDIUM', 'LOW', 'INFO'] },
 1364:             score => { type => 'integer' },
 1365:             flags => { type => 'arrayref' },
 1366:         },
 1367:     }
 1368: 
 1369: =cut
 1370: 
 1371: sub risk_assessment {
 1372: 	my $self = $_[0];
 1373: 
 1374: 	return $self->{_risk} if $self->{_risk};

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 1375: 
 1376: 	my (@flags, $score);
 1377: 	$score = 0;
 1378: 
 1379: 	# Closure to record a flag and accumulate its weight
 1380: 	my $flag = sub {
 1381: 		my ($severity, $name, $detail) = @_;
 1382: 		$score += $FLAG_WEIGHT{$severity} // 1;
 1383: 		push @flags, { severity => $severity, flag => $name, detail => $detail };
 1384: 	};
 1385: 
 1386: 	$self->_risk_check_origin($flag);
 1387: 	$self->_risk_check_auth($flag);
 1388: 	$self->_risk_check_date($flag);
 1389: 	$self->_risk_check_identity($flag);
 1390: 	$self->_risk_check_urls_and_domains($flag);
 1391: 
 1392: 	# Determine overall risk level from accumulated score
 1393: 	my $level = $score >= $SCORE_HIGH   ? 'HIGH'

					

					Mutants (Total: 3, Killed: 0, Survived: 3)
					

 1394: 	          : $score >= $SCORE_MEDIUM ? 'MEDIUM'

					

					Mutants (Total: 3, Killed: 0, Survived: 3)
					

 1395: 	          : $score >= $SCORE_LOW    ? 'LOW'

					

					Mutants (Total: 3, Killed: 0, Survived: 3)
					

 1396: 	          :                           'INFO';
 1397: 
 1398: 	$self->{_risk} = { level => $level, score => $score, flags => \@flags };
 1399: 	return $self->{_risk};

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 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: 
 1414: sub _risk_check_origin :Private {
●1415 → 1422 → 1433 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} =~ /

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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 → 1433 → 1439 1433: 	if (!$orig->{rdns} || $orig->{rdns} eq '(no reverse DNS)') {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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 → 1439 → 1445 1439: 	if ($orig->{confidence} eq 'low') {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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 → 1445 → 0 1445: 	if ($orig->{country} && $orig->{country} =~ /^(?:CN|RU|NG|VN|IN|PK|BD)$/) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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: }
 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: 
 1463: sub _risk_check_auth :Private {
●1464 → 1467 → 1479 1464: 	my ($self, $flag) = @_;
 1465: 	my $auth = $self->_parse_auth_results_cached();
 1466: 
 1467: 	if (defined $auth->{spf}) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 1468: 		if ($auth->{spf} =~ /^fail/i) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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 → 1479 → 1483 1479: 	if (defined $auth->{dkim} && $auth->{dkim} !~ /^pass/i) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 1480: 		$flag->('HIGH', 'dkim_fail',
 1481: 			"DKIM result: $auth->{dkim} -- message signature invalid or absent");
 1482: 	}
●1483 → 1483 → 1488 1483: 	if (defined $auth->{dmarc} && $auth->{dmarc} !~ /^pass/i) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 1484: 		$flag->('HIGH', 'dmarc_fail', "DMARC result: $auth->{dmarc}");
 1485: 	}
 1486: 
 1487: 	# DKIM signing domain vs From: domain mismatch check
●1488 → 1496 → 0 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) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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: }
 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: 
 1520: sub _risk_check_date :Private {
●1521 → 1524 → 1531 1521: 	my ($self, $flag) = @_;
 1522: 	my $date_raw = $self->_header_value('date');
 1523: 
 1524: 	if (!$date_raw || $date_raw !~ /\S/) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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 → 1531 → 1545 1531: 	if ($date_raw =~ /([+-])(\d{2})(\d{2})\s*$/) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 1532: 		my ($sign, $hh, $mm) = ($1, $2, $3);
 1533: 		my $offset_mins = $hh * 60 + $mm;
 1534: 		my $implausible = $mm >= 60

					

					Mutants (Total: 3, Killed: 0, Survived: 3)
					

 1535: 			|| ($sign eq '+' && $offset_mins > $TZ_MAX_POS_MINS)

					

					Mutants (Total: 3, Killed: 0, Survived: 3)
					

 1536: 			|| ($sign eq '-' && $offset_mins > $TZ_MAX_NEG_MINS);

					

					Mutants (Total: 3, Killed: 0, Survived: 3)
					

 1537: 		if ($implausible) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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 → 1548 → 0 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) {

					

					Mutants (Total: 4, Killed: 0, Survived: 4)
					

 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)) {

					

					Mutants (Total: 3, Killed: 0, Survived: 3)
					

 1552: 		$flag->('LOW', 'suspicious_date',
 1553: 			"Date: '$date_raw' is more than $DATE_SKEW_DAYS days in the future");
 1554: 	}
 1555: }
 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: 
 1569: sub _risk_check_identity :Private {
●1570 → 1575 → 1591 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*<([^>]+)>/) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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 → 1591 → 1598 1591: 	if ($from_raw =~ /\@(gmail|yahoo|hotmail|outlook|live|aol|protonmail|yandex)\./i

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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 → 1599 → 1609 1598: 	my $reply_to = $self->_header_value('reply-to');
 1599: 	if ($reply_to) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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)) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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 → 1610 → 1616 1609: 	my $to = $self->_header_value('to') // '';
 1610: 	if ($to =~ /undisclosed|:;/ || $to eq '') {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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 → 1617 → 0 1616: 	my $subj_raw = $self->_header_value('subject') // '';
 1617: 	if ($subj_raw =~ /=\?[^?]+\?[BQ]\?/i) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 1618: 		$flag->('LOW', 'encoded_subject',
 1619: 			"Subject line is MIME-encoded: '$subj_raw' (decoded: '"
 1620: 			. $self->_decode_mime_words($subj_raw) . "')");
 1621: 	}
 1622: }
 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: 
 1636: sub _risk_check_urls_and_domains :Private {
●1637 → 1640 → 1667 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}++) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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}++) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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} }++) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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 → 1667 → 0 1667: 	for my $d ($self->mailto_domains()) {
 1668: 		# Recently registered domain is a common phishing indicator
 1669: 		if ($d->{recently_registered}) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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}) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 1676: 			if(my $exp = $self->_parse_date_to_epoch($d->{expires})) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 1677: 				my $now      = time();
 1678: 				my $remaining = $exp - $now;
 1679: 				if ($remaining > 0 && $remaining < $EXPIRY_WARN_DAYS * $SECS_PER_DAY) {

					

					Mutants (Total: 7, Killed: 0, Survived: 7)
					

 1680: 					$flag->('HIGH', 'domain_expires_soon',
 1681: 						"$d->{domain} expires $d->{expires} -- may be a throwaway domain");
 1682: 				} elsif ($remaining <= 0) {

					

					Mutants (Total: 3, Killed: 0, Survived: 3)
					

 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 &&

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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: }
 1701: 
 1702: # -----------------------------------------------------------------------
 1703: # Public: abuse report text
 1704: # -----------------------------------------------------------------------
 1705: 
 1706: =head2 abuse_report_text()
 1707: 
 1708: Produces a compact, plain-text string suitable for sending as the body of
 1709: an abuse report email.  It summarises risk level, red flags, originating IP,
 1710: abuse contacts, and original message headers.  The message body is omitted
 1711: to keep the report concise.
 1712: 
 1713: Use C<abuse_contacts()> to get the recipient addresses and this method for
 1714: the body text.
 1715: 
 1716: =head3 Usage
 1717: 
 1718:     my $text     = $analyser->abuse_report_text();
 1719:     my @contacts = $analyser->abuse_contacts();
 1720:     for my $c (@contacts) {
 1721:         send_email(to => $c->{address}, body => $text);
 1722:     }
 1723: 
 1724: =head3 Arguments
 1725: 
 1726: None.  C<parse_email()> must have been called first.
 1727: 
 1728: =head3 Returns
 1729: 
 1730: A plain scalar string, newline-terminated, Unix line endings.  Never empty
 1731: or undef.
 1732: 
 1733: =head3 Side Effects
 1734: 
 1735: Calls C<risk_assessment()>, C<originating_ip()>, and C<abuse_contacts()>
 1736: if not already cached.
 1737: 
 1738: =head3 Notes
 1739: 
 1740: Output text is sanitised: control characters that could affect terminal or
 1741: HTML rendering are stripped from all user-derived content before inclusion.
 1742: 
 1743: =head3 API Specification
 1744: 
 1745: =head4 Input
 1746: 
 1747:     []
 1748: 
 1749: =head4 Output
 1750: 
 1751:     { type => 'string' }
 1752: 
 1753: =cut
 1754: 
 1755: sub abuse_report_text {
●1756 → 1768 → 1777 1756: 	my $self = $_[0];
 1757: 	my @out;
 1758: 
 1759: 	push @out, 'This is an automated abuse report generated by Email::Abuse::Investigator.',
 1760: 		 'Please investigate the following spam/phishing message.',
 1761: 		'';
 1762: 
 1763: 	my $risk = $self->risk_assessment();
 1764: 	push @out, "RISK LEVEL: $risk->{level} (score: $risk->{score})",
 1765: 		'';
 1766: 
 1767: 	# List each red flag with its severity prefix
 1768: 	if (@{ $risk->{flags} }) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 1769: 		push @out, 'RED FLAGS IDENTIFIED:';
 1770: 		for my $f (@{ $risk->{flags} }) {
 1771: 			push @out, "  [$f->{severity}] " . _sanitise_output($f->{detail});
 1772: 		}
 1773: 		push @out, '';
 1774: 	}
 1775: 
 1776: 	# Originating IP summary block
●1777 → 1778 → 1786 1777: 	my $orig = $self->originating_ip();
 1778: 	if ($orig) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 1779: 		push @out, 'ORIGINATING IP: ' . _sanitise_output("$orig->{ip} ($orig->{rdns})"),
 1780: 			'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 → 1787 → 1801 1786: 	my @urls = $self->embedded_urls();
 1787: 	if (@urls) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 1788: 		push @out, 'REPORTED URLs:';
 1789: 		for my $u (@urls) {
 1790: 			push @out, '  ' . _sanitise_output($u->{url});
 1791: 			my @meta;
 1792: 			push @meta, "host: $u->{host}"   if $u->{host};
 1793: 			push @meta, "IP: $u->{ip}"       if $u->{ip} && $u->{ip} ne '(unresolved)';
 1794: 			push @meta, "org: $u->{org}"     if $u->{org} && $u->{org} ne '(unknown)';
 1795: 			push @out, '    (' . join('  ', @meta) . ')' if @meta;
 1796: 		}
 1797: 		push @out, '';
 1798: 	}
 1799: 
 1800: 	# Email abuse contacts
●1801 → 1802 → 1809 1801: 	my @contacts = $self->abuse_contacts();
 1802: 	if (@contacts) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 1803: 		push @out, 'ABUSE CONTACTS:';
 1804: 		push @out, '  ' . _sanitise_output("$_->{address} ($_->{role})") for @contacts;
 1805: 		push @out, '';
 1806: 	}
 1807: 
 1808: 	# Web-form contacts (providers that reject email)
●1809 → 1809 → 1823 1809: 	if(my @form_cs = $self->form_contacts()) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 1810: 		push @out, 'WEB-FORM REPORTS REQUIRED:',
 1811: 			'  The following parties do not accept email -- submit manually:';
 1812: 		for my $c (@form_cs) {
 1813: 			push @out, "  [$c->{role}]",
 1814: 				'    Form   : ' . _sanitise_output($c->{form});
 1815: 			push @out, '    Domain : ' . _sanitise_output($c->{form_domain}) if $c->{form_domain};
 1816: 			push @out, '    Paste  : ' . _sanitise_output($c->{form_paste})  if $c->{form_paste};
 1817: 			push @out, '    Upload : ' . _sanitise_output($c->{form_upload}) if $c->{form_upload};
 1818: 		}
 1819: 		push @out, '';
 1820: 	}
 1821: 
 1822: 	# Separator and raw headers (body excluded for brevity)
●1823 → 1827 → 1830 1823: 	push @out, '-' x 72,
 1824: 		'ORIGINAL MESSAGE HEADERS:',
 1825: 		'-' x 72;
 1826: 
 1827: 	for my $h (@{ $self->{_headers} }) {
 1828: 		push @out, _sanitise_output("$h->{name}: $h->{value}");
 1829: 	}
 1830: 	push @out, '';
 1831: 
 1832: 	return join("\n", @out);

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 1833: }
 1834: 
 1835: # -----------------------------------------------------------------------
 1836: # Public: abuse contacts
 1837: # -----------------------------------------------------------------------
 1838: 
 1839: =head2 abuse_contacts()
 1840: 
 1841: Collates the complete set of parties that should receive an abuse report:
 1842: the sending ISP, URL host operators, contact domain web/mail/DNS/registrar
 1843: contacts, account providers identified from key headers, the DKIM signer,
 1844: and the ESP identified via List-Unsubscribe.
 1845: 
 1846: Addresses are deduplicated globally; if the same address is found via
 1847: multiple routes, a single entry is kept and role strings are merged.
 1848: 
 1849: =head3 Usage
 1850: 
 1851:     my @contacts = $analyser->abuse_contacts();
 1852:     my @addrs    = map { $_->{address} } @contacts;
 1853: 
 1854: =head3 Arguments
 1855: 
 1856: None.  C<parse_email()> must have been called first.
 1857: 
 1858: =head3 Returns
 1859: 
 1860: A list of hashrefs, one per unique abuse address, in discovery order.
 1861: Each hashref has keys C<role>, C<roles> (arrayref), C<address>, C<note>,
 1862: C<via>.  Returns an empty list if no contacts can be determined.
 1863: 
 1864: =head3 Side Effects
 1865: 
 1866: Triggers C<originating_ip()>, C<embedded_urls()>, and C<mailto_domains()>
 1867: if not already cached.
 1868: 
 1869: =head3 Notes
 1870: 
 1871: The result is cached on the object; subsequent calls return the same list
 1872: without repeating the contact-collection logic.  The underlying per-IP and
 1873: per-domain lookups are themselves cached by C<originating_ip()>,
 1874: C<embedded_urls()>, and C<mailto_domains()>.
 1875: 
 1876: =head3 API Specification
 1877: 
 1878: =head4 Input
 1879: 
 1880:     []
 1881: 
 1882: =head4 Output
 1883: 
 1884:     (
 1885:         {
 1886:             type => 'hashref',
 1887:             keys => {
 1888:                 role    => { type => 'string' },
 1889:                 roles   => { type => 'arrayref' },
 1890:                 address => { type => 'string', regex => qr/\@/ },
 1891:                 note    => { type => 'string' },
 1892:                 via     => { type => 'string', memberof => [ 'provider-table', 'ip-whois', 'domain-whois' ] }
 1893:             },
 1894:         },
 1895:         ...
 1896:     )
 1897: 
 1898: =cut
 1899: 
 1900: sub abuse_contacts {
 1901: 	my $self = $_[0];
 1902: 	$self->{_contacts} //= [ $self->_compute_abuse_contacts() ];
 1903: 	return @{ $self->{_contacts} };

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 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: 
 1918: sub _compute_abuse_contacts :Private {
●1919 → 1990 → 2011 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.-]+)$/) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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}) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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{$_})" : $_

					

					Mutants (Total: 3, Killed: 0, Survived: 3)
					

 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) {

					

					Mutants (Total: 4, Killed: 0, Survived: 4)
					

 1958: 				my (@url_hosts, %seen_short, @short);
 1959: 				for my $r (@display) {
 1960: 					if ($r =~ /^URL host:\s*(.+)$/) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 1970: 					my $extra = @url_hosts > 3

					

					Mutants (Total: 3, Killed: 0, Survived: 3)
					

 1971: 						? ' and ' . (@url_hosts - 3) . ' more' : '';
 1972: 					my @shown = @url_hosts > 3 ? @url_hosts[0..2] : @url_hosts;

					

					Mutants (Total: 3, Killed: 0, Survived: 3)
					

 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) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 1991: 		my $pa = $self->_provider_abuse_for_ip($orig->{ip}, $orig->{rdns});
 1992: 		if ($pa) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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)') {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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 → 2012 → 2039 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) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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)') {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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 → 2039 → 2106 2039: 	for my $d ($self->mailto_domains()) {
 2040: 		my $dom = $d->{domain};
 2041: 
 2042: 		# Web host contact
 2043: 		if ($d->{web_abuse}) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 2044: 			my $pa = $self->_provider_abuse_for_host($dom);
 2045: 			if ($pa) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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}) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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}) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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}) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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 → 2106 → 2131 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) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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 → 2132 → 2145 2131: 	my $auth = $self->_parse_auth_results_cached();
 2132: 	if ($auth->{dkim_domain}) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 2133: 		my $pa = $self->_provider_abuse_for_host($auth->{dkim_domain});
 2134: 		if ($pa) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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 → 2146 → 2169 2145: 	my $unsub = $self->_header_value('list-unsubscribe');
 2146: 	if ($unsub) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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 → 2171 → 2185 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;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 2186: }
 2187: 
 2188: # -----------------------------------------------------------------------
 2189: # Public: form contacts (providers that require web-form submission)
 2190: # -----------------------------------------------------------------------
 2191: 
 2192: =head2 form_contacts()
 2193: 
 2194: Returns the list of parties that require abuse reports via a web form
 2195: rather than email.  These are providers whose C<%PROVIDER_ABUSE> entry
 2196: has a C<form> key.  Each hashref includes the form URL, paste
 2197: instructions, upload instructions, and the discovery role.
 2198: 
 2199: =head3 Usage
 2200: 
 2201:     my @forms = $analyser->form_contacts();
 2202:     for my $c (@forms) {
 2203:         printf "Open: %s\n", $c->{form};
 2204:     }
 2205: 
 2206: =head3 Arguments
 2207: 
 2208: None.  C<parse_email()> must have been called first.
 2209: 
 2210: =head3 Returns
 2211: 
 2212: A list of hashrefs, one per unique form contact.  Each hashref has keys
 2213: C<form>, C<role>, C<note>, C<form_paste> (optional), C<form_upload>
 2214: (optional), and C<via>.  Returns an empty list if no form contacts are found.
 2215: 
 2216: =head3 Side Effects
 2217: 
 2218: Triggers C<originating_ip()>, C<embedded_urls()>, and C<mailto_domains()>
 2219: if not already cached.
 2220: 
 2221: =head3 Notes
 2222: 
 2223: Deduplication is by form URL.
 2224: 
 2225: =head3 API Specification
 2226: 
 2227: =head4 Input
 2228: 
 2229:     []
 2230: 
 2231: =head4 Output
 2232: 
 2233:     (
 2234:         {
 2235:             type => 'hashref',
 2236:             keys => {
 2237:                 form        => { type => 'string', regex => qr{^https?://} },
 2238:                 role        => { type => 'string' },
 2239:                 note        => { type => 'string' },
 2240:                 form_paste  => { type => 'string', optional => 1 },
 2241:                 form_upload => { type => 'string', optional => 1 },
 2242:                 via         => { type => 'string' },
 2243:             },
 2244:         },
 2245:         ...
 2246:     )
 2247: 
 2248: =cut
 2249: 
 2250: sub form_contacts {
●2251 → 2266 → 2281 2251: 	my $self = $_[0];
 2252: 
 2253: 	my (@contacts, %seen);
 2254: 
 2255: 	# Inner closure: add one form-contact entry, deduplicating by form URL
 2256: 	my $add = sub {
 2257: 		my (%args) = @_;
 2258: 		my $form = $args{form} // '';
 2259: 		return unless $form;
 2260: 		return if $seen{$form}++;
 2261: 		push @contacts, \%args;
 2262: 	};
 2263: 
 2264: 	# Route 1 -- Sending ISP
 2265: 	my $orig = $self->originating_ip();
 2266: 	if ($orig) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 2267: 		my $pa = $self->_provider_abuse_for_ip($orig->{ip}, $orig->{rdns});
 2268: 		if ($pa && $pa->{form}) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 2269: 			$add->(
 2270: 				role        => 'Sending ISP',
 2271: 				form        => $pa->{form},
 2272: 				note        => $pa->{note} // '',
 2273: 				form_paste  => $pa->{form_paste}  // '',
 2274: 				form_upload => $pa->{form_upload} // '',
 2275: 				via         => 'provider-table',
 2276: 			);
 2277: 		}
 2278: 	}
 2279: 
 2280: 	# Route 2 -- URL hosts
●2281 → 2282 → 2299 2281: 	my %url_host_seen;
 2282: 	for my $u ($self->embedded_urls()) {
 2283: 		next if $url_host_seen{ $u->{host} }++;
 2284: 		my $pa = $self->_provider_abuse_for_host($u->{host});
 2285: 		if ($pa && $pa->{form}) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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: 				form_upload => $pa->{form_upload} // '',
 2293: 				via         => 'provider-table',
 2294: 			);
 2295: 		}
 2296: 	}
 2297: 
 2298: 	# Route 3 -- Contact domains (web host + registrar)
●2299 → 2299 → 2333 2299: 	for my $d ($self->mailto_domains()) {
 2300: 		my $dom = $d->{domain};
 2301: 		my $pa  = $self->_provider_abuse_for_host($dom);
 2302: 		if ($pa && $pa->{form}) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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: 				form_upload => $pa->{form_upload} // '',
 2310: 				via         => 'provider-table',
 2311: 			);
 2312: 		}
 2313: 
 2314: 		# Registrar identified via WHOIS -- check for form-only registrar
 2315: 		if ($d->{registrar_abuse} && $d->{registrar_abuse} =~ /\@([\w.-]+)/) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 2316: 			my $reg_domain = lc $1;
 2317: 			my $rpa = $self->_provider_abuse_for_host($reg_domain);
 2318: 			if ($rpa && $rpa->{form}) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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: 					form_upload => $rpa->{form_upload} // '',
 2326: 					via         => 'provider-table',
 2327: 				);
 2328: 			}
 2329: 		}
 2330: 	}
 2331: 
 2332: 	# Route 4 -- Account provider headers
●2333 → 2333 → 2356 2333: 	for my $hname (qw(from reply-to return-path sender)) {
 2334: 		my $val = $self->_header_value($hname) // next;
 2335: 		my $addr_spec = ($val =~ /<([^>]*)>\s*$/) ? $1 : $val;
 2336: 		my ($addr_domain) = $addr_spec =~ /\@([\w.-]+)/;
 2337: 		next unless $addr_domain;
 2338: 		# Skip SRS forwarder rewrite addresses
 2339: 		next if $addr_spec =~ /\+SRS[0-9]?=/i;
 2340: 		my $pa = $self->_provider_abuse_for_host($addr_domain);
 2341: 		if ($pa && $pa->{form}) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 2342: 			my $role_addr = $addr_spec =~ /@/ ? $addr_spec : $val;
 2343: 			$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: 				form_upload => $pa->{form_upload} // '',
 2350: 				via         => 'provider-table',
 2351: 			);
 2352: 		}
 2353: 	}
 2354: 
 2355: 	# Route 5 -- DKIM signer
●2356 → 2357 → 2372 2356: 	my $auth = $self->_parse_auth_results_cached();
 2357: 	if ($auth->{dkim_domain}) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 2358: 		my $pa = $self->_provider_abuse_for_host($auth->{dkim_domain});
 2359: 		if ($pa && $pa->{form}) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 2360: 			$add->(
 2361: 				role        => "DKIM signer: $auth->{dkim_domain}",
 2362: 				form        => $pa->{form},
 2363: 				note        => $pa->{note} // '',
 2364: 				form_paste  => $pa->{form_paste}  // '',
 2365: 				form_upload => $pa->{form_upload} // '',
 2366: 				via         => 'provider-table',
 2367: 			);
 2368: 		}
 2369: 	}
 2370: 
 2371: 	# Route 6 -- List-Unsubscribe ESP domains
●2372 → 2373 → 2393 2372: 	my $unsub = $self->_header_value('list-unsubscribe');
 2373: 	if ($unsub) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 2374: 		my @unsub_domains;
 2375: 		while ($unsub =~ m{https?://([^/:?\s>]+)}gi) { push @unsub_domains, lc $1 }
 2376: 		while ($unsub =~ m{mailto:[^@\s>]+\@([\w.-]+)}gi) { push @unsub_domains, lc $1 }
 2377: 		my %useen;
 2378: 		for my $dom (grep { !$useen{$_}++ } @unsub_domains) {
 2379: 			my $pa = $self->_provider_abuse_for_host($dom);
 2380: 			if ($pa && $pa->{form}) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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: 					form_upload => $pa->{form_upload} // '',
 2387: 					via         => 'provider-table',
 2388: 				);
 2389: 			}
 2390: 		}
 2391: 	}
 2392: 
 2393: 	return @contacts;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 2394: }
 2395: 
 2396: # -----------------------------------------------------------------------
 2397: # Public: full analyst report
 2398: # -----------------------------------------------------------------------
 2399: 
 2400: =head2 report()
 2401: 
 2402: Produces a comprehensive, analyst-facing plain-text report covering all
 2403: findings: envelope fields, risk assessment, originating host, sending
 2404: software, received chain tracking IDs, embedded URLs, contact domain
 2405: intelligence, and recommended abuse contacts.
 2406: 
 2407: Use C<report()> for human review or ticketing systems.  Use
 2408: C<abuse_report_text()> for sending to ISP abuse desks.
 2409: 
 2410: =head3 Usage
 2411: 
 2412:     print $analyser->report();
 2413: 
 2414:     open my $fh, '>', 'report.txt' or croak "Cannot open: $!";
 2415:     print $fh $analyser->report();
 2416:     close $fh;
 2417: 
 2418: =head3 Arguments
 2419: 
 2420: None.  C<parse_email()> must have been called first.
 2421: 
 2422: =head3 Returns
 2423: 
 2424: A plain scalar string, newline-terminated, Unix line endings.  Never empty
 2425: or undef.
 2426: 
 2427: =head3 Side Effects
 2428: 
 2429: Triggers all analysis methods if not already cached.
 2430: 
 2431: =head3 Notes
 2432: 
 2433: The report is idempotent: calling it multiple times on the same object
 2434: always returns an identical string.  All user-derived content is sanitised
 2435: before output.
 2436: 
 2437: =head3 API Specification
 2438: 
 2439: =head4 Input
 2440: 
 2441:     []
 2442: 
 2443: =head4 Output
 2444: 
 2445:     { type => 'string' }
 2446: 
 2447: =cut
 2448: 
 2449: sub report {
●2450 → 2461 → 2469 2450: 	my $self = $_[0];
 2451: 
 2452: 	my @out;
 2453: 
 2454: 	# Banner header
 2455: 	push @out, '=' x 72;
 2456: 	push @out, "  Email::Abuse::Investigator Report  (v$VERSION)";
 2457: 	push @out, '=' x 72;
 2458: 	push @out, '';
 2459: 
 2460: 	# Envelope summary -- decode MIME encoded-words for readability
 2461: 	for my $f (qw(from reply-to return-path subject date message-id)) {
 2462: 		my $v = $self->_header_value($f);
 2463: 		next unless defined $v;
 2464: 		my $decoded = $self->_decode_mime_words($v);
 2465: 		my $label   = ucfirst($f);
 2466: 		push @out, sprintf('  %-14s : %s', $label,
 2467: 			_sanitise_output($decoded ne $v ? "$decoded  [encoded: $v]" : $v));
 2468: 	}
●2469 → 2474 → 2481 2469: 	push @out, '';
 2470: 
 2471: 	# Risk assessment section
 2472: 	my $risk = $self->risk_assessment();
 2473: 	push @out, "[ RISK ASSESSMENT: $risk->{level} (score: $risk->{score}) ]";
 2474: 	if (@{ $risk->{flags} }) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 2475: 		for my $f (@{ $risk->{flags} }) {
 2476: 			push @out, "  [$f->{severity}] " . _sanitise_output($f->{detail});
 2477: 		}
 2478: 	} else {
 2479: 		push @out, '  (no specific red flags detected)';
 2480: 	}
●2481 → 2485 → 2496 2481: 	push @out, '';
 2482: 
 2483: 	# Originating host section
 2484: 	push @out, '[ ORIGINATING HOST ]';
 2485: 	if(my $orig = $self->originating_ip()) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 2486: 		push @out, '  IP           : ' . _sanitise_output($orig->{ip});
 2487: 		push @out, '  Reverse DNS  : ' . _sanitise_output($orig->{rdns})    if $orig->{rdns};
 2488: 		push @out, '  Country      : ' . _sanitise_output($orig->{country}) if $orig->{country};
 2489: 		push @out, '  Organisation : ' . _sanitise_output($orig->{org})     if $orig->{org};
 2490: 		push @out, '  Abuse addr   : ' . _sanitise_output($orig->{abuse})   if $orig->{abuse};
 2491: 		push @out, "  Confidence   : $orig->{confidence}";
 2492: 		push @out, '  Note         : ' . _sanitise_output($orig->{note})    if $orig->{note};
 2493: 	} else {
 2494: 		push @out, '  (could not determine originating IP)';
 2495: 	}
●2496 → 2500 → 2510 2496: 	push @out, '';
 2497: 
 2498: 	# Sending software section (omitted if none found)
 2499: 	my @sw = $self->sending_software();
 2500: 	if (@sw) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 2501: 		push @out, '[ SENDING SOFTWARE / INFRASTRUCTURE CLUES ]';
 2502: 		for my $s (@sw) {
 2503: 			push @out, sprintf('  %-14s : %s', $s->{header}, _sanitise_output($s->{value}));
 2504: 			push @out, "  Note           : $s->{note}";
 2505: 			push @out, '';
 2506: 		}
 2507: 	}
 2508: 
 2509: 	# Received chain tracking IDs (only hops with id or for are shown)
●2510 → 2512 → 2525 2510: 	my @trail = grep { defined $_->{id} || defined $_->{for} }
 2511: 	            $self->received_trail();
 2512: 	if (@trail) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 2513: 		push @out, '[ RECEIVED CHAIN TRACKING IDs ]';
 2514: 		push @out, '  (Supply these to the relevant ISP abuse team to trace the session)';
 2515: 		push @out, '';
 2516: 		for my $hop (@trail) {
 2517: 			push @out, '  IP           : ' . (_sanitise_output($hop->{ip}) // '(unknown)');
 2518: 			push @out, '  Envelope for : ' . _sanitise_output($hop->{for}) if $hop->{for};
 2519: 			push @out, '  Server ID    : ' . _sanitise_output($hop->{id})  if $hop->{id};
 2520: 			push @out, '';
 2521: 		}
 2522: 	}
 2523: 
 2524: 	# Embedded URLs section -- grouped by hostname
●2525 → 2527 → 2570 2525: 	push @out, '[ EMBEDDED HTTP/HTTPS URLs ]';
 2526: 	my @urls = $self->embedded_urls();
 2527: 	if (@urls) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 2528: 		my (%host_order, %host_meta, %host_paths);
 2529: 		my $seq = 0;
 2530: 		for my $u (@urls) {
 2531: 			my $h = $u->{host};
 2532: 			unless (exists $host_order{$h}) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 2533: 				$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: 				};
 2540: 			}
 2541: 			push @{ $host_paths{$h} }, $u->{url};
 2542: 		}
 2543: 
 2544: 		# Output each host group in first-seen order
 2545: 		for my $h (sort { $host_order{$a} <=> $host_order{$b} } keys %host_order) {
 2546: 			my $m    = $host_meta{$h};
 2547: 			my $bare = lc $h; $bare =~ s/^www\.//;
 2548: 			push @out, '  Host         : ' . _sanitise_output($h) .
 2549: 			           (($URL_SHORTENERS{$bare} || $self->{url_shorteners}->{$bare})
 2550: 			            ? '  *** URL SHORTENER -- real destination hidden ***' : '');
 2551: 			push @out, '  IP           : ' . _sanitise_output($m->{ip})      if $m->{ip};
 2552: 			push @out, '  Country      : ' . _sanitise_output($m->{country}) if $m->{country};
 2553: 			push @out, '  Organisation : ' . _sanitise_output($m->{org})     if $m->{org};
 2554: 			push @out, '  Abuse addr   : ' . _sanitise_output($m->{abuse})   if $m->{abuse};
 2555: 			my @paths = @{ $host_paths{$h} };
 2556: 			if (@paths == 1) {

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 2557: 				push @out, '  URL          : ' . _sanitise_output($paths[0]);
 2558: 			} else {
 2559: 				push @out, '  URLs (' . scalar(@paths) . ')     :';
 2560: 				push @out, '    ' . _sanitise_output($_) for @paths;
 2561: 			}
 2562: 			push @out, '';
 2563: 		}
 2564: 	} else {
 2565: 		push @out, '  (none found)';
 2566: 		push @out, '';
 2567: 	}
 2568: 
 2569: 	# Contact / reply-to domains section
●2570 → 2572 → 2612 2570: 	push @out, '[ CONTACT / REPLY-TO DOMAINS ]';
 2571: 	my @mdoms = $self->mailto_domains();
 2572: 	if (@mdoms) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 2573: 		for my $d (@mdoms) {
 2574: 			push @out, '  Domain       : ' . _sanitise_output($d->{domain});
 2575: 			push @out, '  Found in     : ' . _sanitise_output($d->{source});
 2576: 			if ($d->{recently_registered}) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 2577: 				push @out, '  *** WARNING: RECENTLY REGISTERED - possible phishing domain ***';
 2578: 			}
 2579: 			push @out, '  Registered   : ' . $d->{registered}       if $d->{registered};
 2580: 			push @out, '  Expires      : ' . $d->{expires}           if $d->{expires};
 2581: 			push @out, '  Registrar    : ' . _sanitise_output($d->{registrar})       if $d->{registrar};
 2582: 			push @out, '  Reg. abuse   : ' . _sanitise_output($d->{registrar_abuse}) if $d->{registrar_abuse};
 2583: 			if ($d->{web_ip}) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 2584: 				push @out, '  Web host IP  : ' . _sanitise_output($d->{web_ip});
 2585: 				push @out, '  Web host org : ' . _sanitise_output($d->{web_org})   if $d->{web_org};
 2586: 				push @out, '  Web abuse    : ' . _sanitise_output($d->{web_abuse}) if $d->{web_abuse};
 2587: 			} else {
 2588: 				push @out, '  Web host     : (no A record / unreachable)';
 2589: 			}
 2590: 			if ($d->{mx_host}) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 2591: 				push @out, '  MX host      : ' . _sanitise_output($d->{mx_host});
 2592: 				push @out, '  MX IP        : ' . _sanitise_output($d->{mx_ip})    if $d->{mx_ip};
 2593: 				push @out, '  MX org       : ' . _sanitise_output($d->{mx_org})   if $d->{mx_org};
 2594: 				push @out, '  MX abuse     : ' . _sanitise_output($d->{mx_abuse}) if $d->{mx_abuse};
 2595: 			} else {
 2596: 				push @out, '  MX host      : (none found)';
 2597: 			}
 2598: 			if ($d->{ns_host}) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 2599: 				push @out, '  NS host      : ' . _sanitise_output($d->{ns_host});
 2600: 				push @out, '  NS IP        : ' . _sanitise_output($d->{ns_ip})    if $d->{ns_ip};
 2601: 				push @out, '  NS org       : ' . _sanitise_output($d->{ns_org})   if $d->{ns_org};
 2602: 				push @out, '  NS abuse     : ' . _sanitise_output($d->{ns_abuse}) if $d->{ns_abuse};
 2603: 			}
 2604: 			push @out, '';
 2605: 		}
 2606: 	} else {
 2607: 		push @out, '  (none found)';
 2608: 		push @out, '';
 2609: 	}
 2610: 
 2611: 	# Abuse contacts summary
●2612 → 2614 → 2628 2612: 	push @out, '[ WHERE TO SEND ABUSE REPORTS ]';
 2613: 	my @contacts = $self->abuse_contacts();
 2614: 	if (@contacts) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 2615: 		for my $c (@contacts) {
 2616: 			push @out, '  Role         : ' . _sanitise_output($c->{role});
 2617: 			push @out, '  Send to      : ' . _sanitise_output($c->{address});
 2618: 			push @out, '  Note         : ' . _sanitise_output($c->{note}) if $c->{note};
 2619: 			push @out, "  Discovered   : $c->{via}";
 2620: 			push @out, '';
 2621: 		}
 2622: 	} else {
 2623: 		push @out, '  (no abuse contacts could be determined)';
 2624: 		push @out, '';
 2625: 	}
 2626: 
 2627: 	# Web-form contacts (providers that require manual form submission)
●2628 → 2629 → 2661 2628: 	my @form_cs = $self->form_contacts();
 2629: 	if (@form_cs) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 2630: 		push @out, '[ WHERE TO FILE WEB-FORM REPORTS ]';
 2631: 		push @out, '  The following parties require manual submission via a web form.';
 2632: 		push @out, '  Open each URL in a browser, then follow the instructions below it.';
 2633: 		push @out, '';
 2634: 		for my $c (@form_cs) {
 2635: 			push @out, '  Role         : ' . _sanitise_output($c->{role});
 2636: 			push @out, '  Form URL     : ' . _sanitise_output($c->{form});
 2637: 			push @out, '  Domain/URL   : ' . _sanitise_output($c->{form_domain}) if $c->{form_domain};
 2638: 			push @out, '  Note         : ' . _sanitise_output($c->{note})        if $c->{note};
 2639: 			if ($c->{form_paste}) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 2640: 				# Word-wrap the paste hint at ROLE_WRAP_LEN characters
 2641: 				my $hint  = $c->{form_paste};
 2642: 				my @words = split /\s+/, $hint;
 2643: 				my (@lines, $line);
 2644: 				for my $w (@words) {
 2645: 					if (defined $line && length("$line $w") > $ROLE_WRAP_LEN) {

					

					Mutants (Total: 4, Killed: 0, Survived: 4)
					

 2646: 						push @lines, $line;
 2647: 						$line = $w;
 2648: 					} else {
 2649: 						$line = defined $line ? "$line $w" : $w;
 2650: 					}
 2651: 				}
 2652: 				push @lines, $line if defined $line;
 2653: 				push @out, '  Paste        : ' . shift @lines if @lines;
 2654: 				push @out, '                 ' . $_ for @lines;
 2655: 			}
 2656: 			push @out, '  Upload       : ' . _sanitise_output($c->{form_upload}) if $c->{form_upload};
 2657: 			push @out, '';
 2658: 		}
 2659: 	}
 2660: 
 2661: 	push @out, '=' x 72;
 2662: 	return join("\n", @out) . "\n";

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 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: 
 2688: sub _sanitise_output :Private {
 2689: 	my $str = $_[0];
 2690: 	return '' unless defined $str;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 2691: 	# Remove C0 controls (except tab) and DEL
 2692: 	$str =~ s/[\x00-\x08\x0B\x0C\x0E-\x1F\x7F]//g;
 2693: 	return $str;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 2694: }
 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: 
 2725: sub _split_message :Private {
●2726 → 2739 → 2744 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*(.*)/) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 2741: 			push @headers, { name => lc($1), value => $2 };
 2742: 		}
 2743: 	}
●2744 → 2759 → 2769 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) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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 }

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 2766: 		else                 { $self->{_body_plain} = $decoded }
 2767: 	}
 2768: 
●2769 → 2783 → 2795 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 → 2795 → 0 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: }
 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: 
 2833: sub _decode_multipart :Private {
●2834 → 2839 → 2846 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) {

					

					Mutants (Total: 4, Killed: 0, Survived: 4)
					

 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 → 2848 → 0 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) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 2873: 			my ($inner_boundary) = $pct =~ /boundary\s*=\s*"?([^";]+)"?/i;
 2874: 			if ($inner_boundary) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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 }

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 2885: 		elsif ($pct =~ /text/i || !$pct) { $self->{_body_plain} .= $decoded }
 2886: 	}
 2887: }
 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: 
 2906: sub _decode_body :Private {
 2907: 	my ($self, $body, $cte) = @_;
 2908: 	$cte //= '';
 2909: 	return decode_qp($body)     if $cte =~ /quoted-printable/i;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 2910: 	return decode_base64($body) if $cte =~ /base64/i;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 2911: 	return $body // '';

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 2912: }
 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: 
 2941: sub _find_origin :Private {
●2942 → 2947 → 2955 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 → 2955 → 2967 2955: 	unless (@candidates) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 2956: 		my $xoip = $self->_header_value('x-originating-ip');
 2957: 		if ($xoip) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 2958: 			$xoip =~ s/[\[\]\s]//g;
 2959: 			return $self->_enrich_ip($xoip, 'low',

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 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(

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 2968: 		$candidates[0],
 2969: 		@candidates > 1 ? 'high' : 'medium',

					

					Mutants (Total: 3, Killed: 0, Survived: 3)
					

 2970: 		'First external hop in Received: chain',
 2971: 	);
 2972: }
 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: 
 2991: sub _extract_ip_from_received :Private {
●2992 → 2993 → 3006 2992: 	my ($self, $hdr) = @_;
 2993: 	for my $re (@RECEIVED_IP_RE) {
 2994: 		if ($hdr =~ $re) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 2995: 			my $ip = $1;
 2996: 
 2997: 			# Accept IPv6 addresses (contain colons) without further validation
 2998: 			return $ip if $ip =~ /:/;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 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;

					

					Mutants (Total: 3, Killed: 0, Survived: 3)
					

 3003: 			return $ip;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 3004: 		}
 3005: 	}
 3006: 	return;
 3007: }
 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: 
 3026: sub _is_private :Private {
●3027 → 3029 → 3030 3027: 	my ($self, $ip) = @_;
 3028: 	return 1 if !defined($ip) || $ip eq '';

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 3029: 	for my $re (@PRIVATE_RANGES) { return 1 if $ip =~ $re }

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 3030: 	return 0;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 3031: }
 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: 
 3046: sub _is_trusted :Private {
●3047 → 3048 → 3051 3047: 	my ($self, $ip) = @_;
 3048: 	for my $cidr (@{ $self->{trusted_relays} }) {
 3049: 		return 1 if $self->_ip_in_cidr($ip, $cidr);

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 3050: 	}
 3051: 	return 0;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 3052: }
 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: 
 3075: sub _extract_and_resolve_urls :Private {
●3076 → 3090 → 3104 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 → 3105 → 3111 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 → 3111 → 3116 3111: 	if ($HAS_ANYEVENT_DNS && scalar(keys %hostname_needed) > 1) {

					

					Mutants (Total: 4, Killed: 0, Survived: 4)
					

 3112: 		$self->_parallel_resolve_hosts(\%hostname_needed, \%host_cache);
 3113: 	}
 3114: 
 3115: 	# Process each URL: resolve hostname and WHOIS-enrich
●3116 → 3116 → 3154 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}) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 3122: 			# Check the cross-message CHI cache first
 3123: 			my $cached = $_cache ? $_cache->get("url:$host") : undef;
 3124: 			if ($cached) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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}) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 3155: }
 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: 
 3171: sub _is_redirect_cloaker :Private {
●3172 → 3174 → 3178 3172: 	my (undef, $host) = @_;
 3173: 	return 1 if $REDIRECT_HOSTS{$host};

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 3174: 	for my $suffix (@REDIRECT_HOST_SUFFIXES) {
 3175: 		return 1 if length($host) > length($suffix)

					

					Mutants (Total: 5, Killed: 0, Survived: 5)
					

 3176: 		         && substr($host, -length($suffix)) eq $suffix;
 3177: 	}
 3178: 	return '';

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 3179: }
 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: 
 3207: sub _follow_redirect_chain :Protected {
●3208 → 3212 → 3219 3208: 	my ($self, $url) = @_;
 3209: 	return undef unless $HAS_LWP;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 3210: 
 3211: 	# Serve from cache when available
 3212: 	if ($_cache) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 3213: 		my $cached = $_cache->get("redirect:$url");
 3214: 		return $cached if defined $cached;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 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.
●[NOT COVERED] 3219 → 3219 → 3233 3219: 	unless (defined $self->{_ua_nofollow}) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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: 	}
●[NOT COVERED] 3233 → 3237 → 3278 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()) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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["']?[^>]+

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 3281: }
 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: 
 3302: sub _parallel_resolve_hosts :Private {
●3303 → 3317 → 3334 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) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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;

					

					Mutants (Total: 3, Killed: 0, Survived: 3)
					

 3329: 			},
 3330: 		);
 3331: 	}
 3332: 
 3333: 	# Block until all DNS queries complete (subject to AnyEvent's own timeouts)
 3334: 	$cv->recv;
 3335: }
 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: 
 3350: sub _extract_http_urls :Private {
●3351 → 3355 → 3372 3351: 	my ($self, $body) = @_;
 3352: 	my @urls;
 3353: 
 3354: 	# Structural HTML link extraction (handles quoted attributes correctly)
 3355: 	if ($HAS_HTML_LINKEXTOR) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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 → 3372 → 3377 3372: 	while ($body =~ m{(https?://[^\s<>"'\)\]]+)}gi) {
 3373: 		push @urls, $1;
 3374: 	}
 3375: 
 3376: 	# Protocol-relative URLs not caught above
●3377 → 3377 → 3382 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;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 3386: }
 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: 
 3409: sub _extract_and_analyse_domains :Private {
●3410 → 3415 → 3425 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 → 3425 → 3434 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 → 3456 → 3463 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 → 3464 → 3472 3463: 	my $mid = $self->_header_value('message-id');
 3464: 	if ($mid && $mid =~ /\@([\w.-]+)/) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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 → 3473 → 3478 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 → 3479 → 3489 3478: 	my $unsub = $self->_header_value('list-unsubscribe');
 3479: 	if ($unsub) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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 → 3495 → 3499 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;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 3500: }
 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: 
 3514: sub _domains_from_text :Private {
●3515 → 3519 → 3525 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 → 3525 → 3529 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;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 3530: }
 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: 
 3559: sub _analyse_domain :Private {
●3560 → 3567 → 3575 3560: 	my ($self, $domain) = @_;
 3561: 
 3562: 	# Return the per-message cached result if already analysed
 3563: 	return $self->{_domain_info}{$domain}

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 3564: 		if $self->{_domain_info}{$domain};
 3565: 
 3566: 	# Check the cross-message CHI cache before hitting the network
 3567: 	if ($_cache) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 3568: 		my $cached = $_cache->get("dom:$domain");
 3569: 		if ($cached) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 3570: 			$self->{_domain_info}{$domain} = $cached;
 3571: 			return $cached;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 3572: 		}
 3573: 	}
 3574: 
●3575 → 3580 → 3588 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) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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 → 3588 → 3631 3588: 	if ($HAS_NET_DNS) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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')) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 3596: 			my ($best) = sort { $a->preference <=> $b->preference }
 3597: 			             grep { $_->type eq 'MX' } $mxq->answer;
 3598: 			if ($best) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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')) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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 → 3631 → 3683 3631: 	if(my $domain_whois = $self->_domain_whois($domain)) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 3670: 				($info{expires} = $1) =~ s/[TZ].*//;
 3671: 			}
 3672: 		}
 3673: 
 3674: 		# Flag recently-registered domains (< RECENT_REG_DAYS old)
 3675: 		if ($info{registered}) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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;

					

					Mutants (Total: 3, Killed: 0, Survived: 3)
					

 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;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 3687: }
 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: 
 3710: sub _resolve_host :Protected {
●3711 → 3715 → 3720 3711: 	my ($self, $host) = @_;
 3712: 	return $host if $host =~ /^\d{1,3}(?:\.\d{1,3}){3}$/;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 3713: 
 3714: 	# Check the CHI cache before hitting DNS
 3715: 	if ($_cache) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 3716: 		my $cached_ip = $_cache->get("resolve:$host");
 3717: 		return $cached_ip if defined $cached_ip;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 3718: 	}
 3719: 
●3720 → 3722 → 3751 3720: 	my $ip;
 3721: 
 3722: 	if ($HAS_NET_DNS) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 3723: 		my $res = Net::DNS::Resolver->new(
 3724: 			tcp_timeout => $self->{timeout},
 3725: 			udp_timeout => $self->{timeout},
 3726: 		);
 3727: 
 3728: 		# Try A record first, then AAAA for IPv6
 3729: 		for my $type (qw(A AAAA)) {
 3730: 			my $query = $res->search($host, $type);
 3731: 			if ($query) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 3732: 				for my $rr ($query->answer) {
 3733: 					if ($rr->type eq 'A') {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 3734: 						$ip = $rr->address;
 3735: 						last;
 3736: 					} elsif ($rr->type eq 'AAAA') {
 3737: 						$ip = $rr->address;
 3738: 						last;
 3739: 					}
 3740: 				}
 3741: 			}
 3742: 			last if defined $ip;
 3743: 		}
 3744: 	} else {
 3745: 		# Fallback: gethostbyname (IPv4 only)
 3746: 		my $packed = eval { inet_aton($host) };
 3747: 		$ip = $packed ? inet_ntoa($packed) : undef;
 3748: 	}
 3749: 
 3750: 	# Cache the result (including undef as '' to avoid repeated failed lookups)
●3751 → 3751 → 3755 3751: 	if ($_cache) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 3752: 		$_cache->set("resolve:$host", $ip // '');
 3753: 	}
 3754: 
 3755: 	return $ip;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 3756: }
 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: 
 3770: sub _reverse_dns :Protected {
●3771 → 3774 → 3786 3771: 	my ($self, $ip) = @_;
 3772: 	return unless $ip;
 3773: 
 3774: 	if ($HAS_NET_DNS) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 3775: 		my $res   = Net::DNS::Resolver->new(tcp_timeout => $self->{timeout});
 3776: 		my $query = $res->search($ip, 'PTR');
 3777: 		if ($query) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 3778: 			for my $rr ($query->answer) {
 3779: 				return $rr->ptrdname if $rr->type eq 'PTR';

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 3780: 			}
 3781: 		}
 3782: 		return;
 3783: 	}
 3784: 
 3785: 	# Fallback for IPv4 only
 3786: 	return scalar gethostbyaddr(inet_aton($ip), AF_INET);

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 3787: }
 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: 
 3806: sub _whois_ip :Protected {
●3807 → 3810 → 3815 3807: 	my ($self, $ip) = @_;
 3808: 
 3809: 	# Check CHI cache before going to the network
 3810: 	if ($_cache) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 3811: 		my $cached = $_cache->get("whois_ip:$ip");
 3812: 		return $cached if $cached;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 3813: 	}
 3814: 
●3815 → 3818 → 3828 3815: 	my $result = $HAS_LWP ? $self->_rdap_lookup($ip) : {};
 3816: 
 3817: 	# Fall back to raw WHOIS if RDAP returned no organisation
 3818: 	unless ($result->{org}) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 3819: 		my $raw = $self->_raw_whois($ip, 'whois.iana.org');
 3820: 		if ($raw) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 3821: 			my ($ref) = $raw =~ /whois:\s*([\w.-]+)/i;
 3822: 			my $detail = $ref ? $self->_raw_whois($ip, $ref) : $raw;
 3823: 			$result = $self->_parse_whois_text($detail) if $detail;
 3824: 		}
 3825: 	}
 3826: 
 3827: 	# Cache the enrichment result
 3828: 	$_cache->set("whois_ip:$ip", $result) if $_cache && $result;
 3829: 
 3830: 	return $result;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 3831: }
 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: 
 3845: sub _domain_whois :Protected {
 3846: 	my ($self, $domain) = @_;
 3847: 	my $iana = $self->_raw_whois($domain, 'whois.iana.org') // return;
 3848: 	my ($server) = $iana =~ /whois:\s*([\w.-]+)/i;
 3849: 	return unless $server;
 3850: 	return $self->_raw_whois($domain, $server);

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 3851: }
 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: 
 3866: sub _parse_domain_whois_abuse :Private {
●3867 → 3870 → 3874 3867: 	my ($self, $domain) = @_;
 3868: 	my $raw = $self->_domain_whois($domain) // return {};
 3869: 	my %info;
 3870: 	if ($raw =~ /Registrar:\s*(.+)/i) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 3871: 		($info{org} = $1) =~ s/\s+$//;
 3872: 	}
 3873: 	# Try multiple field name patterns for the abuse email
●3874 → 3874 → 3883 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) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 3880: 			($info{abuse} = $1) =~ s/\s+$//;
 3881: 		}
 3882: 	}
 3883: 	return \%info;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 3884: }
 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: 
 3899: sub _rdap_lookup :Protected {
●[NOT COVERED] 3900 → 3904 → 3922 3900: 	my ($self, $ip) = @_;
 3901: 	return {} unless $HAS_LWP;
 3902: 
 3903: 	my $ua = $self->{ua};
 3904: 	if(!defined($ua)) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 3905: 		$ua = LWP::UserAgent->new(
 3906: 			timeout => $self->{timeout},
 3907: 			agent   => "Email-Abuse-Investigator/$VERSION",
 3908: 		);
 3909: 
 3910: 		if($HAS_CONN_CACHE) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 3911: 			my $conn_cache = LWP::ConnCache->new();
 3912: 			$conn_cache->total_capacity(10);
 3913: 			$ua->conn_cache($conn_cache);
 3914: 		}
 3915: 
 3916: 		$ua->env_proxy(1);
 3917: 		$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.
●[NOT COVERED] 3922 → 3929 → 3930 3922: 	my $res = eval { $ua->get("https://rdap.arin.net/registry/ip/$ip") };
 3923: 	return {} unless $res && $res->is_success();
 3924: 
 3925: 	my $j = $res->decoded_content();
 3926: 	my %info;
 3927: 
 3928: 	# Extract organisation name from the JSON response
 3929: 	if ($j =~ /"name"\s*:\s*"([^"]+)"/)   { $info{org}    = $1 }

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

●[NOT COVERED] 3930 → 3930 → 3933 3930: 	if ($j =~ /"handle"\s*:\s*"([^"]+)"/) { $info{handle} = $1 }

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 3931: 
 3932: 	# Extract abuse email from the vcardArray contact block
●[NOT COVERED] 3933 → 3933 → 3940 3933: 	if ($j =~ /"abuse".*?"email"\s*:\s*"([^"]+)"/s) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 3934: 		$info{abuse} = $1;
 3935: 	} elsif ($j =~ /"email"\s*:\s*"([^@"]+@[^"]+)"/) {
 3936: 		$info{abuse} = $1;
 3937: 	}
 3938: 
 3939: 	# Country code from the network's country field
●[NOT COVERED] 3940 → 3940 → 3942 3940: 	if ($j =~ /"country"\s*:\s*"([A-Z]{2})"/) { $info{country} = $1 }

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 3941: 
 3942: 	return \%info;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 3943: }
 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: 
 3967: sub _raw_whois :Protected {
●3968 → 3996 → 4008 3968: 	my ($self, $query, $server) = @_;
 3969: 	$server //= 'whois.iana.org';
 3970: 	$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: 	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: 	my $sock = eval {
 3978: 		$sock_class->new(
 3979: 			PeerAddr => $server,
 3980: 			PeerPort => $WHOIS_PORT,
 3981: 			Proto    => 'tcp',
 3982: 			Timeout  => $self->{timeout},
 3983: 		);
 3984: 	};
 3985: 	return unless $sock;
 3986: 
 3987: 	# Send the WHOIS query in wire format (CRLF-terminated per RFC 3912)
 3988: 	$sock->print("$query\r\n") or do { $sock->close(); return };
 3989: 
 3990: 	# Use IO::Select to implement per-read timeouts without alarm()
 3991: 	my $sel      = IO::Select->new($sock);
 3992: 	my $response = '';
 3993: 	my $buf      = '';
 3994: 
 3995: 	# Read until EOF (server closes) or timeout
 3996: 	while ($sel->can_read($self->{timeout})) {
 3997: 		# Wrap in eval to catch 'Connection reset by peer' thrown by Fatal/autodie
 3998: 		my $n = eval { sysread($sock, $buf, $WHOIS_READ_CHUNK) };
 3999: 
 4000: 		if ($@ || !defined $n || $n <= 0) {

					

					Mutants (Total: 4, Killed: 0, Survived: 4)
					

 4001: 			$self->_debug("WHOIS read failed: $@") if $@;
 4002: 			last;
 4003: 		}
 4004: 		last if !defined($n) || $n <= 0;

					

					Mutants (Total: 3, Killed: 0, Survived: 3)
					

 4005: 		$response .= $buf;
 4006: 	}
 4007: 
 4008: 	$sock->close();
 4009: 	return $response || undef;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 4010: }
 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: 
 4024: sub _parse_whois_text :Private {
●4025 → 4030 → 4040 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) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 4035: 			($info{org} = $1) =~ s/\s+$//;
 4036: 		}
 4037: 	}
 4038: 
 4039: 	# Try multiple field names for the abuse email
●4040 → 4040 → 4050 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) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 4045: 			($info{abuse} = $1) =~ s/\s+$//;
 4046: 		}
 4047: 	}
 4048: 
 4049: 	# Last-resort: any abuse@ address in the response
●4050 → 4050 → 4053 4050: 	if (!$info{abuse} && $text =~ /(abuse\@[\w.-]+)/i) { $info{abuse} = $1 }

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 4051: 
 4052: 	# Country code (case-insensitive match, normalised to uppercase)
●4053 → 4053 → 4056 4053: 	if ($text =~ /^country:\s*([A-Za-z]{2})\s*$/m) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 4054: 		$info{country} = uc $1;
 4055: 	}
 4056: 	return \%info;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 4057: }
 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: 
 4077: sub _parse_auth_results_cached :Private {
●4078 → 4091 → 4092 4078: 	my $self = $_[0];
 4079: 	return $self->{_auth_results} if $self->{_auth_results};

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 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 }

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

●4092 → 4092 → 4093 4092: 	if ($raw =~ /\bdkim=(\S+)/i)  { $auth{dkim}  = $1 }

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

●4093 → 4093 → 4094 4093: 	if ($raw =~ /\bdmarc=(\S+)/i) { $auth{dmarc} = $1 }

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

●4094 → 4094 → 4097 4094: 	if ($raw =~ /\barc=(\S+)/i)   { $auth{arc}   = $1 }

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 4095: 
 4096: 	# Strip trailing punctuation captured by the greedy \S+
●4097 → 4097 → 4103 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 → 4104 → 4110 4103: 	my @dkim_domains;
 4104: 	for my $h (grep { $_->{name} eq 'dkim-signature' } @{ $self->{_headers} }) {
 4105: 		if ($h->{value} =~ /\bd=([^;,\s]+)/) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 4106: 			push @dkim_domains, lc $1;
 4107: 		}
 4108: 	}
 4109: 
●4110 → 4110 → 4123 4110: 	if (@dkim_domains) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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)) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 4125: }
 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: 
 4143: sub _provider_abuse_for_host :Private {
●4144 → 4147 → 4152 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};

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 4149: 		return $PROVIDER_ABUSE{$host} if $PROVIDER_ABUSE{$host};

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 4150: 		$host =~ s/^[^.]+\.//;
 4151: 	}
 4152: 	return;
 4153: }
 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: 
 4168: sub _provider_abuse_for_ip :Private {
 4169: 	my ($self, $ip, $rdns) = @_;
 4170: 	return $self->_provider_abuse_for_host($rdns) if $rdns;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 4171: 	return;
 4172: }
 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: 
 4196: sub _registrable :Private {
●4197 → 4201 → 4208 4197: 	my $host = $_[0];
 4198: 	return unless $host && $host =~ /\./;
 4199: 
 4200: 	# Use Domain::PublicSuffix for accurate PSL-based normalisation
 4201: 	if ($HAS_PUBLIC_SUFFIX) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 4202: 		my $psl = Domain::PublicSuffix->new();
 4203: 		my $root = $psl->get_root_domain(lc $host);
 4204: 		return $root if $root;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 4205: 	}
 4206: 
 4207: 	# Built-in heuristic fallback
●4208 → 4212 → 4216 4208: 	my @labels = split /\./, lc $host;
 4209: 	return $host if @labels <= 2;

					

					Mutants (Total: 5, Killed: 0, Survived: 5)
					

 4210: 
 4211: 	# Detect common ccTLD second-level patterns (e.g. co.uk, com.au)
 4212: 	if ($labels[-1] =~ /^[a-z]{2}$/ &&

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 4213: 	    $labels[-2] =~ /^(?:co|com|net|org|gov|edu|ac|me)$/) {
 4214: 		return join('.', @labels[-3..-1]);

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 4215: 	}
 4216: 	return join('.', @labels[-2..-1]);

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 4217: }
 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: 
 4237: sub _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: }
 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: =head2 header_value( $name )
 4258: 
 4259: Returns the value of the first occurrence of a named header field, or
 4260: C<undef> if the header is absent.  The name comparison is case-insensitive.
 4261: 
 4262: =head3 Usage
 4263: 
 4264:     my $subj = $analyser->header_value('Subject');
 4265:     my $from  = $analyser->header_value('From');
 4266:     my $msgid = $analyser->header_value('Message-ID');
 4267: 
 4268: =head3 Arguments
 4269: 
 4270: =over 4
 4271: 
 4272: =item C<$name> (string, required)
 4273: 
 4274: The header field name, e.g. C<'Subject'>, C<'From'>, C<'X-Mailer'>.
 4275: Comparison is case-insensitive.
 4276: 
 4277: =back
 4278: 
 4279: =head3 Returns
 4280: 
 4281: The raw header value string (not decoded), or C<undef> if the named header
 4282: is not present.  When the same header appears more than once, only the value
 4283: of the first occurrence is returned.
 4284: 
 4285: =head3 Side Effects
 4286: 
 4287: None.  Header data is pre-parsed during C<parse_email()>.
 4288: 
 4289: =head3 Notes
 4290: 
 4291: Header values are returned verbatim, including any MIME encoded-word sequences
 4292: (C<=?charset?B/Q?...?=>).  Pass the result through C<_decode_mime_words()>
 4293: internally if human-readable output is needed.
 4294: 
 4295: =head3 API Specification
 4296: 
 4297: =head4 Input
 4298: 
 4299:     {
 4300:         name => { type => 'string', required => 1 },
 4301:     }
 4302: 
 4303: =head4 Output
 4304: 
 4305:     { type => [ 'string', 'undef' ] }
 4306: 
 4307: =head3 Messages
 4308: 
 4309: None -- returns C<undef> on a missing header, never throws.
 4310: 
 4311: =cut
 4312: 
 4313: sub header_value {
 4314: 	my $self = shift;
 4315: 
 4316: 	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: 	return if((!defined($params)) || !defined($params->{name}));
 4327: 	return if ref($params->{name});
 4328: 	return $self->_header_value($params->{name});

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 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: 
 4345: sub _header_value :Private {
●4346 → 4347 → 4350 4346: 	my ($self, $name) = @_;
 4347: 	for my $h (@{ $self->{_headers} }) {
 4348: 		return $h->{value} if $h->{name} eq lc($name);

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 4349: 	}
 4350: 	return;
 4351: }
 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: 
 4366: sub _ip_in_cidr :Private {
 4367: 	my ($self, $ip, $cidr) = @_;
 4368: 	return $ip eq $cidr unless $cidr =~ m{/};

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 4369: 	my ($net_addr, $prefix) = split m{/}, $cidr;
 4370: 	return 0 if !defined($prefix) || $prefix !~ /^\d+$/ || $prefix > 32;

					

					Mutants (Total: 5, Killed: 0, Survived: 5)
					

 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);

					

					Mutants (Total: 3, Killed: 0, Survived: 3)
					

 4377: }
 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: 
 4391: sub _decode_mime_words :Private {
 4392: 	my ($self, $str) = @_;
 4393: 	return '' unless defined $str;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 4394: 	# Replace each encoded-word with its decoded equivalent
 4395: 	$str =~ s/=\?([^?]+)\?([BbQq])\?([^?]*)\?=/_decode_ew($1,$2,$3)/ge;
 4396: 	return $str;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 4397: }
 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: 
 4408: sub _decode_ew :Private {
●4409 → 4411 → 4418 4409: 	my ($charset, $enc, $text) = @_;
 4410: 	my $raw;
 4411: 	if (uc($enc) eq 'B') {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 4419: }
 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: 
 4433: sub _parse_date_to_epoch :Private {
●4434 → 4441 → 4457 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$/) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 4454: 		};
 4455: 		return $epoch if defined $epoch;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 4456: 	}
●4457 → 4459 → 4463 4457: 	my ($y, $m, $d);
 4458: 
 4459: 	if    ($str =~ /^(\d{4})-(\d{2})-(\d{2})/)         { ($y,$m,$d)=($1,$2,$3) }

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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 → 4465 → 4469 4463: 	return unless $y && $m && $d;
 4464: 
 4465: 	if (eval { require Time::Local; 1 }) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 4466: 		return eval { Time::Local::timegm(0,0,0,$d,$m-1,$y-1900) };

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 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;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 4470: }
 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: 
 4486: sub _parse_rfc2822_date :Private {
●4487 → 4491 → 4499 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})/) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 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 }) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 4496: 			return eval { Time::Local::timegm($S, $M, $H, $d, $m - 1, $y - 1900) };

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 4497: 		}
 4498: 	}
 4499: 	return;
 4500: }
 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: 
 4515: sub _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;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 4523: }
 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: 
 4536: sub _debug :Private {
●4537 → 4539 → 0 4537: 	my ($self, $msg) = @_;
 4538: 
 4539: 	if($self->{verbose}) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 4540: 		if (my $logger = $self->{logger}) { # Set via Object::Configure

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 4541: 			$logger->debug("[Email::Abuse::Investigator] $msg");
 4542: 		} else {
 4543: 			print STDERR "[Email::Abuse::Investigator] $msg\n";
 4544: 		}
 4545: 	}
 4546: }
 4547: 
 4548: 1;
 4549: 
 4550: __END__
 4551: 
 4552: =head1 ALGORITHM: DOMAIN INTELLIGENCE PIPELINE
 4553: 
 4554: For each unique non-infrastructure domain found in the email, the module
 4555: runs the following pipeline:
 4556: 
 4557:     Domain name
 4558:         |
 4559:         +-- A/AAAA record --> web hosting IP --> RDAP --> org + abuse contact
 4560:         |
 4561:         +-- MX record --> mail server hostname --> A --> RDAP --> org + abuse
 4562:         |
 4563:         +-- NS record --> nameserver hostname  --> A --> RDAP --> org + abuse
 4564:         |
 4565:         +-- WHOIS (TLD whois server via IANA referral)
 4566:                +-- Registrar name + abuse contact
 4567:                +-- Creation date  (-> recently-registered flag if < 180 days)
 4568:                +-- Expiry date    (-> expires-soon or expired flags)
 4569: 
 4570: Domains are collected from:
 4571: 
 4572:     From:/Reply-To:/Sender:/Return-Path: headers
 4573:     DKIM-Signature: d=  (signing domain)
 4574:     List-Unsubscribe:   (ESP / bulk sender domain)
 4575:     Message-ID:         (often reveals real sending platform)
 4576:     mailto: links and bare addresses in the body
 4577: 
 4578: =head1 CACHING
 4579: 
 4580: Two levels of caching are used:
 4581: 
 4582: =over 4
 4583: 
 4584: =item Per-message cache (C<$self-E<gt>{_domain_info}>)
 4585: 
 4586: Stores domain analysis results for the lifetime of one C<parse_email()>
 4587: call.  Invalidated by each call to C<parse_email()>.
 4588: 
 4589: =item Cross-message cache (CHI Memory driver, if C<CHI> is installed)
 4590: 
 4591: Stores IP WHOIS, DNS resolution, and domain analysis results across all
 4592: messages processed by the same process.  TTL is one hour.  Prevents
 4593: redundant WHOIS queries for infrastructure that appears in multiple
 4594: messages in the same run (e.g. a sending ISP seen in 500 spam messages).
 4595: 
 4596: =back
 4597: 
 4598: =head1 IPV6 SUPPORT
 4599: 
 4600: IPv6 addresses are extracted from C<Received:> headers using bracketed
 4601: notation (C<[2001:db8::1]>).  They are tested against the private range
 4602: list (which covers ::1, fe80::/10, fc00::/7, fd00::/8, and the
 4603: documentation range 2001:db8::/32) and passed through C<_whois_ip()> and
 4604: C<_rdap_lookup()> in the same way as IPv4 addresses.
 4605: 
 4606: C<_resolve_host()> attempts both A and AAAA lookups when C<Net::DNS> is
 4607: installed.  C<_raw_whois()> uses C<IO::Socket::IP> for dual-stack WHOIS
 4608: connections when that module is installed.
 4609: 
 4610: =head1 SEE ALSO
 4611: 
 4612: =over 4
 4613: 
 4614: =item * L<Configure an Object at Runtime|Object::Configure>
 4615: 
 4616: The provider_abuse, trusted_domains and url_shorteners tables can all be overridden at runtime
 4617: 
 4618: =item * L<Test Dashboard|https://nigelhorne.github.io/Email-Abuse-Investigator/coverage/>
 4619: 
 4620: =item * L<ARIN RDAP|https://rdap.arin.net/>
 4621: 
 4622: =item * L<Net::DNS>, L<LWP::UserAgent>, L<HTML::LinkExtor>
 4623: 
 4624: =item * L<CHI>, L<AnyEvent::DNS>, L<IO::Socket::IP>, L<Domain::PublicSuffix>
 4625: 
 4626: =back
 4627: 
 4628: =head1 REPOSITORY
 4629: 
 4630: L<https://github.com/nigelhorne/Email-Abuse-Investigator>
 4631: 
 4632: =head1 SUPPORT
 4633: 
 4634: This module is provided as-is without any warranty.
 4635: 
 4636: Please report any bugs or feature requests to C<bug-email-abuse-investigator at rt.cpan.org>,
 4637: or through the web interface at
 4638: L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Email-Abuse-Investigator>.
 4639: I will be notified, and then you'll
 4640: automatically be notified of progress on your bug as I make changes.
 4641: 
 4642: You can find documentation for this module with the perldoc command.
 4643: 
 4644:     perldoc Email::Abuse::Investigator
 4645: 
 4646: You can also look for information at:
 4647: 
 4648: =over 4
 4649: 
 4650: =item * MetaCPAN
 4651: 
 4652: L<https://metacpan.org/dist/Email-Abuse-Investigator>
 4653: 
 4654: =item * RT: CPAN's request tracker
 4655: 
 4656: L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=Email-Abuse-Investigator>
 4657: 
 4658: =item * CPAN Testers' Matrix
 4659: 
 4660: L<http://matrix.cpantesters.org/?dist=Email-Abuse-Investigator>
 4661: 
 4662: =item * CPAN Testers Dependencies
 4663: 
 4664: L<http://deps.cpantesters.org/?module=Email-Abuse-Investigator>
 4665: 
 4666: =back
 4667: 
 4668: =head1 REQUIRED MODULES
 4669: 
 4670: The following modules are mandatory:
 4671: 
 4672:     Readonly::Values::Months
 4673:     Socket              (core since Perl 5)
 4674:     IO::Socket::INET    (core since Perl 5)
 4675:     MIME::QuotedPrint   (core since Perl 5.8)
 4676:     MIME::Base64        (core since Perl 5.8)
 4677: 
 4678: The following are optional but strongly recommended:
 4679: 
 4680:     Net::DNS            -- enables MX, NS, AAAA record lookups
 4681:     LWP::UserAgent      -- enables RDAP (faster and richer than raw WHOIS)
 4682:                           and following redirect chains for URL shorteners
 4683:                           and cloud-storage redirect cloakers
 4684:     LWP::ConnCache      -- enables HTTP connection reuse (used with LWP::UserAgent)
 4685:     HTML::LinkExtor     -- enables structural HTML link extraction with entity decoding
 4686:     CHI                 -- enables cross-message IP/domain result caching
 4687:     IO::Socket::IP      -- enables IPv6 WHOIS connections
 4688:     Domain::PublicSuffix -- enables accurate eTLD+1 domain normalisation
 4689:     AnyEvent::DNS       -- enables parallel DNS resolution for multiple URL hosts
 4690: 
 4691: =head1 LIMITATIONS
 4692: 
 4693: =over 4
 4694: 
 4695: =item No charset conversion
 4696: 
 4697: Body text is stored as raw bytes.  Non-ASCII content (UTF-8, Latin-1,
 4698: ISO-2022-JP, etc.) is not decoded to Perl's internal Unicode representation.
 4699: URL and domain extraction from non-ASCII bodies may miss or misparse content.
 4700: Use C<Email::MIME> if full charset support is needed.
 4701: 
 4702: =item Hand-rolled MIME parser
 4703: 
 4704: The built-in MIME parser handles common cases but is not a conforming
 4705: implementation of RFC 2045/2046.  It silently drops parts it cannot decode,
 4706: does not handle C<message/rfc822> attachments, and does not parse
 4707: C<Content-Disposition> filenames.  Replace with C<Email::MIME> or
 4708: C<MIME::Entity> for production use with untrusted input.
 4709: 
 4710: =item IPv4-only CIDR matching for trusted_relays
 4711: 
 4712: C<_ip_in_cidr()> and the C<trusted_relays> constructor argument only support
 4713: IPv4 CIDR notation.  IPv6 trusted relay entries are accepted but silently
 4714: never match.
 4715: 
 4716: =item WHOIS rate-limiting not handled
 4717: 
 4718: C<_raw_whois()> does not retry on rate-limit responses (typically a
 4719: "quota exceeded" reply).  Under high-volume processing the module will
 4720: silently return empty enrichment data for affected IPs and domains.
 4721: 
 4722: =item Not thread-safe
 4723: 
 4724: The class-level C<$_cache> variable and the optional-module C<$HAS_*> flags
 4725: are shared across all threads.  Create a separate object per thread and do
 4726: not share objects across threads.
 4727: 
 4728: =item DMARC policy not fetched
 4729: 
 4730: The module reads the C<Authentication-Results: dmarc=> result from the
 4731: message headers but does not perform live C<_dmarc.domain> TXT record
 4732: lookups.  A missing DMARC result in the headers is not independently flagged.
 4733: 
 4734: =item C<abuse_contacts()> routes duplicated in C<form_contacts()>
 4735: 
 4736: Both methods iterate the same six discovery routes independently.  Any new
 4737: discovery route must be added to both.  A future refactor should share a
 4738: single routing pass.
 4739: 
 4740: =item CHI cache is a class-level mutable global
 4741: 
 4742: The cross-message cache is shared across all instances in the process.
 4743: Tests that populate the cache will affect subsequent tests.  Pass the cache
 4744: in via C<new()> (not currently supported) to enable proper isolation.
 4745: 
 4746: =back
 4747: 
 4748: =encoding utf-8
 4749: 
 4750: =head1 FORMAL SPECIFICATION
 4751: 
 4752: =head2 new
 4753: 
 4754:     -- Z notation (simplified)
 4755:     new == [
 4756:       timeout        : N;
 4757:       trusted_relays : seq STRING;
 4758:       verbose        : BOOL;
 4759:       _raw           : STRING;
 4760:       _headers       : seq (STRING x STRING);
 4761:       _origin?       : IP_INFO | undefined;
 4762:       _urls?         : seq URL_INFO | undefined;
 4763:       _risk?         : RISK_INFO | undefined
 4764:     ]
 4765:     pre: timeout >= 0
 4766:     post: self.timeout = params.timeout /\ self._raw = ''
 4767: 
 4768: =head2 parse_email
 4769: 
 4770:     -- Z notation
 4771:     parse_email == [
 4772:       Delta Email::Abuse::Investigator;
 4773:       text? : STRING | ref STRING
 4774:     ]
 4775:     pre:  defined text?
 4776:     post: self._raw = deref(text?) /\
 4777:           self._origin = undefined /\
 4778:           self._urls   = undefined /\
 4779:           self._risk   = undefined
 4780: 
 4781: =head2 originating_ip
 4782: 
 4783:     -- Z notation
 4784:     originating_ip == [
 4785:       Xi Email::Abuse::Investigator;
 4786:       result! : IP_INFO | undefined
 4787:     ]
 4788:     pre:  self._raw /= ''
 4789:     post: result! = self._origin /\
 4790:           (result! /= undefined => result!.ip in EXTERNAL_IPS)
 4791: 
 4792: =head2 embedded_urls
 4793: 
 4794:     -- Z notation
 4795:     embedded_urls == [
 4796:       Xi Email::Abuse::Investigator;
 4797:       result! : seq URL_INFO
 4798:     ]
 4799:     pre:  self._raw /= ''
 4800:     post: result! = self._urls /\
 4801:           forall u : result! @ u.url =~ m{^https?://}i
 4802: 
 4803: =head2 mailto_domains
 4804: 
 4805:     -- Z notation
 4806:     mailto_domains == [
 4807:       Xi Email::Abuse::Investigator;
 4808:       result! : seq DOMAIN_INFO
 4809:     ]
 4810:     pre:  self._raw /= ''
 4811:     post: result! = self._mailto_domains /\
 4812:           forall d : result! @ d.domain =~ /\.[a-zA-Z]{2,}$/
 4813: 
 4814: =head2 all_domains
 4815: 
 4816:     -- Z notation
 4817:     all_domains == [
 4818:       Xi Email::Abuse::Investigator;
 4819:       result! : seq STRING
 4820:     ]
 4821:     post: result! = deduplicate(
 4822:                       map(_registrable, url_hosts union mailto_domains)
 4823:                     )
 4824: 
 4825: =head2 unresolved_contacts
 4826: 
 4827:     -- Z notation
 4828:     unresolved_contacts == [
 4829:       Xi Email::Abuse::Investigator;
 4830:       result! : seq UNRESOLVED_INFO
 4831:     ]
 4832:     post: forall u : result! @
 4833:             u.domain not_in covered_domains(abuse_contacts, form_contacts)
 4834: 
 4835: =head2 sending_software
 4836: 
 4837:     -- Z notation
 4838:     sending_software == [
 4839:       Xi Email::Abuse::Investigator;
 4840:       result! : seq SW_INFO
 4841:     ]
 4842:     post: result! = self._sending_sw
 4843: 
 4844: =head2 received_trail
 4845: 
 4846:     -- Z notation
 4847:     received_trail == [
 4848:       Xi Email::Abuse::Investigator;
 4849:       result! : seq HOP_INFO
 4850:     ]
 4851:     post: result! = self._rcvd_tracking
 4852: 
 4853: =head2 risk_assessment
 4854: 
 4855:     -- Z notation
 4856:     risk_assessment == [
 4857:       Xi Email::Abuse::Investigator;
 4858:       result! : RISK_INFO
 4859:     ]
 4860:     post: result!.score = sum({ w(f.severity) | f in result!.flags }) /\
 4861:           result!.level = classify(result!.score)
 4862:     where:
 4863:       w(HIGH) = 3; w(MEDIUM) = 2; w(LOW) = 1; w(INFO) = 0
 4864:       classify(s) = HIGH   if s >= 9
 4865:                   | MEDIUM if s >= 5
 4866:                   | LOW    if s >= 2
 4867:                   | INFO   otherwise
 4868: 
 4869: =head2 abuse_report_text
 4870: 
 4871:     -- Z notation
 4872:     abuse_report_text == [
 4873:       Xi Email::Abuse::Investigator;
 4874:       result! : STRING
 4875:     ]
 4876:     post: result! /= '' /\ result! ends_with '\n'
 4877: 
 4878: =head2 abuse_contacts
 4879: 
 4880:     -- Z notation
 4881:     abuse_contacts == [
 4882:       Xi Email::Abuse::Investigator;
 4883:       result! : seq CONTACT_INFO
 4884:     ]
 4885:     post: forall c : result! @ c.address contains '@' /\
 4886:           forall c1, c2 : result! @ c1 /= c2 => c1.address /= c2.address
 4887: 
 4888: =head2 form_contacts
 4889: 
 4890:     -- Z notation
 4891:     form_contacts == [
 4892:       Xi Email::Abuse::Investigator;
 4893:       result! : seq FORM_CONTACT_INFO
 4894:     ]
 4895:     post: forall c : result! @ c.form =~ m{^https?://} /\
 4896:           forall c1, c2 : result! @ c1 /= c2 => c1.form /= c2.form
 4897: 
 4898: =head2 report
 4899: 
 4900:     -- Z notation
 4901:     report == [
 4902:       Xi Email::Abuse::Investigator;
 4903:       result! : STRING
 4904:     ]
 4905:     post: result! /= '' /\ result! ends_with '\n'
 4906: 
 4907: =head2 header_value
 4908: 
 4909:   header_value : Object × FieldName → Maybe FieldValue
 4910:   header_value(o, n) ≜ first { lc(h.name) = lc(n) } o._headers .value
 4911: 
 4912: =head1 LICENCE AND COPYRIGHT
 4913: 
 4914: Copyright 2026 Nigel Horne.
 4915: 
 4916: Usage is subject to GPL2 licence terms.
 4917: If you use it,
 4918: please let me know.
 4919: 
 4920: =cut
 4921: 
 4922: 1;