Michael Hennecke <[EMAIL PROTECTED]> writes: > # BUGS IN REVISION 1.7:
The current version is 1.9. Since 1.7 there has been some changes to the handling of language tags by Sean which I think have fixed some of your issues. You can browse the module history directly off CVS here: http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/libwww-perl/lwp5/lib/HTTP/Negotiate.pm > # * choose() is case-sensitive in the Lang field of the $variants although > # RFC1766 requires that "All tags are to be treated as case insensitive" > # * choose() ignores uppercase Q as quality factor in HTTP_ACCEPT_LANGUAGE > # Shouldn't it treat it case-insensitive? Fixed. > # * choose() produces a -w warning in line 107 when DEBUG is true, > # may be fixed with "$ct='' unless defined $ct;" before line 107 Fixed. > # > # NOT STRICTLY A BUG BUT *VERY* UNFORTUNATE IMPLEMENTATION IN REVISION 1.7: > # > # If the http-accept-language quality factor multiplied by > # the $variant quality factor are the same for a number of variants, > # choose() prefers the variant that comes first in the $variants array, > # not the variant that comes first in http-accept-language. > # This is very unfortunate: > # If the browser doesn't specify q (as is the case in many products today), > # and all qs values in $variants are the same, then the user really > # expects that the order in their http-accept-language list is followed, > # not some arbitrary order in which the variants appear in $variants. > # In particular, this is how Apache's content negotiation works. I fixed that by initializing them with different q values if you don't provide one yourself. Accept-Language: de,en,no is now turned into the same as: Accept-Language: de;q=1, en;q=0.9999, no;q=0.9998 I hope that works well enough in practice. It seems to have the effect you want for your test case. > # In the testcase below, var-de and var-en both end up with Q=1.000, > # de is first in http-accept-language, but choose() returns var-en > # because var-en comes first in $variants > # > > use strict; > use HTTP::Negotiate; > > print "\nTesting HTTP::Negotiate ", &HTTP::Negotiate::Version, " ...\n\n"; > > $HTTP::Negotiate::DEBUG=1; > > $ENV{HTTP_ACCEPT_LANGUAGE}='DE,en,fr;Q=0.5,es;q=0.1'; > > print "HTTP_ACCEPT_LANGUAGE is set to $ENV{HTTP_ACCEPT_LANGUAGE}\n\n"; > > my $variants = [ > ['var-en', undef, 'text/html', undef, undef, 'en', undef], > ['var-de', undef, 'text/html', undef, undef, 'de', undef], > ['var-ES', undef, 'text/html', undef, undef, 'ES', undef], > ['provoke-warning', undef, undef, undef, undef, 'x-no-content-type', undef], > ]; > > my $choice = &HTTP::Negotiate::choose($variants); > > print "\nchoose() has chosen $choice\n"; This was a really well written and well researched bug report. Thank you! Attached is the patch on top of libwww-perl-5.62 that I have applied. Regards, Gisle Index: lib/HTTP/Negotiate.pm =================================================================== RCS file: /cvsroot/libwww-perl/lwp5/lib/HTTP/Negotiate.pm,v retrieving revision 1.9 retrieving revision 1.11 diff -u -p -u -r1.9 -r1.11 --- lib/HTTP/Negotiate.pm 2001/08/07 00:10:45 1.9 +++ lib/HTTP/Negotiate.pm 2001/11/27 22:41:33 1.11 @@ -1,9 +1,9 @@ -# $Id: Negotiate.pm,v 1.9 2001/08/07 00:10:45 gisle Exp $ +# $Id: Negotiate.pm,v 1.11 2001/11/27 22:41:33 gisle Exp $ # package HTTP::Negotiate; -$VERSION = sprintf("%d.%02d", q$Revision: 1.9 $ =~ /(\d+)\.(\d+)/); +$VERSION = sprintf("%d.%02d", q$Revision: 1.11 $ =~ /(\d+)\.(\d+)/); sub Version { $VERSION; } require 5.002; @@ -45,17 +45,26 @@ sub choose ($;$) $request->scan(sub { my($key, $val) = @_; - return unless $key =~ s/^Accept-?//; - my $type = lc $key; - $type = "type" unless length $key; + + my $type; + if ($key =~ s/^Accept-//) { + $type = lc($key); + } + elsif ($key eq "Accept") { + $type = "type"; + } + else { + return; + } + $val =~ s/\s+//g; - my $name; - for $name (split(/,/, $val)) { + my $default_q = 1; + for my $name (split(/,/, $val)) { my(%param, $param); if ($name =~ s/;(.*)//) { for $param (split(/;/, $1)) { my ($pk, $pv) = split(/=/, $param, 2); - $param{$pk} = $pv; + $param{lc $pk} = $pv; } } $name = lc $name; @@ -63,10 +72,12 @@ sub choose ($;$) $param{'q'} = 1 if $param{'q'} > 1; $param{'q'} = 0 if $param{'q'} < 0; } else { - $param{'q'} = 1; - } + $param{'q'} = $default_q; - $param{'q'} = 1 unless defined $param{'q'}; + # This makes sure that the first ones are slightly better off + # and therefore more likely to be chosen. + $default_q -= 0.0001; + } $accept{$type}{$name} = \%param; } }); @@ -102,10 +113,11 @@ sub choose ($;$) for (@$variants) { my($id, $qs, $ct, $enc, $cs, $lang, $bs) = @$_; $qs = 1 unless defined $qs; + $ct = '' unless defined $ct; $bs = 0 unless defined $bs; $lang = lc($lang) if $lang; # lg tags are always case-insensitive if ($DEBUG) { - print "\nEvaluating $id ($ct)\n"; + print "\nEvaluating $id (ct='$ct')\n"; printf " qs = %.3f\n", $qs; print " enc = $enc\n" if $enc && !ref($enc); print " enc = @$enc\n" if $enc && ref($enc); @@ -268,7 +280,7 @@ sub choose ($;$) if ($DEBUG) { $mbx = "undef" unless defined $mbx; - printf "Q=%.3f", $Q; + printf "Q=%.4f", $Q; print " (q=$q, mbx=$mbx, qe=$qe, qc=$qc, ql=$ql, qs=$qs)\n"; }
