){
my $x;
$s=~s/(.*?)\: (.*?)[\r\n]/$x=uc($1);$2/ge;
if(defined($x)){
$x=~s/-/_/g;
$x="HTTP_$x";
$x=~s/HTTP_CONTENT/CONTENT/g;
$ENV{$x}=$s
}
}
if(!$methods{$ENV{'REQUEST_METHOD'}=uc($request[0])}){
@err=(405,$request[0]);
ERR:
goto DAEMON if($$==$mainpid && fork);
die defined(@err)?"Status: $err[0]\n\n$err[0] $rfc2068_status{$err[0]}: '$err[1]'\n":" \n"
}
$RANGE[3]=~s/bytes\=(.*?)-(.*?)\n/@RANGE[0,1]=($1,$2);1/gse if($RANGE[3]=$ENV{'HTTP_RANGE'});
($file,$ENV{'QUERY_STRING'})=split(/\?/,$ENV{'REQUEST_URI'}=$request[1],2);
$file="/$file" if(substr($file,0,1) ne '/');
$file.="\n";
$file=~s/(\/.*?)\/\.\.([\/\n])/$1$2/g;
chomp($file);
$ENV{'REDIRECT_URI'}=$ENV{'SCRIPT_NAME'}=$file||='/';
if(exists($contents_uri{$file})){
$content=$contents_uri{$file};
($content,@guid[0,1])=@$content;
goto EXEC_CGI
}
for(sort keys %map){
my @mask=split(/ /,$_,2);
$content=$file;
$content=~s/$mask[1]//;
if($content eq ''){
undef $content;
$options{$_}='' for(split(//,$mask[0]));
$RANGE[5]=exists($options{'H'});
my $e=$map{$_};
$file=~s/$mask[1]/&$e/e;
$file=~s/\[(.*?)\:(.*?)\]/my $g=($2+0 eq $2||$2 eq ''?$2:getgrnam($2));my $u=($1+0 eq $1||$1 eq ''?$1:getpwnam($1)); die "Invalid uid or gid\n" if(!(defined($u)&&defined($g)));@guid=($u,$g);''/e if(substr($file,0,1) eq '[');
if($$!=$mainpid){
$)="$guid[1] ".($(=$guid[1]) if($guid[1]!=-1);
$<=$>=$guid[0] if($guid[0]!=-1)
}
$ENV{'SCRIPT_FILENAME'}=$file;
undef my @stat;
my $filetype=-d $file?1:-x$file?2:3;
if($filetype==2){
if(exists($contents{$file})){
@stat=stat($file);
if($stat[9]==$contents{$file}[12]){
$content=$contents{$file};
($content,@guid[0,1])=@$content;
goto EXEC_CGI
}
delete($contents{$file})
}
open FH,"<$file" or goto ERR;
@stat=stat(FH) if(!defined(@stat));
read FH,$content,$stat[7] or goto ERR;
close FH;
$content=~s/#\![ ]{0,}(.*?)\n/my $x;for(split(\/[ ]\/,$1)){if(substr($_,0,1) eq '-' && defined(my $o=$opt{substr($_,1,1)})){$x.=&$o(quotemeta(substr($_,2))).';'}};$x/gse if(substr($content,0,2) eq '#!');
$guid[1]=$stat[5] if($stat[2]&02000);
$guid[0]=$stat[4] if($stat[2]&04000);
if($mainpid){
if(!exists($options{'n'})){
$content=eval "sub \{ $content \};";
if(exists($options{'X'})){
$contents_uri{$ENV{'REDIRECT_URI'}}=[$content,@guid]
}elsif(exists($options{'x'})){
$contents{$file}=[$content,@guid,@stat]
}
EXEC_CGI:
$mode=1
}
goto DAEMON if($$==$mainpid && fork);
}
$)="$guid[1] ".($(=$guid[1]) if($guid[1]!=-1);
$<=$>=$guid[0] if($guid[0]!=-1);
if($mode){
exit &$content
}else{
return $content
}
}
goto DAEMON if($$==$mainpid && fork);
@RANGE[2,5]=($RANGE[3],1);
if($filetype==1){
opendir DH,$file or goto ERR;
@stat=stat(DH);
my $s="Index of $ENV{'REQUEST_URI'}";
$s="$s$s
";
for(readdir(DH)){
my @st=stat("$file$_");
$_=~s/([\x00-\x1f,:\"\'\\])/sprintf('%%%02X',ord($1))/eg;
$_.='/' if(-d "$file$_");
$s.="$_ ".localtime($st[9])." $st[7]\n"
}
$s.="
$ENV{'SERVER_SIGNATURE'}";
close DH;
print "Last-Modified: ".localtime($stat[9]),"\nContent-type: text/html\nContent-length: ",length($s),"\n\n",$s
}else{
open FH,"<$file" or goto ERR;
@stat=stat(FH) if(!defined(@stat));
my $l=$stat[7];
my $h="Last-Modified: ".localtime($stat[9])."\nContent-Length: $l\n";
my @x=(split(/\./,$file))[-1,-2];
my ($t,$enc,$n);
read(FH,$content,$n=$l<1024?$l:1024) or goto ERR;
if(substr($content,0,14) eq '=0 && ($t=$mime{$x[1]})){
$h.="Content-encoding: $enc\n"
}
if($RANGE[3]){
substr($content,$n=$l)='' if($RANGE[1] ne ''&&($l=$RANGE[1]+1)<$n);
if($RANGE[0]){
$content='';
seek(FH,$n=$RANGE[0],0) or goto ERR;
seek(STDOUT,$n,0);
}
}
$t||=$mime{$x[0]}||(-B $file?'binary/unknown':'text/plain');
print $h,"Content-type: $t\n\n",$content;
while($l-=$n){
read(FH,$content,$n=$l<1024?$l:1024) or goto ERR;
print $content
}
close FH
}
exit
}
}
}
{
package phttpd;
my ($pos,$buf);
sub TIEHANDLE{bless({})}
sub SEEK{
$pos=0 if(!$_[2]);
$buf='' if(!($pos+=$_[1]))
}
sub PRINT{
shift;
my ($b,$l);
if($RANGE[4]){$b=join('',@_)}
else{
($buf,$b)=split(/[\r]{0,}\n[\r]{0,}\n[\r]{0,}/,join('',$buf,@_),2);
if(defined($b)){
my %hh=('Content-type'=>'text/html','Status'=>200,'Server'=>$ENV{'SERVER_SOFTWARE'},'Date'=>''.localtime(time),'Connection'=>'close');
$_=~s/(.*?)\:[ ]{1,}(.*)[\r]{0,}/$hh{ucfirst(lc($1))}=$2/e for(split("\n",$buf));
if($RANGE[3] && !exists($hh{'Content-range'})){
$RANGE[4]=$RANGE[5]+1;
my $l=$hh{'Content-length'};
if($l ne ''){
$hh{'Content-length'}=(($l<=$RANGE[1]||$RANGE[1] eq '')?$RANGE[1]=$l-1:$RANGE[1])+1-$RANGE[0]
}else{$l='*'}
$hh{'Content-range'}="bytes $RANGE[0]-$RANGE[1]/$l";
$hh{'Status'}=206
}
$buf=delete($hh{'Status'});
$buf="$ENV{'SERVER_PROTOCOL'} $buf $rfc2068_status{$buf}\n";
while(my ($x,$y)=each %hh){$buf.="$x: $y\n"}
untie *STDOUT;
print "$buf\n";
if($ENV{'REQUEST_METHOD'} eq 'HEAD'){
exit if($RANGE[5]);
$RANGE[4]=$RANGE[0]=$RANGE[1]=-1
}elsif(!$RANGE[4]){return print $b}
}else{return 1}
}
$l=length($b);
if($RANGE[1] ne ''){
if($pos>$RANGE[1]){
exit if($RANGE[4]==2);
goto RET
}elsif((my $n=$pos+$l-1-$RANGE[1])>0){
substr($b,-$n)='';
$pos+=$n;
$l-=$n
}
}
if((my $n=$RANGE[0]-$pos)>0){
if($n>$l){$n=$l;$b=''}
else{substr($b,0,$n,'')}
$pos+=$n;
$l-=$n
}
if($l>0){
untie *STDOUT;
print $b;
$pos+=$l
}
RET:
tie(*STDOUT,'phttpd') if($RANGE[4] && !tied(*STDOUT));
1
}
}
eval httpd(@ARGV)