view release on metacpan or  search on metacpan

lib/Apache/LangPrefCookie.pm  view on Meta::CPAN

package Apache::LangPrefCookie;

use strict;
use warnings;

use Apache::Constants qw(OK DECLINED);
use Apache::Request;
use Apache::Cookie;
use Apache::Log ();

our $VERSION = '1.03';

sub handler {
    my $r           = Apache::Request->new(shift);
    my %cookies     = Apache::Cookie->new($r)->parse;
    my $cookie_name = $r->dir_config('LangPrefCookieName') || 'prefer-language';
    my @ua_lang_prefs;

    # $r->log->debug("Looking for cookie: \"$cookie_name\"");

    $r->header_out( 'Vary',
                    $r->header_out('Vary') ? $r->header_out('Vary') . 'cookie'
                    :                        'cookie'
        );

    # if we have no cookie, this is none of our business
    return DECLINED
      unless exists $cookies{$cookie_name}
          and my $cookie_pref_lang = $cookies{$cookie_name}->value();

    # dont parse an empty header just to get "Use of uninitialized value
    # in" warnings
    if ( defined $r->header_in("Accept-Language")
        and length $r->header_in("Accept-Language") )
    {
        @ua_lang_prefs =
          parse_accept_language_header( $r->header_in("Accept-Language") );
    }
    else {

        # RFC 2616 states: "If no Accept-Language header is present in
        # the request, the server SHOULD assume that all languages are
        # equally acceptable."  Since we are going to fool httpd into
        # thinking there is one, we respect the original demand by
        # inserting '*'.
        @ua_lang_prefs = q/*/;
    }

    # Now: unless the cookie wants a language that would be the
    # best matching anyway, rebuild the list of language-ranges
    unless ( $cookie_pref_lang eq $ua_lang_prefs[0] ) {
        my ( $qvalue, $language_ranges ) = ( 1, '' );
        map {
            if (m/^(?:\w{1,8}(?:-\w{1,8})*|\*)$/)
            {
                $language_ranges .= "$_;q=$qvalue, ";
                $qvalue *= .9;
            }
        } ( $cookie_pref_lang, @ua_lang_prefs );
        $language_ranges =~ s/,\s*$//;
        return DECLINED unless length $language_ranges;
        $r->header_in( "Accept-Language", $language_ranges );
        $r->log->debug(
"Cookie \"$cookie_name\" requested \"$cookie_pref_lang\", set \"Accept-Language: $language_ranges\""
        );
    }
    return OK;
}

# taken and modified from Philippe M. Chiasson's Apache::Language;
# later, Aldo Calpini (dada) showed how to get rid of $`
# returns a sorted (from most to least acceptable) list of languages.
sub parse_accept_language_header {
    my $language_ranges = shift;
    my $value           = 1;
    my %pairs;
    foreach ( split( /,/, $language_ranges ) ) {
        s/\s//g;    #strip spaces
        next unless length;
        if (m/(.*?);q=([\d\.]+)/) {

            #is it in the "en;q=0.4" form ?
            $pairs{ lc $1 } = $2 if $2 > 0;
        }
        else {

            #give the first one a q of 1
            $pairs{ lc $_ } = $value;

            #and the others .001 less every time
            $value -= 0.001;
        }
    }
    return sort { $pairs{$b} <=> $pairs{$a} } keys %pairs;
}

1;
__END__

=head1 NAME

Apache::LangPrefCookie - implant a language-preference given by
cookie into httpd's representation of the Accept-Language HTTP-header.

=head1 SYNOPSIS

  <Location />
     PerlInitHandler  Apache::LangPrefCookie
  </Location>

  <Location /foo>
     # optionally set a custom cookie-name, default is "prefer-language"
     PerlSetVar LangPrefCookieName "foo-pref"
  </Location>


=head1 DESCRIPTION

This module looks for a cookie providing a language-code as its value.