view release on metacpan or  search on metacpan

lib/MasonX/Resolver/Polyglot.pm  view on Meta::CPAN

Like our aformentioned English/Spanish site, we have an English index.html, and a Spanish index.html.es.  My site wants to provide the ability to choose the site language without mucking with the brower's language preference.
In my index.html, I have a "Spanish" link which links to "/es/index.html", and an "English" link in my index.html.es that links to "/index.html".  I make all other links in the site _relative_.

The effect this has is to propagate the /es/ prefix, consistantly overriding the browser's language preference until the user clicks on an absolute URL.

Polyglot now makes its language decision order array available through the Apache request pnotes() interface as an array ref.
If you call:

    my @langs   = @{$r->pnotes('POLYGLOT_LANGS')};

@langs will contain a ranked list of language preference.

It makes the language decision it made available by:

    my $lang    =   $r->pnotes('POLYGLOT_LANG');

And also, the original pre-language-stripped URI available like so:

    my $origuri =   $r->pnotes('POLYGLOT_URI')

=cut

package MasonX::Resolver::Polyglot;
$VERSION = q(0.95);

use strict;

# We need this, since our parent is embedded in the HTML::Mason::ApacheHandler file
use HTML::Mason::ApacheHandler;
use base qw(HTML::Mason::Resolver::File);

use HTML::Mason::Tools qw(paths_eq);
use Locale::Language qw(code2language);
use Locale::Country  qw(LOCALE_CODE_ALPHA_2 LOCALE_CODE_ALPHA_3 code2country);
use Apache::Constants;

my $DEBUG = 0;
# This is the name of the env variable that uri_override uses
my $POLYGLOT_LANG       = q(POLYGLOT_LANG);
my $PolyglotDefaultLang = q(PolyglotDefaultLang);
my $PolyglotDefaultURILang = q(PolyglotDefaultURILang);

sub new{
    my $class = shift;
    my $self = $class->SUPER::new(@_);
    $self->{default_lang} = lc Apache->request->dir_config($PolyglotDefaultLang);
    $self->{default_uri_lang} = lc Apache->request->dir_config($PolyglotDefaultURILang);
    return $self;
}    

sub get_info{
    my ($self, $path, $comp_root_key, $comp_root_path) = @_;
    
    # Is this already stored somewhere I can grab it?
    # I suspect this is wasteful.
    my $r = Apache->request;
    
    $DEBUG && $r->log_error(qq(URI:) . $r->uri . qq(, path: $path)); 
    $DEBUG && $r->log_error(qq(Header says: ), $r->header_in('Accept-Language'));
    # Get a ranked list of language prefs based on the Accept-Language and URI
    # everything in get_langs will need an $r
    $self->{r} = $r;
    my @langs = @{$self->get_langs(\$path)};
    $DEBUG && $r->log_error("Languages Accepted: ", join(",", @langs));
    delete $self->{r};
 
    # If we have a default language set, then "" gets spliced in 
    #  immediately after that language in the pref list.

    if($self->{default_lang}){
	for(0..$#langs){
	    if($langs[$_] eq $self->{default_lang}){
		splice(@langs, $_+1, 0, "");
	    }
	}
    }
	
    # No matter what, lastly look for the "pure" version
    push @langs, ""; # so we check a no extension lang last
    
     # CHECK to see if any exist in filesystem
    my $comp;

    # Make language order available through $r->pnotes
    my @POLYGLOT_LANGS = @langs;
    $r->pnotes('POLYGLOT_LANGS', \@POLYGLOT_LANGS);
    while(defined ($_ = shift @langs)){
        $DEBUG && $r->log_error(join("", $path, $_?('.', $_):""), $comp_root_key, $comp_root_path);
	if($comp = $self->SUPER::get_info(join("", $path, $_?('.', $_):""), $comp_root_key, $comp_root_path)){
	    $DEBUG && $r->log_error("picked '$_'");
	    return $comp;
	}
    }
    return;
}

=head1 METHODS

=over 4

=cut

# This resolver has a few new methods that it uses internally to determine what component to choose.
#=item get_langs
#This stores and returns a ranked list of components to try, using the URL and the client's language preferences to order them.  
#=cut

sub get_langs{
    my ($self, $path) = @_;
    # path is a scalar ref to the path that was fed to the resolver

    my %Accept;
    $self->_get_client_pref(\%Accept);
    # URL overrides browser
    $self->_get_env_pref(\%Accept);
    my @langs = sort { $Accept{$b}{q} <=> $Accept{$a}{q} } keys %Accept;
    $self->{langs} = \@langs;
}