read HTTP header

diff --git a/botm_common.pm b/botm_common.pm
index 0277cab838a0c3564c51fade6a44f9b4c510344a..9ddb13d75abfdf3fa3948b1c8a1ab210ea40361c 100644 (file)
--- a/botm_common.pm
+++ b/botm_common.pm
@@ -25,11 +25,12 @@ use Encode ('encode', 'decode');
 
 use Exporter;
 
-our $VERSION     = '1.0.12';
+our $VERSION     = '1.0.13';
 our @ISA         = qw(Exporter);
 our @EXPORT      = ();
 our @EXPORT_OK   = (
        'read_data_file', 'write_data_file',
+       'read_header_file',
        'url_encode', 'url_decode',
        'url_query_encode', 'url_query_decode',
        'split_url', 'join_url', 'merge_url',
@@ -317,6 +318,114 @@ sub write_data_file {
 
 
 
+###################
+##  HTTP HEADER  ##
+###################
+
+# https://tools.ietf.org/html/rfc2616#section-4.2
+
+# read_header_file() reads a HTTP header file and returns a hash with
+# the header values.
+# The status line is returned under :http-version, :status-code and
+# :reason-phrase.
+# all header field names are converted to lowercase.
+#
+# $file is the path to the file to read.
+# file will be opened, read, and closed.
+#
+# alternatively, $file can be an filehandle for already opened file
+# (or STDIN).
+# in this case a fseek to the beginning will be attempted and file
+# will be read and not closed afterwards.
+#
+# File reading stops at end of header, to be able to resume reading
+# afterwards.
+#
+# $encoding is the text encoding of the file to read.
+# if left empty, this will default to "utf8".
+# encoding of an already opened file will not be changed by this.
+#
+sub read_header_file {
+       (my $file, my $encoding) = @_;
+       my $fh;
+       my %data;
+       my $status_line=1;
+       
+       if ($encoding eq '') {
+               $encoding = 'utf8';
+       }
+       
+       # check if $file is actually a path or maybe a filehandle
+       # filehandles are references.
+       if(ref($file)) {
+               $fh=$file;
+               unless (seek($fh, 0, 0)) {
+                       # return %data;
+               }
+       }
+       else {
+               unless (open ($fh, "<:encoding($encoding)", encode('locale_fs', $file))) {
+                       return %data;
+               }
+       }
+       
+       # The name of header field in previous line. Required for header fields that
+       # occupy multiple lines.
+       my $lastname='';
+       
+       while (defined(my $line = <$fh>)) {
+               $line =~ s/[\n]$//g;
+               $line =~ s/[\r]$//g;
+               
+               if ($status_line) {
+                       $line =~ /^([^ ]+) +([^ ]+)( +([^ ].*))?$/;
+                       $data{':http-version'} = $1;
+                       $data{':status-code'} = $2;
+                       $data{':reason-phrase'} = $4;
+                       $status_line = 0;
+                       next;
+               }
+               
+               # $line = decode($encoding, $line);
+               my $name='';
+               my $value='';
+               
+               # Empty line - end of header.
+               if ($line eq ''){
+                       last;
+               }
+               
+               # Line starts with LWS. It's a continuation of the previous line.
+               # Concatenate the field value.
+               elsif($line =~ /^[ \t]+([^ \t](.*[^ \t])?)[ \t]*$/) {
+                       if($lastname ne '') {
+                               $data{$lastname} .= $1;
+                       }
+               }
+               # Line starts with a name followed by colon
+               elsif ($line =~ /^([^:]+):[ \t]*([^ \t](.*[^ \t])?)[ \t]*$/) {
+                       $name = lc($1);
+                       $value = $2;
+                       # If there already was a header field with the same name then the value
+                       # is concantenated, separated by comma.
+                       if ($data{$name} ne '') {
+                               $data{$name}.=', '.$value;
+                       }
+                       # otherwise just save the value
+                       else {
+                               $data{$name} = $value;
+                       }
+                       $lastname = $name;
+               }
+       }
+       # If argument was a path the file must be closed. 
+       unless (ref($file)) {
+               close ($fh);
+       }
+       
+       return %data;
+}
+
 ###########
 ##  URL  ##
 ###########