){$s=~s/(.*?)\: (.*?)[\r\n]/my $x=$1;$x=~tr\/-a-z\/_A-Z\/;$ENV{substr($x,0,7) eq 'CONTENT'?$x:"HTTP_$x"}=$2/ge}
if($_=$domain{"$ENV{'HTTP_HOST'}"}){
@err=&$_;
$content=$err[1];
goto STD if($err[0]);
print $content
}
$RANGE[12]=0;
$RANGE[3]=~s/bytes\=([0-9]*)-([0-9]*)/@RANGE[0,1]=($1,$2);1/gse if($RANGE[3]=$ENV{'HTTP_RANGE'});
$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||='/';
goto (MAP_OK,EXEC_CGI)[$mode=((($content,@stat)=@{$contents{$file=$content}})!=0)] if(($content,@guid)=@{$URIs{$file}});
my $u;
($file,$u)=translate($map,$file);
goto E404 if(!defined($file));
while(my ($k,$v)=each %$u){if($v eq '!'){delete($options{$k})}else{$options{$k}=$v}}
for(0,1){defined($guid[$_]=defined($u=$options{('user','group')[$_]})&&$u ne ''?$u+0 eq $u?$u:$_?getgrnam($u):getpwnam($u):-1)||goto ESEC};
MAP_OK:
if($guid[1]!=-1){
$)="$guid[1] $guid[1]";
if($) ne "$guid[1] $guid[1]"){
ESEC:
wlog('Security->reload');
$RANGE[2]=0;
$content="Status: 302\nLocation: $ENV{'REQUEST_URI'}\n\nSecurity error, close/reload.";
goto STD;
ESEC2:
$RANGE[2]=0;
@err=(500,"Security error");
goto ERR
}
}
if($guid[0]!=-1){
$>=$guid[0];
goto ESEC if($> ne $guid[0]);
}
@stat=stat($file);
if(-d _){
&xfork(1) && goto DAEMON; TH1:
my $s=$ENV{'REQUEST_URI'};
if(substr($s,-1) ne '/'){
print "Status: 301\nLocation: $s/\n\n";
goto &ex
}
opendir FH,$file or goto ERR;
if($ENV{'REQUEST_METHOD'} eq 'PROPFIND'){
# todo: chunked input
my ($i,$j);
for($i=$ENV{'CONTENT_LENGTH'}; $i>0; $i-=$j){
$j=read(STDIN,$s,$filebuf<$i?$filebuf:$i) || last;
}
$RANGE[2]=0 if($RANGE[2]<4); # davfs2 chunked bug?
$s= "Status: 207\nContent-type: text/xml\nLast-Modified: ".gmtime($stat[9]).'
';
for(readdir(FH)){
my @st=stat("$file$_");
$_=~s/([\x00-\x1f,:\"\'\\])/sprintf('%%%02X',ord($1))/eg;
$s.=qq($_
':'/>').'
'.gmtime($st[9])."
$st[7]
HTTP/1.1 200 OK
";
if(length($s)>$filebuf){
print $s or goto ERR;$s='';
last if($RANGE[1]==-1)
}
}
close FH;
print $s.'' or goto ERR;
}else{
$s="Index of $s";
$s="Last-Modified: ".gmtime($stat[9])."\nContent-type: text/html\n\n$s$s
";
for(readdir(FH)){
my @st=stat("$file$_");
$_=~s/([\x00-\x1f,:\"\'\\])/sprintf('%%%02X',ord($1))/eg;
$_.='/' if(-d _);
$s.="$_ ".localtime($st[9])." $st[7]\n";
if(length($s)>$filebuf){
print $s or goto ERR;$s='';
last if($RANGE[1]==-1)
}
}
close FH;
print "$s
$ENV{'SERVER_SIGNATURE'}" or goto ERR;
}
wlog('dir')
}elsif(-x _ &&!exists($options{'nocgi'})){
if(($content,my @s)=@{$contents{$file}}){
goto EXEC_CGI if($mode=($stat[9]==$s[9]));
delete($contents{$file})
}
open FH,"<$file" or goto ERR;
read(FH,$content,$stat[7]) or goto ERR;
close FH;
$content=~s/#\![ ]*(.*?)\n/my $x;for(split(\/[ ]\/,$1)){if(substr($_,0,1) eq '-' && defined(my $o=$opt{substr($_,1,1)})){$x.=&$o(quotemeta(substr($_,2))).';'}};"$x\n"/gse if(substr($content,0,2) eq '#!');
$URIs{$ENV{'SCRIPT_NAME'}}=[$file,@guid] if(exists($options{'X'}));
$contents{$file}=[$content=xeval("sub \{ $content\n\};"),@stat] if(($mode=exists($options{'x'})&&(exists($OPTIONS{'x'})||2))==1);
EXEC_CGI:
&xfork(2) && goto DAEMON; TH2:
wlog('CGI');
for(\&CGI::initialize_globals){defined(&$_)&&&$_}
$guid[1]=$stat[5] if($stat[2]&02000);
$guid[0]=$stat[4] if($stat[2]&04000);
chown @guid,$out;
close($SERVER);
$saveguid[1]=$(=$)="$guid[1] $guid[1]" if($guid[1]!=-1);
$saveguid[0]=$<=$>=$guid[0] if($guid[0]!=-1);
$RANGE[5]=exists($options{'H'});
$RANGE[2]=0 if($RANGE[2]<3);
@ARGV=();
$0=$PROGRAM_NAME=$ENV{'SCRIPT_FILENAME'}=$file;
$contents{$file}=[$content=xeval("sub \{ $content\n\};"),@stat] if($mode==2);
die $@ if($@);
return $mode,$content if($RANGE[2]<3&&!$tid); # ?
$mode?&$content:xeval($content);
$^W=0;
die $@ if($@);
}elsif(-e _){
&xfork(3) && goto DAEMON; TH3:
open FH,"<$file" or goto ERR;
$RANGE[2]=3 if($RANGE[2]>3);
my $l=$stat[7];
my $h="Last-Modified: ".gmtime($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]){
seek(FH,$pos,0) or goto ERR if($pos=$RANGE[0]);
$n=length($content=substr($content,$pos,$RANGE[1] ne ''?($l=$RANGE[1]+1-$pos):($l-=$pos)))
}
$t||=$mime{$x[0]}||(-B _?'binary/unknown':'text/plain');
$h.="Content-type: $t\n\n";
print $h,$content or goto ERR;
if($RANGE[1]!=-1){
while($l-=$n){
read(FH,$content,$n=$l<$filebuf?$l:$filebuf) or goto ERR;
print_($content) or goto ERR
}
}
close FH;
wlog('file');
}else{
E404:
@err=(404,$file);
ERR:
wlog('ERROR:',@err);
if(!$err[1]){
&xfork(4) && goto DAEMON; TH4:
die " \n"
}
$content="Status: $err[0]\n\n$err[0] $rfc2068_status{$err[0]}: '$err[1]'";
STD:
&xfork(5) && goto DAEMON; TH5:
@RANGE[3,6]=(0,1);
print $content
}
print_("0\n\n") if($CHUNKED);
if($RANGE[2]==5){
$RANGE[6]=1;
print ''
}
goto &ex if(!$RANGE[2]);
$OPTIONS{'t'}=abs($RANGE[10]) if($OPTIONS{'t'}>abs($RANGE[10]));
($>,$))=@saveguid;
goto (ALIVE,ESEC)[$> ne $saveguid[0] || $) ne $saveguid[1]]
}
sub TIEHANDLE{bless({})}
sub SEEK{
$rpos=$pos=0 if(!$_[2]);
$buf='' if(!($rpos=$pos+=$_[1]))
}
sub PRINT{
shift;
my ($b,$l,$ll,$n,$h0);
if($RANGE[2]==5){
if((!$RANGE[6])&&!($RANGE[13]&&length($buf)>$RANGE[13])){
$buf.=join('',@_);
return 1
}
$RANGE[2]=3
}
if($RANGE[4]){$ll=length($b=join('',@_))}
else{
($buf,$b)=split(/[\r]*\n[\r]*\n[\r]*/,join('',$buf,@_),2);
if(defined($b)){
$ll=length($b);
if($RANGE[2]){
$l=lc($ENV{'HTTP_CONNECTION'}||'');
$h0=$ENV{'SERVER_PROTOCOL'} lt 'HTTP/1.1';
$RANGE[2]=0 if($l eq 'close'||($h0&&$l ne 'keep-alive'));
}
my %hh=('Content-type'=>'text/html','Status'=>200,'Server'=>$ENV{'SERVER_SOFTWARE'},'Date'=>''.gmtime($time=time));
$_=~s/(.*?)\:[ ]+(.*)[\r]*/$hh{ucfirst(lc($1))}=$2/e for(split(/\n/,$buf));
if($ENV{'REQUEST_METHOD'} eq 'OPTIONS'){
$l=$hh{'Content-length'}=0;
$hh{'DAV'}=1;
}elsif(exists($hh{'Content-length'})){
$l=$hh{'Content-length'}
}elsif($RANGE[6]){
$hh{'Content-length'}=$l=$ll
}elsif($RANGE[2]==4){
$buf.="\n\n$b";
$RANGE[2]=5;
return 1
}else{
$RANGE[2]=0 if($h0);
$l='*'
}
if(lc($hh{'Connection'}||=$RANGE[2]?'keep-alive':'close') eq 'close'){
$RANGE[2]=0
}elsif($RANGE[10] && (my $x=$ENV{'HTTP_KEEP_ALIVE'})){
if($RANGE[10]>$x){$RANGE[10]=$x}
elsif($RANGE[10]!=$x){$hh{'Keep-alive'}||="timeout=$RANGE[10]"}
}
if($RANGE[3] && !exists($hh{'Content-range'})){
$RANGE[4]=$RANGE[5]+1;
$hh{'Content-length'}=(($l<=$RANGE[1]||$RANGE[1] eq '')?$RANGE[1]=$l-1:$RANGE[1])+1-$RANGE[0] if($l ne '*');
$hh{'Content-range'}="bytes $RANGE[0]-$RANGE[1]/$l";
$hh{'Status'}=206
}
if($CHUNKED=($RANGE[2]&&!exists($hh{'Content-length'}))){
if(exists($hh{'Transfer-encoding'})){
$hh{'Transfer-encoding'}.=',chunked'
}else{
$hh{'Transfer-encoding'}='chunked'
}
}
$buf=delete($hh{'Status'});
$buf="$ENV{'SERVER_PROTOCOL'} $buf $rfc2068_status{$buf}\n";
# $buf.="$_: ".($ENV{$_}=$hh{$_})."\n" for(keys %hh);
$buf.="$_: $hh{$_}\n" for(keys %hh);
$buf.="\n";
$RANGE[4]=1;
if($methods{$ENV{'REQUEST_METHOD'}} == 2){
if($RANGE[5]){
EX:
print_($buf) if($buf);
exit
}
@RANGE[0,1]=(-1,-1)
}
}else{return 1}
}
if($RANGE[1] ne ''){
if($pos>$RANGE[1]){
goto EX if($RANGE[4]==2);
$pos+=$ll;
$l=$buf&&print_($buf);
$buf='';
return $l
}elsif(($n=$pos+$ll-1-$RANGE[1])>0){
substr($b,-$n)=''
}
}
substr($b,0,$n,'') if(($n=$RANGE[0]-$pos)>0);
$pos+=$ll;
$b=sprintf("%x\n%s\n",$ll,$b) if($CHUNKED&&($ll-=$n));
if($buf){
$b=$buf.$b;
$buf=''
}
print_($b)
}
sub print_{
my ($i,$n,$l)=(0,0,length($_[0]));
while($l>$i){
select(undef,my $y=$vec_out,undef,$RANGE[9])&&
(($n=send($OUT,substr($_[0],$i,$wbufsize),$wbufsize,$MSG_DONTWAIT))>0)
||return 0;
$i+=$n;
if($maxwbufsize && (my $wb=$wbufsize-$n)>0 && (my $wb1=$l-$i)>0){
$wb=$wb1 if($wb1<$wb);
if(($wb+=unpack('L',getsockopt($OUT,$SOL_SOCKET,$SO_SNDBUF)))<=$maxwbufsize){
setsockopt($OUT,$SOL_SOCKET,$SO_SNDBUF,pack('L',$wb>>1));
(($n=send($OUT,substr($_[0],$i,$maxwbufsize),$maxwbufsize,$MSG_DONTWAIT))<0)&&return 0;
$i+=$n;
}
}
}
1
}
#sub print_{syswrite($OUT,$_[0])}
sub OPEN{open($OUT,$_[1],$_[2]);tie($_[0]=$IN=$OUT,'phttpd')}
sub WRITE{PRINT($_[0],substr($_[1],0,$_[2]))}
sub PRINTF{PRINT(shift,sprintf(shift,@_))}
sub CLOSE{untie $IN;close($IN)}
sub GETC{READ($_[0],my $x,1);$x}
sub READ{
my($i,$s,$n,$cnt)=(0,$_[1]='',$_[2],0);
while($n>0&&select($i=$vec_in,undef,undef,$RANGE[11])){
recv($IN,$s='',$n,$MSG_DONTWAIT);
$cnt+=($i=length($s)||last);
$_[1].=$s;
$n-=$i
}
$cnt
}
sub READLINE{
my($y,$s,$b,$i);
while(select($y=$vec_in,undef,undef,$RANGE[11])){
recv($IN,$s='',$rbufsize,$MSG_PEEK);
recv($IN,$s,($i=index($s,"\n")+1)||length($s)||last,$MSG_DONTWAIT);
$b.=$s;
die "Request too large (>$RANGE[12])\n" if($RANGE[12]&&($rpos+=$i)>$RANGE[12]);
$i&&return $b
}
undef
}
sub sockinit{
for(0,\&socklib){$_&&&$_;setsockopt($_[0],$SOL_SOCKET,$SO_KEEPALIVE,pack('L',$OPTIONS{'k'}!=0))&&last}
if($rbufsize=$OPTIONS{'rbuf'}){setsockopt($_[0],$SOL_SOCKET,$SO_RCVBUF,pack('L',$rbufsize>>1))
}else{$rbufsize=unpack 'L',getsockopt($_[0],$SOL_SOCKET,$SO_RCVBUF)}
if($wbufsize=$OPTIONS{'wbuf'}){setsockopt($_[0],$SOL_SOCKET,$SO_SNDBUF,pack('L',$wbufsize>>1))
}else{$wbufsize=unpack 'L',getsockopt($_[0],$SOL_SOCKET,$SO_SNDBUF)}
$maxwbufsize=$OPTIONS{'maxwbuf'};
}
sub socklib{
if(\&sockaddr_in ne \&Socket::sockaddr_in){
undef *sockaddr_in; undef *inet_aton; undef *inet_ntoa
}
eval q(use Socket qw(:all);
($MSG_PEEK,$MSG_DONTWAIT,$PF_INET,$SOCK_STREAM,$SOL_SOCKET,$SO_REUSEADDR,$SOMAXCONN,$SO_ERROR,$SO_SNDBUF,$SO_RCVBUF,$INADDR_ANY,$SO_LINGER,$SO_KEEPALIVE)=
(MSG_PEEK,MSG_DONTWAIT,PF_INET,SOCK_STREAM,SOL_SOCKET,SO_REUSEADDR,SOMAXCONN,SO_ERROR,SO_SNDBUF,SO_RCVBUF,INADDR_ANY,SO_LINGER,SO_KEEPALIVE);
if(exists($OPTIONS{'6'})){
($IN6ADDR_ANY,$PF_INET6)=(IN6ADDR_ANY,PF_INET6);
}else{
$PROTO_TCP=getprotobyname('tcp');
}
);
($PF_INET,$INADDR_ANY,$PROTO_TCP,*sockaddr_in,*inet_aton,*inet_ntoa)=($PF_INET6,$IN6ADDR_ANY,0,*sockaddr_in6,sub{inet_pton($PF_INET,$_[0])},sub{inet_ntop($PF_INET,$_[0])}) if(exists($OPTIONS{'6'}));
}
sub sockaddr_in{$#_>0?pack 'Sna4x8',2,@_:(unpack 'Sna4x8',$_[0])[1,2]}
sub inet_aton{pack 'C4',split(/\./,$_[0])}
sub inet_ntoa{join('.',unpack('C4',$_[0]))}
sub xfork{$$==$mainpid&&(exists($OPTIONS{'y'})?!($mainpid=fork):fork)}
sub preforker{
my $n=shift||return;
$mainpid="$tid$$";
while(1){
for(1..$n){fork||return}
while(wait()!=-1){fork||return}
}
}
sub end{
$^W=0;
if(@errors){
(@RANGE[2,3,6],$buf)=(0,0,1,'');
print STDERR "Status: 500\n\nError(s):".join("\n",@errors)."While loading: $ENV{'SCRIPT_NAME'}
$ENV{'SERVER_SIGNATURE'}"
}
if($log){for(@errors,$ERROR,$@){$_&&wlog('ERROR:',"<$_>")}}
close($IN);
close($OUT);
close($SERVER);
close($log);
}
sub wlog{defined($log)&&print $log join(' ',"$tid$$/$mainpid",@_,map($ENV{$_},'REMOTE_ADDR','REQUEST_METHOD','HTTP_HOST','REQUEST_URI'))."\n"}
# $! lost
sub _end{$ERROR=$!;goto &end}
sub ex{$ERROR=$!;exit}
$SIG{__DIE__}=sub{push @errors,@_;&ex};
END{&end}
}
my ($mode,$content)=phttpd::httpd();
$mode?&$content:eval $content