#!/usr/local/bin/perl
# ---------------------------------------------------------------------
#
# bbs.cgi
#
# 1998/01/23 Ver.0.05
# 1998/01/23 Ver.0.06 bugfix
# 1998/01/26 Ver.0.07
# タイトルにハンドル名を付加 ID 欄には E-mail addr の名前部分を
# 1998/01/30 Ver.0.08
# 書き込むとモードが初期値になる。bugfix
# webmaster へのメール
# カスタマイズ可能な設定値を外部化し bbs.env としました。
# 1998/01/30 Ver.0.10
# 未読ポインターの付加＆モードの保存
# Re: への対応 第１弾
# 1998/01/30 Ver.0.14 bugfix
# 1998/01/31 Ver.0.15
# 新しいメッセージがないときに n メッセージ表示のボタンを追加
# 偽 pc-van のため w コマンドを追加。こんなの使わないよなぁ(^^;;;
# 1998/02/03 Ver.0.16
# 排他ロック設定忘れ(^^;;; bugfix
# メッセージ#のカウントアップ bugfix
# 1998/02/06 Ver.0.17
# 内容の中の http アドレスへもリンクをつける。
# URL のチェックしていますが、チェックしないほうがよいかもしれませんね(^^;;;
# 引用マークのカスタマイズを可能にしました。
# 1998/02/16 Ver.0.18
# bugfix 内容の中の http アドレスがエラーの時 TEXTAREA に TAG が入る。
# chkurl の名称変更に対応
# 1998/03/02 Ver.0.19
# 日本語コード変換へ対応
# email の入力が省略できるように設定できませんでした。 bugfix
# webmaster へのメールの < 等の除去忘れも発見。 bugfix
# res での tag 除去忘れも発見。 bugfix
# mail address の 形式チェックの @ より前の . を考慮。 bugfix
# http アドレス判定の文字列を見直し bugfix
# 1998/03/03 Ver.0.20 エラーの時 タイトル に TAG が入る。 bugfix
# 1998/03/25 Ver.0.21
# jcodeg.pl の改変部を getcode.pl とし jcode.pl のオリジナルと併用する
# cookie の設定が動作していませんでした。 bugfix
# 1998/03/25 Ver.0.21j0 日本語コード変換の為の試作版
# 1998/03/28 Ver.0.22
# 1998/04/06 Ver.0.23
# 日本語コードの判定 ブラウザの Win Mac の判定忘れ(^^;;; bugfix
# 1998/04/07 Ver.0.24 chkurl のパッケージ化
# 1998/04/08 Ver.0.25 mail の送信先を複数指定できるように拡張しました。
# 1998/05/08 Ver.0.32
# タイトルと名前の中の改行を削除 bugfix
# POST method を使わない設定を可能にしました。for luke
# 1998/05/13 Ver.0.33
# バッファリングを停止し高速化を狙ってみました。
# mail への subject でボード名を [] で囲うようにしました。
# 日本語コードの判定で [ja-euc] の処理を変更しました。
# 1998/05/13 Ver.0.34
# 1998/05/14 Ver.0.35 cookie のタイミングを訂正 bugfix
# 1998/06/15 Ver.0.36 日本語コードの判定を変更しました。
# 1998/06/17 Ver.0.37
# エラー時の処理の bugfix bugfix
# cookie のタイミングを訂正 bugfix
# mail への subject で NO も [] で囲うようにしました。
# 1998/08/24 Ver.0.38 アンロックの処理の bugfix bugfix
# 1998/10/20 Ver.0.39 URL のチェックでのステータス 302 へ対応
# 1999/01/08 Ver.0.40
# 歓迎メッセージの有無を $welcome で指定
# cookie と未読処理の動作を見直しました
# cookie の日付を正規化
# $head, $tail を指定できるように拡張
# url のチェックでのステータス 301 に対応
# メールの送付を CC か BCC を指定できるように
# 1999/01/08 Ver.0.41 メールの発信元、送付先を整理しました。
# 1999/01/11 Ver.0.42 ボタン表示を見直しました。
# 1999/01/19 Ver.0.43 URL のチェックを $chkurl でオプション化
# 1999/01/29 Ver.0.44
# flock の使用を $useflock でオプション化
# メールの subject にタイトルを追加
# cookie の有効期限を MSIE へ対応 (MSIE の方がおかしいと思う(^^;;;
# 1999/02/11 Ver.0.46
# メールの subject にタイトルを位置調整＆ニックネームを追加
# アクセス制限域での未読ポインタファイル機能を追加準備 (BIGLOBE では使えませんが(^^;;;
# 書込み時のレスポンスのタイミングを変更
# ２重書込をエラーにする。
# 1999/02/11 Ver.0.48
# 1999/02/20 Ver.0.49
# 1999/02/24 Ver.0.50
# Mail 中の URL を HTTP_REFERER から、そのメッセージへの Res へ変更
# 1999/02/25 Ver.0.51 Re: でタイトル先頭の Re:#> は複写しない。
# 1999/02/27 Ver.0.52 メールのサブジェクト内で encode されてしまうのを修正
# 1999/02/27 Ver.0.53 $locator を追加
# 1999/03/07 Ver.0.54
# 削除機能を追加
# 書込み用テキストエリアの大きさをカスタマイズ可能に
# 1999/03/08 Ver.0.55
# 1999/03/09 Ver.0.56
# MSIE での書込み用テキストエリアの大きさを調整機能
# ホスト側未読ポインタファイルへハンドル名を付加。
# 未読ポインタファイルに互換性がありません。いちど空にしてください。
# 1999/03/16 Ver.0.57
# 1999/03/17 Ver.0.58 メールの形式をシンプルに変更しました。
# 1999/03/18 Ver.0.59 bugfix
# 1999/03/23 Ver.0.60 オプション $pre, $mlist を追加
# 1999/03/24 Ver.0.61 メール配信先の include
# 1999/03/25 Ver.0.62
# 1999/03/26 Ver.0.63
# 1999/03/26 Ver.0.64 本文中の http アドレスの誤判定を調整
# 1999/03/26 Ver.0.65 to: $mlist を追加
# 1999/03/28 Ver.0.66 $border を追加
# 1999/04/16 Ver.0.68
# 1999/04/18 Ver.0.69
# 1999/04/26 Ver.0.70
# 1999/04/26 Ver.0.71 bugfix
# 1999/05/05 Ver.0.72 削除の動作を改善
# 1999/05/18 Ver.0.73 削除の範囲の bugfix 午前中に誤動作していました。
# 1999/09/01 Ver.0.74 2000 年問題への対応
# 1999/11/24 Ver.0.75 bugfix
# 1999/11/26 Ver.0.76 bugfix
# 1999/12/14 Ver.0.77 Date ヘッダーを追加し、カスタマイズ用変数 $timezone を追加
# 1999/12/19 Ver.0.78 サーチ用
# 1999/12/20 Ver.0.81
# 2000/01/06 Ver.0.82
# 2000/01/07 Ver.0.83
# 2000/01/20 Ver.0.84
# 2000/01/21 Ver.0.85 整形済モードを追加
# 2000/01/21 Ver.0.86 $body を追加
# 2000/01/26 Ver.0.87 bugfix
# 2000/01/29 Ver.0.88 書きこみ完了メッセージの処理を変更
# 2000/01/30 Ver.0.89 公開版
# 2000/03/19 Ver.0.90 当日と１日前のメッセージを削除できるよう変更
# 2000/05/11 Ver.0.91
# Mail のヘッダーへ追加 MIME-Version,Content-Type,Content-Transfer-Encoding
# 2000/07/30 Ver.0.92
# 2000/12/10 Ver.0.93
# 2000/12/11 Ver.0.94 MSIE 対応，暫定対策
# 2000/12/13 Ver.0.95 MSIE 対応，暫定対策
# 2000/12/20 Ver.0.96 Content-Type text/html; charset=Shift_JIS を追加
# 2000/12/20 Ver.0.98
# 2001/10/23 Ver.0.99 Locate にも、charset=Shift_JIS を追加
#
$copyright ='掲示板 Ver.0.99 Copyright (C) 1998-2000 gama';
# Copyright (C) 1998-2000 がま <gama@mvg.biglobe.ne.jp>
# http://www2d.biglobe.ne.jp/~gama/cgi/index.cgi
#
# ---------------------------------------------------------------------
# メール配信モード
# $webmaser か @mailgr が設定されている時
#
# @mailgr 送付先のリスト
# 'include:ファイル名'
# を設定することにより、ファイルから読み込まれる。
#
# $cc @mailgr への送信方法の指定 To,Cc,Bcc
#
# $webmaster が設定されている時
# $webmaster と @mailgr へ配信される。
#
# From: $from で指定されたアドレス
# $from を省略した場合は、$webmaster
# To: $webmaster で指定されたアドレス
# Reply-to： 書き込んだ人のアドレス
#
# ---------------------------------------------------------------------
# メーリングリストモード
#
# $mlist が設定されている場合
#
# $webmaster, @mailgr, $from の設定は無視されます。
#
# $pre =1 の設定を推奨しますが必須ではありません。
#
# From: 書き込んだ人のアドレス
# Reply-to： $mlist で指定されたアドレス
#
# メーリングリストとしての機能は別途有償で提供されています。
#
# ---------------------------------------------------------------------
$body ='<BODY BGCOLOR="#FFFFFF">';
$cc ='Bcc'; # グループメールの指定 'Cc' or 'Bcc' or 'To'
$q_char ='》'; # 引用マーク
$m_mode ='p'; # 書込みの method p: post g: get
$u_mode =''; # 書込み
$delmsg = 1; # 削除機能 0:なし 1:あり
$d_mode =''; # 削除モード
$r_mode =''; # 参照モード
$welcome = 1; # 歓迎メッセージ 0:なし 1:あり
$delmsg = 1; # 削除機能 0:なし 1:あり
$chkurl = 1; # url のチェック 0:なし 1:あり
$useflock = 1; # flock 使用 0:なし 1:あり
# ---------------------------------------------------------------------
# 検索機能は限定リリース中です。いろいろと矛盾が生じる場合があります。
$usesrch = 0; # 検索機能使用 0:なし 1:あり
$idxfile = 'msgdb.dat'; # メッセージ検索用インデックス
# ---------------------------------------------------------------------
$ENV{'TZ'} = 'JST-9'; # timezone の指定
$timezone = '+0900 (JST)';# メールのヘッダー用のタイムゾーン
$debug = 0; # debug 用フラグ
# ---------------------------------------------------------------------
$usepfile = 0; # 未読ポインタファイル使用 0:なし 1:あり
# 注意！
# $usepfile は個別の UserID でアクセス制限されている場合だけ使用できる。
# BIGLOBE では使用できない。
# また @guests にホスト側で管理しない ID を列挙できる。
# ---------------------------------------------------------------------
$form_rows = 20; # 書込み用テキストエリア 行数
$form_cols = 80; # 書込み用テキストエリア 桁数
# ---------------------------------------------------------------------
require 'bbs.env'; # 環境設定、カスタマイズ用
require 'getcode.pl'; # 改造版 getcode
require 'jcode.pl'; # jcode
require 'chkurl.pl' if $chkurl; # chkurl
require 'k2k.pl' if $usesrch; # k2k
# ---------------------------------------------------------------------
$file ="$msgdir/$filehead";
# ---------------------------------------------------------------------
$LOCK_SH = 1; # 共有ロック
$LOCK_EX = 2; # 排他的にロック
$LOCK_NB = 4; # ブロックしない
# ---------------------------------------------------------------------
{
# MSIE は、# 書込み用テキストエリア 桁数 を調整 ------------------
if ( $ENV{'HTTP_USER_AGENT'} =~ /^Mozilla.*compatible; MSIE / ) {
$form_cols = int($form_cols *1);
}
$|=1;
# YY/MM/DD hh:mm ------------------------------------------------------
my($sec,$min,$hour,$mday,$mon,$year,$wday)=localtime;
$time = sprintf("%2.2d\/%2.2d\/%2.2d %2.2d:%2.2d",
$year%100,$mon+1,$mday,$hour,$min );
# mail ヘッダー内の Date-----------------------------------------------
# 10 Aug 2000 12:34:56 +GMT ;RFC1123 など
# Wdy, 10-Aug-2000 12:34:56 GMT ;RFC822 では Wdy は省略可なのだが...
# Date: Tue, 16 Nov 1999 06:34:15 +0900 (JST) :NN4.5 での例
#
$mail_date =sprintf("Date: %s, %2.2d %s %4.4d %2.2d:%2.2d:%2.2d %s",
&getweek($wday),$mday,&getmonth($mon),$year+1900,
$hour,$min,$sec,$timezone);
# ---------------------------------------------------------------------
if ( $ENV{'CONTENT_TYPE'} eq "application/x-www-form-urlencoded") {
read(STDIN, $in, $ENV{'CONTENT_LENGTH'});
} else {
$in=$ENV{'QUERY_STRING'};
}
($cmd,undef) = split('&',$in);
if ($cmd =~ /=/ ){
my(@pairs) = split('&', $in); #
foreach $pair (@pairs) {
my($name, $value) = split('=', $pair);
unless ($FORM{$name}) {
$FORM{$name} = &str_decode_from_form($value);
} else {
$FORM{$name} = $FORM{$name}.','.&str_decode_from_form($value);
}
}
$cmd = $FORM{'cmd'};
$name = $FORM{'Name'};
$email = $FORM{'E_mail'};
$hp = $FORM{'HomePage'};
$title = $FORM{'Title'};
$comment = $FORM{'Comment'};
$pre_mode = $FORM{'pre_mode'};
$ml_header = $FORM{'ml_header'};
$keyword = $FORM{'Keyword'};
}
# ---------------------------------------------------------------------
&set_mode;
# ---------------------------------------------------------------------
&get_lastno; # 発言 # のカウント
# -----------------------------------------------------------------------
if ($u_mode) {
&write_bbs;
} elsif ($s_mode and $usesrch) {
&get_cookie; # cookie
&srch_msg;
} elsif ($cmd =~ /i/ and $usesrch) {
&gen_idx;
} elsif ($d_mode eq 'z' ) {
&get_cookie; # cookie
&delete_msg;
} else {
&get_cookie; # cookie
&read_bbs;
}
exit;
}
# mode の設定 --------------------------------------------------------
# t タイトル表示
# m 内容表示
# f 発言順
# b 逆順
# r レスポンスの書込み
# n 未読処理
# w 書込み FORM のみ
# x 書込み完了メッセージ
# u FORM からの書込み
# d 削除モード
# c 削除確認！
# z 削除！
# s 検索
# i 検索用インデックス作成
sub set_mode {
$no = $cmd;
$no =~ s/[a-z]*//;
if ( $cmd =~ /([dcz])/ ) { # 削除
$d_mode = $1;
}
if ( $cmd =~ /([tm])/ ) {
$r_mode = $1;
} elsif ( $c_r_mode ) {
$r_mode = $c_r_mode;
}
if ( $cmd =~ /([fb])/ ) {
$o_mode = $1;
} elsif ( $c_o_mode ) {
$o_mode = $c_o_mode;
}
if ( $cmd =~ /r/ ) { # Responce to $no
$r_no = $no;
}
if ( $cmd =~ /u/ ) {
$u_mode = 'u';
$cmd =~ s/u//;
}
if ( $cmd =~ /s/ ) {
$s_mode = $FORM{'srchmode'};
}
if ( $no eq '' && $cmd eq '' ) {
$cmd = $cmd . "n"; # 未読処理モードを追加
}
if ( $c_point < 1 ) {
$c_point = 1;
}
# -----------------------------------------------------------------------
if ($r_mode eq 'm' ) { # m 内容表示
$per_scr = $m_per_scr; # msg 表示数
} else {
$per_scr = $t_per_scr; # タイトル表示数
}
# -----------------------------------------------------------------------
&set_pre;
}
# ---------------------------------------------------------------------------
sub set_pre {
if ($pre_mode eq 'off') {
undef $pre;
undef $spre;
} elsif ( ($pre_mode eq 'on') or $pre or $ml_header) {
$pre ='<PRE>';
$spre ='</PRE>';
$pre_mode = 'on';
} else {
$pre_mode = 'off';
}
}
# ---------------------------------------------------------------------------
sub get_lastno {
# 発言 # のカウント -----------------------------------------------------
open(FCTR,"<$fctr");
flock(FCTR,$LOCK_SH) if $useflock; # 共有ロック
$last_no=<FCTR>;
close(FCTR);
chomp($last_no);
}
# 削除 ---------------------------------------------------------------
sub delete_msg {
unless ($delmsg) {
&err_html("削除できません。(delmsg disable)");
exit;
}
unless (open(MSG, "+<$file$no")) { # open
&err_html("指定されたメッセージを読めません。($file$no.)");
exit;
}
flock(MSG,$LOCK_EX) if $useflock; # 排他ロック
my(@temp)=<MSG>;
if (¬_author($temp[1])) {
&err_html("削除できません。(not author)");
exit;
}
seek(MSG, 0, 0);
print(MSG "<!-- delete at $time by $ENV{'REMOTE_USER'}:$name <$email>");
print MSG @temp;
print(MSG " -->\n");
close(MSG);
my($nextcmd)= "$o_mode$r_mode" .'n'; #ex9
print "Content-type: text/html\n\n";
print <<END;
<HTML><HEAD><TITLE>削除されました</TITLE></HEAD>
$body
<H2>削除されました</H2>
<HR><BLOCKQUOTE>
@temp
<CENTER>
<FORM METHOD="GET" ACTION="$cgi_name">
<INPUT TYPE="hidden" NAME="cmd" VALUE="$nextcmd">
<INPUT TYPE="submit" VALUE="戻る"></FORM>
</CENTER>
</BLOCKQUOTE><HR>
</BODY></HTML>
END
# MAIL -----------------------------------------------------------------
&send_mail($no, '発言者削除', '', '');
}
# 削除権限のチェック ------------------------------------------------------
sub not_author{
#★タイトル の行から E-Mail, 日付を取出す
my($tit) = $_[0];
$tit =~ /.*<A HREF=\"mailto:(.*?)\".*(\d\d\/\d\d\/\d\d).*/;
my($msg_email) =$1;
my($msg_date) =$2; # YY/MM/DD
unless ($msg_email eq $email) { # e-mail addr の一致を確認
return 1; # not author
}
# ----------------------------------------------------------------------
# 昨日に設定
my($sec,$min,$hour,$mday,$mon,$year)=localtime(time);
my($date0) = sprintf("%2.2d\/%2.2d\/%2.2d", $year%100,$mon+1,$mday);
($sec,$min,$hour,$mday,$mon,$year) =localtime(time-60*60*24);
my($date1) = sprintf("%2.2d\/%2.2d\/%2.2d", $year%100,$mon+1,$mday);
# 日付が一致したとき
if ( $date0 eq $msg_date ) {
return 0; # OK
}
# 日付が１日前のとき
if ( $date1 eq $msg_date ) {
return 0; # OK
}
return 1; # NG 削除期限を超過
}
# 書込 --------------------------------------------------------------------
sub write_bbs {
# jcode -------------------------------------------------------
local($jstr)=join(' ', $title, $name, $comment);
local($match, $icode) = &getcode'getcode(*jstr);
unless ($icode) {
if ( $ENV{'HTTP_USER_AGENT'}=~ /Mac|Win/) {
$icode = 'sjis';
} else {
$icode = 'euc';
}
}
if ($icode ne 'sjis') {
&jcode'convert(*title, 'sjis', $icode );
&jcode'convert(*name, 'sjis', $icode );
&jcode'convert(*comment, 'sjis', $icode );
}
# -------------------------------------------------------------
$name = &str_conv_for_html($name);
$title = &str_conv_for_html($title);
$comment = &str_conv_for_html($comment);
chomp($name);
chomp($title);
# -------------------------------------------------------------
unless ($name) { # Nickname がないとき Error
&err_html("ニックネームが入力されていません。");
exit;
}
if ($email eq $dflt_email) { # email addr 記入なし
$email = "";
}
if ($need_email ) {
unless ($email) { # email addr がないとき Error
&err_html("E-Mail アドレスが入力されていません。");
exit;
}
unless ($email =~ /^[\w\-\_\.]+@[\w\-\_]+(\.[\w\-\_]+)+$/ ) {
&err_html("E-Mail アドレスの形式がエラーになりました。");
exit;
}
}
if ( $hp eq $dflt_hp ) { # Homepage URL 記入なし
$hp = '';
}
if ( $hp ne '' ) { # HomePage の URL のチェック
my($err) = &check_url($hp);
if ($err) {
&err_html("入力されたアドレスへアクセスできませんでした。<BR>"
."$hp<BR>$err<BR>");
exit;
}
}
unless ( $title ) { # title がないときは Error を表示
&err_html("タイトルが入力されていません。\n");
exit;
}
$title =~ s/#(\d+)/<A HREF=\"${cgi_name}?cmd=${o_mode}${r_mode}$1\">#$1<\/A>/;
# 本文内の http アドレス -----------------------------------------------
$comment=~ s/(http:\/\/\S+?)(\s| |$)/<A HREF=\"$1\">$1<\/A>$2/g; # 空白文字以外
my($temp) = $comment;
while ( $temp=~ /(<A HREF=\".+?\">)(.*)/ ) {
my($url) = $1; # マッチした文字列
$temp=$2; # マッチしたのより後ろ
$url =~ s/.*<A HREF=\"(.+?)\">.*/$1/;
my($err) = &check_url($url);
if ($err) {
&err_html( "本文中に記述されたアドレスへアクセスできませんでした。<BR>"
."$url<BR>$err<BR>" );
exit;
}
}
# 発言 # のカウント ----------------------------------------------------
unless (open(FCTR,"+<$fctr")) {
&err_html( "内部エラー<BR>"
."$fctr が open できません。（設置の状態を確認してください）");
exit;
}
flock(FCTR,$LOCK_EX) if $useflock; # 排他ロック
my($old_no)=<FCTR>;
chomp($old_no);
# 新メッセージのタイトルと内容 -----------------------------------------
$tit_name .= $title.' '.$name;
$msghead = "$tit_name<BR>\n"
."★内容<BR>\n$pre";
$msgbody = "$comment\n";
unless ($pre) {
$msgbody =~ s/\n/<BR>\n/g; # 改行を <BR> へ
} else {
$msgbody .= "$spre\n";
}
if ($hp) {
$msgbody .= sprintf("<A HREF=\"%s\">%s</A><BR>\n", $hp, $hp);
}
$msgbody .= "<HR WIDTH=90%>\n";
if ($locator) { # $locator の処理
$msgbody =~ s/(<A HREF=\")http/$1$locator/g;
}
# ２重書込のチェック ---------------------------------------------------
if ( open(OLDMSG,"$file$old_no") ) {
flock(OLDMSG,$LOCK_SH) if $useflock; # 共有ロック
<OLDMSG>; # ２行分読み飛ばし
<OLDMSG>;
my($oldmsg);
while (<OLDMSG>) {
$oldmsg .=$_;
}
if ($oldmsg eq $msghead.$msgbody) {
&err_html( "このメッセージは書込済です。");
exit;
}
close OLDMSG;
}
# 発言 # のカウントアップ ----------------------------------------------
my($new_no) = $old_no + 1;
seek(FCTR, 0, 0);
printf(FCTR "%d", $new_no);
# COOKIE----------------------------------------------------------------
&set_cookie_name;
# ----------------------------------------------------------------------
my($t_name) = $name;
if ( $email ne '' ) {
$t_name = $email;
$t_name =~ s/^([\w\-\_\.]+)@[\w\-\_\.]+$/$1/;
$t_name = "<A HREF=\"mailto:$email\">$t_name</A>";
}
$bbsmsg = sprintf("#%s %s<BR>\n", $new_no,$bbsname)
.sprintf("★タイトル (%s) %s<BR>\n",$t_name,$time)
.$msghead
.$msgbody;
# BBS ------------------------------------------------------------------
unless (open(BBS,">$file$new_no")) {
&err_html("Can't open $file$new_no.<BR>"
."ディレクトリ($msgdir/)とパーミッション(777)を確認してください。");
exit;
}
flock(BBS,$LOCK_EX) if $useflock; # 排他ロック
print(BBS $bbsmsg); # ここで書き込み！
close(FCTR);
close(BBS);
# 古いメッセージを削除 -------------------------------------------------
$delno=$new_no - $msg_max;
unlink("$file$delno"); # 古いメッセージを一つ削除
$delno=$delno - 1;
unlink("$file$delno"); # 念のため古いメッセージをもう一回削除
# MAIL -----------------------------------------------------------------
&send_mail($new_no, $title, $name, $msgbody);
# Location -------------------------------------------------------------
my($nextcmd)= "$o_mode$r_mode" .'nx';
print "Location: ${cgi_name}?cmd=$nextcmd\n\n";
# print "Location: ${cgi_name}?cmd=$nextcmd; charset=Shift_JIS\n\n";
}
# --------------------------------------------------------------------------
sub send_mail {
my($no) = $_[0];
my($subj) = &str_detag($_[1]); # tag を除去
my($name) = &str_detag($_[2]); # tag を除去
my($msg) = &str_detag($_[3]); # tag を除去
# MAIL -----------------------------------------------------------------
if ( $mlist or $webmaster or @mailgr) {
$msg =~ s/^#/\$/; # pcvan の log への配慮
unless (open(MAIL, "| $nkf -S | $sendmail -t")) {
&err_html("内部エラー<BR>"
."sendmail が open できません。（設置の状態を確認してください）");
exit;
}
if ($mlist) {
print(MAIL "From: \"$name\" <$email>\r\n");
print(MAIL "To: $mlist\r\n");
print(MAIL "Reply-To: $mlist\r\n");
} else {
if ($from) {
print(MAIL "From: $from\r\n");
} else {
print(MAIL "From: $webmaster\r\n");
}
print(MAIL "To: $webmaster\r\n");
if ($email) {
print(MAIL "Reply-To: \"$name\" <$email>\r\n");
}
$subj .= ' '.$name;
foreach $member (@mailgr) {
if ($member =~ /^include:(.*)/i) {
open(MAILGR,"$1");
flock(MAILGR,$LOCK_SH) if $useflock; # 共有ロック
while (<MAILGR>) {
chomp;
print(MAIL "$cc: $_\r\n");
}
close(MAILGR);
} else {
print(MAIL "$cc: $member\r\n");
}
}
}
print(MAIL $mail_date,"\r\n");
print(MAIL "MIME-Version: 1.0\r\n");
print(MAIL "Content-Type: text/plain; charset=ISO-2022-JP\r\n");
print(MAIL "Content-Transfer-Encoding: 7bit\r\n");
print(MAIL "Subject: [$bbsname $no] $subj\r\n","\r\n");
unless ($d_mode eq 'z') {
print(MAIL $msg );
print(MAIL "\n\n");
print(MAIL 'Re:#', $no, ' http://'
, $ENV{'SERVER_NAME'}, $ENV{'SCRIPT_NAME'},
, '?cmd=mr', $no );
}
close(MAIL);
}
}
# 検索用 インデックスの作成------------------------------------------------------
sub gen_idx {
$idxwk =$idxfile.'.tmp';
unless (open(IDXWK,"+<$idxwk") or open(IDXWK,">$idxwk")) {
&err_html("作業用ファイルが開けませんでした。($idxwk)");
exit;
}
if ($useflock) {
unless (flock(IDXWK, $LOCK_EX+$LOCK_NB )) { # ロック ブロックしない
&err_html("作業用ファイルが使用中のため処理できませんでした。($idxwk)");
exit;
}
}
# -----------------------------------------------------------------------
&html_head;
&html_next;
print "<HR>\n";
print "<BLOCKQUOTE>\n";
print "<H3>＊＊＊＊ $bbsname ＊＊＊＊</H3>\n";
print "検索用インデックス作成<br>\n";
# 逆順 新しいものが上
print "<HR WIDTH=90%>\n";
seek(IDXWK, 0, 0); # ファイルの先頭に移動
truncate(IDXWK, 0); # ファイルを空にする。
$no = $last_no; # 発言 # のカウント
print "作成開始<br>\n";
print "作成中 #$no<br>\n";
while ( $no > 1 ) {
print "作成中 #$no<br>\n" if $no%100 == 0;
if (my($dstr)=&get_dstr($no--)) {
print IDXWK $dstr,"\n";
}
}
print "作業用ファイル作成完了<br>\n";
# -----------------------------------------------------------------------
unless (open(MSGDB,">>$idxfile")) {
print "インデックスファイルが開けませんでした。($idxfile)<br>\n";
&html_next;
&foot_html;
return;
}
if ($useflock) {
flock(MSGDB, $LOCK_EX);
}
print "インデックスファイルへ書込中 ($idxwk -> $idxfile)<br>\n";
seek(IDXWK, 0, 0); # ファイルの先頭に移動
seek(MSGDB, 0, 0); # ファイルの先頭に移動
truncate(MSGDB, 0); # ファイルを空にする。
while (<IDXWK>) {
print MSGDB;
}
close(MSGDB);
close(IDXWK);
# -----------------------------------------------------------------------
print "作成完了<br>\n";
print "</BLOCKQUOTE>\n";
print "<HR>\n";
&html_next;
&foot_html;
}
# ---------------------------------------------------------------------------
sub get_dstr {
my($no)=shift; # サブルーチンの引数を
unless (open(MSG,"<$file$no")) {
return;
}
flock(MSG,$LOCK_SH) if $useflock; # 共有ロック
$temp=$/; # Input Record Separator を退避
undef $/; # Input Record Separator
my($dstr)=<MSG>; # 丸ごと入力
close(MSG); # <<<<<<<<< close
$/=$temp; # Input Record Separator を戻す
$dstr =~ s/\n//g; #改行 を取り除く
$dstr =~ s/\Q$bbsname\E//g; #ボード名称 を取り除く
$dstr =~ s/\Q★タイトル\E//g; #★タイトル を取り除く
$dstr =~ s/\Q★内容\E//g; #★内容 を取り除く
$dstr =~ s/\Q$q_char\E//g; #引用マーク を取り除く
$dstr = &str_detag($dstr); #タグ を取り除く
$dstr = &k2k'k2k($dstr);
$dstr =~ s/\s//g; #空白文字 を取り除く
return($dstr);
}
# 検索 ---------------------------------------------------------------------
sub srch_msg {
# -----------------------------------------------------------------------
# $no 指定開始位置
$no = $last_no - $per_scr +1; # $last_no 最新のメッセージ
if ( $no < 1 ) {
$no = 1;
}
$page_top = $no; # $page_top 頁で最古のメッセージ
$page_bottom = $no + $per_scr -1; # $page_bottom 頁で最新のメッセージ
if ( $page_bottom > $last_no ) {
$page_bottom = $last_no;
}
# -----------------------------------------------------------------------
&html_head;
&html_next;
print "<HR>\n";
print "<BLOCKQUOTE>\n";
print "<H3>＊＊＊＊ $bbsname ＊＊＊＊</H3>\n";
print "<HR WIDTH=90%>\n";
if ( $r_mode eq "t" ) {
print "<PRE>";
}
$keyword = &k2k'k2k($keyword) if $usesrch;
open(MSGDB,"<$idxfile");
flock(MSGDB,$LOCK_SH) if $useflock; # 共有ロック
my($no) = $last_no;
$db_rec = <MSGDB>;
$db_no = $db_rec;
$db_no =~ s/^#(\d+).*/$1/;
while ( $db_no < $no ) {
my($dstr) = &get_dstr($no--); # メッセージから
&srch_main($dstr);
}
&srch_main($_);
while (<MSGDB>) {
chomp;
&srch_main($_); # データベースから
}
if ( $r_mode eq "t" ) {
print "</PRE><HR WIDTH=90%>\n";
}
print "</BLOCKQUOTE>\n";
print "<HR>\n";
&html_next;
&form_html;
&foot_html;
}
# ---------------------------------------------------------------------------
sub srch_main {
my($dstr)=shift; # サブルーチンの引数を
my(@words) = split(' ', $keyword);
my($found) = 0;
if ($s_mode eq 'OR' ) { # OR
foreach $aword (@words) {
if ($dstr =~ /\Q$aword\E/ ) { # $aword 中のメタ文字を無効に
$found = 1;
last;
}
}
} else { # AND
$found = 1;
foreach $aword (@words) {
unless ($dstr =~ /\Q$aword\E/ ) { # $aword 中のメタ文字を無効に
$found = 0;
last;
}
}
}
unless ($found) {
return(0);
}
my($no) = $dstr;
$no =~ s/^#(\d+).*/$1/;
&read_main($no);
return(1);
}
# 読む ---------------------------------------------------------------------
sub read_bbs {
# -----------------------------------------------------------------------
# $no 指定開始位置
if ( $c_point > 1 && $cmd =~ /n/ ) { # $c_point 未読ポインタ
$no = $c_point+1;
}
unless ( $no ) {
$no = $last_no - $per_scr +1; # $last_no 最新のメッセージ
}
if ( $no < 1 ) {
$no = 1;
}
$page_top = $no; # $page_top 頁で最古のメッセージ
if ( $cmd =~ /[rc]/ ) { # response or 削除 'C'
$page_bottom = $no;
} else {
$page_bottom = $no + $per_scr -1; # $page_bottom 頁で最新のメッセージ
if ( $page_bottom > $last_no ) {
$page_bottom = $last_no;
}
}
# Cookie --------------------------------------------------------------
if ( $r_mode eq 'm' && ( $c_point < $page_bottom or $c_point > $last_no )) {
&set_cookie_bbs;
}
# ---------------------------------------------------------------------
&html_head;
&html_next;
print "<HR>\n";
print "<BLOCKQUOTE>\n";
if ($cmd =~ /[d|c]/ ) {
$del_msg_ctr =0;
if ($page_top == $page_bottom ) {
$r_mode = 'm';
print "<TABLE><TR>\n";
print "<TD><H3>このメッセージを削除します。</H3></TD>\n";
&next_b('z'.$page_bottom, '削除'); # 次は、削除
print "</TR></TABLE>\n";
} else {
$r_mode = 't';
print "<H3>削除するメッセージの番号を選び、内容を確認してください。</H3>";
}
} else {
if ($cmd =~ /x/ ) {
print "<H3>書きこみました。</H3>\n";
}
print "<H3>＊＊＊＊ $bbsname ＊＊＊＊</H3>\n";
}
if ($cmd =~ /w/ ) {
&form_html;
&foot_html;
return;
}
if ( $r_mode eq "t" ) {
print "<PRE>";
}
if ( $c_point >= $last_no && $cmd =~ /n/ ) {
print "新しいメッセージは、ありません。<BR>\n";
} elsif ( $o_mode eq "f" ) { # 正順 新しいものが下
print "<HR WIDTH=90%>\n";
$no = $page_top; # page_top -> $page_bottom
while ( $page_bottom >= $no ) {
&read_main($no);
$no = $no + 1;
}
} else { # 逆順 新しいものが上
print "<HR WIDTH=90%>\n";
$no = $page_bottom; # page_bottom ... page_top
while ( $page_top <= $no ) {
&read_main($no);
$no = $no - 1;
}
}
if ( $r_mode eq "t" ) {
print "</PRE><HR WIDTH=90%>\n";
}
if ($cmd =~ /[d]/ ) {
if ( $del_msg_ctr == 0 ) {
print "<H3>削除できるメッセージがありませんでした。</H3>";
}
}
print "</BLOCKQUOTE>\n";
unless ( $cmd =~ /[rx]/) {
unless ( $c_point >= $last_no && $cmd =~ /n/ ) {
&html_next;
}
}
print "<HR>\n";
&form_html;
&foot_html;
}
# ---------------------------------------------------------------------------
sub read_main {
my($no)=$_[0]; # サブルーチンの引数を
my(@temp);
unless (open(MSG,"<$file$no")) {
return;
}
flock(MSG,$LOCK_SH) if $useflock; # 共有ロック
my($i)=0;
while (<MSG>) {
if ( /^<BR>\n/ && $i == 1 ) { # ver.006-007 データ互換
$temp[0] =~ s/\n/<BR>\n/; # ver.006-007 データ互換
} else {
s/^<HR.*?>\n//; # ver.009 データ互換
$temp[$i]=$_;
$i++;
}
}
close(MSG);
if ($temp[0] =~ /^<!-- /) {
return;
}
my($dd,$tt)=($temp[1],$temp[2]);
$tt =~ s/<BR>\n//;
if ($d_mode and ¬_author($dd)) {
return;
}
if ( $r_mode eq 't' ) { # タイトル表示
# ) YY/MM/DD をさがして日付だけを取出す。
$dd =~ s/^.*\)\s([\d\/]+)\s.*\n/ $1 /;
if ( $d_mode eq 'd' ) {
$del_msg_ctr++;
print "<a href=\"$cgi_name?cmd=c$no\">$no</A>$dd$tt\n";
} else {
print "<a href=\"$cgi_name?cmd=${o_mode}m$no\">$no</A>$dd$tt\n";
}
} else { # 内容表示
if ($last_no) { # #123/999 最新 # を付加
if ($s_mode) {
$temp[0] =~ s/^(#)(\d+)/<a href=\"$cgi_name?cmd=${o_mode}m$2\">#$2<\/A>\/$last_no/;
} else {
$temp[0] =~ s/^(#\d+)/$1\/$last_no/;
}
}
print @temp;
print "<DIV ALIGN=RIGHT><FONT SIZE=2>";
print "|<A HREF=\"$cgi_name?cmd=".$o_mode.$r_mode."r".$no."\">Re:#$no</A>|";
print "</FONT></DIV>\n";
print "<HR WIDTH=90%>\n";
if ( $cmd =~ /r/ ) {
$tt = &str_detag($tt);
$tt =~ s/^(Re:#\d+>)*//;
$title = "Re:#$no>$tt";
$title =~ s/(.+) (.+)/$1/;
foreach (@temp) {
if (/<PRE>/) {
$pre_mode="on";
&set_pre;
}
$_ = &str_detag($_); # tag を除去（最短一致）
$comment = $comment . $q_char . $_;
}
}
}
}
# ---------------------------------------------------------------------
sub get_cookie {
my(@cookie) = split("; ", $ENV{'HTTP_COOKIE'});
my($cname, $value);
foreach (@cookie) {
($cname, $value) = split("=", $_);
if ($cname eq 'NickName') {
($name,$email,$hp) = split("&",$value); # フィールド毎に分割
}
if ($cname eq 'BBS') {
if ($c_point <= 1) {
($c_point,$c_o_mode,$c_r_mode) = split("&",$value);
# フィールド毎に分割
}
}
}
$name = &str_decode_cookie($name);
$email = &str_decode_cookie($email);
$hp = &str_decode_cookie($hp);
$c_point = &str_decode_cookie($c_point);
$c_o_mode = &str_decode_cookie($c_o_mode);
$c_r_mode = &str_decode_cookie($c_r_mode);
# c_point を $pfile から読み込む --------------------------------
# 例外の user の一覧を参照する。たとえば guest は cookie だけとか
if ($usepfile) {
my($remote_user) = $ENV{'REMOTE_USER'};
unless (grep(/$remote_user/, @guests)) {
&open_pfile;
while (<PFILE>) {
if (/^$remote_user:/i ) {
chomp;
(undef,$c_point,undef) = split(':'); # 未読ポインタ
last;
}
}
}
&close_pfile;
}
}
# Set-Cookie -----------------------------------------------------------
sub set_cookie_bbs {
my($new_point);
if ($last_no < $page_bottom) {
$new_point = &str_encode_for_cookie($last_no);
} else {
$new_point = &str_encode_for_cookie($page_bottom);
}
$c_o_mode = &str_encode_for_cookie($o_mode); # o_mode : 'f','b'
$c_r_mode = &str_encode_for_cookie($r_mode); # r_mode : 't','m'
# c_point を $pfile へ書き込む -------------------------------------
if ($usepfile) {
my($remote_user) = $ENV{'REMOTE_USER'};
&open_pfile;
my($pos) = tell PFILE;
while (<PFILE>) {
if (/^$remote_user:/ ) {
chomp;
seek(PFILE, $pos, 0); # ファイルの途中の位置へ
last;
}
$pos =tell PFILE;
}
# レコードの形式 : usrid:99999999:YY/MM/DD hh:mm\n
my($sec,$min,$hour,$mday,$mon,$year)=localtime;
printf PFILE "%s:%8.8d:%2.2d\/%2.2d\/%2.2d %2.2d:%2.2d:%2.2d %-20.20s\n",
$remote_user, $new_point,
$year%100,$mon+1,$mday,$hour,$min,$sec,
$name;
&close_pfile;
}
# Set-Cookie --------------------------------------------------
# cookie の有効期限を GMT で 1000 日後に設定 60秒*60分*24時間*1000日
my($expire) = &expire_gmt(60*60*24*1000);
# path は省略値
my($cookie) ="Set-Cookie: "
."BBS=$new_point&$c_o_mode&$c_r_mode; "
."expires=$expire; "
."\n";
print $cookie;
}
# ---------------------------------------------------------------------
sub set_cookie_name {
my($t_name) = &str_encode_for_cookie($name);
my($t_email) = &str_encode_for_cookie($email);
my($t_hp) = &str_encode_for_cookie($hp);
my($new_value) = "NickName=$t_name&$t_email&$t_hp";
# 同じ値のときは、パス！
my(@cookie) = split("; ", $ENV{'HTTP_COOKIE'});
foreach (@cookie) {
if ($_ eq $new_value ) {
# まあ、有効期限が切れたらしょうがないよね(^^;;;
return;
}
}
# Set-Cookie --------------------------------------------------
# cookie の有効期限を GMT で 1000 日後に設定 60秒*60分*24時間*1000日
my($expire) = &expire_gmt(60*60*24*1000);
my($path) ='/';
my($cookie) ="Set-Cookie: "
."$new_value; "
."expires=$expire; "
."path=$path; "
."\n";
print $cookie;
}
# ---------------------------------------------------------------------
sub expire_gmt {
my($esec)=$_[0]; # サブルーチンの引数を
my($sec,$min,$hour,$day,$mon,$year,$wday)= gmtime( time+$esec );
# 10 Aug 2000 12:34:56 GMT ;RFC1123
# Wdy, 10-Aug-2000 12:34:56 GMT ;RFC822 では Wdy は省略可なのだが...
my($str) =sprintf("%s, %2.2d-%s-%4.4d %2.2d:%2.2d:%2.2d GMT",
&getweek($wday),$day,&getmonth($mon),$year+1900,
$hour,$min,$sec);
return($str);
}
# ---------------------------------------------------------------------
sub getmonth{
my($mon) =shift; # サブルーチンの引数を
my(@month) = ( "Jan","Feb","Mar","Apr","May","Jun",
"Jul","Aug","Sep","Oct","Nov","Dec" );
return($month[$mon]);
}
# ---------------------------------------------------------------------
sub getweek{
my($wday) =shift; # サブルーチンの引数を
my(@week) = ( "Sun", "Mon","Tue","Wed","Thu","Fri","Sat" );
return($week[$wday]);
}
# ---------------------------------------------------------------------
sub open_pfile {
unless (open(PFILE,"+<$pfile")) {
&err_html("未読ポインタにアクセスできませんでした。($pfile)");
exit;
}
flock(PFILE, $LOCK_EX) if $useflock; # 排他ロック
}
# ---------------------------------------------------------------------
sub close_pfile {
close(PFILE);
}
# ---------------------------------------------------------------------
sub html_head {
print "Content-type: text/html; charset=Shift_JIS\n\n";
print <<END;
<HTML>
<HEAD><META HTTP-EQUIV="Pragma" CONTENT="no-cache">
<TITLE>$bbsname</TITLE></HEAD>
$body
END
if ($welcome && $name) {
print "<H3>$name さん ようこそ！ お待ちしていました！</H3>";
}
print $head;
print "<DIV ALIGN=RIGHT>$time</DIV>";
}
# ---------------------------------------------------------------------
sub html_next {
print "<CENTER>\n<TABLE><TR>";
$back_no = $page_top - $per_scr; # $page_top 頁で最古の No.
$oldest_no = $last_no - $msg_max + 1;
if ( $oldest_no < 1 ) {
$oldest_no = 1;
}
if ( $back_no < 1 ) {
$back_no = 1;
}
if ( $back_no < $oldest_no ) {
$back_no = $oldest_no;
}
if ( $back_no < $page_top ) {
&next_b("$o_mode$r_mode$back_no", "#$back_no -");
}
print <<END;
<TD><FORM METHOD="GET" ACTION="$back_html">
<INPUT TYPE="submit" VALUE="終了"></FORM></TD>
END
if ( $r_mode eq "m" ) {
&next_b( $o_mode."t".$page_top, 'タイトル一覧');
} else {
&next_b( $o_mode."m".$page_top, '内容表示');
}
$foword_no = $page_bottom + 1; # $page_bottom 頁で最新の No.
if ( $last_no > $foword_no ) {
&next_b( $o_mode.$r_mode.$foword_no, "#$foword_no -");
}
&next_b( $o_mode.$r_mode, '最新の '.$per_scr.' メッセージ');
if ( $o_mode eq "b" ) {
&next_b('f'.$r_mode.$page_top, '表示順変更');
} else {
&next_b('b'.$r_mode.$page_top, '表示順変更');
}
# dt 削除のタイトル表示
# c 削除の確認 c999
# z 削除
if ( $delmsg ) {
if ($d_mode eq 'c') {
} elsif ($d_mode ne 'd') {
&next_b("dt", '削除'); # 次は、削除用一覧
}
}
my($andchked)='CHECKED';
my($orchked) ='';
if ( $s_mode eq "OR" ) {
$andchked ='';
$orchked ='CHECKED';
}
print "</TR>";
if ($usesrch) {
print <<END;
<TR>
<TD COLSPAN=6>
<FORM METHOD="$method" ACTION="$cgi_name">
<INPUT TYPE="hidden" NAME="cmd" VALUE="s$o_mode$r_mode">
<INPUT TYPE="text" SIZE=30 NAME="Keyword" VALUE="$FORM{'Keyword'}">
<INPUT TYPE="submit" VALUE="検索">
<INPUT TYPE="radio" NAME="srchmode" VALUE="AND" $andchked >AND
<INPUT TYPE="radio" NAME="srchmode" VALUE="OR" $orchked >OR
</FORM>
</TD>
</TR>
END
}
print "</TABLE></CENTER>";
}
# ---------------------------------------------------------------------
sub next_b {
local($arg,$msg)=@_; # サブルーチンの引数を
print <<END;
<TD><FORM METHOD="GET" ACTION="$cgi_name">
<INPUT TYPE="hidden" NAME="cmd" VALUE="$arg">
<INPUT TYPE="submit" VALUE="$msg"></FORM></TD>
END
}
# ---------------------------------------------------------------------
sub form_html {
if ($d_mode) {
return;
}
$title =~ s/<.*?>//ge; # tag を除去 （最短一致）
$comment =~ s/<.*?>//ge; # tag を除去 （最短一致）
unless ( $hp ) {
$hp=$dflt_hp;
}
unless ( $email ) {
$email=$dflt_email;
}
my($r);
print $border;
if ($cmd =~ /r/ ) {
print "Response to #$r_no<BR><BR>\n";
$r="r$r_no";
}
my($email_need)='（省略不可）';
unless ($need_email) {
$email_need='（よろしければ）';
}
if ($m_mode eq 'g') {
$method = 'GET';
} else {
$method = 'POST';
}
my($pre_on_check,$pre_off_check);
if ($pre) {
$pre_on_check ='CHECKED';
} else {
$pre_off_check ='CHECKED';
}
print <<END;
<FORM METHOD="$method" ACTION="$cgi_name">
<INPUT TYPE="hidden" NAME="cmd" VALUE="u$o_mode$r_mode$r">
おなまえ（ニックネーム）<BR>
<INPUT TYPE="text" SIZE=50 NAME="Name" VALUE="$name"><BR>
メールアドレス$email_need<BR>
<INPUT TYPE="text" SIZE=50 NAME="E_mail" VALUE="$email"><BR>
ホームページアドレス（よろしければ）<BR>
<INPUT TYPE="text" SIZE=50 NAME="HomePage" VALUE="$hp"><BR><BR>
★タイトル<BR>
<INPUT TYPE="text" SIZE=50 NAME="Title" VALUE="$title"><BR>
★内容<BR>
<TEXTAREA NAME="Comment" ROWS="$form_rows" COLS="$form_cols" >$comment</TEXTAREA><BR>
<INPUT TYPE="radio" NAME="pre_mode" VALUE="on" $pre_on_check >整形済入力（空白、改行が有効）
<INPUT TYPE="radio" NAME="pre_mode" VALUE="off" $pre_off_check >未整形入力（改行のみ有効）
<CENTER>
<INPUT TYPE="submit" VALUE="書込">
<INPUT TYPE="reset" VALUE="取消">
</CENTER>
</FORM>
<HR><!-- ===================================== -->
END
}
# ---------------------------------------------------------------------
sub foot_html {
print <<END;
$tail
<FONT SIZE=-1>
<A HREF="http://www2d.biglobe.ne.jp/~gama/cgi/index.cgi">$copyright</a>
</FONT>
<BR><BR>
</BODY></HTML>
END
}
# ---------------------------------------------------------------------
sub err_html {
print "Content-type: text/html\n\n";
my($errmsg)=$_[0]; # サブルーチンの引数
my($errtit,$errback);
if ($d_mode) {
$errtit='削除できませんでした。';
$errback=$cmd;
$errback=~ s/z/c/;
} elsif ($cmd =~ /i/ ) {
$errtit='エラーが発生しました。';
$errback=$cmd;
$errback=~ s/i//;
} else {
$errtit='書き込みにエラーがありました';
$errback=$cmd;
}
print <<END;
<HTML><HEAD><TITLE>$errtit</TITLE></HEAD>
$body
<H2>$errtit</H2>
<HR><!-- ===================================== -->
$errmsg
<CENTER>
<FORM METHOD="GET" ACTION="$cgi_name">
<INPUT TYPE="hidden" NAME="cmd" VALUE="$errback">
<INPUT TYPE="submit" VALUE="戻る"></FORM>
</CENTER>
<HR><!-- ===================================== -->
END
&form_html;
&foot_html;
}
# ---------------------------------------------------------------------
sub str_detag {
local($str)=$_[0]; # サブルーチンの引数を
$str=~ s/<.*?>//ge; # tag を除去 （最短一致）
$str=~ s/&/&/g; # &
$str=~ s/</</g; # <
$str=~ s/>/>/g; # >
return($str);
}
# ---------------------------------------------------------------------
sub str_decode_from_form {
local($str)=$_[0]; # サブルーチンの引数を
$str=~ s/\+/ /g; # + を space へ
$str=~ s/%(..)/pack("c",hex($1))/ge; # decode
$str=~ s/\r//g; # LF を削除
return($str);
}
# ---------------------------------------------------------------------
sub str_conv_for_html {
local($str)=$_[0]; # サブルーチンの引数を
$str=~ s/&/&/g; # &
$str=~ s/</</g; # <
$str=~ s/>/>/g; # >
return($str);
}
# ---------------------------------------------------------------------
sub str_decode_cookie {
local($str)=$_[0]; # サブルーチンの引数を
$str=~ s/^\w+=//; # = までを削除・・・
$str=~ s/%(..)/pack("c",hex($1))/ge; # decode
return($str);
}
# ---------------------------------------------------------------------
sub str_encode_for_cookie {
local($str)=$_[0]; # サブルーチンの引数を
$str=~ s/ /%20/g; # encode
$str=~ s/,/%2C/g; # encode
$str=~ s/;/%3B/g; # encode
$str=~ s/&/%26/g; # encode
return($str);
}
# ---------------------------------------------------------------------
# check_url URL をアクセスしてチェック
# エラーメッセージを返す
# ---------------------------------------------------------------------
sub check_url {
my($url)=$_[0]; # サブルーチンの引数を
unless ($chkurl) {
return (0); # OK
}
my($r)= &chkurl'chkurl($url);
if ($r =~ /\s*(301|302)\s*/ ) {
$r = &chkurl'chkurl($url.'/');
}
if ($r =~ /200/ ) {
return 0; # OK
}
return $r; # NG
}