lib/CGI/Lingua.pm

Index
Structural Coverage (Approximate)

TER1 (Statement): 85.30%
TER2 (Branch): 76.00%
TER3 (LCSAJ): 97.1% (68/70)
Approximate LCSAJ segments: 451

LCSAJ Legend

● Covered — this LCSAJ path was executed during testing.

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

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

        start → end → jump

Uncovered paths show [NOT COVERED] in the tooltip.

Mutant Testing Legend

Survived (tests missed this) Killed (tests detected this) No mutation 
    1: package CGI::Lingua;
    2: 
    3: use warnings;
    4: use strict;
    5: use autodie qw(:file);
    6: 
    7: use Object::Configure 0.14;
    8: use Params::Get 0.13;
    9: use Readonly;
   10: use Scalar::Util qw(blessed);
   11: use Storable;
   12: use Class::Autouse qw{
   13: 	Carp
   14: 	Locale::Language
   15: 	Locale::Object::Country
   16: 	Locale::Object::DB
   17: 	I18N::AcceptLanguage
   18: 	I18N::LangTags::Detect
   19: };
   20: 
   21: our $VERSION = '0.81';
   22: 
   23: # ── Module-level constants ───────────────────────────────────────────────────
   24: # Gathering magic strings here makes behavioural changes one-edit operations.
   25: 
   26: Readonly my $CACHE_TTL_LONG      => '1 month';
   27: Readonly my $CACHE_TTL_SHORT     => '1 hour';
   28: Readonly my $CACHE_NS            => 'CGI::Lingua:';    # namespace prefix for every key
   29: Readonly my $BROKEN_GEOIPFREE    => '45.128.139.41';  # https://github.com/bricas/geo-ipfree/issues/10
   30: Readonly my $BAIDU_SUBNET        => '185.10.104.0/22';# RT-86809: Baidu misreports as EU
   31: Readonly my $DEPRECATED_EN_UK    => 'en-uk';          # some browsers still send this
   32: Readonly my $CANONICAL_EN_GB     => 'en-gb';
   33: Readonly my $ACCEPT_LANG_MAX     => 256;              # max bytes we accept from the header
   34: Readonly my $GEO_UNKNOWN         => -1;               # geo-module sentinel: not yet probed
   35: Readonly my $GEO_ABSENT          =>  0;               # geo-module sentinel: unavailable
   36: Readonly my $GEO_PRESENT         =>  1;               # geo-module sentinel: loaded OK
   37: Readonly my %RTL_LANGS           => (map { $_ => 1 }  # ISO 639-1 codes whose primary script is RTL
   38:     qw(ar dv fa he ku ps sd ug ur yi));
   39: 
   40: =head1 NAME
   41: 
   42: CGI::Lingua - Create a multilingual web page
   43: 
   44: =head1 VERSION
   45: 
   46: Version 0.80
   47: 
   48: =cut
   49: 
   50: =head1 SYNOPSIS
   51: 
   52: CGI::Lingua is a powerful module for multilingual web applications
   53: offering extensive language/country detection strategies.
   54: 
   55: No longer does your website need to be in English only.
   56: CGI::Lingua provides a simple basis to determine which language to display a website.
   57: The website tells CGI::Lingua which languages it supports.
   58: Based on that list CGI::Lingua tells the application which language the user would like to use.
   59: 
   60:     use CGI::Lingua;
   61:     # ...
   62:     my $l = CGI::Lingua->new(['en', 'fr', 'en-gb', 'en-us']);
   63:     my $language = $l->language();
   64:     if ($language eq 'English') {
   65: 	print '<P>Hello</P>';
   66:     } elsif($language eq 'French') {
   67: 	print '<P>Bonjour</P>';
   68:     } else {	# $language eq 'Unknown'
   69: 	my $rl = $l->requested_language();
   70: 	print "<P>Sorry for now this page is not available in $rl.</P>";
   71:     }
   72:     my $c = $l->country();
   73:     if ($c eq 'us') {
   74:       # print contact details in the US
   75:     } elsif ($c eq 'ca') {
   76:       # print contact details in Canada
   77:     } else {
   78:       # print worldwide contact details
   79:     }
   80: 
   81:     # ...
   82: 
   83:     use CHI;
   84:     use CGI::Lingua;
   85:     # ...
   86:     my $cache = CHI->new(driver => 'File', root_dir => '/tmp/cache', namespace => 'CGI::Lingua-countries');
   87:     $l = CGI::Lingua->new({ supported => ['en', 'fr'], cache => $cache });
   88: 
   89: =head1 SUBROUTINES/METHODS
   90: 
   91: =head2 new
   92: 
   93: Creates a CGI::Lingua object.
   94: 
   95: =head3 API SPECIFICATION
   96: 
   97:     Input:
   98:       supported  => ArrayRef[Str] | Str   # required; RFC-1766 language codes
   99:       cache      => Object                # optional; CHI-compatible (get/set)
  100:       config_file => Str                  # optional; YAML/XML/INI config path
  101:       logger     => Object                # optional; must implement warn/info/error
  102:       info       => Object                # optional; CGI::Info-compatible
  103:       data       => Any                   # optional; forwarded to I18N::AcceptLanguage
  104:       dont_use_ip => Bool                 # optional; disable IP-based fallback
  105:       syslog     => Bool | HashRef        # optional; Sys::Syslog integration
  106:       debug      => Bool                  # optional; enable debug logging
  107: 
  108:     Returns: CGI::Lingua blessed hashref, or a clone when called on an object.
  109: 
  110: =head3 MESSAGES
  111: 
  112:     "You must give a list of supported languages"  - no 'supported' key provided
  113:     "List of supported languages must be an array ref" - supported is wrong ref type
  114:     "Supported languages must be the short code"  - string too short or too long
  115:     "Logger must be a blessed object with warn/info/error methods" - bad logger arg
  116: 
  117: =head3 PSEUDOCODE
  118: 
  119:     1. Normalise args via Params::Get and Object::Configure
  120:     2. Validate logger (must be blessed with warn/info/error) if provided
  121:     3. Validate supported (required, string or arrayref)
  122:     4. If cache and REMOTE_ADDR set, attempt to thaw a previously stored state
  123:     5. Bless and return fresh object with sentinel flags set to GEO_UNKNOWN
  124: 
  125: =cut
  126: 
  127: sub new
  128: {
●129 → 133 → 150  129: 	my $class = shift;
  130: 	my $params = Params::Get::get_params('supported', @_);
  131: 
  132: 	# Handle ::new() misuse
  133: 	if(!defined($class)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  134: 		if($params) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  135: 			if(my $logger = $params->{'logger'}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  136: 				$logger->error(__PACKAGE__ . ' use ->new() not ::new() to instantiate');
  137: 			}
  138: 			Carp::croak(__PACKAGE__ . ' use ->new() not ::new() to instantiate');
  139: 		}
  140: 		$class = __PACKAGE__;
  141: 	} elsif(ref($class)) {
  142: 		# Clone: overlay new params onto existing object state
  143: 		$params->{_supported} ||= $params->{supported} if defined $params->{'supported'};
  144: 		return bless { %{$class}, %{$params} }, ref($class);

  Mutants (Total: 2, Killed: 2, Survived: 0)
  145: 	}
  146: 
  147: 	# Validate blessed logger objects before Object::Configure runs.
  148: 	# Non-blessed values (arrayrefs, hashrefs) are valid config forms that
  149: 	# Object::Configure knows how to convert into a Log::Abstraction instance.
●150 → 150 → 160  150: 	if(defined $params->{'logger'} && blessed($params->{'logger'})) {

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

  Mutants (Total: 1, Killed: 1, Survived: 0)
  152: 			$params->{'logger'}->can('warn')
  153: 			&& $params->{'logger'}->can('info')
  154: 			&& $params->{'logger'}->can('error')
  155: 		) {
  156: 			Carp::croak('Logger must be a blessed object with warn/info/error methods');
  157: 		}
  158: 	}
  159: 
●160 → 164 → 180  160: 	$params = Object::Configure::configure($class, $params);
  161: 
  162: 	# Normalise supported / supported_languages alias
  163: 	$params->{'supported'} ||= $params->{'supported_languages'};
  164: 	if(defined($params->{supported})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  165: 		# Validate supported type/length
  166: 		if(ref($params->{supported})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  167: 			if(ref($params->{supported}) ne 'ARRAY') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  168: 				Carp::croak('List of supported languages must be an array ref');
  169: 			}
  170: 		} elsif((length($params->{supported}) < 2) || (length($params->{supported}) > 5)) {

  Mutants (Total: 6, Killed: 6, Survived: 0)
  171: 			Carp::croak('Supported languages must be the short code');
  172: 		}
  173: 	} else {
  174: 		if(my $logger = $params->{'logger'}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  175: 			$logger->error('You must give a list of supported languages');
  176: 		}
  177: 		Carp::croak('You must give a list of supported languages');
  178: 	}
  179: 
●180 → 184 → 206  180: 	my $cache = $params->{cache};
  181: 	my $info  = $params->{info};
  182: 
  183: 	# Try to restore a frozen state from the cache before doing any work
  184: 	if($cache && $ENV{'REMOTE_ADDR'}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  185: 		my $key = _build_cache_key($ENV{'REMOTE_ADDR'}, $params, $class, $info);
  186: 		if(my $rc = $cache->get($key)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  187: 			$rc = Storable::thaw($rc);
  188: 			# Re-inject transient/non-serialisable fields
  189: 			$rc->{logger}           = $params->{'logger'};
  190: 			$rc->{_syslog}          = $params->{syslog};
  191: 			$rc->{_cache}           = $cache;
  192: 			$rc->{_supported}       = $params->{supported};
  193: 			$rc->{_info}            = $info;
  194: 			$rc->{_have_ipcountry}  = $GEO_UNKNOWN;
  195: 			$rc->{_have_geoip}      = $GEO_UNKNOWN;
  196: 			$rc->{_have_geoipfree}  = $GEO_UNKNOWN;
  197: 
  198: 			# If lang= CGI param is active, the cached language choice may be stale
  199: 			if(($rc->{_what_language} || $rc->{_rlanguage}) && $info && $info->lang()) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  200: 				delete @{$rc}{qw(_what_language _rlanguage _country)};
  201: 			}
  202: 			return $rc;

  Mutants (Total: 2, Killed: 2, Survived: 0)
  203: 		}
  204: 	}
  205: 
  206: 	return bless {

  Mutants (Total: 2, Killed: 2, Survived: 0)
  207: 		%{$params},
  208: 		_supported => ref($params->{supported}) ? $params->{supported} : [ $params->{'supported'} ],
  209: 		_cache           => $cache,
  210: 		_info            => $info,
  211: 		_syslog          => $params->{syslog},
  212: 		_dont_use_ip     => $params->{dont_use_ip} || 0,
  213: 		_have_ipcountry  => $GEO_UNKNOWN,
  214: 		_have_geoip      => $GEO_UNKNOWN,
  215: 		_have_geoipfree  => $GEO_UNKNOWN,
  216: 		_debug           => $params->{debug} || 0,
  217: 	}, $class;
  218: }
  219: 
  220: # ── _build_cache_key ──────────────────────────────────────────────────────────
  221: # Purpose:      Produce a deterministic string key for the per-request cache
  222: #               entry stored in new() and DESTROY().
  223: # Entry:        $addr  — IP string (not yet taint-checked; used read-only here)
  224: #               $params — constructor params hashref
  225: #               $class  — package name
  226: #               $info   — optional CGI::Info object
  227: # Exit:         A plain string key of the form "ip/lang/lang1/lang2/..."
  228: sub _build_cache_key
  229: {
●230 → 237 → 248  230: 	my ($addr, $params, $class, $info) = @_;
  231: 
  232: 	my $key = "$addr/";
  233: 
  234: 	# Include the requested language (if determinable) so different
  235: 	# Accept-Language values get distinct cache slots for the same IP.
  236: 	my $l;
  237: 	if($info && ($l = $info->lang())) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  238: 		$key .= "$l/";
  239: 	} elsif($l = $class->_what_language()) {
  240: 		$key .= "$l/";
  241: 	}
  242: 
  243: 	# Fix: was ref($params->{'supported'} eq 'ARRAY') — eq was inside ref(),
  244: 	# so ref() always received a boolean (1 or ''), never the arrayref itself.
  245: 	# Result: arrayref-supported always fell through to the else branch and
  246: 	# stringified to 'ARRAY(0x...)' — a different address every request —
  247: 	# making cache lookups in new() permanently fail.
●248 → 248 → 254  248: 	if(ref($params->{'supported'}) eq 'ARRAY') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  249: 		$key .= join('/', @{$params->{supported}});
  250: 	} else {
  251: 		$key .= $params->{'supported'};
  252: 	}
  253: 
  254: 	return $key;

  Mutants (Total: 2, Killed: 2, Survived: 0)
  255: }
  256: 
  257: # Some of the information takes a long time to work out, so cache what we can
  258: sub DESTROY {
●259 → 259 → 262  259: 	if(defined($^V) && ($^V ge 'v5.14.0')) {

					

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

  260: 		return if ${^GLOBAL_PHASE} eq 'DESTRUCT';
  261: 	}
  262: 	return unless $ENV{'REMOTE_ADDR'};
  263: 
  264: 	my $self = shift;
  265: 	return unless ref($self);
  266: 
  267: 	my $cache = $self->{_cache};
  268: 	return unless $cache;
  269: 
  270: 	my $key = _build_cache_key(
  271: 		$ENV{'REMOTE_ADDR'},
  272: 		{ supported => $self->{_supported} },
  273: 		ref($self),
  274: 		$self->{_info},
  275: 	);
  276: 	return if $cache->get($key);
  277: 
  278: 	$self->_debug("Storing self in cache as $key");
  279: 
  280: 	# Freeze only the computed state — not loggers, file handles, or
  281: 	# geo-module objects (they are re-initialised on next construction).
  282: 	my $copy = bless {
  283: 		_slanguage              => $self->{_slanguage},
  284: 		_slanguage_code_alpha2  => $self->{_slanguage_code_alpha2},
  285: 		_sublanguage_code_alpha2 => $self->{_sublanguage_code_alpha2},
  286: 		_country                => $self->{_country},
  287: 		_rlanguage              => $self->{_rlanguage},
  288: 		_dont_use_ip            => $self->{_dont_use_ip},
  289: 		_have_ipcountry         => $self->{_have_ipcountry},
  290: 		_have_geoip             => $self->{_have_geoip},
  291: 		_have_geoipfree         => $self->{_have_geoipfree},
  292: 	}, ref($self);
  293: 
  294: 	$cache->set($key, Storable::nfreeze($copy), $CACHE_TTL_LONG);
  295: }
  296: 
  297: =head2 language
  298: 
  299: Tells the CGI application in what language to display its messages.
  300: The language is the natural name e.g. 'English' or 'Japanese'.
  301: 
  302: Sublanguages are handled sensibly, so that if a client requests U.S. English
  303: on a site that only serves British English, language() will return 'English'.
  304: 
  305: If none of the requested languages is included within the supported lists,
  306: language() returns 'Unknown'.
  307: 
  308: =head3 API SPECIFICATION
  309: 
  310:     Input:  none beyond $self
  311:     Returns: Str - human-readable language name, or 'Unknown'
  312: 
  313: =cut
  314: 
  315: sub language {
  316: 	my $self = $_[0];
  317: 
  318: 	$self->_find_language() unless $self->{_slanguage};
  319: 	return $self->{_slanguage};

  Mutants (Total: 2, Killed: 2, Survived: 0)
  320: }
  321: 
  322: =head2 preferred_language
  323: 
  324: Same as language().
  325: 
  326: =cut
  327: 
  328: sub preferred_language
  329: {
  330: 	my $self = shift;
  331: 	return $self->language(@_);

  Mutants (Total: 2, Killed: 2, Survived: 0)
  332: }
  333: 
  334: =head2 name
  335: 
  336: Synonym for language, for compatibility with Locale::Object::Language.
  337: 
  338: =cut
  339: 
  340: sub name {
  341: 	my $self = $_[0];
  342: 	return $self->language();

  Mutants (Total: 2, Killed: 2, Survived: 0)
  343: }
  344: 
  345: =head2 sublanguage
  346: 
  347: Tells the CGI what variant to use e.g. 'United Kingdom', or undef if
  348: it can't be determined.
  349: 
  350: =head3 API SPECIFICATION
  351: 
  352:     Input:  none beyond $self
  353:     Returns: Str | undef
  354: 
  355: =cut
  356: 
  357: sub sublanguage {
  358: 	my $self = $_[0];
  359: 
  360: 	$self->_trace('Entered sublanguage');
  361: 	$self->_find_language() unless $self->{_slanguage};
  362: 	$self->_trace('Leaving sublanguage ', ($self->{_sublanguage} || 'undef'));
  363: 	return $self->{_sublanguage};

  Mutants (Total: 2, Killed: 2, Survived: 0)
  364: }
  365: 
  366: =head2 language_code_alpha2
  367: 
  368: Gives the two-character representation of the supported language, e.g. 'en'
  369: when you've asked for en-gb.
  370: 
  371: If none of the requested languages is included within the supported lists,
  372: language_code_alpha2() returns undef.
  373: 
  374: =head3 API SPECIFICATION
  375: 
  376:     Input:  none beyond $self
  377:     Returns: Str (2 chars) | undef
  378: 
  379: =cut
  380: 
  381: sub language_code_alpha2 {
  382: 	my $self = $_[0];
  383: 
  384: 	$self->_trace('Entered language_code_alpha2');
  385: 	$self->_find_language() unless $self->{_slanguage};
  386: 	$self->_trace('language_code_alpha2 returns ', $self->{_slanguage_code_alpha2});
  387: 	return $self->{_slanguage_code_alpha2};

  Mutants (Total: 2, Killed: 2, Survived: 0)
  388: }
  389: 
  390: =head2 code_alpha2
  391: 
  392: Synonym for language_code_alpha2, kept for historical reasons.
  393: 
  394: =cut
  395: 
  396: sub code_alpha2 {
  397: 	my $self = $_[0];
  398: 	return $self->language_code_alpha2();

  Mutants (Total: 2, Killed: 2, Survived: 0)
  399: }
  400: 
  401: =head2 sublanguage_code_alpha2
  402: 
  403: Gives the two-character representation of the supported language, e.g. 'gb'
  404: when you've asked for en-gb, or undef.
  405: 
  406: =head3 API SPECIFICATION
  407: 
  408:     Input:  none beyond $self
  409:     Returns: Str (2 chars) | undef
  410: 
  411: =cut
  412: 
  413: sub sublanguage_code_alpha2 {
  414: 	my $self = $_[0];
  415: 
  416: 	$self->_find_language() unless $self->{_slanguage};
  417: 	return $self->{_sublanguage_code_alpha2};

  Mutants (Total: 2, Killed: 2, Survived: 0)
  418: }
  419: 
  420: =head2 requested_language
  421: 
  422: Gives a human-readable rendition of what language the user asked for whether
  423: or not it is supported.
  424: 
  425: Returns the sublanguage (if appropriate) in parentheses,
  426: e.g. "English (United Kingdom)"
  427: 
  428: =head3 API SPECIFICATION
  429: 
  430:     Input:  none beyond $self
  431:     Returns: Str - e.g. "English (United Kingdom)" or "Unknown"
  432: 
  433: =cut
  434: 
  435: sub requested_language {
  436: 	my $self = $_[0];
  437: 
  438: 	$self->_find_language() unless $self->{_rlanguage};
  439: 	return $self->{_rlanguage};

  Mutants (Total: 2, Killed: 2, Survived: 0)
  440: }
  441: 
  442: # ── _find_language ─────────────────────────────────────────────────────────
  443: # Purpose:      Populate _slanguage, _rlanguage, _sublanguage, and the
  444: #               various code fields by working through the detection pipeline:
  445: #               Accept-Language header → I18N::AcceptLanguage → IP country.
  446: # Entry:        $self->{_slanguage} must be undef (guards repeated calls).
  447: # Exit:         $self->{_slanguage} is set to a language name or 'Unknown'.
  448: # Side Effects: Populates _rlanguage, _sublanguage, *_code_alpha2 fields.
  449: sub _find_language
  450: {
●451 → 459 → 512  451: 	my $self = shift;
  452: 
  453: 	$self->_trace('Entered _find_language');
  454: 
  455: 	$self->{_rlanguage} = 'Unknown';
  456: 	$self->{_slanguage} = 'Unknown';
  457: 
  458: 	my $http_accept_language = $self->_what_language();
  459: 	if(defined($http_accept_language)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  460: 		$self->_debug(
  461: 			"language wanted: $http_accept_language, "
  462: 			. 'languages supported: '
  463: 			. join(', ', @{$self->{_supported}} // '')
  464: 		);
  465: 
  466: 		# Normalise the deprecated en-uk tag that some browsers send
  467: 		if($http_accept_language eq $DEPRECATED_EN_UK) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  468: 			$self->_debug("Resetting country code to GB for $http_accept_language");
  469: 			$http_accept_language = $CANONICAL_EN_GB;
  470: 		}
  471: 
  472: 		# Run the header through the Accept-Language resolver
  473: 		my ($l, $requested_sublanguage) =
  474: 			$self->_accept_language_match($http_accept_language);
  475: 
  476: 		# Resolve the matched code to a full language/sublanguage
  477: 		if($l) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  478: 			return if $self->_resolve_match($l, $requested_sublanguage, $http_accept_language);
  479: 		} elsif($http_accept_language =~ /;/) {
  480: 			# e.g. de-DE,de;q=0.9,en-US;q=0.8 and we support none of those
  481: 			$self->_notice(
  482: 				__PACKAGE__, ': ', __LINE__,
  483: 				": couldn't honour HTTP_ACCEPT_LANGUAGE=$http_accept_language,"
  484: 				. ' supported languages are: '
  485: 				. join(',', @{$self->{_supported}})
  486: 			);
  487: 		}
  488: 
  489: 		# Detected slanguage but rlanguage still Unknown — try I18N::LangTags
  490: 		if($self->{_slanguage} && ($self->{_slanguage} ne 'Unknown')) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  491: 			if($self->{_rlanguage} eq 'Unknown') {

					

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

  492: 				$self->{_rlanguage} = I18N::LangTags::Detect::detect();
  493: 			}
  494: 			if($self->{_rlanguage}) {

					

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

  495: 				if(my $resolved = $self->_code2language($self->{_rlanguage})) {

					

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

  496: 					$self->{_rlanguage} = $resolved;
  497: 				}
  498: 				return;
  499: 			}
  500: 		}
  501: 
  502: 		# Last-chance: 2-char or xx-xx header where we have no match
  503: 		if(

					

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

  504: 			((!$self->{_rlanguage}) || ($self->{_rlanguage} eq 'Unknown'))
  505: 			&& ((length($http_accept_language) == 2) || ($http_accept_language =~ /^..-..$/))

					

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

  506: 		) {
  507: 			$self->{_rlanguage} = $self->_code2language($http_accept_language) || 'Unknown';
  508: 		}
  509: 		$self->{_slanguage} = 'Unknown';
  510: 	}
  511: 
  512: 	return if $self->{_dont_use_ip};
  513: 
  514: 	# Fall back to the official language of the visitor's country
  515: 	$self->_find_language_from_ip($http_accept_language);
  516: }
  517: 
  518: # ── _accept_language_match ────────────────────────────────────────────────
  519: # Purpose:      Run I18N::AcceptLanguage strict matching plus two fallback
  520: #               left-to-right scan passes against $self->{_supported}.
  521: # Entry:        $http_accept_language — validated, untainted Accept-Language value.
  522: # Exit:         Returns ($matched_code, $requested_sublanguage) or (undef, undef).
  523: # Side Effects: Logs debug messages.
  524: sub _accept_language_match
  525: {
●526 → 538 → 543  526: 	my ($self, $http_accept_language) = @_;
  527: 
  528: 	# Suppress I18N::AcceptLanguage's uninitialized-value warnings (RT 74338)
  529: 	local $SIG{__WARN__} = sub {
  530: 		warn $_[0] unless $_[0] =~ /^Use of uninitialized value/;
  531: 	};
  532: 	my $i18n = I18N::AcceptLanguage->new(debug => $self->{_debug}, strict => 1);
  533: 	my $l = $i18n->accepts($http_accept_language, $self->{_supported});
  534: 	local $SIG{__WARN__} = 'DEFAULT';
  535: 
  536: 	# I18N-AcceptLanguage strict mode can return a sublanguage variant when
  537: 	# the request contains a sublanguage we don't support; force a retry.
  538: 	if($l && ($http_accept_language =~ /-/) && ($http_accept_language !~ qr/$l/i)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  539: 		$self->_debug('Forcing fallback');
  540: 		undef $l;
  541: 	}
  542: 
●543 → 544 → 557  543: 	my $requested_sublanguage;
  544: 	if(!$l) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  545: 		# Sort tokens by q-value once; both scan passes share the ordered list
  546: 		my $sorted = $self->_sorted_tokens($http_accept_language);
  547: 		# First fallback: scan for xx-yy pairs, try base language xx
  548: 		($l, $requested_sublanguage) =
  549: 			$self->_scan_sublanguage_pairs($i18n, $sorted);
  550: 		if(!$l) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  551: 			# Second fallback: scan plain tokens without sublanguages
  552: 			$l = $self->_scan_plain_tokens($i18n, $sorted);
  553: 			undef $requested_sublanguage if $l;
  554: 		}
  555: 	}
  556: 
  557: 	return ($l, $requested_sublanguage);
  558: }
  559: 
  560: # ── _sorted_tokens ────────────────────────────────────────────────────────
  561: # Purpose:      Parse an Accept-Language header into tokens sorted by
  562: #               descending quality value so fallback scans honour q= priority.
  563: # Entry:        $header — validated Accept-Language string.
  564: # Exit:         Arrayref of [$language_tag, $quality] pairs, highest q first.
  565: # Side Effects: None.
  566: sub _sorted_tokens
  567: {
●568 → 570 → 579  568: 	my ($self, $header) = @_;
  569: 	my @tokens;
  570: 	for my $token (split /,/, $header) {
  571: 		$token =~ s/^\s+|\s+$//g;
  572: 		my $q = 1.0;
  573: 		if($token =~ s/;\s*q\s*=\s*(\d+(?:\.\d+)?)//) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  574: 			$q = $1 + 0;
  575: 		}
  576: 		$token =~ s/^\s+|\s+$//g;
  577: 		push @tokens, [$token, $q] if length $token;
  578: 	}
  579: 	return [sort { $b->[1] <=> $a->[1] } @tokens];
  580: }
  581: 
  582: # ── _scan_sublanguage_pairs ───────────────────────────────────────────────
  583: # Purpose:      Walk q-sorted tokens looking for xx-yy pairs; try accepting
  584: #               the base language xx from the supported list.
  585: # Entry:        $i18n — I18N::AcceptLanguage instance;
  586: #               $sorted — arrayref from _sorted_tokens.
  587: # Exit:         ($matched_code, $sublanguage_code) or (undef, undef).
  588: # Side Effects: Debug logging.
  589: sub _scan_sublanguage_pairs
  590: {
●591 → 594 → 604  591: 	my ($self, $i18n, $sorted) = @_;
  592: 
  593: 	$self->_debug(__PACKAGE__, ': ', __LINE__, ': scan q-sorted tokens for xx-yy pairs');
  594: 	for my $entry (@{$sorted}) {
  595: 		my ($tag) = @{$entry};
  596: 		next unless $tag =~ /^(..)-(..)$/;
  597: 		my ($base, $sub) = ($1, $2);
  598: 		$self->_debug(__PACKAGE__, ': ', __LINE__, ": see if $base is supported");
  599: 		if($i18n->accepts($base, $self->{_supported})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  600: 			$self->_debug("Fallback to $base as sublanguage $sub is not supported");
  601: 			return ($base, $sub);
  602: 		}
  603: 	}
  604: 	return (undef, undef);
  605: }
  606: 
  607: # ── _scan_plain_tokens ────────────────────────────────────────────────────
  608: # Purpose:      Walk q-sorted tokens that have no sublanguage suffix and try
  609: #               accepting each against the supported list.
  610: # Entry:        $i18n — I18N::AcceptLanguage instance;
  611: #               $sorted — arrayref from _sorted_tokens.
  612: # Exit:         Matched code string, or undef.
  613: # Side Effects: Debug logging.
  614: sub _scan_plain_tokens
  615: {
●616 → 619 → 628  616: 	my ($self, $i18n, $sorted) = @_;
  617: 
  618: 	$self->_debug(__PACKAGE__, ': ', __LINE__, ': scan q-sorted tokens for plain alternatives');
  619: 	for my $entry (@{$sorted}) {
  620: 		my ($tag) = @{$entry};
  621: 		next if $tag =~ /^..-../;    # already tried in the pair scan
  622: 		$self->_debug(__PACKAGE__, ': ', __LINE__, ": see if $tag is supported");
  623: 		if($i18n->accepts($tag, $self->{_supported})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  624: 			$self->_debug("Fallback to $tag as best alternative");
  625: 			return $tag;

  Mutants (Total: 2, Killed: 2, Survived: 0)
  626: 		}
  627: 	}
  628: 	return undef;

					

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

  629: }
  630: 
  631: # ── _resolve_match ────────────────────────────────────────────────────────
  632: # Purpose:      Given a matched code $l (possibly xx or xx-yy), populate all
  633: #               of _slanguage, _rlanguage, _sublanguage and their code fields.
  634: # Entry:        $l — 2-char or xx-yy language code; $requested_sublanguage —
  635: #               2-char variety code or undef; $http_accept_language — full header.
  636: # Exit:         Returns true (1) if the caller should return immediately.
  637: # Side Effects: Mutates $self->{_slanguage}, _rlanguage, _sublanguage, etc.
  638: sub _resolve_match
  639: {
●640 → 644 → 651  640: 	my ($self, $l, $requested_sublanguage, $http_accept_language) = @_;
  641: 
  642: 	$self->_debug("l: $l");
  643: 
  644: 	if($l !~ /^..-../) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  645: 		# Base-language match (e.g. 'en') — no sublanguage component
  646: 		return $self->_resolve_base_match($l, $requested_sublanguage, $http_accept_language);

  Mutants (Total: 2, Killed: 2, Survived: 0)
  647: 	} elsif($l =~ /(.+)-(..)$/) {
  648: 		# Sublanguage match (e.g. 'en-gb') — resolve both language and variant
  649: 		return $self->_resolve_sublanguage_match($l, $1, $2, $http_accept_language);

					

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

  650: 	}
  651: 	return 0;

					

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

  652: }
  653: 
  654: # ── _resolve_base_match ───────────────────────────────────────────────────
  655: # Purpose:      Handle the case where a base-language code matched (no hyphen).
  656: #               Sets _slanguage, _rlanguage; appends sublanguage name to rlanguage
  657: #               when the client requested one we don't support.
  658: # Entry:        $l — 2-char code; $requested_sublanguage — optional; $header.
  659: # Exit:         1 to signal caller should return, 0 otherwise.
  660: # Side Effects: Mutates slanguage, rlanguage, slanguage_code_alpha2.
  661: sub _resolve_base_match
  662: {
●663 → 674 → 683  663: 	my ($self, $l, $requested_sublanguage, $header) = @_;
  664: 
  665: 	$self->{_slanguage} = $self->_code2language($l);
  666: 	return 0 unless $self->{_slanguage};

  Mutants (Total: 2, Killed: 2, Survived: 0)
  667: 
  668: 	$self->_debug("_slanguage: $self->{_slanguage}");
  669: 	$self->{_slanguage_code_alpha2} = $l;
  670: 	$self->{_rlanguage}             = $self->{_slanguage};
  671: 
  672: 	# Attempt to name the sublanguage the client actually asked for
  673: 	my $sl;
  674: 	if($header =~ /..-(..)$/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  675: 		$self->_debug($1);
  676: 		$sl = $self->_code2country($1);
  677: 		$requested_sublanguage //= $1;
  678: 	} elsif($header =~ /..-([a-z]{2,3})$/i) {
  679: 		eval { $sl = Locale::Object::Country->new(code_alpha3 => $1) };
  680: 		$self->_info($@) if $@;
  681: 	}
  682: 
●683 → 683 → 692  683: 	if($sl) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  684: 		$self->{_rlanguage} .= ' (' . $sl->name() . ')';
  685: 	} elsif($requested_sublanguage) {
  686: 		if(my $c = $self->_code2countryname($requested_sublanguage)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  687: 			$self->{_rlanguage} .= " ($c)";
  688: 		} else {
  689: 			$self->{_rlanguage} .= " (Unknown: $requested_sublanguage)";
  690: 		}
  691: 	}
  692: 	return 1;

  Mutants (Total: 2, Killed: 2, Survived: 0)
  693: }
  694: 
  695: # ── _resolve_sublanguage_match ────────────────────────────────────────────
  696: # Purpose:      Handle the case where the full xx-yy code matched in the
  697: #               supported list.  Resolves the variety name and caches results.
  698: # Entry:        $l — full code e.g. 'en-gb'; $alpha2 — 'en'; $variety — 'gb';
  699: #               $header — full Accept-Language value.
  700: # Exit:         1 to signal caller should return, 0 otherwise.
  701: # Side Effects: Mutates _slanguage, _rlanguage, _sublanguage and code fields;
  702: #               writes to cache.
  703: sub _resolve_sublanguage_match
  704: {
●705 → 711 → 766  705: 	my ($self, $l, $alpha2, $variety, $header) = @_;
  706: 
  707: 	my $i18n    = I18N::AcceptLanguage->new(strict => 1);
  708: 	my $accepts = $i18n->accepts($l, $self->{_supported});
  709: 	$self->_debug("accepts = $accepts");
  710: 
  711: 	if($accepts) {

					

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

  712: 		$self->_debug("accepts: $accepts");
  713: 
  714: 		if($accepts =~ /\-/) {

					

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

  715: 			delete $self->{_slanguage};
  716: 		} else {
  717: 			# Cache look-up for the base-language name
  718: 			my $from_cache;
  719: 			if($self->{_cache}) {

					

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

  720: 				$from_cache = $self->{_cache}->get($CACHE_NS . "accepts:$accepts");
  721: 			}
  722: 			my $slanguage;
  723: 			if($from_cache) {

					

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

  724: 				$self->_debug("$accepts is in cache as $from_cache");
  725: 				$slanguage = (split(/=/, $from_cache))[0];
  726: 			} else {
  727: 				$slanguage = $self->_code2language($accepts);
  728: 			}
  729: 
  730: 			if($slanguage) {

					

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

  731: 				$self->{_slanguage} = $slanguage;
  732: 
  733: 				# Normalise deprecated en-uk variety
  734: 				if($variety eq 'uk') {

					

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

  735: 					$self->_warn({ warning => "Resetting country code to GB for $header" });
  736: 					$variety = 'gb';
  737: 				}
  738: 
  739: 				if(defined(my $c = $self->_code2countryname($variety))) {

					

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

  740: 					$self->_debug(__PACKAGE__, ': ', __LINE__, ":  setting sublanguage to $c");
  741: 					$self->{_sublanguage} = $c;
  742: 				}
  743: 				$self->{_slanguage_code_alpha2}   = $accepts;
  744: 				$self->{_sublanguage_code_alpha2}  = $variety;
  745: 
  746: 				if($self->{_sublanguage}) {

					

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

  747: 					$self->{_rlanguage} = "$self->{_slanguage} ($self->{_sublanguage})";
  748: 					$self->_debug(__PACKAGE__, ': ', __LINE__, ": _rlanguage: $self->{_rlanguage}");
  749: 				}
  750: 
  751: 				unless($from_cache) {

					

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

  752: 					$self->_debug("Set $variety to $slanguage=$accepts");
  753: 					$self->{_cache}->set(
  754: 						$CACHE_NS . "accepts:$variety",
  755: 						"$slanguage=$accepts",
  756: 						$CACHE_TTL_LONG
  757: 					) if $self->{_cache};
  758: 				}
  759: 				return 1;

					

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

  760: 			}
  761: 		}
  762: 	}
  763: 
  764: 	# Accepts returned something but we couldn't resolve a language name —
  765: 	# try harder using the variety code directly
●766 → 776 → 833  766: 	$self->{_rlanguage} = $self->_code2language($alpha2);
  767: 	$self->_debug("_rlanguage: $self->{_rlanguage}");
  768: 
  769: 	return 0 unless $accepts;

					

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

  770: 
  771: 	$self->_debug("http_accept_language = $header");
  772: 	$l =~ /(..)-(..)/;
  773: 	$variety = lc($2);
  774: 
  775: 	# Skip numeric/region codes like en-029
  776: 	if(($variety =~ /[a-z]{2,3}/) && !defined($self->{_sublanguage})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  777: 		$self->_get_closest($alpha2, $alpha2);
  778: 		$self->_debug("Find the country code for $variety");
  779: 
  780: 		if($variety eq 'uk') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  781: 			$self->_warn({ warning => "Resetting country code to GB for $header" });
  782: 			$variety = 'gb';
  783: 		}
  784: 
  785: 		my ($from_cache, $language_name);
  786: 		if($self->{_cache}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  787: 			$from_cache = $self->{_cache}->get($CACHE_NS . "variety:$variety");
  788: 		}
  789: 
  790: 		if(defined($from_cache)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  791: 			$self->_debug("$variety is in cache as $from_cache");
  792: 			# Cache stores "countryname=langcode" (e.g. "United Kingdom=en").
  793: 			# Splitting on = gives the country name as the first field.
  794: 			($language_name) = split(/=/, $from_cache);
  795: 		} else {
  796: 			my $db = Locale::Object::DB->new();
  797: 			my @results = @{$db->lookup(
  798: 				table         => 'country',
  799: 				result_column => 'name',
  800: 				search_column => 'code_alpha2',
  801: 				value         => $variety
  802: 			)};
  803: 			if(defined($results[0])) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  804: 				eval { $language_name = $self->_code2countryname($variety) };
  805: 			} else {
  806: 				$self->_debug("Can't find the country code for $variety in Locale::Object::DB");
  807: 			}
  808: 		}
  809: 
  810: 		if($@ || !defined($language_name)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  811: 			$self->_warn({ warning => $@ }) if $@;
  812: 			$self->_debug(__PACKAGE__, ': ', __LINE__, ': setting sublanguage to Unknown');
  813: 			$self->{_sublanguage} = 'Unknown';
  814: 			$self->_warn({ warning => "Can't determine values for $header" });
  815: 		} else {
  816: 			$self->{_sublanguage} = $language_name;
  817: 			$self->_debug('variety name ', $self->{_sublanguage});
  818: 			if($self->{_cache} && !defined($from_cache)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  819: 				# Store "countryname=langcode" so future cache hits return the country
  820: 				# name in the first field.  Previously this stored the language name
  821: 				# ("English=en" for en-gb) which was wrong — the cache-hit branch
  822: 				# split on = and used the first field as the sublanguage (country) name.
  823: 				$self->_debug("Set variety:$variety to $language_name=$self->{_slanguage_code_alpha2}");
  824: 				$self->{_cache}->set(
  825: 					$CACHE_NS . "variety:$variety",
  826: 					"$language_name=$self->{_slanguage_code_alpha2}",
  827: 					$CACHE_TTL_LONG
  828: 				);
  829: 			}
  830: 		}
  831: 	}
  832: 
●833 → 833 → 838  833: 	if(defined($self->{_sublanguage})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  834: 		$self->{_rlanguage} = "$self->{_slanguage} ($self->{_sublanguage})";
  835: 		$self->{_sublanguage_code_alpha2} = $variety;
  836: 		return 1;

					

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

  837: 	}
  838: 	return 0;

					

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

  839: }
  840: 
  841: # ── _find_language_from_ip ────────────────────────────────────────────────
  842: # Purpose:      Fall back to the visitor's IP country when the Accept-Language
  843: #               header produced no usable match.  Looks up the official language
  844: #               of the country and checks it against the supported list.
  845: # Entry:        $http_accept_language — may be undef if no header was present.
  846: # Exit:         Mutates _slanguage, _rlanguage via _get_closest if a match found.
  847: # Side Effects: Calls country(); may write to cache.
  848: sub _find_language_from_ip
  849: {
●850 → 855 → 862  850: 	my ($self, $http_accept_language) = @_;
  851: 
  852: 	my $country = $self->country();
  853: 
  854: 	# If country() returned nothing, try to derive from the LANG env var
  855: 	if(!defined($country) && (my $c = $self->_what_language())) {

					

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

  856: 		if($c =~ /^(..)_(..)/) {

					

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

  857: 			$country = $2;
  858: 		} elsif($c =~ /^(..)$/) {
  859: 			$country = $1;
  860: 		}
  861: 	}
●862 → 867 → 871  862: 	return unless defined $country;
  863: 
  864: 	$self->_debug("country: $country");
  865: 
  866: 	my ($language_name, $language_code2, $from_cache);
  867: 	if($self->{_cache}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  868: 		$from_cache = $self->{_cache}->get($CACHE_NS . 'language_name:' . $country);
  869: 	}
  870: 
●871 → 871 → 886  871: 	if($from_cache) {

					

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

  872: 		$self->_debug("$country is in cache as $from_cache");
  873: 		($language_name, $language_code2) = split(/=/, $from_cache);
  874: 	} else {
  875: 		my $l = $self->_code2country(uc($country));
  876: 		if($l) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  877: 			$l = ($l->languages_official)[0];
  878: 			if(defined $l) {

					

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

  879: 				$language_name  = $l->name;
  880: 				$language_code2 = $l->code_alpha2;
  881: 				$self->_debug("Official language: $language_name") if $language_name;
  882: 			}
  883: 		}
  884: 	}
  885: 
●886 → 889 → 893  886: 	my $ip = $ENV{'REMOTE_ADDR'};
  887: 	return unless $language_name;
  888: 
  889: 	if((!defined($self->{_rlanguage})) || ($self->{_rlanguage} eq 'Unknown')) {

					

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

  890: 		$self->{_rlanguage} = $language_name;
  891: 	}
  892: 
●893 → 893 → 938  893: 	unless((exists $self->{_slanguage}) && ($self->{_slanguage} ne 'Unknown')) {

					

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

  894: 		my $code;
  895: 
  896: 		if($language_name && $language_code2 && !defined($http_accept_language)) {

					

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

  897: 			# Fast-path for search engines that hit with no Accept-Language
  898: 			$self->_debug("Fast assign to $language_code2");
  899: 			$code = $language_code2;
  900: 		} else {
  901: 			$self->_debug("Call language2code on $self->{_rlanguage}");
  902: 			$code = Locale::Language::language2code($self->{_rlanguage});
  903: 
  904: 			unless($code) {

					

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

  905: 				if($http_accept_language && ($http_accept_language ne $self->{_rlanguage})) {

					

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

  906: 					$self->_debug("Call language2code on $http_accept_language");
  907: 					$code = Locale::Language::language2code($http_accept_language);
  908: 				}
  909: 				unless($code) {

					

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

  910: 					# Norwegian (Nynorsk) — strip the parenthetical qualifier
  911: 					if($self->{_rlanguage} =~ /(.+)\s\(.+/) {

					

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

  912: 						if((!defined($http_accept_language)) || ($1 ne $self->{_rlanguage})) {

					

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

  913: 							$self->_debug("Call language2code on $1");
  914: 							$code = Locale::Language::language2code($1);
  915: 						}
  916: 					}
  917: 					unless($code) {

					

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

  918: 						$self->_warn({
  919: 							warning => "Can't determine code from IP $ip for requested language $self->{_rlanguage}"
  920: 						});
  921: 					}
  922: 				}
  923: 			}
  924: 		}
  925: 
  926: 		if($code) {

					

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

  927: 			$self->_get_closest($code, $language_code2);
  928: 			unless($self->{_slanguage}) {

					

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

  929: 				$self->_warn({
  930: 					warning => "Couldn't determine closest language for $language_name in $self->{_supported}"
  931: 				});
  932: 			} else {
  933: 				$self->_debug("language set to $self->{_slanguage}, code set to $code");
  934: 			}
  935: 		}
  936: 	}
  937: 
●938 → 938 → 0  938: 	if(!defined($self->{_slanguage_code_alpha2})) {

					

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

  939: 		$self->_debug("Can't determine slanguage_code_alpha2");
  940: 	} elsif(!defined($from_cache) && $self->{_cache} && defined($self->{_slanguage_code_alpha2})) {
  941: 		$self->_debug("Set $country to $language_name=$self->{_slanguage_code_alpha2}");
  942: 		$self->{_cache}->set(
  943: 			$CACHE_NS . 'language_name:' . $country,
  944: 			"$language_name=$self->{_slanguage_code_alpha2}",
  945: 			$CACHE_TTL_LONG
  946: 		);
  947: 	}
  948: }
  949: 
  950: # ── _get_closest ─────────────────────────────────────────────────────────
  951: # Purpose:      If $language_string matches the base language of any supported
  952: #               entry, set _slanguage and _slanguage_code_alpha2.
  953: # Entry:        $language_string — base code e.g. 'en'; $alpha2 — same or variant.
  954: # Exit:         Mutates _slanguage and _slanguage_code_alpha2 on match.
  955: sub _get_closest
  956: {
●957 → 963 → 0  957: 	my ($self, $language_string, $alpha2) = @_;
  958: 
  959: 	# Map each supported entry to its base language code
  960: 	my %base_languages =
  961: 		map { /^(.+)-/ ? ($1 => $_) : ($_ => $_) } @{$self->{_supported}};
  962: 
  963: 	if(exists $base_languages{$language_string}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  964: 		$self->{_slanguage}             = $self->{_rlanguage};
  965: 		$self->{_slanguage_code_alpha2} = $alpha2;
  966: 	}
  967: }
  968: 
  969: # ── _what_language ────────────────────────────────────────────────────────
  970: # Purpose:      Return the raw (validated, untainted) Accept-Language string,
  971: #               consulting in priority order: cached value, CGI lang= param,
  972: #               HTTP_ACCEPT_LANGUAGE env var, LANG env var (local/debug mode).
  973: # Entry:        May be called as a class method (no $self->{...} access) or
  974: #               as an object method.
  975: # Exit:         A validated language string, or undef if nothing available.
  976: # Side Effects: Caches result in $self->{_what_language} on object calls.
  977: sub _what_language {
●978 → 980 → 994  978: 	my $self = $_[0];
  979: 
  980: 	if(ref($self)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  981: 		$self->_trace('Entered _what_language');
  982: 		if($self->{_what_language}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  983: 			$self->_trace('_what_language: returning cached value: ', $self->{_what_language});
  984: 			return $self->{_what_language};

  Mutants (Total: 2, Killed: 2, Survived: 0)
  985: 		}
  986: 		if(my $info = $self->{_info}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  987: 			if(my $rc = $info->lang()) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  988: 				$self->_trace("_what_language set language to $rc from the lang argument");
  989: 				return $self->{_what_language} = $rc;

  Mutants (Total: 2, Killed: 2, Survived: 0)
  990: 			}
  991: 		}
  992: 	}
  993: 
●994 → 994 → 1007  994: 	if(my $raw_lang = $ENV{'HTTP_ACCEPT_LANGUAGE'}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  995: 		# Validate and untaint — RFC 7231 §5.3.5 character set plus * wildcard
  996: 		if($raw_lang =~ /^([A-Za-z0-9\-,;=.*\s]{1,$ACCEPT_LANG_MAX})$/a) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  997: 			my $rc = $1;    # untainted
  998: 			if(ref($self)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  999: 				return $self->{_what_language} = $rc;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1000: 			}
 1001: 			return $rc;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1002: 		} elsif(ref($self)) {
 1003: 			$self->_warn({ warning => 'HTTP_ACCEPT_LANGUAGE contains invalid characters; ignoring' });
 1004: 		}
 1005: 	}
 1006: 
●1007 → 1007 → 1023 1007: 	if(defined($ENV{'LANG'})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1008: 		# Running locally (debug mode) — derive from system locale.
 1009: 		# Apply the same untainting discipline as HTTP_ACCEPT_LANGUAGE: only
 1010: 		# alphanumeric, hyphen, underscore, and dot are legitimate in a POSIX
 1011: 		# locale name (e.g. "en_US.UTF-8", "de_DE", "ja").  Anything else is
 1012: 		# either malformed or an injection attempt; discard it silently.
 1013: 		if($ENV{'LANG'} =~ /^([A-Za-z0-9_.\-]{1,$ACCEPT_LANG_MAX})$/a) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1014: 			my $rc = $1;    # untainted
 1015: 			if(ref($self)) {

					

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

 1016: 				return $self->{_what_language} = $rc;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1017: 			}
 1018: 			return $rc;

					

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

 1019: 		} elsif(ref($self)) {
 1020: 			$self->_warn({ warning => 'LANG contains invalid characters; ignoring' });
 1021: 		}
 1022: 	}
 1023: 	return;
 1024: }
 1025: 
 1026: =head2 country
 1027: 
 1028: Returns the two-character country code of the remote end in lowercase.
 1029: 
 1030: If L<IP::Country>, L<Geo::IPfree> or L<Geo::IP> is installed,
 1031: CGI::Lingua will make use of that, otherwise, it will do a Whois lookup.
 1032: If you do not have any of those installed I recommend you use the
 1033: caching capability of CGI::Lingua.
 1034: 
 1035: =head3 API SPECIFICATION
 1036: 
 1037:     Input:  none beyond $self
 1038:     Returns: Str (2 lowercase chars) | undef
 1039:       'Unknown' is only returned in the Baidu-EU special case via _handle_eu_country.
 1040: 
 1041: =head3 MESSAGES
 1042: 
 1043:     "GEOIP_COUNTRY_CODE contains an invalid country code; ignoring"
 1044:     "HTTP_CF_IPCOUNTRY contains an invalid country code; ignoring"
 1045:     "X.X.X.X isn't a valid IP address"
 1046:     "Can't determine country from LAN connection X"
 1047:     "Can't determine country from loopback connection X"
 1048:     "cache contains a numeric country: N"
 1049:     "IP matches to a numeric country"
 1050: 
 1051: =cut
 1052: 
 1053: sub country {
●1054 → 1059 → 1065 1054: 	my $self = shift;
 1055: 
 1056: 	$self->_trace(__PACKAGE__, ': Entered country()');
 1057: 
 1058: 	# Return cached result immediately (but see FIXME below about undef caching)
 1059: 	if($self->{_country}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1060: 		$self->_trace('quick return: ', $self->{_country});
 1061: 		return $self->{_country};

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1062: 	}
 1063: 
 1064: 	# mod_geoip: validate against ISO 3166-1 alpha-2 before trusting
●1065 → 1065 → 1075 1065: 	if(defined($ENV{'GEOIP_COUNTRY_CODE'})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1066: 		if($ENV{'GEOIP_COUNTRY_CODE'} =~ /^([A-Z]{2})$/a) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1067: 			$self->{_country} = lc($1);
 1068: 			return $self->{_country};

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1069: 		} else {
 1070: 			$self->_warn({ warning => 'GEOIP_COUNTRY_CODE contains an invalid country code; ignoring' });
 1071: 		}
 1072: 	}
 1073: 
 1074: 	# Cloudflare: 'XX' means Cloudflare couldn't determine country — skip it
●1075 → 1075 → 1084 1075: 	if(($ENV{'HTTP_CF_IPCOUNTRY'}) && ($ENV{'HTTP_CF_IPCOUNTRY'} ne 'XX')) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1076: 		if($ENV{'HTTP_CF_IPCOUNTRY'} =~ /^([A-Z]{2})$/a) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1077: 			$self->{_country} = lc($1);
 1078: 			return $self->{_country};

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1079: 		} else {
 1080: 			$self->_warn({ warning => 'HTTP_CF_IPCOUNTRY contains an invalid country code; ignoring' });
 1081: 		}
 1082: 	}
 1083: 
●1084 → 1089 → 1098 1084: 	my $raw_ip = $ENV{'REMOTE_ADDR'};
 1085: 	return unless defined $raw_ip;
 1086: 
 1087: 	# Validate and untaint the IP address before passing to any geo module
 1088: 	my $ip;
 1089: 	if($raw_ip =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/a) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1090: 		$ip = $1;    # untainted IPv4
 1091: 	} elsif($raw_ip =~ /^([0-9a-fA-F:]{2,39}|[0-9a-fA-F:]{2,30}:(?:\d{1,3}\.){3}\d{1,3})$/a) {
 1092: 		$ip = $1;    # untainted IPv6, including mixed notation (e.g. ::ffff:192.0.2.1)
 1093: 	} else {
 1094: 		$self->_warn({ warning => "$raw_ip isn't a valid IP address" });
 1095: 		return;
 1096: 	}
 1097: 
●1098 → 1101 → 1112 1098: 	require Data::Validate::IP;
 1099: 	Data::Validate::IP->import();
 1100: 
 1101: 	if(!is_ipv4($ip)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1102: 		$self->_debug("$ip isn't IPv4. Is it IPv6?");
 1103: 		if($ip eq '::1') {

					

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

 1104: 			$ip = '127.0.0.1';    # normalise loopback
 1105: 		} elsif($ip =~ /^::ffff:(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/i) {
 1106: 			$ip = $1;             # normalise IPv4-mapped IPv6 (::ffff:a.b.c.d) to plain IPv4
 1107: 		} elsif(!is_ipv6($ip)) {
 1108: 			$self->_warn({ warning => "$ip isn't a valid IP address" });
 1109: 			return;
 1110: 		}
 1111: 	}
●1112 → 1112 → 1116 1112: 	if(is_private_ip($ip)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1113: 		$self->_debug("Can't determine country from LAN connection $ip");
 1114: 		return;
 1115: 	}
●1116 → 1116 → 1122 1116: 	if(is_loopback_ip($ip)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1117: 		$self->_debug("Can't determine country from loopback connection $ip");
 1118: 		return;
 1119: 	}
 1120: 
 1121: 	# Cache look-up — skip for LAN/loopback (already returned above)
●1122 → 1122 → 1138 1122: 	if($self->{_cache}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1123: 		$self->{_country} = $self->{_cache}->get($CACHE_NS . "country:$ip");
 1124: 		if(defined($self->{_country})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1125: 			if($self->{_country} !~ /\D/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1126: 				$self->_warn({ warning => 'cache contains a numeric country: ' . $self->{_country} });
 1127: 				$self->{_cache}->remove($CACHE_NS . "country:$ip");
 1128: 				delete $self->{_country};
 1129: 			} else {
 1130: 				$self->_debug("Get $ip from cache = $self->{_country}");
 1131: 				return $self->{_country};

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1132: 			}
 1133: 		}
 1134: 		$self->_debug("$ip isn't in the cache");
 1135: 	}
 1136: 
 1137: 	# Try IP::Country first (fastest, local database)
●1138 → 1138 → 1147 1138: 	if($self->{_have_ipcountry} == $GEO_UNKNOWN) {

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1139: 		if(eval { require IP::Country }) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1140: 			IP::Country->import();
 1141: 			$self->{_have_ipcountry} = $GEO_PRESENT;
 1142: 			$self->{_ipcountry}      = IP::Country::Fast->new();
 1143: 		} else {
 1144: 			$self->{_have_ipcountry} = $GEO_ABSENT;
 1145: 		}
 1146: 	}
●1147 → 1149 → 1159 1147: 	$self->_debug("have_ipcountry $self->{_have_ipcountry}");
 1148: 
 1149: 	if($self->{_have_ipcountry}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1150: 		$self->{_country} = $self->{_ipcountry}->inet_atocc($ip);
 1151: 		if($self->{_country}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1152: 			$self->{_country} = lc($self->{_country});
 1153: 		} elsif(is_ipv4($ip)) {
 1154: 			$self->_debug("$ip is not known by IP::Country");
 1155: 		}
 1156: 	}
 1157: 
 1158: 	# Try Geo::IP if IP::Country gave nothing
●1159 → 1159 → 1188 1159: 	unless(defined($self->{_country})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1160: 		if($self->{_have_geoip} == $GEO_UNKNOWN) {

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1161: 			$self->_load_geoip();
 1162: 		}
 1163: 		if($self->{_have_geoip} == $GEO_PRESENT) {

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1164: 			$self->{_country} = $self->{_geoip}->country_code_by_addr($ip);
 1165: 		}
 1166: 
 1167: 		# Geo::IPfree has a known-broken entry for $BROKEN_GEOIPFREE
 1168: 		if(!defined($self->{_country}) && ($ip ne $BROKEN_GEOIPFREE)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1169: 			if($self->{_have_geoipfree} == $GEO_UNKNOWN) {

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1170: 				eval { require Geo::IPfree };
 1171: 				unless($@) {

					

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

 1172: 					Geo::IPfree::IP->import();
 1173: 					$self->{_have_geoipfree} = $GEO_PRESENT;
 1174: 					$self->{_geoipfree}      = Geo::IPfree->new();
 1175: 				} else {
 1176: 					$self->{_have_geoipfree} = $GEO_ABSENT;
 1177: 				}
 1178: 			}
 1179: 			if($self->{_have_geoipfree} == $GEO_PRESENT) {

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1180: 				if(my $country = ($self->{_geoipfree}->LookUp($ip))[0]) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1181: 					$self->{_country} = lc($country);
 1182: 				}
 1183: 			}
 1184: 		}
 1185: 	}
 1186: 
 1187: 	# 'eu' is not a real country — discard
●1188 → 1188 → 1193 1188: 	if($self->{_country} && ($self->{_country} eq 'eu')) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1189: 		delete $self->{_country};
 1190: 	}
 1191: 
 1192: 	# Remote JSON lookup via geoplugin
●1193 → 1193 → 1206 1193: 	if((!$self->{_country}) &&

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1194: 	   (eval { require LWP::Simple::WithCache; require JSON::Parse })) {
 1195: 		$self->_debug("Look up $ip on geoplugin");
 1196: 		LWP::Simple::WithCache->import();
 1197: 		JSON::Parse->import();
 1198: 
 1199: 		if(my $data = LWP::Simple::WithCache::get("http://www.geoplugin.net/json.gp?ip=$ip")) {

					

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

 1200: 			eval { $self->{_country} = JSON::Parse::parse_json($data)->{'geoplugin_countryCode'} };
 1201: 			$self->_warn({ warning => "geoplugin returned unparseable JSON: $@" }) if $@;
 1202: 		}
 1203: 	}
 1204: 
 1205: 	# Last resort: Whois
●1206 → 1206 → 1211 1206: 	unless($self->{_country}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1207: 		$self->_resolve_country_via_whois($ip);
 1208: 	}
 1209: 
 1210: 	# Sanitise and normalise whatever we found
●1211 → 1211 → 1239 1211: 	if($self->{_country}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1212: 		if($self->{_country} !~ /\D/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1213: 			$self->_warn({ warning => 'IP matches to a numeric country' });
 1214: 			delete $self->{_country};
 1215: 		} else {
 1216: 			$self->{_country} = lc($self->{_country});
 1217: 
 1218: 			# Legacy mappings
 1219: 			if($self->{_country} eq 'hk') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1220: 				$self->{_country} = 'cn';    # HK is no longer a separate country in Whois
 1221: 			} elsif($self->{_country} eq 'eu') {
 1222: 				$self->_handle_eu_country($ip);
 1223: 			}
 1224: 
 1225: 			if($self->{_country} && ($self->{_country} !~ /\D/)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1226: 				$self->_warn({ warning => "cache contains a numeric country: $self->{_country}" });
 1227: 				delete $self->{_country};
 1228: 			} elsif($self->{_country} && $self->{_cache}) {
 1229: 				$self->_debug("Set $ip to $self->{_country}");
 1230: 				$self->{_cache}->set(
 1231: 					$CACHE_NS . "country:$ip",
 1232: 					$self->{_country},
 1233: 					$CACHE_TTL_SHORT
 1234: 				);
 1235: 			}
 1236: 		}
 1237: 	}
 1238: 
 1239: 	return $self->{_country};

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1240: }
 1241: 
 1242: # ── _resolve_country_via_whois ─────────────────────────────────────────────
 1243: # Purpose:      Attempt Net::Whois::IP then Net::Whois::IANA as a last resort.
 1244: # Entry:        $ip — validated, untainted IP string.
 1245: # Exit:         Sets $self->{_country} if a result was found.
 1246: # Side Effects: Network I/O; logs debug messages.
 1247: sub _resolve_country_via_whois
 1248: {
●1249 → 1263 → 1279 1249: 	my ($self, $ip) = @_;
 1250: 
 1251: 	$self->_debug("Look up $ip on Whois");
 1252: 
 1253: 	require Net::Whois::IP;
 1254: 	Net::Whois::IP->import();
 1255: 
 1256: 	my $whois;
 1257: 	eval {
 1258: 		# Catch connection timeouts by converting Carp::carp into a die
 1259: 		local $SIG{__WARN__} = sub { die $_[0] };
 1260: 		$whois = Net::Whois::IP::whoisip_query($ip);
 1261: 	};
 1262: 
 1263: 	unless($@ || !defined($whois) || (ref($whois) ne 'HASH')) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1264: 		if(defined($whois->{Country})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1265: 			$self->{_country} = $whois->{Country};
 1266: 		} elsif(defined($whois->{country})) {
 1267: 			$self->{_country} = $whois->{country};
 1268: 		}
 1269: 		if($self->{_country}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1270: 			if($self->{_country} eq 'EU') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1271: 				delete $self->{_country};
 1272: 			} elsif(($self->{_country} eq 'US') && defined($whois->{'StateProv'}) && ($whois->{'StateProv'} eq 'PR')) {
 1273: 				# RT#131347: Puerto Rico is not the US
 1274: 				$self->{_country} = 'pr';
 1275: 			}
 1276: 		}
 1277: 	}
 1278: 
●1279 → 1279 → 1289 1279: 	if($self->{_country}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1280: 		$self->_debug("Found $ip on Net::Whois::IP as ", $self->{_country});
 1281: 		# Strip carriage returns (e.g. 190.24.1.122) and trailing comments
 1282: 		$self->{_country} =~ s/[\r\n]//g;
 1283: 		if($self->{_country} =~ /^(..)\s*#/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1284: 			$self->{_country} = $1;
 1285: 		}
 1286: 		return;
 1287: 	}
 1288: 
●1289 → 1296 → 1301 1289: 	$self->_debug("Look up $ip on IANA");
 1290: 
 1291: 	require Net::Whois::IANA;
 1292: 	Net::Whois::IANA->import();
 1293: 
 1294: 	my $iana = Net::Whois::IANA->new();
 1295: 	eval { $iana->whois_query(-ip => $ip) };
 1296: 	unless($@) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1297: 		$self->{_country} = $iana->country();
 1298: 		$self->_debug("IANA reports $ip as ", $self->{_country});
 1299: 	}
 1300: 
●1301 → 1301 → 0 1301: 	if($self->{_country}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1302: 		$self->{_country} =~ s/[\r\n]//g;
 1303: 		if($self->{_country} =~ /^(..)\s*#/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1304: 			$self->{_country} = $1;
 1305: 		}
 1306: 	}
 1307: }
 1308: 
 1309: # ── _handle_eu_country ────────────────────────────────────────────────────
 1310: # Purpose:      Resolve the ambiguous 'eu' country code.  RT-86809 shows that
 1311: #               Baidu reports itself as EU when it is actually in CN.  All
 1312: #               other 'eu' addresses are logged as Unknown.
 1313: # Entry:        $ip — validated, untainted IP string.
 1314: # Exit:         Sets $self->{_country} to 'cn' or 'Unknown'.
 1315: # Side Effects: Loads Net::Subnet; writes info log entry.
 1316: sub _handle_eu_country
 1317: {
●1318 → 1323 → 0 1318: 	my ($self, $ip) = @_;
 1319: 
 1320: 	require Net::Subnet;
 1321: 	Net::Subnet->import();
 1322: 
 1323: 	if(subnet_matcher($BAIDU_SUBNET)->($ip)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1324: 		$self->{_country} = 'cn';
 1325: 	} else {
 1326: 		$self->_info("$ip has country of eu");
 1327: 		$self->{_country} = 'Unknown';
 1328: 	}
 1329: }
 1330: 
 1331: # ── _load_geoip ───────────────────────────────────────────────────────────
 1332: # Purpose:      Probe for the Geo::IP database file and the Geo::IP module;
 1333: #               set _have_geoip and initialise _geoip on success.
 1334: # Entry:        _have_geoip must be GEO_UNKNOWN.
 1335: # Exit:         _have_geoip set to GEO_PRESENT or GEO_ABSENT.
 1336: # Side Effects: Requires Geo::IP; opens GeoIP.dat.
 1337: sub _load_geoip
 1338: {
●1339 → 1349 → 1354 1339: 	my $self = shift;
 1340: 
 1341: 	# Check for the database file before even trying to load the module
 1342: 	# (avoids noisy errors on Windows — CPANTESTERS report 54117bd0)
 1343: 	my $db_present = (
 1344: 		(($^O eq 'MSWin32') && (-r 'c:/GeoIP/GeoIP.dat'))
 1345: 		|| (-r '/usr/local/share/GeoIP/GeoIP.dat')
 1346: 		|| (-r '/usr/share/GeoIP/GeoIP.dat')
 1347: 	);
 1348: 
 1349: 	unless($db_present) {

					

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

 1350: 		$self->{_have_geoip} = $GEO_ABSENT;
 1351: 		return;
 1352: 	}
 1353: 
●[NOT COVERED] 1354 → 1355 → 1360 1354: 	eval { require Geo::IP };
 1355: 	if($@) {

					

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

 1356: 		$self->{_have_geoip} = $GEO_ABSENT;
 1357: 		return;
 1358: 	}
 1359: 
●[NOT COVERED] 1360 → 1364 → 0 1360: 	Geo::IP->import();
 1361: 	$self->{_have_geoip} = $GEO_PRESENT;
 1362: 
 1363: 	# GEOIP_STANDARD = 0 (can't use the constant name directly)
 1364: 	if(-r '/usr/share/GeoIP/GeoIP.dat') {

					

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

 1365: 		$self->{_geoip} = Geo::IP->open('/usr/share/GeoIP/GeoIP.dat', 0);
 1366: 	} else {
 1367: 		$self->{_geoip} = Geo::IP->new(0);
 1368: 	}
 1369: }
 1370: 
 1371: =head2 locale
 1372: 
 1373: HTTP doesn't have a way of transmitting a browser's localisation information
 1374: which would be useful for default currency, date formatting, etc.
 1375: 
 1376: This method attempts to detect the information, but it is a best guess
 1377: and is not 100% reliable.  But it's better than nothing ;-)
 1378: 
 1379: Returns a L<Locale::Object::Country> object.
 1380: 
 1381: =head3 API SPECIFICATION
 1382: 
 1383:     Input:  none beyond $self
 1384:     Returns: Locale::Object::Country | undef
 1385: 
 1386: =cut
 1387: 
 1388: sub locale {
●1389 → 1396 → 1422 1389: 	my $self = shift;
 1390: 
 1391: 	return $self->{_locale} if $self->{_locale};

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1392: 
 1393: 	my $agent = $ENV{'HTTP_USER_AGENT'};
 1394: 
 1395: 	# First try: parse the language tag from the User-Agent parenthetical
 1396: 	if(defined($agent) && ($agent =~ /\((.+)\)/)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1397: 		foreach(split(/;/, $1)) {
 1398: 			my $candidate = $_;
 1399: 			$candidate =~ s/^\s+|\s+$//g;    # trim both ends
 1400: 
 1401: 			if($candidate =~ /^[a-zA-Z]{2}-([a-zA-Z]{2})$/) {

					

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

 1402: 				local $SIG{__WARN__} = undef;
 1403: 				if(my $c = $self->_code2country($1)) {

					

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

 1404: 					$self->{_locale} = $c;
 1405: 					return $c;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1406: 				}
 1407: 			}
 1408: 		}
 1409: 
 1410: 		# Second try: HTTP::BrowserDetect (works for more User-Agents)
 1411: 		if(eval { require HTTP::BrowserDetect }) {

					

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

 1412: 			HTTP::BrowserDetect->import();
 1413: 			my $browser = HTTP::BrowserDetect->new($agent);
 1414: 			if($browser && $browser->country() && (my $c = $self->_code2country($browser->country()))) {

					

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

 1415: 				$self->{_locale} = $c;
 1416: 				return $c;

					

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

 1417: 			}
 1418: 		}
 1419: 	}
 1420: 
 1421: 	# Third try: IP address
●1422 → 1423 → 1440 1422: 	my $country = $self->country();
 1423: 	if($country) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1424: 		$country =~ s/[\r\n]//g;
 1425: 		my $c;
 1426: 		eval {
 1427: 			local $SIG{__WARN__} = sub { die $_[0] };
 1428: 			$c = $self->_code2country($country);
 1429: 		};
 1430: 		unless($@) {

					

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

 1431: 			if($c) {

					

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

 1432: 				$self->{_locale} = $c;
 1433: 				return $c;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1434: 			}
 1435: 		}
 1436: 	}
 1437: 
 1438: 	# Fourth try: mod_geoip env var — apply the same ISO 3166-1 validation
 1439: 	# used in country() to guard against spoofed or malformed values
●1440 → 1440 → 1448 1440: 	if(defined($ENV{'GEOIP_COUNTRY_CODE'})) {

					

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

 1441: 		if($ENV{'GEOIP_COUNTRY_CODE'} =~ /^([A-Z]{2})$/a) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1442: 			if(my $c = $self->_code2country(lc($1))) {

					

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

 1443: 				$self->{_locale} = $c;
 1444: 				return $c;

					

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

 1445: 			}
 1446: 		}
 1447: 	}
 1448: 	return undef;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1449: }
 1450: 
 1451: =head2 time_zone
 1452: 
 1453: Returns the timezone of the web client.
 1454: 
 1455: If L<Geo::IP> is installed,
 1456: CGI::Lingua will make use of that, otherwise it will use L<ip-api.com>
 1457: 
 1458: =head3 API SPECIFICATION
 1459: 
 1460:     Input:  none beyond $self
 1461:     Returns: Str (IANA timezone name) | undef
 1462: 
 1463: =head3 MESSAGES
 1464: 
 1465:     "Couldn't determine the timezone"
 1466:     "LWP::Simple::WithCache and LWP::Simple are both absent; cannot contact ip-api.com"
 1467:       Returns undef rather than croaking; install either LWP variant to enable ip-api lookups.
 1468: 
 1469: =cut
 1470: 
 1471: sub time_zone {
●1472 → 1476 → 1481 1472: 	my $self = shift;
 1473: 
 1474: 	$self->_trace('Entered time_zone');
 1475: 
 1476: 	if($self->{_timezone}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1477: 		$self->_trace('quick return: ', $self->{_timezone});
 1478: 		return $self->{_timezone};

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1479: 	}
 1480: 
●1481 → 1483 → 1539 1481: 	my $raw_ip = $ENV{'REMOTE_ADDR'};
 1482: 
 1483: 	if(defined $raw_ip) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1484: 		# Untaint before any external use — kept in sync with country()'s pattern,
 1485: 		# including the mixed-notation branch for ::ffff:a.b.c.d addresses.
 1486: 		my $ip;
 1487: 		if($raw_ip =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/a) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1488: 			$ip = $1;
 1489: 		} elsif($raw_ip =~ /^([0-9a-fA-F:]{2,39}|[0-9a-fA-F:]{2,30}:(?:\d{1,3}\.){3}\d{1,3})$/a) {
 1490: 			$ip = $1;
 1491: 		} else {
 1492: 			$self->_warn({ warning => "$raw_ip isn't a valid IP address" });
 1493: 			return;
 1494: 		}
 1495: 
 1496: 		if($self->{_have_geoip} == $GEO_UNKNOWN) {

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1497: 			$self->_load_geoip();
 1498: 		}
 1499: 		if($self->{_have_geoip} == $GEO_PRESENT) {

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1500: 			eval { $self->{_timezone} = $self->{_geoip}->time_zone($ip) };
 1501: 		}
 1502: 
 1503: 		unless($self->{_timezone}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1504: 			if(eval { require LWP::Simple::WithCache; require JSON::Parse }) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1505: 				$self->_debug("Look up $ip on ip-api.com");
 1506: 				LWP::Simple::WithCache->import();
 1507: 				JSON::Parse->import();
 1508: 
 1509: 				if(my $data = LWP::Simple::WithCache::get("http://ip-api.com/json/$ip")) {

					

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

 1510: 					eval { $self->{_timezone} = JSON::Parse::parse_json($data)->{'timezone'} };
 1511: 					$self->_warn({ warning => "ip-api.com returned unparseable JSON: $@" }) if $@;
 1512: 				}
 1513: 			} elsif(eval { require LWP::Simple; require JSON::Parse }) {
 1514: 				$self->_debug("Look up $ip on ip-api.com");
 1515: 				LWP::Simple->import();
 1516: 				JSON::Parse->import();
 1517: 
 1518: 				if(my $data = LWP::Simple::get("http://ip-api.com/json/$ip")) {

					

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

 1519: 					eval { $self->{_timezone} = JSON::Parse::parse_json($data)->{'timezone'} };
 1520: 					$self->_warn({ warning => "ip-api.com returned unparseable JSON: $@" }) if $@;
 1521: 				}
 1522: 			} else {
 1523: 				# Neither LWP variant is available — degrade gracefully rather than
 1524: 				# killing the entire request with a croak; caller can check for undef.
 1525: 				$self->_warn({ warning => 'LWP::Simple::WithCache and LWP::Simple are both absent; cannot contact ip-api.com' });
 1526: 			}
 1527: 		}
 1528: 	} else {
 1529: 		# Local connection — read from /etc/timezone or DateTime::TimeZone
 1530: 		if(CORE::open(my $fin, '<', '/etc/timezone')) {

					

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

 1531: 			my $tz = <$fin>;
 1532: 			chomp $tz;
 1533: 			$self->{_timezone} = $tz;
 1534: 		} else {
 1535: 			$self->{_timezone} = DateTime::TimeZone::Local->TimeZone()->name();
 1536: 		}
 1537: 	}
 1538: 
●1539 → 1539 → 1542 1539: 	unless(defined($self->{_timezone})) {

					

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

 1540: 		$self->_warn({ warning => "Couldn't determine the timezone" });
 1541: 	}
 1542: 	return $self->{_timezone};

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1543: }
 1544: 
 1545: =head2 is_rtl
 1546: 
 1547: Returns true (1) if the negotiated language is written right-to-left, false (0)
 1548: otherwise.  Covers Arabic, Hebrew, Persian, Urdu, Yiddish, Dhivehi, Pashto,
 1549: Sindhi, Uyghur, and Kurdish.
 1550: 
 1551: =head3 API SPECIFICATION
 1552: 
 1553:     Input:  none beyond $self
 1554:     Returns: 1 | 0
 1555: 
 1556: =cut
 1557: 
 1558: sub is_rtl
 1559: {
 1560: 	my $self = shift;
 1561: 	return $RTL_LANGS{$self->language_code_alpha2() // ''} ? 1 : 0;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1562: }
 1563: 
 1564: =head2 text_direction
 1565: 
 1566: Returns C<'rtl'> or C<'ltr'> for the negotiated language, suitable for direct
 1567: use as an HTML C<dir> attribute value.
 1568: 
 1569: =head3 API SPECIFICATION
 1570: 
 1571:     Input:  none beyond $self
 1572:     Returns: 'rtl' | 'ltr'
 1573: 
 1574: =cut
 1575: 
 1576: sub text_direction
 1577: {
 1578: 	my $self = shift;
 1579: 	return $self->is_rtl() ? 'rtl' : 'ltr';

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1580: }
 1581: 
 1582: =head2 plural_category
 1583: 
 1584: Returns the CLDR plural category for the integer C<$n> in the negotiated
 1585: language.  The returned string is one of C<'zero'>, C<'one'>, C<'two'>,
 1586: C<'few'>, C<'many'>, or C<'other'>.
 1587: 
 1588: Rules are embedded for ~70 languages including Arabic (6 forms), Slavic
 1589: languages (3-4 forms), Celtic languages (up to 6 forms), and Hebrew, Maltese,
 1590: Romanian, Latvian, Lithuanian, and Slovenian.  Languages not in the table fall
 1591: back to the English rule (n == 1 => C<'one'>, else C<'other'>).
 1592: 
 1593: For fractional numbers or full CLDR v42+ accuracy, use C<Locale::CLDR>.
 1594: 
 1595: =head3 API SPECIFICATION
 1596: 
 1597:     Input:  $n - non-negative integer (fractional values are truncated)
 1598:     Returns: Str - one of zero/one/two/few/many/other
 1599: 
 1600: =cut
 1601: 
 1602: # CLDR plural category rules (https://unicode.org/cldr/charts/42/supplemental/language_plural_rules.html).
 1603: # Values are coderefs: ($n) → category string.  Languages absent from this
 1604: # table fall back to the standard one/other rule inside plural_category().
 1605: my %PLURAL_RULES = (
 1606: 
 1607: 	# ── No plural distinction (always 'other') ────────────────────────────
 1608: 	(map { $_ => sub { 'other' } }
 1609: 		qw(az bm bo dz id ig ii in ja jbo jv jw kde kea km ko lkt lo ms
 1610: 		   my nqo root sah ses sg th to vi wo yo zh)),
 1611: 
 1612: 	# ── Standard: n == 1 → 'one', else 'other' ───────────────────────────
 1613: 	(map { $_ => sub { int($_[0]) == 1 ? 'one' : 'other' } }

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1614: 		qw(af an ast bg bn brx ca cgg da de el en eo es et eu fi
 1615: 		   gl gsw gu ha haw hu ia it kcg kk kl lb lg mas ml mn mr
 1616: 		   nb nd ne nl nn nyn om or pa pap rm rof rwk saq seh sn so
 1617: 		   sq ss ssy st sv sw ta te teo tig tk tl tn ts ur wae xh xog)),
 1618: 
 1619: 	# ── French / Portuguese-BR: n ≤ 1 → 'one' ────────────────────────────
 1620: 	(map { $_ => sub { int($_[0]) <= 1 ? 'one' : 'other' } } qw(fr pt_BR)),

					

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

 1621: 
 1622: 	# ── Arabic: zero/one/two/few/many/other ───────────────────────────────
 1623: 	ar => sub {
 1624: 		my $n    = int($_[0]);
 1625: 		my $m100 = $n % 100;
 1626: 		return 'zero'  if $n == 0;

  Mutants (Total: 3, Killed: 3, Survived: 0)
 1627: 		return 'one'   if $n == 1;

  Mutants (Total: 3, Killed: 3, Survived: 0)
 1628: 		return 'two'   if $n == 2;

  Mutants (Total: 3, Killed: 3, Survived: 0)
 1629: 		return 'few'   if $m100 >= 3  && $m100 <= 10;

					

					Mutants (Total: 8, Killed: 2, Survived: 6)
					

 1630: 		return 'many'  if $m100 >= 11 && $m100 <= 99;

					

					Mutants (Total: 8, Killed: 2, Survived: 6)
					

 1631: 		return 'other';

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1632: 	},
 1633: 
 1634: 	# ── Hebrew: one/two/many/other ────────────────────────────────────────
 1635: 	he => sub {
 1636: 		my $n = int($_[0]);
 1637: 		return 'one'  if $n == 1;

					

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

 1638: 		return 'two'  if $n == 2;

					

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

 1639: 		return 'many' if $n != 0 && $n % 10 == 0;

					

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

 1640: 		return 'other';

					

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

 1641: 	},
 1642: 
 1643: 	# ── Russian / Ukrainian / Belarusian: one/few/many ────────────────────
 1644: 	(map { $_ => sub {
 1645: 		my $n    = int($_[0]);
 1646: 		my $m10  = $n % 10;
 1647: 		my $m100 = $n % 100;
 1648: 		return 'one' if $m10 == 1 && $m100 != 11;

  Mutants (Total: 4, Killed: 4, Survived: 0)
 1649: 		return 'few' if $m10 >= 2 && $m10 <= 4 && ($m100 < 10 || $m100 >= 20);

					

					Mutants (Total: 11, Killed: 8, Survived: 3)
					

 1650: 		return 'many';

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1651: 	} } qw(ru uk be)),
 1652: 
 1653: 	# ── Polish: one/few/many ──────────────────────────────────────────────
 1654: 	pl => sub {
 1655: 		my $n    = int($_[0]);
 1656: 		my $m10  = $n % 10;
 1657: 		my $m100 = $n % 100;
 1658: 		return 'one' if $n == 1;

					

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

 1659: 		return 'few' if $m10 >= 2 && $m10 <= 4 && ($m100 < 10 || $m100 >= 20);

					

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

 1660: 		return 'many';

					

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

 1661: 	},
 1662: 
 1663: 	# ── Czech / Slovak: one/few/other ────────────────────────────────────
 1664: 	(map { $_ => sub {
 1665: 		my $n = int($_[0]);
 1666: 		return 'one' if $n == 1;

					

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

 1667: 		return 'few' if $n >= 2 && $n <= 4;

					

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

 1668: 		return 'other';

					

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

 1669: 	} } qw(cs sk)),
 1670: 
 1671: 	# ── Romanian: one/few/other ───────────────────────────────────────────
 1672: 	ro => sub {
 1673: 		my $n    = int($_[0]);
 1674: 		my $m100 = $n % 100;
 1675: 		return 'one' if $n == 1;

					

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

 1676: 		return 'few' if $n == 0 || ($m100 >= 1 && $m100 <= 19);

					

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

 1677: 		return 'other';

					

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

 1678: 	},
 1679: 
 1680: 	# ── Latvian: zero/one/other ───────────────────────────────────────────
 1681: 	lv => sub {
 1682: 		my $n    = int($_[0]);
 1683: 		my $m10  = $n % 10;
 1684: 		my $m100 = $n % 100;
 1685: 		return 'zero'  if $m10 == 0 || ($m100 >= 11 && $m100 <= 19);

					

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

 1686: 		return 'one'   if $m10 == 1 && $m100 != 11;

					

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

 1687: 		return 'other';

					

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

 1688: 	},
 1689: 
 1690: 	# ── Lithuanian: one/few/other ─────────────────────────────────────────
 1691: 	lt => sub {
 1692: 		my $n    = int($_[0]);
 1693: 		my $m10  = $n % 10;
 1694: 		my $m100 = $n % 100;
 1695: 		return 'one' if $m10 == 1 && ($m100 < 10 || $m100 >= 20);

					

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

 1696: 		return 'few' if $m10 >= 2 && ($m100 < 10 || $m100 >= 20);

					

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

 1697: 		return 'other';

					

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

 1698: 	},
 1699: 
 1700: 	# ── Slovenian: one/two/few/other ──────────────────────────────────────
 1701: 	sl => sub {
 1702: 		my $m100 = int($_[0]) % 100;
 1703: 		return 'one'   if $m100 == 1;

					

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

 1704: 		return 'two'   if $m100 == 2;

					

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

 1705: 		return 'few'   if $m100 == 3 || $m100 == 4;

					

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

 1706: 		return 'other';

					

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

 1707: 	},
 1708: 
 1709: 	# ── Welsh: zero/one/two/few/many/other ───────────────────────────────
 1710: 	cy => sub {
 1711: 		my $n = int($_[0]);
 1712: 		return 'zero'  if $n == 0;

					

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

 1713: 		return 'one'   if $n == 1;

					

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

 1714: 		return 'two'   if $n == 2;

					

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

 1715: 		return 'few'   if $n == 3;

					

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

 1716: 		return 'many'  if $n == 6;

					

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

 1717: 		return 'other';

					

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

 1718: 	},
 1719: 
 1720: 	# ── Irish: one/two/few/many/other ────────────────────────────────────
 1721: 	ga => sub {
 1722: 		my $n = int($_[0]);
 1723: 		return 'one'  if $n == 1;

					

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

 1724: 		return 'two'  if $n == 2;

					

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

 1725: 		return 'few'  if $n >= 3 && $n <= 6;

					

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

 1726: 		return 'many' if $n >= 7 && $n <= 10;

					

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

 1727: 		return 'other';

					

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

 1728: 	},
 1729: 
 1730: 	# ── Maltese: one/two/few/many/other ──────────────────────────────────
 1731: 	mt => sub {
 1732: 		my $n    = int($_[0]);
 1733: 		my $m100 = $n % 100;
 1734: 		return 'one'  if $n == 1;

					

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

 1735: 		return 'two'  if $n == 2;

					

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

 1736: 		return 'few'  if $n == 0 || ($m100 >= 3  && $m100 <= 10);

					

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

 1737: 		return 'many' if $m100 >= 11 && $m100 <= 19;

					

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

 1738: 		return 'other';

					

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

 1739: 	},
 1740: );
 1741: 
 1742: sub plural_category
 1743: {
 1744: 	my ($self, $n) = @_;
 1745: 	my $code = $self->language_code_alpha2() // return 'other';
 1746: 	my $rule = $PLURAL_RULES{$code} // sub { int($_[0]) == 1 ? 'one' : 'other' };

					

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

 1747: 	return $rule->($n);

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1748: }
 1749: 
 1750: =head2 translation_file
 1751: 
 1752: Returns the filesystem path to the best matching translation file for the
 1753: negotiated language in the given directory.
 1754: 
 1755: The lookup tries (in order):
 1756: 
 1757: =over 4
 1758: 
 1759: =item 1. C<$dir/$lang-$sublang.$ext>  (e.g. C<en-gb.json>)
 1760: 
 1761: =item 2. C<$dir/$lang.$ext>           (e.g. C<en.json>)
 1762: 
 1763: =back
 1764: 
 1765: Returns C<undef> if no matching file exists.
 1766: 
 1767: =head3 API SPECIFICATION
 1768: 
 1769:     Input:
 1770:       $dir - Str   path to the directory containing translation files
 1771:       $ext - Str   file extension without leading dot (default: 'json')
 1772:     Returns: Str (absolute or relative path) | undef
 1773: 
 1774: =head3 MESSAGES
 1775: 
 1776:     (none - returns undef silently when no file is found)
 1777: 
 1778: =cut
 1779: 
 1780: sub translation_file
 1781: {
●1782 → 1788 → 1791 1782: 	my ($self, $dir, $ext) = @_;
 1783: 	return unless defined $dir;
 1784: 	$ext //= 'json';
 1785: 	$ext =~ s/^\.//;    # accept '.json' or 'json'
 1786: 
 1787: 	my @candidates;
 1788: 	if(my $sub = $self->sublanguage_code_alpha2()) {

					

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

 1789: 		push @candidates, $self->language_code_alpha2() . '-' . $sub;
 1790: 	}
●1791 → 1794 → 1798 1791: 	push @candidates, $self->language_code_alpha2()
 1792: 		if defined $self->language_code_alpha2();
 1793: 
 1794: 	for my $code (@candidates) {
 1795: 		my $path = "$dir/$code.$ext";
 1796: 		return $path if -e $path;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1797: 	}
 1798: 	return;
 1799: }
 1800: 
 1801: # ── _code2language ────────────────────────────────────────────────────────
 1802: # Purpose:      Translate a 2-char language code to its English name, with
 1803: #               optional CHI caching.
 1804: # Entry:        $code — 2-char ISO 639-1 code; must be defined and non-empty.
 1805: # Exit:         Human-readable language name string, or undef.
 1806: # Side Effects: Reads/writes cache.
 1807: sub _code2language
 1808: {
●1809 → 1812 → 1818 1809: 	my ($self, $code) = @_;
 1810: 
 1811: 	return unless $code;
 1812: 	if(defined($self->{_country})) {

					

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

 1813: 		$self->_debug("_code2language $code, country ", $self->{_country});
 1814: 	} else {
 1815: 		$self->_debug("_code2language $code");
 1816: 	}
 1817: 
●1818 → 1818 → 1822 1818: 	unless($self->{_cache}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1819: 		return Locale::Language::code2language($code);

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1820: 	}
 1821: 
●1822 → 1822 → 1829 1822: 	if(my $from_cache = $self->{_cache}->get($CACHE_NS . "code2language:$code")) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1823: 		$self->_trace("_code2language found in cache $from_cache");
 1824: 		return $from_cache;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1825: 	}
 1826: 
 1827: 	# Compute, cache, then return the value separately —
 1828: 	# CHI->set() is not guaranteed to return the stored value across all drivers
●1829 → 1831 → 1834 1829: 	$self->_trace('_code2language not in cache, storing');
 1830: 	my $name = Locale::Language::code2language($code);
 1831: 	if(defined $name) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1832: 		$self->{_cache}->set($CACHE_NS . "code2language:$code", $name, $CACHE_TTL_LONG);
 1833: 	}
 1834: 	return $name;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1835: }
 1836: 
 1837: # ── _code2country ─────────────────────────────────────────────────────────
 1838: # Purpose:      Translate a 2-char country code to a Locale::Object::Country
 1839: #               object, suppressing the expected "No result found" warning.
 1840: # Entry:        $code — 2-char ISO 3166-1 alpha-2 code (any case).
 1841: # Exit:         Locale::Object::Country object, or undef.
 1842: # Side Effects: None beyond the Locale::Object::Country look-up.
 1843: sub _code2country
 1844: {
●1845 → 1848 → 1854 1845: 	my ($self, $code) = @_;
 1846: 
 1847: 	return unless $code;
 1848: 	if($self->{_country}) {

					

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

 1849: 		$self->_trace(">_code2country $code, country ", $self->{_country});
 1850: 	} else {
 1851: 		$self->_trace(">_code2country $code");
 1852: 	}
 1853: 
 1854: 	my $rc;
 1855: 	{
 1856: 		# Scope the signal handler tightly — only suppress the one known-harmless warning
 1857: 		local $SIG{__WARN__} = sub {
 1858: 			warn $_[0] unless $_[0] =~ /No result found in country table/;
 1859: 		};
 1860: 		$rc = Locale::Object::Country->new(code_alpha2 => $code);
 1861: 	}
 1862: 	$self->_trace('<_code2country ', $code || 'undef');
 1863: 	return $rc;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1864: }
 1865: 
 1866: # ── _code2countryname ─────────────────────────────────────────────────────
 1867: # Purpose:      Translate a 2-char country code to its English name string,
 1868: #               with optional CHI caching.
 1869: # Entry:        $code — 2-char ISO 3166-1 alpha-2 code.
 1870: # Exit:         Country name string, or undef.
 1871: # Side Effects: Reads/writes cache.
 1872: sub _code2countryname
 1873: {
●1874 → 1879 → 1884 1874: 	my ($self, $code) = @_;
 1875: 
 1876: 	return unless $code;
 1877: 	$self->_trace(">_code2countryname $code");
 1878: 
 1879: 	unless($self->{_cache}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1880: 		my $country = $self->_code2country($code);
 1881: 		return defined($country) ? $country->name : undef;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1882: 	}
 1883: 
●1884 → 1884 → 1889 1884: 	if(my $from_cache = $self->{_cache}->get($CACHE_NS . "code2countryname:$code")) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1885: 		$self->_trace("_code2countryname found in cache $from_cache");
 1886: 		return $from_cache;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1887: 	}
 1888: 
●1889 → 1889 → 1897 1889: 	if(my $country = $self->_code2country($code)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1890: 		$self->_debug('_code2countryname not in cache, storing');
 1891: 		my $name = $country->name();
 1892: 		$self->_trace('<_code2countryname ', $name);
 1893: 		# Store then return explicitly — don't rely on set() return value
 1894: 		$self->{_cache}->set($CACHE_NS . "code2countryname:$code", $name, $CACHE_TTL_LONG);
 1895: 		return $name;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1896: 	}
 1897: 	$self->_trace('<_code2countryname undef');
 1898: 	return undef;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1899: }
 1900: 
 1901: # ── _log ──────────────────────────────────────────────────────────────────
 1902: # Purpose:      Append a message to $self->{messages} and forward to the
 1903: #               optional logger object.
 1904: # Entry:        $level — log level string (debug/info/notice/warn/trace/error);
 1905: #               @messages — one or more strings to concatenate.
 1906: # Exit:         void
 1907: # Side Effects: Mutates $self->{messages}; calls logger method if set.
 1908: sub _log
 1909: {
●1910 → 1918 → 0 1910: 	my ($self, $level, @messages) = @_;
 1911: 
 1912: 	return unless ref($self) && scalar(@messages);
 1913: 
 1914: 	my $text = join('', grep defined, @messages);
 1915: 	return unless length($text);
 1916: 	push @{$self->{'messages'}}, { level => $level, message => $text };
 1917: 
 1918: 	if(my $logger = $self->{'logger'}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1919: 		$logger->$level($text);
 1920: 	}
 1921: }
 1922: 
 1923: sub _debug  { my $self = shift; $self->_log('debug',  @_) }
 1924: sub _info   { my $self = shift; $self->_log('info',   @_) }
 1925: sub _notice { my $self = shift; $self->_log('notice', @_) }
 1926: sub _trace  { my $self = shift; $self->_log('trace',  @_) }
 1927: 
 1928: # ── _warn ─────────────────────────────────────────────────────────────────
 1929: # Purpose:      Emit a warning through the logger (if set) or via Carp::carp.
 1930: # Entry:        A single hashref argument: { warning => 'message text' }.
 1931: #               All callers MUST use this structured form — plain-string calls
 1932: #               silently lose the message when no logger is configured.
 1933: # Exit:         void
 1934: # Side Effects: Calls logger->warn() or Carp::carp().
 1935: sub _warn
 1936: {
●1937 → 1938 → 0 1937: 	my $self = shift;
 1938: 	if(defined($self->{'logger'})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1939: 		# Logger gets the warning text as a plain string, not a data structure
 1940: 		my $params = Params::Get::get_params('warning', @_);
 1941: 		$self->{'logger'}->warn($params->{'warning'} // join('', grep defined, @_));
 1942: 	} else {
 1943: 		my $params = Params::Get::get_params('warning', @_);
 1944: 		my $msg    = $params->{'warning'} // join('', grep defined, @_);
 1945: 		$self->_log('warn', $msg);
 1946: 		Carp::carp($msg);
 1947: 	}
 1948: }
 1949: 
 1950: =head1 LIMITATIONS
 1951: 
 1952: =over 4
 1953: 
 1954: =item * B<is_rtl() covers primary-script RTL languages only>
 1955: 
 1956: C<is_rtl()> returns true for the 10 ISO 639-1 codes whose overwhelmingly
 1957: dominant script is right-to-left.  Languages with script variants (e.g.
 1958: Azerbaijani C<az>, which uses Latin in modern Azerbaijan but Arabic in Iran)
 1959: are treated as LTR.  If you serve content in multiple scripts of the same
 1960: language, inspect the sublanguage or Accept-Language header directly.
 1961: 
 1962: =item * B<plural_category() uses embedded CLDR rules, not Locale::CLDR>
 1963: 
 1964: The embedded rules cover ~70 languages and truncate fractional C<$n> to an
 1965: integer.  For full CLDR v42 accuracy (including fractional forms and
 1966: languages not in the table) install and use C<Locale::CLDR> directly.
 1967: 
 1968: =item * B<Logger must be a blessed object>
 1969: 
 1970: The C<logger> parameter is documented as accepting a code ref, array ref, or
 1971: filename, but the current implementation calls C<< $logger->$level() >> and will
 1972: die on non-blessed values.  Wrap alternative logger types in a
 1973: C<Log::Abstraction> instance before passing them to C<new()>.
 1974: 
 1975: =item * B<es-419 sublanguage returns undef>
 1976: 
 1977: Three-part regional codes such as C<es-419> (Latin American Spanish) do not
 1978: resolve to a C<sublanguage()> value because ISO 3166-1 does not define '419'.
 1979: This is a known limitation of the Locale::Object layer.
 1980: 
 1981: =item * B<Whois lookups are slow and unreliable>
 1982: 
 1983: Without C<IP::Country>, C<Geo::IP>, or C<Geo::IPfree> installed, C<country()>
 1984: falls back to Whois queries against live RIPE/ARIN/IANA servers.  These can
 1985: time out under load.  Install at least one local geo-database module and enable
 1986: the CHI cache to avoid this.
 1987: 
 1988: =item * B<Sub::Private not yet enforced>
 1989: 
 1990: The C<_*> private methods are currently accessible from outside the package.
 1991: C<Sub::Private> should be added to enforce encapsulation once white-box tests
 1992: are updated to call only the public API.
 1993: 
 1994: =item * B<IPv4-mapped IPv6 addresses are normalised to IPv4>
 1995: 
 1996: C<REMOTE_ADDR> values in the form C<::ffff:a.b.c.d> (RFC 4291 section 2.5.5)
 1997: are silently rewritten to the embedded C<a.b.c.d> IPv4 address before any
 1998: geo-lookup.  This is correct for country detection purposes but means the raw
 1999: address string is not preserved in cache keys or log messages.
 2000: 
 2001: =item * B<EU country code is irresolvable (with one exception)>
 2002: 
 2003: IP addresses that Whois reports as country C<EU> are mapped to C<'Unknown'>
 2004: unless they fall within Baidu's known subnet (RT-86809).  There is no ISO
 2005: 3166-1 country code for the European Union.
 2006: 
 2007: =back
 2008: 
 2009: =head1 AUTHOR
 2010: 
 2011: Nigel Horne, C<< <njh at nigelhorne.com> >>
 2012: 
 2013: =head1 BUGS
 2014: 
 2015: Please report any bugs or feature requests to the author.
 2016: 
 2017: If C<HTTP_ACCEPT_LANGUAGE> contains a sub-tag with a 3-digit UN M.49 region
 2018: code (e.g. C<es-419> for Latin American Spanish), C<sublanguage()> returns
 2019: C<undef> because ISO 3166-1 does not define numeric codes.
 2020: 
 2021: Please report any bugs or feature requests to C<bug-cgi-lingua at rt.cpan.org>,
 2022: or through the web interface at
 2023: L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CGI-Lingua>.
 2024: I will be notified, and then you'll
 2025: automatically be notified of progress on your bug as I make changes.
 2026: 
 2027: Uses L<I18N::AcceptLanguage> to find the highest priority accepted language.
 2028: This means that if you support languages at a lower priority, it may be missed.
 2029: 
 2030: =head1 SEE ALSO
 2031: 
 2032: =over 4
 2033: 
 2034: =item * L<Test Dashboard|https://nigelhorne.github.io/CGI-Lingua/coverage/>
 2035: 
 2036: =item * VWF - Versatile Web Framework L<https://github.com/nigelhorne/vwf>
 2037: 
 2038: =item * L<HTTP::BrowserDetect>
 2039: 
 2040: =item * L<I18N::AcceptLanguage>
 2041: 
 2042: =item * L<Locale::Country>
 2043: 
 2044: =back
 2045: 
 2046: =head1 SUPPORT
 2047: 
 2048: This module is provided as-is without any warranty.
 2049: 
 2050: You can find documentation for this module with the perldoc command.
 2051: 
 2052:     perldoc CGI::Lingua
 2053: 
 2054: You can also look for information at:
 2055: 
 2056: =over 4
 2057: 
 2058: =item * MetaCPAN
 2059: 
 2060: L<https://metacpan.org/release/CGI-Lingua>
 2061: 
 2062: =item * RT: CPAN's request tracker
 2063: 
 2064: L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=CGI-Lingua>
 2065: 
 2066: =item * CPANTS
 2067: 
 2068: L<http://cpants.cpanauthors.org/dist/CGI-Lingua>
 2069: 
 2070: =item * CPAN Testers' Matrix
 2071: 
 2072: L<http://matrix.cpantesters.org/?dist=CGI-Lingua>
 2073: 
 2074: =item * CPAN Testers Dependencies
 2075: 
 2076: L<http://deps.cpantesters.org/?module=CGI::Lingua>
 2077: 
 2078: =back
 2079: 
 2080: =encoding utf-8
 2081: 
 2082: =head1 FORMAL SPECIFICATION
 2083: 
 2084: =head2 new
 2085: 
 2086:     new : Class × Params → CGI::Lingua
 2087:     ∀ p : Params • p.supported ≠ ∅ ⟹ result.language ∈ (p.supported ∪ {'Unknown'})
 2088: 
 2089: =head2 language
 2090: 
 2091:     language : CGI::Lingua → Str
 2092:     result ∈ {name(l) | l ∈ supported} ∪ {'Unknown'}
 2093: 
 2094: =head2 is_rtl
 2095: 
 2096:     is_rtl : CGI::Lingua → Bool
 2097:     is_rtl(s) ≙ language_code_alpha2(s) ∈ RTL_LANGS
 2098: 
 2099: =head2 text_direction
 2100: 
 2101:     text_direction : CGI::Lingua → {'rtl', 'ltr'}
 2102:     text_direction(s) ≙ is_rtl(s) ? 'rtl' : 'ltr'
 2103: 
 2104: =head2 plural_category
 2105: 
 2106:     plural_category : CGI::Lingua × ℕ → PluralCategory
 2107:     plural_category(s, n) ≙ PLURAL_RULES[language_code_alpha2(s)](n)
 2108: 
 2109: =head2 translation_file
 2110: 
 2111:     translation_file : CGI::Lingua × Path × Ext → Path | undef
 2112:     translation_file(s, d, e) ≙
 2113:       first p ∈ candidates(s) • ∃ file d/p.e
 2114:       where candidates(s) = [lang(s)-sublang(s), lang(s)] \ {undef}
 2115: 
 2116: =head1 ACKNOWLEDGEMENTS
 2117: 
 2118: =head1 LICENSE AND COPYRIGHT
 2119: 
 2120: Copyright 2010-2026 Nigel Horne.
 2121: 
 2122: This program is released under the following licence: GPL2
 2123: 
 2124: =cut
 2125: 
 2126: 1; # End of CGI::Lingua