diff options
| -rw-r--r-- | Changes | 15 | ||||
| -rw-r--r-- | MANIFEST | 7 | ||||
| -rw-r--r-- | META.yml | 26 | ||||
| -rw-r--r-- | Makefile.PL | 46 | ||||
| -rw-r--r-- | README | 188 | ||||
| -rw-r--r-- | lib/HTTP/Negotiate.pm | 528 | ||||
| -rw-r--r-- | t/negotiate.t | 112 |
7 files changed, 922 insertions, 0 deletions
@@ -0,0 +1,15 @@ +_______________________________________________________________________________ +2012-02-18 HTTP-Negotiate 6.01 + +Restore perl-5.8.1 compatiblity. + + + + +_______________________________________________________________________________ +2011-02-27 HTTP-Negotiate 6.00 + +Initial release of HTTP-Negotiate as a separate distribution. There are no code +changes besides incrementing the version number since libwww-perl-5.837. + +The HTTP::Negotiate module used to be bundled with the libwww-perl distribution. diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..cc4dbb5 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,7 @@ +Changes +lib/HTTP/Negotiate.pm +Makefile.PL +MANIFEST This list of files +README +t/negotiate.t +META.yml Module meta-data (added by MakeMaker) diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..efe0479 --- /dev/null +++ b/META.yml @@ -0,0 +1,26 @@ +--- #YAML:1.0 +name: HTTP-Negotiate +version: 6.01 +abstract: choose a variant to serve +author: + - Gisle Aas <gisle@activestate.com> +license: perl +distribution_type: module +configure_requires: + ExtUtils::MakeMaker: 0 +build_requires: + ExtUtils::MakeMaker: 0 +requires: + HTTP::Headers: 6 + perl: 5.008001 +resources: + MailingList: mailto:libwww@perl.org + repository: http://github.com/gisle/http-negotiate +no_index: + directory: + - t + - inc +generated_by: ExtUtils::MakeMaker version 6.57_05 +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: 1.4 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..c468ad5 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,46 @@ +#!perl -w + +require 5.008001; +use strict; +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => 'HTTP::Negotiate', + VERSION_FROM => 'lib/HTTP/Negotiate.pm', + ABSTRACT_FROM => 'lib/HTTP/Negotiate.pm', + AUTHOR => 'Gisle Aas <gisle@activestate.com>', + LICENSE => "perl", + MIN_PERL_VERSION => 5.008001, + PREREQ_PM => { + 'HTTP::Headers' => 6, + }, + META_MERGE => { + resources => { + repository => 'http://github.com/gisle/http-negotiate', + MailingList => 'mailto:libwww@perl.org', + } + }, +); + + +BEGIN { + # compatibility with older versions of MakeMaker + my $developer = -f ".gitignore"; + my %mm_req = ( + LICENCE => 6.31, + META_MERGE => 6.45, + META_ADD => 6.45, + MIN_PERL_VERSION => 6.48, + ); + undef(*WriteMakefile); + *WriteMakefile = sub { + my %arg = @_; + for (keys %mm_req) { + unless (eval { ExtUtils::MakeMaker->VERSION($mm_req{$_}) }) { + warn "$_ $@" if $developer; + delete $arg{$_}; + } + } + ExtUtils::MakeMaker::WriteMakefile(%arg); + }; +} @@ -0,0 +1,188 @@ +NAME + HTTP::Negotiate - choose a variant to serve + +SYNOPSIS + use HTTP::Negotiate qw(choose); + + # ID QS Content-Type Encoding Char-Set Lang Size + $variants = + [['var1', 1.000, 'text/html', undef, 'iso-8859-1', 'en', 3000], + ['var2', 0.950, 'text/plain', 'gzip', 'us-ascii', 'no', 400], + ['var3', 0.3, 'image/gif', undef, undef, undef, 43555], + ]; + + @preferred = choose($variants, $request_headers); + $the_one = choose($variants); + +DESCRIPTION + This module provides a complete implementation of the HTTP content + negotiation algorithm specified in draft-ietf-http-v11-spec-00.ps + chapter 12. Content negotiation allows for the selection of a preferred + content representation based upon attributes of the negotiable variants + and the value of the various Accept* header fields in the request. + + The variants are ordered by preference by calling the function choose(). + + The first parameter is reference to an array of the variants to choose + among. Each element in this array is an array with the values [$id, $qs, + $content_type, $content_encoding, $charset, $content_language, + $content_length] whose meanings are described below. The + $content_encoding and $content_language can be either a single scalar + value or an array reference if there are several values. + + The second optional parameter is either a HTTP::Headers or a + HTTP::Request object which is searched for "Accept*" headers. If this + parameter is missing, then the accept specification is initialized from + the CGI environment variables HTTP_ACCEPT, HTTP_ACCEPT_CHARSET, + HTTP_ACCEPT_ENCODING and HTTP_ACCEPT_LANGUAGE. + + In an array context, choose() returns a list of [variant identifier, + calculated quality, size] tuples. The values are sorted by quality, + highest quality first. If the calculated quality is the same for two + variants, then they are sorted by size (smallest first). *E.g.*: + + (['var1', 1, 2000], ['var2', 0.3, 512], ['var3', 0.3, 1024]); + + Note that also zero quality variants are included in the return list + even if these should never be served to the client. + + In a scalar context, it returns the identifier of the variant with the + highest score or `undef' if none have non-zero quality. + + If the $HTTP::Negotiate::DEBUG variable is set to TRUE, then a lot of + noise is generated on STDOUT during evaluation of choose(). + +VARIANTS + A variant is described by a list of the following values. If the + attribute does not make sense or is unknown for a variant, then use + `undef' instead. + + identifier + This is a string that you use as the name for the variant. This + identifier for the preferred variants returned by choose(). + + qs This is a number between 0.000 and 1.000 that describes the "source + quality". This is what draft-ietf-http-v11-spec-00.ps says about this + value: + + Source quality is measured by the content provider as representing + the amount of degradation from the original source. For example, a + picture in JPEG form would have a lower qs when translated to the XBM + format, and much lower qs when translated to an ASCII-art + representation. Note, however, that this is a function of the source + - an original piece of ASCII-art may degrade in quality if it is + captured in JPEG form. The qs values should be assigned to each + variant by the content provider; if no qs value has been assigned, + the default is generally "qs=1". + + content-type + This is the media type of the variant. The media type does not + include a charset attribute, but might contain other parameters. + Examples are: + + text/html + text/html;version=2.0 + text/plain + image/gif + image/jpg + + content-encoding + This is one or more content encodings that has been applied to the + variant. The content encoding is generally used as a modifier to the + content media type. The most common content encodings are: + + gzip + compress + + content-charset + This is the character set used when the variant contains text. The + charset value should generally be `undef' or one of these: + + us-ascii + iso-8859-1 ... iso-8859-9 + iso-2022-jp + iso-2022-jp-2 + iso-2022-kr + unicode-1-1 + unicode-1-1-utf-7 + unicode-1-1-utf-8 + + content-language + This describes one or more languages that are used in the variant. + Language is described like this in draft-ietf-http-v11-spec-00.ps: A + language is in this context a natural language spoken, written, or + otherwise conveyed by human beings for communication of information + to other human beings. Computer languages are explicitly excluded. + + The language tags are defined by RFC 3066. Examples are: + + no Norwegian + en International English + en-US US English + en-cockney + + content-length + This is the number of bytes used to represent the content. + +ACCEPT HEADERS + The following Accept* headers can be used for describing content + preferences in a request (This description is an edited extract from + draft-ietf-http-v11-spec-00.ps): + + Accept + This header can be used to indicate a list of media ranges which are + acceptable as a response to the request. The "*" character is used to + group media types into ranges, with "*/*" indicating all media types + and "type/*" indicating all subtypes of that type. + + The parameter q is used to indicate the quality factor, which + represents the user's preference for that range of media types. The + parameter mbx gives the maximum acceptable size of the response + content. The default values are: q=1 and mbx=infinity. If no Accept + header is present, then the client accepts all media types with q=1. + + For example: + + Accept: audio/*;q=0.2;mbx=200000, audio/basic + + would mean: "I prefer audio/basic (of any size), but send me any + audio type if it is the best available after an 80% mark-down in + quality and its size is less than 200000 bytes" + + Accept-Charset + Used to indicate what character sets are acceptable for the response. + The "us-ascii" character set is assumed to be acceptable for all user + agents. If no Accept-Charset field is given, the default is that any + charset is acceptable. Example: + + Accept-Charset: iso-8859-1, unicode-1-1 + + Accept-Encoding + Restricts the Content-Encoding values which are acceptable in the + response. If no Accept-Encoding field is present, the server may + assume that the client will accept any content encoding. An empty + Accept-Encoding means that no content encoding is acceptable. + Example: + + Accept-Encoding: compress, gzip + + Accept-Language + This field is similar to Accept, but restricts the set of natural + languages that are preferred in a response. Each language may be + given an associated quality value which represents an estimate of the + user's comprehension of that language. For example: + + Accept-Language: no, en-gb;q=0.8, de;q=0.55 + + would mean: "I prefer Norwegian, but will accept British English + (with 80% comprehension) or German (with 55% comprehension). + +COPYRIGHT + Copyright 1996,2001 Gisle Aas. + + This library is free software; you can redistribute it and/or modify it + under the same terms as Perl itself. + +AUTHOR + Gisle Aas <gisle@aas.no> + diff --git a/lib/HTTP/Negotiate.pm b/lib/HTTP/Negotiate.pm new file mode 100644 index 0000000..d293ce8 --- /dev/null +++ b/lib/HTTP/Negotiate.pm @@ -0,0 +1,528 @@ +package HTTP::Negotiate; + +$VERSION = "6.01"; +sub Version { $VERSION; } + +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 = HTTP::Headers->new; + $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}}) { + print " $pv = $accept{$type}{$name}{$pv}\n"; + } + } + } + } + + my @Q = (); # This is where we collect the results of the + # quality calculations + + # Calculate quality for all the variants that are available. + 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='$ct')\n"; + printf " qs = %.3f\n", $qs; + print " enc = $enc\n" if $enc && !ref($enc); + print " enc = @$enc\n" if $enc && ref($enc); + print " cs = $cs\n" if $cs; + print " lang = $lang\n" if $lang; + print " bs = $bs\n" if $bs; + } + + # Calculate encoding quality + my $qe = 1; + # If the variant has no assigned Content-Encoding, or if no + # Accept-Encoding field is present, then the value assigned + # is "qe=1". If *all* of the variant's content encodings + # are listed in the Accept-Encoding field, then the value + # assigned is "qw=1". If *any* of the variant's content + # encodings are not listed in the provided Accept-Encoding + # field, then the value assigned is "qe=0" + if (exists $accept{'encoding'} && $enc) { + my @enc = ref($enc) ? @$enc : ($enc); + for (@enc) { + print "Is encoding $_ accepted? " if $DEBUG; + unless(exists $accept{'encoding'}{$_}) { + print "no\n" if $DEBUG; + $qe = 0; + last; + } + else { + print "yes\n" if $DEBUG; + } + } + } + + # Calculate charset quality + my $qc = 1; + # If the variant's media-type has no charset parameter, + # or the variant's charset is US-ASCII, or if no Accept-Charset + # field is present, then the value assigned is "qc=1". If the + # variant's charset is listed in the Accept-Charset field, + # then the value assigned is "qc=1. Otherwise, if the variant's + # charset is not listed in the provided Accept-Encoding field, + # then the value assigned is "qc=0". + if (exists $accept{'charset'} && $cs && $cs ne 'us-ascii' ) { + $qc = 0 unless $accept{'charset'}{$cs}; + } + + # Calculate language quality + my $ql = 1; + if ($lang && exists $accept{'language'}) { + my @lang = ref($lang) ? @$lang : ($lang); + # If any of the variant's content languages are listed + # in the Accept-Language field, the the value assigned is + # the largest of the "q" parameter values for those language + # tags. + my $q = undef; + for (@lang) { + next unless exists $accept{'language'}{$_}; + my $this_q = $accept{'language'}{$_}{'q'}; + $q = $this_q unless defined $q; + $q = $this_q if $this_q > $q; + } + if(defined $q) { + $DEBUG and print " -- Exact language match at q=$q\n"; + } + else { + # If there was no exact match and at least one of + # the Accept-Language field values is a complete + # subtag prefix of the content language tag(s), then + # the "q" parameter value of the largest matching + # prefix is used. + $DEBUG and print " -- No exact language match\n"; + my $selected = undef; + for $al (keys %{ $accept{'language'} }) { + 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 " -- $al ISA $lang\n"; + $selected = $al unless defined $selected; + $selected = $al if length($al) > length($selected); + } + else { + $DEBUG and print " -- $lang isn't a $al\n"; + } + } + $q = $accept{'language'}{$selected}{'q'} if $selected; + + # If none of the variant's content language tags or + # tag prefixes are listed in the provided + # Accept-Language field, then the value assigned + # is "ql=0.001" + $q = 0.001 unless defined $q; + } + $ql = $q; + } + else { + $ql = 0.5 if $any_lang && exists $accept{'language'}; + } + + my $q = 1; + my $mbx = undef; + # If no Accept field is given, then the value assigned is "q=1". + # If at least one listed media range matches the variant's media + # type, then the "q" parameter value assigned to the most specific + # of those matched is used (e.g. "text/html;version=3.0" is more + # specific than "text/html", which is more specific than "text/*", + # which in turn is more specific than "*/*"). If not media range + # in the provided Accept field matches the variant's media type, + # then the value assigned is "q=0". + if (exists $accept{'type'} && $ct) { + # First we clean up our content-type + $ct =~ s/\s+//g; + my $params = ""; + $params = $1 if $ct =~ s/;(.*)//; + my($type, $subtype) = split("/", $ct, 2); + my %param = (); + for $param (split(/;/, $params)) { + my($pk,$pv) = split(/=/, $param, 2); + $param{$pk} = $pv; + } + + my $sel_q = undef; + my $sel_mbx = undef; + my $sel_specificness = 0; + + ACCEPT_TYPE: + for $at (keys %{ $accept{'type'} }) { + print "Consider $at...\n" if $DEBUG; + my($at_type, $at_subtype) = split("/", $at, 2); + # Is it a match on the type + next if $at_type ne '*' && $at_type ne $type; + next if $at_subtype ne '*' && $at_subtype ne $subtype; + my $specificness = 0; + $specificness++ if $at_type ne '*'; + $specificness++ if $at_subtype ne '*'; + # Let's see if content-type parameters also match + while (($pk, $pv) = each %param) { + print "Check if $pk = $pv is true\n" if $DEBUG; + next unless exists $accept{'type'}{$at}{$pk}; + next ACCEPT_TYPE + unless $accept{'type'}{$at}{$pk} eq $pv; + print "yes it is!!\n" if $DEBUG; + $specificness++; + } + print "Hurray, type match with specificness = $specificness\n" + if $DEBUG; + + if (!defined($sel_q) || $sel_specificness < $specificness) { + $sel_q = $accept{'type'}{$at}{'q'}; + $sel_mbx = $accept{'type'}{$at}{'mbx'}; + $sel_specificness = $specificness; + } + } + $q = $sel_q || 0; + $mbx = $sel_mbx; + } + + my $Q; + if (!defined($mbx) || $mbx >= $bs) { + $Q = $qs * $qe * $qc * $ql * $q; + } + else { + $Q = 0; + print "Variant's size is too large ==> Q=0\n" if $DEBUG; + } + + if ($DEBUG) { + $mbx = "undef" unless defined $mbx; + printf "Q=%.4f", $Q; + print " (q=$q, mbx=$mbx, qe=$qe, qc=$qc, ql=$ql, qs=$qs)\n"; + } + + push(@Q, [$id, $Q, $bs]); + } + + + @Q = sort { $b->[1] <=> $a->[1] || $a->[2] <=> $b->[2] } @Q; + + return @Q if wantarray; + return undef unless @Q; + return undef if $Q[0][1] == 0; + $Q[0][0]; +} + +1; + +__END__ + + +=head1 NAME + +HTTP::Negotiate - choose a variant to serve + +=head1 SYNOPSIS + + use HTTP::Negotiate qw(choose); + + # ID QS Content-Type Encoding Char-Set Lang Size + $variants = + [['var1', 1.000, 'text/html', undef, 'iso-8859-1', 'en', 3000], + ['var2', 0.950, 'text/plain', 'gzip', 'us-ascii', 'no', 400], + ['var3', 0.3, 'image/gif', undef, undef, undef, 43555], + ]; + + @preferred = choose($variants, $request_headers); + $the_one = choose($variants); + +=head1 DESCRIPTION + +This module provides a complete implementation of the HTTP content +negotiation algorithm specified in F<draft-ietf-http-v11-spec-00.ps> +chapter 12. Content negotiation allows for the selection of a +preferred content representation based upon attributes of the +negotiable variants and the value of the various Accept* header fields +in the request. + +The variants are ordered by preference by calling the function +choose(). + +The first parameter is reference to an array of the variants to +choose among. +Each element in this array is an array with the values [$id, $qs, +$content_type, $content_encoding, $charset, $content_language, +$content_length] whose meanings are described +below. The $content_encoding and $content_language can be either a +single scalar value or an array reference if there are several values. + +The second optional parameter is either a HTTP::Headers or a HTTP::Request +object which is searched for "Accept*" headers. If this +parameter is missing, then the accept specification is initialized +from the CGI environment variables HTTP_ACCEPT, HTTP_ACCEPT_CHARSET, +HTTP_ACCEPT_ENCODING and HTTP_ACCEPT_LANGUAGE. + +In an array context, choose() returns a list of [variant +identifier, calculated quality, size] tuples. The values are sorted by +quality, highest quality first. If the calculated quality is the same +for two variants, then they are sorted by size (smallest first). I<E.g.>: + + (['var1', 1, 2000], ['var2', 0.3, 512], ['var3', 0.3, 1024]); + +Note that also zero quality variants are included in the return list +even if these should never be served to the client. + +In a scalar context, it returns the identifier of the variant with the +highest score or C<undef> if none have non-zero quality. + +If the $HTTP::Negotiate::DEBUG variable is set to TRUE, then a lot of +noise is generated on STDOUT during evaluation of choose(). + +=head1 VARIANTS + +A variant is described by a list of the following values. If the +attribute does not make sense or is unknown for a variant, then use +C<undef> instead. + +=over 3 + +=item identifier + +This is a string that you use as the name for the variant. This +identifier for the preferred variants returned by choose(). + +=item qs + +This is a number between 0.000 and 1.000 that describes the "source +quality". This is what F<draft-ietf-http-v11-spec-00.ps> says about this +value: + +Source quality is measured by the content provider as representing the +amount of degradation from the original source. For example, a +picture in JPEG form would have a lower qs when translated to the XBM +format, and much lower qs when translated to an ASCII-art +representation. Note, however, that this is a function of the source +- an original piece of ASCII-art may degrade in quality if it is +captured in JPEG form. The qs values should be assigned to each +variant by the content provider; if no qs value has been assigned, the +default is generally "qs=1". + +=item content-type + +This is the media type of the variant. The media type does not +include a charset attribute, but might contain other parameters. +Examples are: + + text/html + text/html;version=2.0 + text/plain + image/gif + image/jpg + +=item content-encoding + +This is one or more content encodings that has been applied to the +variant. The content encoding is generally used as a modifier to the +content media type. The most common content encodings are: + + gzip + compress + +=item content-charset + +This is the character set used when the variant contains text. +The charset value should generally be C<undef> or one of these: + + us-ascii + iso-8859-1 ... iso-8859-9 + iso-2022-jp + iso-2022-jp-2 + iso-2022-kr + unicode-1-1 + unicode-1-1-utf-7 + unicode-1-1-utf-8 + +=item content-language + +This describes one or more languages that are used in the variant. +Language is described like this in F<draft-ietf-http-v11-spec-00.ps>: A +language is in this context a natural language spoken, written, or +otherwise conveyed by human beings for communication of information to +other human beings. Computer languages are explicitly excluded. + +The language tags are defined by RFC 3066. Examples +are: + + no Norwegian + en International English + en-US US English + en-cockney + +=item content-length + +This is the number of bytes used to represent the content. + +=back + +=head1 ACCEPT HEADERS + +The following Accept* headers can be used for describing content +preferences in a request (This description is an edited extract from +F<draft-ietf-http-v11-spec-00.ps>): + +=over 3 + +=item Accept + +This header can be used to indicate a list of media ranges which are +acceptable as a response to the request. The "*" character is used to +group media types into ranges, with "*/*" indicating all media types +and "type/*" indicating all subtypes of that type. + +The parameter q is used to indicate the quality factor, which +represents the user's preference for that range of media types. The +parameter mbx gives the maximum acceptable size of the response +content. The default values are: q=1 and mbx=infinity. If no Accept +header is present, then the client accepts all media types with q=1. + +For example: + + Accept: audio/*;q=0.2;mbx=200000, audio/basic + +would mean: "I prefer audio/basic (of any size), but send me any audio +type if it is the best available after an 80% mark-down in quality and +its size is less than 200000 bytes" + + +=item Accept-Charset + +Used to indicate what character sets are acceptable for the response. +The "us-ascii" character set is assumed to be acceptable for all user +agents. If no Accept-Charset field is given, the default is that any +charset is acceptable. Example: + + Accept-Charset: iso-8859-1, unicode-1-1 + + +=item Accept-Encoding + +Restricts the Content-Encoding values which are acceptable in the +response. If no Accept-Encoding field is present, the server may +assume that the client will accept any content encoding. An empty +Accept-Encoding means that no content encoding is acceptable. Example: + + Accept-Encoding: compress, gzip + + +=item Accept-Language + +This field is similar to Accept, but restricts the set of natural +languages that are preferred in a response. Each language may be +given an associated quality value which represents an estimate of the +user's comprehension of that language. For example: + + Accept-Language: no, en-gb;q=0.8, de;q=0.55 + +would mean: "I prefer Norwegian, but will accept British English (with +80% comprehension) or German (with 55% comprehension). + +=back + + +=head1 COPYRIGHT + +Copyright 1996,2001 Gisle Aas. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 AUTHOR + +Gisle Aas <gisle@aas.no> + +=cut diff --git a/t/negotiate.t b/t/negotiate.t new file mode 100644 index 0000000..ef3f889 --- /dev/null +++ b/t/negotiate.t @@ -0,0 +1,112 @@ +#!perl -w + +use Test; +plan tests => 5; + +use HTTP::Request; +use HTTP::Negotiate; + + + # ID QS Content-Type Encoding Char-Set Lang Size + $variants = + [ + ['var1', 0.950, 'text/plain', ['uuencode', + 'compress'], 'iso-8859-2', 'se', 400], + ['var2', 1.000, 'text/html;version=2.0', 'gzip', 'iso-8859-1', 'en', 3000], + ['var3', 0.333, 'image/gif', undef, undef, undef, 43555], + ]; + + +# First we try a request with not accept headers +$request = new HTTP::Request 'GET', 'http://localhost/'; +@a = choose($variants, $request); +show_res(@a); +expect(\@a, [['var2' => 1], + ['var1' => 0.95], + ['var3' => 0.333] + ] +); + + +$a = choose($variants, $request); +print "The chosen one is '$a'\n"; +ok($a, "var2"); + +#------------------ + +$request = new HTTP::Request 'GET', 'http://localhost/'; +$request->header('Accept', 'text/plain; q=0.55, image/gif; mbx=10000'); +$request->push_header('Accept', 'text/*; q=0.25'); +$request->header('Accept-Language', 'no, en'); +$request->header('Accept-Charset', 'iso-8859-1'); +$request->header('Accept-Encoding', 'gzip'); + +@a = choose($variants, $request); +show_res(@a); +expect(\@a, [['var2' => 0.25], + ['var1' => 0], + ['var3' => 0] + ] +); + +$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], + ]; + +$HTTP::Negotiate::DEBUG=1; +$ENV{HTTP_ACCEPT_LANGUAGE}='DE,en,fr;Q=0.5,es;q=0.1'; + +$a = choose($variants); + +ok($a, 'var-de'); + + +$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 ], +]; + +$ENV{HTTP_ACCEPT_LANGUAGE}='en-US'; +$a = choose($variants); +ok($a, 'Generic English'); + +#------------------ + +sub expect +{ + my($res, $exp) = @_; + do { + $a = shift @$res; + $b = shift @$exp; + last if defined($a) ne defined($b); + if (defined($a)) { + ($va, $qa) = @$a; + ($vb, $qb) = @$b; + if ($va ne $vb) { + print "$va == $vb ?\n"; + ok(0); + return; + } + if (abs($qa - $qb) > 0.002) { + print "$qa ~= $qb ?\n"; + ok(0); + return; + } + } + + } until (!defined($a) || !defined($b)); + ok(defined($a), defined($b)); +} + +sub show_res +{ + print "-------------\n"; + for (@_) { + printf "%-6s %.3f\n", @$_; + } + print "-------------\n"; +} |