<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">#!/usr/bin/perl
# karakurt - pure perl httpd v0.01 (c) mahatma, GPLs

eval httpd(@ARGV);
exit $?;

sub httpd{
# 'id mask'=&gt;'[user:group]file'
# 'id mask'=&gt;'file'
my %map=(
 '00 \.\.'=&gt;'404',
 '03 /html/(.*)'=&gt;'html/$1',
# '22 /usr/portage/distfiles/.*'=&gt;'gcache-0.01.cgi',
 '44 ..*'=&gt;'404'
);

my %mime=(
'html'=&gt;'text/html',
'htm'=&gt;'text/html',
'js'=&gt;'text/javascript',
'gif'=&gt;'image/gif',
'jpg'=&gt;'image/jpeg',
'gz'=&gt;'application/x-gzip'
);

my %mime_enc=( # to prevent "content-encoding" just remove real type from mime
'gz'=&gt;'gzip'
);

my %rfc2068_status=(
100=&gt;'Continue',
101=&gt;'Switching Protocols',
200=&gt;'OK',
201=&gt;'Created',
202=&gt;'Accepted',
203=&gt;'Non-Authoritative Information',
204=&gt;'No Content',
205=&gt;'Reset Content',
206=&gt;'Partial Content',
300=&gt;'Multiple Choices',
301=&gt;'Moved Permanently',
302=&gt;'Moved Temporarily',
303=&gt;'See Other',
304=&gt;'Not Modified',
305=&gt;'Use Proxy',
400=&gt;'Bad Request',
401=&gt;'Unauthorized',
402=&gt;'Payment Required',
403=&gt;'Forbidden',
404=&gt;'Not Found',
405=&gt;'Method Not Allowed',
406=&gt;'Not Acceptable',
407=&gt;'Proxy Authentication Required',
408=&gt;'Request Time-out',
409=&gt;'Conflict',
410=&gt;'Gone',
411=&gt;'Length Required',
412=&gt;'Precondition Failed',
413=&gt;'Request Entity Too Large',
414=&gt;'Request-URI Too Large',
415=&gt;'Unsupported Media Type',
500=&gt;'Internal Server Error',
501=&gt;'Not Implemented',
502=&gt;'Bad Gateway',
503=&gt;'Service Unavailable',
504=&gt;'Gateway Time-out',
505=&gt;'HTTP Version not supported'
);

my $version='0.01';
my $server="karakurt";
my $root=substr($0,0,rindex($0,'/'));
my (@OPTIONS,$content,%contents,%contents_uri,$file,@errors,$mainpid,@guid);

$ENV{'REMOTE_ADDR'}=$ENV{'REMOTE_HOST'};
$ENV{'SERVER_PROTOCOL'}='HTTP/1.0';

for(@_){
 if(substr($_,0,1) eq '-'){$OPTIONS{$content=$_}=''}
 else{$OPTIONS{$content}.=$OPTIONS{$content}?" $_":$_}
}

END{print "\n\nError(s): ".join("&lt;br&gt;",$!,@errors)."&lt;br&gt;While loading: $ENV{'SCRIPT_FILENAME'}&lt;hr&gt;phttpd/$version" if(tied(*STDOUT)&amp;&amp;$$!=$mainpid)}
$SIG{__DIE__}=sub{print STDERR "Status: 500\n" if(tied(*STDERR));@errors=(@errors,@_)};

if(exists($OPTIONS{'-a'})){
$mainpid=$$;
my @a=split(':',$OPTIONS{'-a'},2);
eval &lt;&lt;EOT
use Socket;
socket(SERVER,PF_INET,SOCK_STREAM,getprotobyname('tcp'))&amp;&amp;
setsockopt(SERVER,SOL_SOCKET,SO_REUSEADDR,pack("l",1))&amp;&amp;
bind(SERVER, sockaddr_in(\$a[1]||80,\$a[0]?inet_aton(\$a[0]):INADDR_ANY))&amp;&amp;
listen(SERVER,SOMAXCONN)
EOT
||die "Socket open error $!\n";
DAEMON:
untie(*STDERR);
untie(*STDOUT);
close(STDERR);
close(STDOUT);
close(STDIN);
while($mainpid==$$){
 close(CLIENT);
 accept(CLIENT,SERVER) or die;
 last if(exists($OPTIONS{'-x'})||exists($OPTIONS{'-X'}));
 fork;
}
open STDIN,"&lt;&amp;CLIENT" or die;
open STDOUT,"&gt;&amp;CLIENT" or die;
open STDERR,"&gt;&amp;STDOUT" or die;
}elsif(!exists($OPTIONS{'-i'})){
 die "$server/$version pure Perl httpd, (c) Dzianis Kahanovich, 2005, GPLs\n -i - [x]inetd mode (main goal, safe)\n -a [addr][:port] - bind to\nStandalone (dangerous!):\n -x - cache CGI (SCRIPT_FILENAME)\n -X - eXtreme cache CGI (REDIRECT_URI, no checking)\n(only Perl CGI supported)\n";
}

@guid=(-1,-1);
tie(*STDERR,'phttpd');
tie(*STDOUT,'phttpd');
@request=split(/[ \n\r]/,&lt;STDIN&gt;);
for (my $s=&lt;STDIN&gt;;defined($s) &amp;&amp; $s ne "\n" &amp;&amp; $s ne "\r\n";$s=&lt;STDIN&gt;){
 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)&amp;&amp;defined($g)));@guid=($u,$g);''/e if(substr($file,0,1) eq '[');
  if($$!=$mainpid){
   $)="$guid[1] ".($(=$guid[1]) if($guid[1]!=-1);
   $&lt;=$&gt;=$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,"&lt;$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]&amp;02000);
    $guid[0]=$stat[4] if($stat[2]&amp;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);
    $&lt;=$&gt;=$guid[0] if($guid[0]!=-1);
    &amp;$content;
    exit $?
   }
   $)="$stat[5] ".($(=$stat[5]) if($stat[2]&amp;02000);
   $&lt;=$&gt;=$stat[4] if($stat[2]&amp;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="&lt;html&gt;&lt;head&gt;&lt;title&gt;$s&lt;/title&gt;&lt;/head&gt;&lt;body&gt;&lt;H1&gt;$s&lt;/H1&gt;&lt;pre&gt;&lt;hr&gt;&lt;pre&gt;";
   for(readdir(DH)){
    my @st=stat("$file$_");
    $_=~s/([\x00-\x1f,:\"\'\\])/sprintf('%%%02X',ord($1))/eg;
    $s.="&lt;a href='$_'&gt;$_".(-d "$file$_"?'/':'')."&lt;/a&gt;		".localtime($st[9])."	$st[7]\n";
   }
   $s.="&lt;/pre&gt;&lt;hr&gt;&lt;address&gt;$server/$version&lt;/address&gt;&lt;/body&gt;&lt;/html&gt;";
   close DH;
   print "Last-Modified: ".localtime($stat[9]),"\nContent-type: text/html\nContent-length: ",length($s),"\n\n",$s;
  }else{
   open FH,"&lt;$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&gt;$stat[7]?$stat[7]:1024) or die " \n";
   if(substr($content,0,14) eq '&lt;!DOCTYPE html'){
    $t='text/html'
   }elsif(($enc=$mime_enc{$x[0]}) &amp;&amp; substr(",$ENV{'HTTP_ACCEPT_ENCODING'},",",$enc,")&gt;=0 &amp;&amp; ($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)&gt;0){
    read(FH,$content,$cnt=+($n&gt;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'=&gt;'text/html','Status'=&gt;500,'Server'=&gt;"$server/$version",'Date'=&gt;''.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 &amp; 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
</pre></body></html>