Return to Common.pm CVS log

Up to [LON-CAPA] / nsdl / lib / perl / Apache / GATEWAY

Annotation of nsdl/lib/perl/Apache/GATEWAY/Common.pm, revision 1.3

1.1       harris41    1: # Apache::GATEWAY::Common
                      2: #
                      3: # Common.pm
                      4: # API for common gateway routines.
                      5: #
                      6: # For more documentation, read the POD documentation
                      7: # of this module with the perldoc command:
                      8: #
                      9: #         perldoc ./Common.pm
                     10: #
                     11: # Year 2002
                     12: # Scott Harrison
                     13: #
                     14: ###
                     15: 
                     16: package Apache::GATEWAY::Common;
                     17: 
1.2       harris41   18: use Date::Format;
                     19: 
1.3     ! harris41   20: sub requestURL {
        !            21:     my $requestURL=$ENV{'HTTP_HOST'}.$ENV{'REQUEST_URI'};
        !            22:     return $requestURL;
        !            23: }
        !            24: 
1.2       harris41   25: sub responseDate {
                     26:     my $responseDate=Date::Format::time2str("%Y-%m-%dT%T%z",time);
                     27:     $responseDate=~s/(..)$/\:$1/;
                     28:     return $responseDate;
                     29: }
                     30: 
1.1       harris41   31: sub readCGI {
                     32:     my $r=shift;
                     33: # -------------------------------------------------------- Load POST parameters
                     34:     my $buffer;
                     35: 
                     36:     $r->read($buffer,$r->header_in('Content-length'));
                     37:     
                     38:     unless ($buffer=~/^(\-+\w+)\s+Content\-Disposition\:\s*form\-data/si) {
                     39: 	my @pairs=split(/&/,$buffer);
                     40: 	my $pair;
                     41: 	foreach $pair (@pairs) {
                     42: 	    my ($name,$value) = split(/=/,$pair);
                     43: 	    $value =~ tr/+/ /;
                     44: 	    $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
                     45: 	    $name  =~ tr/+/ /;
                     46: 	    $name  =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
                     47: 	    &add_to_env("form.$name",$value);
                     48: 	}
                     49:     } else {
                     50: 	my $contentsep=$1;
                     51: 	my @lines = split (/\n/,$buffer);
                     52: 	my $name='';
                     53: 	my $value='';
                     54: 	my $fname='';
                     55: 	my $fmime='';
                     56: 	my $i;
                     57: 	for ($i=0;$i<=$#lines;$i++) {
                     58: 	    if ($lines[$i]=~/^$contentsep/) {
                     59: 		if ($name) {
                     60: 		    chomp($value);
                     61: 		    if ($fname) {
                     62: 			$ENV{"form.$name.filename"}=$fname;
                     63: 			$ENV{"form.$name.mimetype"}=$fmime;
                     64: 		    } else {
                     65: 			$value=~s/\s+$//s;
                     66: 		    }
                     67: 		    &add_to_env("form.$name",$value);
                     68: 		}
                     69: 		if ($i<$#lines) {
                     70: 		    $i++;
                     71: 		    $lines[$i]=~
                     72: 		/Content\-Disposition\:\s*form\-data\;\s*name\=\"([^\"]+)\"/i;
                     73: 		    $name=$1;
                     74: 		    $value='';
                     75: 		    if ($lines[$i]=~/filename\=\"([^\"]+)\"/i) {
                     76: 			$fname=$1;
                     77: 			if 
                     78:                             ($lines[$i+1]=~/Content\-Type\:\s*([\w\-\/]+)/i) {
                     79: 				$fmime=$1;
                     80: 				$i++;
                     81: 			    } else {
                     82: 				$fmime='';
                     83: 			    }
                     84: 		    } else {
                     85: 			$fname='';
                     86: 			$fmime='';
                     87: 		    }
                     88: 		    $i++;
                     89: 		}
                     90: 	    } else {
                     91: 		$value.=$lines[$i]."\n";
                     92: 	    }
                     93: 	}
                     94:     }
                     95:     my $query=$r->args;
                     96:     foreach (split(/&/,$query)) {
                     97: 	my ($name, $value) = split(/=/,$_);
                     98: #	$name = &Apache::lonnet::unescape($name);
                     99: 	$value =~ tr/+/ /;
                    100: 	$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
                    101:    unless (defined($ENV{'form.'.$name})) { &add_to_env('form.'.$name,$value) };
                    102:     }
                    103: }
                    104: 
                    105: sub add_to_env {
                    106:     my ($name,$value)=@_;
                    107:     if (defined($ENV{$name})) {
                    108: 	if (ref($ENV{$name})) {
                    109: 	    #already have multiple values
                    110: 	    push(@{ $ENV{$name} },$value);
                    111: 	} else {
                    112:     #first time seeing multiple values, convert hash entry to an arrayref
                    113: 	    my $first=$ENV{$name};
                    114: 	    undef($ENV{$name});
                    115: 	    push(@{ $ENV{$name} },$first,$value);
                    116: 	}
                    117:     } else {
                    118: 	$ENV{$name}=$value;
                    119:     }
                    120: }
                    121: 
                    122: 1;