shz.cgi
#!/usr/local/bin/perl
#
#
$myname = "shz.cgi";
$title = '着せ替え総本山の遺産';
$color_text = '#000000';
$color_link = '#0000FF';
$color_vlink = '#800080';
$color_alink = '#FF0000';
$color_bg = '#FFFFE0';
$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';
}
sub service_unavailable
{
my($title, @clients) = @_;
my($expires) = split(/\s/, shift @clients);
my($retry_after) = $expires - $now;
foreach (@clients) {
($expires, $host) = split(/\s/);
if ($retry_after > $expires - $now) {
$retry_after = $expires - $now;
}
}
print "Content-Type: text/html\n\n";
print "<html><head><title>$title</title></head>\n";
print "<body><h1>$title!</h1>\n";
if ($ENV{'HTTP_ACCEPT_LANGUAGE'} =~ /\bja/) {
print "<p>あと $retry_after 秒お待ちください.</p>\n";
} else {
print "<p>Please connect $retry_after seconds later.</p>\n";
}
print "</body></html>\n";
}
if ($ENV{'HTTP_IF_MODIFIED_SINCE'}) {
# always returns 304 since data won't be updated.
print "Status: 304 Not Modified\n\n";
exit 0;
}
if ($maxclients) {
local(*F, @clients, @clientreq);
if (!-e $clientsfile) {
open(F, ">$clientsfile");
close(F);
}
open(F, "+<$clientsfile");
flock(F, 2);
@clients = <F>;
if (@clients >= $maxclients) {
close(F);
&service_unavailable('Too many clients', @clients);
exit 0;
}
if ($maxclientreq &&
grep(/\d*\s+$remotehost\s/, @clients) >= $maxclientreq) {
close(F);
&service_unavailable('Too many requests', @clientreq);
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";
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 make_anchor
{
local($link, $title) = @_;
if ($java) {
if ($link =~ /\?/) {
$link = "$link;j=$java";
} else {
$link = "$link?j=$java";
}
}
$anchor = "<a href=\"$link\">$title</a>";
}
sub get_ttl
{
$file = $_[0];
$file2 = $file;
$file2 =~ s/&/%26/;
$tmp = $file;
$tmp =~ y/a-z/A-Z/;
&make_anchor("$myname?f=$file2", $tmp);
print "<tr><td>$anchor</td>";
open(FI,"$basedir$file.idx") or print "<td>$!: $basedir$file.idx</td>";
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_java_select;
print "<p align=right><a href=\"?dump=myself\"><code>$myname</code></a></p>\n";
}
sub print_java_select
{
local($c);
local($query) = $ENV{'QUERY_STRING'};
$query =~ s/[;&]?j=\d//;
$c = $query ? ';' : '?';
$query = '?' . $query if $query;
print "<p>";
print "<a href=\"$query\">No Java</a> " if $java;
print "<a href=\"${query}${c}j=1\">Java</a> " if $java != 1;
print "<a href=\"${query}${c}j=2\">KissChoco</a> " if $java != 2;
print "</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 );
&make_anchor("$myname?f=$file2;n=$cnt", $ttl);
print "$anchor\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");
&make_anchor("$myname", "トップへ");
print "<div align=\"right\">$anchor</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";
&print_java_select;
}
sub dump
{
foreach $_ ( unpack( "C1000", $_[0] ) ) {
printf( "%02x ", $_ );
}
}
sub print_file
{
local($filename) = @_;
open F, $filename;
while (<F>) {
s#\$linkname#$myname/$name?f=$file2;dl=$arno#;
print;
}
close F;
}
sub print_applet
{
local($width, $height, $fkiss, $trans);
local($tmpfile) = "/tmp/Tmp$$";
open(FD,"$basedir$file.dat");
binmode(FD);
seek(FD,$pos,0);
read(FD,$tmp,$len);
close(FD);
$cnforg = $cnfname;
$cnfname = "*.cnf *.CNF";# unless $cnfname;
open FC, "| $lha p - $cnfname >$tmpfile";
binmode FC;
print FC $tmp;
close FC;
if (!-e $tmpfile) {
print "cannot create $tmpfile";
}
open FC, "$tmpfile";
binmode FC;
#print "<pre>\n";
$_ = <FC>; # ::::::::
#print;
$_ = <FC>; # cnf名
#print;
chomp;
$cnfname = $_;
if (/.*[:\/]([^:\/]+)$/) {
$cnfname = $1;
}
$cnforg = $cnfname unless $cnforg;
$_ = <FC>; # ::::::::
#print;
print "<p>\n";
if ($cnfname ne $cnforg) {
&make_anchor("shz.cgi?f=$file2;n=$arno", $cnfname);
} else {
$anchor = $cnfname;
}
print "$anchor\n";
while (<FC>) {
#print;
if (/^.?::::::::$/) {
$_ = <FC>;
#print;
chomp;
$cnfname = $_;
if (/.*[:\/]([^:\/]+)$/) {
$cnfname = $1;
}
$_ = <FC>;
if ($cnfname ne $cnforg) {
$cnfname2 = $cnfname;
$cnfname2 =~ s/&/%26/g;
&make_anchor("shz.cgi?f=$file2;n=$arno;cnfname=$cnfname2", $cnfname);
} else {
$anchor = $cnfname;
}
print "$anchor\n";
#print;
}
if ($cnfname eq $cnforg) {
if (/^\((\d+)\D+(\d+)/) {
$width = $1;
$height = $2;
}
$fkiss = 1 if (/^;@\s*EventHandler/);
$trans = 1 if (/^#[^;]+;%[tT]/);
}
}
print "</p>\n";
close FC;
unlink $tmpfile;
$width = 448 unless $width;
$height = 320 unless $height;
$jar = $fkiss ? 'fkiss.jar' : 'kiss.jar';
$class = $fkiss ? 'Fkiss' : 'Kiss';
# &print_file("warnfkiss.txt") if $fkiss; # 対応済み
# &print_file("warntrans.txt") if $trans; # 対応済み
if ($cnfname) {
$cnfname = $cnforg;
undef @exsets;
open FE, "./exsets";
while (<FE>) {
chomp;
local($f, $no, $cnf, $exf, $exno, $exname) = split(/;/);
if ($f eq $file && $no eq $arno) {
if ($cnf eq '' || $cnf eq $cnfname) {
push(@exsets, ",shz.cgi/$exname?f=$exf;dl=$exno");
}
}
}
close FE;
local($jarname) = $name;
$jarname =~ s/\.lzh$/.jar/i;
if ($java == 4) {
print "<p><object codetype=\"application/java\" codebase=\"./\" classid=\"java:$class\" archive=\"$jar\" width=$width height=$height>\n";
print "<param name=\"archive\" value=\"$jar\">\n";
print "<param name=\"lzh_name\" value=\"shz.cgi/$name?f=$file2;dl=$arno";
foreach (@exsets) {
print;
}
print "\">\n";
print "<param name=\"cnf_name\" value=\"$cnfname\">\n";
open F, "noapplet.txt";
while (<F>) {
s#\$linkname#shz.cgi/$name?f=$file2;dl=$arno#;
print;
}
close F;
print "</object></p>\n";
} elsif ($java == 3) {
print "<p><object classid=\"clsid:8AD9C840-044E-11D1-B3E9-00805F499D93\"\n";
print "width=$width height=$height\n";
print "codebase=\"http://java.sun.com/products/plugin/1.2/jinstall-12-win32.cab#Version=1,2,0,0\">\n";
print "<param name=\"code\" value=\"$class\">\n";
print "<param name=\"archive\" value=\"$jar\">\n";
print "<param name=\"type\" value=\"application/x-java-applet;version=1.2\">\n";
print "<param name=\"lzh_name\" value=\"shz.cgi/$name?f=$file2;dl=$arno";
foreach (@exsets) {
print;
}
print "\">\n";
print "<param name=\"cnf_name\" value=\"$cnfname\">\n";
print "<embed type=\"application/x-java-applet;version=1.2\" width=$width height=$height\n";
print "code=\"$class\" archive=\"$jar\" lzh_name=\"shz.cgi/$name?f=$file2;dl=$arno";
foreach (@exsets) {
print;
}
print "\" cnf_name=\"$cnfname\"\n";
print "pluginspace=\"http://java.sun.com/products/plugin/1.2/plugin-install.html\">\n";
print "<noembed>\n";
open F, "noapplet.txt";
while (<F>) {
s#\$linkname#shz.cgi/$name?f=$file2;dl=$arno#;
print;
}
close F;
print "</noembed>\n";
print "</embed>\n";
print "</object></p>\n";
} elsif ($java == 2) {
print "<p><applet code=KissChoco archive=\"choco.zip\" width=$width height=".($height+52).">\n";
print "<param name=\"lzh\" value=\"shz.cgi/$name?f=$file2;dl=$arno;.lzh";
foreach (@exsets) {
print;
}
print "\">\n";
print "<param name=\"cnf\" value=\"$cnfname\">\n";
open F, "noapplet.txt";
while (<F>) {
s#\$linkname#shz.cgi/$name?f=$file2;dl=$arno#;
print;
}
close F;
print "</applet></p>\n";
} else {
print "<p><applet code=$class archive=\"$jar\" width=$width height=$height>\n";
print "<param name=\"lzh_name\" value=\"shz.cgi/$name?f=$file2;dl=$arno";
foreach (@exsets) {
print;
}
print "\">\n";
print "<param name=\"cnf_name\" value=\"$cnfname\">\n";
open F, "noapplet.txt";
while (<F>) {
s#\$linkname#shz.cgi/$name?f=$file2;dl=$arno#;
print;
}
close F;
print "</applet></p>\n";
}
}
}
sub print_navigation
{
$_ = $arno-1;
print make_anchor("$myname?f=$file2;n=$_", "前へ") . " \n" if $arno > 1;
$_ = $arno+1;
print make_anchor("$myname?f=$file2;n=$_", "後へ") . " \n";
print make_anchor("$myname?f=$file2", "上へ") . "\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, "nofollow");
$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";
&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 "<a href=\"$myname/$name?f=$file2;dl=$arno\">$name</a>";
print " $date $lenバイト\n";
&print_applet if $java && ($control{"$file\t$arno"} !~ /^b/);
}
print "<table width=\"100%\"><tr>\n";
print "<td>\n";
&print_java_select unless $control{"$file\t$arno"} =~ /^b/;
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);
read(FD,$tmp,$len);
print $tmp;
}
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' );
$java = $value if ( $name eq 'j' );
$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, $attr) = @_;
print "<title>$title</title>\n";
print "<meta name=\"ROBOTS\" content=\"NOFOLLOW\">\n" if $attr =~ /nofollow/;
print "</head>\n";
print "\n";
print "<body bgcolor=\"$color_bg\" 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 "<input type=\"hidden\" name=\"j\" value=\"$java\">" if $java;
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));
}