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";
=2= |