lib/CGI/Lingua.pm

Index
Structural Coverage (Approximate)

TER1 (Statement): 95.14%
TER2 (Branch): 87.63%
TER3 (LCSAJ): 98.8% (83/84)
Approximate LCSAJ segments: 599

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(:all);
    6: 
    7: use Carp ();	# fully qualified calls: nothing imported into this package
    8: use Object::Configure 0.23;
    9: use Params::Get 0.15;	# 0.15 fast-path: unblessed hashref returned directly
   10: use Readonly;
   11: use Scalar::Util ();	# fully qualified, so $obj->blessed() is not a method
   12: use JSON::PP ();
   13: use Class::Autouse qw{
   14: 	Locale::Language
   15: 	Locale::Object::Country
   16: 	Locale::Object::DB
   17: 	I18N::AcceptLanguage
   18: };
   19: 
   20: our $VERSION = '0.87';
   21: 
   22: # Post-release roadmap (from the 0.87 gap analysis).
   23: #
   24: # Upstream services
   25: # TODO: geoplugin.net has no free tier any more, so that look-up is dead code
   26: #	for nearly everyone.  Make the web providers configurable
   27: #	(geo_providers => [...]) with a built-in client for a free HTTPS
   28: #	service, or drop geoplugin.
   29: # TODO: ip-api.com is plain HTTP and limited to 45 requests a minute; answers
   30: #	are validated but can be read and altered in transit.  Allow an API key
   31: #	/ HTTPS provider and add rate limiting or back-off.
   32: # TODO: Support MaxMind GeoLite2 (GeoIP2::Database::Reader or
   33: #	IP::Geolocation::MMDB); GeoIP.dat (frozen 2019) and Geo::IPfree (known
   34: #	wrong entries) are the only local databases today.
   35: # TODO: Add a timeout option: a slow upstream holds the request for LWP's
   36: #	default of 180 seconds.
   37: #
   38: # Features
   39: # TODO: native_name() ("Francais" for French, in that language's script),
   40: #	plus bcp47() / lang_attribute() for the HTML lang attribute.
   41: # TODO: Number, currency and date formatting helpers from the negotiated
   42: #	locale (CLDR via Locale::CLDR, optional).
   43: # TODO: Script detection (zh-Hant / zh-Hans, sr-Latn) and RTL by script
   44: #	rather than by language.
   45: # TODO: Proper 3-letter and UN M.49 regions (es-419, en-029); these are the
   46: #	remaining TODO tests (t/es_419.t, t/en_029.t).
   47: # TODO: A Content-Language / Vary: Accept-Language header helper, and RFC
   48: #	4647 "lookup" fallback chains.
   49: # TODO: PSGI / Plack: middleware or a from_env(\%env) constructor that does
   50: #	not depend on %ENV, removing the "country() reads REMOTE_ADDR when
   51: #	called" pitfall.
   52: #
   53: # Technical debt
   54: # TODO: Split this file into ::Negotiate, ::Geo (one class per provider) and
   55: #	::Cache; most of the mocking pitfalls in the tests come from the
   56: #	coupling.
   57: # TODO: Replace the three geo sentinels and the two package sentinels
   58: #	($_locale_object_db_ok, $_have_dvip) with one capability probe, cached
   59: #	per process.
   60: # TODO: Enforce privacy with Sub::Private once t/function.t and
   61: #	t/extended_tests.t stop calling _-methods directly.
   62: # TODO: Structured log events (a code plus fields) instead of English
   63: #	strings, so applications can translate and filter them.
   64: # TODO: t/integration.t takes about 15 seconds because of its ~45 child
   65: #	processes; run them in parallel or reuse one child per combination.
   66: 
   67: # Gathering magic strings here makes behavioural changes one-edit operations.
   68: 
   69: Readonly my $CACHE_TTL_LONG      => '1 month';
   70: Readonly my $CACHE_TTL_SHORT     => '1 hour';
   71: Readonly my $CACHE_NS            => 'CGI::Lingua:';    # namespace prefix for every key
   72: Readonly my $BROKEN_GEOIPFREE    => '45.128.139.41';  # https://github.com/bricas/geo-ipfree/issues/10
   73: Readonly my $BAIDU_SUBNET        => '185.10.104.0/22';# RT-86809: Baidu misreports as EU
   74: Readonly my $DEPRECATED_EN_UK    => 'en-uk';          # some browsers still send this
   75: Readonly my $CANONICAL_EN_GB     => 'en-gb';
   76: Readonly my $ACCEPT_LANG_MAX     => 256;              # max bytes we accept from the header
   77: Readonly my $UA_MAX              => 512;              # max bytes we accept from HTTP_USER_AGENT
   78: Readonly my $GEO_UNKNOWN         => -1;               # geo-module sentinel: not yet probed
   79: Readonly my $GEO_ABSENT          =>  0;               # geo-module sentinel: unavailable
   80: Readonly my $GEO_PRESENT         =>  1;               # geo-module sentinel: loaded OK
   81: 
   82: # Shapes of the values CGI::Lingua keeps in the cache.  Anything read back
   83: # that does not match is treated as poisoned and discarded.  Language and
   84: # country names from Locale::Language, Locale::Codes and Locale::Object use
   85: # only these characters (e.g. "Cote D'Ivoire", "Modern Greek (1453-)",
   86: # "Falkland Islands (The) [Malvinas]"); none of them use < > " & ; / =.
   87: Readonly my $NAME_RE      => qr/^[A-Za-z][A-Za-z0-9 ,.:'()\[\]\-]{0,99}\z/a;	# ":" for "English (Unknown: zz)"
   88: Readonly my $NAME_CODE_RE => qr/^[A-Za-z][A-Za-z0-9 ,.'()\[\]\-]{0,99}=[a-z]{2,3}\z/a;
   89: Readonly my $LANG_CODE_RE => qr/^[a-z]{2,3}\z/a;
   90: Readonly my $COUNTRY_RE   => qr/^(?:[a-z]{2}|Unknown)\z/a;
   91: 
   92: # A language list from HTTP_ACCEPT_LANGUAGE or a lang= parameter: the RFC 7231
   93: # characters plus "*", spaces and tabs (never CR or LF), at most
   94: # $ACCEPT_LANG_MAX bytes.  Captures the untainted value.
   95: Readonly my $ACCEPT_LANG_RE => qr/^([A-Za-z0-9\-,;=.* \t]{1,$ACCEPT_LANG_MAX})\z/a;
   96: 
   97: # A supported-list entry: a language tag such as "en", "en-gb", "es-419" or
   98: # "zh-Hant" (an underscore is accepted for "en_gb").  "english" is not one.
   99: Readonly my $SUPPORTED_RE => qr/^[A-Za-z]{2,3}(?:[-_][A-Za-z0-9]{2,8})*\z/a;
  100: 
  101: # An IP address as accepted from REMOTE_ADDR, before Data::Validate::IP checks
  102: # it properly: dotted quad, or IPv6 including ::ffff:a.b.c.d.  Captures it.
  103: Readonly my $IP_SHAPE_RE => qr/^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}|[0-9a-fA-F:]{2,39}|[0-9a-fA-F:]{2,30}:(?:\d{1,3}\.){3}\d{1,3})\z/a;
  104: 
  105: # Fields that DESTROY saves and new() restores, with the shape each must have
  106: # time_zone(): IANA zone names (e.g. "America/New_York", "Etc/GMT+8", "UTC")
  107: Readonly my $ZONE_RE       => qr/^[A-Za-z][A-Za-z0-9_+\-\/]{0,50}\z/a;
  108: Readonly my $ZONE_FILE_MAX => 256;	# bytes read from $ZONE_FILE; a zone name is far shorter
  109: 
  110: # File holding the system time zone, read by time_zone() when there is no
  111: # REMOTE_ADDR.  A package variable (not Readonly) so tests can point it at a
  112: # hostile file with "local $CGI::Lingua::ZONE_FILE = ...".
  113: our $ZONE_FILE = '/etc/timezone';
  114: 
  115: # Where _load_geoip() looks for the legacy MaxMind GeoIP.dat used by Geo::IP;
  116: # the first readable regular file wins.  A package variable so a test or a
  117: # site can point it elsewhere ("local @CGI::Lingua::GEOIP_DAT = ...").
  118: our @GEOIP_DAT = (
  119: 	(($^O eq 'MSWin32') ? ('c:/GeoIP/GeoIP.dat') : ()),
  120: 	'/usr/share/GeoIP/GeoIP.dat',
  121: 	'/usr/local/share/GeoIP/GeoIP.dat',
  122: );
  123: 
  124: Readonly my %RESTORABLE => (
  125: 	_slanguage               => $NAME_RE,
  126: 	_rlanguage               => $NAME_RE,
  127: 	_sublanguage             => $NAME_RE,
  128: 	_slanguage_code_alpha2   => $LANG_CODE_RE,
  129: 	_sublanguage_code_alpha2 => $LANG_CODE_RE,
  130: 	_country                 => $COUNTRY_RE,
  131: );
  132: 
  133: # Package-level sentinel for Locale::Object's SQLite database.  undef = not yet
  134: # probed; 0 = database absent (Windows installers often omit it); 1 = available.
  135: # Package-level (not per-object) because the database either exists on the
  136: # filesystem or it doesn't — there is no per-request variability.
  137: my $_locale_object_db_ok;
  138: 
  139: # Package-level sentinel for Data::Validate::IP / NetAddr::IP availability.
  140: # NetAddr::IP::UtilPP fails to build on Windows (mask4to6 bad-argument error),
  141: # which cascades to Data::Validate::IP.  undef = not yet probed; 0 = broken;
  142: # 1 = available.  On first country() call we try to load the module and, if it
  143: # fails, install pure-Perl aliases for the four functions we use.
  144: my $_have_dvip;
  145: 
  146: # Short-name overrides used when Locale::Object's database is absent and we
  147: # fall back to Locale::Codes::Country.  Locale::Codes carries full ISO official
  148: # names (e.g. "United Kingdom of Great Britain and Northern Ireland") while
  149: # Locale::Object returns the common short form ("United Kingdom").  Only
  150: # entries that differ are listed; everything else comes from Locale::Codes.
  151: my %COUNTRY_SHORT_NAMES = (
  152: 	bo => 'Bolivia',
  153: 	cd => 'Democratic Republic of the Congo',
  154: 	fk => 'Falkland Islands',
  155: 	fm => 'Micronesia',
  156: 	gb => 'United Kingdom',
  157: 	ir => 'Iran',
  158: 	kp => 'North Korea',
  159: 	kr => 'South Korea',
  160: 	md => 'Moldova',
  161: 	nl => 'Netherlands',
  162: 	ps => 'Palestine',
  163: 	tw => 'Taiwan',
  164: 	tz => 'Tanzania',
  165: 	us => 'United States',
  166: 	ve => 'Venezuela',
  167: );
  168: 
  169: Readonly my %RTL_LANGS           => (map { $_ => 1 }  # ISO 639-1 codes whose primary script is RTL
  170: 	qw(ar dv fa he ku ps sd ug ur yi));
  171: 
  172: =head1 NAME
  173: 
  174: CGI::Lingua - Create a multilingual web page
  175: 
  176: =head1 VERSION
  177: 
  178: Version 0.87
  179: 
  180: =cut
  181: 
  182: =head1 SYNOPSIS
  183: 
  184: Your website tells CGI::Lingua which languages it can show.
  185: CGI::Lingua looks at what the visitor's web browser asks for,
  186: and tells your website which of its languages to use.
  187: 
  188: =head2 Pick a language for the page
  189: 
  190:     use CGI::Lingua;
  191: 
  192:     # The site has pages in English and French
  193:     my $l = CGI::Lingua->new(supported => ['en', 'fr']);
  194: 
  195:     my $language = $l->language();    # 'English', 'French' or 'Unknown'
  196:     if($language eq 'English') {
  197:         print "<p>Hello</p>\n";
  198:     } elsif($language eq 'French') {
  199:         print "<p>Bonjour</p>\n";
  200:     } else {
  201:         # The visitor wants a language that the site does not have
  202:         my $wanted = $l->requested_language();    # e.g. 'German'
  203:         print "<p>Sorry, this page is not available in $wanted.</p>\n";
  204:     }
  205: 
  206: =head2 Use the short code to choose a file or template
  207: 
  208:     my $l = CGI::Lingua->new(supported => ['en-gb', 'en-us', 'fr']);
  209: 
  210:     my $code    = $l->language_code_alpha2() // 'en';    # 'en' or 'fr'
  211:     my $variant = $l->sublanguage_code_alpha2();         # 'gb', 'us' or undef
  212:     my $template = defined($variant) ? "$code-$variant.tmpl" : "$code.tmpl";
  213: 
  214: =head2 Show different content for different countries
  215: 
  216:     my $l = CGI::Lingua->new(supported => ['en']);
  217: 
  218:     my $country = $l->country() // '';    # e.g. 'us', 'ca', 'gb'
  219:     if($country eq 'us') {
  220:         print "Call us on 1-800-555-0100\n";
  221:     } elsif($country eq 'ca') {
  222:         print "Call us on 1-888-555-0100\n";
  223:     } else {
  224:         print "Email us at help\@example.com\n";
  225:     }
  226: 
  227: =head2 Make it faster with a cache
  228: 
  229: Finding the country of an IP address can be slow.
  230: Give CGI::Lingua a L<CHI> cache so that the work is only done once
  231: for each visitor.
  232: 
  233:     use CHI;
  234:     use CGI::Lingua;
  235: 
  236:     my $cache = CHI->new(
  237:         driver    => 'File',
  238:         root_dir  => '/var/cache/myapp',
  239:         namespace => 'CGI::Lingua',
  240:     );
  241:     my $l = CGI::Lingua->new(supported => ['en', 'fr'], cache => $cache);
  242: 
  243: =head2 Let the visitor choose with a "lang" parameter
  244: 
  245: If you pass a L<CGI::Info> object, a C<lang=fr> parameter in the URL
  246: is used before the browser's settings.
  247: 
  248:     use CGI::Info;
  249:     use CGI::Lingua;
  250: 
  251:     my $info = CGI::Info->new();
  252:     my $l = CGI::Lingua->new(supported => ['en', 'fr', 'de'], info => $info);
  253:     print $l->language();    # 'German' for https://example.com/page?lang=de
  254: 
  255: =head2 Set the HTML "lang" and "dir" attributes
  256: 
  257:     my $l = CGI::Lingua->new(supported => ['en', 'ar', 'he']);
  258:     my $code = $l->language_code_alpha2() // 'en';
  259:     printf qq{<html lang="%s" dir="%s">\n}, $code, $l->text_direction();
  260:     # <html lang="ar" dir="rtl"> for an Arabic-speaking visitor
  261: 
  262: =head2 Choose the right plural form
  263: 
  264:     my $l = CGI::Lingua->new(supported => ['en', 'ru']);
  265:     my %messages = (
  266:         one  => '%d file',
  267:         few  => '%d files (few)',
  268:         many => '%d files (many)',
  269:         other => '%d files',
  270:     );
  271:     my $n = 3;
  272:     printf $messages{$l->plural_category($n)} . "\n", $n;
  273: 
  274: =head2 Load a translation file
  275: 
  276:     # Looks for /var/www/i18n/en-gb.json, then /var/www/i18n/en.json
  277:     my $l = CGI::Lingua->new(supported => ['en-gb', 'en', 'fr']);
  278:     if(my $file = $l->translation_file('/var/www/i18n')) {
  279:         # read and use $file
  280:     }
  281: 
  282: =head2 Guess the visitor's time zone and locale
  283: 
  284:     my $l = CGI::Lingua->new(supported => ['en']);
  285:     my $tz = $l->time_zone() // 'UTC';     # e.g. 'America/New_York'
  286:     if(my $locale = $l->locale()) {         # a Locale::Object::Country
  287:         print 'Currency: ', $locale->currency()->code(), "\n";
  288:     }
  289: 
  290: =head2 Do not guess from the IP address
  291: 
  292:     # Only use what the browser asks for; never look up the IP address
  293:     my $l = CGI::Lingua->new(supported => ['en', 'fr'], dont_use_ip => 1);
  294: 
  295: =head1 DESCRIPTION
  296: 
  297: This section explains, in simple steps, how CGI::Lingua finds the answer.
  298: 
  299: =head2 Finding the language
  300: 
  301: When you first call a language method (for example L</language>),
  302: CGI::Lingua looks for the visitor's language in this order:
  303: 
  304: =over 4
  305: 
  306: =item 1. The C<lang> parameter of the L<CGI::Info> object, if you gave one
  307: to L</new> with C<info>.
  308: 
  309: =item 2. The C<HTTP_ACCEPT_LANGUAGE> environment variable.
  310: The web server sets this from the browser's C<Accept-Language> header,
  311: for example C<fr-CA,fr;q=0.9,en;q=0.8>.
  312: Languages with a higher C<q> value are tried first.
  313: A language with C<q=0> means "not acceptable" (RFC 7231) and is never chosen.
  314: Some browsers still send the old tag C<en-uk>; it is treated as C<en-gb>
  315: (the code for the United Kingdom is C<gb>), with a warning.
  316: 
  317: =item 3. The C<LANG> environment variable.
  318: This is used when you run the program on the command line,
  319: for example C<LANG=fr_FR.UTF-8>.
  320: 
  321: =item 4. The visitor's country (see below).
  322: CGI::Lingua uses the official language of that country.
  323: This step is skipped when you give C<dont_use_ip> to L</new>.
  324: 
  325: =back
  326: 
  327: It then compares the answer with your C<supported> list.
  328: If a visitor asks for C<en-us> and you only support C<en-gb>,
  329: CGI::Lingua still chooses English, because the base language is the same.
  330: If nothing matches, L</language> returns the string C<'Unknown'>.
  331: 
  332: =head2 Finding the country
  333: 
  334: L</country> tries these sources in order, and stops at the first answer:
  335: 
  336: =over 4
  337: 
  338: =item 1. C<GEOIP_COUNTRY_CODE> (set by Apache's mod_geoip).
  339: 
  340: =item 2. C<HTTP_CF_IPCOUNTRY> (set by Cloudflare).
  341: 
  342: =item 3. A local database: L<IP::Country>, then L<Geo::IP>, then L<Geo::IPfree>,
  343: if they are installed.
  344: 
  345: =item 4. The geoplugin.net web service.
  346: 
  347: =item 5. A Whois look-up (L<Net::Whois::IP>, then L<Net::Whois::IANA>).
  348: 
  349: =back
  350: 
  351: Steps 3 to 5 use the visitor's IP address from C<REMOTE_ADDR>.
  352: Private addresses (such as C<192.168.1.1>) and loopback addresses
  353: (such as C<127.0.0.1>) have no country, so the answer is C<undef>.
  354: 
  355: =head2 Remembering answers
  356: 
  357: Each object remembers its answers, so a second call to the same method is fast.
  358: If you give a C<cache> to L</new>, answers are also stored in the cache when the
  359: object is destroyed. The next object created for the same IP address, the same
  360: requested language and the same C<supported> list starts with those answers.
  361: 
  362: =head1 SUBROUTINES/METHODS
  363: 
  364: =head2 new
  365: 
  366: Creates a CGI::Lingua object.
  367: 
  368: You must tell it which languages your website supports, with C<supported>.
  369: Each language is a short code, such as C<'en'> (English),
  370: C<'fr'> (French) or C<'en-gb'> (British English).
  371: 
  372: You can give the arguments as a list, as a hash reference,
  373: as a single array reference (the supported list), or as a single string
  374: (one supported language):
  375: 
  376:     CGI::Lingua->new(supported => ['en', 'fr']);
  377:     CGI::Lingua->new({ supported => ['en', 'fr'] });
  378:     CGI::Lingua->new(['en', 'fr']);
  379:     CGI::Lingua->new('en');
  380: 
  381: The arguments are:
  382: 
  383: =over 4
  384: 
  385: =item * C<supported> (required)
  386: 
  387: The languages your website supports: one short code (a string of 2 to 5
  388: characters) or a reference to an array of language tags.
  389: C<supported_languages> is another name for the same argument.
  390: 
  391: Each entry in the array must look like a language tag: two or three letters,
  392: optionally followed by subtags, such as C<'en'>, C<'en-gb'>, C<'en_gb'>,
  393: C<'es-419'> or C<'zh-Hant'>. Other entries (C<undef>, references, C<''>, or
  394: words such as C<'english'>) could never match, so they are dropped with the
  395: warning C<"Ignoring '...' in the supported list: not a language code">.
  396: An empty list is allowed; L</language> then always returns C<'Unknown'>.
  397: 
  398: =item * C<cache> (optional)
  399: 
  400: An object with C<get()>, C<set()> and C<remove()> methods, such as a L<CHI> object.
  401: CGI::Lingua stores its answers here so that later requests are faster.
  402: If a call to the cache dies (for example a full disc, an unreachable server,
  403: or a L<CHI> object created with C<< on_get_error =E<gt> 'die' >>), CGI::Lingua
  404: warns C<"Cache get failed: ..."> (or C<set> / C<remove>) and carries on as if
  405: the value was not cached. Any method that uses the cache can give this warning.
  406: 
  407: Everything read back from the cache is checked before it is used, because a
  408: cache can be shared with, or written by, other programs. A value that does not
  409: have the shape CGI::Lingua stores (for example C<< gb<script> >> as a country, or
  410: a hash where a language name should be) is removed and warned about with
  411: C<"Discarding malformed cache entry for ...">, and the answer is worked out
  412: again.
  413: 
  414: =item * C<config_file> (optional)
  415: 
  416: The path to a configuration file. It is read by L<Object::Configure>.
  417: Values in this file B<replace> the arguments that you give to C<new()>
  418: (see L</COMMON PITFALLS>).
  419: 
  420: =item * C<logger> (optional)
  421: 
  422: Where to send messages. This can be an object with C<warn()>, C<info()> and
  423: C<error()> methods, or any value that L<Object::Configure> accepts
  424: (for example an array reference, which collects the messages).
  425: It is always changed into a L<Log::Abstraction> object.
  426: Without a logger, warnings go to L<Carp>.
  427: 
  428: =item * C<info> (optional)
  429: 
  430: A L<CGI::Info> object (or any object with a C<lang()> method).
  431: A C<lang> parameter in the request is then used before the browser's
  432: settings. The parameter comes from the visitor, so it is checked like the
  433: C<Accept-Language> header (see L</ENCODING>); a value that fails is ignored with
  434: the warning C<"lang parameter contains invalid characters; ignoring">.
  435: 
  436: =item * C<dont_use_ip> (optional, default false)
  437: 
  438: When true, CGI::Lingua never guesses the language from the visitor's
  439: IP address.
  440: 
  441: =item * C<syslog> (optional)
  442: 
  443: Passed on to the logging configuration.
  444: 
  445: =item * C<debug> (optional, default false)
  446: 
  447: When true, L<I18N::AcceptLanguage> prints debug information.
  448: 
  449: =back
  450: 
  451: If you call C<new()> on an existing object, you get a copy of that object.
  452: The arguments you give replace the values in the copy.
  453: The copy also keeps any answers that the original has already worked out
  454: (see L</COMMON PITFALLS>).
  455: 
  456: =head3 API SPECIFICATION
  457: 
  458: =head4 Input
  459: 
  460:     {
  461:         supported           => { type => 'string|arrayref', optional => 0 },
  462:         supported_languages => { type => 'string|arrayref', optional => 1 },
  463:         cache               => { type => 'object', can => ['get', 'set'], optional => 1 },
  464:         config_file         => { type => 'string', optional => 1 },
  465:         logger              => { type => 'object|arrayref|hashref|string', optional => 1 },
  466:         info                => { type => 'object', can => 'lang', optional => 1 },
  467:         dont_use_ip         => { type => 'boolean', optional => 1 },
  468:         syslog              => { type => 'boolean|hashref', optional => 1 },
  469:         debug               => { type => 'boolean', optional => 1 },
  470:     }
  471: 
  472: You must give C<supported> or its other name C<supported_languages>.
  473: A string must be 2 to 5 characters long.
  474: 
  475: =head4 Output
  476: 
  477:     {
  478:         type => 'object',
  479:         isa  => 'CGI::Lingua',
  480:     }
  481: 
  482: =head3 EXAMPLE
  483: 
  484:     # The most common form: a list of supported codes
  485:     my $l = CGI::Lingua->new(supported => ['en', 'fr', 'de']);
  486: 
  487:     # One supported language
  488:     my $l = CGI::Lingua->new(supported => 'en');
  489: 
  490:     # With a cache, a logger and a CGI::Info object
  491:     use CHI;
  492:     use CGI::Info;
  493:     my $l = CGI::Lingua->new({
  494:         supported => ['en', 'fr'],
  495:         cache     => CHI->new(driver => 'File', root_dir => '/var/cache/myapp'),
  496:         logger    => \my @messages,
  497:         info      => CGI::Info->new(),
  498:     });
  499: 
  500: =head3 MESSAGES
  501: 
  502: C<new()> dies (with L<Carp/croak>) with one of these messages:
  503: 
  504:     "You must give a list of supported languages"
  505:         - supported is missing, undef, 0 or the empty string
  506:     "List of supported languages must be an array ref"
  507:         - supported is a reference, but not to an array
  508:     "Supported languages must be the short code"
  509:         - supported is a string shorter than 2 or longer than 5 characters
  510:     "Logger must be a blessed object with warn/info/error methods"
  511:         - logger is an object that is missing one of these methods
  512:     "CGI::Lingua use ->new() not ::new() to instantiate"
  513:         - new() was called as a function, with arguments
  514:     "info must be an object with a lang() method"
  515:         - info is not an object, or has neither lang() nor AUTOLOAD
  516: 
  517: It warns, and carries on, with:
  518: 
  519:     "Ignoring '...' in the supported list: not a language code"
  520:         - an entry of the supported list is not a language tag
  521:     "Cache get failed: ..."
  522:         - the cache died while looking up saved answers
  523:     "Discarding malformed cache entry for ..."
  524:         - the saved answers were not in the shape CGI::Lingua writes
  525: 
  526: =head3 PSEUDOCODE
  527: 
  528:     1. Read the arguments with Params::Get
  529:     2. If called on an object, return a copy with the new arguments on top
  530:     3. If logger is an object, check that it has warn, info and error
  531:     4. Merge in config_file and environment settings with Object::Configure
  532:     5. Check supported (required; string of 2-5 characters, or an arrayref)
  533:     6. If there is a cache and REMOTE_ADDR is set, try to load saved answers
  534:        from the cache (JSON); if found, return them as an object
  535:     7. Otherwise return a new object with no answers yet
  536: 
  537: =cut
  538: 
  539: sub new
  540: {
●541 → 545 → 565  541: 	my $class = shift;
  542: 	my $params = Params::Get::get_params('supported', @_);
  543: 
  544: 	# Handle ::new() misuse
  545: 	if(!defined($class)) {

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

  Mutants (Total: 1, Killed: 1, Survived: 0)
  547: 			# Object::Configure has not run yet, so the logger may still be in
  548: 			# one of its raw forms (arrayref, hashref, file name)
  549: 			my $logger = $params->{'logger'};
  550: 			if(Scalar::Util::blessed($logger) && $logger->can('error')) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  551: 				$logger->error(__PACKAGE__ . ' use ->new() not ::new() to instantiate');
  552: 			}
  553: 			Carp::croak(__PACKAGE__ . ' use ->new() not ::new() to instantiate');
  554: 		}
  555: 		$class = __PACKAGE__;
  556: 	} elsif(ref($class)) {
  557: 		# Clone: overlay new params onto existing object state
  558: 		$params->{_supported} ||= $params->{supported} if defined $params->{'supported'};
  559: 		return bless { %{$class}, %{$params} }, ref($class);

  Mutants (Total: 2, Killed: 2, Survived: 0)
  560: 	}
  561: 
  562: 	# Validate blessed logger objects before Object::Configure runs.
  563: 	# Non-blessed values (arrayrefs, hashrefs) are valid config forms that
  564: 	# Object::Configure knows how to convert into a Log::Abstraction instance.
●565 → 565 → 576  565: 	if(defined $params->{'logger'} && Scalar::Util::blessed($params->{'logger'})) {

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

  Mutants (Total: 1, Killed: 1, Survived: 0)
  567: 			$params->{'logger'}->can('warn')
  568: 			&& $params->{'logger'}->can('info')
  569: 			&& $params->{'logger'}->can('error')
  570: 		) {
  571: 			Carp::croak('Logger must be a blessed object with warn/info/error methods');
  572: 		}
  573: 	}
  574: 
  575: 	# Object::Configure runs evals and file tests; keep them off the caller's $@ and $!
●576 → 580 → 596  576: 	$params = do { local ($@, $!); Object::Configure::configure($class, $params) };
  577: 
  578: 	# Normalise supported / supported_languages alias
  579: 	$params->{'supported'} ||= $params->{'supported_languages'};
  580: 	if(defined($params->{supported})) {

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

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

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

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

  Mutants (Total: 1, Killed: 1, Survived: 0)
  591: 			$logger->error('You must give a list of supported languages');
  592: 		}
  593: 		Carp::croak('You must give a list of supported languages');
  594: 	}
  595: 
●596 → 601 → 609  596: 	my $cache = $params->{cache};
  597: 	my $info  = $params->{info};
  598: 
  599: 	# info is asked for lang() on every request.  CGI::Info provides lang()
  600: 	# through AUTOLOAD, so can('lang') alone is not enough of a test.
  601: 	if(defined($info) && !(Scalar::Util::blessed($info) && ($info->can('lang') || $info->can('AUTOLOAD')))) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  602: 		Carp::croak('info must be an object with a lang() method');
  603: 	}
  604: 
  605: 	# Keep only entries that are language tags ("en", "en-gb", "es-419").
  606: 	# undef, references (including a list that contains itself), '' and words
  607: 	# such as "english" could never match and would make I18N::AcceptLanguage
  608: 	# warn; say so rather than drop them silently.
●609 → 610 → 634  609: 	my @supported;
  610: 	for my $item (ref($params->{supported}) ? @{$params->{supported}} : ($params->{'supported'})) {
  611: 		my $entry = $item;	# a copy: the loop variable aliases the caller's array
  612: 		if(defined($entry) && !ref($entry) && ($entry =~ $SUPPORTED_RE)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  613: 			if(lc($entry) eq $DEPRECATED_EN_UK) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  614: 				# Same rule as the header: en-uk is en-gb
  615: 				my $msg = "Resetting country code to GB for $entry";
  616: 				if(Scalar::Util::blessed($params->{'logger'}) && $params->{'logger'}->can('warn')) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  617: 					$params->{'logger'}->warn($msg);
  618: 				} else {
  619: 					Carp::carp($msg);
  620: 				}
  621: 				$entry = $CANONICAL_EN_GB;
  622: 			}
  623: 			push @supported, $entry;
  624: 			next;
  625: 		}
  626: 		my $msg = q{Ignoring '} . _printable($entry) . q{' in the supported list: not a language code};
  627: 		if(Scalar::Util::blessed($params->{'logger'}) && $params->{'logger'}->can('warn')) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  628: 			$params->{'logger'}->warn($msg);
  629: 		} else {
  630: 			Carp::carp($msg);
  631: 		}
  632: 	}
  633: 
●634 → 652 → 686  634: 	my $self = bless {
  635: 		%{$params},
  636: 		_supported       => \@supported,
  637: 		_cache           => $cache,
  638: 		_info            => $info,
  639: 		_syslog          => $params->{syslog},
  640: 		_dont_use_ip     => $params->{dont_use_ip} || 0,
  641: 		_have_ipcountry  => $GEO_UNKNOWN,
  642: 		_have_geoip      => $GEO_UNKNOWN,
  643: 		_have_geoipfree  => $GEO_UNKNOWN,
  644: 		_debug           => $params->{debug} || 0,
  645: 	}, $class;
  646: 
  647: 	# Try to restore the answers saved by DESTROY for this visitor.  Only the
  648: 	# fields in %RESTORABLE are taken from the cache, each checked against
  649: 	# its pattern: the cache can be written by others (world-writable /tmp,
  650: 	# unauthenticated Redis), so a hostile entry must not set the logger,
  651: 	# the supported list, dont_use_ip, or an HTML/path payload as a language.
  652: 	if($cache && $ENV{'REMOTE_ADDR'}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  653: 		my $key = _build_cache_key($ENV{'REMOTE_ADDR'}, $params, $class, $info);
  654: 		# No key means REMOTE_ADDR is not a valid address: do not cache
  655: 		if(defined($key) && (my $frozen = _cache_call($params, $cache, 'get', $key))) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  656: 			# JSON::PP rather than Storable::thaw: Storable can run code via
  657: 			# STORABLE_thaw hooks in a crafted blob; JSON cannot.  A blob that
  658: 			# is not JSON (e.g. a legacy Storable entry) is quietly rebuilt.
  659: 			my $rc = do { local $@; eval { local $SIG{__DIE__}; JSON::PP::decode_json($frozen) } };
  660: 			if(ref($rc) eq 'HASH') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  661: 				my @bad = grep {
  662: 					defined($rc->{$_}) && (ref($rc->{$_}) || ($rc->{$_} !~ $RESTORABLE{$_}))
  663: 				} sort keys %RESTORABLE;
  664: 				if(@bad) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  665: 					my $msg = "Discarding malformed cache entry for $key";
  666: 					if(Scalar::Util::blessed($params->{'logger'}) && $params->{'logger'}->can('warn')) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  667: 						$params->{'logger'}->warn($msg);
  668: 					} else {
  669: 						Carp::carp($msg);
  670: 					}
  671: 					_cache_call($params, $cache, 'remove', $key);
  672: 				} else {
  673: 					$self->{$_} = $rc->{$_} for grep { defined $rc->{$_} } keys %RESTORABLE;
  674: 
  675: 					# A lang= CGI parameter overrides the browser, so the
  676: 					# cached language choice may be stale: work it out again
  677: 					if(_info_lang($info)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  678: 						delete @{$self}{qw(_slanguage _rlanguage _sublanguage
  679: 							_slanguage_code_alpha2 _sublanguage_code_alpha2)};
  680: 					}
  681: 				}
  682: 			}
  683: 		}
  684: 	}
  685: 
  686: 	return $self;

  Mutants (Total: 2, Killed: 2, Survived: 0)
  687: }
  688: # ── _build_cache_key ──────────────────────────────────────────────────────────
  689: # Purpose:      Produce a deterministic string key for the per-request cache
  690: #               entry stored in new() and DESTROY().
  691: # Entry:        $addr  — IP string (not yet taint-checked; used read-only here)
  692: #               $params — constructor params hashref
  693: #               $class  — package name
  694: #               $info   — optional CGI::Info object
  695: # Exit:         A plain string key of the form "ip/lang/lang1/lang2/..."
  696: sub _build_cache_key
  697: {
●698 → 712 → 720  698: 	my ($addr, $params, $class, $info) = @_;
  699: 
  700: 	# Every part of the key comes from the visitor or the caller, and cache
  701: 	# backends such as Memcached treat CR, LF and spaces in a key as protocol.
  702: 	# So the key is built only from checked values, and there is no key (and
  703: 	# so no caching) when the address is not a valid one.
  704: 	my $ip = _untaint_ip($addr);
  705: 	return undef unless defined($ip);

					

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

  706: 	my $key = "$ip/";
  707: 
  708: 	# Include the requested language (if determinable) so different
  709: 	# Accept-Language values get distinct cache slots for the same IP.
  710: 	# Both sources are validated; spaces are not significant in the header.
  711: 	my $l;
  712: 	if(defined($l = _info_lang($info)) || defined($l = $class->_what_language())) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  713: 		$l =~ s/[ \t]+//g;
  714: 		$key .= "$l/" if length($l);
  715: 	}
  716: 
  717: 	# Fix: was ref($params->{'supported'} eq 'ARRAY') — eq was inside ref(),
  718: 	# so ref() always received a boolean (1 or ''), never the arrayref itself.
  719: 	# Only entries that new() would keep are used.
  720: 	my @supported = ref($params->{'supported'}) eq 'ARRAY' ? @{$params->{supported}} : ($params->{'supported'});
  721: 	$key .= join('/', grep { defined($_) && !ref($_) && ($_ =~ $SUPPORTED_RE) } @supported);
  722: 
  723: 	return $key;

  Mutants (Total: 2, Killed: 2, Survived: 0)
  724: }
  725: 
  726: # ── _untaint_ip ──────────────────────────────────────────────────────────
  727: # Purpose:      Check that a value has the shape of an IP address and return
  728: #               an untainted copy.  The single place REMOTE_ADDR is checked,
  729: #               so country(), time_zone() and the cache key always agree.
  730: # Entry:        $raw — any scalar.
  731: # Exit:         The address, or undef.  \z, not $, so "1.2.3.4\n" is refused.
  732: # Notes:        Shape only: country() then range-checks with is_ipv4/is_ipv6.
  733: sub _untaint_ip
  734: {
  735: 	my $raw = shift;
  736: 	return undef unless defined($raw) && !ref($raw);

					

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

  737: 	return $raw =~ $IP_SHAPE_RE ? $1 : undef;

  Mutants (Total: 2, Killed: 2, Survived: 0)
  738: }
  739: 
  740: # ── _cache_call ──────────────────────────────────────────────────────────
  741: # Purpose:      Call get/set/remove on the caller-supplied cache without
  742: #               letting a cache failure take down the request.  The cache only
  743: #               saves time, so a broken backend (full disc, unreachable Redis,
  744: #               CHI with on_get_error => 'die') must degrade to "not cached".
  745: # Entry:        $self   — a CGI::Lingua object, or new()'s params hashref
  746: #                         (used only to find a logger);
  747: #               $cache  — the cache object; $method — 'get', 'set' or 'remove';
  748: #               @args   — passed to the method unchanged.
  749: # Exit:         The method's scalar result, or undef if it died.
  750: # Side Effects: Warns "Cache <method> failed: <error>" on failure.
  751: sub _cache_call
  752: {
●753 → 762 → 769  753: 	my ($self, $cache, $method, @args) = @_;
  754: 
  755: 	local $@;
  756: 	my $rc;
  757: 	return $rc if eval { local $SIG{__DIE__}; $rc = $cache->$method(@args); 1 };

  Mutants (Total: 2, Killed: 2, Survived: 0)
  758: 
  759: 	my $err = $@ || 'unknown error';
  760: 	$err =~ s/\s+\z//;
  761: 	my $msg = "Cache $method failed: $err";
  762: 	if(Scalar::Util::blessed($self)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  763: 		$self->_warn({ warning => $msg });
  764: 	} elsif((ref($self) eq 'HASH') && Scalar::Util::blessed($self->{'logger'}) && $self->{'logger'}->can('warn')) {
  765: 		$self->{'logger'}->warn($msg);
  766: 	} else {
  767: 		Carp::carp($msg);
  768: 	}
  769: 	return;
  770: }
  771: 
  772: # ── _info_lang ───────────────────────────────────────────────────────────
  773: # Purpose:      Ask the CGI::Info-style object for the lang= parameter without
  774: #               letting a broken object (an AUTOLOAD that dies) end the request.
  775: # Entry:        $info — the info object, or undef;
  776: #               $self — optional object to warn through when the value is bad.
  777: # Exit:         The validated, untainted lang value, or undef if there is none,
  778: #               the call died, or the value is not a plausible language list.
  779: sub _info_lang
  780: {
  781: 	my ($info, $self) = @_;
  782: 
  783: 	return undef unless $info;

  Mutants (Total: 2, Killed: 2, Survived: 0)
  784: 	local $@;
  785: 	my $lang;
  786: 	return undef unless eval { local $SIG{__DIE__}; $lang = $info->lang(); 1 };

  Mutants (Total: 2, Killed: 2, Survived: 0)
  787: 	return undef unless defined($lang) && length($lang);

  Mutants (Total: 2, Killed: 2, Survived: 0)
  788: 
  789: 	# lang= comes from the query string, so it is as hostile as any header:
  790: 	# same character set and length cap as HTTP_ACCEPT_LANGUAGE
  791: 	return $1 if !ref($lang) && ($lang =~ $ACCEPT_LANG_RE);

  Mutants (Total: 2, Killed: 2, Survived: 0)
  792: 	$self->_warn({ warning => 'lang parameter contains invalid characters; ignoring' }) if ref($self);
  793: 	return undef;

					

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

  794: }
  795: 
  796: # ── _cache_get_valid ─────────────────────────────────────────────────────
  797: # Purpose:      Read a value from the cache and use it only if it has the
  798: #               shape CGI::Lingua itself stores.  The cache may be shared or
  799: #               writable by others; a poisoned entry ("<script>", a hashref,
  800: #               "../../etc") must never become a language or country.
  801: # Entry:        $key — full cache key; $re — the pattern the value must match.
  802: # Exit:         The value, or undef on a miss or a malformed value.
  803: # Side Effects: A malformed value is removed and "Discarding malformed cache
  804: #               entry for <key>" is warned (the value itself is not logged:
  805: #               it is attacker-controlled).
  806: sub _cache_get_valid
  807: {
  808: 	my ($self, $key, $re) = @_;
  809: 
  810: 	my $value = $self->_cache_call($self->{_cache}, 'get', $key);
  811: 	return $value if !defined($value) || (!ref($value) && ($value =~ $re));

  Mutants (Total: 2, Killed: 2, Survived: 0)
  812: 
  813: 	$self->_warn({ warning => "Discarding malformed cache entry for $key" });
  814: 	$self->_cache_call($self->{_cache}, 'remove', $key);
  815: 	return;
  816: }
  817: 
  818: # Some of the information takes a long time to work out, so cache what we can
  819: sub DESTROY {
  820: 	# Destructors run at arbitrary points, e.g. while the caller is examining $@
●821 → 822 → 825  821: 	local ($@, $!);
  822: 	if(defined($^V) && ($^V ge 'v5.14.0')) {

					

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

  823: 		return if ${^GLOBAL_PHASE} eq 'DESTRUCT';
  824: 	}
  825: 	return unless $ENV{'REMOTE_ADDR'};
  826: 
  827: 	my $self = shift;
  828: 	return unless ref($self);
  829: 
  830: 	my $cache = $self->{_cache};
  831: 	return unless $cache;
  832: 
  833: 	my $key = _build_cache_key(
  834: 		$ENV{'REMOTE_ADDR'},
  835: 		{ supported => $self->{_supported} },
  836: 		ref($self),
  837: 		$self->{_info},
  838: 	);
  839: 	return unless defined($key);	# REMOTE_ADDR is not a valid address
  840: 	return if $self->_cache_call($cache, 'get', $key);
  841: 
  842: 	$self->_debug("Storing self in cache as $key");
  843: 
  844: 	# Serialise only the computed state — not loggers, file handles, or
  845: 	# geo-module objects (they are re-initialised on next construction).
  846: 	# JSON::PP is used instead of Storable so that a compromised cache backend
  847: 	# cannot deliver a blob that executes code via STORABLE_thaw hooks.
  848: 	# Only the fields new() will accept back (see %RESTORABLE).  _sublanguage
  849: 	# used to be left out, so sublanguage() was undef after a restore.
  850: 	my %state = map { $_ => $self->{$_} } keys %RESTORABLE;
  851: 
  852: 	$self->_cache_call($cache, 'set', $key, JSON::PP::encode_json(\%state), $CACHE_TTL_LONG);
  853: }
  854: 
  855: =head2 language
  856: 
  857: Returns the name of the language to show to the visitor, in English,
  858: for example C<'English'>, C<'French'> or C<'Japanese'>.
  859: The language is always one of the languages in your C<supported> list.
  860: 
  861: Variants are handled sensibly.
  862: If a visitor asks for American English (C<en-us>)
  863: and your site only has British English (C<en-gb>),
  864: C<language()> returns C<'English'>.
  865: 
  866: If none of the languages that the visitor wants is in your C<supported> list,
  867: C<language()> returns the string C<'Unknown'>.
  868: It never returns C<undef>.
  869: 
  870: =head3 API SPECIFICATION
  871: 
  872: =head4 Input
  873: 
  874:     {}
  875: 
  876: =head4 Output
  877: 
  878:     {
  879:         type => 'string',
  880:         min  => 1,
  881:     }
  882: 
  883: =head3 EXAMPLE
  884: 
  885:     local $ENV{HTTP_ACCEPT_LANGUAGE} = 'fr,en;q=0.9';
  886:     my $l = CGI::Lingua->new(supported => ['en', 'fr']);
  887:     print $l->language();   # "French"
  888: 
  889:     local $ENV{HTTP_ACCEPT_LANGUAGE} = 'de';
  890:     my $l = CGI::Lingua->new(supported => ['en', 'fr']);
  891:     print $l->language();   # "Unknown"
  892: 
  893: =head3 MESSAGES
  894: 
  895: The first call to L</language> (or any other language method) warns, and
  896: ignores the value, when one of its inputs is not acceptable:
  897: 
  898:     "lang parameter contains invalid characters; ignoring"
  899:     "HTTP_ACCEPT_LANGUAGE contains invalid characters; ignoring"
  900:     "LANG contains invalid characters; ignoring"
  901: 
  902: It also warns when it changes the deprecated tag C<en-uk> into C<en-gb>:
  903: 
  904:     "Resetting country code to GB for ..."
  905: 
  906: =cut
  907: 
  908: sub language {
  909: 	my $self = $_[0];
  910: 
  911: 	$self->_find_language() unless $self->{_slanguage};
  912: 	return $self->{_slanguage};

  Mutants (Total: 2, Killed: 2, Survived: 0)
  913: }
  914: 
  915: =head2 preferred_language
  916: 
  917: Another name for L</language>. It takes no arguments and returns the same value.
  918: 
  919: =head3 API SPECIFICATION
  920: 
  921: =head4 Input
  922: 
  923:     {}
  924: 
  925: =head4 Output
  926: 
  927:     {
  928:         type => 'string',
  929:         min  => 1,
  930:     }
  931: 
  932: =cut
  933: 
  934: sub preferred_language
  935: {
  936: 	my $self = shift;
  937: 	return $self->language(@_);

  Mutants (Total: 2, Killed: 2, Survived: 0)
  938: }
  939: 
  940: =head2 name
  941: 
  942: Another name for L</language>, so that a CGI::Lingua object can be used where a
  943: L<Locale::Object::Language> object is expected.
  944: 
  945: =head3 API SPECIFICATION
  946: 
  947: =head4 Input
  948: 
  949:     {}
  950: 
  951: =head4 Output
  952: 
  953:     {
  954:         type => 'string',
  955:         min  => 1,
  956:     }
  957: 
  958: =cut
  959: 
  960: sub name {
  961: 	my $self = $_[0];
  962: 	return $self->language();

  Mutants (Total: 2, Killed: 2, Survived: 0)
  963: }
  964: 
  965: =head2 sublanguage
  966: 
  967: Returns the name of the variant (usually a country) of the chosen language,
  968: for example C<'United Kingdom'> when the chosen language is C<en-gb>.
  969: 
  970: Returns C<undef> when there is no variant, for example when the chosen
  971: language is just C<en>, or when no language was found.
  972: 
  973: =head3 API SPECIFICATION
  974: 
  975: =head4 Input
  976: 
  977:     {}
  978: 
  979: =head4 Output
  980: 
  981:     {
  982:         type     => 'string',
  983:         min      => 1,
  984:         optional => 1,
  985:     }
  986: 
  987: =head3 EXAMPLE
  988: 
  989:     local $ENV{HTTP_ACCEPT_LANGUAGE} = 'en-gb';
  990:     my $l = CGI::Lingua->new(supported => ['en-gb']);
  991:     print $l->sublanguage();   # "United Kingdom"
  992: 
  993: =cut
  994: 
  995: sub sublanguage {
  996: 	my $self = $_[0];
  997: 
  998: 	$self->_trace('Entered sublanguage');
  999: 	$self->_find_language() unless $self->{_slanguage};
 1000: 	$self->_trace('Leaving sublanguage ', ($self->{_sublanguage} || 'undef'));
 1001: 	return $self->{_sublanguage};

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1002: }
 1003: 
 1004: =head2 language_code_alpha2
 1005: 
 1006: Returns the two-letter code (ISO 639-1) of the chosen language,
 1007: for example C<'en'> when the chosen language is C<en-gb>.
 1008: 
 1009: Returns C<undef> when none of the languages that the visitor wants is in your
 1010: C<supported> list (that is, when L</language> returns C<'Unknown'>).
 1011: 
 1012: =head3 API SPECIFICATION
 1013: 
 1014: =head4 Input
 1015: 
 1016:     {}
 1017: 
 1018: =head4 Output
 1019: 
 1020:     {
 1021:         type     => 'string',
 1022:         min      => 2,
 1023:         max      => 2,
 1024:         optional => 1,
 1025:     }
 1026: 
 1027: =head3 EXAMPLE
 1028: 
 1029:     local $ENV{HTTP_ACCEPT_LANGUAGE} = 'en-gb';
 1030:     my $l = CGI::Lingua->new(supported => ['en-gb']);
 1031:     print $l->language_code_alpha2();   # "en"
 1032: 
 1033: =cut
 1034: 
 1035: sub language_code_alpha2 {
 1036: 	my $self = $_[0];
 1037: 
 1038: 	$self->_trace('Entered language_code_alpha2');
 1039: 	$self->_find_language() unless $self->{_slanguage};
 1040: 	$self->_trace('language_code_alpha2 returns ', $self->{_slanguage_code_alpha2});
 1041: 	return $self->{_slanguage_code_alpha2};

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1042: }
 1043: 
 1044: =head2 code_alpha2
 1045: 
 1046: Another name for L</language_code_alpha2>, kept so that old programs still work.
 1047: 
 1048: =head3 API SPECIFICATION
 1049: 
 1050: =head4 Input
 1051: 
 1052:     {}
 1053: 
 1054: =head4 Output
 1055: 
 1056:     {
 1057:         type     => 'string',
 1058:         min      => 2,
 1059:         max      => 2,
 1060:         optional => 1,
 1061:     }
 1062: 
 1063: =cut
 1064: 
 1065: sub code_alpha2 {
 1066: 	my $self = $_[0];
 1067: 	return $self->language_code_alpha2();

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1068: }
 1069: 
 1070: =head2 sublanguage_code_alpha2
 1071: 
 1072: Returns the two-letter code of the variant of the chosen language,
 1073: in lower case, for example C<'gb'> when the chosen language is C<en-gb>.
 1074: 
 1075: Returns C<undef> when there is no variant.
 1076: 
 1077: =head3 API SPECIFICATION
 1078: 
 1079: =head4 Input
 1080: 
 1081:     {}
 1082: 
 1083: =head4 Output
 1084: 
 1085:     {
 1086:         type     => 'string',
 1087:         min      => 2,
 1088:         max      => 2,
 1089:         optional => 1,
 1090:     }
 1091: 
 1092: =head3 EXAMPLE
 1093: 
 1094:     local $ENV{HTTP_ACCEPT_LANGUAGE} = 'en-gb';
 1095:     my $l = CGI::Lingua->new(supported => ['en-gb']);
 1096:     print $l->sublanguage_code_alpha2();   # "gb"
 1097: 
 1098: =cut
 1099: 
 1100: sub sublanguage_code_alpha2 {
 1101: 	my $self = $_[0];
 1102: 
 1103: 	$self->_find_language() unless $self->{_slanguage};
 1104: 	return $self->{_sublanguage_code_alpha2};

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1105: }
 1106: 
 1107: =head2 requested_language
 1108: 
 1109: Returns, in English, the language that the visitor asked for,
 1110: B<whether or not your site supports it>.
 1111: Use it to tell the visitor that their language is not available.
 1112: 
 1113: If the visitor asked for a variant, it is shown in brackets,
 1114: for example C<'English (United Kingdom)'>. A variant that is not a known
 1115: country code is shown as it was sent, for example C<'English (Unknown: zz)'>.
 1116: 
 1117: Returns C<'Unknown'> when the visitor's language cannot be found at all.
 1118: It never returns C<undef>.
 1119: 
 1120: =head3 API SPECIFICATION
 1121: 
 1122: =head4 Input
 1123: 
 1124:     {}
 1125: 
 1126: =head4 Output
 1127: 
 1128:     {
 1129:         type => 'string',
 1130:         min  => 1,
 1131:     }
 1132: 
 1133: =head3 EXAMPLE
 1134: 
 1135:     local $ENV{HTTP_ACCEPT_LANGUAGE} = 'en-gb';
 1136:     my $l = CGI::Lingua->new(supported => ['en']);
 1137:     print $l->language();             # "English"
 1138:     print $l->requested_language();   # "English (United Kingdom)"
 1139: 
 1140:     local $ENV{HTTP_ACCEPT_LANGUAGE} = 'de';
 1141:     my $l = CGI::Lingua->new(supported => ['en']);
 1142:     print $l->language();             # "Unknown"
 1143:     print $l->requested_language();   # "German"
 1144: 
 1145: =cut
 1146: 
 1147: sub requested_language {
 1148: 	my $self = $_[0];
 1149: 
 1150: 	$self->_find_language() unless $self->{_rlanguage};
 1151: 	# _find_language() can leave it undef; the API promises a string
 1152: 	$self->{_rlanguage} //= 'Unknown';
 1153: 	return $self->{_rlanguage};

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1154: }
 1155: 
 1156: # ── _find_language ─────────────────────────────────────────────────────────
 1157: # Purpose:      Populate _slanguage, _rlanguage, _sublanguage, and the
 1158: #               various code fields by working through the detection pipeline:
 1159: #               Accept-Language header → I18N::AcceptLanguage → IP country.
 1160: # Entry:        $self->{_slanguage} must be undef (guards repeated calls).
 1161: # Exit:         $self->{_slanguage} is set to a language name or 'Unknown'.
 1162: # Side Effects: Populates _rlanguage, _sublanguage, *_code_alpha2 fields.
 1163: sub _find_language
 1164: {
●1165 → 1182 → 1196 1165: 	my $self = shift;
 1166: 	# Called by every language accessor; the evals and file tests below must
 1167: 	# not change the caller's $@ or $!
 1168: 	local ($@, $!);
 1169: 
 1170: 	$self->_trace('Entered _find_language');
 1171: 
 1172: 	$self->{_rlanguage} = 'Unknown';
 1173: 	$self->{_slanguage} = 'Unknown';
 1174: 
 1175: 	my $http_accept_language = $self->_what_language();
 1176: 
 1177: 	# RFC 7231 section 5.3.1: q=0 means "not acceptable", so drop those tags
 1178: 	# before matching, or "fr;q=0, en;q=0.5" would choose French.  A q value
 1179: 	# outside the RFC grammar (0 to 1, at most three decimals: "q=abc",
 1180: 	# "q=1e309", "q=-1") makes the tag malformed, so drop it too, rather than
 1181: 	# let I18N::AcceptLanguage guess and warn.
 1182: 	if(defined($http_accept_language) && ($http_accept_language =~ /;\s*q\s*=/i)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1183: 		my @acceptable;
 1184: 		for my $tag (split(/\s*,\s*/, $http_accept_language)) {
 1185: 			if($tag =~ /;\s*q\s*=\s*(\S*?)\s*\z/i) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1186: 				my $q = $1;
 1187: 				next unless $q =~ /^(?:0(?:\.[0-9]{0,3})?|1(?:\.0{0,3})?)\z/;
 1188: 				next if $q == 0;

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1189: 			}
 1190: 			push @acceptable, $tag;
 1191: 		}
 1192: 		$http_accept_language = @acceptable ? join(',', @acceptable) : undef;
 1193: 		$self->_debug('Accept-Language after dropping unacceptable tags: ', $http_accept_language // '(none)');
 1194: 	}
 1195: 
●1196 → 1196 → 1237 1196: 	if(defined($http_accept_language)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1197: 		$self->_debug(
 1198: 			"language wanted: $http_accept_language, "
 1199: 			. 'languages supported: '
 1200: 			. join(', ', @{$self->{_supported}} // '')
 1201: 		);
 1202: 
 1203: 		# Normalise the deprecated en-uk tag that some browsers send, wherever
 1204: 		# it is in the list (not only when it is the whole header)
 1205: 		my $sent = $http_accept_language;
 1206: 		if($http_accept_language =~ s/(?<![A-Za-z0-9-])\Q$DEPRECATED_EN_UK\E(?![A-Za-z0-9-])/$CANONICAL_EN_GB/gi) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1207: 			$self->_warn({ warning => "Resetting country code to GB for $sent" });
 1208: 		}
 1209: 
 1210: 		# Run the header through the Accept-Language resolver
 1211: 		my ($l, $requested_sublanguage) =
 1212: 			$self->_accept_language_match($http_accept_language);
 1213: 
 1214: 		# Resolve the matched code to a full language/sublanguage
 1215: 		if($l) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1216: 			return if $self->_resolve_match($l, $requested_sublanguage, $http_accept_language);
 1217: 		} elsif($http_accept_language =~ /;/) {
 1218: 			# e.g. de-DE,de;q=0.9,en-US;q=0.8 and we support none of those
 1219: 			$self->_notice(
 1220: 				__PACKAGE__, ': ', __LINE__,
 1221: 				": couldn't honour HTTP_ACCEPT_LANGUAGE=$http_accept_language,"
 1222: 				. ' supported languages are: '
 1223: 				. join(',', @{$self->{_supported}})
 1224: 			);
 1225: 		}
 1226: 
 1227: 		# Last-chance: 2-char or xx-xx header where we have no match
 1228: 		if(

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1229: 			((!$self->{_rlanguage}) || ($self->{_rlanguage} eq 'Unknown'))
 1230: 			&& ((length($http_accept_language) == 2) || ($http_accept_language =~ /^..-..$/))

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1231: 		) {
 1232: 			$self->{_rlanguage} = $self->_code2language($http_accept_language) || 'Unknown';
 1233: 		}
 1234: 		$self->{_slanguage} = 'Unknown';
 1235: 	}
 1236: 
 1237: 	return if $self->{_dont_use_ip};
 1238: 
 1239: 	# Fall back to the official language of the visitor's country
 1240: 	$self->_find_language_from_ip($http_accept_language);
 1241: }
 1242: 
 1243: # ── _accept_language_match ────────────────────────────────────────────────
 1244: # Purpose:      Run I18N::AcceptLanguage strict matching plus two fallback
 1245: #               left-to-right scan passes against $self->{_supported}.
 1246: # Entry:        $http_accept_language — validated, untainted Accept-Language value.
 1247: # Exit:         Returns ($matched_code, $requested_sublanguage) or (undef, undef).
 1248: # Side Effects: Logs debug messages.
 1249: sub _accept_language_match
 1250: {
●1251 → 1263 → 1268 1251: 	my ($self, $http_accept_language) = @_;
 1252: 
 1253: 	my $i18n = I18N::AcceptLanguage->new(debug => $self->{_debug}, strict => 1);
 1254: 	my $l;
 1255: 	{
 1256: 		# Suppress I18N::AcceptLanguage's uninitialized-value warnings (RT 74338)
 1257: 		local $SIG{__WARN__} = _warn_filter(qr/^Use of uninitialized value/);
 1258: 		$l = $i18n->accepts($http_accept_language, $self->{_supported});
 1259: 	}
 1260: 
 1261: 	# I18N-AcceptLanguage strict mode can return a sublanguage variant when
 1262: 	# the request contains a sublanguage we don't support; force a retry.
 1263: 	if($l && ($http_accept_language =~ /-/) && ($http_accept_language !~ qr/$l/i)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1264: 		$self->_debug('Forcing fallback');
 1265: 		undef $l;
 1266: 	}
 1267: 
●1268 → 1269 → 1282 1268: 	my $requested_sublanguage;
 1269: 	if(!$l) {

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

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1276: 			# Second fallback: scan plain tokens without sublanguages
 1277: 			$l = $self->_scan_plain_tokens($i18n, $sorted);
 1278: 			undef $requested_sublanguage if $l;
 1279: 		}
 1280: 	}
 1281: 
 1282: 	return ($l, $requested_sublanguage);
 1283: }
 1284: 
 1285: # ── _sorted_tokens ────────────────────────────────────────────────────────
 1286: # Purpose:      Parse an Accept-Language header into tokens sorted by
 1287: #               descending quality value so fallback scans honour q= priority.
 1288: # Entry:        $header — validated Accept-Language string.
 1289: # Exit:         Arrayref of [$language_tag, $quality] pairs, highest q first.
 1290: sub _sorted_tokens
 1291: {
●1292 → 1294 → 1303 1292: 	my ($self, $header) = @_;
 1293: 	my @tokens;
 1294: 	for my $token (split /,/, $header) {
 1295: 		$token =~ s/^\s+|\s+$//g;
 1296: 		my $q = 1.0;
 1297: 		if($token =~ s/;\s*q\s*=\s*(\d+(?:\.\d+)?)//) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1298: 			$q = $1 + 0;
 1299: 		}
 1300: 		$token =~ s/^\s+|\s+$//g;
 1301: 		push @tokens, [$token, $q] if length $token;
 1302: 	}
 1303: 	return [sort { $b->[1] <=> $a->[1] } @tokens];
 1304: }
 1305: 
 1306: # ── _scan_sublanguage_pairs ───────────────────────────────────────────────
 1307: # Purpose:      Walk q-sorted tokens looking for xx-yy pairs; try accepting
 1308: #               the base language xx from the supported list.
 1309: # Entry:        $i18n — I18N::AcceptLanguage instance;
 1310: #               $sorted — arrayref from _sorted_tokens.
 1311: # Exit:         ($matched_code, $sublanguage_code) or (undef, undef).
 1312: # Side Effects: Debug logging.
 1313: sub _scan_sublanguage_pairs
 1314: {
●1315 → 1318 → 1328 1315: 	my ($self, $i18n, $sorted) = @_;
 1316: 
 1317: 	$self->_debug(__PACKAGE__, ': ', __LINE__, ': scan q-sorted tokens for xx-yy pairs');
 1318: 	for my $entry (@{$sorted}) {
 1319: 		my ($tag) = @{$entry};
 1320: 		next unless $tag =~ /^(..)-(..)$/;
 1321: 		my ($base, $sub) = ($1, $2);
 1322: 		$self->_debug(__PACKAGE__, ': ', __LINE__, ": see if $base is supported");
 1323: 		if($i18n->accepts($base, $self->{_supported})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1324: 			$self->_debug("Fallback to $base as sublanguage $sub is not supported");
 1325: 			return ($base, $sub);
 1326: 		}
 1327: 	}
 1328: 	return (undef, undef);
 1329: }
 1330: 
 1331: # ── _scan_plain_tokens ────────────────────────────────────────────────────
 1332: # Purpose:      Walk q-sorted tokens that have no sublanguage suffix and try
 1333: #               accepting each against the supported list.
 1334: # Entry:        $i18n — I18N::AcceptLanguage instance;
 1335: #               $sorted — arrayref from _sorted_tokens.
 1336: # Exit:         Matched code string, or undef.
 1337: # Side Effects: Debug logging.
 1338: sub _scan_plain_tokens
 1339: {
●1340 → 1343 → 1352 1340: 	my ($self, $i18n, $sorted) = @_;
 1341: 
 1342: 	$self->_debug(__PACKAGE__, ': ', __LINE__, ': scan q-sorted tokens for plain alternatives');
 1343: 	for my $entry (@{$sorted}) {
 1344: 		my ($tag) = @{$entry};
 1345: 		next if $tag =~ /^..-../;    # already tried in the pair scan
 1346: 		$self->_debug(__PACKAGE__, ': ', __LINE__, ": see if $tag is supported");
 1347: 		if($i18n->accepts($tag, $self->{_supported})) {

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

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1350: 		}
 1351: 	}
 1352: 	return;
 1353: }
 1354: 
 1355: # ── _resolve_match ────────────────────────────────────────────────────────
 1356: # Purpose:      Given a matched code $l (possibly xx or xx-yy), populate all
 1357: #               of _slanguage, _rlanguage, _sublanguage and their code fields.
 1358: # Entry:        $l — 2-char or xx-yy language code; $requested_sublanguage —
 1359: #               2-char variety code or undef; $http_accept_language — full header.
 1360: # Exit:         Returns true (1) if the caller should return immediately.
 1361: # Side Effects: Mutates $self->{_slanguage}, _rlanguage, _sublanguage, etc.
 1362: sub _resolve_match
 1363: {
●1364 → 1368 → 1375 1364: 	my ($self, $l, $requested_sublanguage, $http_accept_language) = @_;
 1365: 
 1366: 	$self->_debug("l: $l");
 1367: 
 1368: 	if($l !~ /^..-../) {

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

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

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1374: 	}
 1375: 	return 0;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1376: }
 1377: 
 1378: # ── _resolve_base_match ───────────────────────────────────────────────────
 1379: # Purpose:      Handle the case where a base-language code matched (no hyphen).
 1380: #               Sets _slanguage, _rlanguage; appends sublanguage name to rlanguage
 1381: #               when the client requested one we don't support.
 1382: # Entry:        $l — 2-char code; $requested_sublanguage — optional; $header.
 1383: # Exit:         1 to signal caller should return, 0 otherwise.
 1384: # Side Effects: Mutates slanguage, rlanguage, slanguage_code_alpha2.
 1385: sub _resolve_base_match
 1386: {
●1387 → 1398 → 1414 1387: 	my ($self, $l, $requested_sublanguage, $header) = @_;
 1388: 
 1389: 	$self->{_slanguage} = $self->_code2language($l);
 1390: 	return 0 unless $self->{_slanguage};

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1391: 
 1392: 	$self->_debug("_slanguage: $self->{_slanguage}");
 1393: 	$self->{_slanguage_code_alpha2} = $l;
 1394: 	$self->{_rlanguage}             = $self->{_slanguage};
 1395: 
 1396: 	# Attempt to name the sublanguage the client actually asked for
 1397: 	my $sl;
 1398: 	if($header =~ /..-(..)$/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1399: 		$self->_debug($1);
 1400: 		$sl = $self->_code2country($1);
 1401: 		$requested_sublanguage //= $1;
 1402: 	} elsif($header =~ /..-([a-z]{2,3})$/i) {
 1403: 		if($_locale_object_db_ok // 1) {

					

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

 1404: 			eval { $sl = Locale::Object::Country->new(code_alpha3 => $1) };
 1405: 			if($@) {

					

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

 1406: 				$_locale_object_db_ok = 0 if $@ =~ /database was not in/;
 1407: 				$self->_info($@);
 1408: 			} else {
 1409: 				$_locale_object_db_ok = 1;
 1410: 			}
 1411: 		}
 1412: 	}
 1413: 
●1414 → 1414 → 1423 1414: 	if($sl) {

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

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1418: 			$self->{_rlanguage} .= " ($c)";
 1419: 		} else {
 1420: 			$self->{_rlanguage} .= " (Unknown: $requested_sublanguage)";
 1421: 		}
 1422: 	}
 1423: 	return 1;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1424: }
 1425: 
 1426: # ── _resolve_sublanguage_match ────────────────────────────────────────────
 1427: # Purpose:      Handle the case where the full xx-yy code matched in the
 1428: #               supported list.  Resolves the variety name and caches results.
 1429: # Entry:        $l — full code e.g. 'en-gb'; $alpha2 — 'en'; $variety — 'gb';
 1430: #               $header — full Accept-Language value.
 1431: # Exit:         1 to signal caller should return, 0 otherwise.
 1432: # Side Effects: Mutates _slanguage, _rlanguage, _sublanguage and code fields;
 1433: #               writes to cache.
 1434: sub _resolve_sublanguage_match
 1435: {
●1436 → 1459 → 1531 1436: 	my ($self, $l, $alpha2, $variety, $header) = @_;
 1437: 
 1438: 	my $i18n    = I18N::AcceptLanguage->new(strict => 1);
 1439: 	my $accepts = $i18n->accepts($l, $self->{_supported});
 1440: 	$self->_debug('accepts = ', $accepts // 'undef');
 1441: 
 1442: 	# $l is an entry of the supported list with a hyphen (e.g. 'en-gb'), so a
 1443: 	# strict match always gives back that same hyphenated entry.  (An earlier
 1444: 	# branch for a hyphen-less answer could never run, and was removed.)
 1445: 	delete $self->{_slanguage} if $accepts;
 1446: 
 1447: 	# Accepts returned something but we couldn't resolve a language name —
 1448: 	# try harder using the variety code directly
 1449: 	$self->{_rlanguage} = $self->_code2language($alpha2);
 1450: 	$self->_debug("_rlanguage: $self->{_rlanguage}");
 1451: 
 1452: 	return 0 unless $accepts;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1453: 
 1454: 	$self->_debug("http_accept_language = $header");
 1455: 	$l =~ /(..)-(..)/;
 1456: 	$variety = lc($2);
 1457: 
 1458: 	# Skip numeric/region codes like en-029
 1459: 	if(($variety =~ /[a-z]{2,3}/) && !defined($self->{_sublanguage})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1460: 		$self->_get_closest($alpha2, $alpha2);
 1461: 		$self->_debug("Find the country code for $variety");
 1462: 
 1463: 		my ($from_cache, $language_name, $db_error);
 1464: 		if($self->{_cache}) {

					

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

 1465: 			$from_cache = $self->_cache_get_valid($CACHE_NS . "variety:$variety", $NAME_CODE_RE);
 1466: 		}
 1467: 
 1468: 		if(defined($from_cache)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1469: 			$self->_debug("$variety is in cache as $from_cache");
 1470: 			# Cache stores "countryname=langcode" (e.g. "United Kingdom=en").
 1471: 			# Splitting on = gives the country name as the first field.
 1472: 			($language_name) = split(/=/, $from_cache);
 1473: 			# A poisoned entry such as "=en" has an empty name; treat it as a miss
 1474: 			undef $language_name unless defined($language_name) && length($language_name);
 1475: 		} elsif($_locale_object_db_ok // 1) {
 1476: 			# Locale::Object's SQLite database is absent on some Windows
 1477: 			# installations; the sentinel avoids repeated failed new() calls.
 1478: 			# Keep the error in a lexical: $@ itself may still hold an
 1479: 			# unrelated error from the caller when this branch is skipped.
 1480: 			eval {
 1481: 				my $db = Locale::Object::DB->new();
 1482: 				my @results = @{$db->lookup(
 1483: 					table         => 'country',
 1484: 					result_column => 'name',
 1485: 					search_column => 'code_alpha2',
 1486: 					value         => $variety
 1487: 				)};
 1488: 				$_locale_object_db_ok = 1;
 1489: 				if(defined($results[0])) {

					

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

 1490: 					$language_name = $self->_code2countryname($variety);
 1491: 				} else {
 1492: 					$self->_debug("Can't find the country code for $variety in Locale::Object::DB");
 1493: 				}
 1494: 				1;
 1495: 			} or $db_error = ($@ || 'unknown error');
 1496: 			if($db_error) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1497: 				$_locale_object_db_ok = 0
 1498: 					if $db_error =~ /database was not in/;
 1499: 				# fall through: $language_name stays undef, caught below
 1500: 			}
 1501: 		}
 1502: 
 1503: 		if($db_error || !defined($language_name)) {

					

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

 1504: 			$self->_warn({ warning => $db_error }) if $db_error;
 1505: 			# Locale::Object DB may be absent (common on Windows CI); fall back to
 1506: 			# the short-name table / Locale::Codes before giving up.
 1507: 			$language_name = $self->_country_short_name($variety);
 1508: 		}
 1509: 		if(!defined($language_name)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1510: 			$self->_debug(__PACKAGE__, ': ', __LINE__, ': setting sublanguage to Unknown');
 1511: 			$self->{_sublanguage} = 'Unknown';
 1512: 			$self->_warn({ warning => "Can't determine values for $header" });
 1513: 		} else {
 1514: 			$self->{_sublanguage} = $language_name;
 1515: 			$self->_debug('variety name ', $self->{_sublanguage});
 1516: 			if($self->{_cache} && !defined($from_cache)) {

					

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

 1517: 				# Store "countryname=langcode" so future cache hits return the country
 1518: 				# name in the first field.  Previously this stored the language name
 1519: 				# ("English=en" for en-gb) which was wrong — the cache-hit branch
 1520: 				# split on = and used the first field as the sublanguage (country) name.
 1521: 				$self->_debug("Set variety:$variety to $language_name=$self->{_slanguage_code_alpha2}");
 1522: 				$self->_cache_call($self->{_cache}, 'set',
 1523: 					$CACHE_NS . "variety:$variety",
 1524: 					"$language_name=$self->{_slanguage_code_alpha2}",
 1525: 					$CACHE_TTL_LONG
 1526: 				);
 1527: 			}
 1528: 		}
 1529: 	}
 1530: 
●1531 → 1531 → 1536 1531: 	if(defined($self->{_sublanguage})) {

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

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1535: 	}
 1536: 	return 0;

					

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

 1537: }
 1538: 
 1539: # ── _find_language_from_ip ────────────────────────────────────────────────
 1540: # Purpose:      Fall back to the visitor's IP country when the Accept-Language
 1541: #               header produced no usable match.  Looks up the official language
 1542: #               of the country and checks it against the supported list.
 1543: # Entry:        $http_accept_language — may be undef if no header was present.
 1544: # Exit:         Mutates _slanguage, _rlanguage via _get_closest if a match found.
 1545: # Side Effects: Calls country(); may write to cache.
 1546: sub _find_language_from_ip
 1547: {
●1548 → 1553 → 1560 1548: 	my ($self, $http_accept_language) = @_;
 1549: 
 1550: 	my $country = $self->country();
 1551: 
 1552: 	# If country() returned nothing, try to derive from the LANG env var
 1553: 	if(!defined($country) && (my $c = $self->_what_language())) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1554: 		if($c =~ /^(..)_(..)/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1555: 			$country = $2;
 1556: 		} elsif($c =~ /^(..)$/) {
 1557: 			$country = $1;
 1558: 		}
 1559: 	}
●1560 → 1565 → 1569 1560: 	return unless defined $country;
 1561: 
 1562: 	$self->_debug("country: $country");
 1563: 
 1564: 	my ($language_name, $language_code2, $from_cache);
 1565: 	if($self->{_cache}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1566: 		$from_cache = $self->_cache_get_valid($CACHE_NS . 'language_name:' . $country, $NAME_CODE_RE);
 1567: 	}
 1568: 
●1569 → 1569 → 1585 1569: 	if($from_cache) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1570: 		$self->_debug("$country is in cache as $from_cache");
 1571: 		($language_name, $language_code2) = split(/=/, $from_cache);
 1572: 	} else {
 1573: 		my $l = $self->_code2country(uc($country));
 1574: 		if($l) {

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

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1577: 				$language_name  = $l->name;
 1578: 				$language_code2 = $l->code_alpha2;
 1579: 				$self->_debug("Official language: $language_name") if $language_name;
 1580: 			}
 1581: 		}
 1582: 	}
 1583: 
 1584: 	# REMOTE_ADDR is absent when the country came from LANG (command-line use)
●1585 → 1588 → 1592 1585: 	my $ip = $ENV{'REMOTE_ADDR'} // '(none)';
 1586: 	return unless $language_name;
 1587: 
 1588: 	if((!defined($self->{_rlanguage})) || ($self->{_rlanguage} eq 'Unknown')) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1589: 		$self->{_rlanguage} = $language_name;
 1590: 	}
 1591: 
●1592 → 1592 → 1638 1592: 	unless((exists $self->{_slanguage}) && ($self->{_slanguage} ne 'Unknown')) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1593: 		my $code;
 1594: 
 1595: 		if($language_name && $language_code2 && !defined($http_accept_language)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1596: 			# Fast-path for search engines that hit with no Accept-Language
 1597: 			$self->_debug("Fast assign to $language_code2");
 1598: 			$code = $language_code2;
 1599: 		} else {
 1600: 			$self->_debug("Call language2code on $self->{_rlanguage}");
 1601: 			$code = Locale::Language::language2code($self->{_rlanguage});
 1602: 
 1603: 			unless($code) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1604: 				if($http_accept_language && ($http_accept_language ne $self->{_rlanguage})) {

					

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

 1605: 					$self->_debug("Call language2code on $http_accept_language");
 1606: 					$code = Locale::Language::language2code($http_accept_language);
 1607: 				}
 1608: 				unless($code) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1609: 					# Norwegian (Nynorsk) — strip the parenthetical qualifier
 1610: 					if($self->{_rlanguage} =~ /(.+)\s\(.+/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1611: 						if((!defined($http_accept_language)) || ($1 ne $self->{_rlanguage})) {

					

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

 1612: 							$self->_debug("Call language2code on $1");
 1613: 							$code = Locale::Language::language2code($1);
 1614: 						}
 1615: 					}
 1616: 					unless($code) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1617: 						$self->_warn({
 1618: 							warning => "Can't determine code from IP $ip for requested language $self->{_rlanguage}"
 1619: 						});
 1620: 					}
 1621: 				}
 1622: 			}
 1623: 		}
 1624: 
 1625: 		if($code) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1626: 			$self->_get_closest($code, $language_code2);
 1627: 			unless($self->{_slanguage}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1628: 				$self->_warn({
 1629: 					warning => "Couldn't determine closest language for $language_name in "
 1630: 						. join(', ', @{$self->{_supported}})
 1631: 				});
 1632: 			} else {
 1633: 				$self->_debug("language set to $self->{_slanguage}, code set to $code");
 1634: 			}
 1635: 		}
 1636: 	}
 1637: 
●1638 → 1638 → 0 1638: 	if(!defined($self->{_slanguage_code_alpha2})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1639: 		$self->_debug("Can't determine slanguage_code_alpha2");
 1640: 	} elsif(!defined($from_cache) && $self->{_cache} && defined($self->{_slanguage_code_alpha2})) {
 1641: 		$self->_debug("Set $country to $language_name=$self->{_slanguage_code_alpha2}");
 1642: 		$self->_cache_call($self->{_cache}, 'set',
 1643: 			$CACHE_NS . 'language_name:' . $country,
 1644: 			"$language_name=$self->{_slanguage_code_alpha2}",
 1645: 			$CACHE_TTL_LONG
 1646: 		);
 1647: 	}
 1648: }
 1649: 
 1650: # ── _get_closest ─────────────────────────────────────────────────────────
 1651: # Purpose:      If $language_string matches the base language of any supported
 1652: #               entry, set _slanguage and _slanguage_code_alpha2.
 1653: # Entry:        $language_string — base code e.g. 'en'; $alpha2 — same or variant.
 1654: # Exit:         Mutates _slanguage and _slanguage_code_alpha2 on match.
 1655: sub _get_closest
 1656: {
●1657 → 1663 → 0 1657: 	my ($self, $language_string, $alpha2) = @_;
 1658: 
 1659: 	# Map each supported entry to its base language code
 1660: 	my %base_languages =
 1661: 		map { /^(.+)-/ ? ($1 => $_) : ($_ => $_) } @{$self->{_supported}};
 1662: 
 1663: 	if(exists $base_languages{$language_string}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1664: 		$self->{_slanguage}             = $self->{_rlanguage};
 1665: 		$self->{_slanguage_code_alpha2} = $alpha2;
 1666: 	}
 1667: }
 1668: 
 1669: # ── _what_language ────────────────────────────────────────────────────────
 1670: # Purpose:      Return the raw (validated, untainted) Accept-Language string,
 1671: #               consulting in priority order: cached value, CGI lang= param,
 1672: #               HTTP_ACCEPT_LANGUAGE env var, LANG env var (local/debug mode).
 1673: # Entry:        May be called as a class method (no $self->{...} access) or
 1674: #               as an object method.
 1675: # Exit:         A validated language string, or undef if nothing available.
 1676: # Side Effects: Caches result in $self->{_what_language} on object calls.
 1677: sub _what_language {
●1678 → 1680 → 1694 1678: 	my $self = $_[0];
 1679: 
 1680: 	if(ref($self)) {

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

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

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

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1687: 			if(my $rc = _info_lang($info, $self)) {

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

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1690: 			}
 1691: 		}
 1692: 	}
 1693: 
●1694 → 1694 → 1709 1694: 	if(my $raw_lang = $ENV{'HTTP_ACCEPT_LANGUAGE'}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1695: 		# Validate and untaint — RFC 7231 §5.3.5 character set plus * wildcard.
 1696: 		# Spaces and tabs only, not \s: CR and LF would carry header, log-line
 1697: 		# and Memcached-command injection into the cache key and messages.
 1698: 		if($raw_lang =~ $ACCEPT_LANG_RE) {

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

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

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1702: 			}
 1703: 			return $rc;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1704: 		} elsif(ref($self)) {
 1705: 			$self->_warn({ warning => 'HTTP_ACCEPT_LANGUAGE contains invalid characters; ignoring' });
 1706: 		}
 1707: 	}
 1708: 
●1709 → 1709 → 1725 1709: 	if(defined($ENV{'LANG'})) {

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

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

					

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

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

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1719: 			}
 1720: 			return $rc;

					

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

 1721: 		} elsif(ref($self)) {
 1722: 			$self->_warn({ warning => 'LANG contains invalid characters; ignoring' });
 1723: 		}
 1724: 	}
 1725: 	return;
 1726: }
 1727: 
 1728: =head2 country
 1729: 
 1730: Returns the two-letter country code (ISO 3166-1) of the visitor,
 1731: in lower case, for example C<'us'>, C<'gb'> or C<'fr'>.
 1732: 
 1733: Returns C<undef> when the country cannot be found, for example when
 1734: C<REMOTE_ADDR> is not set, is not a valid IP address, or is a private
 1735: (C<192.168.1.1>) or loopback (C<127.0.0.1>) address.
 1736: 
 1737: In one special case it returns the string C<'Unknown'>:
 1738: when a source says the address is in the European Union (C<EU>),
 1739: which is not a country.
 1740: 
 1741: Two answers are corrected: C<hk> (Hong Kong) is returned as C<cn>, and a Whois
 1742: record that says C<US> with the state C<PR> is returned as C<pr> (Puerto Rico
 1743: has its own country code; RT#131347).
 1744: 
 1745: See L</Finding the country> for the order in which the sources are tried.
 1746: If you have none of L<IP::Country>, L<Geo::IP> or L<Geo::IPfree> installed,
 1747: every look-up goes over the network, so please use a C<cache> (see L</new>).
 1748: 
 1749: The answer is remembered, so a second call on the same object is fast.
 1750: 
 1751: Note that as of October 2026 geoplugin.net, one of the remote
 1752: fallbacks, no longer has a free tier: it answers with an HTTP 403 and
 1753: a "please upgrade to a paid plan" message, which contains no country
 1754: code, so the lookup falls through to Whois.
 1755: The geoplugin.net code is kept in case that changes.
 1756: 
 1757: Legacy MaxMind F<GeoIP.dat> databases, as used by L<Geo::IP>, are no
 1758: longer updated (Debian's C<geoip-database> package is frozen at
 1759: 2019-12-24), so they can give the wrong country for addresses that
 1760: have been reallocated since then.
 1761: 
 1762: =head3 API SPECIFICATION
 1763: 
 1764: =head4 Input
 1765: 
 1766:     {}
 1767: 
 1768: =head4 Output
 1769: 
 1770:     {
 1771:         type     => 'string',
 1772:         matches  => qr/^(?:[a-z][a-z]|Unknown)$/,
 1773:         optional => 1,
 1774:     }
 1775: 
 1776: =head3 EXAMPLE
 1777: 
 1778:     # Behind Apache mod_geoip: no IP look-up is needed
 1779:     local $ENV{GEOIP_COUNTRY_CODE} = 'DE';
 1780:     my $l = CGI::Lingua->new(supported => ['en']);
 1781:     print $l->country();   # "de"
 1782: 
 1783:     # From the IP address (the answer depends on your geo database)
 1784:     local $ENV{REMOTE_ADDR} = '8.8.8.8';
 1785:     my $l = CGI::Lingua->new(supported => ['en']);
 1786:     print $l->country() // 'not known';   # "us"
 1787: 
 1788: =head3 MESSAGES
 1789: 
 1790: These are warnings. C<country()> does not die.
 1791: 
 1792:     "GEOIP_COUNTRY_CODE contains an invalid country code; ignoring"
 1793:     "HTTP_CF_IPCOUNTRY contains an invalid country code; ignoring"
 1794:     "X.X.X.X isn't a valid IP address"
 1795:     "cache contains a numeric country: N"
 1796:     "IP matches to a numeric country"
 1797:     "geoplugin returned unparseable JSON: ..."
 1798:     "Discarding malformed country code '...'"
 1799:     "geoplugin lookup failed: ..."
 1800:     "Cache get failed: ...", "Cache set failed: ...", "Cache remove failed: ..."
 1801:     "Discarding malformed cache entry for ..."
 1802: 
 1803: These are debug messages, sent only to the logger:
 1804: 
 1805:     "Can't determine country from LAN connection X"
 1806:     "Can't determine country from loopback connection X"
 1807: 
 1808: =head3 PSEUDOCODE
 1809: 
 1810:     1. Return the remembered answer if there is one
 1811:     2. Check GEOIP_COUNTRY_CODE env var (mod_geoip); validate /^[A-Z]{2}\z/
 1812:     3. Check HTTP_CF_IPCOUNTRY (Cloudflare); skip 'XX'; validate /^[A-Z]{2}\z/
 1813:     4. Untaint and validate REMOTE_ADDR; return undef if absent or invalid;
 1814:        change ::ffff:a.b.c.d into a.b.c.d
 1815:     5. Skip private and loopback IPs (return undef)
 1816:     6. Check CHI cache; return cached value if present
 1817:     7. Try IP::Country::Fast (local DB, fastest)
 1818:     8. Try Geo::IP (local DB)
 1819:     9. Try Geo::IPfree (local DB, skip $BROKEN_GEOIPFREE)
 1820:     10. Try geoplugin.net JSON API (LWP::Simple::WithCache;
 1821:         no free tier as of October 2026, so normally yields nothing)
 1822:     11. Last resort: Net::Whois::IP then Net::Whois::IANA
 1823:     12. Sanitise: discard numeric, normalise HK->CN, handle EU special case,
 1824:         discard anything that is not two lower-case letters
 1825:     13. Store in CHI cache; return result
 1826: 
 1827: =cut
 1828: 
 1829: sub country {
●1830 → 1840 → 1846 1830: 	my $self = shift;
 1831: 	local ($@, $!);	# evals and lazy requires below must not leak to the caller
 1832: 
 1833: 	$self->_trace(__PACKAGE__, ': Entered country()');
 1834: 
 1835: 	# Return cached result immediately if a previous call already resolved it.
 1836: 	# Note: undef results (private/loopback IPs) are NOT cached here because
 1837: 	# country() reads REMOTE_ADDR at call time, not construction time; caching
 1838: 	# undef would give wrong answers if REMOTE_ADDR changes between calls on
 1839: 	# the same object (the documented lazy-read design).  See LIMITATIONS.
 1840: 	if($self->{_country}) {

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

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1843: 	}
 1844: 
 1845: 	# mod_geoip: validate against ISO 3166-1 alpha-2 before trusting
●1846 → 1846 → 1856 1846: 	if(defined($ENV{'GEOIP_COUNTRY_CODE'})) {

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

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

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1850: 		} else {
 1851: 			$self->_warn({ warning => 'GEOIP_COUNTRY_CODE contains an invalid country code; ignoring' });
 1852: 		}
 1853: 	}
 1854: 
 1855: 	# Cloudflare: 'XX' means Cloudflare couldn't determine country — skip it
●1856 → 1856 → 1865 1856: 	if(($ENV{'HTTP_CF_IPCOUNTRY'}) && ($ENV{'HTTP_CF_IPCOUNTRY'} ne 'XX')) {

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

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

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1860: 		} else {
 1861: 			$self->_warn({ warning => 'HTTP_CF_IPCOUNTRY contains an invalid country code; ignoring' });
 1862: 		}
 1863: 	}
 1864: 
●1865 → 1870 → 1881 1865: 	my $raw_ip = $ENV{'REMOTE_ADDR'};
 1866: 	return undef unless defined $raw_ip;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1867: 
 1868: 	# Validate and untaint the IP address before passing to any geo module
 1869: 	my $ip = _untaint_ip($raw_ip);
 1870: 	unless(defined($ip)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1871: 		$self->_warn({ warning => "$raw_ip isn't a valid IP address" });
 1872: 		return undef;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1873: 	}
 1874: 
 1875: 	# Data::Validate::IP depends on NetAddr::IP, which fails to build on Windows
 1876: 	# (NetAddr::IP::UtilPP::mask4to6 bad-argument error).  Try to load it once;
 1877: 	# on failure install pure-Perl aliases for the four bare function names used
 1878: 	# below so the rest of the function is unchanged on both platforms.
 1879: 	# Import only those four: a plain import() installs all 29 of the module's
 1880: 	# exports here, where they would become methods of every object.
●1881 → 1881 → 1895 1881: 	if(!defined($_have_dvip)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1882: 		local $SIG{__DIE__};
 1883: 		if(eval { require Data::Validate::IP; Data::Validate::IP->import(qw(is_ipv4 is_ipv6 is_private_ip is_loopback_ip)); 1 }) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1884: 			$_have_dvip = 1;
 1885: 		} else {
 1886: 			$_have_dvip = 0;
 1887: 			no warnings 'redefine';
 1888: 			*CGI::Lingua::is_ipv4       = \&_is_ipv4;
 1889: 			*CGI::Lingua::is_ipv6       = \&_is_ipv6;
 1890: 			*CGI::Lingua::is_private_ip  = \&_is_private_ip;
 1891: 			*CGI::Lingua::is_loopback_ip = \&_is_loopback_ip;
 1892: 		}
 1893: 	}
 1894: 
●1895 → 1895 → 1913 1895: 	if(!is_ipv4($ip)) {

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

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1898: 			$ip = '127.0.0.1';    # normalise loopback
 1899: 		} elsif($ip =~ /^::ffff:(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/i) {
 1900: 			$ip = $1;             # normalise IPv4-mapped IPv6 (::ffff:a.b.c.d) to plain IPv4
 1901: 			# \d{1,3} matches 0-999; validate range before geo lookups because
 1902: 			# some inet_aton implementations wrap out-of-range octets modulo 256,
 1903: 			# turning 999.999.999.999 into a real routable address.
 1904: 			unless(is_ipv4($ip)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1905: 				$self->_warn({ warning => "$ip isn't a valid IP address" });
 1906: 				return undef;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1907: 			}
 1908: 		} elsif(!is_ipv6($ip)) {
 1909: 			$self->_warn({ warning => "$ip isn't a valid IP address" });
 1910: 			return undef;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1911: 		}
 1912: 	}
●1913 → 1913 → 1917 1913: 	if(is_private_ip($ip)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1914: 		$self->_debug("Can't determine country from LAN connection $ip");
 1915: 		return undef;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1916: 	}
●1917 → 1917 → 1923 1917: 	if(is_loopback_ip($ip)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1918: 		$self->_debug("Can't determine country from loopback connection $ip");
 1919: 		return undef;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1920: 	}
 1921: 
 1922: 	# Cache look-up — skip for LAN/loopback (already returned above)
●1923 → 1923 → 1945 1923: 	if($self->{_cache}) {

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

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

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1927: 				$self->_warn({ warning => 'cache contains a numeric country: ' . $self->{_country} });
 1928: 				$self->_cache_call($self->{_cache}, 'remove', $CACHE_NS . "country:$ip");
 1929: 				delete $self->{_country};
 1930: 			} elsif(ref($self->{_country}) || ($self->{_country} !~ $COUNTRY_RE)) {
 1931: 				# Poisoned entry ("gb<script>", a hashref): same checks as a
 1932: 				# fresh look-up, or the cache would bypass them
 1933: 				$self->_warn({ warning => "Discarding malformed cache entry for ${CACHE_NS}country:$ip" });
 1934: 				$self->_cache_call($self->{_cache}, 'remove', $CACHE_NS . "country:$ip");
 1935: 				delete $self->{_country};
 1936: 			} else {
 1937: 				$self->_debug("Get $ip from cache = $self->{_country}");
 1938: 				return $self->{_country};

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1939: 			}
 1940: 		}
 1941: 		$self->_debug("$ip isn't in the cache");
 1942: 	}
 1943: 
 1944: 	# Try IP::Country first (fastest, local database)
●1945 → 1945 → 1955 1945: 	if($self->{_have_ipcountry} == $GEO_UNKNOWN) {

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

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1947: 			# Require the concrete class directly; IP::Country->import() is not needed
 1948: 			# because IP::Country::Fast->new() is a fully-qualified class method call.
 1949: 			$self->{_have_ipcountry} = $GEO_PRESENT;
 1950: 			$self->{_ipcountry}      = IP::Country::Fast->new();
 1951: 		} else {
 1952: 			$self->{_have_ipcountry} = $GEO_ABSENT;
 1953: 		}
 1954: 	}
●1955 → 1957 → 1967 1955: 	$self->_debug("have_ipcountry $self->{_have_ipcountry}");
 1956: 
 1957: 	if($self->{_have_ipcountry}) {

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

					

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

 1960: 			$self->{_country} = lc($self->{_country});
 1961: 		} elsif(is_ipv4($ip)) {
 1962: 			$self->_debug("$ip is not known by IP::Country");
 1963: 		}
 1964: 	}
 1965: 
 1966: 	# Try Geo::IP if IP::Country gave nothing
●1967 → 1967 → 1998 1967: 	unless(defined($self->{_country})) {

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

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1969: 			$self->_load_geoip();
 1970: 		}
 1971: 		if($self->{_have_geoip} == $GEO_PRESENT) {

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1972: 			$self->{_country} = $self->{_geoip}->country_code_by_addr($ip);
 1973: 		}
 1974: 
 1975: 		# Geo::IPfree has a known-broken entry for $BROKEN_GEOIPFREE
 1976: 		if(!defined($self->{_country}) && ($ip ne $BROKEN_GEOIPFREE)) {

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

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

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1980: 					# No ->import(): Geo::IPfree uses only OO (->LookUp); the old
 1981: 					# Geo::IPfree::IP->import() call was a wrong package and could
 1982: 					# clobber Test::Mockingbird mocks on some versions.
 1983: 					$self->{_have_geoipfree} = $GEO_PRESENT;
 1984: 					$self->{_geoipfree}      = Geo::IPfree->new();
 1985: 				} else {
 1986: 					$self->{_have_geoipfree} = $GEO_ABSENT;
 1987: 				}
 1988: 			}
 1989: 			if($self->{_have_geoipfree} == $GEO_PRESENT) {

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

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1991: 					$self->{_country} = lc($country);
 1992: 				}
 1993: 			}
 1994: 		}
 1995: 	}
 1996: 
 1997: 	# 'eu' is not a real country — discard
●1998 → 1998 → 2003 1998: 	if($self->{_country} && ($self->{_country} eq 'eu')) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1999: 		delete $self->{_country};
 2000: 	}
 2001: 
 2002: 	# Remote JSON lookup via geoplugin
●2003 → 2003 → 2031 2003: 	if((!$self->{_country}) &&

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2004: 	   (eval { require LWP::Simple::WithCache; require JSON::Parse })) {
 2005: 		$self->_debug("Look up $ip on geoplugin");
 2006: 
 2007: 		# A timeout or connection error must not take down the request;
 2008: 		# fall through to Whois instead
 2009: 		my $data = eval { local $SIG{__DIE__}; LWP::Simple::WithCache::get("https://www.geoplugin.net/json.gp?ip=$ip") };
 2010: 		$self->_warn({ warning => "geoplugin lookup failed: $@" }) if $@;
 2011: 		if($data) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2012: 			eval { $self->{_country} = JSON::Parse::parse_json($data)->{'geoplugin_countryCode'} };
 2013: 			$self->_warn({ warning => "geoplugin returned unparseable JSON: $@" }) if $@;
 2014: 		}
 2015: 
 2016: 		# Check the answer now rather than at the end: a junk value (an object,
 2017: 		# "GB<script>") is true, so it would stop the Whois fallback below and
 2018: 		# then be thrown away, leaving no country at all
 2019: 		my $v = $self->{_country};
 2020: 		if(defined($v) && (ref($v) || $v !~ /^[A-Za-z]{2}\z/)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2021: 			if(!ref($v) && length($v) && ($v !~ /\D/)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2022: 				$self->_warn({ warning => 'IP matches to a numeric country' });
 2023: 			} elsif(ref($v) || length($v)) {
 2024: 				$self->_warn({ warning => q{Discarding malformed country code '} . lc($v) . q{'} });
 2025: 			}
 2026: 			delete $self->{_country};
 2027: 		}
 2028: 	}
 2029: 
 2030: 	# Last resort: Whois
●2031 → 2031 → 2036 2031: 	unless($self->{_country}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2032: 		$self->_resolve_country_via_whois($ip);
 2033: 	}
 2034: 
 2035: 	# Sanitise and normalise whatever we found
●2036 → 2036 → 2074 2036: 	if($self->{_country}) {

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

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2038: 			$self->_warn({ warning => 'IP matches to a numeric country' });
 2039: 			delete $self->{_country};
 2040: 		} else {
 2041: 			$self->{_country} = lc($self->{_country});
 2042: 
 2043: 			# Legacy mappings
 2044: 			if($self->{_country} eq 'hk') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2045: 				$self->{_country} = 'cn';    # HK is no longer a separate country in Whois
 2046: 			} elsif($self->{_country} eq 'eu') {
 2047: 				$self->_handle_eu_country($ip);
 2048: 			}
 2049: 
 2050: 			if($self->{_country} && ($self->{_country} !~ /\D/)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2051: 				$self->_warn({ warning => "cache contains a numeric country: $self->{_country}" });
 2052: 				delete $self->{_country};
 2053: 			} elsif($self->{_country} &&
 2054: 				$self->{_country} ne 'Unknown' &&
 2055: 				($self->{_country} !~ /^[a-z]{2}$/)) {
 2056: 				# Reject anything that is not exactly 2 lowercase ASCII letters,
 2057: 				# unless it is the 'Unknown' sentinel written by _handle_eu_country
 2058: 				# for EU addresses that do not map to a specific country.
 2059: 				# Guards against Whois CRLF injection leftovers ("gbx-header: evil")
 2060: 				# and XSS payloads in JSON API responses ("gb<script>...</script>").
 2061: 				$self->_warn({ warning => "Discarding malformed country code '$self->{_country}'" });
 2062: 				delete $self->{_country};
 2063: 			} elsif($self->{_country} && $self->{_cache}) {
 2064: 				$self->_debug("Set $ip to $self->{_country}");
 2065: 				$self->_cache_call($self->{_cache}, 'set',
 2066: 					$CACHE_NS . "country:$ip",
 2067: 					$self->{_country},
 2068: 					$CACHE_TTL_SHORT
 2069: 				);
 2070: 			}
 2071: 		}
 2072: 	}
 2073: 
 2074: 	return $self->{_country};

  Mutants (Total: 2, Killed: 2, Survived: 0)
 2075: }
 2076: 
 2077: # ── _resolve_country_via_whois ─────────────────────────────────────────────
 2078: # Purpose:      Attempt Net::Whois::IP then Net::Whois::IANA as a last resort.
 2079: # Entry:        $ip — validated, untainted IP string.
 2080: # Exit:         Sets $self->{_country} if a result was found.
 2081: # Side Effects: Network I/O; logs debug messages.
 2082: sub _resolve_country_via_whois
 2083: {
●2084 → 2099 → 2115 2084: 	my ($self, $ip) = @_;
 2085: 
 2086: 	$self->_debug("Look up $ip on Whois");
 2087: 
 2088: 	require Net::Whois::IP;
 2089: 	# No ->import(): whoisip_query is called fully-qualified, so import is unneeded
 2090: 	# and on some versions reinstalls the real function, clobbering Test::Mockingbird mocks.
 2091: 
 2092: 	my $whois;
 2093: 	eval {
 2094: 		# Catch connection timeouts by converting Carp::carp into a die
 2095: 		local $SIG{__WARN__} = sub { die $_[0] };
 2096: 		$whois = Net::Whois::IP::whoisip_query($ip);
 2097: 	};
 2098: 
 2099: 	unless($@ || !defined($whois) || (ref($whois) ne 'HASH')) {

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

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2101: 			$self->{_country} = $whois->{Country};
 2102: 		} elsif(defined($whois->{country})) {
 2103: 			$self->{_country} = $whois->{country};
 2104: 		}
 2105: 		if($self->{_country}) {

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

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2107: 				delete $self->{_country};
 2108: 			} elsif(($self->{_country} eq 'US') && defined($whois->{'StateProv'}) && ($whois->{'StateProv'} eq 'PR')) {
 2109: 				# RT#131347: Puerto Rico is not the US
 2110: 				$self->{_country} = 'pr';
 2111: 			}
 2112: 		}
 2113: 	}
 2114: 
●2115 → 2115 → 2124 2115: 	if($self->{_country}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2116: 		$self->_debug("Found $ip on Net::Whois::IP as ", $self->{_country});
 2117: 		$self->{_country} = _clean_country_code($self->{_country});
 2118: 		# _clean_country_code returns undef for malformed values (e.g. CRLF
 2119: 		# injection leftovers); if so, fall through to the IANA look-up.
 2120: 		return if defined $self->{_country};
 2121: 		delete $self->{_country};
 2122: 	}
 2123: 
●2124 → 2133 → 2146 2124: 	$self->_debug("Look up $ip on IANA");
 2125: 
 2126: 	require Net::Whois::IANA;
 2127: 	# No ->import(): Net::Whois::IANA->new() is a class method; import not needed.
 2128: 
 2129: 	# The whole IANA exchange is in one eval: new(), the query and the parse
 2130: 	# of the answer can all die on a network or protocol error, and this is
 2131: 	# the last resort, so a failure simply means "no country"
 2132: 	my $country;
 2133: 	if(eval {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2134: 		local $SIG{__DIE__};
 2135: 		my $iana = Net::Whois::IANA->new();
 2136: 		$iana->whois_query(-ip => $ip);
 2137: 		$country = $iana->country();
 2138: 		1;
 2139: 	}) {
 2140: 		$self->{_country} = $country;
 2141: 		$self->_debug("IANA reports $ip as ", $self->{_country});
 2142: 	} else {
 2143: 		$self->_debug("IANA look-up of $ip failed: $@");
 2144: 	}
 2145: 
●2146 → 2146 → 0 2146: 	if($self->{_country}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2147: 		$self->{_country} = _clean_country_code($self->{_country});
 2148: 		delete $self->{_country} unless defined $self->{_country};
 2149: 	}
 2150: }
 2151: 
 2152: # ── _clean_country_code ───────────────────────────────────────────────────
 2153: # Purpose:      Strip carriage returns and trailing "#…" comments that some
 2154: #               Whois servers append to their country field
 2155: #               (e.g. "US\r", "GB # United Kingdom").
 2156: # Entry:        $raw — raw country string from a Whois response.
 2157: # Exit:         Cleaned 2-char country code string.
 2158: sub _clean_country_code
 2159: {
●2160 → 2167 → 2170 2160: 	my ($raw) = @_;
 2161: 	return unless defined($raw);
 2162: 	$raw =~ s/[\r\n]//g;
 2163: 	# Accept exactly 2 alpha chars, optionally followed by whitespace and a
 2164: 	# comment (e.g. "GB # United Kingdom").  Anything else (CRLF injection
 2165: 	# leftovers, embedded headers) returns undef so the caller can discard it
 2166: 	# rather than propagating a malformed string through the geo pipeline.
 2167: 	if($raw =~ /^([A-Za-z]{2})\s*(?:#.*)?$/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2168: 		return $1;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 2169: 	}
 2170: 	return;
 2171: }
 2172: 
 2173: # ── _in_baidu_subnet ──────────────────────────────────────────────────────
 2174: # Purpose:      Pure-Perl fallback check for the Baidu IPv4 subnet
 2175: #               185.10.104.0/22.  Used when Net::Subnet is absent (e.g. on
 2176: #               Windows where its Socket6 dependency fails to build).
 2177: # Entry:        $ip — untainted IPv4 string.
 2178: # Exit:         Returns true if $ip is within the /22 block, false otherwise.
 2179: sub _in_baidu_subnet
 2180: {
 2181: 	my $ip = shift;
 2182: 	return 0 unless defined($ip) && $ip =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})\z/a;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 2183: 	# pack('C') wraps octets above 255 (300 becomes 44), which would put a
 2184: 	# malformed address such as 185.10.104.300 inside the subnet
 2185: 	return 0 if grep { $_ > 255 } ($1, $2, $3, $4);

  Mutants (Total: 5, Killed: 5, Survived: 0)
 2186: 	# pack/unpack avoids signed-integer overflow on 32-bit Perl
 2187: 	my $n   = unpack('N', pack('C4', $1, $2, $3, $4));
 2188: 	my $net = unpack('N', pack('C4', 185, 10, 104, 0));
 2189: 	return (($n & 0xFFFFFC00) == ($net & 0xFFFFFC00));

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2190: }
 2191: 
 2192: # ── _handle_eu_country ────────────────────────────────────────────────────
 2193: # Purpose:      Resolve the ambiguous 'eu' country code.  RT-86809 shows that
 2194: #               Baidu reports itself as EU when it is actually in CN.  All
 2195: #               other 'eu' addresses are logged as Unknown.
 2196: # Entry:        $ip — validated, untainted IP string.
 2197: # Exit:         Sets $self->{_country} to 'cn' or 'Unknown'.
 2198: # Side Effects: Optionally loads Net::Subnet; writes info log entry.
 2199: sub _handle_eu_country
 2200: {
●2201 → 2206 → 2212 2201: 	my ($self, $ip) = @_;
 2202: 
 2203: 	# Prefer Net::Subnet for correctness; fall back to the pure-Perl helper
 2204: 	# when it is absent (Socket6, its indirect dep, fails to build on Windows).
 2205: 	my $in_baidu;
 2206: 	if(eval { require Net::Subnet; Net::Subnet->import(); 1 }) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2207: 		$in_baidu = subnet_matcher($BAIDU_SUBNET)->($ip);
 2208: 	} else {
 2209: 		$in_baidu = _in_baidu_subnet($ip);
 2210: 	}
 2211: 
●2212 → 2212 → 0 2212: 	if($in_baidu) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2213: 		$self->{_country} = 'cn';
 2214: 	} else {
 2215: 		$self->_info("$ip has country of eu");
 2216: 		$self->{_country} = 'Unknown';
 2217: 	}
 2218: }
 2219: 
 2220: # ── _load_geoip ───────────────────────────────────────────────────────────
 2221: # Purpose:      Probe for the Geo::IP database file and the Geo::IP module;
 2222: #               set _have_geoip and initialise _geoip on success.
 2223: # Entry:        _have_geoip must be GEO_UNKNOWN.
 2224: # Exit:         _have_geoip set to GEO_PRESENT or GEO_ABSENT.
 2225: # Side Effects: Requires Geo::IP; opens GeoIP.dat.
 2226: sub _load_geoip
 2227: {
●2228 → 2233 → 2238 2228: 	my $self = shift;
 2229: 
 2230: 	# Check for the database file before even trying to load the module
 2231: 	# (avoids noisy errors on Windows — CPANTESTERS report 54117bd0)
 2232: 	my ($dat) = grep { -f $_ && -r _ } @GEOIP_DAT;
 2233: 	unless(defined($dat)) {

					

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

 2234: 		$self->{_have_geoip} = $GEO_ABSENT;
 2235: 		return;
 2236: 	}
 2237: 
●2238 → 2238 → 2247 2238: 	unless(eval { local $SIG{__DIE__}; require Geo::IP; 1 }) {

					

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

 2239: 		$self->{_have_geoip} = $GEO_ABSENT;
 2240: 		return;
 2241: 	}
 2242: 
 2243: 	# No ->import(): Geo::IP->open() is a class method.  GEOIP_STANDARD = 0
 2244: 	# (the constant cannot be used by name).  A corrupt or truncated file makes
 2245: 	# open() die or return undef; treat that as no database, rather than let
 2246: 	# country() call a method on undef later.
●[NOT COVERED] 2247 → 2248 → 0 2247: 	my $geoip = eval { local $SIG{__DIE__}; Geo::IP->open($dat, 0) };
 2248: 	if(Scalar::Util::blessed($geoip)) {

					

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

 2249: 		$self->{_have_geoip} = $GEO_PRESENT;
 2250: 		$self->{_geoip}      = $geoip;
 2251: 	} else {
 2252: 		$self->_warn({ warning => "Can't open $dat with Geo::IP; not using it" });
 2253: 		$self->{_have_geoip} = $GEO_ABSENT;
 2254: 	}
 2255: }
 2256: 
 2257: =head2 locale
 2258: 
 2259: Returns a L<Locale::Object::Country> object for the visitor's country.
 2260: You can use it to find, for example, the currency or the country's name.
 2261: 
 2262: HTTP does not send a browser's local settings (such as the currency or the
 2263: date format), so this is a B<best guess>. It is not always right.
 2264: 
 2265: It tries these, in order:
 2266: 
 2267: =over 4
 2268: 
 2269: =item 1. A language tag such as C<en-GB> inside the C<HTTP_USER_AGENT> string.
 2270: 
 2271: =item 2. L<HTTP::BrowserDetect>, if it is installed.
 2272: 
 2273: =item 3. L</country>.
 2274: 
 2275: =item 4. C<GEOIP_COUNTRY_CODE>.
 2276: 
 2277: =back
 2278: 
 2279: Returns C<undef> when nothing is found.
 2280: 
 2281: =head3 API SPECIFICATION
 2282: 
 2283: =head4 Input
 2284: 
 2285:     {}
 2286: 
 2287: =head4 Output
 2288: 
 2289:     {
 2290:         type     => 'object',
 2291:         isa      => 'Locale::Object::Country',
 2292:         optional => 1,
 2293:     }
 2294: 
 2295: =head3 EXAMPLE
 2296: 
 2297:     local $ENV{REMOTE_ADDR} = '8.8.8.8';
 2298:     my $l = CGI::Lingua->new(supported => ['en']);
 2299:     if(my $locale = $l->locale()) {
 2300:         print $locale->name(), "\n";              # e.g. "United States"
 2301:         print $locale->currency()->code(), "\n";  # e.g. "USD"
 2302:     }
 2303: 
 2304: =head3 MESSAGES
 2305: 
 2306:     "HTTP_USER_AGENT contains invalid characters or exceeds length limit; ignoring"
 2307: 
 2308: =head3 PSEUDOCODE
 2309: 
 2310:     1. Return the remembered answer if there is one
 2311:     2. Parse HTTP_USER_AGENT parenthetical for xx-YY language tag
 2312:     3. Try HTTP::BrowserDetect on the full User-Agent string
 2313:     4. Fall back to country() IP lookup
 2314:     5. Fall back to GEOIP_COUNTRY_CODE env var (ISO 3166-1 validated)
 2315:     6. Return undef if all strategies fail
 2316: 
 2317: =cut
 2318: 
 2319: sub locale {
●2320 → 2329 → 2338 2320: 	my $self = shift;
 2321: 	local ($@, $!);	# evals below must not leak to the caller
 2322: 
 2323: 	return $self->{_locale} if $self->{_locale};

  Mutants (Total: 2, Killed: 2, Survived: 0)
 2324: 
 2325: 	# Validate and untaint HTTP_USER_AGENT before passing to any parser.
 2326: 	# The User-Agent header is attacker-controlled; apply the same discipline
 2327: 	# as HTTP_ACCEPT_LANGUAGE.  Printable ASCII (0x20-0x7e), bounded length.
 2328: 	my $agent;
 2329: 	if(defined(my $raw_agent = $ENV{'HTTP_USER_AGENT'})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2330: 		if($raw_agent =~ /^([\x20-\x7e]{1,$UA_MAX})$/a) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2331: 			$agent = $1;    # untainted
 2332: 		} else {
 2333: 			$self->_warn({ warning => 'HTTP_USER_AGENT contains invalid characters or exceeds length limit; ignoring' });
 2334: 		}
 2335: 	}
 2336: 
 2337: 	# First try: parse the language tag from the User-Agent parenthetical
●2338 → 2338 → 2371 2338: 	if(defined($agent) && ($agent =~ /\((.+)\)/)) {

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

					

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

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

					

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

 2346: 					$self->{_locale} = $c;
 2347: 					return $c;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 2348: 				}
 2349: 			}
 2350: 		}
 2351: 
 2352: 		# Second try: HTTP::BrowserDetect (works for more User-Agents)
 2353: 		if(eval { require HTTP::BrowserDetect }) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2354: 			HTTP::BrowserDetect->import();
 2355: 			my $browser = HTTP::BrowserDetect->new($agent);
 2356: 			# Validate country() result before use — the return value comes from
 2357: 			# the third-party module and is not yet untainted or range-checked.
 2358: 			if($browser) {

					

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

 2359: 				my $bc = $browser->country() // '';
 2360: 				if($bc =~ /^([A-Za-z]{2})$/a) {

					

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

 2361: 					if(my $c = $self->_code2country($1)) {

					

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

 2362: 						$self->{_locale} = $c;
 2363: 						return $c;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 2364: 					}
 2365: 				}
 2366: 			}
 2367: 		}
 2368: 	}
 2369: 
 2370: 	# Third try: IP address
●2371 → 2372 → 2389 2371: 	my $country = $self->country();
 2372: 	if($country) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2373: 		$country =~ s/[\r\n]//g;
 2374: 		my $c;
 2375: 		eval {
 2376: 			local $SIG{__WARN__} = sub { die $_[0] };
 2377: 			$c = $self->_code2country($country);
 2378: 		};
 2379: 		unless($@) {

					

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

 2380: 			if($c) {

					

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

 2381: 				$self->{_locale} = $c;
 2382: 				return $c;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 2383: 			}
 2384: 		}
 2385: 	}
 2386: 
 2387: 	# Fourth try: mod_geoip env var — apply the same ISO 3166-1 validation
 2388: 	# used in country() to guard against spoofed or malformed values
●2389 → 2389 → 2397 2389: 	if(defined($ENV{'GEOIP_COUNTRY_CODE'})) {

					

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

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

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

					

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

 2392: 				$self->{_locale} = $c;
 2393: 				return $c;

					

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

 2394: 			}
 2395: 		}
 2396: 	}
 2397: 	return undef;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 2398: }
 2399: 
 2400: =head2 time_zone
 2401: 
 2402: Returns the visitor's time zone, as an IANA time zone name,
 2403: for example C<'Europe/London'> or C<'America/New_York'>.
 2404: 
 2405: When C<REMOTE_ADDR> is set, it uses L<Geo::IP> if a database is installed,
 2406: and otherwise asks the ip-api.com web service (this needs
 2407: L<LWP::Simple::WithCache> or L<LWP::Simple>, and L<JSON::Parse>).
 2408: 
 2409: When C<REMOTE_ADDR> is not set (for example on the command line),
 2410: it returns the time zone of the computer that runs the program.
 2411: 
 2412: Returns C<undef> when the time zone cannot be found.
 2413: 
 2414: =head3 API SPECIFICATION
 2415: 
 2416: =head4 Input
 2417: 
 2418:     {}
 2419: 
 2420: =head4 Output
 2421: 
 2422:     {
 2423:         type     => 'string',
 2424:         matches  => qr/^[A-Za-z][A-Za-z0-9_+\-\/]*$/,
 2425:         optional => 1,
 2426:     }
 2427: 
 2428: =head3 EXAMPLE
 2429: 
 2430:     local $ENV{REMOTE_ADDR} = '8.8.8.8';
 2431:     my $l = CGI::Lingua->new(supported => ['en']);
 2432:     print $l->time_zone() // 'unknown';   # e.g. "America/New_York"
 2433: 
 2434: =head3 MESSAGES
 2435: 
 2436: These are warnings. C<time_zone()> does not die.
 2437: 
 2438:     "Couldn't determine the timezone"
 2439:     "X.X.X.X isn't a valid IP address"
 2440:     "LWP::Simple::WithCache and LWP::Simple are both absent; cannot contact ip-api.com"
 2441:     "JSON::Parse is absent; cannot read ip-api.com answers"
 2442:     "ip-api.com returned unparseable JSON: ..."
 2443:     "DateTime::TimeZone::Local failed: ..."
 2444:     "Discarding malformed timezone '...'"
 2445:     "ip-api.com lookup failed: ..."
 2446: 
 2447: =head3 PSEUDOCODE
 2448: 
 2449:     1. Return the remembered answer if there is one
 2450:     2. If REMOTE_ADDR is set:
 2451:        a. Untaint and validate the IP
 2452:        b. Try Geo::IP->time_zone() (local DB)
 2453:        c. Try LWP::Simple::WithCache + JSON::Parse against ip-api.com
 2454:        d. Fall back to LWP::Simple + JSON::Parse against ip-api.com
 2455:        e. Warn and return undef if neither LWP variant, or JSON::Parse,
 2456:           is installed (the warning names the missing module)
 2457:     3. If REMOTE_ADDR is absent (local/CLI mode):
 2458:        a. Read /etc/timezone if readable
 2459:        b. Fall back to DateTime::TimeZone::Local->TimeZone()->name()
 2460:     4. Discard the answer if it does not look like an IANA name
 2461:     5. Warn "Couldn't determine the timezone" and return undef if all fail
 2462: 
 2463: =cut
 2464: 
 2465: sub time_zone {
●2466 → 2471 → 2476 2466: 	my $self = shift;
 2467: 	local ($@, $!);	# evals, open() and HTTP calls must not leak to the caller
 2468: 
 2469: 	$self->_trace('Entered time_zone');
 2470: 
 2471: 	if($self->{_timezone}) {

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

  Mutants (Total: 2, Killed: 2, Survived: 0)
 2474: 	}
 2475: 
●2476 → 2478 → 2545 2476: 	my $raw_ip = $ENV{'REMOTE_ADDR'};
 2477: 
 2478: 	if(defined $raw_ip) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2479: 		# Untaint before any external use — kept in sync with country()'s pattern,
 2480: 		# including the mixed-notation branch for ::ffff:a.b.c.d addresses.
 2481: 		my $ip = _untaint_ip($raw_ip);
 2482: 		unless(defined($ip)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2483: 			$self->_warn({ warning => "$raw_ip isn't a valid IP address" });
 2484: 			return undef;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 2485: 		}
 2486: 
 2487: 		if($self->{_have_geoip} == $GEO_UNKNOWN) {

  Mutants (Total: 2, Killed: 2, Survived: 0)
 2488: 			$self->_load_geoip();
 2489: 		}
 2490: 		if($self->{_have_geoip} == $GEO_PRESENT) {

  Mutants (Total: 2, Killed: 2, Survived: 0)
 2491: 			eval { $self->{_timezone} = $self->{_geoip}->time_zone($ip) };
 2492: 		}
 2493: 
 2494: 		unless($self->{_timezone}) {

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

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2496: 				$self->_debug("Look up $ip on ip-api.com");
 2497: 
 2498: 				my $data = eval { local $SIG{__DIE__}; LWP::Simple::WithCache::get("http://ip-api.com/json/$ip") };
 2499: 				$self->_warn({ warning => "ip-api.com lookup failed: $@" }) if $@;
 2500: 				if($data) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2501: 					eval { $self->{_timezone} = JSON::Parse::parse_json($data)->{'timezone'} };
 2502: 					$self->_warn({ warning => "ip-api.com returned unparseable JSON: $@" }) if $@;
 2503: 				}
 2504: 			} elsif(eval { require LWP::Simple; require JSON::Parse }) {
 2505: 				$self->_debug("Look up $ip on ip-api.com");
 2506: 
 2507: 				my $data = eval { local $SIG{__DIE__}; LWP::Simple::get("http://ip-api.com/json/$ip") };
 2508: 				$self->_warn({ warning => "ip-api.com lookup failed: $@" }) if $@;
 2509: 				if($data) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2510: 					eval { $self->{_timezone} = JSON::Parse::parse_json($data)->{'timezone'} };
 2511: 					$self->_warn({ warning => "ip-api.com returned unparseable JSON: $@" }) if $@;
 2512: 				}
 2513: 			} else {
 2514: 				# A module is missing — degrade gracefully rather than killing the
 2515: 				# entire request with a croak; caller can check for undef.  Name the
 2516: 				# module that is really missing: an LWP may be present without JSON::Parse.
 2517: 				if(eval { require LWP::Simple::WithCache; 1 } || eval { require LWP::Simple; 1 }) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2518: 					$self->_warn({ warning => 'JSON::Parse is absent; cannot read ip-api.com answers' });
 2519: 				} else {
 2520: 					$self->_warn({ warning => 'LWP::Simple::WithCache and LWP::Simple are both absent; cannot contact ip-api.com' });
 2521: 				}
 2522: 			}
 2523: 		}
 2524: 	} else {
 2525: 		# Local connection — read from /etc/timezone or DateTime::TimeZone
 2526: 		if(defined(my $tz = $self->_read_zone_file())) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2527: 			$self->{_timezone} = $tz;
 2528: 		} else {
 2529: 			# DateTime::TimeZone::Local::TimeZone() is not available on all
 2530: 			# platforms/versions (absent on some Windows Perl builds); guard
 2531: 			# so time_zone() degrades to undef rather than dying.
 2532: 			eval {
 2533: 				local $SIG{__DIE__};
 2534: 				require DateTime::TimeZone::Local;
 2535: 				$self->{_timezone} = DateTime::TimeZone::Local->TimeZone()->name();
 2536: 			};
 2537: 			$self->_warn({ warning => "DateTime::TimeZone::Local failed: $@" }) if $@;
 2538: 		}
 2539: 	}
 2540: 
 2541: 	# Validate the timezone string against a permissive but bounded IANA pattern.
 2542: 	# Rejects XSS payloads (e.g. "Europe/London<script>...") from hostile JSON
 2543: 	# responses while accepting all real IANA zone names (e.g. "America/New_York",
 2544: 	# "Etc/GMT+8", "UTC").
●2545 → 2545 → 2551 2545: 	if(defined($self->{_timezone}) &&

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2546: 	   (ref($self->{_timezone}) || ($self->{_timezone} !~ $ZONE_RE))) {
 2547: 		$self->_warn({ warning => "Discarding malformed timezone '" . _printable($self->{_timezone}) . "'" });
 2548: 		delete $self->{_timezone};
 2549: 	}
 2550: 
●2551 → 2551 → 2554 2551: 	unless(defined($self->{_timezone})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2552: 		$self->_warn({ warning => "Couldn't determine the timezone" });
 2553: 	}
 2554: 	return $self->{_timezone};

  Mutants (Total: 2, Killed: 2, Survived: 0)
 2555: }
 2556: 
 2557: # ── _read_zone_file ──────────────────────────────────────────────────────
 2558: # Purpose:      Read the system time zone name from $ZONE_FILE (normally
 2559: #               /etc/timezone) for command-line use.
 2560: # Entry:        none.
 2561: # Exit:         The zone name, or undef if the file is missing, unreadable,
 2562: #               not a regular file, empty, or does not hold a zone name.
 2563: # Notes:        Only a regular file is opened, and at most $ZONE_FILE_MAX bytes
 2564: #               are read: a symlink to /dev/zero or /dev/urandom, or a huge
 2565: #               file, must not hang the request or exhaust memory.  CORE::
 2566: #               calls bypass autodie, so a failure returns undef, not a die.
 2567: sub _read_zone_file
 2568: {
●2569 → 2579 → 2583 2569: 	my $self = shift;
 2570: 
 2571: 	return undef unless -f $ZONE_FILE && -r _;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 2572: 	CORE::open(my $fin, '<', $ZONE_FILE) or return undef;
 2573: 	my $got = CORE::read($fin, my $buf, $ZONE_FILE_MAX);
 2574: 	CORE::close($fin);
 2575: 	return undef unless $got;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 2576: 
 2577: 	# First word of the file; surrounding spaces and newlines are not part of it
 2578: 	my ($zone) = $buf =~ /\A\s*(\S+)/;
 2579: 	unless(defined($zone) && ($zone =~ $ZONE_RE)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2580: 		$self->_debug("$ZONE_FILE does not hold a time zone name");
 2581: 		return undef;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 2582: 	}
 2583: 	return $zone;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 2584: }
 2585: 
 2586: =head2 is_rtl
 2587: 
 2588: Returns C<1> if the chosen language is written from right to left,
 2589: and C<0> if it is not.
 2590: 
 2591: The right-to-left languages are Arabic (C<ar>), Dhivehi (C<dv>),
 2592: Persian (C<fa>), Hebrew (C<he>), Kurdish (C<ku>), Pashto (C<ps>),
 2593: Sindhi (C<sd>), Uyghur (C<ug>), Urdu (C<ur>) and Yiddish (C<yi>).
 2594: 
 2595: When no language was found, it returns C<0>.
 2596: 
 2597: =head3 API SPECIFICATION
 2598: 
 2599: =head4 Input
 2600: 
 2601:     {}
 2602: 
 2603: =head4 Output
 2604: 
 2605:     {
 2606:         type     => 'boolean',
 2607:         memberof => [0, 1],
 2608:     }
 2609: 
 2610: =head3 EXAMPLE
 2611: 
 2612:     local $ENV{HTTP_ACCEPT_LANGUAGE} = 'ar';
 2613:     my $l = CGI::Lingua->new(supported => ['ar', 'en']);
 2614:     print $l->is_rtl();   # 1
 2615: 
 2616: =cut
 2617: 
 2618: sub is_rtl
 2619: {
 2620: 	my $self = shift;
 2621: 	return $RTL_LANGS{$self->language_code_alpha2() // ''} ? 1 : 0;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 2622: }
 2623: 
 2624: =head2 text_direction
 2625: 
 2626: Returns C<'rtl'> (right to left) or C<'ltr'> (left to right) for the chosen
 2627: language. You can use the value directly in the HTML C<dir> attribute.
 2628: 
 2629: When no language was found, it returns C<'ltr'>.
 2630: 
 2631: =head3 API SPECIFICATION
 2632: 
 2633: =head4 Input
 2634: 
 2635:     {}
 2636: 
 2637: =head4 Output
 2638: 
 2639:     {
 2640:         type     => 'string',
 2641:         memberof => ['ltr', 'rtl'],
 2642:     }
 2643: 
 2644: =head3 EXAMPLE
 2645: 
 2646:     local $ENV{HTTP_ACCEPT_LANGUAGE} = 'he';
 2647:     my $l = CGI::Lingua->new(supported => ['he', 'en']);
 2648:     print '<html dir="', $l->text_direction(), '">';   # <html dir="rtl">
 2649: 
 2650: =cut
 2651: 
 2652: sub text_direction
 2653: {
 2654: 	my $self = shift;
 2655: 	return $self->is_rtl() ? 'rtl' : 'ltr';

  Mutants (Total: 2, Killed: 2, Survived: 0)
 2656: }
 2657: 
 2658: =head2 plural_category($n)
 2659: 
 2660: Many languages use a different word form for different numbers.
 2661: English has two forms ("1 file", "2 files"); Russian has more;
 2662: Japanese has only one.
 2663: 
 2664: C<plural_category($n)> tells you which form to use for the number C<$n>
 2665: in the chosen language.
 2666: It returns one of C<'zero'>, C<'one'>, C<'two'>, C<'few'>, C<'many'> or
 2667: C<'other'>. These are the Unicode CLDR plural category names.
 2668: 
 2669: The rules for about 70 languages are built in, including Arabic (6 forms),
 2670: Slavic languages (3 or 4 forms), Celtic languages (up to 6 forms), Hebrew,
 2671: Maltese, Romanian, Latvian, Lithuanian and Slovenian.
 2672: Other languages use the English rule: C<'one'> for 1, otherwise C<'other'>.
 2673: 
 2674: When no language was found, it always returns C<'other'>.
 2675: 
 2676: C<$n> should be a whole number that is zero or more.
 2677: A number with a fractional part is cut down to a whole number first
 2678: (2.7 becomes 2).
 2679: For full CLDR rules, including fractions, use L<Locale::CLDR>.
 2680: 
 2681: =head3 API SPECIFICATION
 2682: 
 2683: =head4 Input
 2684: 
 2685:     [
 2686:         { type => 'number', min => 0 },
 2687:     ]
 2688: 
 2689: =head4 Output
 2690: 
 2691:     {
 2692:         type     => 'string',
 2693:         memberof => ['zero', 'one', 'two', 'few', 'many', 'other'],
 2694:     }
 2695: 
 2696: =head3 EXAMPLE
 2697: 
 2698:     local $ENV{HTTP_ACCEPT_LANGUAGE} = 'ru';
 2699:     my $l = CGI::Lingua->new(supported => ['ru']);
 2700:     print $l->plural_category(1);    # "one"
 2701:     print $l->plural_category(3);    # "few"
 2702:     print $l->plural_category(11);   # "many"
 2703: 
 2704: =head3 MESSAGES
 2705: 
 2706:     "plural_category: $n must be defined"
 2707:         - dies (croak) when $n is undef
 2708: 
 2709: =cut
 2710: 
 2711: # CLDR plural category rules (https://unicode.org/cldr/charts/42/supplemental/language_plural_rules.html).
 2712: # Values are coderefs: ($n) → category string.  Languages absent from this
 2713: # table fall back to the standard one/other rule inside plural_category().
 2714: my %PLURAL_RULES = (
 2715: 
 2716: 	# ── No plural distinction (always 'other') ────────────────────────────
 2717: 	(map { $_ => sub { 'other' } }
 2718: 		qw(az bm bo dz id ig ii in ja jbo jv jw kde kea km ko lkt lo ms
 2719: 		   my nqo root sah ses sg th to vi wo yo zh)),
 2720: 
 2721: 	# ── Standard: n == 1 → 'one', else 'other' ───────────────────────────
 2722: 	(map { $_ => sub { int($_[0]) == 1 ? 'one' : 'other' } }

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

					

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

 2730: 
 2731: 	# ── Arabic: zero/one/two/few/many/other ───────────────────────────────
 2732: 	ar => sub {
 2733: 		my $n    = int($_[0]);
 2734: 		my $m100 = $n % 100;
 2735: 		return 'zero'  if $n == 0;

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

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

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

					

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

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

					

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

 2740: 		return 'other';

  Mutants (Total: 2, Killed: 2, Survived: 0)
 2741: 	},
 2742: 
 2743: 	# ── Hebrew: one/two/many/other ────────────────────────────────────────
 2744: 	he => sub {
 2745: 		my $n = int($_[0]);
 2746: 		return 'one'  if $n == 1;

					

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

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

					

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

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

					

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

 2749: 		return 'other';

					

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

 2750: 	},
 2751: 
 2752: 	# ── Russian / Ukrainian / Belarusian: one/few/many ────────────────────
 2753: 	(map { $_ => sub {
 2754: 		my $n    = int($_[0]);
 2755: 		my $m10  = $n % 10;
 2756: 		my $m100 = $n % 100;
 2757: 		return 'one' if $m10 == 1 && $m100 != 11;

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

					

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

 2759: 		return 'many';

  Mutants (Total: 2, Killed: 2, Survived: 0)
 2760: 	} } qw(ru uk be)),
 2761: 
 2762: 	# ── Polish: one/few/many ──────────────────────────────────────────────
 2763: 	pl => sub {
 2764: 		my $n    = int($_[0]);
 2765: 		my $m10  = $n % 10;
 2766: 		my $m100 = $n % 100;
 2767: 		return 'one' if $n == 1;

					

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

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

					

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

 2769: 		return 'many';

					

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

 2770: 	},
 2771: 
 2772: 	# ── Czech / Slovak: one/few/other ────────────────────────────────────
 2773: 	(map { $_ => sub {
 2774: 		my $n = int($_[0]);
 2775: 		return 'one' if $n == 1;

					

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

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

					

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

 2777: 		return 'other';

					

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

 2778: 	} } qw(cs sk)),
 2779: 
 2780: 	# ── Romanian: one/few/other ───────────────────────────────────────────
 2781: 	ro => sub {
 2782: 		my $n    = int($_[0]);
 2783: 		my $m100 = $n % 100;
 2784: 		return 'one' if $n == 1;

					

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

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

					

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

 2786: 		return 'other';

					

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

 2787: 	},
 2788: 
 2789: 	# ── Latvian: zero/one/other ───────────────────────────────────────────
 2790: 	lv => sub {
 2791: 		my $n    = int($_[0]);
 2792: 		my $m10  = $n % 10;
 2793: 		my $m100 = $n % 100;
 2794: 		return 'zero'  if $m10 == 0 || ($m100 >= 11 && $m100 <= 19);

					

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

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

					

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

 2796: 		return 'other';

					

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

 2797: 	},
 2798: 
 2799: 	# ── Lithuanian: one/few/other ─────────────────────────────────────────
 2800: 	lt => sub {
 2801: 		my $n    = int($_[0]);
 2802: 		my $m10  = $n % 10;
 2803: 		my $m100 = $n % 100;
 2804: 		return 'one' if $m10 == 1 && ($m100 < 10 || $m100 >= 20);

					

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

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

					

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

 2806: 		return 'other';

					

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

 2807: 	},
 2808: 
 2809: 	# ── Slovenian: one/two/few/other ──────────────────────────────────────
 2810: 	sl => sub {
 2811: 		my $m100 = int($_[0]) % 100;
 2812: 		return 'one'   if $m100 == 1;

					

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

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

					

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

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

					

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

 2815: 		return 'other';

					

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

 2816: 	},
 2817: 
 2818: 	# ── Welsh: zero/one/two/few/many/other ───────────────────────────────
 2819: 	cy => sub {
 2820: 		my $n = int($_[0]);
 2821: 		return 'zero'  if $n == 0;

					

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

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

					

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

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

					

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

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

					

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

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

					

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

 2826: 		return 'other';

					

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

 2827: 	},
 2828: 
 2829: 	# ── Irish: one/two/few/many/other ────────────────────────────────────
 2830: 	ga => sub {
 2831: 		my $n = int($_[0]);
 2832: 		return 'one'  if $n == 1;

					

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

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

					

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

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

					

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

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

					

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

 2836: 		return 'other';

					

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

 2837: 	},
 2838: 
 2839: 	# ── Maltese: one/two/few/many/other ──────────────────────────────────
 2840: 	mt => sub {
 2841: 		my $n    = int($_[0]);
 2842: 		my $m100 = $n % 100;
 2843: 		return 'one'  if $n == 1;

					

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

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

					

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

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

					

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

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

					

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

 2847: 		return 'other';

					

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

 2848: 	},
 2849: );
 2850: 
 2851: sub plural_category
 2852: {
 2853: 	my ($self, $n) = @_;
 2854: 	Carp::croak('plural_category: $n must be defined') unless defined $n;
 2855: 	my $code = $self->language_code_alpha2() // return 'other';
 2856: 	my $rule = $PLURAL_RULES{$code} // sub { int($_[0]) == 1 ? 'one' : 'other' };

					

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

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

  Mutants (Total: 2, Killed: 2, Survived: 0)
 2858: }
 2859: 
 2860: =head2 translation_file($dir, $ext)
 2861: 
 2862: Finds the translation file for the chosen language in the directory C<$dir>,
 2863: and returns its path.
 2864: 
 2865: It tries these file names, in order, and returns the first one that is a
 2866: readable regular file:
 2867: 
 2868: =over 4
 2869: 
 2870: =item 1. C<$dir/$lang-$sublang.$ext>  (for example F<en-gb.json>)
 2871: 
 2872: =item 2. C<$dir/$lang.$ext>           (for example F<en.json>)
 2873: 
 2874: =back
 2875: 
 2876: C<$ext> is the file extension. It is C<'json'> if you do not give it.
 2877: You can write it with or without the dot (C<'po'> or C<'.po'>).
 2878: 
 2879: Returns C<undef> when no such file exists, when no language was found,
 2880: when C<$dir> is C<undef>, or when C<$dir> or C<$ext> is unsafe (see below).
 2881: A directory, a device (such as F</dev/urandom>), a broken symbolic link or a
 2882: file you cannot read is never returned, even if it has the right name.
 2883: 
 2884: For safety, C<$dir> must be a non-empty string (not a reference) without
 2885: C<..> or a null byte, and C<$ext> may only contain letters, digits and C<->.
 2886: Control characters in a rejected value are shown as C<\xNN> in the warning.
 2887: 
 2888: =head3 API SPECIFICATION
 2889: 
 2890: =head4 Input
 2891: 
 2892:     [
 2893:         { type => 'string', min => 1 },
 2894:         { type => 'string', min => 1, matches => qr/^\.?[A-Za-z0-9-]+$/, optional => 1 },
 2895:     ]
 2896: 
 2897: =head4 Output
 2898: 
 2899:     {
 2900:         type     => 'string',
 2901:         optional => 1,
 2902:     }
 2903: 
 2904: =head3 EXAMPLE
 2905: 
 2906:     local $ENV{HTTP_ACCEPT_LANGUAGE} = 'en-gb';
 2907:     my $l = CGI::Lingua->new(supported => ['en-gb', 'en']);
 2908: 
 2909:     my $path = $l->translation_file('/var/www/i18n');
 2910:     # '/var/www/i18n/en-gb.json' if it exists,
 2911:     # else '/var/www/i18n/en.json' if it exists,
 2912:     # else undef
 2913: 
 2914:     # A different extension
 2915:     my $po = $l->translation_file('/var/www/i18n', 'po');
 2916: 
 2917: =head3 MESSAGES
 2918: 
 2919: These are warnings. C<translation_file()> does not die.
 2920: 
 2921:     "translation_file: unsafe directory '...' rejected"
 2922:     "translation_file: unsafe extension '...' rejected"
 2923: 
 2924: =cut
 2925: 
 2926: sub translation_file
 2927: {
●2928 → 2935 → 2940 2928: 	my ($self, $dir, $ext) = @_;
 2929: 	local $!;	# a failed file test sets $!
 2930: 	return undef unless defined $dir;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 2931: 
 2932: 	# Reject traversal attempts in the directory argument.  A real translation
 2933: 	# directory never needs '..' or null bytes; an empty name would mean "/",
 2934: 	# and a reference would be used as the string "ARRAY(0x...)".
 2935: 	if(ref($dir) || !length($dir) || $dir =~ /\.\./ || $dir =~ /\x00/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2936: 		$self->_warn({ warning => "translation_file: unsafe directory '" . _printable($dir) . "' rejected" });
 2937: 		return undef;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 2938: 	}
 2939: 
●2940 → 2945 → 2952 2940: 	$ext //= 'json';
 2941: 	$ext =~ s/^\.//;    # accept '.json' or 'json'
 2942: 
 2943: 	# Valid extensions are letters, digits and hyphens only (e.g. 'json', 'po',
 2944: 	# 'yml'); \z, not $, so "json\n" is refused too
 2945: 	unless($ext =~ /^[A-Za-z0-9\-]+\z/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2946: 		$self->_warn({ warning => "translation_file: unsafe extension '" . _printable($ext) . "' rejected" });
 2947: 		return undef;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 2948: 	}
 2949: 
 2950: 	# The codes become part of a path, so check their shape even though they
 2951: 	# come from the negotiated language
●2952 → 2955 → 2958 2952: 	my $lang = $self->language_code_alpha2();
 2953: 	return undef unless defined($lang) && ($lang =~ $LANG_CODE_RE);

  Mutants (Total: 2, Killed: 2, Survived: 0)
 2954: 	my @candidates;
 2955: 	if(defined(my $sub = $self->sublanguage_code_alpha2())) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2956: 		push @candidates, "$lang-$sub" if $sub =~ $LANG_CODE_RE;
 2957: 	}
●2958 → 2963 → 2967 2958: 	push @candidates, $lang;
 2959: 
 2960: 	# A translation file must be a readable regular file: a directory, a
 2961: 	# device such as /dev/urandom, a dangling symlink or an unreadable file
 2962: 	# named en.json is not one, and handing it back would only fail later
 2963: 	for my $code (@candidates) {
 2964: 		my $path = "$dir/$code.$ext";
 2965: 		return $path if -f $path && -r _;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 2966: 	}
 2967: 	return undef;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 2968: }
 2969: 
 2970: # ── _printable ────────────────────────────────────────────────────────────
 2971: # Purpose:      Make a caller-supplied value safe to put in a log message:
 2972: #               control and non-ASCII characters (newlines that would forge
 2973: #               log lines, NULs, terminal escapes) become \xNN.
 2974: # Entry:        $value — any scalar; a reference is shown as its type.
 2975: # Exit:         A printable ASCII string.
 2976: sub _printable
 2977: {
 2978: 	my $value = shift;
 2979: 	return 'undef' unless defined($value);

					

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

 2980: 	return ref($value) . ' reference' if ref($value);

					

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

 2981: 	$value =~ s/([^\x20-\x7e])/sprintf('\\x%02x', ord($1))/ge;
 2982: 	return $value;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 2983: }
 2984: 
 2985: # ── _code2language ────────────────────────────────────────────────────────
 2986: # Purpose:      Translate a 2-char language code to its English name, with
 2987: #               optional CHI caching.
 2988: # Entry:        $code — 2-char ISO 639-1 code; must be defined and non-empty.
 2989: # Exit:         Human-readable language name string, or undef.
 2990: # Side Effects: Reads/writes cache.
 2991: sub _code2language
 2992: {
●2993 → 2996 → 3002 2993: 	my ($self, $code) = @_;
 2994: 
 2995: 	return unless $code;
 2996: 	if(defined($self->{_country})) {

					

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

 2997: 		$self->_debug("_code2language $code, country ", $self->{_country});
 2998: 	} else {
 2999: 		$self->_debug("_code2language $code");
 3000: 	}
 3001: 
●3002 → 3002 → 3006 3002: 	unless($self->{_cache}) {

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

  Mutants (Total: 2, Killed: 2, Survived: 0)
 3004: 	}
 3005: 
●3006 → 3006 → 3013 3006: 	if(my $from_cache = $self->_cache_get_valid($CACHE_NS . "code2language:$code", $NAME_RE)) {

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

  Mutants (Total: 2, Killed: 2, Survived: 0)
 3009: 	}
 3010: 
 3011: 	# Compute, cache, then return the value separately —
 3012: 	# CHI->set() is not guaranteed to return the stored value across all drivers
●3013 → 3015 → 3018 3013: 	$self->_trace('_code2language not in cache, storing');
 3014: 	my $name = Locale::Language::code2language($code);
 3015: 	if(defined $name) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3016: 		$self->_cache_call($self->{_cache}, 'set', $CACHE_NS . "code2language:$code", $name, $CACHE_TTL_LONG);
 3017: 	}
 3018: 	return $name;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 3019: }
 3020: 
 3021: # ── _code2country ─────────────────────────────────────────────────────────
 3022: # Purpose:      Translate a 2-char country code to a Locale::Object::Country
 3023: #               object, suppressing the expected "No result found" warning.
 3024: # Entry:        $code — 2-char ISO 3166-1 alpha-2 code (any case).
 3025: # Exit:         Locale::Object::Country object, or undef.
 3026: # Side Effects: None beyond the Locale::Object::Country look-up.
 3027: sub _code2country
 3028: {
●3029 → 3032 → 3038 3029: 	my ($self, $code) = @_;
 3030: 
 3031: 	return unless $code;
 3032: 	if($self->{_country}) {

					

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

 3033: 		$self->_trace(">_code2country $code, country ", $self->{_country});
 3034: 	} else {
 3035: 		$self->_trace(">_code2country $code");
 3036: 	}
 3037: 
●3038 → 3039 → 3052 3038: 	my $rc;
 3039: 	if($_locale_object_db_ok // 1) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3040: 		# Suppress the routine "No result found" warning; catch the database-
 3041: 		# absent exception that Windows installations sometimes throw.
 3042: 		local $SIG{__WARN__} = _warn_filter(qr/No result found in country table/);
 3043: 		eval { $rc = Locale::Object::Country->new(code_alpha2 => $code) };
 3044: 		if($@) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3045: 			$_locale_object_db_ok = 0
 3046: 				if $@ =~ /database was not in/;
 3047: 			$rc = undef;
 3048: 		} else {
 3049: 			$_locale_object_db_ok = 1;
 3050: 		}
 3051: 	}
 3052: 	$self->_trace('<_code2country ', $code || 'undef');
 3053: 	return $rc;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 3054: }
 3055: 
 3056: # ── _country_short_name ───────────────────────────────────────────────────
 3057: # Purpose:      Return the common short English name for an ISO 3166-1 alpha-2
 3058: #               code when Locale::Object's database is unavailable.  Uses
 3059: #               %COUNTRY_SHORT_NAMES overrides for codes where Locale::Codes
 3060: #               returns the full ISO official name rather than the short form.
 3061: # Entry:        $code — 2-char country code (any case).
 3062: # Exit:         Short name string, or undef.
 3063: sub _country_short_name
 3064: {
 3065: 	my ($self, $code) = @_;
 3066: 	return unless defined($code);
 3067: 	my $lc = lc($code);
 3068: 	return $COUNTRY_SHORT_NAMES{$lc} if exists $COUNTRY_SHORT_NAMES{$lc};

  Mutants (Total: 2, Killed: 2, Survived: 0)
 3069: 	# Locale::Object may have partially initialised Locale::Codes::Country as a
 3070: 	# dependency before we get here; suppress the spurious 'redefine' warning
 3071: 	# that some Perl/Locale::Codes combinations produce on first full load.
 3072: 	{ local $SIG{__WARN__} = _warn_filter(qr/redefined/);
 3073: 	  require Locale::Codes::Country; }
 3074: 	return Locale::Codes::Country::code2country($lc, 'alpha-2');

  Mutants (Total: 2, Killed: 2, Survived: 0)
 3075: }
 3076: 
 3077: # ── _code2countryname ─────────────────────────────────────────────────────
 3078: # Purpose:      Translate a 2-char country code to its English name string,
 3079: #               with optional CHI caching.
 3080: # Entry:        $code — 2-char ISO 3166-1 alpha-2 code.
 3081: # Exit:         Country name string, or undef.
 3082: # Side Effects: Reads/writes cache.
 3083: sub _code2countryname
 3084: {
●3085 → 3090 → 3096 3085: 	my ($self, $code) = @_;
 3086: 
 3087: 	return unless $code;
 3088: 	$self->_trace(">_code2countryname $code");
 3089: 
 3090: 	unless($self->{_cache}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3091: 		my $country = $self->_code2country($code);
 3092: 		return $country->name if defined($country);

  Mutants (Total: 2, Killed: 2, Survived: 0)
 3093: 		return $self->_country_short_name($code);

  Mutants (Total: 2, Killed: 2, Survived: 0)
 3094: 	}
 3095: 
●3096 → 3096 → 3101 3096: 	if(my $from_cache = $self->_cache_get_valid($CACHE_NS . "code2countryname:$code", $NAME_RE)) {

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

  Mutants (Total: 2, Killed: 2, Survived: 0)
 3099: 	}
 3100: 
●3101 → 3102 → 3110 3101: 	my $name;
 3102: 	if(my $country = $self->_code2country($code)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3103: 		$name = $country->name();
 3104: 	} else {
 3105: 		# Locale::Object database absent (common on Windows); fall back to
 3106: 		# Locale::Codes::Country with a short-name correction table.
 3107: 		$name = $self->_country_short_name($code);
 3108: 	}
 3109: 
●3110 → 3110 → 3116 3110: 	if(defined($name)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3111: 		$self->_debug('_code2countryname not in cache, storing');
 3112: 		$self->_trace('<_code2countryname ', $name);
 3113: 		$self->_cache_call($self->{_cache}, 'set', $CACHE_NS . "code2countryname:$code", $name, $CACHE_TTL_LONG);
 3114: 		return $name;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 3115: 	}
 3116: 	$self->_trace('<_code2countryname undef');
 3117: 	return;
 3118: }
 3119: 
 3120: # ── _log ──────────────────────────────────────────────────────────────────
 3121: # Purpose:      Append a message to $self->{messages} and forward to the
 3122: #               optional logger object.
 3123: # Entry:        $level — log level string (debug/info/notice/warn/trace/error);
 3124: #               @messages — one or more strings to concatenate.
 3125: # Exit:         void
 3126: # Side Effects: Mutates $self->{messages}; calls logger method if set.
 3127: sub _log
 3128: {
●3129 → 3137 → 0 3129: 	my ($self, $level, @messages) = @_;
 3130: 
 3131: 	return unless ref($self) && scalar(@messages);
 3132: 
 3133: 	my $text = join('', grep defined, @messages);
 3134: 	return unless length($text);
 3135: 	push @{$self->{'messages'}}, { level => $level, message => $text };
 3136: 
 3137: 	if(my $logger = $self->{'logger'}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3138: 		$logger->$level($text);
 3139: 	}
 3140: }
 3141: 
 3142: sub _debug  { my $self = shift; $self->_log('debug',  @_) }
 3143: sub _info   { my $self = shift; $self->_log('info',   @_) }
 3144: sub _notice { my $self = shift; $self->_log('notice', @_) }
 3145: sub _trace  { my $self = shift; $self->_log('trace',  @_) }
 3146: 
 3147: # ── _warn ─────────────────────────────────────────────────────────────────
 3148: # Purpose:      Emit a warning through the logger (if set) or via Carp::carp.
 3149: # Entry:        A single hashref argument: { warning => 'message text' }.
 3150: #               All callers MUST use this structured form — plain-string calls
 3151: #               silently lose the message when no logger is configured.
 3152: # Exit:         void
 3153: # Side Effects: Calls logger->warn() or carp().
 3154: sub _warn
 3155: {
●3156 → 3162 → 0 3156: 	my $self = shift;
 3157: 
 3158: 	# Parse once; both branches need the same $msg.
 3159: 	my $params = Params::Get::get_params('warning', @_);
 3160: 	my $msg    = (ref($params) ? $params->{'warning'} : undef) // join('', grep defined, @_);
 3161: 
 3162: 	if(defined($self->{'logger'})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3163: 		$self->{'logger'}->warn($msg);
 3164: 	} else {
 3165: 		$self->_log('warn', $msg);
 3166: 		Carp::carp($msg);
 3167: 	}
 3168: }
 3169: 
 3170: # ── _warn_filter ──────────────────────────────────────────────────────────
 3171: # Purpose:      Build a $SIG{__WARN__} handler that drops warnings matching
 3172: #               $skip and passes every other warning on to the handler that
 3173: #               was active when the filter was built.
 3174: # Entry:        $skip — compiled regex of warnings to drop.
 3175: # Exit:         Code reference suitable for "local $SIG{__WARN__} = ...".
 3176: # Notes:        A plain "warn" inside a __WARN__ handler bypasses every handler
 3177: #               and goes straight to STDERR, so the caller's handler (a logger,
 3178: #               Test::Warnings, ...) would never see the warning; hence the
 3179: #               explicit call to the previous handler.
 3180: sub _warn_filter
 3181: {
 3182: 	my $skip = shift;
 3183: 	my $prev = $SIG{__WARN__};
 3184: 
 3185: 	return sub {

  Mutants (Total: 2, Killed: 2, Survived: 0)
 3186: 		return if $_[0] =~ $skip;
 3187: 		if(ref($prev) eq 'CODE') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3188: 			$prev->(@_);
 3189: 		} else {
 3190: 			warn @_;
 3191: 		}
 3192: 	};
 3193: }
 3194: 
 3195: # ── Pure-Perl IP-validation helpers ──────────────────────────────────────────
 3196: # These are installed into the CGI::Lingua symbol table as is_ipv4() etc. when
 3197: # Data::Validate::IP / NetAddr::IP are unavailable (see country()).
 3198: 
 3199: sub _is_ipv4 {
 3200: 	my $ip = shift;
 3201: 	# /a: without it \d also matches non-ASCII digits such as U+0661, which
 3202: 	# then compare as 0 and make "\x{661}.\x{661}.\x{661}.\x{661}" look valid
 3203: 	return unless defined($ip) && $ip =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})\z/a;
 3204: 	return !(grep { $_ > 255 } ($1, $2, $3, $4));

  Mutants (Total: 5, Killed: 5, Survived: 0)
 3205: }
 3206: 
 3207: sub _is_ipv6 {
●3208 → 3212 → 3217 3208: 	my $ip = shift;
 3209: 	return unless defined($ip) && $ip =~ /:/;
 3210: 	# Socket::inet_pton is core since Perl 5.14 and validates IPv6 reliably
 3211: 	require Socket;
 3212: 	if(defined &Socket::inet_pton) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3213: 		return defined Socket::inet_pton(Socket::AF_INET6(), $ip);

  Mutants (Total: 2, Killed: 2, Survived: 0)
 3214: 	}
 3215: 	# Structural fallback: hex+colons, at least two colons, at most one ::
 3216: 	# (tr/// counts characters, not "::" pairs, so count matches of /::/ instead)
 3217: 	return ($ip =~ /^[0-9a-fA-F:]+\z/ || $ip =~ /^[0-9a-fA-F:]+:\d{1,3}(?:\.\d{1,3}){3}\z/a)

  Mutants (Total: 2, Killed: 2, Survived: 0)
 3218: 		&& (() = $ip =~ /::/g) <= 1

  Mutants (Total: 3, Killed: 3, Survived: 0)
 3219: 		&& ($ip =~ tr/://) >= 2;

  Mutants (Total: 3, Killed: 3, Survived: 0)
 3220: }
 3221: 
 3222: sub _is_private_ip {
●3223 → 3225 → 3233 3223: 	my $ip = shift;
 3224: 	return unless defined($ip);
 3225: 	if($ip =~ /^(\d+)\.(\d+)/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 3226: 		my ($a, $b) = ($1 + 0, $2 + 0);
 3227: 		return 1 if $a == 10;

  Mutants (Total: 3, Killed: 3, Survived: 0)
 3228: 		return 1 if $a == 172 && $b >= 16 && $b <= 31;

  Mutants (Total: 9, Killed: 9, Survived: 0)
 3229: 		return 1 if $a == 192 && $b == 168;

  Mutants (Total: 3, Killed: 3, Survived: 0)
 3230: 		return 1 if $a == 169 && $b == 254;     # link-local / APIPA

  Mutants (Total: 3, Killed: 3, Survived: 0)
 3231: 		return 0;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 3232: 	}
 3233: 	return 1 if $ip =~ /^fe[89ab][0-9a-f]:/i;  # fe80::/10 link-local

  Mutants (Total: 2, Killed: 2, Survived: 0)
 3234: 	return 1 if $ip =~ /^f[cd]/i;              # fc00::/7 ULA

  Mutants (Total: 2, Killed: 2, Survived: 0)
 3235: 	return 0;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 3236: }
 3237: 
 3238: sub _is_loopback_ip {
 3239: 	my $ip = shift;
 3240: 	return unless defined($ip);
 3241: 	return 1 if $ip eq '::1';

  Mutants (Total: 2, Killed: 2, Survived: 0)
 3242: 	return $ip =~ /^127\./;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 3243: }
 3244: 
 3245: =head1 COMMON PITFALLS
 3246: 
 3247: =over 4
 3248: 
 3249: =item * B<Configuration files and environment variables win over your arguments>
 3250: 
 3251: L</new> passes its arguments to L<Object::Configure>.
 3252: If a configuration file (C<config_file>) or an environment variable such as
 3253: C<CGI__Lingua__supported> sets a value, that value B<replaces> the value you
 3254: gave to C<new()>.
 3255: 
 3256: Values are replaced, not merged. If you pass C<< supported => ['en', 'fr'] >>
 3257: and the configuration file says C<supported: [de]>, the object supports only
 3258: C<de>, not C<en>, C<fr> and C<de>.
 3259: For nested values (hashes inside hashes) see the rules in L<Object::Configure>.
 3260: 
 3261: =item * B<A copy made with C<< $object->new() >> keeps old answers>
 3262: 
 3263: When you call C<new()> on an object, the copy starts with every answer that the
 3264: original has already worked out. So if the original has already called
 3265: L</language>, the copy returns the same language,
 3266: even if you give the copy a different C<supported> list:
 3267: 
 3268:     my $l = CGI::Lingua->new(supported => ['en', 'fr']);
 3269:     print $l->language();             # "French"
 3270:     my $copy = $l->new(supported => ['en']);
 3271:     print $copy->language();          # still "French"
 3272: 
 3273: Make the copy before you call any other method, or create a new object with
 3274: C<< CGI::Lingua->new() >>.
 3275: 
 3276: =item * B<'Unknown' is not the same as undef>
 3277: 
 3278: Some methods return the B<string> C<'Unknown'> and some return C<undef>
 3279: when they do not know the answer. C<'Unknown'> is a true value in Perl,
 3280: so C<if($l-E<gt>language())> is always true.
 3281: 
 3282:     Method                    When it does not know
 3283:     ------------------------  -----------------------------
 3284:     language()                'Unknown'  (never undef)
 3285:     requested_language()      'Unknown'  (never undef)
 3286:     sublanguage()             undef
 3287:     language_code_alpha2()    undef
 3288:     sublanguage_code_alpha2() undef
 3289:     country()                 undef  ('Unknown' for EU addresses)
 3290:     locale()                  undef
 3291:     time_zone()               undef
 3292:     translation_file()        undef
 3293:     is_rtl()                  0
 3294:     text_direction()          'ltr'
 3295:     plural_category()         'other'
 3296: 
 3297: Always test with C<eq 'Unknown'> or C<defined()>, as the table shows.
 3298: 
 3299: C<undef> really is one value, even in list context, so it is safe to build a
 3300: hash from the results:
 3301: 
 3302:     my %vars = (country => $l->country(), zone => $l->time_zone());
 3303:     # $vars{zone} is the time zone even when country() is undef
 3304: 
 3305: =item * B<plural_category() returns 'other' when there is no language>
 3306: 
 3307: When no supported language was found, C<plural_category(1)> returns
 3308: C<'other'>, not C<'one'>. Have an C<'other'> form for every message.
 3309: C<plural_category(undef)> dies.
 3310: 
 3311: =item * B<C<supported =E<gt> 0> and C<supported =E<gt> ''> count as missing>
 3312: 
 3313: A false value for C<supported> is treated as if you did not give it,
 3314: so C<new()> dies with "You must give a list of supported languages".
 3315: 
 3316: =item * B<Answers are worked out once, then remembered>
 3317: 
 3318: The first call to a language method reads C<%ENV> and remembers the answer.
 3319: If you change C<%ENV> afterwards, the object does not notice.
 3320: Create a new object for each web request.
 3321: 
 3322: =item * B<country() reads REMOTE_ADDR when you call it>
 3323: 
 3324: C<country()> reads C<$ENV{REMOTE_ADDR}> when you B<call> it,
 3325: not when you create the object. In tests, call C<country()> while
 3326: C<REMOTE_ADDR> still has the value you want:
 3327: 
 3328:     {
 3329:         local $ENV{REMOTE_ADDR} = '8.8.8.8';
 3330:         my $l = CGI::Lingua->new(supported => ['en']);
 3331:         $country = $l->country();    # correct: inside the block
 3332:     }
 3333: 
 3334: =item * B<A bad header is ignored completely>
 3335: 
 3336: If C<HTTP_ACCEPT_LANGUAGE> is longer than 256 characters, or contains a
 3337: character that is not allowed (see L</ENCODING>), the whole header is ignored
 3338: with a warning. CGI::Lingua then uses C<LANG> or the IP address instead.
 3339: 
 3340: =item * B<The supported list holds tags, not names>
 3341: 
 3342: C<< supported => ['english', 'fr'] >> supports only French: C<'english'> is not a
 3343: language tag, so it is dropped (with a warning). Use C<'en'>.
 3344: 
 3345: =item * B<Language names are in English>
 3346: 
 3347: L</language> returns C<'French'>, not C<'Francais'>, and C<'German'>, not
 3348: C<'Deutsch'>. Use L</language_code_alpha2> if you want to show the name in
 3349: the language itself.
 3350: 
 3351: =item * B<The logger you pass is replaced>
 3352: 
 3353: L<Object::Configure> always changes C<logger> into a new L<Log::Abstraction>
 3354: object, so C<< $l->{logger} >> is not the object you passed.
 3355: 
 3356: =item * B<Whole objects are only cached when REMOTE_ADDR is set>
 3357: 
 3358: The answers of an object are read from the cache in L</new>, and written to it
 3359: when the object is destroyed, only when C<REMOTE_ADDR> is set.
 3360: On the command line, only smaller look-ups (such as code-to-name) are cached.
 3361: 
 3362: =item * B<Local geo databases can be out of date>
 3363: 
 3364: Old F<GeoIP.dat> files can give the wrong country for some addresses
 3365: (see L</country>).
 3366: 
 3367: =back
 3368: 
 3369: =head1 ENCODING
 3370: 
 3371: CGI::Lingua works with ASCII text. This table shows what each input accepts.
 3372: 
 3373:     Input                   Accepted characters        Non-ASCII / UTF-8 / emoji
 3374:     ----------------------  -------------------------  -------------------------
 3375:     supported               language tags (en, en-gb,   no: entry is ignored,
 3376:                             es-419); a plain string     with a warning
 3377:                             must be 2-5 chars
 3378:     HTTP_ACCEPT_LANGUAGE    A-Z a-z 0-9 - , ; = . *     no: header is ignored
 3379:                             space and tab (never CR or
 3380:                             LF); max 256 chars
 3381:     lang (CGI::Info)        as HTTP_ACCEPT_LANGUAGE     no: parameter is ignored
 3382:     LANG                    A-Z a-z 0-9 _ . -           no: LANG is ignored
 3383:     HTTP_USER_AGENT         printable ASCII             no: user agent ignored
 3384:                             (0x20-0x7E), max 512 chars
 3385:     REMOTE_ADDR             IPv4 or IPv6 address        no: address is rejected
 3386:     GEOIP_COUNTRY_CODE      exactly two of A-Z          no: value is ignored
 3387:     HTTP_CF_IPCOUNTRY       exactly two of A-Z          no: value is ignored
 3388:     translation_file $dir   any, except ".." and NUL    yes, if your file system
 3389:                                                         supports it (pass bytes
 3390:                                                         encoded as the file
 3391:                                                         system expects)
 3392:     translation_file $ext   A-Z a-z 0-9 -               no: undef is returned
 3393:     plural_category $n      a number                    not applicable
 3394: 
 3395: All values that CGI::Lingua returns are plain ASCII: language names
 3396: (C<'French'>), country names (C<'Reunion'>), codes and time zone names.
 3397: You do not need to decode them.
 3398: 
 3399: =head1 CONFIGURATION VARIABLES
 3400: 
 3401: Two package variables say where CGI::Lingua looks for files on the local
 3402: machine. You do not normally need to change them; tests and unusual
 3403: installations can, with C<local>:
 3404: 
 3405: =over 4
 3406: 
 3407: =item * C<$CGI::Lingua::ZONE_FILE>
 3408: 
 3409: The file that L</time_zone> reads when there is no C<REMOTE_ADDR> (command-line
 3410: use). The default is F</etc/timezone>. Only a readable regular file is used,
 3411: and only its first 256 bytes are read; otherwise L<DateTime::TimeZone> is used.
 3412: 
 3413:     local $CGI::Lingua::ZONE_FILE = '/srv/myapp/timezone';
 3414: 
 3415: =item * C<@CGI::Lingua::GEOIP_DAT>
 3416: 
 3417: The places where L</country> and L</time_zone> look for the legacy MaxMind
 3418: F<GeoIP.dat> used by L<Geo::IP>; the first readable regular file is used. The
 3419: default is F</usr/share/GeoIP/GeoIP.dat> and F</usr/local/share/GeoIP/GeoIP.dat>
 3420: (and F<c:/GeoIP/GeoIP.dat> first, on Windows). A file that L<Geo::IP> cannot
 3421: open is skipped with the warning C<"Can't open ... with Geo::IP; not using it">.
 3422: 
 3423:     local @CGI::Lingua::GEOIP_DAT = ('/opt/geo/GeoIP.dat');
 3424: 
 3425: =back
 3426: 
 3427: =head1 LIMITATIONS
 3428: 
 3429: =over 4
 3430: 
 3431: =item * B<is_rtl() covers primary-script RTL languages only>
 3432: 
 3433: C<is_rtl()> returns true for the 10 ISO 639-1 codes whose overwhelmingly
 3434: dominant script is right-to-left.  Languages with script variants (e.g.
 3435: Azerbaijani C<az>, which uses Latin in modern Azerbaijan but Arabic in Iran)
 3436: are treated as LTR.  If you serve content in multiple scripts of the same
 3437: language, inspect the sublanguage or Accept-Language header directly.
 3438: 
 3439: =item * B<plural_category() uses embedded CLDR rules, not Locale::CLDR>
 3440: 
 3441: The embedded rules cover ~70 languages and truncate fractional C<$n> to an
 3442: integer.  For full CLDR v42 accuracy (including fractional forms and
 3443: languages not in the table) install and use C<Locale::CLDR> directly.
 3444: 
 3445: =item * B<The logger is always a Log::Abstraction object>
 3446: 
 3447: The C<logger> argument can be an object with C<warn()>, C<info()> and
 3448: C<error()> methods, or any value that L<Object::Configure> accepts (such as an
 3449: array reference or a hash reference of options).  In every case
 3450: L<Object::Configure> replaces it with a L<Log::Abstraction> object.  An object
 3451: that is missing one of the three methods is rejected by L</new>.
 3452: 
 3453: =item * B<es-419 sublanguage returns undef>
 3454: 
 3455: Three-part regional codes such as C<es-419> (Latin American Spanish) do not
 3456: resolve to a C<sublanguage()> value because ISO 3166-1 does not define '419'.
 3457: This is a known limitation of the Locale::Object layer.
 3458: 
 3459: =item * B<Whois lookups are slow and unreliable>
 3460: 
 3461: Without C<IP::Country>, C<Geo::IP>, or C<Geo::IPfree> installed, C<country()>
 3462: falls back to Whois queries against live RIPE/ARIN/IANA servers.  These can
 3463: time out under load.  Install at least one local geo-database module and enable
 3464: the CHI cache to avoid this.
 3465: 
 3466: =item * B<Private methods are accessible from outside the package>
 3467: 
 3468: The C<_*> methods use the naming convention for privacy but Perl does not enforce
 3469: it.  C<Sub::Private> or C<Sub::Protected> should be added once all white-box
 3470: tests (C<t/function.t>, C<t/extended_tests.t>) are updated to use the public API
 3471: exclusively.
 3472: 
 3473: =item * B<IPv4-mapped IPv6 addresses are normalised to IPv4>
 3474: 
 3475: C<REMOTE_ADDR> values in the form C<::ffff:a.b.c.d> (RFC 4291 section 2.5.5)
 3476: are silently rewritten to the embedded C<a.b.c.d> IPv4 address before any
 3477: geo-lookup.  This is correct for country detection purposes but means the raw
 3478: address string is not preserved in cache keys or log messages.
 3479: 
 3480: =item * B<EU country code is irresolvable (with one exception)>
 3481: 
 3482: IP addresses that Whois reports as country C<EU> are mapped to C<'Unknown'>
 3483: unless they fall within Baidu's known subnet (RT-86809).  There is no ISO
 3484: 3166-1 country code for the European Union.
 3485: 
 3486: =item * B<country() does not cache undef results>
 3487: 
 3488: When C<country()> cannot determine a country (private IPs, loopback,
 3489: unresolvable addresses), it returns C<undef> without storing the result.  A
 3490: second call on the same object repeats the full validation pipeline.  This is
 3491: intentional: C<country()> reads C<REMOTE_ADDR> at call time rather than at
 3492: construction time, so caching C<undef> would return a wrong answer if
 3493: C<REMOTE_ADDR> changes between calls.  In practice this is rarely a problem
 3494: because C<country()> is called once per request and CGI applications typically
 3495: create a fresh object per request.
 3496: 
 3497: =back
 3498: 
 3499: =head1 AUTHOR
 3500: 
 3501: Nigel Horne, C<< <njh at nigelhorne.com> >>
 3502: 
 3503: =head1 BUGS
 3504: 
 3505: If C<HTTP_ACCEPT_LANGUAGE> contains a sub-tag with a 3-digit UN M.49 region
 3506: code (e.g. C<es-419> for Latin American Spanish), C<sublanguage()> returns
 3507: C<undef> because ISO 3166-1 does not define numeric codes.
 3508: 
 3509: Uses L<I18N::AcceptLanguage> to find the highest priority accepted language.
 3510: This means that if you support languages at a lower priority, it may be missed.
 3511: 
 3512: Please report any bugs or feature requests to C<bug-cgi-lingua at rt.cpan.org>,
 3513: or through the web interface at
 3514: L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CGI-Lingua>.
 3515: I will be notified, and then you'll
 3516: automatically be notified of progress on your bug as I make changes.
 3517: 
 3518: =head1 SEE ALSO
 3519: 
 3520: =over 4
 3521: 
 3522: =item * L<Configure an Object at Runtime|Object::Configure>
 3523: 
 3524: =item * L<Test Dashboard|https://nigelhorne.github.io/CGI-Lingua/coverage/>
 3525: 
 3526: =item * VWF - Versatile Web Framework L<https://github.com/nigelhorne/vwf>
 3527: 
 3528: =item * L<HTTP::BrowserDetect>
 3529: 
 3530: =item * L<I18N::AcceptLanguage>
 3531: 
 3532: =item * L<Locale::Country>
 3533: 
 3534: =back
 3535: 
 3536: =head1 SUPPORT
 3537: 
 3538: This module is provided as-is without any warranty.
 3539: 
 3540: You can find documentation for this module with the perldoc command.
 3541: 
 3542:     perldoc CGI::Lingua
 3543: 
 3544: You can also look for information at:
 3545: 
 3546: =over 4
 3547: 
 3548: =item * MetaCPAN
 3549: 
 3550: L<https://metacpan.org/release/CGI-Lingua>
 3551: 
 3552: =item * RT: CPAN's request tracker
 3553: 
 3554: L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=CGI-Lingua>
 3555: 
 3556: =item * CPANTS
 3557: 
 3558: L<http://cpants.cpanauthors.org/dist/CGI-Lingua>
 3559: 
 3560: =item * CPAN Testers' Matrix
 3561: 
 3562: L<http://matrix.cpantesters.org/?dist=CGI-Lingua>
 3563: 
 3564: =item * CPAN Testers Dependencies
 3565: 
 3566: L<http://deps.cpantesters.org/?module=CGI::Lingua>
 3567: 
 3568: =back
 3569: 
 3570: =encoding utf-8
 3571: 
 3572: =head1 FORMAL SPECIFICATION
 3573: 
 3574: This section describes each method in the Z notation.
 3575: You do not need it to use the module.
 3576: 
 3577: =head2 Types and state
 3578: 
 3579:     [LANGTAG, LANGNAME, CNAME, IPADDR, PATH, ZONE, LOCALE]
 3580: 
 3581:     CC2      == { s : seq CHAR | #s = 2 ∧ ran s ⊆ 'a'..'z' }
 3582:     LC2      == CC2
 3583:     PLURAL   ::= zero | one | two | few | many | other
 3584:     GEO      ::= unknown | absent | present
 3585:     DIR      ::= ltr | rtl
 3586:     RTL_LANGS == { ar, dv, fa, he, ku, ps, sd, ug, ur, yi }
 3587: 
 3588:     ⊥ marks a value that has not been worked out yet (or is undef).
 3589: 
 3590:     ┌─ Lingua ──────────────────────────────────────────────────────
 3591:     │ supported   : seq LANGTAG
 3592:     │ slanguage   : LANGNAME ∪ {Unknown, ⊥}
 3593:     │ rlanguage   : LANGNAME ∪ {Unknown, ⊥}
 3594:     │ code2       : LC2 ∪ {⊥}
 3595:     │ subcode2    : CC2 ∪ {⊥}
 3596:     │ sublanguage : CNAME ∪ {⊥}
 3597:     │ country     : CC2 ∪ {Unknown, ⊥}
 3598:     │ locale      : LOCALE ∪ {⊥}
 3599:     │ timezone    : ZONE ∪ {⊥}
 3600:     │ ipc, gip, gipf : GEO
 3601:     │ dont_use_ip : 𝔹
 3602:     ├───────────────────────────────────────────────────────────────
 3603:     │ slanguage ∉ {Unknown, ⊥} ⇒
 3604:     │     code2 ≠ ⊥ ∧ (∃ t : ran supported • base(t) = code2)
 3605:     │ slanguage = Unknown ⇒ code2 = ⊥ ∧ subcode2 = ⊥
 3606:     │ subcode2 ≠ ⊥ ⇒ code2 ≠ ⊥
 3607:     │ sublanguage ≠ ⊥ ⇒ subcode2 ≠ ⊥
 3608:     │ (slanguage = ⊥) ⇔ (rlanguage = ⊥)
 3609:     └───────────────────────────────────────────────────────────────
 3610: 
 3611:     request   : ENV ⇸ seq (LANGTAG × ℝ)   -- lang param, Accept-Language or LANG
 3612:     negotiate : seq (LANGTAG × ℝ) × seq LANGTAG ⇸ LANGTAG
 3613:     geo       : IPADDR ⇸ CC2              -- first answer of the geo sources
 3614:     official  : CC2 ⇸ LANGTAG             -- official language of a country
 3615: 
 3616:     ┌─ Resolve ─────────────────────────────────────────────────────
 3617:     │ ΔLingua
 3618:     │ env? : ENV
 3619:     ├───────────────────────────────────────────────────────────────
 3620:     │ slanguage = ⊥
 3621:     │ let t == negotiate(request(env?), supported) •
 3622:     │   t ≠ ⊥ ⇒ slanguage' = name(base(t)) ∧ code2' = base(t)
 3623:     │          ∧ subcode2' = variety(t)
 3624:     │   t = ⊥ ∧ ¬ dont_use_ip ∧ official(geo(env?.REMOTE_ADDR)) ∈ ran supported
 3625:     │          ⇒ slanguage' = name(official(geo(env?.REMOTE_ADDR)))
 3626:     │   otherwise slanguage' = Unknown
 3627:     │ rlanguage' ≠ ⊥
 3628:     └───────────────────────────────────────────────────────────────
 3629: 
 3630:     EnsureResolved ≙ (Resolve ∨ (ΞLingua ∧ slanguage ≠ ⊥))
 3631: 
 3632: =head2 new
 3633: 
 3634:     ┌─ New ─────────────────────────────────────────────────────────
 3635:     │ Lingua'
 3636:     │ supported? : LANGTAG ∪ seq LANGTAG
 3637:     │ cache? : CACHE ∪ {⊥}
 3638:     │ env? : ENV
 3639:     ├───────────────────────────────────────────────────────────────
 3640:     │ supported? ∈ LANGTAG ⇒ 2 ≤ #supported? ≤ 5
 3641:     │ supported' = (if supported? ∈ LANGTAG then ⟨supported?⟩ else supported?)
 3642:     │                 ↾ SUPPORTED_TAGS        -- other entries dropped, with a warning
 3643:     │ ipc' = gip' = gipf' = unknown
 3644:     │ dont_use_ip' = dont_use_ip?             -- never taken from the cache
 3645:     │ let ip == untaint_ip(env?.REMOTE_ADDR); saved == decode(cache?(key(ip))) •
 3646:     │ (cache? ≠ ⊥ ∧ ip ≠ ⊥ ∧ key(ip) ∈ dom cache?
 3647:     │      ∧ (∀ f : dom saved ∩ dom RESTORABLE • saved(f) ∈ RESTORABLE(f)))
 3648:     │     ⇒ (∀ f : dom saved ∩ dom RESTORABLE • θLingua'.f = saved(f))
 3649:     │ (cache? ≠ ⊥ ∧ ip ≠ ⊥ ∧ key(ip) ∈ dom cache?
 3650:     │      ∧ (∃ f : dom saved ∩ dom RESTORABLE • saved(f) ∉ RESTORABLE(f)))
 3651:     │     ⇒ key(ip) ∉ dom cache?'            -- poisoned entry removed, with a warning
 3652:     │ otherwise
 3653:     │     slanguage' = rlanguage' = country' = locale' = timezone' = ⊥
 3654:     └───────────────────────────────────────────────────────────────
 3655: 
 3656:     RESTORABLE : FIELD ⇸ ℙ seq CHAR
 3657:     RESTORABLE ≙ { slanguage, rlanguage, sublanguage ↦ NAME,
 3658:                    slanguage_code_alpha2, sublanguage_code_alpha2 ↦ LANGCODE,
 3659:                    country ↦ CC2 ∪ {Unknown} }
 3660: 
 3661:     NewError ≙ [ supported? = ⊥ ∨ supported? ∉ LANGTAG ∪ seq LANGTAG
 3662:                  ∨ (info? ≠ ⊥ ∧ ¬ can(info?, lang) ∧ ¬ can(info?, AUTOLOAD)) ] ⇒ croak
 3663: 
 3664: =head2 language
 3665: 
 3666:     ┌─ Language ────────────────────────────────────────────────────
 3667:     │ EnsureResolved
 3668:     │ result! : LANGNAME ∪ {Unknown}
 3669:     ├───────────────────────────────────────────────────────────────
 3670:     │ result! = slanguage'
 3671:     └───────────────────────────────────────────────────────────────
 3672: 
 3673:     PreferredLanguage ≙ Language
 3674:     Name              ≙ Language
 3675: 
 3676: =head2 sublanguage
 3677: 
 3678:     ┌─ Sublanguage ─────────────────────────────────────────────────
 3679:     │ EnsureResolved
 3680:     │ result! : CNAME ∪ {⊥}
 3681:     ├───────────────────────────────────────────────────────────────
 3682:     │ result! = sublanguage'
 3683:     └───────────────────────────────────────────────────────────────
 3684: 
 3685: =head2 language_code_alpha2
 3686: 
 3687:     ┌─ LanguageCodeAlpha2 ──────────────────────────────────────────
 3688:     │ EnsureResolved
 3689:     │ result! : LC2 ∪ {⊥}
 3690:     ├───────────────────────────────────────────────────────────────
 3691:     │ result! = code2'
 3692:     │ slanguage' = Unknown ⇒ result! = ⊥
 3693:     └───────────────────────────────────────────────────────────────
 3694: 
 3695:     CodeAlpha2 ≙ LanguageCodeAlpha2
 3696: 
 3697: =head2 sublanguage_code_alpha2
 3698: 
 3699:     ┌─ SublanguageCodeAlpha2 ───────────────────────────────────────
 3700:     │ EnsureResolved
 3701:     │ result! : CC2 ∪ {⊥}
 3702:     ├───────────────────────────────────────────────────────────────
 3703:     │ result! = subcode2'
 3704:     └───────────────────────────────────────────────────────────────
 3705: 
 3706: =head2 requested_language
 3707: 
 3708:     ┌─ RequestedLanguage ───────────────────────────────────────────
 3709:     │ EnsureResolved
 3710:     │ result! : seq CHAR
 3711:     ├───────────────────────────────────────────────────────────────
 3712:     │ result! = rlanguage'
 3713:     │ -- rlanguage' = name(b) ⁀ " (" ⁀ cname(v) ⁀ ")" when the visitor
 3714:     │ -- asked for base b with variety v; name(b) when no variety;
 3715:     │ -- Unknown when nothing was asked for.
 3716:     └───────────────────────────────────────────────────────────────
 3717: 
 3718: =head2 country
 3719: 
 3720:     ┌─ Country ─────────────────────────────────────────────────────
 3721:     │ ΔLingua
 3722:     │ env? : ENV
 3723:     │ result! : CC2 ∪ {Unknown, ⊥}
 3724:     ├───────────────────────────────────────────────────────────────
 3725:     │ country ≠ ⊥ ⇒ result! = country ∧ θLingua' = θLingua
 3726:     │ country = ⊥ ⇒
 3727:     │   ( env?.GEOIP_COUNTRY_CODE ∈ CC2↑ ⇒ result! = lc(env?.GEOIP_COUNTRY_CODE) )
 3728:     │   ( env?.HTTP_CF_IPCOUNTRY ∈ CC2↑ \ {XX} ⇒ result! = lc(env?.HTTP_CF_IPCOUNTRY) )
 3729:     │   ( ip = canon(env?.REMOTE_ADDR) ∈ PUBLIC_IP ⇒ result! = norm(geo(ip)) )
 3730:     │   ( ip ∉ PUBLIC_IP ⇒ result! = ⊥ )
 3731:     │ country' = result!
 3732:     │ ipc' ≠ unknown ∨ ipc' = ipc ;  gip' ≠ unknown ∨ gip' = gip
 3733:     │ -- norm maps hk ↦ cn, eu ↦ Unknown (or cn for the Baidu subnet),
 3734:     │ -- and anything ∉ CC2 ↦ ⊥
 3735:     └───────────────────────────────────────────────────────────────
 3736: 
 3737:     where CC2↑ is CC2 in upper case, and canon(::ffff:a.b.c.d) = a.b.c.d.
 3738: 
 3739: =head2 locale
 3740: 
 3741:     ┌─ Locale ──────────────────────────────────────────────────────
 3742:     │ ΔLingua
 3743:     │ env? : ENV
 3744:     │ result! : LOCALE ∪ {⊥}
 3745:     ├───────────────────────────────────────────────────────────────
 3746:     │ locale ≠ ⊥ ⇒ result! = locale ∧ θLingua' = θLingua
 3747:     │ locale = ⊥ ⇒ result! = first ⊥-free of
 3748:     │     ⟨ uatag(env?.HTTP_USER_AGENT), browserdetect(env?.HTTP_USER_AGENT),
 3749:     │       loc(Country.result!), loc(env?.GEOIP_COUNTRY_CODE) ⟩
 3750:     │ result! ≠ ⊥ ⇒ locale' = result!
 3751:     └───────────────────────────────────────────────────────────────
 3752: 
 3753: =head2 time_zone
 3754: 
 3755:     ┌─ TimeZone ────────────────────────────────────────────────────
 3756:     │ ΔLingua
 3757:     │ env? : ENV
 3758:     │ result! : ZONE ∪ {⊥}
 3759:     ├───────────────────────────────────────────────────────────────
 3760:     │ timezone ≠ ⊥ ⇒ result! = timezone
 3761:     │ timezone = ⊥ ∧ env?.REMOTE_ADDR ≠ ⊥ ⇒
 3762:     │     result! = first ⊥-free of ⟨ geoip_tz(ip), ipapi_tz(ip) ⟩
 3763:     │ timezone = ⊥ ∧ env?.REMOTE_ADDR = ⊥ ⇒
 3764:     │     result! = first ⊥-free of ⟨ etc_timezone, local_tz ⟩
 3765:     │ result! ∉ ZONE ⇒ result! = ⊥
 3766:     │ timezone' = result!
 3767:     └───────────────────────────────────────────────────────────────
 3768: 
 3769: =head2 is_rtl
 3770: 
 3771:     ┌─ IsRtl ───────────────────────────────────────────────────────
 3772:     │ EnsureResolved
 3773:     │ result! : {0, 1}
 3774:     ├───────────────────────────────────────────────────────────────
 3775:     │ result! = 1 ⇔ code2' ∈ RTL_LANGS
 3776:     └───────────────────────────────────────────────────────────────
 3777: 
 3778: =head2 text_direction
 3779: 
 3780:     ┌─ TextDirection ───────────────────────────────────────────────
 3781:     │ IsRtl
 3782:     │ dir! : DIR
 3783:     ├───────────────────────────────────────────────────────────────
 3784:     │ dir! = (if result! = 1 then rtl else ltr)
 3785:     └───────────────────────────────────────────────────────────────
 3786: 
 3787: =head2 plural_category
 3788: 
 3789:     PLURAL_RULES : LC2 ⇸ (ℕ → PLURAL)
 3790:     english == λ n : ℕ • (if n = 1 then one else other)
 3791: 
 3792:     ┌─ PluralCategory ──────────────────────────────────────────────
 3793:     │ EnsureResolved
 3794:     │ n? : ℝ
 3795:     │ result! : PLURAL
 3796:     ├───────────────────────────────────────────────────────────────
 3797:     │ n? ≠ ⊥
 3798:     │ code2' = ⊥ ⇒ result! = other
 3799:     │ code2' ∈ dom PLURAL_RULES ⇒ result! = PLURAL_RULES(code2')(trunc n?)
 3800:     │ code2' ∉ dom PLURAL_RULES ∪ {⊥} ⇒ result! = english(trunc n?)
 3801:     └───────────────────────────────────────────────────────────────
 3802: 
 3803:     PluralError ≙ [ n? = ⊥ ] ⇒ croak
 3804: 
 3805: =head2 translation_file
 3806: 
 3807:     ┌─ TranslationFile ─────────────────────────────────────────────
 3808:     │ EnsureResolved
 3809:     │ dir? : PATH ∪ {⊥}
 3810:     │ ext? : seq CHAR ∪ {⊥}
 3811:     │ files : ℙ PATH                       -- readable regular files
 3812:     │ result! : PATH ∪ {⊥}
 3813:     ├───────────────────────────────────────────────────────────────
 3814:     │ e == (if ext? = ⊥ then "json" else strip_dot(ext?))
 3815:     │ (dir? = ⊥ ∨ dir? = ⟨⟩ ∨ ".." ⊆ dir? ∨ NUL ∈ ran dir?
 3816:     │     ∨ ¬ (ran e ⊆ ALNUM ∪ {'-'})) ⇒ result! = ⊥
 3817:     │ otherwise
 3818:     │   cands == ⟨ code2' ⁀ "-" ⁀ subcode2' | subcode2' ≠ ⊥ ⟩ ⁀ ⟨ code2' | code2' ≠ ⊥ ⟩
 3819:     │   result! = first p : ran cands • dir? ⁀ "/" ⁀ p ⁀ "." ⁀ e ∈ files
 3820:     │             (⊥ if there is none)
 3821:     └───────────────────────────────────────────────────────────────
 3822: 
 3823: =head1 STATE DIAGRAM
 3824: 
 3825: A CGI::Lingua object has several independent parts. Each part starts
 3826: empty and is filled in the first time a method needs it.
 3827: After that, the part does not change (it is remembered).
 3828: 
 3829: Part 1: the language (used by language(), sublanguage(),
 3830: language_code_alpha2(), sublanguage_code_alpha2(), requested_language(),
 3831: is_rtl(), text_direction(), plural_category(), translation_file())
 3832: 
 3833:                                   new()
 3834:                                     |
 3835:                                     v
 3836:                       +---------------------------+
 3837:                       |   LANGUAGE NOT CHECKED    |
 3838:                       |   _slanguage = undef      |
 3839:                       +---------------------------+
 3840:                                     |
 3841:                  first call to any language method:
 3842:                  read the lang param, HTTP_ACCEPT_LANGUAGE or LANG,
 3843:                  and compare it with the supported list
 3844:                                     |
 3845:                   +-----------------+------------------+
 3846:                   |                                    |
 3847:              a match                               no match
 3848:                   |                                    |
 3849:                   |                      +-------------+-------------+
 3850:                   |                      |                           |
 3851:                   |               dont_use_ip is false         dont_use_ip
 3852:                   |               side effect: country()       is true
 3853:                   |               is called (Part 2), and           |
 3854:                   |               the country's official            |
 3855:                   |               language is tried                 |
 3856:                   |                 |               |               |
 3857:                   |            supported     not supported          |
 3858:                   v                 v               v               v
 3859:            +----------------------------+   +------------------------------+
 3860:            |          MATCHED           |   |          UNMATCHED           |
 3861:            | language() = 'English' ... |   | language() = 'Unknown'       |
 3862:            | language_code_alpha2() set |   | language_code_alpha2() undef |
 3863:            +----------------------------+   +------------------------------+
 3864: 
 3865:         Both MATCHED and UNMATCHED are final: later calls return the same
 3866:         answers, even if %ENV changes.
 3867: 
 3868: Part 2: the country (used by country(), locale(), and the language IP path)
 3869: 
 3870:     +----------------------+   country(): REMOTE_ADDR missing, invalid,
 3871:     |  COUNTRY NOT KNOWN   |---------------------------------------------+
 3872:     |  _country = undef    |   private or loopback, or no source answers |
 3873:     +----------------------+<--------------------------------------------+
 3874:                |                (returns undef; NOT remembered, so the
 3875:                |                 next call tries again)
 3876:                | country(): a source gives a valid code
 3877:                | side effects: geo modules loaded, sentinels set,
 3878:                |               value stored in cache (if any)
 3879:                v
 3880:     +----------------------+
 3881:     |    COUNTRY KNOWN     |  later calls return the same value
 3882:     |  _country = 'xx'     |  (or 'Unknown' for EU addresses)
 3883:     +----------------------+
 3884: 
 3885: Part 3: each geo module (IP::Country, Geo::IP, Geo::IPfree)
 3886: 
 3887:     +-----------+  first use: module loads   +-----------+
 3888:     |  UNKNOWN  |--------------------------->|  PRESENT  |
 3889:     |   (-1)    |                            |    (1)    |
 3890:     +-----------+--------------------------->+-----------+
 3891:                    first use: module or      +-----------+
 3892:                    database is missing ----->|  ABSENT   |
 3893:                                              |    (0)    |
 3894:                                              +-----------+
 3895: 
 3896: Part 4: locale() and time_zone()
 3897: 
 3898:     +------------+  locale() / time_zone() finds a value  +------------+
 3899:     | NOT KNOWN  |--------------------------------------->|   KNOWN    |
 3900:     |  (undef)   |<-------+                               | remembered |
 3901:     +------------+        | nothing found: returns undef, +------------+
 3902:           |               | stays NOT KNOWN (time_zone()
 3903:           +---------------+ also warns)
 3904: 
 3905: Part 5: the life of the object
 3906: 
 3907:     new() ----------------------> ALIVE ----------------------> DESTROYED
 3908:       |   no cache entry, or        ^      object goes out of     side effect:
 3909:       |   no REMOTE_ADDR            |      scope (DESTROY)        if cache and
 3910:       |                             |                             REMOTE_ADDR are
 3911:       +---- valid cache entry ------+                             set and no entry
 3912:       |     found (the six answer   |                             exists yet, the
 3913:       |     fields restored, each   |                             answers are saved
 3914:       |     checked; geo sentinels  |                             to the cache as
 3915:       |     reset to UNKNOWN)       |                             JSON
 3916:       |                             |
 3917:       +---- malformed cache entry --+
 3918:       |     found (removed, warned;
 3919:       |     answers worked out again)
 3920:       |
 3921:       +---- REMOTE_ADDR not a valid address: the cache is not used
 3922:       |
 3923:       +---- bad arguments ---> croak (no object)
 3924: 
 3925:     $obj->new(...) makes a copy in the ALIVE state that keeps all the
 3926:     answers of $obj (all parts keep their current state).
 3927: 
 3928: =head1 LICENSE AND COPYRIGHT
 3929: 
 3930: Copyright 2010-2026 Nigel Horne.
 3931: 
 3932: Usage is subject to the GPL2 licence terms.
 3933: If you use it,
 3934: please let me know.
 3935: 
 3936: =cut
 3937: 
 3938: 1; # End of CGI::Lingua