File Coverage

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

linestmtbrancondsubtimecode
1package CGI::Lingua;
2
3
19
19
19
1128789
13
412
use warnings;
4
19
19
19
27
15
203
use strict;
5
6
19
19
19
3419
985282
310
use Object::Configure 0.14;
7
19
19
19
57
92
288
use Params::Get 0.13;
8
19
19
19
32
11
420
use Storable; # RT117983
9
19
19
19
4110
58340
49
use Class::Autouse qw{Carp Locale::Language Locale::Object::Country Locale::Object::DB I18N::AcceptLanguage I18N::LangTags::Detect};
10
11our $VERSION = '0.80';
12
13 - 21
=head1 NAME

CGI::Lingua - Create a multilingual web page

=head1 VERSION

Version 0.80

=cut
22
23 - 161
=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.

Takes one mandatory parameter, C<supported>, (aka C<supported_languages>)
a list of languages, in RFC-1766 format,
that the website supports.
It can either be a simple string,
if only one language is supported,
or a reference to a list of languages.

Language codes are of the form primary-code [ - country-code ] e.g.
'en', 'en-gb' for English and British English respectively.

For a list of primary codes refer to ISO-639 (e.g. 'en' for English).
For a list of country codes refer to ISO-3166 (e.g. 'gb' for United Kingdom).

    # Sample web page
    use CGI::Lingua;
    use CHI;
    use Log::Abstraction;

    my $cache = CHI->new(driver => 'File', root_dir => '/tmp/cache');

    # We support English, French, British and American English, in that order
    my $lingua = CGI::Lingua->new(
        supported => ['en', 'fr', 'en-gb', 'en-us'],
        cache     => $cache,
        logger    => Log::Abstraction->new()
    );

    print "Content-Type: text/plain\n\n";
    print 'Language: ', $lingua->language(), "\n";
    print 'Country: ', $lingua->country(), "\n";
    print 'Time Zone: ', $lingua->time_zone(), "\n";

Supported_languages is the same as supported.

It takes several optional parameters:

=over 4

=item * C<cache>

An object which is used to cache country lookups.
This cache object is an object that understands get() and set() messages,
such as a L<CHI> object.

=item * C<config_file>

Points to a configuration file which contains the parameters to C<new()>.
The file can be in any common format,
including C<YAML>, C<XML>, and C<INI>.
This allows the parameters to be set at run time.

=item * C<logger>

Used for warnings and traces.
It can be an object that understands warn() and trace() messages,
such as a L<Log::Abstraction>, L<Log::Log4perl> or L<Log::Any> object,
a reference to code,
a reference to an array,
or a filename.
See L<Log::Abstraction> for further details.

=item * C<info>

Takes an optional parameter info, an object which can be used to see if a CGI
parameter is set, for example, an L<CGI::Info> object.

=item * C<data>

Passed on to L<I18N::AcceptLanguage>.

=item * C<dont_use_ip>

By default, if none of the
requested languages is supported, CGI::Lingua->language() looks in the IP
address for the language to use.
This may not be what you want,
so use this option to disable the feature.

=item * C<syslog>

Takes an optional parameter syslog, to log messages to
L<Sys::Syslog>.
It can be a boolean to enable/disable logging to syslog, or a reference
to a hash to be given to Sys::Syslog::setlogsock.

=back

Since emitting warnings from a CGI class can result in messages being lost (you
may forget to look in your server's log), or appear to the client in
amongst HTML causing invalid HTML, it is recommended either syslog
or logger (or both) are set.
If neither is given, L<Carp> will be used.

=cut
162
163sub new
164{
165
41
2070145
        my $class = shift;
166
41
112
        my $params = Params::Get::get_params('supported', @_);
167
168
39
944
        if(!defined($class)) {
169
0
0
                if($params) {
170                        # Using CGI::Lingua:new(), not CGI::Lingua->new()
171
0
0
                        if(my $logger = $params->{'logger'}) {
172
0
0
                                $logger->error(__PACKAGE__, ' use ->new() not ::new() to instantiate');
173                        }
174
0
0
                        Carp::croak(__PACKAGE__, ' use ->new() not ::new() to instantiate');
175                }
176
177                # FIXME: this only works when no arguments are given
178
0
0
                $class = __PACKAGE__;
179        } elsif(ref($class)) {
180                # clone the given object
181
0
0
                $params->{_supported} ||= $params->{supported} if(defined($params->{'supported'}));
182
0
0
0
0
0
0
                return bless { %{$class}, %{$params} }, ref($class);
183        }
184
185
39
96
        $params = Object::Configure::configure($class, $params);
186
187        # Validate logger object has required methods
188
39
336677
        if(defined $params->{'logger'}) {
189
39
184
                unless(Scalar::Util::blessed($params->{'logger'}) && $params->{'logger'}->can('warn') && $params->{'logger'}->can('info') && $params->{'logger'}->can('error')) {
190
0
0
                        Carp::croak("Logger must be an object with info() and error() methods");
191                }
192        }
193
194        # TODO: check that the number of supported languages is > 0
195        # unless($params->{supported} && ($#params->{supported} > 0)) {
196                # croak('You must give a list of supported languages');
197        # }
198
39
1514
        $params->{'supported'} ||= $params->{'supported_languages'};
199
39
60
        unless($params->{supported}) {
200
2
3
                if(my $logger = $params->{'logger'}) {
201
2
4
                        $logger->error('You must give a list of supported languages');
202                }
203
2
526
                Carp::croak('You must give a list of supported languages');
204        }
205
206
38
318
        my $cache = $params->{cache};
207
38
39
        my $info = $params->{info};
208
209
38
52
        if($cache && $ENV{'REMOTE_ADDR'}) {
210
6
3
                my $key = "$ENV{REMOTE_ADDR}/";
211
6
6
                my $l;
212
6
16
                if($info && ($l = $info->lang())) {
213
0
0
                        $key .= "$l/";
214                } elsif($l = $class->_what_language()) {
215
6
7
                        $key .= "$l/";
216                }
217
6
8
                if(ref($params->{'supported'} eq 'ARRAY')) {
218
0
0
0
0
                        $key .= join('/', @{$params->{supported}});
219                } else {
220
6
6
                        $key .= $params->{'supported'};
221                }
222                # if($logger) {
223                        # $self->debug("Looking in cache for $key");
224                # }
225
6
13
                if(my $rc = $cache->get($key)) {
226                        # if($logger) {
227                                # $logger->debug('Found - thawing');
228                        # }
229
0
0
                        $rc = Storable::thaw($rc);
230
0
0
                        $rc->{logger} = $params->{'logger'};
231
0
0
                        $rc->{_syslog} = $params->{syslog};
232
0
0
                        $rc->{_cache} = $cache;
233
0
0
                        $rc->{_supported} = $params->{supported};
234
0
0
                        $rc->{_info} = $info;
235
0
0
                        $rc->{_have_ipcountry} = -1;
236
0
0
                        $rc->{_have_geoip} = -1;
237
0
0
                        $rc->{_have_geoipfree} = -1;
238
239
0
0
                        if(($rc->{_what_language} || $rc->{_rlanguage}) && $info && $info->lang()) {
240
0
0
                                delete $rc->{_what_language};
241
0
0
                                delete $rc->{_rlanguage};
242
0
0
                                delete $rc->{_country};
243                        }
244
0
0
                        return $rc;
245                }
246        }
247
248        return bless {
249
38
373
                %{$params},
250                _supported => ref($params->{supported}) ? $params->{supported} : [ $params->{'supported'} ], # List of languages (two letters) that the application
251                _cache => $cache,    # CHI
252                _info => $info,
253                # _rlanguage => undef,       # Requested language
254                # _slanguage => undef,       # Language that the website should display
255                # _sublanguage => undef,     # E.g. United States for en-US if you want American English
256                # _slanguage_code_alpha2 => undef, # E.g en, fr
257                # _sublanguage_code_alpha2 => undef, # E.g. us, gb
258                # _country => undef, # Two letters, e.g. gb
259                # _locale => undef,  # Locale::Object::Country
260                _syslog => $params->{syslog},
261                _dont_use_ip => $params->{dont_use_ip} || 0,
262                _have_ipcountry => -1,       # -1 = don't know
263                _have_geoip => -1,   # -1 = don't know
264                _have_geoipfree => -1,       # -1 = don't know
265
38
319
                _debug => $params->{debug} || 0,
266        }, $class;
267}
268
269# Some of the information takes a long time to work out, so cache what we can
270sub DESTROY {
271
44
20434
        if(defined($^V) && ($^V ge 'v5.14.0')) {
272
44
92
                return if ${^GLOBAL_PHASE} eq 'DESTRUCT';       # >= 5.14.0 only
273        }
274
44
100
        unless($ENV{'REMOTE_ADDR'}) {
275
17
123
                return;
276        }
277
27
24
        my $self = shift;
278
27
34
        return unless(ref($self));
279
280
27
26
        my $cache = $self->{_cache};
281
27
98
        return unless($cache);
282
283
6
6
        my $key = "$ENV{REMOTE_ADDR}/";
284
6
6
        if(my $l = $self->_what_language()) {
285
6
4
                $key .= "$l/";
286        }
287
6
6
4
8
        $key .= join('/', @{$self->{_supported}});
288
6
11
        return if($cache->get($key));
289
290
6
236
        $self->_debug("Storing self in cache as $key");
291
292        my $copy = bless {
293                _slanguage => $self->{_slanguage},
294                _slanguage_code_alpha2 => $self->{_slanguage_code_alpha2},
295                _sublanguage_code_alpha2 => $self->{_sublanguage_code_alpha2},
296                _country => $self->{_country},
297                _rlanguage => $self->{_rlanguage},
298                _dont_use_ip => $self->{_dont_use_ip},
299                _have_ipcountry => $self->{_have_ipcountry},
300                _have_geoip => $self->{_have_geoip},
301                _have_geoipfree => $self->{_have_geoipfree},
302
6
75
        }, ref($self);
303
304        # All of these crash, presumably something recursive is going on
305        # my $copy = Clone::clone($self);
306        # my $storable = Storable::nfreeze(Storable::dclone($self));
307        # my $storable = Storable::dclone($self);
308
309
6
10
        $cache->set($key, Storable::nfreeze($copy), '1 month');
310}
311
312
313 - 338
=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'.

    use CGI::Lingua;
    # Site supports English and British English
    my $l = CGI::Lingua->new(supported => ['en', 'fr', 'en-gb']);

If the browser requests 'en-us', then language will be 'English' and
sublanguage will also be undefined, which may seem strange, but it
ensures that sites behave sensibly.

    # Site supports British English only
    my $l = CGI::Lingua->new({ supported => ['fr', 'en-gb']} );

If the script is not being run in a CGI environment, perhaps to debug it, the
locale is used via the LANG environment variable.

=cut
339
340sub language {
341
22
3063
        my $self = $_[0];
342
343
22
41
        unless($self->{_slanguage}) {
344
15
22
                $self->_find_language();
345        }
346
22
64
        return $self->{_slanguage};
347}
348
349 - 353
=head2 preferred_language

Same as language().

=cut
354
355sub preferred_language
356{
357
1
1
        my $self = shift;
358
359
1
2
        $self->language(@_);
360}
361
362 - 366
=head2 name

Synonym for language, for compatibility with Local::Object::Language

=cut
367
368sub name {
369
1
2
        my $self = $_[0];
370
371
1
2
        return $self->language();
372}
373
374 - 382
=head2 sublanguage

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

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

=cut
383
384sub sublanguage {
385
21
26
        my $self = $_[0];
386
387
21
35
        $self->_trace('Entered sublanguage');
388
21
416
        unless($self->{_slanguage}) {
389
1
2
                $self->_find_language();
390        }
391
21
64
        $self->_trace('Leaving sublanguage ', ($self->{_sublanguage} || 'undef'));
392
21
344
        return $self->{_sublanguage};
393}
394
395 - 403
=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.

=cut
404
405sub language_code_alpha2 {
406
8
9
        my $self = $_[0];
407
408
8
22
        $self->_trace('Entered language_code_alpha2');
409
8
199
        unless($self->{_slanguage}) {
410
1
2
                $self->_find_language();
411        }
412
8
17
        $self->_trace('language_code_alpha2 returns ', $self->{_slanguage_code_alpha2});
413
8
185
        return $self->{_slanguage_code_alpha2};
414}
415
416 - 420
=head2 code_alpha2

Synonym for language_code_alpha2, kept for historical reasons.

=cut
421
422sub code_alpha2 {
423
8
532
        my $self = $_[0];
424
425
8
16
        return $self->language_code_alpha2();
426}
427
428 - 433
=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.

=cut
434
435sub sublanguage_code_alpha2 {
436
2
775
        my $self = $_[0];
437
438
2
2
        unless($self->{_slanguage}) {
439
1
2
                $self->_find_language();
440        }
441
2
7
        return $self->{_sublanguage_code_alpha2};
442}
443
444
445 - 453
=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)"

=cut
454
455sub requested_language {
456
44
7420
        my $self = $_[0];
457
458
44
70
        unless($self->{_rlanguage}) {
459
9
13
                $self->_find_language();
460        }
461
44
110
        return $self->{_rlanguage};
462}
463
464# The language cache is stored as country_2_letter -> $language_human_readable_name=$language_2_letter
465# The IP cache is stored as ip -> country_human_readable_name
466
467# Returns the human-readable language, such as 'English'
468
469sub _find_language
470{
471
27
26
        my $self = shift;
472
473
27
43
        $self->_trace('Entered _find_language');
474
475        # Initialize defaults
476
27
566
        $self->{_rlanguage} = 'Unknown';
477
27
36
        $self->{_slanguage} = 'Unknown';
478
479        # Use what the client has said
480
27
42
        my $http_accept_language = $self->_what_language();
481
27
34
        if(defined($http_accept_language)) {
482
27
27
38
70
                $self->_debug("language wanted: $http_accept_language, languages supported: ", join(', ', @{$self->{_supported}}));
483
484
27
393
                if($http_accept_language eq 'en-uk') {
485
0
0
                        $self->_debug("Resetting country code to GB for $http_accept_language");
486
0
0
                        $http_accept_language = 'en-gb';
487                }
488                # Workaround for RT 74338
489                local $SIG{__WARN__} = sub {
490
0
0
                        if($_[0] !~ /^Use of uninitialized value/) {
491
0
0
                                warn $_[0];
492                        }
493
27
86
                };
494
27
107
                my $i18n = I18N::AcceptLanguage->new(debug => $self->{_debug}, strict => 1);
495
27
6202
                my $l = $i18n->accepts($http_accept_language, $self->{_supported});
496
27
2226
                local $SIG{__WARN__} = 'DEFAULT';
497
27
247
                if($l && ($http_accept_language =~ /-/) && ($http_accept_language !~ qr/$l/i)) {
498                        # I18N-AcceptLanguage strict mode doesn't work as I'd expect it to,
499                        # if you support 'en' and 'en-gb' and request 'en-US,en;q=0.8',
500                        # it actually returns 'en-gb'
501
3
4
                        $self->_debug('Forcing fallback');
502
3
41
                        undef $l;
503                }
504
505
27
28
                my $requested_sublanguage;
506
27
32
                if(!$l) {
507                        # FIXME: This scans the HTTP_ACCEPTED_LANGUAGE left to right, it ignores the priority value
508
8
17
                        $self->_debug(__PACKAGE__, ': ', __LINE__, ": look through $http_accept_language for alternatives");
509
8
127
                        while($http_accept_language =~ /(..)\-(..)/g) {
510
7
44
                                $requested_sublanguage = $2;
511                                # Fall back position, e,g. we want US English on a site
512                                # only giving British English, so allow it as English.
513                                # The calling program can detect that it's not the
514                                # wanted flavour of English by looking at
515                                # requested_language
516
7
20
                                $self->_debug(__PACKAGE__, ': ', __LINE__, ": see if $1 is supported");
517
7
91
                                if($i18n->accepts($1, $self->{_supported})) {
518
4
187
                                        $l = $1;
519
4
8
                                        $self->_debug("Fallback to $l as sublanguage $requested_sublanguage is not supported");
520
4
58
                                        last;
521                                }
522                        }
523                }
524
27
110
                if(!$l) {
525                        # FIXME: This scans the HTTP_ACCEPTED_LANGUAGE left to right, it ignores the priority value
526
4
8
                        $self->_debug(__PACKAGE__, ': ', __LINE__, ": look harder through $http_accept_language for alternatives");
527
4
60
                        foreach my $possible(split(/,/, $http_accept_language)) {
528
6
38
                                next if($possible =~ /..\-../); # Already checked those with sublanguages
529
4
6
                                $possible =~ s/;.*$//;
530
4
8
                                $self->_debug(__PACKAGE__, ': ', __LINE__, ": see if $possible is supported");
531
4
55
                                if($i18n->accepts($possible, $self->{_supported})) {
532
1
25
                                        $l = $possible;
533
1
2
                                        $self->_debug("Fallback to $possible as best alternative");
534
1
13
                                        undef $requested_sublanguage;
535
1
1
                                        last;
536                                }
537                        }
538                }
539
540
27
128
                if($l) {
541
24
47
                        $self->_debug("l: $l");
542
543
24
405
                        if($l !~ /^..-..$/) {
544
10
16
                                $self->{_slanguage} = $self->_code2language($l);
545
10
276212
                                if($self->{_slanguage}) {
546
10
23
                                        $self->_debug("_slanguage: $self->{_slanguage}");
547
548                                        # We have the language, but not the right
549                                        # sublanguage, e.g. they want US English but we
550                                        # only support British English or English
551                                        # wanted: en-us, got en-gb and en
552
10
164
                                        $self->{_slanguage_code_alpha2} = $l;
553
10
11
                                        $self->{_rlanguage} = $self->{_slanguage};
554
555
10
13
                                        my $sl;
556
10
58
                                        if($http_accept_language =~ /..-(..)$/) {
557
3
3
                                                $self->_debug($1);
558
3
43
                                                $sl = $self->_code2country($1);
559
3
7
                                                $requested_sublanguage = $1 if(!defined($requested_sublanguage));
560                                        } elsif($http_accept_language =~ /..-([a-z]{2,3})$/i) {
561
0
0
                                                eval {
562
0
0
                                                        $sl = Locale::Object::Country->new(code_alpha3 => $1);
563                                                };
564
0
0
                                                if($@) {
565
0
0
                                                        $self->_info($@);
566                                                }
567                                        }
568
10
17
                                        if($sl) {
569
3
6
                                                $self->{_rlanguage} .= ' (' . $sl->name() . ')';
570                                                # The requested sublanguage
571                                                # isn't supported so don't
572                                                # define that
573                                        } elsif($requested_sublanguage) {
574
2
5
                                                if(my $c = $self->_code2countryname($requested_sublanguage)) {
575
2
29
                                                        $self->{_rlanguage} .= " ($c)";
576                                                } else {
577
0
0
                                                        $self->{_rlanguage} .= " (Unknown: $requested_sublanguage)";
578                                                }
579                                        }
580
10
74
                                        return;
581                                }
582                        } elsif($l =~ /(.+)-(..)$/) {   # TODO: Handle es-419 "Spanish (Latin America)"
583
14
16
                                my $alpha2 = $1;
584
14
14
                                my $variety = $2;
585
14
26
                                my $accepts = $i18n->accepts($l, $self->{_supported});
586
14
931
                                $self->_debug("accepts = $accepts");
587
588
14
192
                                if($accepts) {
589
14
17
                                        $self->_debug("accepts: $accepts");
590
591
14
180
                                        if($accepts =~ /\-/) {
592
14
19
                                                delete $self->{_slanguage};
593                                        } else {
594
0
0
                                                my $from_cache;
595
0
0
                                                if($self->{_cache}) {
596
0
0
                                                        $from_cache = $self->{_cache}->get(__PACKAGE__ . ":accepts:$accepts");
597                                                }
598
0
0
                                                if($from_cache) {
599
0
0
                                                        $self->_debug("$accepts is in cache as $from_cache");
600
0
0
                                                        $self->{_slanguage} = (split(/=/, $from_cache))[0];
601                                                } else {
602
0
0
                                                        $self->{_slanguage} = $self->_code2language($accepts);
603                                                }
604
0
0
                                                if($self->{_slanguage}) {
605
0
0
                                                        if($variety eq 'uk') {
606                                                                # ???
607
0
0
                                                                $self->_warn({
608                                                                        warning => "Resetting country code to GB for $http_accept_language"
609                                                                });
610
0
0
                                                                $variety = 'gb';
611                                                        }
612
0
0
                                                        if(defined(my $c = $self->_code2countryname($variety))) {
613
0
0
                                                                $self->_debug(__PACKAGE__, ': ', __LINE__, ":  setting sublanguage to $c");
614
0
0
                                                                $self->{_sublanguage} = $c;
615                                                        }
616
0
0
                                                        $self->{_slanguage_code_alpha2} = $accepts;
617
0
0
                                                        if($self->{_sublanguage}) {
618
0
0
                                                                $self->{_rlanguage} = "$self->{_slanguage} ($self->{_sublanguage})";
619
0
0
                                                                $self->_debug(__PACKAGE__, ': ', __LINE__, ": _rlanguage: $self->{_rlanguage}");
620                                                        }
621
0
0
                                                        $self->{_sublanguage_code_alpha2} = $variety;
622
0
0
                                                        unless($from_cache) {
623
0
0
                                                                $self->_debug("Set $variety to $self->{_slanguage}=$self->{_slanguage_code_alpha2}");
624
0
0
                                                                $self->{_cache}->set(__PACKAGE__ . ":accepts:$variety", "$self->{_slanguage}=$self->{_slanguage_code_alpha2}", '1 month');
625                                                        }
626
0
0
                                                        return;
627                                                }
628                                        }
629                                }
630
14
24
                                $self->{_rlanguage} = $self->_code2language($alpha2);
631
14
361521
                                $self->_debug("_rlanguage: $self->{_rlanguage}");
632
633
14
248
                                if($accepts) {
634
14
22
                                        $self->_debug("http_accept_language = $http_accept_language");
635                                        # $http_accept_language =~ /(.{2})-(..)/;
636
14
181
                                        $l =~ /(..)-(..)/;
637
14
19
                                        $variety = lc($2);
638                                        # Ignore en-029 etc (Caribbean English)
639
14
47
                                        if(($variety =~ /[a-z]{2,3}/) && !defined($self->{_sublanguage})) {
640
14
24
                                                $self->_get_closest($alpha2, $alpha2);
641
14
19
                                                $self->_debug("Find the country code for $variety");
642
643
14
181
                                                if($variety eq 'uk') {
644                                                        # ???
645
0
0
                                                        $self->_warn({
646                                                                warning => "Resetting country code to GB for $http_accept_language"
647                                                        });
648
0
0
                                                        $variety = 'gb';
649                                                }
650
14
27
                                                my $from_cache;
651                                                my $language_name;
652
14
20
                                                if($self->{_cache}) {
653
4
8
                                                        $from_cache = $self->{_cache}->get(__PACKAGE__ . ":variety:$variety");
654                                                }
655
14
214
                                                if(defined($from_cache)) {
656
2
3
                                                        $self->_debug("$variety is in cache as $from_cache");
657
658
2
19
                                                        my $language_code2;
659
2
4
                                                        ($language_name, $language_code2) = split(/=/, $from_cache);
660
2
2
                                                        $language_name = $self->_code2countryname($variety);
661                                                } else {
662
12
68
                                                        my $db = Locale::Object::DB->new();
663
12
12
57915
23
                                                        my @results = @{$db->lookup(
664                                                                table => 'country',
665                                                                result_column => 'name',
666                                                                search_column => 'code_alpha2',
667                                                                value => $variety
668                                                        )};
669
12
1390
                                                        if(defined($results[0])) {
670
12
10
                                                                eval {
671
12
20
                                                                        $language_name = $self->_code2countryname($variety);
672                                                                };
673                                                        } else {
674
0
0
                                                                $self->_debug("Can't find the country code for $variety in Locale::Object::DB");
675                                                        }
676                                                }
677
14
419
                                                if($@ || !defined($language_name)) {
678
0
0
                                                        $self->_warn($@) if($@);
679
0
0
                                                        $self->_debug(__PACKAGE__, ': ', __LINE__, ': setting sublanguage to Unknown');
680
0
0
                                                        $self->{_sublanguage} = 'Unknown';
681
0
0
                                                        $self->_warn({
682                                                                warning => "Can't determine values for $http_accept_language"
683                                                        });
684                                                } else {
685
14
19
                                                        $self->{_sublanguage} = $language_name;
686
14
23
                                                        $self->_debug('variety name ', $self->{_sublanguage});
687
14
2125
                                                        if($self->{_cache} && !defined($from_cache)) {
688
2
5
                                                                $self->_debug("Set $variety to $self->{_slanguage}=$self->{_slanguage_code_alpha2}");
689
2
20
                                                                $self->{_cache}->set(__PACKAGE__ . ":variety:$variety", "$self->{_slanguage}=$self->{_slanguage_code_alpha2}", '1 month');
690                                                        }
691                                                }
692                                        }
693
14
241
                                        if(defined($self->{_sublanguage})) {
694
14
28
                                                $self->{_rlanguage} = "$self->{_slanguage} ($self->{_sublanguage})";
695
14
15
                                                $self->{_sublanguage_code_alpha2} = $variety;
696
14
79
                                                return;
697                                        }
698                                }
699                        }
700                } elsif($http_accept_language =~ /;/) {
701                        # e.g. HTTP_ACCEPT_LANGUAGE=de-DE,de;q=0.9,en-US;q=0.8,en;q=0.7
702                        # and we don't support DE at all, but we do accept en-US
703
1
1
2
3
                        $self->_notice(__PACKAGE__, ': ', __LINE__, ": couldn't honour HTTP_ACCEPT_LANGUAGE=$http_accept_language, supported languages are: ", join(',', @{$self->{supported}}));
704                }
705
3
22
                if($self->{_slanguage} && ($self->{_slanguage} ne 'Unknown')) {
706
0
0
                        if($self->{_rlanguage} eq 'Unknown') {
707
0
0
                                $self->{_rlanguage} = I18N::LangTags::Detect::detect();
708                        }
709
0
0
                        if($self->{_rlanguage}) {
710
0
0
                                if($l = $self->_code2language($self->{_rlanguage})) {
711
0
0
                                        $self->{_rlanguage} = $l;
712                                # } else {
713                                        # We have the language, but not the right
714                                        # sublanguage, e.g. they want US English but we
715                                        # only support British English
716                                        # wanted: en-us, got en-gb and not en
717                                }
718
0
0
                                return;
719                        }
720                }
721
3
11
                if(((!$self->{_rlanguage}) || ($self->{_rlanguage} eq 'Unknown')) &&
722                   ((length($http_accept_language) == 2) || ($http_accept_language =~ /^..-..$/))) {
723
1
2
                        $self->{_rlanguage} = $self->_code2language($http_accept_language);
724
725
1
40
                        unless($self->{_rlanguage}) {
726
1
1
                                $self->{_rlanguage} = 'Unknown';
727                        }
728                }
729
3
14
                $self->{_slanguage} = 'Unknown';
730        }
731
732
3
4
        if($self->{_dont_use_ip}) {
733
0
0
                return;
734        }
735
736        # The client hasn't said which to use, so guess from their IP address,
737        # or the requested language(s) isn't/aren't supported so use the IP
738        # address for an alternative
739
3
5
        my $country = $self->country();
740
741
3
5
        if((!defined($country)) && (my $c = $self->_what_language())) {
742
2
5
                if($c =~ /^(..)_(..)/) {
743
0
0
                        $country = $2;  # Best guess
744                } elsif($c =~ /^(..)$/) {
745
1
1
                        $country = $1;  # Wrong, but maybe something will drop out
746                }
747        }
748
749
3
6
        if(defined($country)) {
750
1
3
                $self->_debug("country: $country");
751                # Determine the first official language of the country
752
753
1
14
                my $from_cache;
754
1
2
                if($self->{_cache}) {
755
0
0
                        $from_cache = $self->{_cache}->get(__PACKAGE__ . ':language_name:' . $country);
756                }
757
1
1
                my $language_name;
758                my $language_code2;
759
1
1
                if($from_cache) {
760
0
0
                        $self->_debug("$country is in cache as $from_cache");
761
0
0
                        ($language_name, $language_code2) = split(/=/, $from_cache);
762                } else {
763
1
3
                        my $l = $self->_code2country(uc($country));
764
1
2
                        if($l) {
765
0
0
                                $l = ($l->languages_official)[0];
766
0
0
                                if(defined($l)) {
767
0
0
                                        $language_name = $l->name;
768
0
0
                                        $language_code2 = $l->code_alpha2;
769
0
0
                                        if($language_name) {
770
0
0
                                                $self->_debug("Official language: $language_name");
771                                        }
772                                }
773                        }
774                }
775
1
1
                my $ip = $ENV{'REMOTE_ADDR'};
776
1
2
                if($language_name) {
777
0
0
                        if((!defined($self->{_rlanguage})) || ($self->{_rlanguage} eq 'Unknown')) {
778
0
0
                                $self->{_rlanguage} = $language_name;
779                        }
780
0
0
                        unless((exists($self->{_slanguage})) && ($self->{_slanguage} ne 'Unknown')) {
781                                # Check if the language is one that we support
782                                # Don't bother with secondary language
783
0
0
                                my $code;
784
785
0
0
                                if($language_name && $language_code2 && !defined($http_accept_language)) {
786                                        # This sort of thing speeds up search engine access a lot
787
0
0
                                        $self->_debug("Fast assign to $language_code2");
788
0
0
                                        $code = $language_code2;
789                                } else {
790
0
0
                                        $self->_debug("Call language2code on $self->{_rlanguage}");
791
792
0
0
                                        $code = Locale::Language::language2code($self->{_rlanguage});
793
0
0
                                        unless($code) {
794
0
0
                                                if($http_accept_language && ($http_accept_language ne $self->{_rlanguage})) {
795
0
0
                                                        $self->_debug("Call language2code on $http_accept_language");
796
797
0
0
                                                        $code = Locale::Language::language2code($http_accept_language);
798                                                }
799
0
0
                                                unless($code) {
800                                                        # If the language is Norwegian (Nynorsk)
801                                                # lookup Norwegian
802
0
0
                                                if($self->{_rlanguage} =~ /(.+)\s\(.+/) {
803
0
0
                                                                if((!defined($http_accept_language)) || ($1 ne $self->{_rlanguage})) {
804
0
0
                                                                        $self->_debug("Call language2code on $1");
805
806
0
0
                                                                        $code = Locale::Language::language2code($1);
807                                                                }
808                                                        }
809
0
0
                                                        unless($code) {
810
0
0
                                                                $self->_warn({
811                                                                        warning => "Can't determine code from IP $ip for requested language $self->{_rlanguage}"
812                                                                });
813                                                        }
814                                                }
815                                        }
816                                }
817
0
0
                                if($code) {
818
0
0
                                        $self->_get_closest($code, $language_code2);
819
0
0
                                        unless($self->{_slanguage}) {
820
0
0
                                                $self->_warn({
821                                                        warning => "Couldn't determine closest language for $language_name in $self->{_supported}"
822                                                });
823                                        } else {
824
0
0
                                                $self->_debug("language set to $self->{_slanguage}, code set to $code");
825                                        }
826                                }
827                        }
828
0
0
                        if(!defined($self->{_slanguage_code_alpha2})) {
829
0
0
                                $self->_debug("Can't determine slanguage_code_alpha2");
830                        } elsif(!defined($from_cache) && $self->{_cache} &&
831                           defined($self->{_slanguage_code_alpha2})) {
832
0
0
                                $self->_debug("Set $country to $language_name=$self->{_slanguage_code_alpha2}");
833
0
0
                                $self->{_cache}->set(__PACKAGE__ . ':language_name:' . $country, "$language_name=$self->{_slanguage_code_alpha2}", '1 month');
834                        }
835                }
836        }
837}
838
839# Try our very best to give the right country - if they ask for en-us and
840# we only have en-gb then give it to them
841
842# Old code - more readable
843# sub _get_closest {
844        # my ($self, $language_string, $alpha2) = @_;
845#
846        # foreach (@{$self->{_supported}}) {
847                # my $s;
848                # if(/^(.+)-.+/) {
849                        # $s = $1;
850                # } else {
851                        # $s = $_;
852                # }
853                # if($language_string eq $s) {
854                        # $self->{_slanguage} = $self->{_rlanguage};
855                        # $self->{_slanguage_code_alpha2} = $alpha2;
856                        # last;
857                # }
858        # }
859# }
860
861sub _get_closest
862{
863
14
21
        my ($self, $language_string, $alpha2) = @_;
864
865        # Create a hash mapping base languages to their full language codes
866
14
94
14
32
134
18
        my %base_languages = map { /^(.+)-/ ? ($1 => $_) : ($_ => $_) } @{$self->{_supported}};
867
868
14
31
        if(exists($base_languages{$language_string})) {
869
14
15
                $self->{_slanguage} = $self->{_rlanguage};
870
14
26
                $self->{_slanguage_code_alpha2} = $alpha2;
871        }
872}
873
874# What's the language being requested? Can be used in both a class and an object context
875sub _what_language {
876
42
36
        my $self = $_[0];
877
878
42
49
        if(ref($self)) {
879
36
44
                $self->_trace('Entered _what_language');
880
36
567
                if($self->{_what_language}) {
881
8
10
                        $self->_trace('_what_language: returning cached value: ', $self->{_what_language});
882
8
89
                        return $self->{_what_language};      # Useful in case something changes the $info hash
883                }
884
28
42
                if(my $info = $self->{_info}) {
885
0
0
                        if(my $rc = $info->lang()) {
886                                # E.g. cgi-bin/script.cgi?lang=de
887
0
0
                                $self->_trace("_what_language set language to $rc from the lang argument");
888
0
0
                                return $self->{_what_language} = $rc;
889                        }
890                }
891        }
892
893
34
59
        if(my $rc = $ENV{'HTTP_ACCEPT_LANGUAGE'}) {
894
32
33
                if(ref($self)) {
895
26
50
                        return $self->{_what_language} = $rc;
896                }
897
6
7
                return $rc;
898        }
899
900
2
7
        if(defined($ENV{'LANG'})) {
901                # Running the script locally, presumably to debug, so set the language
902                # from the Locale
903
0
0
                if(ref($self)) {
904
0
0
                        return $self->{_what_language} = $ENV{'LANG'};
905                }
906
0
0
                return $ENV{'LANG'};
907        }
908}
909
910 - 919
=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.

=cut
920
921sub country {
922
14
1523
        my $self = shift;
923
924
14
28
        $self->_trace(__PACKAGE__, ': Entered country()');
925
926        # FIXME: If previous calls to country() return undef, we'll
927        # waste time going through again and no doubt returning undef
928        # again.
929
14
412
        if($self->{_country}) {
930
0
0
                $self->_trace('quick return: ', $self->{_country});
931
0
0
                return $self->{_country};
932        }
933
934        # mod_geoip
935
14
37
        if(defined($ENV{'GEOIP_COUNTRY_CODE'})) {
936
0
0
                $self->{_country} = lc($ENV{'GEOIP_COUNTRY_CODE'});
937
0
0
                return $self->{_country};
938        }
939
14
30
        if(($ENV{'HTTP_CF_IPCOUNTRY'}) && ($ENV{'HTTP_CF_IPCOUNTRY'} ne 'XX')) {
940                # Hosted by Cloudfare
941
2
11
                $self->{_country} = lc($ENV{'HTTP_CF_IPCOUNTRY'});
942
2
7
                return $self->{_country};
943        }
944
945
12
18
        my $ip = $ENV{'REMOTE_ADDR'};
946
947
12
34
        return unless(defined($ip));
948
949
1
236
        require Data::Validate::IP;
950
1
14034
        Data::Validate::IP->import();
951
952
1
1
        if(!is_ipv4($ip)) {
953
0
0
                $self->_debug("$ip isn't IPv4. Is it IPv6?");
954
0
0
                if($ip eq '::1') {
955                        # special case that is easy to handle
956
0
0
                        $ip = '127.0.0.1';
957                } elsif(!is_ipv6($ip)) {
958
0
0
                        $self->_warn({
959                                warning => "$ip isn't a valid IP address"
960                        });
961
0
0
                        return;
962                }
963        }
964
1
20
        if(is_private_ip($ip)) {
965
0
0
                $self->_debug("Can't determine country from LAN connection $ip");
966
0
0
                return;
967        }
968
1
59
        if(is_loopback_ip($ip)) {
969
0
0
                $self->_debug("Can't determine country from loopback connection $ip");
970
0
0
                return;
971        }
972
973
1
49
        if($self->{_cache}) {
974
0
0
                $self->{_country} = $self->{_cache}->get(__PACKAGE__ . ":country:$ip");
975
0
0
                if(defined($self->{_country})) {
976
0
0
                        if($self->{_country} !~ /\D/) {
977
0
0
                                $self->_warn('cache contains a numeric country: ', $self->{_country});
978
0
0
                                $self->{_cache}->remove($ip);
979
0
0
                                delete $self->{_country};    # Seems to be a number
980                        } else {
981
0
0
                                $self->_debug("Get $ip from cache = $self->{_country}");
982
0
0
                                return $self->{_country};
983                        }
984                }
985
0
0
                $self->_debug("$ip isn't in the cache");
986        }
987
988
1
3
        if($self->{_have_ipcountry} == -1) {
989
1
1
1
46
                if(eval { require IP::Country; }) {
990
0
0
                        IP::Country->import();
991
0
0
                        $self->{_have_ipcountry} = 1;
992
0
0
                        $self->{_ipcountry} = IP::Country::Fast->new();
993                } else {
994
1
236
                        $self->{_have_ipcountry} = 0;
995                }
996        }
997
1
4
        $self->_debug("have_ipcountry $self->{_have_ipcountry}");
998
999
1
21
        if($self->{_have_ipcountry}) {
1000
0
0
                $self->{_country} = $self->{_ipcountry}->inet_atocc($ip);
1001
0
0
                if($self->{_country}) {
1002
0
0
                        $self->{_country} = lc($self->{_country});
1003                } elsif(is_ipv4($ip)) {
1004                        # Although it doesn't say so, it looks like IP::Country is IPv4 only
1005
0
0
                        $self->_debug("$ip is not known by IP::Country");
1006                }
1007        }
1008
1
1
        unless(defined($self->{_country})) {
1009
1
2
                if($self->{_have_geoip} == -1) {
1010
1
3
                        $self->_load_geoip();
1011                }
1012
1
1
                if($self->{_have_geoip} == 1) {
1013
0
0
                        $self->{_country} = $self->{_geoip}->country_code_by_addr($ip);
1014                }
1015
1016                # FIXME:  45.128.139.41 is broken in Geo::IPFree,
1017                #       see https://github.com/bricas/geo-ipfree/issues/10
1018
1
3
                if(!defined($self->{_country}) && ($ip ne '45.128.139.41')) {
1019
0
0
                        if($self->{_have_geoipfree} == -1) {
1020                                # Don't use 'eval { use ... ' as recommended by Perlcritic
1021                                # See https://www.cpantesters.org/cpan/report/6db47260-389e-11ec-bc66-57723b537541
1022
0
0
                                eval 'require Geo::IPfree';
1023
0
0
                                unless($@) {
1024
0
0
                                        Geo::IPfree::IP->import();
1025
0
0
                                        $self->{_have_geoipfree} = 1;
1026
0
0
                                        $self->{_geoipfree} = Geo::IPfree->new();
1027                                } else {
1028
0
0
                                        $self->{_have_geoipfree} = 0;
1029                                }
1030                        }
1031
0
0
                        if($self->{_have_geoipfree} == 1) {
1032
0
0
                                if(my $country = ($self->{_geoipfree}->LookUp($ip))[0]) {
1033
0
0
                                        $self->{_country} = lc($country);
1034                                }
1035                        }
1036                }
1037        }
1038
1
4
        if($self->{_country} && ($self->{_country} eq 'eu')) {
1039
0
0
                delete($self->{_country});
1040        }
1041
1
2
        if((!$self->{_country}) &&
1042
1
0
42
0
           (eval { require LWP::Simple::WithCache; require JSON::Parse } )) {
1043
0
0
                $self->_debug("Look up $ip on geoplugin");
1044
1045
0
0
                LWP::Simple::WithCache->import();
1046
0
0
                JSON::Parse->import();
1047
1048
0
0
                if(my $data = LWP::Simple::WithCache::get("http://www.geoplugin.net/json.gp?ip=$ip")) {
1049
0
0
                        $self->{_country} = JSON::Parse::parse_json($data)->{'geoplugin_countryCode'};
1050                }
1051        }
1052
1
222
        unless($self->{_country}) {
1053
1
2
                $self->_debug("Look up $ip on Whois");
1054
1055
1
226
                require Net::Whois::IP;
1056
1
5153
                Net::Whois::IP->import();
1057
1058
1
0
                my $whois;
1059
1060
1
1
                eval {
1061                        # Catch connection timeouts to
1062                        # whois.ripe.net by turning the carp
1063                        # into an error
1064
1
0
3
0
                        local $SIG{__WARN__} = sub { die $_[0] };
1065
1
2
                        $whois = Net::Whois::IP::whoisip_query($ip);
1066                };
1067
1
2511015
                unless($@ || !defined($whois) || (ref($whois) ne 'HASH')) {
1068
1
5
                        if(defined($whois->{Country})) {
1069
0
0
                                $self->{_country} = $whois->{Country};
1070                        } elsif(defined($whois->{country})) {
1071
1
7
                                $self->{_country} = $whois->{country};
1072                        }
1073
1
2
                        if($self->{_country}) {
1074
1
17
                                if($self->{_country} eq 'EU') {
1075
0
0
                                        delete($self->{_country});
1076                                } elsif(($self->{_country} eq 'US') && defined($whois->{'StateProv'}) && ($whois->{'StateProv'} eq 'PR')) {
1077                                        # RT#131347: Despite what Whois thinks, Puerto Rico isn't in the US
1078
0
0
                                        $self->{_country} = 'pr';
1079                                }
1080                        }
1081                }
1082
1083
1
3
                if($self->{_country}) {
1084
1
4
                        $self->_debug("Found up $ip on Net::WhoisIP as ", $self->{_country});
1085                } else {
1086
0
0
                        $self->_debug("Look up $ip on IANA");
1087
1088
0
0
                        require Net::Whois::IANA;
1089
0
0
                        Net::Whois::IANA->import();
1090
1091
0
0
                        my $iana = Net::Whois::IANA->new();
1092
0
0
                        eval {
1093
0
0
                                $iana->whois_query(-ip => $ip);
1094                        };
1095
0
0
                        unless ($@) {
1096
0
0
                                $self->{_country} = $iana->country();
1097
0
0
                                $self->_debug("IANA reports $ip as ", $self->{_country});
1098                        }
1099                }
1100
1101
1
42
                if($self->{_country}) {
1102                        # 190.24.1.122 has carriage return in its WHOIS record
1103
1
3
                        $self->{_country} =~ s/[\r\n]//g;
1104
1
6
                        if($self->{_country} =~ /^(..)\s*#/) {
1105                                # Remove comments in the Whois record
1106
0
0
                                $self->{_country} = $1;
1107                        }
1108                }
1109                # TODO - try freegeoip.net if whois has failed
1110        }
1111
1112
1
3
        if($self->{_country}) {
1113
1
3
                if($self->{_country} !~ /\D/) {
1114
0
0
                        $self->_warn('IP matches to a numeric country');
1115
0
0
                        delete $self->{_country};    # Seems to be a number
1116                } else {
1117
1
2
                        $self->{_country} = lc($self->{_country});
1118
1
3
                        if($self->{_country} eq 'hk') {
1119                                # Hong Kong is no longer a country, but Whois thinks
1120                                # it is - try "whois 218.213.130.87"
1121
0
0
                                $self->{_country} = 'cn';
1122                        } elsif($self->{_country} eq 'eu') {
1123
0
0
                                require Net::Subnet;
1124
1125                                # RT-86809, Baidu claims it's in EU not CN
1126
0
0
                                Net::Subnet->import();
1127
0
0
                                if(subnet_matcher('185.10.104.0/22')->($ip)) {
1128
0
0
                                        $self->{_country} = 'cn';
1129                                } else {
1130                                        # There is no country called 'eu'
1131
0
0
                                        $self->_info({
1132                                                warning => "$ip has country of eu"
1133                                        });
1134
0
0
                                        $self->{_country} = 'Unknown';
1135                                }
1136                        }
1137
1138
1
3
                        if($self->{_country} !~ /\D/) {
1139
0
0
                                $self->_warn('cache contains a numeric country: ', $self->{_country});
1140
0
0
                                delete $self->{_country};    # Seems to be a number
1141                        } elsif($self->{_cache}) {
1142
0
0
                                $self->_debug("Set $ip to $self->{_country}");
1143
1144
0
0
                                $self->{_cache}->set(__PACKAGE__ . ":country:$ip", $self->{_country}, '1 hour');
1145                        }
1146                }
1147        }
1148
1149
1
6
        return $self->{_country};
1150}
1151
1152sub _load_geoip
1153{
1154
1
1
        my $self = shift;
1155
1156        # For Windows, see http://www.cpantesters.org/cpan/report/54117bd0-6eaf-1014-8029-ee20cb952333
1157
1
22
        if((($^O eq 'MSWin32') && (-r 'c:/GeoIP/GeoIP.dat')) ||
1158           ((-r '/usr/local/share/GeoIP/GeoIP.dat') || (-r '/usr/share/GeoIP/GeoIP.dat'))) {
1159                # Don't use 'eval { use ... ' as recommended by Perlcritic
1160                # See https://www.cpantesters.org/cpan/report/6db47260-389e-11ec-bc66-57723b537541
1161
0
0
                eval 'require Geo::IP';
1162
0
0
                unless($@) {
1163
0
0
                        Geo::IP->import();
1164
0
0
                        $self->{_have_geoip} = 1;
1165                        # GEOIP_STANDARD = 0, can't use that because you'll
1166                        # get a syntax error
1167
0
0
                        if(-r '/usr/share/GeoIP/GeoIP.dat') {
1168
0
0
                                $self->{_geoip} = Geo::IP->open('/usr/share/GeoIP/GeoIP.dat', 0);
1169                        } else {
1170
0
0
                                $self->{_geoip} = Geo::IP->new(0);
1171                        }
1172                } else {
1173
0
0
                        $self->{_have_geoip} = 0;
1174                }
1175        } else {
1176
1
2
                $self->{_have_geoip} = 0;
1177        }
1178}
1179
1180 - 1194
=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.

To be clear, if you're in the US and request the language in Spanish,
and the site supports it, language() will return 'Spanish', and locale() will
try to return the Locale::Object::Country for the US.

=cut
1195
1196sub locale {
1197
1
1
        my $self = shift;
1198
1199
1
3
        if($self->{_locale}) {
1200
0
0
                return $self->{_locale};
1201        }
1202
1203        # First try from the User Agent.  Probably only works with Mozilla and
1204        # Safari.  I don't know about Opera.  It won't work with IE or Chrome.
1205
1
2
        my $agent = $ENV{'HTTP_USER_AGENT'};
1206
1
14
        my $country;
1207
1
7
        if(defined($agent) && ($agent =~ /\((.+)\)/)) {
1208
1
3
                foreach(split(/;/, $1)) {
1209
5
4
                        my $candidate = $_;
1210
1211
5
7
                        $candidate =~ s/^\s//g;
1212
5
6
                        $candidate =~ s/\s$//g;
1213
5
7
                        if($candidate =~ /^[a-zA-Z]{2}-([a-zA-Z]{2})$/) {
1214
0
0
                                local $SIG{__WARN__} = undef;
1215
0
0
                                if(my $c = $self->_code2country($1)) {
1216
0
0
                                        $self->{_locale} = $c;
1217
0
0
                                        return $c;
1218                                }
1219                                # carp "Warning: unknown country $1 derived from $candidate in HTTP_USER_AGENT ($agent)";
1220                        }
1221                }
1222
1223
1
1
2
435
                if(eval { require HTTP::BrowserDetect; } ) {
1224
1
8201
                        HTTP::BrowserDetect->import();
1225
1
3
                        my $browser = HTTP::BrowserDetect->new($agent);
1226
1227
1
92
                        if($browser && $browser->country() && (my $c = $self->_code2country($browser->country()))) {
1228
1
1
                                $self->{_locale} = $c;
1229
1
9
                                return $c;
1230                        }
1231                }
1232        }
1233
1234        # Try from the IP address
1235
0
0
        $country = $self->country();
1236
1237
0
0
        if($country) {
1238
0
0
                $country =~ s/[\r\n]//g;
1239
1240
0
0
                my $c;
1241
0
0
                eval {
1242
0
0
0
0
                        local $SIG{__WARN__} = sub { die $_[0] };
1243
0
0
                        $c = $self->_code2country($country);
1244                };
1245
0
0
                unless($@) {
1246
0
0
                        if($c) {
1247
0
0
                                $self->{_locale} = $c;
1248
0
0
                                return $c;
1249                        }
1250                }
1251        }
1252
1253        # Try mod_geoip
1254
0
0
        if(defined($ENV{'GEOIP_COUNTRY_CODE'})) {
1255
0
0
                $country = $ENV{'GEOIP_COUNTRY_CODE'};
1256
0
0
                my $c = $self->_code2country($country);
1257
0
0
                if($c) {
1258
0
0
                        $self->{_locale} = $c;
1259
0
0
                        return $c;
1260                }
1261        }
1262
0
0
        return undef;
1263}
1264
1265 - 1272
=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>

=cut
1273
1274sub time_zone {
1275
0
0
        my $self = shift;
1276
1277
0
0
        $self->_trace('Entered time_zone');
1278
1279
0
0
        if($self->{_timezone}) {
1280
0
0
                $self->_trace('quick return: ', $self->{_timezone});
1281
0
0
                return $self->{_timezone};
1282        }
1283
1284
0
0
        if(my $ip = $ENV{'REMOTE_ADDR'}) {
1285
0
0
                if($self->{_have_geoip} == -1) {
1286
0
0
                        $self->_load_geoip();
1287                }
1288
0
0
                if($self->{_have_geoip} == 1) {
1289
0
0
                        eval {
1290
0
0
                                $self->{_timezone} = $self->{_geoip}->time_zone($ip);
1291                        };
1292                }
1293
0
0
                if(!$self->{_timezone}) {
1294
0
0
0
0
0
0
                        if(eval { require LWP::Simple::WithCache; require JSON::Parse } ) {
1295
0
0
                                $self->_debug("Look up $ip on ip-api.com");
1296
1297
0
0
                                LWP::Simple::WithCache->import();
1298
0
0
                                JSON::Parse->import();
1299
1300
0
0
                                if(my $data = LWP::Simple::WithCache::get("http://ip-api.com/json/$ip")) {
1301
0
0
                                        $self->{_timezone} = JSON::Parse::parse_json($data)->{'timezone'};
1302                                }
1303
0
0
0
0
                        } elsif(eval { require LWP::Simple; require JSON::Parse } ) {
1304
0
0
                                $self->_debug("Look up $ip on ip-api.com");
1305
1306
0
0
                                LWP::Simple->import();
1307
0
0
                                JSON::Parse->import();
1308
1309
0
0
                                if(my $data = LWP::Simple::get("http://ip-api.com/json/$ip")) {
1310
0
0
                                        $self->{_timezone} = JSON::Parse::parse_json($data)->{'timezone'};
1311                                }
1312                        } else {
1313
0
0
                                if(my $logger = $self->{'logger'}) {
1314
0
0
                                        $logger->error('You must have LWP::Simple::WithCache installed to connect to ip-api.com');
1315                                }
1316
0
0
                                Carp::croak('You must have LWP::Simple::WithCache or LWP::Simple installed to connect to ip-api.com');
1317                        }
1318                }
1319        } else {
1320                # Not a remote connection
1321
0
0
                if(open(my $fin, '<', '/etc/timezone')) {
1322
0
0
                        my $tz = <$fin>;
1323
0
0
                        chomp $tz;
1324
0
0
                        $self->{_timezone} = $tz;
1325                } else {
1326
0
0
                        $self->{_timezone} = DateTime::TimeZone::Local->TimeZone()->name();
1327                }
1328        }
1329
1330
0
0
        if(!defined($self->{_timezone})) {
1331
0
0
                $self->_warn("Couldn't determine the timezone");
1332        }
1333
0
0
        return $self->{_timezone};
1334}
1335
1336# Wrapper to Locale::Language::code2language which makes use of the cache
1337sub _code2language
1338{
1339
25
28
        my ($self, $code) = @_;
1340
1341
25
25
        return unless($code);
1342
25
30
        if(defined($self->{_country})) {
1343
2
4
                $self->_debug("_code2language $code, country ", $self->{_country});
1344        } else {
1345
23
27
                $self->_debug("_code2language $code");
1346        }
1347
25
311
        unless($self->{_cache}) {
1348
19
35
                return Locale::Language::code2language($code);
1349        }
1350
6
13
        if(my $from_cache = $self->{_cache}->get(__PACKAGE__ . ":code2language:$code")) {
1351
5
416
                $self->_trace("_code2language found in cache $from_cache");
1352
5
55
                return $from_cache;
1353        }
1354
1
47
        $self->_trace('_code2language not in cache, storing');
1355
1
12
        return $self->{_cache}->set(__PACKAGE__ . ":code2language:$code", Locale::Language::code2language($code), '1 month');
1356}
1357
1358# Wrapper to Locale::Object::Country allowing for persistence to be added
1359sub _code2country
1360{
1361
19
86
        my ($self, $code) = @_;
1362
1363
19
21
        return unless($code);
1364
19
28
        if($self->{_country}) {
1365
2
5
                $self->_trace(">_code2country $code, country ", $self->{_country});
1366        } else {
1367
17
25
                $self->_trace(">_code2country $code");
1368        }
1369        local $SIG{__WARN__} = sub {
1370
1
298
                if($_[0] !~ /No result found in country table/) {
1371
0
0
                        warn $_[0];
1372                }
1373
19
301
        };
1374
19
85
        my $rc = Locale::Object::Country->new(code_alpha2 => $code);
1375
19
1392978
        local $SIG{__WARN__} = 'DEFAULT';
1376
19
59
        $self->_trace('<_code2country ', $code || 'undef');
1377
19
438
        return $rc;
1378}
1379
1380# Wrapper to Locale::Object::Country->name which makes use of the cache
1381sub _code2countryname
1382{
1383
16
21
        my ($self, $code) = @_;
1384
1385
16
23
        return unless($code);
1386
16
33
        $self->_trace(">_code2countryname $code");
1387
16
274
        unless($self->{_cache}) {
1388
12
19
                my $country = $self->_code2country($code);
1389
12
18
                if(defined($country)) {
1390
12
24
                        return $country->name;
1391                }
1392
0
0
                return;
1393        }
1394
4
7
        if(my $from_cache = $self->{_cache}->get(__PACKAGE__ . ":code2countryname:$code")) {
1395
2
120
                $self->_trace("_code2countryname found in cache $from_cache");
1396
2
19
                return $from_cache;
1397        }
1398
2
97
        if(my $country = $self->_code2country($code)) {
1399
2
3
                $self->_debug('_code2countryname not in cache, storing');
1400
2
21
                $self->_trace('<_code2countryname ', $country->name());
1401
2
21
                return $self->{_cache}->set(__PACKAGE__ . ":code2countryname:$code", $country->name(), '1 month');
1402        }
1403
0
0
        $self->_trace('<_code2countryname undef');
1404}
1405
1406# Log and remember a message
1407sub _log
1408{
1409
428
445
        my ($self, $level, @messages) = @_;
1410
1411
428
699
        if(ref($self) && scalar(@messages)) {
1412                # FIXME: add caller's function
1413                # if(($level eq 'warn') || ($level eq 'info')) {
1414
428
428
265
952
                        push @{$self->{'messages'}}, { level => $level, message => join('', grep defined, @messages) };
1415                # }
1416
1417
428
486
                if(my $logger = $self->{'logger'}) {
1418
428
793
                        $self->{'logger'}->$level(join('', grep defined, @messages));
1419                }
1420        }
1421}
1422
1423sub _debug {
1424
220
138
        my $self = shift;
1425
220
200
        $self->_log('debug', @_);
1426}
1427
1428sub _info {
1429
0
0
        my $self = shift;
1430
0
0
        $self->_log('info', @_);
1431}
1432
1433sub _notice {
1434
1
1
        my $self = shift;
1435
1
2
        $self->_log('notice', @_);
1436}
1437
1438sub _trace {
1439
207
169
        my $self = shift;
1440
207
237
        $self->_log('trace', @_);
1441}
1442
1443# Emit a warning message somewhere
1444sub _warn
1445{
1446
0
        my $self = shift;
1447
0
        if(defined($self->{'logger'})) {
1448
0
                $self->{'logger'}->warn(\@_);
1449        } else {
1450                # This shouldn't happen, since Object::Configure always sets something
1451
0
                my $params = Params::Get::get_params('warning', @_);
1452
1453
0
                $self->_log('warn', $params->{'warning'});
1454
0
                Carp::carp($params->{'warning'});
1455        }
1456}
1457
1458 - 1536
=head1 AUTHOR

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

=head1 BUGS

Please report any bugs or feature requests to the author.

If HTTP_ACCEPT_LANGUAGE is 3 characters, e.g., es-419,
sublanguage() returns undef.

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-Info/coverage/>

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

=item * L<HTTP::BrowserDetect>

=item * L<I18N::AcceptLangauge>

=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

=head1 ACKNOWLEDGEMENTS

=head1 LICENSE AND COPYRIGHT

Copyright 2010-2026 Nigel Horne.

This program is released under the following licence: GPL2

=cut
1537
15381; # End of CGI::Lingua