#!/usr/bin/perl

require 5.005;
#use strict;
#use vars qw(%Sys %FORM %REPLACE %COOK %SUB @LOGS @TEMPLATE);

;# ━…━━━…━━━…━━━…━━━…━━━…━━━…━━━…━━━…━
;#
;#		新・JawaNote
;;			$::version = '0.92b';
;#
;#		This script is free(Copyright(C) 1996-2003 CGI-StaTion 'Jawa')
;#											 http://www7.big.or.jp/~jawa/
;#
;# ━…━━━…━━━…━━━…━━━…━━━…━━━…━━━…━━━…━
;#
;#		● このスクリプトソースコードの改変・改造を認めます
;#		   (スクリプト規定参照)
;#
;#		● このスクリプトを用いたことによるいかなる損害に対しても
;#		作者は一切の責任を負いません
;#
;#		● 'ＧＡ：：ＪＣＯＤＥ'のみ(C)GandA-Lab.の著作物のため
;#		上記の限りではありません．この関数郡のみを使用したり，改変
;#		することはできません．
;#								  (C)GandA-Lab. http://www.ganda-lab.com/
;#
;#		● 書き換えにはPerlとCGIの知識が必要です．
;#		個人の責任で行って下さい(原則，サポート外となります)．
;#
;#		● 今回よりPerl5以降でのみ動作するように仕様変更しました．
;#		また，初心者でも設置できることに重点を置いたため改造しにくくなって
;#		しまいました．
;#
;#		● ソースは横100文字表示できるエディタで，タブ文字４文字にすると
;#		   多少は見やすくなると思います．
;#
;# ━…━━━…━━━…━━━…━━━…━━━…━━━…━━━…━━━…━
;#
;#		【 オ プ シ ョ ン 】
;#
;#		以下は，オプションの設定項目となります．
;#		ほとんどの場合は，書き換える必要はありません．
;#
;#	○ (オプション) CGIスクリプト名
;#		CGIスクリプト名は自動的に取得されますが，環境によって取得できない
;#		場合があります．
;#		ファイル名を変更したことで，上手く動作しない場合は，
;#		ここでCGIスクリプト名(このファイルの名前)を明記してください．
;#		jnote.cgi を必要に応じて書き換えてください．

$::cgi_name = 'jnote.cgi';

;#	○ (オプション) 記録用ディレクトリ
;#		デフォルトでは，このスクリプト本体と同一ディレクトリ(フォルダ)に
;#		指定されています．
;#		通常はこのままで問題ありません．
;#		もし，変更をされる場合は，以下の ./ を書き換えてください．
;#		なお，URLを記述するのではなく，パス表現で記述してください．
;#		パーミッションの設定もお忘れなく．

$::log_directory = './';

;#	○ (オプション) 日本語文字コードの変換
;#		このＣＧＩは日本語文字コードの変換機能を自前で実装しているので，
;#		日本語文字コード変換ライブラリを必要としません．
;#		しかし，日本語文字コードの変換に jcode.pl ライブラリを用いることが可能です．
;#		もし，jcode.pl がある場合は，そちらを優先して利用し，半角カナを全角カナ
;#		へ変換する機能が追加されます．
;#		どうしても利用したい場合は，以下のパスを jcode.pl のある場所に書き換えてください．
;#		(もしくは，jcode.pl をこのＣＧＩ本体と同じディレクトリ(フォルダ)に置いてください)

$::jcode_liblary = 'jcode.pl';

;#	○ (オプション) 画像強制出力の使用
;#		画像の強制出力の使用を決定します．
;#		画像ファイルがどうしても表示されない場合にCGIで強制的に表示させます。
;#		この機能は，不具合が起きる可能性があります。
;#		どうしても上手くいかないなら，$::FLAG_CGI_IMAGE = 1; と書き換えてみてください．

$::FLAG_CGI_IMAGE = 0;

;#	○ (オプション) セキュリティ
;#		セキュリティ関連機能です．
;#		不正な投稿を簡易的ないくつかの手段で防ぐことができます．
;#		将来的には，ブラウザ上で設定できるようにします．

$::check_url = "";	# ここに JawaNote の正確な URL (http://〜) を書いておくと
					# 他サイトから不正に投稿されたものを拒否できます。
					# (イタズラされて、初めて利用すること！)

@::check_ipad = ();	# ここに 登録されたくない方の IPアドレスを書いておくと、
					# その IPアドレスからの全ての投稿を拒否します。
					# (イタズラされて、初めて利用すること！)

$::check_proxy = 0;	# ここの値を 1 にすると、プロクシ経由の全ての投稿を拒否します．
					# プロクシ経由'全て'を拒否するので注意してください．
					# (イタズラされて、初めて利用すること！)


# -----------------------------------------------------------------------
# ■ メイン処理
# -----------------------------------------------------------------------

$SUB{'jnote_main'} =<<'_sub_';
sub jnote_main
{
	# システムファイルを呼び出す
	require $::system_path if (-r $::system_path);

	# 致命的エラー
	$Sys{'error'} = ($::basename eq '') ? "CGIスクリプト名の取得に失敗しました<br>\n" : '';
	&output_error if ($Sys{'error'});

	# 文字コードをチェック
	&check_code($::jcode_liblary);

	# システム変数のデフォルト設定
	$Sys{'max_form_length'}		||= 10240;
	$Sys{'max_alphabet_length'} ||= 200;
	$Sys{'max_enter_count'}		||= 70;
	$Sys{'cookie_key'}			||= 'cgi_station';
	$Sys{'url_home'}			||= 'http://hogehoge/';
	$Sys{'url_image'}			||= './';
	$Sys{'bbs_title'}			||= 'サンプル';
	$Sys{'log_page'}			||= 10;
	$Sys{'max_log_line'} 		||= 100;
	$Sys{'default_template'}	||= 'standard';
	$Sys{'TZ'}					||= 'JST-9';
	$Sys{'color_rescolor'}		||= '#008000';

	# ブラウザから取得したデータをデコード
	&decode_form;	# フォームから取得
	&get_cookie;	# クッキーから取得

	# システム変数の修正
	$Sys{'dir_template'}	= $FORM{'dir'}  || $Sys{'default_template'};
	$Sys{'file_template'}	= $FORM{'file'} || 'default.html';
	$Sys{'cgi_name'}		= $::cgi_name;
	while(my($key,$val) = each(%Sys))
	{
		$Sys{$key} =~ s/[\\\/]$// if ($key =~ /^(dir|url)_/);
	}

	# ブラウザから取得したデータの修正
	for('no','thread','icon','pwd','ipad') { $FORM{$_} = undef; } # 将来的に対応予定あり
	$FORM{'url'} =~ s/^http:\/\///;
	for ('name','mail','url') { $FORM{$_} ||= ''; }
	for ('name','mail','url') { $COOK{$_} ||= $FORM{$_}; }

	# マスターパスワードが設定されてない→→→セットアップへ
	&mode_setup unless ($Sys{'master'});

	# 各モードの処理を実行
	my $func = sprintf("mode_%s",$FORM{'mode'});
	*code = \&{$func};
	&code if (defined(&code) || $SUB{$func});

	# 管理セッション中ならば，管理用テンプレートに変更
	$Sys{'file_template'} = 'admin.html' if (&check_session);

	# ログファイルを読み込む
	&read_log($FORM{'st'},$Sys{'log_page'});

	# テンプレートファイルを読み込む
	&read_template($Sys{'file_template'});

	# エラーがあれば表示して終了
	&output_error if ($Sys{'error'});

	# クッキー用文字列取得
	$Sys{'Set-Cookie'} = &set_cookie('name','mail','url');

	# テンプレート内の変数書き換え(システム変数)
	&set_system_replacement;

	# HTTPヘッダを表示
	for ('name','mail','url') { $COOK{$_} ||= $FORM{$_}; }
	&output_http_header($FORM{'mode'} eq 'registration' ? $Sys{'Set-Cookie'} : undef);

	# テンプレート内容にしたがってHTMLを表示
	&output_templete;

	# サポート用にバージョン情報表示
	print "<!-- jnote ver $::version (CGI-StaTion: http://www7.big.or.jp/~jawa/)-->\n";
	exit;
}
_sub_

# -----------------------------------------------------------------------
# ■ 各種モード処理
# -----------------------------------------------------------------------

# 記事投稿処理
$SUB{'mode_registration'} =<<'_sub_';
sub mode_registration
{
	# 投稿内容をチェックして
	&check_registration;
	# エラーがなければ投稿処理
	&new_registration unless ($Sys{'error'});
}
_sub_
# 記事削除処理
$SUB{'mode_del'} =<<'_sub_';
sub mode_del
{
	# 管理セッション中でなければ，管理セッションパスワード処理へ
	&mode_admin unless (&check_session);
	# 削除処理
	&del_registration;
}
_sub_
# セットアップ処理
$SUB{'mode_setup'} =<<'_sub_';
sub mode_setup
{
	# マスターパスワードが設定されているなら
	if ($Sys{'master'})
	{
		# 管理セッション中でなければ，管理セッション処理へ
		&mode_admin unless (&check_session);
	}
	# セットアップの書き換えボタンが押されていたら
	if ($FORM{'sys_setup_edit'})
	{
		# ブラウザから得た内容を更新
		while (my($key, $val) = each %Sys)
		{
			next unless (defined($FORM{"sys_$key"}));
			$Sys{$key} = $FORM{"sys_$key"};
		}

		# ブラウザから得た内容の修正
		$Sys{'log_page'} 		= int($Sys{'log_page'}) > 0 ? int($Sys{'log_page'}) : 1;
		$Sys{'max_log_line'} 	= int($Sys{'max_log_line'}) > 0 ? int($Sys{'max_log_line'}) : 1;
		$Sys{'max_alphabet_length'} = int($Sys{'max_alphabet_length'}) > 20 ?
			int($Sys{'max_alphabet_length'}) : 20;
		$Sys{'max_enter_count'} = int($Sys{'max_enter_count'}) > 20 ?
			int($Sys{'max_enter_count'}) : 20;
		$Sys{'max_form_length'} = int($Sys{'max_form_length'}) > 1024 ?
			int($Sys{'max_form_length'}) : 1024;

		# パスワードのチェック
		if ($FORM{'sys_pwd1'} eq $FORM{'sys_pwd2'} && $FORM{'sys_pwd1'} =~ /^\w{6,12}$/)
		{
			$FORM{'master'} = $FORM{'sys_pwd1'};
			$Sys{'master'}  = &crypt_sha($FORM{'sys_pwd1'});
			&check_session;
		}

	}
	# チェック処理
	my %axs = &check_myself;
	&error('パスワードを入力してください') unless ($Sys{'master'});
	$FORM{'session'} ||= 'a';

	# システムファイルに書き込み
	&write_system if ($FORM{'sys_setup_edit'});

	# 結果出力
	&output_http_header(undef, &check_session);
	print "<html><body text='#000000' bgcolor='#ffffff'>\n";
	print "<form action='$Sys{'cgi_name'}' method='post' accept-charset='$Sys{'CharSet'}'>\n";
	print "<input type='hidden' name='mode' value=\"setup\">\n";
	print "<input type='hidden' name='session' value=\"$FORM{'session'}\">\n";
	print "<input type='hidden' name='dir' value=\"$Sys{'dir_template'}\">\n";
	print "<pre><blockquote>\n";
	print "<div align='right'>\n";
	print "<a href='$Sys{'cgi_name'}?dir=$Sys{'dir_template'}&mode=admin&session=$FORM{'session'}'>[管理用モードへ]</a>";
	print "<a href='$Sys{'cgi_name'}'>[掲示板へ]</a>";
	print "</div>\n";
	print "*** セ ッ ト ア ッ プ ***\n\n";
	print "[ <font color='#0000ff'>○</font> ] ＣＧＩは正常に動作しています\n";
	if ($Sys{'error'})
	{
		print "[ <font color='#ff0000'>×</font> ] 問題が発見されました．\n";
		print "<blockquote><font color='#ff0000'>\n";
		print $Sys{'error'};
		print "</font></blockquote>\n";
	}
	else
	{
		print "[ <font color='#0000ff'>○</font> ] 設置上の問題は発見されませんでした．\n\n";
	}


	print<<"_html_";
▽ 修正個所を書き換えて，[システム設定を書き換える]ボタンを押してください．
<hr size=1 noshade>
<input type='hidden' name='sys_setup_edit' value=1>
新しいパスワード： <input type='password' name='sys_pwd1' value='' size=20> ※ 半角英数で6-12文字
新しいパスワード： <input type='password' name='sys_pwd2' value='' size=20> ※ 念のためもう一度
<hr size=1 noshade>
タイトル名：<input type='text' name='sys_bbs_title' value="$Sys{'bbs_title'}" size=60>
戻り先　　：<input type='text' name='sys_url_home' value="$Sys{'url_home'}" size=60>
画像元　　：<input type='text' name='sys_url_image' value="$Sys{'url_image'}" size=60>
<hr size=1 noshade>
表\示件数　　：<input type='text' name='sys_log_page' value="$Sys{'log_page'}" size=5>
最大記事数　：<input type='text' name='sys_max_log_line' value="$Sys{'max_log_line'}" size=5>
引用符の色　：<input type='text' name='sys_color_rescolor' value="$Sys{'color_rescolor'}" size=10> <font color='$Sys{'color_rescolor'}'>■ &gt;あいうえお</font>
<hr size=1 noshade>
テンプレート　　：<input type='text' name='sys_default_template' value="$Sys{'default_template'}" size=20> ※ デフォルトで表\示するテンプレートを指定します
<hr size=1 noshade>
タイムゾーン：<input type='text' name='sys_TZ' value="$Sys{'TZ'}" size=10> <small>(*1)</small>
登録時最大１バイト文字列長：<input type='text' name='sys_max_alphabet_length' value="$Sys{'max_alphabet_length'}" size=10> <small>(*2)</small>
登録時最大改行数：<input type='text' name='sys_max_enter_count' value="$Sys{'max_enter_count'}" size=10> <small>(*2)</small>
登録時最大バイト数：<input type='text' name='sys_max_form_length' value="$Sys{'max_form_length'}" size=10> <small>(*2)</small>
<hr size=1 noshade>
<input type='submit' value='システム設定を書き換える'>

<small>(*1)</small>: 海外サーバ等で時刻が狂う場合に使用します．(JST-9 日本時間)
<small>(*2)</small>: 投稿に直接関係する値なので，適当に書き換えると不具合が生じる可能\性があります．
_html_
	print "</blockquote></pre></form>";
	print "</body></html>\n";
	exit;
}
_sub_
# 管理セッション処理
$SUB{'mode_admin'} =<<'_sub_';
sub mode_admin
{
	# 管理セッションかどうかチェック
	unless (&check_session)
	{
		# 管理セッションじゃないなら，パスワードの入力を求める
		&output_http_header(undef, &check_session);
		if (&read_template('password.html'))
		{
			&set_system_replacement;
			&output_templete;
		}
		else
		{
			print "<html><body>\n";
			print "<br><br><center>\n";
			print "パスワードを入力してください．<br>\n";
			print "<form action='$Sys{'cgi_name'}' method='post' ",
				  "accept-charset='$Sys{'CharSet'}'>\n";
			print "<input type='hidden' name='dir' value=\"$FORM{'dir'}\">\n";
			print "<input type='hidden' name='mode' value='admin'>\n";
			print "<input type='password' name='master' size=12>\n";
			print "<input type='submit' value='管理用'>\n";
			print "</form>\n";
			print "</body></html>\n";
		}
		# 終了！
		exit;
	}
}
_sub_
# ＣＧＩ動作チェック処理
$SUB{'mode_check {'} =<<'_sub_';
sub mode_check {
	&mode_test; # KENT-WEB互換に
}
_sub_
$SUB{'mode_test'} =<<'_sub_';
sub mode_test
{
	my %axs = &check_myself;

	# 結果出力
	&output_http_header;
	print "<html><body text='#000000' bgcolor='#ffffff'><pre>\n";
	print "<div align='right'>\n";
	print "<a href='$Sys{'cgi_name'}'>[掲示板へ]</a>";
	print "</div>\n";
	print "[ <font color='#0000ff'>○</font> ] ＣＧＩは正常に動作しています\n";
	if ($Sys{'error'})
	{
		print "[ <font color='#ff0000'>×</font> ] 問題が発見されました．\n";
		print "<blockquote><font color='#ff0000'>\n";
		print $Sys{'error'};
		print "</font></blockquote>\n";
	}
	else
	{
		print "[ <font color='#0000ff'>○</font> ] 設置上の問題は発見されませんでした．\n\n";
	}
	print "以下はサポート時に使うためのものです．\n\n";
print<<"_html_";
[CGI]
N_JawaNote Version $::version

[File]
ScriptName:$Sys{'cgi_name'}
Template  :[$axs{'template'}]
Directory :[$axs{'dir'}]
SystemFile:[$axs{'system'}]
LoggerFile:[$axs{'log'}]
LockFile  :[$axs{'lock'}]

[Perl]
Path:$^X
Version:$]
Term:$^O
PerlXS:$ENV{'PERLXS'}

[TestForm]
TestFormText:$FORM{'test'}
<form action="$Sys{'cgi_name'}" method="post" accept-charset="$Sys{'CharSet'}">
<input type=hidden name=mode value=test><input type=text name=test size=20 value="">
<input type=submit value="test">
</form>
</pre>
</body></html>
_html_

	exit;
}
_sub_

# -----------------------------------------------------------------------
# ■ HTTP Header を出力
# -----------------------------------------------------------------------

$SUB{'output_http_header'} =<<'_sub_';
sub output_http_header
{
	#use vars '$http_header';
	my $cookie  = shift;	# (引数) クッキー文字列
	my $nocache = shift;	# (引数) キャッシュ情報

	# 既に出力されていないかチェック
	return if ($http_header);
	$http_header = 1;

	# 古いPerlISへの対処
	print "HTTP/1.0 200 OK\n" if ($ENV{'PERLXS'} eq "PerlIS");
	print "Cache-Control: no-cache\n" if ($nocache);
	print "Set-Cookie: $cookie\n" if ($cookie);
	if ($Sys{'CharSet'})
	{
		print "Content-type: text/html; charset=$Sys{'CharSet'}\n\n";
	}
	else
	{
		print "Content-type: text/html\n\n";
	}
}
_sub_

# -----------------------------------------------------------------------
# ■ HTMLでテンプレートを変換しつつ出力する
# -----------------------------------------------------------------------

$SUB{'output_templete'} =<<'_sub_';
sub output_templete
{
	my $depth = shift;			# (引数) ネストの深さ
	my $mode = shift;			# (引数) モード指定 (0:通常 1:logloop 2:exist 3:notexist)
	my $begin_line = shift;		# (引数) 開始する@TEMPLATEの行番号
	my $id = shift;				# (引数) @LOGS の行番号	[logloop用]
	my $key = shift;			# (引数) 置換キー		[exist, notexist用]
	my $line;

	# 念のための緊急脱出用
	($depth < 9) or &output_error('TEMPLATE ERROR');

	# IDがセットされていれば
	# @LOGS の行番号にしたがって，置換内容をセットする
	if (defined($id))
	{
		# 置換できない場合は処理しない
		unless(&set_logger_replacement($id))
		{
			for ($line = $begin_line; $line <= $#TEMPLATE; $line++)
			{
				return $line if ($TEMPLATE[$line] =~ /^<!\/logloop!>/);
			}
			return $line;
		}
	}

	# ループ開始
	for ($line = $begin_line; $line <= $#TEMPLATE; $line++)
	{
		# 現在のテンプレートの内容を得る
		my $text = $TEMPLATE[$line];
		# <!〜form!>の処理
		if ($text =~ /^<!registrationform!>/i)
		{
			print "<form action='$Sys{'cgi_name'}' method='post' ",
				  "accept-charset='$Sys{'CharSet'}'>\n";
			print "<input type='hidden' name='dir' value=\"$FORM{'dir'}\">\n";
			print "<input type='hidden' name='mode' value='registration'>\n";
			next;
		}
		if ($text =~ /^<!passwordform!>/i)
		{
			print "<form action='$Sys{'cgi_name'}' method='post' ",
				  "accept-charset='$Sys{'CharSet'}'>\n";
			print "<input type='hidden' name='dir' value=\"$FORM{'dir'}\">\n";
			print "<input type='hidden' name='mode' value='admin'>\n";
			next;
		}
		if ($text =~ /^<!adminform!>/i)
		{
			print "<form action='$Sys{'cgi_name'}' method='post' ",
				  "accept-charset='$Sys{'CharSet'}'>\n";
			print "<input type='hidden' name='dir' value=\"$FORM{'dir'}\">\n";
			print "<input type='hidden' name='mode' value='del'>\n";
			print "<input type='hidden' name='session' value=\"$FORM{'session'}\">\n";
			next;
		}
		if ($text =~ /^<!\/\w+form!>/i)
		{
			print "</form>\n";
			next;
		}
		# <!logloop!>〜<!/logloop!> の処理
		if ($text =~ /^<!logloop!>/i)
		{
			my $next_line;
			for (0 .. $Sys{'log_page'})
			{
				$next_line = &output_templete($depth+1, 1, $line + 1, $_);
				last if ($next_line > $#TEMPLATE);
			}
			$line = $next_line;
			next;
		}
		return $line if ($mode == 1 and $text =~ /^<!\/logloop!>/i);
		# <!exist!>〜<!/exist!> の処理
		if ($text =~ /^<!exist=\${([\w_]+)}!>/i)
		{
			$line = &output_templete($depth+1, 2, $line + 1, $_ , lc($1));
			next;
		}
		return $line if ($mode == 2 and $text =~ /^<!\/exist!>/i);
		# <!notexist!>〜<!/notexist!> の処理
		if ($text =~ /^<!notexist=\${([\w_]+)}!>/i)
		{
			$line = &output_templete($depth+1, 3, $line + 1, $_ , lc($1));
			next;
		}
		return $line if ($mode == 3 and $text =~ /^<!\/notexist!>/i);
		# 置換して出力する
		next if ($mode == 2 and !$REPLACE{$key});
		next if ($mode == 3 and $REPLACE{$key});
		$text =~ s/(\${([\w]+)})/defined($REPLACE{lc($2)}) ? $REPLACE{lc($2)} : $1/eg;
		print $text;
	}
	return $line;
}
_sub_

# -----------------------------------------------------------------------
# ■ 置換する変数をセット
# -----------------------------------------------------------------------

$SUB{'set_system_replacement'} =<<'_sub_';
sub set_system_replacement
{
	# ログのページ処理関連
	$Sys{'log_page_back'} = $FORM{'st'} - $Sys{'log_page'};
	$Sys{'log_page_next'} = $FORM{'st'} + $Sys{'log_page'};
	$Sys{'log_page_now'} = int($FORM{'st'} / $Sys{'log_page'}) + 1;
	$Sys{'log_page_max'} = int(($Sys{'log_max'}+($Sys{'log_page'}-1)) / $Sys{'log_page'});

	# 各種変数
	my %date = &get_date($Sys{'TZ'});
	while (my($key, $val) = each %date) { $REPLACE{"now_$key"}  = $val; }
	while (my($key, $val) = each %FORM) { $REPLACE{"form_$key"} = $val; }
	while (my($key, $val) = each %Sys)  { $REPLACE{"sys_$key"}  = $val; }
	while (my($key, $val) = each %COOK) { $REPLACE{"cookie_$key"}  = $val; }

	# システム変数(良く使う可能性の高いもの)
	$REPLACE{'charcode'}   = $Sys{'CharCode'};
	$REPLACE{'charset'}    = $Sys{'CharSet'};
	$REPLACE{'set-cookie'} = $Sys{'Set-Cookie'};
	# ＵＲＬ関連
	$REPLACE{'url_home'} = $Sys{'url_home'};
	$REPLACE{'url_image'} = $::FLAG_CGI_IMAGE ? 'jnote.cgi' : $Sys{'url_image'};
	$REPLACE{'url_default'} = $REPLACE{'url_top'} =
		"$Sys{'cgi_name'}?dir=$Sys{'dir_template'}";
	$REPLACE{'url_top'} .= "&session=$FORM{'session'}"
		if ($FORM{'session'});
	$REPLACE{'url_template'} = $REPLACE{'url_default'} . "&file";
	$REPLACE{'url_admin'} = $REPLACE{'url_default'} . "&mode=admin";
	$REPLACE{'url_setup'} = $REPLACE{'url_default'} . "&mode=setup&session=$FORM{'session'}";
	$REPLACE{'url_back'} = $REPLACE{'url_top'} . "&st=$Sys{'log_page_back'}"
		if ($Sys{'log_page_back'} >= 0);
	$REPLACE{'url_next'} = $REPLACE{'url_top'} . "&st=$Sys{'log_page_next'}"
		if ($Sys{'log_page_next'} < $Sys{'log_max'});
}
_sub_
$SUB{'set_logger_replacement'} =<<'_sub_';
sub set_logger_replacement
{
	my $id = shift;			# (引数) @LOGS の行番号

	return 0 if ($id > $#LOGS);
	$REPLACE{'log_id'} = $id + 1;
	# ログからデータ取得
	my %data = &get_logformat($LOGS[$id]);
	# 引用文の作成
	$data{'quotation'} = $data{'comment'};
	$data{'quotation'} =~ s/<br>/\n/g;
	$data{'quotation'} =~ s/^/&gt;/gm;
	$data{'quotation'} .= "\n";
	$data{'quotation'} = '' if ($data{'quotation'} eq ">\n");
	# コメントの修正
	$data{'comment'} =~ s/ /&nbsp;/g;				# スペース置換
	$data{'comment'} = &autolink($data{'comment'});	# URL,メールアドレス置換
	$data{'comment'} =~
		s/(^|>)(&gt;[^<]*)(<|$)/$1<font color=\"$Sys{'color_rescolor'}\">$2<\/font>$3/g;

	my %date = &get_date($Sys{'TZ'}, $data{'time'});
	while (my($key, $val) = each %data) { $REPLACE{"log_$key"} = $val; }
	while (my($key, $val) = each %date) { $REPLACE{"log_$key"} = $val; }
	return 1;
}
_sub_
# -----------------------------------------------------------------------
# ■ ＣＧＩ動作チェック処理
# -----------------------------------------------------------------------

$SUB{'check_myself'} =<<'_sub_';
sub check_myself
{
	my %axs;	# (返値) アクセス権

	# ディレクトリチェック
	unless (-e $::log_directory)
	{
		&error('指定された記録ディレクトリがありません．')
	}
	else
	{
		$axs{'dir'} = ('-','r')[-r $::log_directory].
					  ('-','w')[-w $::log_directory].
					  ('-','x')[-x $::log_directory];
		&error('記録ディレクトリのパーミッションが間違っています．')
			if ($axs{'dir'} ne 'rwx');
	}
	# テンプレートチェック
	&error('指定されたデフォルトテンプレートがありません．')
		unless (-e $Sys{'default_template'});
	$axs{'template'} = ('-','r')[-r $Sys{'default_template'}].
					   ('-','w')[-w $Sys{'default_template'}].
					   ('-','x')[-x $Sys{'default_template'}];

	# ファイルチェック
	my %file = (
		'log'		=> $::log_path,
		'lock'		=> $::lock_file,
		'system'	=> $::system_path,
	);
	for ('log','lock','system')
	{
		my $f = $file{$_};
		unless (-e $f)
		{
			&error("ファイル '$f' がありません");
		}
		else
		{
			eval chmod (0666, $f);
			$axs{$_} = ('-','r')[-r $f]. ('-','w')[-w $f]. ('-','x')[-x $f];
			&error("ファイル '$f' のパーミッションを変更できません．")
				if ($axs{$_} !~ /rw/);
		}
	}

	return %axs;
}
_sub_

# -----------------------------------------------------------------------
# ■ 投稿チェック処理
# -----------------------------------------------------------------------

$SUB{'check_registration'} =<<'_sub_';
sub check_registration
{
	# セキュリティチェック
	&checkReferer($::check_url)			if ($::check_url);
	&checkProxyserver(@::check_ipad)	if (@::check_ipad);
	&checkIPadress($::check_proxy)		if ($::check_proxy);

	# データが投稿されているかチェック
#	&error('タイトルがありません．')		unless ($FORM{'title'});
	&error('名前がありません．')			unless ($FORM{'name'});
	&error('コメントがありません．')		unless ($FORM{'comment'});
#	&error('メールアドレスがありません．')	unless ($FORM{'mail'});
#	&error('URLがありません．')				unless ($FORM{'url'});

	# 文字列長チェック
	&error('タイトル名が長すぎます．')		if (length($FORM{'title'}) > 120);
	&error('名前が長すぎます．')			if (length($FORM{'name'}) > 45);
	&error('メールアドレスが長すぎます．')	if (length($FORM{'mail'}) > 255);
	&error('ＵＲＬが長すぎます．')			if (length($FORM{'url'}) > 255);

	# メールチェック
	$FORM{'mail'} = &d2c($FORM{'mail'});
	&error('メールアドレスを再度，確認してください．')
		if ($FORM{'mail'} &&
		    $FORM{'mail'} !~ /^[\x21-\x7E]+@(([-\w]+\.)*[-\w]+|\[(\d{1,3}\.)+\d{1,3}\])$/);

	# ＵＲＬチェック
	$FORM{'url'} = &d2c($FORM{'url'});
	&error('URLを再度，確認してください．')
		if ($FORM{'url'} && $FORM{'url'} !~ /^[\w!#\$%&*+,-.\/:;=?\@~]+$/);

	# ２重投稿のチェック
	&read_log(0,1);
	my %data = &get_logformat($LOGS[0]);
	for ('title','name','comment') { return if ($FORM{$_} ne $data{$_}); }
	&error('２重投稿はできません');
}
_sub_

# -----------------------------------------------------------------------
# ■ ログの書式を返す
# -----------------------------------------------------------------------

$SUB{'set_logformat'} =<<'_sub_';
sub set_logformat
{
	# (返値) ログの書式

	$FORM{'no'}    = time ."\.$$";
	$FORM{'name'}  ||= '不明';
	$FORM{'title'} ||= '無題';

	return "$FORM{'no'}\t\t$FORM{'title'}\t$FORM{'name'}\t$FORM{'mail'}\t$FORM{'url'}\t\t\t$ENV{'REMOTE_ADDR'}\t$FORM{'comment'}\n";
}
_sub_

# -----------------------------------------------------------------------
# ■ ログからログのデータを得る
# -----------------------------------------------------------------------

$SUB{'get_logformat'} =<<'_sub_';
sub get_logformat
{
	# (返値) ログデータのハッシュ

	my $logformat= shift;	# (引数) ログのフォーマット
	my %ret;

	# 分解
	@ret{'no','thread','title','name','mail','url','icon','pwd','ipad','comment'}
			= split(/\t/,$logformat);
	$ret{'time'} = (split(/\./,$ret{'no'}))[0];
	return %ret;
}
_sub_

# -----------------------------------------------------------------------
# ■ ログファイルを読み込む
# -----------------------------------------------------------------------

$SUB{'read_log'} =<<'_sub_';
sub read_log
{
	my $start = shift;	# (引数) 開始する行
	my $range = shift;	# (引数) 読み込む幅
						# (返値) 1:True 0:False
	# リセット
	$Sys{'log_view'} = 0;
	undef @LOGS;

	# 読み込み
	unless (open IN, $::log_path)
	{
		&error("ログファイルを読み込めません");
		return 0;
	}
	<IN> while($start-- > 0);
	while(<IN>)
	{
		s/\r?\n$//;
		push(@LOGS, $_);
		$Sys{'log_view'}++;
		last unless (--$range);
	}
	1 while(<IN>);
	$Sys{'log_max'} = $.;
	close IN;

	return 1;
}
_sub_

# -----------------------------------------------------------------------
# ■ テンプレートファイルを読み込む
# -----------------------------------------------------------------------

$SUB{'read_template'} =<<'_sub_';
sub read_template
{
	my $templatefile = shift;	# (引数) テンプレートファイル名
								# (返値) 1:True 0:False

	# ファイル正当性チェック
	return 0 unless (&check_filepath("$Sys{'dir_template'}/$templatefile"));
	return 0 unless ($templatefile =~ /\.html?$/i);

	unless (open IN, "$Sys{'dir_template'}/$templatefile")
	{
		&error("テンプレートファイル'$templatefile'を読み込めません");
		return 0;
	}
	@TEMPLATE = <IN>;
	close IN;

	return 1;
}
_sub_

# -----------------------------------------------------------------------
# ■ '新規'投稿処理
# -----------------------------------------------------------------------

$SUB{'new_registration'} =<<'_sub_';
sub new_registration
{
	# (返値) 1:True 0:False

	# ファイルロック
	return 0 unless (&lock_file);

	# 作業用ファイルを作成
	unless (open OUT, ">$::temp_path")
	{
		&error('作業用のファイルを作成できません');
		return 0;
	}
	# 記録用ファイルを開く
	unless (open IN, $::log_path)
	{
		&error('記録用のファイルを読み込めません');
		return 0;
	}
	# 作業用ファイルに出力
	print OUT &set_logformat;
	while(<IN>)
	{
		last if ($. >= $Sys{'max_log_line'});
		print OUT $_;
	}
	close IN;
	close OUT;
	eval chmod (0666, $::temp_path);
	# リネームして更新
	unless (rename($::temp_path,$::log_path))
	{
		&error('ログファイルへのリネームができませんでした．');
		return 0;
	}
	# ファイルアンロック
	&unlock_file;

	return 1;
}
_sub_

# -----------------------------------------------------------------------
# ■ 削除処理
# -----------------------------------------------------------------------

$SUB{'del_registration'} =<<'_sub_';
sub del_registration
{
	# (返値) 1:True 0:False
	#use vars '%DEL';

	# ファイルロック
	return 0 unless (&lock_file);

	# 作業用ファイルを作成
	unless (open OUT, ">$::temp_path")
	{
		&error('作業用のファイルを作成できません');
		return 0;
	}
	# 記録用ファイルを開く
	unless (open IN, $::log_path)
	{
		&error('記録用のファイルを読み込めません');
		return 0;
	}
	# 作業用ファイルに出力
	while(<IN>)
	{
		# %DELハッシュに識別子が存在する時は出力しない＝削除
		print OUT $_ unless ($DEL{(split(/\t/,$_))[0]});
	}
	close IN;
	close OUT;
	eval chmod (0666, $::temp_path);
	# リネームして更新
	unless (rename($::temp_path,$::log_path))
	{
		&error('ログファイルへのリネームができませんでした．');
		return 0;
	}
	# ファイルアンロック
	&unlock_file;

	return 1;
}
_sub_

# -----------------------------------------------------------------------
# ■ %Sysを保存
# -----------------------------------------------------------------------

$SUB{'write_system'} =<<'_sub_';
sub write_system
{
	# ファイルロック
	return 0 unless (&lock_file);

	# 作業用ファイルを作成
	unless (open OUT, ">$::temp_path")
	{
		&error('作業用のファイルを作成できません');
		return 0;
	}
	# 作業用ファイルに出力
	print OUT "%Sys =";
	print OUT &hashprint(\%Sys);
	print OUT "1;\n";
	close OUT;
	eval chmod (0666, $::temp_path);
	# リネームして更新
	unless (rename($::temp_path,$::system_path))
	{
		&error('システムファイルへのリネームができませんでした．');
		return 0;
	}

	# ファイルアンロック
	&unlock_file;
}
_sub_

# -----------------------------------------------------------------------
# ■ ファイル正当性チェック
# -----------------------------------------------------------------------

$SUB{'check_filepath'} =<<'_sub_';
sub check_filepath
{
	my $filepath = shift;

	# 信頼されてないブラウザからのデータ書式をチェックする
	# (半角英数からなるファイル以外は排除する)
	unless ($filepath =~ /^([\w\-\.]+\\?\/?)+$/)
	{
		&error("$filepath は不正な文字列です．");
		return 0;
	}
	if ($filepath =~ /\.\.\//)
	{
		&error("$filepath は親階層を参照しています．");
		return 0;
	}

	# ファイルが存在するかチェックする(最低限必須チェック)
	unless (-r $filepath)
	{
		&error("$filepath は存在しません．");
		return 0;
	}
	# ファイルは正当である
	return 1;
}
_sub_

# -----------------------------------------------------------------------
# ■ ロック機構(排他制御)
# -----------------------------------------------------------------------

# ファイルをロック
$SUB{'lock_file'} =<<'_sub_';
sub lock_file
{
	# (返値) 1:True 0:False

	my $retry	= 4;			# リトライ回数[0 .. X]
	my $timeout = 60;			# タイムアウトまでの時間[秒]

	return 1 if ($Sys{'flock'}++);

	# ロック開始
	for (0..$retry)
	{
		# 時間差でロックする
		return 1
			if (rename($::lock_file, "$::lock_file$^T"));
		sleep 1;
	}
	# 時間差ロック開始
	opendir (DIR, $::log_directory) or
		&error("記録ディレクトリにロックファイルを作成できません．");
	my @files = readdir(DIR);
	close DIR;
	for (@files)
	{
		if (/^$::lock_file(\d+)/)
		{
			return 1
				if ($^T - $1 > $timeout and rename($_, "$::lock_file$^T"));
			last;
		}
	}
	&error("現在，非常に混雑しているため時間をおいてご利用ください．");
	return 0;
}
_sub_
# ファイルをアンロック
$SUB{'unlock_file'} =<<'_sub_';
sub unlock_file
{
	# (返値) 1:True 0:False

	if (--$Sys{'flock'} != 0)
	{
		$Sys{'flock'} = $Sys{'flock'} < 0 ? 0 : $Sys{'flock'};
		return 1;
	}
	return rename("$::lock_file$^T", $::lock_file);
}
_sub_

# -----------------------------------------------------------------------
# ■ 指定した画像ファイルを出力する
# -----------------------------------------------------------------------
# （メモ）メインを呼び出していないため，グローバルな変数を利用してはいけない

$SUB{'output_binary_contents'} =<<'_sub_';
sub output_binary_contents
{
	my $filepath = shift;
	my $data;
	my %CONTENTTYPE = (
        'tif'   => 'tiff',	'tiff'  => 'tiff',	'xbm'   => 'x-xbitmap',
        'png'   => 'png',	'jpg'   => 'jpeg',	'jpeg'  => 'jpeg',	'gif'   => 'gif'
	);

	# 拡張子をチェックする
	$filepath =~ /\.(\w+)$/;
	my $type = $CONTENTTYPE{$1};
	return unless (defined($type));

	# ファイル正当性チェック
	&output_error unless (&check_filepath($filepath));

	# ファイルサイズや更新日時を得る
    my $filesize = (stat($filepath))[7];
	my %date = &get_date('GMT',(stat($filepath))[9]);

	# ファイルを開く
	open IN, $filepath or &output_error("$filepath を開くことができません．<br>");
	binmode IN;

	# 出力開始
	binmode STDOUT;
	print "Last-Modified: $date{'GMT'}\r\n";
	print "Content-Length: $filesize \r\n";
	print "Content-type: image/$type\r\n\r\n";
	while(!eof(IN))
	{
		read(IN, $data, 1024);
		print $data;
	}
	close IN;
	exit 1;
}
_sub_

# -----------------------------------------------------------------------
# ■ 外部からの投稿判断
# -----------------------------------------------------------------------

$SUB{'checkReferer'} =<<'_sub_';
sub checkReferer
{
    my $myurl = shift;		# (引数) 自分自身のＵＲＬ

	my $reffer = $ENV{'HTTP_REFERER'};
	$reffer =~ s/%([0-9a-fA-F][0-9a-fA-F])/chr(hex($1))/eg;
    &error('投稿が不正だと判断されたため，受理できません')
        unless ($reffer =~ /^$myurl/i);
}
_sub_

# -----------------------------------------------------------------------
# ■ プロキシ制限
# -----------------------------------------------------------------------

$SUB{'checkProxyserver'} =<<'_sub_';
sub checkProxyserver
{
    for (
        'HTTP_X_FORWARDED_FOR',
        'HTTP_VIA',
        'HTTP_FORWARDED',
        'HTTP_PROXY_CONNECTION',
        'HTTP_CACHE_INFO',
        'HTTP_CLIENT_IP',
        'HTTP_X_LOCKING',
        'HTTP_XROXY_CONNECTION',
        'HTTP_XONNECTION',
        'HTTP_TE',
    )
    {
        &error('投稿が不正だと判断されたため，受理できません') if ($ENV{$_});
    }
    &error('投稿が不正だと判断されたため，受理できません')
        if ($ENV{'HTTP_USER_AGENT'} =~ /\b(via|proxy|anonym)\b/i);
}
_sub_

# -----------------------------------------------------------------------
# ■ ＩＰアドレス制限
# -----------------------------------------------------------------------

$SUB{'checkIPadress'} =<<'_sub_';
sub checkIPadress
{
	# (引数) @_ 拒否ＩＰアドレスリスト
    my $ipad = $ENV{'REMOTE_ADDR'};

	for (@_)
	{
		&error('投稿が不正だと判断されたため，受理できません') if ($ipad =~ /^\Q$_\E/);
	}
}
_sub_

# -----------------------------------------------------------------------
# ■ CGIネームを返す
# -----------------------------------------------------------------------

$SUB{'get_cginame'} =<<'_sub_';
sub get_cginame
{
	# サーバー依存の変数から得る
	$ENV{'SCRIPT_NAME'} =~ /[\/\\]([^\/\\]+)$/;
	return $1 if (-r $1);
	# Perl依存の変数から得る
	$0 =~ /[\/\\]?([^\/\\]+)$/;
	return $1 if (-r $1);
	# 失敗
	return $_[0] || undef;
}
_sub_

# -----------------------------------------------------------------------
# ■ 時刻を得る
# -----------------------------------------------------------------------

$SUB{'get_date'} =<<'_sub_';
sub get_date
{
	my $tz = shift; 		# (引数) タイムゾーン(省略時はGMT)
	my $t  = shift || time; # (引数) 時間(省略可)
							# (返値) 時間情報のハッシュ
	my %date;

	$ENV{'TZ'} = $tz ? $tz : "GMT";

	@date{'sec','min','hour','day','mon','year','ww'} =
		($tz eq 'GMT') ? gmtime($t) : localtime($t);
	$date{'week'}  = ('Sun','Mon','Tue','Wed','Thu','Fri','Sat')[$date{'ww'}];
	$date{'youbi'} = ('日','月','火','水','木','金','土')[$date{'ww'}];
	$date{'month'} = ('Jan','Feb','Mar','Apr','May','Jun',
					  'Jul','Aug','Sep','Oct','Nov','Dec')[$date{'mon'}];
	$date{'GMT'} = sprintf("%s, %02d\-%s\-%04d %02d\:%02d:%02d GMT",
						  $date{'week'},
						  $date{'day'}, $date{'month'}, $date{'year'}+1900,
						  $date{'hour'}, $date{'min'}, $date{'sec'});
	$date{'year'} %= 100;
	$date{'mon'}++;
	for ('sec','min','hour','day','mon','year')
	{
		$date{$_} = sprintf("%02d",$date{$_});
	}

	return %date;
}
_sub_

# -----------------------------------------------------------------------
# ■ 文字列中のリンクを探し，変換
# -----------------------------------------------------------------------

$SUB{'autolink'} =<<'_sub_';
sub autolink
{
	my $str = shift;	# (引数) 文字列
						# (返値) 変換後の文字列

	# url抽出(前よりかなりましなはず)
	$str=~ s/((s?https?|ftp):\/\/[\w!#\$%&'*+,-.\/:;=?\@~]+)/
			sprintf('<a href="%s" target=_blank>%s<\/a>', &d2c($1), $1)/eg;
	# mail抽出(かなり適当かも．改善の余地あり)
	$str =~ s/([\x21-\x3b\x3d\x3f-\x7E]+@(([-\w]+\.)*[-\w]+|\[(\d{1,3}\.)+\d{1,3}\]))/<A HREF=\"mailto\:$1\">$1<\/A>/g;
	return $str;
}
_sub_

# -----------------------------------------------------------------------
# ■ ハッシュ内容を展開 thanks Grphalt(2002)
# -----------------------------------------------------------------------

$SUB{'hashprint'} =<<'_sub_';
sub hashprint
{
	my $str = shift;
	my $ret;

	if (my $type = ref($str))
	{
		&output_error('NO HASH') unless ($type eq 'HASH');
		$ret .= "\n(\n";
		while (my($key, $val) = each(%{$str}))
		{
			$ret .=  '"'. &scalarprint($key). '"=>';
			$ret .= &hashprint($val);
		}
		$ret .=  ");\n";
	}
	else
	{
		$ret .= '"'. &scalarprint($str). '",'. "\n";
	}
	return $ret;
}
_sub_
$SUB{'scalarprint'} =<<'_sub_';
sub scalarprint
{
	my $ret;

	for (split(//, $_[0]))
	{
		if ($_ =~ /\w/) { $ret .= $_; }
		else { $ret .= sprintf("\\x%02x", ord($_)); }
	}
	return $ret;
}
_sub_

# -----------------------------------------------------------------------
# ■ セッションのチェック(0:失敗 1:成功)
#
#	output_http_headerから呼ばれるため，
#	この関数内で，エラー出力関数を呼び出してはいけません．
# -----------------------------------------------------------------------

$SUB{'check_session'} =<<'_sub_';
sub check_session
{
	#use vars '$session_flag';

	# (返値) 1:True 0:False
	return 1 if ($session_flag);
	return 0 unless ($FORM{'session'} || $FORM{'master'});
	# セッションが確立する条件はパスワード一致と時間

	if (&crypt_sha($FORM{'master'}) eq $Sys{'master'})
	{
		# 新しいセッションパスワード生成
		$FORM{'session'}	 = &make_password(20);
		$Sys{'session'} 	 = &crypt_sha($FORM{'session'});
		$Sys{'settion_ipad'} = $ENV{'REMOTE_ADDR'};
	}
	elsif ($ENV{'REMOTE_ADDR'} ne $Sys{'settion_ipad'} ||
	       $Sys{'settion_time'} < time ||
	       &crypt_sha($FORM{'session'}) ne $Sys{'session'})
	{
		return 0;
	}
	# セッション情報の更新
	$session_flag = 1;
	$Sys{'settion_time'} = time + 1 * 60 * 60; # 3600秒(1時間)
	# システムファイルの更新
	&write_system;
	# ブラウザから得たマスターパスワードを消去
	$FORM{'master'} = undef;
	return 1;
}
_sub_

# -----------------------------------------------------------------------
# ■ パスワード文字列を生成する
# -----------------------------------------------------------------------

$SUB{'make_password'} =<<'_sub_';
sub make_password
{
	my $len = shift;			# (引数) 文字列長
	my $pwd;					# (返値) 生成された文字列

	srand;
	my @char = ('0'..'9','a'..'z','A'..'Z','_');
	for (1 .. $len) { $pwd .= $char[rand(@char)]; }
	return $pwd;
}
_sub_

# -----------------------------------------------------------------------
# ■ SHA1で暗号ダイジェストを得る
# -----------------------------------------------------------------------

$SUB{'crypt_sha'} =<<'_sub_';
sub crypt_sha
{
	#use vars '%SHA';
	my $str = shift;			# (引数) 生成元文字列
								# (返値) 暗号ダイジェスト

	# 暗号化(メッセージダイジェスト生成)は時間がかかるので，キャッシュを利用
	return '@' unless ($str);
	return $SHA{$str} if (defined($SHA{$str}));
	# モジュールが利用できれば優先的に使用し，できなければ自前処理
	if (eval("use Digest::SHA1") == undef)
	{ $SHA{$str} = &SHA1($str); }
	else
	{ $SHA{$str} = Digest::SHA1::sha1_hex($str); }
	return $SHA{$str};
}
_sub_

# -----------------------------------------------------------------------
# ■ SHA1(SECURE HASH ALGORITHM)
#	 詳細はRFC3174を参照．
# -----------------------------------------------------------------------

$SUB{'SHA1'} =<<'_sub_';
sub SHA1
{
	# (引数) 生成元文字列
	# (返値) 暗号ダイジェスト

	#use vars '%SHA';
	eval("use Integer");

	my ($size, $len, $flag, $p, @W);
	# Constants Used
	my @K = (0x5A827999, 0x6ED9EBA1, 0x8F1BBCDC, 0xCA62C1D6);
	# Default HASH
	my @H = (0x67452301, 0xEFCDAB89, 0x98BADCFE, 0x10325476, 0xC3D2E1F0);
	do
	{
		# Message Padding
		my $M = substr($_[0], $p, 64); $p += 64;
		$len = length($M);
		$size += $len;
		if ($len < 64 && !$flag++) { $len++; $M .= "\x80"; }
		# Step A.
		@W = unpack('N16', $M . "\0" x 8);
		$W[15] = $size << 3 if ($len < 57);
		# Step B.
		for my $t (16 .. 79)
		{
			my $tmp = $W[$t - 3] ^ $W[$t - 8] ^ $W[$t - 14] ^ $W[$t - 16];
			$W[$t] = $tmp << 1 | $tmp >> 31;
		}
		# Step C.
		my @wd = @H;
		for my $t (0 .. 79)
		{
			$t = _SHA1($t, $wd[1], $wd[2], $wd[3]) + $wd[4] + $W[$t] + $K[$t / 20];
			$t += $wd[0] << 5 | $wd[0] >> 27;
			$t = $t % 4294967296;			# $t = $t & 0xFFFFFFFF;
			$wd[4] = $wd[3];
			$wd[3] = $wd[2];
			$wd[2] = $wd[1] << 30 | $wd[1] >> 2;
			$wd[1] = $wd[0];
			$wd[0] = $t;
		}
		for (0 .. 4)
		{
			$H[$_] += $wd[$_];
			$H[$_] = $H[$_] % 4294967296;	# $H[$_] = $H[$_] & 0xFFFFFFFF;
		}
	} while ($len > 56);

	return(sprintf('%.8x%.8x%.8x%.8x%.8x', @H));
}
_sub_
$SUB{'_SHA1'} =<<'_sub_';
sub _SHA1
{
	return ($_[1] & ($_[2] ^ $_[3]) ^ $_[3]) if ($_[0] <= 19);
	return ($_[1] ^ $_[2] ^ $_[3]) if ($_[0] <= 39 || $_[0] >= 60);
	return (($_[1] | $_[2]) & $_[3] | $_[1] & $_[2]);
}
_sub_

# -----------------------------------------------------------------------
# ■ 文字実体参照 相互変換
# -----------------------------------------------------------------------
# (引数) 変換元文字列
# (引数) 変換後文字列

# 実体 → 参照
$SUB{'c2d'} =<<'_sub_';
sub c2d
{
	my $str = shift;
	my %c2d = (
		'"' => '&quot;',	'<' => '&lt;',		'>' => '&gt;',
	);

	$str =~ s/(["<>])/$c2d{$1}/g;
	return $str;
}
_sub_

# 参照 → 実体
$SUB{'d2c'} =<<'_sub_';
sub d2c
{
	my $str = shift;
	my %d2c = (
		'nbsp'  => ' ',	'quot'   => '"',	'lt'  => '<',	'gt'  => '>',
		'iexcl' => '!',	'brvbar' => '|',	'shy' => '-',	'yen' => '\\',
	);

	$str =~ s/&(\w+);/$d2c{lc($1)}||"&$1;"/eg;
	return $str;
}
_sub_

# -----------------------------------------------------------------------
# ■ フォームデコード
#	 %FORMハッシュに取得
# -----------------------------------------------------------------------

$SUB{'decode_form'} =<<'_sub_';
sub decode_form
{
	#use vars '%DEL';

	my $buf;
	# フォームデータとして受け入れるものを正規表現で羅列
	my %type = (
		'title'	=>	'.?',	'name'		=>	'.?', 'mail'	=>	'.?',
		'url'	=>	'.?',	'comment'	=>	'.?', 'test'	=>	'.?',
		'del'	=>	'^[\d\.]+$',
		'st'	=>	'^\d+$',
		'mode'	=>	'^\w+$',
		'session'=>	'^\w+$',
		'master'=>	'^[\w]{6,12}$',
		'dir'	=>	'(^$|^[\w\-][\w\.\-\\\/]*$)',
		'file'	=>	'^[\w\.\-]*$',
	);


	# POSTとGETで振り分け
	if ($ENV{'REQUEST_METHOD'} eq "POST")
	{
		if ($ENV{'CONTENT_LENGTH'} > $Sys{'max_form_length'})
		{
			&error('サイズ制限を超過しているため，投稿は拒否されました．');
			return;
		}
		read(STDIN, $buf, $ENV{'CONTENT_LENGTH'});
	}
	else
	{
		$buf = $ENV{'QUERY_STRING'};
	}

	# デコードする
	for (split(/&/,$buf))
	{
		my ($key,$val) = split(/=/,$_);
		$key = lc($key);
		# フォームデータとして定義されているかチェック
		unless ($type{$key} || $key =~ /^sys_/)
		{
			&error("フォームキー'$key'のタイプが未定義です．");
			next;
		}
		# デコード
		$val =~ tr/+/ /;
		$val =~ s/%([0-9a-fA-F][0-9a-fA-F])/chr(hex($1))/eg;
		# 改行の統一
		$val =~ s/\n?\r\n?/\n/g;
		# 文字参照→文字実体変換
		$val =~ s/&/&amp;/g;
		$val = &d2c($val);
		# 100文字以上のアルファベットや記号の羅列をチェック
		&error("不正な文字列が発見されたため，投稿は拒否されました．")
			if ($val =~ /[\x21-\x24\x26-\x2c\x2e-\x7e]{$Sys{'max_alphabet_length'},}/);
		# タブコード変換(ログで利用するため)
		$val =~ s/([^\t\n]{0,4})(\t?)/sprintf("%s%s%s",$1,' ' x (4-length($1)),
													($2 && length($1)==4) ? '    ' : '')/eg;
		$val =~ s/\x20+\n/\n/g; $val =~ s/\x20+$//;
		# 文字実体→文字参照変換
		$val = &c2d($val);
		# マルチバイト文字の処理
		$val = &change_code($val) if ($val =~ /[\e\x80-\xff]/);

		# 改行コードの変換
		&error("改行が非常に多いため，投稿は拒否されました．")
			if (($val =~ s/\n/<br>/g) > $Sys{'max_enter_count'});

		if ($key ne 'del' && $key !~ /^sys_/)
		{
			# フォームデータの正当性チェック
			unless ($val =~ /$type{$key}/)
			{
				&error("フォームキー'$key'の値が不正です．");
				$val = '';
			}
		}
		else
		{
			# 削除番号セット
			$DEL{$val} = 1 ;
		}
		$FORM{$key} = $val;
	}
}
_sub_

# -----------------------------------------------------------------------
# ■ クッキーを焼く thanks まーちゃん(1996)
#	%FORMの内容を保存
# -----------------------------------------------------------------------

$SUB{'set_cookie'} =<<'_sub_';
sub set_cookie
{
	my @list = @_; # (引数) 焼くものリスト

	my %date = &get_date('GMT',time + 30*24*60*60);
	my $cookstr = "cgi:$Sys{'cgi_name'}";
	for my $key (@list)
	{
		my $val = $FORM{$key};
		$key =~ s/(\W)/sprintf("%%%02X", unpack("C", $1))/eg;
		$val =~ s/(\W)/sprintf("%%%02X", unpack("C", $1))/eg;
		$cookstr .= ",$key:$val";
	}
	return "$Sys{'cookie_key'}=$cookstr; expires=$date{'GMT'}";
}
_sub_

# -----------------------------------------------------------------------
# ■ クッキーを食す thanks まーちゃん(1996)
# -----------------------------------------------------------------------

$SUB{'get_cookie'} =<<'_sub_';
sub get_cookie
{
	# クッキーをもらう
	for (split(/;/, $ENV{'HTTP_COOKIE'}))
	{
		my($key, $val) = split(/=/, $_);
		$key =~ s/\s+//g;
		next if ($key ne $Sys{'cookie_key'});
		for (split(/,/, $val))
		{
			my($key, $val) = split(/:/, $_);
			$val =~ s/\s+//g;
			$val =~ s/%([0-9a-fA-F][0-9a-fA-F])/chr(hex($1))/eg;
			$COOK{$key} = &change_code($val);
		}
	}
	return;
}
_sub_

# -----------------------------------------------------------------------
# ■ 文字コードの判断 [JIS,SJIS,EUC]
# -----------------------------------------------------------------------

$SUB{'check_code'} =<<'_sub_';
sub check_code
{
	my $jcode = shift;		# (引数) jcode.pl へのパス(省略時は使用しない)
	my $check_code = shift; # (引数) 文字コードセット

	$Sys{'jcode'} = -r $jcode ? 'jcode.pl' : 'no_jcode';
	require $jcode if ($Sys{'jcode'} ne 'no_jcode' && -r $Sys{'jcode'});
#	eval $GA_JCODE if ($Sys{'jcode'} eq 'no_jcode');
	# ※注意 ここを書き換えると文字化けするかもしれません
	$check_code ||= ord(substr("じゃわ",0,1));
	$check_code = 'sjis' if ($check_code == 0x82);
	$check_code = 'euc'  if ($check_code == 0xA4);
	$check_code = 'jis'  if ($check_code == 0x1B);

	if ($check_code eq 'sjis')
		{ $Sys{'CharCode'} = "sjis"; $Sys{'CharSet'} = "Shift-JIS"; }
	elsif ($check_code eq 'euc')
		{ $Sys{'CharCode'} = "euc";	$Sys{'CharSet'} = "x-euc-jp"; }
	elsif ($check_code eq 'jis')
		{ $Sys{'CharCode'} = "jis";	$Sys{'CharSet'} = "iso-2022-jp"; }
	else
		{
			# Shift-JISとしてエラー「サポートされていない文字コードです」を返す
			$Sys{'CharCode'} = "sjis"; $Sys{'CharSet'} = "Shift-JIS";
			&error("\x83T\x83|\x81[\x83g\x82ｳ\x82\xEA\x82ﾄ\x82｢\x82ﾈ" .
			       "\x82｢\x95ｶ\x8E\x9A\x83R\x81[\x83h\x82ﾅ\x82ｷ");
		}
}
_sub_

# -----------------------------------------------------------------------
# ■ 文字コードの変換 [JIS,SJIS,EUC]
# -----------------------------------------------------------------------

$SUB{'change_code'} =<<'_sub_';
sub change_code
{
	my $text = shift;		# (引数) 文字コードを変換する文字列

	if ($Sys{'jcode'} eq 'jcode.pl')
	{
		# jcode.pl を用いた文字コード変換
		&jcode'convert(*text,$Sys{'CharSet'});
		if ($text =~ /[^\x81-\x9f\xe0-\xfc][\xa1-\xdf]/ or $text =~ /^[\xa1-\xdf]/)
		{
			&jcode'h2z_sjis(*text) if ($Sys{'CharSet'} eq 'sjis');
			&jcode'h2z_euc(*text)  if ($Sys{'CharSet'} eq 'euc');
			&jcode'h2z_jis(*text)  if ($Sys{'CharSet'} eq 'jis');
		}
	}
	else
	{
		# GA::JCODE を用いた文字コード変換
		$text = &SJIS($text) if ($Sys{'CharSet'} eq 'sjis');
		$text = &EUC($text)  if ($Sys{'CharSet'} eq 'euc');
		$text = &JIS($text)  if ($Sys{'CharSet'} eq 'jis');
	}
	return $text;
}
_sub_

# ……………………………………………………………………………………………………
#	△ ＧＡ：：ＪＣＯＤＥ	(※ 注意)
#	￣
#	この文字コード変換関数郡のみ (C)GandA-Lab. の著作物です。
#	CGI-StaTionは事前に改変及び再配布の許可を頂いております。
#	従って、この関数郡のみを切り離して使用することはできません。
#	この関数郡を含むGAライブラリはフリーウェアとして配布されています。
#	また、商用バージョンのGAEXライブラリも用意されています。
#	詳しくは下記URLを参照してください。
#												http://www.ganda-lab.com/
# ……………………………………………………………………………………………………

$SUB{'SJIS'} =<<'_sub_';
sub SJIS
{
	my $str   = shift;
	my $icode = shift || &GetCode($str);

	$str = &euc2sjis($str) if ($icode eq 'euc');
	$str = &jis2sjis($str) if ($icode eq 'jis');

	return($str);
}
_sub_
$SUB{'EUC'} =<<'_sub_';
sub EUC
{
	my $str   = shift;
	my $icode = shift || &GetCode($str);

	$str = &sjis2euc($str) if ($icode eq 'sjis');
	$str = &jis2euc($str)  if ($icode eq 'jis');

	return($str);
}
_sub_
$SUB{'JIS'} =<<'_sub_';
sub JIS
{
	my $str   = shift;
	my $icode = shift || &GetCode($str);

	$str = &euc2jis($str)  if ($icode eq 'euc');
	$str = &sjis2jis($str) if ($icode eq 'sjis');

	return($str);
}
_sub_

$SUB{'GetCode'} =<<'_sub_';
sub GetCode
{
	my $str = shift;
	my $eos = shift || ($ENV{'HTTP_USER_AGENT'} =~ /^Mozilla\/4\.0\ \(compatible\;\ MSIE\ ([56]\.[05])1?\;.*Windows\ (NT|9[85])/ ? 'sjis' : 'euc');

	return('binary') if ($str =~ /[\x00-\x06\x7f\xff]/);
	return('jis')	 if ($str =~ /\e(?:\$[\@B]|\([BJI])/);
	return('ascii')  if ($str !~ /[\x80-\xff]/);

	my($su,$eu);
	$su+=length($1)
		while ($str =~ /[\s\x20-\x7e]+|(?:[\x81-\x9f\xe0-\xfc][\x40-\xfc])+|[\xa1-\xdf]+|(.)/g);
	$eu+=length($1)
		while ($str =~ /[\s\x20-\x7e]+|(?:[\xa1-\xfe][\xa1-\xfe])+|(?:\x8e[\xa1-\xdf])+|(.)/g);

	return(('euc', $eos, 'sjis')[($eu <=> $su)+1]);
}
_sub_

$SUB{'s2e'} =<<'_sub_';
sub s2e
{
	my $str = shift;
	my($c1, $c2) = unpack('CC', $str);

	return("\x8e".chr($c1))
		if (0xa1 <= $c1 && $c1 <= 0xdf);

	if ($c2 >= 0x9f) {
		$c1 = $c1 * 2 - ($c1 >= 0xe0 ? 0xe0 : 0x60);
		$c2 += 2;
	} else {
		$c1 = $c1 * 2 - ($c1 >= 0xe0 ? 0xe1 : 0x61);
		$c2 += 0x60 + ($c2 < 0x7f);
	}
	return(chr($c1). chr($c2));
}
_sub_
$SUB{'e2s'} =<<'_sub_';
sub e2s
{
	my $str = shift;
	my($c1, $c2) = unpack('CC', $str);

	return(chr($c2))
		if ($c1 == 0x8e);

	if ($c1 % 2) {
		$c1 = ($c1>>1) + ($c1 < 0xdf ? 0x31 : 0x71);
		$c2 -= 0x60 + ($c2 < 0xe0);
	} else {
		$c1 = ($c1>>1) + ($c1 < 0xdf ? 0x30 : 0x70);
		$c2 -= 2;
	}
	return(chr($c1). chr($c2));
}
_sub_

# SJIS => EUC
$SUB{'sjis2euc'} =<<'_sub_';
sub sjis2euc
{
	my $str = shift;
	$str =~ s/([\x81-\x9f\xe0-\xfc][\x40-\x7e\x80-\xfc]|[\xa1-\xdf])/&s2e($1)/eg;
	return($str);
}
_sub_

# EUC => SJIS
$SUB{'euc2sjis'} =<<'_sub_';
sub euc2sjis
{
	my $str = shift;
	$str =~ s/([\xa1-\xfe][\xa1-\xfe]|\x8e[\xa1-\xdf])/&e2s($1)/eg;
	return($str);
}
_sub_

# EUC => JIS
$SUB{'euc2jis'} =<<'_sub_';
sub euc2jis
{
	my $str = shift;
	if ($str =~ s/((?:\x8e[\xa1-\xdf])+|(?:[\xa1-\xfe][\xa1-\xfe])+)/&_euc2jis($1)/eg)
	{
		$str =~ s/\e\([BJ](\e\$[\@B]|\e\(I)/$1/g;
	}
	return($str);
}
_sub_
$SUB{'_euc2jis'} =<<'_sub_';
sub _euc2jis
{
	my $str = shift;
	my $esc = ($str =~ tr/\x8e//d) ? "\e(I" : "\e\$B" ;

	$str =~ tr/\xa1-\xfe/\x21-\x7e/;
	return($esc . $str . "\e(B");
}
_sub_

# JIS => EUC
$SUB{'jis2euc'} =<<'_sub_';
sub jis2euc
{
	my $str = shift;
	$str =~ s/(\e\$[\@B]|\e\([BJ]|\e\(I)([^\e]*)/&_jis2euc($1,$2)/eg;
	return($str);
}
_sub_
$SUB{'_jis2euc'} =<<'_sub_';
sub _jis2euc
{
	my $esc = shift;
	my $str = shift;

	if ($esc ne "\e(B" && $esc ne "\e(J")
	{
		$str =~ tr/\x21-\x7e/\xa1-\xfe/;
		$str = "\x8e". join("\x8e", split(//, $str))
			if ($esc eq "\e(I");
	}
	return($str);
}
_sub_

# JIS => SJIS
$SUB{'jis2sjis'} =<<'_sub_';
sub jis2sjis
{
	my $str = shift;
	$str =~ s/(\e\$[\@B]|\e\([BJ]|\e\(I)([^\e]*)/&_jis2sjis($1,$2)/eg;
	return($str);
}
_sub_
$SUB{'_jis2sjis'} =<<'_sub_';
sub _jis2sjis
{
	my $esc = shift;
	my $str = shift;

	if ($esc ne "\e(B" && $esc ne "\e(J")
	{
		$str =~ tr/\x21-\x7e/\xa1-\xfe/;
		$str =~ s/([\xa1-\xfe][\xa1-\xfe])/&e2s($1)/eg
			if ($esc eq "\e\$@" || $esc eq "\e\$B");
	}
	return($str);
}
_sub_

# SJIS => JIS
$SUB{'sjis2jis'} =<<'_sub_';
sub sjis2jis
{
	my $str = shift;

	$str =~ s/((?:[\xa1-\xdf])+|(?:[\x81-\x9f\xe0-\xfc][\x40-\x7e\x80-\xfc])+)/&_sjis2jis($1)/eg
		&& $str =~ s/\e\([BJ](\e\$[\@B]|\e\(I)/$1/g;

	return($str);
}
_sub_
$SUB{'_sjis2jis'} =<<'_sub_';
sub _sjis2jis
{
	my $str = shift;
	if ($str =~ /^[\xa1-\xdf]/)
	{
		$str =~ tr/\xa1-\xdf/\x21-\x5f/;
		return("\e(I" . $str . "\e(B");
	}
	else
	{
		$str =~ s/([\x81-\x9f\xe0-\xfc][\x40-\x7e\x80-\xfc])/&s2e($1)/eg;
		$str =~ tr/\xa1-\xfe/\x21-\x7e/;
		return("\e\$B" . $str . "\e(B");
	}
}
_sub_

# -----------------------------------------------------------------------
# ■ エラー処理(一般)
# -----------------------------------------------------------------------

# エラーはとりあえず，溜めておく
$SUB{'error'} =<<'_sub_';
sub error
{
	$Sys{'error'} .= "$_[0]<br>";
}
_sub_
# 一気に吐き出す
$SUB{'output_error'} =<<'_sub_';
sub output_error
{
	$Sys{'error'} .= shift;
	&output_http_header;
	if (&read_template('error.html'))
	{
		&set_system_replacement;
		&output_templete;
	}
	else
	{
		print<<"_html_";
<html><body>
<hr size=1 noshade>
<table bgcolor="#ffeeee" cellpadding=5 width=100%><td align=center>
<font color="#ff0000"><b>エラー:$Sys{'error'}</b></font>
</td></table>
<hr size=1 noshade>
</body></html>
_html_
	}
	exit;
}
_sub_

# -----------------------------------------------------------------------
# ■ ＣＧＩの前処理，後処理，および，メイン関数呼び出し
# -----------------------------------------------------------------------

# 自分自身の名前を取得
$::cgi_name = &get_cginame($::cgi_name);
($::basename = $::cgi_name) =~ s/\.cgi$//;

# ファイルパスを設定する
$::log_directory =~ s/([^\/])$/$1\//;
$::system_path = $::log_directory . $::basename . '_sys.cgi';
$::log_path    = $::log_directory . $::basename . '.log';
$::temp_path   = $::log_directory . $::basename . $$ . '.tmp';
$::lock_file   = $::log_directory . $::basename . '.loc';

# 画像強制出力
&output_binary_contents($1) if ($::FLAG_CGI_IMAGE && $ENV{'PATH_INFO'} =~ /\/(.*)/);

# メイン処理開始
&jnote_main;
exit;

BEGIN
{
	# WinNT サーバー用(念のため…)
#	chdir('C:/home/usr/cgi-bin/jnote/');
}
END
{
	# 作業用ファイルの削除
	unlink($::temp_path) if (-e $::temp_path && $::temp_path);

	# ロック解除
	if ($Sys{'flock'} != 0)
	{
		$Sys{'flock'} = 1;
		&unlock_file;
	}
}

# -----------------------------------------------------------------------
# ■ AUTOLOAD関数
#	この関数を書き換えると致命的なエラーになります．
#	決して書き換えないこと！
# -----------------------------------------------------------------------

sub AUTOLOAD
{
	#use vars '$AUTOLOAD';
	my ($func) = $AUTOLOAD =~ /::(\w+)$/;

	# 永久ループ防止(念のため)
	die "cgi exective error" if ($func eq 'system_error');

	# 関数呼び出し失敗 -> システムエラー
	$SUB{$func} or &_system_error("未定義の関数 $func が呼び出されました．");

	# 関数生成
	eval $SUB{$func};
	$SUB{$func} = undef;

	# コンパイルエラー
	&_system_error("関数 $func が壊れています．<pre>$@</pre>") if ($@);

	# 関数呼び出し
	goto &{$func};
}
sub _system_error
{
	$Sys{'CharCode'} ||= 'Shift-JIS';
	print "Content-type: text/html; charset=$Sys{'CharCode'}\n\n";
	print<<"_html_";
<html>
<body>
<hr size=1 noshade color='red'>
<h2>致命的なエラー</h2>
<hr size=1 noshade color='red'>
<pre>
<font color='red'>CGIに致命的なエラーが発生したので，処理を中断しました．</font>

このエラーはサポート掲示板に報告して頂けると助かります．
（改造してある場合は，ご遠慮ください）

----------------- [エラー内容] -------------------
CGI SCRIPT:$::cgi_name - $::version
Referer:$ENV{'HTTP_REFERER'}
Path:$^X
Version:$] PerlXS:$ENV{'PERLXS'} Term:$^O

<font color='red'>$_[0]</font>
--------------------------------------------------
</pre>
</body>
</html>
_html_
	exit;
}