TER1 (Statement): 97.56%
TER2 (Branch): 65.55%
TER3 (LCSAJ): 94.4% (118/125)
Approximate LCSAJ segments: 419
● 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.
1: package Email::Abuse::Investigator; 2: 3: use strict; 4: use warnings; 5: use autodie qw(:all); 6: 7: # TODO: phishing spam pretending to be from Fidelity Investments, should be 8: # forwarded to phishing@fidelity.com 9: 10: use Carp qw(croak carp); 11: use IO::Select; 12: use IO::Socket::INET; 13: BEGIN { $Sub::Private::config{mode} = 'enforce' } 14: use Sub::Private; 15: use Sub::Protected; 16: use MIME::QuotedPrint qw( decode_qp ); 17: use MIME::Base64 qw( decode_base64 ); 18: use Object::Configure; 19: use Params::Get; 20: use Params::Validate::Strict 0.34; 21: use Readonly; 22: use Readonly::Values::Months; 23: use Socket qw( inet_aton inet_ntoa AF_INET ); 24: use Time::Piece; 25: 26: =head1 NAME 27: 28: Email::Abuse::Investigator - Analyse spam email to identify originating hosts, 29: hosted URLs, and suspicious domains 30: 31: =head1 VERSION 32: 33: Version 0.14 34: 35: =cut 36: 37: our $VERSION = '0.14'; 38: 39: =head1 SYNOPSIS 40: 41: use Email::Abuse::Investigator; 42: 43: my $analyser = Email::Abuse::Investigator->new( verbose => 1 ); 44: $analyser->parse_email($raw_email_text); 45: 46: # Originating IP and its network owner 47: my $origin = $analyser->originating_ip(); 48: 49: # All HTTP/HTTPS URLs found in the body 50: my @urls = $analyser->embedded_urls(); 51: 52: # All domains extracted from mailto: links and bare addresses in the body 53: my @mdoms = $analyser->mailto_domains(); 54: 55: # All domains mentioned anywhere (union of the above) 56: my @adoms = $analyser->all_domains(); 57: 58: # Full printable report 59: print $analyser->report(); 60: 61: =head1 DESCRIPTION 62: 63: C<Email::Abuse::Investigator> examines the raw source of a spam/phishing e-mail 64: and answers the questions manual abuse investigators ask: 65: 66: =over 4 67: 68: =item 1. Where did the message really come from? 69: 70: Walks the C<Received:> chain, skips private/trusted IPs, and identifies the 71: first external hop. Enriches with rDNS, WHOIS/RDAP org name and abuse 72: contact. Both IPv4 and IPv6 addresses are supported. 73: 74: =item 2. Who hosts the advertised web sites? 75: 76: Extracts every C<http://> and C<https://> URL from both plain-text and HTML 77: parts, resolves each hostname to an IP, and looks up the network owner. 78: 79: =item 3. Who owns the reply-to / contact domains? 80: 81: Extracts domains from C<mailto:> links, bare e-mail addresses in the body, 82: the C<From:>/C<Reply-To:>/C<Sender:>/C<Return-Path:> headers, C<DKIM-Signature: d=> 83: (the signing domain), C<List-Unsubscribe:> (the ESP or bulk-sender domain), and the 84: C<Message-ID:> domain. For each unique domain it gathers: 85: 86: =over 8 87: 88: =item * Domain registrar and registrant (WHOIS) 89: 90: =item * Web-hosting IP and network owner (A record -> RDAP) 91: 92: =item * Mail-hosting IP and network owner (MX record -> RDAP) 93: 94: =item * DNS nameserver operator (NS record -> RDAP) 95: 96: =item * Whether the domain was recently registered (potential flag) 97: 98: =back 99: 100: =back 101: 102: =cut 103: 104: # ----------------------------------------------------------------------- 105: # Optional modules -- gracefully degraded when absent 106: # ----------------------------------------------------------------------- 107: 108: # Net::DNS enables MX, NS, AAAA lookups; falls back to gethostbyname 109: my $HAS_NET_DNS; 110: 111: # LWP::UserAgent enables RDAP queries; falls back to raw WHOIS 112: my $HAS_LWP; 113: my $HAS_CONN_CACHE; 114: 115: # HTML::LinkExtor enables structural HTML link extraction 116: my $HAS_HTML_LINKEXTOR; 117: 118: # CHI enables a persistent cross-message cache for IP/domain data 119: my $HAS_CHI; 120: 121: # IO::Socket::IP provides dual-stack (IPv4+IPv6) socket support 122: my $HAS_IO_SOCKET_IP; 123: 124: # Domain::PublicSuffix enables accurate eTLD+1 normalisation 125: my $HAS_PUBLIC_SUFFIX; 126: 127: # AnyEvent::DNS enables parallel DNS queries 128: my $HAS_ANYEVENT_DNS; 129: 130: BEGIN { 131: $HAS_NET_DNS = eval { require Net::DNS; 1 }; 132: $HAS_LWP = eval { require LWP::UserAgent; 1 }; 133: $HAS_CONN_CACHE = eval { require LWP::ConnCache; 1 }; 134: $HAS_HTML_LINKEXTOR= eval { require HTML::LinkExtor; 1 }; 135: $HAS_CHI = eval { require CHI; 1 }; 136: $HAS_IO_SOCKET_IP = eval { require IO::Socket::IP; 1 }; 137: $HAS_PUBLIC_SUFFIX = eval { require Domain::PublicSuffix; 1 }; 138: $HAS_ANYEVENT_DNS = eval { require AnyEvent::DNS; 1 }; 139: } 140: 141: # ----------------------------------------------------------------------- 142: # Constants -- all magic numbers and strings live here 143: # ----------------------------------------------------------------------- 144: 145: # WHOIS protocol port (IANA-assigned) 146: Readonly::Scalar my $WHOIS_PORT => 43; 147: 148: # Bytes to read per sysread() call from a WHOIS socket 149: Readonly::Scalar my $WHOIS_READ_CHUNK => 4096; 150: 151: # Maximum WHOIS response bytes stored in whois_raw (keep reports compact) 152: Readonly::Scalar my $WHOIS_RAW_MAX => 2048; 153: 154: # Maximum multipart nesting depth (recursion guard -- RFC 2046 has no limit 155: # but we cap it to prevent stack exhaustion on crafted messages) 156: Readonly::Scalar my $MAX_MULTIPART_DEPTH => 20; 157: 158: # Number of days before registration that triggers recently_registered flag 159: Readonly::Scalar my $RECENT_REG_DAYS => 180; 160: 161: # Number of days ahead of expiry that triggers domain_expires_soon flag 162: Readonly::Scalar my $EXPIRY_WARN_DAYS => 30; 163: 164: # Seconds in a day -- used in date arithmetic throughout 165: Readonly::Scalar my $SECS_PER_DAY => 86400; 166: 167: # Suspicious date window: dates outside +/- 7 days raise a flag 168: Readonly::Scalar my $DATE_SKEW_DAYS => 7; 169: 170: # Maximum positive timezone offset in minutes (+14:00 = Line Islands) 171: Readonly::Scalar my $TZ_MAX_POS_MINS => 840; 172: 173: # Maximum negative timezone offset in minutes (-12:00 = Baker Island) 174: Readonly::Scalar my $TZ_MAX_NEG_MINS => 720; 175: 176: # High-risk score threshold 177: Readonly::Scalar my $SCORE_HIGH => 9; 178: 179: # Medium-risk score threshold 180: Readonly::Scalar my $SCORE_MEDIUM => 5; 181: 182: # Low-risk score threshold 183: Readonly::Scalar my $SCORE_LOW => 2; 184: 185: # Flag severity weights (contribute to the numeric risk score) 186: Readonly::Hash my %FLAG_WEIGHT => ( 187: HIGH => 3, 188: MEDIUM => 2, 189: LOW => 1, 190: INFO => 0, 191: ); 192: 193: # Maximum merged-role display string length before summarisation kicks in 194: Readonly::Scalar my $ROLE_MAX_LEN => 80; 195: 196: # CHI cache TTL in seconds (1 hour -- IP allocations change slowly) 197: Readonly::Scalar my $CACHE_TTL_SECS => 3600; 198: 199: # Default constructor timeout for network operations (seconds) 200: Readonly::Scalar my $DEFAULT_TIMEOUT => 10; 201: 202: # Maximum role string length before truncation 203: Readonly::Scalar my $ROLE_WRAP_LEN => 66; 204: 205: # Maximum redirect hops to follow when resolving shortener/redirect-cloaker URLs 206: Readonly::Scalar my $REDIRECT_MAX_HOPS => 3; 207: 208: # Brand names checked in lookalike-domain detection. 209: # Overridable at runtime via Object::Configure. 210: Readonly::Array my @LOOKALIKE_BRANDS => qw( 211: paypal apple google amazon microsoft netflix ebay 212: instagram facebook twitter linkedin bankofamerica 213: wellsfargo chase barclays hsbc lloyds santander 214: ); 215: 216: # ----------------------------------------------------------------------- 217: # Private ranges -- IPs that are never actionable abuse targets 218: # ----------------------------------------------------------------------- 219: 220: # Both IPv4 and IPv6 private/reserved ranges. Each entry is a compiled 221: # regex; _is_private() iterates over them and returns true on first match. 222: my @PRIVATE_RANGES = ( 223: # IPv4 ranges 224: qr/^0\./, # 0.0.0.0/8 this-network (RFC 1122) 225: qr/^127\./, # 127.0.0.0/8 loopback 226: qr/^10\./, # 10.0.0.0/8 RFC 1918 227: qr/^192\.168\./, # 192.168.0.0/16 RFC 1918 228: qr/^172\.(?:1[6-9]|2\d|3[01])\./, # 172.16.0.0/12 RFC 1918 229: qr/^169\.254\./, # 169.254.0.0/16 link-local 230: qr/^100\.(?:6[4-9]|[7-9]\d|1(?:[01]\d|2[0-7]))\./, # 100.64.0.0/10 CGN (RFC 6598) 231: qr/^192\.0\.0\./, # 192.0.0.0/24 IETF protocol (RFC 6890) 232: qr/^192\.0\.2\./, # 192.0.2.0/24 TEST-NET-1 (RFC 5737) 233: qr/^198\.51\.100\./, # 198.51.100.0/24 TEST-NET-2 (RFC 5737) 234: qr/^203\.0\.113\./, # 203.0.113.0/24 TEST-NET-3 (RFC 5737) 235: qr/^255\./, # 255.0.0.0/8 broadcast 236: # IPv6 ranges 237: qr/^::1$/, # IPv6 loopback 238: qr/^fe80:/i, # IPv6 link-local (fe80::/10) 239: qr/^fc/i, # IPv6 ULA fc00::/7 240: qr/^fd/i, # IPv6 ULA fd00::/8 241: qr/^2001:db8:/i, # IPv6 documentation range (RFC 3849) 242: qr/^64:ff9b:/i, # IPv6 NAT64 well-known prefix 243: ); 244: 245: # Priority-ordered patterns for extracting IPs from Received: headers. 246: # Covers bracketed IPv4, bracketed IPv6, parenthesised address, and bare dotted-quad. 247: my @RECEIVED_IP_RE = ( 248: qr/\[\s*([\d.]+)\s*\]/, # [1.2.3.4] 249: qr/\[\s*([0-9a-fA-F:]+)\s*\]/, # [IPv6 address] 250: qr/\(\s*[\w.-]*\s*\[?\s*([\d.]+)\s*\]?\s*\)/, # (hostname [1.2.3.4]) 251: qr/from\s+[\w.-]+\s+([\d.]+)/, # from hostname addr 252: qr/([\d]{1,3}\.[\d]{1,3}\.[\d]{1,3}\.[\d]{1,3})/, # bare dotted-quad fallback 253: ); 254: 255: # ----------------------------------------------------------------------- 256: # Default configuration -- overridable via Object::Configure 257: # ----------------------------------------------------------------------- 258: 259: # Object::Configure may overlay 260: # values from a file before new() uses them. Use Readonly for constants 261: # that should never be overridden at runtime. 262: 263: # ----------------------------------------------------------------------- 264: # Trusted domains (infrastructure -- never report these as abuse targets) 265: # Can be overrideen at runtime by Object::Configure 266: # ----------------------------------------------------------------------- 267: 268: my %TRUSTED_DOMAINS = map { $_ => 1 } qw( 269: gmail.com googlemail.com yahoo.com outlook.com hotmail.com 270: google.com microsoft.com apple.com amazon.com 271: googlegroups.com groups.google.com 272: fonts.googleapis.com fonts.gstatic.com 273: ajax.googleapis.com maps.googleapis.com 274: w3.org 275: fedex.com ups.com dhl.com usps.com royalmail.com 276: ); 277: 278: # ----------------------------------------------------------------------- 279: # URL shortener domains (real destination is hidden behind these) 280: # ----------------------------------------------------------------------- 281: 282: my %URL_SHORTENERS = map { $_ => 1 } qw( 283: bit.ly bitly.com tinyurl.com t.co ow.ly 284: goo.gl is.gd buff.ly ift.tt dlvr.it 285: short.link rebrand.ly tiny.cc cutt.ly rb.gy 286: shorturl.at bl.ink smarturl.it yourls.org clicky.me 287: snip.ly adf.ly bc.vc lnkd.in fb.me 288: youtu.be 289: ); 290: 291: # Cloud object-stores and CDN hosting paths commonly abused to serve redirect 292: # pages that hide the real phishing destination (same evasion as a URL shortener 293: # but using legitimate cloud infrastructure to pass spam filters). 294: # Exact-match hosts; suffix patterns are in @REDIRECT_HOST_SUFFIXES below. 295: my %REDIRECT_HOSTS = map { $_ => 1 } qw( 296: storage.googleapis.com 297: blob.core.windows.net 298: pages.dev 299: firebaseapp.com 300: web.app 301: ); 302: 303: # Subdomain-suffix patterns for bucket-style hosting (e.g. mybucket.s3.amazonaws.com). 304: # Checked by _is_redirect_cloaker() using a suffix match against the bare hostname. 305: Readonly::Array my @REDIRECT_HOST_SUFFIXES => qw( 306: .s3.amazonaws.com 307: .s3-website.amazonaws.com 308: .cloudfront.net 309: .github.io 310: .firebaseapp.com 311: .web.app 312: .translate.goog 313: ); 314: 315: # ----------------------------------------------------------------------- 316: # Well-known provider abuse contacts 317: # Can be overrideen at runtime by Object::Configure 318: # ----------------------------------------------------------------------- 319: 320: # Curated table of provider abuse contacts. Entries with only a 'form' 321: # key (no 'email') require web-form submission; abuse_contacts() suppresses 322: # email addresses for those providers and form_contacts() surfaces them. 323: my %PROVIDER_ABUSE = ( 324: # Google / Gmail 325: 'google.com' => { email => 'abuse@google.com', note => 'Also report Gmail accounts via https://support.google.com/mail/contact/abuse' }, 326: 'gmail.com' => { email => 'abuse@google.com', note => 'Report Gmail spam via https://support.google.com/mail/contact/abuse' }, 327: 'googlemail.com' => { email => 'abuse@google.com', note => 'Report via https://support.google.com/mail/contact/abuse' }, 328: '1e100.net' => { email => 'abuse@google.com', note => 'Google infrastructure' }, 329: 'blogspot.com' => { email => 'abuse@google.com', note => 'Blogger/Blogspot -- report via https://support.google.com/blogger/answer/76315' }, 330: 'blogger.com' => { email => 'abuse@google.com', note => 'Blogger platform abuse' }, 331: 'sites.google.com' => { email => 'abuse@google.com', note => 'Google Sites hosted content' }, 332: 'storage.googleapis.com' => { email => 'google-cloud-compliance@google.com', note => 'Google Cloud Storage bucket abuse -- also report via https://support.google.com/code/go/gce_abuse_report' }, 333: 'gappssmtp.com' => { email => 'abuse@google.com', note => 'Google Workspace SMTP signing service -- report account abuse' }, 334: 'translate.goog' => { email => 'abuse@google.com', note => 'Google Translate URL proxy used to cloak phishing URLs -- report via https://support.google.com/translate/answer/4431190' }, 335: 'googleusercontent.com' => { email => 'abuse@google.com', note => 'Google user content hosting (Docs, Drive, Sites) -- also report via https://support.google.com/drive/answer/2408000' }, 336: # Microsoft 337: 'microsoft.com' => { email => 'abuse@microsoft.com', note => 'Also report via https://www.microsoft.com/en-us/wdsi/support/report-unsafe-site' }, 338: 'outlook.com' => { email => 'abuse@microsoft.com', note => 'Report Outlook spam: https://support.microsoft.com/en-us/office/report-phishing' }, 339: 'hotmail.com' => { email => 'abuse@microsoft.com', note => 'Report via https://support.microsoft.com/en-us/office/report-phishing' }, 340: 'live.com' => { email => 'abuse@microsoft.com', note => 'Microsoft consumer mail' }, 341: 'office365.com' => { email => 'abuse@microsoft.com', note => 'Microsoft 365 infrastructure' }, 342: 'protection.outlook.com' => { email => 'abuse@microsoft.com', note => 'Microsoft EOP gateway' }, 343: # Yahoo 344: 'yahoo.com' => { email => 'abuse@yahoo-inc.com', note => 'Also use https://io.help.yahoo.com/contact/index' }, 345: 'yahoo.co.uk' => { email => 'abuse@yahoo-inc.com', note => 'Yahoo UK' }, 346: # Apple 347: 'apple.com' => { email => 'reportphishing@apple.com', note => 'iCloud / Apple Mail abuse' }, 348: 'icloud.com' => { email => 'reportphishing@apple.com', note => 'iCloud abuse' }, 349: 'me.com' => { email => 'reportphishing@apple.com', note => 'Apple legacy mail' }, 350: # Amazon / AWS 351: 'amazon.com' => { email => 'abuse@amazonaws.com', note => 'Also https://aws.amazon.com/forms/report-abuse' }, 352: 'amazonaws.com' => { email => 'abuse@amazonaws.com', note => 'AWS abuse form: https://aws.amazon.com/forms/report-abuse' }, 353: 'amazonses.com' => { email => 'abuse@amazonaws.com', note => 'Amazon SES sending infrastructure' }, 354: # Cloudflare 355: 'cloudflare.com' => { email => 'abuse@cloudflare.com', note => 'Report via https://www.cloudflare.com/abuse/' }, 356: # Fastly / Akamai 357: 'fastly.net' => { email => 'abuse@fastly.com', note => 'Fastly CDN' }, 358: 'akamai.com' => { email => 'abuse@akamai.com', note => 'Akamai CDN' }, 359: 'akamaitechnologies.com' => { email => 'abuse@akamai.com', note => 'Akamai CDN' }, 360: # Namecheap 361: 'namecheap.com' => { email => 'abuse@namecheap.com', note => 'Registrar abuse' }, 362: # GoDaddy -- web form only; email bounces 363: 'godaddy.com' => { 364: form => 'https://supportcenter.godaddy.com/AbuseReport', 365: form_paste => 'Select the abuse type (spam, phishing, malware etc). ' 366: . 'Enter the domain name in the Domain field. ' 367: . 'Paste the originating IP, risk flags, and the relevant ' 368: . 'Received: headers from the report below.', 369: form_upload => 'Take a screenshot of the report as a .png or .jpg, ' 370: . 'or export it as a .pdf.', 371: note => 'Registrar/host -- email reports not monitored, use web form', 372: }, 373: # SendGrid / Twilio 374: 'sendgrid.net' => { email => 'abuse@sendgrid.com', note => 'ESP -- include full headers' }, 375: 'sendgrid.com' => { email => 'abuse@sendgrid.com', note => 'ESP -- include full headers' }, 376: # Mailchimp / Mandrill 377: 'mailchimp.com' => { email => 'abuse@mailchimp.com', note => 'ESP abuse' }, 378: 'mandrillapp.com' => { email => 'abuse@mailchimp.com', note => 'Mandrill transactional ESP' }, 379: # OVH 380: 'ovh.net' => { email => 'abuse@ovh.net', note => 'OVH hosting' }, 381: 'ovh.com' => { email => 'abuse@ovh.com', note => 'OVH hosting' }, 382: # Hetzner 383: 'hetzner.com' => { email => 'abuse@hetzner.com', note => 'Hetzner hosting' }, 384: # Digital Ocean 385: 'digitalocean.com' => { email => 'abuse@digitalocean.com',note => 'DO abuse form: https://www.digitalocean.com/company/contact/#abuse' }, 386: # Linode / Akamai 387: 'linode.com' => { email => 'abuse@linode.com', note => 'Linode/Akamai Cloud' }, 388: # Constant Contact 389: 'constantcontact.com' => { email => 'abuse@constantcontact.com', note => 'ESP abuse' }, 390: 'r.constantcontact.com' => { email => 'abuse@constantcontact.com', note => 'Constant Contact sending infrastructure' }, 391: # HubSpot 392: 'hubspot.com' => { email => 'abuse@hubspot.com', note => 'ESP abuse' }, 393: 'hs-analytics.net' => { email => 'abuse@hubspot.com', note => 'HubSpot analytics infrastructure' }, 394: # Campaign Monitor 395: 'createsend.com' => { email => 'abuse@campaignmonitor.com', note => 'Campaign Monitor ESP' }, 396: 'cmail20.com' => { email => 'abuse@campaignmonitor.com', note => 'Campaign Monitor sending infrastructure' }, 397: # Klaviyo 398: 'klaviyo.com' => { email => 'abuse@klaviyo.com', note => 'ESP abuse' }, 399: # Brevo (formerly Sendinblue) 400: 'sendinblue.com' => { email => 'abuse@sendinblue.com', note => 'ESP abuse' }, 401: 'brevo.com' => { email => 'abuse@brevo.com', note => 'ESP abuse' }, 402: # Mailgun 403: 'mailgun.com' => { email => 'abuse@mailgun.com', note => 'ESP abuse' }, 404: 'mailgun.org' => { email => 'abuse@mailgun.com', note => 'Mailgun sending infrastructure' }, 405: # Postmark 406: 'postmarkapp.com' => { email => 'abuse@postmarkapp.com', note => 'ESP abuse' }, 407: # WordPress.com 408: 'wordpress.com' => { email => 'abuse@wordpress.com', note => 'WordPress.com hosted blog -- report via https://en.wordpress.com/abuse/' }, 409: 'wp.com' => { email => 'abuse@wordpress.com', note => 'WordPress.com short domain' }, 410: # Wix -- wixsite.com is the subdomain used for all user-hosted Wix sites 411: 'wix.com' => { email => 'abuse@wix.com', note => 'Wix platform abuse -- report via https://support.wix.com/en/article/reporting-abusive-wix-sites' }, 412: 'wixsite.com' => { email => 'abuse@wix.com', note => 'Wix user-hosted site (e.g. exitfed.wixsite.com) -- report the site URL to abuse@wix.com' }, 413: # Substack 414: 'substack.com' => { email => 'abuse@substack.com', note => 'Substack newsletter platform abuse' }, 415: # Change.org -- petition platform used by spammers as a redirect destination 416: 'change.org' => { email => 'abuse@change.org', note => 'Change.org petition platform -- report abuse via https://www.change.org/policies/abuse' }, 417: # ActiveCampaign 418: 'activecampaign.com' => { email => 'abuse@activecampaign.com', note => 'ActiveCampaign ESP' }, 419: 'ac-tinker.com' => { email => 'abuse@activecampaign.com', note => 'ActiveCampaign tracking infrastructure' }, 420: # Salesforce Marketing Cloud 421: 'salesforce.com' => { email => 'abuse@salesforce.com', note => 'Salesforce Marketing Cloud / ExactTarget ESP' }, 422: 'mc.salesforce.com' => { email => 'abuse@salesforce.com', note => 'Salesforce Marketing Cloud sending infrastructure' }, 423: 'exacttarget.com' => { email => 'abuse@salesforce.com', note => 'ExactTarget / Salesforce Marketing Cloud ESP' }, 424: 'et.exacttarget.com' => { email => 'abuse@salesforce.com', note => 'ExactTarget sending infrastructure' }, 425: # Vultr 426: 'vultr.com' => { email => 'abuse@vultr.com', note => 'Vultr hosting' }, 427: # Contabo 428: 'contabo.com' => { email => 'abuse@contabo.com', note => 'Contabo hosting' }, 429: # Leaseweb 430: 'leaseweb.com' => { email => 'abuse@leaseweb.com', note => 'Leaseweb hosting' }, 431: # M247 432: 'm247.com' => { email => 'abuse@m247.com', note => 'M247 hosting' }, 433: # MarkMonitor -- web form only 434: 'markmonitor.com' => { 435: form => 'https://corp.markmonitor.com/domain/ui/abuse-report', 436: form_paste => 'Complete all fields including the domain name and your ' 437: . 'description of the abuse. Paste the originating IP, ' 438: . 'risk flags, and the relevant Received: headers from the ' 439: . 'report below.', 440: form_upload => 'Take a screenshot of the report as a .png or .jpg, or export it as a .pdf. MarkMonitor does not accept .eml files.', 441: note => 'Brand-protection registrar -- email reports not processed', 442: }, 443: # URL shortener operators 444: 'is.gd' => { email => 'abuse@is.gd', note => 'URL shortener -- report via https://is.gd/contact.php' }, 445: 'bitly.com' => { email => 'abuse@bitly.com', note => 'URL shortener abuse' }, 446: 'bit.ly' => { email => 'abuse@bitly.com', note => 'URL shortener abuse' }, 447: 'tinyurl.com' => { email => 'abuse@tinyurl.com', note => 'URL shortener abuse' }, 448: 'ow.ly' => { email => 'abuse@hootsuite.com', note => 'Hootsuite URL shortener' }, 449: 'buff.ly' => { email => 'abuse@buffer.com', note => 'Buffer URL shortener' }, 450: 'rb.gy' => { email => 'abuse@rb.gy', note => 'URL shortener abuse' }, 451: 'cutt.ly' => { email => 'abuse@cutt.ly', note => 'URL shortener abuse' }, 452: 'shorturl.at' => { email => 'abuse@shorturl.at', note => 'URL shortener abuse' }, 453: # Dynadot -- web form only 454: 'dynadot.com' => { 455: form => 'https://www.dynadot.com/report-abuse', 456: form_paste => 'Complete all fields including the domain name and your ' 457: . 'description of the abuse. Paste the originating IP, ' 458: . 'risk flags, and the relevant Received: headers from the ' 459: . 'report below.', 460: form_upload => 'Take a screenshot of the report as a .png or .jpg, ' 461: . 'or export it as a .pdf.', 462: note => 'Registrar -- email reports not monitored, use web form', 463: }, 464: # Global Domain Group -- web form only 465: 'globaldomaingroup.com' => { 466: form => 'https://globaldomaingroup.com/report-abuse', 467: form_paste => 'Complete all fields including the domain name and your ' 468: . 'description of the abuse. Paste the originating IP, ' 469: . 'risk flags, and the relevant Received: headers from the ' 470: . 'report below.', 471: form_upload => 'Attach the original spam message as an .eml file.', 472: note => 'Registrar -- email reports explicitly not accepted', 473: }, 474: # TPG / Internode (Australia) 475: 'tpgi.com.au' => { email => 'abuse@tpg.com.au', note => 'TPG Telecom Australia' }, 476: 'tpg.com.au' => { email => 'abuse@tpg.com.au', note => 'TPG Telecom Australia' }, 477: 'internode.on.net' => { email => 'abuse@internode.on.net',note => 'Internode Australia' }, 478: ); 479: 480: # ----------------------------------------------------------------------- 481: # Constructor 482: # ----------------------------------------------------------------------- 483: 484: =head1 METHODS 485: 486: =head2 new( %options ) 487: 488: Constructs and returns a new C<Email::Abuse::Investigator> analyser object. The 489: object is stateless until C<parse_email()> is called; all analysis results 490: are stored on the object and retrieved via the public accessor methods 491: documented below. 492: 493: A single object may be reused for multiple emails by calling C<parse_email()> 494: again: all per-message cached state from the previous message is discarded 495: automatically. Cross-message IP and domain lookup results are retained 496: in a shared CHI cache (if C<CHI> is installed) to avoid redundant network 497: queries across messages processed in the same process. 498: 499: =head3 Usage 500: 501: # Minimal -- all options take safe defaults 502: my $analyser = Email::Abuse::Investigator->new(); 503: 504: # With options 505: my $analyser = Email::Abuse::Investigator->new( 506: timeout => 15, 507: trusted_relays => ['203.0.113.0/24', '10.0.0.0/8'], 508: verbose => 0, 509: ); 510: 511: $analyser->parse_email($raw_rfc2822_text); 512: my $origin = $analyser->originating_ip(); 513: my @urls = $analyser->embedded_urls(); 514: my @domains = $analyser->mailto_domains(); 515: my $risk = $analyser->risk_assessment(); 516: my @contacts = $analyser->abuse_contacts(); 517: print $analyser->report(); 518: 519: =head3 Arguments 520: 521: All arguments are optional named parameters passed as a flat key-value list. 522: 523: =over 4 524: 525: =item C<timeout> (integer, default 10) 526: 527: Maximum seconds to wait for any single network operation. Set to 0 to 528: disable timeouts (not recommended for production use). 529: 530: =item C<trusted_relays> (arrayref of strings, default []) 531: 532: IP addresses or CIDR blocks to skip during Received: chain analysis. 533: Each element may be an exact IPv4 address (C<'192.0.2.1'>) or a CIDR 534: block (C<'192.0.2.0/24'>). 535: 536: =item C<verbose> (boolean, default 0) 537: 538: When true, diagnostic messages are written to STDERR. 539: 540: =back 541: 542: =head3 Returns 543: 544: A blessed C<Email::Abuse::Investigator> object. No network I/O is performed 545: during construction. 546: 547: =head3 Side Effects 548: 549: If C<CHI> is installed, a shared in-memory cache is initialised (or 550: re-used if a cache was already created by a prior call to C<new()>). 551: This cache persists for the lifetime of the process. 552: 553: =head3 Notes 554: 555: =over 4 556: 557: =item * 558: 559: Unknown option keys are silently ignored. 560: 561: =item * 562: 563: The object is not thread-safe. Use a separate object per thread. 564: 565: =item * 566: 567: WHOIS read timeouts use C<IO::Select> rather than C<alarm()>, so they 568: work correctly on Windows and in threaded Perl interpreters. 569: 570: =back 571: 572: =head3 API Specification 573: 574: =head4 Input 575: 576: { 577: timeout => { 578: type => 'integer', 579: optional => 1, 580: min => 0, 581: default => 10, 582: }, 583: trusted_relays => { 584: type => 'arrayref', 585: element_type => 'string', 586: optional => 1, 587: default => [], 588: }, 589: verbose => { 590: type => 'boolean', 591: optional => 1, 592: default => 0, 593: }, 594: } 595: 596: =head4 Output 597: 598: { 599: type => 'object', 600: isa => 'Email::Abuse::Investigator', 601: } 602: 603: =cut 604: 605: # Class-level cross-message CHI cache (shared across all instances). 606: # Populated lazily on first call to new() when CHI is available. 607: my $_cache; 608: 609: sub new { ●610 → 637 → 646 610: my $class = shift; 611: 612: # Accept hash or hashref arguments uniformly 613: my $params = Params::Validate::Strict::validate_strict({ 614: args => Params::Get::get_params(undef, \@_) || {}, 615: schema => { 616: timeout => { 617: 'type' => 'integer', 618: 'optional' => 1, 619: 'min' => 0, 620: }, 621: trusted_relays => { 622: 'type' => 'arrayref', 623: 'element_type' => 'string', 624: 'optional' => 1, 625: }, 626: verbose => { 627: 'type' => 'boolean', 628: 'optional' => 1, 629: }, 630: }, 631: }); 632: 633: # Merge in any file-based configuration via Object::Configure 634: $params = Object::Configure::configure($class, $params); 635: 636: # Initialise the cross-message CHI cache on first construction 637: if ($HAS_CHI && !$_cache) {Mutants (Total: 1, Killed: 1, Survived: 0)
638: $_cache = CHI->new( 639: driver => 'Memory', 640: global => 1, 641: expires_in => $CACHE_TTL_SECS, 642: ); 643: } 644: 645: # Build and bless the object with default slot values 646: return bless {
Mutants (Total: 2, Killed: 2, Survived: 0)
647: timeout => $DEFAULT_TIMEOUT, 648: trusted_relays => [], 649: verbose => 0, 650: _raw => '', 651: _headers => [], 652: _body_plain => '', 653: _body_html => '', 654: _received => [], 655: _origin => undef, 656: _urls => undef, # lazy-computed by embedded_urls() 657: _mailto_domains=> undef, # lazy-computed by mailto_domains() 658: _contacts => undef, # lazy-computed by abuse_contacts() 659: _domain_info => {}, # per-message domain analysis cache 660: _sending_sw => [], # X-Mailer / X-PHP-Originating-Script etc. 661: _rcvd_tracking => [], # per-hop tracking IDs from Received: headers 662: %{$params}, # Overlay Object::Configure and caller-supplied values 663: }, $class; 664: } 665: 666: # ----------------------------------------------------------------------- 667: # Public: parse 668: # ----------------------------------------------------------------------- 669: 670: =head2 parse_email( $text ) 671: 672: Feeds a raw RFC 2822 email message to the analyser and prepares it for 673: subsequent interrogation. This is the only method that must be called 674: before any other public method. 675: 676: If the same object is used for a second message, calling C<parse_email()> 677: again completely replaces all per-message state from the first message. 678: The cross-message CHI cache is B<not> flushed; IP and domain lookups 679: cached from prior messages are retained. 680: 681: =head3 Usage 682: 683: my $raw = do { local $/; <STDIN> }; 684: $analyser->parse_email($raw); 685: 686: # Scalar reference (avoids copying large messages) 687: $analyser->parse_email(\$raw); 688: 689: # Chained 690: my $analyser = Email::Abuse::Investigator->new()->parse_email($raw); 691: 692: =head3 Arguments 693: 694: =over 4 695: 696: =item C<$text> (string or string reference, required) 697: 698: Complete raw RFC 2822 email message, including all headers and the body. 699: Both LF-only and CRLF line endings are accepted. 700: 701: =back 702: 703: =head3 Returns 704: 705: The object itself (C<$self>), enabling method chaining. 706: 707: =head3 Side Effects 708: 709: Parses headers, decodes the body (quoted-printable, base64, multipart), 710: extracts sending-software fingerprints, and populates per-hop tracking 711: data. All previously computed lazy results are discarded. 712: 713: =head3 Notes 714: 715: =over 4 716: 717: =item * 718: 719: If C<$text> is empty or contains no header/body separator, all public 720: methods will return empty/safe values. 721: 722: =item * 723: 724: Decoding errors in base64 or quoted-printable payloads are silenced; raw 725: bytes are used in place of correct output to prevent exceptions. 726: 727: =back 728: 729: =head3 API Specification 730: 731: =head4 Input 732: 733: [ 734: { 735: type => [ 'string', 'stringref' ] 736: }, 737: ] 738: 739: =head4 Output 740: 741: { 742: type => 'object', 743: isa => 'Email::Abuse::Investigator', 744: } 745: 746: =cut 747: 748: # TODO: Allow a Mail::Message object to be passed in 749: sub parse_email { 750: my $self = shift; 751: 752: # Accept both positional string and named 'text' argument 753: my $args = Params::Get::get_params('text', \@_); 754: my $text = $args->{text}; 755: 756: # Dereference a scalar-ref in a single clean pass 757: $text = $$text if ref($text) eq 'SCALAR'; 758: 759: # Any other reference type is a programming error 760: Carp::croak(__PACKAGE__ . ': parse_email() requires a string or scalar reference') if ref($text); 761: 762: # Sanitise: strip control characters that could affect terminal output. 763: # Keep \t (tabs in headers), \n (line endings), \r (CRLF mail format). 764: $text =~ s/[^\x09\x0A\x0D\x20-\x7E\x80-\xFF]//g if defined $text; 765: 766: # Store the sanitised raw text for later reproduction in reports 767: $self->{_raw} = $text // ''; 768: 769: # Invalidate all per-message lazy caches 770: $self->{_origin} = undef; 771: $self->{_urls} = undef; 772: $self->{_mailto_domains} = undef; 773: $self->{_contacts} = undef; 774: $self->{_domain_info} = {}; 775: $self->{_risk} = undef; 776: $self->{_auth_results} = undef; 777: $self->{_sending_sw} = []; 778: $self->{_rcvd_tracking} = []; 779: 780: # Perform synchronous header/body parsing (no network I/O) 781: $self->_split_message($text) if defined $text && $text =~ /\S/; 782: return $self;
Mutants (Total: 2, Killed: 2, Survived: 0)
783: } 784: 785: # ----------------------------------------------------------------------- 786: # Public: originating host 787: # ----------------------------------------------------------------------- 788: 789: =head2 originating_ip() 790: 791: Identifies the IP address of the machine that originally injected the 792: message into the mail system by walking the C<Received:> chain, skipping 793: private/trusted hops, and enriching the first external hop with rDNS, 794: WHOIS/RDAP organisation name, abuse contact, and country code. 795: 796: Both IPv4 and IPv6 addresses are extracted and evaluated. 797: 798: The result is cached; subsequent calls return the same hashref without 799: repeating network I/O. 800: 801: =head3 Usage 802: 803: my $orig = $analyser->originating_ip(); 804: if (defined $orig) { 805: printf "Origin: %s (%s)\n", $orig->{ip}, $orig->{rdns}; 806: printf "Owner: %s\n", $orig->{org}; 807: } 808: 809: =head3 Arguments 810: 811: None. C<parse_email()> must have been called first. 812: 813: =head3 Returns 814: 815: A hashref with keys C<ip>, C<rdns>, C<org>, C<abuse>, C<confidence>, 816: C<note>, and C<country> (may be undef). Returns C<undef> if no suitable 817: originating IP can be determined. 818: 819: =head3 Side Effects 820: 821: On first call: one PTR lookup and one RDAP/WHOIS query. Results are cached 822: in the object and in the cross-message CHI cache (if available). 823: 824: =head3 Notes 825: 826: Only the first (oldest) external IP in the chain is reported. See 827: C<received_trail()> for the full chain. 828: 829: =head3 API Specification 830: 831: =head4 Input 832: 833: [] 834: 835: =head4 Output 836: 837: { 838: type => [ 'hashref', 'undef' ], 839: keys => { 840: ip => { type => 'string', regex => qr/[\d.:a-fA-F]/ }, 841: rdns => { type => 'string' }, 842: org => { type => 'string' }, 843: abuse => { type => 'string' }, 844: confidence => { type => 'string', memberof => [ 'high', 'medium', 'low' ] }, 845: note => { type => 'string' }, 846: country => { type => 'string', optional => 1 }, 847: }, 848: } 849: 850: =cut 851: 852: sub originating_ip { 853: my $self = $_[0]; 854: 855: # Return the cached result if we already have it 856: $self->{_origin} //= $self->_find_origin(); 857: return $self->{_origin};
Mutants (Total: 2, Killed: 2, Survived: 0)
858: } 859: 860: # ----------------------------------------------------------------------- 861: # Public: HTTP/HTTPS URLs 862: # ----------------------------------------------------------------------- 863: 864: =head2 embedded_urls() 865: 866: Extracts every HTTP and HTTPS URL from the message body and enriches each 867: one with the hosting IP address, network organisation name, abuse contact, 868: and country code. Both IPv4 and IPv6 host addresses are supported. 869: 870: URL extraction runs across both plain-text and HTML body parts. DNS 871: lookups for each unique hostname are optionally parallelised via 872: C<AnyEvent::DNS> if that module is installed. 873: 874: The result is cached; subsequent calls return the same list without 875: repeating network I/O. 876: 877: =head3 Usage 878: 879: my @urls = $analyser->embedded_urls(); 880: for my $u (@urls) { 881: printf "URL: %s host: %s org: %s\n", 882: $u->{url}, $u->{host}, $u->{org}; 883: } 884: 885: =head3 Arguments 886: 887: None. C<parse_email()> must have been called first. 888: 889: =head3 Returns 890: 891: A list of hashrefs, one per unique URL, in first-seen order. Returns an 892: empty list if no HTTP/HTTPS URLs are present. Each hashref has keys 893: C<url>, C<host>, C<ip>, C<org>, C<abuse>, C<country>. 894: 895: =head3 Side Effects 896: 897: Per unique hostname: one A/AAAA lookup and one RDAP/WHOIS query. Results 898: are cached in the object and in the cross-message CHI cache. 899: 900: =head3 Notes 901: 902: Only C<http://> and C<https://> URLs are extracted. URL shortener hosts 903: are included in the returned list (they are flagged by C<risk_assessment()>). 904: 905: When L<LWP::UserAgent> is available, URLs whose host is a known URL shortener 906: or cloud-storage redirect cloaker (Google Cloud Storage C<storage.googleapis.com>, 907: Azure Blob Storage C<blob.core.windows.net>, Cloudflare Pages C<pages.dev>, 908: S3 buckets, CloudFront distributions, etc.) are automatically resolved by 909: following HTTP 3xx redirects and HTML C<meta http-equiv="refresh"> or 910: C<window.location> patterns up to C<$REDIRECT_MAX_HOPS> hops. The resolved 911: destination URL is added to the returned list alongside the original, so abuse 912: contacts for the real phishing target are always reported even when the email 913: body contains only an object-store redirect URL. 914: 915: =head3 API Specification 916: 917: =head4 Input 918: 919: [] 920: 921: =head4 Output 922: 923: ( 924: { 925: type => 'hashref', 926: keys => { 927: url => { type => 'string', regex => qr{^https?://}i }, 928: host => { type => 'string' }, 929: ip => { type => 'string' }, 930: org => { type => 'string' }, 931: abuse => { type => 'string' }, 932: country => { type => 'string', optional => 1 }, 933: }, 934: }, 935: ... 936: ) 937: 938: =cut 939: 940: sub embedded_urls { 941: my $self = $_[0]; 942: 943: $self->{_urls} //= $self->_extract_and_resolve_urls(); 944: return @{ $self->{_urls} };
Mutants (Total: 2, Killed: 2, Survived: 0)
945: } 946: 947: # ----------------------------------------------------------------------- 948: # Public: mailto / reply-to / from domains 949: # ----------------------------------------------------------------------- 950: 951: =head2 mailto_domains() 952: 953: Identifies every domain associated with the message as a contact, reply, 954: or delivery address, then runs a full intelligence pipeline on each one 955: (A record, MX, NS, WHOIS) to determine hosting and registration details. 956: 957: The result is cached; subsequent calls return the same list without 958: repeating network I/O. 959: 960: =head3 Usage 961: 962: my @domains = $analyser->mailto_domains(); 963: for my $d (@domains) { 964: printf "Domain: %s registrar: %s\n", 965: $d->{domain}, $d->{registrar} // 'unknown'; 966: } 967: 968: =head3 Arguments 969: 970: None. C<parse_email()> must have been called first. 971: 972: =head3 Returns 973: 974: A list of hashrefs, one per unique domain. See the main POD for the full 975: set of possible keys. Returns an empty list if no qualifying domains are 976: found. 977: 978: =head3 Side Effects 979: 980: Per unique domain: up to three A lookups, one MX lookup, one NS lookup, 981: and two WHOIS queries. Results are cached in the object and in the 982: cross-message CHI cache. 983: 984: =head3 Notes 985: 986: MX and NS lookups require C<Net::DNS>. Without it those keys are absent 987: from every returned hashref. 988: 989: =head3 API Specification 990: 991: =head4 Input 992: 993: [] 994: 995: =head4 Output 996: 997: ( 998: { 999: type => 'hashref', 1000: keys => { 1001: domain => { type => 'string' }, 1002: source => { type => 'string' }, 1003: # All other keys optional -- see main POD 1004: }, 1005: }, 1006: ... 1007: ) 1008: 1009: =cut 1010: 1011: sub mailto_domains { 1012: my $self = $_[0]; 1013: 1014: $self->{_mailto_domains} //= $self->_extract_and_analyse_domains(); 1015: return @{ $self->{_mailto_domains} };
Mutants (Total: 2, Killed: 2, Survived: 0)
1016: } 1017: 1018: =head2 all_domains() 1019: 1020: Returns the deduplicated union of every registrable domain seen anywhere 1021: in the message -- URL hosts from C<embedded_urls()> and contact domains 1022: from C<mailto_domains()> -- normalised to eTLD+1 form. 1023: 1024: Triggers C<embedded_urls()> and C<mailto_domains()> lazily. 1025: 1026: =head3 Usage 1027: 1028: my @domains = $analyser->all_domains(); 1029: print "$_\n" for @domains; 1030: 1031: =head3 Arguments 1032: 1033: None. 1034: 1035: =head3 Returns 1036: 1037: A list of plain strings (registrable domain names), lower-cased, no 1038: duplicates, in first-seen order. 1039: 1040: =head3 Side Effects 1041: 1042: Triggers C<embedded_urls()> and C<mailto_domains()> if not already cached. 1043: 1044: =head3 Notes 1045: 1046: Normalisation to eTLD+1 uses C<Domain::PublicSuffix> if installed, falling 1047: back to a built-in heuristic otherwise. 1048: 1049: =head3 API Specification 1050: 1051: =head4 Input 1052: 1053: [] 1054: 1055: =head4 Output 1056: 1057: ( 1058: { type => 'string', regex => qr/^[a-z0-9][a-z0-9.-]*\.[a-z]{2,}$/ }, 1059: ... 1060: ) 1061: 1062: =cut 1063: 1064: sub all_domains { ●1065 → 1069 → 1075 1065: my $self = $_[0]; 1066: my (%seen, @out); 1067: 1068: # Collect registrable domains from URL hosts first 1069: for my $u ($self->embedded_urls()) { 1070: my $dom = _registrable($u->{host}); 1071: push @out, $dom if $dom && !$seen{$dom}++; 1072: } 1073: 1074: # Then from contact domains (normalise subdomains to registrable parent) ●1075 → 1075 → 1079 1075: for my $d ($self->mailto_domains()) { 1076: my $dom = _registrable($d->{domain}) // $d->{domain}; 1077: push @out, $dom if $dom && !$seen{$dom}++; 1078: } 1079: return @out;
Mutants (Total: 2, Killed: 2, Survived: 0)
1080: } 1081: 1082: =head2 unresolved_contacts() 1083: 1084: Returns a list of domains and URL hosts found in the message for which no 1085: abuse contact could be determined. Useful for surfacing parties that may 1086: warrant manual investigation. 1087: 1088: =head3 Usage 1089: 1090: my @unresolved = $analyser->unresolved_contacts(); 1091: for my $u (@unresolved) { 1092: printf "Unresolved: %s (%s) via %s\n", 1093: $u->{domain}, $u->{type}, $u->{source}; 1094: } 1095: 1096: =head3 Arguments 1097: 1098: None. 1099: 1100: =head3 Returns 1101: 1102: A list of hashrefs, each with keys C<domain>, C<type> (C<'url_host'> or 1103: C<'domain'>), and C<source> (where the domain was found). 1104: 1105: =head3 Side Effects 1106: 1107: Triggers C<embedded_urls()>, C<mailto_domains()>, C<abuse_contacts()>, 1108: and C<form_contacts()> if not already cached. 1109: 1110: =head3 Notes 1111: 1112: Domains sourced only from spoofable sending headers (C<From:>, 1113: C<Return-Path:>, C<Sender:>) are excluded. 1114: 1115: =head3 API Specification 1116: 1117: =head4 Input 1118: 1119: [] 1120: 1121: =head4 Output 1122: 1123: ( 1124: { 1125: type => 'hashref', 1126: keys => { 1127: domain => { type => 'string' }, 1128: type => { type => 'string', memberof => [ 'url_host', 'domain' ] }, 1129: source => { type => 'string' }, 1130: }, 1131: }, 1132: ... 1133: ) 1134: 1135: =cut 1136: 1137: sub unresolved_contacts { ●1138 → 1142 → 1152 1138: my $self = $_[0]; 1139: 1140: # Build a set of domains already covered by email or form contacts 1141: my %covered; 1142: for my $c ($self->abuse_contacts(), $self->form_contacts()) { 1143: my $dom = $c->{form_domain}; 1144: unless ($dom) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1145: # Extract domain from abuse email address 1146: ($dom) = ($c->{address} // '') =~ /\@([\w.-]+)/; 1147: } 1148: $covered{lc $dom}++ if $dom; 1149: } 1150: 1151: # Also mark URL hosts that already have a resolved abuse address ●1152 → 1152 → 1157 1152: for my $u ($self->embedded_urls()) { 1153: (my $bare = lc $u->{host}) =~ s/^www\.//; 1154: $covered{$bare}++ if $u->{abuse} && $u->{abuse} ne '(unknown)'; 1155: } 1156: ●1157 → 1160 → 1173 1157: my (@out, %seen); 1158: 1159: # Check URL hosts first 1160: for my $u ($self->embedded_urls()) { 1161: (my $bare = lc $u->{host}) =~ s/^www\.//; 1162: next if $covered{$bare}; 1163: next if $self->_provider_abuse_for_host($bare); 1164: next if $seen{"url:$bare"}++; 1165: push @out, { 1166: domain => $u->{host}, 1167: type => 'url_host', 1168: source => 'URL in body', 1169: }; 1170: } 1171: 1172: # Then check contact domains, skipping spoofable-header-only sources ●1173 → 1173 → 1187 1173: for my $d ($self->mailto_domains()) { 1174: my $dom = $d->{domain}; 1175: my $source = $d->{source} // ''; 1176: next if $source =~ /^(?:From:|Return-Path:|Sender:) header$/; 1177: next if $covered{lc $dom}; 1178: next if $self->_provider_abuse_for_host($dom); 1179: next if $seen{"dom:$dom"}++; 1180: push @out, { 1181: domain => $dom, 1182: type => 'domain', 1183: source => $source, 1184: }; 1185: } 1186: 1187: return @out;
Mutants (Total: 2, Killed: 2, Survived: 0)
1188: } 1189: 1190: # ----------------------------------------------------------------------- 1191: # Public: sending software fingerprint 1192: # ----------------------------------------------------------------------- 1193: 1194: =head2 sending_software() 1195: 1196: Returns information extracted from headers that identify the software or 1197: server-side infrastructure used to compose or inject the message. Headers 1198: such as C<X-PHP-Originating-Script> reveal the exact PHP script and Unix 1199: account responsible on shared-hosting platforms. 1200: 1201: Data is extracted during C<parse_email()> with no network I/O. 1202: 1203: =head3 Usage 1204: 1205: my @sw = $analyser->sending_software(); 1206: for my $s (@sw) { 1207: printf "%-30s : %s\n", $s->{header}, $s->{value}; 1208: } 1209: 1210: =head3 Arguments 1211: 1212: None. C<parse_email()> must have been called first. 1213: 1214: =head3 Returns 1215: 1216: A list of hashrefs in alphabetical header-name order. Returns an empty 1217: list if none of the watched headers are present. Each hashref has keys 1218: C<header>, C<value>, and C<note>. 1219: 1220: =head3 Side Effects 1221: 1222: None. Data is pre-collected during C<parse_email()>. 1223: 1224: =head3 Notes 1225: 1226: Header names are lower-cased. Header values are stored verbatim. 1227: 1228: =head3 API Specification 1229: 1230: =head4 Input 1231: 1232: [] 1233: 1234: =head4 Output 1235: 1236: ( 1237: { 1238: type => 'hashref', 1239: keys => { 1240: header => { type => 'string' }, 1241: value => { type => 'string' }, 1242: note => { type => 'string' }, 1243: }, 1244: }, 1245: ... 1246: ) 1247: 1248: =cut 1249: 1250: sub sending_software { 1251: my $self = $_[0]; 1252: 1253: return @{ $self->{_sending_sw} };
Mutants (Total: 2, Killed: 2, Survived: 0)
1254: } 1255: 1256: # ----------------------------------------------------------------------- 1257: # Public: per-hop tracking IDs 1258: # ----------------------------------------------------------------------- 1259: 1260: =head2 received_trail() 1261: 1262: Returns per-hop tracking data extracted from the C<Received:> header chain: 1263: the IP address, envelope recipient address, and server session ID for each 1264: relay. ISP postmasters use these identifiers to locate the SMTP session in 1265: their logs. 1266: 1267: =head3 Usage 1268: 1269: my @trail = $analyser->received_trail(); 1270: for my $hop (@trail) { 1271: printf "IP: %s ID: %s\n", 1272: $hop->{ip} // '?', $hop->{id} // '?'; 1273: } 1274: 1275: =head3 Arguments 1276: 1277: None. C<parse_email()> must have been called first. 1278: 1279: =head3 Returns 1280: 1281: A list of hashrefs in oldest-first order. Returns an empty list if no 1282: C<Received:> headers are present or none yielded extractable data. Each 1283: hashref has keys C<received>, C<ip> (may be undef), C<for> (may be undef), 1284: C<id> (may be undef). 1285: 1286: =head3 Side Effects 1287: 1288: None. Data is pre-collected during C<parse_email()>. 1289: 1290: =head3 Notes 1291: 1292: Private IPs are NOT filtered here; all IPs including RFC 1918 addresses 1293: are returned as found. Filtering is applied only by C<originating_ip()>. 1294: 1295: =head3 API Specification 1296: 1297: =head4 Input 1298: 1299: [] 1300: 1301: =head4 Output 1302: 1303: ( 1304: { 1305: type => 'hashref', 1306: keys => { 1307: received => { type => 'string' }, 1308: ip => { type => 'string', optional => 1 }, 1309: for => { type => 'string', optional => 1 }, 1310: id => { type => 'string', optional => 1 }, 1311: }, 1312: }, 1313: ... 1314: ) 1315: 1316: =cut 1317: 1318: sub received_trail { 1319: my $self = $_[0]; 1320: 1321: return @{ $self->{_rcvd_tracking} };
Mutants (Total: 2, Killed: 2, Survived: 0)
1322: } 1323: 1324: # ----------------------------------------------------------------------- 1325: # Public: risk assessment 1326: # ----------------------------------------------------------------------- 1327: 1328: =head2 risk_assessment() 1329: 1330: Evaluates the message against heuristic checks and returns an overall risk 1331: level, a weighted numeric score, and a list of every specific red flag. 1332: 1333: The assessment covers five categories: originating IP, email authentication, 1334: Date: header validity, identity/header consistency, and URL/domain properties. 1335: 1336: The result is cached; subsequent calls return the same hashref without 1337: repeating any analysis. 1338: 1339: =head3 Usage 1340: 1341: my $risk = $analyser->risk_assessment(); 1342: printf "Risk: %s (score: %d)\n", $risk->{level}, $risk->{score}; 1343: for my $f (@{ $risk->{flags} }) { 1344: printf " [%s] %s\n", $f->{severity}, $f->{detail}; 1345: } 1346: 1347: =head3 Arguments 1348: 1349: None. C<parse_email()> must have been called first. 1350: 1351: =head3 Returns 1352: 1353: A hashref with keys C<level> (HIGH/MEDIUM/LOW/INFO), C<score> (integer), 1354: and C<flags> (arrayref of hashrefs with C<severity>, C<flag>, C<detail>). 1355: 1356: =head3 Side Effects 1357: 1358: Triggers C<originating_ip()>, C<embedded_urls()>, and C<mailto_domains()> 1359: if not already cached. 1360: 1361: =head3 Notes 1362: 1363: Scores: HIGH >= 9, MEDIUM >= 5, LOW >= 2, INFO < 2. 1364: Flag weights: HIGH=3, MEDIUM=2, LOW=1, INFO=0. 1365: 1366: =head3 API Specification 1367: 1368: =head4 Input 1369: 1370: [] 1371: 1372: =head4 Output 1373: 1374: { 1375: type => 'hashref', 1376: keys => { 1377: level => { type => 'string', memberof => ['HIGH', 'MEDIUM', 'LOW', 'INFO'] }, 1378: score => { type => 'integer' }, 1379: flags => { type => 'arrayref' }, 1380: }, 1381: } 1382: 1383: =cut 1384: 1385: sub risk_assessment { 1386: my $self = $_[0]; 1387: 1388: return $self->{_risk} if $self->{_risk};
Mutants (Total: 2, Killed: 2, Survived: 0)
1389: 1390: my (@flags, $score); 1391: $score = 0; 1392: 1393: # Closure to record a flag and accumulate its weight 1394: my $flag = sub { 1395: my ($severity, $name, $detail) = @_; 1396: $score += $FLAG_WEIGHT{$severity} // 1; 1397: push @flags, { severity => $severity, flag => $name, detail => $detail }; 1398: }; 1399: 1400: $self->_risk_check_origin($flag); 1401: $self->_risk_check_auth($flag); 1402: $self->_risk_check_date($flag); 1403: $self->_risk_check_identity($flag); 1404: $self->_risk_check_urls_and_domains($flag); 1405: 1406: # Determine overall risk level from accumulated score 1407: my $level = $score >= $SCORE_HIGH ? 'HIGH'
Mutants (Total: 3, Killed: 3, Survived: 0)
1408: : $score >= $SCORE_MEDIUM ? 'MEDIUM'
Mutants (Total: 3, Killed: 3, Survived: 0)
1409: : $score >= $SCORE_LOW ? 'LOW'
Mutants (Total: 3, Killed: 3, Survived: 0)
1410: : 'INFO'; 1411: 1412: $self->{_risk} = { level => $level, score => $score, flags => \@flags }; 1413: return $self->{_risk};
Mutants (Total: 2, Killed: 2, Survived: 0)
1414: } 1415: 1416: # _risk_check_origin( $flag ) 1417: # 1418: # Purpose: 1419: # Evaluate the originating IP for residential rDNS, absent rDNS, 1420: # low-confidence origin, and high-spam-volume country. 1421: # 1422: # Entry criteria: 1423: # $flag -- coderef( severity, name, detail ) that accumulates flags. 1424: # 1425: # Exit status: 1426: # Returns nothing; side effects via $flag closure. 1427: 1428: sub _risk_check_origin :Private { ●1429 → 1436 → 1447 1429: my ($self, $flag) = @_; 1430: my $orig = $self->originating_ip(); 1431: return unless $orig; 1432: 1433: return if(!defined($orig->{ip})); 1434: 1435: # Residential / broadband rDNS patterns suggest a compromised host 1436: if ($orig->{rdns} && $orig->{rdns} =~ /
Mutants (Total: 1, Killed: 1, Survived: 0)
1437: \d+[-_.]\d+[-_.]\d+[-_.]\d+ # dotted-quad in rDNS 1438: | (?:dsl|adsl|cable|broad|dial|dynamic|dhcp|ppp| 1439: residential|cust|home|pool|client|user| 1440: static\d|host\d) 1441: /xi) { 1442: $flag->('HIGH', 'residential_sending_ip', 1443: "Sending IP $orig->{ip} rDNS '$orig->{rdns}' looks like a broadband/residential line, not a legitimate mail server"); 1444: } 1445: 1446: # Absence of rDNS is a strong spam indicator ●1447 → 1447 → 1453 1447: if (!$orig->{rdns} || $orig->{rdns} eq '(no reverse DNS)') {
Mutants (Total: 1, Killed: 1, Survived: 0)
1448: $flag->('HIGH', 'no_reverse_dns', 1449: "Sending IP $orig->{ip} has no reverse DNS -- legitimate mail servers always have rDNS"); 1450: } 1451: 1452: # Low-confidence origin means the IP came from an unverifiable header ●1453 → 1453 → 1459 1453: if ($orig->{confidence} eq 'low') {
Mutants (Total: 1, Killed: 1, Survived: 0)
1454: $flag->('MEDIUM', 'low_confidence_origin', 1455: "Originating IP taken from unverified header ($orig->{note})"); 1456: } 1457: 1458: # Statistically high-volume spam countries (informational only) ●1459 → 1459 → 0 1459: if ($orig->{country} && $orig->{country} =~ /^(?:CN|RU|NG|VN|IN|PK|BD)$/) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1460: $flag->('INFO', 'high_spam_country', 1461: 'Sending IP is in ' . _country_name($orig->{country}) . 1462: " ($orig->{country}) -- statistically high spam volume country"); 1463: } 1464: } 1465: 1466: # _risk_check_auth( $flag ) 1467: # 1468: # Purpose: 1469: # Evaluate SPF, DKIM, DMARC results and DKIM signing domain alignment. 1470: # 1471: # Entry criteria: 1472: # $flag -- accumulator coderef. 1473: # 1474: # Exit status: 1475: # Returns nothing; side effects via $flag closure. 1476: 1477: sub _risk_check_auth :Private { ●1478 → 1481 → 1493 1478: my ($self, $flag) = @_; 1479: my $auth = $self->_parse_auth_results_cached(); 1480: 1481: if (defined $auth->{spf}) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1482: if ($auth->{spf} =~ /^fail/i) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1483: $flag->('HIGH', 'spf_fail', 1484: "SPF result: $auth->{spf} -- sending IP not authorised by domain's SPF record"); 1485: } elsif ($auth->{spf} =~ /^softfail/i) { 1486: $flag->('MEDIUM', 'spf_softfail', 1487: "SPF result: softfail (~all) -- sending IP not explicitly authorised"); 1488: } elsif ($auth->{spf} !~ /^pass/i) { 1489: $flag->('HIGH', 'spf_fail', 1490: "SPF result: $auth->{spf} -- sending IP not authorised"); 1491: } 1492: } ●1493 → 1493 → 1497 1493: if (defined $auth->{dkim} && $auth->{dkim} !~ /^pass/i) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1494: $flag->('HIGH', 'dkim_fail', 1495: "DKIM result: $auth->{dkim} -- message signature invalid or absent"); 1496: } ●1497 → 1497 → 1502 1497: if (defined $auth->{dmarc} && $auth->{dmarc} !~ /^pass/i) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1498: $flag->('HIGH', 'dmarc_fail', "DMARC result: $auth->{dmarc}"); 1499: } 1500: 1501: # DKIM signing domain vs From: domain mismatch check ●1502 → 1510 → 0 1502: return unless $auth->{dkim_domain}; 1503: my ($from_domain) = ($self->_header_value('from') // '') =~ /\@([\w.-]+)/; 1504: return unless $from_domain; 1505: my $reg_dkim = _registrable($auth->{dkim_domain}) // $auth->{dkim_domain}; 1506: my $reg_from = _registrable(lc $from_domain) // lc $from_domain; 1507: return if $reg_dkim eq $reg_from; 1508: 1509: # Passing DKIM with a different domain is normal for ESPs 1510: if ($auth->{dkim} && $auth->{dkim} =~ /^pass/i) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1511: $flag->('INFO', 'dkim_domain_mismatch', 1512: "DKIM signed by '$auth->{dkim_domain}' but From: domain is '$from_domain'" 1513: . ' -- message sent via third-party sender (normal for bulk/ESP mail)'); 1514: } else { 1515: # Failing DKIM plus mismatched domain is more suspicious 1516: $flag->('MEDIUM', 'dkim_domain_mismatch', 1517: "DKIM signed by '$auth->{dkim_domain}' but From: domain is '$from_domain'" 1518: . ' and DKIM did not pass -- possible impersonation'); 1519: } 1520: } 1521: 1522: # _risk_check_date( $flag ) 1523: # 1524: # Purpose: 1525: # Validate the Date: header for presence, plausible timezone, and 1526: # date not too far in the past or future. 1527: # 1528: # Entry criteria: 1529: # $flag -- accumulator coderef. 1530: # 1531: # Exit status: 1532: # Returns nothing; side effects via $flag closure. 1533: 1534: sub _risk_check_date :Private { ●1535 → 1538 → 1545 1535: my ($self, $flag) = @_; 1536: my $date_raw = $self->_header_value('date'); 1537: 1538: if (!$date_raw || $date_raw !~ /\S/) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1539: $flag->('MEDIUM', 'missing_date', 1540: 'No Date: header -- violates RFC 5322; common in spam'); 1541: return; 1542: } 1543: 1544: # Check for an implausible timezone offset (outside real-world bounds) ●1545 → 1545 → 1559 1545: if ($date_raw =~ /([+-])(\d{2})(\d{2})\s*$/) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1546: my ($sign, $hh, $mm) = ($1, $2, $3); 1547: my $offset_mins = $hh * 60 + $mm; 1548: my $implausible = $mm >= 60
Mutants (Total: 3, Killed: 3, Survived: 0)
1549: || ($sign eq '+' && $offset_mins > $TZ_MAX_POS_MINS)
Mutants (Total: 3, Killed: 3, Survived: 0)
1550: || ($sign eq '-' && $offset_mins > $TZ_MAX_NEG_MINS);
Mutants (Total: 3, Killed: 3, Survived: 0)
1551: if ($implausible) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1552: $flag->('MEDIUM', 'implausible_timezone', 1553: "Date: '$date_raw' contains an implausible timezone offset " 1554: . "($sign$hh$mm) -- header is likely forged"); 1555: } 1556: } 1557: 1558: # Check for dates more than DATE_SKEW_DAYS outside the analysis window ●1559 → 1562 → 0 1559: my $date_epoch = _parse_rfc2822_date($date_raw); 1560: return unless defined $date_epoch; 1561: my $delta = time() - $date_epoch; 1562: if ($delta > $DATE_SKEW_DAYS * $SECS_PER_DAY) {
Mutants (Total: 4, Killed: 4, Survived: 0)
1563: $flag->('LOW', 'suspicious_date', 1564: "Date: '$date_raw' is more than $DATE_SKEW_DAYS days in the past"); 1565: } elsif ($delta < -($DATE_SKEW_DAYS * $SECS_PER_DAY)) {
Mutants (Total: 3, Killed: 3, Survived: 0)
1566: $flag->('LOW', 'suspicious_date', 1567: "Date: '$date_raw' is more than $DATE_SKEW_DAYS days in the future"); 1568: } 1569: } 1570: 1571: # _risk_check_identity( $flag ) 1572: # 1573: # Purpose: 1574: # Check From: display-name spoofing, free webmail, Reply-To mismatch, 1575: # undisclosed recipients, and MIME-encoded Subject. 1576: # 1577: # Entry criteria: 1578: # $flag -- accumulator coderef. 1579: # 1580: # Exit status: 1581: # Returns nothing; side effects via $flag closure. 1582: 1583: sub _risk_check_identity :Private { ●1584 → 1589 → 1605 1584: my ($self, $flag) = @_; 1585: my $from_raw = $self->_header_value('from') // ''; 1586: my $from_decoded = $self->_decode_mime_words($from_raw); 1587: 1588: # Display-name domain spoofing: "PayPal paypal.com" <phish@evil.example> 1589: if ($from_decoded =~ /^"?([^"<]+?)"?\s*<([^>]+)>/) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1590: my ($display, $addr) = ($1, $2); 1591: while ($display =~ /\b([\w-]+\.(?:com|net|org|io|co|uk|au|gov|edu))\b/gi) { 1592: my $disp_domain = lc $1; 1593: my ($addr_domain) = $addr =~ /\@([\w.-]+)/; 1594: $addr_domain = lc($addr_domain // ''); 1595: my $reg_disp = _registrable($disp_domain); 1596: my $reg_addr = _registrable($addr_domain); 1597: if ($reg_disp && $reg_addr && $reg_disp ne $reg_addr) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1598: $flag->('HIGH', 'display_name_domain_spoof', 1599: "From: display name mentions '$disp_domain' but actual address is <$addr>"); 1600: } 1601: } 1602: } 1603: 1604: # Free webmail sender flag (no corporate infrastructure) ●1605 → 1605 → 1612 1605: if ($from_raw =~ /\@(gmail|yahoo|hotmail|outlook|live|aol|protonmail|yandex)\./i
Mutants (Total: 1, Killed: 1, Survived: 0)
1606: || $from_raw =~ /\@mail\.ru(?:[\s>]|$)/i) { 1607: $flag->('MEDIUM', 'free_webmail_sender', 1608: "Message sent from free webmail address ($from_raw)"); 1609: } 1610: 1611: # Reply-To differs from From: -- replies harvested by different address ●1612 → 1613 → 1623 1612: my $reply_to = $self->_header_value('reply-to'); 1613: if ($reply_to) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1614: my ($from_addr) = $from_raw =~ /([\w.+%-]+\@[\w.-]+)/; 1615: my ($reply_addr) = $reply_to =~ /([\w.+%-]+\@[\w.-]+)/; 1616: if ($from_addr && $reply_addr && lc($from_addr) ne lc($reply_addr)) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1617: $flag->('MEDIUM', 'reply_to_differs_from_from', 1618: "Reply-To ($reply_addr) differs from From: ($from_addr)"); 1619: } 1620: } 1621: 1622: # Undisclosed or absent To: header ●1623 → 1624 → 1630 1623: my $to = $self->_header_value('to') // ''; 1624: if ($to =~ /undisclosed|:;/ || $to eq '') {
Mutants (Total: 1, Killed: 1, Survived: 0)
1625: $flag->('MEDIUM', 'undisclosed_recipients', 1626: "To: header is '$to' -- message was bulk-sent with hidden recipient list"); 1627: } 1628: 1629: # MIME-encoded Subject (potential filter evasion) ●1630 → 1631 → 0 1630: my $subj_raw = $self->_header_value('subject') // ''; 1631: if ($subj_raw =~ /=\?[^?]+\?[BQ]\?/i) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1632: $flag->('LOW', 'encoded_subject', 1633: "Subject line is MIME-encoded: '$subj_raw' (decoded: '" 1634: . $self->_decode_mime_words($subj_raw) . "')"); 1635: } 1636: } 1637: 1638: # _risk_check_urls_and_domains( $flag ) 1639: # 1640: # Purpose: 1641: # Check embedded URLs for shorteners and plain HTTP, and contact domains 1642: # for recent registration, imminent expiry, and lookalike brand names. 1643: # 1644: # Entry criteria: 1645: # $flag -- accumulator coderef. 1646: # 1647: # Exit status: 1648: # Returns nothing; side effects via $flag closure. 1649: 1650: sub _risk_check_urls_and_domains :Private { ●1651 → 1654 → 1681 1651: my ($self, $flag) = @_; 1652: my (%shortener_seen, %cloaker_seen, %url_host_seen); 1653: 1654: for my $u ($self->embedded_urls()) { 1655: # Skip trusted infrastructure -- these are not spam indicators 1656: next unless($u->{host}); 1657: my $bare = lc $u->{host}; 1658: next unless defined($bare); 1659: $bare =~ s/^www\.//; 1660: next if $self->{trusted_domains}->{$bare}; 1661: next if $TRUSTED_DOMAINS{$bare}; 1662: 1663: # URL shortener hides real destination 1664: if(($URL_SHORTENERS{$bare} || $self->{url_shorteners}->{$bare}) && !$shortener_seen{$bare}++) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1665: $flag->('MEDIUM', 'url_shortener', 1666: "$u->{host} is a URL shortener -- the real destination is hidden"); 1667: } 1668: # Cloud object-store / CDN used as a redirect cloaker 1669: if ($self->_is_redirect_cloaker($bare) && !$cloaker_seen{$bare}++) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1670: $flag->('MEDIUM', 'redirect_cloaker', 1671: "$u->{host} is a cloud storage or CDN host used as a redirect cloaker -- the real phishing destination is hidden behind a client-side redirect"); 1672: } 1673: # Plain HTTP provides no encryption 1674: if ($u->{url} =~ m{^http://}i && !$url_host_seen{ $u->{host} }++) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1675: $flag->('LOW', 'http_not_https', 1676: "$u->{host} linked over plain HTTP -- no encryption"); 1677: } 1678: } 1679: 1680: # Domain-level checks against contact/reply domains ●1681 → 1681 → 0 1681: for my $d ($self->mailto_domains()) { 1682: # Recently registered domain is a common phishing indicator 1683: if ($d->{recently_registered}) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1684: $flag->('HIGH', 'recently_registered_domain', 1685: "$d->{domain} was registered $d->{registered} (less than ${\$RECENT_REG_DAYS} days ago)"); 1686: } 1687: 1688: # Domain expiry checks 1689: if ($d->{expires}) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1690: if(my $exp = $self->_parse_date_to_epoch($d->{expires})) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1691: my $now = time(); 1692: my $remaining = $exp - $now; 1693: if ($remaining > 0 && $remaining < $EXPIRY_WARN_DAYS * $SECS_PER_DAY) {
Mutants (Total: 7, Killed: 7, Survived: 0)
1694: $flag->('HIGH', 'domain_expires_soon', 1695: "$d->{domain} expires $d->{expires} -- may be a throwaway domain"); 1696: } elsif ($remaining <= 0) {
1697: $flag->('HIGH', 'domain_expired', 1698: "$d->{domain} expired $d->{expires} -- domain has lapsed"); 1699: } 1700: } 1701: } 1702: 1703: # Lookalike domain check (brand name in a non-brand domain) 1704: for my $brand (@LOOKALIKE_BRANDS) { 1705: next if(!defined($d->{domain})); 1706: if ($d->{domain} =~ /\Q$brand\E/i &&Mutants (Total: 3, Killed: 0, Survived: 3)
- NUM_BOUNDARY_1696_25_<: Numeric boundary flip <= to <
HIGH: Likely missing edge-case test (boundary value)🧪 Suggested Test# Boundary test suggestion is( func(VALUE_AT_BOUNDARY), EXPECTED, 'Test boundary behaviour' );- NUM_BOUNDARY_1696_25_>: Numeric boundary flip <= to >
HIGH: Likely missing edge-case test (boundary value)🧪 Suggested Test# Boundary test suggestion is( func(VALUE_AT_BOUNDARY), EXPECTED, 'Test boundary behaviour' );- NUM_BOUNDARY_1696_25_>=: Numeric boundary flip <= to >=
HIGH: Likely missing edge-case test (boundary value)🧪 Suggested Test# Boundary test suggestion is( func(VALUE_AT_BOUNDARY), EXPECTED, 'Test boundary behaviour' );Mutants (Total: 1, Killed: 1, Survived: 0)
1707: $d->{domain} !~ /^\Q$brand\E\.(?:com|co\.uk|net|org)$/) { 1708: $flag->('HIGH', 'lookalike_domain', 1709: "$d->{domain} contains brand name '$brand' but is not the real domain -- possible phishing"); 1710: last; 1711: } 1712: } 1713: } 1714: } 1715: 1716: # ----------------------------------------------------------------------- 1717: # Public: abuse report text 1718: # ----------------------------------------------------------------------- 1719: 1720: =head2 abuse_report_text() 1721: 1722: Produces a compact, plain-text string suitable for sending as the body of 1723: an abuse report email. It summarises risk level, red flags, originating IP, 1724: abuse contacts, and original message headers. The message body is omitted 1725: to keep the report concise. 1726: 1727: Use C<abuse_contacts()> to get the recipient addresses and this method for 1728: the body text. 1729: 1730: =head3 Usage 1731: 1732: my $text = $analyser->abuse_report_text(); 1733: my @contacts = $analyser->abuse_contacts(); 1734: for my $c (@contacts) { 1735: send_email(to => $c->{address}, body => $text); 1736: } 1737: 1738: =head3 Arguments 1739: 1740: None. C<parse_email()> must have been called first. 1741: 1742: =head3 Returns 1743: 1744: A plain scalar string, newline-terminated, Unix line endings. Never empty 1745: or undef. 1746: 1747: =head3 Side Effects 1748: 1749: Calls C<risk_assessment()>, C<originating_ip()>, and C<abuse_contacts()> 1750: if not already cached. 1751: 1752: =head3 Notes 1753: 1754: Output text is sanitised: control characters that could affect terminal or 1755: HTML rendering are stripped from all user-derived content before inclusion. 1756: 1757: =head3 API Specification 1758: 1759: =head4 Input 1760: 1761: [] 1762: 1763: =head4 Output 1764: 1765: { type => 'string' } 1766: 1767: =cut 1768: 1769: sub abuse_report_text { ●1770 → 1782 → 1791 1770: my $self = $_[0]; 1771: my @out; 1772: 1773: push @out, 'This is an automated abuse report generated by Email::Abuse::Investigator.', 1774: 'Please investigate the following spam/phishing message.', 1775: ''; 1776: 1777: my $risk = $self->risk_assessment(); 1778: push @out, "RISK LEVEL: $risk->{level} (score: $risk->{score})", 1779: ''; 1780: 1781: # List each red flag with its severity prefix 1782: if (@{ $risk->{flags} }) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1783: push @out, 'RED FLAGS IDENTIFIED:'; 1784: for my $f (@{ $risk->{flags} }) { 1785: push @out, " [$f->{severity}] " . _sanitise_output($f->{detail}); 1786: } 1787: push @out, ''; 1788: } 1789: 1790: # Originating IP summary block ●1791 → 1792 → 1800 1791: my $orig = $self->originating_ip(); 1792: if ($orig) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1793: push @out, 'ORIGINATING IP: ' . _sanitise_output("$orig->{ip} ($orig->{rdns})"), 1794: 'NETWORK OWNER: ' . _sanitise_output($orig->{org}), 1795: ''; 1796: } 1797: 1798: # List every reported URL so the receiving abuse desk knows exactly 1799: # which resources to investigate or suspend. ●1800 → 1801 → 1815 1800: my @urls = $self->embedded_urls(); 1801: if (@urls) {
1802: push @out, 'REPORTED URLs:'; 1803: for my $u (@urls) { 1804: push @out, ' ' . _sanitise_output($u->{url}); 1805: my @meta; 1806: push @meta, "host: $u->{host}" if $u->{host}; 1807: push @meta, "IP: $u->{ip}" if $u->{ip} && $u->{ip} ne '(unresolved)'; 1808: push @meta, "org: $u->{org}" if $u->{org} && $u->{org} ne '(unknown)'; 1809: push @out, ' (' . join(' ', @meta) . ')' if @meta; 1810: } 1811: push @out, ''; 1812: } 1813: 1814: # Email abuse contacts ●1815 → 1816 → 1823 1815: my @contacts = $self->abuse_contacts(); 1816: if (@contacts) {Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_1801_2: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomesMutants (Total: 1, Killed: 1, Survived: 0)
1817: push @out, 'ABUSE CONTACTS:'; 1818: push @out, ' ' . _sanitise_output("$_->{address} ($_->{role})") for @contacts; 1819: push @out, ''; 1820: } 1821: 1822: # Web-form contacts (providers that reject email) ●1823 → 1823 → 1837 1823: if(my @form_cs = $self->form_contacts()) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1824: push @out, 'WEB-FORM REPORTS REQUIRED:', 1825: ' The following parties do not accept email -- submit manually:'; 1826: for my $c (@form_cs) { 1827: push @out, " [$c->{role}]", 1828: ' Form : ' . _sanitise_output($c->{form}); 1829: push @out, ' Domain : ' . _sanitise_output($c->{form_domain}) if $c->{form_domain}; 1830: push @out, ' Paste : ' . _sanitise_output($c->{form_paste}) if $c->{form_paste}; 1831: push @out, ' Upload : ' . _sanitise_output($c->{form_upload}) if $c->{form_upload}; 1832: } 1833: push @out, ''; 1834: } 1835: 1836: # Separator and raw headers (body excluded for brevity) ●1837 → 1841 → 1844 1837: push @out, '-' x 72, 1838: 'ORIGINAL MESSAGE HEADERS:', 1839: '-' x 72; 1840: 1841: for my $h (@{ $self->{_headers} }) { 1842: push @out, _sanitise_output("$h->{name}: $h->{value}"); 1843: } 1844: push @out, ''; 1845: 1846: return join("\n", @out);
Mutants (Total: 2, Killed: 2, Survived: 0)
1847: } 1848: 1849: # ----------------------------------------------------------------------- 1850: # Public: abuse contacts 1851: # ----------------------------------------------------------------------- 1852: 1853: =head2 abuse_contacts() 1854: 1855: Collates the complete set of parties that should receive an abuse report: 1856: the sending ISP, URL host operators, contact domain web/mail/DNS/registrar 1857: contacts, account providers identified from key headers, the DKIM signer, 1858: and the ESP identified via List-Unsubscribe. 1859: 1860: Addresses are deduplicated globally; if the same address is found via 1861: multiple routes, a single entry is kept and role strings are merged. 1862: 1863: =head3 Usage 1864: 1865: my @contacts = $analyser->abuse_contacts(); 1866: my @addrs = map { $_->{address} } @contacts; 1867: 1868: =head3 Arguments 1869: 1870: None. C<parse_email()> must have been called first. 1871: 1872: =head3 Returns 1873: 1874: A list of hashrefs, one per unique abuse address, in discovery order. 1875: Each hashref has keys C<role>, C<roles> (arrayref), C<address>, C<note>, 1876: C<via>. Returns an empty list if no contacts can be determined. 1877: 1878: =head3 Side Effects 1879: 1880: Triggers C<originating_ip()>, C<embedded_urls()>, and C<mailto_domains()> 1881: if not already cached. 1882: 1883: =head3 Notes 1884: 1885: The result is cached on the object; subsequent calls return the same list 1886: without repeating the contact-collection logic. The underlying per-IP and 1887: per-domain lookups are themselves cached by C<originating_ip()>, 1888: C<embedded_urls()>, and C<mailto_domains()>. 1889: 1890: =head3 API Specification 1891: 1892: =head4 Input 1893: 1894: [] 1895: 1896: =head4 Output 1897: 1898: ( 1899: { 1900: type => 'hashref', 1901: keys => { 1902: role => { type => 'string' }, 1903: roles => { type => 'arrayref' }, 1904: address => { type => 'string', regex => qr/\@/ }, 1905: note => { type => 'string' }, 1906: via => { type => 'string', memberof => [ 'provider-table', 'ip-whois', 'domain-whois' ] } 1907: }, 1908: }, 1909: ... 1910: ) 1911: 1912: =cut 1913: 1914: sub abuse_contacts { 1915: my $self = $_[0]; 1916: $self->{_contacts} //= [ $self->_compute_abuse_contacts() ]; 1917: return @{ $self->{_contacts} };
Mutants (Total: 2, Killed: 2, Survived: 0)
1918: } 1919: 1920: # _compute_abuse_contacts() -> list of contact hashrefs 1921: # 1922: # Purpose: 1923: # Actual implementation of abuse_contacts(). Separated so the public 1924: # method can cache without duplicating logic. 1925: # 1926: # Entry criteria: 1927: # parse_email() must have been called. 1928: # 1929: # Exit status: 1930: # Returns list of deduplicated contact hashrefs. 1931: 1932: sub _compute_abuse_contacts :Private { ●1933 → 2004 → 2025 1933: my $self = $_[0]; 1934: 1935: my (@contacts, %seen_idx); 1936: 1937: # Inner closure: add one contact entry, merging roles for duplicate addresses 1938: my $add = sub { 1939: my (%args) = @_; 1940: my $addr = lc($args{address} // ''); 1941: return unless $addr && $addr =~ /\@/; 1942: 1943: # Suppress addresses belonging to form-only providers (no email accepted) 1944: if ($addr =~ /\@([\w.-]+)$/) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1945: my $dom = $1; 1946: my $pa = $self->_provider_abuse_for_host($dom); 1947: return if $pa && $pa->{form} && !$pa->{email}; 1948: } 1949: 1950: if (exists $seen_idx{$addr}) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1951: # Merge the new role into the existing entry 1952: my $entry = $contacts[ $seen_idx{$addr} ]; 1953: push @{ $entry->{roles} }, $args{role}; 1954: 1955: # Collapse repeated role labels to avoid unreadable strings 1956: my (%role_counts, @ordered_roles); 1957: for my $r (@{ $entry->{roles} }) { 1958: push @ordered_roles, $r unless $role_counts{$r}++; 1959: } 1960: my @display = map { 1961: $role_counts{$_} > 1 ? "$_ (x$role_counts{$_})" : $_
1962: } @ordered_roles; 1963: my $joined = join(' and ', @display); 1964: 1965: # Summarise if the merged string is too long to read. 1966: # "URL host: hostname" entries are grouped by listing the actual 1967: # hostnames so the summary is actionable (e.g. "URL host: a.example, 1968: # b.example" rather than the unhelpful "URL host, URL host"). 1969: # All other role types fall back to stripping at the first [:(\d] 1970: # boundary to produce a compact type label. 1971: if (length($joined) > $ROLE_MAX_LEN) {Mutants (Total: 3, Killed: 0, Survived: 3)
- NUM_BOUNDARY_1961_22_<: Numeric boundary flip > to <
HIGH: Likely missing edge-case test (boundary value)🧪 Suggested Test# Boundary test suggestion is( func(VALUE_AT_BOUNDARY), EXPECTED, 'Test boundary behaviour' );- NUM_BOUNDARY_1961_22_>=: Numeric boundary flip > to >=
HIGH: Likely missing edge-case test (boundary value)🧪 Suggested Test# Boundary test suggestion is( func(VALUE_AT_BOUNDARY), EXPECTED, 'Test boundary behaviour' );- NUM_BOUNDARY_1961_22_<=: Numeric boundary flip > to <=
HIGH: Likely missing edge-case test (boundary value)🧪 Suggested Test# Boundary test suggestion is( func(VALUE_AT_BOUNDARY), EXPECTED, 'Test boundary behaviour' );Mutants (Total: 4, Killed: 4, Survived: 0)
1972: my (@url_hosts, %seen_short, @short); 1973: for my $r (@display) { 1974: if ($r =~ /^URL host:\s*(.+)$/) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1975: push @url_hosts, $1; 1976: } else { 1977: (my $s = $r) =~ s/[:(\d].*//; 1978: $s =~ s/\s+$//; 1979: push @short, $s unless $seen_short{$s}++; 1980: } 1981: } 1982: my @parts; 1983: if (@url_hosts) {
1984: my $extra = @url_hosts > 3Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_1983_5: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomesMutants (Total: 3, Killed: 3, Survived: 0)
1985: ? ' and ' . (@url_hosts - 3) . ' more' : ''; 1986: my @shown = @url_hosts > 3 ? @url_hosts[0..2] : @url_hosts;
Mutants (Total: 3, Killed: 3, Survived: 0)
1987: push @parts, 'URL host: ' . join(', ', @shown) . $extra; 1988: } 1989: push @parts, @short; 1990: $joined = scalar(@display) . ' routes: ' . join(', ', @parts); 1991: } 1992: $entry->{role} = $joined; 1993: return; 1994: } 1995: 1996: # First time seeing this address -- record and store 1997: $seen_idx{$addr} = scalar @contacts; 1998: $args{roles} = [ $args{role} ]; 1999: push @contacts, \%args; 2000: }; 2001: 2002: # Route 1 -- Sending ISP (originating IP) 2003: my $orig = $self->originating_ip(); 2004: if ($orig) {
Mutants (Total: 1, Killed: 1, Survived: 0)
2005: my $pa = $self->_provider_abuse_for_ip($orig->{ip}, $orig->{rdns}); 2006: if ($pa) {
Mutants (Total: 1, Killed: 1, Survived: 0)
2007: $add->( 2008: role => 'Sending ISP', 2009: address => $pa->{email}, 2010: note => "$orig->{ip} ($orig->{rdns}) -- $pa->{note}", 2011: via => 'provider-table', 2012: ); 2013: } 2014: if ($orig->{abuse} && $orig->{abuse} ne '(unknown)') {
Mutants (Total: 1, Killed: 1, Survived: 0)
2015: $add->( 2016: role => 'Sending ISP', 2017: address => $orig->{abuse}, 2018: note => "Network owner of originating IP $orig->{ip} ($orig->{org})", 2019: via => 'ip-whois', 2020: ); 2021: } 2022: } 2023: 2024: # Route 2 -- URL hosts ●2025 → 2026 → 2053 2025: my %url_host_seen; 2026: for my $u ($self->embedded_urls()) { 2027: next if $url_host_seen{ $u->{host} }++; 2028: my $bare_host = lc $u->{host}; 2029: $bare_host =~ s/^www\.//; 2030: # Skip trusted infrastructure (Google, W3C, etc.) 2031: next if $self->{trusted_domains}->{$bare_host}; 2032: next if $TRUSTED_DOMAINS{$bare_host}; 2033: my $pa = $self->_provider_abuse_for_host($u->{host}); 2034: if ($pa) {
Mutants (Total: 1, Killed: 1, Survived: 0)
2035: $add->( 2036: role => "URL host: $u->{host}", 2037: address => $pa->{email}, 2038: note => "$u->{host} -- $pa->{note}", 2039: via => 'provider-table', 2040: ); 2041: } 2042: if ($u->{abuse} && $u->{abuse} ne '(unknown)') {
Mutants (Total: 1, Killed: 1, Survived: 0)
2043: $add->( 2044: role => "URL host: $u->{host}", 2045: address => $u->{abuse}, 2046: note => "Hosting $u->{host} ($u->{ip}, $u->{org})", 2047: via => 'ip-whois', 2048: ); 2049: } 2050: } 2051: 2052: # Route 3 -- Contact domain hosting and registration ●2053 → 2053 → 2120 2053: for my $d ($self->mailto_domains()) { 2054: my $dom = $d->{domain}; 2055: 2056: # Web host contact 2057: if ($d->{web_abuse}) {
Mutants (Total: 1, Killed: 1, Survived: 0)
2058: my $pa = $self->_provider_abuse_for_host($dom); 2059: if ($pa) {
2060: $add->(role => "Web host of $dom", address => $pa->{email}, 2061: note => $pa->{note}, via => 'provider-table'); 2062: } 2063: $add->( 2064: role => "Web host of $dom", 2065: address => $d->{web_abuse}, 2066: note => sprintf('Hosting %s (%s, %s)', 2067: $dom // '(unknown domain)', 2068: $d->{web_ip} // '(unknown IP)', 2069: $d->{web_org} // '(unknown org)'), 2070: via => 'ip-whois', 2071: ); 2072: } 2073: 2074: # MX (mail host) contact 2075: if ($d->{mx_abuse}) {Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_2059_4: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomesMutants (Total: 1, Killed: 1, Survived: 0)
2076: $add->( 2077: role => "Mail host (MX) for $dom", 2078: address => $d->{mx_abuse}, 2079: note => sprintf('MX %s (%s, %s)', 2080: $d->{mx_host} // '(unknown host)', 2081: $d->{mx_ip} // '(unknown IP)', 2082: $d->{mx_org} // '(unknown org)'), 2083: via => 'ip-whois', 2084: ); 2085: } 2086: 2087: # NS (DNS host) contact 2088: if ($d->{ns_abuse}) {
Mutants (Total: 1, Killed: 1, Survived: 0)
2089: $add->( 2090: role => "DNS host (NS) for $dom", 2091: address => $d->{ns_abuse}, 2092: note => sprintf('NS %s (%s, %s)', 2093: $d->{ns_host} // '(unknown host)', 2094: $d->{ns_ip} // '(unknown IP)', 2095: $d->{ns_org} // '(unknown org)'), 2096: via => 'ip-whois', 2097: ); 2098: } 2099: 2100: # Domain registrar (skip if domain only seen in spoofable headers) 2101: if ($d->{registrar_abuse}) {
Mutants (Total: 1, Killed: 1, Survived: 0)
2102: my $spoofable_only = 2103: $d->{source} =~ /^(?:From:|Return-Path:|Sender:) header$/ && 2104: !scalar(grep { 2105: $_->{host} && 2106: _registrable($_->{host}) eq (_registrable($dom) // $dom) 2107: } $self->embedded_urls()); 2108: unless ($spoofable_only) {
Mutants (Total: 1, Killed: 1, Survived: 0)
2109: $add->( 2110: role => "Domain registrar for $dom", 2111: address => $d->{registrar_abuse}, 2112: note => 'Registrar: ' . ($d->{registrar} // '(unknown)'), 2113: via => 'domain-whois', 2114: ); 2115: } 2116: } 2117: } 2118: 2119: # Route 4 -- From:/Reply-To:/Return-Path:/Sender: account provider ●2120 → 2120 → 2145 2120: for my $hname (qw(from reply-to return-path sender)) { 2121: my $val = $self->_header_value($hname) // next; 2122: 2123: # Extract addr-spec from angle-bracket form to avoid display-name @-signs 2124: my $addr_spec = ($val =~ /<([^>]*)>\s*$/) ? $1 : $val; 2125: my ($addr_domain) = $addr_spec =~ /\@([\w.-]+)/; 2126: next unless $addr_domain; 2127: 2128: # Skip SRS-rewritten forwarder addresses (not the real sender) 2129: next if $addr_spec =~ /\+SRS[0-9]?=/i; 2130: 2131: my $pa = $self->_provider_abuse_for_host($addr_domain); 2132: if ($pa) {
Mutants (Total: 1, Killed: 1, Survived: 0)
2133: my $role_addr = $addr_spec =~ /\@/ ? $addr_spec : $val; 2134: $role_addr =~ s/^\s+|\s+$//g; 2135: $add->( 2136: role => "Account provider ($hname: $role_addr)", 2137: address => $pa->{email}, 2138: note => $pa->{note}, 2139: via => 'provider-table', 2140: ); 2141: } 2142: } 2143: 2144: # Route 5 -- DKIM signing organisation ●2145 → 2146 → 2159 2145: my $auth = $self->_parse_auth_results_cached(); 2146: if ($auth->{dkim_domain}) {
Mutants (Total: 1, Killed: 1, Survived: 0)
2147: my $pa = $self->_provider_abuse_for_host($auth->{dkim_domain}); 2148: if ($pa) {
Mutants (Total: 1, Killed: 1, Survived: 0)
2149: $add->( 2150: role => "DKIM signer: $auth->{dkim_domain}", 2151: address => $pa->{email}, 2152: note => $pa->{note}, 2153: via => 'provider-table', 2154: ); 2155: } 2156: } 2157: 2158: # Route 6 -- List-Unsubscribe ESP domain ●2159 → 2160 → 2183 2159: my $unsub = $self->_header_value('list-unsubscribe'); 2160: if ($unsub) {
2161: my @unsub_domains; 2162: while ($unsub =~ m{https?://([^/:?\s>]+)}gi) { 2163: push @unsub_domains, lc $1; 2164: } 2165: while ($unsub =~ m{mailto:[^@\s>]+\@([\w.-]+)}gi) { 2166: push @unsub_domains, lc $1; 2167: } 2168: my %unsub_seen; 2169: for my $dom (grep { !$unsub_seen{$_}++ } @unsub_domains) { 2170: my $pa = $self->_provider_abuse_for_host($dom); 2171: if ($pa) {Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_2160_2: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes2172: $add->( 2173: role => "ESP / bulk sender (List-Unsubscribe: $dom)", 2174: address => $pa->{email}, 2175: note => "$pa->{note} -- responsible for this bulk delivery", 2176: via => 'provider-table', 2177: ); 2178: } 2179: } 2180: } 2181: 2182: # Route 7 -- Reply addresses embedded in the message body ●2183 → 2185 → 2199 2183: my %body_addr_seen; 2184: my $combined_body = $self->{_body_plain} . "\n" . $self->{_body_html}; 2185: for my $addr_dom ($self->_domains_from_text($combined_body)) { 2186: next if $body_addr_seen{$addr_dom}++; 2187: my $pa = $self->_provider_abuse_for_host($addr_dom); 2188: next unless $pa && $pa->{email}; 2189: my ($example_addr) = $combined_body =~ /(\S+\@\Q$addr_dom\E)/i; 2190: $example_addr //= "\@$addr_dom"; 2191: $add->( 2192: role => "Reply address in body ($example_addr)", 2193: address => $pa->{email}, 2194: note => $pa->{note}, 2195: via => 'provider-table', 2196: ); 2197: } 2198: 2199: return @contacts;Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_2171_4: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomesMutants (Total: 2, Killed: 2, Survived: 0)
2200: } 2201: 2202: # ----------------------------------------------------------------------- 2203: # Public: form contacts (providers that require web-form submission) 2204: # ----------------------------------------------------------------------- 2205: 2206: =head2 form_contacts() 2207: 2208: Returns the list of parties that require abuse reports via a web form 2209: rather than email. These are providers whose C<%PROVIDER_ABUSE> entry 2210: has a C<form> key. Each hashref includes the form URL, paste 2211: instructions, upload instructions, and the discovery role. 2212: 2213: =head3 Usage 2214: 2215: my @forms = $analyser->form_contacts(); 2216: for my $c (@forms) { 2217: printf "Open: %s\n", $c->{form}; 2218: } 2219: 2220: =head3 Arguments 2221: 2222: None. C<parse_email()> must have been called first. 2223: 2224: =head3 Returns 2225: 2226: A list of hashrefs, one per unique form contact. Each hashref has keys 2227: C<form>, C<role>, C<note>, C<form_paste> (optional), C<form_upload> 2228: (optional), and C<via>. Returns an empty list if no form contacts are found. 2229: 2230: =head3 Side Effects 2231: 2232: Triggers C<originating_ip()>, C<embedded_urls()>, and C<mailto_domains()> 2233: if not already cached. 2234: 2235: =head3 Notes 2236: 2237: Deduplication is by form URL. 2238: 2239: =head3 API Specification 2240: 2241: =head4 Input 2242: 2243: [] 2244: 2245: =head4 Output 2246: 2247: ( 2248: { 2249: type => 'hashref', 2250: keys => { 2251: form => { type => 'string', regex => qr{^https?://} }, 2252: role => { type => 'string' }, 2253: note => { type => 'string' }, 2254: form_paste => { type => 'string', optional => 1 }, 2255: form_upload => { type => 'string', optional => 1 }, 2256: via => { type => 'string' }, 2257: }, 2258: }, 2259: ... 2260: ) 2261: 2262: =cut 2263: 2264: sub form_contacts { ●2265 → 2280 → 2295 2265: my $self = $_[0]; 2266: 2267: my (@contacts, %seen); 2268: 2269: # Inner closure: add one form-contact entry, deduplicating by form URL 2270: my $add = sub { 2271: my (%args) = @_; 2272: my $form = $args{form} // ''; 2273: return unless $form; 2274: return if $seen{$form}++; 2275: push @contacts, \%args; 2276: }; 2277: 2278: # Route 1 -- Sending ISP 2279: my $orig = $self->originating_ip(); 2280: if ($orig) {
2281: my $pa = $self->_provider_abuse_for_ip($orig->{ip}, $orig->{rdns}); 2282: if ($pa && $pa->{form}) {Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_2280_2: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes2283: $add->( 2284: role => 'Sending ISP', 2285: form => $pa->{form}, 2286: note => $pa->{note} // '', 2287: form_paste => $pa->{form_paste} // '', 2288: form_upload => $pa->{form_upload} // '', 2289: via => 'provider-table', 2290: ); 2291: } 2292: } 2293: 2294: # Route 2 -- URL hosts ●2295 → 2296 → 2313 2295: my %url_host_seen; 2296: for my $u ($self->embedded_urls()) { 2297: next if $url_host_seen{ $u->{host} }++; 2298: my $pa = $self->_provider_abuse_for_host($u->{host}); 2299: if ($pa && $pa->{form}) {Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_2282_3: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomesMutants (Total: 1, Killed: 1, Survived: 0)
2300: $add->( 2301: role => "URL host: $u->{host}", 2302: form => $pa->{form}, 2303: form_domain => $u->{host}, 2304: note => $pa->{note} // '', 2305: form_paste => $pa->{form_paste} // '', 2306: form_upload => $pa->{form_upload} // '', 2307: via => 'provider-table', 2308: ); 2309: } 2310: } 2311: 2312: # Route 3 -- Contact domains (web host + registrar) ●2313 → 2313 → 2347 2313: for my $d ($self->mailto_domains()) { 2314: my $dom = $d->{domain}; 2315: my $pa = $self->_provider_abuse_for_host($dom); 2316: if ($pa && $pa->{form}) {
2317: $add->( 2318: role => "Web host of $dom", 2319: form => $pa->{form}, 2320: form_domain => $dom, 2321: note => $pa->{note} // '', 2322: form_paste => $pa->{form_paste} // '', 2323: form_upload => $pa->{form_upload} // '', 2324: via => 'provider-table', 2325: ); 2326: } 2327: 2328: # Registrar identified via WHOIS -- check for form-only registrar 2329: if ($d->{registrar_abuse} && $d->{registrar_abuse} =~ /\@([\w.-]+)/) {Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_2316_3: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomesMutants (Total: 1, Killed: 1, Survived: 0)
2330: my $reg_domain = lc $1; 2331: my $rpa = $self->_provider_abuse_for_host($reg_domain); 2332: if ($rpa && $rpa->{form}) {
Mutants (Total: 1, Killed: 1, Survived: 0)
2333: $add->( 2334: role => "Domain registrar for $dom (web form only)", 2335: form => $rpa->{form}, 2336: form_domain => $dom, 2337: note => $rpa->{note} // '', 2338: form_paste => $rpa->{form_paste} // '', 2339: form_upload => $rpa->{form_upload} // '', 2340: via => 'provider-table', 2341: ); 2342: } 2343: } 2344: } 2345: 2346: # Route 4 -- Account provider headers ●2347 → 2347 → 2370 2347: for my $hname (qw(from reply-to return-path sender)) { 2348: my $val = $self->_header_value($hname) // next; 2349: my $addr_spec = ($val =~ /<([^>]*)>\s*$/) ? $1 : $val; 2350: my ($addr_domain) = $addr_spec =~ /\@([\w.-]+)/; 2351: next unless $addr_domain; 2352: # Skip SRS forwarder rewrite addresses 2353: next if $addr_spec =~ /\+SRS[0-9]?=/i; 2354: my $pa = $self->_provider_abuse_for_host($addr_domain); 2355: if ($pa && $pa->{form}) {
Mutants (Total: 1, Killed: 1, Survived: 0)
2356: my $role_addr = $addr_spec =~ /@/ ? $addr_spec : $val; 2357: $role_addr =~ s/^\s+|\s+$//g; 2358: $add->( 2359: role => "Account provider ($hname: $role_addr)", 2360: form => $pa->{form}, 2361: note => $pa->{note} // '', 2362: form_paste => $pa->{form_paste} // '', 2363: form_upload => $pa->{form_upload} // '', 2364: via => 'provider-table', 2365: ); 2366: } 2367: } 2368: 2369: # Route 5 -- DKIM signer ●2370 → 2371 → 2386 2370: my $auth = $self->_parse_auth_results_cached(); 2371: if ($auth->{dkim_domain}) {
2372: my $pa = $self->_provider_abuse_for_host($auth->{dkim_domain}); 2373: if ($pa && $pa->{form}) {Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_2371_2: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes2374: $add->( 2375: role => "DKIM signer: $auth->{dkim_domain}", 2376: form => $pa->{form}, 2377: note => $pa->{note} // '', 2378: form_paste => $pa->{form_paste} // '', 2379: form_upload => $pa->{form_upload} // '', 2380: via => 'provider-table', 2381: ); 2382: } 2383: } 2384: 2385: # Route 6 -- List-Unsubscribe ESP domains ●2386 → 2387 → 2407 2386: my $unsub = $self->_header_value('list-unsubscribe'); 2387: if ($unsub) {Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_2373_3: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes2388: my @unsub_domains; 2389: while ($unsub =~ m{https?://([^/:?\s>]+)}gi) { push @unsub_domains, lc $1 } 2390: while ($unsub =~ m{mailto:[^@\s>]+\@([\w.-]+)}gi) { push @unsub_domains, lc $1 } 2391: my %useen; 2392: for my $dom (grep { !$useen{$_}++ } @unsub_domains) { 2393: my $pa = $self->_provider_abuse_for_host($dom); 2394: if ($pa && $pa->{form}) {Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_2387_2: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes2395: $add->( 2396: role => "ESP / bulk sender (List-Unsubscribe: $dom)", 2397: form => $pa->{form}, 2398: note => $pa->{note} // '', 2399: form_paste => $pa->{form_paste} // '', 2400: form_upload => $pa->{form_upload} // '', 2401: via => 'provider-table', 2402: ); 2403: } 2404: } 2405: } 2406: 2407: return @contacts;Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_2394_4: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomesMutants (Total: 2, Killed: 2, Survived: 0)
2408: } 2409: 2410: # ----------------------------------------------------------------------- 2411: # Public: full analyst report 2412: # ----------------------------------------------------------------------- 2413: 2414: =head2 report() 2415: 2416: Produces a comprehensive, analyst-facing plain-text report covering all 2417: findings: envelope fields, risk assessment, originating host, sending 2418: software, received chain tracking IDs, embedded URLs, contact domain 2419: intelligence, and recommended abuse contacts. 2420: 2421: Use C<report()> for human review or ticketing systems. Use 2422: C<abuse_report_text()> for sending to ISP abuse desks. 2423: 2424: =head3 Usage 2425: 2426: print $analyser->report(); 2427: 2428: open my $fh, '>', 'report.txt' or croak "Cannot open: $!"; 2429: print $fh $analyser->report(); 2430: close $fh; 2431: 2432: =head3 Arguments 2433: 2434: None. C<parse_email()> must have been called first. 2435: 2436: =head3 Returns 2437: 2438: A plain scalar string, newline-terminated, Unix line endings. Never empty 2439: or undef. 2440: 2441: =head3 Side Effects 2442: 2443: Triggers all analysis methods if not already cached. 2444: 2445: =head3 Notes 2446: 2447: The report is idempotent: calling it multiple times on the same object 2448: always returns an identical string. All user-derived content is sanitised 2449: before output. 2450: 2451: =head3 API Specification 2452: 2453: =head4 Input 2454: 2455: [] 2456: 2457: =head4 Output 2458: 2459: { type => 'string' } 2460: 2461: =cut 2462: 2463: sub report { ●2464 → 2475 → 2483 2464: my $self = $_[0]; 2465: 2466: my @out; 2467: 2468: # Banner header 2469: push @out, '=' x 72; 2470: push @out, " Email::Abuse::Investigator Report (v$VERSION)"; 2471: push @out, '=' x 72; 2472: push @out, ''; 2473: 2474: # Envelope summary -- decode MIME encoded-words for readability 2475: for my $f (qw(from reply-to return-path subject date message-id)) { 2476: my $v = $self->_header_value($f); 2477: next unless defined $v; 2478: my $decoded = $self->_decode_mime_words($v); 2479: my $label = ucfirst($f); 2480: push @out, sprintf(' %-14s : %s', $label, 2481: _sanitise_output($decoded ne $v ? "$decoded [encoded: $v]" : $v)); 2482: } ●2483 → 2488 → 2495 2483: push @out, ''; 2484: 2485: # Risk assessment section 2486: my $risk = $self->risk_assessment(); 2487: push @out, "[ RISK ASSESSMENT: $risk->{level} (score: $risk->{score}) ]"; 2488: if (@{ $risk->{flags} }) {
Mutants (Total: 1, Killed: 1, Survived: 0)
2489: for my $f (@{ $risk->{flags} }) { 2490: push @out, " [$f->{severity}] " . _sanitise_output($f->{detail}); 2491: } 2492: } else { 2493: push @out, ' (no specific red flags detected)'; 2494: } ●2495 → 2499 → 2510 2495: push @out, ''; 2496: 2497: # Originating host section 2498: push @out, '[ ORIGINATING HOST ]'; 2499: if(my $orig = $self->originating_ip()) {
Mutants (Total: 1, Killed: 1, Survived: 0)
2500: push @out, ' IP : ' . _sanitise_output($orig->{ip}); 2501: push @out, ' Reverse DNS : ' . _sanitise_output($orig->{rdns}) if $orig->{rdns}; 2502: push @out, ' Country : ' . _sanitise_output($orig->{country}) if $orig->{country}; 2503: push @out, ' Organisation : ' . _sanitise_output($orig->{org}) if $orig->{org}; 2504: push @out, ' Abuse addr : ' . _sanitise_output($orig->{abuse}) if $orig->{abuse}; 2505: push @out, " Confidence : $orig->{confidence}"; 2506: push @out, ' Note : ' . _sanitise_output($orig->{note}) if $orig->{note}; 2507: } else { 2508: push @out, ' (could not determine originating IP)'; 2509: } ●2510 → 2514 → 2524 2510: push @out, ''; 2511: 2512: # Sending software section (omitted if none found) 2513: my @sw = $self->sending_software(); 2514: if (@sw) {
Mutants (Total: 1, Killed: 1, Survived: 0)
2515: push @out, '[ SENDING SOFTWARE / INFRASTRUCTURE CLUES ]'; 2516: for my $s (@sw) { 2517: push @out, sprintf(' %-14s : %s', $s->{header}, _sanitise_output($s->{value})); 2518: push @out, " Note : $s->{note}"; 2519: push @out, ''; 2520: } 2521: } 2522: 2523: # Received chain tracking IDs (only hops with id or for are shown) ●2524 → 2526 → 2539 2524: my @trail = grep { defined $_->{id} || defined $_->{for} } 2525: $self->received_trail(); 2526: if (@trail) {
Mutants (Total: 1, Killed: 1, Survived: 0)
2527: push @out, '[ RECEIVED CHAIN TRACKING IDs ]'; 2528: push @out, ' (Supply these to the relevant ISP abuse team to trace the session)'; 2529: push @out, ''; 2530: for my $hop (@trail) { 2531: push @out, ' IP : ' . (_sanitise_output($hop->{ip}) // '(unknown)'); 2532: push @out, ' Envelope for : ' . _sanitise_output($hop->{for}) if $hop->{for}; 2533: push @out, ' Server ID : ' . _sanitise_output($hop->{id}) if $hop->{id}; 2534: push @out, ''; 2535: } 2536: } 2537: 2538: # Embedded URLs section -- grouped by hostname ●2539 → 2541 → 2584 2539: push @out, '[ EMBEDDED HTTP/HTTPS URLs ]'; 2540: my @urls = $self->embedded_urls(); 2541: if (@urls) {
Mutants (Total: 1, Killed: 1, Survived: 0)
2542: my (%host_order, %host_meta, %host_paths); 2543: my $seq = 0; 2544: for my $u (@urls) { 2545: my $h = $u->{host}; 2546: unless (exists $host_order{$h}) {
Mutants (Total: 1, Killed: 1, Survived: 0)
2547: $host_order{$h} = $seq++; 2548: $host_meta{$h} = { 2549: ip => $u->{ip}, 2550: org => $u->{org}, 2551: abuse => $u->{abuse}, 2552: country => $u->{country}, 2553: }; 2554: } 2555: push @{ $host_paths{$h} }, $u->{url}; 2556: } 2557: 2558: # Output each host group in first-seen order 2559: for my $h (sort { $host_order{$a} <=> $host_order{$b} } keys %host_order) { 2560: my $m = $host_meta{$h}; 2561: my $bare = lc $h; $bare =~ s/^www\.//; 2562: push @out, ' Host : ' . _sanitise_output($h) . 2563: (($URL_SHORTENERS{$bare} || $self->{url_shorteners}->{$bare}) 2564: ? ' *** URL SHORTENER -- real destination hidden ***' : ''); 2565: push @out, ' IP : ' . _sanitise_output($m->{ip}) if $m->{ip}; 2566: push @out, ' Country : ' . _sanitise_output($m->{country}) if $m->{country}; 2567: push @out, ' Organisation : ' . _sanitise_output($m->{org}) if $m->{org}; 2568: push @out, ' Abuse addr : ' . _sanitise_output($m->{abuse}) if $m->{abuse}; 2569: my @paths = @{ $host_paths{$h} }; 2570: if (@paths == 1) {
Mutants (Total: 2, Killed: 2, Survived: 0)
2571: push @out, ' URL : ' . _sanitise_output($paths[0]); 2572: } else { 2573: push @out, ' URLs (' . scalar(@paths) . ') :'; 2574: push @out, ' ' . _sanitise_output($_) for @paths; 2575: } 2576: push @out, ''; 2577: } 2578: } else { 2579: push @out, ' (none found)'; 2580: push @out, ''; 2581: } 2582: 2583: # Contact / reply-to domains section ●2584 → 2586 → 2626 2584: push @out, '[ CONTACT / REPLY-TO DOMAINS ]'; 2585: my @mdoms = $self->mailto_domains(); 2586: if (@mdoms) {
Mutants (Total: 1, Killed: 1, Survived: 0)
2587: for my $d (@mdoms) { 2588: push @out, ' Domain : ' . _sanitise_output($d->{domain}); 2589: push @out, ' Found in : ' . _sanitise_output($d->{source}); 2590: if ($d->{recently_registered}) {
Mutants (Total: 1, Killed: 1, Survived: 0)
2591: push @out, ' *** WARNING: RECENTLY REGISTERED - possible phishing domain ***'; 2592: } 2593: push @out, ' Registered : ' . $d->{registered} if $d->{registered}; 2594: push @out, ' Expires : ' . $d->{expires} if $d->{expires}; 2595: push @out, ' Registrar : ' . _sanitise_output($d->{registrar}) if $d->{registrar}; 2596: push @out, ' Reg. abuse : ' . _sanitise_output($d->{registrar_abuse}) if $d->{registrar_abuse}; 2597: if ($d->{web_ip}) {
Mutants (Total: 1, Killed: 1, Survived: 0)
2598: push @out, ' Web host IP : ' . _sanitise_output($d->{web_ip}); 2599: push @out, ' Web host org : ' . _sanitise_output($d->{web_org}) if $d->{web_org}; 2600: push @out, ' Web abuse : ' . _sanitise_output($d->{web_abuse}) if $d->{web_abuse}; 2601: } else { 2602: push @out, ' Web host : (no A record / unreachable)'; 2603: } 2604: if ($d->{mx_host}) {
Mutants (Total: 1, Killed: 1, Survived: 0)
2605: push @out, ' MX host : ' . _sanitise_output($d->{mx_host}); 2606: push @out, ' MX IP : ' . _sanitise_output($d->{mx_ip}) if $d->{mx_ip}; 2607: push @out, ' MX org : ' . _sanitise_output($d->{mx_org}) if $d->{mx_org}; 2608: push @out, ' MX abuse : ' . _sanitise_output($d->{mx_abuse}) if $d->{mx_abuse}; 2609: } else { 2610: push @out, ' MX host : (none found)'; 2611: } 2612: if ($d->{ns_host}) {
Mutants (Total: 1, Killed: 1, Survived: 0)
2613: push @out, ' NS host : ' . _sanitise_output($d->{ns_host}); 2614: push @out, ' NS IP : ' . _sanitise_output($d->{ns_ip}) if $d->{ns_ip}; 2615: push @out, ' NS org : ' . _sanitise_output($d->{ns_org}) if $d->{ns_org}; 2616: push @out, ' NS abuse : ' . _sanitise_output($d->{ns_abuse}) if $d->{ns_abuse}; 2617: } 2618: push @out, ''; 2619: } 2620: } else { 2621: push @out, ' (none found)'; 2622: push @out, ''; 2623: } 2624: 2625: # Abuse contacts summary ●2626 → 2628 → 2642 2626: push @out, '[ WHERE TO SEND ABUSE REPORTS ]'; 2627: my @contacts = $self->abuse_contacts(); 2628: if (@contacts) {
Mutants (Total: 1, Killed: 1, Survived: 0)
2629: for my $c (@contacts) { 2630: push @out, ' Role : ' . _sanitise_output($c->{role}); 2631: push @out, ' Send to : ' . _sanitise_output($c->{address}); 2632: push @out, ' Note : ' . _sanitise_output($c->{note}) if $c->{note}; 2633: push @out, " Discovered : $c->{via}"; 2634: push @out, ''; 2635: } 2636: } else { 2637: push @out, ' (no abuse contacts could be determined)'; 2638: push @out, ''; 2639: } 2640: 2641: # Web-form contacts (providers that require manual form submission) ●2642 → 2643 → 2675 2642: my @form_cs = $self->form_contacts(); 2643: if (@form_cs) {
Mutants (Total: 1, Killed: 1, Survived: 0)
2644: push @out, '[ WHERE TO FILE WEB-FORM REPORTS ]'; 2645: push @out, ' The following parties require manual submission via a web form.'; 2646: push @out, ' Open each URL in a browser, then follow the instructions below it.'; 2647: push @out, ''; 2648: for my $c (@form_cs) { 2649: push @out, ' Role : ' . _sanitise_output($c->{role}); 2650: push @out, ' Form URL : ' . _sanitise_output($c->{form}); 2651: push @out, ' Domain/URL : ' . _sanitise_output($c->{form_domain}) if $c->{form_domain}; 2652: push @out, ' Note : ' . _sanitise_output($c->{note}) if $c->{note}; 2653: if ($c->{form_paste}) {
Mutants (Total: 1, Killed: 1, Survived: 0)
2654: # Word-wrap the paste hint at ROLE_WRAP_LEN characters 2655: my $hint = $c->{form_paste}; 2656: my @words = split /\s+/, $hint; 2657: my (@lines, $line); 2658: for my $w (@words) { 2659: if (defined $line && length("$line $w") > $ROLE_WRAP_LEN) {
2660: push @lines, $line; 2661: $line = $w; 2662: } else { 2663: $line = defined $line ? "$line $w" : $w; 2664: } 2665: } 2666: push @lines, $line if defined $line; 2667: push @out, ' Paste : ' . shift @lines if @lines; 2668: push @out, ' ' . $_ for @lines; 2669: } 2670: push @out, ' Upload : ' . _sanitise_output($c->{form_upload}) if $c->{form_upload}; 2671: push @out, ''; 2672: } 2673: } 2674: 2675: push @out, '=' x 72; 2676: return join("\n", @out) . "\n";Mutants (Total: 4, Killed: 0, Survived: 4)
- NUM_BOUNDARY_2659_46_<: Numeric boundary flip > to <
HIGH: Likely missing edge-case test (boundary value)🧪 Suggested Test# Boundary test suggestion is( func(VALUE_AT_BOUNDARY), EXPECTED, 'Test boundary behaviour' );- NUM_BOUNDARY_2659_46_>=: Numeric boundary flip > to >=
HIGH: Likely missing edge-case test (boundary value)🧪 Suggested Test# Boundary test suggestion is( func(VALUE_AT_BOUNDARY), EXPECTED, 'Test boundary behaviour' );- NUM_BOUNDARY_2659_46_<=: Numeric boundary flip > to <=
HIGH: Likely missing edge-case test (boundary value)🧪 Suggested Test# Boundary test suggestion is( func(VALUE_AT_BOUNDARY), EXPECTED, 'Test boundary behaviour' );- COND_INV_2659_6: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomesMutants (Total: 2, Killed: 2, Survived: 0)
2677: } 2678: 2679: # ----------------------------------------------------------------------- 2680: # Private: output sanitisation 2681: # ----------------------------------------------------------------------- 2682: 2683: # _sanitise_output( $str ) -> $str 2684: # 2685: # Purpose: 2686: # Strip control characters that could affect terminal rendering or HTML 2687: # injection from any string that will appear in a report or abuse email. 2688: # Preserves printable ASCII, high-bytes (for UTF-8 content), tabs, and 2689: # line endings. 2690: # 2691: # Entry criteria: 2692: # $str -- a defined or undef scalar. 2693: # 2694: # Exit status: 2695: # Returns the sanitised string, or the empty string if $str is undef. 2696: # 2697: # Notes: 2698: # Only strips C0 control characters below 0x20 (except \t) and the DEL 2699: # character (0x7F). High bytes (0x80-0xFF) are preserved because they 2700: # form valid UTF-8 multi-byte sequences in headers and body text. 2701: 2702: sub _sanitise_output :Private { 2703: my $str = $_[0]; 2704: return '' unless defined $str;
Mutants (Total: 2, Killed: 2, Survived: 0)
2705: # Remove C0 controls (except tab) and DEL 2706: $str =~ s/[\x00-\x08\x0B\x0C\x0E-\x1F\x7F]//g; 2707: return $str;
Mutants (Total: 2, Killed: 2, Survived: 0)
2708: } 2709: 2710: # ----------------------------------------------------------------------- 2711: # Private: message parsing 2712: # ----------------------------------------------------------------------- 2713: 2714: # _split_message( $text ) 2715: # 2716: # Purpose: 2717: # Split a raw RFC 2822 email into headers and body, parse all headers, 2718: # decode the body (including multipart), extract sending-software 2719: # fingerprints, and populate per-hop tracking data. 2720: # 2721: # Entry criteria: 2722: # $text -- defined scalar, already dereferenced by parse_email(). 2723: # $self->{_sending_sw} and $self->{_rcvd_tracking} reset to [] by caller. 2724: # 2725: # Exit status: 2726: # Returns undef silently if the header block is empty/whitespace-only. 2727: # Otherwise all results are communicated via side effects on $self. 2728: # 2729: # Side effects: 2730: # Populates _headers, _received, _body_plain, _body_html, _sending_sw, 2731: # and _rcvd_tracking. 2732: # 2733: # Notes: 2734: # Delegates to _decode_multipart() for multipart/* content types. 2735: # Lines not matching the header pattern are silently discarded. 2736: # Boundary extraction uses a simple regex; missing boundary causes the 2737: # body to be skipped silently. 2738: 2739: sub _split_message :Private { ●2740 → 2753 → 2758 2740: my ($self, $text) = @_; 2741: 2742: # Split at the first blank line (RFC 2822 header/body separator) 2743: my ($header_block, $body_raw) = split /\r?\n\r?\n/, $text, 2; 2744: 2745: return unless defined $header_block && $header_block =~ /\S/; 2746: $body_raw //= ''; 2747: 2748: # Unfold RFC 2822 continuation lines (s2.2.3) 2749: $header_block =~ s/\r?\n([ \t]+)/ $1/g; 2750: 2751: # Parse each header line into a { name, value } pair 2752: my @headers; 2753: for my $line (split /\r?\n/, $header_block) { 2754: if ($line =~ /^([\w-]+)\s*:\s*(.*)/) {
Mutants (Total: 1, Killed: 1, Survived: 0)
2755: push @headers, { name => lc($1), value => $2 }; 2756: } 2757: } ●2758 → 2773 → 2783 2758: $self->{_headers} = \@headers; 2759: 2760: # Collect all Received: header values (most-recent first, as in message) 2761: $self->{_received} = [ 2762: map { $_->{value} } 2763: grep { $_->{name} eq 'received' } @headers 2764: ]; 2765: 2766: # Determine content type and transfer encoding from top-level headers 2767: my ($ct_h) = grep { $_->{name} eq 'content-type' } @headers; 2768: my ($cte_h) = grep { $_->{name} eq 'content-transfer-encoding' } @headers; 2769: my $ct = defined $ct_h ? $ct_h->{value} : ''; 2770: my $cte = defined $cte_h ? $cte_h->{value} : ''; 2771: 2772: # Decode multipart or single-part body as appropriate 2773: if ($ct =~ /multipart/i) {
Mutants (Total: 1, Killed: 1, Survived: 0)
2774: my ($boundary) = $ct =~ /boundary="?([^";]+)"?/i; 2775: # Pass depth=0 to enforce the MAX_MULTIPART_DEPTH recursion guard 2776: $self->_decode_multipart($body_raw, $boundary, 0) if $boundary; 2777: } else { 2778: my $decoded = $self->_decode_body($body_raw, $cte); 2779: if ($ct =~ /html/i) { $self->{_body_html} = $decoded }
Mutants (Total: 1, Killed: 1, Survived: 0)
2780: else { $self->{_body_plain} = $decoded } 2781: } 2782: ●2783 → 2797 → 2809 2783: $self->_debug(sprintf 'Parsed %d headers, %d Received lines', 2784: scalar @headers, scalar @{ $self->{_received} }); 2785: 2786: # --- Sending software fingerprints --- 2787: # These headers identify the mailer or shared-hosting script that sent 2788: # the message; invaluable for shared-hosting abuse reports. 2789: my %sw_notes = ( 2790: 'x-php-originating-script' => 'PHP script on shared hosting -- report to hosting abuse team', 2791: 'x-source' => 'Source file on shared hosting -- report to hosting abuse team', 2792: 'x-source-host' => 'Sending hostname injected by shared hosting provider', 2793: 'x-source-args' => 'Command-line args injected by shared hosting provider', 2794: 'x-mailer' => 'Email client or bulk-mailer identifier', 2795: 'user-agent' => 'Email client identifier', 2796: ); 2797: for my $sw_hdr (sort keys %sw_notes) { 2798: my ($h) = grep { $_->{name} eq $sw_hdr } @headers; 2799: next unless $h; 2800: push @{ $self->{_sending_sw} }, { 2801: header => $sw_hdr, 2802: value => $h->{value}, 2803: note => $sw_notes{$sw_hdr}, 2804: }; 2805: } 2806: 2807: # --- Per-hop tracking IDs from Received: chain --- 2808: # Walk oldest-first (reverse) so _rcvd_tracking is oldest-first ●2809 → 2809 → 0 2809: for my $rcvd (reverse @{ $self->{_received} }) { 2810: my $ip = $self->_extract_ip_from_received($rcvd); 2811: my ($for_addr) = $rcvd =~ /\bfor\s+<?([^\s>]+\@[\w.-]+\.[\w]+)>?/i; 2812: my ($srv_id) = $rcvd =~ /\bid\s+([\w.-]+)/i; 2813: # Skip hops with no actionable tracking data 2814: next unless defined $ip || defined $for_addr || defined $srv_id; 2815: push @{ $self->{_rcvd_tracking} }, { 2816: received => $rcvd, 2817: ip => $ip, 2818: for => $for_addr, 2819: id => $srv_id, 2820: }; 2821: } 2822: } 2823: 2824: # _decode_multipart( $body, $boundary, $depth ) 2825: # 2826: # Purpose: 2827: # Recursively split a MIME multipart body on its boundary and decode each 2828: # text/plain and text/html part. Nested multipart/* containers are 2829: # recursed into up to MAX_MULTIPART_DEPTH levels deep. 2830: # 2831: # Entry criteria: 2832: # $body -- the raw body text of the multipart container. 2833: # $boundary -- the boundary string from the Content-Type header. 2834: # $depth -- current recursion depth (starts at 0 from _split_message). 2835: # 2836: # Exit status: 2837: # Returns undef if $depth >= MAX_MULTIPART_DEPTH (recursion guard). 2838: # Otherwise all results via side effects. 2839: # 2840: # Side effects: 2841: # Appends decoded text to $self->{_body_plain} and $self->{_body_html}. 2842: # 2843: # Notes: 2844: # Whitespace-only MIME segments between boundaries are silently skipped. 2845: # Decoding errors are silenced; raw bytes are used as fallback. 2846: 2847: sub _decode_multipart :Private { ●2848 → 2853 → 2860 2848: my ($self, $body, $boundary, $depth) = @_; 2849: $depth //= 0; 2850: 2851: # Enforce the recursion depth limit to prevent stack exhaustion on 2852: # pathological crafted messages with deeply nested multipart structures. 2853: if ($depth >= $MAX_MULTIPART_DEPTH) {
Mutants (Total: 4, Killed: 4, Survived: 0)
2854: Carp::carp 'Email::Abuse::Investigator: multipart nesting depth limit', 2855: "($MAX_MULTIPART_DEPTH) exceeded; stopping recursion"; 2856: return; 2857: } 2858: 2859: # Split on the boundary marker; the (?:--)? suffix handles closing boundary ●2860 → 2862 → 0 2860: my @parts = split /--\Q$boundary\E(?:--)?/, $body; 2861: 2862: for my $part (@parts) { 2863: # Skip whitespace-only segments between boundaries 2864: next unless $part =~ /\S/; 2865: 2866: $part =~ s/^\r?\n//; 2867: 2868: # Each MIME part has its own headers separated from body by a blank line 2869: my ($phdr_block, $pbody) = split /\r?\n\r?\n/, $part, 2; 2870: next unless defined $pbody; 2871: 2872: # Unfold continuation header lines within this part 2873: $phdr_block =~ s/\r?\n([ \t]+)/ $1/g; 2874: 2875: # Parse this part's headers into a simple hash 2876: my %phdr; 2877: for my $line (split /\r?\n/, $phdr_block) { 2878: $phdr{ lc($1) } = $2 if $line =~ /^([\w-]+)\s*:\s*(.*)/; 2879: } 2880: 2881: my $pct = $phdr{'content-type'} // ''; 2882: my $pcte = $phdr{'content-transfer-encoding'} // ''; 2883: 2884: # Nested multipart/* must be recursed into; without this URLs in 2885: # multipart/alternative inside multipart/mixed would be missed. 2886: if ($pct =~ /multipart/i) {
Mutants (Total: 1, Killed: 1, Survived: 0)
2887: my ($inner_boundary) = $pct =~ /boundary\s*=\s*"?([^";]+)"?/i; 2888: if ($inner_boundary) {
Mutants (Total: 1, Killed: 1, Survived: 0)
2889: $inner_boundary =~ s/\s+$//; 2890: # Increment depth counter for the recursion guard 2891: $self->_decode_multipart($pbody, $inner_boundary, $depth + 1); 2892: } 2893: next; 2894: } 2895: 2896: # Decode transfer encoding and accumulate by content type 2897: my $decoded = $self->_decode_body($pbody, $pcte); 2898: if ($pct =~ /text\/html/i) { $self->{_body_html} .= $decoded }
Mutants (Total: 1, Killed: 1, Survived: 0)
2899: elsif ($pct =~ /text/i || !$pct) { $self->{_body_plain} .= $decoded } 2900: } 2901: } 2902: 2903: # _decode_body( $body, $cte ) -> string 2904: # 2905: # Purpose: 2906: # Decode a MIME body part according to its Content-Transfer-Encoding. 2907: # 2908: # Entry criteria: 2909: # $body -- raw body string (may be undef). 2910: # $cte -- Content-Transfer-Encoding value string (may be undef). 2911: # 2912: # Exit status: 2913: # Returns the decoded string, or the original string if the encoding is 2914: # 7bit/8bit/binary or unrecognised. 2915: # 2916: # Notes: 2917: # decode_qp and decode_base64 are imported from MIME:: modules; errors 2918: # from malformed content are silenced by the eval wrappers they provide. 2919: 2920: sub _decode_body :Private { 2921: my ($self, $body, $cte) = @_; 2922: $cte //= ''; 2923: return decode_qp($body) if $cte =~ /quoted-printable/i;
Mutants (Total: 2, Killed: 2, Survived: 0)
2924: return decode_base64($body) if $cte =~ /base64/i;
Mutants (Total: 2, Killed: 2, Survived: 0)
2925: return $body // '';
Mutants (Total: 2, Killed: 2, Survived: 0)
2926: } 2927: 2928: # ----------------------------------------------------------------------- 2929: # Private: Received-chain -> originating IP 2930: # ----------------------------------------------------------------------- 2931: 2932: # _find_origin() 2933: # 2934: # Purpose: 2935: # Walk the Received: chain (oldest-first) to find the first external IP, 2936: # or fall back to X-Originating-IP. Enrich with rDNS and WHOIS. 2937: # 2938: # Entry criteria: 2939: # $self->{_received} populated by _split_message(). 2940: # $self->{trusted_relays} set by new(). 2941: # 2942: # Exit status: 2943: # Returns { ip, rdns, org, abuse, country, confidence, note } on success. 2944: # Returns undef if no usable IP can be identified. 2945: # 2946: # Side effects: 2947: # Network I/O via _enrich_ip(): one PTR lookup, one RDAP/WHOIS query. 2948: # Results are also stored in the CHI cross-message cache if available. 2949: # 2950: # Notes: 2951: # confidence 'high' = 2+ distinct external IPs; 2952: # 'medium' = exactly one external IP; 2953: # 'low' = taken from X-Originating-IP. 2954: 2955: sub _find_origin :Private { ●2956 → 2961 → 2969 2956: my $self = $_[0]; 2957: 2958: my @candidates; 2959: 2960: # Walk oldest-first (reverse) to collect external IPs 2961: for my $hdr (reverse @{ $self->{_received} }) { 2962: my $ip = $self->_extract_ip_from_received($hdr) // next; 2963: next if $self->_is_private($ip); 2964: next if $self->_is_trusted($ip); 2965: push @candidates, $ip; 2966: } 2967: 2968: # Fall back to X-Originating-IP if no external IPs in Received: chain ●2969 → 2969 → 2981 2969: unless (@candidates) {
Mutants (Total: 1, Killed: 1, Survived: 0)
2970: my $xoip = $self->_header_value('x-originating-ip'); 2971: if ($xoip) {
Mutants (Total: 1, Killed: 1, Survived: 0)
2972: $xoip =~ s/[\[\]\s]//g; 2973: return $self->_enrich_ip($xoip, 'low',
Mutants (Total: 2, Killed: 2, Survived: 0)
2974: 'Taken from X-Originating-IP (webmail, unverified)') 2975: unless $self->_is_private($xoip); 2976: } 2977: return; 2978: } 2979: 2980: # Report the oldest (first) external IP; confidence depends on count 2981: return $self->_enrich_ip(
Mutants (Total: 2, Killed: 2, Survived: 0)
2982: $candidates[0], 2983: @candidates > 1 ? 'high' : 'medium',
Mutants (Total: 3, Killed: 3, Survived: 0)
2984: 'First external hop in Received: chain', 2985: ); 2986: } 2987: 2988: # _extract_ip_from_received( $hdr ) -> ipv4_or_ipv6_string | undef 2989: # 2990: # Purpose: 2991: # Extract the most-significant IP address from a raw Received: header 2992: # value, trying patterns in priority order. Supports both IPv4 dotted- 2993: # quad and IPv6 bracket notation. 2994: # 2995: # Entry criteria: 2996: # $hdr -- a defined Received: header value string. 2997: # 2998: # Exit status: 2999: # Returns the IP string on success, undef if no IP can be extracted. 3000: # 3001: # Notes: 3002: # IPv4 addresses are validated (all octets <= 255). 3003: # IPv6 addresses are returned as-is if they contain colons. 3004: 3005: sub _extract_ip_from_received :Private { ●3006 → 3007 → 3020 3006: my ($self, $hdr) = @_; 3007: for my $re (@RECEIVED_IP_RE) { 3008: if ($hdr =~ $re) {
Mutants (Total: 1, Killed: 1, Survived: 0)
3009: my $ip = $1; 3010: 3011: # Accept IPv6 addresses (contain colons) without further validation 3012: return $ip if $ip =~ /:/;
3013: 3014: # Validate IPv4 format and octet range 3015: next unless $ip =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/; 3016: next if grep { $_ > 255 } split /\./, $ip;Mutants (Total: 2, Killed: 0, Survived: 2)
- BOOL_NEGATE_3012_4: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes🧪 Suggested Test# Boolean branch test suggestion ok( !func(INPUT), 'Verify boolean branch behaviour' );- RETURN_UNDEF_3012_4: Replace return expression with undef
LOW: Mutation survived, but impact may be minor🧪 Suggested Test# Return value assertion is( func(INPUT), EXPECTED, 'Verify correct return value' );Mutants (Total: 3, Killed: 3, Survived: 0)
3017: return $ip;
Mutants (Total: 2, Killed: 2, Survived: 0)
3018: } 3019: } 3020: return; 3021: } 3022: 3023: # _is_private( $ip ) -> bool 3024: # 3025: # Purpose: 3026: # Test whether an IP address falls in any private, reserved, or special- 3027: # use range (IPv4 or IPv6) that should never be reported as a spam origin. 3028: # 3029: # Entry criteria: 3030: # $ip -- a scalar IP string (IPv4 or IPv6); may be undef. 3031: # 3032: # Exit status: 3033: # Returns 1 (true) if the IP is private/reserved, 0 (false) otherwise. 3034: # Returns 1 for undef or empty strings. 3035: # 3036: # Notes: 3037: # Uses the module-level @PRIVATE_RANGES array of pre-compiled regexes. 3038: # Covers all ranges listed in RFC 1122, 1918, 5737, 6598, and RFC 4193. 3039: 3040: sub _is_private :Private { ●3041 → 3043 → 3044 3041: my ($self, $ip) = @_; 3042: return 1 if !defined($ip) || $ip eq '';
Mutants (Total: 2, Killed: 2, Survived: 0)
3043: for my $re (@PRIVATE_RANGES) { return 1 if $ip =~ $re }
Mutants (Total: 2, Killed: 2, Survived: 0)
3044: return 0;
Mutants (Total: 2, Killed: 2, Survived: 0)
3045: } 3046: 3047: # _is_trusted( $ip ) -> bool 3048: # 3049: # Purpose: 3050: # Test whether an IP address matches any entry in the caller-supplied 3051: # trusted_relays list (exact IP or CIDR block). 3052: # 3053: # Entry criteria: 3054: # $ip -- a defined IPv4 address string. 3055: # $self->{trusted_relays} -- arrayref of exact IPs or CIDR strings. 3056: # 3057: # Exit status: 3058: # Returns 1 (true) if the IP matches any trusted relay, 0 otherwise. 3059: 3060: sub _is_trusted :Private { ●3061 → 3062 → 3065 3061: my ($self, $ip) = @_; 3062: for my $cidr (@{ $self->{trusted_relays} }) { 3063: return 1 if $self->_ip_in_cidr($ip, $cidr);
Mutants (Total: 2, Killed: 2, Survived: 0)
3064: } 3065: return 0;
Mutants (Total: 2, Killed: 2, Survived: 0)
3066: } 3067: 3068: # ----------------------------------------------------------------------- 3069: # Private: HTTP/HTTPS URL extraction and resolution 3070: # ----------------------------------------------------------------------- 3071: 3072: # _extract_and_resolve_urls() -> arrayref of url hashrefs 3073: # 3074: # Purpose: 3075: # Extract all HTTP/HTTPS URLs from the decoded body, resolve each unique 3076: # hostname to an IP, and enrich with WHOIS/RDAP data. Optionally uses 3077: # AnyEvent::DNS to parallelise the DNS resolution step. 3078: # 3079: # Entry criteria: 3080: # $self->{_body_plain} and $self->{_body_html} populated by _split_message(). 3081: # 3082: # Exit status: 3083: # Returns an arrayref of url hashrefs (possibly empty). 3084: # 3085: # Side effects: 3086: # Network I/O per unique hostname: one A/AAAA lookup, one RDAP/WHOIS. 3087: # Results stored in the CHI cross-message cache if available. 3088: 3089: sub _extract_and_resolve_urls :Private { ●3090 → 3104 → 3118 3090: my $self = $_[0]; 3091: my (%url_seen, %host_cache); 3092: my @results; 3093: my $combined = $self->{_body_plain} . "\n" . $self->{_body_html}; 3094: 3095: # Collect unique URLs from body 3096: my @urls = grep { !$url_seen{$_}++ } $self->_extract_http_urls($combined); 3097: 3098: # For URL-shortener and redirect-cloaker hosts, follow the redirect chain to 3099: # discover the real destination (e.g. GCS bucket → phishing landing page). 3100: # Done before DNS resolution so that destination hostnames can be parallelised. 3101: # _follow_redirect_chain() is a :Protected seam that handles LWP availability 3102: # internally — do not guard this block with $HAS_LWP so the seam can be 3103: # stubbed unconditionally in tests regardless of whether LWP is installed. 3104: for my $url (@urls) { 3105: my ($host) = $url =~ m{https?://([^/:?\s#]+)}i; 3106: next unless $host; 3107: my $bare = lc $host; 3108: $bare =~ s/^www\.//; 3109: next unless $URL_SHORTENERS{$bare} 3110: || ($self->{url_shorteners} && $self->{url_shorteners}{$bare}) 3111: || $self->_is_redirect_cloaker($bare); 3112: my $dest = $self->_follow_redirect_chain($url); 3113: next unless defined $dest && !$url_seen{$dest}++; 3114: push @urls, $dest; 3115: } 3116: 3117: # Extract unique hostnames for parallel DNS resolution (including redirect destinations) ●3118 → 3119 → 3125 3118: my %hostname_needed; 3119: for my $url (@urls) { 3120: my ($host) = $url =~ m{https?://([^/:?\s#]+)}i; 3121: $hostname_needed{$host}++ if $host; 3122: } 3123: 3124: # Parallelise DNS lookups if AnyEvent::DNS is available ●3125 → 3125 → 3130 3125: if ($HAS_ANYEVENT_DNS && scalar(keys %hostname_needed) > 1) {
3126: $self->_parallel_resolve_hosts(\%hostname_needed, \%host_cache); 3127: } 3128: 3129: # Process each URL: resolve hostname and WHOIS-enrich ●3130 → 3130 → 3168 3130: for my $url (@urls) { 3131: my ($host) = $url =~ m{https?://([^/:?\s#]+)}i; 3132: next unless $host; 3133: 3134: # Resolve and WHOIS once per unique hostname, then cache the result 3135: unless (exists $host_cache{$host}) {Mutants (Total: 4, Killed: 0, Survived: 4)
- NUM_BOUNDARY_3125_57_<: Numeric boundary flip > to <
HIGH: Likely missing edge-case test (boundary value)🧪 Suggested Test# Boundary test suggestion is( func(VALUE_AT_BOUNDARY), EXPECTED, 'Test boundary behaviour' );- NUM_BOUNDARY_3125_57_>=: Numeric boundary flip > to >=
HIGH: Likely missing edge-case test (boundary value)🧪 Suggested Test# Boundary test suggestion is( func(VALUE_AT_BOUNDARY), EXPECTED, 'Test boundary behaviour' );- NUM_BOUNDARY_3125_57_<=: Numeric boundary flip > to <=
HIGH: Likely missing edge-case test (boundary value)🧪 Suggested Test# Boundary test suggestion is( func(VALUE_AT_BOUNDARY), EXPECTED, 'Test boundary behaviour' );- COND_INV_3125_2: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomesMutants (Total: 1, Killed: 1, Survived: 0)
3136: # Check the cross-message CHI cache first 3137: my $cached = $_cache ? $_cache->get("url:$host") : undef; 3138: if ($cached) {
Mutants (Total: 1, Killed: 1, Survived: 0)
3139: $host_cache{$host} = $cached; 3140: } else { 3141: my $ip = $self->_resolve_host($host) // '(unresolved)'; 3142: my $whois = $ip ne '(unresolved)' 3143: ? $self->_whois_ip($ip) 3144: : {}; 3145: 3146: # Fall back to domain WHOIS if IP lookup returned nothing 3147: if (!$whois->{abuse}) {
Mutants (Total: 1, Killed: 1, Survived: 0)
3148: my $reg = _registrable($host) // $host; 3149: my $dw = $self->_parse_domain_whois_abuse($reg); 3150: $whois = $dw if $dw->{abuse}; 3151: } 3152: 3153: my $entry = { 3154: ip => $ip, 3155: org => $whois->{org} // '(unknown)', 3156: abuse => $whois->{abuse} // '(unknown)', 3157: country => $whois->{country} // undef, 3158: }; 3159: $host_cache{$host} = $entry; 3160: 3161: # Store in cross-message cache for reuse across messages 3162: $_cache->set("url:$host", $entry) if $_cache; 3163: } 3164: } 3165: 3166: push @results, { url => $url, host => $host, %{ $host_cache{$host} } }; 3167: } 3168: return \@results;
Mutants (Total: 2, Killed: 2, Survived: 0)
3169: } 3170: 3171: # _is_redirect_cloaker( $bare_host ) -> bool 3172: # 3173: # Purpose: 3174: # Return true if $bare_host is a known cloud-storage or CDN host that is 3175: # commonly abused to serve client-side redirect pages hiding the real 3176: # phishing destination. Checks the exact-match %REDIRECT_HOSTS table and 3177: # the suffix patterns in @REDIRECT_HOST_SUFFIXES. 3178: # 3179: # Entry criteria: 3180: # $bare_host -- lowercase hostname with any leading "www." already stripped. 3181: # 3182: # Exit status: 3183: # Returns 1 (true) or empty string (false). 3184: 3185: sub _is_redirect_cloaker :Private { ●3186 → 3188 → 3192 3186: my (undef, $host) = @_; 3187: return 1 if $REDIRECT_HOSTS{$host};
Mutants (Total: 2, Killed: 2, Survived: 0)
3188: for my $suffix (@REDIRECT_HOST_SUFFIXES) { 3189: return 1 if length($host) > length($suffix)
3190: && substr($host, -length($suffix)) eq $suffix; 3191: } 3192: return '';Mutants (Total: 5, Killed: 0, Survived: 5)
- NUM_BOUNDARY_3189_29_<: Numeric boundary flip > to <
HIGH: Likely missing edge-case test (boundary value)🧪 Suggested Test# Boundary test suggestion is( func(VALUE_AT_BOUNDARY), EXPECTED, 'Test boundary behaviour' );- NUM_BOUNDARY_3189_29_>=: Numeric boundary flip > to >=
HIGH: Likely missing edge-case test (boundary value)🧪 Suggested Test# Boundary test suggestion is( func(VALUE_AT_BOUNDARY), EXPECTED, 'Test boundary behaviour' );- NUM_BOUNDARY_3189_29_<=: Numeric boundary flip > to <=
HIGH: Likely missing edge-case test (boundary value)🧪 Suggested Test# Boundary test suggestion is( func(VALUE_AT_BOUNDARY), EXPECTED, 'Test boundary behaviour' );- BOOL_NEGATE_3189_3: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes🧪 Suggested Test# Boolean branch test suggestion ok( !func(INPUT), 'Verify boolean branch behaviour' );- RETURN_UNDEF_3189_3: Replace return expression with undef
LOW: Mutation survived, but impact may be minor🧪 Suggested Test# Return value assertion is( func(INPUT), EXPECTED, 'Verify correct return value' );Mutants (Total: 2, Killed: 2, Survived: 0)
3193: } 3194: 3195: # _follow_redirect_chain( $url ) -> $final_url | undef 3196: # 3197: # Purpose: 3198: # Follow up to $REDIRECT_MAX_HOPS HTTP hops for a given URL and return the 3199: # final destination. Detects HTTP 3xx Location: redirects, HTML 3200: # <meta http-equiv="refresh" content="...url=..."> tags, and 3201: # window.location.replace() / window.location.href JavaScript patterns. 3202: # Used to expose the real phishing landing page hidden behind a cloud 3203: # object-store redirect page (e.g. a GCS bucket containing only a 3204: # meta-refresh pointing to the attacker-controlled domain). 3205: # 3206: # Entry criteria: 3207: # $url -- an https?:// URL string whose host has already been identified 3208: # as a URL shortener or redirect cloaker. 3209: # LWP::UserAgent must be installed ($HAS_LWP must be true). 3210: # 3211: # Exit status: 3212: # Returns the first URL that differs from the input after following the 3213: # chain, or undef if no redirect was found or LWP is unavailable. 3214: # Never returns the input $url unchanged. 3215: # 3216: # Side effects: 3217: # Up to $REDIRECT_MAX_HOPS HTTP GET requests. 3218: # Successful result cached in the cross-message CHI cache keyed 3219: # "redirect:<url>" to avoid re-fetching across messages. 3220: 3221: sub _follow_redirect_chain :Protected { ●3222 → 3226 → 3233 3222: my ($self, $url) = @_; 3223: return undef unless $HAS_LWP;
3224: 3225: # Serve from cache when available 3226: if ($_cache) {Mutants (Total: 2, Killed: 0, Survived: 2)
- BOOL_NEGATE_3223_2: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes🧪 Suggested Test# Boolean branch test suggestion ok( !func(INPUT), 'Verify boolean branch behaviour' );- RETURN_UNDEF_3223_2: Replace return expression with undef
LOW: Mutation survived, but impact may be minor🧪 Suggested Test# Return value assertion is( func(INPUT), EXPECTED, 'Verify correct return value' );3227: my $cached = $_cache->get("redirect:$url"); 3228: return $cached if defined $cached;Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_3226_2: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes3229: } 3230: 3231: # Dedicated no-follow UA so we can inspect each redirect hop manually. 3232: # Stored separately from the RDAP UA ($self->{ua}) which needs auto-follow. ●[NOT COVERED] 3233 → 3233 → 3247 3233: unless (defined $self->{_ua_nofollow}) {Mutants (Total: 2, Killed: 0, Survived: 2)
- BOOL_NEGATE_3228_3: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes🧪 Suggested Test# Boolean branch test suggestion ok( !func(INPUT), 'Verify boolean branch behaviour' );- RETURN_UNDEF_3228_3: Replace return expression with undef
LOW: Mutation survived, but impact may be minor🧪 Suggested Test# Return value assertion is( func(INPUT), EXPECTED, 'Verify correct return value' );3234: my $ua = LWP::UserAgent->new( 3235: timeout => $self->{timeout}, 3236: agent => "Email-Abuse-Investigator/$VERSION", 3237: max_redirect => 0, 3238: ); 3239: if ($HAS_CONN_CACHE) {Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_3233_2: Invert condition unless to if
MEDIUM: Add tests asserting both true and false outcomes3240: my $cc = LWP::ConnCache->new(); 3241: $cc->total_capacity(4); 3242: $ua->conn_cache($cc); 3243: } 3244: $ua->env_proxy(1); 3245: $self->{_ua_nofollow} = $ua; 3246: } ●[NOT COVERED] 3247 → 3251 → 3292 3247: my $ua = $self->{_ua_nofollow}; 3248: 3249: my $current = $url; 3250: my $final; 3251: for my $hop (1 .. $REDIRECT_MAX_HOPS) { 3252: my $res = eval { $ua->get($current) }; 3253: last unless $res; 3254: 3255: if ($res->is_redirect()) {Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_3239_3: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes3256: # HTTP 3xx: extract Location header 3257: my $loc = $res->header('Location'); 3258: last unless defined $loc; 3259: 3260: # Resolve relative Location URLs against the current base 3261: if ($loc !~ m{^https?://}i) {Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_3255_3: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes3262: require URI; 3263: $loc = URI->new_abs($loc, $current)->as_string(); 3264: } 3265: $final = $loc; 3266: $current = $loc; 3267: } elsif ($res->is_success()) { 3268: # 2xx: inspect body for client-side redirect patterns 3269: my $body = $res->decoded_content() // ''; 3270: my $dest; 3271: 3272: # <meta http-equiv="refresh" content="N; url=https://..."> 3273: if ($body =~ m{<meta[^>]+http-equiv\s*=\s*["']?refresh["']?[^>]+Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_3261_4: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes3274: content\s*=\s*["'][^"']*url\s*=\s*(https?://[^"'\s>]+)}xi) { 3275: $dest = $1; 3276: } 3277: # window.location.replace("...") or window.location.href = "..." 3278: elsif ($body =~ m{window\.location(?:\.replace\s*\(\s*|\.href\s*=\s*) 3279: ["'](https?://[^"']+)["']}xi) { 3280: $dest = $1; 3281: } 3282: 3283: last unless defined $dest; 3284: $final = $dest; 3285: $current = $dest; 3286: } else { 3287: last; 3288: } 3289: } 3290: 3291: # Cache for reuse across messages in this session 3292: $_cache->set("redirect:$url", $final) if $_cache && defined $final; 3293: 3294: return $final;Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_3273_4: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes3295: } 3296: 3297: # _parallel_resolve_hosts( \%hostnames, \%cache ) 3298: # 3299: # Purpose: 3300: # Resolve multiple hostnames to IPs in parallel using AnyEvent::DNS. 3301: # Populates the cache with resolved IPs so the sequential loop in 3302: # _extract_and_resolve_urls() can skip the DNS step for pre-resolved hosts. 3303: # 3304: # Entry criteria: 3305: # $hostnames_ref -- hashref keyed by hostname (values ignored). 3306: # $cache_ref -- hashref to populate with { ip => '...' } results. 3307: # AnyEvent::DNS must be installed ($HAS_ANYEVENT_DNS is true). 3308: # 3309: # Exit status: 3310: # Returns undef; all results written to %$cache_ref via side effects. 3311: # 3312: # Notes: 3313: # Errors (NXDOMAIN, timeout) are silently swallowed; the sequential 3314: # resolution loop will return '(unresolved)' for those hosts. 3315: 3316: sub _parallel_resolve_hosts :Private { ●3317 → 3331 → 3348 3317: my ($self, $hostnames_ref, $cache_ref) = @_; 3318: # Guard both conditions together: an empty hash must never reach condvar 3319: # creation because $cv->recv would block forever with $pending == 0. 3320: return unless $HAS_ANYEVENT_DNS && %$hostnames_ref; 3321: 3322: # Build an AnyEvent condvar to wait for all lookups to complete 3323: my $cv = AnyEvent->condvar; 3324: my $pending = scalar keys %$hostnames_ref; 3325: 3326: # AnyEvent::DNS::resolve is a method, not a standalone function. 3327: # Use the global resolver singleton; passing a bare string as the 3328: # first arg would make Perl treat the hostname as the invocant. 3329: my $resolver = AnyEvent::DNS::resolver(); 3330: 3331: for my $host (keys %$hostnames_ref) { 3332: # Fire an async A query for each hostname 3333: $resolver->resolve( 3334: $host, 'a', 3335: sub { 3336: my @answers = @_; 3337: if (@answers) {Mutants (Total: 2, Killed: 0, Survived: 2)
- BOOL_NEGATE_3294_2: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes🧪 Suggested Test# Boolean branch test suggestion ok( !func(INPUT), 'Verify boolean branch behaviour' );- RETURN_UNDEF_3294_2: Replace return expression with undef
LOW: Mutation survived, but impact may be minor🧪 Suggested Test# Return value assertion is( func(INPUT), EXPECTED, 'Verify correct return value' );3338: # Cache the first A record result 3339: $cache_ref->{$host} = { ip => $answers[0][4] }; 3340: } 3341: # Decrement the pending counter; signal when all done 3342: $cv->send if --$pending <= 0;Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_3337_5: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes3343: }, 3344: ); 3345: } 3346: 3347: # Block until all DNS queries complete (subject to AnyEvent's own timeouts) 3348: $cv->recv; 3349: } 3350: 3351: # _extract_http_urls( $body ) -> list of url strings 3352: # 3353: # Purpose: 3354: # Extract all HTTP and HTTPS URLs from a body string, using both 3355: # structural HTML parsing (if HTML::LinkExtor is available) and a 3356: # plain-text regex pass. Deduplicates and strips trailing punctuation. 3357: # 3358: # Entry criteria: 3359: # $body -- combined plain+HTML body string. 3360: # 3361: # Exit status: 3362: # Returns a list of URL strings (possibly empty), deduplicated. 3363: 3364: sub _extract_http_urls :Private { ●3365 → 3369 → 3386 3365: my ($self, $body) = @_; 3366: my @urls; 3367: 3368: # Structural HTML link extraction (handles quoted attributes correctly) 3369: if ($HAS_HTML_LINKEXTOR) {Mutants (Total: 3, Killed: 0, Survived: 3)
- NUM_BOUNDARY_3342_29_<: Numeric boundary flip <= to <
HIGH: Likely missing edge-case test (boundary value)🧪 Suggested Test# Boundary test suggestion is( func(VALUE_AT_BOUNDARY), EXPECTED, 'Test boundary behaviour' );- NUM_BOUNDARY_3342_29_>: Numeric boundary flip <= to >
HIGH: Likely missing edge-case test (boundary value)🧪 Suggested Test# Boundary test suggestion is( func(VALUE_AT_BOUNDARY), EXPECTED, 'Test boundary behaviour' );- NUM_BOUNDARY_3342_29_>=: Numeric boundary flip <= to >=
HIGH: Likely missing edge-case test (boundary value)🧪 Suggested Test# Boundary test suggestion is( func(VALUE_AT_BOUNDARY), EXPECTED, 'Test boundary behaviour' );Mutants (Total: 1, Killed: 1, Survived: 0)
3370: my $p = HTML::LinkExtor->new(sub { 3371: my ($tag, %attrs) = @_; 3372: for my $attr (qw(href src action)) { 3373: my $val = $attrs{$attr} // ''; 3374: if ($val =~ m{^https?://}i) {
Mutants (Total: 1, Killed: 1, Survived: 0)
3375: push @urls, $val; 3376: } elsif ($val =~ m{^//[\w.-]}) { 3377: # Protocol-relative -- assume https 3378: push @urls, 'https:' . $val; 3379: } 3380: } 3381: }); 3382: $p->parse($body); 3383: } 3384: 3385: # Plain-text regex pass for bare URLs not in HTML attributes ●3386 → 3386 → 3391 3386: while ($body =~ m{(https?://[^\s<>"'\)\]]+)}gi) { 3387: push @urls, $1; 3388: } 3389: 3390: # Protocol-relative URLs not caught above ●3391 → 3391 → 3396 3391: while ($body =~ m{(?:^|[\s"'=])(//[\w.-][^\s<>"'\)\]]*)}gim) { 3392: push @urls, 'https:' . $1; 3393: } 3394: 3395: # Deduplicate and strip trailing punctuation 3396: my %seen; 3397: my @all = grep { !$seen{$_}++ } @urls; 3398: s/[.,;:!?\)>\]]+$// for @all; 3399: return @all;
Mutants (Total: 2, Killed: 2, Survived: 0)
3400: } 3401: 3402: # ----------------------------------------------------------------------- 3403: # Private: domain extraction and full analysis 3404: # ----------------------------------------------------------------------- 3405: 3406: # _extract_and_analyse_domains() -> arrayref of domain hashrefs 3407: # 3408: # Purpose: 3409: # Collect all non-infrastructure contact domains from headers and body, 3410: # run the full domain intelligence pipeline on each, and return an arrayref 3411: # suitable for storage in $self->{_mailto_domains}. 3412: # 3413: # Entry criteria: 3414: # _split_message() must have been called. 3415: # 3416: # Exit status: 3417: # Always returns an arrayref; never undef. 3418: # 3419: # Side effects: 3420: # Network I/O per domain via _analyse_domain(). 3421: # Results stored in $self->{_domain_info} and CHI cache. 3422: 3423: sub _extract_and_analyse_domains :Private { ●3424 → 3429 → 3439 3424: my $self = $_[0]; 3425: my (%seen, @domains_with_source); 3426: 3427: # Build a set of recipient domains to exclude (victims, not senders) 3428: my %recipient_domains; 3429: for my $hname (qw(to cc)) { 3430: my $val = $self->_header_value($hname) // next; 3431: for my $dom ($self->_domains_from_text($val)) { 3432: my $reg = _registrable($dom) // $dom; 3433: $recipient_domains{$dom}++; 3434: $recipient_domains{$reg}++; 3435: } 3436: } 3437: 3438: # Also exclude domains from Received: "for" envelope recipients ●3439 → 3439 → 3448 3439: for my $hop (@{ $self->{_rcvd_tracking} }) { 3440: next unless $hop->{for} && $hop->{for} =~ /\@([\w.-]+)/; 3441: my $dom = lc $1; 3442: my $reg = _registrable($dom) // $dom; 3443: $recipient_domains{$dom}++; 3444: $recipient_domains{$reg}++; 3445: } 3446: 3447: # Inner closure: record a domain if it passes all filters ●3448 → 3470 → 3477 3448: my $record = sub { 3449: my ($dom, $source) = @_; 3450: $dom = lc $dom; 3451: $dom =~ s/\.$//; 3452: next if $self->{trusted_domains}->{$dom}; 3453: return if $TRUSTED_DOMAINS{$dom}; 3454: return if $recipient_domains{$dom}; 3455: return if $recipient_domains{ _registrable($dom) // $dom }; 3456: # Discard non-routable hostnames (single-label, pseudo-TLDs, etc.) 3457: return unless $dom =~ /\.[a-zA-Z]{2,}$/; 3458: return if $dom =~ /\.(?:local|internal|lan|localdomain|arpa)$/i; 3459: return if $seen{$dom}++; 3460: push @domains_with_source, { domain => $dom, source => $source }; 3461: }; 3462: 3463: # Collect from standard sender/reply headers 3464: my %header_sources = ( 3465: 'from' => 'From: header', 3466: 'reply-to' => 'Reply-To: header', 3467: 'return-path' => 'Return-Path: header', 3468: 'sender' => 'Sender: header', 3469: ); 3470: for my $hname (sort keys %header_sources) { 3471: my $val = $self->_header_value($hname) // next; 3472: $record->($_, $header_sources{$hname}) 3473: for $self->_domains_from_text($val); 3474: } 3475: 3476: # Message-ID domain often reveals the real bulk-sending platform ●3477 → 3478 → 3486 3477: my $mid = $self->_header_value('message-id'); 3478: if ($mid && $mid =~ /\@([\w.-]+)/) {
Mutants (Total: 1, Killed: 1, Survived: 0)
3479: my $mid_dom = lc $1; 3480: my $mid_reg = _registrable($mid_dom) // $mid_dom; 3481: $record->($mid_dom, 'Message-ID: header') 3482: unless $TRUSTED_DOMAINS{$mid_dom} || $TRUSTED_DOMAINS{$mid_reg} || $self->{trusted_domains}->{$mid_dom} || $self->{trusted_domains}->{$mid_reg}; 3483: } 3484: 3485: # DKIM signing domain(s) -- the organisation that vouches for the message ●3486 → 3487 → 3492 3486: my $auth = $self->_parse_auth_results_cached(); 3487: for my $dkim_d (@{ $auth->{dkim_domains} // [] }) { 3488: $record->($dkim_d, 'DKIM-Signature: d= (signing domain)'); 3489: } 3490: 3491: # List-Unsubscribe identifies the ESP or bulk sender ●3492 → 3493 → 3503 3492: my $unsub = $self->_header_value('list-unsubscribe'); 3493: if ($unsub) {
3494: while ($unsub =~ m{https?://([^/:?\s>]+)}gi) { 3495: $record->(lc $1, 'List-Unsubscribe: header'); 3496: } 3497: while ($unsub =~ m{mailto:[^@\s>]+\@([\w.-]+)}gi) { 3498: $record->(lc $1, 'List-Unsubscribe: header'); 3499: } 3500: } 3501: 3502: # Body email addresses (mailto: and bare user@domain forms) ●3503 → 3509 → 3513 3503: my $combined = $self->{_body_plain} . "\n" . $self->{_body_html}; 3504: $record->($_, 'email address / mailto in body') 3505: for $self->_domains_from_text($combined); 3506: 3507: # Run the full intelligence pipeline on each collected domain 3508: my @results; 3509: for my $entry (@domains_with_source) { 3510: my $info = $self->_analyse_domain($entry->{domain}); 3511: push @results, { %$entry, %$info }; 3512: } 3513: return \@results;Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_3493_2: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomesMutants (Total: 2, Killed: 2, Survived: 0)
3514: } 3515: 3516: # _domains_from_text( $text ) -> list of domain strings 3517: # 3518: # Purpose: 3519: # Extract unique domain names from mailto: links and bare user@domain 3520: # addresses in a block of text. 3521: # 3522: # Entry criteria: 3523: # $text -- a defined scalar of decoded body or header text. 3524: # 3525: # Exit status: 3526: # Returns a list of lower-cased domain strings (possibly empty). 3527: 3528: sub _domains_from_text :Private { ●3529 → 3533 → 3539 3529: my ($self, $text) = @_; 3530: my (%seen, @out); 3531: 3532: # mailto: links (including HTML-entity-encoded @ signs from QP) 3533: while ($text =~ /mailto:(?:[^@\s<>"]+)@([\w.-]+)/gi) { 3534: my $dom = lc $1; $dom =~ s/\.$//; 3535: push @out, $dom unless $seen{$dom}++; 3536: } 3537: 3538: # Bare user@domain patterns ●3539 → 3539 → 3543 3539: while ($text =~ /\b[\w.+%-]+@([\w.-]+\.[a-zA-Z]{2,})\b/g) { 3540: my $dom = lc $1; $dom =~ s/\.$//; 3541: push @out, $dom unless $seen{$dom}++; 3542: } 3543: return @out;
Mutants (Total: 2, Killed: 2, Survived: 0)
3544: } 3545: 3546: # _analyse_domain( $domain ) -> hashref 3547: # 3548: # Purpose: 3549: # Run the complete intelligence pipeline for a single domain: A record 3550: # (web hosting), MX record (mail hosting), NS record (DNS hosting), 3551: # and WHOIS (registrar, creation/expiry dates, abuse contact). 3552: # Each IP is enriched via RDAP/WHOIS. Results are cached per domain 3553: # in $self->{_domain_info} and in the CHI cross-message cache. 3554: # 3555: # Entry criteria: 3556: # $domain -- lower-cased, no trailing dot, not in TRUSTED_DOMAINS. 3557: # $self->{timeout} used for all network operations. 3558: # 3559: # Exit status: 3560: # Always returns a hashref reference; never undef; may be empty ({}). 3561: # Possible keys: web_ip, web_org, web_abuse, mx_host, mx_ip, mx_org, 3562: # mx_abuse, ns_host, ns_ip, ns_org, ns_abuse, registrar, 3563: # registrar_abuse, registered, expires, recently_registered, whois_raw. 3564: # 3565: # Side effects: 3566: # Network I/O; writes result to $self->{_domain_info}{$domain} and CHI. 3567: # 3568: # Notes: 3569: # MX/NS lookups require Net::DNS; absent without it. 3570: # recently_registered is set to 1 (not 0) when the threshold is met. 3571: # whois_raw is truncated to WHOIS_RAW_MAX bytes. 3572: 3573: sub _analyse_domain :Private { ●3574 → 3581 → 3589 3574: my ($self, $domain) = @_; 3575: 3576: # Return the per-message cached result if already analysed 3577: return $self->{_domain_info}{$domain}
Mutants (Total: 2, Killed: 2, Survived: 0)
3578: if $self->{_domain_info}{$domain}; 3579: 3580: # Check the cross-message CHI cache before hitting the network 3581: if ($_cache) {
Mutants (Total: 1, Killed: 1, Survived: 0)
3582: my $cached = $_cache->get("dom:$domain"); 3583: if ($cached) {
3584: $self->{_domain_info}{$domain} = $cached; 3585: return $cached;Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_3583_3: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes3586: } 3587: } 3588: ●3589 → 3594 → 3602 3589: $self->_debug("Analysing domain: $domain"); 3590: my %info; 3591: 3592: # --- A record -> web hosting IP --- 3593: my $web_ip = $self->_resolve_host($domain); 3594: if ($web_ip) {Mutants (Total: 2, Killed: 0, Survived: 2)
- BOOL_NEGATE_3585_4: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes🧪 Suggested Test# Boolean branch test suggestion ok( !func(INPUT), 'Verify boolean branch behaviour' );- RETURN_UNDEF_3585_4: Replace return expression with undef
LOW: Mutation survived, but impact may be minor🧪 Suggested Test# Return value assertion is( func(INPUT), EXPECTED, 'Verify correct return value' );Mutants (Total: 1, Killed: 1, Survived: 0)
3595: $info{web_ip} = $web_ip; 3596: my $w = $self->_whois_ip($web_ip); 3597: $info{web_org} = $w->{org} if $w->{org}; 3598: $info{web_abuse} = $w->{abuse} if $w->{abuse}; 3599: } 3600: 3601: # MX and NS lookups require Net::DNS ●3602 → 3602 → 3645 3602: if ($HAS_NET_DNS) {
Mutants (Total: 1, Killed: 1, Survived: 0)
3603: my $res = Net::DNS::Resolver->new( 3604: tcp_timeout => $self->{timeout}, 3605: udp_timeout => $self->{timeout}, 3606: ); 3607: 3608: # --- MX record -> mail hosting --- 3609: if(my $mxq = $res->search($domain, 'MX')) {
3610: my ($best) = sort { $a->preference <=> $b->preference } 3611: grep { $_->type eq 'MX' } $mxq->answer; 3612: if ($best) {Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_3609_3: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes3613: (my $mx_host = lc $best->exchange) =~ s/\.$//; 3614: $info{mx_host} = $mx_host; 3615: my $mx_ip = $self->_resolve_host($mx_host); 3616: if ($mx_ip) {Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_3612_4: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes3617: $info{mx_ip} = $mx_ip; 3618: my $mw = $self->_whois_ip($mx_ip); 3619: $info{mx_org} = $mw->{org} if $mw->{org}; 3620: $info{mx_abuse} = $mw->{abuse} if $mw->{abuse}; 3621: } 3622: } 3623: } 3624: 3625: # --- NS record -> DNS hosting --- 3626: if(my $nsq = $res->search($domain, 'NS')) {Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_3616_5: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes3627: # Sort alphabetically so DNS round-robin ordering never changes which 3628: # nameserver we record -- both runs of the same domain always agree. 3629: my ($first) = sort { $a->nsdname cmp $b->nsdname } grep { $_->type eq 'NS' } $nsq->answer; 3630: if ($first) {Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_3626_3: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes3631: (my $ns_host = lc $first->nsdname) =~ s/\.$//; 3632: $info{ns_host} = $ns_host; 3633: my $ns_ip = $self->_resolve_host($ns_host); 3634: if ($ns_ip) {Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_3630_4: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes3635: $info{ns_ip} = $ns_ip; 3636: my $nw = $self->_whois_ip($ns_ip); 3637: $info{ns_org} = $nw->{org} if $nw->{org}; 3638: $info{ns_abuse} = $nw->{abuse} if $nw->{abuse}; 3639: } 3640: } 3641: } 3642: } 3643: 3644: # --- Domain WHOIS -> registrar + dates --- ●3645 → 3645 → 3697 3645: if(my $domain_whois = $self->_domain_whois($domain)) {Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_3634_5: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomesMutants (Total: 1, Killed: 1, Survived: 0)
3646: # Truncate raw WHOIS for storage but parse structured fields from full text 3647: $info{whois_raw} = substr($domain_whois, 0, $WHOIS_RAW_MAX); 3648: 3649: # Registrar name 3650: if ($domain_whois =~ /Registrar:\s*(.+)/i) {
Mutants (Total: 1, Killed: 1, Survived: 0)
3651: ($info{registrar} = $1) =~ s/\s+$//; 3652: } 3653: 3654: # Registrar abuse contact email (try multiple field names) 3655: for my $pat ( 3656: qr/Registrar Abuse Contact Email:\s*(\S+@\S+)/i, 3657: qr/Abuse Contact Email:\s*(\S+@\S+)/i, 3658: qr/abuse-contact:\s*(\S+@\S+)/i, 3659: ) { 3660: if (!$info{registrar_abuse} && $domain_whois =~ $pat) {
Mutants (Total: 1, Killed: 1, Survived: 0)
3661: ($info{registrar_abuse} = $1) =~ s/\s+$//; 3662: } 3663: } 3664: 3665: # Domain creation date (multiple registrar field name variations) 3666: for my $pat ( 3667: qr/Creation Date:\s*(\S+)/i, 3668: qr/Created(?:\s+On)?:\s*(\S+)/i, 3669: qr/Registration Time:\s*(\S+)/i, 3670: qr/^registered:\s*(\S+)/im, 3671: ) { 3672: if (!$info{registered} && $domain_whois =~ $pat) {
Mutants (Total: 1, Killed: 1, Survived: 0)
3673: ($info{registered} = $1) =~ s/[TZ].*//; 3674: } 3675: } 3676: 3677: # Domain expiry date 3678: for my $pat ( 3679: qr/Registry Expiry Date:\s*(\S+)/i, 3680: qr/Expir(?:y|ation)(?: Date)?:\s*(\S+)/i, 3681: qr/paid-till:\s*(\S+)/i, 3682: ) { 3683: if (!$info{expires} && $domain_whois =~ $pat) {
Mutants (Total: 1, Killed: 1, Survived: 0)
3684: ($info{expires} = $1) =~ s/[TZ].*//; 3685: } 3686: } 3687: 3688: # Flag recently-registered domains (< RECENT_REG_DAYS old) 3689: if ($info{registered}) {
Mutants (Total: 1, Killed: 1, Survived: 0)
3690: my $epoch = $self->_parse_date_to_epoch($info{registered}); 3691: $info{recently_registered} = 1 3692: if $epoch && (time() - $epoch) < $RECENT_REG_DAYS * $SECS_PER_DAY;
Mutants (Total: 3, Killed: 3, Survived: 0)
3693: } 3694: } 3695: 3696: # Store in per-message and cross-message caches 3697: $self->{_domain_info}{$domain} = \%info; 3698: $_cache->set("dom:$domain", \%info) if $_cache; 3699: 3700: return \%info;
Mutants (Total: 2, Killed: 2, Survived: 0)
3701: } 3702: 3703: # ----------------------------------------------------------------------- 3704: # Private: DNS helpers 3705: # ----------------------------------------------------------------------- 3706: 3707: # _resolve_host( $host ) -> ip_string | undef 3708: # 3709: # Purpose: 3710: # Resolve a hostname to an IPv4 (or IPv6) address. Uses Net::DNS for 3711: # both A and AAAA queries when available; falls back to inet_aton for 3712: # pure IPv4 resolution. 3713: # 3714: # Entry criteria: 3715: # $host -- hostname string or already-numeric IP. 3716: # 3717: # Exit status: 3718: # Returns the first resolved IP string, or undef on failure. 3719: # 3720: # Notes: 3721: # When the input is already a dotted-quad IPv4 it is returned immediately. 3722: # AAAA records are tried if the A query fails and Net::DNS is available. 3723: 3724: sub _resolve_host :Protected { ●3725 → 3729 → 3734 3725: my ($self, $host) = @_; 3726: return $host if $host =~ /^\d{1,3}(?:\.\d{1,3}){3}$/;
Mutants (Total: 2, Killed: 2, Survived: 0)
3727: 3728: # Check the CHI cache before hitting DNS 3729: if ($_cache) {
Mutants (Total: 1, Killed: 1, Survived: 0)
3730: my $cached_ip = $_cache->get("resolve:$host"); 3731: return $cached_ip if defined $cached_ip;
3732: } 3733: ●3734 → 3736 → 3765 3734: my $ip; 3735: 3736: if ($HAS_NET_DNS) {Mutants (Total: 2, Killed: 0, Survived: 2)
- BOOL_NEGATE_3731_3: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes🧪 Suggested Test# Boolean branch test suggestion ok( !func(INPUT), 'Verify boolean branch behaviour' );- RETURN_UNDEF_3731_3: Replace return expression with undef
LOW: Mutation survived, but impact may be minor🧪 Suggested Test# Return value assertion is( func(INPUT), EXPECTED, 'Verify correct return value' );Mutants (Total: 1, Killed: 1, Survived: 0)
3737: my $res = Net::DNS::Resolver->new( 3738: tcp_timeout => $self->{timeout}, 3739: udp_timeout => $self->{timeout}, 3740: ); 3741: 3742: # Try A record first, then AAAA for IPv6 3743: for my $type (qw(A AAAA)) { 3744: my $query = $res->search($host, $type); 3745: if ($query) {
3746: for my $rr ($query->answer) { 3747: if ($rr->type eq 'A') {Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_3745_4: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes3748: $ip = $rr->address; 3749: last; 3750: } elsif ($rr->type eq 'AAAA') { 3751: $ip = $rr->address; 3752: last; 3753: } 3754: } 3755: } 3756: last if defined $ip; 3757: } 3758: } else { 3759: # Fallback: gethostbyname (IPv4 only) 3760: my $packed = eval { inet_aton($host) }; 3761: $ip = $packed ? inet_ntoa($packed) : undef; 3762: } 3763: 3764: # Cache the result (including undef as '' to avoid repeated failed lookups) ●3765 → 3765 → 3769 3765: if ($_cache) {Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_3747_6: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomesMutants (Total: 1, Killed: 1, Survived: 0)
3766: $_cache->set("resolve:$host", $ip // ''); 3767: } 3768: 3769: return $ip;
Mutants (Total: 2, Killed: 2, Survived: 0)
3770: } 3771: 3772: # _reverse_dns( $ip ) -> hostname | undef 3773: # 3774: # Purpose: 3775: # Perform a PTR (reverse DNS) lookup for an IP address. Supports both 3776: # IPv4 and IPv6 via Net::DNS when available; falls back to gethostbyaddr. 3777: # 3778: # Entry criteria: 3779: # $ip -- a defined IPv4 or IPv6 address string. 3780: # 3781: # Exit status: 3782: # Returns the PTR hostname string, or undef if no record exists. 3783: 3784: sub _reverse_dns :Protected { ●3785 → 3788 → 3800 3785: my ($self, $ip) = @_; 3786: return unless $ip; 3787: 3788: if ($HAS_NET_DNS) {
Mutants (Total: 1, Killed: 1, Survived: 0)
3789: my $res = Net::DNS::Resolver->new(tcp_timeout => $self->{timeout}); 3790: my $query = $res->search($ip, 'PTR'); 3791: if ($query) {
3792: for my $rr ($query->answer) { 3793: return $rr->ptrdname if $rr->type eq 'PTR';Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_3791_3: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes3794: } 3795: } 3796: return; 3797: } 3798: 3799: # Fallback for IPv4 only 3800: return scalar gethostbyaddr(inet_aton($ip), AF_INET);Mutants (Total: 2, Killed: 0, Survived: 2)
- BOOL_NEGATE_3793_5: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes🧪 Suggested Test# Boolean branch test suggestion ok( !func(INPUT), 'Verify boolean branch behaviour' );- RETURN_UNDEF_3793_5: Replace return expression with undef
LOW: Mutation survived, but impact may be minor🧪 Suggested Test# Return value assertion is( func(INPUT), EXPECTED, 'Verify correct return value' );3801: } 3802: 3803: # ----------------------------------------------------------------------- 3804: # Private: WHOIS / RDAP 3805: # ----------------------------------------------------------------------- 3806: 3807: # _whois_ip( $ip ) -> hashref 3808: # 3809: # Purpose: 3810: # Enrich an IP address with organisation name, abuse contact, and country 3811: # code. Tries RDAP first (if LWP is available), then falls back to raw 3812: # WHOIS via IANA referral. Results are cached in CHI if available. 3813: # 3814: # Entry criteria: 3815: # $ip -- a defined IPv4 or IPv6 address string. 3816: # 3817: # Exit status: 3818: # Returns { org, abuse, country } hashref; keys absent when unknown. 3819: 3820: sub _whois_ip :Protected { ●3821 → 3824 → 3829 3821: my ($self, $ip) = @_; 3822: 3823: # Check CHI cache before going to the network 3824: if ($_cache) {Mutants (Total: 2, Killed: 0, Survived: 2)
- BOOL_NEGATE_3800_2: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes🧪 Suggested Test# Boolean branch test suggestion ok( !func(INPUT), 'Verify boolean branch behaviour' );- RETURN_UNDEF_3800_2: Replace return expression with undef
LOW: Mutation survived, but impact may be minor🧪 Suggested Test# Return value assertion is( func(INPUT), EXPECTED, 'Verify correct return value' );Mutants (Total: 1, Killed: 1, Survived: 0)
3825: my $cached = $_cache->get("whois_ip:$ip"); 3826: return $cached if $cached;
3827: } 3828: ●3829 → 3832 → 3842 3829: my $result = $HAS_LWP ? $self->_rdap_lookup($ip) : {}; 3830: 3831: # Fall back to raw WHOIS if RDAP returned no organisation 3832: unless ($result->{org}) {Mutants (Total: 2, Killed: 0, Survived: 2)
- BOOL_NEGATE_3826_3: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes🧪 Suggested Test# Boolean branch test suggestion ok( !func(INPUT), 'Verify boolean branch behaviour' );- RETURN_UNDEF_3826_3: Replace return expression with undef
LOW: Mutation survived, but impact may be minor🧪 Suggested Test# Return value assertion is( func(INPUT), EXPECTED, 'Verify correct return value' );Mutants (Total: 1, Killed: 1, Survived: 0)
3833: my $raw = $self->_raw_whois($ip, 'whois.iana.org'); 3834: if ($raw) {
Mutants (Total: 1, Killed: 1, Survived: 0)
3835: my ($ref) = $raw =~ /whois:\s*([\w.-]+)/i; 3836: my $detail = $ref ? $self->_raw_whois($ip, $ref) : $raw; 3837: $result = $self->_parse_whois_text($detail) if $detail; 3838: } 3839: } 3840: 3841: # Cache the enrichment result 3842: $_cache->set("whois_ip:$ip", $result) if $_cache && $result; 3843: 3844: return $result;
Mutants (Total: 2, Killed: 2, Survived: 0)
3845: } 3846: 3847: # _domain_whois( $domain ) -> raw_whois_string | undef 3848: # 3849: # Purpose: 3850: # Perform a two-step WHOIS lookup for a domain: first ask IANA for the 3851: # TLD's authoritative WHOIS server, then query that server. 3852: # 3853: # Entry criteria: 3854: # $domain -- a lower-cased domain name string. 3855: # 3856: # Exit status: 3857: # Returns the raw WHOIS response string, or undef on failure. 3858: 3859: sub _domain_whois :Protected { 3860: my ($self, $domain) = @_; 3861: my $iana = $self->_raw_whois($domain, 'whois.iana.org') // return; 3862: my ($server) = $iana =~ /whois:\s*([\w.-]+)/i; 3863: return unless $server; 3864: return $self->_raw_whois($domain, $server);
Mutants (Total: 2, Killed: 2, Survived: 0)
3865: } 3866: 3867: # _parse_domain_whois_abuse( $domain ) -> hashref 3868: # 3869: # Purpose: 3870: # Lightweight domain WHOIS lookup to extract only registrar name and 3871: # abuse contact. Used as a fallback in _extract_and_resolve_urls() when 3872: # a URL host cannot be resolved to an IP. 3873: # 3874: # Entry criteria: 3875: # $domain -- a registrable domain name string. 3876: # 3877: # Exit status: 3878: # Returns { org, abuse } hashref; empty hashref on failure. 3879: 3880: sub _parse_domain_whois_abuse :Private { ●3881 → 3884 → 3888 3881: my ($self, $domain) = @_; 3882: my $raw = $self->_domain_whois($domain) // return {}; 3883: my %info; 3884: if ($raw =~ /Registrar:\s*(.+)/i) {
Mutants (Total: 1, Killed: 1, Survived: 0)
3885: ($info{org} = $1) =~ s/\s+$//; 3886: } 3887: # Try multiple field name patterns for the abuse email ●3888 → 3888 → 3897 3888: for my $pat ( 3889: qr/Registrar Abuse Contact Email:\s*(\S+\@\S+)/i, 3890: qr/Abuse Contact Email:\s*(\S+\@\S+)/i, 3891: qr/abuse-contact:\s*(\S+\@\S+)/i, 3892: ) { 3893: if (!$info{abuse} && $raw =~ $pat) {
Mutants (Total: 1, Killed: 1, Survived: 0)
3894: ($info{abuse} = $1) =~ s/\s+$//; 3895: } 3896: } 3897: return \%info;
Mutants (Total: 2, Killed: 2, Survived: 0)
3898: } 3899: 3900: # _rdap_lookup( $ip ) -> hashref 3901: # 3902: # Purpose: 3903: # Query the ARIN RDAP API for IP block ownership information. RDAP is 3904: # preferred over raw WHOIS because it returns structured JSON. 3905: # 3906: # Entry criteria: 3907: # $ip -- a defined IPv4 or IPv6 address string. RFC 4007 zone 3908: # identifiers (e.g. %eth0 appended to link-local addresses) 3909: # are stripped before validation. The remaining value must 3910: # match dotted-quad IPv4 or bare hex-colon IPv6; malformed 3911: # inputs return {} immediately without a network call. 3912: # LWP::UserAgent must be installed. 3913: # 3914: # Exit status: 3915: # Returns { org, abuse, country } hashref; empty hashref on failure or 3916: # when $ip does not pass format validation. 3917: # 3918: # Security: 3919: # $ip is validated before being interpolated into the RDAP URL path to 3920: # prevent URL path manipulation. Zone IDs are stripped first because 3921: # a literal '%' in the path would corrupt the URL. 3922: 3923: sub _rdap_lookup :Protected { ●3924 → 3928 → 3942 3924: my ($self, $ip) = @_; 3925: return {} unless $HAS_LWP; 3926: 3927: my $ua = $self->{ua}; 3928: if(!defined($ua)) {
3929: $ua = LWP::UserAgent->new( 3930: timeout => $self->{timeout}, 3931: agent => "Email-Abuse-Investigator/$VERSION", 3932: ); 3933: 3934: if($HAS_CONN_CACHE) {Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_3928_2: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes3935: my $conn_cache = LWP::ConnCache->new(); 3936: $conn_cache->total_capacity(10); 3937: $ua->conn_cache($conn_cache); 3938: } 3939: 3940: $ua->env_proxy(1); 3941: $self->{ua} = $ua; ●[NOT COVERED] 3942 → 3948 → 3956 3942: } 3943: 3944: # Validate and normalise the IP before interpolating into the URL path. 3945: # Strip RFC 4007 IPv6 zone IDs (%eth0 suffix) which would corrupt the URL, 3946: # then assert the result is a valid dotted-quad IPv4 or bare hex IPv6. 3947: (my $safe_ip = $ip) =~ s/%.*\z//; 3948: unless ($safe_ip =~ /\A\d{1,3}(?:\.\d{1,3}){3}\z/Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_3934_3: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes3949: || $safe_ip =~ /\A[0-9a-fA-F:]+\z/) { 3950: $self->_debug("_rdap_lookup: malformed IP '$ip' -- skipping"); 3951: return {}; 3952: } 3953: 3954: # Use the ARIN RDAP endpoint; it covers the ARIN region and redirects 3955: # for RIPE/APNIC/LACNIC/AfriNIC allocations. ●[NOT COVERED] 3956 → 3963 → 3964 3956: my $res = eval { $ua->get("https://rdap.arin.net/registry/ip/$safe_ip") }; 3957: return {} unless $res && $res->is_success(); 3958: 3959: my $j = $res->decoded_content(); 3960: my %info; 3961: 3962: # Extract organisation name from the JSON response 3963: if ($j =~ /"name"\s*:\s*"([^"]+)"/) { $info{org} = $1 }Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_3948_2: Invert condition unless to if
MEDIUM: Add tests asserting both true and false outcomes●[NOT COVERED] 3964 → 3964 → 3967 3964: if ($j =~ /"handle"\s*:\s*"([^"]+)"/) { $info{handle} = $1 }Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_3963_2: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes3965: 3966: # Extract abuse email from the vcardArray contact block ●[NOT COVERED] 3967 → 3967 → 3974 3967: if ($j =~ /"abuse".*?"email"\s*:\s*"([^"]+)"/s) {Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_3964_2: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes3968: $info{abuse} = $1; 3969: } elsif ($j =~ /"email"\s*:\s*"([^@"]+@[^"]+)"/) { 3970: $info{abuse} = $1; 3971: } 3972: 3973: # Country code from the network's country field ●[NOT COVERED] 3974 → 3974 → 3976 3974: if ($j =~ /"country"\s*:\s*"([A-Z]{2})"/) { $info{country} = $1 }Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_3967_2: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes3975: 3976: return \%info;Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_3974_2: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes3977: } 3978: 3979: # _raw_whois( $query, $server ) -> string | undef 3980: # 3981: # Purpose: 3982: # Open a TCP connection to a WHOIS server on port 43, send the query, 3983: # and return the full response as a string. Uses IO::Select for read 3984: # timeouts so that alarm() is never needed (alarm() is unreliable on 3985: # Windows and in threaded Perl). Supports IPv6 WHOIS servers via 3986: # IO::Socket::IP when that module is available. 3987: # 3988: # Entry criteria: 3989: # $query -- the domain name or IP to query (defined, non-empty after 3990: # stripping control characters; croaks if it becomes empty). 3991: # $server -- the WHOIS server hostname (default: 'whois.iana.org'). 3992: # $self->{timeout} -- seconds used for connect and per-read waits. 3993: # 3994: # Exit status: 3995: # Returns the raw WHOIS response string, or undef on connection/write failure. 3996: # Croaks if $query is empty or contains only control characters. 3997: # 3998: # Security: 3999: # All ASCII control characters (C0 range 0x00-0x1F and DEL 0x7F) are 4000: # stripped from $query before it is sent to the socket. This prevents 4001: # WHOIS protocol injection via CRLF sequences that could smuggle a second 4002: # query into the same TCP stream. The guard is enforced at this 4003: # :Protected boundary so subclass callers are also protected. 4004: # 4005: # Notes: 4006: # Uses IO::Socket::IP (dual-stack) when available, falling back to 4007: # IO::Socket::INET (IPv4 only) otherwise. The IO::Select loop reads 4008: # until the server closes the connection or the per-read timeout expires. 4009: 4010: sub _raw_whois :Protected { ●4011 → 4049 → 4061 4011: my ($self, $query, $server) = @_; 4012: $server //= 'whois.iana.org'; 4013: 4014: # Strip all C0/C1 control characters to prevent WHOIS protocol injection. 4015: # Legitimate domain names and IP addresses never contain CR, LF, NUL, or 4016: # any other control character; their presence indicates either a caller bug 4017: # or hostile input embedded in a malicious email. This guard is placed at 4018: # the :Protected boundary so subclass callers are also protected. 4019: (my $safe_query = $query) =~ s/[\x00-\x1F\x7F]+//g; 4020: Carp::croak(__PACKAGE__ . '::_raw_whois: empty query after stripping control characters') 4021: unless length $safe_query; 4022: 4023: $self->_debug("WHOIS $server -> $safe_query"); 4024: 4025: # Choose the socket class based on what is installed. 4026: # IO::Socket::IP supports both IPv4 and IPv6 WHOIS servers. 4027: my $sock_class = $HAS_IO_SOCKET_IP ? 'IO::Socket::IP' : 'IO::Socket::INET'; 4028: 4029: # Attempt TCP connection to port 43 on the WHOIS server 4030: my $sock = eval { 4031: $sock_class->new( 4032: PeerAddr => $server, 4033: PeerPort => $WHOIS_PORT, 4034: Proto => 'tcp', 4035: Timeout => $self->{timeout}, 4036: ); 4037: }; 4038: return unless $sock; 4039: 4040: # Send the WHOIS query in wire format (CRLF-terminated per RFC 3912) 4041: $sock->print("$safe_query\r\n") or do { $sock->close(); return }; 4042: 4043: # Use IO::Select to implement per-read timeouts without alarm() 4044: my $sel = IO::Select->new($sock); 4045: my $response = ''; 4046: my $buf = ''; 4047: 4048: # Read until EOF (server closes) or timeout 4049: while ($sel->can_read($self->{timeout})) { 4050: # Wrap in eval to catch 'Connection reset by peer' thrown by Fatal/autodie 4051: my $n = eval { sysread($sock, $buf, $WHOIS_READ_CHUNK) }; 4052: 4053: if ($@ || !defined $n || $n <= 0) {Mutants (Total: 2, Killed: 0, Survived: 2)
- BOOL_NEGATE_3976_2: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes🧪 Suggested Test# Boolean branch test suggestion ok( !func(INPUT), 'Verify boolean branch behaviour' );- RETURN_UNDEF_3976_2: Replace return expression with undef
LOW: Mutation survived, but impact may be minor🧪 Suggested Test# Return value assertion is( func(INPUT), EXPECTED, 'Verify correct return value' );4054: $self->_debug("WHOIS read failed: $@") if $@; 4055: last; 4056: } 4057: last if !defined($n) || $n <= 0;Mutants (Total: 4, Killed: 0, Survived: 4)
- NUM_BOUNDARY_4053_31_<: Numeric boundary flip <= to <
HIGH: Likely missing edge-case test (boundary value)🧪 Suggested Test# Boundary test suggestion is( func(VALUE_AT_BOUNDARY), EXPECTED, 'Test boundary behaviour' );- NUM_BOUNDARY_4053_31_>: Numeric boundary flip <= to >
HIGH: Likely missing edge-case test (boundary value)🧪 Suggested Test# Boundary test suggestion is( func(VALUE_AT_BOUNDARY), EXPECTED, 'Test boundary behaviour' );- NUM_BOUNDARY_4053_31_>=: Numeric boundary flip <= to >=
HIGH: Likely missing edge-case test (boundary value)🧪 Suggested Test# Boundary test suggestion is( func(VALUE_AT_BOUNDARY), EXPECTED, 'Test boundary behaviour' );- COND_INV_4053_3: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes4058: $response .= $buf; 4059: } 4060: 4061: $sock->close(); 4062: return $response || undef;Mutants (Total: 3, Killed: 0, Survived: 3)
- NUM_BOUNDARY_4057_30_<: Numeric boundary flip <= to <
HIGH: Likely missing edge-case test (boundary value)🧪 Suggested Test# Boundary test suggestion is( func(VALUE_AT_BOUNDARY), EXPECTED, 'Test boundary behaviour' );- NUM_BOUNDARY_4057_30_>: Numeric boundary flip <= to >
HIGH: Likely missing edge-case test (boundary value)🧪 Suggested Test# Boundary test suggestion is( func(VALUE_AT_BOUNDARY), EXPECTED, 'Test boundary behaviour' );- NUM_BOUNDARY_4057_30_>=: Numeric boundary flip <= to >=
HIGH: Likely missing edge-case test (boundary value)🧪 Suggested Test# Boundary test suggestion is( func(VALUE_AT_BOUNDARY), EXPECTED, 'Test boundary behaviour' );Mutants (Total: 2, Killed: 2, Survived: 0)
4063: } 4064: 4065: # _parse_whois_text( $text ) -> hashref 4066: # 4067: # Purpose: 4068: # Parse a raw WHOIS IP block response to extract organisation name, 4069: # abuse contact email, and country code. 4070: # 4071: # Entry criteria: 4072: # $text -- a defined WHOIS response string. 4073: # 4074: # Exit status: 4075: # Returns { org, abuse, country } hashref; keys absent when not found. 4076: 4077: sub _parse_whois_text :Private { ●4078 → 4083 → 4093 4078: my ($self, $text) = @_; 4079: return {} unless $text; 4080: my %info; 4081: 4082: # Try multiple field names for the organisation name 4083: for my $pat ( 4084: qr/^OrgName:\s*(.+)/mi, qr/^org-name:\s*(.+)/mi, 4085: qr/^owner:\s*(.+)/mi, qr/^descr:\s*(.+)/mi, 4086: ) { 4087: if (!$info{org} && $text =~ $pat) {
Mutants (Total: 1, Killed: 1, Survived: 0)
4088: ($info{org} = $1) =~ s/\s+$//; 4089: } 4090: } 4091: 4092: # Try multiple field names for the abuse email ●4093 → 4093 → 4103 4093: for my $pat ( 4094: qr/OrgAbuseEmail:\s*(\S+@\S+)/mi, 4095: qr/abuse-mailbox:\s*(\S+@\S+)/mi, 4096: ) { 4097: if (!$info{abuse} && $text =~ $pat) {
Mutants (Total: 1, Killed: 1, Survived: 0)
4098: ($info{abuse} = $1) =~ s/\s+$//; 4099: } 4100: } 4101: 4102: # Last-resort: any abuse@ address in the response ●4103 → 4103 → 4106 4103: if (!$info{abuse} && $text =~ /(abuse\@[\w.-]+)/i) { $info{abuse} = $1 }
Mutants (Total: 1, Killed: 1, Survived: 0)
4104: 4105: # Country code (case-insensitive match, normalised to uppercase) ●4106 → 4106 → 4109 4106: if ($text =~ /^country:\s*([A-Za-z]{2})\s*$/m) {
Mutants (Total: 1, Killed: 1, Survived: 0)
4107: $info{country} = uc $1; 4108: } 4109: return \%info;
Mutants (Total: 2, Killed: 2, Survived: 0)
4110: } 4111: 4112: # ----------------------------------------------------------------------- 4113: # Private: authentication results parsing 4114: # ----------------------------------------------------------------------- 4115: 4116: # _parse_auth_results_cached() -> hashref 4117: # 4118: # Purpose: 4119: # Parse the Authentication-Results: header(s) from the message once, 4120: # cache the result, and return it. Extracts SPF, DKIM, DMARC, ARC 4121: # results and the DKIM signing domain(s). 4122: # 4123: # Entry criteria: 4124: # $self->{_headers} populated by _split_message(). 4125: # 4126: # Exit status: 4127: # Returns { spf, dkim, dmarc, arc, dkim_domain, dkim_domains } hashref. 4128: # Keys absent when the corresponding header or field is not present. 4129: 4130: sub _parse_auth_results_cached :Private { ●4131 → 4144 → 4145 4131: my $self = $_[0]; 4132: return $self->{_auth_results} if $self->{_auth_results};
Mutants (Total: 2, Killed: 2, Survived: 0)
4133: 4134: my %auth; 4135: 4136: # Concatenate all Authentication-Results: header values 4137: my $raw = join('; ', 4138: map { $_->{value} } 4139: grep { $_->{name} eq 'authentication-results' } 4140: @{ $self->{_headers} } 4141: ); 4142: 4143: # Extract individual authentication mechanism results 4144: if ($raw =~ /\bspf=(\S+)/i) { $auth{spf} = $1 }
Mutants (Total: 1, Killed: 1, Survived: 0)
●4145 → 4145 → 4146 4145: if ($raw =~ /\bdkim=(\S+)/i) { $auth{dkim} = $1 }
Mutants (Total: 1, Killed: 1, Survived: 0)
●4146 → 4146 → 4147 4146: if ($raw =~ /\bdmarc=(\S+)/i) { $auth{dmarc} = $1 }
Mutants (Total: 1, Killed: 1, Survived: 0)
●4147 → 4147 → 4150 4147: if ($raw =~ /\barc=(\S+)/i) { $auth{arc} = $1 }
Mutants (Total: 1, Killed: 1, Survived: 0)
4148: 4149: # Strip trailing punctuation captured by the greedy \S+ ●4150 → 4150 → 4156 4150: for my $k (qw(spf dkim dmarc arc)) { 4151: $auth{$k} =~ s/[;,\s]+$// if defined $auth{$k}; 4152: } 4153: 4154: # Extract DKIM signing domains from all DKIM-Signature: d= tags. 4155: # Prefer the first domain that matches the provider table (identifies ESP). ●4156 → 4157 → 4163 4156: my @dkim_domains; 4157: for my $h (grep { $_->{name} eq 'dkim-signature' } @{ $self->{_headers} }) { 4158: if ($h->{value} =~ /\bd=([^;,\s]+)/) {
Mutants (Total: 1, Killed: 1, Survived: 0)
4159: push @dkim_domains, lc $1; 4160: } 4161: } 4162: ●4163 → 4163 → 4176 4163: if (@dkim_domains) {
Mutants (Total: 1, Killed: 1, Survived: 0)
4164: # Check if any signing domain matches a known provider 4165: my $preferred; 4166: for my $d (@dkim_domains) { 4167: if ($self->_provider_abuse_for_host($d)) {
Mutants (Total: 1, Killed: 1, Survived: 0)
4168: $preferred = $d; 4169: last; 4170: } 4171: } 4172: $auth{dkim_domain} = $preferred // $dkim_domains[0]; 4173: $auth{dkim_domains} = \@dkim_domains; 4174: } 4175: 4176: $self->{_auth_results} = \%auth; 4177: return \%auth;
Mutants (Total: 2, Killed: 2, Survived: 0)
4178: } 4179: 4180: # ----------------------------------------------------------------------- 4181: # Private: provider-table lookups 4182: # ----------------------------------------------------------------------- 4183: 4184: # _provider_abuse_for_host( $host ) -> hashref | undef 4185: # 4186: # Purpose: 4187: # Look up a hostname (and each of its parent domains, stripping one label 4188: # at a time from the left) in the %PROVIDER_ABUSE table. 4189: # 4190: # Entry criteria: 4191: # $host -- a defined hostname or domain string. 4192: # 4193: # Exit status: 4194: # Returns the %PROVIDER_ABUSE entry hashref on match, undef otherwise. 4195: 4196: sub _provider_abuse_for_host :Private { ●4197 → 4200 → 4205 4197: my ($self, $host) = @_; 4198: $host = lc $host; 4199: # Strip successive subdomains until we find a match or exhaust labels 4200: while ($host =~ /\./) { 4201: return $self->{provider_abuse}->{$host} if $self->{provider_abuse}->{$host};
4202: return $PROVIDER_ABUSE{$host} if $PROVIDER_ABUSE{$host};Mutants (Total: 2, Killed: 0, Survived: 2)
- BOOL_NEGATE_4201_3: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes🧪 Suggested Test# Boolean branch test suggestion ok( !func(INPUT), 'Verify boolean branch behaviour' );- RETURN_UNDEF_4201_3: Replace return expression with undef
LOW: Mutation survived, but impact may be minor🧪 Suggested Test# Return value assertion is( func(INPUT), EXPECTED, 'Verify correct return value' );Mutants (Total: 2, Killed: 2, Survived: 0)
4203: $host =~ s/^[^.]+\.//; 4204: } 4205: return; 4206: } 4207: 4208: # _provider_abuse_for_ip( $ip, $rdns ) -> hashref | undef 4209: # 4210: # Purpose: 4211: # Look up an IP's reverse-DNS hostname in the %PROVIDER_ABUSE table to 4212: # identify well-known provider networks by rDNS pattern. 4213: # 4214: # Entry criteria: 4215: # $ip -- IPv4 or IPv6 address string (used as fallback if $rdns absent). 4216: # $rdns -- optional rDNS hostname string. 4217: # 4218: # Exit status: 4219: # Returns the %PROVIDER_ABUSE entry on match, undef otherwise. 4220: 4221: sub _provider_abuse_for_ip :Private { 4222: my ($self, $ip, $rdns) = @_; 4223: return $self->_provider_abuse_for_host($rdns) if $rdns;
Mutants (Total: 2, Killed: 2, Survived: 0)
4224: return; 4225: } 4226: 4227: # ----------------------------------------------------------------------- 4228: # Private: eTLD+1 normalisation 4229: # ----------------------------------------------------------------------- 4230: 4231: # _registrable( $host ) -> string | undef 4232: # 4233: # Purpose: 4234: # Return the registrable eTLD+1 form of a hostname. Uses 4235: # Domain::PublicSuffix when installed for accurate results; falls back 4236: # to a built-in heuristic for the common two-letter ccTLD+2 pattern. 4237: # 4238: # Entry criteria: 4239: # $host -- a hostname string (may include subdomains). 4240: # 4241: # Exit status: 4242: # Returns the registrable domain string, or undef for single-label 4243: # hostnames (e.g. 'localhost'). 4244: # 4245: # Notes: 4246: # The heuristic handles co.uk, com.au, net.jp, org.nz etc. but not 4247: # uncommon second-level delegations like ltd.uk or plc.uk. 4248: 4249: sub _registrable :Private { ●4250 → 4254 → 4261 4250: my $host = $_[0]; 4251: return unless $host && $host =~ /\./; 4252: 4253: # Use Domain::PublicSuffix for accurate PSL-based normalisation 4254: if ($HAS_PUBLIC_SUFFIX) {
Mutants (Total: 1, Killed: 1, Survived: 0)
4255: my $psl = Domain::PublicSuffix->new(); 4256: my $root = $psl->get_root_domain(lc $host); 4257: return $root if $root;
4258: } 4259: 4260: # Built-in heuristic fallback ●4261 → 4265 → 4269 4261: my @labels = split /\./, lc $host; 4262: return $host if @labels <= 2;Mutants (Total: 2, Killed: 0, Survived: 2)
- BOOL_NEGATE_4257_3: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes🧪 Suggested Test# Boolean branch test suggestion ok( !func(INPUT), 'Verify boolean branch behaviour' );- RETURN_UNDEF_4257_3: Replace return expression with undef
LOW: Mutation survived, but impact may be minor🧪 Suggested Test# Return value assertion is( func(INPUT), EXPECTED, 'Verify correct return value' );4263: 4264: # Detect common ccTLD second-level patterns (e.g. co.uk, com.au) 4265: if ($labels[-1] =~ /^[a-z]{2}$/ &&Mutants (Total: 5, Killed: 2, Survived: 3)
- NUM_BOUNDARY_4262_26_<: Numeric boundary flip <= to <
HIGH: Likely missing edge-case test (boundary value)🧪 Suggested Test# Boundary test suggestion is( func(VALUE_AT_BOUNDARY), EXPECTED, 'Test boundary behaviour' );- NUM_BOUNDARY_4262_26_>: Numeric boundary flip <= to >
HIGH: Likely missing edge-case test (boundary value)🧪 Suggested Test# Boundary test suggestion is( func(VALUE_AT_BOUNDARY), EXPECTED, 'Test boundary behaviour' );- NUM_BOUNDARY_4262_26_>=: Numeric boundary flip <= to >=
HIGH: Likely missing edge-case test (boundary value)🧪 Suggested Test# Boundary test suggestion is( func(VALUE_AT_BOUNDARY), EXPECTED, 'Test boundary behaviour' );Mutants (Total: 1, Killed: 1, Survived: 0)
4266: $labels[-2] =~ /^(?:co|com|net|org|gov|edu|ac|me)$/) { 4267: return join('.', @labels[-3..-1]);
Mutants (Total: 2, Killed: 2, Survived: 0)
4268: } 4269: return join('.', @labels[-2..-1]);
Mutants (Total: 2, Killed: 2, Survived: 0)
4270: } 4271: 4272: # ----------------------------------------------------------------------- 4273: # Private: utilities 4274: # ----------------------------------------------------------------------- 4275: 4276: # _enrich_ip( $ip, $confidence, $note ) -> origin hashref 4277: # 4278: # Purpose: 4279: # Perform rDNS and WHOIS/RDAP for a single IP and package the results 4280: # into the standard origin hashref returned by originating_ip(). 4281: # 4282: # Entry criteria: 4283: # $ip -- a defined, non-private IPv4 or IPv6 address string. 4284: # $confidence -- 'high', 'medium', or 'low'. 4285: # $note -- human-readable explanation of why this IP was chosen. 4286: # 4287: # Exit status: 4288: # Returns { ip, rdns, org, abuse, country, confidence, note } hashref. 4289: 4290: sub _enrich_ip :Private { 4291: my ($self, $ip, $confidence, $note) = @_; 4292: my $rdns = $self->_reverse_dns($ip); 4293: my $whois = $self->_whois_ip($ip); 4294: return { 4295: ip => $ip, 4296: rdns => $rdns // '(no reverse DNS)', 4297: org => $whois->{org} // '(unknown)', 4298: abuse => $whois->{abuse} // '(unknown)', 4299: country => $whois->{country} // undef, 4300: confidence => $confidence, 4301: note => $note, 4302: }; 4303: } 4304: 4305: # _header_value( $name ) -> value_string | undef 4306: # 4307: # Purpose: 4308: # Return the value of the first header matching the given lower-cased 4309: # header name. 4310: =head2 header_value( $name ) 4311: 4312: Returns the value of the first occurrence of a named header field, or 4313: C<undef> if the header is absent. The name comparison is case-insensitive. 4314: 4315: =head3 Usage 4316: 4317: my $subj = $analyser->header_value('Subject'); 4318: my $from = $analyser->header_value('From'); 4319: my $msgid = $analyser->header_value('Message-ID'); 4320: 4321: =head3 Arguments 4322: 4323: =over 4 4324: 4325: =item C<$name> (string, required) 4326: 4327: The header field name, e.g. C<'Subject'>, C<'From'>, C<'X-Mailer'>. 4328: Comparison is case-insensitive. 4329: 4330: =back 4331: 4332: =head3 Returns 4333: 4334: The raw header value string (not decoded), or C<undef> if the named header 4335: is not present. When the same header appears more than once, only the value 4336: of the first occurrence is returned. 4337: 4338: =head3 Side Effects 4339: 4340: None. Header data is pre-parsed during C<parse_email()>. 4341: 4342: =head3 Notes 4343: 4344: Header values are returned verbatim, including any MIME encoded-word sequences 4345: (C<=?charset?B/Q?...?=>). Pass the result through C<_decode_mime_words()> 4346: internally if human-readable output is needed. 4347: 4348: =head3 API Specification 4349: 4350: =head4 Input 4351: 4352: { 4353: name => { type => 'string', required => 1 }, 4354: } 4355: 4356: =head4 Output 4357: 4358: { type => [ 'string', 'undef' ] } 4359: 4360: =head3 Messages 4361: 4362: None -- returns C<undef> on a missing header, never throws. 4363: 4364: =cut 4365: 4366: sub header_value { 4367: my $self = shift; 4368: 4369: my $params = Params::Validate::Strict::validate_strict({ 4370: args => Params::Get::get_params('name', \@_) || {}, 4371: schema => { 4372: name => { 4373: 'type' => 'string', 4374: 'optional' => 0, 4375: } 4376: } 4377: }); 4378: 4379: return if((!defined($params)) || !defined($params->{name})); 4380: return if ref($params->{name}); 4381: return $self->_header_value($params->{name});
Mutants (Total: 2, Killed: 2, Survived: 0)
4382: } 4383: 4384: # 4385: # _header_value( $name ) -> string | undef 4386: # 4387: # Purpose: 4388: # Internal implementation for header_value(). Walks _headers list and 4389: # returns the value of the first matching header. 4390: # 4391: # Entry criteria: 4392: # $name -- a lower-cased header name string. 4393: # $self->{_headers} populated by _split_message(). 4394: # 4395: # Exit status: 4396: # Returns the value string, or undef if the header is not present. 4397: 4398: sub _header_value :Private { ●4399 → 4400 → 4403 4399: my ($self, $name) = @_; 4400: for my $h (@{ $self->{_headers} }) { 4401: return $h->{value} if $h->{name} eq lc($name);
Mutants (Total: 2, Killed: 2, Survived: 0)
4402: } 4403: return; 4404: } 4405: 4406: # _ip_in_cidr( $ip, $cidr ) -> bool 4407: # 4408: # Purpose: 4409: # Test whether an IPv4 address falls within a CIDR block or is an exact 4410: # match (when $cidr contains no '/' separator). 4411: # 4412: # Entry criteria: 4413: # $ip -- a defined dotted-quad IPv4 address string. 4414: # $cidr -- a CIDR string like '10.0.0.0/8' or an exact IP. 4415: # 4416: # Exit status: 4417: # Returns 1 (true) if the IP is within the CIDR block, 0 otherwise. 4418: 4419: sub _ip_in_cidr :Private { 4420: my ($self, $ip, $cidr) = @_; 4421: return $ip eq $cidr unless $cidr =~ m{/};
Mutants (Total: 2, Killed: 2, Survived: 0)
4422: my ($net_addr, $prefix) = split m{/}, $cidr; 4423: return 0 if !defined($prefix) || $prefix !~ /^\d+$/ || $prefix > 32;
Mutants (Total: 5, Killed: 5, Survived: 0)
4424: 4425: # Compute the network mask and compare masked network addresses 4426: my $mask = ~0 << (32 - $prefix); 4427: my $net_n = unpack 'N', (inet_aton($net_addr) // return 0); 4428: my $ip_n = unpack 'N', (inet_aton($ip) // return 0); 4429: return ($ip_n & $mask) == ($net_n & $mask);
Mutants (Total: 3, Killed: 3, Survived: 0)
4430: } 4431: 4432: # _decode_mime_words( $str ) -> decoded_string 4433: # 4434: # Purpose: 4435: # Decode MIME encoded-words (=?charset?B/Q?...?=) in a header value 4436: # string for human-readable display in reports. 4437: # 4438: # Entry criteria: 4439: # $str -- a defined header value string; may be undef. 4440: # 4441: # Exit status: 4442: # Returns the decoded string, or '' if $str is undef. 4443: 4444: sub _decode_mime_words :Private { 4445: my ($self, $str) = @_; 4446: return '' unless defined $str;
Mutants (Total: 2, Killed: 2, Survived: 0)
4447: # Replace each encoded-word with its decoded equivalent 4448: $str =~ s/=\?([^?]+)\?([BbQq])\?([^?]*)\?=/_decode_ew($1,$2,$3)/ge; 4449: return $str;
Mutants (Total: 2, Killed: 2, Survived: 0)
4450: } 4451: 4452: # _decode_ew( $charset, $enc, $text ) -> decoded_bytes 4453: # 4454: # Purpose: 4455: # Decode a single MIME encoded-word component (base64 or quoted-printable). 4456: # 4457: # Notes: 4458: # Non-UTF-8 charsets return raw bytes; good enough for display-name spoof 4459: # detection which only needs ASCII matching. 4460: 4461: sub _decode_ew :Private { ●4462 → 4464 → 4471 4462: my ($charset, $enc, $text) = @_; 4463: my $raw; 4464: if (uc($enc) eq 'B') {
Mutants (Total: 1, Killed: 1, Survived: 0)
4465: $raw = decode_base64($text); 4466: } else { 4467: # Quoted-printable encoded-word uses underscore for space 4468: $text =~ s/_/ /g; 4469: $raw = decode_qp($text); 4470: } 4471: return $raw;
Mutants (Total: 2, Killed: 2, Survived: 0)
4472: } 4473: 4474: # _parse_date_to_epoch( $str ) -> epoch_int | undef 4475: # 4476: # Purpose: 4477: # Parse common WHOIS date strings to a Unix epoch integer. 4478: # Handles YYYY-MM-DD, YYYY-MM-DDThh:mm:ssZ, and DD-Mon-YYYY formats. 4479: # 4480: # Entry criteria: 4481: # $str -- a defined date string; may be undef. 4482: # 4483: # Exit status: 4484: # Returns epoch integer on success, undef if the string cannot be parsed. 4485: 4486: sub _parse_date_to_epoch :Private { ●4487 → 4494 → 4510 4487: my ($self, $str) = @_; 4488: return unless $str; 4489: 4490: # Clean the string of trailing whitespace/newlines 4491: $str =~ s/^\s+|\s+$//g; 4492: 4493: # Guard Regex: Validates the strict YYYY-MM-DDThh:mm:ssZ format 4494: if ($str =~ /^(\d{4}-\d{2}-\d{2}T\d{2}:\d{2}:\d{2})(?:\.\d+)?Z$/) {
Mutants (Total: 1, Killed: 1, Survived: 0)
4495: # Parse the string 4496: # We use 'strptime' to create a Time::Piece object. 4497: # The 'Z' indicates UTC (Zulu time). 4498: my $epoch = eval { 4499: my $t = Time::Piece->strptime($1, '%Y-%m-%dT%H:%M:%S'); 4500: 4501: # Return seconds since the epoch 4502: # Time::Piece handles the timezone offset internally when calling ->epoch 4503: 4504: # strptime returns a local time object. 4505: # We must subtract the local timezone offset to get the true UTC epoch. 4506: return $t->epoch - $t->tzoffset->seconds;
Mutants (Total: 2, Killed: 2, Survived: 0)
4507: }; 4508: return $epoch if defined $epoch;
Mutants (Total: 2, Killed: 2, Survived: 0)
4509: } ●4510 → 4512 → 4516 4510: my ($y, $m, $d); 4511: 4512: if ($str =~ /^(\d{4})-(\d{2})-(\d{2})/) { ($y,$m,$d)=($1,$2,$3) }
Mutants (Total: 1, Killed: 1, Survived: 0)
4513: elsif ($str =~ /^(\d{2})-([A-Za-z]{3})-(\d{4})/) { ($d,$m,$y)=($1,$Readonly::Values::Months::months{lc$2}//0,$3) } 4514: elsif ($str =~ /^(\d{2})\/(\d{2})\/(\d{4})/) { ($m,$d,$y)=($1,$2,$3) } 4515: ●4516 → 4518 → 4522 4516: return unless $y && $m && $d; 4517: 4518: if (eval { require Time::Local; 1 }) {
Mutants (Total: 1, Killed: 1, Survived: 0)
4519: return eval { Time::Local::timegm(0,0,0,$d,$m-1,$y-1900) };
Mutants (Total: 2, Killed: 2, Survived: 0)
4520: } 4521: # Approximate fallback without Time::Local 4522: return ($y-1970)*365.25*$SECS_PER_DAY + ($m-1)*30.5*$SECS_PER_DAY + ($d-1)*$SECS_PER_DAY;
4523: } 4524: 4525: # _parse_rfc2822_date( $str ) -> epoch_int | undef 4526: # 4527: # Purpose: 4528: # Parse an RFC 2822 Date: header value to a Unix epoch integer. 4529: # Timezone offsets are intentionally ignored; the function returns a 4530: # UTC-equivalent value. For the 7-day suspicious_date window the 4531: # maximum error is ~14 hours, well within the tolerance. 4532: # 4533: # Entry criteria: 4534: # $str -- a defined Date: header value string. 4535: # 4536: # Exit status: 4537: # Returns epoch integer on success, undef if the string cannot be parsed. 4538: 4539: sub _parse_rfc2822_date :Private { ●4540 → 4544 → 4552 4540: my $str = $_[0]; 4541: return unless $str; 4542: 4543: # Match: DD Mon YYYY HH:MM:SS (timezone offset ignored) 4544: if ($str =~ /(\d{1,2})\s+([A-Za-z]{3})\s+(\d{4})\s+(\d{2}):(\d{2}):(\d{2})/) {Mutants (Total: 2, Killed: 0, Survived: 2)
- BOOL_NEGATE_4522_2: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes🧪 Suggested Test# Boolean branch test suggestion ok( !func(INPUT), 'Verify boolean branch behaviour' );- RETURN_UNDEF_4522_2: Replace return expression with undef
LOW: Mutation survived, but impact may be minor🧪 Suggested Test# Return value assertion is( func(INPUT), EXPECTED, 'Verify correct return value' );Mutants (Total: 1, Killed: 1, Survived: 0)
4545: my ($d, $m, $y, $H, $M, $S) = 4546: ($1, $Readonly::Values::Months::months{ lc $2 } // 0, $3, $4, $5, $6); 4547: return unless $m; 4548: if (eval { require Time::Local; 1 }) {
Mutants (Total: 1, Killed: 1, Survived: 0)
4549: return eval { Time::Local::timegm($S, $M, $H, $d, $m - 1, $y - 1900) };
Mutants (Total: 2, Killed: 2, Survived: 0)
4550: } 4551: } 4552: return; 4553: } 4554: 4555: # _country_name( $cc ) -> country_name_string 4556: # 4557: # Purpose: 4558: # Return a human-readable country name for a two-letter ISO 3166-1 4559: # alpha-2 country code. Only the small set of statistically high-volume 4560: # spam-originating countries is covered; other codes are returned as-is. 4561: # 4562: # Entry criteria: 4563: # $cc -- a two-letter uppercase country code string. 4564: # 4565: # Exit status: 4566: # Returns the country name string, or the code itself if not in the table. 4567: 4568: sub _country_name :Private { 4569: my $cc = $_[0]; 4570: my %names = ( 4571: CN => 'China', RU => 'Russia', NG => 'Nigeria', 4572: VN => 'Vietnam', IN => 'India', PK => 'Pakistan', 4573: BD => 'Bangladesh', 4574: ); 4575: return $names{$cc} // $cc;
Mutants (Total: 2, Killed: 2, Survived: 0)
4576: } 4577: 4578: # _debug( $msg ) 4579: # 4580: # Purpose: 4581: # Write a diagnostic message to STDERR when verbose mode is enabled. 4582: # 4583: # Entry criteria: 4584: # $msg -- a defined message string. 4585: # 4586: # Notes: 4587: # Messages are prefixed with the class name for easy grepping. 4588: 4589: sub _debug :Private { ●4590 → 4592 → 0 4590: my ($self, $msg) = @_; 4591: 4592: if($self->{verbose}) {
Mutants (Total: 1, Killed: 1, Survived: 0)
4593: if (my $logger = $self->{logger}) { # Set via Object::Configure
Mutants (Total: 1, Killed: 1, Survived: 0)
4594: $logger->debug("[Email::Abuse::Investigator] $msg"); 4595: } else { 4596: print STDERR "[Email::Abuse::Investigator] $msg\n"; 4597: } 4598: } 4599: } 4600: 4601: 1; 4602: 4603: __END__ 4604: 4605: =head1 ALGORITHM: DOMAIN INTELLIGENCE PIPELINE 4606: 4607: For each unique non-infrastructure domain found in the email, the module 4608: runs the following pipeline: 4609: 4610: Domain name 4611: | 4612: +-- A/AAAA record --> web hosting IP --> RDAP --> org + abuse contact 4613: | 4614: +-- MX record --> mail server hostname --> A --> RDAP --> org + abuse 4615: | 4616: +-- NS record --> nameserver hostname --> A --> RDAP --> org + abuse 4617: | 4618: +-- WHOIS (TLD whois server via IANA referral) 4619: +-- Registrar name + abuse contact 4620: +-- Creation date (-> recently-registered flag if < 180 days) 4621: +-- Expiry date (-> expires-soon or expired flags) 4622: 4623: Domains are collected from: 4624: 4625: From:/Reply-To:/Sender:/Return-Path: headers 4626: DKIM-Signature: d= (signing domain) 4627: List-Unsubscribe: (ESP / bulk sender domain) 4628: Message-ID: (often reveals real sending platform) 4629: mailto: links and bare addresses in the body 4630: 4631: =head1 CACHING 4632: 4633: Two levels of caching are used: 4634: 4635: =over 4 4636: 4637: =item Per-message cache (C<$self-E<gt>{_domain_info}>) 4638: 4639: Stores domain analysis results for the lifetime of one C<parse_email()> 4640: call. Invalidated by each call to C<parse_email()>. 4641: 4642: =item Cross-message cache (CHI Memory driver, if C<CHI> is installed) 4643: 4644: Stores IP WHOIS, DNS resolution, and domain analysis results across all 4645: messages processed by the same process. TTL is one hour. Prevents 4646: redundant WHOIS queries for infrastructure that appears in multiple 4647: messages in the same run (e.g. a sending ISP seen in 500 spam messages). 4648: 4649: =back 4650: 4651: =head1 SECURITY 4652: 4653: =head2 WHOIS query sanitization 4654: 4655: C<_raw_whois()> strips all ASCII control characters (C<\x00>-C<\x1F> and 4656: C<\x7F>) from C<$query> before writing it to the socket. This prevents 4657: WHOIS protocol injection: a maliciously crafted domain name containing 4658: embedded C<\r\n> would otherwise smuggle a second WHOIS command into the 4659: same TCP connection. If stripping leaves an empty string the method 4660: croaks immediately rather than sending a blank query. 4661: 4662: =head2 RDAP IP validation 4663: 4664: C<_rdap_lookup()> validates C<$ip> before interpolating it into the ARIN 4665: RDAP URL path. RFC 4007 IPv6 zone identifiers (C<%eth0> suffixes on 4666: link-local addresses) are stripped first; the remaining value must match 4667: either a dotted-quad IPv4 address or a pure hex-colon IPv6 address. A 4668: value that fails this check returns C<{}> immediately without making any 4669: network call. 4670: 4671: =head2 CLI path validation 4672: 4673: Both C<bin/abuse_check> and C<bin/submit_abuse_report> validate the 4674: C<$ARGV[0]> file path before opening it. They reject any path that 4675: contains NUL bytes or bare CR/LF characters, and independently reject 4676: paths containing directory-traversal sequences (C<../>). This makes the 4677: scripts safe to invoke under C<perl -T> (taint mode) and prevents 4678: accidental or intentional access to files outside the intended directory. 4679: 4680: =head1 IPV6 SUPPORT 4681: 4682: IPv6 addresses are extracted from C<Received:> headers using bracketed 4683: notation (C<[2001:db8::1]>). They are tested against the private range 4684: list (which covers ::1, fe80::/10, fc00::/7, fd00::/8, and the 4685: documentation range 2001:db8::/32) and passed through C<_whois_ip()> and 4686: C<_rdap_lookup()> in the same way as IPv4 addresses. RFC 4007 zone 4687: identifiers (e.g. C<%eth0>) are stripped by C<_rdap_lookup()> before the 4688: address is placed in the RDAP URL. 4689: 4690: C<_resolve_host()> attempts both A and AAAA lookups when C<Net::DNS> is 4691: installed. C<_raw_whois()> uses C<IO::Socket::IP> for dual-stack WHOIS 4692: connections when that module is installed. 4693: 4694: =head1 SEE ALSO 4695: 4696: =over 4 4697: 4698: =item * L<Configure an Object at Runtime|Object::Configure> 4699: 4700: The provider_abuse, trusted_domains and url_shorteners tables can all be overridden at runtime 4701: 4702: =item * L<Test Dashboard|https://nigelhorne.github.io/Email-Abuse-Investigator/coverage/> 4703: 4704: =item * L<ARIN RDAP|https://rdap.arin.net/> 4705: 4706: =item * L<Net::DNS>, L<LWP::UserAgent>, L<HTML::LinkExtor> 4707: 4708: =item * L<CHI>, L<AnyEvent::DNS>, L<IO::Socket::IP>, L<Domain::PublicSuffix> 4709: 4710: =back 4711: 4712: =head1 REPOSITORY 4713: 4714: L<https://github.com/nigelhorne/Email-Abuse-Investigator> 4715: 4716: =head1 SUPPORT 4717: 4718: This module is provided as-is without any warranty. 4719: 4720: Please report any bugs or feature requests to C<bug-email-abuse-investigator at rt.cpan.org>, 4721: or through the web interface at 4722: L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Email-Abuse-Investigator>. 4723: I will be notified, and then you'll 4724: automatically be notified of progress on your bug as I make changes. 4725: 4726: You can find documentation for this module with the perldoc command. 4727: 4728: perldoc Email::Abuse::Investigator 4729: 4730: You can also look for information at: 4731: 4732: =over 4 4733: 4734: =item * MetaCPAN 4735: 4736: L<https://metacpan.org/dist/Email-Abuse-Investigator> 4737: 4738: =item * RT: CPAN's request tracker 4739: 4740: L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=Email-Abuse-Investigator> 4741: 4742: =item * CPAN Testers' Matrix 4743: 4744: L<http://matrix.cpantesters.org/?dist=Email-Abuse-Investigator> 4745: 4746: =item * CPAN Testers Dependencies 4747: 4748: L<http://deps.cpantesters.org/?module=Email-Abuse-Investigator> 4749: 4750: =back 4751: 4752: =head1 REQUIRED MODULES 4753: 4754: The following modules are mandatory: 4755: 4756: Readonly::Values::Months 4757: Socket (core since Perl 5) 4758: IO::Socket::INET (core since Perl 5) 4759: MIME::QuotedPrint (core since Perl 5.8) 4760: MIME::Base64 (core since Perl 5.8) 4761: 4762: The following are optional but strongly recommended: 4763: 4764: Net::DNS -- enables MX, NS, AAAA record lookups 4765: LWP::UserAgent -- enables RDAP (faster and richer than raw WHOIS) 4766: and following redirect chains for URL shorteners 4767: and cloud-storage redirect cloakers 4768: LWP::ConnCache -- enables HTTP connection reuse (used with LWP::UserAgent) 4769: HTML::LinkExtor -- enables structural HTML link extraction with entity decoding 4770: CHI -- enables cross-message IP/domain result caching 4771: IO::Socket::IP -- enables IPv6 WHOIS connections 4772: Domain::PublicSuffix -- enables accurate eTLD+1 domain normalisation 4773: AnyEvent::DNS -- enables parallel DNS resolution for multiple URL hosts 4774: 4775: =head1 LIMITATIONS 4776: 4777: =over 4 4778: 4779: =item No charset conversion 4780: 4781: Body text is stored as raw bytes. Non-ASCII content (UTF-8, Latin-1, 4782: ISO-2022-JP, etc.) is not decoded to Perl's internal Unicode representation. 4783: URL and domain extraction from non-ASCII bodies may miss or misparse content. 4784: Use C<Email::MIME> if full charset support is needed. 4785: 4786: =item Hand-rolled MIME parser 4787: 4788: The built-in MIME parser handles common cases but is not a conforming 4789: implementation of RFC 2045/2046. It silently drops parts it cannot decode, 4790: does not handle C<message/rfc822> attachments, and does not parse 4791: C<Content-Disposition> filenames. Replace with C<Email::MIME> or 4792: C<MIME::Entity> for production use with untrusted input. 4793: 4794: =item IPv4-only CIDR matching for trusted_relays 4795: 4796: C<_ip_in_cidr()> and the C<trusted_relays> constructor argument only support 4797: IPv4 CIDR notation. IPv6 trusted relay entries are accepted but silently 4798: never match. 4799: 4800: =item WHOIS rate-limiting not handled 4801: 4802: C<_raw_whois()> does not retry on rate-limit responses (typically a 4803: "quota exceeded" reply). Under high-volume processing the module will 4804: silently return empty enrichment data for affected IPs and domains. 4805: 4806: =item Not thread-safe 4807: 4808: The class-level C<$_cache> variable and the optional-module C<$HAS_*> flags 4809: are shared across all threads. Create a separate object per thread and do 4810: not share objects across threads. 4811: 4812: =item DMARC policy not fetched 4813: 4814: The module reads the C<Authentication-Results: dmarc=> result from the 4815: message headers but does not perform live C<_dmarc.domain> TXT record 4816: lookups. A missing DMARC result in the headers is not independently flagged. 4817: 4818: =item C<abuse_contacts()> routes duplicated in C<form_contacts()> 4819: 4820: Both methods iterate the same six discovery routes independently. Any new 4821: discovery route must be added to both. A future refactor should share a 4822: single routing pass. 4823: 4824: =item CHI cache is a class-level mutable global 4825: 4826: The cross-message cache is shared across all instances in the process. 4827: Tests that populate the cache will affect subsequent tests. Pass the cache 4828: in via C<new()> (not currently supported) to enable proper isolation. 4829: 4830: =back 4831: 4832: =encoding utf-8 4833: 4834: =head1 FORMAL SPECIFICATION 4835: 4836: =head2 new 4837: 4838: -- Z notation (simplified) 4839: new == [ 4840: timeout : N; 4841: trusted_relays : seq STRING; 4842: verbose : BOOL; 4843: _raw : STRING; 4844: _headers : seq (STRING x STRING); 4845: _origin? : IP_INFO | undefined; 4846: _urls? : seq URL_INFO | undefined; 4847: _risk? : RISK_INFO | undefined 4848: ] 4849: pre: timeout >= 0 4850: post: self.timeout = params.timeout /\ self._raw = '' 4851: 4852: =head2 parse_email 4853: 4854: -- Z notation 4855: parse_email == [ 4856: Delta Email::Abuse::Investigator; 4857: text? : STRING | ref STRING 4858: ] 4859: pre: defined text? 4860: post: self._raw = deref(text?) /\ 4861: self._origin = undefined /\ 4862: self._urls = undefined /\ 4863: self._risk = undefined 4864: 4865: =head2 originating_ip 4866: 4867: -- Z notation 4868: originating_ip == [ 4869: Xi Email::Abuse::Investigator; 4870: result! : IP_INFO | undefined 4871: ] 4872: pre: self._raw /= '' 4873: post: result! = self._origin /\ 4874: (result! /= undefined => result!.ip in EXTERNAL_IPS) 4875: 4876: =head2 embedded_urls 4877: 4878: -- Z notation 4879: embedded_urls == [ 4880: Xi Email::Abuse::Investigator; 4881: result! : seq URL_INFO 4882: ] 4883: pre: self._raw /= '' 4884: post: result! = self._urls /\ 4885: forall u : result! @ u.url =~ m{^https?://}i 4886: 4887: =head2 mailto_domains 4888: 4889: -- Z notation 4890: mailto_domains == [ 4891: Xi Email::Abuse::Investigator; 4892: result! : seq DOMAIN_INFO 4893: ] 4894: pre: self._raw /= '' 4895: post: result! = self._mailto_domains /\ 4896: forall d : result! @ d.domain =~ /\.[a-zA-Z]{2,}$/ 4897: 4898: =head2 all_domains 4899: 4900: -- Z notation 4901: all_domains == [ 4902: Xi Email::Abuse::Investigator; 4903: result! : seq STRING 4904: ] 4905: post: result! = deduplicate( 4906: map(_registrable, url_hosts union mailto_domains) 4907: ) 4908: 4909: =head2 unresolved_contacts 4910: 4911: -- Z notation 4912: unresolved_contacts == [ 4913: Xi Email::Abuse::Investigator; 4914: result! : seq UNRESOLVED_INFO 4915: ] 4916: post: forall u : result! @ 4917: u.domain not_in covered_domains(abuse_contacts, form_contacts) 4918: 4919: =head2 sending_software 4920: 4921: -- Z notation 4922: sending_software == [ 4923: Xi Email::Abuse::Investigator; 4924: result! : seq SW_INFO 4925: ] 4926: post: result! = self._sending_sw 4927: 4928: =head2 received_trail 4929: 4930: -- Z notation 4931: received_trail == [ 4932: Xi Email::Abuse::Investigator; 4933: result! : seq HOP_INFO 4934: ] 4935: post: result! = self._rcvd_tracking 4936: 4937: =head2 risk_assessment 4938: 4939: -- Z notation 4940: risk_assessment == [ 4941: Xi Email::Abuse::Investigator; 4942: result! : RISK_INFO 4943: ] 4944: post: result!.score = sum({ w(f.severity) | f in result!.flags }) /\ 4945: result!.level = classify(result!.score) 4946: where: 4947: w(HIGH) = 3; w(MEDIUM) = 2; w(LOW) = 1; w(INFO) = 0 4948: classify(s) = HIGH if s >= 9 4949: | MEDIUM if s >= 5 4950: | LOW if s >= 2 4951: | INFO otherwise 4952: 4953: =head2 abuse_report_text 4954: 4955: -- Z notation 4956: abuse_report_text == [ 4957: Xi Email::Abuse::Investigator; 4958: result! : STRING 4959: ] 4960: post: result! /= '' /\ result! ends_with '\n' 4961: 4962: =head2 abuse_contacts 4963: 4964: -- Z notation 4965: abuse_contacts == [ 4966: Xi Email::Abuse::Investigator; 4967: result! : seq CONTACT_INFO 4968: ] 4969: post: forall c : result! @ c.address contains '@' /\ 4970: forall c1, c2 : result! @ c1 /= c2 => c1.address /= c2.address 4971: 4972: =head2 form_contacts 4973: 4974: -- Z notation 4975: form_contacts == [ 4976: Xi Email::Abuse::Investigator; 4977: result! : seq FORM_CONTACT_INFO 4978: ] 4979: post: forall c : result! @ c.form =~ m{^https?://} /\ 4980: forall c1, c2 : result! @ c1 /= c2 => c1.form /= c2.form 4981: 4982: =head2 report 4983: 4984: -- Z notation 4985: report == [ 4986: Xi Email::Abuse::Investigator; 4987: result! : STRING 4988: ] 4989: post: result! /= '' /\ result! ends_with '\n' 4990: 4991: =head2 header_value 4992: 4993: header_value : Object × FieldName → Maybe FieldValue 4994: header_value(o, n) ≜ first { lc(h.name) = lc(n) } o._headers .value 4995: 4996: =head1 AUTHOR 4997: 4998: Nigel Horne, C<< <njh@nigelhorne.com> >> 4999: 5000: =head1 LICENCE AND COPYRIGHT 5001: 5002: Copyright 2026 Nigel Horne. 5003: 5004: Usage is subject to the GPL2 licence terms. 5005: If you use it, 5006: please let me know. 5007: 5008: =cut 5009: 5010: 1;