From: b <rowerynaksiezycu@gmail.com>
Date: Wed, 5 Jul 2023 21:57:54 +0000 (+0000)
Subject: read HTTP header
X-Git-Tag: v1.0.13
X-Git-Url: http://bicyclesonthemoon.info/git-projects/?a=commitdiff_plain;h=refs%2Ftags%2Fv1.0.13;p=botm%2Fcommon-perl

read HTTP header
---

diff --git a/botm_common.pm b/botm_common.pm
index 0277cab..9ddb13d 100644
--- 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  ##
 ###########