File Coverage

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

linestmtbrancondsubtimecode
1package CGI::Lingua;
2
3
19
19
19
1141102
16
398
use warnings;
4
19
19
19
29
12
204
use strict;
5
6
19
19
19
3366
875971
298
use Object::Configure 0.14;
7
19
19
19
52
85
268
use Params::Get 0.13;
8
19
19
19
31
14
396
use Storable; # RT117983
9
19
19
19
4377
58806
67
use Class::Autouse qw{Carp Locale::Language Locale::Object::Country Locale::Object::DB I18N::AcceptLanguage I18N::LangTags::Detect};
10
11our $VERSION = '0.79';
12
13 - 21
=head1 NAME

CGI::Lingua - Create a multilingual web page

=head1 VERSION

Version 0.79

=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>,
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
40
1993607
        my $class = shift;
166
40
101
        my $params = Params::Get::get_params('supported', @_);
167
168
39
823
        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
70
        $params = Object::Configure::configure($class, $params);
186
187        # Validate logger object has required methods
188
39
336844
        if(defined $params->{'logger'}) {
189
39
157
                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
1361
        $params->{'supported'} ||= $params->{'supported_languages'};
199
39
52
        unless($params->{supported}) {
200
2
3
                if(my $logger = $params->{'logger'}) {
201
2
3
                        $logger->error('You must give a list of supported languages');
202                }
203
2
2149
                Carp::croak('You must give a list of supported languages');
204        }
205
206
38
283
        my $cache = $params->{cache};
207
38
30
        my $info = $params->{info};
208
209
38
54
        if($cache && $ENV{'REMOTE_ADDR'}) {
210
6
5
                my $key = "$ENV{REMOTE_ADDR}/";
211
6
4
                my $l;
212
6
13
                if($info && ($l = $info->lang())) {
213
0
0
                        $key .= "$l/";
214                } elsif($l = $class->_what_language()) {
215
6
7
                        $key .= "$l/";
216                }
217
6
7
                if(ref($params->{'supported'} eq 'ARRAY')) {
218
0
0
0
0
                        $key .= join('/', @{$params->{supported}});
219                } else {
220
6
8
                        $key .= $params->{'supported'};
221                }
222                # if($logger) {
223                        # $self->debug("Looking in cache for $key");
224                # }
225
6
11
                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
240
0
0
                        if(($rc->{_what_language} || $rc->{_rlanguage}) && $info && $info->lang()) {
241
0
0
                                delete $rc->{_what_language};
242
0
0
                                delete $rc->{_rlanguage};
243
0
0
                                delete $rc->{_country};
244                        }
245
0
0
                        return $rc;
246                }
247        }
248
249        return bless {
250
38
317
                %{$params},
251                _supported => ref($params->{supported}) ? $params->{supported} : [ $params->{'supported'} ], # List of languages (two letters) that the application
252                _cache => $cache,    # CHI
253                _info => $info,
254                # _rlanguage => undef,       # Requested language
255                # _slanguage => undef,       # Language that the website should display
256                # _sublanguage => undef,     # E.g. United States for en-US if you want American English
257                # _slanguage_code_alpha2 => undef, # E.g en, fr
258                # _sublanguage_code_alpha2 => undef, # E.g. us, gb
259                # _country => undef, # Two letters, e.g. gb
260                # _locale => undef,  # Locale::Object::Country
261                _syslog => $params->{syslog},
262                _dont_use_ip => $params->{dont_use_ip} || 0,
263                _have_ipcountry => -1,       # -1 = don't know
264                _have_geoip => -1,   # -1 = don't know
265                _have_geoipfree => -1,       # -1 = don't know
266
38
295
                _debug => $params->{debug} || 0,
267        }, $class;
268}
269
270# Some of the information takes a long time to work out, so cache what we can
271sub DESTROY {
272
44
19328
        if(defined($^V) && ($^V ge 'v5.14.0')) {
273
44
73
                return if ${^GLOBAL_PHASE} eq 'DESTRUCT';       # >= 5.14.0 only
274        }
275
44
85
        unless($ENV{'REMOTE_ADDR'}) {
276
17
93
                return;
277        }
278
27
25
        my $self = shift;
279
27
29
        return unless(ref($self));
280
281
27
30
        my $cache = $self->{_cache};
282
27
127
        return unless($cache);
283
284
6
5
        my $key = "$ENV{REMOTE_ADDR}/";
285
6
6
        if(my $l = $self->_what_language()) {
286
6
5
                $key .= "$l/";
287        }
288
6
6
5
7
        $key .= join('/', @{$self->{_supported}});
289
6
9
        return if($cache->get($key));
290
291
6
229
        $self->_debug("Storing self in cache as $key");
292
293        my $copy = bless {
294                _slanguage => $self->{_slanguage},
295                _slanguage_code_alpha2 => $self->{_slanguage_code_alpha2},
296                _sublanguage_code_alpha2 => $self->{_sublanguage_code_alpha2},
297                _country => $self->{_country},
298                _rlanguage => $self->{_rlanguage},
299                _dont_use_ip => $self->{_dont_use_ip},
300                _have_ipcountry => $self->{_have_ipcountry},
301                _have_geoip => $self->{_have_geoip},
302                _have_geoipfree => $self->{_have_geoipfree},
303
6
74
        }, ref($self);
304
305        # All of these crash, presumably something recursive is going on
306        # my $copy = Clone::clone($self);
307        # my $storable = Storable::nfreeze(Storable::dclone($self));
308        # my $storable = Storable::dclone($self);
309
310
6
9
        $cache->set($key, Storable::nfreeze($copy), '1 month');
311}
312
313
314 - 339
=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
340
341sub language {
342
22
2882
        my $self = $_[0];
343
344
22
31
        unless($self->{_slanguage}) {
345
15
16
                $self->_find_language();
346        }
347
22
51
        return $self->{_slanguage};
348}
349
350 - 354
=head2 preferred_language

Same as language().

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

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

=cut
368
369sub name {
370
0
0
        my $self = $_[0];
371
372
0
0
        return $self->language();
373}
374
375 - 383
=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
384
385sub sublanguage {
386
21
22
        my $self = $_[0];
387
388
21
24
        $self->_trace('Entered sublanguage');
389
21
318
        unless($self->{_slanguage}) {
390
1
2
                $self->_find_language();
391        }
392
21
40
        $self->_trace('Leaving sublanguage ', ($self->{_sublanguage} || 'undef'));
393
21
291
        return $self->{_sublanguage};
394}
395
396 - 404
=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
405
406sub language_code_alpha2 {
407
8
5
        my $self = $_[0];
408
409
8
10
        $self->_trace('Entered language_code_alpha2');
410
8
127
        unless($self->{_slanguage}) {
411
1
6
                $self->_find_language();
412        }
413
8
12
        $self->_trace('language_code_alpha2 returns ', $self->{_slanguage_code_alpha2});
414
8
118
        return $self->{_slanguage_code_alpha2};
415}
416
417 - 421
=head2 code_alpha2

Synonym for language_code_alpha2, kept for historical reasons.

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

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

=item * L<HTTP::BrowserDetect>

=item * L<I18N::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-2025 Nigel Horne.

This program is released under the following licence: GPL2

=cut
1538
15391; # End of CGI::Lingua