git.maemo.org Git - dh-make-perl/blob - dev/arm/libwww-perl/libwww-perl-5.813/lib/HTTP/Headers/Util.pm

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