# Last updated: "Mon, 06 May 2002 10:58:45 JST-9"
package Bbs;
use strict;

use vars qw($VERSION);
$VERSION = '0.00';
sub version { $VERSION; }

require 5.004;

=head1 NAME なまえ

Bbs - お絵描き掲示板 ２ｃｈ互換 スレ立て・レス処理その他もろもろベースクラス

=head1 SYNOPSIS がいよう

 #!/usr/local/bin/perl
 use Bbs;
 my $bbs = Bbs->new();
 my ($tmpl, $msg);

 if($bbs->write_all()){
   if( $bbs->flag('notice_response') ) {
     # 物申す事がある(2重書き込みや連続投稿の警告とか)
     $tmpl = $bbs->path('template').$bbs->conf('template_error');
   } else {
     # 正常にレス書き込み処理が終了した
     $tmpl = $bbs->path('template').$bbs->conf('template_wait');
   }
 }else{
   if ( $bbs->from('new') eq 'thread' ) {
     # 新規スレ立てならスレ立てテンプレートを選択
     $tmpl = $bbs->path('template').$bbs->conf('template_new_thread');
   } else {
     # 普通のエラーならばエラーのテンプレートを選択
     $tmpl = $bbs->path('template').$bbs->conf('template_error');
   }
 }
 $msg = $bbs->template(\$tmpl);
 $bbs->print_headerfields();
 print $$msg;
 exit;

=head1 DESCRIPTION せつめい

このBBSクラスは、投稿されたデータを適当に処理します。
ログ形式・ファイル構成で２ｃｈスクリプトとほぼ同等の互換性を持っています。多分。

=head1 WARNING ちゅうい

B<use it at your own risk>

まだ、このスクリプトは作りかけです。

うっかりローカルで動かしたり、うっかりサーバーに設置してファイルが消えたり・上書きされても知りません。

まぁ、そんな事はめったに無いとは思いますが、万が一そういう事が起こってもめんどくさいので責任は一切取りません。

あと、スクリプトで致命的な問題が見つかったとしてもめんどくさいので直さないかもしれません。

要するにやる気が無い。

=head1 NOTE めも

 xyzzy以外のエディタで見ると非常に見にくい。
 全てのメソッドは成功したらリファレンスか何らかの値を返す。もし処理でエラーが出た場合は、必ず偽を返す。
 POSTやGETで送られてきたデータは一切信用しない。
 値はなるべくアクセサで変更しよう。
 sjis以外は色々めんどくさいから受け付けない。でも、気まぐれでちゃんとやるかも。
 お絵描き掲示板をわざわざi-modeで見ることはないだろうから、それに色々めんどくさいから対応しない。でも、気まぐれで対応するかも。
 キャップ持ちは特別扱いしない。普通に扱う。要するにキャップ持ちの規制回避処理を作るのがめんどくさい。
 そろそろ、このモジュールも太ってきたので分割してダイエット？

 ★できること・できないこととか
 ◎新しいスレッドを立てるとか
 ◎スレッドへの書き込み（レス）とか
 ◎subject.txtの書き換えとか
 ◎subback.htmlの書き換えとか
 ◎index.htmlの書き換えとか
 ◎テンプレートとか
 ×ホスト規制関係とか
 △串規制関係とか
 △ポートスキャンとか
 ◎２重カキコチェックとか
 ×投稿したレスのパスによる自己あぼんとか
 ×投稿したレスのパスによる編集とか
 ◎キャップとか
 ×キャップパス暗号化とか
 ◎トリップとか
 ◎ID表示・非表示とか
 ◎fusianasanとか
 ◎クエリーとか
 ◎レスアンカーの制限とか
 ◎URIのアンカーとか
 ◎変な文字が混ざっていないかチェックとか
 ◎日付を作るとか
 △ホスト名取得と串判定とか
 ◎クッキーとか
 ◎エラーHTML出力とか
 ◎http://pc.2ch.net/test/read.cgi/php/1010669197/900n を参考にNGワード置換とか

 ∧,⊂ヾ
ミﾟДﾟミｿ < HARDCORE will never die !!
 ﾐ ⊃ﾐ
 ﾐ　　ﾐ
 ⊂,,ｼ〜
 ∪

=head1 SEE ALSO さらに見るべし

最も激しく参考にした2ch流出スクリプト
L<http://mankomankomanko.virtualave.net/bbs.txt>

結構激しく参考にした17氏による改造2ch流出スクリプト及び付属管理ツール
L<http://www.apc.7777.net/aborn/index2.html>

【スレッド】　２ch型掲示板その４　【フロート式】
L<http://pc.2ch.net/test/read.cgi/php/1010669197/>

SETTING.TXT解読スレ
L<http://qb.2ch.net/test/read.cgi/jikken/1016112587/>

xrea.com part9
L<http://pc.2ch.net/test/read.cgi/perl/1016979723/>

POD（Plain Old Document）書き方参考
L<http://member.nifty.ne.jp/hippo2000/perltips/podread.htm>

テンプレート処理(Perl embeded HTML)参考
L<http://www.goice.co.jp/member/mo/amuse/perlTips.html>

フィーネ萌えーヽ(´ー｀)ノ式拡張表示参考
L<http://ton.2ch.net/sec/kako/996/996966367.html>

=head1 AUTHOR かいたひと

written by ◆sUY48rs.E<lt>I<momokotan@s3.xrea.com>E<gt> in 2002

◆sUY48rs. is very idler.

=cut

sub new ## コンストラクタ
{
	my $e = shift; # e は either
	return if ref $e;
	my $s = bless {}, $e;
	$s->initialize(\@_);
	$s; # 最後に評価したものをreturn
}

sub initialize ## 初期化
{
	my $s = shift; # s は self の省略
	my %a = @{$_[0]}; # a は args
	$s->{'from'} = { # UAから送られてくるデータ関係とか
		'bbs'=>undef, 'key'=>undef, 'time'=>undef, 'subject'=>undef, 'name'=>undef, 'mail'=>undef, 'message'=>undef, 'date'=>undef, 'host'=>undef, 'id'=>undef, 'st'=>undef, 'to'=>undef, 'ls'=>undef,
	};
	$s->{'path'} = { # 各種パス関係とか
		'script'=>undef, 'bbs'=>undef, 'dat'=>undef, 'dat2'=>undef, 'kako'=>undef, 'subject'=>undef, 'subback'=>undef, 'caps'=>undef, 'template'=>undef,
	};
	$s->{'conf'} = { # 板の初期設定の初期化 initialize_conf()でSETTING.TXTを読み出して項目がかぶってれば値は上書き。(SETTING.TXTが優先)
		'setting'			=> 'SETTING.TXT',
		'subject'			=> 'subject.txt',
		'subback'			=> 'subback.html',
		'index'				=> 'index.html',
		#'rip'				=> 'rip.txt',
		'caps'				=> 'caps.cgi',
		'response'			=> 'response.cgi',	# レスのホスト一時格納（仮名）
		'thread'			=> 'thread.cgi',	# スレッドのホスト一時格納（仮名）
		'kushi'				=> 'kushi.cgi',		# プロクシ規制リスト（仮名）
		'kisei'				=> 'kisei.cgi',		# 板別規制ファイル（仮名）
		'head'				=> 'head.html',		# 板のトップ表示
		'option'			=> 'option.txt',	# サーバ別まとめて表示（クリックで救えるとか）
		'putad'				=> 'putad.txt',		# 広告（１６メロミックス）
		'headad'			=> 'headad.txt',	# 広告（e-Bankなど）
		'henkan'			=> 'henkan.cgi',	# 変換する文字列リスト

		'template_index'		=> 'index.tmpl',		# index.htmlのテンプレート
		'template_new_thread'		=> 'new_thread.tmpl',		# 新規スレ立ての確認画面のテンプレート
		'template_error'		=> 'error.tmpl',		# エラー画面のテンプレート
		'template_notice'		=> 'notice.tmpl',		# 警告画面のテンプレート
		'template_wait'			=> 'wait.tmpl',			# 書き込み完了時のテンプレート
		'template_notice_new_thread'	=> 'notice_new_thread.tmpl',	# スレ立て最終確認画面のテンプレート
		'template_notice_response'	=> 'notice_response.tmpl',	# スレ立て最終確認画面のテンプレート
		#'template_index'		=> 'index.tmpl',
		#'template_index'		=> 'index.tmpl',

		'line_break'			=> '<br />',		# \nを置換する文字列

		# [%a: 短い形式の曜日] [%A: 長い形式の曜日] [%b: 短い形式の月] [%B: 長い形式の月] [%d: 日(00〜59)] [%H: 時(00〜23)] [%m: 月(01〜12)] [%M: 分(00〜59)] [%S: 秒(00〜59)] [%p: 午前/午後] [%v: 曜日(日本語)] [%y: 年(2桁)] [%Y: 年(4桁)] [%z: タイムゾーン名(JST-9)] [%Z: タイムゾーン(+0900)]
		'date_time_format'		=> '%Y/%m/%d (%v) %H:%M',

		'delimiter_dat'			=> '<>',	# datのデリミタ
		'delimiter_subject'		=> '<>',	# subjectのデリミタ
		'delimiter_response'		=> '<>',	# 2重カキコチェックのデリミタ
		'delimiter_thread'		=> '<>',	# スレッド立てすぎチェックのデリミタ
		'delimiter_henkan'		=> '<>',	# 変換文字列リストのデリミタ

		'notice_line_length'		=> 230,		# 警告を出す一行の長さ
		'notice_line_break'		=> 25,		# 警告を出す改行数

		'limit_line_length'		=> 256,		# 一行の長さ制限
		'limit_line_break'		=> 32,		# 改行数制限
		'limit_fromtime'		=> 1080,	# フォームのtimeの制限時間（秒）
		'limit_dat_file_size'		=> 512000,	# datの最大ファイルサイズ（byte）
		'limit_dat_line'		=> 1000,	# スレッドストッパーをかける行数
		'limit_line_number'		=> 16,		# レス省略までの行数 index.tmplで使用

		'cookie_expire'			=> 252288000,#86400,	# クッキー有効期限(秒)
		'cookie_jcode_encode'		=> '',		# Jcode.pmを使用して作った、URLエンコードのクッキーを食べさせるかどうか 使用しない場合はそのまま何もせず食べさせる。本当はちゃんとやらないといけないんだけど・・・

		'stopper_thread_name'		=> 'スレッドストッパー(´･ω･`)', # スレスト名前
		'stopper_thread_datetime'	=> '書き込めません', # スレスト投稿日時（最重要）
		'stopper_thread_message'	=> 'もうこのスレッドに書き込む事は出来ません。新しいスレッドを立ててね。', # スレスト本文

		'check_from'			=> 'checked',	# 送られてきた情報をチェック debug用
		'check_thread'			=> 'checked',	# スレ立てすぎチェック
		'check_response'		=> 'checked',	# 2重カキコチェック
		'check_line_length'		=> 'checked',	# 長すぎる行がありますチェック
		'check_port'			=> 'checked',	# ポートチェックするかどうか
		'check_port_list'		=> '80,8080,3128,1080',	# チェックするポート
		'check_port_timeout'		=> 5,		# ポートチェックのタイムアウト
		'check_advance_env_chk'		=> undef,	# 診断くんのソースをパクッて作ったモジュールによる串チェック

		'renew_index'			=> 'checked',	# indexを作るかどうか
		'renew_subback'			=> 'checked',	# subbackを作るかどうか

		'replacement_cap'		=> 'checked',	# capを使う
		'replacement_trip'		=> 'checked',	# トリップを使う
		'replacement_fusianasan'	=> 'checked',	# fusianasanを使う
		'replacement_resanchor'		=> 'checked',	# resanchorを使う
		'replacement_urianchor'		=> 'checked',	# urianchorを使う
		'replacement_tag'		=> 'checked',	# \nを<br>に置換
		'replacement_unicode'		=> 'checked',	# unicodeは？に置換
		'replacement_char_entity_set'	=> 'checked',	# & < > " などを文字参照に置換
		'replacement_msg_char_entity_set'	=> 'checked',	# 本文の & < > " などを文字参照に置換
		'replacement_ng_word'		=> 'checked',	# NGワードは適当に置換

		# SETTING.TXTデフォルト設定
		'BBS_TITLE'		=> '学校の怪談＠お絵かき掲示板', #掲示板名称
		'BBS_SUBTITLE'		=> 'つくりかけ', #掲示板副題
		'BBS_FIGUREHEAD'	=> '../images/2ch.gif', #看板画像
		'BBS_HEADLINK'		=> 'http://www.2ch.net/guide/', #看板リンク
		'BBS_BACKGROUND'	=> '../images/ba.gif', #背景画像
		'BG_COLOR_INFO'		=> '#CCFFCC',
		'BG_COLOR_THREAD'	=> '#EEEEEE',
		'TEXT_COLOR_BASE'	=> '#000000',
		'TEXT_COLOR_SUBJECT'	=> '#FF0000',
		'TEXT_COLOR_NAME'	=> '#228822',
		'LINK_COLOR'		=> '#0000CC',
		'ALINK_COLOR'		=> '#FF0000',
		'VLINK_COLOR'		=> '#AA0088',
		'THREAD_MENU'		=> 50,		#スレッド一覧の表示数
		'THREAD_NUMBER'		=> 20,		#index.htmlで表示するスレッド数
		'CONTENTS_NUMBER'	=> 10,		#スレッドでの最新レス数
		'LIMIT_SUBJECT'		=> 48,		#スレッドタイトル文字数制限
		'LIMIT_NAME'		=> 48,		#名前文字数制限
		'LIMIT_MAIL'		=> 48,		#メール欄文字数制限
		'LIMIT_MESSAGE'		=> 2048,	#本文文字数制限
		'LIMIT_LINE'		=> 16,		#改行制限＆「省略されました全てを・・」の条件 
		'NANASHI_NAME'		=> '名無しさん',#名無しさんの名前
		'CAP_CHECK'		=> undef,	#
		'NAME_CHECK'		=> undef,	#名前強制入力
		'PROXY_CHECK'		=> undef,	#串禁止
		'RES_CHECK'		=> 'checked',	#書きこみ確認画面を出す
		'HOST_CHECK'		=> 'checked',	#変なホストはじき？
		'UNICODE_CHANGE'	=> 'checked',	#ユニコード置換 checked:置換 pass || undef:やらない
		'THREAD_TATESUGI'	=> 25,		#スレ立てチェック数
		'THREAD_JUNBAN'		=> undef,	#スペシャルなスレ立て規制 用途不明
		'RES_RENZOKU'		=> 12,		#12回分のログを記録して、
		'RES_KAKISUGI'		=> 5,		#そのうち5回同じ人が投稿したら確認画面に飛ばす
		'PING_ITAZURA'		=> 12,		#確認画面に飛ばされた奴を12回分記録して
		'PING_IYADURA'		=> 5,		#そのうち5回同じ人が引っかかったらアク禁に飛ばす
		'ASETTYA_DAME'		=> 3,		#強制レス間隔
		'ID_DISP'		=> 'show',	#ID表示 [show:任意] [snow:任意逝印] [force:強制] [none || undef:表示しない]
	};
	$s->{'permission'} = { # 各種ファイルのデフォルトパーミッション
		'index'		=> 0666,
		'subject'	=> 0666,
		'dat'		=> 0666,
		'lst'		=> 0600,
		#'rip'		=> 0600,
		'caps'		=> 0600,
		'response'	=> 0600, # レスのホスト一時格納（仮名）
		'thread'	=> 0600, # スレッドのホスト一時格納（仮名）
	};
	$s->{'flag'} = { # モジュールが内部で使ったりするふらぐとか 基本的に０か１のどちらか
		'print_headerfields'	=> 0,	# content-type: text/htmlとか出力したかどうか
		'use_proxy'		=> 0,	# proxy使ってるかどうか
		'new_thread'		=> 0,	# スレ立てかどうか
		'write_thread'		=> 0,	# レスかどうか
		'use_cap'		=> 0,	# キャップ持ちかどうか
		'use_trip'		=> 0,	# キャップ持ちかどうか
		'error'			=> 0,	# どこかでえらーがおきたかどうか
		'notice_response'	=> 0,	# 警告出すかどうか
	};
	$s->{'counter'} = { # カウンタ
		'dat_count'	=> 0,	# datの行数
		'line_count'	=> 0,	# 置換した<br>の数
		'resanchor'	=> 0,	# レスのアンカーの数
		'urianchor'	=> 0,	# URIのアンカーの数
	};
	$s->{'headerfields'} = {
		'Content-Type: '	=> 'text/html; charset=Shift_JIS',
	};
	$s->{'cookie'} = {
		'NAME'=>undef, 'MAIL'=>undef, 'SPID'=>undef,
	};
	my ($n,$v);
	my @c = split '; ', $ENV{'HTTP_COOKIE'};
	($n,$v) = split('=', $_, 2), $s->{'cookie'}->{$n} = $v foreach @c;
	$s->{'error_reason'}	= {
		'title'	=> undef,
		'head'	=> undef,
		'body'	=> undef,
	};
	my ($k1,$k2); # key1 key2
	while ( $k1 = each %a ) {
		$s->{$k1} = $a{$k1}, next unless ref $a{$k1} eq 'HASH';
		$s->{$k1}->{$k2} = $a{$k1}->{$k2} while $k2 = each %{$a{$k1}};
	}
	$s;
}
##
#	まとめて値を設定とか
##
sub initialize_path ## pathへまとめて設定
{
	# あらかじめ値が設定されていた場合は変更しない
	$_[0]->path( 'script'	=> '../test/' )				unless defined $_[0]->path('script'); # bbs.cgi read.cgiの置いてある場所
	$_[0]->path( 'bbs'	=> '../'.$_[0]->from('bbs').'/' )	unless defined $_[0]->path('bbs');
	$_[0]->path( 'dat'	=> '../'.$_[0]->from('bbs').'/dat/' )	unless defined $_[0]->path('dat');
	$_[0]->path( 'subject'	=> '../'.$_[0]->from('bbs').'/' )	unless defined $_[0]->path('subject'); # subjectの置いてあるパスを作る
	$_[0]->path( 'subback'	=> '../'.$_[0]->from('bbs').'/' )	unless defined $_[0]->path('subback'); # subbackの置いてあるパスを作る
	$_[0]->path( 'caps'	=> '../'.$_[0]->conf('caps') )		unless defined $_[0]->path('caps'); # capsの置いてあるパスを作る
	$_[0]->path( 'template'	=> './template/default/' )		unless defined $_[0]->path('template'); # templateのパスを作る
	$_[0];
}
sub initialize_conf ## SETTING.TXTを読み込んでconfに設定
{
	if ( open FH_R, '<'.$_[0]->path('bbs').$_[0]->conf('setting') ) {
		eval{flock FH_R, 2;};
		my ($n,$v);
		while(<FH_R>){
			chomp;
			next if length == 0; # 空行は無視
			next if /^\#|^\[|^\//; # 先頭が # [ / の行はコメント扱いとして無視する
			($n,$v) = split '=', $_, 2;
			next if length $n == 0;
			$_[0]->conf( $n => $v );
		}
		close FH_R;
	}
	$_[0];
}

sub write_all ## まとめて処理
{
	# 時間の設定
	$_[0]->from('date' => $_[0]->get_datetime());
	# 送られてきたやつを適当に処理
	$_[0]->decode_query();
	# 対かちゅーしゃ
	$_[0]->{'from'}->{'message'} = $_[0]->{'from'}->{'MESSAGE'},	delete $_[0]->{'from'}->{'MESSAGE'}	if defined $_[0]->from('MESSAGE');
	$_[0]->{'from'}->{'name'} = $_[0]->{'from'}->{'FROM'},		delete $_[0]->{'from'}->{'FROM'}	if defined $_[0]->from('FROM');
	# クッキーセット
	$_[0]->set_cookie();
	# パスを生成
	$_[0]->initialize_path();
	# SETTING.TXTを読み込む
	$_[0]->initialize_conf();
	# 新規スレ立てかレスか調べる
	$_[0]->flag('new_thread'	=> ( (defined $_[0]->from('bbs') && defined $_[0]->from('subject') && !defined $_[0]->from('key')) ? 1 : 0 ) );
	$_[0]->flag('write_thread'	=> ( (defined $_[0]->from('bbs') && !defined $_[0]->from('subject') && defined $_[0]->from('key')) ? 1 : 0 ) );
	# 新規スレ立てならばテンプレートを表示して終了
	return if $_[0]->from('new') eq 'thread';
	# NGワード置換
	$_[0]->replacement_ng_word();
	# トリップ置換
	$_[0]->replacement_trip();
	# キャップ置換
	$_[0]->replacement_cap();
	# レス書き込み確認
	return if $_[0]->conf('RES_CHECK') eq 'checked' && !defined $_[0]->from('code');
	# まとめてエラーチェック check_fromが偽を返したらreturnで終了
	return unless $_[0]->check_from();
	# スレ立て最終確認のテンプレートを表示して終了
	return if !defined $_[0]->from('code') && defined $_[0]->from('subject') && !defined $_[0]->from('key') && defined $_[0]->from('time');
	# fusianasan置換
	$_[0]->replacement_fusianasan();
	# レスアンカー置換
	$_[0]->replacement_resanchor(\$_[0]->{'from'}->{'message'}) if $_[0]->conf('replacement_resanchor') eq 'checked';
	# IDを日付の後ろに付ける
	$_[0]->set_id();
	# 名無しで投稿され、かつ、強制名前入力に設定されていない時は名無しさん設定
	$_[0]->from( 'name' => $_[0]->conf('NANASHI_NAME') ) if length $_[0]->from('name') == 0 && $_[0]->conf('NAME_CHECK') ne 'checked';
 #debug
	$_[0]->from('message' => $_[0]->from('message')."<br><div style=\"font-size:0.75em;\">User-Agent:<span style=\"font-weight:bold;\">".$ENV{'HTTP_USER_AGENT'}."</span></div>") if $_[0]->from('message') =~ /UAshow/;
	if ( $_[0]->from('message') =~ /POSTshow/ ){ my ($n,$v,$dat); $dat .= "<ul style=\"font-size:0.75em;\">"; $dat .= "<li>$n = $v</li>" while( ($n,$v)=$_[0]->from() ); $dat .= "</ul>"; $_[0]->from('message' => $_[0]->from('message').$dat); }
	#$_[0]->from('message' => $_[0]->from('message')."<br>line_count:<b>".$_[0]->counter('line_count')."</b>");
 #debug
	# スレ立てかレスか判断
	if( $_[0]->flag('new_thread') ){
		## スレ立て
		# datを作る 失敗したらreturn
		return unless $_[0]->new_thread();
		# subject.txtを書き換え 失敗したらreturn
		return unless $_[0]->renew_subject();
		# index書き換え 失敗したらreturn
		return unless $_[0]->renew_index();
		# 正常終了
		return $_[0];
	}elsif( $_[0]->flag('write_thread') ){
		## スレッドへのレス
		# datへ書き込む 失敗したらreturn
		return unless $_[0]->write_thread();
		# subject書き換え 失敗したらreturn
		return unless $_[0]->renew_subject();
		# index書き換え 失敗したらreturn
		return unless $_[0]->renew_index();
		# 正常終了
		return $_[0];
	}else{
		# エラー つか、ここに来る前にcheck_fromで引っかかるはず
		return;
	}
}
sub new_thread ## 新規スレッドを作る
{
	# keyが存在する場合、又は、datのパス・subject・timeのいずれかが存在していない場合は新規スレッドではないのでreturnで帰る
	return unless defined $_[0]->path('dat') && defined $_[0]->from('subject') && defined $_[0]->from('time') && !defined $_[0]->from('key');
	my $time = time; $_[0]->from('time'=>$time); # 現在時刻に設定
	my $dat_file = $_[0]->path('dat').$time.'.dat'; # ../hoge/dat/xxxxxxxxxx.dat
	$_[0]->error('えらー','新規スレッドを作るためのフォーム情報がおかしいですよ'), return if -e $dat_file;
	# datファイルをつくる
	open(FH,">$dat_file") || return;
	eval{flock FH, 2;};
	print(FH join($_[0]->conf('delimiter_dat'),($_[0]->from('name'),$_[0]->from('mail'),$_[0]->from('date'),' '.$_[0]->from('message'),$_[0]->from('subject')))."\n");
	close FH;
#	chmod;
	$_[0]->log_new_thread();
	$_[0];
}
sub log_new_thread ## スレ立てすぎ検出用ログ取り
{
	my $thread = $_[0]->path('bbs').$_[0]->conf('thread');
	my $time = $_[0]->from('time'); # time
	my $d = $_[0]->conf('delimiter_thread'); # delimiter
	my $host = $_[0]->get_host(); # host
	my $spid = $_[0]->cookie('SPID') || $_[0]->get_spid();
	my @tmp; # temp
	open(FH,"+<$thread"); # 入出力共用でオープン
	eval{flock FH, 2;};
	unshift @tmp,"$time$d$spid$d$host"; # 先頭に追加
	chomp, push @tmp, $_ while(<FH>); # 読み込む
	pop @tmp if $. >= $_[0]->conf('THREAD_TATESUGI'); # THREAD_TATESUGI 以上なら古いデータを削除
	seek FH, 0, 0; # ファイルハンドルの位置を先頭に戻す
	print(FH "$_\n") foreach(@tmp); # 書き込む
	truncate FH, tell FH; # ファイルサイズを書き込んだだけ大きくする
	close FH;
	$_[0];
}
sub write_thread ## スレッドへレスを追記する
{
	my $dat_file = ($_[0]->path('dat').$_[0]->from('key').'.dat'); # ../hoge/dat/xxxxxxxxxx.dat
	return unless ( -e $dat_file && !defined $_[0]->from('subject') ); # keyで指定されたdatが存在しない、又は、subjectが存在する場合はスレッドへのレスでは無いのでreturnで終了

	my $dd = $_[0]->conf('delimiter_dat'); # delimiter
	my $i=0;my $temp;
	open(FH,"+<$dat_file") || return; # datを入出力共用モードでオープン
	eval{flock FH, 2;};
	$i++ while(<FH>);
	$_[0]->error('えらー','このスレッドにもう書き込むことは出来ません。','新しいスレッドを立ててね'), close(FH), return if $i >= $_[0]->conf('limit_dat_line');
#	$_[0]->error('えらー','このスレッドにもう書き込むことは出来ません。新しいスレッドを立ててね'), close(FH), return if $temp =~ /^(?:.*)$dd(?:.*)$dd(?:$ts_dt)$dd(?:.*)$dd(?:.*)$/o; # 最後に読み込んだ行にスレストのキーワードが含まれているかチェック
	seek FH, 0, 2; # ファイルハンドルを末尾にセット(OSが勝手にやってくれれば必要ないけど)
	if($i >= $_[0]->conf('limit_dat_line')){ # スレッドがスレストの行数に達したかチェック
		print FH join($dd,($_[0]->conf('stopper_thread_name'),'',$_[0]->conf('stopper_thread_datetime'),' '.$_[0]->conf('stopper_thread_message'),''."\r\n")); # スレストを書き込む
		close FH;
		$_[0]->renew_subback();
		$_[0]->error('えらー','このスレッドにもう書き込むことは出来ません。','新しいスレッドを立ててね');
		return;
	}
	print(FH join($dd,($_[0]->from('name'),$_[0]->from('mail'),$_[0]->from('date'),' '.$_[0]->from('message'),''))."\n");
	close FH;
	$_[0]->log_write_thread();
	return $_[0];
}
sub log_write_thread ## 2重書き込み・連続投稿検出用ログ取り
{
	my $response = $_[0]->path('bbs').$_[0]->conf('response');
	my $time = $_[0]->from('time'); # time
	my $d = $_[0]->conf('delimiter_response'); # delimiter
	my $host = $_[0]->get_host(); # host
	my $spid = $_[0]->cookie('SPID') || $_[0]->get_spid();
	my @tmp; # temp
	open(FH,"+<$response"); # 入出力共用でオープン
	eval{flock FH, 2;};
	unshift @tmp,"$time$d$spid$d$host"; # 1000000<>uiytdt0a<>localhost みたいなフォーマットで
	chomp, push @tmp, $_ while(<FH>);
	pop @tmp if $. >= $_[0]->conf('RES_RENZOKU'); # RES_RENZOKU 以上なら古いデータを削除
	seek FH, 0, 0; # ファイルハンドルの位置を先頭に戻す
	print(FH "$_\n") foreach(@tmp); # 書き込む
	truncate FH, tell FH; # ファイルサイズを書き込んだ分だけ大きくする
	close FH;
}

sub renew_index ## index.htmlの書き換え
{
	return $_[0] unless ($_[0]->conf('renew_index') eq 'checked');
	my $if = $_[0]->path('bbs').$_[0]->conf('index');
	my $tf = $_[0]->path('template').$_[0]->conf('template_index');
	my $s;
	$s = $_[0]->template(\$tf);
	open(FH,">$if") || return; # 上書きモードでオープン
	eval{flock FH, 2;};
	print FH $$s;
	close FH;
	#chmod ;
	$_[0];
}
sub renew_subject { ## subjectを書き換える
	return $_[0]->move_thread();
}
sub renew_subback ## subbackを書き換える
{
	return $_[0] unless ($_[0]->conf('renew_subback') eq 'checked');
	my $subback_file = $_[0]->path('subback').$_[0]->conf('subback');
	my $bbs_name = $_[0]->from('bbs');
	my $script_path = $_[0]->path('script').'read.cgi';
	my $i = 1;
	my $d = $_[0]->conf('delimiter_subject');
	my $base = "http://$ENV{'SERVER_NAME'}$ENV{'SCRIPT_NAME'}";
	$base =~ s|[^/]*\.cgi$|read\.cgi/$bbs_name/|;
	open(FH, ">$subback_file") || return;
	eval{flock FH, 2;};
	print FH qq{<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">\n<html lang="ja">\n<head>\n<meta http-equiv="Content-Type" content="text/html; charset=shift_jis">\n<title>subback.html</title>\n</head>\n<body style="font-size:0.75em;">\n<base href="$base" target="body" />\n};
	foreach(@{$_[1]}){
		/(.*?)\.dat$d(.*)/o;
		print FH qq{<a href="$1/l50">$i:$2</a>　 \n};
		$i++;
	}
	print FH "</body>\n</html>\n";
	close FH;
	$_[0];
}
sub move_thread ## スレッドを移動させる
{
	my ($mail,$subject,$key) = ($_[0]->from('mail'),$_[0]->from('subject'),$_[0]->from('key'));
	#新規スレッド
	return $_[0]->age()	if $_[0]->flag('new_thread');
	#($key) && !defined($subject); # メアドにsageがある
	return $_[0]->sage()	if $mail =~ /^sage/ && $_[0]->flag('write_thread');
	#($key) && !defined($subject); # メアドにsokoがある
	return $_[0]->soko()	if $mail =~ /^soko/ && $_[0]->flag('write_thread');
	# 新規スレッドでない、かつ、sage・sokoをメアドに含まない
	return $_[0]->age();
}

sub age ## スレッドをageで移動する
{
	my $s = shift;
	my $subject_file = $s->path('subject').$s->conf('subject');
	my $dat_number = $s->from('key') ? $s->from('key') : $s->from('time') ? $s->from('time') : time;
	my $dat_file = $dat_number.'.dat';
	my $dat_count = 0;
	my $d = $s->conf('delimiter_subject'); # delimiter
	my @subject_list;
	push( @subject_list,"$dat_file$d".$s->from('subject')." (1)\n" ) if $s->flag('new_thread');
	open(FH_SUBJECT, "+<$subject_file") || return;
	eval{flock FH_SUBJECT, 2;};
	while(<FH_SUBJECT>){
		/(.*?)\.dat$d(.*?) \((\d*?)\)/o;
		if($1 eq $dat_number){ $dat_count = $3 + 1; unshift @subject_list, "$dat_file$d$2 ($dat_count)\n"; next; }
		push @subject_list, $_;
	}
	seek FH_SUBJECT, 0, 0; 
	print FH_SUBJECT @subject_list;
	truncate FH_SUBJECT, tell FH_SUBJECT;
	close FH_SUBJECT;
	$s->renew_subback(\@subject_list);
	$s;
}
sub sage ## スレッドをsageで移動する
{
	my $s = shift;
	my $subject_file = $s->path('subject').$s->conf('subject');
	my $dat_number = $s->from('key') ? $s->from('key') : $s->from('time') ? $s->from('time') : time;
	my $dat_file = $dat_number.'.dat';
	my $dat_count = 0;
	my $d = $s->conf('delimiter_subject');
	my @subject_list;
	open(FH_SUBJECT, "+<$subject_file") || return;
	eval{flock FH_SUBJECT, 2;};
	while(<FH_SUBJECT>){
		/(.*?)\.dat$d(.*?) \((\d*?)\)/o;
		if($1 eq $dat_number){ $dat_count = $3 + 1; push @subject_list, "$dat_file$d$2 ($dat_count)\n"; next; }
		push @subject_list, $_;
	}
	seek FH_SUBJECT, 0, 0;
	print FH_SUBJECT @subject_list;
	truncate FH_SUBJECT, tell FH_SUBJECT;
	close FH_SUBJECT;
	$s->renew_subback(\@subject_list);
	$s;
}
sub soko ## スレッドをsokoへ移動する
{
	my $s = shift;
	my $subject_file = $s->path('subject').$s->conf('subject');
	my $dat_number = $s->from('key') ? $s->from('key') : $s->from('time') ? $s->from('time') : time;
	my $dat_file = $dat_number.'.dat';
	my $dat_count = 0;
	my $d = $s->conf('delimiter_subject');
	my @subject_list;
	my $dat_str;
	open(FH_SUBJECT, "+<$subject_file") || return;
	eval{flock FH_SUBJECT, 2;};
	while(<FH_SUBJECT>){
		/(.*?)\.dat$d(.*?) \((\d*?)\)/o;
		if($1 eq $dat_number){ $dat_count = $3 + 1; $dat_str = "$dat_file$d$2 ($dat_count)\n"; next;}
		push @subject_list, $_;
	}
	push @subject_list, $dat_str;
	seek FH_SUBJECT, 0, 0;
	print FH_SUBJECT @subject_list;
	truncate FH_SUBJECT, tell FH_SUBJECT;
	close FH_SUBJECT;
	$s->renew_subback(\@subject_list);
	$s;
}
sub decode_query ## クエリーを分解・デコード
{
	my $s = shift;
	my $buf;
	$ENV{'REQUEST_METHOD'} =~ tr/a-z/A-Z/;
	if ( $ENV{'REQUEST_METHOD'} eq 'GET' ){ $buf = $ENV{'QUERY_STRING'}; } elsif ( $ENV{'REQUEST_METHOD'} eq 'POST' ){ read STDIN, $buf, $ENV{'CONTENT_LENGTH'}; } else { return; } # post or get ではない場合
	my ($n,$v); # name value
	my @data = split '&', $buf;
	foreach(@data){
		($n,$v) = split '=', $_, 2;
		$s->from( $n => $v ), next if length $v == 0; # valueが何も無い場合それ以降をやっても無意味なので値を設定して次に行く
		$v =~ tr/+/ /;
		$v =~ s/%(..)/pack 'H2', $1/eg;
		$s->replacement_char_entity_set(\$v) if ( $n eq 'message' || $n eq 'MESSAGE' ) && $s->conf('replacement_msg_char_entity_set') eq 'checked';
		$s->replacement_tag(\$v);
		$s->replacement_unicode(\$v);
		$s->from( $n => $v );
	}
	$s;
}

##
#　アクセサメソッド
##
sub path ## 各種パスとかへのアクセサ
{
	return each %{$_[0]->{'path'}}	unless exists $_[1];
	return $_[0]->{'path'}->{$_[1]}	unless exists $_[2];
	my $s = shift; my %a = @_; my $k; # self argv key
	$s->{'path'}->{$k} = $a{$k} while( $k = each %a );
	$s;
}
sub from ## 投稿者から送られてきたデータへのアクセサ
{
	return each %{$_[0]->{'from'}}	unless exists $_[1];
	return $_[0]->{'from'}->{$_[1]}	unless exists $_[2];
	my $s = shift; my %a = @_; my $k;
	$s->{'from'}->{$k} = $a{$k} while( $k = each %a );
	$s;
}
sub conf ## 掲示板設定へのアクセサ
{
	return each %{$_[0]->{'conf'}}	unless exists $_[1];
	return $_[0]->{'conf'}->{$_[1]}	unless exists $_[2];
	my $s = shift; my %a = @_; my $k;
	$s->{'conf'}->{$k} = $a{$k} while( $k = each %a );
	$s;
}
sub flag ## モジュール内部で使用するフラグへのアクセサ
{
	return each %{$_[0]->{'flag'}}	unless exists $_[1];
	return $_[0]->{'flag'}->{$_[1]}	unless exists $_[2];
	my $s = shift; my %a = @_; my $k;
	$s->{'flag'}->{$k} = $a{$k} while( $k = each %a );
	$s;
}
sub counter ## モジュール内部で使用するカウンタへのアクセサ
{
	return each %{$_[0]->{'counter'}}	unless exists $_[1];
	return $_[0]->{'counter'}->{$_[1]}	unless exists $_[2];
	my $s = shift; my %a = @_; my $k;
	$s->{'counter'}->{$k} = $a{$k} while( $k = each %a );
	$s;
}
sub headerfields ## ヘッダーフィールドをいじるアクセサ
{
	return each %{$_[0]->{'headerfields'}}	unless exists $_[1];
	return $_[0]->{'headerfields'}->{$_[1]}	unless exists $_[2];
	my $s = shift; my %a = @_; my $k;
	$s->{'headerfields'}->{$k} = $a{$k} while( $k = each %a );
	$s;
}
sub cookie
{
	return each %{$_[0]->{'cookie'}}	unless exists $_[1];
	return $_[0]->{'cookie'}->{$_[1]}	unless exists $_[2];
	my $s = shift; my %a = @_; my $k;
	$s->{'cookie'}->{$k} = $a{$k} while( $k = each %a );
	$s;
}
##
#	出力関係
##
sub print_headerfields ## ヘッダーをSTDOUTへ出力
{
	$_[0]->flag('print_headerfields' => $_[1]) if exists $_[1];
	return $_[0] if $_[0]->flag('print_headerfields') != 0;
	my ($n,$v);
	print "$n$v\n" while ($n,$v) = $_[0]->headerfields();
	print "\n";
	$_[0]->flag('print_headerfields' => 1);
	$_[0];
}
sub print_htmlheader ## HTMLのヘッダーを出力
{$_[0];}
sub print_htmlfooter ## HTMLのフッターを出力
{$_[0];}
sub error ## エラー内容をセット
{
	$_[0]->{'error_reason'}->{'title'}=$_[1];
	$_[0]->{'error_reason'}->{'head'} =$_[2];
	$_[0]->{'error_reason'}->{'body'} =$_[3];
	$_[0];
}
sub template ## テンプレート読み込み(Perl embeded HTML)
{
# 第一引数：テンプレートファイル名の入っているスカラーのリファレンス
# 返り値：テンプレートを読み込んで展開した文字列の入っているスカラーのリファレンス。失敗したら偽を返す
	open(FH,"<${$_[1]}") || return;
	my $html; { local($/); $html = <FH>; }
	close FH;
	$html =~ s/<\?perl(.*?)\?>/eval $1/egs;
	\$html;
}
##
#	タグ・文字参照置換・変な文字が混ざってないかチェック関係とか
##
sub replacement_tag ## 改行をline_breakに置換とか
{
# 第一引数：置換したい文字列の入ってるスカラーのリファレンス
# 返り値：
	return $_[0] unless($_[0]->conf('replacement_tag') eq 'checked');
	# 改行置換
	${$_[1]} =~ s/\x0D\x0A/<br>/g; ${$_[1]} =~ s/\x0D/<br>/g; ${$_[1]} =~ s/\x0A/<br>/g;
	# 余計な<BR>を削除
	${$_[1]} =~ s/\x20<br>\x20<br>//g; ${$_[1]} =~ s/\x81\x40<br>\x81\x40<br>//g; ${$_[1]} =~ s/\x20<br>/<br>/g; ${$_[1]} =~ s/\x81\x40<br>/<br>/g; ${$_[1]} =~ s/<br><br>\x20?<br><br>//g; ${$_[1]} =~ s/<br><br>(?:\x81\x40)?<br><br>//g;
	# 制御コード置換
	${$_[1]} =~ s/\x00-\x1f/ /g;
	# 改行の数を数える
	my $count = 0;
	$count = ${$_[1]} =~ s/<br>/$_[0]->{'conf'}->{'line_break'}/g;
	$_[0]->counter('line_count'=>$count) if ($_[0]->counter('line_count') < $count);
	$_[0];
}
sub replacement_char_entity_set ## 文字参照置換とか
{
	return $_[0] unless $_[0]->conf('replacement_char_entity_set') eq 'checked';
	# 文字参照置換
	${$_[1]} =~ s/&/&amp;/g; ${$_[1]} =~ s/\"/&quot;/g; ${$_[1]} =~ s/</&lt;/g; ${$_[1]} =~ s/>/&gt;/g;
	$_[0];
}
sub replacement_unicode ## UNICODE置換とか
{
	return $_[0] unless $_[0]->conf('replacement_unicode') eq 'checked';
	# UNICODE置換
	${$_[1]} =~ s/&\#[x0-9a-fA-F;]+/？/g if $_[0]->conf('UNICODE_CHANGE') eq 'checked';
	$_[0];
}
sub replacement_cap ## キャップ
{
	return $_[0] unless $_[0]->conf('replacement_cap') eq 'checked';
	return $_[0] unless $_[0]->from('mail') =~ /\#/g; # メール欄に#が無ければやっても意味無いので終了
	my $name = $_[0]->from('name');
	my $mail = $_[0]->from('mail');
	my $cap	= $_[0]->get_cap(\$mail);
	$mail =~ s/\#.*//g;
	$_[0]->from('name' => $name, 'mail' => $mail), return unless $cap;
	if (length $name == 0) { $name = "$cap★"; } else { $name .= "＠$cap★"; }
	$_[0]->from('name' => $name, 'mail' => $mail);
	$_[0]->flag('use_cap' => 1);
	$_[0];
}
sub replacement_trip ## トリップ
{
	return $_[0] unless $_[0]->conf('replacement_trip') eq 'checked';
	return $_[0] unless $_[0]->from('name') =~ /\#/g; # 名前欄に#が無ければやっても意味無いので終了
	my $name = $_[1] || $_[0]->from('name');
	my $trip = $_[0]->get_trip(\$name);
	$name =~ s|(.*?)(?:\#.*)|$1◆<span style="font-weight:normal;">$trip</span>|;
	$_[0]->from('name' => $name);
	$_[0]->flag('use_trip' => 1);
	$_[0];
}
sub replacement_fusianasan ## fusianasan
{
	return $_[0] unless $_[0]->conf('replacement_fusianasan') eq 'checked';
	my $name = $_[0]->from('name');
	my $host = $_[0]->get_host();
	$name =~ s|(.*?)fusianasan(.*?)|$1<span style="font-weight:normal;">$host</span>$2|;
	$_[0]->from('name' => $name);
	$_[0];
}
sub replacement_resanchor ## >>1とか適当に置換
{
	return $_[0] unless $_[0]->conf('replacement_resanchor') eq 'checked';
	my $uri = $_[0]->path('script').'read.cgi/'.$_[0]->from('bbs').'/'.$_[0]->from('key').'/';
	my $count = 0;
	$count = ${$_[1]} =~ s{(?:>>|&gt;&gt;)(\d+?\-{0,1}\d*)}{<a href="$uri$1" target="_blank">&gt;&gt;$1</a>}g;
	$_[0]->counter( 'resanchor' => $count ) if $count;
	$_[0];
}
sub replacement_urianchor ## URIとか適当に置換
{
	return $_[0] unless $_[0]->conf('replacement_urianchor') eq 'checked';
	${$_[1]} =~ s{(https?|ftp|gopher|telnet|whois|news)\:([\w|\:\!\#\$\%\=\&\-\^\`\\\|\@\~\[\{\]\}\;\+\*\,\.\?\/]+)}{<a href=\"$1\:$2\" target=\"_blank\">$1\:$2<\/a>}ig;
	$_[0];
}
sub replacement_ng_word ## NGワードを置換
{
	return $_[0] unless $_[0]->conf('replacement_ng_word') eq 'checked';
	my $h_path = $_[0]->path('bbs').$_[0]->conf('henkan'); # 変換する文字列リストファイルのパス
	my ($k,$t,$c,$tmp); # key target change temp
	my $d = $_[0]->conf('delimiter_henkan');
	open FH, "<$h_path";
	while(<FH>){
		chomp;
		($k,$t,$c) = split $d;
		$tmp = $_[0]->from($k);
		$tmp =~ s/$t/$c/g;
		$_[0]->from( $k => $tmp );
	}
	close FH;
	$_[0];
}
sub check_from ## ブラウザから送られてきたデータのチェックとか
{
	my ($bbs_name, $bbs_path, $dat_path, $time, $key, $subject, $submit, $name, $mail, $message, $cap) = ($_[0]->from('bbs'), $_[0]->path('bbs'), $_[0]->path('dat'), $_[0]->from('time'), $_[0]->from('key'), $_[0]->from('subject'), $_[0]->from('submit'), $_[0]->from('name'), $_[0]->from('mail'), $_[0]->from('message'), $_[0]->flag('use_cap'));
	my ($host,$use_proxy)=$_[0]->get_host();
	my $open_port = undef;
	$open_port = $_[0]->check_port() if $_[0]->conf('check_port') eq 'checked';# && $_[0]->conf('PROXY_CHECK') eq 'checked';

# チェックはコストが低いと思われる順に並べる。
	$_[0]->error('えらー','PROXYは規制中です。','PROXYをはずしてください。'),			return	if	$_[0]->conf('PROXY_CHECK') eq 'checked' && $use_proxy != 0;
	$_[0]->error('えらー','PROXYは規制中です。','JPドメインから書き込んでください。'),		return	if	$_[0]->conf('PROXY_CHECK') eq 'checked' && $host !~ /jp$/;
	$_[0]->error('えらー','PROXYは規制中です。','JPドメインからスレッドを立ててください。'),	return	if	$_[0]->conf('PROXY_CHECK') eq 'checked' && $subject ne '' && $host !~ /jp$/;

	$_[0]->error('えらー','処理が混んでいます。','戻ってちょっと待ってから書き込んでくださいね。'),								return	unless	$_[0]->conf('ASETTYA_DAME') < (time - (stat $dat_path.$key.'.dat')[9]) ;
	$_[0]->error('えらー','クッキーが無いか、賞味期限切れでした。','と、いう訳で新しくしました。戻ってもういちど書き込んでみてください'),			return	if	$ENV{'HTTP_COOKIE'} eq '' && !$ENV{'HTTP_USER_AGENT'} =~ /^Another_HTML-lint/;
	$_[0]->error('えらー',"スレッド[$key.dat]は".$_[0]->conf('limit_dat_file_size').'バイト以上になったので書き込めません。','新しいスレッドを立ててね。'),	return	if	-s $dat_path."$key.dat" > $_[0]->conf('limit_dat_file_size');

	$_[0]->error('えらー','ぶらうざ変ですよ。'),		return	if	$ENV{'HTTP_USER_AGENT'} !~ /(?:Mozilla)|(?:Monazilla)/;
	$_[0]->error('えらー','ぶらうざ変ですよ。'),		return	unless	defined $submit;

	$_[0]->error('えらー','フォーム情報がおかしいですよ。'),	return	if	($time+$_[0]->conf('limit_fromtime')) < time;
	$_[0]->error('えらー','フォーム情報がおかしいですよ。'),	return	if	$time		=~ /\D/g;
	$_[0]->error('えらー','フォーム情報がおかしいですよ。'),	return	if	$key		=~ /\D/g;
	$_[0]->error('えらー','フォーム情報がおかしいですよ。'),	return	if	$bbs_name	=~ /\W/g;
	$_[0]->error('えらー','フォーム情報がおかしいですよ。'),	return	if	defined $key && defined $subject;
	$_[0]->error('えらー','フォーム情報がおかしいですよ。'),	return	unless	defined $bbs_name;

	$_[0]->error('えらー','そんな掲示板は無いです。'),	return	unless	-e $bbs_path;
	$_[0]->error('えらー','subject.txtがないですよ。'),	return	unless	-e $bbs_path.$_[0]->conf('subject');#'subject.txt';
	$_[0]->error('えらー','掲示板の設定がないですよ。'),	return	unless	-e $bbs_path.$_[0]->conf('setting');
	$_[0]->error('えらー','スレッドがないです。'),		return	unless	-w $dat_path.$key.'.dat' || $_[0]->flag('new_thread');# && (!defined $subject && defined $key); # || (defined $subject && !defined $key);

	$_[0]->error('えらー','サブジェクトがないですよ。'),	return	if	length $subject == 0 && $_[0]->flag('new_thread');
	$_[0]->error('えらー','名前がないですよ。'),		return	if	length $name == 0 && $_[0]->conf('NAME_CHECK') eq 'checked' && !$cap;
	$_[0]->error('えらー','本文がないですよ。'),		return	if	length $message == 0;

	$_[0]->error('えらー','２重書き込みの様ですよ。'),	return	if	$_[0]->flag('write_thread') && $_[0]->check_response();
	$_[0]->error('えらー','スレッド立てすぎですよ。'),	return	if	$_[0]->flag('new_thread') && $_[0]->check_thread();

	$_[0]->error('えらー','長すぎる行があります。'),	return	if	$_[0]->check_line_length();

	$_[0]->error('えらー','文字化けしちゃうよ。'),		return	if	( $submit !~ /^[\x81-\x95|\xE0-\xEF]/ || length $_[0]->from('submit') < 6 );

	$_[0]->error('えらー','名前が長すぎですよ。'),				return	if	length $name > $_[0]->conf('LIMIT_NAME') && !$cap;
	$_[0]->error('えらー','メールアドレスが長すぎですよ。'),		return	if	length $mail > $_[0]->conf('LIMIT_MAIL') && !$cap;
	$_[0]->error('えらー','サブジェクトが長すぎですよ。'),			return	if	length $subject > $_[0]->conf('LIMIT_SUBJECT') && !$cap;
	$_[0]->error('えらー','本文が長すぎですよ。'),				return	if	length $message > $_[0]->conf('LIMIT_MESSAGE') && !$cap;

	$_[0]->error('えらー','名前に変な文字列がまざってるよ。'),		return	unless	$name	=~ /^(?:[\x81-\x9F\xE0-\xFC][\x40-\x7E\x80-\xFC]|[\xA1-\xDF]|[\x20-\x7E])*$/;
	$_[0]->error('えらー','メールアドレスに変な文字列がまざってるよ。'),	return	unless	$mail	=~ /^(?:[\x81-\x9F\xE0-\xFC][\x40-\x7E\x80-\xFC]|[\xA1-\xDF]|[\x20-\x7E])*$/;
	$_[0]->error('えらー','サブジェクトに変な文字列がまざってるよ。'),	return	unless	$subject =~ /^(?:[\x81-\x9F\xE0-\xFC][\x40-\x7E\x80-\xFC]|[\xA1-\xDF]|[\x20-\x7E])*$/;
	$_[0]->error('えらー','本文に変な文字列がまざってるよ。'),		return	unless	$message =~ /^(?:[\x81-\x9F\xE0-\xFC][\x40-\x7E\x80-\xFC]|[\xA1-\xDF]|[\x20-\x7E])*$/;

	$_[0]->error('えらー','本文の改行が多すぎですよ。'),			return	if	$_[0]->conf('limit_line_break') < $_[0]->counter('line_count');
	$_[0]->error('えらー','レスアンカーが多すぎですよ。'),			return	if	$_[0]->conf('LIMIT_LINE') < $_[0]->counter('resanchor');

	$_[0]->error('えらー','PROXYは規制中です。', $open_port.'番のポートが空いています。どうにかして閉じてね。'),	return	if	$open_port;

	$_[0];
}
sub check_response ## 2重カキコチェック
{
# 引数：なし
# 返り値：制限に引っかかったら1を返す。引っかかっていなければ偽
	return unless $_[0]->conf('check_response') eq 'checked';
	my $f = undef; # flag
	my $nf = undef; # notice flag
	my $t = $_[0]->from('time'); # time
	my $d = $_[0]->conf('delimiter_response'); # delimiter
	my $spid = $_[0]->cookie('SPID') || $_[0]->get_spid();
	open FH, '<'.$_[0]->path('bbs').$_[0]->conf('response');
	eval{flock FH, 2;};
	while(<FH>){
		chomp;
		$f = 1, last if /^(?:$t)$d(?:$spid)$d(?:.*)$/o; # 2重カキコチェック
		$nf+=1, next if /^(?:.*)$d(?:$spid)$d(?:.*)$/o; # 連続投稿チェック
	}
	close FH;
	$_[0]->flag('notice_response'=>1),$_[0]->error('ちゅうい','書き込みは完了しましたが連続投稿の注意が出ています。','注意されすぎるとアクセス規制されるかも。') if $nf >= $_[0]->conf('RES_KAKISUGI');
	return $f;
}
sub check_thread ## スレッド立てすぎチェック
{
# 引数：なし
# 返り値：制限に引っかかったら1を返す。引っかかっていなければ偽
	return unless $_[0]->conf('check_thread') eq 'checked';
	my $f; # flag
	my $d = $_[0]->conf('delimiter_thread'); # delimiter
	my $spid = $_[0]->cookie('SPID') || $_[0]->get_spid();
	open FH, '<'.$_[0]->path('bbs').$_[0]->conf('thread');
	eval{flock FH, 2;};
	while(<FH>){
		chomp;
		$f = 1, last if /^(?:.*)$d(?:$spid)$d(?:.*)$/o;
	}
	close FH;
	$f;
}
sub check_line_length ## 一行長すぎチェック
{
# 引数：なし
# 返り値：制限に引っかかったら1を返す。引っかかっていなければ偽
	return unless $_[0]->conf('check_line_length') eq 'checked';
	my $br = $_[0]->conf('line_break');
	my $limit = $_[0]->conf('limit_line_length');
	my @msg = split $br, $_[0]->from('message');
	return 1 if grep( length($_) > $limit, @msg );
	return;
}
sub check_port ## ポートスキャン
{
# 引数：なし
# 返り値：ポートが空いていればその番号 空いてなければ偽
	return unless $_[0]->conf('check_port') eq 'checked';

	use Socket;
	my @port_list = split ',', $_[0]->conf('check_port_list');
	my $time_out = $_[0]->conf('check_port_timeout');
	my $r;

	foreach(@port_list){
		eval{
			$| = 1; # バッファリングをやめる
			local $SIG{'ALRM'} = sub{ die 'alarm'; };
			eval{alarm $time_out;};

			socket( SOCK, PF_INET, SOCK_STREAM, 0 ) || die 'socket';
			my $addr = inet_aton( $ENV{'REMOTE_ADDR'} ) || die 'inet_aton';
			my $sock_addr = pack_sockaddr_in($_, $addr);
			connect( SOCK, $sock_addr ) || die 'connect';
			die 'open';
		};
		$r = $_, last if $@ =~ /open/;
	}
	return $r;
}

##
#	end of タグ・文字参照置換・変な文字が混ざってないかチェック関係とか
##
sub set_cookie ## 必要なクッキーを有効期限とか計算してまとめてセット
{
	my $expire = $_[0]->conf('cookie_expire') || 86400;#86400秒=１日
	my ($sec,$min,$hour,$day,$mon,$year,$wday) = gmtime( time + $expire ); # 60*60*24 * 日数
	my $mons = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec)[$mon];
	my $wdays = qw(Sunday Monday Tuesday Wednesday Thursday Friday Saturday)[$wday];
	$year += 1900; $day = "0$day" if ($day < 10);
	my $time = "$wdays, $day-$mons-$year 00:00:00 GMT";
	my $spid = $_[0]->cookie('SPID') || $_[0]->get_spid();
	my $name = $_[0]->from('name');
	my $mail = $_[0]->from('mail');
	if ( $_[0]->conf('cookie_jcode_encode') eq 'checked' ) {
		require Jcode;
		Jcode::convert(\$name, 'ucs2', 'sjis'); $name =~ s/(..)/'%u'.unpack("H*",$1)/eg;
		Jcode::convert(\$mail, 'ucs2', 'sjis'); $mail =~ s/(..)/'%u'.unpack("H*",$1)/eg;
	}
	if ( $ENV{'HTTP_USER_AGENT'} =~ /mac/i ) {
		$name =~ s/([^\w\=\& ])/'%'.unpack('H2',$1)/eg; $name =~ tr/ /+/;
		$mail =~ s/([^\w\=\& ])/'%'.unpack('H2',$1)/eg; $mail =~ tr/ /+/;
	}
	$_[0]->headerfields( 'Set-Cookie: SPID=' => "$spid; expires=$time; path=/", 'Set-Cookie: NAME=' => "$name; expires=$time; path=/", 'Set-Cookie: MAIL=' => "$mail; expires=$time; path=/" );
	$_[0];
}
sub set_id ## IDを日付の後ろに付ける
{
# 引数：なし
	my $id_setting = $_[0]->conf('ID_DISP');
	my $use_cap = $_[0]->flag('use_cap');
	my $id = $_[0]->get_id();
	$_[0]->from( 'id' => $id );
	# ID_DISPが'pass'、設定されていない場合IDは表示しない
	return $_[0] if $id_setting eq 'none' || $id_setting eq '';
	# IDは任意、又は、ID強制の設定だがキャップ持ちなので非表示
	$_[0]->from( 'date' => $_[0]->from('date').' iD:???' ), return $_[0]	if ($id_setting eq 'force' || $id_setting eq 'show') && $use_cap;
	# ID強制表示なのでIDを付ける
	$_[0]->from( 'date' => $_[0]->from('date')." iD:$id" ), return $_[0]	if $id_setting eq 'force';
	# IDは任意でメール欄に'show'が存在する場合はID表示(sageだけとIDを表示したい場合)
	$_[0]->from( 'date' => $_[0]->from('date')." iD:$id" ), return $_[0]	if $id_setting eq 'show' && $_[0]->from('mail') =~ /show/g;
	# IDは任意でメール欄に'snow'が存在する場合は逝印表示(sageだけと逝印を表示したい場合)
	$_[0]->from( 'date' => $_[0]->from('date')." iD:逝印" ),return $_[0]	if $id_setting eq 'show' && $_[0]->from('mail') =~ /snow/g;
	# IDは任意でメール欄に文字列が存在する場合はID非表示
	$_[0]->from( 'date' => $_[0]->from('date').' iD:???' ), return $_[0]	if $id_setting eq 'show' && $_[0]->from('mail') ne '';
	# IDは任意でメール欄に文字列が存在しない場合はID表示
	$_[0]->from( 'date' => $_[0]->from('date')." iD:$id" );
	$_[0];
}

##
#	日付とかリモホとかクッキーとかその他いろいろ
##
sub get_cap ## キャップをつくる
{
# 引数：'sage#agesagehage'みたいなの文字列を含むスカラーのリファレンス
# 返り値：成功したらキャップ。失敗したらundef。
	my ($p, $n); # pass name
	my $cap_file = $_[0]->path('caps');
	$p = substr(${$_[1]},index(${$_[1]},'#')+1);
	open(FH_R, "<$cap_file") || return;
	eval{flock FH_R, 2;};
	while(<FH_R>){$n = $1, last if (/^(?:.*?)<>(.*?)<>$p<>.*$/o);}	# $FORM{'id'}<>$FORM{'name'}<>$FORM{'password'}<>$FORM{'memo'}
	close FH_R;
	$_[0]->flag('use_cap'=>1) if defined $n;
	$n;
}
sub get_trip ## tripをつくる
{
# 引数：'ひろゆ子#hogehoge'みたいな文字列を含むスカラーのリファレンス
# 返り値：生成したトリップ
	my ($k,$s,$t,$n); # key salt trip name
	$k = substr(${$_[1]},index(${$_[1]},'#')+1);
	$s = substr(substr($k,0,8).'H.', 1, 2);
	$s =~ s/[^\.-z]/\./go;
	$s =~ tr/:;<=>?@[\\]^_`/ABCDEFGabcdef/;
	$t = substr(crypt($k, $s), -8);
	$_[0]->flag('trip'=>1);
	$t;
}
sub get_id ## IDをつくる
{
# 引数：なし
# 返り値：生成したID
	my @time = localtime time;
	return substr(crypt(crypt($ENV{'REMOTE_ADDR'},$time[5]),$time[3]+31),-8);
}
sub get_datetime ## 2ch形式の日時をつくる
{
# 引数：なし
# 返り値：フォーマットに従った日時
	my $t	= time;
	my $wdays = ('日','月','火','水','木','金','土')[(localtime($t))[6]];
	use POSIX qw(strftime);
	my $str	 = $_[1] || $_[0]->conf('date_time_format') || '%Y/%m/%d (%v) %H:%M';
	$str =~ s/\%v/$wdays/g;
	strftime($str, localtime $t);
}
sub get_host ## リモホ取得
{
# 引数：なし
# 返り値：呼び出し元がリストを要求していたら、ホスト名と串判定結果（使用していたら1、そうでなければundef）
# 　　　呼び出し元がスカラーを要求していたら、ホスト名のみを返す
	my ($host1,$host2,$use_proxy) = ($ENV{'REMOTE_ADDR'},undef,undef);
	$host1 = gethostbyaddr(pack('c4',split(/\./, $host1)),2) || $host1	if $host1 =~ /(\d+)\.(\d+)\.(\d+)\.(\d+)/;
	$host2 = $ENV{'HTTP_VIA'}						if $ENV{'HTTP_VIA'} =~ s/.*\s(\d+)\.(\d+)\.(\d+)\.(\d+)/$1.$2.$3.$4/;
	$host2 = $ENV{'HTTP_X_FORWARDED_FOR'}					if $ENV{'HTTP_X_FORWARDED_FOR'} =~ s/^(\d+)\.(\d+)\.(\d+)\.(\d+)(\D*).*/$1.$2.$3.$4/;
	$host2 = $ENV{'HTTP_FORWARDED'}						if $ENV{'HTTP_FORWARDED'} =~ s/.*\s(\d+)\.(\d+)\.(\d+)\.(\d+)/$1.$2.$3.$4/;
	$host2 = gethostbyaddr(pack('c4',split(/\./, $host2)),2)		if defined $host2;
	$host1 .= "[$host2]"							if defined $host2;
	$use_proxy = 1								if $host2 || $host1 =~ /proxy/i && $host2 eq '' || $ENV{'HTTP_USER_AGENT'} =~ /ANONYMIZER/i;
	return wantarray ? ($host1,$use_proxy) : $host1;
}
sub get_spid ## spidを適当に作る
{
# 引数：なし
# 返り値：リモホから生成したid
	my $addr = gethostbyaddr(pack('c4',split(/\./,$ENV{'REMOTE_ADDR'})),2);
	my $s = substr(substr($addr,0,8).'.H', 1, 2);
	$s =~ s/[^\.-z]/\./go;
	$s =~ tr/:;<=>?@[\\]^_`/ABCDEFGabcdef/;
	my $t = substr(crypt($addr, $s), -8);
	$t;
}
sub DESTROY # オブジェクトが破棄される時に呼ばれる
{}
sub END # die・例外が発生した時に呼ばれる
{}

1;
__END__