view release on metacpan or  search on metacpan

lib/CGI/Lingua.pm  view on Meta::CPAN

	my $in_baidu;
	if(eval { require Net::Subnet; Net::Subnet->import(); 1 }) {
		$in_baidu = subnet_matcher($BAIDU_SUBNET)->($ip);
	} else {
		$in_baidu = _in_baidu_subnet($ip);
	}

	if($in_baidu) {
		$self->{_country} = 'cn';
	} else {
		$self->_info("$ip has country of eu");
		$self->{_country} = 'Unknown';
	}
}

# ── _load_geoip ───────────────────────────────────────────────────────────
# Purpose:      Probe for the Geo::IP database file and the Geo::IP module;
#               set _have_geoip and initialise _geoip on success.
# Entry:        _have_geoip must be GEO_UNKNOWN.
# Exit:         _have_geoip set to GEO_PRESENT or GEO_ABSENT.
# Side Effects: Requires Geo::IP; opens GeoIP.dat.
sub _load_geoip
{
	my $self = shift;

	# Check for the database file before even trying to load the module
	# (avoids noisy errors on Windows — CPANTESTERS report 54117bd0)
	my $db_present = (
		(($^O eq 'MSWin32') && (-r 'c:/GeoIP/GeoIP.dat'))
		|| (-r '/usr/local/share/GeoIP/GeoIP.dat')
		|| (-r '/usr/share/GeoIP/GeoIP.dat')
	);

	unless($db_present) {
		$self->{_have_geoip} = $GEO_ABSENT;
		return;
	}

	eval { require Geo::IP };
	if($@) {
		$self->{_have_geoip} = $GEO_ABSENT;
		return;
	}

	# No ->import(): Geo::IP->open() and Geo::IP->new() are class methods; import unneeded.
	$self->{_have_geoip} = $GEO_PRESENT;

	# GEOIP_STANDARD = 0 (can't use the constant name directly)
	if(-r '/usr/share/GeoIP/GeoIP.dat') {
		$self->{_geoip} = Geo::IP->open('/usr/share/GeoIP/GeoIP.dat', 0);
	} else {
		$self->{_geoip} = Geo::IP->new(0);
	}
}

=head2 locale

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

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

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

=head3 EXAMPLE

    local $ENV{REMOTE_ADDR} = '8.8.8.8';
    my $locale = $l->locale();
    if (defined $locale) {
        print $locale->name();          # e.g. "United States"
        print $locale->currency_code(); # e.g. "USD"
    }

=head3 API SPECIFICATION

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

=head3 PSEUDOCODE

    1. Return cached _locale immediately if already computed
    2. Parse HTTP_USER_AGENT parenthetical for xx-YY language tag
    3. Try HTTP::BrowserDetect on the full User-Agent string
    4. Fall back to country() IP lookup
    5. Fall back to GEOIP_COUNTRY_CODE env var (ISO 3166-1 validated)
    6. Return undef if all strategies fail

=cut

sub locale {
	my $self = shift;

	return $self->{_locale} if $self->{_locale};

	# Validate and untaint HTTP_USER_AGENT before passing to any parser.
	# The User-Agent header is attacker-controlled; apply the same discipline
	# as HTTP_ACCEPT_LANGUAGE.  Printable ASCII (0x20-0x7e), bounded length.
	my $agent;
	if(defined(my $raw_agent = $ENV{'HTTP_USER_AGENT'})) {
		if($raw_agent =~ /^([\x20-\x7e]{1,$UA_MAX})$/a) {
			$agent = $1;    # untainted
		} else {
			$self->_warn({ warning => 'HTTP_USER_AGENT contains invalid characters or exceeds length limit; ignoring' });
		}
	}

	# First try: parse the language tag from the User-Agent parenthetical
	if(defined($agent) && ($agent =~ /\((.+)\)/)) {
		foreach(split(/;/, $1)) {
			my $candidate = $_;
			$candidate =~ s/^\s+|\s+$//g;    # trim both ends

			if($candidate =~ /^[a-zA-Z]{2}-([a-zA-Z]{2})$/) {
				local $SIG{__WARN__} = undef;
				if(my $c = $self->_code2country($1)) {
					$self->{_locale} = $c;
					return $c;
				}
			}
		}

lib/CGI/Lingua.pm  view on Meta::CPAN

=item * CPAN Testers' Matrix

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

=item * CPAN Testers Dependencies

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

=back

=encoding utf-8

=head1 FORMAL SPECIFICATION

=head2 new

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

=head2 language

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

=head2 sublanguage

    sublanguage : CGI::Lingua -> Str | undef
    result = country_name(sublanguage_code_alpha2(self))
             when sublanguage_code_alpha2(self) is defined,
             undef otherwise

=head2 language_code_alpha2

    language_code_alpha2 : CGI::Lingua -> Str(2) | undef
    result = base_code(matched_supported_entry)
             when a supported language was matched, undef otherwise

=head2 sublanguage_code_alpha2

    sublanguage_code_alpha2 : CGI::Lingua -> Str(2) | undef
    result = variety_code(matched_supported_entry) | undef

=head2 requested_language

    requested_language : CGI::Lingua -> Str
    result = name(base) + " (" + name(variety) + ")"
             when variety is known,
           = name(base)   when no variety,
           = 'Unknown'    when no language detected

=head2 country

    country : CGI::Lingua -> Str(2,lowercase) | undef
    -- 'Unknown' returned only in the EU/Baidu special case
    result = lc(code) where code satisfies ISO 3166-1 alpha-2
             | undef when IP is private, loopback, or unresolvable

=head2 locale

    locale : CGI::Lingua -> Locale::Object::Country | undef
    -- Best-guess detection; not guaranteed accurate.
    result = first defined value from:
        1. UA parenthetical language tag
        2. HTTP::BrowserDetect country
        3. country() IP lookup
        4. GEOIP_COUNTRY_CODE env var

=head2 time_zone

    time_zone : CGI::Lingua -> Str | undef
    result is an IANA timezone name (e.g. 'Europe/London') or undef

=head2 is_rtl

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

=head2 text_direction

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

=head2 plural_category

    plural_category : CGI::Lingua x N -> PluralCategory
    plural_category(s, n) = PLURAL_RULES[language_code_alpha2(s)](trunc(n))
    -- Falls back to English rule (n=1 -> 'one'; else 'other')
    -- when language_code_alpha2(s) is undef or not in the rules table.

=head2 translation_file

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

=head1 ACKNOWLEDGEMENTS

=head1 LICENSE AND COPYRIGHT

Copyright 2010-2026 Nigel Horne.

Usage is subject to the GPL2 licence terms.
If you use it,
please let me know.

=cut

1; # End of CGI::Lingua