shz.cgi
#!/usr/bin/perl
#
#
$myname = "shz.cgi";
$title = '着せ替え総本山の遺産';
$color_text = '#000000';
$color_link = '#0000FF';
$color_vlink = '#800080';
$color_alink = '#FF0000';
$color_bg = '#FFFFE0';
$background = '';
$basedir = '';
$lha = '/usr/local/bin/lha';
$errorlog = "error-log";
$search_all = 1;
$maxclients = 0; # Limit of Clients (0:unlimited)
$maxclientreq = 0; # Limit of request per client (0:unlimited)
$clientsfile = "clients";
$txbps = 0; # 転送速度 (bytes/sec, 0:unlimited)
$config = "./config.pl";
require "$config" if -e $config;
$remotehost = &getclient;
binmode(STDIN);
binmode(STDOUT);
sub handler
{
local($sig) = @_;
local(*F);
$_ = &tmstr(localtime(time)) . " $myname[$$]: SIG{$sig} $remotehost\n $decode_buffer\n";
open(F, ">>$errorlog");
print F $_;
close(F);
&end;
exit 0;
}
foreach ('HUP', 'INT', 'QUIT', 'ABRT', 'FPE', 'KILL', 'PIPE', 'ALRM', 'TERM') {
$SIG{$_} = 'handler';
}
if ($maxclients) {
local(*F, @clients);
if (!-e $clientsfile) {
open(F, ">$clientsfile");
close(F);
}
open(F, "+<$clientsfile");
flock(F, 2);
@clients = <F>;
if (@clients >= $maxclients) {
close(F);
print "Content-Type: text/html\n\n";
print "<html><head><title>Too many clients</title></head>\n";
print "<body><h1>Too many clients!</h1>\n";
print "<p>Please connect some minutes later.</p>\n";
print "</body></html>\n";
exit 0;
}
if ($maxclientreq &&
grep(/\d*\s+$remotehost\s/, @clients) >= $maxclientreq) {
close(F);
print "Content-Type: text/html\n\n";
print "<html><head><title>Too many requests</title></head>\n";
print "<body><h1>Too many requests!</h1>\n";
print "<p>Please connect some minutes later.</p>\n";
print "</body></html>\n";
exit 0;
}
seek(F, 0, 0);
push(@clients, "$$\t$remotehost $ENV{'QUERY_STRING'}\n");
print F @clients;
close(F);
$clients = @clients;
}
&read_control;
&decode;
if ( $dl ) {
&download;
&end;
exit 0;
}
print "Content-type: text/html; charset=Shift_JIS\n\n";
print "<html>\n";
print "\n";
print "<head>\n";
print qq(<script type="text/javascript" src="https://emk.name/dhtml/stdio.js"></script>\n);
print qq(<script type="text/javascript" src="https://emk.name/dhtml/unlzh.js"></script>\n);
print qq(<script type="text/javascript" src="https://emk.name/dhtml/kiss.js"></script>\n);
if ( $word ) {
&search;
}
elsif ( $file ) {
if ( $arno ) {
&log_read;
}
else {
&log_list;
}
}
elsif ( $dump ) {
&dump_file("$myname");
}
else {
&top_page;
}
print "</body>\n";
print "</html>\n";
&end;
exit 0;
sub get_ttl
{
$file = $_[0];
$file2 = $file;
$file2 =~ s/&/%26/;
$tmp = $file;
$tmp =~ y/a-z/A-Z/;
print "<tr><td><a href=\"$myname?f=$file2\">$tmp</a></td>";
open(FI,"$basedir$file.idx");
binmode(FI);
if ( read(FI,$buf,256) == 256 ) {
$id = substr($buf,0x1a,8);
$wtr = substr($buf,0x22,16);
$ttl = substr($buf,0xb0,40);
$ttl =~ s/\0.*//;
print "<td>$ttl</td>";
}
close(FI);
print "</tr>\n";
}
sub make_files
{
@files = (
'anime',
'cgdata',
'cgtalk',
'comic',
'free',
'game',
'hgame',
'info',
'junkdata',
'junktalk',
'kissdata',
'kissinfo',
'kissq&a',
'kisstalk',
'ksug',
'local',
'music',
'needs',
'prof',
'proglib',
'progtalk',
'q&a',
'sfx',
'test',
'xxxdata',
'xxxtalk' );
}
sub top_page
{
&make_files;
&print_title($title);
print "<div align=\"center\">\n";
print "<H2>$title</H2>\n";
&print_form;
print "<table border=1>\n";
foreach $_ ( @files ) {
&get_ttl( $_ );
}
print "</table>\n";
print "</div>\n";
print "<p align=right><a href=\"?dump=myself\"><code>$myname</code></a></p>\n";
}
sub log_list_line
{
$id = substr($buf,0x1a,8);
$wtr = substr($buf,0x22,16);
$wtr =~ s/\0/ /g;
$_ = substr($buf,0xb0,40);
s/\0.*//;
&enc_amp_lt_gt;
$ttl = $_;
&date_string( unpack("x172V",$buf) );
$flags = unpack("x54v", $buf);
printf( "%4d:", $cnt );
if ($flags & 1) {
print " " x 46 . "(削除)\n";
} else {
print "$id $wtr $date ";
($pos,$len) = unpack("x224V2",$buf);
print '●' if ( $len );
print "<a href=\"$myname?f=$file2;n=$cnt\">$ttl</a>\n";
}
}
sub log_list
{
$file2 = $file;
$file2 =~ s/&/%26/;
$tmp = $file;
$tmp =~ y/a-z/A-Z/;
open(FI,"$basedir$file.idx");
binmode(FI);
if ( read(FI,$buf,256) == 256 ) {
$_ = substr($buf,0xb0,40);
s/\0.*//;
&enc_amp_lt_gt;
$ttl = $_;
&print_title("$tmp : $ttl");
print "<div align=\"right\"><a href=\"$myname\">トップへ</a></div>\n";
print "<H3>$tmp : $ttl</H3>\n";
}
print "●印はバイナリデータがあります<br>\n";
print "<pre>";
$cnt = 1;
while ( read(FI,$buf,256) == 256 ) {
&log_list_line;
$cnt++;
}
close(FI);
print "</pre>\n";
}
sub dump
{
foreach $_ ( unpack( "C1000", $_[0] ) ) {
printf( "%02x ", $_ );
}
}
sub print_html5
{
local($tmpfile) = "/tmp/Tmp$$";
open(FD,"$basedir$file.dat");
binmode(FD);
seek(FD,$pos,0);
read(FD,$tmp,$len);
close(FD);
open FC, "| $lha lgq - *.lzh *.LZH >$tmpfile";
binmode FC;
$SIG{PIPE} = 'IGNORE';
$status = print FC $tmp or $! != EPIPE;
$SIG{PIPE} = 'handler';
close FC;
return unless $status;
open FC, $tmpfile;
undef @nest_arcs;
while (<FC>) {
chomp;
@line = split(/ /);
push @nest_arcs, $line[$#line];
}
close FC;
$cnforg = $cnfname;
$cnfname = "*.cnf *.CNF";# unless $cnfname;
open FC, "| $lha lgq - $cnfname >$tmpfile";
binmode FC;
print FC $tmp;
close FC;
foreach (@nest_arcs) {
open FC, "| $lha pgq - $_ | $lha lgq - $cnfname >>$tmpfile";
binmode FC;
print FC $tmp;
close FC;
}
if (!-e $tmpfile) {
print "cannot create $tmpfile";
}
open FC, "$tmpfile";
binmode FC;
$_ = <FC>; # cnf名
chomp;
@line = split(/ /);
$cnfname = $line[$#line];
if ($cnfname =~ /.*[:\/]([^:\/]+)$/) {
$cnfname = $1;
}
$cnforg = $cnfname unless $cnforg;
print "<p id=\"cnfnames\">\n";
# if ($cnfname ne $cnforg) {
# $anchor = "<a href=\"$myname?f=$file2;n=$arno\">$cnfname</a>";
# } else {
# $anchor = $cnfname;
# }
# print "$anchor\n";
while (<FC>) {
chomp;
@line = split(/ /);
$cnfname = $line[$#line];
if ($cnfname =~ /.*[:\/]([^:\/]+)$/) {
$cnfname = $1;
}
# if ($cnfname ne $cnforg) {
# $cnfname2 = $cnfname;
# $cnfname2 =~ s/&/%26/g;
# $anchor = "<a href=\"$myname?f=$file2;n=$arno;cnfname=$cnfname2\">$cnfname</a>";
# } else {
# $anchor = $cnfname;
# }
# print "$anchor\n";
}
print "</p>\n";
close FC;
unlink $tmpfile;
if ($cnfname) {
$cnfname = $cnforg;
undef @exsets;
push(@exsets, qq("$myname/$name?f=$file2;dl=$arno"));
$index = 0;
open FE, "./exsets";
while (<FE>) {
chomp;
local($f, $no, $cnf, $exf, $exno, $exname, $dir) = split(/;/);
if ($f eq $file && $no eq $arno) {
if ($cnf eq '' || lc $cnf eq lc $cnfname) {
if ($dir eq '+') {
push(@exsets, qq("$myname/$exname?f=$exf;dl=$exno"));
} else {
unshift(@exsets, qq("$myname/$exname?f=$exf;dl=$exno"));
$index++;
}
}
}
}
close FE;
if (@exsets > 1) {
$arcname = "[" . join(',', @exsets) . "]";
} else {
$arcname = $exsets[0];
}
print <<EOM;
<script type="text/javascript"><!--
(function(){
var cnfnames = document.getElementById("cnfnames");
load_cnf(cnfnames, function(arcnames){
//cnfnames.appendChild(document.createElement("br"));
var first = true;
var filenames = arcnames[$index][1];
for (var j = 0; j < filenames.length; j++) {
if (!/\\.cnf\$/i.exec(filenames[j])) continue;
var filename = filenames[j];
var leafname = filename[filename.length - 1];
if (leafname == "$cnfname") {
cnfnames.appendChild(document.createTextNode(leafname + "\\n"));
} else {
var a = document.createElement("a");
if (first) {
a.href = "$myname?f=$file2;n=$arno";
} else {
a.href = "$myname?f=$file2;n=$arno;cnfname=" + leafname.replace(/[#&]/, function(c){return "%"+c.charCodeAt(0).toString(16);});
}
a.appendChild(document.createTextNode(leafname));
cnfnames.appendChild(a);
cnfnames.appendChild(document.createTextNode("\\n"));
}
first = false;
}
return "$cnfname";
}, $arcname, undefined, true);
})();
--></script>
EOM
}
}
sub print_navigation
{
$_ = $arno-1;
print "<a href=\"$myname?f=$file2;n=$_\">前へ</a> \n" if $arno > 1;
$_ = $arno+1;
if ($_*256 < $idxsize) {
print "<a href=\"$myname?f=$file2;n=$_\">後へ</a> \n";
} else {
print "後へ \n";
}
print "<a href=\"$myname?f=$file2\">上へ</a>\n";
}
sub log_read
{
$file2 = $file;
$file2 =~ s/&/%26/;
open(FI,"$basedir$file.idx");
binmode(FI);
seek(FI,256*$arno,0);
if ( read(FI,$buf,256) == 256 ) {
$flags = unpack("x54v", $buf);
if ($flags & 1) {
$ttl = "(削除)";
} else {
$id = substr($buf,0x1a,8);
$wtr = substr($buf,0x22,16);
$_ = substr($buf,0xb0,40);
s/\0.*//;
&enc_amp_lt_gt;
$ttl = $_;
&date_string( unpack("x172V",$buf) );
}
&print_title($ttl);
$ref = unpack("x4v", $buf);
print "<table width=\"100%\"><tr>\n";
print "<td width=\"5%\">$arno</td>";
print "<td width=\"10%\">$id</td>";
print "<td width=\"15%\">$wtr</td>";
print "<td width=\"50%\">$date</td>";
print "<td width=\"20%\" align=\"right\">\n";
$idxsize = -s "$basedir$file.idx";
&print_navigation();
print "</td></tr></table>\n";
print "<h3>$ttl</h3>\n";
unless ($flags & 1) {
$_ = $ref;
print "<a href=\"$myname?f=$file2;n=$_\">$ref</a>へのコメント<br>\n" if $ref > 1;
($pos,$len) = unpack("x216V2",$buf);
#print "<p>pos=$pos len=$len<br>\n";
if ( $len ) {
open(FD,"$basedir$file.dat");
binmode(FD);
seek(FD,$pos,0);
read(FD,$tmp,$len);
#&dump( $tmp );
$_ = $tmp;
s/\0.*//;
s/\r\n/\n/g;
s/\r/\n/g;
&enc_amp_lt_gt;
$tmp = $_;
print "<hr><pre>$tmp</pre><hr>\n";
close(FD);
}
($pos,$len) = unpack("x224V2",$buf);
if ( $len ) {
&date_string( unpack("x234V",$buf) );
&date_string2( unpack("x234V",$buf) );
$name = unpack("x238A12",$buf);
#&dump( $tmp );
$name =~ s/\0.*//;
print qq(<a href="$myname/$name?f=$file2;dl=$arno">$name</a>);
print " $date $lenバイト\n";
&print_html5 if ($control{"$file\t$arno"} !~ /^b/);
}
print "<table width=\"100%\"><tr>\n";
print "<td align=\"right\">\n";
&print_navigation();
print "</td></tr></table>\n";
if ($control{"$file\t$arno"}) {
&control_print("$file\t$arno");
}
}
}
close(FI);
}
sub control_print
{
local($key) = @_;
split(/\t+/, $control{$key}, 2);
print $_[1];
}
sub download
{
$_ = "$file\t$dl";
&download_inhibit($_) if $control{$_} =~ /^b/;
open(FI,"$basedir$file.idx");
binmode(FI);
seek(FI,256*$dl,0);
if ( read(FI,$buf,256) == 256 ) {
$flags = unpack("x54v", $buf);
unless ($flags & 1) {
open(FD,"$basedir$file.dat");
binmode(FD);
($pos,$len) = unpack("x224V2",$buf);
if ( $len ) {
&date_string( unpack("x234V",$buf) );
&date_string2( unpack("x234V",$buf) );
$name = unpack("x238A12",$buf);
$name =~ s/\0.*//;
print "Content-Type: application/octet-stream\n";
print "Content-Length: $len\n";
print "Last-Modified: $date2\n\n";
seek(FD,$pos,0);
$| = 1;
while ($len) {
local ($i);
$i = $len;
$i = $txbps if $txbps && $i > $txbps;
$i = read(FD,$tmp,$i);
print $tmp;
sleep(1) if $txbps; # for Band-width limit
$len -= $i;
}
}
close(FD);
}
}
close(FI);
}
sub download_inhibit
{
local($key) = @_;
print "Content-type: text/html; charset=Shift_JIS\n\n";
print "<html>\n";
print "\n";
print "<head>\n";
&print_title("Deleted binary");
&control_print($key);
print "</body></html>\n";
&end;
exit 0;
}
sub decode
{
if ($ENV{'REQUEST_METHOD'} =~ /POST/i) {
read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'});
} else {
$buffer = $ENV{'REDIRECT_QUERY_STRING'} || $ENV{'QUERY_STRING'};
}
$decode_buffer = $buffer;
@pairs = split(/[;&]/, $buffer);
foreach $pair (@pairs) {
($name, $value) = split(/=/, $pair);
$value =~ tr/+/ /;
$value =~ s/%([0-9a-fA-F][0-9a-fA-F])/pack("C", hex($1))/eg;
$file = $value if ( $name eq 'f' );
$arno = $value if ( $name eq 'n' );
$dl = $value if ( $name eq 'dl' );
$dump = $value if ( $name eq 'dump' );
$word = $value if ( $name eq 'word' );
$cnfname = $value if ( $name eq 'cnfname' );
$cnfname =~ s/[^-a-zA-Z0-9._@~&\$#]//g;
}
}
sub date_string
{
# 2038年問題が発生するかもしれません
if ($_[0] < 0 || $_[0] > 0x7fffffff) {
$date = '(illegal-time)';
return;
}
local($sec,$min,$hour,$mday,$month,$year,$wday,$yday,$isdst) = localtime($_[0]);
$date = sprintf("%d/%02d/%02d %02d:%02d:%02d",
$year+1900, $month+1, $mday, $hour, $min, $sec);
}
sub date_string2
{
$date2 = '(illegal-time)';
# 2038年問題が発生するかもしれません
$date2 = &tmstr(gmtime($_[0])) if ($_[0] >= 0 && $_[0] <= 0x7fffffff);
}
sub tmstr
{
sprintf("%s, %02d %s %d %02d:%02d:%02d GMT",
(Sun,Mon,Tue,Wed,Thu,Fri,Sat)[$_[6]], $_[3],
(Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec)[$_[4]],
$_[5] + 1900, $_[2], $_[1], $_[0]);
}
sub print_title
{
local($title) = @_;
print "<title>$title</title>\n";
print "</head>\n";
print "\n";
print "<body bgcolor=\"$color_bg\" background=\"$background\" text=\"$color_text\" link=\"$color_link\" vlink=\"$color_vlink\" alink=\"$color_alink\">\n";
print "\n";
}
sub dump_file
{
local($file) = @_;
local(*F);
&print_title($file);
print "<h1><code>$file</code></h1>\n";
print "<pre>";
open(F, $file);
while (<F>) {
&enc_amp_lt_gt;
print;
}
close(F);
print "</pre>\n";
}
sub enc_amp_lt_gt {
s/&/&/g;
s/</</g;
s/>/>/g;
}
# アクセス制御ファイル "control" を読み込み %control にその内容をセット
# %control は "$file\t$no" をキーとし "$mode\t$comment" という値
#
sub read_control
{
local($_, $file, $no, $mode, $comment, *F);
if (open(F, "control")) {
while (<F>) {
next if /^#/;
s/\r?\n$//;
next if split(/[ \t]+/, $_, 4) < 2;
$file = $_[0];
$no = $_[1];
$mode = $_[2] if $_[2];
$comment = $_[3] if $_[3];
$control{"$file\t$no"} = "$mode\t$comment";
}
close(F);
}
}
sub print_form
{
print "<form action=\"$myname\">";
print "<input type=\"text\" name=\"word\" value=\"\">";
print "<input type=\"submit\" value=\"検索\">";
print "</form>";
}
sub search
{
&make_files;
$_ = $word;
&enc_amp_lt_gt;
$ttl = "検索結果 : $_";
&print_title($ttl);
print "<div align=\"right\"><a href=\"$myname\">トップへ</a></div>\n";
print "<H3>$ttl</H3>\n";
print "●印はバイナリデータがあります<br>\n";
$word =~ s/([\\\^\.\$\|\(\)\[\]\*\+\?\{\}])/\\$1/g; # quotemeta
@words = split(/ /, $word);
$total_hit = 0;
foreach $_ ( @files ) {
if ($search_all || !(/data/ || /lib/)) {
&log_search( $_ );
$total_hit += $hit;
}
}
print "<p>$total_hit 件見つかりました。</p>";
}
sub matched
{
local($word);
foreach $word (@words) {
return 0 unless ($tmp =~ /$word/);
}
return 1;
}
sub log_search
{
local($file) = @_;
local($flags);
$file2 = $file;
$file2 =~ s/&/%26/;
$board = $file;
$board =~ y/a-z/A-Z/;
open(FI, "$basedir$file.idx");
binmode(FI);
open(FD, "$basedir$file.dat");
binmode(FD);
if (read(FI, $buf, 256) == 256) {
$_ = substr($buf, 0xb0, 40);
s/\0.*//;
&enc_amp_lt_gt;
$ttl = $_;
}
$hit = 0;
$cnt = 1;
while (read(FI, $buf, 256) == 256) {
($pos, $len) = unpack("x216V2", $buf);
$flags = unpack("x54v", $buf);
if ($len && !($flags & 1)) {
seek(FD, $pos, 0);
read(FD, $tmp, $len);
if (&matched) {
print "<h4>$board : $ttl</h4>\n<pre>\n" unless $hit;
&log_list_line;
$hit++;
}
}
$cnt++;
}
print "</pre>\n" if $hit;
}
sub end
{
if ($maxclients) {
local(*F, @clients);
open(F, "+<$clientsfile");
flock(F, 2);
@clients = <F>;
grep(s/^$$\t.*\n$//, @clients);
truncate(F, 0);
seek(F, 0, 0);
print F @clients;
close(F);
}
}
sub getclient
{
local($_, $r);
$_ = $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'};
$_ = gethostbyaddr(pack('C4',split(/\./,$_)),2) || $_ if /\d+\.\d+\.\d+\.\d+/;
$r = $_;
$_ = $ENV{'HTTP_X_FORWARDED_FOR'};
if ($_) {
if (/\d+\.\d+\.\d+\.\d+/ && !&isprivateip($_)) {
$_ = gethostbyaddr(pack('C4',split(/\./,$_)),2);
}
$r = "$r/$_";
}
$r;
}
sub isprivateip
{
local(@ip) = split(/\./, $_[0]);
(($ip[0] == 10) ||
($ip[0] == 172 && $ip[1] >= 16 && $ip[1] <= 31) ||
($ip[0] == 192 && $ip[1] == 168));
}