| Subject: | HTTP::Negotiate language matching bug |
There appears to be a bug inside HTTP::Negotiate matching languages. First it tries for an exact match, and falls-back to trying for a partial match. Here is some code to demonstrate:
--
#!perl
use strict;
use warnings FATAL => 'all';
use HTTP::Negotiate qw(choose);
use HTTP::Headers;
my @variants = (
[ 'Canadian English' => 1.0, 'text/html', undef, undef, 'en-CA', undef ],
[ 'Generic English' => 1.0, 'text/html', undef, undef, 'en', undef ],
[ 'Non-Specific' => 1.0, 'text/html', undef, undef, undef, undef ],
);
local $HTTP::Negotiate::DEBUG = 1;
my $preference = choose(
\@variants,
HTTP::Headers->new(
'Accept' => 'text/html',
'Accept-Language' => 'en-US',
),
);
print "PREFERENCE: $preference\n";
--
You'll notice that the Non-Specific option is currently chosen, but it should've been "Generic English".
The attached patch for HTTP::Negotiate should correct the bug.
--- old/lib/HTTP/Negotiate.pm 2004-04-09 08:07:04.000000000 -0700
+++ new/lib/HTTP/Negotiate.pm 2005-06-16 01:25:15.000000000 -0700
@@ -191,11 +191,11 @@
$DEBUG and print " -- No exact language match\n";
my $selected = undef;
for $al (keys %{ $accept{'language'} }) {
- if (substr($lang, 0, 1 + length($al)) eq "$al-") {
+ if (index($al, "$lang-") == 0) {
# $lang starting with $al isn't enough, or else
# Accept-Language: hu (Hungarian) would seem
# to accept a document in hup (Hupa)
- $DEBUG and print " -- $lang ISA $al\n";
+ $DEBUG and print " -- $al ISA $lang\n";
$selected = $al unless defined $selected;
$selected = $al if length($al) > length($selected);
}