}
}
$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];
}
=3= |