home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _c9f3318835ad4d3f3c7fc9add2b4ff76 < prev    next >
Encoding:
Text File  |  2004-06-01  |  16.4 KB  |  533 lines
  1. # $Id: Negotiate.pm,v 1.15 2004/04/09 15:07:04 gisle Exp $
  2. #
  3.  
  4. package HTTP::Negotiate;
  5.  
  6. $VERSION = sprintf("%d.%02d", q$Revision: 1.15 $ =~ /(\d+)\.(\d+)/);
  7. sub Version { $VERSION; }
  8.  
  9. require 5.002;
  10. require Exporter;
  11. @ISA = qw(Exporter);
  12. @EXPORT = qw(choose);
  13.  
  14. require HTTP::Headers;
  15.  
  16. $DEBUG = 0;
  17.  
  18. sub choose ($;$)
  19. {
  20.     my($variants, $request) = @_;
  21.     my(%accept);
  22.  
  23.     unless (defined $request) {
  24.     # Create a request object from the CGI envirionment variables
  25.     $request = new HTTP::Headers;
  26.     $request->header('Accept', $ENV{HTTP_ACCEPT})
  27.       if $ENV{HTTP_ACCEPT};
  28.     $request->header('Accept-Charset', $ENV{HTTP_ACCEPT_CHARSET})
  29.       if $ENV{HTTP_ACCEPT_CHARSET};
  30.     $request->header('Accept-Encoding', $ENV{HTTP_ACCEPT_ENCODING})
  31.       if $ENV{HTTP_ACCEPT_ENCODING};
  32.     $request->header('Accept-Language', $ENV{HTTP_ACCEPT_LANGUAGE})
  33.       if $ENV{HTTP_ACCEPT_LANGUAGE};
  34.     }
  35.  
  36.     # Get all Accept values from the request.  Build a hash initialized
  37.     # like this:
  38.     #
  39.     #   %accept = ( type =>     { 'audio/*'     => { q => 0.2, mbx => 20000 },
  40.     #                             'audio/basic' => { q => 1 },
  41.     #                           },
  42.     #               language => { 'no'          => { q => 1 },
  43.     #                           }
  44.     #             );
  45.  
  46.     $request->scan(sub {
  47.     my($key, $val) = @_;
  48.  
  49.     my $type;
  50.     if ($key =~ s/^Accept-//) {
  51.         $type = lc($key);
  52.     }
  53.     elsif ($key eq "Accept") {
  54.         $type = "type";
  55.     }
  56.     else {
  57.         return;
  58.     }
  59.  
  60.     $val =~ s/\s+//g;
  61.     my $default_q = 1;
  62.     for my $name (split(/,/, $val)) {
  63.         my(%param, $param);
  64.         if ($name =~ s/;(.*)//) {
  65.         for $param (split(/;/, $1)) {
  66.             my ($pk, $pv) = split(/=/, $param, 2);
  67.             $param{lc $pk} = $pv;
  68.         }
  69.         }
  70.         $name = lc $name;
  71.         if (defined $param{'q'}) {
  72.         $param{'q'} = 1 if $param{'q'} > 1;
  73.         $param{'q'} = 0 if $param{'q'} < 0;
  74.         }
  75.         else {
  76.         $param{'q'} = $default_q;
  77.  
  78.         # This makes sure that the first ones are slightly better off
  79.         # and therefore more likely to be chosen.
  80.         $default_q -= 0.0001;
  81.         }
  82.         $accept{$type}{$name} = \%param;
  83.     }
  84.     });
  85.  
  86.     # Check if any of the variants specify a language.  We do this
  87.     # because it influences how we treat those without (they default to
  88.     # 0.5 instead of 1).
  89.     my $any_lang = 0;
  90.     for $var (@$variants) {
  91.     if ($var->[5]) {
  92.         $any_lang = 1;
  93.         last;
  94.     }
  95.     }
  96.  
  97.     if ($DEBUG) {
  98.     print "Negotiation parameters in the request\n";
  99.     for $type (keys %accept) {
  100.         print " $type:\n";
  101.         for $name (keys %{$accept{$type}}) {
  102.         print "    $name\n";
  103.         for $pv (keys %{$accept{$type}{$name}}) {
  104.             print "      $pv = $accept{$type}{$name}{$pv}\n";
  105.         }
  106.         }
  107.     }
  108.     }
  109.  
  110.     my @Q = ();  # This is where we collect the results of the
  111.          # quality calcualtions
  112.  
  113.     # Calculate quality for all the variants that are available.
  114.     for (@$variants) {
  115.     my($id, $qs, $ct, $enc, $cs, $lang, $bs) = @$_;
  116.     $qs = 1 unless defined $qs;
  117.         $ct = '' unless defined $ct;
  118.     $bs = 0 unless defined $bs;
  119.     $lang = lc($lang) if $lang; # lg tags are always case-insensitive
  120.     if ($DEBUG) {
  121.         print "\nEvaluating $id (ct='$ct')\n";
  122.         printf "  qs   = %.3f\n", $qs;
  123.         print  "  enc  = $enc\n"  if $enc && !ref($enc);
  124.         print  "  enc  = @$enc\n" if $enc && ref($enc);
  125.         print  "  cs   = $cs\n"   if $cs;
  126.         print  "  lang = $lang\n" if $lang;
  127.         print  "  bs   = $bs\n"   if $bs;
  128.     }
  129.  
  130.     # Calculate encoding quality
  131.     my $qe = 1;
  132.     # If the variant has no assignes Content-Encoding, or if no
  133.     # Accept-Encoding field is present, then the value assigned
  134.     # is "qe=1".  If *all* of the variant's content encoddings
  135.     # are listed in the Accept-Encoding field, then the value
  136.     # assigned is "qw=1".  If *any* of the variant's content
  137.     # encodings are not listed in the provided Accept-Encoding
  138.     # field, then the value assigned is "qe=0"
  139.     if (exists $accept{'encoding'} && $enc) {
  140.         my @enc = ref($enc) ? @$enc : ($enc);
  141.         for (@enc) {
  142.         print "Is encoding $_ accepted? " if $DEBUG;
  143.         unless(exists $accept{'encoding'}{$_}) {
  144.             print "no\n" if $DEBUG;
  145.             $qe = 0;
  146.             last;
  147.         }
  148.         else {
  149.             print "yes\n" if $DEBUG;
  150.         }
  151.         }
  152.     }
  153.  
  154.     # Calculate charset quality
  155.     my $qc  = 1;
  156.     # If the variant's media-type has not charset parameter,
  157.     # or the variant's charset is US-ASCII, or if no Accept-Charset
  158.     # field is present, then the value assigned is "qc=1".  If the
  159.     # variant's charset is listed in the Accept-Charset field,
  160.     # then the value assigned is "qc=1.  Otherwise, if the variant's
  161.     # charset is not listed in the provided Accept-Encoding field,
  162.     # then the value assigned is "qc=0".
  163.     if (exists $accept{'charset'} && $cs && $cs ne 'us-ascii' ) {
  164.         $qc = 0 unless $accept{'charset'}{$cs};
  165.     }
  166.  
  167.     # Calculate language quality
  168.     my $ql  = 1;
  169.     if ($lang && exists $accept{'language'}) {
  170.         my @lang = ref($lang) ? @$lang : ($lang);
  171.         # If any of the variant's content languages are listed
  172.         # in the Accept-Language field, the the value assigned is
  173.         # the maximus of the "q" paramet values for thos language
  174.         # tags.
  175.         my $q = undef;
  176.         for (@lang) {
  177.         next unless exists $accept{'language'}{$_};
  178.         my $this_q = $accept{'language'}{$_}{'q'};
  179.         $q = $this_q unless defined $q;
  180.         $q = $this_q if $this_q > $q;
  181.         }
  182.         if(defined $q) {
  183.             $DEBUG and print " -- Exact language match at q=$q\n";
  184.         }
  185.         else {
  186.         # If there was no exact match and at least one of
  187.         # the Accept-Language field values is a complete
  188.         # subtag prefix of the content language tag(s), then
  189.         # the "q" parameter value of the largest matching
  190.         # prefix is used.
  191.         $DEBUG and print " -- No exact language match\n";
  192.         my $selected = undef;
  193.         for $al (keys %{ $accept{'language'} }) {
  194.             if (substr($lang, 0, 1 + length($al)) eq "$al-") {
  195.                 # $lang starting with $al isn't enough, or else
  196.                 #  Accept-Language: hu (Hungarian) would seem
  197.                 #  to accept a document in hup (Hupa)
  198.                 $DEBUG and print " -- $lang ISA $al\n";
  199.             $selected = $al unless defined $selected;
  200.             $selected = $al if length($al) > length($selected);
  201.             }
  202.             else {
  203.                 $DEBUG and print " -- $lang  isn't a $al\n";
  204.             }
  205.         }
  206.         $q = $accept{'language'}{$selected}{'q'} if $selected;
  207.  
  208.         # If none of the variant's content language tags or
  209.         # tag prefixes are listed in the provided
  210.         # Accept-Language field, then the value assigned
  211.         # is "ql=0.001"
  212.         $q = 0.001 unless defined $q;
  213.         }
  214.         $ql = $q;
  215.     }
  216.     else {
  217.         $ql = 0.5 if $any_lang && exists $accept{'language'};
  218.     }
  219.  
  220.     my $q   = 1;
  221.     my $mbx = undef;
  222.     # If no Accept field is given, then the value assigned is "q=1".
  223.     # If at least one listed media range matches the variant's media
  224.     # type, then the "q" parameter value assigned to the most specific
  225.     # of those matched is used (e.g. "text/html;version=3.0" is more
  226.     # specific than "text/html", which is more specific than "text/*",
  227.     # which in turn is more specific than "*/*"). If not media range
  228.     # in the provided Accept field matches the variant's media type,
  229.     # then the value assigned is "q=0".
  230.     if (exists $accept{'type'} && $ct) {
  231.         # First we clean up our content-type
  232.         $ct =~ s/\s+//g;
  233.         my $params = "";
  234.         $params = $1 if $ct =~ s/;(.*)//;
  235.         my($type, $subtype) = split("/", $ct, 2);
  236.         my %param = ();
  237.         for $param (split(/;/, $params)) {
  238.         my($pk,$pv) = split(/=/, $param, 2);
  239.         $param{$pk} = $pv;
  240.         }
  241.  
  242.         my $sel_q = undef;
  243.         my $sel_mbx = undef;
  244.         my $sel_specificness = 0;
  245.  
  246.         ACCEPT_TYPE:
  247.         for $at (keys %{ $accept{'type'} }) {
  248.         print "Consider $at...\n" if $DEBUG;
  249.         my($at_type, $at_subtype) = split("/", $at, 2);
  250.         # Is it a match on the type
  251.         next if $at_type    ne '*' && $at_type    ne $type;
  252.         next if $at_subtype ne '*' && $at_subtype ne $subtype;
  253.         my $specificness = 0;
  254.         $specificness++ if $at_type ne '*';
  255.         $specificness++ if $at_subtype ne '*';
  256.         # Let's see if content-type parameters also match
  257.         while (($pk, $pv) = each %param) {
  258.             print "Check if $pk = $pv is true\n" if $DEBUG;
  259.             next unless exists $accept{'type'}{$at}{$pk};
  260.             next ACCEPT_TYPE
  261.               unless $accept{'type'}{$at}{$pk} eq $pv;
  262.             print "yes it is!!\n" if $DEBUG;
  263.             $specificness++;
  264.         }
  265.         print "Hurray, type match with specificness = $specificness\n"
  266.           if $DEBUG;
  267.  
  268.         if (!defined($sel_q) || $sel_specificness < $specificness) {
  269.             $sel_q   = $accept{'type'}{$at}{'q'};
  270.             $sel_mbx = $accept{'type'}{$at}{'mbx'};
  271.             $sel_specificness = $specificness;
  272.         }
  273.         }
  274.         $q   = $sel_q || 0;
  275.         $mbx = $sel_mbx;
  276.     }
  277.  
  278.     my $Q;
  279.     if (!defined($mbx) || $mbx >= $bs) {
  280.         $Q = $qs * $qe * $qc * $ql * $q;
  281.     }
  282.     else {
  283.         $Q = 0;
  284.         print "Variant's size is too large ==> Q=0\n" if $DEBUG;
  285.     }
  286.  
  287.     if ($DEBUG) {
  288.         $mbx = "undef" unless defined $mbx;
  289.         printf "Q=%.4f", $Q;
  290.         print "  (q=$q, mbx=$mbx, qe=$qe, qc=$qc, ql=$ql, qs=$qs)\n";
  291.     }
  292.  
  293.     push(@Q, [$id, $Q, $bs]);
  294.     }
  295.  
  296.  
  297.     @Q = sort { $b->[1] <=> $a->[1] || $a->[2] <=> $b->[2] } @Q;
  298.  
  299.     return @Q if wantarray;
  300.     return undef unless @Q;
  301.     return undef if $Q[0][1] == 0;
  302.     $Q[0][0];
  303. }
  304.  
  305. 1;
  306.  
  307. __END__
  308.  
  309.  
  310. =head1 NAME
  311.  
  312. HTTP::Negotiate - choose a variant to serve
  313.  
  314. =head1 SYNOPSIS
  315.  
  316.  use HTTP::Negotiate qw(choose);
  317.  
  318.  #  ID       QS     Content-Type   Encoding Char-Set        Lang   Size
  319.  $variants =
  320.   [['var1',  1.000, 'text/html',   undef,   'iso-8859-1',   'en',   3000],
  321.    ['var2',  0.950, 'text/plain',  'gzip',  'us-ascii',     'no',    400],
  322.    ['var3',  0.3,   'image/gif',   undef,   undef,          undef, 43555],
  323.   ];
  324.  
  325.  @prefered = choose($variants, $request_headers);
  326.  $the_one  = choose($variants);
  327.  
  328. =head1 DESCRIPTION
  329.  
  330. This module provides a complete implementation of the HTTP content
  331. negotiation algorithm specified in F<draft-ietf-http-v11-spec-00.ps>
  332. chapter 12.  Content negotiation allows for the selection of a
  333. preferred content representation based upon attributes of the
  334. negotiable variants and the value of the various Accept* header fields
  335. in the request.
  336.  
  337. The variants are ordered by preference by calling the function
  338. choose().
  339.  
  340. The first parameter is reference to an array of the variants to
  341. choose among.
  342. Each element in this array is an array with the values [$id, $qs,
  343. $content_type, $content_encoding, $charset, $content_language,
  344. $content_length] whose meanings are described
  345. below. The $content_encoding and $content_language can be either a
  346. single scalar value or an array reference if there are several values.
  347.  
  348. The second optional parameter is either a HTTP::Headers or a HTTP::Request
  349. object which is searched for "Accept*" headers.  If this
  350. parameter is missing, then the accept specification is initialized
  351. from the CGI environment variables HTTP_ACCEPT, HTTP_ACCEPT_CHARSET,
  352. HTTP_ACCEPT_ENCODING and HTTP_ACCEPT_LANGUAGE.
  353.  
  354. In an array context, choose() returns a list of [variant
  355. identifier, calculated quality, size] tuples.  The values are sorted by
  356. quality, highest quality first.  If the calculated quality is the same
  357. for two variants, then they are sorted by size (smallest first). I<E.g.>:
  358.  
  359.   (['var1', 1, 2000], ['var2', 0.3, 512], ['var3', 0.3, 1024]);
  360.  
  361. Note that also zero quality variants are included in the return list
  362. even if these should never be served to the client.
  363.  
  364. In a scalar context, it returns the identifier of the variant with the
  365. highest score or C<undef> if none have non-zero quality.
  366.  
  367. If the $HTTP::Negotiate::DEBUG variable is set to TRUE, then a lot of
  368. noise is generated on STDOUT during evaluation of choose().
  369.  
  370. =head1 VARIANTS
  371.  
  372. A variant is described by a list of the following values.  If the
  373. attribute does not make sense or is unknown for a variant, then use
  374. C<undef> instead.
  375.  
  376. =over 3
  377.  
  378. =item identifier
  379.  
  380. This is a string that you use as the name for the variant.  This
  381. identifier for the preferred variants returned by choose().
  382.  
  383. =item qs
  384.  
  385. This is a number between 0.000 and 1.000 that describes the "source
  386. quality".  This is what F<draft-ietf-http-v11-spec-00.ps> says about this
  387. value:
  388.  
  389. Source quality is measured by the content provider as representing the
  390. amount of degradation from the original source.  For example, a
  391. picture in JPEG form would have a lower qs when translated to the XBM
  392. format, and much lower qs when translated to an ASCII-art
  393. representation.  Note, however, that this is a function of the source
  394. - an original piece of ASCII-art may degrade in quality if it is
  395. captured in JPEG form.  The qs values should be assigned to each
  396. variant by the content provider; if no qs value has been assigned, the
  397. default is generally "qs=1".
  398.  
  399. =item content-type
  400.  
  401. This is the media type of the variant.  The media type does not
  402. include a charset attribute, but might contain other parameters.
  403. Examples are:
  404.  
  405.   text/html
  406.   text/html;version=2.0
  407.   text/plain
  408.   image/gif
  409.   image/jpg
  410.  
  411. =item content-encoding
  412.  
  413. This is one or more content encodings that has been applied to the
  414. variant.  The content encoding is generally used as a modifier to the
  415. content media type.  The most common content encodings are:
  416.  
  417.   gzip
  418.   compress
  419.  
  420. =item content-charset
  421.  
  422. This is the character set used when the variant contains text.
  423. The charset value should generally be C<undef> or one of these:
  424.  
  425.   us-ascii
  426.   iso-8859-1 ... iso-8859-9
  427.   iso-2022-jp
  428.   iso-2022-jp-2
  429.   iso-2022-kr
  430.   unicode-1-1
  431.   unicode-1-1-utf-7
  432.   unicode-1-1-utf-8
  433.  
  434. =item content-language
  435.  
  436. This describes one or more languages that are used in the variant.
  437. Language is described like this in F<draft-ietf-http-v11-spec-00.ps>: A
  438. language is in this context a natural language spoken, written, or
  439. otherwise conveyed by human beings for communication of information to
  440. other human beings.  Computer languages are explicitly excluded.
  441.  
  442. The language tags are defined by RFC 3066.  Examples
  443. are:
  444.  
  445.   no               Norwegian
  446.   en               International English
  447.   en-US            US English
  448.   en-cockney
  449.  
  450. =item content-length
  451.  
  452. This is the number of bytes used to represent the content.
  453.  
  454. =back
  455.  
  456. =head1 ACCEPT HEADERS
  457.  
  458. The following Accept* headers can be used for describing content
  459. preferences in a request (This description is an edited extract from
  460. F<draft-ietf-http-v11-spec-00.ps>):
  461.  
  462. =over 3
  463.  
  464. =item Accept
  465.  
  466. This header can be used to indicate a list of media ranges which are
  467. acceptable as a response to the request.  The "*" character is used to
  468. group media types into ranges, with "*/*" indicating all media types
  469. and "type/*" indicating all subtypes of that type.
  470.  
  471. The parameter q is used to indicate the quality factor, which
  472. represents the user's preference for that range of media types.  The
  473. parameter mbx gives the maximum acceptable size of the response
  474. content. The default values are: q=1 and mbx=infinity. If no Accept
  475. header is present, then the client accepts all media types with q=1.
  476.  
  477. For example:
  478.  
  479.   Accept: audio/*;q=0.2;mbx=200000, audio/basic
  480.  
  481. would mean: "I prefer audio/basic (of any size), but send me any audio
  482. type if it is the best available after an 80% mark-down in quality and
  483. its size is less than 200000 bytes"
  484.  
  485.  
  486. =item Accept-Charset
  487.  
  488. Used to indicate what character sets are acceptable for the response.
  489. The "us-ascii" character set is assumed to be acceptable for all user
  490. agents.  If no Accept-Charset field is given, the default is that any
  491. charset is acceptable.  Example:
  492.  
  493.   Accept-Charset: iso-8859-1, unicode-1-1
  494.  
  495.  
  496. =item Accept-Encoding
  497.  
  498. Restricts the Content-Encoding values which are acceptable in the
  499. response.  If no Accept-Encoding field is present, the server may
  500. assume that the client will accept any content encoding.  An empty
  501. Accept-Encoding means that no content encoding is acceptable.  Example:
  502.  
  503.   Accept-Encoding: compress, gzip
  504.  
  505.  
  506. =item Accept-Language
  507.  
  508. This field is similar to Accept, but restricts the set of natural
  509. languages that are preferred in a response.  Each language may be
  510. given an associated quality value which represents an estimate of the
  511. user's comprehension of that language.  For example:
  512.  
  513.   Accept-Language: no, en-gb;q=0.8, de;q=0.55
  514.  
  515. would mean: "I prefer Norwegian, but will accept British English (with
  516. 80% comprehension) or German (with 55% comprehension).
  517.  
  518. =back
  519.  
  520.  
  521. =head1 COPYRIGHT
  522.  
  523. Copyright 1996,2001 Gisle Aas.
  524.  
  525. This library is free software; you can redistribute it and/or
  526. modify it under the same terms as Perl itself.
  527.  
  528. =head1 AUTHOR
  529.  
  530. Gisle Aas <gisle@aas.no>
  531.  
  532. =cut
  533.