add function reading HTTP header from ENV (CGI)

diff --git a/botm_common.pm b/botm_common.pm
index a479feb6b5877e822769959be2cdd1e0d6f95be1..19e4ff8ffc6584f021d5963be5391615b0555325 100644 (file)
--- a/botm_common.pm
+++ b/botm_common.pm
@@ -25,12 +25,12 @@ use Encode ('encode', 'decode');
 
 use Exporter;
 
-our $VERSION     = '1.0.18';
+our $VERSION     = '1.0.19';
 our @ISA         = qw(Exporter);
 our @EXPORT      = ();
 our @EXPORT_OK   = (
        'read_data_file', 'write_data_file', 'write_postdata_file',
-       'read_header_file',
+       'read_header_file', 'read_header_env',
        'url_encode', 'url_decode',
        'url_query_encode', 'url_query_decode',
        'split_url', 'join_url', 'merge_url',
@@ -484,6 +484,40 @@ sub read_header_file {
        return %data;
 }
 
+# NOTE: !at this point I don't know if the ENV has the HTTP header
+# data encoded or decoded. But doesn't really matter as the header
+# shouldn't have non-ASCII data anyway
+sub read_header_env {
+       (my $env) = @_;
+       
+       my %data;
+       
+       foreach my $key (keys %$env) {
+               my $name = '';
+               my $value= '';
+               
+               if ($key =~ /^HTTP_([A-Z0-9_]+)$/) {
+                       $name=$1;
+               }
+               elsif ($key =~ /^(CONTENT_[A-Z0-9_]+)$/) {
+                       $name=$1;
+               }
+               else{
+                       next;
+               }
+               $name =~ s/_/-/g;
+               $name = lc($name);
+               if ($$env{$key} =~ /^([\x20-\x7e]*)$/) {
+                       $value=$1;
+               }
+               else {
+                       next;
+               }
+               $data{$name}=$value;
+       }
+       return %data;
+}
+
 ###########
 ##  URL  ##
 ###########
@@ -521,7 +555,7 @@ sub url_encode {
        (my $t, my $encoding, my $all) = @_;
        
        if ($encoding eq '') {
-               $encoding = "UTF-8";
+               $encoding = 'UTF-8';
        }
 
        if ($all) {
@@ -540,7 +574,7 @@ sub url_encode_1ch {
        (my $ch, my $encoding) = @_;
        
        if ($encoding eq '') {
-               $encoding = "UTF-8";
+               $encoding = 'UTF-8';
        }
        $ch = encode($encoding, $ch);
        $ch =~ s/(.)/sprintf('%%%02X',ord($1))/egs;
@@ -555,7 +589,7 @@ sub url_decode {
        (my $t, my $encoding) = @_;
        
        if ($encoding eq '') {
-               $encoding = "utf8";
+               $encoding = 'utf8';
        }
        $t =~ s/((%[0-9A-Fa-f]{2})+)/url_decode_xch($1)/egs;
        return $t;
@@ -569,7 +603,7 @@ sub url_decode_xch {
        my $y = '';
        
        if ($encoding eq '') {
-               $encoding = "utf8";
+               $encoding = 'utf8';
        }
        while ($xch ne '') {
                $y .= chr(hex(substr($xch, 1, 2)));
@@ -819,6 +853,8 @@ sub url_query_decode {
        (my $query, my $encoding) = @_;
        my %data;
        
+       $query =~ s/\n$//s;
+       $query =~ s/\r$//s;
        my @list = split('&', $query);
        foreach my $entry (@list) {
                (my $name, my $value) = split('=', $entry, 2);
@@ -3335,7 +3371,4 @@ sub html_entity_decode_1en {
        }
 }
 
-
-
-
 1