){
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);
chdir($root);
$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;
$file=~s/$mask/eval "\"$map{$_}\""/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;
print "Status: 200\n";
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 \};";
$contents{$file}=[$content,@guid,@stat] if(exists($OPTIONS{'-x'}));
$contents_uri{$ENV{'REDIRECT_URI'}}=[$content,@guid] if(exists($OPTIONS{'-X'}));
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;
$s.="$_".(-d "$file$_"?'/':'')." ".localtime($st[9])." $st[7]\n";
}
$s.="
$server/$version";
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'=>500,'Server'=>"$server/$version",'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.pl - karakurt, small pure Perl http daemon ([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 (c) Dzianis Kahanovich, GPLs
This software are with NOT 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 NOT WARRANTY and all
PROBLEMS ARE YOUR OWN!!
Configuration:
Look to %map variable and comments. There are regular expression/substitution +
eval strings. Also try suexec file mode bits. I think, with mind you may
build good scurity 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).
Do not put "tar" into %mime - your 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 remeber: while all CGI scripts running via "eval" - all Perl commandline
options in scripts will be ignored.
There are 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, CGI
=cut