package HTTP::Negotiate;

$VERSION = "5.813";
sub Version { $VERSION; }

require 5.002;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(choose);

require HTTP::Headers;

$DEBUG = 0;

sub choose ($;$)
{
    my($variants, $request) = @_;
    my(%accept);

    unless (defined $request) {
	# Create a request object from the CGI environment variables
	$request = new HTTP::Headers;
	$request->header('Accept', $ENV{HTTP_ACCEPT})
	  if $ENV{HTTP_ACCEPT};
	$request->header('Accept-Charset', $ENV{HTTP_ACCEPT_CHARSET})
	  if $ENV{HTTP_ACCEPT_CHARSET};
	$request->header('Accept-Encoding', $ENV{HTTP_ACCEPT_ENCODING})
	  if $ENV{HTTP_ACCEPT_ENCODING};
	$request->header('Accept-Language', $ENV{HTTP_ACCEPT_LANGUAGE})
	  if $ENV{HTTP_ACCEPT_LANGUAGE};
    }

    # Get all Accept values from the request.  Build a hash initialized
    # like this:
    #
    #   %accept = ( type =>     { 'audio/*'     => { q => 0.2, mbx => 20000 },
    #                             'audio/basic' => { q => 1 },
    #                           },
    #               language => { 'no'          => { q => 1 },
    #                           }
    #             );

    $request->scan(sub {
	my($key, $val) = @_;

	my $type;
	if ($key =~ s/^Accept-//) {
	    $type = lc($key);
	}
	elsif ($key eq "Accept") {
	    $type = "type";
	}
	else {
	    return;
	}

	$val =~ s/\s+//g;
	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{lc $pk} = $pv;
		}
	    }
	    $name = lc $name;
	    if (defined $param{'q'}) {
		$param{'q'} = 1 if $param{'q'} > 1;
		$param{'q'} = 0 if $param{'q'} < 0;
	    }
	    else {
		$param{'q'} = $default_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;
	}
    });

    # Check if any of the variants specify a language.  We do this
    # because it influences how we treat those without (they default to
    # 0.5 instead of 1).
    my $any_lang = 0;
    for $var (@$variants) {
	if ($var->[5]) {
	    $any_lang = 1;
	    last;
	}
    }

    if ($DEBUG) {
	print "Negotiation parameters in the request\n";
	for $type (keys %accept) {
	    print " $type:\n";
	    for $name (keys %{$accept{$type}}) {
		print "    $name\n";
		for $pv (keys %{$accept{$type}{$name}}) {