Return to Common.pm CVS log

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

format the requestURL variable expected by OAI protocol

    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: 
   18: use Date::Format;
   19: 
   20: sub requestURL {
   21:     my $requestURL=$ENV{'HTTP_HOST'}.$ENV{'REQUEST_URI'};
   22:     return $requestURL;
   23: }
   24: 
   25: sub responseDate {
   26:     my $responseDate=Date::Format::time2str("%Y-%m-%dT%T%z",time);
   27:     $responseDate=~s/(..)$/\:$1/;
   28:     return $responseDate;
   29: }
   30: 
   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;