#!/usr/local/bin/perl

#┌─────────────────────────────────
#│ ASKA BBS : aska.cgi - 2013/02/15
#│ Copyright (c) KentWeb
#│ http://www.kent-web.com/
#└─────────────────────────────────

# モジュール宣言
use strict;
use CGI::Carp qw(fatalsToBrowser);
use lib "./lib";
use Jcode;

# 設定ファイル認識
require "./init.cgi";
my %cf = &init;

# データ受理
my %in = &parse_form;

# 処理分岐
if ($in{mode} eq 'regist') { &regist; }
if ($in{mode} eq 'find') { &find_data; }
if ($in{mode} eq 'note') { &note_page; }
if ($in{mode} eq 'del_log') { &del_log; }
&bbs_list;

#-----------------------------------------------------------
#  記事表示
#-----------------------------------------------------------
sub bbs_list {
	# レス処理
	$in{res} =~ s/\D//g;
	my %res;
	if ($in{res}) {
		my $flg;
		open(IN,"$cf{logfile}") or error("open err: $cf{logfile}");
		while (<IN>) {
			my ($no,$sub,$com) = (split(/<>/))[0,4,5];
			if ($in{res} == $no) {
				$flg++;
				$res{sub} = $sub;
				$res{com} = $com;
				last;
			}
		}
		close(IN);

		if (!$flg) { &error("該当記事が見つかりません"); }

		$res{sub} =~ s/^Re://g;
		$res{sub} =~ s/\[\d+\]\s?//g;
		$res{sub} = "Re:[$in{res}] $res{sub}";
		$res{com} = "&gt; $res{com}";
		$res{com} =~ s/<br>/\n&gt; /ig;
	}

	# ページ数定義
	my $pg = $in{pg} || 0;

	# データオープン
	my ($i,@log);
	open(IN,"$cf{logfile}") or error("open err: $cf{logfile}");
	while (<IN>) {
		$i++;
		next if ($i < $pg + 1);
		next if ($i > $pg + $cf{pg_max});

		push(@log,$_);
	}
	close(IN);

	# 繰越ボタン作成
	my $page_btn = &make_pgbtn($i,$pg);

	# クッキー取得
	my @cook = &get_cookie;
	$cook[2] ||= 'http://';

	# テンプレート読込
	open(IN,"$cf{tmpldir}/bbs.html") or error("open err: bbs.html");
	my $tmpl = join('', <IN>);
	close(IN);

	# 文字置換
	$tmpl =~ s/!([a-z]+_cgi)!/$cf{$1}/g;
	$tmpl =~ s/!homepage!/$cf{homepage}/g;
	$tmpl =~ s/!page_btn!/$page_btn/g;
	$tmpl =~ s/!name!/$cook[0]/;
	$tmpl =~ s/!email!/$cook[1]/;
	$tmpl =~ s/!url!/$cook[2]/;
	$tmpl =~ s/!sub!/$res{sub}/;
	$tmpl =~ s/!comment!/$res{com}/;
	$tmpl =~ s/!bbs_title!/$cf{bbs_title}/g;

	# テンプレート分割
	my ($head,$loop,$foot) = $tmpl =~ /(.+)<!-- loop_begin -->(.+)<!-- loop_end -->(.+)/s
			? ($1,$2,$3) : &error("テンプレート不正");

	# 画像認証作成
	my ($str_plain,$str_crypt);
	if ($cf{use_captcha} > 0) {
		require $cf{captcha_pl};
		($str_plain,$str_crypt) = cap::make($cf{captcha_key},$cf{cap_len});
		$head =~ s/!str_crypt!/$str_crypt/g;
	} else {
		$head =~ s/<!-- captcha_begin -->.+<!-- captcha_end -->//s;
	}

	# ヘッダ表示
	print "Content-type: text/html; charset=shift_jis\n\n";
	print $head;

	# ループ部
	foreach (@log) {
		my ($no,$date,$name,$eml,$sub,$com,$url,undef,undef,undef) = split(/<>/);
		$name = qq|<a href="mailto:$eml">$name</a>| if ($eml);
		$com = &autolink($com) if ($cf{autolink});
		$com =~ s/([>]|^)(&gt;[^<]*)/$1<span style="color:$cf{ref_col}">$2<\/span>/g if ($cf{ref_col});
		$com .= qq|<p class="url"><a href="$url" target="_blank">$url</a></p>| if ($url);

		my $tmp = $loop;
		$tmp =~ s/!num!/$no/g;
		$tmp =~ s/!sub!/$sub/g;
		$tmp =~ s/!name!/$name/g;
		$tmp =~ s/!date!/$date/g;
		$tmp =~ s/!comment!/$com/g;
		$tmp =~ s/!bbs_cgi!/$cf{bbs_cgi}/g;
		print $tmp;
	}

	# フッタ
	&footer($foot);
}

#-----------------------------------------------------------
#  記事書込
#-----------------------------------------------------------
sub regist {
	# 投稿チェック
	if ($cf{postonly} && $ENV{REQUEST_METHOD} ne 'POST') {
		&error("不正なリクエストです");
	}

	# 不要改行カット
	$in{sub}  =~ s/<br>//g;
	$in{name} =~ s/<br>//g;
	$in{pwd}  =~ s/<br>//g;
	$in{captcha} =~ s/<br>//g;
	$in{comment} =~ s/(<br>)+$//g;

	# チェック
	if ($cf{no_wd}) { &no_wd; }
	if ($cf{jp_wd}) { &jp_wd; }
	if ($cf{urlnum} > 0) { &urlnum; }

	# 画像認証チェック
	if ($cf{use_captcha} > 0) {
		require $cf{captcha_pl};
		if ($in{captcha} !~ /^\d{$cf{cap_len}}$/) {
			&error("画像認証が入力不備です。<br>投稿フォームに戻って再読込み後、再入力してください");
		}

		# 投稿キーチェック
		# -1 : キー不一致
		#  0 : 制限時間オーバー
		#  1 : キー一致
		my $chk = cap::check($in{captcha},$in{str_crypt},$cf{captcha_key},$cf{cap_time},$cf{cap_len});
		if ($chk == 0) {
			&error("画像認証が制限時間を超過しました。<br>投稿フォームに戻って再読込み後、指定の数字を再入力してください");
		} elsif ($chk == -1) {
			&error("画像認証が不正です。<br>投稿フォームに戻って再読込み後、再入力してください");
		}
	}

	# 未入力の場合
	if ($in{url} eq "http://") { $in{url} = ""; }
	$in{sub} ||= '無題';

	# フォーム内容をチェック
	my $err;
	if ($in{name} eq "") { $err .= "名前が入力されていません<br>"; }
	if ($in{comment} eq "") { $err .= "コメントが入力されていません<br>"; }
	if ($in{email} ne '' && $in{email} !~ /^[\w\.\-]+\@[\w\.\-]+\.[a-zA-Z]{2,6}$/) {
		$err .= "Ｅメールの入力内容が不正です<br>";
	}
	if ($in{url} ne '' && $in{url} !~ /^https?:\/\/[\w-.!~*'();\/?:\@&=+\$,%#]+$/) {
		$err .= "参照先URLの入力内容が不正です<br>";
	}
	if ($err) { &error($err); }

	# コード変換
	if ($cf{chg_code} == 1) {
		$in{name} = Jcode->new($in{name})->sjis;
		$in{sub}  = Jcode->new($in{sub})->sjis;
		$in{comment} = Jcode->new($in{comment})->sjis;
	}

	# ホスト取得
	my ($host,$addr) = &get_host;

	# 削除キー暗号化
	my $pwd = &encrypt($in{pwd}) if ($in{pwd} ne "");

	# 時間取得
	my $time = time;
	my ($min,$hour,$mday,$mon,$year,$wday) = (localtime($time))[1..6];
	my @wk = ('Sun','Mon','Tue','Wed','Thu','Fri','Sat');
	my $date = sprintf("%04d/%02d/%02d(%s) %02d:%02d",
				$year+1900,$mon+1,$mday,$wk[$wday],$hour,$min);

	# 先頭記事読み取り
	open(DAT,"+< $cf{logfile}") or error("open err: $cf{logfile}");
	eval "flock(DAT, 2);";
	my $top = <DAT>;

	# 重複投稿チェック
	my ($no,$dat,$nam,$eml,$sub,$com,$url,$hos,$pw,$tim) = split(/<>/, $top);
	if ($in{name} eq $nam && $in{comment} eq $com) {
		close(DAT);
		&error("二重投稿は禁止です");
	}

	# 連続投稿チェック
	my $flg;
	if ($cf{regCtl} == 1) {
		if ($host eq $hos && $time - $tim < $cf{wait}) { $flg = 1; }
	} elsif ($cf{regCtl} == 2) {
		if ($time - $tim < $cf{wait}) { $flg = 1; }
	}
	if ($flg) {
		close(DAT);
		&error("現在投稿制限中です。もうしばらくたってから投稿をお願いします");
	}

	# 記事No採番
	$no++;

	# 記事数調整
	my @data = ($top);
	my $i = 0;
	while (<DAT>) {
		$i++;
		push(@data,$_);

		last if ($i >= $cf{maxlog}-1);
	}

	# 更新
	seek(DAT, 0, 0);
	print DAT "$no<>$date<>$in{name}<>$in{email}<>$in{sub}<>$in{comment}<>$in{url}<>$host<>$pwd<>$time<>\n";
	print DAT @data;
	truncate(DAT, tell(DAT));
	close(DAT);

	# クッキー格納
	&set_cookie($in{name},$in{email},$in{url}) if ($in{cookie} == 1);

	# メール通知
	&mail_to($date,$host) if ($cf{mailing} == 1);

	# 完了画面
	&message("ありがとうございます。記事を受理しました。");
}

#-----------------------------------------------------------
#  ワード検索
#-----------------------------------------------------------
sub find_data {
	# 条件
	$in{cond} =~ s/\D//g;

	# 検索条件プルダウン
	my %op = (1 => 'AND', 0 => 'OR');
	my $op_cond;
	foreach (1,0) {
		if ($in{cond} eq $_) {
			$op_cond .= qq|<option value="$_" selected>$op{$_}\n|;
		} else {
			$op_cond .= qq|<option value="$_">$op{$_}\n|;
		}
	}

	# 検索実行
	if ($cf{chg_code} == 1) {
		$in{word} = Jcode->new($in{word})->sjis;
	}
	my @log = &search($in{word},$in{cond}) if ($in{word} ne '');

	# テンプレート読み込み
	open(IN,"$cf{tmpldir}/find.html") or error("open err: find.html");
	my $tmpl = join('', <IN>);
	close(IN);

	# 文字置換
	$tmpl =~ s/!bbs_cgi!/$cf{bbs_cgi}/g;
	$tmpl =~ s/<!-- op_cond -->/$op_cond/;
	$tmpl =~ s/!word!/$in{word}/;

	# テンプレート分割
	my ($head,$loop,$foot) = $tmpl =~ /(.+)<!-- loop_begin -->(.+)<!-- loop_end -->(.+)/s
			? ($1,$2,$3) : &error("テンプレート不正");

	# ヘッダ部
	print "Content-type: text/html; charset=shift_jis\n\n";
	print $head;

	# ループ部
	foreach (@log) {
		my ($no,$date,$name,$eml,$sub,$com,$url,undef,undef,undef) = split(/<>/);
		$name = qq|<a href="mailto:$eml">$name</a>| if ($eml);
		$com  = &autolink($com) if ($cf{autolink});
		$com =~ s/([>]|^)(&gt;[^<]*)/$1<span style="color:$cf{ref_col}">$2<\/span>/g if ($cf{ref_col});
		$url  = qq|<a href="$url" target="_blank">$url</a>| if ($url);

		my $tmp = $loop;
		$tmp =~ s/!sub!/$sub/g;
		$tmp =~ s/!date!/$date/g;
		$tmp =~ s/!name!/$name/g;
		$tmp =~ s/!home!/$url/g;
		$tmp =~ s/!comment!/$com/g;
		print $tmp;
	}

	# フッタ
	&footer($foot);
}

#-----------------------------------------------------------
#  検索実行
#-----------------------------------------------------------
sub search {
	my ($word,$cond) = @_;

	# キーワードを配列化
	$word =~ s/　/ /g;
	my @wd = split(/\s+/, $word);

	# キーワード検索準備（Shift-JIS定義）
	my $ascii = '[\x00-\x7F]';
	my $hanka = '[\xA1-\xDF]';
	my $kanji = '[\x81-\x9F\xE0-\xFC][\x40-\x7E\x80-\xFC]';

	# 検索処理
	my @log;
	open(IN,"$cf{logfile}") or error("open err: $cf{logfile}");
	while (<IN>) {
		my ($no,$date,$nam,$eml,$sub,$com,$url,$hos,$pw,$tim) = split(/<>/);

		my $flg;
		foreach my $wd (@wd) {
			if ("$nam $eml $sub $com $url" =~ /^(?:$ascii|$hanka|$kanji)*?\Q$wd\E/i) {
				$flg++;
				if ($cond == 0) { last; }
			} else {
				if ($cond == 1) { $flg = 0; last; }
			}
		}
		next if (!$flg);

		push(@log,$_);
	}
	close(IN);

	# 検索結果
	return @log;
}

#-----------------------------------------------------------
#  留意事項表示
#-----------------------------------------------------------
sub note_page {
	open(IN,"$cf{tmpldir}/note.html") or &error("open err: note.html");
	my $tmpl = join('', <IN>);
	close(IN);

	print "Content-type: text/html; charset=shift_jis\n\n";
	print $tmpl;
	exit;
}

#-----------------------------------------------------------
#  ユーザ記事削除
#-----------------------------------------------------------
sub del_log {
	# 入力チェック
	if ($in{num} eq '' or $in{pwd} eq '') {
		&error("削除Noまたは削除キーが入力モレです");
	}

	my ($flg,$crypt,@log);
	open(DAT,"+< $cf{logfile}") or error("open err: $cf{logfile}");
	eval "flock(DAT, 2);";
	while (<DAT>) {
		my ($no,$dat,$nam,$eml,$sub,$com,$url,$hos,$pw,$tim) = split(/<>/);

		if ($in{num} == $no) {
			$flg++;
			$crypt = $pw;
			next;
		}
		push(@log,$_);
	}

	if (!$flg || $crypt eq '') {
		close(DAT);
		&error("削除キーが設定されていないか又は記事が見当たりません");
	}

	# 削除キーを照合
	if (&decrypt($in{pwd},$crypt) != 1) {
		close(DAT);
		&error("認証できません");
	}

	# ログ更新
	seek(DAT, 0, 0);
	print DAT @log;
	truncate(DAT, tell(DAT));
	close(DAT);

	&message("記事を削除しました");
}

#-----------------------------------------------------------
#  エラー画面
#-----------------------------------------------------------
sub error {
	my $err = shift;

	open(IN,"$cf{tmpldir}/error.html") or die;
	my $tmpl = join('', <IN>);
	close(IN);

	$tmpl =~ s/!error!/$err/g;

	print "Content-type: text/html; charset=shift_jis\n\n";
	print $tmpl;
	exit;
}

#-----------------------------------------------------------
#  メール送信
#-----------------------------------------------------------
sub mail_to {
	my ($date,$host) = @_;

	# 件名をMIMEエンコード
	my $msub = Jcode->new("BBS : $in{sub}",'sjis')->mime_encode;

	# コメント内の改行復元
	my $com = $in{comment};
	$com =~ s/<br>/\n/g;
	$com =~ s/&lt;/>/g;
	$com =~ s/&gt;/</g;
	$com =~ s/&quot;/"/g;
	$com =~ s/&amp;/&/g;
	$com =~ s/&#39;/'/g;

	# メール本文を定義
	my $mbody = <<"EOM";
掲示板に投稿がありました。

投稿日：$date
ホスト：$host

件名  ：$in{sub}
お名前：$in{name}
E-mail：$in{email}
URL   ：$in{url}

$com
EOM

	# JISコード変換
	$mbody = Jcode->new($mbody,'sjis')->jis;

	# メールアドレスがない場合は管理者メールに置き換え
	$in{email} ||= $cf{mailto};

	# sendmailコマンド
	my $scmd = "$cf{sendmail} -t -i";
	if ($cf{sendm_f}) {
		$scmd .= " -f $in{email}";
	}

	# 送信
	open(MAIL,"| $scmd") or error("送信失敗");
	print MAIL "To: $cf{mailto}\n";
	print MAIL "From: $in{email}\n";
	print MAIL "Subject: $msub\n";
	print MAIL "MIME-Version: 1.0\n";
	print MAIL "Content-type: text/plain; charset=ISO-2022-JP\n";
	print MAIL "Content-Transfer-Encoding: 7bit\n";
	print MAIL "X-Mailer: $cf{version}\n\n";
	print MAIL "$mbody\n";
	close(MAIL);
}

#-----------------------------------------------------------
#  フッター
#-----------------------------------------------------------
sub footer {
	my $foot = shift;

	# 著作権表記（削除・改変禁止）
	my $copy = <<EOM;
<p style="margin-top:2em;text-align:center;font-family:Verdana,Helvetica,Arial;font-size:10px;">
- <a href="http://www.kent-web.com/" target="_top">ASKA BBS</a> -
</p>
EOM

	if ($foot =~ /(.+)(<\/body[^>]*>.*)/si) {
		print "$1$copy$2\n";
	} else {
		print "$foot$copy\n";
		print "</body></html>\n";
	}
	exit;
}

#-----------------------------------------------------------
#  自動リンク
#-----------------------------------------------------------
sub autolink {
	my $text = shift;

	$text =~ s/(s?https?:\/\/([\w-.!~*'();\/?:\@=+\$,%#]|&amp;)+)/<a href="$1" target="_blank">$1<\/a>/g;
	return $text;
}

#-----------------------------------------------------------
#  禁止ワードチェック
#-----------------------------------------------------------
sub no_wd {
	my $flg;
	foreach ( split(/,/, $cf{no_wd}) ) {
		if (index("$in{name} $in{sub} $in{comment}", $_) >= 0) {
			$flg = 1;
			last;
		}
	}
	if ($flg) { &error("禁止ワードが含まれています"); }
}

#-----------------------------------------------------------
#  日本語チェック
#-----------------------------------------------------------
sub jp_wd {
	if ($in{comment} !~ /[\x81-\x9F\xE0-\xFC][\x40-\x7E\x80-\xFC]/) {
		&error("メッセージに日本語が含まれていません");
	}
}

#-----------------------------------------------------------
#  URL個数チェック
#-----------------------------------------------------------
sub urlnum {
	my $com = $in{comment};
	my ($num) = ($com =~ s|(https?://)|$1|ig);
	if ($num > $cf{urlnum}) {
		&error("コメント中のURLアドレスは最大$cf{urlnum}個までです");
	}
}

#-----------------------------------------------------------
#  アクセス制限
#-----------------------------------------------------------
sub get_host {
	# IP&ホスト取得
	my $host = $ENV{REMOTE_HOST};
	my $addr = $ENV{REMOTE_ADDR};
	if ($cf{gethostbyaddr} && ($host eq "" || $host eq $addr)) {
		$host = gethostbyaddr(pack("C4", split(/\./, $addr)), 2);
	}

	# IPチェック
	my $flg;
	foreach ( split(/\s+/, $cf{deny_addr}) ) {
		s/\./\\\./g;
		s/\*/\.\*/g;

		if ($addr =~ /^$_/i) { $flg++; last; }
	}
	if ($flg) {
		&error("アクセスを許可されていません");

	# ホストチェック
	} elsif ($host) {

		foreach ( split(/\s+/, $cf{deny_host}) ) {
			s/\./\\\./g;
			s/\*/\.\*/g;

			if ($host =~ /$_$/i) { $flg++; last; }
		}
		if ($flg) {
			&error("アクセスを許可されていません");
		}
	}

	if ($host eq "") { $host = $addr; }
	return ($host,$addr);
}

#-----------------------------------------------------------
#  crypt暗号
#-----------------------------------------------------------
sub encrypt {
	my $in = shift;

	my @wd = ('a'..'z', 'A'..'Z', '0'..'9', '.', '/');
	srand;
	my $salt = $wd[int(rand(@wd))] . $wd[int(rand(@wd))];
	crypt($in,$salt) || crypt ($in,'$1$'.$salt);
}

#-----------------------------------------------------------
#  crypt照合
#-----------------------------------------------------------
sub decrypt {
	my ($in,$dec) = @_;

	my $salt = $dec =~ /^\$1\$(.*)\$/ ? $1 : substr($dec,0,2);
	if (crypt($in,$salt) eq $dec || crypt($in,'$1$'.$salt) eq $dec) {
		return 1;
	} else {
		return 0;
	}
}

#-----------------------------------------------------------
#  完了メッセージ
#-----------------------------------------------------------
sub message {
	my $msg = shift;

	open(IN,"$cf{tmpldir}/message.html") or error("open err: message.html");
	my $tmpl = join('', <IN>);
	close(IN);

	$tmpl =~ s/!bbs_cgi!/$cf{bbs_cgi}/g;
	$tmpl =~ s/!message!/$msg/g;

	print "Content-type: text/html; charset=shift_jis\n\n";
	print $tmpl;
	exit;
}

#-----------------------------------------------------------
#  繰越ボタン作成
#-----------------------------------------------------------
sub make_pgbtn {
	my ($i,$pg) = @_;

	# ページ繰越定義
	$cf{pg_max} ||= 10;
	my $next = $pg + $cf{pg_max};
	my $back = $pg - $cf{pg_max};

	# ページ繰越ボタン作成
	my $pg_btn;
	if ($back >= 0 || $next < $i) {
		$pg_btn .= "Page: ";

		my ($x,$y) = (1,0);
		while ($i > 0) {
			if ($pg == $y) {
				$pg_btn .= qq(| <b>$x</b> );
			} else {
				$pg_btn .= qq(| <a href="$cf{bbs_cgi}?pg=$y">$x</a> );
			}
			$x++;
			$y += $cf{pg_max};
			$i -= $cf{pg_max};
		}
		$pg_btn .= "|";
	}
	return $pg_btn;
}

#-----------------------------------------------------------
#  クッキー発行
#-----------------------------------------------------------
sub set_cookie {
	my @data = @_;

	# 60日間有効
	my ($sec,$min,$hour,$mday,$mon,$year,$wday,undef,undef) = gmtime(time + 60*24*60*60);
	my @mon  = qw|Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec|;
	my @week = qw|Sun Mon Tue Wed Thu Fri Sat|;

	# 時刻フォーマット
	my $gmt = sprintf("%s, %02d-%s-%04d %02d:%02d:%02d GMT",
				$week[$wday],$mday,$mon[$mon],$year+1900,$hour,$min,$sec);

	# URLエンコード
	my $cook;
	foreach (@data) {
		s/(\W)/sprintf("%%%02X", unpack("C", $1))/eg;
		$cook .= "$_<>";
	}

	print "Set-Cookie: $cf{cookie_id}=$cook; expires=$gmt\n";
}

#-----------------------------------------------------------
#  クッキー取得
#-----------------------------------------------------------
sub get_cookie {
	# クッキー取得
	my $cook = $ENV{HTTP_COOKIE};

	# 該当IDを取り出す
	my %cook;
	foreach ( split(/;/, $cook) ) {
		my ($key,$val) = split(/=/);
		$key =~ s/\s//g;
		$cook{$key} = $val;
	}

	# URLデコード
	my @cook;
	foreach ( split(/<>/, $cook{$cf{cookie_id}}) ) {
		s/%([0-9A-Fa-f][0-9A-Fa-f])/pack("H2", $1)/eg;
		s/[&"'<>]//g;

		push(@cook,$_);
	}
	return @cook;
}