<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">#!/usr/bin/perl -U
# virtual hosting script v0.5.1 (c) Denis Kaganovich AKA mahatma
# redirect &amp; compress by gzip on-the-fly multiple vhosts witheout real
# virtual hosts support on site. very simple!

### config begin
my $root=$ENV{DOCUMENT_ROOT}||'.';
my $mode=1; # 0-single, 1-www.doe.com-"doe/", 2-"www.doe.com/"
my $index=['index.htm','index.html'];
my $linkindex='index.cgi'; # indexfile link for $linktype=1
my $codepage='koi8-r'; # codepage ID to send with HTTP header with "text/*" types.
my $enable_gzip=1;
my $vbase="$root/"; # base path to real vhosts repository
my $logs="$root/log/"; # path to logs
my $loglevel=1; # 0-4 (0-off)
my $linktype=0; # 0-symlink; 1-dir; 2,3-internal (don't touch); for 1 must be absolute $vbase
my $cache=1; # cache .gz?
my $zbase="$root/cache/"; # path to gzip cache
my $gzip='/usr/bin/gzip'; # gzip
my $mkdir_mode=0770; # for $linktype=1
my $ExecCGI=1; # while too experimental! no gzipped, etc
### config end

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

my %mime_gz=( # -1
'Lynx'=&gt;{
	'text/html'=&gt;2,
	'text/plain'=&gt;2,
	'*'=&gt;1
}, # for Lynx gzip only text/html &amp; text/plain
'*'=&gt;{
	'image/jpeg'=&gt;1,
	'*'=&gt;2
} # for others compress all exclude jpeg
);

my %cgi=(
'.cgi'=&gt;1,
'.pl'=&gt;1,
'.php3'=&gt;1,
'.php'=&gt;1
);

$enable_gzip=index($ENV{HTTP_ACCEPT_ENCODING},'gzip',0)&gt;=0?$enable_gzip:0;
my $hthead='&lt;!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2//EN"&gt;';
my $iam=$ENV{SCRIPT_FILENAME};
my $i;
my $ndx='';
my $txt='';
my $p=$mode==0?'':lc($ENV{HTTP_HOST});
if($mode==1){
	$p=substr($p,4) if(index($p,'www.')==0);
	$p=substr($p,0,index($p,'.'));
}elsif($mode==0){chop($vbase) if(substr($vbase,-1) eq '/')};
my $rs=$ENV{REDIRECT_STATUS}+0;
my $f=$ENV{REQUEST_URI};
my $meth=$ENV{REQUEST_METHOD}||"?";
my $log=$loglevel&gt;0?localtime(time)." - $ENV{REMOTE_ADDR}:$ENV{REMOTE_PORT} ".($loglevel&gt;1?$ENV{HTTP_X_FORWARDED_FOR}||'-':'')." $meth $ENV{HTTP_HOST}$f".($loglevel&gt;2?' '.($ENV{HTTP_REFERER}||'?'):''):'';
my @fs;
$i=index($f,'?'); $f=substr($f,0,$i) if($i&gt;0);
my $ff="$vbase$p$f";
my $t;
if($rs==404&amp;&amp;substr($f,-1) ne '/'&amp;&amp;-d $ff){$ff.='/';$f.='/'}
if(substr($f,-1) eq '/'){		
	for ($i=0;$i&lt;scalar(@$index) &amp;&amp; !(@fs=stat("$ff".($ndx=@$index[$i]))); $i++){};
	if(@fs){$f.=$ndx; $ff.=$ndx}
	else{
		$t='.html';
		chop($i) if(length($i=$f)&gt;1);
		$txt.="$hthead\n&lt;html&gt;&lt;head&gt;&lt;title&gt;Index of $i&lt;/title&gt;&lt;/head&gt;&lt;body&gt;&lt;table width=100%&gt;&lt;tr&gt;&lt;th&gt;Name&lt;/th&gt;&lt;th&gt;Size&lt;/th&gt;&lt;th&gt;Date&lt;/th&gt;&lt;th&gt;Description&lt;/th&gt;&lt;/tr&gt;";
		opendir DH,$ff or err(404,"path not found");
		my @dir=readdir(DH);
		@fs=stat($ff);
		my @stat;
		for $i (@dir){
			@stat=stat("$ff$i");
			@fs[9]=@stat[9] if(@fs[9]&lt;@stat[9]);
			$txt.="\n&lt;tr&gt;&lt;td&gt;&lt;a href=\"$i\"&gt;$i&lt;/a&gt;&lt;/td&gt;&lt;td&gt;@stat[7]&lt;/td&gt;&lt;td&gt;".localtime(@stat[9])."&lt;/td&gt;&lt;td&gt;&amp;nbsp;&lt;/td&gt;&lt;/tr&gt;"
		}
		closedir DH;
		$txt.='&lt;/table&gt;&lt;/body&gt;&lt;/html&gt;';
		$ff='';
	}

}
$t=$t||lc(substr($f,$i=rindex($f,'.')));

if($ExecCGI==1 &amp;&amp; $ff ne '' &amp;&amp; $cgi{$t}==1 &amp;&amp; -x $ff){
	$log.=" - &amp;$ff" if($loglevel&gt;0);
	my $q='';
	open FH,"|$ff" or err(500,'cgi error');
	if($meth eq 'POST'){
	read(STDIN,$txt,$ENV{CONTENT_LENGTH});
	print FH $txt;
	}
	print &lt;FH&gt;;
	close(FH);
	lexit(0);
}

my $zz=0;
if($enable_gzip==1 &amp;&amp; $t eq '.gz'){
	my $j=rindex($f,'.',$i-1);
	$t=lc(substr($f,$j,$i-$j));
	$zz=1;
}
my $loc=$f;
@fs=(@fs[9])?@fs:stat($ff);
err(404,'not found') if(!@fs);
$i=my $m=$mime{$t}||'*/*';
my $a=$ENV{HTTP_USER_AGENT};
$log.=" \"$a\"" if($loglevel&gt;3);
$a=substr($a,0,index($a,'/'));
$log.=" $a" if($loglevel&gt;0 &amp;&amp; $loglevel&lt;4);
$m.="; codepage=$codepage" if($codepage ne '' &amp;&amp; index($m,'text/')&gt;=0);

if($enable_gzip==1){
my $fz="$zbase$p$f.gz";
my $z=$mime_gz{$a}||$mime_gz{'*'}||{'*'=&gt;2};
$z=($z-&gt;{$i}||$z-&gt;{'*'}||2)-1;
if($z==1||$zz==1){
	if($zz==0){
	$loc.='.gz';
	if($cache==0){$ff=$txt eq ''?"$gzip -cfn9 $ff |":"|$gzip -cfn9"}
	else{
		my @fzs=stat($fz);
		if((@fzs[9]||-1)&lt;@fs[9]){
			mklink($fz,4,length($zbase));
			if($txt eq ''){`$gzip -cfn9 $ff &gt;$fz`}
			else{
				open FH, "|$gzip -cfn9 &gt;$fz";
				print FH $txt;
				close(FH);
				$txt=''
			}
			@fzs=stat($fz)
		}
		@fs[7]=@fzs[7];
		$ff=$fz
	}
	}
	$m.="\nContent-Encoding: gzip" if($t ne '.tar');
}
}

$m="Content-Type: $m\nContent-Location: $loc\nLast-Modified: ".localtime(@fs[9])."\n\n";
$log.=" - $ff" if($loglevel&gt;0);
if($txt ne '' &amp;&amp; $ff eq ''){print 'Content-Length: ',length($txt),"\n",$m,($meth ne 'HEAD')?$txt:''}
else{
	mklink("$root$f$ndx",$linktype,length($root)) if($rs==404||$rs==403);
	$m="Content-Length: @fs[7]\n$m" if(index($ff,'|')&lt;0);
	if($meth ne 'HEAD'){
	    open FH,$ff or err(403,'access denied'); binmode FH;
	    if($cache==0 &amp;&amp; $txt ne ''){print $m;print FH $txt}
	    else{print $m,&lt;FH&gt;;close FH}
	}else{print $m}
}

lexit(0);

#################################################
sub mklink{
my $r=shift||return 1;
my $lnk=shift; # 0-symlink; 1-dir; 2-dir w/o last; 3-experimental, not work now
my $i0=shift||0;
my ($i,$i1)=(0,0);
my $l=length($r);
my $rr;
while($i0&lt;=$l){
	$i=index($r,'/',$i0);
	$i1=$i&lt;0?$l:$i;
	$rr=substr($r,0,$i1);
	if($lnk==3||($lnk==0 &amp;&amp; $i&gt;=0)){symlink('.',$rr)}
	elsif($lnk==1 &amp;&amp; $i&lt;0 &amp;&amp; substr($r,-1) eq '/'){symlink($iam,"$r$linkindex")}
	elsif($lnk==0||($lnk==1 &amp;&amp; $i&lt;0)){symlink($iam,$rr)}
	elsif($lnk&gt;0 &amp;&amp; $i&gt;=0){mkdir($rr,$mkdir_mode)}
	$i0=$i1+1;
}
}

sub err{
my $e=shift;
my $t=shift;
print qq(Content-Type: text/html
Pragma: no-cache
Content-Location: /error/$e.html

$hthead
&lt;html&gt;&lt;head&gt;&lt;title&gt;$e - $t&lt;/title&gt;&lt;/head&gt;&lt;body&gt;
&lt;center&gt;&lt;b&gt;Error $e&lt;/b&gt;&lt;br&gt;$ENV{REQUEST_URI}&lt;br&gt;$t&lt;/center&gt;
&lt;/body&gt;&lt;/html&gt;);
lexit($e); 
}

sub lexit{
my $e=shift;
if($loglevel&gt;0){
open FL, "&gt;&gt;$logs$p.log" or die "log error";
print FL "$log - $e\n";
close FL;
}
exit($e);
}

__END__
=head1 NAME

vhscript-0.5.1.pl (AKA index.cgi) - Virtual Hosting Script (+accelerator/gzip).

=head1 DESCRIPTION

Allow alternative ways to:
1) virtual hosting;
2) transparently compress (accelerate) traffic by gzip.

=head1 README

Virtual Hosting Script	v0.5.1		(c) Denis Kaganovich AKA mahatma

There are simple script, that allow to alternative ways to:
1) virtual hosting;
2) transparently compress (accelerate) traffic by gzip.

(c)opyleft. Free. You MUST change code to tune.

WARNING: slotly tested, I have not security ideas. May be there are simple
large gap to your system, may be not. Try if sure. I am use it. Please,
don't write me nothing about changes, just do it self.

Installation:

Select ways to host. There are 3 modes ($mode):
0. Single virtual host.
1. Default: every vhost last level name lowercase witheout "www".
Examples: "www.doe.com" - "doe", "doe.com" - "doe".
2. Full host name lowercase.

Recommended name of script are "index.cgi".

Change "$enable_gzip" to "0" to turn off compression (default - ON if supported
by client).

Move all your [compressible] files and subdirectories into preferred directory.

Change ".htaccess" file something like this:
---
Options ExecCGI FollowSymLinks
ErrorDocument 403 /index.cgi
ErrorDocument 404 /index.cgi
AddHandler cgi-script .html .cgi .txt .jpg .htm .gif .js .bbs .rar .zip .tgz .exe .doc .pdf
---

Create writable cache (default - ".gz" ) directory if gzip &amp; cache enabled.

a) If your hoster supported for "ErrorDocument" in .htaccess - just try to access
your files. First request will be "404", but file will sended. Every next
request will be clean.


b) If your hoster are not support "ErrorDocument" - create:

dirtype=0 - symlinks in root: for every your directory, linked to ".",
for every file - linked to script. 

dirtype=1 - full directory structure and symlinks for files, linked to script.

Make "AddHandler cgi-script ..." to all file types and  script type (now
".cgi").

Edit config section.

Tested with Perl 5.8.0 &amp; Apache/1.3.28. Some with older Perl/Apache.
No perl modules usage.

=head1 PREREQUISITES

Perl 5.6.0 (last tested with 5.8.0, but IMHO stay compatible).

=head1 COREQUISITES

Perl 5, no modules

=pod OSNAMES

All

=pod SCRIPT CATEGORIES

Web, CGI

=cut
</pre></body></html>