view release on metacpan or  search on metacpan

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

    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.

=head3 API SPECIFICATION

    Input:
      supported  => ArrayRef[Str] | Str   # required; RFC-1766 language codes
      cache      => Object                # optional; CHI-compatible (get/set)
      config_file => Str                  # optional; YAML/XML/INI config path
      logger     => Object                # optional; must implement warn/info/error
      info       => Object                # optional; CGI::Info-compatible
      data       => Any                   # optional; forwarded to I18N::AcceptLanguage
      dont_use_ip => Bool                 # optional; disable IP-based fallback
      syslog     => Bool | HashRef        # optional; Sys::Syslog integration
      debug      => Bool                  # optional; enable debug logging

    Returns: CGI::Lingua blessed hashref, or a clone when called on an object.

=head3 MESSAGES

    "You must give a list of supported languages"  - no 'supported' key provided
    "List of supported languages must be an array ref" - supported is wrong ref type
    "Supported languages must be the short code"  - string too short or too long
    "Logger must be a blessed object with warn/info/error methods" - bad logger arg

=head3 PSEUDOCODE

    1. Normalise args via Params::Get and Object::Configure
    2. Validate logger (must be blessed with warn/info/error) if provided
    3. Validate supported (required, string or arrayref)
    4. If cache and REMOTE_ADDR set, attempt to thaw a previously stored state
    5. Bless and return fresh object with sentinel flags set to GEO_UNKNOWN

=cut

sub new
{
	my $class = shift;
	my $params = Params::Get::get_params('supported', @_);

	# Handle ::new() misuse
	if(!defined($class)) {
		if($params) {
			if(my $logger = $params->{'logger'}) {
				$logger->error(__PACKAGE__ . ' use ->new() not ::new() to instantiate');
			}
			croak(__PACKAGE__ . ' use ->new() not ::new() to instantiate');
		}
		$class = __PACKAGE__;
	} elsif(ref($class)) {
		# Clone: overlay new params onto existing object state
		$params->{_supported} ||= $params->{supported} if defined $params->{'supported'};
		return bless { %{$class}, %{$params} }, ref($class);
	}

	# Validate blessed logger objects before Object::Configure runs.
	# Non-blessed values (arrayrefs, hashrefs) are valid config forms that
	# Object::Configure knows how to convert into a Log::Abstraction instance.
	if(defined $params->{'logger'} && blessed($params->{'logger'})) {
		unless(
			$params->{'logger'}->can('warn')
			&& $params->{'logger'}->can('info')
			&& $params->{'logger'}->can('error')
		) {
			croak('Logger must be a blessed object with warn/info/error methods');
		}
	}

	$params = Object::Configure::configure($class, $params);

	# Normalise supported / supported_languages alias
	$params->{'supported'} ||= $params->{'supported_languages'};
	if(defined($params->{supported})) {
		# Validate supported type/length
		if(ref($params->{supported})) {
			if(ref($params->{supported}) ne 'ARRAY') {
				croak('List of supported languages must be an array ref');
			}
		} elsif((length($params->{supported}) < 2) || (length($params->{supported}) > 5)) {
			croak('Supported languages must be the short code');
		}
	} else {
		if(my $logger = $params->{'logger'}) {
			$logger->error('You must give a list of supported languages');
		}
		croak('You must give a list of supported languages');
	}

	my $cache = $params->{cache};
	my $info  = $params->{info};

	# Try to restore a frozen state from the cache before doing any work
	if($cache && $ENV{'REMOTE_ADDR'}) {
		my $key = _build_cache_key($ENV{'REMOTE_ADDR'}, $params, $class, $info);
		if(my $rc = $cache->get($key)) {
			$rc = Storable::thaw($rc);
			# Re-inject transient/non-serialisable fields
			$rc->{logger}           = $params->{'logger'};
			$rc->{_syslog}          = $params->{syslog};
			$rc->{_cache}           = $cache;
			$rc->{_supported}       = $params->{supported};
			$rc->{_info}            = $info;
			$rc->{_have_ipcountry}  = $GEO_UNKNOWN;
			$rc->{_have_geoip}      = $GEO_UNKNOWN;
			$rc->{_have_geoipfree}  = $GEO_UNKNOWN;

			# If lang= CGI param is active, the cached language choice may be stale
			if(($rc->{_what_language} || $rc->{_rlanguage}) && $info && $info->lang()) {
				delete @{$rc}{qw(_what_language _rlanguage _country)};
			}
			return $rc;