){
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
}
}
$ENV{'REQUEST_METHOD'}=uc($request[0]);
($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))[1];
$content=$file;
$content=~s/$mask//;
if($content eq ''){
undef $content;
my $e=$map{$_};
$file=~s/$mask/&$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;
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 die " \n";
@stat=stat(FH) if(!defined(@stat));
read FH,$content,$stat[7] or die " \n";
close FH;
if(defined($mainpid)){
$guid[1]=$stat[5] if($stat[2]&02000);
$guid[0]=$stat[4] if($stat[2]&04000);
$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:
if($$==$mainpid){
fork;
goto DAEMON if($$==$mainpid);
}
$)="$guid[1] ".($(=$guid[1]) if($guid[1]!=-1);
$<=$>=$guid[0] if($guid[0]!=-1);
&$content;
exit $?
}
$)="$stat[5] ".($(=$stat[5]) if($stat[2]&02000);
$<=$>=$stat[4] if($stat[2]&04000);
return $content;
}
if($$==$mainpid){
fork;
goto DAEMON if($$==$mainpid);
}
if($filetype==1){
opendir DH,$file or die " \n";
@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 die " \n";
@stat=stat(FH) if(!defined(@stat));
my $h="Last-Modified: ".localtime($stat[9])."\n";
my @x=(split(/\./,$file))[-1,-2];
my ($t,$enc);
read(FH,$content,my $cnt=1024>$stat[7]?$stat[7]:1024) or die " \n";
if(substr($content,0,14) eq '=0 && ($t=$mime{$x[1]})){
$h.="Content-encoding: $enc\n"
}
$t||=$mime{$x[0]}||(-B $file?'binary/unknown':'text/plain');
print $h,"Content-Length: ",$stat[7],"\nContent-type: $t\n\n",$content;
while((my $n=$stat[7]-$cnt)>0){
read(FH,$content,$cnt=+($n>1024?1024:$n)) or die " \n";
print $content
}
close FH
}
exit $?
}
}
}
{
package phttpd;
my $buf;
sub TIEHANDLE{bless({})}
sub PRINT{
shift;
($buf,my $b)=split(/[\r]{0,}\n[\r]{0,}\n[\r]{0,}/,join('',$buf,@_),2);
if(defined($b)){
untie *STDOUT;
untie *STDERR;
my %hh=('Content-type'=>'text/html','Status'=>200,'Server'=>$ENV{'SERVER_SOFTWARE'},'Date'=>''.localtime(time));
$_=~s/(.*?)\:[ ]{1,}(.*)[\r]{0,}/$hh{ucfirst(lc($1))}=$2/e for(split("\n",$buf));
$buf=delete($hh{'Status'});
$buf="$ENV{'SERVER_PROTOCOL'} $buf $rfc2068_status{$buf}\n";
while(my ($x,$y)=each %hh){$buf.="$x: $y\n"}
print $buf,"\n",$b;
undef $buf;
}
1
}
}
__END__
=head1 NAME
phttpd-0.01.01.pl - karakurt, small pure Perl httpd ([x]inetd or standalone).
=head1 DESCRIPTION
Small pure Perl httpd, only Perl CGI, faster Perl CGI execution.
Nice for configuration/single Perl CGI purposes.
=head1 README
karakurt, pure Perl httpd v0.01.01 (c) Dzianis Kahanovich, GPLs
This software are with NO WARRANTY!
I wrote it becouse I needs for small, fast, all-in-one httpd/perl, main -
in xinetd. There are my first server sockets programming (daemon/standalone),
then standalone mode are totally experemental, but caching modes are much more
experemental and unsecure and unsafe. Use it only for debugged, verifyed
scripts set. Also eXtreme mode must be not used with wildcard redirections:
every new URI will creating new cache entry. For real tasks even non-cached
mode are fast as perl "eval" method. But if you have commercial ;) heavy-loaded
perl-only site and if my daemon/forking model satisfy you (heh) - you may
trying eXtreme mode. But all software are with NO WARRANTY and all
PROBLEMS ARE YOUR OWN RISC!!
Configuration:
Look to %map variable and comments. There are regular expression/substitution.
Also try suexec file mode bits. I think, with mind you may build good security
for YOUR site (I not think that may be used in multi-user mode, but may be yes,
may be no - I trying to care for minimal security in non-cached mode, but not
believe in this).
Virtual hosts: use $ENV{'HTTP_HOST'} in %map target.
Do not put "tar" into %mime - you will get auto-ungzipping in your browser
(encoding). I experienced about "binary/unknown" are good content-type for
all binary downloads and real situations.
Also: while all CGI scripts running via "eval" - all Perl comman dline options
in scripts will be ignored.
May be easy added cool features in daemon (transparent compressing, etc), but
with price of unsimplifying code. Now it is minimal and functional and primary
will be used (by me) in LAN & localhost.
=head1 PREREQUISITES
Perl 5 (tested with 5.8.6 only)
=head1 COREQUISITES
Perl 5, no modules (xinetd). Sockets (for daemon mode only).
=pod OSNAMES
All
=pod SCRIPT CATEGORIES
Web
=cut