File Coverage

File:blib/lib/CGI/Lingua.pm
Coverage:80.9%

linestmtbrancondsubtimecode
1package CGI::Lingua;
2
3
27
27
27
1869126
22
558
use warnings;
4
27
27
27
41
20
253
use strict;
5
27
27
27
3259
105977
62
use autodie qw(:file);
6
7
27
27
27
19723
1730055
523
use Object::Configure 0.14;
8
27
27
27
85
122
434
use Params::Get 0.13;
9
27
27
27
50
20
461
use Readonly;
10
27
27
27
72
22
418
use Scalar::Util qw(blessed);
11
27
27
27
52
21
570
use Storable;
12
27
76
use Class::Autouse qw{
13        Carp
14        Locale::Language
15        Locale::Object::Country
16        Locale::Object::DB
17        I18N::AcceptLanguage
18        I18N::LangTags::Detect
19
27
27
6605
83559
};
20
21our $VERSION = '0.81';
22
23# ── Module-level constants ───────────────────────────────────────────────────
24# Gathering magic strings here makes behavioural changes one-edit operations.
25
26Readonly my $CACHE_TTL_LONG      => '1 month';
27Readonly my $CACHE_TTL_SHORT     => '1 hour';
28Readonly my $CACHE_NS            => 'CGI::Lingua:';    # namespace prefix for every key
29Readonly my $BROKEN_GEOIPFREE    => '45.128.139.41';  # https://github.com/bricas/geo-ipfree/issues/10
30Readonly my $BAIDU_SUBNET        => '185.10.104.0/22';# RT-86809: Baidu misreports as EU
31Readonly my $DEPRECATED_EN_UK    => 'en-uk';          # some browsers still send this
32Readonly my $CANONICAL_EN_GB     => 'en-gb';
33Readonly my $ACCEPT_LANG_MAX     => 256;              # max bytes we accept from the header
34Readonly my $GEO_UNKNOWN         => -1;               # geo-module sentinel: not yet probed
35Readonly my $GEO_ABSENT          =>  0;               # geo-module sentinel: unavailable
36Readonly my $GEO_PRESENT         =>  1;               # geo-module sentinel: loaded OK
37Readonly my %RTL_LANGS           => (map { $_ => 1 }  # ISO 639-1 codes whose primary script is RTL
38    qw(ar dv fa he ku ps sd ug ur yi));
39
40 - 48
=head1 NAME

CGI::Lingua - Create a multilingual web page

=head1 VERSION

Version 0.80

=cut
49
50 - 125
=head1 SYNOPSIS

CGI::Lingua is a powerful module for multilingual web applications
offering extensive language/country detection strategies.

No longer does your website need to be in English only.
CGI::Lingua provides a simple basis to determine which language to display a website.
The website tells CGI::Lingua which languages it supports.
Based on that list CGI::Lingua tells the application which language the user would like to use.

    use CGI::Lingua;
    # ...
    my $l = CGI::Lingua->new(['en', 'fr', 'en-gb', 'en-us']);
    my $language = $l->language();
    if ($language eq 'English') {
        print '<P>Hello</P>';
    } elsif($language eq 'French') {
        print '<P>Bonjour</P>';
    } else {    # $language eq 'Unknown'
        my $rl = $l->requested_language();
        print "<P>Sorry for now this page is not available in $rl.</P>";
    }
    my $c = $l->country();
    if ($c eq 'us') {
      # print contact details in the US
    } elsif ($c eq 'ca') {
      # print contact details in Canada
    } else {
      # print worldwide contact details
    }

    # ...

    use CHI;
    use CGI::Lingua;
    # ...
    my $cache = CHI->new(driver => 'File', root_dir => '/tmp/cache', namespace => 'CGI::Lingua-countries');
    $l = CGI::Lingua->new({ supported => ['en', 'fr'], cache => $cache });

=head1 SUBROUTINES/METHODS

=head2 new

Creates a CGI::Lingua object.

=head3 API SPECIFICATION

    Input:
      supported  => ArrayRef[Str] | Str   # required; RFC-1766 language codes
      cache      => Object                # optional; CHI-compatible (get/set)
      config_file => Str                  # optional; YAML/XML/INI config path
      logger     => Object                # optional; must implement warn/info/error
      info       => Object                # optional; CGI::Info-compatible
      data       => Any                   # optional; forwarded to I18N::AcceptLanguage
      dont_use_ip => Bool                 # optional; disable IP-based fallback
      syslog     => Bool | HashRef        # optional; Sys::Syslog integration
      debug      => Bool                  # optional; enable debug logging

    Returns: CGI::Lingua blessed hashref, or a clone when called on an object.

=head3 MESSAGES

    "You must give a list of supported languages"  - no 'supported' key provided
    "List of supported languages must be an array ref" - supported is wrong ref type
    "Supported languages must be the short code"  - string too short or too long
    "Logger must be a blessed object with warn/info/error methods" - bad logger arg

=head3 PSEUDOCODE

    1. Normalise args via Params::Get and Object::Configure
    2. Validate logger (must be blessed with warn/info/error) if provided
    3. Validate supported (required, string or arrayref)
    4. If cache and REMOTE_ADDR set, attempt to thaw a previously stored state
    5. Bless and return fresh object with sentinel flags set to GEO_UNKNOWN

=cut
126
127sub new
128{
129
1645
3593406
        my $class = shift;
130
1645
2186
        my $params = Params::Get::get_params('supported', @_);
131
132        # Handle ::new() misuse
133
1641
26354
        if(!defined($class)) {
134
2
2
                if($params) {
135
2
4
                        if(my $logger = $params->{'logger'}) {
136
0
0
                                $logger->error(__PACKAGE__ . ' use ->new() not ::new() to instantiate');
137                        }
138
2
15
                        Carp::croak(__PACKAGE__ . ' use ->new() not ::new() to instantiate');
139                }
140
0
0
                $class = __PACKAGE__;
141        } elsif(ref($class)) {
142                # Clone: overlay new params onto existing object state
143
3
12
                $params->{_supported} ||= $params->{supported} if defined $params->{'supported'};
144
3
3
3
2
9
11
                return bless { %{$class}, %{$params} }, ref($class);
145        }
146
147        # Validate blessed logger objects before Object::Configure runs.
148        # Non-blessed values (arrayrefs, hashrefs) are valid config forms that
149        # Object::Configure knows how to convert into a Log::Abstraction instance.
150
1636
1866
        if(defined $params->{'logger'} && blessed($params->{'logger'})) {
151
7
33
                unless(
152                        $params->{'logger'}->can('warn')
153                        && $params->{'logger'}->can('info')
154                        && $params->{'logger'}->can('error')
155                ) {
156
3
210
                        Carp::croak('Logger must be a blessed object with warn/info/error methods');
157                }
158        }
159
160
1633
2507
        $params = Object::Configure::configure($class, $params);
161
162        # Normalise supported / supported_languages alias
163
1633
2971994
        $params->{'supported'} ||= $params->{'supported_languages'};
164
1633
2213
        if(defined($params->{supported})) {
165                # Validate supported type/length
166
1627
3230
                if(ref($params->{supported})) {
167
596
915
                        if(ref($params->{supported}) ne 'ARRAY') {
168
243
3195
                                Carp::croak('List of supported languages must be an array ref');
169                        }
170                } elsif((length($params->{supported}) < 2) || (length($params->{supported}) > 5)) {
171
185
2744
                        Carp::croak('Supported languages must be the short code');
172                }
173        } else {
174
6
16
                if(my $logger = $params->{'logger'}) {
175
6
18
                        $logger->error('You must give a list of supported languages');
176                }
177
6
2039
                Carp::croak('You must give a list of supported languages');
178        }
179
180
1200
1315
        my $cache = $params->{cache};
181
1200
822
        my $info  = $params->{info};
182
183        # Try to restore a frozen state from the cache before doing any work
184
1200
1378
        if($cache && $ENV{'REMOTE_ADDR'}) {
185
31
55
                my $key = _build_cache_key($ENV{'REMOTE_ADDR'}, $params, $class, $info);
186
31
82
                if(my $rc = $cache->get($key)) {
187
6
568
                        $rc = Storable::thaw($rc);
188                        # Re-inject transient/non-serialisable fields
189
6
124
                        $rc->{logger}           = $params->{'logger'};
190
6
9
                        $rc->{_syslog}          = $params->{syslog};
191
6
14
                        $rc->{_cache}           = $cache;
192
6
11
                        $rc->{_supported}       = $params->{supported};
193
6
6
                        $rc->{_info}            = $info;
194
6
13
                        $rc->{_have_ipcountry}  = $GEO_UNKNOWN;
195
6
18
                        $rc->{_have_geoip}      = $GEO_UNKNOWN;
196
6
15
                        $rc->{_have_geoipfree}  = $GEO_UNKNOWN;
197
198                        # If lang= CGI param is active, the cached language choice may be stale
199
6
47
                        if(($rc->{_what_language} || $rc->{_rlanguage}) && $info && $info->lang()) {
200
0
0
0
0
                                delete @{$rc}{qw(_what_language _rlanguage _country)};
201                        }
202
6
19
                        return $rc;
203                }
204        }
205
206        return bless {
207
1194
7135
                %{$params},
208                _supported => ref($params->{supported}) ? $params->{supported} : [ $params->{'supported'} ],
209                _cache           => $cache,
210                _info            => $info,
211                _syslog          => $params->{syslog},
212                _dont_use_ip     => $params->{dont_use_ip} || 0,
213                _have_ipcountry  => $GEO_UNKNOWN,
214                _have_geoip      => $GEO_UNKNOWN,
215                _have_geoipfree  => $GEO_UNKNOWN,
216
1194
1987
                _debug           => $params->{debug} || 0,
217        }, $class;
218}
219
220# ── _build_cache_key ──────────────────────────────────────────────────────────
221# Purpose:      Produce a deterministic string key for the per-request cache
222#               entry stored in new() and DESTROY().
223# Entry:        $addr  â€” IP string (not yet taint-checked; used read-only here)
224#               $params — constructor params hashref
225#               $class  â€” package name
226#               $info   â€” optional CGI::Info object
227# Exit:         A plain string key of the form "ip/lang/lang1/lang2/..."
228sub _build_cache_key
229{
230
70
50120
        my ($addr, $params, $class, $info) = @_;
231
232
70
73
        my $key = "$addr/";
233
234        # Include the requested language (if determinable) so different
235        # Accept-Language values get distinct cache slots for the same IP.
236
70
46
        my $l;
237
70
210
        if($info && ($l = $info->lang())) {
238
3
9
                $key .= "$l/";
239        } elsif($l = $class->_what_language()) {
240
46
54
                $key .= "$l/";
241        }
242
243        # Fix: was ref($params->{'supported'} eq 'ARRAY') — eq was inside ref(),
244        # so ref() always received a boolean (1 or ''), never the arrayref itself.
245        # Result: arrayref-supported always fell through to the else branch and
246        # stringified to 'ARRAY(0x...)' — a different address every request —
247        # making cache lookups in new() permanently fail.
248
70
101
        if(ref($params->{'supported'}) eq 'ARRAY') {
249
69
69
48
89
                $key .= join('/', @{$params->{supported}});
250        } else {
251
1
1
                $key .= $params->{'supported'};
252        }
253
254
70
85
        return $key;
255}
256
257# Some of the information takes a long time to work out, so cache what we can
258sub DESTROY {
259
1228
252628
        if(defined($^V) && ($^V ge 'v5.14.0')) {
260
1228
1744
                return if ${^GLOBAL_PHASE} eq 'DESTRUCT';
261        }
262
1228
5522
        return unless $ENV{'REMOTE_ADDR'};
263
264
175
128
        my $self = shift;
265
175
160
        return unless ref($self);
266
267
175
249
        my $cache = $self->{_cache};
268
175
1135
        return unless $cache;
269
270        my $key = _build_cache_key(
271                $ENV{'REMOTE_ADDR'},
272                { supported => $self->{_supported} },
273                ref($self),
274                $self->{_info},
275
32
81
        );
276
32
51
        return if $cache->get($key);
277
278
26
924
        $self->_debug("Storing self in cache as $key");
279
280        # Freeze only the computed state — not loggers, file handles, or
281        # geo-module objects (they are re-initialised on next construction).
282        my $copy = bless {
283                _slanguage              => $self->{_slanguage},
284                _slanguage_code_alpha2  => $self->{_slanguage_code_alpha2},
285                _sublanguage_code_alpha2 => $self->{_sublanguage_code_alpha2},
286                _country                => $self->{_country},
287                _rlanguage              => $self->{_rlanguage},
288                _dont_use_ip            => $self->{_dont_use_ip},
289                _have_ipcountry         => $self->{_have_ipcountry},
290                _have_geoip             => $self->{_have_geoip},
291                _have_geoipfree         => $self->{_have_geoipfree},
292
26
892
        }, ref($self);
293
294
26
66
        $cache->set($key, Storable::nfreeze($copy), $CACHE_TTL_LONG);
295}
296
297 - 313
=head2 language

Tells the CGI application in what language to display its messages.
The language is the natural name e.g. 'English' or 'Japanese'.

Sublanguages are handled sensibly, so that if a client requests U.S. English
on a site that only serves British English, language() will return 'English'.

If none of the requested languages is included within the supported lists,
language() returns 'Unknown'.

=head3 API SPECIFICATION

    Input:  none beyond $self
    Returns: Str - human-readable language name, or 'Unknown'

=cut
314
315sub language {
316
142
5944
        my $self = $_[0];
317
318
142
306
        $self->_find_language() unless $self->{_slanguage};
319
142
633
        return $self->{_slanguage};
320}
321
322 - 326
=head2 preferred_language

Same as language().

=cut
327
328sub preferred_language
329{
330
7
41
        my $self = shift;
331
7
16
        return $self->language(@_);
332}
333
334 - 338
=head2 name

Synonym for language, for compatibility with Locale::Object::Language.

=cut
339
340sub name {
341
7
23
        my $self = $_[0];
342
7
30
        return $self->language();
343}
344
345 - 355
=head2 sublanguage

Tells the CGI what variant to use e.g. 'United Kingdom', or undef if
it can't be determined.

=head3 API SPECIFICATION

    Input:  none beyond $self
    Returns: Str | undef

=cut
356
357sub sublanguage {
358
45
107
        my $self = $_[0];
359
360
45
65
        $self->_trace('Entered sublanguage');
361
45
1355
        $self->_find_language() unless $self->{_slanguage};
362
45
99
        $self->_trace('Leaving sublanguage ', ($self->{_sublanguage} || 'undef'));
363
45
1149
        return $self->{_sublanguage};
364}
365
366 - 379
=head2 language_code_alpha2

Gives the two-character representation of the supported language, e.g. 'en'
when you've asked for en-gb.

If none of the requested languages is included within the supported lists,
language_code_alpha2() returns undef.

=head3 API SPECIFICATION

    Input:  none beyond $self
    Returns: Str (2 chars) | undef

=cut
380
381sub language_code_alpha2 {
382
61
75
        my $self = $_[0];
383
384
61
69
        $self->_trace('Entered language_code_alpha2');
385
61
2162
        $self->_find_language() unless $self->{_slanguage};
386
61
74
        $self->_trace('language_code_alpha2 returns ', $self->{_slanguage_code_alpha2});
387
61
1798
        return $self->{_slanguage_code_alpha2};
388}
389
390 - 394
=head2 code_alpha2

Synonym for language_code_alpha2, kept for historical reasons.

=cut
395
396sub code_alpha2 {
397
14
661
        my $self = $_[0];
398
14
26
        return $self->language_code_alpha2();
399}
400
401 - 411
=head2 sublanguage_code_alpha2

Gives the two-character representation of the supported language, e.g. 'gb'
when you've asked for en-gb, or undef.

=head3 API SPECIFICATION

    Input:  none beyond $self
    Returns: Str (2 chars) | undef

=cut
412
413sub sublanguage_code_alpha2 {
414
19
795
        my $self = $_[0];
415
416
19
40
        $self->_find_language() unless $self->{_slanguage};
417
19
35
        return $self->{_sublanguage_code_alpha2};
418}
419
420 - 433
=head2 requested_language

Gives a human-readable rendition of what language the user asked for whether
or not it is supported.

Returns the sublanguage (if appropriate) in parentheses,
e.g. "English (United Kingdom)"

=head3 API SPECIFICATION

    Input:  none beyond $self
    Returns: Str - e.g. "English (United Kingdom)" or "Unknown"

=cut
434
435sub requested_language {
436
64
7583
        my $self = $_[0];
437
438
64
114
        $self->_find_language() unless $self->{_rlanguage};
439
64
186
        return $self->{_rlanguage};
440}
441
442# ── _find_language ─────────────────────────────────────────────────────────
443# Purpose:      Populate _slanguage, _rlanguage, _sublanguage, and the
444#               various code fields by working through the detection pipeline:
445#               Accept-Language header → I18N::AcceptLanguage → IP country.
446# Entry:        $self->{_slanguage} must be undef (guards repeated calls).
447# Exit:         $self->{_slanguage} is set to a language name or 'Unknown'.
448# Side Effects: Populates _rlanguage, _sublanguage, *_code_alpha2 fields.
449sub _find_language
450{
451
165
896
        my $self = shift;
452
453
165
225
        $self->_trace('Entered _find_language');
454
455
165
6933
        $self->{_rlanguage} = 'Unknown';
456
165
162
        $self->{_slanguage} = 'Unknown';
457
458
165
215
        my $http_accept_language = $self->_what_language();
459
165
194
        if(defined($http_accept_language)) {
460                $self->_debug(
461                        "language wanted: $http_accept_language, "
462                        . 'languages supported: '
463
143
143
163
357
                        . join(', ', @{$self->{_supported}} // '')
464                );
465
466                # Normalise the deprecated en-uk tag that some browsers send
467
143
4217
                if($http_accept_language eq $DEPRECATED_EN_UK) {
468
5
38
                        $self->_debug("Resetting country code to GB for $http_accept_language");
469
5
145
                        $http_accept_language = $CANONICAL_EN_GB;
470                }
471
472                # Run the header through the Accept-Language resolver
473
143
467
                my ($l, $requested_sublanguage) =
474                        $self->_accept_language_match($http_accept_language);
475
476                # Resolve the matched code to a full language/sublanguage
477
143
196
                if($l) {
478
120
169
                        return if $self->_resolve_match($l, $requested_sublanguage, $http_accept_language);
479                } elsif($http_accept_language =~ /;/) {
480                        # e.g. de-DE,de;q=0.9,en-US;q=0.8 and we support none of those
481                        $self->_notice(
482                                __PACKAGE__, ': ', __LINE__,
483                                ": couldn't honour HTTP_ACCEPT_LANGUAGE=$http_accept_language,"
484                                . ' supported languages are: '
485
2
2
2
7
                                . join(',', @{$self->{_supported}})
486                        );
487                }
488
489                # Detected slanguage but rlanguage still Unknown — try I18N::LangTags
490
25
92
                if($self->{_slanguage} && ($self->{_slanguage} ne 'Unknown')) {
491
0
0
                        if($self->{_rlanguage} eq 'Unknown') {
492
0
0
                                $self->{_rlanguage} = I18N::LangTags::Detect::detect();
493                        }
494
0
0
                        if($self->{_rlanguage}) {
495
0
0
                                if(my $resolved = $self->_code2language($self->{_rlanguage})) {
496
0
0
                                        $self->{_rlanguage} = $resolved;
497                                }
498
0
0
                                return;
499                        }
500                }
501
502                # Last-chance: 2-char or xx-xx header where we have no match
503
25
112
                if(
504                        ((!$self->{_rlanguage}) || ($self->{_rlanguage} eq 'Unknown'))
505                        && ((length($http_accept_language) == 2) || ($http_accept_language =~ /^..-..$/))
506                ) {
507
16
24
                        $self->{_rlanguage} = $self->_code2language($http_accept_language) || 'Unknown';
508                }
509
25
89082
                $self->{_slanguage} = 'Unknown';
510        }
511
512
47
65
        return if $self->{_dont_use_ip};
513
514        # Fall back to the official language of the visitor's country
515
46
78
        $self->_find_language_from_ip($http_accept_language);
516}
517
518# ── _accept_language_match ────────────────────────────────────────────────
519# Purpose:      Run I18N::AcceptLanguage strict matching plus two fallback
520#               left-to-right scan passes against $self->{_supported}.
521# Entry:        $http_accept_language — validated, untainted Accept-Language value.
522# Exit:         Returns ($matched_code, $requested_sublanguage) or (undef, undef).
523# Side Effects: Logs debug messages.
524sub _accept_language_match
525{
526
143
156
        my ($self, $http_accept_language) = @_;
527
528        # Suppress I18N::AcceptLanguage's uninitialized-value warnings (RT 74338)
529        local $SIG{__WARN__} = sub {
530
2
48
                warn $_[0] unless $_[0] =~ /^Use of uninitialized value/;
531
143
372
        };
532
143
469
        my $i18n = I18N::AcceptLanguage->new(debug => $self->{_debug}, strict => 1);
533
143
14242
        my $l = $i18n->accepts($http_accept_language, $self->{_supported});
534
143
10227
        local $SIG{__WARN__} = 'DEFAULT';
535
536        # I18N-AcceptLanguage strict mode can return a sublanguage variant when
537        # the request contains a sublanguage we don't support; force a retry.
538
143
842
        if($l && ($http_accept_language =~ /-/) && ($http_accept_language !~ qr/$l/i)) {
539
3
5
                $self->_debug('Forcing fallback');
540
3
53
                undef $l;
541        }
542
543
143
130
        my $requested_sublanguage;
544
143
148
        if(!$l) {
545                # Sort tokens by q-value once; both scan passes share the ordered list
546
28
51
                my $sorted = $self->_sorted_tokens($http_accept_language);
547                # First fallback: scan for xx-yy pairs, try base language xx
548
28
47
                ($l, $requested_sublanguage) =
549                        $self->_scan_sublanguage_pairs($i18n, $sorted);
550
28
47
                if(!$l) {
551                        # Second fallback: scan plain tokens without sublanguages
552
24
45
                        $l = $self->_scan_plain_tokens($i18n, $sorted);
553
24
39
                        undef $requested_sublanguage if $l;
554                }
555        }
556
557
143
643
        return ($l, $requested_sublanguage);
558}
559
560# ── _sorted_tokens ────────────────────────────────────────────────────────
561# Purpose:      Parse an Accept-Language header into tokens sorted by
562#               descending quality value so fallback scans honour q= priority.
563# Entry:        $header — validated Accept-Language string.
564# Exit:         Arrayref of [$language_tag, $quality] pairs, highest q first.
565# Side Effects: None.
566sub _sorted_tokens
567{
568
36
280
        my ($self, $header) = @_;
569
36
26
        my @tokens;
570
36
55
        for my $token (split /,/, $header) {
571
53
127
                $token =~ s/^\s+|\s+$//g;
572
53
39
                my $q = 1.0;
573
53
97
                if($token =~ s/;\s*q\s*=\s*(\d+(?:\.\d+)?)//) {
574
17
29
                        $q = $1 + 0;
575                }
576
53
94
                $token =~ s/^\s+|\s+$//g;
577
53
92
                push @tokens, [$token, $q] if length $token;
578        }
579
36
21
62
41
        return [sort { $b->[1] <=> $a->[1] } @tokens];
580}
581
582# ── _scan_sublanguage_pairs ───────────────────────────────────────────────
583# Purpose:      Walk q-sorted tokens looking for xx-yy pairs; try accepting
584#               the base language xx from the supported list.
585# Entry:        $i18n — I18N::AcceptLanguage instance;
586#               $sorted — arrayref from _sorted_tokens.
587# Exit:         ($matched_code, $sublanguage_code) or (undef, undef).
588# Side Effects: Debug logging.
589sub _scan_sublanguage_pairs
590{
591
30
54
        my ($self, $i18n, $sorted) = @_;
592
593
30
47
        $self->_debug(__PACKAGE__, ': ', __LINE__, ': scan q-sorted tokens for xx-yy pairs');
594
30
30
894
44
        for my $entry (@{$sorted}) {
595
39
39
176
37
                my ($tag) = @{$entry};
596
39
72
                next unless $tag =~ /^(..)-(..)$/;
597
13
17
                my ($base, $sub) = ($1, $2);
598
13
39
                $self->_debug(__PACKAGE__, ': ', __LINE__, ": see if $base is supported");
599
13
299
                if($i18n->accepts($base, $self->{_supported})) {
600
5
192
                        $self->_debug("Fallback to $base as sublanguage $sub is not supported");
601
5
92
                        return ($base, $sub);
602                }
603        }
604
25
92
        return (undef, undef);
605}
606
607# ── _scan_plain_tokens ────────────────────────────────────────────────────
608# Purpose:      Walk q-sorted tokens that have no sublanguage suffix and try
609#               accepting each against the supported list.
610# Entry:        $i18n — I18N::AcceptLanguage instance;
611#               $sorted — arrayref from _sorted_tokens.
612# Exit:         Matched code string, or undef.
613# Side Effects: Debug logging.
614sub _scan_plain_tokens
615{
616
27
26
        my ($self, $i18n, $sorted) = @_;
617
618
27
40
        $self->_debug(__PACKAGE__, ': ', __LINE__, ': scan q-sorted tokens for plain alternatives');
619
27
27
798
42
        for my $entry (@{$sorted}) {
620
35
35
89
33
                my ($tag) = @{$entry};
621
35
50
                next if $tag =~ /^..-../;    # already tried in the pair scan
622
29
46
                $self->_debug(__PACKAGE__, ': ', __LINE__, ": see if $tag is supported");
623
29
850
                if($i18n->accepts($tag, $self->{_supported})) {
624
3
32
                        $self->_debug("Fallback to $tag as best alternative");
625
3
75
                        return $tag;
626                }
627        }
628
24
788
        return undef;
629}
630
631# ── _resolve_match ────────────────────────────────────────────────────────
632# Purpose:      Given a matched code $l (possibly xx or xx-yy), populate all
633#               of _slanguage, _rlanguage, _sublanguage and their code fields.
634# Entry:        $l — 2-char or xx-yy language code; $requested_sublanguage —
635#               2-char variety code or undef; $http_accept_language — full header.
636# Exit:         Returns true (1) if the caller should return immediately.
637# Side Effects: Mutates $self->{_slanguage}, _rlanguage, _sublanguage, etc.
638sub _resolve_match
639{
640
121
161
        my ($self, $l, $requested_sublanguage, $http_accept_language) = @_;
641
642
121
170
        $self->_debug("l: $l");
643
644
121
3799
        if($l !~ /^..-../) {
645                # Base-language match (e.g. 'en') — no sublanguage component
646
76
121
                return $self->_resolve_base_match($l, $requested_sublanguage, $http_accept_language);
647        } elsif($l =~ /(.+)-(..)$/) {
648                # Sublanguage match (e.g. 'en-gb') — resolve both language and variant
649
45
98
                return $self->_resolve_sublanguage_match($l, $1, $2, $http_accept_language);
650        }
651
0
0
        return 0;
652}
653
654# ── _resolve_base_match ───────────────────────────────────────────────────
655# Purpose:      Handle the case where a base-language code matched (no hyphen).
656#               Sets _slanguage, _rlanguage; appends sublanguage name to rlanguage
657#               when the client requested one we don't support.
658# Entry:        $l — 2-char code; $requested_sublanguage — optional; $header.
659# Exit:         1 to signal caller should return, 0 otherwise.
660# Side Effects: Mutates slanguage, rlanguage, slanguage_code_alpha2.
661sub _resolve_base_match
662{
663
78
108
        my ($self, $l, $requested_sublanguage, $header) = @_;
664
665
78
113
        $self->{_slanguage} = $self->_code2language($l);
666
78
270132
        return 0 unless $self->{_slanguage};
667
668
74
156
        $self->_debug("_slanguage: $self->{_slanguage}");
669
74
2300
        $self->{_slanguage_code_alpha2} = $l;
670
74
75
        $self->{_rlanguage}             = $self->{_slanguage};
671
672        # Attempt to name the sublanguage the client actually asked for
673
74
56
        my $sl;
674
74
156
        if($header =~ /..-(..)$/) {
675
8
29
                $self->_debug($1);
676
8
200
                $sl = $self->_code2country($1);
677
8
22
                $requested_sublanguage //= $1;
678        } elsif($header =~ /..-([a-z]{2,3})$/i) {
679
1
1
1
2
                eval { $sl = Locale::Object::Country->new(code_alpha3 => $1) };
680
1
266
                $self->_info($@) if $@;
681        }
682
683
74
107
        if($sl) {
684
7
15
                $self->{_rlanguage} .= ' (' . $sl->name() . ')';
685        } elsif($requested_sublanguage) {
686
4
8
                if(my $c = $self->_code2countryname($requested_sublanguage)) {
687
2
14
                        $self->{_rlanguage} .= " ($c)";
688                } else {
689
2
3
                        $self->{_rlanguage} .= " (Unknown: $requested_sublanguage)";
690                }
691        }
692
74
165
        return 1;
693}
694
695# ── _resolve_sublanguage_match ────────────────────────────────────────────
696# Purpose:      Handle the case where the full xx-yy code matched in the
697#               supported list.  Resolves the variety name and caches results.
698# Entry:        $l — full code e.g. 'en-gb'; $alpha2 — 'en'; $variety — 'gb';
699#               $header — full Accept-Language value.
700# Exit:         1 to signal caller should return, 0 otherwise.
701# Side Effects: Mutates _slanguage, _rlanguage, _sublanguage and code fields;
702#               writes to cache.
703sub _resolve_sublanguage_match
704{
705
45
92
        my ($self, $l, $alpha2, $variety, $header) = @_;
706
707
45
68
        my $i18n    = I18N::AcceptLanguage->new(strict => 1);
708
45
531
        my $accepts = $i18n->accepts($l, $self->{_supported});
709
45
1766
        $self->_debug("accepts = $accepts");
710
711
45
1244
        if($accepts) {
712
45
70
                $self->_debug("accepts: $accepts");
713
714
45
1160
                if($accepts =~ /\-/) {
715
45
52
                        delete $self->{_slanguage};
716                } else {
717                        # Cache look-up for the base-language name
718
0
0
                        my $from_cache;
719
0
0
                        if($self->{_cache}) {
720
0
0
                                $from_cache = $self->{_cache}->get($CACHE_NS . "accepts:$accepts");
721                        }
722
0
0
                        my $slanguage;
723
0
0
                        if($from_cache) {
724
0
0
                                $self->_debug("$accepts is in cache as $from_cache");
725
0
0
                                $slanguage = (split(/=/, $from_cache))[0];
726                        } else {
727
0
0
                                $slanguage = $self->_code2language($accepts);
728                        }
729
730
0
0
                        if($slanguage) {
731
0
0
                                $self->{_slanguage} = $slanguage;
732
733                                # Normalise deprecated en-uk variety
734
0
0
                                if($variety eq 'uk') {
735
0
0
                                        $self->_warn({ warning => "Resetting country code to GB for $header" });
736
0
0
                                        $variety = 'gb';
737                                }
738
739
0
0
                                if(defined(my $c = $self->_code2countryname($variety))) {
740
0
0
                                        $self->_debug(__PACKAGE__, ': ', __LINE__, ":  setting sublanguage to $c");
741
0
0
                                        $self->{_sublanguage} = $c;
742                                }
743
0
0
                                $self->{_slanguage_code_alpha2}   = $accepts;
744
0
0
                                $self->{_sublanguage_code_alpha2}  = $variety;
745
746
0
0
                                if($self->{_sublanguage}) {
747
0
0
                                        $self->{_rlanguage} = "$self->{_slanguage} ($self->{_sublanguage})";
748
0
0
                                        $self->_debug(__PACKAGE__, ': ', __LINE__, ": _rlanguage: $self->{_rlanguage}");
749                                }
750
751
0
0
                                unless($from_cache) {
752
0
0
                                        $self->_debug("Set $variety to $slanguage=$accepts");
753                                        $self->{_cache}->set(
754                                                $CACHE_NS . "accepts:$variety",
755                                                "$slanguage=$accepts",
756                                                $CACHE_TTL_LONG
757
0
0
                                        ) if $self->{_cache};
758                                }
759
0
0
                                return 1;
760                        }
761                }
762        }
763
764        # Accepts returned something but we couldn't resolve a language name —
765        # try harder using the variety code directly
766
45
2118
        $self->{_rlanguage} = $self->_code2language($alpha2);
767
45
357754
        $self->_debug("_rlanguage: $self->{_rlanguage}");
768
769
45
1386
        return 0 unless $accepts;
770
771
45
67
        $self->_debug("http_accept_language = $header");
772
45
1167
        $l =~ /(..)-(..)/;
773
45
80
        $variety = lc($2);
774
775        # Skip numeric/region codes like en-029
776
45
138
        if(($variety =~ /[a-z]{2,3}/) && !defined($self->{_sublanguage})) {
777
45
103
                $self->_get_closest($alpha2, $alpha2);
778
45
78
                $self->_debug("Find the country code for $variety");
779
780
45
1160
                if($variety eq 'uk') {
781
0
0
                        $self->_warn({ warning => "Resetting country code to GB for $header" });
782
0
0
                        $variety = 'gb';
783                }
784
785
45
39
                my ($from_cache, $language_name);
786
45
58
                if($self->{_cache}) {
787
8
14
                        $from_cache = $self->{_cache}->get($CACHE_NS . "variety:$variety");
788                }
789
790
45
440
                if(defined($from_cache)) {
791
4
8
                        $self->_debug("$variety is in cache as $from_cache");
792                        # Cache stores "countryname=langcode" (e.g. "United Kingdom=en").
793                        # Splitting on = gives the country name as the first field.
794
4
84
                        ($language_name) = split(/=/, $from_cache);
795                } else {
796
41
147
                        my $db = Locale::Object::DB->new();
797
41
41
74094
80
                        my @results = @{$db->lookup(
798                                table         => 'country',
799                                result_column => 'name',
800                                search_column => 'code_alpha2',
801                                value         => $variety
802                        )};
803
41
5051
                        if(defined($results[0])) {
804
40
40
35
70
                                eval { $language_name = $self->_code2countryname($variety) };
805                        } else {
806
1
2
                                $self->_debug("Can't find the country code for $variety in Locale::Object::DB");
807                        }
808                }
809
810
45
299
                if($@ || !defined($language_name)) {
811
1
2
                        $self->_warn({ warning => $@ }) if $@;
812
1
3
                        $self->_debug(__PACKAGE__, ': ', __LINE__, ': setting sublanguage to Unknown');
813
1
28
                        $self->{_sublanguage} = 'Unknown';
814
1
3
                        $self->_warn({ warning => "Can't determine values for $header" });
815                } else {
816
44
56
                        $self->{_sublanguage} = $language_name;
817
44
72
                        $self->_debug('variety name ', $self->{_sublanguage});
818
44
1299
                        if($self->{_cache} && !defined($from_cache)) {
819                                # Store "countryname=langcode" so future cache hits return the country
820                                # name in the first field.  Previously this stored the language name
821                                # ("English=en" for en-gb) which was wrong — the cache-hit branch
822                                # split on = and used the first field as the sublanguage (country) name.
823
4
8
                                $self->_debug("Set variety:$variety to $language_name=$self->{_slanguage_code_alpha2}");
824                                $self->{_cache}->set(
825
4
86
                                        $CACHE_NS . "variety:$variety",
826                                        "$language_name=$self->{_slanguage_code_alpha2}",
827                                        $CACHE_TTL_LONG
828                                );
829                        }
830                }
831        }
832
833
45
497
        if(defined($self->{_sublanguage})) {
834
45
68
                $self->{_rlanguage} = "$self->{_slanguage} ($self->{_sublanguage})";
835
45
49
                $self->{_sublanguage_code_alpha2} = $variety;
836
45
140
                return 1;
837        }
838
0
0
        return 0;
839}
840
841# ── _find_language_from_ip ────────────────────────────────────────────────
842# Purpose:      Fall back to the visitor's IP country when the Accept-Language
843#               header produced no usable match.  Looks up the official language
844#               of the country and checks it against the supported list.
845# Entry:        $http_accept_language — may be undef if no header was present.
846# Exit:         Mutates _slanguage, _rlanguage via _get_closest if a match found.
847# Side Effects: Calls country(); may write to cache.
848sub _find_language_from_ip
849{
850
46
55
        my ($self, $http_accept_language) = @_;
851
852
46
72
        my $country = $self->country();
853
854        # If country() returned nothing, try to derive from the LANG env var
855
46
88
        if(!defined($country) && (my $c = $self->_what_language())) {
856
25
78
                if($c =~ /^(..)_(..)/) {
857
2
4
                        $country = $2;
858                } elsif($c =~ /^(..)$/) {
859
14
19
                        $country = $1;
860                }
861        }
862
46
69
        return unless defined $country;
863
864
20
37
        $self->_debug("country: $country");
865
866
20
641
        my ($language_name, $language_code2, $from_cache);
867
20
28
        if($self->{_cache}) {
868
2
4
                $from_cache = $self->{_cache}->get($CACHE_NS . 'language_name:' . $country);
869        }
870
871
20
137
        if($from_cache) {
872
1
3
                $self->_debug("$country is in cache as $from_cache");
873
1
33
                ($language_name, $language_code2) = split(/=/, $from_cache);
874        } else {
875
19
48
                my $l = $self->_code2country(uc($country));
876
19
37
                if($l) {
877
12
28
                        $l = ($l->languages_official)[0];
878
12
5758
                        if(defined $l) {
879
12
21
                                $language_name  = $l->name;
880
12
47
                                $language_code2 = $l->code_alpha2;
881
12
62
                                $self->_debug("Official language: $language_name") if $language_name;
882                        }
883                }
884        }
885
886
20
465
        my $ip = $ENV{'REMOTE_ADDR'};
887
20
41
        return unless $language_name;
888
889
13
41
        if((!defined($self->{_rlanguage})) || ($self->{_rlanguage} eq 'Unknown')) {
890
6
7
                $self->{_rlanguage} = $language_name;
891        }
892
893
13
46
        unless((exists $self->{_slanguage}) && ($self->{_slanguage} ne 'Unknown')) {
894
13
11
                my $code;
895
896
13
46
                if($language_name && $language_code2 && !defined($http_accept_language)) {
897                        # Fast-path for search engines that hit with no Accept-Language
898
4
5
                        $self->_debug("Fast assign to $language_code2");
899
4
136
                        $code = $language_code2;
900                } else {
901
9
23
                        $self->_debug("Call language2code on $self->{_rlanguage}");
902
9
286
                        $code = Locale::Language::language2code($self->{_rlanguage});
903
904
9
92523
                        unless($code) {
905
0
0
                                if($http_accept_language && ($http_accept_language ne $self->{_rlanguage})) {
906
0
0
                                        $self->_debug("Call language2code on $http_accept_language");
907
0
0
                                        $code = Locale::Language::language2code($http_accept_language);
908                                }
909
0
0
                                unless($code) {
910                                        # Norwegian (Nynorsk) — strip the parenthetical qualifier
911
0
0
                                        if($self->{_rlanguage} =~ /(.+)\s\(.+/) {
912
0
0
                                                if((!defined($http_accept_language)) || ($1 ne $self->{_rlanguage})) {
913
0
0
                                                        $self->_debug("Call language2code on $1");
914
0
0
                                                        $code = Locale::Language::language2code($1);
915                                                }
916                                        }
917
0
0
                                        unless($code) {
918
0
0
                                                $self->_warn({
919                                                        warning => "Can't determine code from IP $ip for requested language $self->{_rlanguage}"
920                                                });
921                                        }
922                                }
923                        }
924                }
925
926
13
19
                if($code) {
927
13
30
                        $self->_get_closest($code, $language_code2);
928
13
18
                        unless($self->{_slanguage}) {
929
0
0
                                $self->_warn({
930                                        warning => "Couldn't determine closest language for $language_name in $self->{_supported}"
931                                });
932                        } else {
933
13
26
                                $self->_debug("language set to $self->{_slanguage}, code set to $code");
934                        }
935                }
936        }
937
938
13
494
        if(!defined($self->{_slanguage_code_alpha2})) {
939
8
10
                $self->_debug("Can't determine slanguage_code_alpha2");
940        } elsif(!defined($from_cache) && $self->{_cache} && defined($self->{_slanguage_code_alpha2})) {
941
1
3
                $self->_debug("Set $country to $language_name=$self->{_slanguage_code_alpha2}");
942                $self->{_cache}->set(
943
1
30
                        $CACHE_NS . 'language_name:' . $country,
944                        "$language_name=$self->{_slanguage_code_alpha2}",
945                        $CACHE_TTL_LONG
946                );
947        }
948}
949
950# ── _get_closest ─────────────────────────────────────────────────────────
951# Purpose:      If $language_string matches the base language of any supported
952#               entry, set _slanguage and _slanguage_code_alpha2.
953# Entry:        $language_string — base code e.g. 'en'; $alpha2 — same or variant.
954# Exit:         Mutates _slanguage and _slanguage_code_alpha2 on match.
955sub _get_closest
956{
957
63
112
        my ($self, $language_string, $alpha2) = @_;
958
959        # Map each supported entry to its base language code
960        my %base_languages =
961
63
152
63
52
296
72
                map { /^(.+)-/ ? ($1 => $_) : ($_ => $_) } @{$self->{_supported}};
962
963
63
99
        if(exists $base_languages{$language_string}) {
964
53
80
                $self->{_slanguage}             = $self->{_rlanguage};
965
53
81
                $self->{_slanguage_code_alpha2} = $alpha2;
966        }
967}
968
969# ── _what_language ────────────────────────────────────────────────────────
970# Purpose:      Return the raw (validated, untainted) Accept-Language string,
971#               consulting in priority order: cached value, CGI lang= param,
972#               HTTP_ACCEPT_LANGUAGE env var, LANG env var (local/debug mode).
973# Entry:        May be called as a class method (no $self->{...} access) or
974#               as an object method.
975# Exit:         A validated language string, or undef if nothing available.
976# Side Effects: Caches result in $self->{_what_language} on object calls.
977sub _what_language {
978
286
2842
        my $self = $_[0];
979
980
286
319
        if(ref($self)) {
981
217
218
                $self->_trace('Entered _what_language');
982
217
6503
                if($self->{_what_language}) {
983
27
42
                        $self->_trace('_what_language: returning cached value: ', $self->{_what_language});
984
27
840
                        return $self->{_what_language};
985                }
986
190
240
                if(my $info = $self->{_info}) {
987
2
4
                        if(my $rc = $info->lang()) {
988
2
8
                                $self->_trace("_what_language set language to $rc from the lang argument");
989
2
60
                                return $self->{_what_language} = $rc;
990                        }
991                }
992        }
993
994
257
362
        if(my $raw_lang = $ENV{'HTTP_ACCEPT_LANGUAGE'}) {
995                # Validate and untaint — RFC 7231 §5.3.5 character set plus * wildcard
996
214
526
                if($raw_lang =~ /^([A-Za-z0-9\-,;=.*\s]{1,$ACCEPT_LANG_MAX})$/a) {
997
190
1203
                        my $rc = $1;    # untainted
998
190
205
                        if(ref($self)) {
999
142
280
                                return $self->{_what_language} = $rc;
1000                        }
1001
48
88
                        return $rc;
1002                } elsif(ref($self)) {
1003
24
122
                        $self->_warn({ warning => 'HTTP_ACCEPT_LANGUAGE contains invalid characters; ignoring' });
1004                }
1005        }
1006
1007
67
619
        if(defined($ENV{'LANG'})) {
1008                # Running locally (debug mode) — derive from system locale.
1009                # Apply the same untainting discipline as HTTP_ACCEPT_LANGUAGE: only
1010                # alphanumeric, hyphen, underscore, and dot are legitimate in a POSIX
1011                # locale name (e.g. "en_US.UTF-8", "de_DE", "ja").  Anything else is
1012                # either malformed or an injection attempt; discard it silently.
1013
9
24
                if($ENV{'LANG'} =~ /^([A-Za-z0-9_.\-]{1,$ACCEPT_LANG_MAX})$/a) {
1014
5
127
                        my $rc = $1;    # untainted
1015
5
8
                        if(ref($self)) {
1016
5
13
                                return $self->{_what_language} = $rc;
1017                        }
1018
0
0
                        return $rc;
1019                } elsif(ref($self)) {
1020
4
56
                        $self->_warn({ warning => 'LANG contains invalid characters; ignoring' });
1021                }
1022        }
1023
62
708
        return;
1024}
1025
1026 - 1051
=head2 country

Returns the two-character country code of the remote end in lowercase.

If L<IP::Country>, L<Geo::IPfree> or L<Geo::IP> is installed,
CGI::Lingua will make use of that, otherwise, it will do a Whois lookup.
If you do not have any of those installed I recommend you use the
caching capability of CGI::Lingua.

=head3 API SPECIFICATION

    Input:  none beyond $self
    Returns: Str (2 lowercase chars) | undef
      'Unknown' is only returned in the Baidu-EU special case via _handle_eu_country.

=head3 MESSAGES

    "GEOIP_COUNTRY_CODE contains an invalid country code; ignoring"
    "HTTP_CF_IPCOUNTRY contains an invalid country code; ignoring"
    "X.X.X.X isn't a valid IP address"
    "Can't determine country from LAN connection X"
    "Can't determine country from loopback connection X"
    "cache contains a numeric country: N"
    "IP matches to a numeric country"

=cut
1052
1053sub country {
1054
144
2672
        my $self = shift;
1055
1056
144
206
        $self->_trace(__PACKAGE__, ': Entered country()');
1057
1058        # Return cached result immediately (but see FIXME below about undef caching)
1059
144
5444
        if($self->{_country}) {
1060
7
13
                $self->_trace('quick return: ', $self->{_country});
1061
7
224
                return $self->{_country};
1062        }
1063
1064        # mod_geoip: validate against ISO 3166-1 alpha-2 before trusting
1065
137
177
        if(defined($ENV{'GEOIP_COUNTRY_CODE'})) {
1066
16
39
                if($ENV{'GEOIP_COUNTRY_CODE'} =~ /^([A-Z]{2})$/a) {
1067
9
18
                        $self->{_country} = lc($1);
1068
9
16
                        return $self->{_country};
1069                } else {
1070
7
12
                        $self->_warn({ warning => 'GEOIP_COUNTRY_CODE contains an invalid country code; ignoring' });
1071                }
1072        }
1073
1074        # Cloudflare: 'XX' means Cloudflare couldn't determine country — skip it
1075
128
436
        if(($ENV{'HTTP_CF_IPCOUNTRY'}) && ($ENV{'HTTP_CF_IPCOUNTRY'} ne 'XX')) {
1076
8
24
                if($ENV{'HTTP_CF_IPCOUNTRY'} =~ /^([A-Z]{2})$/a) {
1077
5
11
                        $self->{_country} = lc($1);
1078
5
15
                        return $self->{_country};
1079                } else {
1080
3
8
                        $self->_warn({ warning => 'HTTP_CF_IPCOUNTRY contains an invalid country code; ignoring' });
1081                }
1082        }
1083
1084
123
119
        my $raw_ip = $ENV{'REMOTE_ADDR'};
1085
123
170
        return unless defined $raw_ip;
1086
1087        # Validate and untaint the IP address before passing to any geo module
1088
89
48
        my $ip;
1089
89
259
        if($raw_ip =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/a) {
1090
79
79
                $ip = $1;    # untainted IPv4
1091        } elsif($raw_ip =~ /^([0-9a-fA-F:]{2,39}|[0-9a-fA-F:]{2,30}:(?:\d{1,3}\.){3}\d{1,3})$/a) {
1092
3
5
                $ip = $1;    # untainted IPv6, including mixed notation (e.g. ::ffff:192.0.2.1)
1093        } else {
1094
7
17
                $self->_warn({ warning => "$raw_ip isn't a valid IP address" });
1095
7
258
                return;
1096        }
1097
1098
82
1557
        require Data::Validate::IP;
1099
82
88600
        Data::Validate::IP->import();
1100
1101
82
121
        if(!is_ipv4($ip)) {
1102
4
35
                $self->_debug("$ip isn't IPv4. Is it IPv6?");
1103
4
159
                if($ip eq '::1') {
1104
3
6
                        $ip = '127.0.0.1';    # normalise loopback
1105                } elsif($ip =~ /^::ffff:(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/i) {
1106
0
0
                        $ip = $1;             # normalise IPv4-mapped IPv6 (::ffff:a.b.c.d) to plain IPv4
1107                } elsif(!is_ipv6($ip)) {
1108
1
10
                        $self->_warn({ warning => "$ip isn't a valid IP address" });
1109
1
2
                        return;
1110                }
1111        }
1112
81
1591
        if(is_private_ip($ip)) {
1113
2
71
                $self->_debug("Can't determine country from LAN connection $ip");
1114
2
67
                return;
1115        }
1116
79
4821
        if(is_loopback_ip($ip)) {
1117
40
1285
                $self->_debug("Can't determine country from loopback connection $ip");
1118
40
1422
                return;
1119        }
1120
1121        # Cache look-up — skip for LAN/loopback (already returned above)
1122
39
1873
        if($self->{_cache}) {
1123
13
26
                $self->{_country} = $self->{_cache}->get($CACHE_NS . "country:$ip");
1124
13
612
                if(defined($self->{_country})) {
1125
5
7
                        if($self->{_country} !~ /\D/) {
1126
4
11
                                $self->_warn({ warning => 'cache contains a numeric country: ' . $self->{_country} });
1127
4
129
                                $self->{_cache}->remove($CACHE_NS . "country:$ip");
1128
4
151
                                delete $self->{_country};
1129                        } else {
1130
1
2
                                $self->_debug("Get $ip from cache = $self->{_country}");
1131
1
32
                                return $self->{_country};
1132                        }
1133                }
1134
12
22
                $self->_debug("$ip isn't in the cache");
1135        }
1136
1137        # Try IP::Country first (fastest, local database)
1138
38
454
        if($self->{_have_ipcountry} == $GEO_UNKNOWN) {
1139
1
1
3
42
                if(eval { require IP::Country }) {
1140
0
0
                        IP::Country->import();
1141
0
0
                        $self->{_have_ipcountry} = $GEO_PRESENT;
1142
0
0
                        $self->{_ipcountry}      = IP::Country::Fast->new();
1143                } else {
1144
1
162
                        $self->{_have_ipcountry} = $GEO_ABSENT;
1145                }
1146        }
1147
38
140
        $self->_debug("have_ipcountry $self->{_have_ipcountry}");
1148
1149
38
1213
        if($self->{_have_ipcountry}) {
1150
25
45
                $self->{_country} = $self->{_ipcountry}->inet_atocc($ip);
1151
25
48
                if($self->{_country}) {
1152
23
49
                        $self->{_country} = lc($self->{_country});
1153                } elsif(is_ipv4($ip)) {
1154
2
15
                        $self->_debug("$ip is not known by IP::Country");
1155                }
1156        }
1157
1158        # Try Geo::IP if IP::Country gave nothing
1159
38
103
        unless(defined($self->{_country})) {
1160
14
17
                if($self->{_have_geoip} == $GEO_UNKNOWN) {
1161
1
3
                        $self->_load_geoip();
1162                }
1163
14
40
                if($self->{_have_geoip} == $GEO_PRESENT) {
1164
1
4
                        $self->{_country} = $self->{_geoip}->country_code_by_addr($ip);
1165                }
1166
1167                # Geo::IPfree has a known-broken entry for $BROKEN_GEOIPFREE
1168
14
56
                if(!defined($self->{_country}) && ($ip ne $BROKEN_GEOIPFREE)) {
1169
13
39
                        if($self->{_have_geoipfree} == $GEO_UNKNOWN) {
1170
0
0
0
0
                                eval { require Geo::IPfree };
1171
0
0
                                unless($@) {
1172
0
0
                                        Geo::IPfree::IP->import();
1173
0
0
                                        $self->{_have_geoipfree} = $GEO_PRESENT;
1174
0
0
                                        $self->{_geoipfree}      = Geo::IPfree->new();
1175                                } else {
1176
0
0
                                        $self->{_have_geoipfree} = $GEO_ABSENT;
1177                                }
1178                        }
1179
13
32
                        if($self->{_have_geoipfree} == $GEO_PRESENT) {
1180
1
5
                                if(my $country = ($self->{_geoipfree}->LookUp($ip))[0]) {
1181
1
4
                                        $self->{_country} = lc($country);
1182                                }
1183                        }
1184                }
1185        }
1186
1187        # 'eu' is not a real country — discard
1188
38
97
        if($self->{_country} && ($self->{_country} eq 'eu')) {
1189
2
3
                delete $self->{_country};
1190        }
1191
1192        # Remote JSON lookup via geoplugin
1193
38
57
        if((!$self->{_country}) &&
1194
15
0
736
0
           (eval { require LWP::Simple::WithCache; require JSON::Parse })) {
1195
0
0
                $self->_debug("Look up $ip on geoplugin");
1196
0
0
                LWP::Simple::WithCache->import();
1197
0
0
                JSON::Parse->import();
1198
1199
0
0
                if(my $data = LWP::Simple::WithCache::get("http://www.geoplugin.net/json.gp?ip=$ip")) {
1200
0
0
0
0
                        eval { $self->{_country} = JSON::Parse::parse_json($data)->{'geoplugin_countryCode'} };
1201
0
0
                        $self->_warn({ warning => "geoplugin returned unparseable JSON: $@" }) if $@;
1202                }
1203        }
1204
1205        # Last resort: Whois
1206
38
147
        unless($self->{_country}) {
1207
15
28
                $self->_resolve_country_via_whois($ip);
1208        }
1209
1210        # Sanitise and normalise whatever we found
1211
38
53
        if($self->{_country}) {
1212
25
48
                if($self->{_country} !~ /\D/) {
1213
2
6
                        $self->_warn({ warning => 'IP matches to a numeric country' });
1214
2
135
                        delete $self->{_country};
1215                } else {
1216
23
28
                        $self->{_country} = lc($self->{_country});
1217
1218                        # Legacy mappings
1219
23
37
                        if($self->{_country} eq 'hk') {
1220
3
4
                                $self->{_country} = 'cn';    # HK is no longer a separate country in Whois
1221                        } elsif($self->{_country} eq 'eu') {
1222
2
4
                                $self->_handle_eu_country($ip);
1223                        }
1224
1225
23
93
                        if($self->{_country} && ($self->{_country} !~ /\D/)) {
1226
0
0
                                $self->_warn({ warning => "cache contains a numeric country: $self->{_country}" });
1227
0
0
                                delete $self->{_country};
1228                        } elsif($self->{_country} && $self->{_cache}) {
1229
7
13
                                $self->_debug("Set $ip to $self->{_country}");
1230                                $self->{_cache}->set(
1231                                        $CACHE_NS . "country:$ip",
1232                                        $self->{_country},
1233
7
207
                                        $CACHE_TTL_SHORT
1234                                );
1235                        }
1236                }
1237        }
1238
1239
38
1071
        return $self->{_country};
1240}
1241
1242# ── _resolve_country_via_whois ─────────────────────────────────────────────
1243# Purpose:      Attempt Net::Whois::IP then Net::Whois::IANA as a last resort.
1244# Entry:        $ip — validated, untainted IP string.
1245# Exit:         Sets $self->{_country} if a result was found.
1246# Side Effects: Network I/O; logs debug messages.
1247sub _resolve_country_via_whois
1248{
1249
12
148
        my ($self, $ip) = @_;
1250
1251
12
51
        $self->_debug("Look up $ip on Whois");
1252
1253
12
563
        require Net::Whois::IP;
1254
12
201
        Net::Whois::IP->import();
1255
1256
12
6
        my $whois;
1257
12
16
        eval {
1258                # Catch connection timeouts by converting Carp::carp into a die
1259
12
1
50
25
                local $SIG{__WARN__} = sub { die $_[0] };
1260
12
16
                $whois = Net::Whois::IP::whoisip_query($ip);
1261        };
1262
1263
12
59
        unless($@ || !defined($whois) || (ref($whois) ne 'HASH')) {
1264
9
10
                if(defined($whois->{Country})) {
1265
8
19
                        $self->{_country} = $whois->{Country};
1266                } elsif(defined($whois->{country})) {
1267
1
3
                        $self->{_country} = $whois->{country};
1268                }
1269
9
9
                if($self->{_country}) {
1270
9
23
                        if($self->{_country} eq 'EU') {
1271
2
3
                                delete $self->{_country};
1272                        } elsif(($self->{_country} eq 'US') && defined($whois->{'StateProv'}) && ($whois->{'StateProv'} eq 'PR')) {
1273                                # RT#131347: Puerto Rico is not the US
1274
1
1
                                $self->{_country} = 'pr';
1275                        }
1276                }
1277        }
1278
1279
12
23
        if($self->{_country}) {
1280
7
13
                $self->_debug("Found $ip on Net::Whois::IP as ", $self->{_country});
1281                # Strip carriage returns (e.g. 190.24.1.122) and trailing comments
1282
7
224
                $self->{_country} =~ s/[\r\n]//g;
1283
7
13
                if($self->{_country} =~ /^(..)\s*#/) {
1284
2
3
                        $self->{_country} = $1;
1285                }
1286
7
10
                return;
1287        }
1288
1289
5
9
        $self->_debug("Look up $ip on IANA");
1290
1291
5
161
        require Net::Whois::IANA;
1292
5
187
        Net::Whois::IANA->import();
1293
1294
5
8
        my $iana = Net::Whois::IANA->new();
1295
5
5
9
7
        eval { $iana->whois_query(-ip => $ip) };
1296
5
12
        unless($@) {
1297
5
7
                $self->{_country} = $iana->country();
1298
5
13
                $self->_debug("IANA reports $ip as ", $self->{_country});
1299        }
1300
1301
5
156
        if($self->{_country}) {
1302
4
6
                $self->{_country} =~ s/[\r\n]//g;
1303
4
10
                if($self->{_country} =~ /^(..)\s*#/) {
1304
2
3
                        $self->{_country} = $1;
1305                }
1306        }
1307}
1308
1309# ── _handle_eu_country ────────────────────────────────────────────────────
1310# Purpose:      Resolve the ambiguous 'eu' country code.  RT-86809 shows that
1311#               Baidu reports itself as EU when it is actually in CN.  All
1312#               other 'eu' addresses are logged as Unknown.
1313# Entry:        $ip — validated, untainted IP string.
1314# Exit:         Sets $self->{_country} to 'cn' or 'Unknown'.
1315# Side Effects: Loads Net::Subnet; writes info log entry.
1316sub _handle_eu_country
1317{
1318
4
23
        my ($self, $ip) = @_;
1319
1320
4
485
        require Net::Subnet;
1321
4
2024
        Net::Subnet->import();
1322
1323
4
8
        if(subnet_matcher($BAIDU_SUBNET)->($ip)) {
1324
2
73
                $self->{_country} = 'cn';
1325        } else {
1326
2
45
                $self->_info("$ip has country of eu");
1327
2
85
                $self->{_country} = 'Unknown';
1328        }
1329}
1330
1331# ── _load_geoip ───────────────────────────────────────────────────────────
1332# Purpose:      Probe for the Geo::IP database file and the Geo::IP module;
1333#               set _have_geoip and initialise _geoip on success.
1334# Entry:        _have_geoip must be GEO_UNKNOWN.
1335# Exit:         _have_geoip set to GEO_PRESENT or GEO_ABSENT.
1336# Side Effects: Requires Geo::IP; opens GeoIP.dat.
1337sub _load_geoip
1338{
1339
3
23
        my $self = shift;
1340
1341        # Check for the database file before even trying to load the module
1342        # (avoids noisy errors on Windows — CPANTESTERS report 54117bd0)
1343
3
52
        my $db_present = (
1344                (($^O eq 'MSWin32') && (-r 'c:/GeoIP/GeoIP.dat'))
1345                || (-r '/usr/local/share/GeoIP/GeoIP.dat')
1346                || (-r '/usr/share/GeoIP/GeoIP.dat')
1347        );
1348
1349
3
6
        unless($db_present) {
1350
3
4
                $self->{_have_geoip} = $GEO_ABSENT;
1351
3
9
                return;
1352        }
1353
1354
0
0
0
0
        eval { require Geo::IP };
1355
0
0
        if($@) {
1356
0
0
                $self->{_have_geoip} = $GEO_ABSENT;
1357
0
0
                return;
1358        }
1359
1360
0
0
        Geo::IP->import();
1361
0
0
        $self->{_have_geoip} = $GEO_PRESENT;
1362
1363        # GEOIP_STANDARD = 0 (can't use the constant name directly)
1364
0
0
        if(-r '/usr/share/GeoIP/GeoIP.dat') {
1365
0
0
                $self->{_geoip} = Geo::IP->open('/usr/share/GeoIP/GeoIP.dat', 0);
1366        } else {
1367
0
0
                $self->{_geoip} = Geo::IP->new(0);
1368        }
1369}
1370
1371 - 1386
=head2 locale

HTTP doesn't have a way of transmitting a browser's localisation information
which would be useful for default currency, date formatting, etc.

This method attempts to detect the information, but it is a best guess
and is not 100% reliable.  But it's better than nothing ;-)

Returns a L<Locale::Object::Country> object.

=head3 API SPECIFICATION

    Input:  none beyond $self
    Returns: Locale::Object::Country | undef

=cut
1387
1388sub locale {
1389
19
550
        my $self = shift;
1390
1391
19
36
        return $self->{_locale} if $self->{_locale};
1392
1393
17
17
        my $agent = $ENV{'HTTP_USER_AGENT'};
1394
1395        # First try: parse the language tag from the User-Agent parenthetical
1396
17
46
        if(defined($agent) && ($agent =~ /\((.+)\)/)) {
1397
6
16
                foreach(split(/;/, $1)) {
1398
15
11
                        my $candidate = $_;
1399
15
34
                        $candidate =~ s/^\s+|\s+$//g;    # trim both ends
1400
1401
15
23
                        if($candidate =~ /^[a-zA-Z]{2}-([a-zA-Z]{2})$/) {
1402
2
5
                                local $SIG{__WARN__} = undef;
1403
2
4
                                if(my $c = $self->_code2country($1)) {
1404
2
3
                                        $self->{_locale} = $c;
1405
2
6
                                        return $c;
1406                                }
1407                        }
1408                }
1409
1410                # Second try: HTTP::BrowserDetect (works for more User-Agents)
1411
4
4
4
440
                if(eval { require HTTP::BrowserDetect }) {
1412
4
7998
                        HTTP::BrowserDetect->import();
1413
4
11
                        my $browser = HTTP::BrowserDetect->new($agent);
1414
4
432
                        if($browser && $browser->country() && (my $c = $self->_code2country($browser->country()))) {
1415
1
2
                                $self->{_locale} = $c;
1416
1
7
                                return $c;
1417                        }
1418                }
1419        }
1420
1421        # Third try: IP address
1422
14
115
        my $country = $self->country();
1423
14
22
        if($country) {
1424
8
13
                $country =~ s/[\r\n]//g;
1425
8
6
                my $c;
1426
8
8
                eval {
1427
8
0
24
0
                        local $SIG{__WARN__} = sub { die $_[0] };
1428
8
16
                        $c = $self->_code2country($country);
1429                };
1430
8
16
                unless($@) {
1431
8
12
                        if($c) {
1432
8
8
                                $self->{_locale} = $c;
1433
8
14
                                return $c;
1434                        }
1435                }
1436        }
1437
1438        # Fourth try: mod_geoip env var — apply the same ISO 3166-1 validation
1439        # used in country() to guard against spoofed or malformed values
1440
6
10
        if(defined($ENV{'GEOIP_COUNTRY_CODE'})) {
1441
2
4
                if($ENV{'GEOIP_COUNTRY_CODE'} =~ /^([A-Z]{2})$/a) {
1442
0
0
                        if(my $c = $self->_code2country(lc($1))) {
1443
0
0
                                $self->{_locale} = $c;
1444
0
0
                                return $c;
1445                        }
1446                }
1447        }
1448
6
7
        return undef;
1449}
1450
1451 - 1469
=head2 time_zone

Returns the timezone of the web client.

If L<Geo::IP> is installed,
CGI::Lingua will make use of that, otherwise it will use L<ip-api.com>

=head3 API SPECIFICATION

    Input:  none beyond $self
    Returns: Str (IANA timezone name) | undef

=head3 MESSAGES

    "Couldn't determine the timezone"
    "LWP::Simple::WithCache and LWP::Simple are both absent; cannot contact ip-api.com"
      Returns undef rather than croaking; install either LWP variant to enable ip-api lookups.

=cut
1470
1471sub time_zone {
1472
12
739
        my $self = shift;
1473
1474
12
21
        $self->_trace('Entered time_zone');
1475
1476
11
469
        if($self->{_timezone}) {
1477
3
7
                $self->_trace('quick return: ', $self->{_timezone});
1478
3
91
                return $self->{_timezone};
1479        }
1480
1481
8
11
        my $raw_ip = $ENV{'REMOTE_ADDR'};
1482
1483
8
9
        if(defined $raw_ip) {
1484                # Untaint before any external use — kept in sync with country()'s pattern,
1485                # including the mixed-notation branch for ::ffff:a.b.c.d addresses.
1486
6
6
                my $ip;
1487
6
22
                if($raw_ip =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/a) {
1488
4
5
                        $ip = $1;
1489                } elsif($raw_ip =~ /^([0-9a-fA-F:]{2,39}|[0-9a-fA-F:]{2,30}:(?:\d{1,3}\.){3}\d{1,3})$/a) {
1490
0
0
                        $ip = $1;
1491                } else {
1492
2
6
                        $self->_warn({ warning => "$raw_ip isn't a valid IP address" });
1493
2
6
                        return;
1494                }
1495
1496
4
6
                if($self->{_have_geoip} == $GEO_UNKNOWN) {
1497
1
6
                        $self->_load_geoip();
1498                }
1499
4
10
                if($self->{_have_geoip} == $GEO_PRESENT) {
1500
1
1
3
1
                        eval { $self->{_timezone} = $self->{_geoip}->time_zone($ip) };
1501                }
1502
1503
4
11
                unless($self->{_timezone}) {
1504
3
3
0
2
169
0
                        if(eval { require LWP::Simple::WithCache; require JSON::Parse }) {
1505
0
0
                                $self->_debug("Look up $ip on ip-api.com");
1506
0
0
                                LWP::Simple::WithCache->import();
1507
0
0
                                JSON::Parse->import();
1508
1509
0
0
                                if(my $data = LWP::Simple::WithCache::get("http://ip-api.com/json/$ip")) {
1510
0
0
0
0
                                        eval { $self->{_timezone} = JSON::Parse::parse_json($data)->{'timezone'} };
1511
0
0
                                        $self->_warn({ warning => "ip-api.com returned unparseable JSON: $@" }) if $@;
1512                                }
1513
3
0
132
0
                        } elsif(eval { require LWP::Simple; require JSON::Parse }) {
1514
0
0
                                $self->_debug("Look up $ip on ip-api.com");
1515
0
0
                                LWP::Simple->import();
1516
0
0
                                JSON::Parse->import();
1517
1518
0
0
                                if(my $data = LWP::Simple::get("http://ip-api.com/json/$ip")) {
1519
0
0
0
0
                                        eval { $self->{_timezone} = JSON::Parse::parse_json($data)->{'timezone'} };
1520
0
0
                                        $self->_warn({ warning => "ip-api.com returned unparseable JSON: $@" }) if $@;
1521                                }
1522                        } else {
1523                                # Neither LWP variant is available — degrade gracefully rather than
1524                                # killing the entire request with a croak; caller can check for undef.
1525
3
6
                                $self->_warn({ warning => 'LWP::Simple::WithCache and LWP::Simple are both absent; cannot contact ip-api.com' });
1526                        }
1527                }
1528        } else {
1529                # Local connection — read from /etc/timezone or DateTime::TimeZone
1530
2
52
                if(CORE::open(my $fin, '<', '/etc/timezone')) {
1531
2
473
                        my $tz = <$fin>;
1532
2
3
                        chomp $tz;
1533
2
16
                        $self->{_timezone} = $tz;
1534                } else {
1535
0
0
                        $self->{_timezone} = DateTime::TimeZone::Local->TimeZone()->name();
1536                }
1537        }
1538
1539
6
440
        unless(defined($self->{_timezone})) {
1540
3
5
                $self->_warn({ warning => "Couldn't determine the timezone" });
1541        }
1542
6
208
        return $self->{_timezone};
1543}
1544
1545 - 1556
=head2 is_rtl

Returns true (1) if the negotiated language is written right-to-left, false (0)
otherwise.  Covers Arabic, Hebrew, Persian, Urdu, Yiddish, Dhivehi, Pashto,
Sindhi, Uyghur, and Kurdish.

=head3 API SPECIFICATION

    Input:  none beyond $self
    Returns: 1 | 0

=cut
1557
1558sub is_rtl
1559{
1560
6
46
        my $self = shift;
1561
6
8
        return $RTL_LANGS{$self->language_code_alpha2() // ''} ? 1 : 0;
1562}
1563
1564 - 1574
=head2 text_direction

Returns C<'rtl'> or C<'ltr'> for the negotiated language, suitable for direct
use as an HTML C<dir> attribute value.

=head3 API SPECIFICATION

    Input:  none beyond $self
    Returns: 'rtl' | 'ltr'

=cut
1575
1576sub text_direction
1577{
1578
2
17
        my $self = shift;
1579
2
3
        return $self->is_rtl() ? 'rtl' : 'ltr';
1580}
1581
1582 - 1600
=head2 plural_category

Returns the CLDR plural category for the integer C<$n> in the negotiated
language.  The returned string is one of C<'zero'>, C<'one'>, C<'two'>,
C<'few'>, C<'many'>, or C<'other'>.

Rules are embedded for ~70 languages including Arabic (6 forms), Slavic
languages (3-4 forms), Celtic languages (up to 6 forms), and Hebrew, Maltese,
Romanian, Latvian, Lithuanian, and Slovenian.  Languages not in the table fall
back to the English rule (n == 1 => C<'one'>, else C<'other'>).

For fractional numbers or full CLDR v42+ accuracy, use C<Locale::CLDR>.

=head3 API SPECIFICATION

    Input:  $n - non-negative integer (fractional values are truncated)
    Returns: Str - one of zero/one/two/few/many/other

=cut
1601
1602# CLDR plural category rules (https://unicode.org/cldr/charts/42/supplemental/language_plural_rules.html).
1603# Values are coderefs: ($n) → category string.  Languages absent from this
1604# table fall back to the standard one/other rule inside plural_category().
1605my %PLURAL_RULES = (
1606
1607        # ── No plural distinction (always 'other') ────────────────────────────
1608        (map { $_ => sub { 'other' } }
1609                qw(az bm bo dz id ig ii in ja jbo jv jw kde kea km ko lkt lo ms
1610                   my nqo root sah ses sg th to vi wo yo zh)),
1611
1612        # ── Standard: n == 1 → 'one', else 'other' ───────────────────────────
1613        (map { $_ => sub { int($_[0]) == 1 ? 'one' : 'other' } }
1614                qw(af an ast bg bn brx ca cgg da de el en eo es et eu fi
1615                   gl gsw gu ha haw hu ia it kcg kk kl lb lg mas ml mn mr
1616                   nb nd ne nl nn nyn om or pa pap rm rof rwk saq seh sn so
1617                   sq ss ssy st sv sw ta te teo tig tk tl tn ts ur wae xh xog)),
1618
1619        # ── French / Portuguese-BR: n ≤ 1 → 'one' ────────────────────────────
1620        (map { $_ => sub { int($_[0]) <= 1 ? 'one' : 'other' } } qw(fr pt_BR)),
1621
1622        # ── Arabic: zero/one/two/few/many/other ───────────────────────────────
1623        ar => sub {
1624                my $n    = int($_[0]);
1625                my $m100 = $n % 100;
1626                return 'zero'  if $n == 0;
1627                return 'one'   if $n == 1;
1628                return 'two'   if $n == 2;
1629                return 'few'   if $m100 >= 3  && $m100 <= 10;
1630                return 'many'  if $m100 >= 11 && $m100 <= 99;
1631                return 'other';
1632        },
1633
1634        # ── Hebrew: one/two/many/other ────────────────────────────────────────
1635        he => sub {
1636                my $n = int($_[0]);
1637                return 'one'  if $n == 1;
1638                return 'two'  if $n == 2;
1639                return 'many' if $n != 0 && $n % 10 == 0;
1640                return 'other';
1641        },
1642
1643        # ── Russian / Ukrainian / Belarusian: one/few/many ────────────────────
1644        (map { $_ => sub {
1645                my $n    = int($_[0]);
1646                my $m10  = $n % 10;
1647                my $m100 = $n % 100;
1648                return 'one' if $m10 == 1 && $m100 != 11;
1649                return 'few' if $m10 >= 2 && $m10 <= 4 && ($m100 < 10 || $m100 >= 20);
1650                return 'many';
1651        } } qw(ru uk be)),
1652
1653        # ── Polish: one/few/many ──────────────────────────────────────────────
1654        pl => sub {
1655                my $n    = int($_[0]);
1656                my $m10  = $n % 10;
1657                my $m100 = $n % 100;
1658                return 'one' if $n == 1;
1659                return 'few' if $m10 >= 2 && $m10 <= 4 && ($m100 < 10 || $m100 >= 20);
1660                return 'many';
1661        },
1662
1663        # ── Czech / Slovak: one/few/other ────────────────────────────────────
1664        (map { $_ => sub {
1665                my $n = int($_[0]);
1666                return 'one' if $n == 1;
1667                return 'few' if $n >= 2 && $n <= 4;
1668                return 'other';
1669        } } qw(cs sk)),
1670
1671        # ── Romanian: one/few/other ───────────────────────────────────────────
1672        ro => sub {
1673                my $n    = int($_[0]);
1674                my $m100 = $n % 100;
1675                return 'one' if $n == 1;
1676                return 'few' if $n == 0 || ($m100 >= 1 && $m100 <= 19);
1677                return 'other';
1678        },
1679
1680        # ── Latvian: zero/one/other ───────────────────────────────────────────
1681        lv => sub {
1682                my $n    = int($_[0]);
1683                my $m10  = $n % 10;
1684                my $m100 = $n % 100;
1685                return 'zero'  if $m10 == 0 || ($m100 >= 11 && $m100 <= 19);
1686                return 'one'   if $m10 == 1 && $m100 != 11;
1687                return 'other';
1688        },
1689
1690        # ── Lithuanian: one/few/other ─────────────────────────────────────────
1691        lt => sub {
1692                my $n    = int($_[0]);
1693                my $m10  = $n % 10;
1694                my $m100 = $n % 100;
1695                return 'one' if $m10 == 1 && ($m100 < 10 || $m100 >= 20);
1696                return 'few' if $m10 >= 2 && ($m100 < 10 || $m100 >= 20);
1697                return 'other';
1698        },
1699
1700        # ── Slovenian: one/two/few/other ──────────────────────────────────────
1701        sl => sub {
1702                my $m100 = int($_[0]) % 100;
1703                return 'one'   if $m100 == 1;
1704                return 'two'   if $m100 == 2;
1705                return 'few'   if $m100 == 3 || $m100 == 4;
1706                return 'other';
1707        },
1708
1709        # ── Welsh: zero/one/two/few/many/other ───────────────────────────────
1710        cy => sub {
1711                my $n = int($_[0]);
1712                return 'zero'  if $n == 0;
1713                return 'one'   if $n == 1;
1714                return 'two'   if $n == 2;
1715                return 'few'   if $n == 3;
1716                return 'many'  if $n == 6;
1717                return 'other';
1718        },
1719
1720        # ── Irish: one/two/few/many/other ────────────────────────────────────
1721        ga => sub {
1722                my $n = int($_[0]);
1723                return 'one'  if $n == 1;
1724                return 'two'  if $n == 2;
1725                return 'few'  if $n >= 3 && $n <= 6;
1726                return 'many' if $n >= 7 && $n <= 10;
1727                return 'other';
1728        },
1729
1730        # ── Maltese: one/two/few/many/other ──────────────────────────────────
1731        mt => sub {
1732                my $n    = int($_[0]);
1733                my $m100 = $n % 100;
1734                return 'one'  if $n == 1;
1735                return 'two'  if $n == 2;
1736                return 'few'  if $n == 0 || ($m100 >= 3  && $m100 <= 10);
1737                return 'many' if $m100 >= 11 && $m100 <= 19;
1738                return 'other';
1739        },
1740);
1741
1742sub plural_category
1743{
1744
16
69
        my ($self, $n) = @_;
1745
16
13
        my $code = $self->language_code_alpha2() // return 'other';
1746
15
0
19
0
        my $rule = $PLURAL_RULES{$code} // sub { int($_[0]) == 1 ? 'one' : 'other' };
1747
15
13
        return $rule->($n);
1748}
1749
1750 - 1778
=head2 translation_file

Returns the filesystem path to the best matching translation file for the
negotiated language in the given directory.

The lookup tries (in order):

=over 4

=item 1. C<$dir/$lang-$sublang.$ext>  (e.g. C<en-gb.json>)

=item 2. C<$dir/$lang.$ext>           (e.g. C<en.json>)

=back

Returns C<undef> if no matching file exists.

=head3 API SPECIFICATION

    Input:
      $dir - Str   path to the directory containing translation files
      $ext - Str   file extension without leading dot (default: 'json')
    Returns: Str (absolute or relative path) | undef

=head3 MESSAGES

    (none - returns undef silently when no file is found)

=cut
1779
1780sub translation_file
1781{
1782
5
42
        my ($self, $dir, $ext) = @_;
1783
5
7
        return unless defined $dir;
1784
4
16
        $ext //= 'json';
1785
4
5
        $ext =~ s/^\.//;    # accept '.json' or 'json'
1786
1787
4
3
        my @candidates;
1788
4
5
        if(my $sub = $self->sublanguage_code_alpha2()) {
1789
0
0
                push @candidates, $self->language_code_alpha2() . '-' . $sub;
1790        }
1791
4
5
        push @candidates, $self->language_code_alpha2()
1792                if defined $self->language_code_alpha2();
1793
1794
4
5
        for my $code (@candidates) {
1795
4
4
                my $path = "$dir/$code.$ext";
1796
4
41
                return $path if -e $path;
1797        }
1798
1
2
        return;
1799}
1800
1801# ── _code2language ────────────────────────────────────────────────────────
1802# Purpose:      Translate a 2-char language code to its English name, with
1803#               optional CHI caching.
1804# Entry:        $code — 2-char ISO 639-1 code; must be defined and non-empty.
1805# Exit:         Human-readable language name string, or undef.
1806# Side Effects: Reads/writes cache.
1807sub _code2language
1808{
1809
147
736
        my ($self, $code) = @_;
1810
1811
147
158
        return unless $code;
1812
145
156
        if(defined($self->{_country})) {
1813
3
7
                $self->_debug("_code2language $code, country ", $self->{_country});
1814        } else {
1815
142
161
                $self->_debug("_code2language $code");
1816        }
1817
1818
145
4159
        unless($self->{_cache}) {
1819
123
217
                return Locale::Language::code2language($code);
1820        }
1821
1822
22
46
        if(my $from_cache = $self->{_cache}->get($CACHE_NS . "code2language:$code")) {
1823
7
592
                $self->_trace("_code2language found in cache $from_cache");
1824
7
132
                return $from_cache;
1825        }
1826
1827        # Compute, cache, then return the value separately —
1828        # CHI->set() is not guaranteed to return the stored value across all drivers
1829
15
642
        $self->_trace('_code2language not in cache, storing');
1830
15
441
        my $name = Locale::Language::code2language($code);
1831
15
355839
        if(defined $name) {
1832
14
44
                $self->{_cache}->set($CACHE_NS . "code2language:$code", $name, $CACHE_TTL_LONG);
1833        }
1834
15
2346
        return $name;
1835}
1836
1837# ── _code2country ─────────────────────────────────────────────────────────
1838# Purpose:      Translate a 2-char country code to a Locale::Object::Country
1839#               object, suppressing the expected "No result found" warning.
1840# Entry:        $code — 2-char ISO 3166-1 alpha-2 code (any case).
1841# Exit:         Locale::Object::Country object, or undef.
1842# Side Effects: None beyond the Locale::Object::Country look-up.
1843sub _code2country
1844{
1845
90
633
        my ($self, $code) = @_;
1846
1847
90
106
        return unless $code;
1848
88
108
        if($self->{_country}) {
1849
13
20
                $self->_trace(">_code2country $code, country ", $self->{_country});
1850        } else {
1851
75
100
                $self->_trace(">_code2country $code");
1852        }
1853
1854
88
2522
        my $rc;
1855        {
1856                # Scope the signal handler tightly — only suppress the one known-harmless warning
1857
88
66
                local $SIG{__WARN__} = sub {
1858
14
78344
                        warn $_[0] unless $_[0] =~ /No result found in country table/;
1859
88
241
                };
1860
88
313
                $rc = Locale::Object::Country->new(code_alpha2 => $code);
1861        }
1862
88
2501931
        $self->_trace('<_code2country ', $code || 'undef');
1863
88
3279
        return $rc;
1864}
1865
1866# ── _code2countryname ─────────────────────────────────────────────────────
1867# Purpose:      Translate a 2-char country code to its English name string,
1868#               with optional CHI caching.
1869# Entry:        $code — 2-char ISO 3166-1 alpha-2 code.
1870# Exit:         Country name string, or undef.
1871# Side Effects: Reads/writes cache.
1872sub _code2countryname
1873{
1874
51
335
        my ($self, $code) = @_;
1875
1876
51
82
        return unless $code;
1877
49
83
        $self->_trace(">_code2countryname $code");
1878
1879
49
1634
        unless($self->{_cache}) {
1880
42
60
                my $country = $self->_code2country($code);
1881
42
92
                return defined($country) ? $country->name : undef;
1882        }
1883
1884
7
16
        if(my $from_cache = $self->{_cache}->get($CACHE_NS . "code2countryname:$code")) {
1885
1
74
                $self->_trace("_code2countryname found in cache $from_cache");
1886
1
32
                return $from_cache;
1887        }
1888
1889
6
253
        if(my $country = $self->_code2country($code)) {
1890
5
11
                $self->_debug('_code2countryname not in cache, storing');
1891
5
120
                my $name = $country->name();
1892
5
41
                $self->_trace('<_code2countryname ', $name);
1893                # Store then return explicitly — don't rely on set() return value
1894
5
119
                $self->{_cache}->set($CACHE_NS . "code2countryname:$code", $name, $CACHE_TTL_LONG);
1895
5
764
                return $name;
1896        }
1897
1
2
        $self->_trace('<_code2countryname undef');
1898
1
30
        return undef;
1899}
1900
1901# ── _log ──────────────────────────────────────────────────────────────────
1902# Purpose:      Append a message to $self->{messages} and forward to the
1903#               optional logger object.
1904# Entry:        $level — log level string (debug/info/notice/warn/trace/error);
1905#               @messages — one or more strings to concatenate.
1906# Exit:         void
1907# Side Effects: Mutates $self->{messages}; calls logger method if set.
1908sub _log
1909{
1910
2183
2895
        my ($self, $level, @messages) = @_;
1911
1912
2183
2759
        return unless ref($self) && scalar(@messages);
1913
1914
2181
2584
        my $text = join('', grep defined, @messages);
1915
2181
1518
        return unless length($text);
1916
2180
2180
1124
2535
        push @{$self->{'messages'}}, { level => $level, message => $text };
1917
1918
2180
2000
        if(my $logger = $self->{'logger'}) {
1919
2178
2224
                $logger->$level($text);
1920        }
1921}
1922
1923
1121
1121
688
907
sub _debug  { my $self = shift; $self->_log('debug',  @_) }
1924
4
4
1031
9
sub _info   { my $self = shift; $self->_log('info',   @_) }
1925
4
4
869
8
sub _notice { my $self = shift; $self->_log('notice', @_) }
1926
1045
1045
1560
1042
sub _trace  { my $self = shift; $self->_log('trace',  @_) }
1927
1928# ── _warn ─────────────────────────────────────────────────────────────────
1929# Purpose:      Emit a warning through the logger (if set) or via Carp::carp.
1930# Entry:        A single hashref argument: { warning => 'message text' }.
1931#               All callers MUST use this structured form — plain-string calls
1932#               silently lose the message when no logger is configured.
1933# Exit:         void
1934# Side Effects: Calls logger->warn() or Carp::carp().
1935sub _warn
1936{
1937
20
128
        my $self = shift;
1938
20
29
        if(defined($self->{'logger'})) {
1939                # Logger gets the warning text as a plain string, not a data structure
1940
18
24
                my $params = Params::Get::get_params('warning', @_);
1941
18
323
                $self->{'logger'}->warn($params->{'warning'} // join('', grep defined, @_));
1942        } else {
1943
2
5
                my $params = Params::Get::get_params('warning', @_);
1944
2
34
                my $msg    = $params->{'warning'} // join('', grep defined, @_);
1945
2
4
                $self->_log('warn', $msg);
1946
2
2
                Carp::carp($msg);
1947        }
1948}
1949
1950 - 2124
=head1 LIMITATIONS

=over 4

=item * B<is_rtl() covers primary-script RTL languages only>

C<is_rtl()> returns true for the 10 ISO 639-1 codes whose overwhelmingly
dominant script is right-to-left.  Languages with script variants (e.g.
Azerbaijani C<az>, which uses Latin in modern Azerbaijan but Arabic in Iran)
are treated as LTR.  If you serve content in multiple scripts of the same
language, inspect the sublanguage or Accept-Language header directly.

=item * B<plural_category() uses embedded CLDR rules, not Locale::CLDR>

The embedded rules cover ~70 languages and truncate fractional C<$n> to an
integer.  For full CLDR v42 accuracy (including fractional forms and
languages not in the table) install and use C<Locale::CLDR> directly.

=item * B<Logger must be a blessed object>

The C<logger> parameter is documented as accepting a code ref, array ref, or
filename, but the current implementation calls C<< $logger->$level() >> and will
die on non-blessed values.  Wrap alternative logger types in a
C<Log::Abstraction> instance before passing them to C<new()>.

=item * B<es-419 sublanguage returns undef>

Three-part regional codes such as C<es-419> (Latin American Spanish) do not
resolve to a C<sublanguage()> value because ISO 3166-1 does not define '419'.
This is a known limitation of the Locale::Object layer.

=item * B<Whois lookups are slow and unreliable>

Without C<IP::Country>, C<Geo::IP>, or C<Geo::IPfree> installed, C<country()>
falls back to Whois queries against live RIPE/ARIN/IANA servers.  These can
time out under load.  Install at least one local geo-database module and enable
the CHI cache to avoid this.

=item * B<Sub::Private not yet enforced>

The C<_*> private methods are currently accessible from outside the package.
C<Sub::Private> should be added to enforce encapsulation once white-box tests
are updated to call only the public API.

=item * B<IPv4-mapped IPv6 addresses are normalised to IPv4>

C<REMOTE_ADDR> values in the form C<::ffff:a.b.c.d> (RFC 4291 section 2.5.5)
are silently rewritten to the embedded C<a.b.c.d> IPv4 address before any
geo-lookup.  This is correct for country detection purposes but means the raw
address string is not preserved in cache keys or log messages.

=item * B<EU country code is irresolvable (with one exception)>

IP addresses that Whois reports as country C<EU> are mapped to C<'Unknown'>
unless they fall within Baidu's known subnet (RT-86809).  There is no ISO
3166-1 country code for the European Union.

=back

=head1 AUTHOR

Nigel Horne, C<< <njh at nigelhorne.com> >>

=head1 BUGS

Please report any bugs or feature requests to the author.

If C<HTTP_ACCEPT_LANGUAGE> contains a sub-tag with a 3-digit UN M.49 region
code (e.g. C<es-419> for Latin American Spanish), C<sublanguage()> returns
C<undef> because ISO 3166-1 does not define numeric codes.

Please report any bugs or feature requests to C<bug-cgi-lingua at rt.cpan.org>,
or through the web interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CGI-Lingua>.
I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.

Uses L<I18N::AcceptLanguage> to find the highest priority accepted language.
This means that if you support languages at a lower priority, it may be missed.

=head1 SEE ALSO

=over 4

=item * L<Test Dashboard|https://nigelhorne.github.io/CGI-Lingua/coverage/>

=item * VWF - Versatile Web Framework L<https://github.com/nigelhorne/vwf>

=item * L<HTTP::BrowserDetect>

=item * L<I18N::AcceptLanguage>

=item * L<Locale::Country>

=back

=head1 SUPPORT

This module is provided as-is without any warranty.

You can find documentation for this module with the perldoc command.

    perldoc CGI::Lingua

You can also look for information at:

=over 4

=item * MetaCPAN

L<https://metacpan.org/release/CGI-Lingua>

=item * RT: CPAN's request tracker

L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=CGI-Lingua>

=item * CPANTS

L<http://cpants.cpanauthors.org/dist/CGI-Lingua>

=item * CPAN Testers' Matrix

L<http://matrix.cpantesters.org/?dist=CGI-Lingua>

=item * CPAN Testers Dependencies

L<http://deps.cpantesters.org/?module=CGI::Lingua>

=back

=encoding utf-8

=head1 FORMAL SPECIFICATION

=head2 new

    new : Class × Params → CGI::Lingua
    âˆ€ p : Params • p.supported ≠ ∅ ⟹ result.language ∈ (p.supported ∪ {'Unknown'})

=head2 language

    language : CGI::Lingua → Str
    result ∈ {name(l) | l ∈ supported} ∪ {'Unknown'}

=head2 is_rtl

    is_rtl : CGI::Lingua → Bool
    is_rtl(s) ≙ language_code_alpha2(s) ∈ RTL_LANGS

=head2 text_direction

    text_direction : CGI::Lingua → {'rtl', 'ltr'}
    text_direction(s) ≙ is_rtl(s) ? 'rtl' : 'ltr'

=head2 plural_category

    plural_category : CGI::Lingua × â„• → PluralCategory
    plural_category(s, n) ≙ PLURAL_RULES[language_code_alpha2(s)](n)

=head2 translation_file

    translation_file : CGI::Lingua × Path × Ext → Path | undef
    translation_file(s, d, e) ≙
      first p ∈ candidates(s) • ∃ file d/p.e
      where candidates(s) = [lang(s)-sublang(s), lang(s)] \ {undef}

=head1 ACKNOWLEDGEMENTS

=head1 LICENSE AND COPYRIGHT

Copyright 2010-2026 Nigel Horne.

This program is released under the following licence: GPL2

=cut
2125
21261; # End of CGI::Lingua