File Coverage

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

linestmtbrancondsubtimecode
1package CGI::Lingua;
2
3
19
19
19
1258259
15
437
use warnings;
4
19
19
19
31
14
207
use strict;
5
6
19
19
19
3408
816742
299
use Object::Configure 0.14;
7
19
19
19
50
95
275
use Params::Get 0.13;
8
19
19
19
30
12
411
use Storable; # RT117983
9
19
19
19
4362
59080
71
use Class::Autouse qw{Carp Locale::Language Locale::Object::Country Locale::Object::DB I18N::AcceptLanguage I18N::LangTags::Detect};
10
11our $VERSION = '0.77';
12
13 - 21
=head1 NAME

CGI::Lingua - Create a multilingual web page

=head1 VERSION

Version 0.77

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

Same as language().

=cut
346
347sub preferred_language
348{
349
1
2
        my $self = shift;
350
351
1
2
        $self->language(@_);
352}
353
354 - 358
=head2 name

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

=cut
359
360sub name {
361
1
1
        my $self = shift;
362
363
1
2
        return $self->language();
364}
365
366 - 374
=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
375
376sub sublanguage {
377
21
25
        my $self = shift;
378
379
21
27
        $self->_trace('Entered sublanguage');
380
21
350
        unless($self->{_slanguage}) {
381
1
2
                $self->_find_language();
382        }
383
21
45
        $self->_trace('Leaving sublanguage ', ($self->{_sublanguage} || 'undef'));
384
21
304
        return $self->{_sublanguage};
385}
386
387 - 395
=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
396
397sub language_code_alpha2 {
398
8
6
        my $self = shift;
399
400
8
10
        $self->_trace('Entered language_code_alpha2');
401
8
141
        unless($self->{_slanguage}) {
402
1
6
                $self->_find_language();
403        }
404
8
14
        $self->_trace('language_code_alpha2 returns ', $self->{_slanguage_code_alpha2});
405
8
118
        return $self->{_slanguage_code_alpha2};
406}
407
408 - 412
=head2 code_alpha2

Synonym for language_code_alpha2, kept for historical reasons.

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