<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.38 (c) mahatma, GPLs

=head1 NAME

phttpd-0.01.38.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.38           (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: all CGI scripts running via "eval", Perl commandline options are
emulated very relaxed.

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.

Keep-alive are off by default. Use it with "-t" option only. Mode 2&amp;3 may cause
problems with pipelining, but I am not sure. Mode 3 may be violated by bad
CGI/Content-length. Mode 4 are slow and experemental (unknown Content-length
are buffered). Mode 5 using internally (totally buffered).

"X" and "x" caching on/off in commandline give various multitasking and
security. If "on" - precompile "eval" will work in main process, then fork -
there are slow and unsecure. If "off", but "on" in $map - caching will be
only per-keep-alive (if enabled), but scripts will separated by user:group,
then user may violate only own site.

Commandline examples:
Good server: "--a :80 --m 2 --x --k 3 --t 1"
Secure &amp; light: "--a :80 --m 1 --y --d --t 3"
Secure fast server: "--a :80 --m 5 --y --d --k 3 --t 10 -t1 300" + "x" in $map

Run w/o options for help.

Changes:
0.01.18 - bugfixes, caching now work, keep-alive.
0.01.19 - bugfixes, keep-alive off by default.
0.01.21 - bugfixes... changed command format.
0.01.22 - caching changed (secure per-keep-alive possible).
0.01.24 - security fix.
0.01.25 - fixes, IO.
0.01.26 - repaired "--i", timeouts.
0.01.27 - I/O fixed.
0.01.32 - fixes, log, %map.
0.01.34 - HEAD fix.
0.01.35 - ~ fork modes, log, $map +threads.
0.01.38 - chunked (1.1 ondemand), close+reload on security error, bugfix.

=head1 PREREQUISITES

Perl 5

=head1 COREQUISITES

Perl 5, no modules.

=pod OSNAMES

All

=pod SCRIPT CATEGORIES

Networking
Web

=cut

{
package phttpd;
sub xeval{eval $_[0]};

my $map=[sub{"$ENV{REMOTE_ADDR},$ENV{SERVER_ADDR}"},[
 ['127\.0\.0\.1\,127\.0\.0\.1','ph-setup.cgi'],
 ['..*',[sub{$_[0]},[
  ['\.\.',sub{"404"}],
#  ['/usr/portage/distfiles/.*',sub{"gcache-0.01.cgi",{'x'=&gt;1}}],
#  ['/usr/portage/(.*)',sub{"/usr/portage/$1",{'nocgi'=&gt;1}}],
#  ['/~(.*?)(/.*)',sub{"/home/$1/public_html$2",{'user'=&gt;$1,'group'=&gt;'users'}}],
#  ['/(.*)',sub{"$ENV{'DOCUMENT_ROOT'}/$1",{'x'=&gt;1}}],
  ['/(.*)',sub{"html/$1"}],
  ['..*','404',{'x'=&gt;1}]
 ]]]
]];

sub translate{
my ($x1,$x2)=@{$_[0]};
$x1=&amp;$x1($_[1]) if(ref($x1) eq 'CODE');
for(@{$x2}){
 my ($y1,$y2)=@$_;
 my $x=$x1;
 $y1=&amp;$y1($_[1]) if(ref($y1) eq 'CODE');
 $x=~s/$y1//;
 $x1=~s/$y1/return ($x=ref($y2)) eq 'ARRAY'?translate($y2,$_[1]):$x eq 'CODE'?&amp;$y2($_[1]):@$_[1,2]/e if($x eq '')
}
}

# 'Host' =&gt; sub{}, may be used for clustering
my %domain=(
# 'www.domain.com'=&gt;sub{cluster('.domain.com')},
 ''=&gt;sub{1,"Status: 400\n\nerror"} # rfc
);

# single-host cluster (no vhosting)
# remember first used IP in cookie and redirect here later
sub cluster{
my $cookie="karakurtCluster";
my $ip=$ENV{'SERVER_ADDR'};
my $l=length($cookie)+1;
my $h;
for(split(/;[ ]*/,$ENV{'HTTP_COOKIE'})){$h=substr($_,$l) if(substr($_,0,$l) eq "$cookie=")}
return if($ip eq $h);
return 1,"Status: 300\nLocation: http://$h$ENV{REQUEST_URI}\n\n" if($h);
0,$l="Set-cookie: $cookie=$ip".($_[0]?"; domain=$_[0]":'')."\n"
}

my (%OPTIONS,@RANGE,@errors,$ERROR,$CHUNKED,$mainpid,$SERVER,$IN,$OUT,$vec_in,$vec_out,$rbufsize,$wbufsize,$filebuf,$log,$a);
my $tid='';
# RANGE: 0-1 2=keep-alive 3=range requested 4=range proceed('2'=break) 5=break
#  6-done 7-timeout 8-timeout/r 9-timeout/w 10-timeout/init
#  11-timeout/read/var 12-buf/limit

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 ($rpos,$pos,$buf);
my ($MSG_PEEK,$MSG_DONTWAIT,$PF_INET,$SOCK_STREAM,$PROTO_TCP,$SOL_SOCKET,$SO_REUSEADDR,$SOMAXCONN,$SO_ERROR,$SO_SNDBUF,$SO_RCVBUF,$INADDR_ANY,$SO_LINGER,$SO_KEEPALIVE)=(2,64,2,1,6,1,2,512,4,7,8,pack('x4'),13,9);

my $ID='karakurt/0.01.38';

%ENV=(
'PATH'=&gt;$ENV{'PATH'},
#'REMOTE_ADDR'=&gt;$ENV{'REMOTE_HOST'},
'DOCUMENT_ROOT'=&gt;substr($0,0,rindex($0,'/')),
'GATEWAY_INTERFACE'=&gt;'CGI/1.1',
'SERVER_PROTOCOL'=&gt;'HTTP/1.0',
'SERVER_SOFTWARE'=&gt;"$ID perl/$] $^O",
'SERVER_SIGNATURE'=&gt;"&lt;ADDRESS&gt;$ID&lt;/ADDRESS&gt;\n"
);

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',
'xml'=&gt;'application/xml'
);

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

my %opt=(
 '0'=&gt;sub{"\$\/=".oct($_[0])},
 'C'=&gt;sub{'${^WIDE_SYSTEM_CALLS}=1'},
 'e'=&gt;sub{"eval(\"$_[0]\")"},
 'i'=&gt;sub{"\$\^I=\"$_[0]\""},
 'I'=&gt;sub{'push @INC,\"'.$_[0].'"'},
 't'=&gt;sub{'${^TAINT}=1'}, #warn
 'T'=&gt;sub{'${^TAINT}=1'}, #fatal
 'W'=&gt;sub{'$^W=1'},
 'X'=&gt;sub{'$^W=0'}
);

sub httpd{

if(defined($_[0])){
 $tid=threads-&gt;self;
 $tid-&gt;detach;
 $tid=$tid-&gt;tid.".";
 *ex=*_end;
 goto "TH$_[0]";
}

my ($content,%contents,%URIs,@guid,%options,$conf);
my @saveguid=($&gt;,$));
my %methods=('GET'=&gt;1,'POST'=&gt;1,'HEAD'=&gt;1);

for(@ARGV){
 if(substr($_,0,2) eq '--'){$OPTIONS{$content=substr($_,2)}=''}
 else{$OPTIONS{$content}.=$OPTIONS{$content}?" $_":$_}
}
chdir($ENV{'DOCUMENT_ROOT'});
do $OPTIONS{'c'} if($conf=-M $OPTIONS{'c'});

eval q(
 use threads;
 $tid=".";
 *xfork=sub {"$tid$$" eq $mainpid||return;threads-&gt;new(\&amp;httpd,@_)-&gt;detach;1}
) if(exists($OPTIONS{'th'}));

&amp;socklib if(exists($OPTIONS{'l'}));
if(exists($OPTIONS{'L'})){
 open $log,"&gt;&gt;$OPTIONS{'L'}";
 select($log); $|=1; select(STDOUT);
}
if(exists($OPTIONS{'a'})){
my @ad=split(/:/,$OPTIONS{'a'},3);
for(0,\&amp;socklib){
 $_&amp;&amp;&amp;$_;
 socket($SERVER,$PF_INET,$SOCK_STREAM,$PROTO_TCP)&amp;&amp;
 setsockopt($SERVER,$SOL_SOCKET,$SO_REUSEADDR,pack("l",1))&amp;&amp;
 (defined($OPTIONS{'tw'})?setsockopt($SERVER,$SOL_SOCKET,$SO_LINGER,pack('LL',1,$OPTIONS{'tw'})):1)&amp;&amp;
 bind($SERVER, sockaddr_in($ad[1]||591,$ad[0]?inet_aton($ad[0]):$INADDR_ANY))&amp;&amp;
 listen($SERVER,$ad[2]||$SOMAXCONN)&amp;&amp;
 goto SERV_OK
}
die "Socket open error: $!\n";
SERV_OK:
sockinit($SERVER);
close(STDERR);
close(STDOUT);
close(STDIN);
exists($OPTIONS{'d'})&amp;&amp;fork&amp;&amp;exit;
preforker($OPTIONS{'z'});
fork||last for(2..$OPTIONS{'m'});
DAEMON:
($&gt;,$))=@saveguid;
$SIG{CHLD}='IGNORE';
while(1){
 close($IN);
 $mainpid||="$tid$$";
 $a=accept($IN,$SERVER) or die;
 if(exists($OPTIONS{'c'})&amp;&amp;$conf!=(my $x=-M $OPTIONS{'c'})){$conf=$x;do $OPTIONS{'c'}}
 last if(exists($OPTIONS{'x'})||exists($OPTIONS{'X'})||!&amp;xfork(0))
}
TH0:
$OUT=$IN
}elsif(exists($OPTIONS{'i'})){
 $OUT=*STDOUT;
 $a=getpeername($IN=*STDIN);
 sockinit($IN)
}else{
 exit print qq($ID pure Perl httpd, (c) Dzianis Kahanovich, 2005-2010, GPLs
--i - [x]inetd mode (main goal, safe)
--a [addr][:port[:queue]] - bind to|":591:512"
--H - break CGI (HEAD|range)
--c [file] - load config
--k [n] - keep-alive 0-5: none|HTTP/1.0|smart|smart+CGI|smart+buff|buff_CGI
--x - cache CGI (SCRIPT_FILENAME -&gt; precompile)
--X - eXtreme cache CGI (SCRIPT_NAME -&gt; SCRIPT_FILENAME)
--t|t0|t1|tw|tr [n] - timeouts (default|start|alive|write|read)
--rbuf|wbuf [n] - buffers size
--l large code (may be safe)
--L [file] - log to
--nocgi - disable CGI
--b [n] - buffer limit (CGI_buff &amp; request, average)
Standalone:
--m [n] - listeners|1
--y - inversed fork
--d - detach
--z [n] - fixed prefork
--th - use threads (heavy experemental)
(only Perl CGI supported)
)
}
($ENV{'REMOTE_PORT'},$a)=sockaddr_in($a);
$ENV{'REMOTE_ADDR'}=inet_ntoa($a);
($ENV{'SERVER_PORT'},$a)=sockaddr_in(getsockname($IN));
$ENV{'SERVER_ADDR'}=inet_ntoa($a);
vec($vec_in='',fileno($IN),1)=1;
$vec_out=$vec_in;
#vec($vec_out='',fileno($OUT),1)=1;
$filebuf=$wbufsize&gt;&gt;1;
$RANGE[10]=$OPTIONS{'t0'};
tie(*STDIN,'phttpd');
tie(*STDERR=*STDOUT,'phttpd');
my %ENV0=%ENV;
ALIVE:
%ENV=%ENV0;
my ($mode,$file,@stat,@err)=(0);
%options=%OPTIONS;
@RANGE=('','',$OPTIONS{'k'},0,0,0,0,$OPTIONS{'t'},$OPTIONS{'tr'},$OPTIONS{'tw'},$OPTIONS{'t1'},$RANGE[10],$OPTIONS{'b'},0);
for(8..11){$RANGE[$_]||=$RANGE[7]}
($rpos,$pos,$buf)=(0,0,'');
my @request=split(/[ \n\r]+/,&lt;STDIN&gt;,4);
@RANGE[11,13]=@RANGE[8,12];
$ENV{'SERVER_PROTOCOL'}=substr($content=$request[2],5,5,'')&lt;1.1||$RANGE[2]==1?'HTTP/1.0':'HTTP/1.1';
if($content ne 'HTTP/'){@err=(400,$request[2]);goto ERR}
if(!$methods{$ENV{'REQUEST_METHOD'}=$request[0]}){@err=(405,$request[0]);goto ERR}
($file,$ENV{'QUERY_STRING'})=(split(/\?/,$file=$ENV{'REQUEST_URI'}=$request[1],2),'');
for(my $s=&lt;STDIN&gt;;defined($s) &amp;&amp; $s ne "\n" &amp;&amp; $s ne "\r\n";$s=&lt;STDIN&gt;){$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=&amp;$_;
 $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')[$_]})&amp;&amp;$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-&gt;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){
  $&gt;=$guid[0];
  goto ESEC if($&gt; ne $guid[0]);
 }
 @stat=stat($file);
 if(-d _){
  &amp;xfork(1) &amp;&amp; goto DAEMON; TH1:
  my $s=$ENV{'REQUEST_URI'};
  if(substr($s,-1) ne '/'){
   print "Status: 301\nLocation: $s/\n\n";
   goto &amp;ex
  }
  opendir FH,$file or goto ERR;
  $s="Index of $s";
  $s="Last-Modified: ".gmtime($stat[9])."\nContent-type: text/html\n\n&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(FH)){
   my @st=stat("$file$_");
   $_=~s/([\x00-\x1f,:\"\'\\])/sprintf('%%%02X',ord($1))/eg;
   $_.='/' if(-d _);
   $s.="&lt;a href='$_'&gt;$_&lt;/a&gt;		".localtime($st[9])."	$st[7]\n";
   if(length($s)&gt;$filebuf){
    print $s or goto ERR;$s='';
    last if($RANGE[1]==-1)
   }
  }
  close FH;
  print "$s&lt;/pre&gt;&lt;hr&gt;$ENV{'SERVER_SIGNATURE'}&lt;/body&gt;&lt;/html&gt;" or goto ERR;
  wlog('dir')
 }elsif(-x _ &amp;&amp;!exists($options{'nocgi'})){
  if(($content,my @s)=@{$contents{$file}}){
   goto EXEC_CGI if($mode=($stat[9]==$s[9]));
   delete($contents{$file})
  }
  open FH,"&lt;$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 '-' &amp;&amp; defined(my $o=$opt{substr($_,1,1)})){$x.=&amp;$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'})&amp;&amp;(exists($OPTIONS{'x'})||2))==1);
 EXEC_CGI:
  &amp;xfork(2) &amp;&amp; goto DAEMON; TH2:
  wlog('CGI');
  for(\&amp;CGI::initialize_globals){defined(&amp;$_)&amp;&amp;&amp;$_}
  $guid[1]=$stat[5] if($stat[2]&amp;02000);
  $guid[0]=$stat[4] if($stat[2]&amp;04000);
  chown @guid,$out;
  close($SERVER);
  $saveguid[1]=$(=$)="$guid[1] $guid[1]" if($guid[1]!=-1);
  $saveguid[0]=$&lt;=$&gt;=$guid[0] if($guid[0]!=-1);
  $RANGE[5]=exists($options{'H'});
  $RANGE[2]=0 if($RANGE[2]&lt;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]&lt;3&amp;&amp;!$tid); # ?
  $mode?&amp;$content:xeval($content);
  $^W=0;
  die $@ if($@);
 }elsif(-e _){
  &amp;xfork(3) &amp;&amp; goto DAEMON; TH3:
  open FH,"&lt;$file" or goto ERR;
  $RANGE[2]=3 if($RANGE[2]&gt;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&lt;1024?$l:1024) or goto ERR;
  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"
  }
  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&lt;$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]){
   &amp;xfork(4) &amp;&amp; goto DAEMON; TH4:
   die " \n"
  }
  $content="Status: $err[0]\n\n$err[0] $rfc2068_status{$err[0]}: '$err[1]'";
STD:
  &amp;xfork(5) &amp;&amp; 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 &amp;ex if(!$RANGE[2]);
 $OPTIONS{'t'}=abs($RANGE[10]) if($OPTIONS{'t'}&gt;abs($RANGE[10]));
 ($&gt;,$))=@saveguid;
 goto (ALIVE,ESEC)[$&gt; 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])&amp;&amp;!($RANGE[13]&amp;&amp;length($buf)&gt;$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&amp;&amp;$l ne 'keep-alive'));
 }
 my %hh=('Content-type'=&gt;'text/html','Status'=&gt;200,'Server'=&gt;$ENV{'SERVER_SOFTWARE'},'Date'=&gt;''.gmtime($time=time));
 $_=~s/(.*?)\:[ 	]+(.*)[\r]*/$hh{ucfirst(lc($1))}=$2/e for(split(/\n/,$buf));
 if(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] &amp;&amp; (my $x=$ENV{'HTTP_KEEP_ALIVE'})){
  if($RANGE[10]&gt;$x){$RANGE[10]=$x}
  elsif($RANGE[10]!=$x){$hh{'Keep-alive'}||="timeout=$RANGE[10]"}
 } 
 if($RANGE[3] &amp;&amp; !exists($hh{'Content-range'})){
  $RANGE[4]=$RANGE[5]+1;
  $hh{'Content-length'}=(($l&lt;=$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]&amp;&amp;!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($ENV{'REQUEST_METHOD'} eq 'HEAD'){
  if($RANGE[5]){
  EX:
   print_($buf) if($buf);
   exit
  }
  @RANGE[0,1]=(-1,-1)
 }
}else{return 1}
}
if($RANGE[1] ne ''){
 if($pos&gt;$RANGE[1]){
  goto EX if($RANGE[4]==2);
  $pos+=$ll;
  $l=$buf&amp;&amp;print_($buf);
  $buf='';
  return $l
 }elsif(($n=$pos+$ll-1-$RANGE[1])&gt;0){
  substr($b,-$n)=''
 }
}
substr($b,0,$n,'') if($n=$RANGE[0]-$pos);
$pos+=$ll;
$b=sprintf("%x\n%s\n",$ll,$b) if($CHUNKED&amp;&amp;($ll-=$n));
if($buf){
 $b=$buf.$b;
 $buf=''
}
print_($b)
}

sub print_{
for(my ($i,$n,$l)=(0,0,length($_[0]));$l&gt;$i;$i+=$n){
 select(undef,my $y=$vec_out,undef,$RANGE[9])&amp;&amp;
 ($n=send($OUT,substr($_[0],$i,$wbufsize),$wbufsize,$MSG_DONTWAIT))
 ||return 0
}
1
}

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&gt;0&amp;&amp;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 (&gt;$RANGE[12])\n" if($RANGE[12]&amp;&amp;($rpos+=$i)&gt;$RANGE[12]);
 $i&amp;&amp;return $b
}
undef
}

sub sockinit{
for(0,\&amp;socklib){$_&amp;&amp;&amp;$_;setsockopt($_[0],$SOL_SOCKET,$SO_KEEPALIVE,pack('L',$OPTIONS{'k'}!=0))&amp;&amp;last}
if($rbufsize=$OPTIONS{'rbuf'}){setsockopt($_[0],$SOL_SOCKET,$SO_RCVBUF,pack('L',$rbufsize&gt;&gt;1))
}else{$rbufsize=unpack 'L',getsockopt($_[0],$SOL_SOCKET,$SO_RCVBUF)}
if($wbufsize=$OPTIONS{'wbuf'}){setsockopt($_[0],$SOL_SOCKET,$SO_SNDBUF,pack('L',$wbufsize&gt;&gt;1))
}else{$wbufsize=unpack 'L',getsockopt($_[0],$SOL_SOCKET,$SO_SNDBUF)}
}

sub socklib{
if(\&amp;sockaddr_in ne \&amp;Socket::sockaddr_in){
 undef *sockaddr_in; undef *inet_aton; undef *inet_ntoa
}
eval q(use Socket;
 ($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);
 $PROTO_TCP=getprotobyname('tcp')
)
}

sub sockaddr_in{$#_&gt;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&amp;&amp;(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):&lt;pre&gt;".join("\n",@errors)."&lt;/pre&gt;While loading: $ENV{'SCRIPT_NAME'}&lt;hr&gt;$ENV{'SERVER_SIGNATURE'}"
 }
 if($log){for(@errors,$ERROR,$@){$_&amp;&amp;wlog('ERROR:',"&lt;$_&gt;")}}
 close($IN);
 close($OUT);
 close($SERVER);
 close($log);
}
sub wlog{defined($log)&amp;&amp;print $log join(' ',"$tid$$/$mainpid",@_,map($ENV{$_},'REMOTE_ADDR','REQUEST_METHOD','HTTP_HOST','REQUEST_URI'))."\n"}
# $! lost
sub _end{$ERROR=$!;goto &amp;end}
sub ex{$ERROR=$!;exit}
$SIG{__DIE__}=sub{push @errors,@_;&amp;ex};
END{&amp;end}
}

my ($mode,$content)=phttpd::httpd();
$mode?&amp;$content:eval $content</pre></body></html>