home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl_ste.zip / HTTP / Headers / Util.pm
Text File  |  1997-10-02  |  3KB  |  135 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.2 $ =~ /(\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 provide a few functions that helps parsing and
  25. construction of valid header values.  None of the functions are
  26. exported by default.
  27.  
  28. The following functions are provided:
  29.  
  30. =over 4
  31.  
  32. =item split_header_words( @header_values )
  33.  
  34. This function will split the header values given as argument into a
  35. list of anonymous arrays containing key/value pairs.  The function
  36. know how to deal with ",", ";" and "=" as well as quoted values.
  37. Multiple values are treated as if they were separated by comma.
  38.  
  39. This is easier to describe with an example:
  40.  
  41.    split_header_words('foo="bar"; port="80,81"; discard, bar=baz')
  42.    split_header_words('text/html; charset="iso-8859-1");
  43.  
  44. will return
  45.  
  46.    [foo=>'bar', port=>'80,81', discard=> undef], [bar=>'baz' ]
  47.    ['text/html' => undef, charset => 'iso-8859-1']
  48.  
  49. =cut
  50.  
  51.  
  52. sub split_header_words
  53. {
  54.     my(@val) = @_;
  55.     my @res;
  56.     for (@val) {
  57.     my @cur;
  58.     while (length) {
  59.         if (s/^\s*(=*[^\s=;,]+)//) {
  60.         push(@cur, $1);
  61.         if (s/^\s*=\s*\"([^\"\\]*(?:\\.[^\"\\]*)*)\"//) {
  62.             my $val = $1;
  63.             $val =~ s/\\(.)/$1/g;
  64.             push(@cur, $val);
  65.         } elsif (s/^\s*=\s*([^;,]+)//) {
  66.             my $val = $1;
  67.             $val =~ s/\s+$//;
  68.             push(@cur, $val);
  69.         } else {
  70.             push(@cur, undef);
  71.         }
  72.         } elsif (s/^\s*,//) {
  73.         push(@res, [@cur]);
  74.         @cur = ();
  75.         } elsif (s/^\s*;?//) {
  76.         # continue
  77.         } else {
  78.         warn "This should not happen: $_\n";
  79.         }
  80.     }
  81.     push(@res, \@cur) if @cur;
  82.     }
  83.     @res;
  84. }
  85.  
  86.  
  87. =item join_header_words( @arrays )
  88.  
  89. This will do the opposite convertion of what split_header_words()
  90. does.  It takes a list of anonymous arrays as argument and produce a
  91. single header value.  Attribute values are quoted if needed.  Example:
  92.  
  93.    join_header_words(["text/plain" => undef, charset => "iso-8859/1"]);
  94.  
  95. =cut
  96.  
  97. sub join_header_words
  98. {
  99.     my @res;
  100.     for (@_) {
  101.     my @cur = @$_;
  102.     my @attr;
  103.     while (@cur) {
  104.         my $k = shift @cur;
  105.         my $v = shift @cur;
  106.         if (defined $v) {
  107.         if ($v =~ /^\w+$/) {
  108.             $k .= "=$v";
  109.         } else {
  110.             $v =~ s/([\"\\])/\\$1/g;  # escape " and \
  111.             $k .= qq(="$v");
  112.         }
  113.         }
  114.         push(@attr, $k);
  115.     }
  116.     push(@res, join("; ", @attr)) if @attr;
  117.     }
  118.     join(", ", @res);
  119. }
  120.  
  121. 1;
  122.  
  123. __END__
  124.  
  125. =back
  126.  
  127. =head1 COPYRIGHT
  128.  
  129. Copyright 1997, Gisle Aas
  130.  
  131. This library is free software; you can redistribute it and/or
  132. modify it under the same terms as Perl itself.
  133.  
  134. =cut
  135.