develooper Front page | perl.perl5.porters | Postings from January 2001

Re: [ID 20010109.003] Patch 8138 broke a test in libwww

Thread Next
From:
andreas.koenig
Date:
January 9, 2001 04:46
Subject:
Re: [ID 20010109.003] Patch 8138 broke a test in libwww
Message ID:
m34rz8zyex.fsf@ak-71.mind.de
Same script, now down under 50 lines. No closure anymore, no package
but main....

use strict;

my $request = {'accept' => ['text/plain;q=0.15','text/*;q=0.25']};

my(%accept);

my $key = "accept";
my $vals = $request->{$key};
for my $val (@$vals) {
  my(%param);
  if ($val =~ s/;(.*)//) {
    for my $param (split(/;/, $1)) {
      my ($pk, $pv) = split(/=/, $param, 2);
      $param{$pk} = $pv;
    }
  }
  $param{'q'} = 0 if defined $param{'q'} && $param{'q'} < 0;
  $accept{"type"}{$val} = \%param;
}

my($qs, $ct, $q) = (1.000, 'text/html', 1);
my $params = $1 if $ct =~ s/;(.*)//;
my($type, $subtype) = split("/", $ct, 2);
my %param = ();
for my $p (split(/;/, $params)) {
  my($pk,$pv) = split(/=/, $p, 2);
  $param{$pk} = $pv;
}

my $sel_q;
for my $at (qw(text/* text/plain)) {
  my($at_type, $at_subtype) = split("/", $at, 2);
  print "at[$at]subtype[$subtype]at_subtype[$at_subtype]\n";
  if ($at_subtype ne '*' && $at_subtype ne $subtype){
    next;
  }
  $sel_q = $accept{'type'}{$at}{'q'} unless defined($sel_q);
}
$q = $sel_q || 0;

my $Q = $qs * $q;
printf "# Q=%.3f (q=%s, qs=%s)\n", $Q, $q, $qs;
print $Q ? "ok\n" : "not ok\n";




-- 
andreas

Thread Next


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About