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";
        }
 

Reply via email to