#! c:/perl/bin/perl
#
# mbutil.pl
#
# 1.001 : 途中表示を潤滑にするように変更
# 1.0 : 2/28/05 : Created
#
# nerimb3.cgi ヘルプユーティリティ
# 「メッセージボード３」はこのスクリプトが無くても動きます。
#
# 以下のPerlのパッケージがインストールされてないといけません。
#   LWP::UserAgent
#   GD
#   CGI::Carp
#
# mode=cleanlink
#  メッセージボード３の「リンク抜粋」の中のリンクリストからデッドリンクを排除します。
#
# mode=makebar
#  メッセージボード３の「統計」で使われる棒グラフの棒をgifファイルで作成します。
#
# $Id: mbutil.pl,v 1.12 2005/07/28 14:46:36 Hideki Kanayama Exp $
# Copyright(c) 2005 Hideki kanayama all right reserved

use LWP::UserAgent;
use GD;
use CGI::Carp qw(fatalsToBrowser);
use FileHandle;

$version = '1.001';
$lastupdatedyear = '2005';

#$query = new CGI;

$program = $0;
$program =~ s/^.+[\/\\]([^\/\\]+)$/$1/;
$script = "$program";
$nerimb = "nerimb3.cgi";

$admindat = "adminpwd.dat";
$setupfile = "mbsetup.pl";
$rejectlink = "rejectlink.dat";

$bar_r = "0";
$bar_g = "128";
$bar_b = "0";
$bar_x = "20";
$bar_y = "20";

if (-e $setupfile){
	require "$setupfile";
}

&parsedata;

if ($in{mode} eq 'makebar'){
	&makebar;
} elsif ($in{mode} eq 'cleanlink'){
	&cleanlink;
} elsif ($in{mode} eq 'dispbar'){
	&dispbar;
} else {
	&menu;
}

sub menu {

my $title = 'メッセージボード　ユーティリティ';

&htmlhead($title);

print <<END;

<center>
<h2>$title</h2>
<hr>

<font size=+1><b>rejectlink.dat更新</b></font><p>
<form actoin="$script" method=post>
<input type=hidden name=mode value=\"cleanlink\">
管理用パスワード<input type=password size=10 name=pwd><br>
<input type=submit name=\"cleanlink\" value=\"デッドリンクを検出し、$rejectlinkに追加する\"><br>
一旦ボタンをクリックしたら途中でブラウザの中止ボタンなどで止めないでください。<br>
サーバーに高負荷のままジョブが残って大変な事になります。<br>
全ての結果が再表\\示されるまでお待ちください。
</form>
</center>

<hr>

<center><font size=+1><b>統計で使われる棒グラフの棒（gifファイル）作成</b></font></center><p>

<form actoin="$script" method=post>
<table cols=2 width=30% border=1 align=center>
<tr><td align=right width=10% nowrap>
サイズ
</td>
<td align=left>
x=<input type=text size=10 name=pic_x value="20">px<br>
y=<input type=text size=10 name=pic_y value="20">px<br>
</td>
</tr>
<tr><td align=right>
色
</td>
<td align=left nowrap>
R=<input type=text size=10 name=pic_r value="0"> 0 ≦ R ≦ 255<br>
G=<input type=text size=10 name=pic_g value="128"> 0 ≦ G ≦ 255<br>
B=<input type=text size=10 name=pic_b value="0"> 0 ≦ B ≦ 255<br>
</td>
</tr>
<tr><td colspan=2 align=center nowrap>
管理用パスワード<input type=password size=10 name=pwd><br>
<input type=submit name=gen value='作成'>
</td></tr>
</table>
<input type=hidden name=mode value=makebar>
</form>

<hr>
END
print "<center>";
print "<a href=\"$top_link\">【トップへ】</a> <a href=\"$nerimb\">【メッセージボードへ】</a>\n";
print "</center>";

&htmltail;


}

sub makebar {

	&checkadmin;

	$in{pic_r} = 255 if $in{pic_r} > 255;
	$in{pic_g} = 255 if $in{pic_g} > 255;
	$in{pic_b} = 255 if $in{pic_b} > 255;

	my $gifdata = &dispbar(1);

	open(GIF,"> $gif") or &error("$gifが開けません");
	binmode GIF;
	print GIF $gifdata;
	close(GIF);

	my $title = 'makebar';
	&htmlhead($title);

	print "<center>以下gif画像が$gifとして作成されました。<p>\n";
	print "<a href=\"$gif\"><img src=\"$script?mode=dispbar&pic_x=$in{pic_x}&pic_y=$in{pic_y}&pic_r=$in{pic_r}&pic_g=$in{pic_g}&pic_b=$in{pic_b}\" border=0 alt=\"$gif\"></a>\n";
	print "<p>\n";
	&backlink;
	print "</center>";

	&htmltail;

}

sub dispbar {
	my ($ret) = shift;

	my ($bar_x,$bar_y,$bar_r,$bar_g,$bar_b) = ($in{pic_x},$in{pic_y},$in{pic_r},$in{pic_g},$in{pic_b});

	my $im = new GD::Image($bar_x,$bar_y);
	my $color = $im->colorAllocate($bar_r,$bar_g,$bar_b);
	$im->fill($bar_x,$bar_y,$color);
	my $gifdata = $im->gif();

	if ($ret == 1){
		return ($gifdata);
	} else {
		print "Content-type: image/gif\n\n";
		print "$gifdata";
	}
}

sub backlink {
	print "<a href=\"$script\">【ユーティリティへ】</a> <a href=\"$nerimb\">【メッセージボードへ】</a>\n";
}

sub parsedata {

	if ($ENV{"REQUEST_METHOD"} eq "GET"){
		$data=$ENV{"QUERY_STRING"};
		$method = 'GET';
	} elsif ($ENV{"REQUEST_METHOD"} eq "POST"){
		read(STDIN,$data,$ENV{"CONTENT_LENGTH"});
		$method = 'POST'
	}

	@tmparray=split(/&/,$data);

	foreach $string (@tmparray){
		($key,$value)=split(/=/,$string);

		$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
	
#		&jcode'convert(*value,'sjis');
	
		if ($key !~ /^comment/ && $key ne style_sheet && $key ne head_insert && $key ne team){
			$br = "";
		} else {
			$br = "<br>";
			$value =~ tr/+/ / if ($key !~ /^comment/);
			$value =~ s/=/&#61;/g;
		}

		$value =~ s/</&lt;/g; $value =~ s/>/&gt;/g;
		if ($value =~ /\r\n/) { $value =~ s/\r\n/$br/g; }
		if ($value =~ /\n/) { $value =~ s/\n/$br/g; }
		if ($value =~ /\r/) { $value =~ s/\r/$br/g; }
		if ($value =~ /,/) { $value =~ s/,/&#44;/g; }

		if ($key eq subject){
			$value =~ s/\'/&#39;/g;
		}
	
		$in{"$key"}=$value;
	}



	return(%in);

}

sub checkadmin {

if (open(FILE,"< $admindat")){;
	$filepwd = <FILE>;
	close(FILE);
	if ($filepwd =~ /^\$1\$/) { $salt = 3; } else { $salt = 0; }
	$f2 = substr($filepwd,$salt,2);
	$inpwd = crypt($in{pwd},$f2);
} else {
	&error('パスワードファイルが存在しません');
}

if ("$inpwd" ne "$filepwd"){
	&error('パスワードが違います。');
}

}

sub debug_in {
print "Content-type: text/html\n\n";
foreach (keys(%in)){
	print "$_ -> $in{$_}<br>\n";
}
}

sub error {

my ($msg) = shift;

unlink("$lockfile");

&htmlhead($msg);

print "<br><center>$msg</center>\n";


&htmltail;
exit;

}

sub htmlhead {

my ($title) = shift;

if ($bgimage_en == 1){
	$bgimage = "background=\"$bgimagefile\"";
} else {
	$bgimage = "bgcolor=\"$bgcolor\"";
}

print "Content-type:text/html\n\n";
print "<html>\n";
print "<HEAD>\n";
print "<META HTTP-EQUIV=\"Content-Type\" CONTENT=\"text/html; charset=Shift_JIS\">\n";
print "<META NAME=\"Author\" CONTENT=\"Hideki Kanayama\">\n";
print "<TITLE>$title</TITLE>\n";
if ($head_insert_en == 1){
	print "$head_insert\n";
}

if ($style_sheet_en == 1){
	print "<STYLE type=\"text/css\">\n";
	print "$style_sheet";
	print "\n</style>\n";
}
print "</HEAD>\n";
print "<BODY TEXT=\"#000000\" $bgimage LINK=\"#0000EE\" VLINK=\"#551A8B\" ALINK=\"#FF0000\">\n";


}

sub htmltail {
print "<div align=\"right\"><i>$script Ver. $version</i></div>\n";
print "<div align=\"right\"><i>Copyright(C) $lastupdatedyear, Hideki</i></div>\n";
print "</body></html>\n";
}


sub cleanlink {

&checkadmin;

my @reject;

if (open(REJECT,"< $rejectlink")){
	@reject = <REJECT>;
	close(REJECT);
	chomp @reject;
} else {
	@reject = ();
}

my $filename = &getfilename;

my $ua = LWP::UserAgent->new;
$ua->timeout(10);

my @deadlink = ();

&htmlhead('クリーンリンク');

print "デッドリンク検出中・・・・<br>";
my $flag = 0;
my $i = 1;

open(FILE,"< $filename");
STDOUT->autoflush(1);
while (<FILE>){
	chomp;
	($number,$b,$c,$d,$e,$date,$title,$main,$encpwd,$imagefile)=split(/,/);
	if (/https?:\/\/[\w\.\~\-\/\?\&\+\=\:\@\%\;\#\%\$]*/){
		foreach (split(/<[Bb][rR]>/,$main)){
			if (/(https?:\/\/[\w\.\~\-\/\?\&\+\=\:\@\%\;\#\%\$]*)/ && !/^\&gt;/){
				$linkarray2 .= "$1<br>";
				print "$number ";
				print "<br>\n" if ($i % 20 == 0);
				$i++;
			}
		}
		if($linkarray2 ne ""){
			($aaa)=grep(/^$number/,@reject);
			if ($aaa != $number){
				(@available_link) = split(/<br>/,$linkarray2);
				foreach (@available_link){
					my $response = $ua->get($_);
					if (! $response->is_success){
						$flag = 1;
						push(@deadlink,$number) if (!grep(/^$number$/,(@reject,@deadlink)));
						print "<p>$number -> $_ : ";
						print $response->status_line;
						print "<p>";
						$i=0;
					}
				}
			}
		}
		$linkarray2="";
	}
}

close(FILE);

print "<br>\n";

if ($flag == 1){
	my $alldeadlink = join ("\n",@deadlink);
	open(RL, ">> $rejectlink");
	print RL $alldeadlink;
	print RL "\n";
	close(RL);
} else {
	print "デッドリンクはありませんでした。<p>";
}

&backlink;

&htmltail;

}

sub getfilename {

my $filename;

if ($compatible == 1) {
	if (-e $mbarchdata && -e $mbpastdata && -e $mbdata){
		`$cat  $mbarchdata $mbpastdata $mbdata > $alldata`;
		chmod(0666,"$alldata");
		$filename="$alldata";
	} elsif ((! -e $mbarchdata) && -e $mbpastdata && -e $mbdata){
		`$cat  $mbpastdata $mbdata > $alldata`;
		chmod(0666,"$alldata");
		$filename="$alldata";
	} elsif ((! -e $mbarchdata) && (! -e $mbpastdata) && -e $mbdata){
		$filename="$mbdata";
	}
} else {
	$filename = $mbdata;
}

return $filename;

}