\n"); $Page->Print("$title\n"); $Page->Print("\n"); } } #------------------------------------------------------------------------------------------------------------ # # r.cgi内容出力 # ------------------------------------------------------------------------------------- # @param なし # @return なし # #------------------------------------------------------------------------------------------------------------ sub PrintReadContents { my ($Sys, $Page) = @_; my ($work, @elem, $i); $work = $Sys->{'SYS'}->Get('OPTION'); @elem = split(/\,/, $work); # 1表示フラグがTRUEで開始が1でなければ1を表示する if ($elem[3] == 0 && $elem[1] != 1) { PrintResponse($Sys, $Page, 1, 0); } # 残りのレスを表示する for ($i = $elem[1] ; $i <= $elem[2] ; $i++) { PrintResponse($Sys, $Page, $i, $elem[2]); } } #------------------------------------------------------------------------------------------------------------ # # r.cgiフッタ出力 # ------------------------------------------------------------------------------------- # @param なし # @return なし # #------------------------------------------------------------------------------------------------------------ sub PrintReadFoot { my ($Sys, $Page) = @_; my ($oSYS, $Conv, $bbs, $key, $ver, $rmax, $pathNext, $pathPrev); my ($baseBBS, $pathBBS, $pathAll, $pathLast, $resNum, $cgipath); # 前準備 $oSYS = $Sys->{'SYS'}; $Conv = $Sys->{'CONV'}; $bbs = $oSYS->Get('BBS'); $key = $oSYS->Get('KEY'); $ver = $oSYS->Get('VERSION'); $rmax = $oSYS->Get('RESMAX'); $cgipath = $oSYS->Get('CGIPATH'); $baseBBS = $oSYS->Get('BBS_ABS'); $pathBBS = $Conv->MakePath("$baseBBS/i/index.html"); $pathAll = $Sys->{'CONV'}->CreatePath($oSYS, 1, $bbs, $key, '1-10n'); $pathLast = $Sys->{'CONV'}->CreatePath($oSYS, 1, $bbs, $key, 'l10'); $resNum = $Sys->{'DAT'}->Size(); # 前、次番号の取得 { my ($st, $ed, $b1, $b2, $f1, $f2); $st = $oSYS->GetOption(2); $ed = $oSYS->GetOption(3); $b1 = ($st - 11 > 0) ? ($st - 11) : 1; $b2 = ($b1 == 1) ? 10 : ($b1 + 10); $f1 = ($ed + 1 < $rmax) ? ($ed + 1) : $rmax; $f2 = ($ed + 10 < $rmax) ? ($ed + 10) : $rmax; $pathNext = $Conv->CreatePath($oSYS, 1, $bbs, $key, "${f1}-${f2}n"); $pathPrev = $Conv->CreatePath($oSYS, 1, $bbs, $key, "${b1}-${b2}n"); } $Page->Print('
'); # メニューの表示 $Page->Print("上"); $Page->Print("前"); $Page->Print("次"); $Page->Print("新"); $Page->Print("1-"); $Page->Print("板"); # 投稿フォームの表示 # レス最大数を超えている場合はフォーム表示しない if ($rmax > $Sys->{'DAT'}->Size()) { $Page->Print(<
[$n]$elem[0]：$elem[2]
AAS
$elem[3]
\n"); } #------------------------------------------------------------------------------------------------------------ # # r.cgi探索画面表示 # ------------------------------------------------------------------------------------- # @param なし # @return なし # #------------------------------------------------------------------------------------------------------------ sub PrintReadSearch { my ($Sys, $Page, $err) = @_; # 存在しないので404を返す。 $Page->Print("Status: 404 Not Found\n"); # 仮エラーページ PrintReadError($Sys, $Page, $err); } #------------------------------------------------------------------------------------------------------------ # # r.cgiエラー表示 # ------------------------------------------------------------------------------------- # @param なし # @return なし # #------------------------------------------------------------------------------------------------------------ sub PrintReadError { my ($Sys, $Page, $err) = @_; my $code; $code = 'Shift_JIS'; # HTMLヘッダの出力 $Page->Print("Content-type: text/html\n\n"); $Page->Print('
'); $Page->Print("こちら"); $Page->Print("から掲示板へ戻ってください。\n"); } # PC用表示 else { my $oSET = $Sys->{'SET'}; $Page->Print("Content-type: text/html\n\n
画面を切り替えるまでしばらくお待ち下さい。'); $Page->Print('
'); } # 告知欄表示(表示させたくない場合はコメントアウトか条件を0に) if (0) { require './module/denethor.pl'; my $BANNER = new DENETHOR; $BANNER->Load($SYS); $BANNER->Print($Page, 100, 0, $SYS->Get('AGENT')); } $Page->Print(''); } #------------------------------------------------------------------------------------------------------------ # # remake.cgiエラーページ表示 # ------------------------------------------------------------------------------------- # @param なし # @return なし # #------------------------------------------------------------------------------------------------------------ sub PrintBBSError { my ($Sys, $Page, $err) = @_; my ($ERROR); require './module/orald.pl'; $ERROR = new ORALD; $ERROR->Load($Sys->{'SYS'}); $ERROR->Print($Sys, $Page, $err, $Sys->{'SYS'}->Get('AGENT')); } zerochplus_0.7.5/test/read.cgi 0000755 0000000 0000000 00000051111 14216364774 013267 0 ustar #!/usr/bin/perl #============================================================================================================ # # 読み出し専用CGI # #============================================================================================================ use lib './perllib'; use strict; #use warnings; no warnings 'once'; ##use CGI::Carp qw(fatalsToBrowser warningsToBrowser); # CGIの実行結果を終了コードとする exit(ReadCGI()); #------------------------------------------------------------------------------------------------------------ # # read.cgiメイン # ------------------------------------------------------------------------------------- # @param なし # @return なし # #------------------------------------------------------------------------------------------------------------ sub ReadCGI { require './module/constant.pl'; require './module/thorin.pl'; my $Page = THORIN->new; my $CGI = {}; my $err = Initialize($CGI, $Page); # 初期化・準備に成功したら内容表示 if ($err == $ZP::E_SUCCESS) { # ヘッダ表示 PrintReadHead($CGI, $Page); # メニュー表示 PrintReadMenu($CGI, $Page); # 内容表示 PrintReadContents($CGI, $Page); # フッタ表示 PrintReadFoot($CGI, $Page); } # 初期化に失敗したらエラー表示 else { # 対象スレッドが見つからなかった場合は探索画面を表示する if ($err == $ZP::E_PAGE_FINDTHREAD) { PrintReadSearch($CGI, $Page); } # それ以外は通常エラー else { PrintReadError($CGI, $Page, $err); } } # 表示結果を出力 $Page->Flush(0, 0, ''); return $err; } #------------------------------------------------------------------------------------------------------------ # # read.cgi初期化・前準備 # ------------------------------------------------------------------------------------- # @param $CGI # @param $Page # @return なし # #------------------------------------------------------------------------------------------------------------ sub Initialize { my ($CGI, $Page) = @_; # 各使用モジュールの生成と初期化 require './module/melkor.pl'; require './module/isildur.pl'; require './module/gondor.pl'; require './module/galadriel.pl'; my $Sys = MELKOR->new; my $Conv = GALADRIEL->new; my $Set = ISILDUR->new; my $Dat = ARAGORN->new; %$CGI = ( 'SYS' => $Sys, 'SET' => $Set, 'CONV' => $Conv, 'DAT' => $Dat, 'PAGE' => $Page, 'CODE' => 'Shift_JIS', ); # システム初期化 $Sys->Init(); # 夢が広がりんぐ $Sys->Set('MainCGI', $CGI); # 起動パラメータの解析 my @elem = $Conv->GetArgument(\%ENV); # BBS指定がおかしい if (!defined $elem[0] || $elem[0] eq '') { return $ZP::E_READ_INVALIDBBS; } # スレッドキー指定がおかしい elsif (!defined $elem[1] || $elem[1] eq '' || ($elem[1] =~ /[^0-9]/) || (length($elem[1]) != 10 && length($elem[1]) != 9)) { return $ZP::E_READ_INVALIDKEY; } # システム変数設定 $Sys->Set('MODE', 0); $Sys->Set('BBS', $elem[0]); $Sys->Set('KEY', $elem[1]); $Sys->Set('CLIENT', $Conv->GetClient()); $Sys->Set('AGENT', $Conv->GetAgentMode($Sys->Get('CLIENT'))); $Sys->Set('BBSPATH_ABS', $Conv->MakePath($Sys->Get('CGIPATH'), $Sys->Get('BBSPATH'))); $Sys->Set('BBS_ABS', $Conv->MakePath($Sys->Get('BBSPATH_ABS'), $Sys->Get('BBS'))); $Sys->Set('BBS_REL', $Conv->MakePath($Sys->Get('BBSPATH'), $Sys->Get('BBS'))); # 設定ファイルの読み込みに失敗 if ($Set->Load($Sys) == 0) { return $ZP::E_READ_FAILEDLOADSET; } my $submax = $Set->Get('BBS_SUBJECT_MAX') || $Sys->Get('SUBMAX'); $Sys->Set('SUBMAX', $submax); my $resmax = $Set->Get('BBS_RES_MAX') || $Sys->Get('RESMAX'); $Sys->Set('RESMAX', $resmax); my $path = $Conv->MakePath($Sys->Get('BBSPATH')."/$elem[0]/dat/$elem[1].dat"); # datファイルの読み込みに失敗 if ($Dat->Load($Sys, $path, 1) == 0) { return $ZP::E_READ_FAILEDLOADDAT; } $Dat->Close(); # 表示開始終了位置の設定 my @regs = $Conv->RegularDispNum( $Sys, $Dat, $elem[2], $elem[3], $elem[4]); $Sys->SetOption($elem[2], $regs[0], $regs[1], $elem[5], $elem[6]); return $ZP::E_SUCCESS; } #------------------------------------------------------------------------------------------------------------ # # read.cgiヘッダ出力 # ------------------------------------------------------------------------------------- # @param $CGI # @param $Page # @param $title # @return なし # #------------------------------------------------------------------------------------------------------------ sub PrintReadHead { my ($CGI, $Page, $title) = @_; my $Sys = $CGI->{'SYS'}; my $Set = $CGI->{'SET'}; my $Dat = $CGI->{'DAT'}; require './module/legolas.pl'; require './module/denethor.pl'; my $Caption = LEGOLAS->new; my $Banner = DENETHOR->new; $Caption->Load($Sys, 'META'); $Banner->Load($Sys); my $code = $CGI->{'CODE'}; $title = $Dat->GetSubject() if(!defined $title); $title = '' if(!defined $title); # HTMLヘッダの出力 $Page->Print("Content-type: text/html\n\n"); $Page->Print(<
\n");
# カウンター表示
if ($account ne '') {
$Page->Print(';
$Page->Print()
\n");
}
$Page->Print("
\n\n");
# レス数限界警告表示
{
my $rmax = $Sys->Get('RESMAX');
if ($resNum >= $rmax) {
$Page->Print("\n");
$Page->Print(" \n");
$Page->Print(" ■掲示板に戻る■\n");
$Page->Print(" 全部\n");
# スレッドメニューを表示
for my $i (0 .. 9) {
last if ($resNum <= $i * 100);
my $st = $i * 100 + 1;
my $ed = ($i + 1) * 100;
my $pathMenu = $Conv->CreatePath($Sys, 0, $bbs, $key, "$st-$ed");
$Page->Print(" $st-\n");
}
$Page->Print(" 最新50\n");
$Page->Print(" \n");
$Page->Print(" \n");
if ($PRtext ne '') {
$Page->Print(" [PR]$PRtext[PR]\n");
}
else {
$Page->Print(" \n");
}
$Page->Print(" \n");
$Page->Print("
\n");
$Page->Print("\n");
$Page->Print("レス数が$rmaxを超えています。残念ながら全部は表\示しません。\n");
$Page->Print("
\n\n");
}
elsif ($resNum >= $rmax - int($rmax / 20)) {
$Page->Print("\n");
$Page->Print("レス数が".($rmax-int($rmax/20))."を超えています。$rmaxを超えると表\示できなくなるよ。\n");
$Page->Print("
\n\n");
}
elsif ($resNum >= $rmax - int($rmax / 10)) {
$Page->Print("\n");
$Page->Print("レス数が".($rmax-int($rmax/10))."を超えています。$rmaxを超えると表\示できなくなるよ。\n");
$Page->Print("
\n\n");
}
}
# スレッドタイトル表示
{
my $title = $Dat->GetSubject();
my $ttlCol = $Set->Get('BBS_SUBJECT_COLOR');
$Page->Print("\n\n"); $Page->Print("
$title
\n\n"); $Page->Print("- \n");
}
}
#------------------------------------------------------------------------------------------------------------
#
# read.cgi内容出力
# -------------------------------------------------------------------------------------
# @param $CGI
# @param $Page
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintReadContents
{
my ($CGI, $Page) = @_;
my $Sys = $CGI->{'SYS'};
# 拡張機能ロード
require './module/athelas.pl';
my $Plugin = ATHELAS->new;
$Plugin->Load($Sys);
# 有効な拡張機能一覧を取得
my @pluginSet = ();
$Plugin->GetKeySet('VALID', 1, \@pluginSet);
my $count = 0;
my @commands = ();
foreach my $id (@pluginSet) {
# タイプがread.cgiの場合はロードして実行
if ($Plugin->Get('TYPE', $id) & 4) {
my $file = $Plugin->Get('FILE', $id);
my $className = $Plugin->Get('CLASS', $id);
if (-e "./plugin/$file") {
require "./plugin/$file";
my $Config = PLUGINCONF->new($Plugin, $id);
$commands[$count] = $className->new($Config);
$count++;
}
}
}
my $work = $Sys->Get('OPTION');
my @elem = split(/\,/, $work);
# 1表示フラグがTRUEで開始が1でなければ1を表示する
if ($elem[3] == 0 && $elem[1] != 1) {
PrintResponse($CGI, $Page, \@commands, 1);
}
# 残りのレスを表示する
for my $i ($elem[1] .. $elem[2]) {
PrintResponse($CGI, $Page, \@commands, $i);
}
}
#------------------------------------------------------------------------------------------------------------
#
# read.cgiフッタ出力
# -------------------------------------------------------------------------------------
# @param $CGI
# @param $Page
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintReadFoot
{
my ($CGI, $Page) = @_;
# 前準備
my $Sys = $CGI->{'SYS'};
my $Set = $CGI->{'SET'};
my $Conv = $CGI->{'CONV'};
my $Dat = $CGI->{'DAT'};
my $bbs = $Sys->Get('BBS');
my $key = $Sys->Get('KEY');
my $ver = $Sys->Get('VERSION');
my $rmax = $Sys->Get('RESMAX');
my $datPath = $Conv->MakePath($Sys->Get('BBS_REL')."/dat/$key.dat");
my $datSize = int((stat $datPath)[7] / 1024);
my $cgipath = $Sys->Get('CGIPATH');
# datファイルのサイズ表示
$Page->Print("
\n"); # フッタメニューの表示 { # メニューリンクの項目設定 my @elem = split(/\,/, $Sys->Get('OPTION')); my $nxt = ($elem[2] + 100 > $rmax ? $rmax : $elem[2] + 100); my $nxs = $elem[2]; my $prv = ($elem[1] - 100 < 1 ? 1 : $elem[1] - 100); my $prs = $prv + 100; # 新着の表示 if ($rmax > $Dat->Size()) { my $dispStr = ($Dat->Size() == $elem[2] ? '新着レスの表\示' : '続きを読む'); my $pathNew = $Conv->CreatePath($Sys, 0, $bbs, $key, "$elem[2]-"); $Page->Print("
\n\n"); } # パスの設定 my $pathBBS = $Sys->Get('BBS_ABS'); my $pathAll = $Conv->CreatePath($Sys, 0, $bbs, $key, ''); my $pathPrev = $Conv->CreatePath($Sys, 0, $bbs, $key, "$prv-$prs"); my $pathNext = $Conv->CreatePath($Sys, 0, $bbs, $key, "$nxs-$nxt"); my $pathLast = $Conv->CreatePath($Sys, 0, $bbs, $key, 'l50'); $Page->Print("
\n");
$Page->Print("掲示板に戻る\n");
$Page->Print("全部\n");
$Page->Print("前100\n");
$Page->Print("次100\n");
$Page->Print("最新50\n");
$Page->Print("
\n");
}
# 投稿フォームの表示
# レス最大数を超えている場合はフォーム表示しない
if ($rmax > $Dat->Size()) {
my $cookName = '';
my $cookMail = '';
my $tm = int(time);
# cookie設定ON時はcookieを取得する
if (($Sys->Get('CLIENT') & $ZP::C_PC) && $Set->Equal('SUBBBS_CGI_ON', 1)) {
require './module/radagast.pl';
my $Cookie = RADAGAST->new;
$Cookie->Init();
my $sanitize = sub {
$_ = shift;
s/&/&/g;
s//>/g;
s/"/"/g;
return $_;
};
$cookName = &$sanitize($Cookie->Get('NAME', '', 'utf8'));
$cookMail = &$sanitize($Cookie->Get('MAIL', '', 'utf8'));
}
$Page->Print(<HTML } $Page->Print(<
ぜろちゃんねるプラス HTML } #------------------------------------------------------------------------------------------------------------ # # read.cgiレス表示 # ------------------------------------------------------------------------------------- # @param $CGI # @param $Page # @param $commands # @param $n # @return なし # #------------------------------------------------------------------------------------------------------------ sub PrintResponse { my ($CGI, $Page, $commands, $n) = @_; # 前準備 my $Sys = $CGI->{'SYS'}; my $Set = $CGI->{'SET'}; my $Conv = $CGI->{'CONV'}; my $Dat = $CGI->{'DAT'}; my $pDat = $Dat->Get($n - 1); my @elem = split(/<>/, $$pDat); my $nameCol = $Set->Get('BBS_NAME_COLOR'); # URLと引用個所の適応 $Conv->ConvertURL($Sys, $Set, 0, \$elem[3]); $Conv->ConvertQuotation($Sys, \$elem[3], 0); # 拡張機能を実行 $Sys->Set('_DAT_', \@elem); $Sys->Set('_NUM_', $n); foreach my $command (@$commands) { $command->execute($Sys, undef, 4); } $Page->Print("
\n");
$Page->Print(" ■掲示板に戻る■\n");
$Page->Print("
\n");
$Page->Print("\n\n"); $Page->Print("
指定されたスレッドは存在しません
\n\n"); $Page->Print("\n- \n");
for my $i (0 .. $size - 1) {
my $pDat = $Dat->Get($i);
my @elem = split(/<>/, $$pDat);
$Page->Print('
- ' . ($i + 1) . ' ：'); # メール欄有り if ($elem[1] eq '') { $Page->Print("$elem[0]"); } # メール欄無し else { $Page->Print("$elem[0]"); } $Page->Print("：$elem[2] \n
- $elem[3]
\n\n"); $Page->Print(<
ぜろちゃんねるプラス HTML } #------------------------------------------------------------------------------------------------------------ # # read.cgiエラー表示 # ------------------------------------------------------------------------------------- # @param $CGI # @param $Page # @param $err # @return なし # #------------------------------------------------------------------------------------------------------------ sub PrintReadError { my ($CGI, $Page, $err) = @_; my $code = $CGI->{'CODE'}; # HTMLヘッダの出力 $Page->Print("Content-type: text/html\n\n"); $Page->Print('
\n");
$Page->Print(" ■掲示板に戻る■\n");
$Page->Print("
\n\n");
$Page->Print("\n\n"); $Page->Print("
$title
\n\n"); $Page->Print("\n\n"); $Page->Print("隊長! 過去ログ倉庫で、スレッド $server$path.html"); $Page->Print(" .dat を発見しました。"); $Page->Print("\n"); } # poolにあり elsif (-e $Conv->MakePath("$spath/pool/$key.cgi")) { my $title = "html化待ちです…"; PrintReadHead($CGI, $Page, $title); $Page->Print("\n
\n");
$Page->Print(" ■掲示板に戻る■\n");
$Page->Print("
\n\n");
$Page->Print("\n\n"); $Page->Print("
$title
\n\n"); $Page->Print("\n\n"); $Page->Print("$key.datはhtml化を待っています。"); $Page->Print('ここは待つしかない・・・。\n"); } # どこにもない else { return 0; } $Page->Print(<
'."\n"); $Page->Print("
READ.CGI - $ver
ぜろちゃんねるプラス
HTML
return 1;
}
zerochplus_0.7.5/test/info/users.cgi 0000755 0000000 0000000 00000000130 14216364774 014443 0 ustar 0000000001<>Administrator<>431XyHmErk<>システムアドミニストレータ<>システム管理者。<>1
zerochplus_0.7.5/test/info/errmsg.cgi 0000755 0000000 0000000 00000006553 14216364774 014620 0 ustar # 100〜入力内容
100<>サブジェクト長すぎ<>サブジェクトが長すぎます！
101<>名前長すぎ<>名前が長すぎます！
102<>メール長すぎ<>メールアドレスが長すぎます！
103<>本文長すぎ<>本文が長すぎます！
104<>1行長すぎ<>長すぎる行があります！
105<>改行多すぎ<>改行が多すぎます！
106<>アンカー多すぎ<>レスアンカーリンクが多すぎます！
150<>タイトルが無い<>サブジェクトが存在しません！
151<>本文が無い<>本文がありません！
152<>名前が無い<>名前いれてちょ。
# 200〜掲示板規制
200<>スレッド停止<>このスレッドは停止されてます。もう書けない。。。
201<>書き込み限界<>{!RESMAX!}を超えてます。このスレッドにはもう書けない。。。
202<>スレッド移転<>このスレッドは移転されたようです。詳しくは（略
203<>読取専用<>現在この掲示板は読取専用です。ここは待つしかない。。。
204<>スレッド規制<>携帯からのスレッド作成はキャップのみ可能です。ぜろちゃんねるプラス
PCから試してみてください。 205<>CGI禁止<>現在この掲示板ではCGIの使用が禁止されてます
indexだけでお楽しみください。 206<>サイズオーバー<>datファイルのサイズが限界を超えました。新しいスレッドを作成してください。 207<>海外串<>JPドメイン以外からのスレッド作成を規制しています。 # 200〜掲示板規制 500<>スレッド立てすぎ<>スレッド立てすぎです。もうちょいもちついてください。 501<>連続投稿<>連続投稿ですか？？ 502<>二重かきこ<>二重かきこですか？？ 503<>もまいらもちつけ。<>もうちょっと落ち着いて書きこみしてください。{!WAIT!}秒ぐらい。 504<>スレッド規制<>現在この板のスレッド作成はキャップのみ可能です。
管理人に相談してください。。。 505<>Samba規制1<>{!SAMBATIME!} sec たたないと書けません。({!SAMBA!}回目、{!WAIT!} sec しかたってない)
\n
\n今のところ、キャップ以外に回避する方法はありません。\n 506<>Samba規制2<>連打しないでください。もうそろそろ規制リストに入れますよ。。(￣ー￣)ニヤリッ
\n
\n\n 507<>Samba規制3<>もうずっと書けませんよ。
\n
\nあなたは、規制リストに追加されました。
\n【解除する方法】
\n{!WAIT!}分以上初心者の方々を優しく導いてあげてください。
\nこれ以外に解除の方法はありません。
\n 508<>Samba規制中<>まだ書けませんよ。
あなたは、規制リストに追加されています。
【解除する方法】
{!WAIT!}分以上初心者の方々を優しく導いてあげてください。
これ以外に解除の方法はありません。
---------- 600<>NGワード<>NGワードが含まれてます。抜かないと書き込みできません。 601<>規制ユーザ<>アクセス規制中です！！({!HITS!}) # 890〜BEシステムエラー系 890<>情報取得失敗<>BEユーザー情報の取得に失敗しました。 891<>接続失敗<>be.2ch.netに接続できませんでした。({!CODE!}) 892<>BEログイン失敗<>BEログインに失敗しました。({!CHK!}) 893<>BEログイン必須<>be.2ch.netでログインしてないと書けません。 894<>BE_TYPE2規制<>Beログインしてください(t)。be.2ch.net # 900〜スレッドエラー系 900<>スレッド指定が変です<>スレッドキーに数字以外がありそうです。
もう一度よく確かめてちょ。 901<>スレッド指定が変です<>スレッドキーの数がおかしいですよん。
もう一度よく確かめてちょ。 902<>スレッド指定が変です<>書き込もうとしているスレッドは存在しないか、削除されています。。。 # 950〜システムエラー系 950<>端末固有情報不明<>端末固有情報を送信してください。 997<>ＰＲＯＸＹ規制<>公開ＰＲＯＸＹからの投稿は受け付けていません！！ 998<>ブラウザ変ですよん<>アクセス不正です。このCGIは外部からのアクセスは認めてないです。。 999<>ブラウザ変ですよん<>フォーム情報が正しく読めないです。 990<>システムエラー<>システムが変です。サポート版で聞いたほうがいいかも。。 zerochplus_0.7.5/test/info/category.cgi 0000755 0000000 0000000 00000000060 14216364774 015121 0 ustar 0000000001<>一般<>一般、もしくは未分類の掲示板 zerochplus_0.7.5/test/search.cgi 0000755 0000000 0000000 00000026661 14216364774 013635 0 ustar #!/usr/bin/perl #============================================================================================================ # # 検索用CGI(まちがえてすみません) # search.cgi # ----------------------------------------------------- # 2003.11.22 star # 2004.09.16 システム改変に伴う変更 # 2009.06.19 HTML部分の大幅な書き直し # #============================================================================================================ use strict; #use warnings; ##use CGI::Carp qw(fatalsToBrowser warningsToBrowser); no warnings 'once'; BEGIN { use lib './perllib'; } # CGIの実行結果を終了コードとする exit(SearchCGI()); #------------------------------------------------------------------------------------------------------------ # # CGIメイン処理 - SearchCGI # ------------------------------------------------ # 引 数：なし # 戻り値：なし # #------------------------------------------------------------------------------------------------------------ sub SearchCGI { my ($Sys, $Page, $Form, $BBS); require './module/melkor.pl'; require './module/thorin.pl'; require './module/samwise.pl'; require './module/nazguls.pl'; $Sys = new MELKOR; $Page = new THORIN; $Form = SAMWISE->new(1); $BBS = new NAZGUL; $Form->DecodeForm(1); $Sys->Init(); $BBS->Load($Sys); PrintHead($Sys, $Page, $BBS, $Form); # 検索ワードがある場合は検索を実行する if ($Form->Get('WORD', '') ne '') { Search($Sys, $Form, $Page, $BBS); } PrintFoot($Sys, $Page); $Page->Flush(0, 0, ''); } #------------------------------------------------------------------------------------------------------------ # # ヘッダ出力 - PrintHead # ------------------------------------------------ # 引 数：なし # 戻り値：なし # #------------------------------------------------------------------------------------------------------------ sub PrintHead { my ($Sys, $Page, $BBS, $Form) = @_; my ($pBBS, $bbs, $name, $dir, $Banner); my ($sMODE, $sBBS, $sKEY, $sWORD, @sTYPE, @cTYPE, $types, $BBSpath, @bbsSet, $id); my $sanitize = sub { $_ = shift; s/&/&/g; s//>/g; s/"/"/g;#" return $_; }; $sMODE = &$sanitize($Form->Get('MODE', '')); $sBBS = &$sanitize($Form->Get('BBS', '')); $sKEY = &$sanitize($Form->Get('KEY', '')); $sWORD = &$sanitize($Form->Get('WORD')); @sTYPE = $Form->GetAtArray('TYPE', 0); $types = ($sTYPE[0] || 0) | ($sTYPE[1] || 0) | ($sTYPE[2] || 0); $cTYPE[0] = ($types & 1 ? 'checked' : ''); $cTYPE[1] = ($types & 2 ? 'checked' : ''); $cTYPE[2] = ($types & 4 ? 'checked' : ''); $BBSpath = $Sys->Get('BBSPATH'); # バナーの読み込み require './module/denethor.pl'; $Banner = new DENETHOR; $Banner->Load($Sys); $Page->Print("Content-type: text/html;charset=Shift_JIS\n\n"); $Page->Print(<
|
検索＠0chPlus
|
【ヒット数：$n】
検索結果
-
HTML
}
#------------------------------------------------------------------------------------------------------------
#
# 検索結果内容出力
# -------------------------------------------------------------------------------------
# @param $Page THORIN
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintResult
{
my ($Page, $BBS, $Conv, $n, $base, $pResult) = @_;
my ($name, @bbsSet);
$BBS->GetKeySet('DIR', $$pResult[0], \@bbsSet);
if (@bbsSet > 0) {
$name = $BBS->Get('NAME', $bbsSet[0]);
$Page->Print("
- $n 名前：");
if ($$pResult[4] eq '') {
$Page->Print("$$pResult[3]");
}
else {
$Page->Print("$$pResult[3]");
}
$Page->Print(<
-
$$pResult[6]
【$name】 【スレッド】 【レス】
HTML
}
}
#------------------------------------------------------------------------------------------------------------
#
# 検索結果フッタ出力
# -------------------------------------------------------------------------------------
# @param $Page THORIN
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintResultFoot
{
my ($Page) = @_;
$Page->Print("
＿|￣|○ 一件もヒットしませんでした。。
【ヒット数：0】システムエラー
|
まだかな、まだかな、まなかな(規制一覧表\)
あなたのリモホ[$HOST]
by ぜろちゃんねるプラス ★
##############################################################################
# ここから
'."\n");
$Page->Print('#-----------------------------------------------------------------------------
'."\n");
$Page->Print("# $BBSs{$dir} [ $dir ]
\n");
$Page->Print('#-----------------------------------------------------------------------------
'."\n");
$path = "$BBSpath/$dir/info/access.cgi";
if ( -e $path && open(SEC, '<', $path) ) {
flock(FILE, 1);
$line =
'."\n");
$color = "blue";
}
while (
/g;
s/(http:\/\/.*)
/$1<\/a>
/g;
$Page->Print($_."\n");
}
close(SEC);
}
else {
$Page->Print('Cannot open access.cgi.
'."\n");
}
$Page->Print('
##############################################################################
ぜろちゃんねるプラス
MADAKANA.CGI - $ver
HTML
}
#------------------------------------------------------------------------------------------------------------
#
# madakana.cgiエラー表示
# -------------------------------------------------------------------------------------
# @param なし
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintMadaError
{
my ($Sys, $Page, $err) = @_;
my ($code);
$code = 'Shift_JIS';
# HTMLヘッダの出力
$Page->Print("Content-type: text/html\n\n");
$Page->Print('");
# 看板画像表示あり
if ($image ne '') {
# 看板画像からのリンクあり
if ($link ne '') {
$Page->Print("![\"$image\"](\"$image\")
"); } # 看板画像にリンクはなし else { $Page->Print("
"); } } $Page->Print("
");
# ヘッダテーブルの表示
$Caption->Load($Sys, 'HEAD');
$Caption->Print($Page, $Set);
# スレッド作成フォームの表示
{
my $tblCol = $Set->Get('BBS_MAKETHREAD_COLOR');
my $name = $Cookie->Get('NAME', '', 'utf8');
my $mail = $Cookie->Get('MAIL', '', 'utf8');
my $bbs = $Form->Get('bbs');
my $tm = int(time);
my $ver = $Sys->Get('VERSION');
$Page->Print(<"); } # 看板画像にリンクはなし else { $Page->Print("
"); } } $Page->Print("
$ver
HTML } $Page->Print("\n\n\n"); } #------------------------------------------------------------------------------------------------------------ # # bbs.cgiスレッド作成ページ(携帯)表示 # ------------------------------------------------------------------------------------- # @param $CGI # @param $Page THORIN # @return なし # #------------------------------------------------------------------------------------------------------------ sub PrintBBSMobileThreadCreate { my ($CGI, $Page) = @_; my $Sys = $CGI->{'SYS'}; my $Set = $CGI->{'SET'}; require './module/denethor.pl'; my $Banner = DENETHOR->new; $Banner->Load($Sys); my $title = $Set->Get('BBS_TITLE'); my $bbs = $Sys->Get('BBS'); my $tm = int(time); $Page->Print("Content-type: text/html\n\n"); $Page->Print("名前： $name
E-mail： $mail
内容：
$msg
投稿確認
・投稿者は、投稿に関して発生する責任が全て投稿者に帰すことを承諾します。
・投稿者は、話題と無関係な広告の投稿に関して、相応の費用を支払うことを承諾します
・投稿者は、投稿された内容について、掲示板運営者がコピー、保存、引用、転載等の利用することを許諾します。
また、掲示板運営者に対して、著作者人格権を一切行使しないことを承諾します。
・投稿者は、掲示板運営者が指定する第三者に対して、著作物の利用許諾を一切しないことを承諾します。
・投稿者は、投稿に関して発生する責任が全て投稿者に帰すことを承諾します。
・投稿者は、話題と無関係な広告の投稿に関して、相応の費用を支払うことを承諾します
・投稿者は、投稿された内容について、掲示板運営者がコピー、保存、引用、転載等の利用することを許諾します。
また、掲示板運営者に対して、著作者人格権を一切行使しないことを承諾します。
・投稿者は、掲示板運営者が指定する第三者に対して、著作物の利用許諾を一切しないことを承諾します。
変更する場合は戻るボタンで戻って書き直して下さい。
現在、荒らし対策でクッキーを設定していないと書きこみできないようにしています。
(cookieを設定するとこの画面はでなくなります。)
'); $Page->Print("こちら"); $Page->Print("から掲示板へ戻ってください。\n"); } # PC用表示 else { my $bbsPath = $Conv->MakePath($Sys->Get('BBS_REL')); my $name = $Form->Get('NAME', ''); my $mail = $Form->Get('MAIL', ''); $Cookie->Set('NAME', $name, 'utf8') if ($Set->Equal('BBS_NAMECOOKIE_CHECK', 'checked')); $Cookie->Set('MAIL', $mail, 'utf8') if ($Set->Equal('BBS_MAILCOOKIE_CHECK', 'checked')); $Cookie->Out($Page, $Set->Get('BBS_COOKIEPATH'), 60 * 24 * 30); $Page->Print("Content-type: text/html\n\n"); $Page->Print(<
画面を切り替えるまでしばらくお待ち下さい。
HTML } # 告知欄表示(表示させたくない場合はコメントアウトか条件を0に) if (0) { require './module/denethor.pl'; my $Banner = DENETHOR->new; $Banner->Load($Sys); $Banner->Print($Page, 100, 0, $Sys->Get('AGENT')); } $Page->Print("\n\n\n"); } #------------------------------------------------------------------------------------------------------------ # # bbs.cgiエラーページ表示 # ------------------------------------------------------------------------------------- # @param $CGI # @param $Page # @param $err # @return なし # #------------------------------------------------------------------------------------------------------------ sub PrintBBSError { my ($CGI, $Page, $err) = @_; require './module/orald.pl'; my $Error = ORALD->new; $Error->Load($CGI->{'SYS'}); $Error->Print($CGI, $Page, $err, $CGI->{'SYS'}->Get('AGENT')); } zerochplus_0.7.5/test/index.html 0000644 0000000 0000000 00000000015 14216364774 013657 0 ustar 403 Forbidden zerochplus_0.7.5/test/module/isildur.pl 0000644 0000000 0000000 00000024052 14216364775 015167 0 ustar #============================================================================================================ # # SETTINGデータ管理モジュール # #============================================================================================================ package ISILDUR; use strict; #use warnings; #------------------------------------------------------------------------------------------------------------ # # コンストラクタ # ------------------------------------------------------------------------------------- # @param なし # @return モジュールオブジェクト # #------------------------------------------------------------------------------------------------------------ sub new { my $this = shift; my $obj = { 'SYS' => undef, 'SETTING' => undef, }; bless $obj, $this; return $obj; } #------------------------------------------------------------------------------------------------------------ # # 掲示板設定読み込み # ------------------------------------------------------------------------------------- # @param $Sys MELKOR # @return エラー番号 # #------------------------------------------------------------------------------------------------------------ sub Load { my $this = shift; my ($Sys) = @_; $this->{'SYS'} = $Sys; my $set = $this->{'SETTING'} = {}; InitSettingData($set); my $path = $Sys->Get('BBSPATH') . '/' . $Sys->Get('BBS') . '/SETTING.TXT'; if (open(my $fh, '<', $path)) { flock($fh, 2); my @lines = <$fh>; close($fh); map { s/[\r\n]+\z// } @lines; foreach (@lines) { if ($_ =~ /^(.+?)=(.*)$/) { $set->{$1} = $2; } } return 1; } return 0; } #------------------------------------------------------------------------------------------------------------ # # 掲示板設定書き込み # ------------------------------------------------------------------------------------- # @param $Sys MELKOR # @return なし # #------------------------------------------------------------------------------------------------------------ sub Save { my $this = shift; my ($Sys) = @_; my $path = $Sys->Get('BBSPATH') . '/' . $Sys->Get('BBS') . '/SETTING.TXT'; # ２ちゃんねるのSETTING.TXT順序 my @ch2setting = qw( BBS_TITLE BBS_TITLE_PICTURE BBS_TITLE_COLOR BBS_TITLE_LINK BBS_BG_COLOR BBS_BG_PICTURE BBS_NONAME_NAME BBS_MAKETHREAD_COLOR BBS_MENU_COLOR BBS_THREAD_COLOR BBS_TEXT_COLOR BBS_NAME_COLOR BBS_LINK_COLOR BBS_ALINK_COLOR BBS_VLINK_COLOR BBS_THREAD_NUMBER BBS_CONTENTS_NUMBER BBS_LINE_NUMBER BBS_MAX_MENU_THREAD BBS_SUBJECT_COLOR BBS_PASSWORD_CHECK BBS_UNICODE BBS_DELETE_NAME BBS_NAMECOOKIE_CHECK BBS_MAILCOOKIE_CHECK BBS_SUBJECT_COUNT BBS_NAME_COUNT BBS_MAIL_COUNT BBS_MESSAGE_COUNT BBS_NEWSUBJECT BBS_THREAD_TATESUGI BBS_AD2 SUBBBS_CGI_ON NANASHI_CHECK timecount timeclose BBS_PROXY_CHECK BBS_OVERSEA_THREAD BBS_OVERSEA_PROXY BBS_RAWIP_CHECK BBS_SLIP BBS_DISP_IP BBS_FORCE_ID BBS_BE_ID BBS_BE_TYPE2 BBS_NO_ID BBS_JP_CHECK BBS_VIP931 BBS_4WORLD BBS_YMD_WEEKS BBS_NINJA ); my %orz = %{$this->{'SETTING'}}; chmod($Sys->Get('PM-TXT'), $path); if (open(my $fh, (-f $path ? '+<' : '>'), $path)) { flock($fh, 2); binmode($fh); seek($fh, 0, 0); # 順番に出力 foreach my $key (@ch2setting) { my $val = $this->Get($key, ''); print $fh "$key=$val\n"; delete $orz{$key}; } foreach my $key (sort keys %orz) { my $val = $this->Get($key, ''); print $fh "$key=$val\n"; delete $orz{$key}; } truncate($fh, tell($fh)); close($fh); } else { warn "can't save setting: $path"; } chmod($Sys->Get('PM-TXT'), $path); } #------------------------------------------------------------------------------------------------------------ # # 掲示板設定読み込み(指定ファイル) # ------------------------------------------------------------------------------------- # @param $path 指定ファイルのパス # @return エラー番号 # #------------------------------------------------------------------------------------------------------------ sub LoadFrom { my $this = shift; my ($path) = @_; my $set = $this->{'SETTING'} = {}; if (open(my $fh, '<', $path)) { flock($fh, 2); my @lines = <$fh>; close($fh); map { s/[\r\n]+\z// } @lines; foreach (@lines) { if ($_ =~ /^(.+?)=(.*)$/) { $set->{$1} = $2; } } return 1; } else { warn "can't load setting: $path"; } return 0; } #------------------------------------------------------------------------------------------------------------ # # 掲示板設定書き込み(指定ファイル) # ------------------------------------------------------------------------------------- # @param $path 指定ファイルのパス # @return なし # #------------------------------------------------------------------------------------------------------------ sub SaveAs { my $this = shift; my ($path) = @_; chmod($this->{'SYS'}->Get('PM-TXT'), $path); if (open(my $fh, (-f $path ? '+<' : '>'), $path)) { flock($fh, 2); seek($fh, 0, 0); binmode($fh); foreach my $key (keys %{$this->{'SETTING'}}) { my $val = $this->{'SETTING'}->{$key}; print $fh "$key=$val\n"; } truncate($fh, tell($fh)); close($fh); } else { warn "can't save setting: $path"; } chmod($this->{'SYS'}->Get('PM-TXT'), $path); } #------------------------------------------------------------------------------------------------------------ # # 掲示板設定キー取得 # ------------------------------------------------------------------------------------- # @param $keySet キーセット格納バッファ # @return なし # #------------------------------------------------------------------------------------------------------------ sub GetKeySet { my $this = shift; my ($keySet) = @_; push @$keySet, keys %{$this->{'SETTING'}}; } #------------------------------------------------------------------------------------------------------------ # # 掲示板設定値比較 # ------------------------------------------------------------------------------------- # @param $key 設定キー # @param $val 設定値 # @return 同等なら真を返す # #------------------------------------------------------------------------------------------------------------ sub Equal { my $this = shift; my ($key, $val) = @_; return(defined $this->{'SETTING'}->{$key} && $this->{'SETTING'}->{$key} eq $val); } #------------------------------------------------------------------------------------------------------------ # # 掲示板設定値取得 # ------------------------------------------------------------------------------------- # @param $key 設定キー # $default : デフォルト # @return 設定値 # #------------------------------------------------------------------------------------------------------------ sub Get { my $this = shift; my ($key, $default) = @_; my $val = $this->{'SETTING'}->{$key}; return (defined $val ? $val : (defined $default ? $default : undef)); } #------------------------------------------------------------------------------------------------------------ # # 掲示板設定値設定 # ------------------------------------------------------------------------------------- # @param $key 設定キー # @param $val 設定値 # @return なし # #------------------------------------------------------------------------------------------------------------ sub Set { my $this = shift; my ($key, $val) = @_; $this->{'SETTING'}->{$key} = $val; } #------------------------------------------------------------------------------------------------------------ # # SETTING項目初期化 - InitSettingData # ------------------------------------------- # 引 数：$pSET : ハッシュの参照 # 戻り値：なし # #------------------------------------------------------------------------------------------------------------ sub InitSettingData { my ($pSET) = @_; my %set = ( # ２ちゃんねる互換設定項目 'BBS_TITLE' => '掲示板＠ぜろちゃんねるプラス', 'BBS_TITLE_PICTURE' => 'kanban.gif', 'BBS_TITLE_COLOR' => '#000000', 'BBS_TITLE_LINK' => 'http://zerochplus.sourceforge.jp/', 'BBS_BG_COLOR' => '#FFFFFF', 'BBS_BG_PICTURE' => 'ba.gif', 'BBS_NONAME_NAME' => '名無しさん＠ぜろちゃんねるプラス', 'BBS_MAKETHREAD_COLOR' => '#CCFFCC', 'BBS_MENU_COLOR' => '#CCFFCC', 'BBS_THREAD_COLOR' => '#EFEFEF', 'BBS_TEXT_COLOR' => '#000000', 'BBS_NAME_COLOR' => 'green', 'BBS_LINK_COLOR' => '#0000FF', 'BBS_ALINK_COLOR' => '#FF0000', 'BBS_VLINK_COLOR' => '#AA0088', 'BBS_THREAD_NUMBER' => 10, 'BBS_CONTENTS_NUMBER' => 10, 'BBS_LINE_NUMBER' => 12, 'BBS_MAX_MENU_THREAD' => 30, 'BBS_SUBJECT_COLOR' => '#FF0000', 'BBS_PASSWORD_CHECK' => 'checked', 'BBS_UNICODE' => 'pass', 'BBS_DELETE_NAME' => 'あぼーん', 'BBS_NAMECOOKIE_CHECK' => 'checked', 'BBS_MAILCOOKIE_CHECK' => 'checked', 'BBS_SUBJECT_COUNT' => 48, 'BBS_NAME_COUNT' => 128, 'BBS_MAIL_COUNT' => 64, 'BBS_MESSAGE_COUNT' => 2048, 'BBS_NEWSUBJECT' => 1, 'BBS_THREAD_TATESUGI' => 5, 'BBS_AD2' => '', 'SUBBBS_CGI_ON' => 1, 'NANASHI_CHECK' => '', 'timecount' => 7, 'timeclose' => 5, 'BBS_PROXY_CHECK' => '', 'BBS_OVERSEA_THREAD' => '', 'BBS_OVERSEA_PROXY' => '', 'BBS_RAWIP_CHECK' => '', 'BBS_SLIP' => '', 'BBS_DISP_IP' => '', 'BBS_FORCE_ID' => 'checked', 'BBS_BE_ID' => '', 'BBS_BE_TYPE2' => '', 'BBS_NO_ID' => '', 'BBS_JP_CHECK' => '', 'BBS_YMD_WEEKS' => '日/月/火/水/木/金/土', 'BBS_NINJA' => '', # 以下0chオリジナル設定項目 'BBS_DATMAX' => 512, 'BBS_SUBJECT_MAX' => '', 'BBS_RES_MAX' => '', 'BBS_COOKIEPATH' => '/', 'BBS_READONLY' => 'caps', 'BBS_REFERER_CUSHION' => 'jump.x0.to/', 'BBS_THREADCAPONLY' => '', 'BBS_THREADMOBILE' => '', 'BBS_TRIPCOLUMN' => 10, 'BBS_SUBTITLE' => 'またーり雑談', 'BBS_COLUMN_NUMBER' => 256, 'BBS_SAMBATIME' => '', 'BBS_HOUSHITIME' => '', 'BBS_CAP_COLOR' => '', 'BBS_TATESUGI_HOUR' => '0', 'BBS_TATESUGI_COUNT' => '5', 'BBS_TATESUGI_COUNT2' => '1', 'BBS_INDEX_LINE_NUMBER' => 12, ); while (my ($key, $val) = each(%set)) { $pSET->{$key} = $val; } } #============================================================================================================ # Module END #============================================================================================================ 1; zerochplus_0.7.5/test/module/faramir.pl 0000644 0000000 0000000 00000014645 14216364775 015144 0 ustar #============================================================================================================ # # アクセスユーザ管理モジュール # #============================================================================================================ package FARAMIR; use strict; #use warnings; #------------------------------------------------------------------------------------------------------------ # # モジュールコンストラクタ - new # ------------------------------------------- # 引 数：なし # 戻り値：モジュールオブジェクト # #------------------------------------------------------------------------------------------------------------ sub new { my $class = shift; my $obj = { 'TYPE' => undef, 'METHOD' => undef, 'USER' => undef, 'SYS' => undef, }; bless $obj, $class; return $obj; } #------------------------------------------------------------------------------------------------------------ # # ユーザデータ読み込み - Load # ------------------------------------------- # 引 数：$Sys : MELKOR # 戻り値：正常読み込み:0,エラー:1 # #------------------------------------------------------------------------------------------------------------ sub Load { my $this = shift; my ($Sys) = @_; $this->{'SYS'} = $Sys; $this->{'USER'} = []; my $path = $Sys->Get('BBSPATH') . '/' . $Sys->Get('BBS') . "/info/access.cgi"; if (open(my $fh, '<', $path)) { flock($fh, 2); my @datas = <$fh>; close($fh); map { s/[\r\n]+\z// } @datas; my @head = split(/<>/, shift(@datas), -1); $this->{'TYPE'} = $head[0]; $this->{'METHOD'} = $head[1]; push @{$this->{'USER'}}, @datas; return 0; } return 1; } #------------------------------------------------------------------------------------------------------------ # # ユーザデータ書き込み - Save # ------------------------------------------- # 引 数：$Sys : MELKOR # 戻り値：正常書き込み:0,エラー:-1 # #------------------------------------------------------------------------------------------------------------ sub Save { my $this = shift; my ($Sys) = @_; my $path = $Sys->Get('BBSPATH') . '/' . $Sys->Get('BBS') . "/info/access.cgi"; chmod($Sys->Get('PM-ADM'), $path); if (open(my $fh, (-f $path ? '+<' : '>'), $path)) { flock($fh, 2); seek($fh, 0, 0); binmode($fh); print $fh "$this->{'TYPE'}<>$this->{'METHOD'}\n"; foreach (@{$this->{'USER'}}) { print $fh "$_\n"; } truncate($fh, tell($fh)); close($fh); } chmod($Sys->Get('PM-ADM'), $path); return 0; } #------------------------------------------------------------------------------------------------------------ # # ユーザ追加 - Set # ------------------------------------------- # 引 数：$name : 追加ユーザ # 戻り値：なし # #------------------------------------------------------------------------------------------------------------ sub Add { my $this = shift; my ($name) = @_; push @{$this->{'USER'}}, $name; } #------------------------------------------------------------------------------------------------------------ # # ユーザデータ取得 - Get # ------------------------------------------- # 引 数：$key : 取得キー # $default : デフォルト # 戻り値：ユーザデータ # #------------------------------------------------------------------------------------------------------------ sub Get { my $this = shift; my ($key, $default) = @_; my $val = $this->{$key}; return (defined $val ? $val : (defined $default ? $default : undef)); } #------------------------------------------------------------------------------------------------------------ # # ユーザクリア - Clear # ------------------------------------------- # 引 数：なし # 戻り値：なし # #------------------------------------------------------------------------------------------------------------ sub Clear { my $this = shift; $this->{'USER'} = []; } #------------------------------------------------------------------------------------------------------------ # # ユーザデータ設定 - SetData # ------------------------------------------- # 引 数：$key : 設定キー # $data : 設定データ # 戻り値：なし # #------------------------------------------------------------------------------------------------------------ sub Set { my $this = shift; my ($key, $data) = @_; $this->{$key} = $data; } #------------------------------------------------------------------------------------------------------------ # # ユーザ調査 - Check # ------------------------------------------- # 引 数：$host : 調査ホスト # $addr : 調査IPアドレス # $koyuu : 端末固有識別子 # 戻り値：登録ユーザ:1,未登録ユーザ:0 # #------------------------------------------------------------------------------------------------------------ sub Check { my $this = shift; my ($host, $addr, $koyuu) = @_; my $Sys = $this->{'SYS'}; my $addrb = unpack('B32', pack('C*', split(/\./, $addr))); my $flag = 0; my $adex = '[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}'; foreach my $line (@{$this->{'USER'}}) { next if ($line =~ /^[#;]|^$/); # IPアドレス/CIDR if ($line =~ m|^($adex)(?:/([0-9]+))?$|) { my $leng = $2 || 32; my $a = unpack("B$leng", pack('C*', split(/\./, $1))); if (substr($addrb, 0, $leng) eq $a) { $flag = 1; $Sys->Set('HITS', $line); last; } } # IPアドレス範囲指定 elsif ($line =~ m|^($adex)-($adex)$|) { my $a = unpack('B32', pack('C*', split(/\./, $1))); my $b = unpack('B32', pack('C*', split(/\./, $2))); ($b, $a) = ($a, $b) if ($a gt $b); if ($addrb ge $a && $addrb le $b) { $flag = 1; $Sys->Set('HITS', $line); last; } } # 端末固有識別子 elsif (defined $koyuu && $koyuu =~ /^\Q$line\E$/) { $flag = 1; $Sys->Set('HITS', $line); last; } # ホスト名(正規表現) elsif ($host =~ /$line/) { $flag = 1; $Sys->Set('HITS', $line); last; } } # 規制ユーザ if ($flag && $this->{'TYPE'} eq 'disable') { if ($this->{'METHOD'} eq 'disable') { # 処理：書き込み不可 return 4; } elsif ($this->{'METHOD'} eq 'host') { # 処理：ホスト表示 return 2; } else { return 4; } } # 限定ユーザ以外 elsif (! $flag && $this->{'TYPE'} eq 'enable') { if ($this->{'METHOD'} eq 'disable') { # 処理：書き込み不可 return 4; } elsif ($this->{'METHOD'} eq 'host') { # 処理：ホスト表示 return 2; } else { return 4; } } return 0; } #============================================================================================================ # モジュール終端 #============================================================================================================ 1; zerochplus_0.7.5/test/module/galadriel.pl 0000644 0000000 0000000 00000101364 14216364775 015442 0 ustar #============================================================================================================ # # 汎用データ変換・取得モジュール # #============================================================================================================ package GALADRIEL; use strict; #use warnings; no warnings qw(once); #------------------------------------------------------------------------------------------------------------ # # モジュールコンストラクタ - new # ------------------------------------------- # 引 数：なし # 戻り値：モジュールオブジェクト # #------------------------------------------------------------------------------------------------------------ sub new { my $class = shift; my $obj = {}; bless $obj, $class; return $obj; } #------------------------------------------------------------------------------------------------------------ # # URL引数取得 - GetArgument # ------------------------------------------- # 引 数：$pENV : %ENVのリファレンス # 戻り値：引数配列 # #------------------------------------------------------------------------------------------------------------ sub GetArgument { my $this = shift; my ($pENV) = @_; my @retArg = (); # PATH_INFOあり if (defined $pENV->{'PATH_INFO'} && $pENV->{'PATH_INFO'} ne '') { my @Awork = split(/\//, $pENV->{'PATH_INFO'}, -1); @retArg = (@Awork[1, 2], ConvertOption($Awork[3])); } # QUERY_STRING else { my @Awork = split(/[&;]/, $pENV->{'QUERY_STRING'}, -1); @retArg = (undef, undef, 0, 1, 1000, 1, 0); foreach (@Awork) { my ($var, $val) = split(/=/, $_, 2); $retArg[0] = $val if ($var eq 'bbs'); # BBS $retArg[1] = $val if ($var eq 'key'); # スレッドキー $retArg[3] = $val if ($var eq 'st'); # 開始レス番 $retArg[4] = $val if ($var eq 'to'); # 終了レス番 # 1非表示 if ($var eq 'nofirst' && $val eq 'true') { $retArg[5] = 1; } # 最新n件表示 if ($var eq 'last' && $val != -1) { $retArg[2] = 1; $retArg[3] = $val; $retArg[4] = $val; } } # 単独表示フラグ if ($retArg[3] == $retArg[4] && $retArg[2] != 1) { $retArg[6] = 1; } } return @retArg; } #------------------------------------------------------------------------------------------------------------ # # 表示レス数正規化 - RegularDispNum # ------------------------------------------- # 引 数：$Sys : MELKOR # $Dat : ARAGORNオブジェクト # $last : lastフラグ # $start : 開始行 # $end : 終了行 # 戻り値：(開始行、終了行) # #------------------------------------------------------------------------------------------------------------ sub RegularDispNum { my $this = shift; my ($Sys, $Dat, $last, $start, $end) = @_; # 大きさ判定 swap if ($start > $end && $end != -1) { ($start, $end) = ($end, $start); } my $resmax = $Dat->Size(); my ($st, $ed); # 最新n件表示 if ($last == 1) { $st = $resmax - $start + 1; $st = 1 if ($st < 1); $ed = $resmax; } # 指定表示 elsif ($start || $end) { if ($end == -1) { $st = $start < 1 ? 1 : $start; $ed = $resmax; } else { $st = $start < 1 ? 1 : $start; $ed = $end < $resmax ? $end : $resmax; } } # 全件表示 else { $st = 1; $ed = $resmax; } # 時間による制限有り if ($Sys->Get('LIMTIME')) { # 表示レス数が100超えた if ($ed - $st >= 100) { $ed = $st + 100 - 1; } } return ($st, $ed); } #------------------------------------------------------------------------------------------------------------ # # URL変換 - ConvertURL # -------------------------------------------- # 引 数：$Sys : MELKORモジュール # $Set : SETTING # $mode : エージェント # $text : 変換テキスト(リファレンス) # 戻り値：変換後のメッセージ # #------------------------------------------------------------------------------------------------------------ sub ConvertURL { my $this = shift; my ($Sys, $Set, $mode, $text) = @_; # 時間による制限有り return $text if ($Sys->Get('LIMTIME')); my $server = $Sys->Get('SERVER'); my $cushion = $Set->Get('BBS_REFERER_CUSHION'); my $reg1 = q{(https?|ftp)://(([-\w.!~*'();/?:\@=+\$,%#]|&(?![lg]t;))+)}; # URL検索１ my $reg2 = q{<(https?|ftp)::(([-\w.!~*'();/?:\@=+\$,%#]|&(?![lg]t;))+)>}; # URL検索２ # 携帯から if ($mode eq 'O') { $$text =~ s/$reg1/<$1::$2>/g; while ($$text =~ /$reg2/) { my $work = (split(/\//, $2))[0]; $work =~ s/(www\.|\.com|\.net|\.jp|\.co|\.ne)//g; $$text =~ s|$reg2|$work|; } $$text =~ s/
/
/g; $$text =~ s/\s*
/
/g; $$text =~ s/(?:
){2}/
/g; $$text =~ s/(?:
){3,}/
/g; } # PCから else { # クッションあり if ($cushion) { $server =~ /$reg1/; $server = $2; $$text =~ s/$reg1/<$1::$2>/g; while ($$text =~ /$reg2/) { # 自鯖リンク -> クッションなし if ($2 =~ m{^\Q$server\E(?:/|$)}) { $$text =~ s|$reg2|$1://$2|; } # 自鯖以外 else { if($1 eq 'http') { $$text =~ s|$reg2|$1://$2|; } elsif ($cushion =~ m{^(?:jump\.x0\.to|nun\.nu)/$}) { $$text =~ s|$reg2|$1://$2|; } else { $$text =~ s|$reg2|$1://$2|; } } } } # クッション無し else { $$text =~ s|$reg1|$1://$2|g; } } return $text; } #------------------------------------------------------------------------------------------------------------ # # 引用変換 - ConvertQuotation # -------------------------------------------- # 引 数：$Sys : MELKORオブジェクト # $text : 変換テキスト # $mode : エージェント # 戻り値：変換後のメッセージ # #------------------------------------------------------------------------------------------------------------ sub ConvertQuotation { my $this = shift; my ($Sys, $text, $mode) = @_; # 時間による制限有り return $text if ($Sys->Get('LIMTIME')); my $pathCGI = $Sys->Get('SERVER') . $Sys->Get('CGIPATH'); if ($Sys->Get('PATHKIND')) { # URLベースを生成 my $buf = '>>$1-$2}g; $$text =~ s{>>([1-9][0-9]*)-(?!0)} {$buf&st=$1&to=-1" target="_blank">>>$1-}g; $$text =~ s{>>-([1-9][0-9]*)} {$buf&st=1&to=$1" target="_blank">>>$1-}g; $$text =~ s{>>([1-9][0-9]*)} {$buf&st=$1&to=$1" target="_blank">>>$1}g; } else{ # URLベースを生成 my $buf = '>>$1-$2}g; $$text =~ s{>>([1-9][0-9]*)-(?!0)} {$buf/$1-" target="_blank">>>$1-}g; $$text =~ s{>>-([1-9][0-9]*)} {$buf/-$1" target="_blank">>>-$1}g; $$text =~ s{>>([1-9][0-9]*)} {$buf/$1" target="_blank">>>$1}g; } $$text =~ s{>>(?=[1-9])}{>>}g; return $text; } #------------------------------------------------------------------------------------------------------------ # # 特殊引用変換 - ConvertSpecialQuotation # -------------------------------------------- # 引 数：$Sys : MELKORオブジェクト # $text : 変換テキスト # $mode : エージェント # 戻り値：変換後のメッセージ # #------------------------------------------------------------------------------------------------------------ sub ConvertSpecialQuotation { my $this = shift; my ($Sys, $text, $mode) = @_; if ($mode ne 'O') { my @lines = split(/
/, $text, -1); map { $_ = "$_" if (/^＞/); $_ = "$_" if (/^#/); } @lines; return join('
', @lines); } return $text; } #------------------------------------------------------------------------------------------------------------ # # テキスト削除 - DeleteText # -------------------------------------------- # 引 数：$text : 対象テキスト(リファレンス) # $len : 最大文字数 # 戻り値：成形後テキスト # #------------------------------------------------------------------------------------------------------------ sub DeleteText { my $this = shift; my ($text, $len) = @_; my @lines = split(/ ?
?/, $$text, -1); my $ret = ''; my $tlen = 0; foreach (@lines) { $tlen += length $_; last if ($tlen > $len); $ret .= "$_
"; $tlen += 4; } return substr($ret, 0, -4); } #------------------------------------------------------------------------------------------------------------ # # 改行数取得 - GetTextLine # -------------------------------------------- # 引 数：$text : 対象テキスト(リファレンス) # 戻り値：改行数 # #------------------------------------------------------------------------------------------------------------ sub GetTextLine { my $this = shift; my ($text) = @_; $_ = $$text; my $l = s/(\r\n|[\r\n])/a/g || s/(
)/a/gi; return ($l + 1); } #------------------------------------------------------------------------------------------------------------ # # 行列情報取得 - GetTextInfo # ------------------------------------------------ # 引 数：$text : 調査テキスト(リファレンス) # 戻り値：($tline,$tcolumn) : テキストの行数と # テキストの最大桁数 # 備 考：テキストの行区切りは
になっていること # #------------------------------------------------------------------------------------------------------------ sub GetTextInfo { my $this = shift; my ($text) = @_; my @lines = split(/ ?
?/, $$text, -1); my $mx = 0; foreach (@lines) { if ($mx < length($_)) { $mx = length($_); } } return (scalar(@lines), $mx); } #------------------------------------------------------------------------------------------------------------ # # エージェントモード取得 - GetAgentMode # -------------------------------------------- # 引 数：$UA : ユーザーエージェント # 戻り値：エージェントモード # #------------------------------------------------------------------------------------------------------------ sub GetAgentMode { my $this = shift; my ($client) = @_; my $agent = '0'; if ($client & $ZP::C_MOBILEBROWSER) { $agent = 'O'; } elsif ($client & $ZP::C_FULLBROWSER) { $agent = 'Q'; } elsif ($client & $ZP::C_P2) { $agent = 'P'; } elsif ($client & $ZP::C_IPHONE_F) { $agent = 'i'; } elsif ($client & $ZP::C_IPHONEWIFI) { $agent = 'I'; } else { $agent = '0'; } return $agent; } #------------------------------------------------------------------------------------------------------------ # # クライアント(機種)取得 - GetClient # -------------------------------------------- # 引 数：なし # 戻り値：クライアント(機種) # #------------------------------------------------------------------------------------------------------------ sub GetClient { my $this = shift; my $ua = $ENV{'HTTP_USER_AGENT'} || ''; my $host = $ENV{'REMOTE_HOST'}; my $addr = $ENV{'REMOTE_ADDR'}; my $client = 0; require './module/cidr_list.pl'; my $cidr = $ZP_CIDR::cidr; if (CIDRHIT($cidr->{'docomo'}, $addr)) { $client = $ZP::C_DOCOMO_M; } elsif (CIDRHIT($cidr->{'docomo_pc'}, $addr)) { $client = $ZP::C_DOCOMO_F; } elsif (CIDRHIT($cidr->{'vodafone'}, $addr)) { $client = $ZP::C_SOFTBANK_M; } elsif (CIDRHIT($cidr->{'vodafone_pc'}, $addr)) { $client = $ZP::C_SOFTBANK_F; } elsif (CIDRHIT($cidr->{'ezweb'}, $addr)) { $client = $ZP::C_AU_M; } elsif (CIDRHIT($cidr->{'ezweb_pc'}, $addr)) { $client = $ZP::C_AU_F; } elsif (CIDRHIT($cidr->{'emobile'}, $addr)) { if ($ua =~ m|^emobile/1\.0\.0|) { $client = $ZP::C_EMOBILE_M; } else { $client = $ZP::C_EMOBILE_F; } } elsif (CIDRHIT($cidr->{'willcom'}, $addr)) { if ($ua =~ m|^Mozilla/3\.0|) { $client = $ZP::C_WILLCOM_M; } elsif ($ua =~ m|^Mozilla/4\.0| && $ua =~ m/IEMobile|PPC/) { $client = $ZP::C_WILLCOM_M; } else { $client = $ZP::C_WILLCOM_F; } } elsif (CIDRHIT($cidr->{'ibis'}, $addr)) { $client = $ZP::C_IBIS; } elsif (CIDRHIT($cidr->{'jig'}, $addr)) { $client = $ZP::C_JIG; } elsif (CIDRHIT($cidr->{'iphone'}, $addr)) { $client = $ZP::C_IPHONE_F; } elsif (CIDRHIT($cidr->{'p2'}, $addr)) { $client = $ZP::C_P2; } elsif ($host =~ m|\.opera-mini\.net$|) { $client = $ZP::C_OPERAMINI; } elsif ($ua =~ / iPhone| iPad/) { $client = $ZP::C_IPHONEWIFI; } else { $client = $ZP::C_PC; } return $client; } #------------------------------------------------------------------------------------------------------------ # # IPチェック(CIDR対応) by (-Ac) # ------------------------------------------------------------------------------------- # @param $orz CIDRリスト(配列) # @param $ho チェック文字 # @return ヒットした場合1 それ以外は0 # #------------------------------------------------------------------------------------------------------------ sub CIDRHIT { my ($orz, $ho) = @_; foreach (@$orz) { # 完全一致 = /32 ってことで^^; $_ .= '/32' if ($_ !~ m|/|); # 以下CIDR形式 my ($target, $length) = split('/', $_); my $ipaddr = unpack("B$length", pack('C*', split(/\./, $ho))); $target = unpack("B$length", pack('C*', split(/\./, $target))); if ($target eq $ipaddr) { return 1; } } return 0; } #------------------------------------------------------------------------------------------------------------ # # 携帯機種情報取得 # ------------------------------------------------------------------------------------- # @param $client # @return 個体識別番号 # #------------------------------------------------------------------------------------------------------------ sub GetProductInfo { my $this = shift; my ($client) = @_; my $product; # docomo if ( $client & $ZP::C_DOCOMO ) { # $ENV{'HTTP_X_DCMGUID'} - 端末製造番号, 個体識別情報, ユーザID, iモードID $product = $ENV{'HTTP_X_DCMGUID'}; $product =~ s/^X-DCMGUID: ([a-zA-Z0-9]+)$/$1/i; } # SoftBank elsif ( $client & $ZP::C_SOFTBANK ) { # USERAGENTに含まれる15桁の数字 - 端末シリアル番号 $product = $ENV{'HTTP_USER_AGENT'}; $product =~ s/.+\/SN([A-Za-z0-9]+)\ .+/$1/; } # au elsif ( $client & $ZP::C_AU ) { # $ENV{'HTTP_X_UP_SUBNO'} - サブスクライバID, EZ番号 $product = $ENV{'HTTP_X_UP_SUBNO'}; $product =~ s/([A-Za-z0-9_]+).ezweb.ne.jp/$1/i; } # e-mobile(音声端末) elsif ( $client & $ZP::C_EMOBILE ) { # $ENV{'X-EM-UID'} - $product = $ENV{'X-EM-UID'}; $product =~ s/x-em-uid: (.+)/$1/i; } # 公式p2 elsif ( $client & $ZP::C_P2 ) { # $ENV{'HTTP_X_P2_CLIENT_IP'} - (発言者のIP) # $ENV{'HTTP_X_P2_MOBILE_SERIAL_BBM'} - (発言者の固体識別番号) $ENV{'REMOTE_P2'} = $ENV{'REMOTE_ADDR'}; $ENV{'REMOTE_ADDR'} = $ENV{'HTTP_X_P2_CLIENT_IP'}; $ENV{'REMOTE_HOST'} = $this->GetRemoteHost($ENV{'REMOTE_ADDR'}); if( $ENV{'HTTP_X_P2_MOBILE_SERIAL_BBM'} ne "" ) { $product = $ENV{'HTTP_X_P2_MOBILE_SERIAL_BBM'}; } else { $product = $ENV{'HTTP_USER_AGENT'}; $product =~ s/.+p2-user-hash: (.+)\)/$1/i; } } else { $product = $ENV{'REMOTE_HOST'}; } return $product; } #------------------------------------------------------------------------------------------------------------ # # リモートホスト(IP)取得関数 - GetRemoteHost # --------------------------------------------- # 引 数：なし # 戻り値：IP、リモホス # #------------------------------------------------------------------------------------------------------------ sub GetRemoteHost { my $this = shift; my $host = $ENV{'REMOTE_ADDR'}; $host = gethostbyaddr(pack('C4', split(/\./, $host)), 2) || $host; return $host; } #------------------------------------------------------------------------------------------------------------ # # ID作成関数 - MakeID # -------------------------------------- # 引 数：$server : サーバー名 # $client : 端末 # $koyuu : 端末固有識別子 # $bbs : 板名 # $column : ID桁数 # 戻り値：ID # #------------------------------------------------------------------------------------------------------------ sub MakeID { my $this = shift; my ($server, $client, $koyuu, $bbs, $column) = @_; # 種の生成 my $uid; if ($client & ($ZP::C_P2 | $ZP::C_MOBILE)) { # 端末番号 もしくは p2-user-hash の上位3文字を取得 #$uid = main::GetProductInfo($this, $ENV{'HTTP_USER_AGENT'}, $ENV{'REMOTE_HOST'}); if (length($koyuu) > 8) { $uid = substr($koyuu, 0, 2) . substr($koyuu, -6, 3); } else { $uid = substr($koyuu, 0, 5); } } else { # IPを分解 my @nums = split(/\./, $ENV{'REMOTE_ADDR'}); # 上位3つの1桁目取得 $uid = substr($nums[3], -2) . substr($nums[2], -2) . substr($nums[1], -1); } my @times = localtime time; # サーバー名･板名を結合する $uid .= substr(crypt($server, $times[4]), 2, 1) . substr(crypt($bbs, $times[4]), 2, 2); # 桁を設定 $column *= -1; # IDの生成 my $ret = substr(crypt(crypt($uid, $times[5]), $times[3] + 31), $column); $ret =~ s/\./+/g; return $ret; } sub MakeIDnew { my $this = shift; my ($Sys, $column) = @_; require Digest::SHA::PurePerl; my $ctx = Digest::SHA::PurePerl->new; $ctx->add('0ch+ ID Generation'); $ctx->add(':', $Sys->Get('SERVER')); $ctx->add(':', $Sys->Get('BBS')); $ctx->add(':', $Sys->Get('KOYUU')); $ctx->add(':', join('-', (localtime)[3,4,5])); #$ctx->add(':', $Sys->Get('KEY')); my $id = $ctx->b64digest; $id = substr($id, 0, $column); return $id; } #------------------------------------------------------------------------------------------------------------ # # トリップ作成関数 - ConvertTrip # -------------------------------------- # 引 数：$key : トリップキー(リファレンス) # $column : 桁数 # $shatrip : 12桁トリップON/OFF # 戻り値：変換後文字列 # #------------------------------------------------------------------------------------------------------------ sub ConvertTrip { my $this = shift; my ($key, $column, $shatrip) = @_; # cryptのときの桁取得 $column *= -1; my $trip = ''; $$key = '' if (!defined $$key); if (length($$key) >= 12) { # 先頭1文字の取得 my $mark = substr($$key, 0, 1); if ($mark eq '#' || $mark eq '$') { # 生キー if ($$key =~ m|^#([0-9a-zA-Z]{16})([./0-9A-Za-z]{0,2})$|) { my $key2 = pack('H*', $1); my $salt = substr($2 . '..', 0, 2); # 0x80問題再現 $key2 =~ s/\x80[\x00-\xff]*$//; $trip = substr(crypt($key2, $salt), $column); } # 将来の拡張用 else { $trip = '???'; } } # SHA1(新仕様)トリップ elsif ($shatrip) { require Digest::SHA::PurePerl; Digest::SHA::PurePerl->import( qw(sha1_base64) ); $trip = substr(sha1_base64($$key), 0, 12); $trip =~ tr/+/./; } } # 従来のトリップ生成方式 if ($trip eq '') { my $salt = substr($$key, 1, 2); $salt = '' if (!defined $salt); $salt .= 'H.'; $salt =~ s/[^\.-z]/\./go; $salt =~ tr/:;<=>?@[\\]^_`/ABCDEFGabcdef/; # 0x80問題再現 $$key =~ s/\x80[\x00-\xff]*$//; $trip = substr(crypt($$key, $salt), $column); } return $trip; } #------------------------------------------------------------------------------------------------------------ # # オプション変換 - ConvertOption # -------------------------------------- # 引 数：$opt : オプション # 戻り値：結果配列 # #------------------------------------------------------------------------------------------------------------ sub ConvertOption { my ($opt) = @_; $opt = '' if (!defined $opt); # 初期値 my @ret = ( -1, # ラストフラグ -1, # 開始行 -1, # 終了行 -1, # >>1非表示フラグ -1 # 単独表示フラグ ); # 最新n件(1無し) if ($opt =~ /l(\d+)n/) { $ret[0] = 1; $ret[1] = $1 + 1; $ret[2] = $1 + 1; $ret[3] = 1; } # 最新n件(1あり) elsif ($opt =~ /l(\d+)/) { $ret[0] = 1; $ret[1] = $1; $ret[2] = $1; $ret[3] = 0; } # n-m(1無し) elsif ($opt =~ /(\d+)-(\d+)n/) { $ret[0] = 0; $ret[1] = $1; $ret[2] = $2; $ret[3] = 1; } # n-m(1あり) elsif ($opt =~ /(\d+)-(\d+)/) { $ret[0] = 0; $ret[1] = $1; $ret[2] = $2; $ret[3] = 0; } # n以降(1無し) elsif ($opt =~ /(\d+)-n/) { $ret[0] = 0; $ret[1] = $1; $ret[2] = -1; $ret[3] = 1; } # n以降(1あり) elsif ($opt =~ /(\d+)-/) { $ret[0] = 0; $ret[1] = $1; $ret[2] = -1; $ret[3] = 0; } # nまで(1あり) elsif ($opt =~ /-(\d+)/) { $ret[0] = 0; $ret[1] = 1; $ret[2] = $1; $ret[3] = 0; } # n表示(1無し) elsif ($opt =~ /(\d+)n/) { $ret[0] = 0; $ret[1] = $1; $ret[2] = $1; $ret[3] = 1; $ret[4] = 1; } # n表示(1あり) elsif ($opt =~ /(\d+)/) { $ret[0] = 0; $ret[1] = $1; $ret[2] = $1; $ret[3] = 1; $ret[4] = 1; } return @ret; } #------------------------------------------------------------------------------------------------------------ # # パス生成 - CreatePath # ------------------------------------------- # 引 数：$Sys : MELKOR # $mode : 0:read 1:r # $bbs : BBSキー # $key : スレッドキー # $opt : オプション # 戻り値：生成されたパス # #------------------------------------------------------------------------------------------------------------ sub CreatePath { my $this = shift; my ($Sys, $mode, $bbs, $key, $opt) = @_; my $path = $Sys->Get('SERVER') . $Sys->Get('CGIPATH') . ($mode eq 0 ? '/read.cgi' : '/r.cgi'); # QUERY_STRINGパス生成 if ($Sys->Get('PATHKIND')) { my @opts = ConvertOption($opt); # ベース作成 $path .= "?bbs=$bbs&key=$key"; # 最新n件表示 if ($opts[0]) { $path .= "&last=$opts[1]"; } # 指定表示 else { $path .= "&st=$opts[1]"; $path .= "&to=$opts[2]"; } # >>1表示の付加 $path .= '&nofirst=' . ($opts[3] == 1 ? 'true' : 'false'); } # PATH_INFOパス生成 else { $path .= "/$bbs/$key/$opt"; } return $path; } #------------------------------------------------------------------------------------------------------------ # # 日付取得 - GetDate # -------------------------------------- # 引 数：$Set : SETTING.TXT # $msect : msec on/off # 戻り値：日付文字列 # #------------------------------------------------------------------------------------------------------------ sub GetDate { my $this = shift; my ($Set, $msect) = @_; $ENV{'TZ'} = 'JST-9'; my @info = localtime time; $info[5] += 1900; $info[4] += 1; # 曜日の取得 my $week = ('日', '月', '火', '水', '木', '金', '土')[$info[6]]; if (defined $Set && ! $Set->Equal('BBS_YMD_WEEKS', '')) { $week = (split(/\//, $Set->Get('BBS_YMD_WEEKS')))[$info[6]]; } my $str = ''; $str .= sprintf('%04d/%02d/%02d', $info[5], $info[4], $info[3]); $str .= "($week)" if ($week ne ''); $str .= sprintf(' %02d:%02d:%02d', $info[2], $info[1], $info[0]); # msecの取得 if ($msect) { eval { require Time::HiRes; my $times = Time::HiRes::time(); $str .= sprintf(".%02d", ($times * 100) % 100); }; } return $str; } #------------------------------------------------------------------------------------------------------------ # # シリアル値から日付文字列を取得する # ------------------------------------------------------------------------------------- # @param $serial シリアル値 # @param $mode 0:時間表示有り 1:日付のみ # @return 日付文字列 # #------------------------------------------------------------------------------------------------------------ sub GetDateFromSerial { my $this = shift; my ($serial, $mode) = @_; $ENV{'TZ'} = 'JST-9'; my @info = localtime $serial; $info[5] += 1900; $info[4] += 1; my $str = sprintf('%04d/%02d/%02d', $info[5], $info[4], $info[3]); $str .= sprintf(' %02d:%02d', $info[2], $info[1]) if (!$mode); return $str; } #------------------------------------------------------------------------------------------------------------ # # ID部分文字列生成 # ------------------------------------------------------------------------------------- # @param $Set ISILDUR # @param $Form SAMWISE # @param $Sec # @param $id ID # @param $koyuu 端末固有番号 # @param $type 端末識別子 # @return ID部分文字列 # #------------------------------------------------------------------------------------------------------------ sub GetIDPart { my $this = shift; my ($Set, $Form, $Sec, $id, $capID, $koyuu, $type) = @_; my $noid = $Sec->IsAuthority($capID, $ZP::CAP_DISP_NOID, $Form->Get('bbs')); my $noslip = $Sec->IsAuthority($capID, $ZP::CAP_DISP_NOSLIP, $Form->Get('bbs')); my $customid = $Sec->IsAuthority($capID, $ZP::CAP_DISP_CUSTOMID, $Form->Get('bbs')); # ID表示無し if ($Set->Equal('BBS_NO_ID', 'checked')) { return ''; } # ホスト表示 elsif ($Set->Equal('BBS_DISP_IP', 'checked')) { my $str = '???'; if ($noid) { $str = '???'; } elsif ($type eq 'O') { $str = "$koyuu $ENV{'REMOTE_HOST'}"; } elsif ($type eq 'P') { $str = "$koyuu $ENV{'REMOTE_HOST'} ($ENV{'REMOTE_ADDR'})"; } else { $str = "$koyuu"; } if (!$noslip && $Set->Equal('BBS_SLIP', 'checked')) { $str .= " $type"; } return "HOST:$str"; } # IP表示 Ver.Siberia elsif ($Set->Equal('BBS_DISP_IP', 'siberia')){ my $str = '???'; if ($noid) { $str = '???'; } elsif ($type eq 'P') { $str = "$ENV{'REMOTE_P2'}"; } else { $str = "$ENV{'REMOTE_ADDR'}"; } if (!$noslip && $Set->Equal('BBS_SLIP', 'checked')) { $str .= " $type"; } return "発信元:$str"; } # IP表示 Ver.Sakhalin elsif ($Set->Equal('BBS_DISP_IP', 'sakhalin')) { my $str = '???'; if ($noid) { $str = '???'; } elsif ($type eq 'P') { $str = "$ENV{'HTTP_X_P2_CLIENT_IP'} ($koyuu)"; } elsif ($type eq 'O') { $str = "$ENV{'REMOTE_ADDR'} ($koyuu)"; } else { $str = "$ENV{'REMOTE_ADDR'}"; } if (!$noslip && $Set->Equal('BBS_SLIP', 'checked')) { $str .= " $type"; } return "発信元:$str"; } # 各キャップ専用ID elsif ($customid && $Sec->Get($capID, 'CUSTOMID', 1) ne '') { my $str = $Sec->Get($capID, 'CUSTOMID', 1); if (!$noslip && $Set->Equal('BBS_SLIP', 'checked')) { $str .= " $type"; } return "ID:$str"; } # ID表示 else { my $str = '???'; if ($noid) { $str = '???'; } elsif ($Set->Equal('BBS_FORCE_ID', 'checked')) { $str = $id; } elsif ($Form->IsInput(['mail'])) { $str = '???'; } else { $str = $id; } if (!$noslip && $Set->Equal('BBS_SLIP', 'checked')) { $str .= "$type"; } return "ID:$str"; } } #------------------------------------------------------------------------------------------------------------ # # 特殊文字変換 - ConvertCharacter0 # -------------------------------------- # 引 数：$data : 変換元データ(参照) # 戻り値：なし # #------------------------------------------------------------------------------------------------------------ sub ConvertCharacter0 { my $this = shift; my ($data) = @_; $$data = '' if (!defined $$data); $$data =~ s/^($ZP::RE_SJIS*?)＃/$1#/g; } #------------------------------------------------------------------------------------------------------------ # # 特殊文字変換 - ConvertCharacter1 # -------------------------------------- # 引 数：$data : 変換元データ(参照) # $mode : # 戻り値：なし # #------------------------------------------------------------------------------------------------------------ sub ConvertCharacter1 { my $this = shift; my ($data, $mode) = @_; $$data = '' if (!defined $$data); # all $$data =~ s//>/g; # mail if ($mode == 1) { $$data =~ s/"/"/g;#" } # text if ($mode == 2) { $$data =~ s/\n/
/g; } # not text else { $$data =~ s/\n//g; } } #------------------------------------------------------------------------------------------------------------ # # 禁則文字変換 - ConvertCharacter2 # -------------------------------------- # 引 数：$data : 変換元データ(参照) # $mode : # 戻り値：なし # #------------------------------------------------------------------------------------------------------------ sub ConvertCharacter2 { my $this = shift; my ($data, $mode) = @_; $$data = '' if (!defined $$data); # name mail if ($mode == 0 || $mode == 1) { $$data =~ s/★/☆/g; $$data =~ s/◆/◇/g; $$data =~ s/削除/”削除”/g; } # name if ($mode == 0) { $$data =~ s/管理/”管理”/g; $$data =~ s/管直/”管直”/g; $$data =~ s/復帰/”復帰”/g; } } #------------------------------------------------------------------------------------------------------------ # # 特殊文字変換 - ConvertFusianasan # -------------------------------------- # 引 数：$data : 変換元データ(参照) # $host : # 戻り値：なし # #------------------------------------------------------------------------------------------------------------ sub ConvertFusianasan { my $this = shift; my ($data, $host) = @_; $$data = '' if (!defined $$data); $$data =~ s/山崎渉/fusianasan/g; $$data =~ s|^($ZP::RE_SJIS*?)fusianasan|$1$host|g; $$data =~ s|^($ZP::RE_SJIS*?)fusianasan|$1 $host|g; } #------------------------------------------------------------------------------------------------------------ # # 連続アンカー検出 - IsAnker # -------------------------------------- # 引 数：$text : 検査対象テキスト # $num : 最大アンカー数 # 戻り値：0:許容内 1:だめぽ # #------------------------------------------------------------------------------------------------------------ sub IsAnker { my $this = shift; my ($text, $num) = @_; $_ = $$text; my $cnt = s/>>([1-9])//g; return ($cnt > $num ? 1 : 0); } #------------------------------------------------------------------------------------------------------------ # # リファラ判断 - IsReferer # -------------------------------------- # 引 数：$Sys : MELKOR # 戻り値：許可なら0,NGなら1 # #------------------------------------------------------------------------------------------------------------ sub IsReferer { my $this = shift; my ($Sys, $pENV) = @_; my $svr = $Sys->Get('SERVER'); if ($pENV->{'HTTP_REFERER'} =~ /\Q$svr\E/) { # 自鯖からならOK return 0; } if ($pENV->{'HTTP_USER_AGENT'} =~ /Monazilla/) { # ２ちゃんツールもOK return 0; } return 1; } #------------------------------------------------------------------------------------------------------------ # # プロクシチェック - IsProxy # -------------------------------------- # 引 数：$Sys : MELKOR # $Form : # $from : 名前欄 # $mode : エージェント # 戻り値：プロクシなら対象ポート番号 # #------------------------------------------------------------------------------------------------------------ sub IsProxy { my $this = shift; my ($Sys, $Form, $from, $mode) = @_; # 携帯, iPhone(3G回線) はプロキシ規制を回避する return 0 if ($mode eq 'O' || $mode eq 'i'); my @dnsbls = (); push(@dnsbls, 'niku.2ch.net') if($Sys->Get('BBQ')); push(@dnsbls, 'bbx.2ch.net') if($Sys->Get('BBX')); # DNSBL問い合わせ my $addr = join('.', reverse( split(/\./, $ENV{'REMOTE_ADDR'}))); foreach my $dnsbl (@dnsbls) { if (CheckDNSBL("$addr.$dnsbl") eq '127.0.0.2') { $Form->Set('FROM', " [―\{}\@{}\@{}-] $from"); return ($mode eq 'P' ? 0 : 1); } } return 0; } #------------------------------------------------------------------------------------------------------------ # # DNSBL正引き(timeout付き) - CheckDNSBL # -------------------------------------- # 引 数：$host : 正引きするHOST # 戻り値：プロキシであれば127.0.0.2 # #------------------------------------------------------------------------------------------------------------ sub CheckDNSBL { my ($host) = @_; my $ret = eval { require Net::DNS; my $res = Net::DNS::Resolver->new; $res->tcp_timeout(1); $res->udp_timeout(1); $res->retry(1); if ((my $query = $res->query($host))) { my @ans = $query->answer; foreach (@ans) { return $_->address; } } if ($res->errorstring eq 'query timed out') { return '127.0.0.0'; } }; return $ret if (defined $ret); if ($@) { require Net::DNS::Lite; my $res = Net::DNS::Lite->new( server => [ qw(8.8.4.4 8.8.8.8) ], # google public dns timeout => [2, 3], ); my @ans = $res->resolve($host, 'a'); return $_->[4] foreach (@ans); } return '127.0.0.1'; } #------------------------------------------------------------------------------------------------------------ # # パス合成・正規化 - MakePath * not mkdir/mkpath # -------------------------------------- # 引 数：$path1 : パス1 # $path2 : パス2 # 戻り値：正規化パス # #------------------------------------------------------------------------------------------------------------ sub MakePath { my $this = (ref($_[0]) eq 'GALADRIEL' ? shift : undef); my ($path1, $path2) = @_; $path1 = '.' if (! defined $path1 || $path1 eq ''); $path2 = '.' if (! defined $path2 || $path2 eq ''); my @dir1 = ($path1 =~ m[^/|[^/]+]g); my @dir2 = ($path2 =~ m[^/|[^/]+]g); my $absflg = 0; if ($dir2[0] eq '/') { $absflg = 1; @dir1 = @dir2; } else { push @dir1, @dir2; } my @dir3 = (); my $depth = 0; for my $i (0 .. $#dir1) { if ($i == 0 && $dir1[$i] eq '/') { $absflg = 1; } elsif ($dir1[$i] eq '.' || $dir1[$i] eq '') { } elsif ($dir1[$i] eq '..') { if ($depth >= 1) { pop @dir3; } else { if ($absflg) { last; } if ($#dir3 == -1 || $dir3[$#dir3] eq '..') { push @dir3, '..'; } else { pop @dir3; } } $depth--; } else { push @dir3, $dir1[$i]; $depth++; } } my $path3; if ($#dir3 == -1) { $path3 = ($absflg ? '/' : '.'); } else { $path3 = ($absflg ? '/' : '') . join('/', @dir3); } return $path3; } #============================================================================================================ # モジュール終端 #============================================================================================================ 1; zerochplus_0.7.5/test/module/index.html 0000644 0000000 0000000 00000000015 14216364774 015144 0 ustar 403 Forbidden zerochplus_0.7.5/test/module/elves.pl 0000644 0000000 0000000 00000052352 14216364775 014636 0 ustar #============================================================================================================ # # 管理セキュリティ管理モジュール # ------------------------------------------------------------------------------------- # このモジュールは管理CGIのセキュリティ情報を管理します。 # 以下の3つのパッケージによって構成されます # # GLORFINDEL : ユーザ情報管理 # GILDOR : グループ情報管理 # ARWEN : セキュリティインタフェイス # #============================================================================================================ #============================================================================================================ # # ユーザ管理パッケージ # #============================================================================================================ package GLORFINDEL; use strict; #use warnings; #------------------------------------------------------------------------------------------------------------ # # コンストラクタ # ------------------------------------------------------------------------------------- # @param なし # @return モジュールオブジェクト # #------------------------------------------------------------------------------------------------------------ sub new { my $class = shift; my $obj = { 'NAME' => undef, 'PASS' => undef, 'FULL' => undef, 'EXPL' => undef, 'SYSAD' => undef, }; bless $obj, $class; return $obj; } #------------------------------------------------------------------------------------------------------------ # # ユーザ情報読み込み # ------------------------------------------------------------------------------------- # @param $Sys MELKOR # @return なし # #------------------------------------------------------------------------------------------------------------ sub Load { my $this = shift; my ($Sys) = @_; # ハッシュ初期化 $this->{'NAME'} = {}; $this->{'PASS'} = {}; $this->{'FULL'} = {}; $this->{'EXPL'} = {}; $this->{'SYSAD'} = {}; my $path = '.' . $Sys->Get('INFO') . '/users.cgi'; if (open(my $fh, '<', $path)) { flock($fh, 2); my @lines = <$fh>; close($fh); map { s/[\r\n]+\z// } @lines; foreach (@lines) { next if ($_ eq ''); my @elem = split(/<>/, $_, -1); if (scalar(@elem) < 6) { warn "invalid line in $path"; next; } my $id = $elem[0]; $this->{'NAME'}->{$id} = $elem[1]; $this->{'PASS'}->{$id} = $elem[2]; $this->{'FULL'}->{$id} = $elem[3]; $this->{'EXPL'}->{$id} = $elem[4]; $this->{'SYSAD'}->{$id} = $elem[5]; } } } #------------------------------------------------------------------------------------------------------------ # # ユーザ情報保存 # ------------------------------------------------------------------------------------- # @param $Sys MELKOR # @return なし # #------------------------------------------------------------------------------------------------------------ sub Save { my $this = shift; my ($Sys) = @_; my $path = '.' . $Sys->Get('INFO') . '/users.cgi'; chmod($Sys->Get('PM-ADM'), $path); if (open(my $fh, (-f $path ? '+<' : '>'), $path)) { flock($fh, 2); binmode($fh); seek($fh, 0, 0); foreach (keys %{$this->{'NAME'}}) { my $data = join('<>', $_, $this->{'NAME'}->{$_}, $this->{'PASS'}->{$_}, $this->{'FULL'}->{$_}, $this->{'EXPL'}->{$_}, $this->{'SYSAD'}->{$_} ); print $fh "$data\n"; } truncate($fh, tell($fh)); close($fh); } chmod($Sys->Get('PM-ADM'), $path); } #------------------------------------------------------------------------------------------------------------ # # ユーザIDセット取得 # ------------------------------------------------------------------------------------- # @param $kind 検索種別 # @param $name 検索ワード # @param $pBuf IDセット格納バッファ # @return キーセット数 # #------------------------------------------------------------------------------------------------------------ sub GetKeySet { my $this = shift; my ($kind, $name, $pBuf) = @_; my $n = 0; if ($kind eq 'ALL') { $n += push @$pBuf, keys %{$this->{'NAME'}}; } else { foreach my $key (keys %{$this->{$kind}}) { if ($this->{$kind}->{$key} eq $name || $kind eq 'ALL') { $n += push @$pBuf, $key; } } } return $n; } #------------------------------------------------------------------------------------------------------------ # # ユーザ情報取得 # ------------------------------------------------------------------------------------- # @param $kind 情報種別 # @param $key ユーザID # @param $default デフォルト # @return ユーザ情報 # #------------------------------------------------------------------------------------------------------------ sub Get { my $this = shift; my ($kind, $key, $default) = @_; my $val = $this->{$kind}->{$key}; return (defined $val ? $val : (defined $default ? $default : undef)); } #------------------------------------------------------------------------------------------------------------ # # ユーザ追加 # ------------------------------------------------------------------------------------- # @param $name 情報種別 # @param $pass ユーザID # @param $full # @param $explan 説明 # @param $sysad 管理者フラグ # @return ユーザID # #------------------------------------------------------------------------------------------------------------ sub Add { my $this = shift; my ($name, $pass, $full, $explan, $sysad) = @_; my $id = time; $this->{'NAME'}->{$id} = $name; $this->{'PASS'}->{$id} = $this->GetStrictPass($pass, $id); $this->{'EXPL'}->{$id} = $explan; $this->{'FULL'}->{$id} = $full; $this->{'SYSAD'}->{$id} = $sysad; return $id; } #------------------------------------------------------------------------------------------------------------ # # ユーザ情報設定 # ------------------------------------------------------------------------------------- # @param $id ユーザID # @param $kind 情報種別 # @param $val 設定値 # @return なし # #------------------------------------------------------------------------------------------------------------ sub Set { my $this = shift; my ($id, $kind, $val) = @_; if (exists $this->{$kind}->{$id}) { if ($kind eq 'PASS') { $val = $this->GetStrictPass($val, $id); } $this->{$kind}->{$id} = $val; } } #------------------------------------------------------------------------------------------------------------ # # ユーザ情報削除 # ------------------------------------------------------------------------------------- # @param $id 削除ユーザID # @return なし # #------------------------------------------------------------------------------------------------------------ sub Delete { my $this = shift; my ($id) = @_; delete $this->{'NAME'}->{$id}; delete $this->{'PASS'}->{$id}; delete $this->{'FULL'}->{$id}; delete $this->{'EXPL'}->{$id}; delete $this->{'SYSAD'}->{$id}; } #------------------------------------------------------------------------------------------------------------ # # 暗号化パス取得 # ------------------------------------------------------------------------------------- # @param $pass パスワード # @param $key パスワード変換キー # @return 暗号化されたパスコード # #------------------------------------------------------------------------------------------------------------ sub GetStrictPass { my $this = shift; my ($pass, $key) = @_; my $hash; if (length($pass) >= 9) { require Digest::SHA::PurePerl; Digest::SHA::PurePerl->import( qw(sha1_base64) ); $hash = substr(crypt($key, 'ZC'), -2); $hash = substr(sha1_base64("ZeroChPlus_${hash}_$pass"), 0, 10); } else { $hash = substr(crypt($pass, substr(crypt($key, 'ZC'), -2)), -10); } return $hash; } #============================================================================================================ # # グループ管理パッケージ # #============================================================================================================ package GILDOR; use strict; #use warnings; #------------------------------------------------------------------------------------------------------------ # # コンストラクタ # ------------------------------------------------------------------------------------- # @param なし # @return モジュールオブジェクト # #------------------------------------------------------------------------------------------------------------ sub new { my $class = shift; my $obj = { 'NAME' => undef, 'EXPL' => undef, 'AUTH' => undef, 'USERS' => undef, }; bless $obj, $class; return $obj; } #------------------------------------------------------------------------------------------------------------ # # グループ情報読み込み # ------------------------------------------------------------------------------------- # @param $Sys MELKOR # @return なし # #------------------------------------------------------------------------------------------------------------ sub Load { my $this = shift; my ($Sys) = @_; # ハッシュ初期化 $this->{'NAME'} = {}; $this->{'EXPL'} = {}; $this->{'AUTH'} = {}; $this->{'USERS'} = {}; my $path = $Sys->Get('BBSPATH') . '/' . $Sys->Get('BBS') . '/info/groups.cgi'; if (open(my $fh, '<', $path)) { flock($fh, 2); my @lines = <$fh>; close($fh); map { s/[\r\n]+\z// } @lines; foreach (@lines) { next if ($_ eq ''); my @elem = split(/<>/, $_, -1); if (scalar(@elem) < 5) { warn "invalid line in $path"; next; } my $id = $elem[0]; $elem[4] =~ s/ //g; $this->{'NAME'}->{$id} = $elem[1]; $this->{'EXPL'}->{$id} = $elem[2]; $this->{'AUTH'}->{$id} = $elem[3]; $this->{'USERS'}->{$id} = $elem[4]; } } } #------------------------------------------------------------------------------------------------------------ # # グループ情報保存 # ------------------------------------------------------------------------------------- # @param $Sys MELKOR # @return なし # #------------------------------------------------------------------------------------------------------------ sub Save { my $this = shift; my ($Sys) = @_; my $path = $Sys->Get('BBSPATH') . '/' . $Sys->Get('BBS') . '/info/groups.cgi'; chmod($Sys->Get('PM-ADM'), $path); if (open(my $fh, (-f $path ? '+<' : '>'), $path)) { flock($fh, 2); seek($fh, 0, 0); binmode($fh); foreach (keys %{$this->{'NAME'}}) { my $data = join('<>', $_, $this->{'NAME'}->{$_}, $this->{'EXPL'}->{$_}, $this->{'AUTH'}->{$_}, $this->{'USERS'}->{$_} ); print $fh "$data\n"; } truncate($fh, tell($fh)); close($fh); } chmod($Sys->Get('PM-ADM'), $path); } #------------------------------------------------------------------------------------------------------------ # # グループIDセット取得 # ------------------------------------------------------------------------------------- # @param $pBuf IDセット格納バッファ # @return グループID数 # #------------------------------------------------------------------------------------------------------------ sub GetKeySet { my $this = shift; my ($pBuf) = @_; my $n += push @$pBuf, keys %{$this->{'NAME'}}; return $n; } #------------------------------------------------------------------------------------------------------------ # # グループ情報取得 # ------------------------------------------------------------------------------------- # @param $kind 種別 # @param $key グループID # @param $default デフォルト # @return グループ名 # #------------------------------------------------------------------------------------------------------------ sub Get { my $this = shift; my ($kind, $key, $default) = @_; my $val = $this->{$kind}->{$key}; return (defined $val ? $val : (defined $default ? $default : undef)); } #------------------------------------------------------------------------------------------------------------ # # グループ追加 # ------------------------------------------------------------------------------------- # @param $name 情報種別 # @param $explan 説明 # @param $authors 権限セット # @param $users ユーザセット # @return グループID # #------------------------------------------------------------------------------------------------------------ sub Add { my $this = shift; my ($name, $explan, $authors, $users) = @_; my $id = time; $this->{'NAME'}->{$id} = $name; $this->{'EXPL'}->{$id} = $explan; $this->{'AUTH'}->{$id} = $authors; $this->{'USERS'}->{$id} = $users; return $id; } #------------------------------------------------------------------------------------------------------------ # # グループユーザ追加 # ------------------------------------------------------------------------------------- # @param $id グループID # @param $user 追加ユーザID # @return なし # #------------------------------------------------------------------------------------------------------------ sub AddUser { my $this = shift; my ($id, $user) = @_; my @users = split(/\,/, $this->{'USERS'}->{$id}); my @match = grep($user, @users); # 登録済みのユーザは重複登録しない if (scalar(@match)) { $this->{'USERS'}->{$id} .= ",$user"; } } #------------------------------------------------------------------------------------------------------------ # # グループ情報設定 # ------------------------------------------------------------------------------------- # @param $id グループID # @param $kind 情報種別 # @param $val 設定値 # @return なし # #------------------------------------------------------------------------------------------------------------ sub Set { my $this = shift; my ($id, $kind, $val) = @_; if (exists $this->{$kind}->{$id}) { $this->{$kind}->{$id} = $val; } } #------------------------------------------------------------------------------------------------------------ # # グループ情報削除 # ------------------------------------------------------------------------------------- # @param $id 削除グループID # @return なし # #------------------------------------------------------------------------------------------------------------ sub Delete { my $this = shift; my ($id) = @_; delete $this->{'NAME'}->{$id}; delete $this->{'EXPL'}->{$id}; delete $this->{'AUTH'}->{$id}; delete $this->{'USERS'}->{$id}; } #------------------------------------------------------------------------------------------------------------ # # 所属ユーザグループ取得 # ------------------------------------------------------------------------------------- # @param $id ユーザID # @return ユーザが所属しているグループID # #------------------------------------------------------------------------------------------------------------ sub GetBelong { my $this = shift; my ($id) = @_; my $Users = $this->{'USERS'}; foreach my $group (keys %$Users) { my @users = split(/\,/, $Users->{$group}); foreach my $user (@users) { if ($id eq $user) { return $group; } } } return ''; } #============================================================================================================ # # セキュリティ管理パッケージ # #============================================================================================================ package ARWEN; use strict; #use warnings; use CGI::Session; #------------------------------------------------------------------------------------------------------------ # # コンストラクタ # ------------------------------------------------------------------------------------- # @param なし # @return モジュールオブジェクト # #------------------------------------------------------------------------------------------------------------ sub new { my $class = shift; my $obj = { 'SYS' => undef, 'USER' => undef, 'GROUP' => undef, 'BBS' => undef, 'SOPT' => undef, }; bless $obj, $class; return $obj; } #------------------------------------------------------------------------------------------------------------ # # 初期化 # ------------------------------------------------------------------------------------- # @param $Sys MELKOR # @return なし # #------------------------------------------------------------------------------------------------------------ sub Init { my $this = shift; my ($Sys) = @_; $this->{'SYS'} = $Sys; # 2重ロード防止 if (! defined $this->{'USER'}) { $this->{'USER'} = GLORFINDEL->new; $this->{'GROUP'} = GILDOR->new; $this->{'USER'}->Load($Sys); my $infopath = $Sys->Get('INFO'); $this->{'SOPT'} = { 'min' => 30, 'driver' => 'driver:file;serializer:default', 'option' => { Directory => ".$infopath/.session/" }, }; $this->CleanSessions; } } #------------------------------------------------------------------------------------------------------------ # # ログイン判定 # ------------------------------------------------------------------------------------- # @param $name ユーザ名 # @param $pass パスワード # @param $sid セッションID # @return 正式なユーザなら1を返す # #------------------------------------------------------------------------------------------------------------ sub IsLogin { my $this = shift; my ($name, $pass, $sid) = @_; my $User = $this->{'USER'}; my @keySet = (); $User->GetKeySet('NAME', $name, \@keySet); return (0, '') if (!scalar(@keySet)); my $opt = $this->{'SOPT'}; if (defined $pass && $pass ne '') { my $userid = undef; foreach my $id (@keySet) { my $lPass = $User->Get('PASS', $id); my $hash = $User->GetStrictPass($pass, $id); if ($lPass eq $hash) { $userid = $id; last; } } return (0, '') if (!$userid); my $session = CGI::Session->new($opt->{'driver'}, undef, $opt->{'option'}); $session->param('addr', $ENV{'REMOTE_ADDR'}); $session->param('user', $name); $session->param('uid', $userid); $session->expire("+$opt->{'min'}m"); return ($userid, $session->id()); } elsif (defined $sid && $sid ne '') { my $session = CGI::Session->new($opt->{'driver'}, $sid, $opt->{'option'}); $_ = $session->param('addr'); if (!defined $_ || $_ ne $ENV{'REMOTE_ADDR'}) { $session->delete(); return (0, ''); } $_ = $session->param('user'); if (!defined $_ || $_ ne $name) { $session->delete(); return (0, ''); } my $userid = undef; $_ = $session->param('uid'); foreach my $id (@keySet) { if ($_ eq $id) { $userid = $id; last; } } if (!$userid) { $session->delete(); return (0, ''); } $session->expire("+$opt->{'min'}m"); return ($userid, $session->id()); } else { return (0, ''); } } sub Logout { my $this = shift; my ($sid) = @_; my $opt = $this->{'SOPT'}; my $session = CGI::Session->new($opt->{'driver'}, $sid, $opt->{'option'}); $session->delete(); } sub CleanSessions { my $this = shift; my $opt = $this->{'SOPT'}; CGI::Session->find($opt->{'driver'}, sub { my ($session) = @_; if ($session->is_empty || $session->atime + 60*$opt->{'min'} <= time) { $session->delete(); } }, $opt->{'option'}); } #------------------------------------------------------------------------------------------------------------ # # 権限判定前グループ情報準備 # ------------------------------------------------------------------------------------- # @param $bbs 適応個所 # @return なし # #------------------------------------------------------------------------------------------------------------ sub SetGroupInfo { my $this = shift; my ($bbs) = @_; my $Sys = $this->{'SYS'}; my $oldbbs = $Sys->Get('BBS'); $Sys->Set('BBS', $bbs); $this->{'BBS'} = $bbs; $this->{'GROUP'}->Load($Sys); $Sys->Set('BBS', $oldbbs); } #------------------------------------------------------------------------------------------------------------ # # 権限判定 # ------------------------------------------------------------------------------------- # @param $id ユーザID # @param $author 権限 # @param $bbs 適応個所 # @return ユーザが権限を持っていたら1を返す # #------------------------------------------------------------------------------------------------------------ sub IsAuthority { my $this = shift; my ($id, $author, $bbs) = @_; # システム管理権限グループなら無条件OK my $sysad = $this->{'USER'}->Get('SYSAD', $id); return 1 if ($sysad); return 0 if ($bbs eq '*'); # 対象BBSに所属しているか確認 my $group = $this->{'GROUP'}->GetBelong($id); return 0 if ($group eq ''); # 権限を持っているか確認 my $auth = $this->{'GROUP'}->Get('AUTH', $group); my @authors = split(/\,/, $auth); foreach my $auth (@authors) { if ($auth == $author) { return 1; } } return 0; } #------------------------------------------------------------------------------------------------------------ # # 所属掲示板リスト取得 # ------------------------------------------------------------------------------------- # @param $id ユーザID # @param $BBS NAZGULオブジェクト # @param $pList 結果格納用配列の参照 # @return 所属掲示板数 # #------------------------------------------------------------------------------------------------------------ sub GetBelongBBSList { my $this = shift; my ($id, $Bbs, $pList) = @_; my $n = 0; # システム管理ユーザは全てのBBSに所属とする if ($this->{'USER'}->Get('SYSAD', $id)) { $Bbs->GetKeySet('ALL', '', $pList); $n = scalar @$pList; } # 一般ユーザは所属グループから判断する else { my $origbbs = $this->{'BBS'}; my @keySet = (); $Bbs->GetKeySet('ALL', '', \@keySet); foreach my $bbsID (@keySet) { my $bbsDir = $Bbs->Get('DIR', $bbsID); SetGroupInfo($this, $bbsDir); if ($this->{'GROUP'}->GetBelong($id) ne '') { $n += push @$pList, $bbsID; } } # 後処理 if (defined $origbbs) { SetGroupInfo($this, $origbbs); } } return $n; } #============================================================================================================ # Module END #============================================================================================================ 1; zerochplus_0.7.5/test/module/thorin.pl 0000644 0000000 0000000 00000006763 14216364775 015030 0 ustar #============================================================================================================ # # 出力管理モジュール # #============================================================================================================ package THORIN; use strict; #use warnings; #------------------------------------------------------------------------------------------------------------ # # モジュールコンストラクタ - new # ------------------------------------------- # 引 数：なし # 戻り値：モジュールオブジェクト # #------------------------------------------------------------------------------------------------------------ sub new { my $class = shift; my $obj = { 'BUFF' => [], }; bless $obj, $class; return $obj; } #------------------------------------------------------------------------------------------------------------ # # バッファ出力 - Print # ------------------------------------------- # 引 数：$line : 出力テキスト # 戻り値：なし # #------------------------------------------------------------------------------------------------------------ sub Print { my $this = shift; my ($line) = @_; push @{$this->{'BUFF'}}, $line; } #------------------------------------------------------------------------------------------------------------ # # INPUTタグ出力 - HTMLInput # ------------------------------------------- # 引 数：$kind : タイプ # $name : 名前 # $value : 値 # 戻り値：なし # #------------------------------------------------------------------------------------------------------------ sub HTMLInput { my $this = shift; my ($kind, $name, $value) = @_; my $line = "\n"; push @{$this->{'BUFF'}}, $line; } #------------------------------------------------------------------------------------------------------------ # # バッファフラッシュ - Flush # ------------------------------------------- # 引 数：$flag : 出力フラグ # $perm : パーミッション # $szFilePath : 出力パス # 戻り値：なし # #------------------------------------------------------------------------------------------------------------ sub Flush { my $this = shift; my ($flag, $perm, $path) = @_; # ファイルへ出力 if ($flag) { chmod($perm, $path); if (open(my $fh, (-f $path ? '+<' : '>'), $path)) { flock($fh, 2); seek($fh, 0, 0); print $fh @{$this->{'BUFF'}}; truncate($fh, tell($fh)); close($fh); } chmod($perm, $path); } # 標準出力に出力 else { print @{$this->{'BUFF'}}; } } #------------------------------------------------------------------------------------------------------------ # # バッファクリア - Clear # ------------------------------------------- # 引 数：なし # 戻り値：なし # #------------------------------------------------------------------------------------------------------------ sub Clear { my $this = shift; $this->{'BUFF'} = []; } #------------------------------------------------------------------------------------------------------------ # # マージ - Merge # ------------------------------------------- # 引 数：$thorin : THORINモジュール # 戻り値：なし # #------------------------------------------------------------------------------------------------------------ sub Merge { my $this = shift; my ($thorin) = @_; push @{$this->{'BUFF'}}, @{$thorin->{'BUFF'}}; } #============================================================================================================ # モジュール終端 #============================================================================================================ 1; zerochplus_0.7.5/test/module/legolas.pl 0000644 0000000 0000000 00000012451 14216364775 015142 0 ustar #============================================================================================================ # # ヘッダ・フッタ・META管理モジュール # #============================================================================================================ package LEGOLAS; use strict; #use warnings; #------------------------------------------------------------------------------------------------------------ # # モジュールコンストラクタ - new # ------------------------------------------- # 引 数：なし # 戻り値：モジュールオブジェクト # #------------------------------------------------------------------------------------------------------------ sub new { my $class = shift; my $obj = { 'HEAD' => undef, 'TEXT' => undef, 'URL' => undef, 'PATH' => undef, 'FILE' => undef, }; bless $obj, $class; return $obj; } #------------------------------------------------------------------------------------------------------------ # # ヘッダ・フッタの読み込み - Load # ------------------------------------------- # 引 数：$Sys : モジュール # $kind : 種類 # 戻り値：エラー番号 # #------------------------------------------------------------------------------------------------------------ sub Load { my $this = shift; my ($Sys, $kind) = @_; my $path = $Sys->Get('BBSPATH') . '/' . $Sys->Get('BBS'); my $file = ''; $file = 'head.txt' if ($kind eq 'HEAD'); $file = 'foot.txt' if ($kind eq 'FOOT'); $file = 'meta.txt' if ($kind eq 'META'); $this->{'TEXT'} = $Sys->Get('HEADTEXT'); $this->{'URL'} = $Sys->Get('HEADURL'); $this->{'PATH'} = $path; $this->{'FILE'} = $file; my $head = $this->{'HEAD'} = []; if (open(my $fh, '<', "$path/$file")) { flock($fh, 2); @$head = <$fh>; close($fh); return 0; } return -1; } #------------------------------------------------------------------------------------------------------------ # # ヘッダ・フッタの書き込み - Save # ------------------------------------------- # 引 数：$Sys : MELKORモジュール # 戻り値：なし # #------------------------------------------------------------------------------------------------------------ sub Save { my $this = shift; my ($Sys) = @_; my $path = "$this->{'PATH'}/$this->{'FILE'}"; chmod($Sys->Get('PM-TXT'), $path); if (open(my $fh, (-f $path ? '+<' : '>'), $path)) { flock($fh, 2); seek($fh, 0, 0); print $fh @{$this->{'HEAD'}}; truncate($fh, tell($fh)); close($fh); } else { warn "can't save header/footer: $path"; } chmod($Sys->Get('PM-TXT'), $path); } #------------------------------------------------------------------------------------------------------------ # # 内容の設定 - Set # ------------------------------------------- # 引 数：$head : 設定内容(リファレンス) # 戻り値：なし # #------------------------------------------------------------------------------------------------------------ sub Set { my $this = shift; my ($head) = @_; open(my $fh, '<', $head); my @lines = <$fh>; close $fh; $this->{'HEAD'} = \@lines; } #------------------------------------------------------------------------------------------------------------ # # 内容の取得 # ------------------------------------------------------------------------------------- # @param なし # @return 内容の参照 # #------------------------------------------------------------------------------------------------------------ sub Get { my $this = shift; return $this->{'HEAD'}; } #------------------------------------------------------------------------------------------------------------ # # 内容の表示 # ------------------------------------------------------------------------------------- # @param $Page THORIN # @param $Set ISILDUR # @return なし # #------------------------------------------------------------------------------------------------------------ sub Print { my $this = shift; my ($Page, $Set) = @_; # head.txtの場合はヘッダ全てを表示する if ($this->{'FILE'} eq 'head.txt') { my $bbs = $Set->Get('BBS_SUBTITLE'); my $tcol = $Set->Get('BBS_MENU_COLOR'); my $text = $this->{'TEXT'}; my $url = $this->{'URL'}; $Page->Print(<
| \n");
$Page->Print(" ||||
| $text | \n"); $Page->Print("||||
\n"); } # META.txtはインデント elsif ($this->{'FILE'} eq 'meta.txt') { foreach (@{$this->{'HEAD'}}) { $Page->Print(" $_"); } $Page->Print("\n"); } # その他は内容をそのまま表示 else { foreach (@{$this->{'HEAD'}}) { $Page->Print($_); } } } #============================================================================================================ # モジュール終端 #============================================================================================================ 1; zerochplus_0.7.5/test/module/vara.pl 0000644 0000000 0000000 00000062046 14216364775 014452 0 ustar #============================================================================================================ # # 掲示板書き込み支援モジュール # #============================================================================================================ package VARA; use strict; #use warnings; #------------------------------------------------------------------------------------------------------------ # # コンストラクタ # ------------------------------------------------------------------------------------- # @param なし # @return モジュールオブジェクト # #------------------------------------------------------------------------------------------------------------ sub new { my $class = shift; my $obj = { 'SYS' => undef, 'SET' => undef, 'FORM' => undef, 'THREADS' => undef, 'CONV' => undef, 'SECURITY' => undef, 'PLUGIN' => undef, }; bless $obj, $class; return $obj; } #------------------------------------------------------------------------------------------------------------ # # 初期化 # ------------------------------------------------------------------------------------- # @param $Sys MELKOR(必須) # @param $Form SAMWISE(必須) # @param $Set ISILDUR # @param $Thread BILBO # @param $Conv GALADRIEL # @return なし # #------------------------------------------------------------------------------------------------------------ sub Init { my $this = shift; my ($Sys, $Form, $Set, $Threads, $Conv) = @_; $this->{'SYS'} = $Sys; $this->{'FORM'} = $Form; $this->{'SET'} = $Set; $this->{'THREADS'} = $Threads; $this->{'CONV'} = $Conv; # モジュールが用意されてない場合はここで生成する if (!defined $Set) { require './module/isildur.pl'; $this->{'SET'} = ISILDUR->new; $this->{'SET'}->Load($Sys); } if (!defined $Threads) { require './module/baggins.pl'; $this->{'THREADS'} = BILBO->new; $this->{'THREADS'}->Load($Sys); } if (!defined $Conv) { require './module/galadriel.pl'; $this->{'CONV'} = GALADRIEL->new; } # キャップ管理モジュールロード require './module/ungoliants.pl'; $this->{'SECURITY'} = SECURITY->new; $this->{'SECURITY'}->Init($Sys); $this->{'SECURITY'}->SetGroupInfo($Sys->Get('BBS')); # 拡張機能情報管理モジュールロード require './module/athelas.pl'; $this->{'PLUGIN'} = ATHELAS->new; $this->{'PLUGIN'}->Load($Sys); } #------------------------------------------------------------------------------------------------------------ # # 書き込み処理 - WriteData # ------------------------------------------- # 引 数：なし # 戻り値：なし # #------------------------------------------------------------------------------------------------------------ sub Write { my $this = shift; # 書き込み前準備 $this->ReadyBeforeCheck(); my $err = $ZP::E_SUCCESS; # 入力内容チェック(名前、メール) return $err if (($err = $this->NormalizationNameMail()) != $ZP::E_SUCCESS); # 入力内容チェック(本文) return $err if (($err = $this->NormalizationContents()) != $ZP::E_SUCCESS); # 規制チェック return $err if (($err = $this->IsRegulation()) != $ZP::E_SUCCESS); # データの書き込み require './module/gondor.pl'; my $Sys = $this->{'SYS'}; my $Set = $this->{'SET'}; my $Form = $this->{'FORM'}; my $Conv = $this->{'CONV'}; my $Threads = $this->{'THREADS'}; my $Sec = $this->{'SECURITY'}; my $threadid = $Sys->Get('KEY'); $Threads->LoadAttr($Sys); # 情報欄 my $datepart = $Conv->GetDate($Set, $Sys->Get('MSEC')); my $id = $Conv->MakeIDnew($Sys, 8); my $idpart = $Conv->GetIDPart($Set, $Form, $Sec, $id, $Sys->Get('CAPID'), $Sys->Get('KOYUU'), $Sys->Get('AGENT')); my $bepart = ''; my $extrapart = ''; $Form->Set('datepart', $datepart); $Form->Set('idpart', $idpart); #$Form->Set('BEID', ''); # type=1|2 $Form->Set('extrapart', $extrapart); my $updown = 'top'; $updown = '' if ($Form->Contain('mail', 'sage')); $updown = '' if ($Threads->GetAttr($threadid, 'sagemode')); $Sys->Set('updown', $updown); # 書き込み直前処理 $err = $this->ReadyBeforeWrite(ARAGORN::GetNumFromFile($Sys->Get('DATPATH')) + 1); return $err if ($err != $ZP::E_SUCCESS); # レス要素の取得 my $subject = $Form->Get('subject', ''); my $name = $Form->Get('FROM', ''); my $mail = $Form->Get('mail', ''); my $text = $Form->Get('MESSAGE', ''); $datepart = $Form->Get('datepart', ''); $idpart = $Form->Get('idpart', ''); $bepart = $Form->Get('BEID', ''); $extrapart = $Form->Get('extrapart', ''); my $info = $datepart; $info .= " $idpart" if ($idpart ne ''); $info .= " $bepart" if ($bepart ne ''); $info .= " $extrapart" if ($extrapart ne ''); my $data = "$name<>$mail<>$info<>$text<>$subject"; my $line = "$data\n"; my $datPath = $Sys->Get('DATPATH'); # ログ書き込み require './module/peregrin.pl'; my $Log = PEREGRIN->new; $Log->Load($Sys, 'WRT', $threadid); $Log->Set($Set, length($Form->Get('MESSAGE')), $Sys->Get('VERSION'), $Sys->Get('KOYUU'), $data, $Sys->Get('AGENT', 0)); $Log->Save($Sys); # リモートホスト保存(SETTING.TXT変更により、常に保存) SaveHost($Sys, $Form); # datファイルへ直接書き込み my $resNum = 0; my $err2 = ARAGORN::DirectAppend($Sys, $datPath, $line); if ($err2 == 0) { # レス数が最大数を超えたらover設定をする $resNum = ARAGORN::GetNumFromFile($datPath); if ($resNum >= $Sys->Get('RESMAX')) { # datにOVERスレッドレスを書き込む Get1001Data($Sys, \$line); ARAGORN::DirectAppend($Sys, $datPath, $line); $resNum++; } $err = $ZP::E_SUCCESS; } # datファイル追記失敗 elsif ($err2 == 1) { $err = $ZP::E_POST_NOTEXISTDAT; } elsif ($err2 == 2) { $err = $ZP::E_LIMIT_STOPPEDTHREAD; } if ($err == $ZP::E_SUCCESS) { # subject.txtの更新 # スレッド作成モードなら新規に追加する if ($Sys->Equal('MODE', 1)) { require './module/earendil.pl'; my $path = $Sys->Get('BBSPATH') . '/' . $Sys->Get('BBS'); my $Pools = FRODO->new; $Pools->Load($Sys); $Threads->Add($threadid, $subject, 1); # スレッド数限界によるdat落ち処理 my $submax = $Sys->Get('SUBMAX'); my @tlist; $Threads->GetKeySet('ALL', undef, \@tlist); foreach my $lid (reverse @tlist) { last if ($Threads->GetNum() <= $submax); # 不落属性あり next if ($Threads->GetAttr($lid, 'nopool')); $Pools->Add($lid, $Threads->Get('SUBJECT', $lid), $Threads->Get('RES', $lid)); $Threads->Delete($lid); EARENDIL::Copy("$path/dat/$lid.dat", "$path/pool/$lid.cgi"); unlink "$path/dat/$lid.dat"; } $Pools->Save($Sys); $Threads->Save($Sys); } # 書き込みモードならレス数の更新 else { $updown = $Sys->Get('updown', ''); $Threads->OnDemand($Sys, $threadid, $resNum, $updown); } } return $err; } #------------------------------------------------------------------------------------------------------------ # # 前準備 # ------------------------------------------------------------------------------------- # @param なし # @return なし # #------------------------------------------------------------------------------------------------------------ sub ReadyBeforeCheck { my ($this) = @_; my $Sys = $this->{'SYS'}; my $Form = $this->{'FORM'}; # cookie用にオリジナルを保存する my $from = $Form->Get('FROM'); my $mail = $Form->Get('mail'); $from =~ s/[\r\n]//g; $mail =~ s/[\r\n]//g; $Form->Set('NAME', $from); $Form->Set('MAIL', $mail); # キャップパスの抽出と削除 $Sys->Set('CAPID', ''); if ($mail =~ s/(?:#|＃)(.+)//) { my $capPass = $1; # キャップ情報設定 my $capID = $this->{'SECURITY'}->GetCapID($capPass); $Sys->Set('CAPID', $capID); $Form->Set('mail', $mail); } # datパスの生成 my $datPath = $Sys->Get('BBSPATH') . '/' . $Sys->Get('BBS') . '/dat/' . $Sys->Get('KEY') . '.dat'; $Sys->Set('DATPATH', $datPath); # 本文禁則文字変換 my $text = $Form->Get('MESSAGE'); $this->{'CONV'}->ConvertCharacter1(\$text, 2); $Form->Set('MESSAGE', $text); } #------------------------------------------------------------------------------------------------------------ # # 書き込み直前処理 # ------------------------------------------------------------------------------------- # @param なし # @param $res # @return なし # #------------------------------------------------------------------------------------------------------------ sub ReadyBeforeWrite { my $this = shift; my ($res) = @_; my $Sys = $this->{'SYS'}; my $Form = $this->{'FORM'}; my $Sec = $this->{'SECURITY'}; my $capID = $Sys->Get('CAPID', ''); my $bbs = $Form->Get('bbs'); my $from = $Form->Get('FROM'); my $koyuu = $Sys->Get('KOYUU'); my $client = $Sys->Get('CLIENT'); my $host = $ENV{'REMOTE_HOST'}; my $addr = $ENV{'REMOTE_ADDR'}; # 規制ユーザ・NGワードチェック { # 規制ユーザ if (!$Sec->IsAuthority($capID, $ZP::CAP_REG_NGUSER, $bbs)) { require './module/faramir.pl'; my $vUser = FARAMIR->new; $vUser->Load($Sys); my $koyuu2 = ($client & $ZP::C_MOBILE_IDGET & ~$ZP::C_P2 ? $koyuu : undef); my $check = $vUser->Check($host, $addr, $koyuu2); if ($check == 4) { return $ZP::E_REG_NGUSER; } elsif ($check == 2) { return $ZP::E_REG_NGUSER if ($from !~ /$host/i); # $hostは正規表現 $Form->Set('FROM', "
/
/g; $Form->Set('MESSAGE', " $text "); # 名無し設定 $from = $Form->Get('FROM', ''); if ($from eq '') { $from = $this->{'SET'}->Get('BBS_NONAME_NAME'); $Form->Set('FROM', $from); } return 0; } #------------------------------------------------------------------------------------------------------------ # # プラグイン処理 # ------------------------------------------------------------------------------------- # @param $type # @return なし # #------------------------------------------------------------------------------------------------------------ sub ExecutePlugin { my $this = shift; my ($type) = @_; my $Sys = $this->{'SYS'}; my $Form = $this->{'FORM'}; my $Plugin = $this->{'PLUGIN'}; # 有効な拡張機能一覧を取得 my @pluginSet = (); $Plugin->GetKeySet('VALID', 1, \@pluginSet); foreach my $id (@pluginSet) { # タイプが先呼び出しの場合はロードして実行 if ($Plugin->Get('TYPE', $id) & $type) { my $file = $Plugin->Get('FILE', $id); my $className = $Plugin->Get('CLASS', $id); require "./plugin/$file"; my $Config = PLUGINCONF->new($Plugin, $id); my $command = $className->new($Config); $command->execute($Sys, $Form, $type); } } } #------------------------------------------------------------------------------------------------------------ # # 規制チェック # ------------------------------------------------------------------------------------- # @param なし # @return 規制通過なら0を返す # 規制チェックにかかったらエラーコードを返す # #------------------------------------------------------------------------------------------------------------ sub IsRegulation { my $this = shift; my $Sys = $this->{'SYS'}; my $Set = $this->{'SET'}; my $Sec = $this->{'SECURITY'}; my $bbs = $this->{'FORM'}->Get('bbs'); my $from = $this->{'FORM'}->Get('FROM'); my $capID = $Sys->Get('CAPID', ''); my $datPath = $Sys->Get('DATPATH'); my $client = $Sys->Get('CLIENT'); my $mode = $Sys->Get('AGENT'); my $koyuu = $Sys->Get('KOYUU'); my $host = $ENV{'REMOTE_HOST'}; my $addr = $ENV{'REMOTE_ADDR'}; my $islocalip = 0; $islocalip = 1 if ($addr =~ /^(127|172|192|10)\./); # レス書き込みモード時のみ if ($Sys->Equal('MODE', 2)) { require './module/gondor.pl'; # 移転スレッド return $ZP::E_LIMIT_MOVEDTHREAD if (ARAGORN::IsMoved($datPath)); # レス最大数 return $ZP::E_LIMIT_OVERMAXRES if ($Sys->Get('RESMAX') < ARAGORN::GetNumFromFile($datPath)); # datファイルサイズ制限 if ($Set->Get('BBS_DATMAX')) { my $datSize = int((stat $datPath)[7] / 1024); if ($Set->Get('BBS_DATMAX') < $datSize) { return $ZP::E_LIMIT_OVERDATSIZE; } } } # REFERERチェック if ($Set->Equal('BBS_REFERER_CHECK', 'checked')) { if ($this->{'CONV'}->IsReferer($this->{'SYS'}, \%ENV)) { return $ZP::E_POST_INVALIDREFERER; } } # PROXYチェック if (!$islocalip && $Set->Equal('BBS_PROXY_CHECK', 'checked')) { if ($this->{'CONV'}->IsProxy($this->{'SYS'}, $this->{'FORM'}, $from, $mode)) { #$this->{'FORM'}->Set('FROM', " [―\{}\@{}\@{}-] $from"); if (!$Sec->IsAuthority($capID, $ZP::CAP_REG_DNSBL, $bbs)) { return $ZP::E_REG_DNSBL; } } } # 読取専用 if (!$Set->Equal('BBS_READONLY', 'none')) { if (!$Sec->IsAuthority($capID, $ZP::CAP_LIMIT_READONLY, $bbs)) { return $ZP::E_LIMIT_READONLY; } } # JPホスト以外規制 if (!$islocalip && $Set->Equal('BBS_JP_CHECK', 'checked')) { if ($host !~ /\.jp$/i) { if (!$Sec->IsAuthority($capID, $ZP::CAP_REG_NOTJPHOST, $bbs)) { return $ZP::E_REG_NOTJPHOST; } } } # スレッド作成モード if ($Sys->Equal('MODE', 1)) { # スレッドキーが重複しないようにする my $tPath = $Sys->Get('BBSPATH') . '/' . $Sys->Get('BBS') . '/dat/'; my $key = $Sys->Get('KEY'); $key++ while (-e "$tPath$key.dat"); $Sys->Set('KEY', $key); $datPath = "$tPath$key.dat"; # スレッド作成(携帯から) if (!$Set->Equal('BBS_THREADMOBILE', 'checked') && ($client & $ZP::C_MOBILE)) { if (!$Sec->IsAuthority($capID, $ZP::CAP_LIMIT_MOBILETHREAD, $bbs)) { return $ZP::E_LIMIT_MOBILETHREAD; } } # スレッド作成(キャップのみ) if ($Set->Equal('BBS_THREADCAPONLY', 'checked')) { if (!$Sec->IsAuthority($capID, $ZP::CAP_LIMIT_THREADCAPONLY, $bbs)) { return $ZP::E_LIMIT_THREADCAPONLY; } } # スレッド作成(スレッド立てすぎ) require './module/peregrin.pl'; my $Log = PEREGRIN->new; $Log->Load($Sys, 'THR'); if (!$Sec->IsAuthority($capID, $ZP::CAP_REG_MANYTHREAD, $bbs)) { my $tateHour = $Set->Get('BBS_TATESUGI_HOUR', '0') - 0; my $tateCount = $Set->Get('BBS_TATESUGI_COUNT', '0') - 0; if ($tateHour != 0 && $tateCount != 0 && $Log->IsTatesugi($tateHour) >= $tateCount) { return $ZP::E_REG_MANYTHREAD; } my $tateClose = $Set->Get('BBS_THREAD_TATESUGI', '0') - 0; my $tateCount2 = $Set->Get('BBS_TATESUGI_COUNT2', '0') - 0; if ($tateClose != 0 && $tateCount2 != 0 && $Log->Search($koyuu, 3, $mode, $host, $tateClose) >= $tateCount2) { return $ZP::E_REG_MANYTHREAD; } } $Log->Set($Set, $Sys->Get('KEY'), $Sys->Get('VERSION'), $koyuu, undef, $mode); $Log->Save($Sys); # Sambaログ if (!$Sec->IsAuthority($capID, $ZP::CAP_REG_SAMBA, $bbs) || !$Sec->IsAuthority($capID, $ZP::CAP_REG_NOTIMEPOST, $bbs)) { my $Logs = PEREGRIN->new; $Logs->Load($Sys, 'SMB'); $Logs->Set($Set, $Sys->Get('KEY'), $Sys->Get('VERSION'), $koyuu); $Logs->Save($Sys); } } # レス書き込みモード else { require './module/peregrin.pl'; if (!$Sec->IsAuthority($capID, $ZP::CAP_REG_SAMBA, $bbs) || !$Sec->IsAuthority($capID, $ZP::CAP_REG_NOTIMEPOST, $bbs)) { my $Logs = PEREGRIN->new; $Logs->Load($Sys, 'SMB'); my $Logh = PEREGRIN->new; $Logh->Load($Sys, 'SBH'); my $n = 0; my $tm = 0; my $Samba = int($Set->Get('BBS_SAMBATIME', '') eq '' ? $Sys->Get('DEFSAMBA') : $Set->Get('BBS_SAMBATIME')); my $Houshi = int($Set->Get('BBS_HOUSHITIME', '') eq '' ? $Sys->Get('DEFHOUSHI') : $Set->Get('BBS_HOUSHITIME')); my $Holdtm = int($Sys->Get('SAMBATM')); # Samba if ($Samba && !$Sec->IsAuthority($capID, $ZP::CAP_REG_SAMBA, $bbs)) { if ($Houshi) { my ($ishoushi, $htm) = $Logh->IsHoushi($Houshi, $koyuu); if ($ishoushi) { $Sys->Set('WAIT', $htm); return $ZP::E_REG_SAMBA_STILL; } } ($n, $tm) = $Logs->IsSamba($Samba, $koyuu); } # 短時間投稿 (Samba優先) if (!$n && $Holdtm && !$Sec->IsAuthority($capID, $ZP::CAP_REG_NOTIMEPOST, $bbs)) { $tm = $Logs->IsTime($Holdtm, $koyuu); } $Logs->Set($Set, $Sys->Get('KEY'), $Sys->Get('VERSION'), $koyuu); $Logs->Save($Sys); if ($n >= 6 && $Houshi) { $Logh->Set($Set, $Sys->Get('KEY'), $Sys->Get('VERSION'), $koyuu); $Logh->Save($Sys); $Sys->Set('WAIT', $Houshi); return $ZP::E_REG_SAMBA_LISTED; } elsif ($n) { $Sys->Set('SAMBATIME', $Samba); $Sys->Set('WAIT', $tm); $Sys->Set('SAMBA', $n); return ($n > 3 && $Houshi ? $ZP::E_REG_SAMBA_WARNING : $ZP::E_REG_SAMBA_CAUTION); } elsif ($tm > 0) { $Sys->Set('WAIT', $tm); return $ZP::E_REG_NOTIMEPOST; } } # レス書き込み(連続投稿) if (!$Sec->IsAuthority($capID, $ZP::CAP_REG_NOBREAKPOST, $bbs)) { if ($Set->Get('timeclose') && $Set->Get('timecount') ne '') { my $Log = PEREGRIN->new; $Log->Load($Sys, 'HST'); my $cnt = $Log->Search($koyuu, 2, $mode, $host, $Set->Get('timecount')); if ($cnt >= $Set->Get('timeclose')) { return $ZP::E_REG_NOBREAKPOST; } } } # レス書き込み(二重投稿) if (!$Sec->IsAuthority($capID, $ZP::CAP_REG_DOUBLEPOST, $bbs)) { if ($this->{'SYS'}->Get('KAKIKO') == 1) { my $Log = PEREGRIN->new; $Log->Load($Sys, 'WRT', $Sys->Get('KEY')); if ($Log->Search($koyuu, 1) - 2 == length($this->{'FORM'}->Get('MESSAGE'))) { return $ZP::E_REG_DOUBLEPOST; } } } #$Log->Set($Set, length($this->{'FORM'}->Get('MESSAGE')), $Sys->Get('VERSION'), $koyuu, $datas, $mode); #$Log->Save($Sys); } # パスを保存 $Sys->Set('DATPATH', $datPath); return $ZP::E_SUCCESS; } #------------------------------------------------------------------------------------------------------------ # # 名前・メール欄の正規化 # ------------------------------------------------------------------------------------- # @param なし # @return 規制通過なら0を返す # 規制チェックにかかったらエラーコードを返す # #------------------------------------------------------------------------------------------------------------ sub NormalizationNameMail { my $this = shift; my $Sys = $this->{'SYS'}; my $Form = $this->{'FORM'}; my $Sec = $this->{'SECURITY'}; my $Set = $this->{'SET'}; my $name = $Form->Get('FROM'); my $mail = $Form->Get('mail'); my $subject = $Form->Get('subject'); my $bbs = $Form->Get('bbs'); my $host = $ENV{'REMOTE_HOST'}; # キャップ情報取得 my $capID = $Sys->Get('CAPID', ''); my $capName = ''; my $capColor = ''; if ($capID && $Sec->IsAuthority($capID, $ZP::CAP_DISP_HANLDLE, $bbs)) { $capName = $Sec->Get($capID, 'NAME', 1, ''); $capColor = $Sec->Get($Sec->{'GROUP'}->GetBelong($capID), 'COLOR', 0, ''); $capColor = $Set->Get('BBS_CAP_COLOR', '') if ($capColor eq ''); } # ＃ -> # $this->{'CONV'}->ConvertCharacter0(\$name); # トリップ変換 my $trip = ''; if ($name =~ /\#(.*)$/x) { my $key = $1; $trip = $this->{'CONV'}->ConvertTrip(\$key, $Set->Get('BBS_TRIPCOLUMN'), $Sys->Get('TRIP12')); } # 特殊文字変換 フォーム情報再設定 $this->{'CONV'}->ConvertCharacter1(\$name, 0); $this->{'CONV'}->ConvertCharacter1(\$mail, 1); $this->{'CONV'}->ConvertCharacter1(\$subject, 3); $Form->Set('FROM', $name); $Form->Set('mail', $mail); $Form->Set('subject', $subject); $Form->Set('TRIPKEY', $trip); # プラグイン実行 フォーム情報再取得 $this->ExecutePlugin($Sys->Get('MODE')); $name = $Form->Get('FROM', ''); $mail = $Form->Get('mail', ''); $subject = $Form->Get('subject', ''); $bbs = $Form->Get('bbs'); $host = $Form->Get('HOST'); $trip = $Form->Get('TRIPKEY', '???'); # 2ch互換 $name =~ s/^ //; # 禁則文字変換 $this->{'CONV'}->ConvertCharacter2(\$name, 0); $this->{'CONV'}->ConvertCharacter2(\$mail, 1); $this->{'CONV'}->ConvertCharacter2(\$subject, 3); # トリップと名前を結合する $name =~ s|\#.*$| ◆$trip |x if ($trip ne ''); # fusiana変換 2ch互換 $this->{'CONV'}->ConvertFusianasan(\$name, $host); # キャップ名結合 if ($capName ne '') { $name = ($name ne '' ? "$name＠" : ''); if ($capColor eq '') { $name .= "$capName ★"; } else { $name .= "$capName ★"; } } # スレッド作成時 if ($Sys->Equal('MODE', 1)) { return $ZP::E_FORM_NOSUBJECT if ($subject eq ''); # サブジェクト欄の文字数確認 if (!$Sec->IsAuthority($capID, $ZP::CAP_FORM_LONGSUBJECT, $bbs)) { if ($Set->Get('BBS_SUBJECT_COUNT') < length($subject)) { return $ZP::E_FORM_LONGSUBJECT; } } } # 名前欄の文字数確認 if (!$Sec->IsAuthority($capID, $ZP::CAP_FORM_LONGNAME, $bbs)) { if ($Set->Get('BBS_NAME_COUNT') < length($name)) { return $ZP::E_FORM_LONGNAME; } } # メール欄の文字数確認 if (!$Sec->IsAuthority($capID, $ZP::CAP_FORM_LONGMAIL, $bbs)) { if ($Set->Get('BBS_MAIL_COUNT') < length($mail)) { return $ZP::E_FORM_LONGMAIL; } } # 名前欄の入力確認 if (!$Sec->IsAuthority($capID, $ZP::CAP_FORM_NONAME, $bbs)) { if ($Set->Equal('NANASHI_CHECK', 'checked') && $name eq '') { return $ZP::E_FORM_NONAME; } } # 正規化した内容を再度設定 $Form->Set('FROM', $name); $Form->Set('mail', $mail); $Form->Set('subject', $subject); return $ZP::E_SUCCESS; } #------------------------------------------------------------------------------------------------------------ # # テキスト欄の正規化 # ------------------------------------------------------------------------------------- # @param なし # @return 規制通過なら0を返す # 規制チェックにかかったらエラーコードを返す # #------------------------------------------------------------------------------------------------------------ sub NormalizationContents { my $this = shift; my $Form = $this->{'FORM'}; my $Sec = $this->{'SECURITY'}; my $Set = $this->{'SET'}; my $Sys = $this->{'SYS'}; my $Conv = $this->{'CONV'}; my $bbs = $Form->Get('bbs'); my $text = $Form->Get('MESSAGE'); my $host = $Form->Get('HOST'); my $capID = $this->{'SYS'}->Get('CAPID', ''); # 禁則文字変換 $Conv->ConvertCharacter2(\$text, 2); my ($ln, $cl) = $Conv->GetTextInfo(\$text); # 本文が無い return $ZP::E_FORM_NOTEXT if ($text eq ''); # 本文が長すぎ if (!$Sec->IsAuthority($capID, $ZP::CAP_FORM_LONGTEXT, $bbs)) { if ($Set->Get('BBS_MESSAGE_COUNT') < length($text)) { return $ZP::E_FORM_LONGTEXT; } } # 改行が多すぎ if (!$Sec->IsAuthority($capID, $ZP::CAP_FORM_MANYLINE, $bbs)) { if (($Set->Get('BBS_LINE_NUMBER') * 2) < $ln) { return $ZP::E_FORM_MANYLINE; } } # 1行が長すぎ if (!$Sec->IsAuthority($capID, $ZP::CAP_FORM_LONGLINE, $bbs)) { if ($Set->Get('BBS_COLUMN_NUMBER') < $cl) { return $ZP::E_FORM_LONGLINE; } } # アンカーが多すぎ if ($Sys->Get('ANKERS')) { if ($Conv->IsAnker(\$text, $Sys->Get('ANKERS'))) { return $ZP::E_FORM_MANYANCHOR; } } # 本文ホスト表示 #if (!$Sec->IsAuthority($capID, $ZP::CAP_DISP_NOHOST, $bbs)) { # if ($Set->Equal('BBS_RAWIP_CHECK', 'checked') && $Sys->Equal('MODE', 1)) { # $text .= '
'; # $text .= "$ENV{'REMOTE_ADDR'} , $host ,
"; # } #} $Form->Set('MESSAGE', $text); return $ZP::E_SUCCESS; } #------------------------------------------------------------------------------------------------------------ # # 1001のレスデータを設定する # ------------------------------------------------------------------------------------- # @param $Sys MELKOR # @param $data 1001レス格納バッファ # #------------------------------------------------------------------------------------------------------------ sub Get1001Data { my ($Sys, $data) = @_; my $endPath = $Sys->Get('BBSPATH') . '/' . $Sys->Get('BBS') . '/1000.txt'; # 1000.txtが存在すればその内容、無ければデフォルトの1001を使用する if (open(my $fh, '<', $endPath)) { flock($fh, 2); $$data = <$fh>; close($fh); } else { my $resmax = $Sys->Get('RESMAX'); my $resmax1 = $resmax + 1; my $resmaxz = $resmax; my $resmaxz1 = $resmax1; $resmaxz =~ s/([0-9])/"\x82".chr(0x4f+$1)/eg; # 全角数字 $resmaxz1 =~ s/([0-9])/"\x82".chr(0x4f+$1)/eg; # 全角数字 $$data = "$resmaxz1<><>Over $resmax Thread<>このスレッドは$resmaxzを超えました。
"; $$data .= 'もう書けないので、新しいスレッドを立ててくださいです。。。<>' . "\n"; } } #------------------------------------------------------------------------------------------------------------ # # ホストログを出力する # ------------------------------------------------------------------------------------- # @param $Sys MELKOR # @param $data 1001レス格納バッファ # #------------------------------------------------------------------------------------------------------------ sub SaveHost { my ($Sys, $Form) = @_; my $bbs = $Sys->Get('BBSPATH') . '/' . $Sys->Get('BBS'); my $host = $ENV{'REMOTE_HOST'}; my $agent = $Sys->Get('AGENT'); my $koyuu = $Sys->Get('KOYUU'); if ($agent ne '0') { if ($agent eq 'P') { $host = "$host($koyuu)$ENV{'REMOTE_ADDR'}"; } else { $host = "$host($koyuu)"; } } require './module/imrahil.pl'; my $Logger = IMRAHIL->new; if ($Logger->Open("$bbs/log/HOST", $Sys->Get('HSTMAX'), 2 | 4) == 0) { $Logger->Put($host, $Sys->Get('KEY'), $Sys->Get('MODE')); $Logger->Write(); } } #============================================================================================================ # Module END #============================================================================================================ 1; zerochplus_0.7.5/test/module/melkor.pl 0000644 0000000 0000000 00000024662 14216364775 015014 0 ustar #============================================================================================================ # # システムデータ管理モジュール # #============================================================================================================ package MELKOR; use strict; #use warnings; no warnings 'redefine'; #------------------------------------------------------------------------------------------------------------ # # コンストラクタ # ------------------------------------------------------------------------------------- # @param なし # @return モジュールオブジェクト # #------------------------------------------------------------------------------------------------------------ sub new { my $class = shift; my $obj = { 'SYS' => undef, 'KEY' => undef, }; bless $obj, $class; return $obj; } #------------------------------------------------------------------------------------------------------------ # # 初期化 # ------------------------------------------------------------------------------------- # @param なし # @return 正常終了したら0を返す # #------------------------------------------------------------------------------------------------------------ sub Init { my $this = shift; # システム設定を読み込む return $this->Load; } #------------------------------------------------------------------------------------------------------------ # # システム設定読み込み # ------------------------------------------------------------------------------------- # @param なし # @return 正常終了したら0を返す # #------------------------------------------------------------------------------------------------------------ sub Load { my $this = shift; # システム情報ハッシュの初期化 my $pSys = $this->{'SYS'} = {}; $this->{'KEY'} = []; InitSystemValue($this->{'SYS'}, $this->{'KEY'}); my $sysFile = $this->{'SYS'}->{'SYSFILE'}; # 設定ファイルから読み込む if (open(my $fh, '<', $sysFile)) { flock($fh, 2); my @lines = <$fh>; close($fh); map { s/[\r\n]+\z// } @lines; foreach (@lines) { if ($_ =~ /^(.+?)<>(.*)$/) { $pSys->{$1} = $2; } } } # 時間制限のチェック my @dlist = localtime time; if (($dlist[2] >= $pSys->{'LINKST'} || $dlist[2] < $pSys->{'LINKED'}) && ($pSys->{'URLLINK'} eq 'FALSE')) { $pSys->{'LIMTIME'} = 1; } else { $pSys->{'LIMTIME'} = 0; } if ($this->Get('CONFVER', '') ne $pSys->{'VERSION'}) { $this->Save(); } return 0; } #------------------------------------------------------------------------------------------------------------ # # システム設定書き込み # ------------------------------------------------------------------------------------- # @param なし # @return なし # #------------------------------------------------------------------------------------------------------------ sub Save { my $this = shift; $this->NormalizeConf(); my $path = $this->{'SYS'}->{'SYSFILE'}; chmod($this->Get('PM-ADM'), $path); if (open(my $fh, (-f $path ? '+<' : '>'), $path)) { flock($fh, 2); seek($fh, 0, 0); binmode($fh); foreach my $key (@{$this->{'KEY'}}) { my $val = $this->{'SYS'}->{$key}; print $fh "$key<>$val\n"; } truncate($fh, tell($fh)); close($fh); } else { warn "can't save config: $path"; } chmod($this->Get('PM-ADM'), $path); } #------------------------------------------------------------------------------------------------------------ # # システム設定値取得 # ------------------------------------------------------------------------------------- # @param $key 取得キー # $default : デフォルト # @return 設定値 # #------------------------------------------------------------------------------------------------------------ sub Get { my $this = shift; my ($key, $default) = @_; my $val = $this->{'SYS'}->{$key}; return (defined $val ? $val : (defined $default ? $default : undef)); } #------------------------------------------------------------------------------------------------------------ # # システム設定値設定 # ------------------------------------------------------------------------------------- # @param $key 設定キー # @param $data 設定値 # @return なし # #------------------------------------------------------------------------------------------------------------ sub Set { my $this = shift; my ($key, $data) = @_; $this->{'SYS'}->{$key} = $data; } #------------------------------------------------------------------------------------------------------------ # # システム設定値比較 # ------------------------------------------------------------------------------------- # @param $key 設定キー # @param $val 設定値 # @return 同等なら真を返す # #------------------------------------------------------------------------------------------------------------ sub Equal { my $this = shift; my ($key, $data) = @_; return($this->{'SYS'}->{$key} eq $data); } #------------------------------------------------------------------------------------------------------------ # # オプション値取得- GetOption # ------------------------------------------- # 引 数：$flag : 取得フラグ # 戻り値：成功:オプション値 # 失敗:-1 # #------------------------------------------------------------------------------------------------------------ sub GetOption { my $this = shift; my ($flag) = @_; my @elem = split(/\,/, $this->{'SYS'}->{'OPTION'}); return $elem[$flag - 1]; } #------------------------------------------------------------------------------------------------------------ # # オプション値設定 - SetOption # ------------------------------------------- # 引 数：$last : ラストフラグ # $start : 開始行 # $end : 終了行 # $one : >>1表示フラグ # $alone : 単独表示フラグ # 戻り値：なし # #------------------------------------------------------------------------------------------------------------ sub SetOption { my $this = shift; my ($last, $start, $end, $one, $alone) = @_; $this->{'SYS'}->{'OPTION'} = "$last,$start,$end,$one,$alone"; } #------------------------------------------------------------------------------------------------------------ # # システム変数初期化 - InitSystemValue # ------------------------------------------- # 引 数：$pSys : ハッシュの参照 # $pKey : 配列の参照 # 戻り値：なし # #------------------------------------------------------------------------------------------------------------ sub InitSystemValue { my ($pSys, $pKey) = @_; my %sys = ( 'SYSFILE' => './info/system.cgi', # システム設定ファイル 'SERVER' => '', # 設置サーバパス 'CGIPATH' => '/test', # CGI設置パス 'INFO' => '/info', # 管理データ設置パス 'DATA' => '/datas', # 初期データ設置パス 'BBSPATH' => '..', # 掲示板設置パス 'DEBUG' => 0, # デバグモード 'VERSION' => '0ch+ BBS 0.7.5 20220323', # CGIバージョン 'PM-DAT' => 0644, # datパーミション 'PM-STOP' => 0444, # スレストパーミション 'PM-TXT' => 0644, # TXTパーミション 'PM-LOG' => 0600, # LOGパーミション 'PM-ADM' => 0600, # 管理ファイル群 'PM-ADIR' => 0700, # 管理DIRパーミション 'PM-BDIR' => 0711, # 板DIRパーミション 'PM-LDIR' => 0700, # ログDIRパーミション 'PM-KDIR' => 0755, # 倉庫DIRパーミション 'ERRMAX' => 500, # エラーログ最大保持数 'SUBMAX' => 500, # subject最大保持数 'RESMAX' => 1000, # レス最大書き込み数 'ADMMAX' => 500, # 管理操作ログ最大保持数 'HSTMAX' => 500, # ホストログ最大保持数 'ANKERS' => 10, # 最大アンカー数 'URLLINK' => 'TRUE', # URLへの自動リンク 'LINKST' => 23, # リンク禁止開始時間 'LINKED' => 2, # リンク禁止終了時間 'PATHKIND' => 0, # 生成パスの種類 'HEADTEXT' => '■掲示板一覧■', # ヘッダ下部の表示文字列 'HEADURL' => '../', # ヘッダ下部のURL 'FASTMODE' => 0, # 高速モード # ここからぜろプラオリジナル 'SAMBATM' => 0, # 短時間投稿規制秒数 'DEFSAMBA' => 10, # Samba待機秒数デフォルト値 'DEFHOUSHI' => 60, # Samba奉仕時間(分)デフォルト値 'BANNER' => 1, # read.cgi他の告知欄の表示 'KAKIKO' => 1, # 2重かきこですか？？ 'COUNTER' => '', # ofuda.cc アカウント 'PRTEXT' => 'ぜろちゃんねるプラス', # PR欄の表示文字列 'PRLINK' => 'http://zerochplus.sourceforge.jp/', # PR欄のリンクURL 'TRIP12' => 1, # 12桁トリップを変換するかどうか 'MSEC' => 0, # msecまで表示するか 'BBSGET' => 0, # bbs.cgiでGETメソッドを使用するかどうか 'CONFVER' => '', # システム設定ファイルのバージョン 'UPCHECK' => 1, # 更新チェック間隔(日) # DNSBL設定 'BBQ' => 1, # BBQ(niku.2ch.net) 'BBX' => 0, # BBX(bbx.2ch.net) 'PERM_EXEC' => 0700, 'PERM_DATA' => 0600, 'PERM_CONTENT' => 0644, 'PERM_SYSDIR' => 0700, 'PERM_DIR' => 0711, ); if ('Permission') { my $uid = (stat $ENV{'SCRIPT_FILENAME'})[4]; if ($uid == 0) { # root / not linux } elsif ($uid == $<) { # suEXEC } else { $sys{'PM-DAT'} = 0666; $sys{'PM-STOP'} = 0444; $sys{'PM-TXT'} = 0666; $sys{'PM-LOG'} = 0666; $sys{'PM-ADM'} = 0666; $sys{'PM-ADIR'} = 0777; $sys{'PM-BDIR'} = 0777; $sys{'PM-LDIR'} = 0777; $sys{'PM-KDIR'} = 0777; } } while (my ($key, $val) = each %sys) { $pSys->{$key} = $val; } # 情報保持キー my @key = grep { 'VERSION' !~ /\b$_\b/ } sort keys %sys; splice @$pKey, 0, scalar(@$pKey); push @$pKey, @key; } #------------------------------------------------------------------------------------------------------------ # # システム変数正規化 - NormalizeConf # ------------------------------------------- # 引 数： # 戻り値：なし # #------------------------------------------------------------------------------------------------------------ sub NormalizeConf { my $this = shift; my ($path, $buf, $perm, $server, $cgipath); if ($this->Get('SERVER', '') eq '') { my $path = $ENV{'SCRIPT_NAME'}; $path =~ s|/[^/]+\.cgi([\/\?].*)?$||; $this->Set('SERVER', 'http://' . $ENV{'HTTP_HOST'}); $this->Set('CGIPATH', $path); } if ('set CGI Path') { my $server = $this->Get('SERVER', ''); my $cgipath = $this->Get('CGIPATH', ''); if ($server =~ m|^(http://[^/]+)(/.+)$|) { $server = $1; $cgipath = "$2$cgipath"; } $this->Set('SERVER', $server); $this->Set('CGIPATH', $cgipath); } $this->Set('CONFVER', $this->Get('VERSION')); } #============================================================================================================ # Module END #============================================================================================================ 1; zerochplus_0.7.5/test/module/samwise.pl 0000644 0000000 0000000 00000022005 14216364775 015160 0 ustar #============================================================================================================ # # フォーム情報管理モジュール # #============================================================================================================ package SAMWISE; use strict; #use warnings; #------------------------------------------------------------------------------------------------------------ # # モジュールコンストラクタ - new # ------------------------------------------- # 引 数：$throughget GETリクエストの受け入れ # 戻り値：モジュールオブジェクト # #------------------------------------------------------------------------------------------------------------ sub new { my $class = shift; my ($throughget) = @_; my $form = ''; if ($ENV{'REQUEST_METHOD'} eq 'POST') { read STDIN, $form, $ENV{'CONTENT_LENGTH'}; } elsif ($throughget && defined $ENV{'QUERY_STRING'}) { $form = $ENV{'QUERY_STRING'}; } my @SRC = split(/[&;]/, $form); my $obj = { 'FORM' => undef, 'SRC' => \@SRC, }; bless $obj, $class; return $obj; } #------------------------------------------------------------------------------------------------------------ # # フォーム情報デコード - DecodeForm # ------------------------------------------- # 引 数：$mode : # 戻り値：なし # #------------------------------------------------------------------------------------------------------------ sub DecodeForm { my $this = shift; my ($mode) = @_; $this->{'FORM'} = {}; foreach (@{$this->{'SRC'}}) { my ($var, $val) = split(/=/, $_, 2); $val =~ tr/+/ /; $val =~ s/%([0-9a-fA-F][0-9a-fA-F])/pack('C', hex($1))/eg; $val =~ s/\r\n|\r|\n/\n/g; $val =~ s/\0//g; $this->{'FORM'}->{$var} = $val; $this->{'FORM'}->{"Raw_$var"} = $val; } } #------------------------------------------------------------------------------------------------------------ # # 特定フォーム情報デコード - GetAtArray # ------------------------------------------- # 引 数：$key : 取得キー # $f : 変換フラグ # 戻り値：キーデータの配列 # #------------------------------------------------------------------------------------------------------------ sub GetAtArray { my $this = shift; my ($key, $f) = @_; my @ret = (); foreach (@{$this->{'SRC'}}) { my ($var, $val) = split(/=/, $_, 2); if ($key eq $var) { $val =~ tr/+/ /; $val =~ s/%([0-9a-fA-F][0-9a-fA-F])/pack('C', hex($1))/eg; $val =~ s/\r\n|\r|\n/\n/g; $val =~ s/\0//g; if ($f) { $val =~ s/"/"/g; $val =~ s//>/g; $val =~ s/\r\n|\r|\n/
/g; } push @ret, $val; } } return @ret; } #------------------------------------------------------------------------------------------------------------ # # フォーム情報取得 - Get # ------------------------------------------- # 引 数：$key : 取得キー # $default : デフォルト # 戻り値：データ # #------------------------------------------------------------------------------------------------------------ sub Get { my $this = shift; my ($key, $default) = @_; my $val = $this->{'FORM'}->{$key}; return (defined $val ? $val : (defined $default ? $default : '')); } #------------------------------------------------------------------------------------------------------------ # # フォーム情報設定 - Set # ------------------------------------------- # 引 数：$key : 取得キー # $data : 設定データ # 戻り値：なし # #------------------------------------------------------------------------------------------------------------ sub Set { my $this = shift; my ($key, $data) = @_; $this->{'FORM'}->{$key} = $data; } #------------------------------------------------------------------------------------------------------------ # # form値存在確認 # ------------------------------------------------------------------------------------- # @param $key キー # @param $data 値 # @return 値が等しいならtrueを返す # #------------------------------------------------------------------------------------------------------------ sub Equal { my $this = shift; my ($key, $data) = @_; my $val = $this->{'FORM'}->{$key}; return (defined $val && $val eq $data); } #------------------------------------------------------------------------------------------------------------ # # 入力チェック - IsInput # ------------------------------------------- # 引 数：$pkeylist : 判定項目リスト(リファレンス) # 戻り値：入力OKなら1,未入力ありなら0 # #------------------------------------------------------------------------------------------------------------ sub IsInput { my $this = shift; my ($pKeyList) = @_; foreach (@$pKeyList) { my $val = $this->{'FORM'}->{$_}; if (!defined $val || $val eq '') { return 0; } } return 1; } #------------------------------------------------------------------------------------------------------------ # # 全入力チェック - IsInput # ------------------------------------------- # 引 数：なし # 戻り値：入力OKなら1,未入力ありなら0 # #------------------------------------------------------------------------------------------------------------ sub IsInputAll { my $this = shift; foreach (values %{$this->{'FORM'}}) { if ($_ eq '') { return 0; } } return 1; } #------------------------------------------------------------------------------------------------------------ # # form値存在確認 # ------------------------------------------------------------------------------------- # @param $key キー # @return キーが存在したらtrue # #------------------------------------------------------------------------------------------------------------ sub IsExist { my $this = shift; my ($key) = @_; return exists $this->{'FORM'}->{$key}; } #------------------------------------------------------------------------------------------------------------ # # form値存在確認 # ------------------------------------------------------------------------------------- # @param $key キー # @param $string 検索文字 # @return 検索文字が存在したら1 # #------------------------------------------------------------------------------------------------------------ sub Contain { my $this = shift; my ($key, $string) = @_; if ($this->{'FORM'}->{$key} =~ /\Q$string\E/) { return 1; } return 0; } #------------------------------------------------------------------------------------------------------------ # # 列挙form値取得 # ------------------------------------------------------------------------------------- # @param $pArray 結果格納バッファ # @param @list 取得データリスト # @return なし # #------------------------------------------------------------------------------------------------------------ sub GetListData { my $this = shift; my ($pArray, @list) = @_; foreach (@list) { push @$pArray, $this->{'FORM'}->{$_}; } } #------------------------------------------------------------------------------------------------------------ # # 数字調査 # ------------------------------------------------------------------------------------- # @param $pKeys 調査データキー # @return 数字なら1 # #------------------------------------------------------------------------------------------------------------ sub IsNumber { my $this = shift; my ($pKeys) = @_; foreach (@$pKeys) { if ($this->{'FORM'}->{$_} =~ /[^0-9]/) { return 0; } } return 1; } #------------------------------------------------------------------------------------------------------------ # # 半角英数字調査 # ------------------------------------------------------------------------------------- # @param $pKeys 調査データキー # @return 半角英数字なら1 # #------------------------------------------------------------------------------------------------------------ sub IsAlphabet { my $this = shift; my ($pKeys) = @_; foreach (@$pKeys) { if ($this->{'FORM'}->{$_} =~ /[^0-9a-zA-Z_@]/) { return 0; } } return 1; } #------------------------------------------------------------------------------------------------------------ # # キャップキー用文字列調査 # ------------------------------------------------------------------------------------- # @param $pKeys 調査データキー # @return 半角英数字なら1 # #------------------------------------------------------------------------------------------------------------ sub IsCapKey { my $this = shift; my ($pKeys) = @_; foreach (@$pKeys) { if ($this->{'FORM'}->{$_} =~ /[^0-9a-zA-Z\_\.\+\-\*\/\@\:\!\%\&\(\)\=\~\^]/) { return 0; } } return 1; } #------------------------------------------------------------------------------------------------------------ # # 掲示板ディレクトリ名用文字列調査 # ------------------------------------------------------------------------------------- # @param $pKeys 調査データキー # @return 半角英数字なら1 # #------------------------------------------------------------------------------------------------------------ sub IsBBSDir { my $this = shift; my ($pKeys) = @_; foreach (@$pKeys) { if ($this->{'FORM'}->{$_} =~ /[^0-9a-zA-Z\_\-]/) { return 0; } } return 1; } #============================================================================================================ # モジュール終端 #============================================================================================================ 1; zerochplus_0.7.5/test/module/imrahil.pl 0000644 0000000 0000000 00000020270 14216364775 015137 0 ustar #============================================================================================================ # # ログ管理モジュール # -------------------------------------- # Modeのビットについて # 0:読取専用 # 1:オープンと同時に内容読み込み # 2:最大サイズを超えたログを保存 # 3〜:未使用 # #============================================================================================================ package IMRAHIL; use strict; #use warnings; #------------------------------------------------------------------------------------------------------------ # # コンストラクタ # ------------------------------------------------------------------------------------- # @param $file ログファイルパス(拡張子除く) # @param $limit ログ最大サイズ # @param $mode モード # @return モジュールオブジェクト # #------------------------------------------------------------------------------------------------------------ sub new { my $class = shift; my ($file, $limit, $mode) = @_; my $obj = { 'PATH' => $file, 'LIMIT' => $limit, 'MODE' => $mode, 'STAT' => 0, 'HANDLE' => undef, 'LOGS' => undef, 'SIZE' => undef, }; bless $obj, $class; return $obj; } #------------------------------------------------------------------------------------------------------------ # # デストラクタ # ------------------------------------------------------------------------------------- # @param なし # @return なし # #------------------------------------------------------------------------------------------------------------ sub DESTROY { my $this = shift; $this->Close; } #------------------------------------------------------------------------------------------------------------ # # ログオープン # ------------------------------------------------------------------------------------- # @param $file ログファイルパス(拡張子除く) # @param $limit ログ最大サイズ # @param $mode モード # @return 成功:0,失敗:-1 # #------------------------------------------------------------------------------------------------------------ sub Open { my $this = shift; my ($file, $limit, $mode) = @_; if (defined $file && defined $limit && defined $mode) { $this->{'PATH'} = $file; $this->{'LIMIT'} = $limit; $this->{'MODE'} = $mode; } else { $file = $this->{'PATH'}; $limit = int $this->{'LIMIT'}; $mode = int $this->{'MODE'}; } $this->Close; my $ret = -1; if (!$this->{'STAT'}) { $file .= '.cgi'; if (open(my $fh, (-f $file ? '+<' : '>'), $file)) { flock($fh, 2); seek($fh, 0, 2); binmode($fh); $this->{'HANDLE'} = $fh; $this->{'STAT'} = 1; $ret = ($mode & 2 ? $this->Read() : 0); } else { warn "can't open log: $file"; } } return $ret; } #------------------------------------------------------------------------------------------------------------ # # ログクローズ # ------------------------------------------------------------------------------------- # @param なし # @return なし # #------------------------------------------------------------------------------------------------------------ sub Close { my $this = shift; if ($this->{'STAT'}) { close($this->{'HANDLE'}); $this->{'HANDLE'} = undef; $this->{'STAT'} = 0; } } #------------------------------------------------------------------------------------------------------------ # # 読み込み # ------------------------------------------------------------------------------------- # @param なし # @return 成功:0,失敗:-1 # #------------------------------------------------------------------------------------------------------------ sub Read { my $this = shift; if ($this->{'STAT'}) { my $fh = $this->{'HANDLE'}; seek($fh, 0, 0); my @lines = <$fh>; map { s/[\r\n]+\z// } @lines; $this->{'LOGS'} = \@lines; $this->{'SIZE'} = scalar(@lines); return 0; } return -1; } #------------------------------------------------------------------------------------------------------------ # # 書き込み # ------------------------------------------------------------------------------------- # @param なし # @return なし # #------------------------------------------------------------------------------------------------------------ sub Write { my $this = shift; # ファイルオープン状態なら書き込みを実行する if ($this->{'STAT'}) { if (!($this->{'MODE'} & 1)) { my $fh = $this->{'HANDLE'}; seek($fh, 0, 0); for (my $i = 0 ; $i < $this->{'SIZE'} ; $i++) { print $fh "$this->{'LOGS'}->[$i]\n"; } truncate($fh, tell($fh)); } $this->Close(); } } #------------------------------------------------------------------------------------------------------------ # # データ取得 # ------------------------------------------------------------------------------------- # @param $line 取得データ行 # @return 取得データ # #------------------------------------------------------------------------------------------------------------ sub Get { my $this = shift; my ($line) = @_; if ($line >= 0 && $line < $this->{'SIZE'}) { return $this->{'LOGS'}->[$line]; } return undef; } #------------------------------------------------------------------------------------------------------------ # # データ追加 # ------------------------------------------------------------------------------------- # @param $pData 追加データ # @return なし # #------------------------------------------------------------------------------------------------------------ sub Put { my $this = shift; my (@datas) = @_; my $tm = time; my $logData = join('<>', $tm, @datas); push @{$this->{'LOGS'}}, $logData; $this->{'SIZE'}++; if ($this->{'SIZE'} + 10 > $this->{'LIMIT'}) { my $logName = "$this->{'PATH'}_old.cgi"; if (open(my $fh, '>>', $logName)) { flock($fh, 2); binmode($fh); while ($this->{'SIZE'} > $this->{'LIMIT'}) { my $old = shift @{$this->{'LOGS'}}; $this->{'SIZE'}--; if ($this->{'MODE'} & 4) { print $fh "$old\n"; } } close($fh); } } } #------------------------------------------------------------------------------------------------------------ # # サイズ取得 # ------------------------------------------------------------------------------------- # @param なし # @return サイズ # #------------------------------------------------------------------------------------------------------------ sub Size { my $this = shift; return $this->{'SIZE'}; } #------------------------------------------------------------------------------------------------------------ # # ログ退避 # ------------------------------------------------------------------------------------- # @param なし # @return なし # #------------------------------------------------------------------------------------------------------------ sub MoveToOld { my $this = shift; my $logName = "$this->{'PATH'}_old.cgi"; if (open(my $fh, '>>', $logName)) { flock($fh, 2); binmode($fh); for(my $i = 0 ; $i < $this->{'SIZE'} ; $i++) { print $fh "$this->{'LOGS'}->[$i]\n"; } close($fh); } } #------------------------------------------------------------------------------------------------------------ # # ログクリア # ------------------------------------------------------------------------------------- # @param なし # @return なし # #------------------------------------------------------------------------------------------------------------ sub Clear { my $this = shift; $this->{'LOGS'} = []; $this->{'SIZE'} = 0; } #------------------------------------------------------------------------------------------------------------ # # 検索 # ------------------------------------------------------------------------------------- # @param $index 検索要素のインデクス # @param $word 検索データ # @param $pResult 結果格納用配列の参照 # @return ヒット数 # #------------------------------------------------------------------------------------------------------------ sub search { my $this = shift; my ($index, $word, $pResult) = @_; my $num = 0; for(my $i = 0 ; $i < $this->{'SIZE'} ; $i++) { my @elem = split(/<>/, $this->{'LOGS'}->[$i], -1); if ($elem[$index] eq $word) { push @$pResult, $this->{'LOGS'}->[$i]; $num++; } } return $num; } #============================================================================================================ # Module END #============================================================================================================ 1; zerochplus_0.7.5/test/module/orald.pl 0000644 0000000 0000000 00000013721 14216364775 014616 0 ustar #============================================================================================================ # # エラー情報管理モジュール # #============================================================================================================ package ORALD; use strict; #use warnings; #------------------------------------------------------------------------------------------------------------ # # モジュールコンストラクタ - new # ------------------------------------------- # 引 数：なし # 戻り値：モジュールオブジェクト # #------------------------------------------------------------------------------------------------------------ sub new { my $this = shift; my $obj = { 'SUBJECT' => undef, 'MESSAGE' => undef, 'ERR' => undef, }; bless $obj, $this; return $obj; } #------------------------------------------------------------------------------------------------------------ # # エラー情報読み込み - Load # ------------------------------------------- # 引 数：$Sys : MELKOR # 戻り値：なし # #------------------------------------------------------------------------------------------------------------ sub Load { my $this = shift; my ($Sys) = @_; $this->{'ERR'} = undef; my $path = '.' . $Sys->Get('INFO') . '/errmsg.cgi'; if (open(my $fh, '<', $path)) { flock($fh, 2); my @lines = <$fh>; close($fh); map { s/[\r\n]+\z// } @lines; foreach (@lines) { next if ($_ eq '' || $_ =~ /^#/); my @elem = split(/<>/, $_, -1); if (scalar(@elem) < 3) { warn "invalid line in $path"; next; } my $id = $elem[0]; $this->{'SUBJECT'}->{$id} = $elem[1]; $this->{'MESSAGE'}->{$id} = $elem[2]; } } } #------------------------------------------------------------------------------------------------------------ # # エラー情報取得 - Get # ------------------------------------------- # 引 数：$err : エラー番号 # $kind : 種類 # 戻り値：エラー情報 # #------------------------------------------------------------------------------------------------------------ sub Get { my $this = shift; my ($err, $kind) = @_; my $val = $this->{$kind}->{$err}; return $val; } #------------------------------------------------------------------------------------------------------------ # # エラーページ出力 - PrintBBS # ------------------------------------------- # 引 数：$CGI : # $Page : THORIN # $err : エラー番号 # $mode : エージェント # 戻り値：なし # #------------------------------------------------------------------------------------------------------------ sub Print { my $this = shift; my ($CGI, $Page, $err, $mode) = @_; my $Form = $CGI->{'FORM'}; my $Sys = $CGI->{'SYS'}; my $version = $Sys->Get('VERSION'); my $bbsPath = $Sys->Get('BBSPATH') . '/' . $Sys->Get('BBS'); my $message = $this->{'MESSAGE'}->{$err}; # エラーメッセージの置換 my $sanitize = sub { #$_[0] =~ s/&/&/g; $_[0] =~ s//>/g; return $_[0]; }; $message =~ s/\\n/\n/g; $message =~ s/{!(.*?)!}/&$sanitize($Sys->Get($1, ''))/ge; # リモートホストの取得 my $koyuu = $Sys->Get('KOYUU'); $mode = '0' if (! defined $mode); $mode = 'O' if ($Form->Equal('mb', 'on')); # エラーログを保存 require './module/peregrin.pl'; my $Log = PEREGRIN->new; $Log->Load($Sys, 'ERR', ''); $Log->Set('', $err, $version, $koyuu, $mode); $Log->Save($Sys); #$Page->Print("Status: 412 Precondition Failed\n"); if ($mode eq 'O') { my $subject = $this->{'SUBJECT'}->{$err}; $Page->Print("Content-type: text/html\n\n"); $Page->Print("
"); $Page->Print("$message
こちら"); $Page->Print("から戻ってください"); } else { my $Cookie = $CGI->{'COOKIE'}; my $Set = $CGI->{'SET'}; my $name = &$sanitize($Form->Get('NAME')); my $mail = &$sanitize($Form->Get('MAIL')); my $msg = $Form->Get('MESSAGE'); # cookie情報の出力 if ($Set->Equal('BBS_NAMECOOKIE_CHECK', 'checked')) { $Cookie->Set('NAME', $name, 'utf8'); } if ($Set->Equal('BBS_MAILCOOKIE_CHECK', 'checked')) { $Cookie->Set('MAIL', $mail, 'utf8'); } $Cookie->Out($Page, $Set->Get('BBS_COOKIEPATH'), 60 * 24 * 30); $Page->Print("Content-type: text/html\n\n"); if ($err < $ZP::E_REG_SAMBA_CAUTION || $err > $ZP::E_REG_SAMBA_STILL) { $Page->Print(<
ＥＲＲＯＲ：$message
ホスト$koyuu
名前： $name
E-mail： $mail
内容：
$msg
こちらでリロードしてください。 GO!
$version
HTML
}
else {
my $sambaerr = {
$ZP::E_REG_SAMBA_CAUTION => $ZP::E_REG_SAMBA_2CH1,
$ZP::E_REG_SAMBA_WARNING => $ZP::E_REG_SAMBA_2CH2,
$ZP::E_REG_SAMBA_LISTED => $ZP::E_REG_SAMBA_2CH3,
$ZP::E_REG_SAMBA_STILL => $ZP::E_REG_SAMBA_2CH3,
}->{$err};
$Page->Print(<
ＥＲＲＯＲ - $sambaerr $message
(Samba24-2.13互換)
$version
HTML
}
}
}
#============================================================================================================
# モジュール終端
#============================================================================================================
1;
zerochplus_0.7.5/test/module/session.pl 0000644 0000000 0000000 00000016645 14216364775 015210 0 ustar #============================================================================================================
#
# セッション管理モジュール
#
#============================================================================================================
#============================================================================================================
#
# セッションマネージャパッケージ
#
#============================================================================================================
package SessionManager;
use strict;
#use warnings;
#------------------------------------------------------------------------------------------------------------
#
# セッションの取得
# -------------------------------------------------------------------------------------
# @param なし
# @return Sessionオブジェクト
#
#------------------------------------------------------------------------------------------------------------
sub getSession
{
my $session = new Session;
my $id = createSessionID();
my $filePath = "./info/session/$id";
my $check = 1;
# セッション情報ファイルが存在する場合はそれを読み込む
if (open(my $fh, '<', $filePath)) {
flock($fh, 2);
my @lines = <$fh>;
close($fh);
map { s/[\r\n]+\z// } @lines;
foreach (@lines) {
# 1行目(セッション開始時間)を取得
if ($check) {
$check = 0;
$session->setId($_);
if (time - $_ > 3600) {
$session->setId(time);
last;
}
# 2行目以降(セッション属性値)を取得
}
else {
my ($key, $value) = split(/=/, $_);
$value =~ s/&equal;/=/g;
$session->setAttribute($key, $value);
}
}
# セッション情報ファイルが存在しない場合は空ファイルを作成する
}
else {
if (!-e './info/session' || !-d './info/session') {
require './module/earendil.pl';
EARENDIL::CreateDirectory('./info/session', 0770);
}
open(my $fh, '>', $filePath);
close($fh);
$session->setId(time);
}
return $session;
}
#------------------------------------------------------------------------------------------------------------
#
# セッションの保存
# -------------------------------------------------------------------------------------
# @param $session Sessionオブジェクト
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub setSession
{
my ($session) = @_;
my $id = createSessionID($ENV{'REMOTE_ADDR'});
my $filePath = "./info/session/$id";
if (open(my $fh, '+<', $filePath)) {
flock($fh, 2);
seek($fh, 0, 0);
binmode($fh);
print $fh $session->getId() . "\n";
foreach my $key (keys %{$session->{'ATTRIBUTE'}}) {
my $value = $session->getAttribute($key);
$value =~ s/=/&equal;/g;
print $fh "$key=$value\n";
}
truncate($fh, tell($fh));
close($fh);
}
}
#------------------------------------------------------------------------------------------------------------
#
# セッションの削除
# -------------------------------------------------------------------------------------
# @param なし
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub removeSession
{
my $id = createSessionID($ENV{'REMOTE_ADDR'});
my $filePath = "./info/session/$id";
unlink $filePath;
}
#------------------------------------------------------------------------------------------------------------
#
# セッションIDの生成
# -------------------------------------------------------------------------------------
# @param なし
# @return セッションID
#
#------------------------------------------------------------------------------------------------------------
sub createSessionID
{
my $key = $ENV{'REMOTE_ADDR'};
$key =~ s/\.//g;
$key = substr($ENV{'REMOTE_ADDR'}, -8);
return substr(crypt($key, substr(crypt($key, 'ZC'), -2)), -26);
}
#============================================================================================================
#
# セッションオブジェクトパッケージ
#
#============================================================================================================
package Session;
use strict;
#use warnings;
#------------------------------------------------------------------------------------------------------------
#
# コンストラクタ
# -------------------------------------------------------------------------------------
# @param なし
# @return セッションオブジェクト
#
#------------------------------------------------------------------------------------------------------------
sub new
{
my $class = shift;
my $obj = {
'ID' => undef,
'ATTRIBUTE' => undef,
};
bless $obj, $class;
return $obj;
}
#------------------------------------------------------------------------------------------------------------
#
# デストラクタ
# -------------------------------------------------------------------------------------
# @param なし
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub DESTROY
{
my $this = shift;
if (defined $this->{'ID'}) {
SessionManager::setSession($this);
}
}
#------------------------------------------------------------------------------------------------------------
#
# 属性設定
# -------------------------------------------------------------------------------------
# @param $key 属性キー
# @param $value 属性値
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub setAttribute
{
my $this = shift;
my ($key, $value) = @_;
$this->{'ATTRIBUTE'}->{$key} = $value;
}
#------------------------------------------------------------------------------------------------------------
#
# 属性取得
# -------------------------------------------------------------------------------------
# @param $key 属性キー
# @return 属性値
#
#------------------------------------------------------------------------------------------------------------
sub getAttribute
{
my $this = shift;
my ($key) = @_;
return $this->{'ATTRIBUTE'}->{$key};
}
#------------------------------------------------------------------------------------------------------------
#
# 属性削除
# -------------------------------------------------------------------------------------
# @param $key 属性キー
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub removeAttribute
{
my $this = shift;
my ($key) = @_;
delete $this->{'ATTRIBUTE'}->{$key};
}
#------------------------------------------------------------------------------------------------------------
#
# ID設定
# -------------------------------------------------------------------------------------
# @param $id ID
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub setId
{
my $this = shift;
my ($id) = @_;
$this->{'ID'} = $id;
}
#------------------------------------------------------------------------------------------------------------
#
# ID取得
# -------------------------------------------------------------------------------------
# @param なし
# @return ID
#
#------------------------------------------------------------------------------------------------------------
sub getId
{
my $this = shift;
return $this->{'ID'};
}
#============================================================================================================
# Module END
#============================================================================================================
1;
zerochplus_0.7.5/test/module/balrogs.pl 0000644 0000000 0000000 00000013610 14216364774 015142 0 ustar #============================================================================================================
#
# 検索モジュール(BALROGS)
#
#============================================================================================================
package BALROGS;
use strict;
#use warnings;
use Encode qw(encode decode);
#------------------------------------------------------------------------------------------------------------
#
# コンストラクタ
# -------------------------------------------------------------------------------------
# @param なし
# @return モジュールオブジェクト
#
#------------------------------------------------------------------------------------------------------------
sub new
{
my $class = shift;
my $obj = {
'SYS' => undef,
'TYPE' => undef,
'SEARCHSET' => undef,
'RESULTSET' => undef,
};
bless $obj, $class;
return $obj;
}
#------------------------------------------------------------------------------------------------------------
#
# 検索設定
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @param $mode 0:全検索,1:BBS内検索,2:スレッド内検索
# @param $type 0:全検索,1:名前検索,2:本文検索
# 4:ID(日付)検索
# @param $bbs 検索BBS名($mode=1の場合に指定)
# @param $thread 検索スレッド名($mode=2の場合に指定)
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Create
{
my $this = shift;
my ($Sys, $mode, $type, $bbs, $thread) = @_;
$this->{'SYS'} = $Sys;
$this->{'TYPE'} = $type;
$this->{'SEARCHSET'} = [];
$this->{'RESULTSET'} = [];
my $pSearchSet = $this->{'SEARCHSET'};
# 鯖内全検索
if ($mode == 0) {
require './module/baggins.pl';
require './module/nazguls.pl';
my $BBSs = NAZGUL->new;
$BBSs->Load($Sys);
my @bbsSet = ();
$BBSs->GetKeySet('ALL', '', \@bbsSet);
my $BBSpath = $Sys->Get('BBSPATH');
foreach my $bbsID (@bbsSet) {
my $dir = $BBSs->Get('DIR', $bbsID);
# 板ディレクトリに.0ch_hiddenというファイルがあれば読み飛ばす
next if (-e "$BBSpath/$dir/.0ch_hidden");
$Sys->Set('BBS', $dir);
my $Threads = BILBO->new;
$Threads->Load($Sys);
my @threadSet = ();
$Threads->GetKeySet('ALL', '', \@threadSet);
foreach my $threadID (@threadSet) {
my $set = "$dir<>$threadID";
push @$pSearchSet, $set;
}
}
}
# 掲示板内全検索
elsif ($mode == 1) {
require './module/baggins.pl';
my $Threads = BILBO->new;
$Sys->Set('BBS', $bbs);
$Threads->Load($Sys);
my @threadSet = ();
$Threads->GetKeySet('ALL', '', \@threadSet);
foreach my $threadID (@threadSet) {
my $set = "$bbs<>$threadID";
push @$pSearchSet, $set;
}
}
# スレッド内全検索
elsif ($mode == 2) {
my $set = "$bbs<>$thread";
push @$pSearchSet, $set;
}
# 指定がおかすぃ
else {
return;
}
# datモジュール読み込み
if (! defined $this->{'ARAGORN'}) {
require './module/gondor.pl';
$this->{'ARAGORN'} = ARAGORN->new;
}
}
#------------------------------------------------------------------------------------------------------------
#
# 検索実行
# -------------------------------------------------------------------------------------
# @param $word 検索ワード
# @param $f 前結果クリアフラグ
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Run
{
my $this = shift;
my ($word, $f) = @_;
my $pSearchSet = $this->{'SEARCHSET'};
$this->{'RESULTSET'} = [] if ($f);
foreach (@$pSearchSet) {
my ($bbs, $key) = split(/<>/, $_);
$this->{'SYS'}->Set('BBS', $bbs);
$this->{'SYS'}->Set('KEY', $key);
$this->Search($word);
}
return $this->{'RESULTSET'};
}
#------------------------------------------------------------------------------------------------------------
#
# 検索結果取得
# -------------------------------------------------------------------------------------
# @param なし
# @return 結果セット
#
#------------------------------------------------------------------------------------------------------------
sub GetResultSet
{
my $this = shift;
return $this->{'RESULTSET'};
}
#------------------------------------------------------------------------------------------------------------
#
# 検索実装部
# -------------------------------------------------------------------------------------
# @param $word : 検索ワード
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Search
{
my $this = shift;
my ($word) = @_;
my $bbs = $this->{'SYS'}->Get('BBS');
my $key = $this->{'SYS'}->Get('KEY');
my $Path = $this->{'SYS'}->Get('BBSPATH') . "/$bbs/dat/$key.dat";
my $ARAGORN = $this->{'ARAGORN'};
my $word = decode('cp932', $word);
if ($ARAGORN->Load($this->{'SYS'}, $Path, 1)) {
my $pResultSet = $this->{'RESULTSET'};
my $type = $this->{'TYPE'} || 0x7;
# すべてのレス数でループ
for (my $i = 0 ; $i < $ARAGORN->Size() ; $i++) {
my $bFind = 0;
my $pDat = $ARAGORN->Get($i);
my $data = decode('cp932', $$pDat);
my @elem = split(/<>/, $data, -1);
# 名前検索
if ($type & 0x1) {
if ($elem[0] =~ s/(\Q$word\E)(?![^<>]*>)/$1<\/span>/g) {
$bFind = 1;
}
}
# 本文検索
if ($type & 0x2) {
if ($elem[3] =~ s/(\Q$word\E)(?![^<>]*>)/$1<\/span>/g) {
$bFind = 1;
}
}
# ID or 日付検索
if ($type & 0x4) {
if ($elem[2] =~ s/(\Q$word\E)(?![^<>]*>)/$1<\/span>/g) {
$bFind = 1;
}
}
if ($bFind) {
my $SetStr = "$bbs<>$key<>" . ($i + 1) . '<>';
$SetStr .= join('<>', @elem);
$SetStr = encode('cp932', $SetStr);
push @$pResultSet, $SetStr;
}
}
}
$ARAGORN->Close();
}
#============================================================================================================
# Module END
#============================================================================================================
1;
zerochplus_0.7.5/test/module/gandalf.pl 0000644 0000000 0000000 00000021043 14216364775 015105 0 ustar #============================================================================================================
#
# ユーザ通知管理モジュール
#
#============================================================================================================
package GANDALF;
use strict;
#use warnings;
#------------------------------------------------------------------------------------------------------------
#
# コンストラクタ
# -------------------------------------------------------------------------------------
# @param なし
# @return モジュールオブジェクト
#
#------------------------------------------------------------------------------------------------------------
sub new
{
my $class = shift;
my $obj = {
'TO' => undef,
'FROM' => undef,
'SUBJECT' => undef,
'TEXT' => undef,
'DATE' => undef,
'LIMIT' => undef,
};
bless $obj, $class;
return $obj;
}
#------------------------------------------------------------------------------------------------------------
#
# 通知情報読み込み
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Load
{
my $this = shift;
my ($Sys) = @_;
# ハッシュ初期化
$this->{'TO'} = {};
$this->{'FROM'} = {};
$this->{'SUBJECT'} = {};
$this->{'TEXT'} = {};
$this->{'DATE'} = {};
$this->{'LIMIT'} = {};
my $path = '.' . $Sys->Get('INFO') . '/notice.cgi';
if (open(my $fh, '<', $path)) {
flock($fh, 2);
my @lines = <$fh>;
close($fh);
map { s/[\r\n]+\z// } @lines;
foreach (@lines) {
next if ($_ eq '');
my @elem = split(/<>/, $_, -1);
if (scalar(@elem) < 7) {
warn "invalid line in $path";
#next;
}
my $id = $elem[0];
$this->{'TO'}->{$id} = $elem[1];
$this->{'FROM'}->{$id} = $elem[2];
$this->{'SUBJECT'}->{$id} = $elem[3];
$this->{'TEXT'}->{$id} = $elem[4];
$this->{'DATE'}->{$id} = $elem[5];
$this->{'LIMIT'}->{$id} = $elem[6];
}
}
}
#------------------------------------------------------------------------------------------------------------
#
# 通知情報保存
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Save
{
my $this = shift;
my ($Sys) = @_;
foreach my $id (keys %{$this->{'TO'}}) {
if ($this->IsLimitOut($id)) {
$this->Delete($id);
}
}
my $path = '.' . $Sys->Get('INFO') . '/notice.cgi';
chmod($Sys->Get('PM-ADM'), $path);
if (open(my $fh, (-f $path ? '+<' : '>'), $path)) {
flock($fh, 2);
seek($fh, 0, 0);
binmode($fh);
foreach (keys %{$this->{'TO'}}) {
my $data = join('<>',
$_,
$this->{'TO'}->{$_},
$this->{'FROM'}->{$_},
$this->{'SUBJECT'}->{$_},
$this->{'TEXT'}->{$_},
$this->{'DATE'}->{$_},
$this->{'LIMIT'}->{$_}
);
print $fh "$data\n";
}
truncate($fh, tell($fh));
close($fh);
}
chmod($Sys->Get('PM-ADM'), $path);
}
#------------------------------------------------------------------------------------------------------------
#
# IDセット取得
# -------------------------------------------------------------------------------------
# @param $kind 検索種別
# @param $name 検索ワード
# @param $pBuf IDセット格納バッファ
# @return キーセット数
#
#------------------------------------------------------------------------------------------------------------
sub GetKeySet
{
my $this = shift;
my ($kind, $name, $pBuf) = @_;
my $n = 0;
if ($kind eq 'ALL') {
$n += push @$pBuf, keys(%{$this->{'TO'}});
}
else {
foreach my $key (keys(%{$this->{$kind}})) {
if (($this->{$kind}->{$key} eq $name) || ($kind eq 'ALL')) {
$n += push @$pBuf, $key;
}
}
}
return $n;
}
#------------------------------------------------------------------------------------------------------------
#
# 通知情報取得
# -------------------------------------------------------------------------------------
# @param $kind 情報種別
# @param $key ID
# @param $default デフォルト
# @return 情報
#
#------------------------------------------------------------------------------------------------------------
sub Get
{
my $this = shift;
my ($kind, $key, $default) = @_;
my $val = $this->{$kind}->{$key};
return (defined $val ? $val : (defined $default ? $default : undef));
}
#------------------------------------------------------------------------------------------------------------
#
# 通知情報追加
# -------------------------------------------------------------------------------------
# @param $to 通知先ユーザ
# @param $from 送信ユーザ
# @param $subj タイトル
# @param $text 内容
# @param $limit 期限
# @return ID
#
#------------------------------------------------------------------------------------------------------------
sub Add
{
my $this = shift;
my ($to, $from, $subj, $text, $limit) = @_;
my $id = time;
$id++ while (exists $this->{'TO'}->{$id});
$this->{'TO'}->{$id} = $to;
$this->{'FROM'}->{$id} = $from;
$this->{'SUBJECT'}->{$id} = $subj;
$this->{'TEXT'}->{$id} = $text;
$this->{'DATE'}->{$id} = time;
$this->{'LIMIT'}->{$id} = $limit;
return $id;
}
#------------------------------------------------------------------------------------------------------------
#
# 通知情報設定
# -------------------------------------------------------------------------------------
# @param $id ID
# @param $kind 情報種別
# @param $val 設定値
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Set
{
my $this = shift;
my ($id, $kind, $val) = @_;
if (exists $this->{$kind}->{$id}) {
$this->{$kind}->{$id} = $val;
}
}
#------------------------------------------------------------------------------------------------------------
#
# 通知情報削除
# -------------------------------------------------------------------------------------
# @param $id 削除ID
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Delete
{
my $this = shift;
my ($id) = @_;
delete $this->{'TO'}->{$id};
delete $this->{'FROM'}->{$id};
delete $this->{'SUBJECT'}->{$id};
delete $this->{'TEXT'}->{$id};
delete $this->{'DATE'}->{$id};
delete $this->{'LIMIT'}->{$id};
}
#------------------------------------------------------------------------------------------------------------
#
# 通知情報判定
# -------------------------------------------------------------------------------------
# @param $id 通知ID
# @param $user ユーザID
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub IsInclude
{
my $this = shift;
my ($id, $user) = @_;
# 全体通知
if ($this->{'TO'}->{$id} eq '*') {
return 1;
}
my @users = split(/\, ?/, $this->{'TO'}->{$id});
foreach (@users) {
if ($_ eq $user) {
return 1;
}
}
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# 通知情報期限切れ判定
# -------------------------------------------------------------------------------------
# @param $id 通知ID
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub IsLimitOut
{
my $this = shift;
my ($id) = @_;
# 全体通知の場合のみ
if ($this->{'TO'}->{$id} eq '*') {
my $now = time;
if ($now > $this->{'LIMIT'}->{$id}) {
return 1;
}
}
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# 通知先ユーザ削除
# -------------------------------------------------------------------------------------
# @param $id 通知ID
# @param $user ユーザID
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub RemoveToUser
{
my $this = shift;
my ($id, $user) = @_;
# 全体通知は個別削除不可
if ($this->{'TO'}->{$id} eq '*') {
return;
}
my @users = split(/\, ?/, $this->{'TO'}->{$id});
my @news = ();
foreach (@users) {
if ($_ ne $user) {
push(@news, $_);
}
}
# すべての通知先ユーザが削除されたら、その通知は破棄する
if (scalar(@news) == 0) {
$this->Delete($id);
}
else {
$this->{'TO'}->{$id} = join(',', @news);
}
}
#============================================================================================================
# Module END
#============================================================================================================
1;
zerochplus_0.7.5/test/module/athelas.pl 0000644 0000000 0000000 00000036206 14216364774 015140 0 ustar #============================================================================================================
#
# プラグイン管理モジュール
#
#============================================================================================================
package ATHELAS;
use strict;
#use warnings;
#------------------------------------------------------------------------------------------------------------
#
# コンストラクタ
# -------------------------------------------------------------------------------------
# @param なし
# @return モジュールオブジェクト
#
#------------------------------------------------------------------------------------------------------------
sub new
{
my $class = shift;
my $obj = {
'Sys' => undef,
'FILE' => undef,
'CLASS' => undef,
'NAME' => undef,
'EXPL' => undef,
'TYPE' => undef,
'VALID' => undef,
'CONFIG' => undef,
'CONFTYPE' => undef,
'ORDER' => undef,
};
bless $obj, $class;
return $obj;
}
#------------------------------------------------------------------------------------------------------------
#
# プラグイン情報読み込み
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Load
{
my $this = shift;
my ($Sys) = @_;
# ハッシュ初期化
$this->{'SYS'} = $Sys;
$this->{'FILE'} = {};
$this->{'CLASS'} = {};
$this->{'NAME'} = {};
$this->{'EXPL'} = {};
$this->{'TYPE'} = {};
$this->{'VALID'} = {};
$this->{'CONFIG'} = {};
$this->{'CONFTYPE'} = {};
$this->{'ORDER'} = [];
my $path = '.' . $Sys->Get('INFO') . '/plugins.cgi';
if (open(my $fh, '<', $path)) {
flock($fh, 2);
my @lines = <$fh>;
close($fh);
map { s/[\r\n]+\z// } @lines;
foreach (@lines) {
next if ($_ eq '');
my @elem = split(/<>/, $_, -1);
if (scalar(@elem) < 7) {
warn "invalid line in $path";
#next;
}
eval { require "./plugin/$elem[1]"; };
next if ($@);
my $id = $elem[0];
$this->{'FILE'}->{$id} = $elem[1];
$this->{'CLASS'}->{$id} = $elem[2];
$this->{'NAME'}->{$id} = $elem[3];
$this->{'EXPL'}->{$id} = $elem[4];
$this->{'TYPE'}->{$id} = $elem[5];
$this->{'VALID'}->{$id} = $elem[6];
$this->{'CONFIG'}->{$id} = {};
$this->{'CONFTYPE'}->{$id} = {};
push @{$this->{'ORDER'}}, $id;
$this->SetDefaultConfig($id);
$this->LoadConfig($id);
}
}
}
#------------------------------------------------------------------------------------------------------------
#
# プラグイン個別設定読み込み
# -------------------------------------------------------------------------------------
# @param $id
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub LoadConfig
{
my $this = shift;
my ($id) = @_;
my $config = $this->{'CONFIG'}->{$id};
my $conftype = $this->{'CONFTYPE'}->{$id};
my $file = $this->{'FILE'}->{$id};
my $path = undef;
if ($file =~ /^(0ch_.*)\.pl$/) {
$path = "./plugin_conf/$1.cgi";
}
else {
warn "invalid plugin file name: $file";
return;
}
if (open(my $fh, '<', $path)) {
flock($fh, 2);
my @lines = <$fh>;
close($fh);
map { s/[\r\n]+\z// } @lines;
foreach (@lines) {
my @elem = split(/<>/, $_, -1);
if (scalar(@elem) < 3) {
warn "invalid line in $path";
next;
}
$config->{$elem[1]} = $elem[2];
$conftype->{$elem[1]} = $elem[0];
}
}
}
#------------------------------------------------------------------------------------------------------------
#
# プラグイン個別設定保存
# -------------------------------------------------------------------------------------
# @param $id
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub SaveConfig
{
my $this = shift;
my ($id) = @_;
my $config = $this->{'CONFIG'}->{$id};
my $conftype = $this->{'CONFTYPE'}->{$id};
my $file = $this->{'FILE'}->{$id};
my $path = undef;
if ($file =~ /^(0ch_.*)\.pl$/) {
$path = "./plugin_conf/$1.cgi";
}
else {
warn "invalid plugin file name: $file";
return;
}
if (scalar(keys %$config) > 0) {
chmod($this->{'SYS'}->Get('PM-ADM'), $path);
if (open(my $fh, (-f $path ? '+<' : '>'), $path)) {
flock($fh, 2);
seek($fh, 0, 0);
foreach my $key (sort keys %$config) {
next unless (defined $config->{$key});
my $val = $config->{$key};
my $type = $conftype->{$key};
if ($type == 1) {
$val -= 0;
}
elsif ($type == 2) {
$val =~ s/\r\n|[\r\n]//g; $val =~ s/<>/<>/g; } elsif ($type == 3) { $val = ($val ? 1 : 0); } print $fh "$type<>$key<>$val\n"; } truncate($fh, tell($fh)); close($fh); } else { warn "can't save subject: $path"; } chmod($this->{'SYS'}->Get('PM-ADM'), $path); } else { unlink $path; } } sub HasConfig { my $this = shift; my ($id) = @_; return scalar(keys %{$this->{'CONFIG'}->{$id}}); } #------------------------------------------------------------------------------------------------------------ # # プラグイン個別設定初期値設定 # ------------------------------------------------------------------------------------- # @param $id # @return なし # #------------------------------------------------------------------------------------------------------------ sub SetDefaultConfig { my $this = shift; my ($id) = @_; my $config = $this->{'CONFIG'}->{$id} = {}; my $conftype = $this->{'CONFTYPE'}->{$id} = {}; my $file = $this->{'FILE'}->{$id}; my $className = undef; if ($file =~ /^0ch_(.*)\.pl$/) { $className = "ZPL_$1"; } else { warn "invalid plugin file name: $file"; return; } require "./plugin/$file"; if ($className->can('getConfig')) { my $plugin = $className->new; my $conf = $plugin->getConfig; foreach my $key (keys %$conf) { $config->{$key} = $conf->{$key}->{'default'}; $conftype->{$key} = $conf->{$key}->{'valuetype'}; } } } #------------------------------------------------------------------------------------------------------------ # # プラグイン情報保存 # ------------------------------------------------------------------------------------- # @param $Sys MELKOR # @return なし # #------------------------------------------------------------------------------------------------------------ sub Save { my $this = shift; my ($Sys) = @_; my $path = '.' . $Sys->Get('INFO') . '/plugins.cgi'; chmod($Sys->Get('PM-ADM'), $path); if (open(my $fh, (-f $path ? '+<' : '>'), $path)) { flock($fh, 2); seek($fh, 0, 0); binmode($fh); foreach my $id (@{$this->{'ORDER'}}) { my $data = join('<>', $id, $this->{'FILE'}->{$id}, $this->{'CLASS'}->{$id}, $this->{'NAME'}->{$id}, $this->{'EXPL'}->{$id}, $this->{'TYPE'}->{$id}, $this->{'VALID'}->{$id} ); print $fh "$data\n"; } truncate($fh, tell($fh)); close($fh); } chmod($Sys->Get('PM-ADM'), $path); } #------------------------------------------------------------------------------------------------------------ # # プラグインIDセット取得 # ------------------------------------------------------------------------------------- # @param $kind 検索種別 # @param $name 検索ワード # @param $pBuf IDセット格納バッファ # @return キーセット数 # #------------------------------------------------------------------------------------------------------------ sub GetKeySet { my $this = shift; my ($kind, $name, $pBuf) = @_; my $n = 0; if ($kind eq 'ALL') { $n += push @$pBuf, @{$this->{'ORDER'}}; } else { foreach my $key (@{$this->{'ORDER'}}) { if ($this->{$kind}->{$key} eq $name || $name eq 'ALL') { $n += push @$pBuf, $key; } } } return $n; } #------------------------------------------------------------------------------------------------------------ # # プラグイン情報取得 # ------------------------------------------------------------------------------------- # @param $kind 情報種別 # @param $key ユーザID # @param $default デフォルト # @return ユーザ情報 # #------------------------------------------------------------------------------------------------------------ sub Get { my $this = shift; my ($kind, $key, $default) = @_; my $val = $this->{$kind}->{$key}; return (defined $val ? $val : (defined $default ? $default : undef)); } #------------------------------------------------------------------------------------------------------------ # # プラグイン情報設定 # ------------------------------------------------------------------------------------- # @param $id ユーザID # @param $kind 情報種別 # @param $val 設定値 # @return なし # #------------------------------------------------------------------------------------------------------------ sub Set { my $this = shift; my ($id, $kind, $val) = @_; if (exists $this->{$kind}->{$id}) { $this->{$kind}->{$id} = $val; } } #------------------------------------------------------------------------------------------------------------ # # プラグイン追加 # ------------------------------------------------------------------------------------- # @param $file プラグインファイル名 # @param $valid 有効フラグ # @return プラグインID # #------------------------------------------------------------------------------------------------------------ sub Add { my $this = shift; my ($file, $valid) = @_; my $id = time; $id++ while (exists $this->{'FILE'}->{$id}); if (! -e "./plugin/$file") { warn "not found plugin: ./plugin/$file"; return undef; } my $className = undef; if ($file =~ /0ch_(.*)\.pl/) { $className = "ZPL_$1"; } else { warn "invalid plugin file name: $file"; return undef; } require "./plugin/$file"; if (!$className->can('new')) { warn "invalid plugin file name: $file"; return undef; } my $plugin = $className->new; $this->{'FILE'}->{$id} = $file; $this->{'CLASS'}->{$id} = $className; $this->{'NAME'}->{$id} = $plugin->getName; $this->{'EXPL'}->{$id} = $plugin->getExplanation; $this->{'TYPE'}->{$id} = $plugin->getType; $this->{'VALID'}->{$id} = $valid; $this->{'CONFIG'}->{$id} = {}; $this->{'CONFTYPE'}->{$id} = {}; $this->SetDefaultConfig($id); $this->LoadConfig($id); $this->SaveConfig($id); push @{$this->{'ORDER'}}, $id; return $id; } #------------------------------------------------------------------------------------------------------------ # # プラグイン情報削除 # ------------------------------------------------------------------------------------- # @param $id 削除プラグインID # @return なし # #------------------------------------------------------------------------------------------------------------ sub Delete { my $this = shift; my ($id) = @_; delete $this->{'FILE'}->{$id}; delete $this->{'CLASS'}->{$id}; delete $this->{'NAME'}->{$id}; delete $this->{'EXPL'}->{$id}; delete $this->{'TYPE'}->{$id}; delete $this->{'VALID'}->{$id}; delete $this->{'CONFIG'}->{$id}; delete $this->{'CONFTYPE'}->{$id}; my $order = $this->{'ORDER'}; for my $i (reverse(0 .. $#$order)) { if ($order->[$i] eq $id) { splice(@$order, $i, 1); } } } #------------------------------------------------------------------------------------------------------------ # # プラグイン情報更新 # ------------------------------------------------------------------------------------- # @param なし # @return なし # #------------------------------------------------------------------------------------------------------------ sub Update { my $this = shift; my ($plugin, $exist); my @files = (); if (opendir(my $dh, './plugin')) { @files = readdir($dh); closedir($dh); } else { $this->{'FILE'} = {}; $this->{'CLASS'} = {}; $this->{'NAME'} = {}; $this->{'EXPL'} = {}; $this->{'TYPE'} = {}; $this->{'VALID'} = {}; $this->{'CONFIG'} = {}; $this->{'CONFTYPE'} = {}; $this->{'ORDER'} = []; return; } # プラグイン追加・更新フェイズ foreach my $file (@files) { if ($file =~ /^0ch_(.*)\.pl/) { my $className = "ZPL_$1"; my @keySet = (); if (scalar $this->GetKeySet('FILE', $file, \@keySet) > 0) { my $id = $keySet[0]; require "./plugin/$file"; my $plugin = $className->new; $this->{'NAME'}->{$id} = $plugin->getName; $this->{'EXPL'}->{$id} = $plugin->getExplanation; $this->{'TYPE'}->{$id} = $plugin->getType; $this->SetDefaultConfig($id); $this->LoadConfig($id); $this->SaveConfig($id); } else { $this->Add($file, 0); } } } # プラグイン削除フェイズ my @keySet = (); if ($this->GetKeySet('ALL', '', \@keySet) > 0) { foreach my $id (@keySet) { my $exist = 0; foreach my $file (@files) { if ($this->Get('FILE', $id) eq $file) { $exist = 1; last; } } if ($exist == 0) { $this->Delete($id); } } } } #============================================================================================================ # # プラグイン個別設定管理モジュール # #============================================================================================================ package PLUGINCONF; #------------------------------------------------------------------------------------------------------------ # # コンストラクタ # ------------------------------------------------------------------------------------- # @param $Plugin ATHELAS # @param $id # @return モジュールオブジェクト # #------------------------------------------------------------------------------------------------------------ sub new { my $class = shift; my ($Plugin, $id) = @_; my $obj = { 'PLUGIN' => $Plugin, 'id' => $id }; bless $obj, $class; return $obj; } #------------------------------------------------------------------------------------------------------------ # # プラグイン個別設定設定 # ------------------------------------------------------------------------------------- # @param $key # @param $val # @return なし # #------------------------------------------------------------------------------------------------------------ sub SetConfig { my $this = shift; my ($key, $val) = @_; my $id = $this->{'id'}; my $Plugin = $this->{'PLUGIN'}; my $config = $Plugin->{'CONFIG'}->{$id}; my $conftype = $Plugin->{'CONFTYPE'}->{$id}; my $type = 0; if (defined $conftype->{$key}) { $type = $conftype->{$key}; } else { if (ref(\$val) eq 'SCALAR') { $type = 2; } else { $type = 0; return; } $conftype->{$key} = $type; } if ($type == 1) { $val -= 0; } elsif ($type == 2) { $val =~ s/\r\n|[\r\n]/
/g; $val =~ s/<>/<>/g; } elsif ($type == 3) { $val = ($val ? 1 : 0); } $config->{$key} = $val; $Plugin->SaveConfig($id); } #------------------------------------------------------------------------------------------------------------ # # プラグイン個別設定取得 # ------------------------------------------------------------------------------------- # @param $key # @return プラグイン個別設定 # #------------------------------------------------------------------------------------------------------------ sub GetConfig { my $this = shift; my ($key) = @_; my $id = $this->{'id'}; my $config = $this->{'PLUGIN'}->{'CONFIG'}->{$id}; return $config->{$key}; } #============================================================================================================ # Module END #============================================================================================================ 1; zerochplus_0.7.5/test/module/varda.pl 0000644 0000000 0000000 00000051647 14216364775 014623 0 ustar #============================================================================================================ # # bbs.cgi支援モジュール # #============================================================================================================ package VARDA; use strict; #use warnings; #------------------------------------------------------------------------------------------------------------ # # コンストラクタ # ------------------------------------------------------------------------------------- # @param なし # @return モジュールオブジェクト # #------------------------------------------------------------------------------------------------------------ sub new { my $class = shift; my $obj = { 'SYS' => undef, 'SET' => undef, 'THREADS' => undef, 'CONV' => undef, 'BANNER' => undef, 'CODE' => undef, }; bless $obj, $class; return $obj; } #------------------------------------------------------------------------------------------------------------ # # 初期化 # ------------------------------------------------------------------------------------- # @param $Sys MELKOR # @param $Setting ISILDUR # @return なし # #------------------------------------------------------------------------------------------------------------ sub Init { my $this = shift; my ($Sys, $Setting) = @_; require './module/baggins.pl'; require './module/galadriel.pl'; require './module/denethor.pl'; # 使用モジュールを設定 $this->{'SYS'} = $Sys; $this->{'THREADS'} = BILBO->new; $this->{'CONV'} = GALADRIEL->new; $this->{'BANNER'} = DENETHOR->new; $this->{'CODE'} = 'sjis'; if (!defined $Setting) { require './module/isildur.pl'; $this->{'SET'} = ISILDUR->new; $this->{'SET'}->Load($Sys); } else { $this->{'SET'} = $Setting; } # 情報の読み込み $this->{'THREADS'}->Load($Sys); $this->{'BANNER'}->Load($Sys); } #------------------------------------------------------------------------------------------------------------ # # index.html生成 # ------------------------------------------------------------------------------------- # @param なし # @return 生成されたら1を返す # #------------------------------------------------------------------------------------------------------------ sub CreateIndex { my $this = shift; my $Sys = $this->{'SYS'}; my $Threads = $this->{'THREADS'}; my $bbsSetting = $this->{'SET'}; # CREATEモード、またはスレッドがindex表示範囲内の場合のみindexを更新する if ($Sys->Equal('MODE', 'CREATE') || ($Threads->GetPosition($Sys->Get('KEY')) < $bbsSetting->Get('BBS_MAX_MENU_THREAD'))) { require './module/thorin.pl'; require './module/legolas.pl'; my $Index = THORIN->new; my $Caption = LEGOLAS->new; PrintIndexHead($this, $Index, $Caption); PrintIndexMenu($this, $Index); PrintIndexPreview($this, $Index); PrintIndexFoot($this, $Index, $Caption); my $path = $Sys->Get('BBSPATH') . '/' . $Sys->Get('BBS') . '/index.html'; $Index->Flush(1, $Sys->Get('PM-TXT'), $path); return 1; } return 0; } #------------------------------------------------------------------------------------------------------------ # # i/index.html生成 # ------------------------------------------------------------------------------------- # @param なし # @return なし # #------------------------------------------------------------------------------------------------------------ sub CreateIIndex { my $this = shift; require './module/thorin.pl'; my $Page = THORIN->new; # 前準備 my $Sys = $this->{'SYS'}; my $Threads = $this->{'THREADS'}; my $Set = $this->{'SET'}; my $Conv = $this->{'CONV'}; my $bbs = $Sys->Get('BBS'); # HTMLヘッダの出力 my $title = $Set->Get('BBS_TITLE'); my $code = $this->{'CODE'}; $Page->Print("
\n"); } # フッタ部分の出力 my $cgiPath = $Sys->Get('CGIPATH'); my $pathf = "$cgiPath/p.cgi" . ($Sys->Get('PATHKIND') ? "?bbs=$bbs&st=$i" : "/$bbs/$i"); $Page->Print("
"); $Page->Print("続き\n"); $Page->Print("
\n"); # i/index.htmlに書き込み my $pathi = $Sys->Get('BBSPATH') . "/$bbs"; $Page->Flush(1, $Sys->Get('PM-TXT'), "$pathi/i/index.html"); } #------------------------------------------------------------------------------------------------------------ # # subback.html生成 # ------------------------------------------------------------------------------------- # @param なし # @return なし # #------------------------------------------------------------------------------------------------------------ sub CreateSubback { my $this = shift; require './module/thorin.pl'; my $Page = THORIN->new; my $Sys = $this->{'SYS'}; my $Threads = $this->{'THREADS'}; my $Set = $this->{'SET'}; my $Conv = $this->{'CONV'}; require './module/legolas.pl'; my $Caption = LEGOLAS->new; $Caption->Load($Sys, 'META'); # HTMLヘッダの出力 my $title = $Set->Get('BBS_TITLE'); my $code = $this->{'CODE'}; $Page->Print(<
");
$Page->Print("\n");
# 全スレッドを取得
my @threadSet = ();
$Threads->GetKeySet('ALL', '', \@threadSet);
# スレッド分だけループをまわす
my $bbs = $Sys->Get('BBS');
my $max = $Sys->Get('SUBMAX');
my $i = 0;
foreach my $key (@threadSet) {
last if (++$i > $max);
my $name = $Threads->Get('SUBJECT', $key);
my $res = $Threads->Get('RES', $key);
my $path = $Conv->CreatePath($Sys, 0, $bbs, $key, 'l50');
$Page->Print("$i: $name($res) \n");
}
# フッタ部分の出力
my $cgipath = $Sys->Get('CGIPATH');
my $version = $Sys->Get('VERSION');
$Page->Print(<
$version
HTML
# subback.htmlに書き込み
my $paths = $Sys->Get('BBSPATH') . "/$bbs";
$Page->Flush(1, $Sys->Get('PM-TXT'), "$paths/subback.html");
}
#------------------------------------------------------------------------------------------------------------
#
# index.html生成(ヘッダ部分)
# -------------------------------------------------------------------------------------
# @param $Page
# @param $Caption
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintIndexHead
{
my $this = shift;
my ($Page, $Caption) = @_;
$Caption->Load($this->{'SYS'}, 'META');
my $title = $this->{'SET'}->Get('BBS_TITLE');
my $link = $this->{'SET'}->Get('BBS_TITLE_LINK');
my $image = $this->{'SET'}->Get('BBS_TITLE_PICTURE');
# my $code = $this->{'CODE'};
# HTMLヘッダの出力
$Page->Print(<");
# 看板画像からのリンクあり
if ($link ne '') {
$Page->Print("");
}
# 看板画像にリンクはなし
else {
$Page->Print("");
}
$Page->Print("
\n");
}
# ヘッダテーブルの表示
$Caption->Load($this->{'SYS'}, 'HEAD');
$Caption->Print($Page, $this->{'SET'});
}
#------------------------------------------------------------------------------------------------------------
#
# index.html生成(スレッドメニュー部分)
# -------------------------------------------------------------------------------------
# @param $Page
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintIndexMenu
{
my $this = shift;
my ($Page) = @_;
my $Conv = $this->{'CONV'};
my $menuCol = $this->{'SET'}->Get('BBS_MENU_COLOR');
# バナーの表示
$this->{'BANNER'}->Print($Page, 95, 0, 0) if ($this->{'SYS'}->Get('BANNER') & 3);
$Page->Print(<|
MENU
my @threadSet = ();
$this->{'THREADS'}->GetKeySet('ALL', '', \@threadSet);
# スレッド分だけループをまわす
my $prevNum = $this->{'SET'}->Get('BBS_THREAD_NUMBER');
my $menuNum = $this->{'SET'}->Get('BBS_MAX_MENU_THREAD');
my $max = $this->{'SYS'}->Get('SUBMAX');
my $i = 0;
foreach my $key (@threadSet) {
last if ((++$i > $menuNum) || ($i > $max));
my $name = $this->{'THREADS'}->Get('SUBJECT', $key);
my $res = $this->{'THREADS'}->Get('RES', $key);
my $path = $Conv->CreatePath($this->{'SYS'}, 0, $this->{'SYS'}->Get('BBS'), $key, 'l50');
# プレビュースレッドの場合はプレビューへのリンクを貼る
if ($i <= $prevNum) {
$Page->Print(" $i: ");
$Page->Print("$name($res) \n");
}
else {
$Page->Print(" $i: $name($res) \n");
}
}
$Page->Print(< |
【$cnt:$res】$subject
-
THREAD
# プレビューの表示
my $datPath = "$basePath/dat/$key.dat";
$Dat->Load($this->{'SYS'}, $datPath, 1);
$this->{'SYS'}->Set('KEY', $key);
PrintThreadPreviewOne($this, $Page, $Dat, \@commands);
$Dat->Close();
# フッタ部分の表示
my $allPath = $Conv->CreatePath($this->{'SYS'}, 0, $this->{'SYS'}->Get('BBS'), $key, '');
my $lastPath = $Conv->CreatePath($this->{'SYS'}, 0, $this->{'SYS'}->Get('BBS'), $key, 'l50');
my $numPath = $Conv->CreatePath($this->{'SYS'}, 0, $this->{'SYS'}->Get('BBS'), $key, '1-100');
$Page->Print(<
| |
タイトル： 名前： E-mail： 内容： |
ページのおしまいだよ。。と FOOT $Page->Print("\n\n"); } #------------------------------------------------------------------------------------------------------------ # # index.html生成(スレッドプレビュー部分) # ------------------------------------------------------------------------------------- # @param $Page # @param $Dat # @param $commands # @return なし # #------------------------------------------------------------------------------------------------------------ sub PrintThreadPreviewOne { my $this = shift; my ($Page, $Dat, $commands) = @_; my $Sys = $this->{'SYS'}; # 前準備 my $contNum = $this->{'SET'}->Get('BBS_CONTENTS_NUMBER'); my $cgiPath = $Sys->Get('SERVER') . $Sys->Get('CGIPATH'); my $bbs = $Sys->Get('BBS'); my $key = $Sys->Get('KEY'); my $tm = time; # 表示数の正規化 my ($start, $end) = $this->{'CONV'}->RegularDispNum($Sys, $Dat, 1, $contNum, $contNum); $start++ if ($start == 1); # 1の表示 PrintResponse($this, $Page, $Dat, $commands, 1); # 残りの表示 for (my $i = $start; $i <= $end; $i++) { PrintResponse($this, $Page, $Dat, $commands, $i); } # 書き込みフォームの表示 $Page->Print(<