git.maemo.org Git - pkg-perl/blob - deb-src/libwww-perl/libwww-perl-5.813/t/base/negotiate.t

   1 print "1..5\n";
   2
   3 use HTTP::Request;
   4 use HTTP::Negotiate;
   5
   6
   7 $no = 1;
   8 sub ok
   9 {
  10     print "ok " . $no++ . "\n";
  11 }
  12
  13 sub not_ok
  14 {
  15     print "not ";
  16     ok;
  17 }
  18
  19
  20  #  ID       QS     Content-Type             Encoding     Char-Set      Lang    Size
  21  $variants =
  22   [
  23    ['var1',  0.950, 'text/plain',           ['uuencode',
  24                                              'compress'], 'iso-8859-2', 'se',    400],
  25    ['var2',  1.000, 'text/html;version=2.0', 'gzip',      'iso-8859-1', 'en',   3000],
  26    ['var3',  0.333, 'image/gif',            undef,        undef,        undef, 43555],
  27  ];
  28
  29
  30 # First we try a request with not accept headers
  31 $request = new HTTP::Request 'GET', 'http://localhost/';
  32 @a = choose($variants, $request);
  33 show_res(@a);
  34 expect(\@a, [['var2' => 1],
  35              ['var1' => 0.95],
  36              ['var3' => 0.333]
  37             ]
  38 );
  39
  40
  41 $a = choose($variants, $request);
  42 print "The chosen one is '$a'\n";
  43 if ($a eq 'var2') {
  44     ok;
  45 }
  46 else {
  47     not_ok;
  48 }
  49
  50 #------------------
  51
  52 $request = new HTTP::Request 'GET', 'http://localhost/';
  53 $request->header('Accept', 'text/plain; q=0.55, image/gif; mbx=10000');
  54 $request->push_header('Accept', 'text/*; q=0.25');
  55 $request->header('Accept-Language', 'no, en');
  56 $request->header('Accept-Charset', 'iso-8859-1');
  57 $request->header('Accept-Encoding', 'gzip');
  58
  59 @a = choose($variants, $request);
  60 show_res(@a);
  61 expect(\@a, [['var2' => 0.25],
  62              ['var1' => 0],
  63              ['var3' => 0]
  64             ]
  65 );
  66
  67 $variants = [
  68   ['var-en', undef, 'text/html', undef, undef, 'en', undef],
  69   ['var-de', undef, 'text/html', undef, undef, 'de', undef],
  70   ['var-ES', undef, 'text/html', undef, undef, 'ES', undef],
  71   ['provoke-warning',  undef, undef, undef, undef, 'x-no-content-type', undef],
  72  ];
  73
  74 $HTTP::Negotiate::DEBUG=1;
  75 $ENV{HTTP_ACCEPT_LANGUAGE}='DE,en,fr;Q=0.5,es;q=0.1';
  76
  77 $a = choose($variants);
  78
  79 if ($a eq 'var-de') {
  80      ok;
  81 }
  82 else {
  83      not_ok
  84 }
  85
  86
  87 $variants = [
  88   [ 'Canadian English' => 1.0, 'text/html', undef, undef, 'en-CA', undef ],
  89   [ 'Generic English'  => 1.0, 'text/html', undef, undef, 'en',    undef ],
  90   [ 'Non-Specific'     => 1.0, 'text/html', undef, undef, undef,   undef ],
  91 ];
  92
  93 $ENV{HTTP_ACCEPT_LANGUAGE}='en-US';
  94 $a = choose($variants);
  95 if ($a eq 'Generic English') {
  96     ok;
  97 }
  98 else {
  99     not_ok;
 100 }
 101
 102 #------------------
 103
 104 sub expect
 105 {
 106     my($res, $exp) = @_;
 107     do {
 108         $a = shift @$res;
 109         $b = shift @$exp;
 110         last if defined($a) ne defined($b);
 111         if (defined($a)) {
 112             ($va, $qa) = @$a;
 113             ($vb, $qb) = @$b;
 114             if ($va ne $vb) {
 115                 print "$va == $vb ?\n";
 116                 not_ok;
 117                 return;
 118             }
 119             if (abs($qa - $qb) > 0.002) {
 120                 print "$qa ~= $qb ?\n";
 121                 not_ok;
 122                 return;
 123             }
 124         }
 125
 126     } until (!defined($a) || !defined($b));
 127     return not_ok if defined($a) ne defined($b);
 128     ok;
 129 }
 130
 131 sub show_res
 132 {
 133     print "-------------\n";
 134     for (@_) {
 135         printf "%-6s %.3f\n", @$_;
 136     }
 137     print "-------------\n";
 138 }