home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _6ade10c786dd7b3611e85e0fd48b12e4 < prev    next >
Text File  |  2000-03-15  |  5KB  |  181 lines
  1. package HTTP::Headers::Util;
  2.  
  3. use strict;
  4. use vars qw($VERSION @ISA @EXPORT_OK);
  5.  
  6. $VERSION = sprintf("%d.%02d", q$Revision: 1.8 $ =~ /(\d+)\.(\d+)/);
  7.  
  8. require Exporter;
  9. @ISA=qw(Exporter);
  10.  
  11. @EXPORT_OK=qw(split_header_words join_header_words);
  12.  
  13. =head1 NAME
  14.  
  15. HTTP::Headers::Util - Header value parsing utility functions
  16.  
  17. =head1 SYNOPSIS
  18.  
  19.   use HTTP::Headers::Util qw(split_header_words);
  20.   @values = split_header_words($h->header("Content-Type"));
  21.  
  22. =head1 DESCRIPTION
  23.  
  24. This module provides a few functions that helps parsing and
  25. construction of valid HTTP header values.  None of the functions are
  26. exported by default.
  27.  
  28. The following functions are available:
  29.  
  30. =over 4
  31.  
  32.  
  33. =item split_header_words( @header_values )
  34.  
  35. This function will parse the header values given as argument into a
  36. list of anonymous arrays containing key/value pairs.  The function
  37. knows how to deal with ",", ";" and "=" as well as quoted values after
  38. "=".  A list of space separated tokens are parsed as if they were
  39. separated by ";".
  40.  
  41. If the @header_values passed as argument contains multiple values,
  42. then they are treated as if they were a single value separated by
  43. comma ",".
  44.  
  45. This means that this function is useful for parsing header fields that
  46. follow this syntax (BNF as from the HTTP/1.1 specification, but we relax
  47. the requirement for tokens).
  48.  
  49.   headers           = #header
  50.   header            = (token | parameter) *( [";"] (token | parameter))
  51.  
  52.   token             = 1*<any CHAR except CTLs or separators>
  53.   separators        = "(" | ")" | "<" | ">" | "@"
  54.                     | "," | ";" | ":" | "\" | <">
  55.                     | "/" | "[" | "]" | "?" | "="
  56.                     | "{" | "}" | SP | HT
  57.  
  58.   quoted-string     = ( <"> *(qdtext | quoted-pair ) <"> )
  59.   qdtext            = <any TEXT except <">>
  60.   quoted-pair       = "\" CHAR
  61.  
  62.   parameter         = attribute "=" value
  63.   attribute         = token
  64.   value             = token | quoted-string
  65.  
  66. Each I<header> is represented by an anonymous array of key/value
  67. pairs.  The value for a simple token (not part of a parameter) is C<undef>.
  68. Syntactically incorrect headers will not necessary be parsed as you
  69. would want.
  70.  
  71. This is easier to describe with some examples:
  72.  
  73.    split_header_words('foo="bar"; port="80,81"; discard, bar=baz')
  74.    split_header_words('text/html; charset="iso-8859-1");
  75.    split_header_words('Basic realm="\"foo\\bar\""');
  76.  
  77. will return
  78.  
  79.    [foo=>'bar', port=>'80,81', discard=> undef], [bar=>'baz' ]
  80.    ['text/html' => undef, charset => 'iso-8859-1']
  81.    [Basic => undef, realm => '"foo\bar"']
  82.  
  83. =cut
  84.  
  85.  
  86. sub split_header_words
  87. {
  88.     my(@val) = @_;
  89.     my @res;
  90.     for (@val) {
  91.     my @cur;
  92.     while (length) {
  93.         if (s/^\s*(=*[^\s=;,]+)//) {  # 'token' or parameter 'attribute'
  94.         push(@cur, $1);
  95.         # a quoted value
  96.         if (s/^\s*=\s*\"([^\"\\]*(?:\\.[^\"\\]*)*)\"//) {
  97.             my $val = $1;
  98.             $val =~ s/\\(.)/$1/g;
  99.             push(@cur, $val);
  100.         # some unquoted value
  101.         } elsif (s/^\s*=\s*([^;,\s]*)//) {
  102.             my $val = $1;
  103.             $val =~ s/\s+$//;
  104.             push(@cur, $val);
  105.         # no value, a lone token
  106.         } else {
  107.             push(@cur, undef);
  108.         }
  109.         } elsif (s/^\s*,//) {
  110.         push(@res, [@cur]) if @cur;
  111.         @cur = ();
  112.         } elsif (s/^\s*;// || s/^\s+//) {
  113.         # continue
  114.         } else {
  115.         die "This should not happen: '$_'";
  116.         }
  117.     }
  118.     push(@res, \@cur) if @cur;
  119.     }
  120.     @res;
  121. }
  122.  
  123.  
  124. =item join_header_words( @arrays )
  125.  
  126. This will do the opposite of the conversion done by split_header_words().
  127. It takes a list of anonymous arrays as arguments (or a list of
  128. key/value pairs) and produces a single header value.  Attribute values
  129. are quoted if needed.
  130.  
  131. Example:
  132.  
  133.    join_header_words(["text/plain" => undef, charset => "iso-8859/1"]);
  134.    join_header_words(""text/plain" => undef, charset => "iso-8859/1");
  135.  
  136. will both return the string:
  137.  
  138.    text/plain; charset="iso-8859/1"
  139.  
  140. =cut
  141.  
  142. sub join_header_words
  143. {
  144.     @_ = ([@_]) if @_ && !ref($_[0]);
  145.     my @res;
  146.     for (@_) {
  147.     my @cur = @$_;
  148.     my @attr;
  149.     while (@cur) {
  150.         my $k = shift @cur;
  151.         my $v = shift @cur;
  152.         if (defined $v) {
  153.         if ($v =~ /^\w+$/) {
  154.             $k .= "=$v";
  155.         } else {
  156.             $v =~ s/([\"\\])/\\$1/g;  # escape " and \
  157.             $k .= qq(="$v");
  158.         }
  159.         }
  160.         push(@attr, $k);
  161.     }
  162.     push(@res, join("; ", @attr)) if @attr;
  163.     }
  164.     join(", ", @res);
  165. }
  166.  
  167. 1;
  168.  
  169. __END__
  170.  
  171. =back
  172.  
  173. =head1 COPYRIGHT
  174.  
  175. Copyright 1997-1998, Gisle Aas
  176.  
  177. This library is free software; you can redistribute it and/or
  178. modify it under the same terms as Perl itself.
  179.  
  180. =cut
  181.