File Coverage

blib/lib/HTTP/AcceptLanguage.pm

Criterion	Covered	Total	%
statement	84	84	100.0
branch	40	40	100.0
condition	9	12	75.0
subroutine	10	10	100.0
pod	3	3	100.0
total	146	149	97.9

package HTTP::AcceptLanguage;
use strict;
use warnings;
use 5.008_005;
our $VERSION = '0.02';

our $MATCH_PRIORITY_0_01_STYLE;

my $LANGUAGE_RANGE = qr/(?:[A-Za-z0-9]{1,8}(?:-[A-Za-z0-9]{1,8})*|\*)/;
my $QVALUE         = qr/(?:0(?:\.[0-9]{0,3})?|1(?:\.0{0,3})?)/;

sub new {
    my($class, $header) = @_;

    my @parsed_header;
    if ($header) {
        @parsed_header = $class->_parse($header);
    }

    bless {
        header        => $header,
        parsed_header => \@parsed_header,
    }, $class;
}

sub _parse {
    my($class, $header) = @_;
    $header =~ s/\s//g; #loose

    my @elements;
    my %high_qualities;
    for my $element (split /,+/, $header) {
        my($language, $quality) = $element =~ /\A($LANGUAGE_RANGE)(?:;q=($QVALUE))?\z/;
        $quality = 1 unless defined $quality;
        next unless $language && $quality > 0;

        my($primary) = split /-/, $language;
        push @elements, {
            language            => $language,
            language_primary_lc => lc($primary),
            language_lc         => lc($language),
            quality             => $quality,
        };
        if ((not exists $high_qualities{$language}) || $quality >  $high_qualities{$language}) {
            $high_qualities{$language} = $quality;
        }
    }

    # RFC2616: The language quality factor assigned to a language-tag by the Accept-Language field is the quality value of the longest language- range in the field that matches the language-tag.
    grep {
        my $language = $_->{language};
        $high_qualities{$language} ? (
            $high_qualities{$language} == $_->{quality} ? delete $high_qualities{$language} : 0
        ) : 0;
    } @elements;
}

sub languages {
    my $self = shift;
    $self->{languages} ||= do {
        use sort 'stable';
        my @languages = map { $_->{language} } sort { $b->{quality} <=> $a->{quality} } @{ $self->{parsed_header} };
        \@languages;
    };
    @{ $self->{languages} };
}

sub match {
    my($self, @languages) = @_;
    my @normlized_languages = map {
        $_ ? ( +{
            tag    => $_,
            tag_lc => lc($_),
        } ) : ()
    } @languages;
    return undef unless scalar(@normlized_languages);

    unless (scalar(@{ $self->{parsed_header} })) {
        # RFC2616: SHOULD assume that all languages are equally acceptable. If an Accept-Language header is present, then all languages which are assigned a quality factor greater than 0 are acceptable.
        return $normlized_languages[0]->{tag};
    }

    $self->{sorted_parsed_header} ||= do {
        use sort 'stable';
        [ sort { $b->{quality} <=> $a->{quality} } @{ $self->{parsed_header} } ];
    };

    # If language-quality has the same value, is a priority order of the $self->{sorted_parsed_header}.
    # If you set $MATCH_PRIORITY_0_01_STYLE=1, takes is a priority order of the @languages
    if ($MATCH_PRIORITY_0_01_STYLE) {
        my %header_tags;
        my %header_primary_tags;
        my $detect_langguage = sub {
            if (scalar(%header_tags)) {
                # RFC give priority to full match.
                for my $tag (@normlized_languages) {
                    return $tag->{tag} if $header_tags{$tag->{tag_lc}};
                }
                for my $tag (@normlized_languages) {
                    return $tag->{tag} if $header_primary_tags{$tag->{tag_lc}};
                }
            }
        };
        my $current_quality = 0;
        for my $language (@{ $self->{sorted_parsed_header} }) {
            if ($current_quality != $language->{quality}) {
                # check of the last quality languages
                my $ret = $detect_langguage->();
                return $ret if $ret;

                # cleanup
                $current_quality = $language->{quality};
                %header_tags         = ();
                %header_primary_tags = ();
            }

            # wildcard
            return $normlized_languages[0]->{tag} if $language->{language} eq '*';

            $header_tags{$language->{language_lc}}                 = 1;
            $header_primary_tags{$language->{language_primary_lc}} = 1;
        }

        my $ret = $detect_langguage->();
        return $ret if $ret;
    } else {
        # 0.02 or more
        for my $language (@{ $self->{sorted_parsed_header} }) {
            # wildcard
            return $normlized_languages[0]->{tag} if $language->{language} eq '*';

            # RFC give priority to full match.
            for my $tag (@normlized_languages) {
                return $tag->{tag} if $language->{language_lc} eq $tag->{tag_lc};
            }
            for my $tag (@normlized_languages) {
                return $tag->{tag} if $language->{language_primary_lc} eq $tag->{tag_lc};
            }
        }
    }

    return undef; # not matched
}

1;
__END__