File Coverage

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

linestmtbrancondsubtimecode
1package CGI::Lingua;
2
3
19
19
19
947875
15
358
use warnings;
4
19
19
19
23
16
206
use strict;
5
6
19
19
19
2446
839597
287
use Object::Configure 0.14;
7
19
19
19
62
101
262
use Params::Get 0.13;
8
19
19
19
31
17
434
use Storable; # RT117983
9
19
19
19
3301
49402
50
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
1870332
        my $class = shift;
166
41
117
        my $params = Params::Get::get_params('supported', @_);
167
168
39
859
        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
111
        $params = Object::Configure::configure($class, $params);
186
187        # Validate logger object has required methods
188
39
290851
        if(defined $params->{'logger'}) {
189
39
192
                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
1490
        $params->{'supported'} ||= $params->{'supported_languages'};
199
39
63
        if(!defined($params->{supported})) {
200
2
4
                if(my $logger = $params->{'logger'}) {
201
2
4
                        $logger->error('You must give a list of supported languages');
202                }
203
2
545
                Carp::croak('You must give a list of supported languages');
204        }
205
206
38
373
        if(ref($params->{supported})) {
207
37
69
                if(ref($params->{supported}) ne 'ARRAY') {
208
0
0
                        Carp::croak('List of supported languages must be an array ref');
209                }
210        } elsif((length($params->{supported}) < 2) || (length($params->{supported}) > 5)) {
211
1
259
                Carp::croak('Supported languages must be the short code');
212        }
213
214
38
43
        my $cache = $params->{cache};
215
38
28
        my $info = $params->{info};
216
217
38
62
        if($cache && $ENV{'REMOTE_ADDR'}) {
218
6
6
                my $key = "$ENV{REMOTE_ADDR}/";
219
6
4
                my $l;
220
6
18
                if($info && ($l = $info->lang())) {
221
0
0
                        $key .= "$l/";
222                } elsif($l = $class->_what_language()) {
223
6
6
                        $key .= "$l/";
224                }
225
6
21
                if(ref($params->{'supported'} eq 'ARRAY')) {
226
0
0
0
0
                        $key .= join('/', @{$params->{supported}});
227                } else {
228
6
7
                        $key .= $params->{'supported'};
229                }
230                # if($logger) {
231                        # $self->debug("Looking in cache for $key");
232                # }
233
6
16
                if(my $rc = $cache->get($key)) {
234                        # if($logger) {
235                                # $logger->debug('Found - thawing');
236                        # }
237
0
0
                        $rc = Storable::thaw($rc);
238
0
0
                        $rc->{logger} = $params->{'logger'};
239
0
0
                        $rc->{_syslog} = $params->{syslog};
240
0
0
                        $rc->{_cache} = $cache;
241
0
0
                        $rc->{_supported} = $params->{supported};
242
0
0
                        $rc->{_info} = $info;
243
0
0
                        $rc->{_have_ipcountry} = -1;
244
0
0
                        $rc->{_have_geoip} = -1;
245
0
0
                        $rc->{_have_geoipfree} = -1;
246
247
0
0
                        if(($rc->{_what_language} || $rc->{_rlanguage}) && $info && $info->lang()) {
248
0
0
                                delete $rc->{_what_language};
249
0
0
                                delete $rc->{_rlanguage};
250
0
0
                                delete $rc->{_country};
251                        }
252
0
0
                        return $rc;
253                }
254        }
255
256        return bless {
257
38
400
                %{$params},
258                _supported => ref($params->{supported}) ? $params->{supported} : [ $params->{'supported'} ], # List of languages (two letters) that the application
259                _cache => $cache,    # CHI
260                _info => $info,
261                # _rlanguage => undef,       # Requested language
262                # _slanguage => undef,       # Language that the website should display
263                # _sublanguage => undef,     # E.g. United States for en-US if you want American English
264                # _slanguage_code_alpha2 => undef, # E.g en, fr
265                # _sublanguage_code_alpha2 => undef, # E.g. us, gb
266                # _country => undef, # Two letters, e.g. gb
267                # _locale => undef,  # Locale::Object::Country
268                _syslog => $params->{syslog},
269                _dont_use_ip => $params->{dont_use_ip} || 0,
270                _have_ipcountry => -1,       # -1 = don't know
271                _have_geoip => -1,   # -1 = don't know
272                _have_geoipfree => -1,       # -1 = don't know
273
38
337
                _debug => $params->{debug} || 0,
274        }, $class;
275}
276
277# Some of the information takes a long time to work out, so cache what we can
278sub DESTROY {
279
44
18280
        if(defined($^V) && ($^V ge 'v5.14.0')) {
280
44
67
                return if ${^GLOBAL_PHASE} eq 'DESTRUCT';       # >= 5.14.0 only
281        }
282
44
90
        unless($ENV{'REMOTE_ADDR'}) {
283
17
108
                return;
284        }
285
27
21
        my $self = shift;
286
27
38
        return unless(ref($self));
287
288
27
26
        my $cache = $self->{_cache};
289
27
137
        return unless($cache);
290
291
6
5
        my $key = "$ENV{REMOTE_ADDR}/";
292
6
7
        if(my $l = $self->_what_language()) {
293
6
5
                $key .= "$l/";
294        }
295
6
6
6
9
        $key .= join('/', @{$self->{_supported}});
296
6
8
        return if($cache->get($key));
297
298
6
217
        $self->_debug("Storing self in cache as $key");
299
300        my $copy = bless {
301                _slanguage => $self->{_slanguage},
302                _slanguage_code_alpha2 => $self->{_slanguage_code_alpha2},
303                _sublanguage_code_alpha2 => $self->{_sublanguage_code_alpha2},
304                _country => $self->{_country},
305                _rlanguage => $self->{_rlanguage},
306                _dont_use_ip => $self->{_dont_use_ip},
307                _have_ipcountry => $self->{_have_ipcountry},
308                _have_geoip => $self->{_have_geoip},
309                _have_geoipfree => $self->{_have_geoipfree},
310
6
71
        }, ref($self);
311
312        # All of these crash, presumably something recursive is going on
313        # my $copy = Clone::clone($self);
314        # my $storable = Storable::nfreeze(Storable::dclone($self));
315        # my $storable = Storable::dclone($self);
316
317
6
16
        $cache->set($key, Storable::nfreeze($copy), '1 month');
318}
319
320
321 - 346
=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
347
348sub language {
349
22
2974
        my $self = $_[0];
350
351
22
35
        unless($self->{_slanguage}) {
352
15
24
                $self->_find_language();
353        }
354
22
52
        return $self->{_slanguage};
355}
356
357 - 361
=head2 preferred_language

Same as language().

=cut
362
363sub preferred_language
364{
365
1
1
        my $self = shift;
366
367
1
2
        $self->language(@_);
368}
369
370 - 374
=head2 name

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

=cut
375
376sub name {
377
1
1
        my $self = $_[0];
378
379
1
2
        return $self->language();
380}
381
382 - 390
=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
391
392sub sublanguage {
393
21
22
        my $self = $_[0];
394
395
21
24
        $self->_trace('Entered sublanguage');
396
21
309
        unless($self->{_slanguage}) {
397
1
1
                $self->_find_language();
398        }
399
21
39
        $self->_trace('Leaving sublanguage ', ($self->{_sublanguage} || 'undef'));
400
21
253
        return $self->{_sublanguage};
401}
402
403 - 411
=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
412
413sub language_code_alpha2 {
414
8
4
        my $self = $_[0];
415
416
8
12
        $self->_trace('Entered language_code_alpha2');
417
8
113
        unless($self->{_slanguage}) {
418
1
2
                $self->_find_language();
419        }
420
8
12
        $self->_trace('language_code_alpha2 returns ', $self->{_slanguage_code_alpha2});
421
8
107
        return $self->{_slanguage_code_alpha2};
422}
423
424 - 428
=head2 code_alpha2

Synonym for language_code_alpha2, kept for historical reasons.

=cut
429
430sub code_alpha2 {
431
8
516
        my $self = $_[0];
432
433
8
12
        return $self->language_code_alpha2();
434}
435
436 - 441
=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
442
443sub sublanguage_code_alpha2 {
444
2
713
        my $self = $_[0];
445
446
2
4
        unless($self->{_slanguage}) {
447
1
1
                $self->_find_language();
448        }
449
2
12
        return $self->{_sublanguage_code_alpha2};
450}
451
452
453 - 461
=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
462
463sub requested_language {
464
44
6475
        my $self = $_[0];
465
466
44
55
        unless($self->{_rlanguage}) {
467
9
16
                $self->_find_language();
468        }
469
44
92
        return $self->{_rlanguage};
470}
471
472# The language cache is stored as country_2_letter -> $language_human_readable_name=$language_2_letter
473# The IP cache is stored as ip -> country_human_readable_name
474
475# Returns the human-readable language, such as 'English'
476
477sub _find_language
478{
479
27
24
        my $self = shift;
480
481
27
44
        $self->_trace('Entered _find_language');
482
483        # Initialize defaults
484
27
476
        $self->{_rlanguage} = 'Unknown';
485
27
28
        $self->{_slanguage} = 'Unknown';
486
487        # Use what the client has said
488
27
41
        my $http_accept_language = $self->_what_language();
489
27
38
        if(defined($http_accept_language)) {
490
27
27
29
65
                $self->_debug("language wanted: $http_accept_language, languages supported: ", join(', ', @{$self->{_supported}}));
491
492
27
344
                if($http_accept_language eq 'en-uk') {
493
0
0
                        $self->_debug("Resetting country code to GB for $http_accept_language");
494
0
0
                        $http_accept_language = 'en-gb';
495                }
496                # Workaround for RT 74338
497                local $SIG{__WARN__} = sub {
498
0
0
                        if($_[0] !~ /^Use of uninitialized value/) {
499
0
0
                                warn $_[0];
500                        }
501
27
70
                };
502
27
119
                my $i18n = I18N::AcceptLanguage->new(debug => $self->{_debug}, strict => 1);
503
27
5473
                my $l = $i18n->accepts($http_accept_language, $self->{_supported});
504
27
2094
                local $SIG{__WARN__} = 'DEFAULT';
505
27
213
                if($l && ($http_accept_language =~ /-/) && ($http_accept_language !~ qr/$l/i)) {
506                        # I18N-AcceptLanguage strict mode doesn't work as I'd expect it to,
507                        # if you support 'en' and 'en-gb' and request 'en-US,en;q=0.8',
508                        # it actually returns 'en-gb'
509
3
6
                        $self->_debug('Forcing fallback');
510
3
47
                        undef $l;
511                }
512
513
27
28
                my $requested_sublanguage;
514
27
36
                if(!$l) {
515                        # FIXME: This scans the HTTP_ACCEPTED_LANGUAGE left to right, it ignores the priority value
516
8
18
                        $self->_debug(__PACKAGE__, ': ', __LINE__, ": look through $http_accept_language for alternatives");
517
8
130
                        while($http_accept_language =~ /(..)\-(..)/g) {
518
7
65
                                $requested_sublanguage = $2;
519                                # Fall back position, e,g. we want US English on a site
520                                # only giving British English, so allow it as English.
521                                # The calling program can detect that it's not the
522                                # wanted flavour of English by looking at
523                                # requested_language
524
7
16
                                $self->_debug(__PACKAGE__, ': ', __LINE__, ": see if $1 is supported");
525
7
89
                                if($i18n->accepts($1, $self->{_supported})) {
526
4
179
                                        $l = $1;
527
4
9
                                        $self->_debug("Fallback to $l as sublanguage $requested_sublanguage is not supported");
528
4
41
                                        last;
529                                }
530                        }
531                }
532
27
105
                if(!$l) {
533                        # FIXME: This scans the HTTP_ACCEPTED_LANGUAGE left to right, it ignores the priority value
534
4
8
                        $self->_debug(__PACKAGE__, ': ', __LINE__, ": look harder through $http_accept_language for alternatives");
535
4
54
                        foreach my $possible(split(/,/, $http_accept_language)) {
536
6
35
                                next if($possible =~ /..\-../); # Already checked those with sublanguages
537
4
5
                                $possible =~ s/;.*$//;
538
4
5
                                $self->_debug(__PACKAGE__, ': ', __LINE__, ": see if $possible is supported");
539
4
49
                                if($i18n->accepts($possible, $self->{_supported})) {
540
1
22
                                        $l = $possible;
541
1
1
                                        $self->_debug("Fallback to $possible as best alternative");
542
1
11
                                        undef $requested_sublanguage;
543
1
1
                                        last;
544                                }
545                        }
546                }
547
548
27
125
                if($l) {
549
24
40
                        $self->_debug("l: $l");
550
551
24
370
                        if($l !~ /^..-..$/) {
552
10
18
                                $self->{_slanguage} = $self->_code2language($l);
553
10
250358
                                if($self->{_slanguage}) {
554
10
24
                                        $self->_debug("_slanguage: $self->{_slanguage}");
555
556                                        # We have the language, but not the right
557                                        # sublanguage, e.g. they want US English but we
558                                        # only support British English or English
559                                        # wanted: en-us, got en-gb and en
560
10
191
                                        $self->{_slanguage_code_alpha2} = $l;
561
10
11
                                        $self->{_rlanguage} = $self->{_slanguage};
562
563
10
9
                                        my $sl;
564
10
59
                                        if($http_accept_language =~ /..-(..)$/) {
565
3
4
                                                $self->_debug($1);
566
3
40
                                                $sl = $self->_code2country($1);
567
3
7
                                                $requested_sublanguage = $1 if(!defined($requested_sublanguage));
568                                        } elsif($http_accept_language =~ /..-([a-z]{2,3})$/i) {
569
0
0
                                                eval {
570
0
0
                                                        $sl = Locale::Object::Country->new(code_alpha3 => $1);
571                                                };
572
0
0
                                                if($@) {
573
0
0
                                                        $self->_info($@);
574                                                }
575                                        }
576
10
18
                                        if($sl) {
577
3
8
                                                $self->{_rlanguage} .= ' (' . $sl->name() . ')';
578                                                # The requested sublanguage
579                                                # isn't supported so don't
580                                                # define that
581                                        } elsif($requested_sublanguage) {
582
2
4
                                                if(my $c = $self->_code2countryname($requested_sublanguage)) {
583
2
12
                                                        $self->{_rlanguage} .= " ($c)";
584                                                } else {
585
0
0
                                                        $self->{_rlanguage} .= " (Unknown: $requested_sublanguage)";
586                                                }
587                                        }
588
10
70
                                        return;
589                                }
590                        } elsif($l =~ /(.+)-(..)$/) {   # TODO: Handle es-419 "Spanish (Latin America)"
591
14
17
                                my $alpha2 = $1;
592
14
15
                                my $variety = $2;
593
14
24
                                my $accepts = $i18n->accepts($l, $self->{_supported});
594
14
853
                                $self->_debug("accepts = $accepts");
595
596
14
169
                                if($accepts) {
597
14
16
                                        $self->_debug("accepts: $accepts");
598
599
14
174
                                        if($accepts =~ /\-/) {
600
14
17
                                                delete $self->{_slanguage};
601                                        } else {
602
0
0
                                                my $from_cache;
603
0
0
                                                if($self->{_cache}) {
604
0
0
                                                        $from_cache = $self->{_cache}->get(__PACKAGE__ . ":accepts:$accepts");
605                                                }
606
0
0
                                                if($from_cache) {
607
0
0
                                                        $self->_debug("$accepts is in cache as $from_cache");
608
0
0
                                                        $self->{_slanguage} = (split(/=/, $from_cache))[0];
609                                                } else {
610
0
0
                                                        $self->{_slanguage} = $self->_code2language($accepts);
611                                                }
612
0
0
                                                if($self->{_slanguage}) {
613
0
0
                                                        if($variety eq 'uk') {
614                                                                # ???
615
0
0
                                                                $self->_warn({
616                                                                        warning => "Resetting country code to GB for $http_accept_language"
617                                                                });
618
0
0
                                                                $variety = 'gb';
619                                                        }
620
0
0
                                                        if(defined(my $c = $self->_code2countryname($variety))) {
621
0
0
                                                                $self->_debug(__PACKAGE__, ': ', __LINE__, ":  setting sublanguage to $c");
622
0
0
                                                                $self->{_sublanguage} = $c;
623                                                        }
624
0
0
                                                        $self->{_slanguage_code_alpha2} = $accepts;
625
0
0
                                                        if($self->{_sublanguage}) {
626
0
0
                                                                $self->{_rlanguage} = "$self->{_slanguage} ($self->{_sublanguage})";
627
0
0
                                                                $self->_debug(__PACKAGE__, ': ', __LINE__, ": _rlanguage: $self->{_rlanguage}");
628                                                        }
629
0
0
                                                        $self->{_sublanguage_code_alpha2} = $variety;
630
0
0
                                                        unless($from_cache) {
631
0
0
                                                                $self->_debug("Set $variety to $self->{_slanguage}=$self->{_slanguage_code_alpha2}");
632
0
0
                                                                $self->{_cache}->set(__PACKAGE__ . ":accepts:$variety", "$self->{_slanguage}=$self->{_slanguage_code_alpha2}", '1 month');
633                                                        }
634
0
0
                                                        return;
635                                                }
636                                        }
637                                }
638
14
24
                                $self->{_rlanguage} = $self->_code2language($alpha2);
639
14
333466
                                $self->_debug("_rlanguage: $self->{_rlanguage}");
640
641
14
258
                                if($accepts) {
642
14
33
                                        $self->_debug("http_accept_language = $http_accept_language");
643                                        # $http_accept_language =~ /(.{2})-(..)/;
644
14
172
                                        $l =~ /(..)-(..)/;
645
14
18
                                        $variety = lc($2);
646                                        # Ignore en-029 etc (Caribbean English)
647
14
49
                                        if(($variety =~ /[a-z]{2,3}/) && !defined($self->{_sublanguage})) {
648
14
26
                                                $self->_get_closest($alpha2, $alpha2);
649
14
22
                                                $self->_debug("Find the country code for $variety");
650
651
14
175
                                                if($variety eq 'uk') {
652                                                        # ???
653
0
0
                                                        $self->_warn({
654                                                                warning => "Resetting country code to GB for $http_accept_language"
655                                                        });
656
0
0
                                                        $variety = 'gb';
657                                                }
658
14
11
                                                my $from_cache;
659                                                my $language_name;
660
14
20
                                                if($self->{_cache}) {
661
4
7
                                                        $from_cache = $self->{_cache}->get(__PACKAGE__ . ":variety:$variety");
662                                                }
663
14
196
                                                if(defined($from_cache)) {
664
2
3
                                                        $self->_debug("$variety is in cache as $from_cache");
665
666
2
17
                                                        my $language_code2;
667
2
4
                                                        ($language_name, $language_code2) = split(/=/, $from_cache);
668
2
3
                                                        $language_name = $self->_code2countryname($variety);
669                                                } else {
670
12
85
                                                        my $db = Locale::Object::DB->new();
671
12
12
53168
26
                                                        my @results = @{$db->lookup(
672                                                                table => 'country',
673                                                                result_column => 'name',
674                                                                search_column => 'code_alpha2',
675                                                                value => $variety
676                                                        )};
677
12
1511
                                                        if(defined($results[0])) {
678
12
11
                                                                eval {
679
12
25
                                                                        $language_name = $self->_code2countryname($variety);
680                                                                };
681                                                        } else {
682
0
0
                                                                $self->_debug("Can't find the country code for $variety in Locale::Object::DB");
683                                                        }
684                                                }
685
14
426
                                                if($@ || !defined($language_name)) {
686
0
0
                                                        $self->_warn($@) if($@);
687
0
0
                                                        $self->_debug(__PACKAGE__, ': ', __LINE__, ': setting sublanguage to Unknown');
688
0
0
                                                        $self->{_sublanguage} = 'Unknown';
689
0
0
                                                        $self->_warn({
690                                                                warning => "Can't determine values for $http_accept_language"
691                                                        });
692                                                } else {
693
14
19
                                                        $self->{_sublanguage} = $language_name;
694
14
24
                                                        $self->_debug('variety name ', $self->{_sublanguage});
695
14
197
                                                        if($self->{_cache} && !defined($from_cache)) {
696
2
5
                                                                $self->_debug("Set $variety to $self->{_slanguage}=$self->{_slanguage_code_alpha2}");
697
2
19
                                                                $self->{_cache}->set(__PACKAGE__ . ":variety:$variety", "$self->{_slanguage}=$self->{_slanguage_code_alpha2}", '1 month');
698                                                        }
699                                                }
700                                        }
701
14
208
                                        if(defined($self->{_sublanguage})) {
702
14
18
                                                $self->{_rlanguage} = "$self->{_slanguage} ($self->{_sublanguage})";
703
14
19
                                                $self->{_sublanguage_code_alpha2} = $variety;
704
14
78
                                                return;
705                                        }
706                                }
707                        }
708                } elsif($http_accept_language =~ /;/) {
709                        # e.g. HTTP_ACCEPT_LANGUAGE=de-DE,de;q=0.9,en-US;q=0.8,en;q=0.7
710                        # and we don't support DE at all, but we do accept en-US
711
1
1
2
2
                        $self->_notice(__PACKAGE__, ': ', __LINE__, ": couldn't honour HTTP_ACCEPT_LANGUAGE=$http_accept_language, supported languages are: ", join(',', @{$self->{supported}}));
712                }
713
3
21
                if($self->{_slanguage} && ($self->{_slanguage} ne 'Unknown')) {
714
0
0
                        if($self->{_rlanguage} eq 'Unknown') {
715
0
0
                                $self->{_rlanguage} = I18N::LangTags::Detect::detect();
716                        }
717
0
0
                        if($self->{_rlanguage}) {
718
0
0
                                if($l = $self->_code2language($self->{_rlanguage})) {
719
0
0
                                        $self->{_rlanguage} = $l;
720                                # } else {
721                                        # We have the language, but not the right
722                                        # sublanguage, e.g. they want US English but we
723                                        # only support British English
724                                        # wanted: en-us, got en-gb and not en
725                                }
726
0
0
                                return;
727                        }
728                }
729
3
12
                if(((!$self->{_rlanguage}) || ($self->{_rlanguage} eq 'Unknown')) &&
730                   ((length($http_accept_language) == 2) || ($http_accept_language =~ /^..-..$/))) {
731
1
3
                        $self->{_rlanguage} = $self->_code2language($http_accept_language);
732
733
1
37
                        unless($self->{_rlanguage}) {
734
1
2
                                $self->{_rlanguage} = 'Unknown';
735                        }
736                }
737
3
14
                $self->{_slanguage} = 'Unknown';
738        }
739
740
3
3
        if($self->{_dont_use_ip}) {
741
0
0
                return;
742        }
743
744        # The client hasn't said which to use, so guess from their IP address,
745        # or the requested language(s) isn't/aren't supported so use the IP
746        # address for an alternative
747
3
6
        my $country = $self->country();
748
749
3
6
        if((!defined($country)) && (my $c = $self->_what_language())) {
750
2
5
                if($c =~ /^(..)_(..)/) {
751
0
0
                        $country = $2;  # Best guess
752                } elsif($c =~ /^(..)$/) {
753
1
1
                        $country = $1;  # Wrong, but maybe something will drop out
754                }
755        }
756
757
3
5
        if(defined($country)) {
758
1
3
                $self->_debug("country: $country");
759                # Determine the first official language of the country
760
761
1
12
                my $from_cache;
762
1
3
                if($self->{_cache}) {
763
0
0
                        $from_cache = $self->{_cache}->get(__PACKAGE__ . ':language_name:' . $country);
764                }
765
1
1
                my $language_name;
766                my $language_code2;
767
1
2
                if($from_cache) {
768
0
0
                        $self->_debug("$country is in cache as $from_cache");
769
0
0
                        ($language_name, $language_code2) = split(/=/, $from_cache);
770                } else {
771
1
3
                        my $l = $self->_code2country(uc($country));
772
1
3
                        if($l) {
773
0
0
                                $l = ($l->languages_official)[0];
774
0
0
                                if(defined($l)) {
775
0
0
                                        $language_name = $l->name;
776
0
0
                                        $language_code2 = $l->code_alpha2;
777
0
0
                                        if($language_name) {
778
0
0
                                                $self->_debug("Official language: $language_name");
779                                        }
780                                }
781                        }
782                }
783
1
1
                my $ip = $ENV{'REMOTE_ADDR'};
784
1
3
                if($language_name) {
785
0
0
                        if((!defined($self->{_rlanguage})) || ($self->{_rlanguage} eq 'Unknown')) {
786
0
0
                                $self->{_rlanguage} = $language_name;
787                        }
788
0
0
                        unless((exists($self->{_slanguage})) && ($self->{_slanguage} ne 'Unknown')) {
789                                # Check if the language is one that we support
790                                # Don't bother with secondary language
791
0
0
                                my $code;
792
793
0
0
                                if($language_name && $language_code2 && !defined($http_accept_language)) {
794                                        # This sort of thing speeds up search engine access a lot
795
0
0
                                        $self->_debug("Fast assign to $language_code2");
796
0
0
                                        $code = $language_code2;
797                                } else {
798
0
0
                                        $self->_debug("Call language2code on $self->{_rlanguage}");
799
800
0
0
                                        $code = Locale::Language::language2code($self->{_rlanguage});
801
0
0
                                        unless($code) {
802
0
0
                                                if($http_accept_language && ($http_accept_language ne $self->{_rlanguage})) {
803
0
0
                                                        $self->_debug("Call language2code on $http_accept_language");
804
805
0
0
                                                        $code = Locale::Language::language2code($http_accept_language);
806                                                }
807
0
0
                                                unless($code) {
808                                                        # If the language is Norwegian (Nynorsk)
809                                                # lookup Norwegian
810
0
0
                                                if($self->{_rlanguage} =~ /(.+)\s\(.+/) {
811
0
0
                                                                if((!defined($http_accept_language)) || ($1 ne $self->{_rlanguage})) {
812
0
0
                                                                        $self->_debug("Call language2code on $1");
813
814
0
0
                                                                        $code = Locale::Language::language2code($1);
815                                                                }
816                                                        }
817
0
0
                                                        unless($code) {
818
0
0
                                                                $self->_warn({
819                                                                        warning => "Can't determine code from IP $ip for requested language $self->{_rlanguage}"
820                                                                });
821                                                        }
822                                                }
823                                        }
824                                }
825
0
0
                                if($code) {
826
0
0
                                        $self->_get_closest($code, $language_code2);
827
0
0
                                        unless($self->{_slanguage}) {
828
0
0
                                                $self->_warn({
829                                                        warning => "Couldn't determine closest language for $language_name in $self->{_supported}"
830                                                });
831                                        } else {
832
0
0
                                                $self->_debug("language set to $self->{_slanguage}, code set to $code");
833                                        }
834                                }
835                        }
836
0
0
                        if(!defined($self->{_slanguage_code_alpha2})) {
837
0
0
                                $self->_debug("Can't determine slanguage_code_alpha2");
838                        } elsif(!defined($from_cache) && $self->{_cache} &&
839                           defined($self->{_slanguage_code_alpha2})) {
840
0
0
                                $self->_debug("Set $country to $language_name=$self->{_slanguage_code_alpha2}");
841
0
0
                                $self->{_cache}->set(__PACKAGE__ . ':language_name:' . $country, "$language_name=$self->{_slanguage_code_alpha2}", '1 month');
842                        }
843                }
844        }
845}
846
847# Try our very best to give the right country - if they ask for en-us and
848# we only have en-gb then give it to them
849
850# Old code - more readable
851# sub _get_closest {
852        # my ($self, $language_string, $alpha2) = @_;
853#
854        # foreach (@{$self->{_supported}}) {
855                # my $s;
856                # if(/^(.+)-.+/) {
857                        # $s = $1;
858                # } else {
859                        # $s = $_;
860                # }
861                # if($language_string eq $s) {
862                        # $self->{_slanguage} = $self->{_rlanguage};
863                        # $self->{_slanguage_code_alpha2} = $alpha2;
864                        # last;
865                # }
866        # }
867# }
868
869sub _get_closest
870{
871
14
19
        my ($self, $language_string, $alpha2) = @_;
872
873        # Create a hash mapping base languages to their full language codes
874
14
94
14
20
146
18
        my %base_languages = map { /^(.+)-/ ? ($1 => $_) : ($_ => $_) } @{$self->{_supported}};
875
876
14
25
        if(exists($base_languages{$language_string})) {
877
14
16
                $self->{_slanguage} = $self->{_rlanguage};
878
14
23
                $self->{_slanguage_code_alpha2} = $alpha2;
879        }
880}
881
882# What's the language being requested? Can be used in both a class and an object context
883sub _what_language {
884
42
34
        my $self = $_[0];
885
886
42
46
        if(ref($self)) {
887
36
39
                $self->_trace('Entered _what_language');
888
36
423
                if($self->{_what_language}) {
889
8
10
                        $self->_trace('_what_language: returning cached value: ', $self->{_what_language});
890
8
98
                        return $self->{_what_language};      # Useful in case something changes the $info hash
891                }
892
28
40
                if(my $info = $self->{_info}) {
893
0
0
                        if(my $rc = $info->lang()) {
894                                # E.g. cgi-bin/script.cgi?lang=de
895
0
0
                                $self->_trace("_what_language set language to $rc from the lang argument");
896
0
0
                                return $self->{_what_language} = $rc;
897                        }
898                }
899        }
900
901
34
51
        if(my $rc = $ENV{'HTTP_ACCEPT_LANGUAGE'}) {
902
32
38
                if(ref($self)) {
903
26
43
                        return $self->{_what_language} = $rc;
904                }
905
6
8
                return $rc;
906        }
907
908
2
4
        if(defined($ENV{'LANG'})) {
909                # Running the script locally, presumably to debug, so set the language
910                # from the Locale
911
0
0
                if(ref($self)) {
912
0
0
                        return $self->{_what_language} = $ENV{'LANG'};
913                }
914
0
0
                return $ENV{'LANG'};
915        }
916}
917
918 - 927
=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
928
929sub country {
930
14
1159
        my $self = shift;
931
932
14
25
        $self->_trace(__PACKAGE__, ': Entered country()');
933
934        # FIXME: If previous calls to country() return undef, we'll
935        # waste time going through again and no doubt returning undef
936        # again.
937
14
289
        if($self->{_country}) {
938
0
0
                $self->_trace('quick return: ', $self->{_country});
939
0
0
                return $self->{_country};
940        }
941
942        # mod_geoip
943
14
32
        if(defined($ENV{'GEOIP_COUNTRY_CODE'})) {
944
0
0
                $self->{_country} = lc($ENV{'GEOIP_COUNTRY_CODE'});
945
0
0
                return $self->{_country};
946        }
947
14
30
        if(($ENV{'HTTP_CF_IPCOUNTRY'}) && ($ENV{'HTTP_CF_IPCOUNTRY'} ne 'XX')) {
948                # Hosted by Cloudfare
949
2
5
                $self->{_country} = lc($ENV{'HTTP_CF_IPCOUNTRY'});
950
2
5
                return $self->{_country};
951        }
952
953
12
15
        my $ip = $ENV{'REMOTE_ADDR'};
954
955
12
22
        return unless(defined($ip));
956
957
1
192
        require Data::Validate::IP;
958
1
12781
        Data::Validate::IP->import();
959
960
1
2
        if(!is_ipv4($ip)) {
961
0
0
                $self->_debug("$ip isn't IPv4. Is it IPv6?");
962
0
0
                if($ip eq '::1') {
963                        # special case that is easy to handle
964
0
0
                        $ip = '127.0.0.1';
965                } elsif(!is_ipv6($ip)) {
966
0
0
                        $self->_warn({
967                                warning => "$ip isn't a valid IP address"
968                        });
969
0
0
                        return;
970                }
971        }
972
1
17
        if(is_private_ip($ip)) {
973
0
0
                $self->_debug("Can't determine country from LAN connection $ip");
974
0
0
                return;
975        }
976
1
68
        if(is_loopback_ip($ip)) {
977
0
0
                $self->_debug("Can't determine country from loopback connection $ip");
978
0
0
                return;
979        }
980
981
1
45
        if($self->{_cache}) {
982
0
0
                $self->{_country} = $self->{_cache}->get(__PACKAGE__ . ":country:$ip");
983
0
0
                if(defined($self->{_country})) {
984
0
0
                        if($self->{_country} !~ /\D/) {
985
0
0
                                $self->_warn('cache contains a numeric country: ', $self->{_country});
986
0
0
                                $self->{_cache}->remove($ip);
987
0
0
                                delete $self->{_country};    # Seems to be a number
988                        } else {
989
0
0
                                $self->_debug("Get $ip from cache = $self->{_country}");
990
0
0
                                return $self->{_country};
991                        }
992                }
993
0
0
                $self->_debug("$ip isn't in the cache");
994        }
995
996
1
2
        if($self->{_have_ipcountry} == -1) {
997
1
1
1
36
                if(eval { require IP::Country; }) {
998
0
0
                        IP::Country->import();
999
0
0
                        $self->{_have_ipcountry} = 1;
1000
0
0
                        $self->{_ipcountry} = IP::Country::Fast->new();
1001                } else {
1002
1
275
                        $self->{_have_ipcountry} = 0;
1003                }
1004        }
1005
1
3
        $self->_debug("have_ipcountry $self->{_have_ipcountry}");
1006
1007
1
22
        if($self->{_have_ipcountry}) {
1008
0
0
                $self->{_country} = $self->{_ipcountry}->inet_atocc($ip);
1009
0
0
                if($self->{_country}) {
1010
0
0
                        $self->{_country} = lc($self->{_country});
1011                } elsif(is_ipv4($ip)) {
1012                        # Although it doesn't say so, it looks like IP::Country is IPv4 only
1013
0
0
                        $self->_debug("$ip is not known by IP::Country");
1014                }
1015        }
1016
1
2
        unless(defined($self->{_country})) {
1017
1
2
                if($self->{_have_geoip} == -1) {
1018
1
3
                        $self->_load_geoip();
1019                }
1020
1
2
                if($self->{_have_geoip} == 1) {
1021
0
0
                        $self->{_country} = $self->{_geoip}->country_code_by_addr($ip);
1022                }
1023
1024                # FIXME:  45.128.139.41 is broken in Geo::IPFree,
1025                #       see https://github.com/bricas/geo-ipfree/issues/10
1026
1
5
                if(!defined($self->{_country}) && ($ip ne '45.128.139.41')) {
1027
0
0
                        if($self->{_have_geoipfree} == -1) {
1028                                # Don't use 'eval { use ... ' as recommended by Perlcritic
1029                                # See https://www.cpantesters.org/cpan/report/6db47260-389e-11ec-bc66-57723b537541
1030
0
0
                                eval 'require Geo::IPfree';
1031
0
0
                                unless($@) {
1032
0
0
                                        Geo::IPfree::IP->import();
1033
0
0
                                        $self->{_have_geoipfree} = 1;
1034
0
0
                                        $self->{_geoipfree} = Geo::IPfree->new();
1035                                } else {
1036
0
0
                                        $self->{_have_geoipfree} = 0;
1037                                }
1038                        }
1039
0
0
                        if($self->{_have_geoipfree} == 1) {
1040
0
0
                                if(my $country = ($self->{_geoipfree}->LookUp($ip))[0]) {
1041
0
0
                                        $self->{_country} = lc($country);
1042                                }
1043                        }
1044                }
1045        }
1046
1
2
        if($self->{_country} && ($self->{_country} eq 'eu')) {
1047
0
0
                delete($self->{_country});
1048        }
1049
1
2
        if((!$self->{_country}) &&
1050
1
0
27
0
           (eval { require LWP::Simple::WithCache; require JSON::Parse } )) {
1051
0
0
                $self->_debug("Look up $ip on geoplugin");
1052
1053
0
0
                LWP::Simple::WithCache->import();
1054
0
0
                JSON::Parse->import();
1055
1056
0
0
                if(my $data = LWP::Simple::WithCache::get("http://www.geoplugin.net/json.gp?ip=$ip")) {
1057
0
0
                        $self->{_country} = JSON::Parse::parse_json($data)->{'geoplugin_countryCode'};
1058                }
1059        }
1060
1
183
        unless($self->{_country}) {
1061
1
2
                $self->_debug("Look up $ip on Whois");
1062
1063
1
153
                require Net::Whois::IP;
1064
1
4596
                Net::Whois::IP->import();
1065
1066
1
1
                my $whois;
1067
1068
1
1
                eval {
1069                        # Catch connection timeouts to
1070                        # whois.ripe.net by turning the carp
1071                        # into an error
1072
1
0
2
0
                        local $SIG{__WARN__} = sub { die $_[0] };
1073
1
2
                        $whois = Net::Whois::IP::whoisip_query($ip);
1074                };
1075
1
2393521
                unless($@ || !defined($whois) || (ref($whois) ne 'HASH')) {
1076
1
12
                        if(defined($whois->{Country})) {
1077
0
0
                                $self->{_country} = $whois->{Country};
1078                        } elsif(defined($whois->{country})) {
1079
1
55
                                $self->{_country} = $whois->{country};
1080                        }
1081
1
3
                        if($self->{_country}) {
1082
1
4
                                if($self->{_country} eq 'EU') {
1083
0
0
                                        delete($self->{_country});
1084                                } elsif(($self->{_country} eq 'US') && defined($whois->{'StateProv'}) && ($whois->{'StateProv'} eq 'PR')) {
1085                                        # RT#131347: Despite what Whois thinks, Puerto Rico isn't in the US
1086
0
0
                                        $self->{_country} = 'pr';
1087                                }
1088                        }
1089                }
1090
1091
1
1
                if($self->{_country}) {
1092
1
5
                        $self->_debug("Found up $ip on Net::WhoisIP as ", $self->{_country});
1093                } else {
1094
0
0
                        $self->_debug("Look up $ip on IANA");
1095
1096
0
0
                        require Net::Whois::IANA;
1097
0
0
                        Net::Whois::IANA->import();
1098
1099
0
0
                        my $iana = Net::Whois::IANA->new();
1100
0
0
                        eval {
1101
0
0
                                $iana->whois_query(-ip => $ip);
1102                        };
1103
0
0
                        unless ($@) {
1104
0
0
                                $self->{_country} = $iana->country();
1105
0
0
                                $self->_debug("IANA reports $ip as ", $self->{_country});
1106                        }
1107                }
1108
1109
1
43
                if($self->{_country}) {
1110                        # 190.24.1.122 has carriage return in its WHOIS record
1111
1
3
                        $self->{_country} =~ s/[\r\n]//g;
1112
1
7
                        if($self->{_country} =~ /^(..)\s*#/) {
1113                                # Remove comments in the Whois record
1114
0
0
                                $self->{_country} = $1;
1115                        }
1116                }
1117                # TODO - try freegeoip.net if whois has failed
1118        }
1119
1120
1
2
        if($self->{_country}) {
1121
1
3
                if($self->{_country} !~ /\D/) {
1122
0
0
                        $self->_warn('IP matches to a numeric country');
1123
0
0
                        delete $self->{_country};    # Seems to be a number
1124                } else {
1125
1
2
                        $self->{_country} = lc($self->{_country});
1126
1
2
                        if($self->{_country} eq 'hk') {
1127                                # Hong Kong is no longer a country, but Whois thinks
1128                                # it is - try "whois 218.213.130.87"
1129
0
0
                                $self->{_country} = 'cn';
1130                        } elsif($self->{_country} eq 'eu') {
1131
0
0
                                require Net::Subnet;
1132
1133                                # RT-86809, Baidu claims it's in EU not CN
1134
0
0
                                Net::Subnet->import();
1135
0
0
                                if(subnet_matcher('185.10.104.0/22')->($ip)) {
1136
0
0
                                        $self->{_country} = 'cn';
1137                                } else {
1138                                        # There is no country called 'eu'
1139
0
0
                                        $self->_info({
1140                                                warning => "$ip has country of eu"
1141                                        });
1142
0
0
                                        $self->{_country} = 'Unknown';
1143                                }
1144                        }
1145
1146
1
6
                        if($self->{_country} !~ /\D/) {
1147
0
0
                                $self->_warn('cache contains a numeric country: ', $self->{_country});
1148
0
0
                                delete $self->{_country};    # Seems to be a number
1149                        } elsif($self->{_cache}) {
1150
0
0
                                $self->_debug("Set $ip to $self->{_country}");
1151
1152
0
0
                                $self->{_cache}->set(__PACKAGE__ . ":country:$ip", $self->{_country}, '1 hour');
1153                        }
1154                }
1155        }
1156
1157
1
4
        return $self->{_country};
1158}
1159
1160sub _load_geoip
1161{
1162
1
0
        my $self = shift;
1163
1164        # For Windows, see http://www.cpantesters.org/cpan/report/54117bd0-6eaf-1014-8029-ee20cb952333
1165
1
20
        if((($^O eq 'MSWin32') && (-r 'c:/GeoIP/GeoIP.dat')) ||
1166           ((-r '/usr/local/share/GeoIP/GeoIP.dat') || (-r '/usr/share/GeoIP/GeoIP.dat'))) {
1167                # Don't use 'eval { use ... ' as recommended by Perlcritic
1168                # See https://www.cpantesters.org/cpan/report/6db47260-389e-11ec-bc66-57723b537541
1169
0
0
                eval 'require Geo::IP';
1170
0
0
                unless($@) {
1171
0
0
                        Geo::IP->import();
1172
0
0
                        $self->{_have_geoip} = 1;
1173                        # GEOIP_STANDARD = 0, can't use that because you'll
1174                        # get a syntax error
1175
0
0
                        if(-r '/usr/share/GeoIP/GeoIP.dat') {
1176
0
0
                                $self->{_geoip} = Geo::IP->open('/usr/share/GeoIP/GeoIP.dat', 0);
1177                        } else {
1178
0
0
                                $self->{_geoip} = Geo::IP->new(0);
1179                        }
1180                } else {
1181
0
0
                        $self->{_have_geoip} = 0;
1182                }
1183        } else {
1184
1
1
                $self->{_have_geoip} = 0;
1185        }
1186}
1187
1188 - 1202
=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
1203
1204sub locale {
1205
1
1
        my $self = shift;
1206
1207
1
3
        if($self->{_locale}) {
1208
0
0
                return $self->{_locale};
1209        }
1210
1211        # First try from the User Agent.  Probably only works with Mozilla and
1212        # Safari.  I don't know about Opera.  It won't work with IE or Chrome.
1213
1
3
        my $agent = $ENV{'HTTP_USER_AGENT'};
1214
1
1
        my $country;
1215
1
7
        if(defined($agent) && ($agent =~ /\((.+)\)/)) {
1216
1
14
                foreach(split(/;/, $1)) {
1217
5
3
                        my $candidate = $_;
1218
1219
5
7
                        $candidate =~ s/^\s//g;
1220
5
5
                        $candidate =~ s/\s$//g;
1221
5
18
                        if($candidate =~ /^[a-zA-Z]{2}-([a-zA-Z]{2})$/) {
1222
0
0
                                local $SIG{__WARN__} = undef;
1223
0
0
                                if(my $c = $self->_code2country($1)) {
1224
0
0
                                        $self->{_locale} = $c;
1225
0
0
                                        return $c;
1226                                }
1227                                # carp "Warning: unknown country $1 derived from $candidate in HTTP_USER_AGENT ($agent)";
1228                        }
1229                }
1230
1231
1
1
2
347
                if(eval { require HTTP::BrowserDetect; } ) {
1232
1
7185
                        HTTP::BrowserDetect->import();
1233
1
2
                        my $browser = HTTP::BrowserDetect->new($agent);
1234
1235
1
119
                        if($browser && $browser->country() && (my $c = $self->_code2country($browser->country()))) {
1236
1
2
                                $self->{_locale} = $c;
1237
1
7
                                return $c;
1238                        }
1239                }
1240        }
1241
1242        # Try from the IP address
1243
0
0
        $country = $self->country();
1244
1245
0
0
        if($country) {
1246
0
0
                $country =~ s/[\r\n]//g;
1247
1248
0
0
                my $c;
1249
0
0
                eval {
1250
0
0
0
0
                        local $SIG{__WARN__} = sub { die $_[0] };
1251
0
0
                        $c = $self->_code2country($country);
1252                };
1253
0
0
                unless($@) {
1254
0
0
                        if($c) {
1255
0
0
                                $self->{_locale} = $c;
1256
0
0
                                return $c;
1257                        }
1258                }
1259        }
1260
1261        # Try mod_geoip
1262
0
0
        if(defined($ENV{'GEOIP_COUNTRY_CODE'})) {
1263
0
0
                $country = $ENV{'GEOIP_COUNTRY_CODE'};
1264
0
0
                my $c = $self->_code2country($country);
1265
0
0
                if($c) {
1266
0
0
                        $self->{_locale} = $c;
1267
0
0
                        return $c;
1268                }
1269        }
1270
0
0
        return undef;
1271}
1272
1273 - 1280
=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
1281
1282sub time_zone {
1283
0
0
        my $self = shift;
1284
1285
0
0
        $self->_trace('Entered time_zone');
1286
1287
0
0
        if($self->{_timezone}) {
1288
0
0
                $self->_trace('quick return: ', $self->{_timezone});
1289
0
0
                return $self->{_timezone};
1290        }
1291
1292
0
0
        if(my $ip = $ENV{'REMOTE_ADDR'}) {
1293
0
0
                if($self->{_have_geoip} == -1) {
1294
0
0
                        $self->_load_geoip();
1295                }
1296
0
0
                if($self->{_have_geoip} == 1) {
1297
0
0
                        eval {
1298
0
0
                                $self->{_timezone} = $self->{_geoip}->time_zone($ip);
1299                        };
1300                }
1301
0
0
                if(!$self->{_timezone}) {
1302
0
0
0
0
0
0
                        if(eval { require LWP::Simple::WithCache; require JSON::Parse } ) {
1303
0
0
                                $self->_debug("Look up $ip on ip-api.com");
1304
1305
0
0
                                LWP::Simple::WithCache->import();
1306
0
0
                                JSON::Parse->import();
1307
1308
0
0
                                if(my $data = LWP::Simple::WithCache::get("http://ip-api.com/json/$ip")) {
1309
0
0
                                        $self->{_timezone} = JSON::Parse::parse_json($data)->{'timezone'};
1310                                }
1311
0
0
0
0
                        } elsif(eval { require LWP::Simple; require JSON::Parse } ) {
1312
0
0
                                $self->_debug("Look up $ip on ip-api.com");
1313
1314
0
0
                                LWP::Simple->import();
1315
0
0
                                JSON::Parse->import();
1316
1317
0
0
                                if(my $data = LWP::Simple::get("http://ip-api.com/json/$ip")) {
1318
0
0
                                        $self->{_timezone} = JSON::Parse::parse_json($data)->{'timezone'};
1319                                }
1320                        } else {
1321
0
0
                                if(my $logger = $self->{'logger'}) {
1322
0
0
                                        $logger->error('You must have LWP::Simple::WithCache installed to connect to ip-api.com');
1323                                }
1324
0
0
                                Carp::croak('You must have LWP::Simple::WithCache or LWP::Simple installed to connect to ip-api.com');
1325                        }
1326                }
1327        } else {
1328                # Not a remote connection
1329
0
0
                if(open(my $fin, '<', '/etc/timezone')) {
1330
0
0
                        my $tz = <$fin>;
1331
0
0
                        chomp $tz;
1332
0
0
                        $self->{_timezone} = $tz;
1333                } else {
1334
0
0
                        $self->{_timezone} = DateTime::TimeZone::Local->TimeZone()->name();
1335                }
1336        }
1337
1338
0
0
        if(!defined($self->{_timezone})) {
1339
0
0
                $self->_warn("Couldn't determine the timezone");
1340        }
1341
0
0
        return $self->{_timezone};
1342}
1343
1344# Wrapper to Locale::Language::code2language which makes use of the cache
1345sub _code2language
1346{
1347
25
40
        my ($self, $code) = @_;
1348
1349
25
30
        return unless($code);
1350
25
32
        if(defined($self->{_country})) {
1351
2
3
                $self->_debug("_code2language $code, country ", $self->{_country});
1352        } else {
1353
23
24
                $self->_debug("_code2language $code");
1354        }
1355
25
291
        unless($self->{_cache}) {
1356
19
43
                return Locale::Language::code2language($code);
1357        }
1358
6
14
        if(my $from_cache = $self->{_cache}->get(__PACKAGE__ . ":code2language:$code")) {
1359
5
395
                $self->_trace("_code2language found in cache $from_cache");
1360
5
47
                return $from_cache;
1361        }
1362
1
50
        $self->_trace('_code2language not in cache, storing');
1363
1
13
        return $self->{_cache}->set(__PACKAGE__ . ":code2language:$code", Locale::Language::code2language($code), '1 month');
1364}
1365
1366# Wrapper to Locale::Object::Country allowing for persistence to be added
1367sub _code2country
1368{
1369
19
86
        my ($self, $code) = @_;
1370
1371
19
27
        return unless($code);
1372
19
28
        if($self->{_country}) {
1373
2
3
                $self->_trace(">_code2country $code, country ", $self->{_country});
1374        } else {
1375
17
25
                $self->_trace(">_code2country $code");
1376        }
1377        local $SIG{__WARN__} = sub {
1378
1
363
                if($_[0] !~ /No result found in country table/) {
1379
0
0
                        warn $_[0];
1380                }
1381
19
288
        };
1382
19
95
        my $rc = Locale::Object::Country->new(code_alpha2 => $code);
1383
19
1246663
        local $SIG{__WARN__} = 'DEFAULT';
1384
19
63
        $self->_trace('<_code2country ', $code || 'undef');
1385
19
402
        return $rc;
1386}
1387
1388# Wrapper to Locale::Object::Country->name which makes use of the cache
1389sub _code2countryname
1390{
1391
16
21
        my ($self, $code) = @_;
1392
1393
16
24
        return unless($code);
1394
16
32
        $self->_trace(">_code2countryname $code");
1395
16
261
        unless($self->{_cache}) {
1396
12
22
                my $country = $self->_code2country($code);
1397
12
22
                if(defined($country)) {
1398
12
23
                        return $country->name;
1399                }
1400
0
0
                return;
1401        }
1402
4
8
        if(my $from_cache = $self->{_cache}->get(__PACKAGE__ . ":code2countryname:$code")) {
1403
2
118
                $self->_trace("_code2countryname found in cache $from_cache");
1404
2
18
                return $from_cache;
1405        }
1406
2
112
        if(my $country = $self->_code2country($code)) {
1407
2
5
                $self->_debug('_code2countryname not in cache, storing');
1408
2
21
                $self->_trace('<_code2countryname ', $country->name());
1409
2
35
                return $self->{_cache}->set(__PACKAGE__ . ":code2countryname:$code", $country->name(), '1 month');
1410        }
1411
0
0
        $self->_trace('<_code2countryname undef');
1412}
1413
1414# Log and remember a message
1415sub _log
1416{
1417
428
395
        my ($self, $level, @messages) = @_;
1418
1419
428
582
        if(ref($self) && scalar(@messages)) {
1420                # FIXME: add caller's function
1421                # if(($level eq 'warn') || ($level eq 'info')) {
1422
428
428
188
758
                        push @{$self->{'messages'}}, { level => $level, message => join('', grep defined, @messages) };
1423                # }
1424
1425
428
419
                if(my $logger = $self->{'logger'}) {
1426
428
636
                        $self->{'logger'}->$level(join('', grep defined, @messages));
1427                }
1428        }
1429}
1430
1431sub _debug {
1432
220
132
        my $self = shift;
1433
220
187
        $self->_log('debug', @_);
1434}
1435
1436sub _info {
1437
0
0
        my $self = shift;
1438
0
0
        $self->_log('info', @_);
1439}
1440
1441sub _notice {
1442
1
1
        my $self = shift;
1443
1
2
        $self->_log('notice', @_);
1444}
1445
1446sub _trace {
1447
207
150
        my $self = shift;
1448
207
202
        $self->_log('trace', @_);
1449}
1450
1451# Emit a warning message somewhere
1452sub _warn
1453{
1454
0
        my $self = shift;
1455
0
        if(defined($self->{'logger'})) {
1456
0
                $self->{'logger'}->warn(\@_);
1457        } else {
1458                # This shouldn't happen, since Object::Configure always sets something
1459
0
                my $params = Params::Get::get_params('warning', @_);
1460
1461
0
                $self->_log('warn', $params->{'warning'});
1462
0
                Carp::carp($params->{'warning'});
1463        }
1464}
1465
1466 - 1544
=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
1545
15461; # End of CGI::Lingua