"); } # 看板画像にリンクはなし 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を設定するとこの画面はでなくなります。)
あなたのリモホ[$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('
\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("$key.datはhtml化を待っています。"); $Page->Print('ここは待つしかない・・・。\n"); } # どこにもない else { return 0; } $Page->Print(<
'."\n"); $Page->Print("
|
検索＠0chPlus
|
【ヒット数：0】システムエラー
|
･転んでも泣かないzerochplus_0.7.4/test/datas/default_img.gif 0000644 0000764 0001040 00000044014 12067470216 015750 0 ustar GIF89a ｮ ･ ﾆ ﾎ ﾑ ﾗ ｿｮ! ｻｦ * , 1 0 ｲ( |: -Qv<80Tｫ1 -V+V;0Y,\ 晦･;4]1`宇F[8`K｡BB^vP卯4e5dF`唔Cc;h9h5jFf Ф~YCj 散
･出されたものは残さず食べる
･Perl使いを尊重する
V* 7@x\`)ﾐ@ f0 ﾒ私ﾞ)ひ ､ﾀyG臉ｭﾆﾀy@ﾇ轗i7; 4ﾞBPR%
紫ﾁ艱ﾐπ緇0;h` ^ｵｿｻ5ﾟﾇ ﾈ栞$仗ｷｫﾀｻ躱 4|Na<ﾞ ｫﾂoﾀ|､^ ｹ ?ｨzﾘ｢ﾖﾟﾉNﾛﾏｿﾏ ｸｦ6Xx
ｸ ﾘ88Zvｸ ﾘ "8$X#ﾈ7ｶﾚ 擒$ｼ疆 V!+A $"ﾊ#"0ﾘﾊ# %S2$｣ ;殯:ｨ!ル JfNx7恒 杳
ｮp ｷ ｺ ﾚ進(ﾘｱﾅﾐ/＝/<簷ﾌ｡(ﾊﾐG2)ﾆa*cN?%ｳ 芯? H=q4 9"(飴ﾀ C uh９2闢,寅
>! ﾏﾊs=mT2ﾂ0 ｰ VX0廡HIﾀ｡$窿睡Xﾄ}<&$+ @kpp己弧x経ｰ/6` 単kｰK註載ｸ剤ﾘ剤h6廃Y`ｺ$p手守(zrﾓ 箚 ｮ0M^ｨ %C+ﾄrn )c5 be.{8}<\/b>:([0-9]+)<\/p>/ ) {
$point = BeRank($Form, $1);
}
else {
# おかしかったらみんな０ポイント
$point = '2BP(0)';
}
# 基礎BE番号取得+セット
$Form->Set('BEBASE', ID2BASE($beid) );
# BEポイントセット
$Form->Set('BEID', "BE:$beid-$point");
# アイコンとってくるよ！
if ( $be_icon && $Form->Get('MESSAGE') ne "" ) {
if ( $content =~ m|､0脳DRsFｹｱ暑ﾑ-Y`7挺 ｰJ $P貿y防y ｴ-ｰoﾐ耗 0L!h.]c災eｸR*涜
ﾔ`2ｦﾐﾆC/Dﾄ
*ｩpA
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.4/test/info/index.html 0000644 0000764 0001040 00000000015 12145672440 014626 0 ustar 403 Forbidden zerochplus_0.7.4/test/info/users.cgi 0000644 0000764 0001040 00000000130 12067470216 014454 0 ustar 0000000001<>Administrator<>431XyHmErk<>システムアドミニストレータ<>システム管理者。<>1
zerochplus_0.7.4/test/info/.session/index.html 0000644 0000764 0001040 00000000015 12145672440 016367 0 ustar 403 Forbidden zerochplus_0.7.4/test/module/athelas.pl 0000644 0000764 0001040 00000036206 12236106655 015155 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.4/test/module/baggins.pl 0000644 0000764 0001040 00000072061 12236106655 015145 0 ustar #============================================================================================================
#
# スレッド情報管理モジュール
# -------------------------------------------------------------------------------------
# このモジュールはスレッド情報を管理します。
# 以下の2つのパッケージによって構成されます
#
# BILBO : 現行スレッド情報管理
# FRODO : プールスレッド情報管理
#
#============================================================================================================
#============================================================================================================
#
# スレッド情報管理パッケージ
#
#============================================================================================================
package BILBO;
use strict;
#use warnings;
#------------------------------------------------------------------------------------------------------------
#
# コンストラクタ
# -------------------------------------------------------------------------------------
# @param なし
# @return モジュールオブジェクト
#
#------------------------------------------------------------------------------------------------------------
sub new
{
my $class = shift;
my $obj = {
'SUBJECT' => undef,
'RES' => undef,
'SORT' => undef,
'NUM' => undef,
'HANDLE' => undef,
'ATTR' => undef,
};
bless $obj, $class;
return $obj;
}
#------------------------------------------------------------------------------------------------------------
#
# デストラクタ
# -------------------------------------------------------------------------------------
# @param なし
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub DESTROY
{
my $this = shift;
my $handle = $this->{'HANDLE'};
if ($handle) {
close($handle);
}
$this->{'HANDLE'} = undef;
}
#------------------------------------------------------------------------------------------------------------
#
# オープン
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @return ファイルハンドル
#
#------------------------------------------------------------------------------------------------------------
sub Open
{
my $this = shift;
my ($Sys) = @_;
my $path = $Sys->Get('BBSPATH') . '/' .$Sys->Get('BBS') . '/subject.txt';
my $fh = undef;
if ($this->{'HANDLE'}) {
$fh = $this->{'HANDLE'};
seek($fh, 0, 0);
}
else {
chmod($Sys->Get('PM-TXT'), $path);
if (open($fh, (-f $path ? '+<' : '>'), $path)) {
flock($fh, 2);
binmode($fh);
seek($fh, 0, 0);
$this->{'HANDLE'} = $fh;
}
else {
warn "can't load subject: $path";
}
}
return $fh;
}
#------------------------------------------------------------------------------------------------------------
#
# 強制クローズ
# -------------------------------------------------------------------------------------
# @param なし
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Close
{
my $this = shift;
my $handle = $this->{'HANDLE'};
if ($handle) {
close($handle);
}
$this->{'HANDLE'} = undef;
}
#------------------------------------------------------------------------------------------------------------
#
# スレッド情報読み込み
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Load
{
my $this = shift;
my ($Sys) = @_;
$this->{'SUBJECT'} = {};
$this->{'RES'} = {};
$this->{'SORT'} = [];
my $fh = $this->Open($Sys) or return;
my @lines = <$fh>;
map { s/[\r\n]+\z// } @lines;
my $num = 0;
foreach (@lines) {
next if ($_ eq '');
if ($_ =~ /^(.+?)\.dat<>(.*?) ?\(([0-9]+)\)$/) {
$this->{'SUBJECT'}->{$1} = $2;
$this->{'RES'}->{$1} = $3;
push @{$this->{'SORT'}}, $1;
$num++;
}
else {
warn "invalid line";
next;
}
}
$this->{'NUM'} = $num;
$this->LoadAttr($Sys);
}
#------------------------------------------------------------------------------------------------------------
#
# スレッド情報保存
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Save
{
my $this = shift;
my ($Sys) = @_;
my $fh = $this->Open($Sys) or return;
my $subject = $this->{'SUBJECT'};
$this->CustomizeOrder();
foreach (@{$this->{'SORT'}}) {
next if (!defined $subject->{$_});
print $fh "$_.dat<>$subject->{$_} ($this->{'RES'}->{$_})\n";
}
truncate($fh, tell($fh));
$this->Close();
my $path = $Sys->Get('BBSPATH') . '/' .$Sys->Get('BBS') . '/subject.txt';
chmod($Sys->Get('PM-TXT'), $path);
$this->SaveAttr($Sys);
}
#------------------------------------------------------------------------------------------------------------
#
# オンデマンド式レス数更新
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @param $id スレッドID
# @param $val レス数
# @param $updown '', 'top', 'bottom', '+n', '-n'
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub OnDemand
{
my $this = shift;
my ($Sys, $id, $val, $updown) = @_;
my $subject = {};
$this->{'SUBJECT'} = $subject;
$this->{'RES'} = {};
$this->{'SORT'} = [];
my $fh = $this->Open($Sys) or return;
my @lines = <$fh>;
map { s/[\r\n]+\z// } @lines;
my $num = 0;
foreach (@lines) {
next if ($_ eq '');
if ($_ =~ /^(.+?)\.dat<>(.*?) ?\(([0-9]+)\)$/) {
$subject->{$1} = $2;
$this->{'RES'}->{$1} = $3;
push @{$this->{'SORT'}}, $1;
$num++;
}
else {
warn "invalid line";
next;
}
}
$this->{'NUM'} = $num;
# レス数更新
if (exists $this->{'RES'}->{$id}) {
$this->{'RES'}->{$id} = $val;
}
# スレッド移動
if ($updown eq 'top') {
$this->AGE($id);
} elsif ($updown eq 'bottom') {
$this->DAME($id);
} elsif ($updown =~ /^([\+\-][0-9]+)$/) {
$this->UpDown($id, int($1));
}
$this->CustomizeOrder();
# subject書き込み
seek($fh, 0, 0);
foreach (@{$this->{'SORT'}}) {
next if (!defined $subject->{$_});
print $fh "$_.dat<>$subject->{$_} ($this->{'RES'}->{$_})\n";
}
truncate($fh, tell($fh));
$this->Close();
my $path = $Sys->Get('BBSPATH') . '/' .$Sys->Get('BBS') . '/subject.txt';
chmod($Sys->Get('PM-TXT'), $path);
}
#------------------------------------------------------------------------------------------------------------
#
# スレッドIDセット取得
# -------------------------------------------------------------------------------------
# @param $kind 検索種別('ALL'の場合すべて)
# @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->{'SORT'}};
}
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 $id スレッドID
# @param $subject スレッドタイトル
# @param $res レス
# @return スレッドID
#
#------------------------------------------------------------------------------------------------------------
sub Add
{
my $this = shift;
my ($id, $subject, $res) = @_;
$this->{'SUBJECT'}->{$id} = $subject;
$this->{'RES'}->{$id} = $res;
unshift @{$this->{'SORT'}}, $id;
$this->{'NUM'}++;
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->{'SUBJECT'}->{$id};
delete $this->{'RES'}->{$id};
# for pool
#delete $this->{'ATTR'}->{$id};
my $sort = $this->{'SORT'};
for (my $i = 0; $i < scalar(@$sort); $i++) {
if ($id eq $sort->[$i]) {
splice @$sort, $i, 1;
$this->{'NUM'}--;
last;
}
}
}
#------------------------------------------------------------------------------------------------------------
#
# スレッド属性情報読み込み
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub LoadAttr
{
my $this = shift;
my ($Sys) = @_;
$this->{'ATTR'} = {};
my $path = $Sys->Get('BBSPATH') . '/' .$Sys->Get('BBS') . '/info/attr.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) < 2) {
warn "invalid line in $path";
next;
}
my $id = $elem[0];
# for pool, don't skip
#next if (!defined $this->{'SUBJECT'}->{$id});
my $hash = {};
foreach (split /[&;]/, $elem[1]) {
my ($key, $val) = split(/=/, $_, 2);
$key =~ tr/+/ /;
$key =~ s/%([0-9a-f][0-9a-f])/pack('C', hex($1))/egi;
$val =~ tr/+/ /;
$val =~ s/%([0-9a-f][0-9a-f])/pack('C', hex($1))/egi;
$hash->{$key} = $val if ($val ne '');
}
$this->{'ATTR'}->{$id} = $hash;
}
}
}
#------------------------------------------------------------------------------------------------------------
#
# スレッド属性情報保存
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub SaveAttr
{
my $this = shift;
my ($Sys) = @_;
my $path = $Sys->Get('BBSPATH') . '/' .$Sys->Get('BBS') . '/info/attr.cgi';
chmod($Sys->Get('PM-ADM'), $path);
if (open(my $fh, (-f $path ? '+<' : '>'), $path)) {
flock($fh, 2);
binmode($fh);
seek($fh, 0, 0);
my $Attr = $this->{'ATTR'};
foreach my $id (keys %$Attr) {
my $hash = $Attr->{$id};
next if (!defined $hash);
my $attrs = '';
while (my ($key, $val) = each %$hash) {
next if (!defined $val || $val eq '');
$key =~ s/([^\w])/'%'.unpack('H2', $1)/eg;
$val =~ s/([^\w])/'%'.unpack('H2', $1)/eg;
$attrs .= "$key=$val&";
}
next if ($attrs eq '');
my $data = join('<>',
$id,
$attrs,
);
print $fh "$data\n";
}
truncate($fh, tell($fh));
close($fh);
}
chmod($Sys->Get('PM-ADM'), $path);
}
#------------------------------------------------------------------------------------------------------------
#
# スレッド属性情報取得
# -------------------------------------------------------------------------------------
# @param $key スレッドID
# @param $attr 属性名
# @return スレッド属性情報
#
#------------------------------------------------------------------------------------------------------------
sub GetAttr
{
my $this = shift;
my ($key, $attr) = @_;
if (!defined $this->{'ATTR'}) {
warn "Attr info is not loaded.";
return;
}
my $Attr = $this->{'ATTR'};
my $val = undef;
$val = $Attr->{$key}->{$attr} if (defined $Attr->{$key});
# undef => empty string
return (defined $val ? $val : '');
}
#------------------------------------------------------------------------------------------------------------
#
# スレッド属性情報設定
# -------------------------------------------------------------------------------------
# @param $key スレッドID
# @param $attr 属性名
# @param $val 属性値
#
#------------------------------------------------------------------------------------------------------------
sub SetAttr
{
my $this = shift;
my ($key, $attr, $val) = @_;
if (!defined $this->{'ATTR'}) {
warn "Attr info is not loaded.";
return;
}
my $Attr = $this->{'ATTR'};
$Attr->{$key} = {} if (!defined $Attr->{$key});
$Attr->{$key}->{$attr} = $val;
}
#------------------------------------------------------------------------------------------------------------
#
# スレッド属性情報削除
# -------------------------------------------------------------------------------------
# @param $key スレッドID
#
#------------------------------------------------------------------------------------------------------------
sub DeleteAttr
{
my $this = shift;
my ($key) = @_;
if (!defined $this->{'ATTR'}) {
warn "Attr info is not loaded.";
return;
}
my $Attr = $this->{'ATTR'};
delete $Attr->{$key};
}
#------------------------------------------------------------------------------------------------------------
#
# スレッド数取得
# -------------------------------------------------------------------------------------
# @param なし
# @return スレッド数
#
#------------------------------------------------------------------------------------------------------------
sub GetNum
{
my $this = shift;
return $this->{'NUM'};
}
#------------------------------------------------------------------------------------------------------------
#
# 最後のスレッドID取得
# -------------------------------------------------------------------------------------
# @param なし
# @return スレッドID
#
#------------------------------------------------------------------------------------------------------------
sub GetLastID
{
my $this = shift;
my $sort = $this->{'SORT'};
return $sort->[$#$sort];
}
#------------------------------------------------------------------------------------------------------------
#
# スレッド順調整
# -------------------------------------------------------------------------------------
# @param なし
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub CustomizeOrder
{
my $this = shift;
my @float = ();
my @sort = ();
foreach my $id (@{$this->{'SORT'}}) {
if ($this->GetAttr($id, 'float')) {
push @float, $id;
} else {
push @sort, $id;
}
}
$this->{'SORT'} = [@float, @sort];
}
#------------------------------------------------------------------------------------------------------------
#
# スレッドあげ
# -------------------------------------------------------------------------------------
# @param スレッドID
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub AGE
{
my $this = shift;
my ($id) = @_;
my $sort = $this->{'SORT'};
for (my $i = 0; $i < scalar(@$sort); $i++) {
if ($id eq $sort->[$i]) {
splice @$sort, $i, 1;
unshift @$sort, $id;
last;
}
}
}
#------------------------------------------------------------------------------------------------------------
#
# スレッドだめ
# -------------------------------------------------------------------------------------
# @param スレッドID
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub DAME
{
my $this = shift;
my ($id) = @_;
my $sort = $this->{'SORT'};
for (my $i = 0; $i < scalar(@$sort); $i++) {
if ($id eq $sort->[$i]) {
splice @$sort, $i, 1;
push @$sort, $id;
last;
}
}
}
#------------------------------------------------------------------------------------------------------------
#
# スレッド移動
# -------------------------------------------------------------------------------------
# @param $id スレッドID
# @param $n 移動数(+上げ -下げ)
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub UpDown
{
my $this = shift;
my ($id, $n) = @_;
my $sort = $this->{'SORT'};
my $max = scalar(@$sort);
for (my $i = 0; $i < $max; $i++) {
if ($id eq $sort->[$i]) {
my $to = $i - $n;
$to = 0 if ($to < 0);
$to = $max-1 if ($to > $max-1);
splice @$sort, $i, 1;
splice @$sort, $to, 0, $id;
last;
}
}
}
#------------------------------------------------------------------------------------------------------------
#
# スレッド情報更新
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Update
{
my $this = shift;
my ($Sys) = @_;
my $base = $Sys->Get('BBSPATH') . '/' . $Sys->Get('BBS') . '/dat';
$this->CustomizeOrder();
foreach my $id (@{$this->{'SORT'}}) {
if (open(my $fh, '<', "$base/$id.dat")) {
flock($fh, 2);
my $n = 0;
$n++ while (<$fh>);
close($fh);
$this->{'RES'}->{$id} = $n;
}
else {
warn "can't open file: $base/$id.dat";
}
}
}
#------------------------------------------------------------------------------------------------------------
#
# スレッド情報完全更新
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub UpdateAll
{
my $this = shift;
my ($Sys) = @_;
my $psort = $this->{'SORT'};
$this->{'SORT'} = [];
$this->{'SUBJECT'} = {};
$this->{'RES'} = {};
my $idhash = {};
my @dirSet = ();
my $base = $Sys->Get('BBSPATH') . '/' . $Sys->Get('BBS') . '/dat';
my $num = 0;
# ディレクトリ内一覧を取得
if (opendir(my $fh, $base)) {
@dirSet = readdir($fh);
closedir($fh);
}
else {
warn "can't open dir: $base";
return;
}
foreach my $el (@dirSet) {
if ($el =~ /^(.*)\.dat$/ && open(my $fh, '<', "$base/$el")) {
flock($fh, 2);
my $id = $1;
my $n = 1;
my $first = <$fh>;
$n++ while (<$fh>);
close($fh);
$first =~ s/[\r\n]+\z//;
my @elem = split(/<>/, $first, -1);
$this->{'SUBJECT'}->{$id} = $elem[4];
$this->{'RES'}->{$id} = $n;
$idhash->{$id} = 1;
$num++;
}
}
$this->{'NUM'} = $num;
foreach my $id (@$psort) {
if (defined $idhash->{$id}) {
push @{$this->{'SORT'}}, $id;
delete $idhash->{$id};
}
}
foreach my $id (sort keys %$idhash) {
unshift @{$this->{'SORT'}}, $id;
}
$this->CustomizeOrder();
}
#------------------------------------------------------------------------------------------------------------
#
# スレッド位置取得
# -------------------------------------------------------------------------------------
# @param $id スレッドID
# @return スレッド位置。取得できない場合は-1
#
#------------------------------------------------------------------------------------------------------------
sub GetPosition
{
my $this = shift;
my ($id) = @_;
my $sort = $this->{'SORT'};
for (my $i = 0; $i < scalar(@$sort); $i++) {
if ($id eq $sort->[$i]) {
return $i;
}
}
return -1;
}
#============================================================================================================
#
# プールスレッド情報管理パッケージ
#
#============================================================================================================
package FRODO;
use strict;
#use warnings;
#------------------------------------------------------------------------------------------------------------
#
# コンストラクタ
# -------------------------------------------------------------------------------------
# @param なし
# @return モジュールオブジェクト
#
#------------------------------------------------------------------------------------------------------------
sub new
{
my $class = shift;
my $obj = {
'SUBJECT' => undef,
'RES' => undef,
'SORT' => undef,
'NUM' => undef,
'ATTR' => undef,
};
bless $obj, $class;
return $obj;
}
#------------------------------------------------------------------------------------------------------------
#
# スレッド情報読み込み
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Load
{
my $this = shift;
my ($Sys) = @_;
$this->{'SUBJECT'} = {};
$this->{'RES'} = {};
$this->{'SORT'} = [];
my $path = $Sys->Get('BBSPATH') . '/' .$Sys->Get('BBS') . '/pool/subject.cgi';
if (open(my $fh, '<', $path)) {
flock($fh, 2);
my @lines = <$fh>;
close($fh);
map { s/[\r\n]+\z// } @lines;
my $num = 0;
for (@lines) {
next if ($_ eq '');
if ($_ =~ /^(.+?)\.dat<>(.*?) ?\(([0-9]+)\)$/) {
$this->{'SUBJECT'}->{$1} = $2;
$this->{'RES'}->{$1} = $3;
push @{$this->{'SORT'}}, $1;
$num++;
}
else {
warn "invalid line in $path";
next;
}
}
$this->{'NUM'} = $num;
}
$this->LoadAttr($Sys);
}
#------------------------------------------------------------------------------------------------------------
#
# スレッド情報保存
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Save
{
my $this = shift;
my ($Sys) = @_;
my $path = $Sys->Get('BBSPATH') . '/' .$Sys->Get('BBS') . '/pool/subject.cgi';
chmod($Sys->Get('PM-ADM'), $path);
if (open(my $fh, (-f $path ? '+<' : '>'), $path)) {
flock($fh, 2);
seek($fh, 0, 0);
binmode($fh);
my $subject = $this->{'SUBJECT'};
foreach (@{$this->{'SORT'}}) {
next if (!defined $subject->{$_});
print $fh "$_.dat<>$subject->{$_} ($this->{'RES'}->{$_})\n";
}
truncate($fh, tell($fh));
close($fh);
}
else {
warn "can't save subject: $path";
}
chmod($Sys->Get('PM-ADM'), $path);
$this->SaveAttr($Sys);
}
#------------------------------------------------------------------------------------------------------------
#
# スレッドIDセット取得
# -------------------------------------------------------------------------------------
# @param $kind 検索種別('ALL'の場合すべて)
# @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->{'SORT'}};
}
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 $id スレッドID
# @param $subject スレッドタイトル
# @param $res レス
# @return スレッドID
#
#------------------------------------------------------------------------------------------------------------
sub Add
{
my $this = shift;
my ($id, $subject, $res) = @_;
$this->{'SUBJECT'}->{$id} = $subject;
$this->{'RES'}->{$id} = $res;
unshift @{$this->{'SORT'}}, $id;
$this->{'NUM'}++;
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->{'SUBJECT'}->{$id};
delete $this->{'RES'}->{$id};
my $sort = $this->{'SORT'};
for (my $i = 0; $i < scalar(@$sort); $i++) {
if ($id eq $sort->[$i]) {
splice @$sort, $i, 1;
$this->{'NUM'}--;
last;
}
}
}
#------------------------------------------------------------------------------------------------------------
#
# スレッド数取得
# -------------------------------------------------------------------------------------
# @param なし
# @return スレッド数
#
#------------------------------------------------------------------------------------------------------------
sub GetNum
{
my $this = shift;
return $this->{'NUM'};
}
#------------------------------------------------------------------------------------------------------------
#
# スレッド属性情報関連
#
#------------------------------------------------------------------------------------------------------------
sub LoadAttr
{
return BILBO::LoadAttr(@_);
}
sub SaveAttr
{
return BILBO::SaveAttr(@_);
}
sub GetAttr
{
return BILBO::GetAttr(@_);
}
sub SetAttr
{
return BILBO::SetAttr(@_);
}
sub DeleteAttr
{
return BILBO::DeleteAttr(@_);
}
#------------------------------------------------------------------------------------------------------------
#
# スレッド情報更新
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Update
{
my $this = shift;
my ($Sys) = @_;
my ($id, $base, $n);
$base = $Sys->Get('BBSPATH') . '/' . $Sys->Get('BBS') . '/pool';
foreach my $id (@{$this->{'SORT'}}) {
if (open(my $fh, '<', "$base/$id.cgi")) {
flock($fh, 2);
my $n = 0;
$n++ while (<$fh>);
close($fh);
$this->{'RES'}->{$id} = $n;
}
else {
warn "can't open file: $base/$id.dat";
}
}
}
#------------------------------------------------------------------------------------------------------------
#
# スレッド情報完全更新
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub UpdateAll
{
my $this = shift;
my ($Sys) = @_;
$this->{'SORT'} = [];
$this->{'SUBJECT'} = {};
$this->{'RES'} = {};
my @dirSet = ();
my $base = $Sys->Get('BBSPATH') . '/' . $Sys->Get('BBS') . '/pool';
my $num = 0;
# ディレクトリ内一覧を取得
if (opendir(my $fh, $base)) {
@dirSet = readdir($fh);
closedir($fh);
}
else {
warn "can't open dir: $base";
return;
}
foreach my $el (@dirSet) {
if ($el =~ /^(.*)\.cgi$/ && open(my $fh, '<', "$base/$el")) {
flock($fh, 2);
my $id = $1;
my $n = 1;
my $first = <$fh>;
$n++ while (<$fh>);
close($fh);
$first =~ s/[\r\n]+\z//;
my @elem = split(/<>/, $first, -1);
$this->{'SUBJECT'}->{$id} = $elem[4];
$this->{'RES'}->{$id} = $n;
push @{$this->{'SORT'}}, $id;
$num++;
}
}
$this->{'NUM'} = $num;
}
#============================================================================================================
# Module END
#============================================================================================================
1;
zerochplus_0.7.4/test/module/balrogs.pl 0000644 0000764 0001040 00000013366 12236106655 015167 0 ustar #============================================================================================================
#
# 検索モジュール(BALROGS)
#
#============================================================================================================
package BALROGS;
use strict;
#use warnings;
#------------------------------------------------------------------------------------------------------------
#
# コンストラクタ
# -------------------------------------------------------------------------------------
# @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'};
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 @elem = split(/<>/, $$pDat, -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);
push @$pResultSet, $SetStr;
}
}
}
$ARAGORN->Close();
}
#============================================================================================================
# Module END
#============================================================================================================
1;
zerochplus_0.7.4/test/module/celeborn.pl 0000644 0000764 0001040 00000031166 12236106655 015325 0 ustar #============================================================================================================
#
# 過去ログ管理モジュール
#
#============================================================================================================
package CELEBORN;
use strict;
#use warnings;
#------------------------------------------------------------------------------------------------------------
#
# コンストラクタ
# -------------------------------------------------------------------------------------
# @param なし
# @return モジュールオブジェクト
#
#------------------------------------------------------------------------------------------------------------
sub new
{
my $class = shift;
my $obj = {
'KEY' => undef,
'SUBJECT' => undef,
'DATE' => undef,
'PATH' => undef
};
bless $obj, $class;
return $obj;
}
#------------------------------------------------------------------------------------------------------------
#
# 過去ログ情報ファイル読み込み
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @return エラー番号
#
#------------------------------------------------------------------------------------------------------------
sub Load
{
my $this = shift;
my ($Sys) = @_;
$this->{'KEY'} = {};
$this->{'SUBJECT'} = {};
$this->{'DATE'} = {};
$this->{'PATH'} = {};
my $path = $Sys->Get('BBSPATH') . '/' . $Sys->Get('BBS') . '/kako/kako.idx';
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(/<>/, $_);
if (scalar(@elem) < 5) {
warn "invalid line in $path";
next;
}
my $id = $elem[0];
$this->{'KEY'}->{$id} = $elem[1];
$this->{'SUBJECT'}->{$id} = $elem[2];
$this->{'DATE'}->{$id} = $elem[3];
$this->{'PATH'}->{$id} = $elem[4];
}
return 0;
}
return -1;
}
#------------------------------------------------------------------------------------------------------------
#
# 過去ログ情報ファイル書き込み
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Save
{
my $this = shift;
my ($Sys) = @_;
my $path = $Sys->Get('BBSPATH') . '/' . $Sys->Get('BBS') . '/kako/kako.idx';
chmod($Sys->Get('PM-DAT'), $path);
if (open(my $fh, (-f $path ? '+<' : '>'), $path)) {
flock($fh, 2);
seek($fh, 0, 0);
binmode($fh);
foreach (keys %{$this->{'KEY'}}) {
my $data = join('<>',
$_,
$this->{'KEY'}->{$_},
$this->{'SUBJECT'}->{$_},
$this->{'DATE'}->{$_},
$this->{'PATH'}->{$_}
);
print $fh "$data\n";
}
truncate($fh, tell($fh));
close($fh);
}
else {
warn "can't save subject: $path";
}
chmod($Sys->Get('PM-DAT'), $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') {
foreach my $key (keys %{$this->{'KEY'}}) {
if ($this->{'KEY'}->{$key} ne '0') {
$n += push @$pBuf, $key;
}
}
}
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 $key スレッドキー
# @param $subject スレッドタイトル
# @param $date 更新日時
# @param $path パス
# @return ID
#
#------------------------------------------------------------------------------------------------------------
sub Add
{
my $this = shift;
my ($key, $subject, $date, $path) = @_;
my $id = time;
$id++ while (exists $this->{'KEY'}->{$id});
$this->{'KEY'}->{$id} = $key;
$this->{'SUBJECT'}->{$id} = $subject;
$this->{'DATE'}->{$id} = $date;
$this->{'PATH'}->{$id} = $path;
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->{'KEY'}->{$id};
delete $this->{'SUBJECT'}->{$id};
delete $this->{'DATE'}->{$id};
delete $this->{'PATH'}->{$id};
}
#------------------------------------------------------------------------------------------------------------
#
# 過去ログ情報の更新
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub UpdateInfo
{
my $this = shift;
my ($Sys) = @_;
require './module/earendil.pl';
$this->{'KEY'} = {};
$this->{'SUBJECT'} = {};
$this->{'DATE'} = {};
$this->{'PATH'} = {};
my $path = $Sys->Get('BBSPATH') . '/' . $Sys->Get('BBS') . '/kako';
# ディレクトリ情報を取得
my $hierarchy = {};
my @dirList = ();
EARENDIL::GetFolderHierarchy($path, $hierarchy);
EARENDIL::GetFolderList($hierarchy, \@dirList, '');
foreach my $dir (@dirList) {
my @fileList = ();
EARENDIL::GetFileList("$path/$dir", \@fileList, '([0-9]+)\.html');
$this->Add(0, 0, 0, $dir);
foreach my $file (sort @fileList) {
my @elem = split(/\./, $file);
my $subj = GetThreadSubject("$path/$dir/$file");
if (defined $subj) {
$this->Add($elem[0], $subj, time, $dir);
}
}
}
}
#------------------------------------------------------------------------------------------------------------
#
# 過去ログindexの更新
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @param $Page
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub UpdateIndex
{
my $this = shift;
my ($Sys, $Page) = @_;
# 告知情報読み込み
require './module/denethor.pl';
my $Banner = DENETHOR->new;
$Banner->Load($Sys);
my $basePath = $Sys->Get('BBSPATH') . '/' . $Sys->Get('BBS');
# パスをキーにしてハッシュを作成
my %PATHES = ();
foreach my $id (keys %{$this->{'KEY'}}) {
my $path = $this->{'PATH'}->{$id};
$PATHES{$path} = $id;
}
my @dirs = keys %PATHES;
unshift @dirs, '';
# パスごとにindexを生成する
foreach my $path (@dirs) {
my @info = ();
# 1階層下のサブフォルダを取得する
my @folderList = ();
GetSubFolders($path, \@dirs, \@folderList);
foreach my $dir (sort @folderList) {
push @info, "0<>0<>0<>$dir";
}
# ログデータがあれば情報配列に追加する
foreach my $id (keys %{$this->{'KEY'}}) {
if ($path eq $this->{'PATH'}->{$id} && $this->{'KEY'}->{$id} ne '0') {
my $data = join('<>',
$this->{'KEY'}->{$id},
$this->{'SUBJECT'}->{$id},
$this->{'DATE'}->{$id},
$path
);
push @info, "$data";
}
}
# indexファイルを出力する
$Page->Clear();
OutputIndex($Sys, $Page, $Banner, \@info, $basePath, $path);
chmod($Sys->Get('PM-KDIR'), "$basePath/kako$path");
}
}
#------------------------------------------------------------------------------------------------------------
#
# サブフォルダを取得する
# -------------------------------------------------------------------------------------
# @param $base 親フォルダパス
# @param $pDirs ディレクトリ名の配列
# @param $pList サブフォルダ格納配列
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub GetSubFolders
{
my ($base, $pDirs, $pList) = @_;
# foreach my $dir とすると$pDirが破壊される
foreach (@$pDirs) {
my $dir = $_;
if ($dir =~ s|^\Q$base/\E|| && $dir !~ m|/|) {
push @$pList, $dir;
}
}
}
#------------------------------------------------------------------------------------------------------------
#
# 過去ログタイトルの取得
# -------------------------------------------------------------------------------------
# @param $path 取得するファイルのパス
# @return タイトル
#
#------------------------------------------------------------------------------------------------------------
sub GetThreadSubject
{
my ($path) = @_;
my $title = undef;
if (open(my $fh, '<', $path)) {
flock($fh, 2);
my @lines = <$fh>;
close($fh);
foreach (@lines) {
if ($_ =~ m|$board
\n\n
HTML
foreach (@$pInfo) {
my @elem = split(/<>/, $_, -1);
# サブフォルダ情報
if ($elem[0] eq '0') {
$Page->Print(" KEY
subject
date
\n \n");
}
# 過去ログ情報
else {
$Page->Print(" Directory \n ");
$Page->Print("$elem[3] \n - \n \n \n");
}
}
$Page->Print("$elem[0] \n ");
$Page->Print("$elem[1] \n $elem[2] \n
\n");
$Page->Print(<
$version
HTML
# index.htmlを出力する
$Page->Flush(1, 0666, "$base/kako$path/index.html");
}
#============================================================================================================
# モジュール終端
#============================================================================================================
1;
zerochplus_0.7.4/test/module/cidr_list.pl 0000644 0000764 0001040 00000025340 12236106655 015505 0 ustar #============================================================================================================
#
# 携帯IPのCIDRチェック
#
# by ぜろちゃんねるプラス
# http://zerochplus.sourceforge.jp/
#
#============================================================================================================
package ZP_CIDR;
use strict;
##use warnings;
our $cidr = ();
#------------------------------------------------------------------------------------------------------------
#
# CIDRリスト
# -------------------------------------------------------------------------------------
# ただ我武者羅に資料を集めて配列化しただけ
# どう使うかはあなた次第だ
#
#------------------------------------------------------------------------------------------------------------
{
# NTT docomo : iモード [ docomo.ne.jp ]
$cidr->{'docomo'} = [
# http://www.nttdocomo.co.jp/service/developer/make/content/ip/
# 2011/05更新 2013/10/12確認
'210.153.84.0/24', '210.136.161.0/24', '210.153.86.0/24', '124.146.174.0/24',
'124.146.175.0/24', '202.229.176.0/24', '202.229.177.0/24', '202.229.178.0/24',
];
# NTT docomo : iモードフルブラウザ
$cidr->{'docomo_pc'} = [
# http://www.nttdocomo.co.jp/service/developer/make/content/ip/
# 2011/05更新 2013/10/12確認
'210.153.87.0/24',
];
# NTT docomo : spモード(スマートフォン)
$cidr->{'docomo_smart'} = [
# http://www.nttdocomo.co.jp/service/developer/smart_phone/technical_info/etc/
# 2013/10/12確認
'1.66.96.0/21', '1.66.104.0/23', '1.72.0.0/21', '1.72.8.0/23',
'1.72.10.0/24', '1.75.0.0/21', '1.75.8.0/22', '1.75.12.0/23',
'1.75.14.0/24', '1.75.16.0/20', '1.75.152.0/21', '1.75.224.0/19',
'1.78.0.0/19', '1.78.32.0/21', '1.78.40.0/22', '1.78.64.0/18',
'1.79.6.0/23', '1.79.8.0/21', '1.79.16.0/21', '1.79.24.0/22',
'1.79.28.0/23', '1.79.30.0/24', '1.79.32.0/21', '1.79.66.0/23',
'1.79.68.0/22', '1.79.72.0/21', '1.79.80.0/20', '1.79.96.0/21',
'49.96.0.0/18', '49.96.216.0/21', '49.96.224.0/19', '49.97.0.0/18',
'49.97.64.0/20', '49.97.88.0/22', '49.97.92.0/22', '49.97.96.0/19',
'49.98.7.0/24', '49.98.8.0/21', '49.98.16.0/24', '49.98.32.0/19',
'49.98.64.0/18', '49.98.128.0/17', '110.163.6.0/23', '110.163.8.0/22',
'110.163.12.0/23', '110.163.216.0/21', '110.163.224.0/22', '183.74.0.0/21',
'183.74.8.0/23', '183.75.128.0/18',
# 2013年11月 削除予定
'1.75.160.0/20', '1.75.176.0/22', '1.75.180.0/23', '183.74.224.0/20',
'183.74.240.0/21', '183.74.248.0/22',
# 2013年11月 追加予定
'1.75.196.0/22', '1.75.208.0/21', '1.79.176.0/21',
# 2013年11月 一部削除し変更予定 ※
'183.74.192.0/19',
# 2013年11月 追加予定 ※前行より変更
'183.74.192.0/20',
];
# SoftBank : 3G [ softbank.ne.jp ]
$cidr->{'vodafone'} =
$cidr->{'softbank'} = [
# http://creation.mb.softbank.jp/web/web_ip.html
# 2012/07/25更新 2013/10/12確認
'123.108.237.112/28', '123.108.239.224/28', '202.253.96.144/28', '202.253.99.144/28',
'210.228.189.188/30',
];
# Softbank : 3G PCサイトブラウザ
$cidr->{'vodafone_pc'} =
$cidr->{'softbank_pc'} = [
# http://creation.mb.softbank.jp/web/web_ip.html
# 2012/07/25更新 2013/10/12確認
'123.108.237.128/28', '123.108.239.240/28', '202.253.96.160/28', '202.253.99.160/28',
'210.228.189.196/30',
];
# Softbank : スマートフォン ※3G PCサイトブラウザを含む
$cidr->{'softbank_smart'} = [
# https://www.support.softbankmobile.co.jp/partner/home_tech1/
# 2013/08/09更新 2013/10/12確認
'123.108.237.128/28', '123.108.239.240/28', '126.163.0.0/16', '126.192.0.0/16',
'126.193.0.0/16', '126.194.208.0/22', '126.204.0.0/16', '202.253.96.160/28',
'202.253.99.160/28', '210.228.189.196/30',
# Xシリーズ 一部アプリ
# https://www.support.softbankmobile.co.jp/partner_st/home_tech1/X_series/index.cfm
# 2013/05/31更新 2013/10/12確認
'126.243.0.0/16',
];
# Softbank : iPhone/iPad 3G
$cidr->{'softbank_iphone'} = [
# 非公式情報 (基本放置でいきましょう 2012.06 じ)
# panda-world.ne.jp
# http://d.hatena.ne.jp/y-kawaz/20110427/1303870851
# https://twitter.com/panda_watcher
'126.95.0.0/16', '126.140.0.0/14', '126.144.0.0/12', '126.160.0.0/11',
'126.195.0.0/16', '126.196.0.0/14', '126.200.0.0/13', '126.208.0.0/12',
'126.224.0.0/11',
# http://d.hatena.ne.jp/unstablelife/20101228/1293538861
# http://durianjp.com/mt/2011/01/iphone-ip.html
#'126.160.0.0/11', '126.192.0.0/10',
];
# KDDI au : EZweb [ ezweb.ne.jp ]
$cidr->{'ezweb'} = [
# http://www.au.kddi.com/ezfactory/tec/spec/ezsava_ip.html
# 2013/09/19更新 2013/10/12確認
'210.230.128.224/28', '219.108.158.0/27', '219.125.146.0/28', '61.117.2.32/29',
'61.117.2.40/29', '219.108.158.40/29', '111.86.142.0/26', '111.86.143.192/27',
'111.86.141.64/26', '111.86.141.128/26', '111.86.141.192/26', '111.86.142.160/27',
'111.86.143.224/27', '111.86.147.0/27', '111.86.142.128/27', '111.86.143.32/27',
'111.86.142.192/27', '111.86.142.224/27', '111.86.143.0/27', '111.86.147.128/27',
'111.86.147.32/27', '111.86.147.64/27', '111.86.147.96/27', '111.86.147.160/27',
'111.86.147.192/27', '111.86.147.224/27',
# 2011年秋冬モデル以降の一部機種のEZサーバ
'111.107.116.64/26', '106.162.214.160/29', '111.107.116.192/28',
];
# KDDI au : EZweb PCサイトビューア
$cidr->{'ezweb_pc'} = [
# http://www.au.kddi.com/ezfactory/tec/spec/ezsava_ip.html
# 2012/09/13更新 2013/10/12確認
'222.15.68.192/26', '59.135.39.128/27', '118.152.214.160/27', '118.152.214.128/27',
'222.1.136.96/27', '222.1.136.64/27', '59.128.128.0/20', '111.86.140.40/30',
'111.86.140.44/30', '111.86.140.48/30', '111.86.140.52/30', '111.86.140.56/30',
'111.86.140.60/30', '111.87.241.144/28',
];
# KDDI au : IS NET/LTE NET(スマートフォン)
$cidr->{'ezweb_smart'} = [
# http://www.au.kddi.com/developer/android/kaihatsu/network/
# 2013/10更新 2013/10/12確認
'106.128.0.0/13', '111.86.140.128/27', '182.248.112.128/26', '182.249.0.0/16',
'182.250.0.0/15',
# 注) 182.249.0.0/16は以下のアドレスを除く
# 182.249.246.1〜182.249.246.3
# 182.249.246.11〜182.249.246.13
# 182.249.246.21〜182.249.246.23
# 182.249.246.31〜182.249.246.33
# 182.249.246.97〜182.249.246.126
];
# イー・モバイル [ emobile.ad.jp ]
$cidr->{'emobile'} = [
# http://developer.emnet.ne.jp/ipaddress.html
# 2008/02/26更新 2013/10/12確認
'117.55.1.224/27'
];
# WILLCOM [ prin.ne.jp ]
$cidr->{'willcom'} = [
# http://www.willcom-inc.com/ja/service/contents_service/create/center_info/
# 2013/09/26更新 2013/10/12確認
'61.198.129.0/24', '61.198.130.0/24', '61.198.132.0/24', '61.198.133.0/24',
'61.198.134.0/24', '61.198.135.0/24', '61.198.136.0/24', '61.198.137.0/24',
'61.198.139.0/29', '61.198.139.128/27', '61.198.139.160/28', '61.198.142.0/24',
'61.198.160.0/24', '61.198.161.0/24', '61.198.162.0/24', '61.198.163.0/24',
'61.198.164.0/24', '61.198.168.0/24', '61.198.169.0/24', '61.198.170.0/24',
'61.198.171.0/24', '61.198.172.0/24', '61.198.173.0/24', '61.198.174.0/24',
'61.198.175.0/24', '61.198.248.0/24', '61.198.249.0/24', '61.198.250.0/24',
'61.198.251.0/24', '61.198.252.0/24', '61.198.253.0/24', '61.198.255.0/24',
'61.204.0.0/24', '61.204.2.0/24', '61.204.3.128/25', '61.204.4.0/24',
'61.204.5.0/24', '61.204.6.128/25', '61.204.7.0/25', '61.204.92.0/24',
'61.204.93.0/24', '61.204.94.0/24', '61.204.95.0/24', '114.20.49.0/24',
'114.20.50.0/24', '114.20.51.0/24', '114.20.52.0/24', '114.20.53.0/24',
'114.20.54.0/24', '114.20.55.0/24', '114.20.56.0/24', '114.20.57.0/24',
'114.20.58.0/24', '114.20.59.0/24', '114.20.60.0/24', '114.20.61.0/24',
'114.20.62.0/24', '114.20.63.0/24', '114.20.64.0/24', '114.20.65.0/24',
'114.20.66.0/24', '114.20.67.0/24', '114.20.128.0/17', '114.21.128.0/24',
'114.21.129.0/24', '114.21.130.0/24', '114.21.131.0/24', '114.21.132.0/24',
'114.21.133.0/24', '114.21.134.0/24', '114.21.135.0/24', '114.21.136.0/24',
'114.21.137.0/24', '114.21.138.0/24', '114.21.139.0/24', '114.21.140.0/24',
'114.21.141.0/24', '114.21.142.0/24', '114.21.143.0/24', '114.21.144.0/24',
'114.21.145.0/24', '114.21.146.0/24', '114.21.147.0/24', '114.21.148.0/24',
'114.21.149.0/24', '125.28.0.0/24', '125.28.1.0/24', '125.28.2.0/24',
'125.28.3.0/24', '125.28.6.0/24', '125.28.7.0/24', '125.28.8.0/24',
'125.28.11.0/24', '125.28.12.0/24', '125.28.13.0/24', '125.28.14.0/24',
'125.28.15.0/24', '125.28.16.0/24', '125.28.17.0/24', '210.168.246.0/24',
'210.168.247.0/24', '210.169.92.0/24', '210.169.93.0/24', '210.169.95.0/24',
'210.169.96.0/24', '210.169.97.0/24', '210.169.98.0/24', '210.169.99.0/24',
'210.255.190.0/24', '211.126.192.128/25', '211.18.232.0/24', '211.18.233.0/24',
'211.18.234.0/24', '211.18.235.0/24', '211.18.236.0/24', '211.18.237.0/24',
'211.18.238.0/24', '211.18.239.0/24', '219.108.2.0/24', '219.108.3.0/24',
'219.108.4.0/24', '219.108.5.0/24', '219.108.6.0/24', '219.108.7.0/24',
'219.108.10.0/24', '219.108.11.0/24', '219.108.12.0/24', '219.108.13.0/24',
'219.108.14.0/24', '219.108.15.0/24', '221.109.128.0/18', '221.119.0.0/24',
'221.119.1.0/24', '221.119.2.0/24', '221.119.3.0/24', '221.119.4.0/24',
'221.119.5.0/24', '221.119.6.0/24', '221.119.7.0/24', '221.119.8.0/24',
'221.119.9.0/24',
];
# ibisブラウザ
$cidr->{'ibis'} = [
# http://ibis.ne.jp/support/browserIP.jsp
# 2013/10/12確認
'54.248.5.162/32', '54.248.145.37/32', '54.248.147.159/32', '54.248.148.218/32',
'54.248.150.59/32', '54.248.153.81/32', '54.248.160.163/32', '54.248.164.51/32',
'54.248.165.159/32', '54.248.173.87/32', '54.248.176.184/32', '54.248.178.251/32',
'54.248.181.37/32', '54.248.184.172/32', '54.248.187.26/32', '54.248.226.234/32',
'54.248.229.21/32', '54.248.233.80/32', '175.41.198.11/32', '176.34.14.9/32',
];
# jigブラウザ
$cidr->{'jig'} = [
# http://br.jig.jp/pc/ip_br.html
# 2013/07/31更新 2013/10/12確認
'112.78.114.208/32', '112.78.207.6/31', '112.78.207.8/29', '112.78.207.16/29',
'112.78.207.24/31', '112.78.215.70/31', '112.78.215.72/29', '112.78.215.80/29',
'112.78.215.88/31', '112.78.215.166/31', '112.78.215.168/29', '112.78.215.176/29',
'112.78.215.184/31', '112.78.215.230/31', '112.78.215.232/29', '112.78.215.240/29',
'112.78.215.248/31', '182.48.5.230/31', '182.48.5.232/29', '202.181.98.160/32',
'202.181.98.179/32', '202.181.98.196/32', '210.188.205.81/32', '210.188.205.83/32',
'219.94.177.6/31', '219.94.177.8/29', '219.94.177.16/29', '219.94.177.24/31',
'219.94.182.230/31', '219.94.182.232/29', '219.94.182.240/29', '219.94.182.248/31',
'219.94.183.102/31', '219.94.183.104/29', '219.94.183.112/29', '219.94.183.120/31',
'219.94.184.70/31', '219.94.184.72/29',
];
$cidr->{'iphone'} = [(
@{$cidr->{'softbank_iphone'}},
)];
# uqwimax.jp
# p2
$cidr->{'p2'} = [
# cw43.razil.jp
'210.135.98.43',
# p202.razil.jp
'210.135.100.132',
];
}
1;
zerochplus_0.7.4/test/module/constant.pl 0000644 0000764 0001040 00000014042 12236106655 015357 0 ustar #============================================================================================================
#
# 定数モジュール(ZP)
#
# by ぜろちゃんねるプラス
# http://zerochplus.sourceforge.jp/
#
#============================================================================================================
package ZP;
use strict;
#use warnings;
#use bigint;
# CLIENT
# M: Mobile Browser, F: Full Browser
our $C_PC = 0x00000001;
our $C_P2 = 0x00000002;
our $C_DOCOMO_M = 0x00000004;
our $C_DOCOMO_F = 0x00000008;
our $C_DOCOMO = $C_DOCOMO_M | $C_DOCOMO_F;
our $C_AU_M = 0x00000010;
our $C_AU_F = 0x00000020;
our $C_AU = $C_AU_M | $C_AU_F;
our $C_SOFTBANK_M = 0x00000040;
our $C_SOFTBANK_F = 0x00000080;
our $C_SOFTBANK = $C_SOFTBANK_M | $C_SOFTBANK_F;
our $C_WILLCOM_M = 0x00000100;
our $C_WILLCOM_F = 0x00000200;
our $C_WILLCOM = $C_WILLCOM_M | $C_WILLCOM_F;
our $C_EMOBILE_M = 0x00000400;
our $C_EMOBILE_F = 0x00000800;
our $C_EMOBILE = $C_EMOBILE_M | $C_EMOBILE_F;
our $C_IBIS = 0x00001000;
our $C_JIG = 0x00002000;
our $C_OPERAMINI = 0x00004000;
our $C_IPHONE_F = 0x00008000;
our $C_IPHONEWIFI = 0x00010000;
our $C_IPHONE = $C_IPHONE_F | $C_IPHONEWIFI;
our $C_FBSERVICE = $C_IBIS | $C_JIG | $C_OPERAMINI;
our $C_MOBILEBROWSER = $C_DOCOMO_M | $C_AU_M | $C_SOFTBANK_M | $C_WILLCOM_M | $C_EMOBILE_M;
our $C_FULLBROWSER = $C_DOCOMO_F | $C_AU_F | $C_SOFTBANK_F | $C_WILLCOM_F | $C_EMOBILE_F | $C_FBSERVICE;
our $C_MOBILE = $C_MOBILEBROWSER | $C_FULLBROWSER;
our $C_MOBILE_IDGET = $C_DOCOMO_M | $C_AU_M | $C_SOFTBANK_M | $C_EMOBILE_M | $C_P2;
# ERRORNUM
our $E_SUCCESS = 0; # must FALSE
# 入力内容に関するエラー
our $E_FORM_LONGSUBJECT = 100;
our $E_FORM_LONGNAME = 101;
our $E_FORM_LONGMAIL = 102;
our $E_FORM_LONGTEXT = 103;
our $E_FORM_LONGLINE = 104;
our $E_FORM_MANYLINE = 105;
our $E_FORM_MANYANCHOR = 106;
our $E_FORM_NOSUBJECT = 150;
our $E_FORM_NOTEXT = 151;
our $E_FORM_NONAME = 152;
# 制限に関するエラー
our $E_LIMIT_STOPPEDTHREAD = 200;
our $E_LIMIT_OVERMAXRES = 201;
our $E_LIMIT_MOVEDTHREAD = 202;
our $E_LIMIT_READONLY = 203;
our $E_LIMIT_MOBILETHREAD = 204;
our $E_LIMIT_FORBIDDENCGI = 205;
our $E_LIMIT_OVERDATSIZE = 206;
our $E_LIMIT_THREADCAPONLY = 504;
# 規制に関するエラー
our $E_REG_MANYTHREAD = 500;
our $E_REG_NOBREAKPOST = 501;
our $E_REG_DOUBLEPOST = 502;
our $E_REG_NOTIMEPOST = 503;
our $E_REG_SAMBA_CAUTION = 505; # continuously
our $E_REG_SAMBA_WARNING = 506; # 505+1
our $E_REG_SAMBA_LISTED = 507; # 505+2
our $E_REG_SAMBA_STILL = 508; # 505+3
our $E_REG_SAMBA_2CH1 = 593; # 2ch errnum
our $E_REG_SAMBA_2CH2 = 599; # 2ch errnum
our $E_REG_SAMBA_2CH3 = 594; # 2ch errnum
our $E_REG_NGWORD = 600;
our $E_REG_NGUSER = 601;
our $E_REG_NOTJPHOST = 207;
our $E_REG_DNSBL = 997;
# BEに関するエラー
our $E_BE_GETFAILED = 890;
our $E_BE_CONNECTFAILED = 891;
our $E_BE_LOGINFAILED = 892;
our $E_BE_MUSTLOGIN = 893;
our $E_BE_MUSTLOGIN2 = 894;
# リクエストエラー
our $E_THREAD_INVALIDKEY = 900;
our $E_THREAD_WRONGLENGTH = 901;
our $E_THREAD_NOTEXIST = 902;
our $E_POST_NOPRODUCT = 950;
our $E_POST_INVALIDREFERER = 998;
our $E_POST_INVALIDFORM = 999;
our $E_POST_NOTEXISTBBS = $E_POST_INVALIDFORM;
our $E_POST_NOTEXISTDAT = $E_POST_INVALIDFORM;
# read.cgi用エラー
our $E_READ_R_INVALIDBBS = 1001; # 2ch errnum
our $E_READ_R_INVALIDKEY = 1002; # 2ch errnum
our $E_READ_FAILEDLOADDAT = 1003; # 2ch errnum
our $E_READ_FAILEDLOADSET = 1004; # 2ch errnum
our $E_READ_INVALIDBBS = 2011; # 2ch errnum
our $E_READ_INVALIDKEY = 3001; # 2ch errnum
# システム・その他のエラー
our $E_SYSTEM_ERROR = 990;
# ページ表示用番号
our $E_PAGE_FINDTHREAD = $E_READ_FAILEDLOADDAT;
our $E_PAGE_THREAD = 9000;
our $E_PAGE_COOKIE = 9001;
our $E_PAGE_WRITE = 9002;
our $E_PAGE_THREADMOBILE = 9003;
# CAP PERMISSION
our $CAP_FORM_LONGSUBJECT = 1; # タイトル文字数 制限解除
our $CAP_FORM_LONGNAME = 2; # 名前文字数 制限解除
our $CAP_FORM_LONGMAIL = 3; # メール文字数 制限解除
our $CAP_FORM_LONGTEXT = 4; # 本文文字数 制限解除
our $CAP_FORM_MANYLINE = 5; # 本文行数 制限解除
our $CAP_FORM_LONGLINE = 6; # 本文1行文字数 制限解除
our $CAP_FORM_NONAME = 7; # 名無し 制限解除
our $CAP_REG_MANYTHREAD = 8; # スレッド作成 規制解除
our $CAP_LIMIT_THREADCAPONLY = 9; # スレッド作成可能
our $CAP_REG_NOBREAKPOST = 10; # 連続投稿 規制解除
our $CAP_REG_DOUBLEPOST = 11; # 二重書き込み 規制解除
our $CAP_REG_NOTIMEPOST = 12; # 短時間投稿 規制解除
our $CAP_LIMIT_READONLY = 13; # 読取専用 制限解除
our $CAP_DISP_NOID = 14; # ID非表示
our $CAP_DISP_NOHOST = 15; # 本文ホスト非表示
our $CAP_LIMIT_MOBILETHREAD = 16; # 携帯からのスレッド作成 制限解除
our $CAP_DISP_HANLDLE = 17; # コテハン★表示
our $CAP_REG_SAMBA = 18; # Samba 規制解除
our $CAP_REG_DNSBL = 19; # プロキシ 規制解除
our $CAP_REG_NOTJPHOST = 20; # 海外ホスト 規制解除
our $CAP_REG_NGUSER = 21; # ユーザー 規制解除
our $CAP_REG_NGWORD = 22; # NGワード 規制解除
our $CAP_DISP_NOSLIP = 23; # 端末識別子非表示
our $CAP_DISP_CUSTOMID = 24; # 専用ID許可
our $CAP_MAXNUM = 24;
# USER AUTHORITY
our $AUTH_SYSADMIN = 0; # システム管理権限(形式的に)
our $AUTH_USERGROUP = 1; # 管理グループ設定
our $AUTH_CAPGROUP = 2; # キャップグループ設定
our $AUTH_THREADSTOP = 3; # スレッド停止・再開
our $AUTH_THREADPOOL = 4; # スレッドdat落ち・復活
our $AUTH_TREADDELETE = 5; # スレッド削除
our $AUTH_THREADINFO = 6; # スレッド情報更新
our $AUTH_KAKOCREATE = 7; # 過去ログ生成
our $AUTH_KAKODELETE = 8; # 過去ログ削除
our $AUTH_BBSSETTING = 9; # 掲示板設定
our $AUTH_NGWORDS = 10; # NGワード編集
our $AUTH_ACCESUSER = 11; # アクセス制限編集
our $AUTH_RESDELETE = 12; # レスあぼーん
our $AUTH_RESEDIT = 13; # レス編集
our $AUTH_BBSEDIT = 14; # 各種編集
our $AUTH_LOGVIEW = 15; # ログの閲覧・削除
our $AUTH_MAXNUM = 15;
# REGEXP
our $RE_SJIS = '(?:[\x00-\x7f\xa1-\xdf]|[\x81-\x9f\xe0-\xef][\x40-\x7e\x80-\xfc])';
#============================================================================================================
# モジュール終端
#============================================================================================================
1;
zerochplus_0.7.4/test/module/denethor.pl 0000644 0000764 0001040 00000014630 12236106655 015341 0 ustar #============================================================================================================
#
# バナー管理モジュール
#
#============================================================================================================
package DENETHOR;
use strict;
#use warnings;
#------------------------------------------------------------------------------------------------------------
#
# モジュールコンストラクタ - new
# -------------------------------------------
# 引 数：なし
# 戻り値：モジュールオブジェクト
#
#------------------------------------------------------------------------------------------------------------
sub new
{
my $class = shift;
my $obj = {
'TEXTPC' => undef, # PC用テキスト
'TEXTSB' => undef, # サブバナーテキスト
'TEXTMB' => undef, # 携帯用テキスト
'COLPC' => undef, # PC用背景色
'COLMB' => undef, # 携帯用背景色
};
bless $obj, $class;
return $obj;
}
#------------------------------------------------------------------------------------------------------------
#
# バナー情報読み込み - Load
# -------------------------------------------
# 引 数：$Sys : MELKOR
# 戻り値：成功:0,失敗:-1
#
#------------------------------------------------------------------------------------------------------------
sub Load
{
my $this = shift;
my ($Sys) = @_;
$this->{'TEXTPC'} = 'なるほど告知欄じゃねーの なるほど告知欄じゃねーの
') if ($f & 1);
# 携帯用バナー表示
if ($mode) {
$Page->Print('Print("bgcolor=$this->{'COLMB'}>");
$Page->Print("$this->{'TEXTMB'}
\n");
}
# PC用バナー表示
else {
$Page->Print("Print(" bgcolor=\"$this->{'COLPC'}\" align=\"center\">\n");
$Page->Print("$this->{'TEXTPC'}\n
\n");
}
# 下区切り
$Page->Print("
\n\n") if ($f & 2);
}
#------------------------------------------------------------------------------------------------------------
#
# サブバナー出力 - PrintSub
# -------------------------------------------
# 引 数：$Page : モジュール
# 戻り値：バナー出力したら1,その他は0
#
#------------------------------------------------------------------------------------------------------------
sub PrintSub
{
my $this = shift;
my ($Page) = @_;
# サブバナーが存在したら表示する
if ($this->{'TEXTSB'} ne '') {
$Page->Print("\n");
$Page->Print("$this->{'TEXTSB'}\n");
$Page->Print("\n");
return 1;
}
return 0;
}
#============================================================================================================
# モジュール終端
#============================================================================================================
1;
zerochplus_0.7.4/test/module/earendil.pl 0000644 0000764 0001040 00000016447 12236106655 015324 0 ustar #============================================================================================================
#
# ファイル操作ユーティリティモジュール
#
#============================================================================================================
package EARENDIL;
use strict;
#use warnings;
#------------------------------------------------------------------------------------------------------------
#
# ファイルコピー
# -------------------------------------------------------------------------------------
# @param $src コピー元ファイルパス
# @param $dst コピー先ファイルパス
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Copy
{
my ($src, $dst) = @_;
if (open(my $fh_s, '<', $src) && open(my $fh_d, (-f $dst ? '+<' : '>'), $dst)) {
flock($fh_s, 2);
flock($fh_d, 2);
seek($fh_d, 0, 0);
binmode($fh_s);
binmode($fh_d);
print $fh_d (<$fh_s>);
truncate($fh_d, tell($fh_d));
close($fh_s);
close($fh_d);
# パーミッション設定
chmod((stat $src)[2], $dst);
return 1;
}
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# ファイル移動
# -------------------------------------------------------------------------------------
# @param $src 移動元ファイルパス
# @param $dst 移動先ファイルパス
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Move
{
my ($src, $dst) = @_;
if (Copy($src, $dst)) {
unlink $src; # コピー元削除
}
}
#------------------------------------------------------------------------------------------------------------
#
# ディレクトリ再帰削除
# -------------------------------------------------------------------------------------
# @param $path 削除するパス
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub DeleteDirectory
{
my ($path) = @_;
# ファイル情報を取得
my %fileList = ();
GetFileInfoList($path, \%fileList);
foreach my $file (keys %fileList) {
if ($file ne '.' && $file ne '..') {
my (undef, undef, $attr) = split(/<>/, $fileList{$file}, -1);
if ($attr & 1) { # ディレクトリなら
DeleteDirectory("$path/$file"); # 再帰呼び出し
}
else { # ファイルなら
unlink "$path/$file"; # そのまま削除
}
}
}
rmdir $path;
}
#------------------------------------------------------------------------------------------------------------
#
# ファイル情報一覧取得
# -------------------------------------------------------------------------------------
# @param $Path 一覧取得するパス
# @param $pList 一覧を格納するハッシュの参照
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub GetFileInfoList
{
my ($Path, $pList) = @_;
my @arFiles = ();
if (opendir(my $dh, $Path)) {
@arFiles = readdir($dh);
closedir($dh);
}
# ディレクトリ内の全ファイルを走査
foreach my $file (@arFiles) {
my $Full = "$Path/$file";
my $Attr = 0;
my $Size = -s $Full; # サイズ取得
my $Perm = substr(sprintf('%o', (stat $Full)[2]), -4); # パーミッション取得
$Attr |= 1 if (-d $Full); # ディレクトリ？
$Attr |= 2 if (-T $Full); # テキストファイル？
$pList->{$file} = "$Size<>$Perm<>$Attr";
}
}
#------------------------------------------------------------------------------------------------------------
#
# 指定ファイル一覧取得
# -------------------------------------------------------------------------------------
# @param $path 一覧取得するパス
# @param $pList 一覧を格納する配列の参照
# @param $opt 抽出オプション(正規表現)
# @return 見つかったファイル数
#
#------------------------------------------------------------------------------------------------------------
sub GetFileList
{
my ($path, $pList, $opt) = @_;
my @files = ();
if (opendir(my $dh, $path)) {
@files = readdir($dh);
closedir($dh);
}
my $num = 0;
foreach my $file (@files) {
# ディレクトリじゃなく抽出条件が一致したら配列にプッシュする
if (! -d "$path/$file") {
if ($file =~ /$opt/) { # $optは正規表現
push @$pList, $file;
$num++;
}
}
}
return $num;
}
#------------------------------------------------------------------------------------------------------------
#
# ディレクトリ作成
# -------------------------------------------------------------------------------------
# @param $path 作成するパス
# @param $perm ディレクトリのパーミッション
# @return 作成に成功したら1を返す
#
#------------------------------------------------------------------------------------------------------------
sub CreateDirectory
{
my ($path, $perm) = @_;
if (! -e $path) {
return mkdir($path, $perm);
}
return 0;
}
#-------------------------------------------------------------------------------------------------------------
#
# ディレクトリ作成
# ------------------------------------------------------------------
# @param $path 生成パス
# @return なし
#
#-------------------------------------------------------------------------------------------------------------
sub CreateFolderHierarchy
{
my ($path, $perm) = @_;
while (1) {
if (-d $path) {
return;
}
else {
if (mkdir($path, $perm)) {
return;
}
# ディレクトリ作成失敗時は再帰的に1つ下の階層を作成する
else {
my $upath = $path;
$upath =~ s|[\\\/][^\\\/]*$||;
CreateFolderHierarchy($upath, $perm);
}
}
}
}
#------------------------------------------------------------------------------------------------------------
#
# ディレクトリ検索
# -------------------------------------------------------------------------------------
# @param $path 検索するパス
# @param $pHash 検索結果格納用ハッシュ
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub GetFolderHierarchy
{
my ($path, $pHash) = @_;
my @elements = ();
if (opendir(my $dh, $path)) {
@elements = readdir($dh);
closedir($dh);
}
foreach my $elem (sort @elements) {
# ディレクトリが見つかったら再帰的に探索する
if (-d "$path/$elem" && $elem ne '.' && $elem ne '..') {
my %folders = ();
GetFolderHierarchy("$path/$elem", \%folders);
if (scalar(keys(%folders)) > 0) {
$pHash->{$elem} = \%folders;
}
else {
$pHash->{$elem} = undef; # don't delete
}
}
}
}
#------------------------------------------------------------------------------------------------------------
#
# ディレクトリリスト取得
# GetFolderHierarchyで取得したハッシュからディレクトリ一覧の配列を取得する
# -------------------------------------------------------------------------------------
# @param $pHash GetFolderHierarchyで取得したハッシュ
# @param $pList 結果格納用配列
# @param $base ベースパス
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub GetFolderList
{
my ($pHash, $pList, $base) = @_;
foreach my $key (keys %$pHash) {
push @$pList, "$base/$key";
if (defined $pHash->{$key}) {
GetFolderList($pHash->{$key}, $pList, "$base/$key");
}
}
}
#============================================================================================================
# Module END
#============================================================================================================
1;
zerochplus_0.7.4/test/module/elves.pl 0000644 0000764 0001040 00000052352 12236106655 014652 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.4/test/module/faramir.pl 0000644 0000764 0001040 00000014645 12236106655 015160 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.4/test/module/galadriel.pl 0000644 0000764 0001040 00000101364 12236106655 015456 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.4/test/module/gandalf.pl 0000644 0000764 0001040 00000021043 12236106655 015121 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.4/test/module/gondor.pl 0000644 0000764 0001040 00000030251 12236106655 015016 0 ustar #============================================================================================================
#
# datファイル管理モジュール
#
#============================================================================================================
package ARAGORN;
use strict;
#use warnings;
#------------------------------------------------------------------------------------------------------------
#
# コンストラクタ
# -------------------------------------------------------------------------------------
# @param なし
# @return モジュールオブジェクト
#
#------------------------------------------------------------------------------------------------------------
sub new
{
my $class = shift;
my $obj = {
'LINE' => undef,
'PATH' => undef,
'RES' => undef,
'HANDLE' => undef,
'MAX' => undef,
'STAT' => 0,
'PERM' => undef,
'MODE' => undef,
};
bless $obj, $class;
return $obj;
}
#------------------------------------------------------------------------------------------------------------
#
# デストラクタ
# -------------------------------------------------------------------------------------
# @param なし
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub DESTROY
{
my $this = shift;
# ファイルオープン状態の場合はクローズする
if ($this->{'STAT'}) {
my $fh = $this->{'HANDLE'};
if ($fh) {
#truncate($fh, tell($fh));
close($fh);
chmod $this->{'PERM'}, $this->{'PATH'};
}
}
}
#------------------------------------------------------------------------------------------------------------
#
# 読み込み
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @param $szPath 読み込みパス
# @param $readOnly モード
# @return 成功したら読み込んだレス数
#
#------------------------------------------------------------------------------------------------------------
sub Load
{
my $this = shift;
my ($Sys, $szPath, $readOnly) = @_;
# 状態が初期状態なら読み込み開始
if ($this->{'STAT'} == 0) {
$this->{'RES'} = 0;
$this->{'LINE'} = [];
$this->{'MAX'} = $Sys->Get('RESMAX');
$this->{'PATH'} = $szPath;
$this->{'PERM'} = GetPermission($szPath);
$this->{'MODE'} = $readOnly;
chmod($Sys->Get('PM-DAT'), $szPath);
if (open(my $fh, ($readOnly ? '<' : '+<'), $szPath)) {
flock($fh, 2);
binmode($fh);
my @lines = <$fh>;
push @{$this->{'LINE'}}, @lines;
# 書き込みモードの場合
seek($fh, 0, 0) if (! $readOnly);
# ハンドルを保存し状態を読み込み状態にする
$this->{'HANDLE'} = $fh;
$this->{'STAT'} = 1;
$this->{'RES'} = scalar(@{$this->{'LINE'}});
}
return $this->{'RES'};
}
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# 再読み込み
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @param $readOnly モード
# @return 成功したら読み込んだレス数
#
#------------------------------------------------------------------------------------------------------------
sub ReLoad
{
my $this = shift;
my ($Sys, $readOnly) = @_;
if ($this->{'STAT'}) {
$this->Close();
return $this->Load($Sys, $this->{'PATH'}, $readOnly);
}
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# 書き込み
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Save
{
my $this = shift;
my ($Sys) = @_;
# ファイルオープン状態なら書き込みを実行する
my $fh = $this->{'HANDLE'};
if ($this->{'STAT'} && $fh) {
if (! $this->{'MODE'}) {
seek($fh, 0, 0);
print $fh @{$this->{'LINE'}};
truncate($fh, tell($fh));
close($fh);
chmod($this->{'PERM'}, $this->{'PATH'});
$this->{'STAT'} = 0;
$this->{'HANDLE'} = undef;
}
else {
$this->Close();
}
}
}
#------------------------------------------------------------------------------------------------------------
#
# 強制クローズ
# -------------------------------------------------------------------------------------
# @param なし
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Close
{
my $this = shift;
# ファイルオープン状態の場合はクローズする
if ($this->{'STAT'}) {
my $fh = $this->{'HANDLE'};
#truncate($handle, tell($handle));
close($fh);
chmod($this->{'PERM'}, $this->{'PATH'});
$this->{'STAT'} = 0;
$this->{'HANDLE'} = undef;
}
}
#------------------------------------------------------------------------------------------------------------
#
# データ設定
# -------------------------------------------------------------------------------------
# @param $line 設定行
# @param $data 設定データ
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Set
{
my $this = shift;
my ($line, $data) = @_;
$this->{'LINE'}->[$line] = $data;
}
#------------------------------------------------------------------------------------------------------------
#
# データ取得
# -------------------------------------------------------------------------------------
# @param $line 取得行
# @return 行データの参照
#
#------------------------------------------------------------------------------------------------------------
sub Get
{
my $this = shift;
my ($line) = @_;
if ($line >= 0 && $line < $this->{'RES'}) {
return \($this->{'LINE'}->[$line]);
}
return undef;
}
#------------------------------------------------------------------------------------------------------------
#
# データ追加
# -------------------------------------------------------------------------------------
# @param $data 追加データ
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Add
{
my $this = shift;
my ($data) = @_;
# 最大データ数内なら追加する
if ($this->{'MAX'} > $this->{'RES'}) {
push @{$this->{'LINE'}}, $data;
$this->{'RES'}++;
}
}
#------------------------------------------------------------------------------------------------------------
#
# データ削除
# -------------------------------------------------------------------------------------
# @param $num 削除行
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Delete
{
my $this = shift;
my ($num) = @_;
splice @{$this->{'LINE'}}, $num, 1;
$this->{'RES'}--;
}
#------------------------------------------------------------------------------------------------------------
#
# レス数取得
# -------------------------------------------------------------------------------------
# @param なし
# @return レス数
#
#------------------------------------------------------------------------------------------------------------
sub Size
{
my $this = shift;
return $this->{'RES'};
}
#------------------------------------------------------------------------------------------------------------
#
# サブジェクト取得
# -------------------------------------------------------------------------------------
# @param なし
# @return サブジェクト
#
#------------------------------------------------------------------------------------------------------------
sub GetSubject
{
my $this = shift;
my @elem = split(/<>/, $this->{'LINE'}->[0], -1);
$elem[4] =~ s/[\r\n]+\z//;
return $elem[4];
}
#------------------------------------------------------------------------------------------------------------
#
# スレッド停止 * 0.8.xから非推奨
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @return 成功:1 失敗:0
#
#------------------------------------------------------------------------------------------------------------
sub Stop
{
my $this = shift;
my ($Sys) = @_;
# ↓スレスト文言
my $stopData = "停止しました。。。<>停止<>停止<>真・スレッドストッパー。。。（￣ー￣）ﾆﾔﾘｯ<>停止したよ。\n";
# レス最大数超えてる場合はスレスト不可
if ($this->Size() <= $Sys->Get('RESMAX')) {
# 停止状態じゃない場合のみ実行
if (! $this->IsStopped($Sys)) {
# 停止データを追加して強制的にセーブする
$this->Add($stopData);
$this->Save($Sys);
# パーミッションを停止用に設定する
chmod($Sys->Get('PM-STOP'), $this->{'PATH'});
return 1;
}
}
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# スレッド開始 * 0.8.xから非推奨
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @return 成功:1 失敗:0
#
#------------------------------------------------------------------------------------------------------------
sub Start
{
my $this = shift;
my ($Sys) = @_;
# 停止状態の場合のみ実行
if ($this->IsStopped($Sys)) {
# 最終行を削除して保存
my $line = $this->{'RES'} - 1;
$this->Delete($line);
$this->Save($Sys);
# パーミッションを通常用に設定する
chmod($Sys->Get('PM-DAT'), $this->{'PATH'});
return 1;
}
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# dat直接追記
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @param $path 追記ファイルパス
# @param $data 追記データ
# @return 追記できたら0を返す
#
#------------------------------------------------------------------------------------------------------------
sub DirectAppend
{
my ($Sys, $path, $data) = @_;
if (GetPermission($path) != $Sys->Get('PM-STOP')) {
if (open(my $fh, '>>', $path)) {
flock($fh, 2);
binmode($fh);
print $fh "$data";
close($fh);
chmod($Sys->Get('PM-DAT'), $path);
return 0;
}
}
else {
return 2;
}
return 1;
}
#------------------------------------------------------------------------------------------------------------
#
# ファイル指定レス数取得
# -------------------------------------------------------------------------------------
# @param $path 指定ファイルパス
# @return レス数
#
#------------------------------------------------------------------------------------------------------------
sub GetNumFromFile
{
my ($path) = @_;
my $cnt = 0;
if (open(my $fh, '<', $path)) {
flock($fh, 2);
$cnt++ while (<$fh>);
close($fh);
}
return $cnt;
}
#------------------------------------------------------------------------------------------------------------
#
# パーミッション取得
# -------------------------------------------------------------------------------------
# @param $path 指定ファイルパス
# @return パーミッション
#
#------------------------------------------------------------------------------------------------------------
sub GetPermission
{
my ($path) = @_;
return (-e $path ? (stat $path)[2] & 0777 : 0);
}
#------------------------------------------------------------------------------------------------------------
#
# 移転検査
# -------------------------------------------------------------------------------------
# @param $path 指定ファイルパス
# @return パーミッション
#
#------------------------------------------------------------------------------------------------------------
sub IsMoved
{
my ($path) = @_;
if (open(my $fh, '<', $path)) {
flock($fh, 2);
my $line = <$fh>;
close($fh);
my @elem = split(/<>/, $line, -1);
if ($elem[2] ne '移転') {
return 0;
}
}
return 1;
}
#------------------------------------------------------------------------------------------------------------
#
# 停止検査 * 0.8.xから非推奨
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @return boolean
#
#------------------------------------------------------------------------------------------------------------
sub IsStopped
{
my $this = shift;
my ($Sys) = @_;
return $this->{'PERM'} == $Sys->Get('PM-STOP');
}
#============================================================================================================
# Module END
#============================================================================================================
1;
zerochplus_0.7.4/test/module/httpservice.pl 0000644 0000764 0001040 00000031260 12236106655 016067 0 ustar #============================================================================================================
#
# httpサービスモジュール
#
#============================================================================================================
package HTTPSERVICE;
use strict;
#use warnings;
use Socket;
#------------------------------------------------------------------------------------------------------------
#
# コンストラクタ
# -------------------------------------------------------------------------------------
# @param なし
# @return httpサービスオブジェクト
#
#------------------------------------------------------------------------------------------------------------
sub new
{
my $class = shift;
my $obj = {
'METHOD' => 'GET',
'URI' => undef,
'PARAMETER' => undef,
'CONTENT_TYPE' => 'application/x-www-form-urlencoded',
'REFERER' => undef,
'AGENT' => 'Mozilla/5.0 Zero-Channel BBS Plus Project',
'CONNECTION' => 'close',
'LANGUAGE' => 'ja,en-us;q=0.7,en;q=0.3',
'PROXY_HOST' => undef,
'PROXY_PORT' => undef,
'TIMEOUT' => 3,
'CODE' => 500,
'HEADER' => undef,
'CONTENT' => undef
};
bless $obj, $class;
return $obj;
}
#------------------------------------------------------------------------------------------------------------
#
# http要求送信
# -------------------------------------------------------------------------------------
# @param なし
# @return エラーコード
# 1:正常終了
# -1:URIエラー
# -2:socketエラー
#
#------------------------------------------------------------------------------------------------------------
sub request
{
my $this = shift;
# URIを分解
my $uri = $this->{'URI'};
my ($host, $port, $target) = decompositionURI($uri);
return -1 if (!defined $host);
# プロキシを使用する
if (defined $this->{'PROXY_HOST'}) {
$host = $this->{'PROXY_HOST'};
$port = $this->{'PROXY_PORT'} || 80;
$target = $uri;
}
# リクエストクエリの作成
my $request = createRequestString($this, $host, $target);
eval
{
local $SIG{'ALRM'} = sub { die "connect time out. $!" };
alarm($this->{'TIMEOUT'});
# ソケットの作成
my $sockaddr = pack_sockaddr_in($port, inet_aton($host));
socket(SOCKET, PF_INET, SOCK_STREAM, 0);
select(SOCKET);
$| = 1;
select(STDOUT);
connect(SOCKET, $sockaddr);
binmode(SOCKET);
#autoflush SOCKET (1);
# リクエスト送信
print SOCKET $request;
$this->{'REQUEST'} = $request;
my $chunkedflag = 0;
my $code = -1;
my $header = '';
my $content = '';
while (
\n\n");
#$Page->Print("
\n");
if ($text ne '') {
$Page->Print("
\n");
$Page->Print("
\n");
$Page->Print("
$bbs
■ ▼
\n");
$Page->Print("
HEAD
foreach (@{$this->{'HEAD'}}) {
$Page->Print(" $_");
}
$Page->Print(" \n");
$Page->Print(" \n");
$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.4/test/module/melkor.pl 0000644 0000764 0001040 00000024616 12236106655 015027 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.4 20131106', # 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 = 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.4/test/module/nazguls.pl 0000644 0000764 0001040 00000035712 12236106655 015220 0 ustar #============================================================================================================
#
# 掲示板情報管理モジュール
# -------------------------------------------------------------------------------------
# このモジュールは管理CGIの掲示板情報を管理します。
# 以下の2つのパッケージによって構成されます
#
# NAZGUL : 掲示板情報管理
# ANGMAR : カテゴリ情報管理
#
#============================================================================================================
#============================================================================================================
#
# 掲示板情報管理パッケージ
#
#============================================================================================================
package NAZGUL;
use strict;
#use warnings;
#------------------------------------------------------------------------------------------------------------
#
# コンストラクタ
# -------------------------------------------------------------------------------------
# @param なし
# @return モジュールオブジェクト
#
#------------------------------------------------------------------------------------------------------------
sub new
{
my $class = shift;
my $obj = {
'NAME' => undef,
'DIR' => undef,
'SUBJECT' => undef,
'CATEGORY' => undef,
};
bless $obj, $class;
return $obj;
}
#------------------------------------------------------------------------------------------------------------
#
# 掲示板情報読み込み
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Load
{
my $this = shift;
my ($Sys) = @_;
$this->{'NAME'} = {};
$this->{'DIR'} = {};
$this->{'SUBJECT'} = {};
$this->{'CATEGORY'} = {};
my $path = '.' . $Sys->Get('INFO') . '/bbss.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];
$this->{'NAME'}->{$id} = $elem[1];
$this->{'DIR'}->{$id} = $elem[2];
$this->{'SUBJECT'}->{$id} = $elem[3];
$this->{'CATEGORY'}->{$id} = $elem[4];
}
}
else {
warn "can't load bbs info: $path";
}
}
#------------------------------------------------------------------------------------------------------------
#
# 掲示板情報保存
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Save
{
my $this = shift;
my ($Sys) = @_;
my $path = '.' . $Sys->Get('INFO') . '/bbss.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->{'DIR'}->{$_},
$this->{'SUBJECT'}->{$_},
$this->{'CATEGORY'}->{$_}
);
print $fh "$data\n";
}
truncate($fh, tell($fh));
close($fh);
}
else {
warn "can't save bbs info: $path";
}
chmod($Sys->Get('PM-ADM'), $path);
}
#------------------------------------------------------------------------------------------------------------
#
# 掲示板IDセット取得
# -------------------------------------------------------------------------------------
# @param $kind 検索種別('ALL'の場合すべて)
# @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, sort keys %{$this->{'NAME'}};
}
else {
foreach my $key (keys %{$this->{$kind}}) {
if (($this->{$kind}->{$key} eq $name)) {
$n += push @$pBuf, $key;
}
}
}
return $n;
}
#------------------------------------------------------------------------------------------------------------
#
# 掲示板情報取得
# -------------------------------------------------------------------------------------
# @param $kind 情報種別
# @param $key ユーザID
# $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 $dir 掲示板ディレクトリ
# @param $subject 説明
# @param $category 掲示板カテゴリ
# @return 掲示板ID
#
#------------------------------------------------------------------------------------------------------------
sub Add
{
my $this = shift;
my ($name, $dir, $subject, $category) = @_;
my $id = time;
$this->{'NAME'}->{$id} = $name;
$this->{'DIR'}->{$id} = $dir;
$this->{'SUBJECT'}->{$id} = $subject;
$this->{'CATEGORY'}->{$id} = $category;
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->{'NAME'}->{$id};
delete $this->{'DIR'}->{$id};
delete $this->{'SUBJECT'}->{$id};
delete $this->{'CATEGORY'}->{$id};
}
#------------------------------------------------------------------------------------------------------------
#
# 掲示板情報更新
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @param $skey 掲示板名称のキー
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Update
{
my $this = shift;
my ($Sys, $skey) = @_;
# 現在の情報をすべてクリア
$this->{'NAME'} = {};
$this->{'DIR'} = {};
$this->{'SUBJECT'} = {};
$this->{'CATEGORY'} = {};
my $bbsroot = $Sys->Get('BBSPATH');
$skey = 'BBS_TITLE' if ($skey eq '');
# BBSルート対象
my @dirs = ();
if (opendir(my $dh, $bbsroot)) {
@dirs = readdir($dh);
closedir($dh);
}
# 掲示板ルート検索
foreach my $dir (@dirs) {
# ディレクトリ発見, SETTING.TXT存在
if (-d "$bbsroot/$dir" && -e "$bbsroot/$dir/SETTING.TXT") {
my $id = time;
$id++ while (exists $this->{'DIR'}->{$id});
$this->{'DIR'}->{$id} = $dir;
$this->{'CATEGORY'}->{$id} = '0000000001';
my $path = "$bbsroot/$dir/SETTING.TXT";
if (open(my $fh, '<', $path)) {
flock($fh, 2);
my @lines = <$fh>;
close($fh);
map { s/[\r\n]+\z// } @lines;
# SETTING.TXTから必要な情報を取得する
my $f = 0;
foreach (@lines) {
next if ($_ !~ /^(.+?)=(.*)$/);
my ($key, $dat) = ($1, $2);
if ($key eq $skey) {
$this->{'NAME'}->{$id} = $dat;
$f++;
}
elsif ($key eq 'BBS_SUBTITLE') {
$this->{'SUBJECT'}->{$id} = $dat;
$f++;
}
last if ($f == 2);
}
}
else {
warn "can't load setting: $path";
}
}
}
}
#------------------------------------------------------------------------------------------------------------
#
# 掲示板コンテンツ生成 - CreateContents
# -------------------------------------------
# 引 数：$Sys : MELKOR
# $Page : THORIN
# 戻り値：なし
#
#------------------------------------------------------------------------------------------------------------
sub CreateContents
{
my $this = shift;
my ($Sys, $Page) = @_;
# カテゴリ情報を読み込み
my @catSet = ();
my $Category = ANGMAR->new;
$Category->Load($Sys);
$Category->GetKeySet(\@catSet);
$Page->Print('
');
# ここらへんに自分の掲示板の名前を入れる
$Page->Print('0ch+ BBS
');
$Page->Print("Contents
\n");
foreach my $cid (@catSet) {
# カテゴリ出力
my $name = $Category->Get('NAME', $cid);
$Page->Print("$name
\n");
my @keySet = ();
$this->GetKeySet('CATEGORY', $cid, \@keySet);
foreach my $id (@keySet) {
my $name = $this->{'NAME'}->{$id};
my $dir = $this->{'DIR'}->{$id};
# 掲示板リンク出力
$Page->Print(" ");
$Page->Print("$name
\n");
}
$Page->Print('
');
}
my $bbsroot = $Sys->Get('BBSPATH');
my $ver = $Sys->Get('VERSION');
$Page->Print("
$ver\n");
$Page->Flush(1, $Sys->Get('PM-TXT'), "$bbsroot/contents.html");
}
#============================================================================================================
#
# カテゴリ情報管理パッケージ
#
#============================================================================================================
package ANGMAR;
use strict;
#use warnings;
#------------------------------------------------------------------------------------------------------------
#
# コンストラクタ
# -------------------------------------------------------------------------------------
# @param なし
# @return モジュールオブジェクト
#
#------------------------------------------------------------------------------------------------------------
sub new
{
my $class = shift;
my $obj = {
'NAME' => undef,
'SUBJECT' => undef,
};
bless $obj, $class;
return $obj;
}
#------------------------------------------------------------------------------------------------------------
#
# カテゴリ情報読み込み
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Load
{
my $this = shift;
my ($Sys) = @_;
my $path = '.' . $Sys->Get('INFO') . '/category.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->{'NAME'}->{$id} = $elem[1];
$this->{'SUBJECT'}->{$id} = $elem[2];
}
}
else {
warn "can't load category info: $path";
}
}
#------------------------------------------------------------------------------------------------------------
#
# カテゴリ情報保存
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Save
{
my $this = shift;
my ($Sys) = @_;
my $path = '.' . $Sys->Get('INFO') . '/category.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->{'SUBJECT'}->{$_}
);
print $fh "$data\n";
}
truncate($fh, tell($fh));
close($fh);
}
else {
warn "can't save category info: $path";
}
chmod($Sys->Get('PM-ADM'), $path);
}
#------------------------------------------------------------------------------------------------------------
#
# カテゴリIDセット取得
# -------------------------------------------------------------------------------------
# @param $pBuf IDセット格納バッファ
# @return キーセット数
#
#------------------------------------------------------------------------------------------------------------
sub GetKeySet
{
my $this = shift;
my ($pBuf) = @_;
my $n = push @$pBuf, keys %{$this->{'NAME'}};
return $n;
}
#------------------------------------------------------------------------------------------------------------
#
# カテゴリ情報取得
# -------------------------------------------------------------------------------------
# @param $kind 情報種別
# @param $key カテゴリID
# $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 $subject 説明
# @return カテゴリID
#
#------------------------------------------------------------------------------------------------------------
sub Add
{
my $this = shift;
my ($name, $subject) = @_;
my $id = time;
$this->{'NAME'}->{$id} = $name;
$this->{'SUBJECT'}->{$id} = $subject;
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->{'NAME'}->{$id};
delete $this->{'SUBJECT'}->{$id};
}
#============================================================================================================
# Module END
#============================================================================================================
1;
zerochplus_0.7.4/test/module/newrelease.pl 0000644 0000764 0001040 00000013000 12236106655 015651 0 ustar #============================================================================================================
#
# アップデート通知
#
#============================================================================================================
package ZP_NEWRELEASE;
use strict;
#use warnings;
use Encode;
#------------------------------------------------------------------------------------------------------------
#
# モジュールコンストラクタ - new
# -------------------------------------------
# 引 数：なし
# 戻り値：モジュールオブジェクト
#
#------------------------------------------------------------------------------------------------------------
sub new
{
my $class = shift;
my $obj = {
'NEWRELEASE' => undef,
};
bless $obj, $class;
return $obj;
}
#------------------------------------------------------------------------------------------------------------
#
# 初期化 - Init
# -------------------------------------------------------------------------------------
# 引 数：$Sys : MELKOR
# 戻り値：0
#
#------------------------------------------------------------------------------------------------------------
sub Init
{
my $this = shift;
my ($Sys) = @_;
$this->{'NEWRELEASE'} = {
'CheckURL' => 'http://zerochplus.sourceforge.jp/Release.txt',
'Interval' => 60 * 60 * 24, # 24時間
'RawVer' => $Sys->Get('VERSION'),
'CachePATH' => '.' . $Sys->Get('INFO') . '/Release.cgi',
'CachePM' => $Sys->Get('PM-ADM'),
'Update' => 0,
};
}
#------------------------------------------------------------------------------------------------------------
#
# 更新チェック - Check
# -------------------------------------------------------------------------------------
# 引 数：なし
# 戻り値：0
#
#------------------------------------------------------------------------------------------------------------
sub Check
{
my $this = shift;
my $hash = $this->{'NEWRELEASE'};
my $url = $hash->{'CheckURL'};
my $interval = $hash->{'Interval'};
my $rawver = $hash->{'RawVer'};
my @ver;
# 0ch+ BBS n.m.r YYYYMMDD 形式であることをちょっと期待している
# または 0ch+ BBS dev-rREV YYYYMMDD
if ( $rawver =~ /(\d+(?:\.\d+)+)/ ) {
@ver = split /\./, $1;
} elsif ( $rawver =~ /dev-r(\d+)/ ) {
@ver = ( 'dev', $1 );
} else {
@ver = ( 'dev', 0 );
}
my $date = '00000000';
if ( $rawver =~ /(\d{8})/ ) {
$date = $1;
}
my $path = $hash->{'CachePATH'};
# キャッシュの有効期限が過ぎてたらデータをとってくる
if ( !-f $path || ( stat $path )[9] < time - $interval ) {
# 同時接続防止みたいな
utime ( undef, undef, $path );
require('./module/httpservice.pl');
my $proxy = HTTPSERVICE->new;
# URLを指定
$proxy->setURI($url);
# UserAgentを設定
$proxy->setAgent($rawver);
# タイムアウトを設定
$proxy->setTimeout(3);
# とってくるよ
$proxy->request();
# とれた
if ( $proxy->getStatus() eq 200 ) {
if (open(my $fh, (-f $path ? '+<' : '>'), $path)) {
flock($fh, 2);
seek($fh, 0, 0);
binmode($fh);
print $fh $proxy->getContent();
truncate($fh, tell($fh));
close($fh);
}
chmod($hash->{'CachePM'}, $path);
}
}
# 比較部
my @release = ();
if (open(my $fh, '<', $path)) {
flock($fh, 2);
while ( <$fh> ) {
# $l =~ s/\x0d?\x0a?$//;
# samwiseと同等のサニタイジングを行います
$_ =~ s/[\x0d\x0a\0]//g;
$_ =~ s/"/"/g;
$_ =~ s//>/g;
Encode::from_to( $_, 'utf8', 'sjis' );
push @release, $_;
}
close($fh);
}
# 爆弾(BOM)処理
$release[0] =~ s/^\xef\xbb\xbf//;
# n.m.r形式であることを期待している
my @newver = split /\./, $release[0];
# YYYY.MM.DD形式であることを期待している
my $newdate = join '', (split /\./, $release[2], 3);
my $i = 0;
my $newrelease = 0;
# バージョン比較
# とりあえず自verがdevなら無視(下の日付で確認)
if ( $ver[0] ne 'dev' ) {
foreach my $nv ( @newver ) {
my $vv = shift @ver;
if ( $vv < $nv ) {
$newrelease = 1;
} elsif ( $vv > $nv ) {
# なぜかインストール済みの方があたらしい
last;
}
}
}
# よくわかんなかったらあらためて日付で確認する
unless ( $newrelease ) {
if ( $date < $newdate ) {
$newrelease = 1;
}
}
$this->{'NEWRELEASE'}->{'Update'} = $newrelease;
$this->{'NEWRELEASE'}->{'Ver'} = shift @release;
$this->{'NEWRELEASE'}->{'URL'} = 'http://sourceforge.jp/projects/zerochplus/releases/' . shift @release;
$this->{'NEWRELEASE'}->{'Date'} = shift @release;
shift @release; # 4行目(空行)を消す
# 残りはリリースノートとかそういうのが残る
$this->{'NEWRELEASE'}->{'Detail'} = \@release;
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# 設定値取得 - Get
# -------------------------------------------------------------------------------------
# @param $key 取得キー
# $default : デフォルト
# @return 設定値
#
#------------------------------------------------------------------------------------------------------------
sub Get
{
my $this = shift;
my ($key, $default) = @_;
my $val = $this->{'NEWRELEASE'}->{$key};
return (defined $val ? $val : (defined $default ? $default : undef));
}
#------------------------------------------------------------------------------------------------------------
#
# 設定値設定 - Set
# -------------------------------------------------------------------------------------
# @param $key 設定キー
# @param $data 設定値
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Set
{
my $this = shift;
my ($key, $data) = @_;
$this->{'NEWRELEASE'}->{$key} = $data;
}
1;
zerochplus_0.7.4/test/module/orald.pl 0000644 0000764 0001040 00000013721 12236106655 014632 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.4/test/module/peregrin.pl 0000644 0000764 0001040 00000027634 12236106655 015354 0 ustar #============================================================================================================
#
# 管理ログデータ管理モジュール
#
#============================================================================================================
package PEREGRIN;
use strict;
#use warnings;
#------------------------------------------------------------------------------------------------------------
#
# モジュールコンストラクタ - new
# -------------------------------------------
# 引 数：
# 戻り値：モジュールオブジェクト
#
#------------------------------------------------------------------------------------------------------------
sub new
{
my $this = shift;
my $obj = {
'LOG' => undef,
'PATH' => undef,
'FILE' => undef,
'MAX' => undef,
'MAXA' => undef,
'MAXH' => undef,
'MAXS' => undef,
'KIND' => undef,
'NUM' => undef,
};
bless $obj, $this;
return $obj;
}
#------------------------------------------------------------------------------------------------------------
#
# ログ読み込み - Load
# ------------------------------------------------
# 引 数：$Sys : MELKOR
# $log : ログ種類
# $key : スレッドキー(書き込みの場合のみ)
# 戻り値：なし
#
#------------------------------------------------------------------------------------------------------------
sub Load
{
my $this = shift;
my ($Sys, $log, $key) = @_;
$this->{'LOG'} = [];
$this->{'PATH'} = '';
$this->{'FILE'} = '';
$this->{'KIND'} = 0;
$this->{'MAX'} = $Sys->Get('ERRMAX');
$this->{'MAXA'} = $Sys->Get('ADMMAX');
$this->{'MAXH'} = $Sys->Get('HSTMAX');
$this->{'MAXS'} = $Sys->Get('SUBMAX');
$this->{'NUM'} = 0;
my $file = '';
my $kind = 0;
if ($log eq 'ERR') { $file = 'errs.cgi'; $kind = 1; } # エラーログ
if ($log eq 'THR') { $file = 'IP.cgi'; $kind = 2; } # スレッド作成ログ
if ($log eq 'WRT') { $file = "$key.cgi"; $kind = 3; } # 書き込みログ
if ($log eq 'HST') { $file = "HOST.cgi"; $kind = 5; } # ホストログ
if ($log eq 'SMB') { $file = "samba.cgi"; $kind = 6; } # Sambaログ
if ($log eq 'SBH') { $file = "houshi.cgi"; $kind = 7; } # Samba規制ログ
$this->{'KIND'} = $kind;
my $path = $Sys->Get('BBSPATH') . '/' . $Sys->Get('BBS') . '/log';
if ($kind) {
if (open(my $fh, '<', "$path/$file")) {
flock($fh, 2);
my @lines = <$fh>;
close($fh);
push @{$this->{'LOG'}}, @lines;
$this->{'NUM'} = scalar(@lines);
}
$this->{'PATH'} = $path;
$this->{'FILE'} = $file;
}
}
#------------------------------------------------------------------------------------------------------------
#
# エラーログ書き込み - SaveError
# -------------------------------------------
# 引 数：$Sys : MELKOR
# 戻り値：なし
#
#------------------------------------------------------------------------------------------------------------
sub Save
{
my $this = shift;
my ($Sys) = @_;
my $path = "$this->{'PATH'}/$this->{'FILE'}";
if ($this->{'KIND'}) {
chmod($Sys->Get('PM-LOG'), $path);
if (open(my $fh, (-f $path ? '+<' : '>'), $path)) {
flock($fh, 2);
seek($fh, 0, 0);
print $fh @{$this->{'LOG'}};
truncate($fh, tell($fh));
close $fh;
}
chmod($Sys->Get('PM-LOG'), $path);
}
}
#------------------------------------------------------------------------------------------------------------
#
# ログ追加 - Set
# -------------------------------------------
# 引 数：$I : ISILDUR
# $data1 : 汎用データ1
# $data2 : 汎用データ2
# $koyuu : 端末固有識別子
# $data : DAT形式のログ
# $mode : ID末尾分
# 戻り値：なし
#
#------------------------------------------------------------------------------------------------------------
sub Set
{
my $this = shift;
my ($I, $data1, $data2, $koyuu, $data, $mode) = @_;
$mode = '0' if (! defined $mode);
my $host = $ENV{'REMOTE_HOST'};
if ($mode ne '0') {
if ($mode eq 'P') {
$host = "$host($koyuu)$ENV{'REMOTE_ADDR'}";
}
else {
$host = "$host($koyuu)";
}
}
# 読み込み済み
my $kind = $this->{'KIND'};
if ($kind) {
my $tm = time;
my $work = '';
if ($kind == 3) {
my @logdat = split(/<>/, $data, -1);
$work = join('<>',
$logdat[0],
$logdat[1],
$logdat[2],
substr($logdat[3], 0, 30),
$logdat[4],
$host,
$ENV{'REMOTE_ADDR'},
$data1,
$ENV{'HTTP_USER_AGENT'}
);
}
else {
$work = join('<>',
$tm,
$data1,
$data2,
$host
);
}
my $log = $this->{'LOG'};
# 末尾へ追加
push @$log, "$work\n";
my $nm = ++$this->{'NUM'};
my $bf = 0;
if ($kind == 1) { $bf = $nm - $this->{'MAX'}; } # エラーログ
if ($kind == 2) { $bf = $nm - $this->{'MAXS'}; } # スレッドログ
# if ($kind == 3) { $bf = $nm - $I->Get('timecount'); } # 書き込みログ
if ($kind == 5) { $bf = $nm - $this->{'MAXH'}; } # ホストログ
if ($kind == 6) { $bf = $nm - $this->{'MAX'}; } # samba
if ($kind == 7) { $bf = $nm - $this->{'MAX'}; } # houshi
# 先頭ログの削除
splice @$log, 0, $bf;
$this->{'NUM'} = scalar(@$log);
}
}
#------------------------------------------------------------------------------------------------------------
#
# ログ取得 - Get
# -------------------------------------------
# 引 数：$ln : ログ番号
# 戻り値：@data
#
#------------------------------------------------------------------------------------------------------------
sub Get
{
my $this = shift;
my ($ln) = @_;
if ($ln >= 0 && $ln < $this->{'NUM'}) {
my $work = $this->{'LOG'}->[$ln];
$work =~ s/[\r\n]+\z//;
my @data = split(/<>/, $work, -1);
return @data;
}
else {
return undef;
}
}
#------------------------------------------------------------------------------------------------------------
#
# ログ数取得
# -------------------------------------------------------------------------------------
# @param なし
# @return レス数
#
#------------------------------------------------------------------------------------------------------------
sub Size
{
my $this = shift;
return $this->{'NUM'};
}
#------------------------------------------------------------------------------------------------------------
#
# ログ検索 - Search
# -------------------------------------------
# 引 数：$data : サーチキー
# $f : サーチモード
# $mode : エージェント
# $host : リモートホスト
# $count : 検索数
# 戻り値：各種データ
#
#------------------------------------------------------------------------------------------------------------
sub Search
{
my $this = shift;
my ($data, $f, $mode, $host, $count) = @_;
my $kind = $this->{'KIND'};
# data1で検索
if ($f == 1) {
my $max = scalar(@{$this->{'LOG'}}) - 1;
for my $i (reverse(0 .. $max)) {
my $log = $this->{'LOG'}->[$i];
$log =~ s/[\r\n]+\z//;
my ($key, $val) = (split /<>/, $log, -1)[$kind == 3 ? (5, 7) : (1, 3)];
$key = $1 if ($key =~ /\((.*)\)/);
if ($data eq $key) {
return $val;
}
}
}
else {
if ($mode ne '0') {
if ($mode eq 'P') {
$host = "$host($data)$ENV{'REMOTE_ADDR'}";
}
else {
$host = "$host($data)";
}
}
# host出現数
if ($f == 2) {
my $num = 0;
my $max = scalar(@{$this->{'LOG'}}) - 1;
$count = $max + 1 if (!defined $count);
my $min = 1 + $max - $count;
$min = 0 if ($min < 0);
for my $i (reverse($min .. $max)) {
my $log = $this->{'LOG'}->[$i];
$log =~ s/[\r\n]+\z//;
my $key = (split /<>/, $log, -1)[$kind == 3 ? 5 : $kind == 5 ? 1 : 3];
$key = $1 if ($key =~ /\((.*)\)/);
if ($data eq $key) {
$num++;
}
}
return $num;
}
# THR
elsif ($f == 3) {
my $num = 0;
my $max = scalar(@{$this->{'LOG'}}) - 1;
$count = $max + 1 if (! defined $count);
my $min = 1 + $max - $count;
$min = 0 if ($min < 0);
for my $i (reverse($min .. $max)) {
my $log = $this->{'LOG'}->[$i];
$log =~ s/[\r\n]+\z//;
my ($key, $val) = (split /<>/, $log, -1)[1, 3];
$val = $1 if ($val =~ /\((.*)\)/);
if ($data eq $val) {
$num++;
}
}
return $num;
}
}
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# 時間判定 - IsTime
# -------------------------------------------
# 引 数：$tmn : 判定時間(秒)
# $host : リモートホスト
# 戻り値：時間内:残り秒数,時間外:0
# 備 考：最終ログから$tmn秒経過したかどうかを判定
#
#------------------------------------------------------------------------------------------------------------
sub IsTime
{
my $this = shift;
my ($tmn, $host) = @_;
my $kind = $this->{'KIND'};
return 0 if ($kind == 3);
my $nw = time;
my $n = scalar(@{$this->{'LOG'}});
for my $i (reverse(0 .. $n - 1)) {
my $log = $this->{'LOG'}->[$i];
$log =~ s/[\r\n]+\z//;
my ($tm, undef, undef, $val) = split(/<>/, $log, -1);
if ($host eq $val) {
# 残り秒数を返す
my $rem = $tmn - ($nw - $tm);
$rem = 0 if ($rem < 0);
return $rem;
}
}
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# Samba判定 - IsSamba
# -------------------------------------------
# 引 数：$sb : Samba時間(秒)
# $host : リモートホスト
# 戻り値：$n : Samba回数
# $tm : 必要待ち時間
#
#------------------------------------------------------------------------------------------------------------
sub IsSamba
{
my $this = shift;
my ($sb, $host) = @_;
my $kind = $this->{'KIND'};
return (0, 0) if ($kind != 6);
my $nw = time;
my $n = scalar(@{$this->{'LOG'}});
my @iplist = ();
my $ptm = $nw;
for my $i (reverse(0 .. $n - 1)) {
my $log = $this->{'LOG'}->[$i];
$log =~ s/[\r\n]+\z//;
my ($tm, undef, undef, $val) = split(/<>/, $log, -1);
next if ($host ne $val);
last if ($sb <= $ptm - $tm);
push @iplist, $tm;
$ptm = $tm;
}
$n = scalar(@iplist);
if ($n) {
return ($n, ($nw - $iplist[0]));
}
return (0, 0);
}
#------------------------------------------------------------------------------------------------------------
#
# 奉仕活動中判定 - IsHoushi
# -------------------------------------------
# 引 数：$houshi : 奉仕活動時間(分)
# $host : リモートホスト
# 戻り値：$ishoushi : 奉仕活動中
# $tm : 必要待ち時間(分)
#
#------------------------------------------------------------------------------------------------------------
sub IsHoushi
{
my $this = shift;
my ($houshi, $host) = @_;
my $kind = $this->{'KIND'};
return (0, 0) if ($kind != 7);
my $nw = time;
my $n = scalar(@{$this->{'LOG'}});
for my $i (reverse(0 .. $n - 1)) {
my $log = $this->{'LOG'}->[$i];
$log =~ s/[\r\n]+\z//;
my ($tm, undef, undef, $val) = split(/<>/, $log, -1);
next if ($host ne $val);
my $intv = $nw - $tm;
last if ($houshi * 60 <= $intv);
return (1, $houshi - ($intv - ($intv % 60 || 60)) / 60);
}
return (0, 0);
}
#------------------------------------------------------------------------------------------------------------
#
# スレッド立てすぎ判定 - IsTatesugi
# -------------------------------------------
# 引 数：$hour : スレッド作成数規制時間(時間)
# 戻り値：$count : スレッド数
#
#------------------------------------------------------------------------------------------------------------
sub IsTatesugi
{
my $this = shift;
my ($hour) = @_;
my $kind = $this->{'KIND'};
return 0 if ($kind != 2);
my $nw = time;
my $n = scalar(@{$this->{'LOG'}});
my $count = 0;
for my $i (reverse(0 .. $n - 1)) {
my $log = $this->{'LOG'}->[$i];
$log =~ s/[\r\n]+\z//;
my $tm = (split(/<>/, $log, -1))[0];
last if ($hour * 3600 <= $nw - $tm);
$count++;
}
return $count;
}
#------------------------------------------------------------------------------------------------------------
#
# ログ1行削除 - Delete
# -------------------------------------------
# 引 数：$num
# 戻り値：なし
#
#------------------------------------------------------------------------------------------------------------
sub Delete
{
my $this = shift;
my ($num) = @_;
$this->{'NUM'} -= scalar splice @{$this->{'LOG'}}, $num, 1;
}
#============================================================================================================
# モジュール終端
#============================================================================================================
1;
zerochplus_0.7.4/test/module/radagast.pl 0000644 0000764 0001040 00000013373 12236106655 015322 0 ustar #============================================================================================================
#
# cookie管理モジュール
#
#============================================================================================================
package RADAGAST;
use strict;
#use warnings;
use Encode;
#------------------------------------------------------------------------------------------------------------
#
# コンストラクタ
# -------------------------------------------------------------------------------------
# @param なし
# @return モジュールオブジェクト
#
#------------------------------------------------------------------------------------------------------------
sub new
{
my $class = shift;
my $obj = {
'COOKIE' => undef,
};
bless $obj, $class;
return $obj;
}
#------------------------------------------------------------------------------------------------------------
#
# cookie値取得
# -------------------------------------------------------------------------------------
# @param なし
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Init
{
my $this = shift;
$this->{'COOKIE'} = {};
if ($ENV{'HTTP_COOKIE'}) {
my @pairs = split(/;\s*/, $ENV{'HTTP_COOKIE'});
foreach (@pairs) {
my ($name, $value) = split(/=/, $_, 2);
$value =~ s/^"|"$//g;
$value =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/pack('H2', $1)/eg;
$this->{'COOKIE'}->{$name} = $value;
}
return 1;
}
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# cookie値設定
# -------------------------------------------------------------------------------------
# @param $key キー
# @param $val 設定値
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Set
{
my $this = shift;
my ($key, $val, $enc) = @_;
Encode::from_to($val, 'sjis', $enc) if (defined $enc);
$this->{'COOKIE'}->{$key} = $val;
}
#------------------------------------------------------------------------------------------------------------
#
# cookie値取得
# -------------------------------------------------------------------------------------
# @param $key キー
# $default : デフォルト
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Get
{
my $this = shift;
my ($key, $default, $enc) = @_;
my $val = $this->{'COOKIE'}->{$key};
Encode::from_to($val, $enc, 'sjis') if (defined $val && defined $enc);
return (defined $val ? $val : (defined $default ? $default : undef));
}
#------------------------------------------------------------------------------------------------------------
#
# cookie値削除
# -------------------------------------------------------------------------------------
# @param $key キー
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Delete
{
my $this = shift;
my ($key) = @_;
delete $this->{'COOKIE'}->{$key};
}
#------------------------------------------------------------------------------------------------------------
#
# cookie値存在確認
# -------------------------------------------------------------------------------------
# @param $key キー
# @return キーが存在したらtrue
#
#------------------------------------------------------------------------------------------------------------
sub IsExist
{
my $this = shift;
my ($key) = @_;
return exists($this->{'COOKIE'}->{$key});
}
#------------------------------------------------------------------------------------------------------------
#
# cookie出力
# -------------------------------------------------------------------------------------
# @param $Page 出力モジュール
# @param $path cookieパス
# @param $limit 有効期限
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Out
{
my $this = shift;
my ($Page, $path, $limit) = @_;
# 日付情報の設定
my @gmt = gmtime(time + $limit * 60);
my @week = qw(Sun Mon Tue Wed Thu Fri Sat);
my @month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
# 有効期限文字列生成
my $date = sprintf('%s, %02d-%s-%04d %02d:%02d:%02d GMT',
$week[$gmt[6]], $gmt[3], $month[$gmt[4]], $gmt[5] + 1900,
$gmt[2], $gmt[1], $gmt[0]);
# 設定されているcookieを全て出力する
foreach my $key (keys %{$this->{'COOKIE'}}) {
my $value = $this->{'COOKIE'}->{$key};
$value =~ s/([^\w])/'%'.unpack('H2', $1)/eg;
$Page->Print("Set-Cookie: $key=\"$value\"; expires=$date; path=$path\n");
}
}
#------------------------------------------------------------------------------------------------------------
#
# cookie取得用javascript出力
# -------------------------------------------------------------------------------------
# @param $Page 出力モジュール
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Print
{
my $this = shift;
my ($Page) = @_;
$Page->Print(<
/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.4/test/module/session.pl 0000644 0000764 0001040 00000016645 12236106655 015224 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.4/test/module/thorin.pl 0000644 0000764 0001040 00000006763 12236106655 015044 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.4/test/module/ungoliants.pl 0000644 0000764 0001040 00000051537 12236106655 015723 0 ustar #============================================================================================================
#
# キャップ管理モジュール
# -------------------------------------------------------------------------------------
# このモジュールはキャップ情報を管理します。
# 以下の3つのパッケージによって構成されます
#
# UNGOLIANT : キャップ情報管理
# SHELOB : キャップグループ情報管理
# SECURITY : セキュリティインタフェイス
#
#============================================================================================================
#============================================================================================================
#
# キャップ管理パッケージ
#
#============================================================================================================
package UNGOLIANT;
use strict;
#use warnings;
#------------------------------------------------------------------------------------------------------------
#
# コンストラクタ
# -------------------------------------------------------------------------------------
# @param なし
# @return モジュールオブジェクト
#
#------------------------------------------------------------------------------------------------------------
sub new
{
my $class = shift;
my $obj = {
'NAME' => undef,
'PASS' => undef,
'FULL' => undef,
'EXPL' => undef,
'SYSAD' => undef,
'CUSTOMID' => 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'} = {};
$this->{'CUSTOMID'} = {};
my $path = '.' . $Sys->Get('INFO') . '/caps.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) { # 7
warn "invalid line in $path";
next;
}
push @elem, '';
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];
$this->{'CUSTOMID'}->{$id} = $elem[6];
}
}
}
#------------------------------------------------------------------------------------------------------------
#
# キャップ情報保存
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Save
{
my $this = shift;
my ($Sys) = @_;
my $path = '.' . $Sys->Get('INFO') . '/caps.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->{'PASS'}->{$_},
$this->{'FULL'}->{$_},
$this->{'EXPL'}->{$_},
$this->{'SYSAD'}->{$_},
$this->{'CUSTOMID'}->{$_},
);
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, $customid) = @_;
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;
$this->{'CUSTOMID'}->{$id} = $customid;
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};
delete $this->{'CUSTOMID'}->{$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 SHELOB;
use strict;
#use warnings;
#------------------------------------------------------------------------------------------------------------
#
# コンストラクタ
# -------------------------------------------------------------------------------------
# @param なし
# @return モジュールオブジェクト
#
#------------------------------------------------------------------------------------------------------------
sub new
{
my $class = shift;
my $obj = {
'NAME' => undef,
'EXPL' => undef,
'COLOR' => undef,
'AUTH' => undef,
'CAPS' => undef,
'ISCOMMON' => undef,
};
bless $obj, $class;
return $obj;
}
#------------------------------------------------------------------------------------------------------------
#
# グループ情報読み込み
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @param $sysgroup 共通グループかどうか
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Load
{
my $this = shift;
my ($Sys, $sysgroup) = @_;
# ハッシュ初期化
$this->{'NAME'} = {};
$this->{'EXPL'} = {};
$this->{'COLOR'} = {};
$this->{'AUTH'} = {};
$this->{'CAPS'} = {};
$this->{'ISCOMMON'} = {};
my $path = '.' . $Sys->Get('INFO') . '/capgroups.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];
$elem[4] = '' if (!defined $elem[4]);
$elem[5] = '' if (!defined $elem[5]);
$this->{'NAME'}->{$id} = $elem[1];
$this->{'EXPL'}->{$id} = $elem[2];
$this->{'AUTH'}->{$id} = $elem[3];
$this->{'CAPS'}->{$id} = $elem[4];
$this->{'COLOR'}->{$id} = $elem[5];
$this->{'ISCOMMON'}->{$id} = 1;
}
}
if (!$sysgroup) {
$path = $Sys->Get('BBSPATH') . '/' . $Sys->Get('BBS') . '/info/capgroups.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];
$elem[4] = '' if (!defined $elem[4]);
$elem[5] = '' if (!defined $elem[5]);
$this->{'NAME'}->{$id} = $elem[1];
$this->{'EXPL'}->{$id} = $elem[2];
$this->{'AUTH'}->{$id} = $elem[3];
$this->{'CAPS'}->{$id} = $elem[4];
$this->{'COLOR'}->{$id} = $elem[5];
$this->{'ISCOMMON'}->{$id} = 0;
}
}
}
}
#------------------------------------------------------------------------------------------------------------
#
# グループ情報保存
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @param $sysgroup 共通グループかどうか
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Save
{
my $this = shift;
my ($Sys, $sysgroup) = @_;
my $commflg = ($sysgroup ? 1 : 0);
my $path;
if ($commflg) {
$path = '.' . $Sys->Get('INFO') . '/capgroups.cgi';
}
else {
$path = $Sys->Get('BBSPATH') . '/' . $Sys->Get('BBS') . '/info/capgroups.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'}}) {
next if ($this->{'ISCOMMON'}->{$_} ne $commflg);
my $data = join('<>',
$_,
$this->{'NAME'}->{$_},
$this->{'EXPL'}->{$_},
$this->{'AUTH'}->{$_},
$this->{'CAPS'}->{$_},
$this->{'COLOR'}->{$_},
);
print $fh "$data\n";
}
truncate($fh, tell($fh));
close($fh);
}
chmod($Sys->Get('PM-ADM'), $path);
}
#------------------------------------------------------------------------------------------------------------
#
# グループIDセット取得
# -------------------------------------------------------------------------------------
# @param $pBuf IDセット格納バッファ
# @param $sysgroup 共通グループかどうか
# @return グループID数
#
#------------------------------------------------------------------------------------------------------------
sub GetKeySet
{
my $this = shift;
my ($pBuf, $sysgroup) = @_;
my $n = 0;
my $commflg = ($sysgroup ? 1 : 0);
foreach (keys %{$this->{'NAME'}}) {
next if ($this->{'ISCOMMON'}->{$_} ne $commflg);
$n += push @$pBuf, $_;
}
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 $caps キャップセット
# @return グループID
#
#------------------------------------------------------------------------------------------------------------
sub Add
{
my $this = shift;
my ($name, $explan, $color, $authors, $caps, $sysgroup) = @_;
my $id = time;
$this->{'NAME'}->{$id} = $name;
$this->{'EXPL'}->{$id} = $explan;
$this->{'COLOR'}->{$id} = $color;
$this->{'AUTH'}->{$id} = $authors;
$this->{'CAPS'}->{$id} = $caps;
$this->{'ISCOMMON'}->{$id} = ($sysgroup ? 1 : 0);
return $id;
}
#------------------------------------------------------------------------------------------------------------
#
# グループキャップ追加
# -------------------------------------------------------------------------------------
# @param $id グループID
# @param $user 追加キャップID
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub AddCap
{
my $this = shift;
my ($id, $cap) = @_;
my @users = split(/\,/, $this->{'CAPS'}->{$id});
my @match = grep($cap, @users);
my $nuser = scalar(@match);
# 登録済みのキャップは重複登録しない
if ($nuser == 0) {
$this->{'CAPS'}->{$id} .= ",$cap";
}
}
#------------------------------------------------------------------------------------------------------------
#
# グループ情報設定
# -------------------------------------------------------------------------------------
# @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->{'COLOR'}->{$id};
delete $this->{'AUTH'}->{$id};
delete $this->{'CAPS'}->{$id};
delete $this->{'ISCOMMON'}->{$id};
}
#------------------------------------------------------------------------------------------------------------
#
# 所属キャップグループ取得
# -------------------------------------------------------------------------------------
# @param $id キャップID
# @return キャップが所属しているグループID
#
#------------------------------------------------------------------------------------------------------------
sub GetBelong
{
my $this = shift;
my ($id) = @_;
my $ret = '';
foreach my $group (keys %{$this->{'CAPS'}}) {
my @users = split(/\,/, $this->{'CAPS'}->{$group});
foreach my $user (@users) {
if ($id eq $user) {
$ret = $group;
# 共通グループを優先
if ($this->{'ISCOMMON'}->{$group}) {
return $ret;
}
}
}
}
return $ret;
}
#============================================================================================================
#
# セキュリティ管理パッケージ
#
#============================================================================================================
package SECURITY;
use strict;
#use warnings;
#------------------------------------------------------------------------------------------------------------
#
# コンストラクタ
# -------------------------------------------------------------------------------------
# @param なし
# @return モジュールオブジェクト
#
#------------------------------------------------------------------------------------------------------------
sub new
{
my $class = shift;
my $obj = {
'SYS' => undef,
'CAP' => undef,
'GROUP' => undef,
};
bless $obj, $class;
return $obj;
}
#------------------------------------------------------------------------------------------------------------
#
# 初期化
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Init
{
my $this = shift;
my ($Sys) = @_;
$this->{'SYS'} = $Sys;
# 2重ロード防止
if (! defined $this->{'CAP'}) {
$this->{'CAP'} = UNGOLIANT->new;
$this->{'GROUP'} = SHELOB->new;
$this->{'CAP'}->Load($Sys);
}
}
#------------------------------------------------------------------------------------------------------------
#
# 情報取得
# -------------------------------------------------------------------------------------
# @param $id キャップ/グループID
# @param $key 取得キー
# @param $f 取得種別
# @param $default デフォルト
# @return 正式なキャップなら1を返す
#
#------------------------------------------------------------------------------------------------------------
sub Get
{
my $this = shift;
my ($id, $key, $f, $default) = @_;
if ($f) {
return $this->{'CAP'}->Get($key, $id, $default);
}
else {
return $this->{'GROUP'}->Get($key, $id, $default);
}
}
#------------------------------------------------------------------------------------------------------------
#
# キャップID取得
# -------------------------------------------------------------------------------------
# @param $pass パスワード
# @return パスワードに対応するキャップID
#
#------------------------------------------------------------------------------------------------------------
sub GetCapID
{
my $this = shift;
my ($pass) = @_;
my $Cap = $this->{'CAP'};
my @capSet = ();
$Cap->GetKeySet('ALL', '', \@capSet);
foreach my $id (@capSet) {
my $capPass = $Cap->GetStrictPass($pass, $id);
if ($capPass eq $Cap->Get('PASS', $id)) {
return $id;
}
}
return '';
}
#------------------------------------------------------------------------------------------------------------
#
# 権限判定前グループ情報準備
# -------------------------------------------------------------------------------------
# @param $bbs 適応個所
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub SetGroupInfo
{
my $this = shift;
my ($bbs) = @_;
my $oldBBS = $this->{'SYS'}->Get('BBS');
$this->{'SYS'}->Set('BBS', $bbs);
$this->{'GROUP'}->Load($this->{'SYS'});
$this->{'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->{'CAP'}->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 $authors = $this->{'GROUP'}->Get('AUTH', $group);
my @authors = split(/\,/, $authors);
foreach my $auth (@authors) {
return 1 if ($auth == $author);
}
return 0;
}
#============================================================================================================
# Module END
#============================================================================================================
1;
zerochplus_0.7.4/test/module/vara.pl 0000644 0000764 0001040 00000062046 12236106655 014466 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.4/test/module/varda.pl 0000644 0000764 0001040 00000051647 12236106655 014637 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("\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(<");
}
# 看板画像にリンクはなし
else {
$Page->Print("
");
}
$Page->Print("
MENU
# サブバナーの表示(表示したら空行をひとつ挿入)
if ($this->{'BANNER'}->PrintSub($Page)) {
$Page->Print("\n");
}
}
#------------------------------------------------------------------------------------------------------------
#
# index.html生成(スレッドプレビュー部分)
# -------------------------------------------------------------------------------------
# @param $Page
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintIndexPreview
{
my $this = shift;
my ($Page) = @_;
# 拡張機能ロード
require './module/athelas.pl';
my $Plugin = ATHELAS->new;
$Plugin->Load($this->{'SYS'});
# 有効な拡張機能一覧を取得
my @commands = ();
my @pluginSet = ();
$Plugin->GetKeySet('VALID', 1, \@pluginSet);
my $count = 0;
foreach my $id (@pluginSet) {
# タイプがread.cgiの場合はロードして実行
if ($Plugin->Get('TYPE', $id) & 8) {
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);
}
}
}
require './module/gondor.pl';
my $Dat = ARAGORN->new;
my @threadSet = ();
$this->{'THREADS'}->GetKeySet('ALL', '', \@threadSet);
# 前準備
my $prevNum = $this->{'SET'}->Get('BBS_THREAD_NUMBER');
my $threadNum = (scalar(@threadSet) > $prevNum ? $prevNum : scalar(@threadSet));
my $tblCol = $this->{'SET'}->Get('BBS_THREAD_COLOR');
my $ttlCol = $this->{'SET'}->Get('BBS_SUBJECT_COLOR');
my $prevT = $threadNum;
my $nextT = ($threadNum > 1 ? 2 : 1);
my $Conv = $this->{'CONV'};
my $basePath = $this->{'SYS'}->Get('BBSPATH') . '/' . $this->{'SYS'}->Get('BBS');
my $max = $this->{'SYS'}->Get('SUBMAX');
my $cnt = 0;
foreach my $key (@threadSet) {
last if (++$cnt > $prevNum || $cnt > $max);
my $subject = $this->{'THREADS'}->Get('SUBJECT', $key);
my $res = $this->{'THREADS'}->Get('RES', $key);
$nextT = 1 if ($cnt == $threadNum);
# ヘッダ部分の表示
$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(<
KAKIKO
# カウンタの更新
$nextT++;
$prevT++;
$prevT = 1 if ($cnt == 1);
}
}
#------------------------------------------------------------------------------------------------------------
#
# index.html生成(フッタ部分)
# -------------------------------------------------------------------------------------
# @param $Page
# @param $Caption
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintIndexFoot
{
my $this = shift;
my ($Page, $Caption) = @_;
my $Sys = $this->{'SYS'};
my $Set = $this->{'SET'};
my $tblCol = $Set->Get('BBS_MAKETHREAD_COLOR');
my $cgipath = $Sys->Get('CGIPATH');
my $bbs = $Sys->Get('BBS');
my $ver = $Sys->Get('VERSION');
my $samba = int ($Set->Get('BBS_SAMBATIME', '') eq ''
? $Sys->Get('DEFSAMBA') : $Set->Get('BBS_SAMBATIME'));
my $tm = time;
# スレッド作成画面を別画面で表示
if ($Set->Equal('BBS_PASSWORD_CHECK', 'checked')) {
$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(<
FORM
}
# スレッド作成フォームはindexと同じ画面に表示
else {
$Page->Print(<
FORM
}
# footの表示
$Caption->Load($Sys, 'FOOT');
$Caption->Print($Page, $Set);
$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(<
HTML
}
#------------------------------------------------------------------------------------------------------------
#
# エラーの表示
# -------------------------------------------------------------------------------------
# @param $pLog ログ用
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintError
{
my $this = shift;
my ($pLog) = @_;
my ($Page, $ecode);
$Page = $this->{'INN'};
# エラーコードの抽出
$ecode = pop @$pLog;
$Page->Print(<
$processNameを正常に完了しました。
処理ログ
HTML
# ログの表示
foreach $text (@$pLog) {
$Page->Print(" $text
\n");
}
$Page->Print(<
HTML
}
#============================================================================================================
# モジュール終端
#============================================================================================================
1;
zerochplus_0.7.4/test/mordor/sys.bbs.pl 0000644 0000764 0001040 00000077367 12236106656 015152 0 ustar #============================================================================================================
#
# システム管理 - 掲示板 モジュール
# sys.bbs.pl
# ---------------------------------------------------------------------------
# 2004.01.31 start
#
#============================================================================================================
package MODULE;
use strict;
#use warnings;
#------------------------------------------------------------------------------------------------------------
#
# コンストラクタ
# -------------------------------------------------------------------------------------
# @param なし
# @return モジュールオブジェクト
#
#------------------------------------------------------------------------------------------------------------
sub new
{
my $this = shift;
my ($obj, @LOG);
$obj = {
LOG => \@LOG
};
bless $obj, $this;
return $obj;
}
#------------------------------------------------------------------------------------------------------------
#
# 表示メソッド
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @param $Form SAMWISE
# @param $pSys 管理システム
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub DoPrint
{
my $this = shift;
my ($Sys, $Form, $pSys) = @_;
my ($BASE, $Page, $subMode);
require './mordor/sauron.pl';
$BASE = SAURON->new;
# 管理情報を登録
$Sys->Set('ADMIN', $pSys);
# 管理マスタオブジェクトの生成
$Page = $BASE->Create($Sys, $Form);
$subMode = $Form->Get('MODE_SUB');
# メニューの設定
SetMenuList($BASE, $pSys);
if ($subMode eq 'LIST') { # 掲示板一覧画面
PrintBBSList($Page, $Sys, $Form);
}
elsif ($subMode eq 'CREATE') { # 掲示板作成画面
PrintBBSCreate($Page, $Sys, $Form);
}
elsif ($subMode eq 'DELETE') { # 掲示板削除確認画面
PrintBBSDelete($Page, $Sys, $Form);
}
elsif ($subMode eq 'CATCHANGE') { # 掲示板カテゴリ変更画面
PrintBBScategoryChange($Page, $Sys, $Form);
}
elsif ($subMode eq 'CATEGORY') { # カテゴリ一覧画面
PrintCategoryList($Page, $Sys, $Form);
}
elsif ($subMode eq 'CATEGORYADD') { # カテゴリ追加画面
PrintCategoryAdd($Page, $Sys, $Form);
}
elsif ($subMode eq 'CATEGORYDEL') { # カテゴリ削除画面
PrintCategoryDelete($Page, $Sys, $Form);
}
elsif ($subMode eq 'COMPLETE') { # 処理完了画面
$Sys->Set('_TITLE', 'Process Complete');
$BASE->PrintComplete('掲示板処理', $this->{'LOG'});
}
elsif ($subMode eq 'FALSE') { # 処理失敗画面
$Sys->Set('_TITLE', 'Process Failed');
$BASE->PrintError($this->{'LOG'});
}
$BASE->Print($Sys->Get('_TITLE'), 1);
}
#------------------------------------------------------------------------------------------------------------
#
# 機能メソッド
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @param $Form SAMWISE
# @param $pSys 管理システム
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub DoFunction
{
my $this = shift;
my ($Sys, $Form, $pSys) = @_;
my ($subMode, $err);
# 管理情報を登録
$Sys->Set('ADMIN', $pSys);
$subMode = $Form->Get('MODE_SUB');
$err = 0;
if ($subMode eq 'CREATE') { # 掲示板作成
$err = FunctionBBSCreate($Sys, $Form, $this->{'LOG'});
}
elsif ($subMode eq 'DELETE') { # 掲示板削除
$err = FunctionBBSDelete($Sys, $Form, $this->{'LOG'});
}
elsif ($subMode eq 'CATCHANGE') { # カテゴリ変更
$err = FunctionCategoryChange($Sys, $Form, $this->{'LOG'});
}
elsif ($subMode eq 'CATADD') { # カテゴリ追加
$err = FunctionCategoryAdd($Sys, $Form, $this->{'LOG'});
}
elsif ($subMode eq 'CATDEL') { # カテゴリ削除
$err = FunctionCategoryDelete($Sys, $Form, $this->{'LOG'});
}
elsif ($subMode eq 'UPDATE') { # 掲示板情報更新
$err = FunctionBBSInfoUpdate($Sys, $Form, $this->{'LOG'});
}
elsif ($subMode eq 'UPDATEBBS') { # 掲示板更新
$err = FunctionBBSUpdate($Sys, $Form, $this->{'LOG'});
}
# 処理結果表示
if ($err) {
$pSys->{'LOGGER'}->Put($Form->Get('UserName'), "BBS($subMode)", "ERROR:$err");
push @{$this->{'LOG'}}, $err;
$Form->Set('MODE_SUB', 'FALSE');
}
else {
$pSys->{'LOGGER'}->Put($Form->Get('UserName'), "BBS($subMode)", 'COMPLETE');
$Form->Set('MODE_SUB', 'COMPLETE');
}
$this->DoPrint($Sys, $Form, $pSys);
}
#------------------------------------------------------------------------------------------------------------
#
# メニューリスト設定
# -------------------------------------------------------------------------------------
# @param $Base SAURON
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub SetMenuList
{
my ($Base, $pSys) = @_;
$Base->SetMenu('掲示板一覧', "'sys.bbs','DISP','LIST'");
# システム管理権限のみ
if ($pSys->{'SECINFO'}->IsAuthority($pSys->{'USER'}, $ZP::AUTH_SYSADMIN, '*')) {
$Base->SetMenu('掲示板作成', "'sys.bbs','DISP','CREATE'");
$Base->SetMenu('
HTML
if ($ecode == 1000) {
$Page->Print(" ERROR:$ecode - 本機能\の処理を実行する権限がありません。\n");
}
elsif ($ecode == 1001) {
$Page->Print(" ERROR:$ecode - 入力必須項目が空欄になっています。\n");
}
elsif ($ecode == 1002) {
$Page->Print(" ERROR:$ecode - 設定項目に規定外の文字が使用されています。\n");
}
elsif ($ecode == 2000) {
$Page->Print(" ERROR:$ecode - 掲示板ディレクトリの作成に失敗しました。
\n");
$Page->Print(" パーミッション、または既に同名の掲示板が作成されていないかを確認してください。\n");
}
elsif ($ecode == 2001) {
$Page->Print(" ERROR:$ecode - SETTING.TXTの生成に失敗しました。\n");
}
elsif ($ecode == 2002) {
$Page->Print(" ERROR:$ecode - 掲示板構\成要素の生成に失敗しました。\n");
}
elsif ($ecode == 2003) {
$Page->Print(" ERROR:$ecode - 過去ログ初期情報の生成に失敗しました。\n");
}
elsif ($ecode == 2004) {
$Page->Print(" ERROR:$ecode - 掲示板情報の更新に失敗しました。\n");
}
else {
$Page->Print(" ERROR:$ecode - 不明なエラーが発生しました。\n");
}
$Page->Print(<
');
$Page->Print(" ");
foreach (@$pLog) {
$Page->Print(" $_
");
$Page->Print('
\n");
}
$Page->Print("
');
}
$Page->Print(<
', '');
$Base->SetMenu('掲示板カテゴリ一覧', "'sys.bbs','DISP','CATEGORY'");
}
}
#------------------------------------------------------------------------------------------------------------
#
# 掲示板一覧の表示
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintBBSList
{
my ($Page, $SYS, $Form) = @_;
my ($BBS, $Category, @bbsSet, @catSet, $id, $name, $category, $subject);
my ($common1, $common2, $sCat, @belongBBS, $belongID, $isSysad);
$SYS->Set('_TITLE', 'BBS List');
require './module/nazguls.pl';
$BBS = NAZGUL->new;
$Category = ANGMAR->new;
$BBS->Load($SYS);
$Category->Load($SYS);
$sCat = $Form->Get('BBS_CATEGORY', '');
# ユーザ所属のBBS一覧を取得
$SYS->Get('ADMIN')->{'SECINFO'}->GetBelongBBSList($SYS->Get('ADMIN')->{'USER'}, $BBS, \@belongBBS);
# システム管理権限を取得
$isSysad = $SYS->Get('ADMIN')->{'SECINFO'}->IsAuthority($SYS->Get('ADMIN')->{'USER'}, $ZP::AUTH_SYSADMIN, '*');
# 掲示板情報を取得
if ($sCat eq '' || $sCat eq 'ALL') {
$BBS->GetKeySet('ALL', '', \@bbsSet);
}
else {
$BBS->GetKeySet('CATEGORY', $sCat, \@bbsSet);
}
$Category->GetKeySet(\@catSet);
$Page->Print("");
$Page->Print("
\n");
}
#------------------------------------------------------------------------------------------------------------
#
# 掲示板作成画面の表示
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintBBSCreate
{
my ($Page, $SYS, $Form) = @_;
my ($BBS, $Category, @bbsSet, @catSet, $id, $name);
$SYS->Set('_TITLE', 'BBS Create');
require './module/nazguls.pl';
$BBS = NAZGUL->new;
$Category = ANGMAR->new;
$BBS->Load($SYS);
$Category->Load($SYS);
# 掲示板情報を取得
$BBS->GetKeySet('ALL', '', \@bbsSet);
$Category->GetKeySet(\@catSet);
$Page->Print("カテゴリ");
$Page->Print(" ");
$Page->Print(" BBS Name");
$Page->Print(" Category");
$Page->Print(" SubScription ");
$Page->Print(" $name $category ");
$Page->Print("$subject
");
$Page->Print(" ") if (1);
$Page->Print(" ") if ($isSysad);
$Page->Print(" ") if (1);
$Page->Print(" ") if ($isSysad);
$Page->Print("");
$Page->Print("
");
}
#------------------------------------------------------------------------------------------------------------
#
# 掲示板削除確認画面の表示
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintBBSDelete
{
my ($Page, $SYS, $Form) = @_;
my ($BBS, $Category, @bbsSet, $id, $name, $subject, $category);
$SYS->Set('_TITLE', 'BBS Delete Confirm');
require './module/nazguls.pl';
$BBS = NAZGUL->new;
$Category = ANGMAR->new;
$BBS->Load($SYS);
$Category->Load($SYS);
@bbsSet = $Form->GetAtArray('BBSS');
$Page->Print("各項目を設定して[作成]ボタンを押してください。 掲示板カテゴリ ");
$Page->Print("掲示板ディレクトリ ");
$Page->Print(" 掲示板名称 ");
$Page->Print(" 説明 ");
$Page->Print(" 掲示板設定継承 ");
$Page->Print("Print("onclick=\"DoSubmit('sys.bbs','FUNC','CREATE')\"> ");
$Page->Print("
");
}
#------------------------------------------------------------------------------------------------------------
#
# 掲示板カテゴリ変更画面の表示
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintBBScategoryChange
{
my ($Page, $SYS, $Form) = @_;
my ($BBS, $Category, @bbsSet, @catSet, $id, $name, $subject, $category);
$SYS->Set('_TITLE', 'Category Change');
require './module/nazguls.pl';
$BBS = NAZGUL->new;
$Category = ANGMAR->new;
$BBS->Load($SYS);
$Category->Load($SYS);
@bbsSet = $Form->GetAtArray('BBSS');
$Category->GetKeySet(\@catSet);
$Page->Print("以下の掲示板を削除します。 ");
$Page->Print(" \n");
# 掲示板リストを出力
foreach $id (@bbsSet) {
$name = $BBS->Get('NAME', $id);
$subject = $BBS->Get('SUBJECT', $id);
$category = $BBS->Get('CATEGORY', $id);
$category = $Category->Get('NAME', $category);
$Page->Print("BBS Name");
$Page->Print(" Category");
$Page->Print(" SubScription $name ");
$Page->Print("$category ");
$Page->Print("$subject ");
$Page->Print("※注：削除した掲示板を元に戻すことはできません。 Print("onclick=\"DoSubmit('sys.bbs','FUNC','DELETE')\" class=\"delete\"> ");
$Page->Print("
");
}
#------------------------------------------------------------------------------------------------------------
#
# カテゴリ一覧画面の表示
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintCategoryList
{
my ($Page, $SYS, $Form) = @_;
my ($Category, $BBS, $id, $name, $subj, $common);
my (@catsSet, @bbsSet, $bbsNum);
$SYS->Set('_TITLE', 'Category List');
require './module/nazguls.pl';
$BBS = NAZGUL->new;
$Category = ANGMAR->new;
$BBS->Load($SYS);
$Category->Load($SYS);
$Category->GetKeySet(\@catsSet);
$Page->Print("以下の掲示板のカテゴリを変更します。 ");
$Page->Print(" \n");
# 掲示板リストを出力
foreach $id (@bbsSet) {
$name = $BBS->Get('NAME', $id);
$subject = $BBS->Get('SUBJECT', $id);
$category = $BBS->Get('CATEGORY', $id);
$category = $Category->Get('NAME', $category);
$Page->Print("BBS Name");
$Page->Print(" Category");
$Page->Print(" SubScription $name ");
$Page->Print("$category ");
$Page->Print("$subject 変更後カテゴリ：Print("onclick=\"DoSubmit('sys.bbs','FUNC','CATCHANGE')\"> ");
$Page->Print("
");
}
#------------------------------------------------------------------------------------------------------------
#
# カテゴリ追加画面の表示
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintCategoryAdd
{
my ($Page, $SYS, $Form) = @_;
my ($common);
$SYS->Set('_TITLE', 'Category Add');
$common = "onclick=\"DoSubmit('sys.bbs','FUNC','CATADD');\"";
$Page->Print(" ");
$Page->Print(" Category Name");
$Page->Print(" SubScription");
$Page->Print(" Belonging ");
$Page->Print(" $name $subj ");
$Page->Print("$bbsNum ");
$Page->Print(" ");
$Page->Print(" ");
$Page->Print(" ");
$Page->Print("
");
}
#------------------------------------------------------------------------------------------------------------
#
# カテゴリ削除画面の表示
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintCategoryDelete
{
my ($Page, $SYS, $Form) = @_;
my ($Category, $name, $subj, @catSet, $id);
$SYS->Set('_TITLE', 'Category Delete Confirm');
require './module/nazguls.pl';
$Category = ANGMAR->new;
$Category->Load($SYS);
@catSet = $Form->GetAtArray('CATS');
$Page->Print("各項目を設定して[追加]ボタンを押してください。 カテゴリ名称 カテゴリ説明 ");
$Page->Print("");
$Page->Print(" ");
$Page->Print("
");
}
#------------------------------------------------------------------------------------------------------------
#
# 掲示板の生成
# -------------------------------------------------------------------------------------
# @param $Sys システム変数
# @param $Form フォーム変数
# @param $pLog ログ用
# @return エラーコード
#
#------------------------------------------------------------------------------------------------------------
sub FunctionBBSCreate
{
my ($Sys, $Form, $pLog) = @_;
my ($bbsCategory, $bbsDir, $bbsName, $bbsExplanation, $bbsInherit);
my ($createPath, $dataPath);
# 権限チェック
{
my $SEC = $Sys->Get('ADMIN')->{'SECINFO'};
my $chkID = $Sys->Get('ADMIN')->{'USER'};
if (($SEC->IsAuthority($chkID, $ZP::AUTH_SYSADMIN, '*')) == 0) {
return 1000;
}
}
# 入力チェック
{
my @inList = ('BBS_DIR', 'BBS_NAME', 'BBS_CATEGORY');
if (! $Form->IsInput(\@inList)) {
return 1001;
}
if (! $Form->IsBBSDir(['BBS_DIR'])) {
return 1002;
}
}
require './module/earendil.pl';
# POSTデータの取得
$bbsCategory = $Form->Get('BBS_CATEGORY');
$bbsDir = $Form->Get('BBS_DIR');
$bbsName = $Form->Get('BBS_NAME');
$bbsExplanation = $Form->Get('BBS_EXPLANATION');
$bbsInherit = $Form->Get('BBS_INHERIT');
# パスの設定
$createPath = $Sys->Get('BBSPATH') . '/' . $bbsDir;
$dataPath = '.' . $Sys->Get('DATA');
# 掲示板ディレクトリの作成に成功したら、その下のディレクトリを作成する
if (! (EARENDIL::CreateDirectory($createPath, $Sys->Get('PM-BDIR')))) {
return 2000;
}
# サブディレクトリ生成
EARENDIL::CreateDirectory("$createPath/i", $Sys->Get('PM-BDIR'));
EARENDIL::CreateDirectory("$createPath/dat", $Sys->Get('PM-BDIR'));
EARENDIL::CreateDirectory("$createPath/log", $Sys->Get('PM-LDIR'));
EARENDIL::CreateDirectory("$createPath/kako", $Sys->Get('PM-BDIR'));
EARENDIL::CreateDirectory("$createPath/pool", $Sys->Get('PM-ADIR'));
EARENDIL::CreateDirectory("$createPath/info", $Sys->Get('PM-ADIR'));
# デフォルトデータのコピー
EARENDIL::Copy("$dataPath/default_img.gif", "$createPath/kanban.gif");
EARENDIL::Copy("$dataPath/default_bac.gif", "$createPath/ba.gif");
EARENDIL::Copy("$dataPath/default_hed.txt", "$createPath/head.txt");
EARENDIL::Copy("$dataPath/default_fot.txt", "$createPath/foot.txt");
EARENDIL::Copy("$dataPath/index.html", "$createPath/log/index.html");
EARENDIL::Copy("$dataPath/index.html", "$createPath/pool/index.html");
EARENDIL::Copy("$dataPath/index.html", "$createPath/info/index.html");
push @$pLog, "■掲示板ディレクトリ生成完了...[$createPath]";
# 設定継承情報のコピー
if ($bbsInherit ne '') {
my ($BBS, $inheritPath);
require './module/nazguls.pl';
$BBS = NAZGUL->new;
$BBS->Load($Sys);
$inheritPath = $Sys->Get('BBSPATH') . '/' . $BBS->Get('DIR', $bbsInherit);
EARENDIL::Copy("$inheritPath/SETTING.TXT", "$createPath/SETTING.TXT");
EARENDIL::Copy("$inheritPath/info/groups.cgi", "$createPath/info/groups.cgi");
EARENDIL::Copy("$inheritPath/info/capgroups.cgi", "$createPath/info/capgroups.cgi");
push @$pLog, "■設定継承完了...[$inheritPath]";
}
my ($bbsSetting);
# 掲示板設定情報生成
require './module/isildur.pl';
$bbsSetting = ISILDUR->new;
$Sys->Set('BBS', $bbsDir);
$bbsSetting->Load($Sys);
require './module/galadriel.pl';
my $createPath2 = GALADRIEL::MakePath($Sys->Get('CGIPATH'), $createPath);
my $cookiePath = GALADRIEL::MakePath($Sys->Get('CGIPATH'), $Sys->Get('BBSPATH'));
$cookiePath .= '/' if ($cookiePath ne '/');
$bbsSetting->Set('BBS_TITLE', $bbsName);
$bbsSetting->Set('BBS_SUBTITLE', $bbsExplanation);
$bbsSetting->Set('BBS_BG_PICTURE', "$createPath2/ba.gif");
$bbsSetting->Set('BBS_TITLE_PICTURE', "$createPath2/kanban.gif");
$bbsSetting->Set('BBS_COOKIEPATH', $cookiePath);
$bbsSetting->Save($Sys);
push @$pLog, '■掲示板設定完了...';
# 掲示板構成要素生成
my ($BBSAid);
require './module/varda.pl';
$BBSAid = VARDA->new;
$Sys->Set('MODE', 'CREATE');
$BBSAid->Init($Sys, $bbsSetting);
$BBSAid->CreateIndex();
$BBSAid->CreateIIndex();
$BBSAid->CreateSubback();
push @$pLog, '■掲示板構\成要素生成完了...';
# 過去ログインデクス生成
require './module/thorin.pl';
require './module/celeborn.pl';
my $PastLog = CELEBORN->new;
my $Page = THORIN->new;
$PastLog->Load($Sys);
$PastLog->UpdateInfo($Sys);
$PastLog->UpdateIndex($Sys, $Page);
$PastLog->Save($Sys);
push @$pLog, '■過去ログインデクス生成完了...';
# 掲示板情報に追加
require './module/nazguls.pl';
my $BBS = NAZGUL->new;
$BBS->Load($Sys);
$BBS->Add($bbsName, $bbsDir, $bbsExplanation, $bbsCategory);
$BBS->Save($Sys);
push @$pLog, '■掲示板情報追加完了';
push @$pLog, " 名前：$bbsName";
push @$pLog, " サブジェクト：$bbsExplanation";
push @$pLog, " カテゴリ：$bbsCategory";
push @$pLog, '以下のカテゴリを削除します。 ");
$Page->Print(" \n");
# ユーザリストを出力
foreach $id (@catSet) {
$name = $Category->Get('NAME', $id);
$subj = $Category->Get('SUBJECT', $id);
$Page->Print("Category Name");
$Page->Print(" SubScription $name ");
$Page->Print("$subj ");
$Page->Print("※注：削除したカテゴリを元に戻すことはできません。
");
$Page->Print("※注：所属している掲示板のカテゴリは強制的に「一般」になります。Print("onclick=\"DoSubmit('sys.bbs','FUNC','CATDEL')\" class=\"delete\">
以下のURLに掲示板を作成しました。';
push @$pLog, "$createPath/";
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# 掲示板の更新
# -------------------------------------------------------------------------------------
# @param $Sys システム変数
# @param $Form フォーム変数
# @param $pLog ログ用
# @return エラーコード
#
#------------------------------------------------------------------------------------------------------------
sub FunctionBBSUpdate
{
my ($Sys, $Form, $pLog) = @_;
my ($BBSAid, $BBS, @bbsSet, $id, $bbs, $name);
require './module/nazguls.pl';
require './module/varda.pl';
$BBS = NAZGUL->new;
$BBSAid = VARDA->new;
$BBS->Load($Sys);
@bbsSet = $Form->GetAtArray('BBSS');
foreach $id (@bbsSet) {
$bbs = $BBS->Get('DIR', $id, '');
next if ($bbs eq '');
$name = $BBS->Get('NAME', $id);
$Sys->Set('BBS', $bbs);
$Sys->Set('MODE', 'CREATE');
$BBSAid->Init($Sys, undef);
$BBSAid->CreateIndex();
$BBSAid->CreateIIndex();
$BBSAid->CreateSubback();
push @$pLog, "■掲示板「$name」を更新しました。";
}
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# 掲示板情報の更新
# -------------------------------------------------------------------------------------
# @param $Sys システム変数
# @param $Form フォーム変数
# @param $pLog ログ用
# @return エラーコード
#
#------------------------------------------------------------------------------------------------------------
sub FunctionBBSInfoUpdate
{
my ($Sys, $Form, $pLog) = @_;
my ($BBS);
# 権限チェック
{
my $SEC = $Sys->Get('ADMIN')->{'SECINFO'};
my $chkID = $Sys->Get('ADMIN')->{'USER'};
if (($SEC->IsAuthority($chkID, $ZP::AUTH_SYSADMIN, '*')) == 0) {
return 1000;
}
}
require './module/nazguls.pl';
$BBS = NAZGUL->new;
$BBS->Load($Sys);
$BBS->Update($Sys, '');
$BBS->Save($Sys);
push @$pLog, '■掲示板情報の更新が正常に終了しました。';
push @$pLog, '※カテゴリは全て「一般」に設定されたので、再設定してください。';
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# 掲示板の削除
# -------------------------------------------------------------------------------------
# @param $Sys システム変数
# @param $Form フォーム変数
# @param $pLog ログ用
# @return エラーコード
#
#------------------------------------------------------------------------------------------------------------
sub FunctionBBSDelete
{
my ($Sys, $Form, $pLog) = @_;
my ($BBS, @bbsSet, $id, $dir, $name, $path);
# 権限チェック
{
my $SEC = $Sys->Get('ADMIN')->{'SECINFO'};
my $chkID = $Sys->Get('ADMIN')->{'USER'};
if (($SEC->IsAuthority($chkID, $ZP::AUTH_SYSADMIN, '*')) == 0) {
return 1000;
}
}
require './module/nazguls.pl';
require './module/earendil.pl';
$BBS = NAZGUL->new;
$BBS->Load($Sys);
@bbsSet = $Form->GetAtArray('BBSS');
foreach $id (@bbsSet) {
$dir = $BBS->Get('DIR', $id);
next if (! defined $dir);
$name = $BBS->Get('NAME', $id);
$path = $Sys->Get('BBSPATH') . "/$dir";
# 掲示板ディレクトリと掲示板情報の削除
EARENDIL::DeleteDirectory($path);
$BBS->Delete($id);
push @$pLog, "■掲示板「$name($dir)」を削除しました。
";
}
$BBS->Save($Sys);
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# カテゴリの追加
# -------------------------------------------------------------------------------------
# @param $Sys システム変数
# @param $Form フォーム変数
# @param $pLog ログ用
# @return エラーコード
#
#------------------------------------------------------------------------------------------------------------
sub FunctionCategoryAdd
{
my ($Sys, $Form, $pLog) = @_;
my ($Category, $name, $subj);
# 権限チェック
{
my $SEC = $Sys->Get('ADMIN')->{'SECINFO'};
my $chkID = $Sys->Get('ADMIN')->{'USER'};
if (($SEC->IsAuthority($chkID, $ZP::AUTH_SYSADMIN, '*')) == 0) {
return 1000;
}
}
require './module/nazguls.pl';
$Category = ANGMAR->new;
$Category->Load($Sys);
$name = $Form->Get('NAME');
$subj = $Form->Get('SUBJ');
$Category->Add($name, $subj);
$Category->Save($Sys);
# ログの設定
{
push @$pLog, '■ カテゴリ追加';
push @$pLog, "カテゴリ名称：$name";
push @$pLog, "カテゴリ説明：$subj";
}
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# カテゴリの削除
# -------------------------------------------------------------------------------------
# @param $Sys システム変数
# @param $Form フォーム変数
# @param $pLog ログ用
# @return エラーコード
#
#------------------------------------------------------------------------------------------------------------
sub FunctionCategoryDelete
{
my ($Sys, $Form, $pLog) = @_;
my ($Category, $BBS, $name, $id, $bbsID);
my (@categorySet, @bbsSet);
# 権限チェック
{
my $SEC = $Sys->Get('ADMIN')->{'SECINFO'};
my $chkID = $Sys->Get('ADMIN')->{'USER'};
if (($SEC->IsAuthority($chkID, $ZP::AUTH_SYSADMIN, '*')) == 0) {
return 1000;
}
}
require './module/nazguls.pl';
$BBS = NAZGUL->new;
$Category = ANGMAR->new;
$BBS->Load($Sys);
$Category->Load($Sys);
@categorySet = $Form->GetAtArray('CATS');
foreach $id (@categorySet) {
if ($id ne '0000000001') {
$name = $Category->Get('NAME', $id);
$BBS->GetKeySet('CATEGORY', $id, \@bbsSet);
foreach $bbsID (@bbsSet) {
$BBS->Set($bbsID, 'CATEGORY', '0000000001');
}
undef @bbsSet;
$Category->Delete($id);
push @$pLog, "カテゴリ「$name」を削除";
}
}
$BBS->Save($Sys);
$Category->Save($Sys);
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# カテゴリの変更
# -------------------------------------------------------------------------------------
# @param $Sys システム変数
# @param $Form フォーム変数
# @param $pLog ログ用
# @return エラーコード
#
#------------------------------------------------------------------------------------------------------------
sub FunctionCategoryChange
{
my ($Sys, $Form, $pLog) = @_;
my ($BBS, $Category, @bbsSet, $idCat, $nmCat, $nmBBS, $id);
# 権限チェック
{
my $SEC = $Sys->Get('ADMIN')->{'SECINFO'};
my $chkID = $Sys->Get('ADMIN')->{'USER'};
if (($SEC->IsAuthority($chkID, $ZP::AUTH_SYSADMIN, '*')) == 0) {
return 1000;
}
}
require './module/nazguls.pl';
$BBS = NAZGUL->new;
$Category = ANGMAR->new;
$BBS->Load($Sys);
$Category->Load($Sys);
@bbsSet = $Form->GetAtArray('BBSS');
$idCat = $Form->Get('SEL_CATEGORY');
$nmCat = $Category->Get('NAME', $idCat);
foreach $id (@bbsSet) {
$BBS->Set($id, 'CATEGORY', $idCat);
$nmBBS = $BBS->Get('NAME', $id);
push @$pLog, "「$nmBBS」のカテゴリを「$nmCat」に変更";
}
$BBS->Save($Sys);
return 0;
}
#============================================================================================================
# Module END
#============================================================================================================
1;
zerochplus_0.7.4/test/mordor/sys.cap.pl 0000644 0000764 0001040 00000040347 12236106656 015133 0 ustar #============================================================================================================
#
# システム管理 - キャップ モジュール
# sys.cap.pl
# ---------------------------------------------------------------------------
# 2004.06.26 start
#
#============================================================================================================
package MODULE;
use strict;
#use warnings;
#------------------------------------------------------------------------------------------------------------
#
# コンストラクタ
# -------------------------------------------------------------------------------------
# @param なし
# @return モジュールオブジェクト
#
#------------------------------------------------------------------------------------------------------------
sub new
{
my $this = shift;
my ($obj, @LOG);
$obj = {
'LOG' => \@LOG
};
bless $obj, $this;
return $obj;
}
#------------------------------------------------------------------------------------------------------------
#
# 表示メソッド
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @param $Form SAMWISE
# @param $pSys 管理システム
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub DoPrint
{
my $this = shift;
my ($Sys, $Form, $pSys) = @_;
my ($subMode, $BASE, $BBS, $Page);
require './mordor/sauron.pl';
$BASE = SAURON->new;
# 管理マスタオブジェクトの生成
$Page = $BASE->Create($Sys, $Form);
$subMode = $Form->Get('MODE_SUB');
# メニューの設定
SetMenuList($BASE, $pSys);
if ($subMode eq 'LIST') { # スレッド一覧画面
PrintCapList($Page, $Sys, $Form);
}
elsif ($subMode eq 'CREATE') { # キャップ作成画面
PrintCapSetting($Page, $Sys, $Form, 0);
}
elsif ($subMode eq 'EDIT') { # キャップ編集画面
PrintCapSetting($Page, $Sys, $Form, 1);
}
elsif ($subMode eq 'DELETE') { # キャップ削除確認画面
PrintCapDelete($Page, $Sys, $Form);
}
elsif ($subMode eq 'COMPLETE') { # キャップ設定完了画面
$Sys->Set('_TITLE', 'Process Complete');
$BASE->PrintComplete('キャップ処理', $this->{'LOG'});
}
elsif ($subMode eq 'FALSE') { # キャップ設定失敗画面
$Sys->Set('_TITLE', 'Process Failed');
$BASE->PrintError($this->{'LOG'});
}
$BASE->Print($Sys->Get('_TITLE'), 1);
}
#------------------------------------------------------------------------------------------------------------
#
# 機能メソッド
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @param $Form SAMWISE
# @param $pSys 管理システム
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub DoFunction
{
my $this = shift;
my ($Sys, $Form, $pSys) = @_;
my ($subMode, $err);
$subMode = $Form->Get('MODE_SUB');
$err = 0;
if ($subMode eq 'CREATE') { # キャップ作成
$err = FuncCapSetting($Sys, $Form, 0, $this->{'LOG'});
}
elsif ($subMode eq 'EDIT') { # キャップ編集
$err = FuncCapSetting($Sys, $Form, 1, $this->{'LOG'});
}
elsif ($subMode eq 'DELETE') { # キャップ削除
$err = FuncCapDelete($Sys, $Form, $this->{'LOG'});
}
# 処理結果表示
if ($err) {
$pSys->{'LOGGER'}->Put($Form->Get('UserName'),"CAP($subMode)", "ERROR:$err");
push @{$this->{'LOG'}}, $err;
$Form->Set('MODE_SUB', 'FALSE');
}
else {
$pSys->{'LOGGER'}->Put($Form->Get('UserName'),"CAP($subMode)", 'COMPLETE');
$Form->Set('MODE_SUB', 'COMPLETE');
}
$this->DoPrint($Sys, $Form, $pSys);
}
#------------------------------------------------------------------------------------------------------------
#
# メニューリスト設定
# -------------------------------------------------------------------------------------
# @param $Base SAURON
# @param $pSys 管理システム
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub SetMenuList
{
my ($Base, $pSys) = @_;
# 共通表示メニュー
$Base->SetMenu('キャップ一覧', "'sys.cap','DISP','LIST'");
# システム管理権限のみ
if ($pSys->{'SECINFO'}->IsAuthority($pSys->{'USER'}, $ZP::AUTH_SYSADMIN, '*')) {
$Base->SetMenu('キャップ登録', "'sys.cap','DISP','CREATE'");
}
}
#------------------------------------------------------------------------------------------------------------
#
# キャップ一覧の表示
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintCapList
{
my ($Page, $Sys, $Form) = @_;
my ($Cap, @userSet, $name, $expl, $full, $id, $common, $customid);
my ($dispNum, $i, $dispSt, $dispEd, $userNum, $isAuth);
$Sys->Set('_TITLE', 'Caps List');
require './module/ungoliants.pl';
$Cap = UNGOLIANT->new;
# キャップ情報の読み込み
$Cap->Load($Sys);
# キャップ情報を取得
$Cap->GetKeySet('ALL', '', \@userSet);
# 表示数の設定
$userNum = @userSet;
$dispNum = ($Form->Get('DISPNUM') eq '' ? 10 : $Form->Get('DISPNUM'));
$dispSt = ($Form->Get('DISPST') eq '' ? 0 : $Form->Get('DISPST'));
$dispSt = ($dispSt < 0 ? 0 : $dispSt);
$dispEd = (($dispSt + $dispNum) > $userNum ? $userNum : ($dispSt + $dispNum));
$common = "DoSubmit('sys.cap','DISP','LIST');";
$Page->Print("");
$Page->Print("
");
$Page->HTMLInput('hidden', 'DISPST', '');
}
#------------------------------------------------------------------------------------------------------------
#
# キャップ設定の表示
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @param $mode 作成の場合:0, 編集の場合:1
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintCapSetting
{
my ($Page, $Sys, $Form, $mode) = @_;
my ($User, $id, $common, $name, $pass, $expl, $full, $sysad, $customid);
$Sys->Set('_TITLE', 'Cap Edit') if ($mode == 1);
$Sys->Set('_TITLE', 'Cap Create') if ($mode == 0);
require './module/ungoliants.pl';
$User = UNGOLIANT->new;
# キャップ情報の読み込み
$User->Load($Sys);
# 編集モードならキャップ情報を取得する
if ($mode) {
$name = $User->Get('NAME', $Form->Get('SELECT_CAP'));
$pass = $User->Get('PASS', $Form->Get('SELECT_CAP'));
$expl = $User->Get('EXPL', $Form->Get('SELECT_CAP'));
$full = $User->Get('FULL', $Form->Get('SELECT_CAP'));
$sysad = $User->Get('SYSAD', $Form->Get('SELECT_CAP')) ? 'checked' : '';
$customid = $User->Get('CUSTOMID', $Form->Get('SELECT_CAP'));
}
else {
$Form->Set('SELECT_CAP', '');
$name = '';
$pass = '';
$expl = '';
$full = '';
$sysad = '';
}
$Page->Print("Print(");$common\"><< PREV | Print("" . ($dispSt + $dispNum) . ");$common\">NEXT >>");
$Page->Print(" ");
$Page->Print("表\示数");
$Page->Print(" ");
$Page->Print("Cap Display Name ");
$Page->Print("Cap Full Name ");
$Page->Print("Custom ID ");
$Page->Print("Explanation ");
$Page->Print(" $name ");
}
else{
$Page->Print("$name ");
}
$Page->Print("$full $customid $expl ");
$Page->Print("");
$Page->Print(" ");
$Page->Print("
");
}
#------------------------------------------------------------------------------------------------------------
#
# キャップ削除確認画面の表示
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintCapDelete
{
my ($Page, $SYS, $Form) = @_;
my ($Cap, $Group, @userSet, $id, $name, $grop, $expl, $full);
$SYS->Set('_TITLE', 'Cap Delete Confirm');
require './module/ungoliants.pl';
$Cap = UNGOLIANT->new;
# キャップ情報を取得
$Cap->Load($SYS);
@userSet = $Form->GetAtArray('CAPS');
$Page->Print("各項目を設定して[設定]ボタンを押してください。 キャップ表\示名 ");
$Page->Print(" パスワード ");
$Page->Print(" キャップフルネーム ");
$Page->Print(" 説明 ");
$Page->Print(" 専用ID(要権限) ");
$Page->Print(" ");
$Page->Print("システム共通権限 ");
$Page->Print(" ");
$Page->Print("
");
}
#------------------------------------------------------------------------------------------------------------
#
# キャップ作成/編集
# -------------------------------------------------------------------------------------
# @param $Sys システム変数
# @param $Form フォーム変数
# @param $mode 編集:1, 作成:0
# @param $pLog ログ用
# @return エラーコード
#
#------------------------------------------------------------------------------------------------------------
sub FuncCapSetting
{
my ($Sys, $Form, $mode, $pLog) = @_;
my ($Cap, $name, $pass, $expl, $grop, $chg, $sysad, $full, $customid);
# 権限チェック
{
my $SEC = $Sys->Get('ADMIN')->{'SECINFO'};
my $chkID = $Sys->Get('ADMIN')->{'USER'};
if (($SEC->IsAuthority($chkID, $ZP::AUTH_SYSADMIN, '*')) == 0) {
return 1000;
}
}
# 入力チェック
{
my @inList = ('PASS');
if (! $Form->IsInput(\@inList)) {
return 1001;
}
if (! $Form->IsCapKey(\@inList)) {
return 1002;
}
}
require './module/ungoliants.pl';
$Cap = UNGOLIANT->new;
$Cap->Load($Sys);
# 設定入力情報を取得
$name = $Form->Get('NAME');
$pass = $Form->Get('PASS');
$expl = $Form->Get('EXPL');
$full = $Form->Get('FULL');
$customid = $Form->Get('CUSTOMID');
$sysad = $Form->Equal('SYSAD', 'on') ? 1 : 0;
$chg = 0;
if ($mode) { # 編集モード
# パスワードが変更されていたら再設定する
if ($pass ne $Cap->Get('PASS', $Form->Get('SELECT_CAP'))){
$Cap->Set($Form->Get('SELECT_CAP'), 'PASS', $pass);
$chg = 1;
}
$Cap->Set($Form->Get('SELECT_CAP'), 'NAME', $name);
$Cap->Set($Form->Get('SELECT_CAP'), 'EXPL', $expl);
$Cap->Set($Form->Get('SELECT_CAP'), 'FULL', $full);
$Cap->Set($Form->Get('SELECT_CAP'), 'SYSAD', $sysad);
$Cap->Set($Form->Get('SELECT_CAP'), 'CUSTOMID', $customid);
}
else { # 登録モード
$Cap->Add($name, $pass, $full, $expl, $sysad, $customid);
$chg = 1;
}
# 設定情報を保存
$Cap->Save($Sys);
# ログの設定
{
push @$pLog, "■ キャップ [ $name ] " . ($mode ? '設定' : '作成');
push @$pLog, ' パスワード：' . ($chg ? $pass : '変更なし');
push @$pLog, " フルネーム：$full";
push @$pLog, " 説明：$expl";
push @$pLog, " 専用ID：$customid";
push @$pLog, ' システム管理：' . ($sysad ? '有り' : '無し');
}
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# キャップ削除
# -------------------------------------------------------------------------------------
# @param $Sys システム変数
# @param $Form フォーム変数
# @param $pLog ログ用
# @return エラーコード
#
#------------------------------------------------------------------------------------------------------------
sub FuncCapDelete
{
my ($Sys, $Form, $pLog) = @_;
my ($Cap, @userSet);
# 権限チェック
{
my $SEC = $Sys->Get('ADMIN')->{'SECINFO'};
my $chkID = $Sys->Get('ADMIN')->{'USER'};
if (($SEC->IsAuthority($chkID, $ZP::AUTH_SYSADMIN, '*')) == 0) {
return 1000;
}
}
require './module/ungoliants.pl';
$Cap = UNGOLIANT->new;
$Cap->Load($Sys);
@userSet = $Form->GetAtArray('CAPS');
# 選択キャップを全削除
foreach (@userSet) {
next if (! defined $Cap->Get('NAME', $_));
# Administratorは削除不可
if ($_ eq '0000000001') {
push @$pLog, '□ キャップ [ Administrator ] は削除できませんでした。';
}
# それ以外は削除可
else {
my $name = $Cap->Get('NAME', $_);
my $pass = $Cap->Get('PASS', $_);
push @$pLog, "■ キャップ [ $name / $pass ] を削除しました。";
$Cap->Delete($_);
}
}
# 設定情報を保存
$Cap->Save($Sys);
return 0;
}
#============================================================================================================
# Module END
#============================================================================================================
1;
zerochplus_0.7.4/test/mordor/sys.capg.pl 0000644 0000764 0001040 00000047012 12236106656 015276 0 ustar #============================================================================================================
#
# システム管理 - 共通キャップグループ モジュール
# sys.capg.pl
# ---------------------------------------------------------------------------
# 2011.02.12 start ぜろちゃんねるプラス
#
#============================================================================================================
package MODULE;
use strict;
#use warnings;
#------------------------------------------------------------------------------------------------------------
#
# コンストラクタ
# -------------------------------------------------------------------------------------
# @param なし
# @return モジュールオブジェクト
#
#------------------------------------------------------------------------------------------------------------
sub new
{
my $this = shift;
my ($obj, @LOG);
$obj = {
'LOG' => \@LOG
};
bless $obj, $this;
return $obj;
}
#------------------------------------------------------------------------------------------------------------
#
# 表示メソッド
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @param $Form SAMWISE
# @param $pSys 管理システム
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub DoPrint
{
my $this = shift;
my ($Sys, $Form, $pSys) = @_;
my ($subMode, $BASE, $BBS, $Page);
require './mordor/sauron.pl';
$BASE = SAURON->new;
# 管理マスタオブジェクトの生成
$Page = $BASE->Create($Sys, $Form);
$subMode = $Form->Get('MODE_SUB');
# メニューの設定
SetMenuList($BASE, $pSys);
if ($subMode eq 'LIST') { # グループ一覧画面
PrintGroupList($Page, $Sys, $Form);
}
elsif ($subMode eq 'CREATE') { # グループ作成画面
PrintGroupSetting($Page, $Sys, $Form, 0);
}
elsif ($subMode eq 'EDIT') { # グループ編集画面
PrintGroupSetting($Page, $Sys, $Form, 1);
}
elsif ($subMode eq 'DELETE') { # グループ削除確認画面
PrintGroupDelete($Page, $Sys, $Form);
}
elsif ($subMode eq 'COMPLETE') { # グループ設定完了画面
$Sys->Set('_TITLE', 'Process Complete');
$BASE->PrintComplete('キャップグループ処理', $this->{'LOG'});
}
elsif ($subMode eq 'FALSE') { # グループ設定失敗画面
$Sys->Set('_TITLE', 'Process Failed');
$BASE->PrintError($this->{'LOG'});
}
$BASE->Print($Sys->Get('_TITLE'), 1);
}
#------------------------------------------------------------------------------------------------------------
#
# 機能メソッド
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @param $Form SAMWISE
# @param $pSys 管理システム
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub DoFunction
{
my $this = shift;
my ($Sys, $Form, $pSys) = @_;
my ($subMode, $err);
$subMode = $Form->Get('MODE_SUB');
$err = 0;
if ($subMode eq 'CREATE') { # グループ作成
$err = FunctionGroupSetting($Sys, $Form, 0, $this->{'LOG'});
}
elsif ($subMode eq 'EDIT') { # グループ編集
$err = FunctionGroupSetting($Sys, $Form, 1, $this->{'LOG'});
}
elsif ($subMode eq 'DELETE') { # グループ削除
$err = FunctionGroupDelete($Sys, $Form, $this->{'LOG'});
}
# 処理結果表示
if ($err) {
$pSys->{'LOGGER'}->Put($Form->Get('UserName'), "SYSCAP_GROUP($subMode)", "ERROR:$err");
push @{$this->{'LOG'}}, $err;
$Form->Set('MODE_SUB', 'FALSE');
}
else {
$pSys->{'LOGGER'}->Put($Form->Get('UserName'), "SYSCAP_GROUP($subMode)", 'COMPLETE');
$Form->Set('MODE_SUB', 'COMPLETE');
}
$this->DoPrint($Sys, $Form, $pSys);
}
#------------------------------------------------------------------------------------------------------------
#
# メニューリスト設定
# -------------------------------------------------------------------------------------
# @param $Base SAURON
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub SetMenuList
{
my ($Base, $pSys) = @_;
$Base->SetMenu('グループ一覧', "'sys.capg','DISP','LIST'");
# 管理グループ設定権限のみ
if ($pSys->{'SECINFO'}->IsAuthority($pSys->{'USER'}, $ZP::AUTH_SYSADMIN, '*')) {
$Base->SetMenu('グループ登録', "'sys.capg','DISP','CREATE'");
}
}
#------------------------------------------------------------------------------------------------------------
#
# グループ一覧の表示
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintGroupList
{
my ($Page, $Sys, $Form) = @_;
my ($Group, @groupSet, @user, $name, $expl, $color, $id, $common, $isAuth, $n);
$Sys->Set('_TITLE', 'Common CAP Group List');
require './module/ungoliants.pl';
$Group = SHELOB->new;
# グループ情報の読み込み
$Group->Load($Sys, 1);
$Group->GetKeySet(\@groupSet, 1);
$Page->Print("以下のキャップを削除します。 ");
$Page->Print(" User Name ");
$Page->Print("User Full Name ");
$Page->Print("Explanation \n");
# キャップリストを出力
foreach $id (@userSet) {
$name = $Cap->Get('NAME', $id);
$expl = $Cap->Get('EXPL', $id);
$full = $Cap->Get('FULL', $id);
$Page->Print("$name ");
$Page->Print("$full ");
$Page->Print("$expl ");
$Page->Print("※注：削除したキャップを元に戻すことはできません。 Print("onclick=\"DoSubmit('sys.cap','FUNC','DELETE')\" class=\"delete\"> ");
$Page->Print("
");
}
#------------------------------------------------------------------------------------------------------------
#
# グループ設定の表示
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @param $mode 作成の場合:0, 編集の場合:1
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintGroupSetting
{
my ($Page, $Sys, $Form, $mode) = @_;
my ($Group, $User, @userSet, @authNum, $i, $num, $id);
my ($name, $expl, $color, @auth, @user, $common);
$Sys->Set('_TITLE', 'Common CAP Group Edit') if ($mode == 1);
$Sys->Set('_TITLE', 'Common CAP Group Create') if ($mode == 0);
require './module/ungoliants.pl';
$User = UNGOLIANT->new;
$Group = SHELOB->new;
# ユーザ情報の読み込み
$User->Load($Sys);
$Group->Load($Sys, 1);
$User->GetKeySet('ALL', '', \@userSet);
# 編集モードならユーザ情報を取得する
if ($mode) {
$name = $Group->Get('NAME', $Form->Get('SELECT_CAPGROUP'));
$expl = $Group->Get('EXPL', $Form->Get('SELECT_CAPGROUP'));
$color = $Group->Get('COLOR', $Form->Get('SELECT_CAPGROUP'));
@auth = split(/\,/, (defined ($_ = $Group->Get('AUTH', $Form->Get('SELECT_CAPGROUP'))) ? $_ : ''));
@user = split(/\,/, (defined ($_ = $Group->Get('CAPS', $Form->Get('SELECT_CAPGROUP'))) ? $_ : ''));
# 権限番号マッピング配列を作成
for ($i = 0 ; $i < $ZP::CAP_MAXNUM ; $i++) {
$authNum[$i] = '';
}
foreach $num (@auth) {
$authNum[$num - 1] = 'checked';
}
}
else {
$Form->Set('SELECT_CAPGROUP', '');
$name = '';
$expl = '';
$color = '';
for ($i = 0 ; $i < $ZP::CAP_MAXNUM ; $i++) {
$authNum[$i] = '';
}
}
$Page->Print(" ");
$Page->Print("Group Name ");
$Page->Print("Subscription ");
$Page->Print("Cap Color ");
$Page->Print("Caps ");
if ($isAuth) {
$Page->Print(" $name $expl $color $n $name $expl $color $n \n");
}
}
$common = "onclick=\"DoSubmit('sys.capg', 'DISP'";
$Page->HTMLInput('hidden', 'SELECT_CAPGROUP', '');
$Page->Print("");
$Page->Print("");
$Page->Print(" ");
$Page->Print("
各情報を入力して[設定]ボタンを押してください。 基本情報 ");
$Page->Print("
グループ名称 ");
$Page->Print(" 説明 ");
$Page->Print(" キャップの色(無記入でデフォルト) ");
$Page->Print(" 権限情報 ");
$Page->Print("所属キャップ ");
# 権限一覧表示
$Page->Print("タイトル文字数規制解除 \n
");
$Page->Print("名前文字数規制解除
");
$Page->Print("メール文字数規制解除
");
$Page->Print("本文文字数規制解除
");
$Page->Print("本文行数規制解除
");
$Page->Print("本文1行文字数規制解除
");
$Page->Print("名無し規制解除
");
$Page->Print("スレッド作成規制解除
");
$Page->Print("スレッド作成可能\(キャップ)
");
$Page->Print("連続投稿規制解除
");
$Page->Print("二重書き込み規制解除
");
$Page->Print("短時間投稿規制解除
");
$Page->Print("読取専用規制解除
");
$Page->Print("専用ID許可
");
$Page->Print("ID非表\示
");
$Page->Print("端末識別子非表\示
");
$Page->Print("本文ホスト非表\示
");
$Page->Print("携帯からのスレッド作成
");
$Page->Print("コテハン★表\示
");
$Page->Print("Samba規制解除
");
$Page->Print("プロキシ規制解除
");
$Page->Print("海外ホスト規制解除
");
$Page->Print("ユーザー規制解除
");
$Page->Print("NGワード規制解除
");
$Page->Print("");
# 所属ユーザ一覧表示
foreach $id (@userSet) {
my $groupid = $Group->GetBelong($id);
# システム共通キャップ、他のグループに所属しているキャップは非表示
if (0 == $User->Get('SYSAD', $id) &&
( $groupid eq '' || $groupid eq $Form->Get('SELECT_CAPGROUP') )) {
my $userName = $User->Get('NAME', $id);
my $fullName = $User->Get('FULL', $id);
my $check = '';
foreach (@user) {
if ($_ eq $id) {
$check = 'checked'
}
}
$Page->Print("$userName($fullName)
");
}
}
# submit設定
$common = "'" . $Form->Get('MODE_SUB') . "'";
$common = "onclick=\"DoSubmit('sys.capg', 'FUNC', $common)\"";
$Page->HTMLInput('hidden', 'SELECT_CAPGROUP', $Form->Get('SELECT_CAPGROUP'));
$Page->Print("");
$Page->Print("
");
}
#------------------------------------------------------------------------------------------------------------
#
# グループ削除確認画面の表示
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintGroupDelete
{
my ($Page, $SYS, $Form) = @_;
my ($Group, $BBS, @groupSet, $name, $expl, $rang, $id, $common);
$SYS->Set('_TITLE', 'Common CAP Group Delete Confirm');
require './module/ungoliants.pl';
$Group = SHELOB->new;
$Group->Load($SYS, 1);
# ユーザ情報を取得
@groupSet = $Form->GetAtArray('CAP_GROUPS');
$Page->Print("");
$Page->Print("
");
}
#------------------------------------------------------------------------------------------------------------
#
# グループ作成/編集
# -------------------------------------------------------------------------------------
# @param $Sys システム変数
# @param $Form フォーム変数
# @param $mode 編集:1, 作成:0
# @param $pLog ログ用
# @return エラーコード
#
# 2010.08.12 windyakin ★
# -> キャップ権限の追加
#
#------------------------------------------------------------------------------------------------------------
sub FunctionGroupSetting
{
my ($Sys, $Form, $mode, $pLog) = @_;
my ($Group, $User, @userSet, @authNum, @belongUser);
my ($name, $expl, $color, $auth, $user, $i);
# 権限チェック
{
my $SEC = $Sys->Get('ADMIN')->{'SECINFO'};
my $chkID = $Sys->Get('ADMIN')->{'USER'};
if (($SEC->IsAuthority($chkID, $ZP::AUTH_CAPGROUP, $Sys->Get('BBS'))) == 0) {
return 1000;
}
}
# 入力チェック
{
my @inList = ('GROUPNAME_CAP');
if (! $Form->IsInput(\@inList)) {
return 1001;
}
}
require './module/ungoliants.pl';
$User = UNGOLIANT->new;
$Group = SHELOB->new;
# ユーザ情報の読み込み
$User->Load($Sys);
$Group->Load($Sys, 1);
# 基本情報の設定
$name = $Form->Get('GROUPNAME_CAP');
$expl = $Form->Get('GROUPSUBS_CAP');
$color = $Form->Get('GROUPCOLOR_CAP');
$color =~ s/[^\w\d\#]//ig;
# 権限情報の生成
my %field2auth = (
'C_SUBJECT' => $ZP::CAP_FORM_LONGSUBJECT,
'C_NAME' => $ZP::CAP_FORM_LONGNAME,
'C_MAIL' => $ZP::CAP_FORM_LONGMAIL,
'C_CONTENTS' => $ZP::CAP_FORM_LONGTEXT,
'C_CONTLINE' => $ZP::CAP_FORM_MANYLINE,
'C_LINECOUNT' => $ZP::CAP_FORM_LONGLINE,
'C_NONAME' => $ZP::CAP_FORM_NONAME,
'C_THREAD' => $ZP::CAP_REG_MANYTHREAD,
'C_THREADCAP' => $ZP::CAP_LIMIT_THREADCAPONLY,
'C_CONTINUAS' => $ZP::CAP_REG_NOBREAKPOST,
'C_DUPLICATE' => $ZP::CAP_REG_DOUBLEPOST,
'C_SHORTWRITE' => $ZP::CAP_REG_NOTIMEPOST,
'C_READONLY' => $ZP::CAP_LIMIT_READONLY,
'C_CUSTOMID' => $ZP::CAP_DISP_CUSTOMID,
'C_IDDISP' => $ZP::CAP_DISP_NOID,
'C_NOSLIP' => $ZP::CAP_DISP_NOSLIP,
'C_HOSTDISP' => $ZP::CAP_DISP_NOHOST,
'C_MOBILETHREAD' => $ZP::CAP_LIMIT_MOBILETHREAD,
'C_FIXHANLDLE' => $ZP::CAP_DISP_HANLDLE,
'C_SAMBA' => $ZP::CAP_REG_SAMBA,
'C_PROXY' => $ZP::CAP_REG_DNSBL,
'C_JPHOST' => $ZP::CAP_REG_NOTJPHOST,
'C_NGUSER' => $ZP::CAP_REG_NGUSER,
'C_NGWORD' => $ZP::CAP_REG_NGWORD,
);
my @auths = ();
foreach (keys %field2auth) {
if ($Form->Equal($_, 'on')) {
push @auths, $field2auth{$_};
}
}
$auth = join(',', @auths);
# 所属ユーザ情報の生成
@belongUser = $Form->GetAtArray('BELONGUSER_CAP');
$user = join(',', @belongUser);
# 設定情報の登録
if ($mode){
my $groupID = $Form->Get('SELECT_CAPGROUP');
$Group->Set($groupID, 'NAME', $name);
$Group->Set($groupID, 'EXPL', $expl);
$Group->Set($groupID, 'COLOR', $color);
$Group->Set($groupID, 'AUTH', $auth);
$Group->Set($groupID, 'CAPS', $user);
$Group->Set($groupID, 'ISCOMMON', 1);
}
else {
$Group->Add($name, $expl, $color, $auth, $user, 1);
}
# 設定を保存
$Group->Save($Sys, 1);
# 処理ログ
{
my $id;
push @$pLog, '■以下のキャップグループを登録しました。';
push @$pLog, "グループ名称：$name";
push @$pLog, "説明：$expl";
push @$pLog, "色：$color";
push @$pLog, "権限：$auth";
push @$pLog, '所属キャップ：';
foreach $id (@belongUser){
push @$pLog, ' > ' . $User->Get('NAME', $id);
}
}
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# グループ削除
# -------------------------------------------------------------------------------------
# @param $Sys システム変数
# @param $Form フォーム変数
# @param $pLog ログ用
# @return エラーコード
#
#------------------------------------------------------------------------------------------------------------
sub FunctionGroupDelete
{
my ($Sys, $Form, $pLog) = @_;
my ($Group, @groupSet, $id);
# 権限チェック
{
my $SEC = $Sys->Get('ADMIN')->{'SECINFO'};
my $chkID = $Sys->Get('ADMIN')->{'USER'};
if (($SEC->IsAuthority($chkID, $ZP::AUTH_CAPGROUP, $Sys->Get('BBS'))) == 0) {
return 1000;
}
}
require './module/ungoliants.pl';
$Group = SHELOB->new;
# ユーザ情報の読み込み
$Group->Load($Sys, 1);
push @$pLog, '■以下のグループを削除しました。';
@groupSet = $Form->GetAtArray('CAP_GROUPS');
foreach $id (@groupSet) {
next if (! defined $Group->Get('NAME', $id));
push @$pLog, $Group->Get('NAME', $id, '') . '(' . $Group->Get('EXPL', $id, '') . ')';
$Group->Delete($id);
}
# 設定の保存
$Group->Save($Sys, 1);
return 0;
}
#============================================================================================================
# Module END
#============================================================================================================
1;
zerochplus_0.7.4/test/mordor/sys.edit.pl 0000644 0000764 0001040 00000031442 12236106656 015311 0 ustar #============================================================================================================
#
# システム管理 - 編集 モジュール
# sys.edit.pl
# ---------------------------------------------------------------------------
# 2004.09.15 start
#
#============================================================================================================
package MODULE;
use strict;
#use warnings;
#------------------------------------------------------------------------------------------------------------
#
# コンストラクタ
# -------------------------------------------------------------------------------------
# @param なし
# @return モジュールオブジェクト
#
#------------------------------------------------------------------------------------------------------------
sub new
{
my $this = shift;
my ($obj, @LOG);
$obj = {
'LOG' => \@LOG
};
bless $obj, $this;
return $obj;
}
#------------------------------------------------------------------------------------------------------------
#
# 表示メソッド
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @param $Form SAMWISE
# @param $pSys 管理システム
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub DoPrint
{
my $this = shift;
my ($Sys, $Form, $pSys) = @_;
my ($subMode, $BASE, $Page);
require './mordor/sauron.pl';
$BASE = SAURON->new;
# 管理情報を登録
$Sys->Set('ADMIN', $pSys);
# 管理マスタオブジェクトの生成
$Page = $BASE->Create($Sys, $Form);
$subMode = $Form->Get('MODE_SUB');
# メニューの設定
SetMenuList($BASE, $pSys);
if ($subMode eq 'BANNER_PC') { # PC用告知編集画面
PrintBannerForPCEdit($Page, $Sys, $Form);
}
elsif ($subMode eq 'BANNER_MOBILE') { # 携帯用告知編集画面
PrintBannerForMobileEdit($Page, $Sys, $Form);
}
elsif ($subMode eq 'BANNER_SUB') { # サブ告知編集画面
PrintBannerForSubEdit($Page, $Sys, $Form);
}
elsif ($subMode eq 'COMPLETE') { # システム設定完了画面
$Sys->Set('_TITLE', 'Process Complete');
$BASE->PrintComplete('システム編集処理', $this->{'LOG'});
}
elsif ($subMode eq 'FALSE') { # システム設定失敗画面
$Sys->Set('_TITLE', 'Process Failed');
$BASE->PrintError($this->{'LOG'});
}
$BASE->Print($Sys->Get('_TITLE'), 1);
}
#------------------------------------------------------------------------------------------------------------
#
# 機能メソッド
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @param $Form SAMWISE
# @param $pSys 管理システム
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub DoFunction
{
my $this = shift;
my ($Sys, $Form, $pSys) = @_;
my ($subMode, $err);
# 管理情報を登録
$Sys->Set('ADMIN', $pSys);
$subMode = $Form->Get('MODE_SUB');
$err = 0;
if ($subMode eq 'BANNER_PC') { # PC用告知
$err = FunctionBannerEdit($Sys, $Form, 1, $this->{'LOG'});
}
elsif ($subMode eq 'BANNER_MOBILE') { # 携帯用告知
$err = FunctionBannerEdit($Sys, $Form, 2, $this->{'LOG'});
}
elsif ($subMode eq 'BANNER_SUB') { # サブバナー
$err = FunctionBannerEdit($Sys, $Form, 3, $this->{'LOG'});
}
# 処理結果表示
if ($err) {
$pSys->{'LOGGER'}->Put($Form->Get('UserName'), "SYSTEM_EDIT($subMode)", "ERROR:$err");
push @{$this->{'LOG'}}, $err;
$Form->Set('MODE_SUB', 'FALSE');
}
else {
$pSys->{'LOGGER'}->Put($Form->Get('UserName'), "SYSTEM_EDIT($subMode)", 'COMPLETE');
$Form->Set('MODE_SUB', 'COMPLETE');
}
$this->DoPrint($Sys, $Form, $pSys);
}
#------------------------------------------------------------------------------------------------------------
#
# メニューリスト設定
# -------------------------------------------------------------------------------------
# @param $Base SAURON
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub SetMenuList
{
my ($Base, $pSys) = @_;
$Base->SetMenu('告知編集(PC用)', "'sys.edit','DISP','BANNER_PC'");
$Base->SetMenu('告知編集(携帯用)', "'sys.edit','DISP','BANNER_MOBILE'");
$Base->SetMenu('告知編集(サブ)', "'sys.edit','DISP','BANNER_SUB'");
}
#------------------------------------------------------------------------------------------------------------
#
# 告知欄(PC)編集画面の表示
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintBannerForPCEdit
{
my ($Page, $SYS, $Form) = @_;
my ($Banner, $bgColor, $content, $common);
$SYS->Set('_TITLE', 'PC Banner Edit');
require './module/denethor.pl';
$Banner = DENETHOR->new;
$Banner->Load($SYS);
$Page->Print("以下のキャップグループを削除します。 ");
$Page->Print(" Group Name ");
$Page->Print("Subscription ");
# ユーザリストを出力
foreach $id (@groupSet) {
$name = $Group->Get('NAME', $id);
$expl = $Group->Get('EXPL', $id);
$Page->Print("$name $expl ");
$Page->Print("※注：削除したグループを元に戻すことはできません。
");
$Page->Print("※注：削除するグループに所属しているキャップはすべて未所属状態になります。Print("onclick=\"DoSubmit('sys.capg','FUNC','DELETE')\" class=\"delete\"> ");
$Page->Print("
");
}
#------------------------------------------------------------------------------------------------------------
#
# 告知欄(携帯)編集画面の表示
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintBannerForMobileEdit
{
my ($Page, $SYS, $Form) = @_;
my ($Banner, $bgColor, $content, $common);
$SYS->Set('_TITLE', 'Mobile Banner Edit');
require './module/denethor.pl';
$Banner = DENETHOR->new;
$Banner->Load($SYS);
$Page->Print("Preview ");
# 告知欄プレビュー表示
if ($Form->IsExist('PC_CONTENT')) {
$Banner->Set('COLPC', $Form->Get('PC_BGCOLOR'));
$Banner->Set('TEXTPC', $Form->Get('PC_CONTENT'));
$bgColor = $Form->Get('PC_BGCOLOR');
$content = $Form->Get('PC_CONTENT');
}
else {
$bgColor = $Banner->Get('COLPC');
$content = $Banner->Get('TEXTPC');
}
# プレビューデータの作成
my $BannerPage = THORIN->new;
$Banner->Print($BannerPage, 100, 0, 0);
$BannerPage->{'BUFF'} = CreatePreviewData($BannerPage->{'BUFF'});
$Page->Merge($BannerPage);
$common = "onclick=\"DoSubmit('sys.edit'";
$Page->Print(" 背景色 ");
$Page->Print(" 内容 ");
$Page->Print(" ※告知欄の表\示は設定で消すことができます。 [システム設定]→[表\示設定]→告知欄表\示(index.html以外の告知欄を表\示するのチェックをOFF) ");
$Page->Print(" ");
$Page->Print("");
$Page->Print(" ");
$Page->Print("
");
}
#------------------------------------------------------------------------------------------------------------
#
# 告知欄(サブ)編集画面の表示
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintBannerForSubEdit
{
my ($Page, $SYS, $Form) = @_;
my ($Banner, $content, $common);
$SYS->Set('_TITLE', 'Sub Banner Edit');
require './module/denethor.pl';
$Banner = DENETHOR->new;
$Banner->Load($SYS);
$Page->Print("Preview ");
# 告知欄プレビュー表示
if ($Form->IsExist('MOBILE_CONTENT')) {
$Banner->Set('COLMB', $Form->Get('MOBILE_BGCOLOR'));
$Banner->Set('TEXTMB', $Form->Get('MOBILE_CONTENT'));
$bgColor = $Form->Get('MOBILE_BGCOLOR');
$content = $Form->Get('MOBILE_CONTENT');
}
else {
$bgColor = $Banner->Get('COLMB');
$content = $Banner->Get('TEXTMB');
}
# プレビューデータの作成
my $BannerPage = THORIN->new;
$Banner->Print($BannerPage, 100, 0, 1);
$BannerPage->{'BUFF'} = CreatePreviewData($BannerPage->{'BUFF'});
$Page->Merge($BannerPage);
$common = "onclick=\"DoSubmit('sys.edit'";
$Page->Print(" 背景色 ");
$Page->Print(" 内容 ");
$Page->Print(" ");
$Page->Print(" ");
$Page->Print("");
$Page->Print(" ");
$Page->Print("
");
}
#------------------------------------------------------------------------------------------------------------
#
# 告知欄編集
# -------------------------------------------------------------------------------------
# @param $Sys システム変数
# @param $Form フォーム変数
# @param $pLog ログ用
# @return エラーコード
#
#------------------------------------------------------------------------------------------------------------
sub FunctionBannerEdit
{
my ($Sys, $Form, $mode, $pLog) = @_;
my ($Banner);
# 権限チェック
{
my $SEC = $Sys->Get('ADMIN')->{'SECINFO'};
my $chkID = $Sys->Get('ADMIN')->{'USER'};
if (($SEC->IsAuthority($chkID, $ZP::AUTH_SYSADMIN, '*')) == 0) {
return 1000;
}
}
# 入力チェック
if ($mode != 3) {
my @inList;
@inList = ('PC_CONTENT', 'PC_BGCOLOR') if ($mode == 1);
@inList = ('MOBILE_CONTENT', 'MOBILE_BGCOLOR') if ($mode == 2);
if (! $Form->IsInput(\@inList)) {
return 1001;
}
}
require './module/denethor.pl';
$Banner = DENETHOR->new;
$Banner->Load($Sys);
if ($mode == 1) {
$Banner->Set('TEXTPC', $Form->Get('PC_CONTENT'));
$Banner->Set('COLPC', $Form->Get('PC_BGCOLOR'));
push @$pLog, 'PC用告知欄を設定しました。';
}
elsif ($mode == 2) {
$Banner->Set('TEXTMB', $Form->Get('MOBILE_CONTENT'));
$Banner->Set('COLMB', $Form->Get('MOBILE_BGCOLOR'));
push @$pLog, '携帯用告知欄を設定しました。';
}
elsif ($mode == 3) {
$Banner->Set('TEXTSB', $Form->Get('SUB_CONTENT'));
push @$pLog, 'サブバナーを設定しました。';
}
# 設定の保存
$Banner->Save($Sys);
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# プレビューデータの作成
# -------------------------------------------------------------------------------------
# @param $pData 作成元配列の参照
# @return プレビューデータの配列
#
#------------------------------------------------------------------------------------------------------------
sub CreatePreviewData
{
my ($pData) = @_;
my @temp;
foreach (@$pData) {
$_ =~ s/<[fF][oO][rR][mM].*?>/Preview ");
# 告知欄プレビュー表示
if ($Form->IsExist('SUB_CONTENT')) {
$Banner->Set('TEXTSB', $Form->Get('SUB_CONTENT'));
$content = $Form->Get('SUB_CONTENT');
}
else {
$content = $Banner->Get('TEXTSB');
}
# プレビューデータの作成
my $BannerPage = THORIN->new;
$Banner->PrintSub($BannerPage);
$BannerPage->{'BUFF'} = CreatePreviewData($BannerPage->{'BUFF'});
$Page->Merge($BannerPage);
$common = "onclick=\"DoSubmit('sys.edit'";
$Page->Print(" 内容 ");
$Page->Print(" ");
$Page->Print(" ");
$Page->Print("");
$Page->Print("
/g;
$_ =~ s/<\/[fF][oO][rR][mM]>/
/g;
$_ =~ s/[nN][aA][mM][eE].*?=/_name_=/g;
push @temp, $_;
}
return \@temp;
}
#============================================================================================================
# Module END
#============================================================================================================
1;
zerochplus_0.7.4/test/mordor/sys.setting.pl 0000644 0000764 0001040 00000136046 12236106656 016047 0 ustar #============================================================================================================
#
# システム管理 - 設定 モジュール
# sys.setting.pl
# ---------------------------------------------------------------------------
# 2004.02.14 start
#
# ぜろちゃんねるプラス
# 2010.08.12 設定項目追加による改変
#
#============================================================================================================
package MODULE;
use strict;
#use warnings;
#------------------------------------------------------------------------------------------------------------
#
# コンストラクタ
# -------------------------------------------------------------------------------------
# @param なし
# @return モジュールオブジェクト
#
#------------------------------------------------------------------------------------------------------------
sub new
{
my $this = shift;
my ($obj, @LOG);
$obj = {
'LOG' => \@LOG
};
bless $obj, $this;
return $obj;
}
#------------------------------------------------------------------------------------------------------------
#
# 表示メソッド
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @param $Form SAMWISE
# @param $pSys 管理システム
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub DoPrint
{
my $this = shift;
my ($Sys, $Form, $pSys) = @_;
my ($subMode, $BASE, $Page);
require './mordor/sauron.pl';
$BASE = SAURON->new;
# 管理情報を登録
$Sys->Set('ADMIN', $pSys);
# 管理マスタオブジェクトの生成
$Page = $BASE->Create($Sys, $Form);
$subMode = $Form->Get('MODE_SUB');
# メニューの設定
SetMenuList($BASE, $pSys);
if ($subMode eq 'INFO') { # システム情報画面
PrintSystemInfo($Page, $Sys, $Form);
}
elsif ($subMode eq 'BASIC') { # 基本設定画面
PrintBasicSetting($Page, $Sys, $Form);
}
elsif ($subMode eq 'PERMISSION') { # パーミッション設定画面
PrintPermissionSetting($Page, $Sys, $Form);
}
elsif ($subMode eq 'LIMITTER') { # リミッタ設定画面
PrintLimitterSetting($Page, $Sys, $Form);
}
elsif ($subMode eq 'OTHER') { # その他設定画面
PrintOtherSetting($Page, $Sys, $Form);
}
=pod
elsif ($subMode eq 'PLUS') { # ぜろプラスオリジナル
PrintPlusSetting($Page, $Sys, $Form);
}
=cut
elsif ($subMode eq 'VIEW') { # 表示設定
PrintPlusViewSetting($Page, $Sys, $Form);
}
elsif ($subMode eq 'SEC') { # 規制設定
PrintPlusSecSetting($Page, $Sys, $Form);
}
elsif ($subMode eq 'PLUGIN') { # 拡張機能設定画面
PrintPluginSetting($Page, $Sys, $Form);
}
elsif ($subMode eq 'PLUGINCONF') { # 拡張機能個別設定設定画面
PrintPluginOptionSetting($Page, $Sys, $Form);
}
elsif ($subMode eq 'COMPLETE') { # システム設定完了画面
$Sys->Set('_TITLE', 'Process Complete');
$BASE->PrintComplete('システム設定処理', $this->{'LOG'});
}
elsif ($subMode eq 'FALSE') { # システム設定失敗画面
$Sys->Set('_TITLE', 'Process Failed');
$BASE->PrintError($this->{'LOG'});
}
$BASE->Print($Sys->Get('_TITLE'), 1);
}
#------------------------------------------------------------------------------------------------------------
#
# 機能メソッド
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @param $Form SAMWISE
# @param $pSys 管理システム
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub DoFunction
{
my $this = shift;
my ($Sys, $Form, $pSys) = @_;
my ($subMode, $err);
# 管理情報を登録
$Sys->Set('ADMIN', $pSys);
$subMode = $Form->Get('MODE_SUB');
$err = 0;
if ($subMode eq 'BASIC') { # 基本設定
$err = FunctionBasicSetting($Sys, $Form, $this->{'LOG'});
}
elsif ($subMode eq 'PERMISSION') { # パーミッション設定
$err = FunctionPermissionSetting($Sys, $Form, $this->{'LOG'});
}
elsif ($subMode eq 'LIMITTER') { # 制限設定
$err = FunctionLimitterSetting($Sys, $Form, $this->{'LOG'});
}
elsif ($subMode eq 'OTHER') { # その他設定
$err = FunctionOtherSetting($Sys, $Form, $this->{'LOG'});
}
=pod
elsif ($subMode eq 'PLUS') { # ぜろプラスオリジナル
$err = FunctionPlusSetting($Sys, $Form, $this->{'LOG'});
}
=cut
elsif ($subMode eq 'VIEW') { # 表示設定
$err = FunctionPlusViewSetting($Sys, $Form, $this->{'LOG'});
}
elsif ($subMode eq 'SEC') { # 規制設定
$err = FunctionPlusSecSetting($Sys, $Form, $this->{'LOG'});
}
elsif ($subMode eq 'SET_PLUGIN') { # 拡張機能情報設定
$err = FunctionPluginSetting($Sys, $Form, $this->{'LOG'});
}
elsif ($subMode eq 'UPDATE_PLUGIN') { # 拡張機能情報更新
$err = FunctionPluginUpdate($Sys, $Form, $this->{'LOG'});
}
elsif ($subMode eq 'SET_PLUGINCONF') { # 拡張機能個別設定設定
$err = FunctionPluginOptionSetting($Sys, $Form, $this->{'LOG'});
}
# 処理結果表示
if ($err) {
$pSys->{'LOGGER'}->Put($Form->Get('UserName'),"SYSTEM_SETTING($subMode)", "ERROR:$err");
push @{$this->{'LOG'}}, $err;
$Form->Set('MODE_SUB', 'FALSE');
}
else {
$pSys->{'LOGGER'}->Put($Form->Get('UserName'),"SYSTEM_SETTING($subMode)", 'COMPLETE');
$Form->Set('MODE_SUB', 'COMPLETE');
}
$this->DoPrint($Sys, $Form, $pSys);
}
#------------------------------------------------------------------------------------------------------------
#
# メニューリスト設定
# -------------------------------------------------------------------------------------
# @param $Base SAURON
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub SetMenuList
{
my ($Base, $pSys) = @_;
$Base->SetMenu('情報', "'sys.setting','DISP','INFO'");
# システム管理権限のみ
if ($pSys->{'SECINFO'}->IsAuthority($pSys->{'USER'}, $ZP::AUTH_SYSADMIN, '*')) {
$Base->SetMenu('
', '');
$Base->SetMenu('基本設定', "'sys.setting','DISP','BASIC'");
$Base->SetMenu('パーミッション設定', "'sys.setting','DISP','PERMISSION'");
$Base->SetMenu('リミッタ設定', "'sys.setting','DISP','LIMITTER'");
$Base->SetMenu('その他設定', "'sys.setting','DISP','OTHER'");
$Base->SetMenu('
', '');
$Base->SetMenu('表示設定', "'sys.setting','DISP','VIEW'");
$Base->SetMenu('規制設定', "'sys.setting','DISP','SEC'");
$Base->SetMenu('
', '');
$Base->SetMenu('拡張機能\設定', "'sys.setting','DISP','PLUGIN'");
}
}
#------------------------------------------------------------------------------------------------------------
#
# システム情報画面の表示
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintSystemInfo
{
my ($Page, $SYS, $Form) = @_;
$SYS->Set('_TITLE', '0ch+ Administrator Information');
my $zerover = $SYS->Get('VERSION');
my $perlver = $];
my $perlpath = $^X;
my $filename = $ENV{'SCRIPT_FILENAME'} || $0;
my $serverhost = $ENV{'HTTP_HOST'};
my $servername = $ENV{'SERVER_NAME'};
my $serversoft = $ENV{'SERVER_SOFTWARE'};
my @checklist = (qw(
Encode
Time::HiRes
Time::Local
Socket
), qw(
CGI::Session
Storable
Digest::SHA::PurePerl
Net::DNS::Lite
List::MoreUtils
LWP::UserAgent
XML::Simple
), qw(
Net::DNS
));
my $core = {};
eval {
require Module::CoreList;
$core = $Module::CoreList::version{$perlver};
};
$Page->Print("
0ch+ BBS - Administrator Script");
$Page->Print("");
$Page->Print("
");
}
#------------------------------------------------------------------------------------------------------------
#
# システム基本設定画面の表示
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintBasicSetting
{
my ($Page, $SYS, $Form) = @_;
my ($server, $cgi, $bbs, $info, $data, $common);
$SYS->Set('_TITLE', 'System Base Setting');
$server = $SYS->Get('SERVER');
$cgi = $SYS->Get('CGIPATH');
$bbs = $SYS->Get('BBSPATH');
$info = $SYS->Get('INFO');
$data = $SYS->Get('DATA');
$common = "onclick=\"DoSubmit('sys.setting','FUNC','BASIC');\"";
if ($server eq '') {
my $sname = $ENV{'SERVER_NAME'};
$server = "http://$sname";
}
if ($cgi eq '') {
my $path = $ENV{'SCRIPT_NAME'};
$path =~ s|/[^/]+/[^/]+$||;
$cgi = "$path$cgi";
}
$Page->Print("■0ch+ Information Version $zerover ■Perl Information Version $perlver Perl Path $perlpath Server Software $serversoft Server Name $servername Server Host $serverhost Script Path $filename ■Perl Packages (include perllib) $pkg $var ");
$Page->Print("
");
}
#------------------------------------------------------------------------------------------------------------
#
# パーミッション設定画面の表示
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintPermissionSetting
{
my ($Page, $Sys, $Form) = @_;
$Sys->Set('_TITLE', 'System Permission Setting');
my $datP = sprintf("%o", $Sys->Get('PM-DAT'));
my $txtP = sprintf("%o", $Sys->Get('PM-TXT'));
my $logP = sprintf("%o", $Sys->Get('PM-LOG'));
my $admP = sprintf("%o", $Sys->Get('PM-ADM'));
my $stopP = sprintf("%o", $Sys->Get('PM-STOP'));
my $admDP = sprintf("%o", $Sys->Get('PM-ADIR'));
my $bbsDP = sprintf("%o", $Sys->Get('PM-BDIR'));
my $logDP = sprintf("%o", $Sys->Get('PM-LDIR'));
my $kakoDP = sprintf("%o", $Sys->Get('PM-KDIR'));
my $common = "onclick=\"DoSubmit('sys.setting','FUNC','PERMISSION');\"";
$Page->Print("各項目を設定して[設定]ボタンを押してください。
\n");
$Page->Print("いくつかの例を挙げます。
\n");
$Page->Print(" 例1: http://example.jp/test/admin.cgi
\n");
$Page->Print(" 例2: http://example.net/~user/test/admin.cgi
\n");
$Page->Print(" 例3: http://example.com/cgi-bin/test/admin.cgi稼動サーバ(末尾の / は要りません) ");
$Page->Print("
");
$Page->Print(" 例1: http://example.jp
");
$Page->Print(" 例2: http://example.netCGI設置ディレクトリ(絶対パス) ");
$Page->Print("
");
$Page->Print(" 例1: /test
");
$Page->Print(" 例2: /~user/test
");
$Page->Print(" 例3: /cgi-bin/test掲示板配置ディレクトリ(相対パス) ");
$Page->Print("
");
$Page->Print(" 例1: .jp/bbs1/ → ..
");
$Page->Print(" 例2: .net/~user/bbs2/ → ..
");
$Page->Print(" 例3: .com/bbs3/ → ../..システム情報ディレクトリ(/ から始める)
");
$Page->Print(" 例1: .jp/test/info → /info
");
$Page->Print("システムデータディレクトリ(/ から始める)
");
$Page->Print(" 例1: .jp/test/info → /datas
");
$Page->Print("");
$Page->Print(" ");
$Page->Print("
");
}
#------------------------------------------------------------------------------------------------------------
#
# 制限設定画面の表示
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @return なし
#
# 2010.08.12 windyakin ★
# -> システム変更に伴う設定項目の追加
#
#------------------------------------------------------------------------------------------------------------
sub PrintLimitterSetting
{
my ($Page, $SYS, $Form) = @_;
my (@vSYS, $common);
$SYS->Set('_TITLE', 'System Limitter Setting');
$common = "onclick=\"DoSubmit('sys.setting','FUNC','LIMITTER');\"";
$vSYS[0] = $SYS->Get('RESMAX');
$vSYS[1] = $SYS->Get('SUBMAX');
$vSYS[2] = $SYS->Get('ANKERS');
$vSYS[3] = $SYS->Get('ERRMAX');
$vSYS[4] = $SYS->Get('HSTMAX');
$vSYS[5] = $SYS->Get('ADMMAX');
$Page->Print("各項目を設定して[設定]ボタンを押してください。
");
$Page->Print("（8進値で設定すること）datファイルパーミッション ");
$Page->Print("テキストファイルパーミッション ");
$Page->Print("ログファイルパーミッション ");
$Page->Print("管理ファイルパーミッション ");
$Page->Print("停止スレッドファイルパーミッション ");
$Page->Print("管理ディレクトリパーミッション ");
$Page->Print("掲示板ディレクトリパーミッション ");
$Page->Print("ログ保存ディレクトリパーミッション ");
$Page->Print("過去ログ倉庫ディレクトリパーミッション ");
$Page->Print("");
$Page->Print(" ");
$Page->Print("
");
}
#------------------------------------------------------------------------------------------------------------
#
# その他設定画面の表示
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintOtherSetting
{
my ($Page, $SYS, $Form) = @_;
my ($urlLink, $linkSt, $linkEd, $pathKind, $headText, $headUrl, $FastMode, $BBSGET, $upCheck);
my ($linkChk, $pathInfo, $pathQuery, $fastMode, $bbsget);
my ($common);
$SYS->Set('_TITLE', 'System Other Setting');
$urlLink = $SYS->Get('URLLINK');
$linkSt = $SYS->Get('LINKST');
$linkEd = $SYS->Get('LINKED');
$pathKind = $SYS->Get('PATHKIND');
$headText = $SYS->Get('HEADTEXT');
$headUrl = $SYS->Get('HEADURL');
$FastMode = $SYS->Get('FASTMODE');
$BBSGET = $SYS->Get('BBSGET');
$upCheck = $SYS->Get('UPCHECK');
$linkChk = ($urlLink eq 'TRUE' ? 'checked' : '');
$fastMode = ($FastMode == 1 ? 'checked' : '');
$pathInfo = ($pathKind == 0 ? 'checked' : '');
$pathQuery = ($pathKind == 1 ? 'checked' : '');
$bbsget = ($BBSGET == 1 ? 'checked' : '');
$common = "onclick=\"DoSubmit('sys.setting','FUNC','OTHER');\"";
$Page->Print("各項目を設定して[設定]ボタンを押してください。 1掲示板のsubject最大保持数 ");
$Page->Print("1スレッドのレス最大数 ");
$Page->Print("1レスのアンカー最大数(0で無制限) ");
$Page->Print("エラーログ最大保持数 ");
$Page->Print("ホストログ最大保持数 ");
$Page->Print("管理操作ログ最大保持数 ");
$Page->Print("");
$Page->Print(" ");
$Page->Print("
");
}
#------------------------------------------------------------------------------------------------------------
#
# 表示設定画面の表示(ぜろちゃんねるプラスオリジナル)
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @return なし
#
# 2010.09.08 windyakin ★
# -> 表示設定と規制設定の分離
#
#------------------------------------------------------------------------------------------------------------
sub PrintPlusViewSetting
{
my ($Page, $SYS, $Form) = @_;
$SYS->Set('_TITLE', 'System View Setting');
my $Banner = $SYS->Get('BANNER');
my $Counter = $SYS->Get('COUNTER');
my $Prtext = $SYS->Get('PRTEXT');
my $Prlink = $SYS->Get('PRLINK');
my $Msec = $SYS->Get('MSEC');
my $bannerindex = ($Banner & 3 ? 'checked' : '');
my $banner = ($Banner & 5 ? 'checked' : '');
my $msec = ($Msec == 1 ? 'checked' : '');
my $common = "onclick=\"DoSubmit('sys.setting','FUNC','VIEW');\"";
$Page->Print("各項目を設定して[設定]ボタンを押してください。 ヘッダ関連 ヘッダ下部に表\示するテキスト ");
$Page->Print("上記テキストに貼\るリンクのURL ");
$Page->Print("本文中のURL ");
$Page->Print("本文中URLへの自動リンク ");
$Page->Print("以下自動リンクOFF時のみ有効 リンク禁止時間帯 ");
$Page->Print("時 〜 ");
$Page->Print("時 動作モード(read.cgi) PATH種別 ");
$Page->Print("PATHINFO ");
$Page->Print("QUERYSTRING ");
$Page->Print("高速書き込みモード ");
$Page->Print("bbs.cgiのGETメソ\ッド bbs.cgiでGETメソ\ッドを使用する ");
$Page->Print("更新チェック関連 更新チェックの間隔 ");
$Page->Print("日(0でチェック無効) ");
$Page->Print(" ");
$Page->Print("
");
}
#------------------------------------------------------------------------------------------------------------
#
# 規制設定画面の表示(ぜろちゃんねるプラスオリジナル)
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @return なし
#
# 2010.09.08 windyakin ★
# -> 表示設定と規制設定の分離
#
#------------------------------------------------------------------------------------------------------------
sub PrintPlusSecSetting
{
my ($Page, $SYS, $Form) = @_;
my ($Kakiko, $Samba, $DefSamba, $DefHoushi, $Trip12, $BBQ, $BBX);
my ($kakiko, $trip12, $bbq, $bbx);
my ($common);
$SYS->Set('_TITLE', 'System Regulation Setting');
$Kakiko = $SYS->Get('KAKIKO');
$Samba = $SYS->Get('SAMBATM');
$DefSamba = $SYS->Get('DEFSAMBA');
$DefHoushi = $SYS->Get('DEFHOUSHI');
$Trip12 = $SYS->Get('TRIP12');
$BBQ = $SYS->Get('BBQ');
$BBX = $SYS->Get('BBX');
$kakiko = ($Kakiko == 1 ? 'checked' : '');
$trip12 = ($Trip12 == 1 ? 'checked' : '');
$bbq = ($BBQ == 1 ? 'checked' : '');
$bbx = ($BBX == 1 ? 'checked' : '');
$common = "onclick=\"DoSubmit('sys.setting','FUNC','SEC');\"";
$Page->Print("各項目を設定して[設定]ボタンを押してください。 Read.cgi関連 ofuda.ccのアカウント名を入力 (未入力でカウンター非表\示) ");
$Page->Print("PR欄の表\示文字列 (未入力でPR欄非表\示) ");
$Page->Print("PR欄のリンクURL ");
$Page->Print("告知欄表\示 index.htmlの告知欄を表\示する ");
$Page->Print("index.html以外の告知欄を表\示する ");
$Page->Print("msec表\示 ミリ秒まで表\示する ");
$Page->Print("");
$Page->Print(" ");
$Page->Print("
");
}
#------------------------------------------------------------------------------------------------------------
#
# 拡張機能設定画面の表示
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintPluginSetting
{
my ($Page, $SYS, $Form) = @_;
my (@pluginSet, $num, $common, $Plugin);
$SYS->Set('_TITLE', 'System Plugin Setting');
$common = "onclick=\"DoSubmit('sys.setting','FUNC'";
require './module/athelas.pl';
$Plugin = ATHELAS->new;
$Plugin->Load($SYS);
$num = $Plugin->GetKeySet('ALL', '', \@pluginSet);
# 拡張機能が存在する場合は有効・無効設定画面を表示
if ($num > 0) {
my ($id, $file, $class, $name, $expl, $valid);
$Page->Print("各項目を設定して[設定]ボタンを押してください。 ２重かきこですか？？ 同じIPからの書き込みの文字数が変化しない場合規制する ");
$Page->Print("短時間投稿規制 短時間投稿規制秒数を入力(0で規制無効) ");
$Page->Print("Samba規制 Samba待機秒数デフォルト値を入力(0で規制無効) ");
$Page->Print("
");
$Page->Print("Sambaの設定は掲示板ごとに設定できますSamba奉仕時間(分)デフォルト値を入力 ");
$Page->Print("新仕様トリップ 新仕様トリップ(12桁=SHA-1)を有効にする ");
$Page->Print("DNSBL設定 適用するDNSBLにチェックをいれてください
\n");
$Page->Print("");
$Page->Print("BBQ\n");
$Page->Print("BBX\n");
$Page->Print("");
$Page->Print(" ");
$Page->Print("
HTML
}
#------------------------------------------------------------------------------------------------------------
#
# ユーザ通知作成画面の表示
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintNoticeCreate
{
my ($Page, $Sys, $Form) = @_;
my ($isSysad, $User, @userSet, $id, $name, $full, $common);
$Sys->Set('_TITLE', 'User Notice Create');
$isSysad = $Sys->Get('ADMIN')->{'SECINFO'}->IsAuthority($Sys->Get('ADMIN')->{'USER'}, $ZP::AUTH_SYSADMIN, '*');
$User = $Sys->Get('ADMIN')->{'SECINFO'}->{'USER'};
$User->GetKeySet('ALL', '', \@userSet);
$Page->Print(<有効にする機能\にチェックを入れてください。 ");
$Page->Print(" \n");
for my $i (0 .. $#pluginSet) {
$id = $pluginSet[$i];
$file = $Plugin->Get('FILE', $id);
$class = $Plugin->Get('CLASS', $id);
$name = $Plugin->Get('NAME', $id);
$expl = $Plugin->Get('EXPL', $id);
$valid = $Plugin->Get('VALID', $id) == 1 ? 'checked' : '';
$Page->Print("Order ");
$Page->Print("Function Name ");
$Page->Print("Explanation ");
$Page->Print("File ");
$Page->Print("Options ");
$Page->Print(" $name ");
$Page->Print("$expl $file ");
if ($class->can('getConfig') && scalar(keys %{$class->getConfig()}) > 0) {
$Page->Print("Print("DoSubmit('sys.setting','DISP','PLUGINCONF');\">個別設定 ");
}
else {
$Page->Print("");
}
$Page->Print(" ");
$Page->Print(" ");
}
else {
$Page->Print(" ");
$Page->Print("
");
}
#------------------------------------------------------------------------------------------------------------
#
# 拡張機能個別設定設定画面の表示
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintPluginOptionSetting
{
my ($Page, $SYS, $Form) = @_;
my ($common, $Plugin, $Config, %conftype);
my ($id, $file, $className, $conf);
$id = $Form->Get('PLGID');
require './module/athelas.pl';
$Plugin = ATHELAS->new;
$Plugin->Load($SYS);
$Config = PLUGINCONF->new($Plugin, $id);
$SYS->Set('_TITLE', 'System Plugin Option Setting - ' . $Plugin->Get('NAME', $id));
$common = "onclick=\"DoSubmit('sys.setting','FUNC'";
$file = $Plugin->Get('FILE', $id);
require "./plugin/$file";
$file =~ /^0ch_(.*)\.pl$/;
$className = "ZPL_$1";
if ($className->can('getConfig')) {
my $plugin = $className->new;
$conf = $plugin->getConfig();
}
$Page->Print("プラグインは存在しません。 ");
}
$Page->Print("");
$Page->Print("");
$Page->Print(" ");
$Page->Print("
");
}
#------------------------------------------------------------------------------------------------------------
#
# 拡張機能個別設定設定
# -------------------------------------------------------------------------------------
# @param $Sys システム変数
# @param $Form フォーム変数
# @param $pLog ログ用
# @return エラーコード
#
#------------------------------------------------------------------------------------------------------------
sub FunctionPluginOptionSetting
{
my ($Sys, $Form, $pLog) = @_;
my ($common, $Plugin, $Config, %conftype);
my ($id, $file, $className, $plugin, $conf);
# 権限チェック
{
my $SEC = $Sys->Get('ADMIN')->{'SECINFO'};
my $chkID = $Sys->Get('ADMIN')->{'USER'};
if (($SEC->IsAuthority($chkID, $ZP::AUTH_SYSADMIN, '*')) == 0) {
return 1000;
}
}
$id = $Form->Get('PLGID');
require './module/athelas.pl';
$Plugin = ATHELAS->new;
$Plugin->Load($Sys);
$Config = PLUGINCONF->new($Plugin, $id);
$file = $Plugin->Get('FILE', $id);
require "./plugin/$file";
$file =~ /^0ch_(.*)\.pl$/;
$className = "ZPL_$1";
$plugin = new $className;
if ($className->can('getConfig')) {
$conf = $plugin->getConfig();
}
if (defined $conf) {
push @$pLog, "$className";
foreach my $key (sort keys %$conf) {
my ($val);
$val = $Form->Get('PLUGIN_OPT_' . unpack('H*', $key));
$Config->SetConfig($key, $val);
push @$pLog, "$key を設定しました。";
}
}
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# 基本設定
# -------------------------------------------------------------------------------------
# @param $Sys システム変数
# @param $Form フォーム変数
# @param $pLog ログ用
# @return エラーコード
#
#------------------------------------------------------------------------------------------------------------
sub FunctionBasicSetting
{
my ($Sys, $Form, $pLog) = @_;
my ($SYSTEM);
# 権限チェック
{
my $SEC = $Sys->Get('ADMIN')->{'SECINFO'};
my $chkID = $Sys->Get('ADMIN')->{'USER'};
if (($SEC->IsAuthority($chkID, $ZP::AUTH_SYSADMIN, '*')) == 0) {
return 1000;
}
}
# 入力チェック
{
my @inList = ('SERVER', 'CGIPATH', 'BBSPATH', 'INFO', 'DATA');
if (! $Form->IsInput(\@inList)) {
return 1001;
}
}
require './module/melkor.pl';
$SYSTEM = MELKOR->new;
$SYSTEM->Init();
$SYSTEM->Set('SERVER', $Form->Get('SERVER'));
$SYSTEM->Set('CGIPATH', $Form->Get('CGIPATH'));
$SYSTEM->Set('BBSPATH', $Form->Get('BBSPATH'));
$SYSTEM->Set('INFO', $Form->Get('INFO'));
$SYSTEM->Set('DATA', $Form->Get('DATA'));
$SYSTEM->Save();
# ログの設定
{
push @$pLog, '■ 基本設定';
push @$pLog, ' サーバ：' . $Form->Get('SERVER');
push @$pLog, ' CGIパス：' . $Form->Get('CGIPATH');
push @$pLog, ' 掲示板パス：' . $Form->Get('BBSPATH');
push @$pLog, ' 管理データフォルダ：' . $Form->Get('INFO');
push @$pLog, ' 基本データフォルダ：' . $Form->Get('DATA');
}
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# パーミッション設定
# -------------------------------------------------------------------------------------
# @param $Sys システム変数
# @param $Form フォーム変数
# @param $pLog ログ用
# @return エラーコード
#
#------------------------------------------------------------------------------------------------------------
sub FunctionPermissionSetting
{
my ($Sys, $Form, $pLog) = @_;
my ($SYSTEM);
# 権限チェック
{
my $SEC = $Sys->Get('ADMIN')->{'SECINFO'};
my $chkID = $Sys->Get('ADMIN')->{'USER'};
if (($SEC->IsAuthority($chkID, $ZP::AUTH_SYSADMIN, '*')) == 0) {
return 1000;
}
}
require './module/melkor.pl';
$SYSTEM = MELKOR->new;
$SYSTEM->Init();
$SYSTEM->Set('PM-DAT', oct($Form->Get('PERM_DAT')));
$SYSTEM->Set('PM-TXT', oct($Form->Get('PERM_TXT')));
$SYSTEM->Set('PM-LOG', oct($Form->Get('PERM_LOG')));
$SYSTEM->Set('PM-ADM', oct($Form->Get('PERM_ADMIN')));
$SYSTEM->Set('PM-STOP', oct($Form->Get('PERM_STOP')));
$SYSTEM->Set('PM-ADIR', oct($Form->Get('PERM_ADMIN_DIR')));
$SYSTEM->Set('PM-BDIR', oct($Form->Get('PERM_BBS_DIR')));
$SYSTEM->Set('PM-LDIR', oct($Form->Get('PERM_LOG_DIR')));
$SYSTEM->Set('PM-KDIR', oct($Form->Get('PERM_KAKO_DIR')));
$SYSTEM->Save();
# ログの設定
{
push @$pLog, '■ 基本設定';
push @$pLog, ' datパーミッション：' . $Form->Get('PERM_DAT');
push @$pLog, ' txtパーミッション：' . $Form->Get('PERM_TXT');
push @$pLog, ' logパーミッション：' . $Form->Get('PERM_LOG');
push @$pLog, ' 管理ファイルパーミッション：' . $Form->Get('PERM_ADMIN');
push @$pLog, ' 停止スレッドパーミッション：' . $Form->Get('PERM_STOP');
push @$pLog, ' 管理DIRパーミッション：' . $Form->Get('PERM_ADMIN_DIR');
push @$pLog, ' 掲示板DIRパーミッション：' . $Form->Get('PERM_BBS_DIR');
push @$pLog, ' ログDIRパーミッション：' . $Form->Get('PERM_LOG_DIR');
push @$pLog, ' 倉庫DIRパーミッション：' . $Form->Get('PERM_KAKO_DIR');
}
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# 制限値設定
# -------------------------------------------------------------------------------------
# @param $Sys システム変数
# @param $Form フォーム変数
# @param $pLog ログ用
# @return エラーコード
#
#------------------------------------------------------------------------------------------------------------
sub FunctionLimitterSetting
{
my ($Sys, $Form, $pLog) = @_;
my ($SYSTEM);
# 権限チェック
{
my $SEC = $Sys->Get('ADMIN')->{'SECINFO'};
my $chkID = $Sys->Get('ADMIN')->{'USER'};
if (($SEC->IsAuthority($chkID, $ZP::AUTH_SYSADMIN, '*')) == 0) {
return 1000;
}
}
require './module/melkor.pl';
$SYSTEM = MELKOR->new;
$SYSTEM->Init();
$SYSTEM->Set('RESMAX', $Form->Get('RESMAX'));
$SYSTEM->Set('SUBMAX', $Form->Get('SUBMAX'));
$SYSTEM->Set('ANKERS', $Form->Get('ANKERS'));
$SYSTEM->Set('ERRMAX', $Form->Get('ERRMAX'));
$SYSTEM->Set('HSTMAX', $Form->Get('HSTMAX'));
$SYSTEM->Set('ADMMAX', $Form->Get('ADMMAX'));
$SYSTEM->Save();
# ログの設定
{
push @$pLog, '■ 基本設定';
push @$pLog, ' subject最大数：' . $Form->Get('SUBMAX');
push @$pLog, ' レス最大数：' . $Form->Get('RESMAX');
push @$pLog, ' アンカー最大数：' . $Form->Get('ANKERS');
push @$pLog, ' エラーログ最大数：' . $Form->Get('ERRMAX');
push @$pLog, ' ホストログ最大数：' . $Form->Get('HSTMAX');
push @$pLog, ' 管理操作ログ最大数：' . $Form->Get('ADMMAX');
}
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# その他設定
# -------------------------------------------------------------------------------------
# @param $Sys システム変数
# @param $Form フォーム変数
# @param $pLog ログ用
# @return エラーコード
#
#------------------------------------------------------------------------------------------------------------
sub FunctionOtherSetting
{
my ($Sys, $Form, $pLog) = @_;
my ($SYSTEM);
# 権限チェック
{
my $SEC = $Sys->Get('ADMIN')->{'SECINFO'};
my $chkID = $Sys->Get('ADMIN')->{'USER'};
if (($SEC->IsAuthority($chkID, $ZP::AUTH_SYSADMIN, '*')) == 0) {
return 1000;
}
}
require './module/melkor.pl';
$SYSTEM = MELKOR->new;
$SYSTEM->Init();
$SYSTEM->Set('HEADTEXT', $Form->Get('HEADTEXT'));
$SYSTEM->Set('HEADURL', $Form->Get('HEADURL'));
$SYSTEM->Set('URLLINK', ($Form->Equal('URLLINK', 'on') ? 'TRUE' : 'FALSE'));
$SYSTEM->Set('LINKST', $Form->Get('LINKST'));
$SYSTEM->Set('LINKED', $Form->Get('LINKED'));
$SYSTEM->Set('PATHKIND', $Form->Get('PATHKIND'));
$SYSTEM->Set('FASTMODE', ($Form->Equal('FASTMODE', 'on') ? 1 : 0));
$SYSTEM->Set('BBSGET', ($Form->Equal('BBSGET', 'on') ? 1 : 0));
$SYSTEM->Set('UPCHECK', $Form->Get('UPCHECK'));
$SYSTEM->Save();
# ログの設定
{
push @$pLog, '■ その他設定';
push @$pLog, ' ヘッダテキスト：' . $SYSTEM->Get('HEADTEXT');
push @$pLog, ' ヘッダURL：' . $SYSTEM->Get('HEADURL');
push @$pLog, ' URL自動リンク：' . $SYSTEM->Get('URLLINK');
push @$pLog, ' 開始時間：' . $SYSTEM->Get('LINKST');
push @$pLog, ' 終了時間：' . $SYSTEM->Get('LINKED');
push @$pLog, ' PATH種別：' . $SYSTEM->Get('PATHKIND');
push @$pLog, ' 高速モード：' . $SYSTEM->Get('FASTMODE');
push @$pLog, ' bbs.cgiのGETメソ\ッド：' . $SYSTEM->Get('BBSGET');
push @$pLog, ' 更新チェック間隔：' . $SYSTEM->Get('UPCHECK');
}
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# 表示設定(ぜろちゃんねるプラスオリジナル)
# -------------------------------------------------------------------------------------
# @param $Sys システム変数
# @param $Form フォーム変数
# @param $pLog ログ用
# @return エラーコード
#
# 2010.09.08 windyakin ★
# -> 表示設定と規制設定の分離
#
#------------------------------------------------------------------------------------------------------------
sub FunctionPlusViewSetting
{
my ($Sys, $Form, $pLog) = @_;
my ($SYSTEM);
# 権限チェック
{
my $SEC = $Sys->Get('ADMIN')->{'SECINFO'};
my $chkID = $Sys->Get('ADMIN')->{'USER'};
if (($SEC->IsAuthority($chkID, $ZP::AUTH_SYSADMIN, '*')) == 0) {
return 1000;
}
}
require './module/melkor.pl';
$SYSTEM = MELKOR->new;
$SYSTEM->Init();
$SYSTEM->Set('COUNTER', $Form->Get('COUNTER'));
$SYSTEM->Set('PRTEXT', $Form->Get('PRTEXT'));
$SYSTEM->Set('PRLINK', $Form->Get('PRLINK'));
my $banner = ($Form->Equal('BANNERINDEX', 'on')?2:0) | ($Form->Equal('BANNER', 'on')?4:0);
$SYSTEM->Set('BANNER', $banner);
$SYSTEM->Set('MSEC', ($Form->Equal('MSEC', 'on') ? 1 : 0));
$SYSTEM->Save();
# ログの設定
{
push @$pLog, ' カウンターアカウント：' . $SYSTEM->Get('COUNTER');
push @$pLog, ' PR欄表\示文字列：' . $SYSTEM->Get('PRTEXT');
push @$pLog, ' PR欄リンクURL：' . $SYSTEM->Get('PRLINK');
push @$pLog, ' バナー表\示：' . $SYSTEM->Get('BANNER');
push @$pLog, ' ミリ秒表示：' . $SYSTEM->Get('MSEC');
}
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# 規制設定(ぜろちゃんねるプラスオリジナル)
# -------------------------------------------------------------------------------------
# @param $Sys システム変数
# @param $Form フォーム変数
# @param $pLog ログ用
# @return エラーコード
#
# 2010.09.08 windyakin ★
# -> 表示設定と規制設定の分離
#
#------------------------------------------------------------------------------------------------------------
sub FunctionPlusSecSetting
{
my ($Sys, $Form, $pLog) = @_;
my ($SYSTEM);
# 権限チェック
{
my $SEC = $Sys->Get('ADMIN')->{'SECINFO'};
my $chkID = $Sys->Get('ADMIN')->{'USER'};
if (($SEC->IsAuthority($chkID, $ZP::AUTH_SYSADMIN, '*')) == 0) {
return 1000;
}
}
require './module/melkor.pl';
$SYSTEM = MELKOR->new;
$SYSTEM->Init();
$SYSTEM->Set('KAKIKO', ($Form->Equal('KAKIKO', 'on') ? 1 : 0));
$SYSTEM->Set('SAMBATM', $Form->Get('SAMBATM'));
$SYSTEM->Set('DEFSAMBA', $Form->Get('DEFSAMBA'));
$SYSTEM->Set('DEFHOUSHI', $Form->Get('DEFHOUSHI'));
$SYSTEM->Set('TRIP12', ($Form->Equal('TRIP12', 'on') ? 1 : 0));
$SYSTEM->Set('BBQ', ($Form->Equal('BBQ', 'on') ? 1 : 0));
$SYSTEM->Set('BBX', ($Form->Equal('BBX', 'on') ? 1 : 0));
$SYSTEM->Save();
{
push @$pLog, ' 2重カキコ規制：' . $SYSTEM->Get('KAKIKO');
push @$pLog, ' 連続投稿規制秒数：' . $SYSTEM->Get('SAMBATM');
push @$pLog, ' Samba待機秒数：' . $SYSTEM->Get('DEFSAMBA');
push @$pLog, ' Samba奉仕時間：' . $SYSTEM->Get('DEFHOUSHI');
push @$pLog, ' 12桁トリップ：' . $SYSTEM->Get('TRIP12');
push @$pLog, ' BBQ：' . $SYSTEM->Get('BBQ');
push @$pLog, ' BBX：' . $SYSTEM->Get('BBX');
}
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# プラグイン情報設定
# -------------------------------------------------------------------------------------
# @param $Sys システム変数
# @param $Form フォーム変数
# @param $pLog ログ用
# @return エラーコード
#
#------------------------------------------------------------------------------------------------------------
sub FunctionPluginSetting
{
my ($Sys, $Form, $pLog) = @_;
my ($Plugin);
# 権限チェック
{
my $SEC = $Sys->Get('ADMIN')->{'SECINFO'};
my $chkID = $Sys->Get('ADMIN')->{'USER'};
if (($SEC->IsAuthority($chkID, $ZP::AUTH_SYSADMIN, '*')) == 0) {
return 1000;
}
}
require './module/athelas.pl';
$Plugin = ATHELAS->new;
$Plugin->Load($Sys);
my (@pluginSet, @validSet, %order);
$Plugin->GetKeySet('ALL', '', \@pluginSet);
@validSet = $Form->GetAtArray('PLUGIN_VALID');
for my $i (0 .. $#pluginSet) {
my $id = $pluginSet[$i];
my $valid = 0;
foreach (@validSet) {
if ($_ eq $id) {
$valid = 1;
last;
}
}
push @$pLog, $Plugin->Get('NAME', $id) . ' を' . ($valid ? '有効' : '無効') . 'に設定しました。';
$Plugin->Set($id, 'VALID', $valid);
$_ = $Form->Get("PLUGIN_${id}_ORDER", $i + 1);
$_ = $i + 1 if ($_ ne ($_ - 0));
$_ -= 0;
$order{$_} = [] if (! exists $order{$_});
push @{$order{$_}}, $id;
}
$Plugin->{'ORDER'} = [];
push @{$Plugin->{'ORDER'}}, @{$order{$_}} foreach (sort {$a <=> $b} keys %order);
$Plugin->Save($Sys);
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# プラグイン情報更新
# -------------------------------------------------------------------------------------
# @param $Sys システム変数
# @param $Form フォーム変数
# @param $pLog ログ用
# @return エラーコード
#
#------------------------------------------------------------------------------------------------------------
sub FunctionPluginUpdate
{
my ($Sys, $Form, $pLog) = @_;
my ($Plugin);
# 権限チェック
{
my $SEC = $Sys->Get('ADMIN')->{'SECINFO'};
my $chkID = $Sys->Get('ADMIN')->{'USER'};
if (($SEC->IsAuthority($chkID, $ZP::AUTH_SYSADMIN, '*')) == 0) {
return 1000;
}
}
require './module/athelas.pl';
$Plugin = ATHELAS->new;
# 情報の更新と保存
$Plugin->Load($Sys);
$Plugin->Update();
$Plugin->Save($Sys);
# ログの設定
{
push @$pLog, '■ プラグイン情報の更新';
push @$pLog, ' プラグイン情報の更新を完了しました。';
}
return 0;
}
#============================================================================================================
# Module END
#============================================================================================================
1;
zerochplus_0.7.4/test/mordor/sys.top.pl 0000644 0000764 0001040 00000043712 12236106656 015171 0 ustar #============================================================================================================
#
# システム管理 - ユーザ モジュール
# sys.top.pl
# ---------------------------------------------------------------------------
# 2004.09.11 start
#
#============================================================================================================
package MODULE;
use strict;
#use warnings;
no warnings 'redefine';
#------------------------------------------------------------------------------------------------------------
#
# コンストラクタ
# -------------------------------------------------------------------------------------
# @param なし
# @return モジュールオブジェクト
#
#------------------------------------------------------------------------------------------------------------
sub new
{
my $this = shift;
my ($obj, @LOG);
$obj = {
'LOG' => \@LOG
};
bless $obj, $this;
return $obj;
}
#------------------------------------------------------------------------------------------------------------
#
# 表示メソッド
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @param $Form SAMWISE
# @param $pSys 管理システム
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub DoPrint
{
my $this = shift;
my ($Sys, $Form, $pSys) = @_;
my ($subMode, $BASE, $BBS, $Page);
require './mordor/sauron.pl';
$BASE = SAURON->new;
# 管理マスタオブジェクトの生成
$Page = $BASE->Create($Sys, $Form);
$subMode = $Form->Get('MODE_SUB');
# メニューの設定
SetMenuList($BASE, $pSys);
if ($subMode eq 'NOTICE') { # 通知一覧画面
CheckVersionUpdate($Sys);
PrintNoticeList($Page, $Sys, $Form);
}
elsif ($subMode eq 'NOTICE_CREATE') { # 通知一覧画面
PrintNoticeCreate($Page, $Sys, $Form);
}
elsif ($subMode eq 'ADMINLOG') { # ログ閲覧画面
PrintAdminLog($Page, $Sys, $Form, $pSys->{'LOGGER'});
}
elsif ($subMode eq 'COMPLETE') { # 設定完了画面
$Sys->Set('_TITLE', 'Process Complete');
$BASE->PrintComplete('ユーザ通知処理', $this->{'LOG'});
}
elsif ($subMode eq 'FALSE') { # 設定失敗画面
$Sys->Set('_TITLE', 'Process Failed');
$BASE->PrintError($this->{'LOG'});
}
$BASE->Print($Sys->Get('_TITLE'), 1);
}
#------------------------------------------------------------------------------------------------------------
#
# 機能メソッド
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @param $Form SAMWISE
# @param $pSys 管理システム
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub DoFunction
{
my $this = shift;
my ($Sys, $Form, $pSys) = @_;
my ($subMode, $err);
$subMode = $Form->Get('MODE_SUB');
$err = 0;
if ($subMode eq 'CREATE') { # 通知作成
$err = FunctionNoticeCreate($Sys, $Form, $this->{'LOG'});
}
elsif ($subMode eq 'DELETE') { # 通知削除
$err = FunctionNoticeDelete($Sys, $Form, $this->{'LOG'});
}
elsif ($subMode eq 'LOG_REMOVE') { # 操作ログ削除
$err = FunctionLogRemove($Sys, $Form, $pSys->{'LOGGER'}, $this->{'LOG'});
}
# 処理結果表示
if ($err) {
$pSys->{'LOGGER'}->Put($Form->Get('UserName'), "SYSTEM_TOP($subMode)", "ERROR:$err");
push @{$this->{'LOG'}}, $err;
$Form->Set('MODE_SUB', 'FALSE');
}
else {
$pSys->{'LOGGER'}->Put($Form->Get('UserName'), "SYSTEM_TOP($subMode)", 'COMPLETE');
$Form->Set('MODE_SUB', 'COMPLETE');
}
$this->DoPrint($Sys, $Form, $pSys);
}
#------------------------------------------------------------------------------------------------------------
#
# メニューリスト設定
# -------------------------------------------------------------------------------------
# @param $Base SAURON
# @param $Sys MELKOR
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub SetMenuList
{
my ($Base, $pSys) = @_;
# 共通表示メニュー
$Base->SetMenu('ユーザ通知一覧', "'sys.top','DISP','NOTICE'");
$Base->SetMenu('ユーザ通知作成', "'sys.top','DISP','NOTICE_CREATE'");
# システム管理権限のみ
if ($pSys->{'SECINFO'}->IsAuthority($pSys->{'USER'}, $ZP::AUTH_SYSADMIN, '*')) {
$Base->SetMenu('個別設定 ");
$Page->Print(" \n");
%conftype = (
1 => '数値',
2 => '文字列',
3 => '真偽値',
);
if (defined $conf) {
foreach my $key (sort keys %$conf) {
my ($val, $type, $desc);
$val = $Config->GetConfig($key);
$type = $conf->{$key}->{'valuetype'};
$desc = $conf->{$key}->{'description'};
$val =~ s/([\"<>\x5c])/\x5c$1/g if ($type eq 2);
$Page->Print("Name ");
$Page->Print("Value ");
$Page->Print("Explanation ");
$Page->Print("Type $key ");
if ($type eq 3) {
$Page->Print("");
}
else {
$Page->Print(" ");
}
$Page->Print(" $desc $conftype{$type} ");
$Page->Print("");
$Page->Print("");
$Page->Print("
', '');
$Base->SetMenu('操作ログ閲覧', "'sys.top','DISP','ADMINLOG'");
}
}
#------------------------------------------------------------------------------------------------------------
#
# ユーザ通知一覧の表示
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintNoticeList
{
my ($Page, $Sys, $Form) = @_;
my ($Notices, @noticeSet, $from, $subj, $text, $date, $id, $common);
my ($dispNum, $i, $dispSt, $dispEd, $listNum, $isAuth, $curUser);
my ($orz, $or2);
$Sys->Set('_TITLE', 'User Notice List');
require './module/gandalf.pl';
require './module/galadriel.pl';
$Notices = GANDALF->new;
# 通知情報の読み込み
$Notices->Load($Sys);
# 通知情報を取得
$Notices->GetKeySet('ALL', '', \@noticeSet);
@noticeSet = sort @noticeSet;
@noticeSet = reverse @noticeSet;
# 表示数の設定
$listNum = @noticeSet;
$dispNum = $Form->Get('DISPNUM_NOTICE', 5) || 5;
$dispSt = $Form->Get('DISPST_NOTICE', 0) || 0;
$dispSt = ($dispSt < 0 ? 0 : $dispSt);
$dispEd = (($dispSt + $dispNum) > $listNum ? $listNum : ($dispSt + $dispNum));
$orz = $dispSt - $dispNum;
$or2 = $dispSt + $dispNum;
$common = "DoSubmit('sys.top','DISP','NOTICE');";
$Page->Print(<
<< PREV |
NEXT >>
表\示数
HTML
# カレントユーザ
$curUser = $Sys->Get('ADMIN')->{'USER'};
# 通知一覧を出力
for ($i = $dispSt ; $i < $dispEd ; $i++) {
$id = $noticeSet[$i];
if ($Notices->IsInclude($id, $curUser) && ! $Notices->IsLimitOut($id)) {
if ($Notices->Get('FROM', $id) eq '0000000000') {
$from = '0ch+管理システム';
}
else {
$from = $Sys->Get('ADMIN')->{'SECINFO'}->{'USER'}->Get('NAME', $Notices->Get('FROM', $id));
}
$subj = $Notices->Get('SUBJECT', $id);
$text = $Notices->Get('TEXT', $id);
$date = GALADRIEL::GetDateFromSerial(undef, $Notices->Get('DATE', $id), 0);
$Page->Print(<Notification
タイトル
本文
通知先ユーザ
HTML
if ($isSysad) {
$Page->Print(<
全体通知
有効期限：日
個別通知
HTML
}
else {
$Page->Print(<
個別通知
HTML
}
# ユーザ一覧を表示
foreach $id (@userSet) {
$name = $User->Get('NAME', $id);
$full = $User->Get('FULL', $id);
$Page->Print(" $name($full)
\n");
}
$Page->Print(<
HTML
}
#------------------------------------------------------------------------------------------------------------
#
# 管理操作ログ閲覧画面の表示
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintAdminLog
{
my ($Page, $Sys, $Form, $Logger) = @_;
my ($common);
my ($dispNum, $i, $dispSt, $dispEd, $listNum, $isSysad, $data, @elem);
my ($orz, $or2);
$Sys->Set('_TITLE', 'Operation Log');
$isSysad = $Sys->Get('ADMIN')->{'SECINFO'}->IsAuthority($Sys->Get('ADMIN')->{'USER'}, $ZP::AUTH_SYSADMIN, '*');
# 表示数の設定
$listNum = $Logger->Size();
$dispNum = ($Form->Get('DISPNUM_LOG') eq '' ? 10 : $Form->Get('DISPNUM_LOG'));
$dispSt = ($Form->Get('DISPST_LOG') eq '' ? 0 : $Form->Get('DISPST_LOG'));
$dispSt = ($dispSt < 0 ? 0 : $dispSt);
$dispEd = (($dispSt + $dispNum) > $listNum ? $listNum : ($dispSt + $dispNum));
$common = "DoSubmit('sys.top','DISP','ADMINLOG');";
$orz = $dispSt - $dispNum;
$or2 = $dispSt + $dispNum;
$Page->Print(<
<< PREV |
NEXT >>
表\示数
HTML
require './module/galadriel.pl';
# ログ一覧を出力
for ($i = $dispSt ; $i < $dispEd ; $i++) {
$data = $Logger->Get($listNum - $i - 1);
@elem = split(/<>/, $data);
if (1) {
$elem[0] = GALADRIEL::GetDateFromSerial(undef, $elem[0], 0);
$Page->Print(" Date
User
Operation
Result
$elem[0] $elem[1] $elem[2] $elem[3]
HTML
}
#------------------------------------------------------------------------------------------------------------
#
# ユーザ通知作成
# -------------------------------------------------------------------------------------
# @param $Sys システム変数
# @param $Form フォーム変数
# @param $pLog ログ用
# @return エラーコード
#
#------------------------------------------------------------------------------------------------------------
sub FunctionNoticeCreate
{
my ($Sys, $Form, $pLog) = @_;
my ($Notice, $subject, $content, $date, $limit, $users);
# 権限チェック
{
my $SEC = $Sys->Get('ADMIN')->{'SECINFO'};
my $chkID = $Sys->Get('ADMIN')->{'USER'};
if ($chkID eq '') {
return 1000;
}
}
# 入力チェック
{
my @inList = ('NOTICE_TITLE', 'NOTICE_CONTENT');
if (! $Form->IsInput(\@inList)) {
return 1001;
}
@inList = ('NOTICE_LIMIT');
if ($Form->Equal('NOTICE_KIND', 'ALL') && ! $Form->IsInput(\@inList)) {
return 1001;
}
@inList = ('NOTICE_USERS');
if ($Form->Equal('NOTICE_KIND', 'ONE') && ! $Form->IsInput(\@inList)) {
return 1001;
}
}
require './module/gandalf.pl';
$Notice = GANDALF->new;
$Notice->Load($Sys);
$date = time;
$subject = $Form->Get('NOTICE_TITLE');
$content = $Form->Get('NOTICE_CONTENT');
require './module/galadriel.pl';
GALADRIEL::ConvertCharacter1(undef, \$subject, 0);
GALADRIEL::ConvertCharacter1(undef, \$content, 2);
if ($Form->Equal('NOTICE_KIND', 'ALL')) {
$users = '*';
$limit = $Form->Get('NOTICE_LIMIT');
$limit = $date + ($limit * 24 * 60 * 60);
}
else {
my @toSet = $Form->GetAtArray('NOTICE_USERS');
$users = join(',', @toSet);
$limit = 0;
}
# 通知情報を追加
$Notice->Add($users, $Sys->Get('ADMIN')->{'USER'}, $subject, $content, $limit);
$Notice->Save($Sys);
push @$pLog, 'ユーザへの通知終了';
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# 通知削除
# -------------------------------------------------------------------------------------
# @param $Sys システム変数
# @param $Form フォーム変数
# @param $pLog ログ用
# @return エラーコード
#
#------------------------------------------------------------------------------------------------------------
sub FunctionNoticeDelete
{
my ($Sys, $Form, $pLog) = @_;
my ($Notice, @noticeSet, $curUser, $id);
# 権限チェック
{
my $SEC = $Sys->Get('ADMIN')->{'SECINFO'};
my $chkID = $Sys->Get('ADMIN')->{'USER'};
if ($chkID eq '') {
return 1000;
}
}
require './module/gandalf.pl';
$Notice = GANDALF->new;
$Notice->Load($Sys);
@noticeSet = $Form->GetAtArray('NOTICES');
$curUser = $Sys->Get('ADMIN')->{'USER'};
foreach $id (@noticeSet) {
next if (! defined $Notice->Get('SUBJECT', $id));
if ($Notice->Get('TO', $id) eq '*') {
if ($Notice->Get('FROM', $id) ne $curUser) {
my $subj = $Notice->Get('SUBJECT', $id);
push @$pLog, "通知「$subj」は全体通知なので削除できませんでした。";
}
else {
my $subj = $Notice->Get('SUBJECT', $id);
$Notice->Delete($id);
push @$pLog, "全体通知「$subj」を削除しました。";
}
}
else {
my $subj = $Notice->Get('SUBJECT', $id);
$Notice->RemoveToUser($id, $curUser);
push @$pLog, "通知「$subj」を削除しました。";
}
}
$Notice->Save($Sys);
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# 操作ログ削除
# -------------------------------------------------------------------------------------
# @param $Sys システム変数
# @param $Form フォーム変数
# @param $pLog ログ用
# @return エラーコード
#
#------------------------------------------------------------------------------------------------------------
sub FunctionLogRemove
{
my ($Sys, $Form, $Logger, $pLog) = @_;
my ($Notice, @noticeSet, $curUser, $id);
# 権限チェック
{
my $SEC = $Sys->Get('ADMIN')->{'SECINFO'};
my $chkID = $Sys->Get('ADMIN')->{'USER'};
if (($SEC->IsAuthority($chkID, $ZP::AUTH_SYSADMIN, '*')) == 0) {
return 1000;
}
}
$Logger->Clear();
push @$pLog, '操作ログを削除しました。';
return 0;
}
sub CheckVersionUpdate
{
my ($Sys) = @_;
my $nr = $Sys->Get('ADMIN')->{'NEWRELEASE'};
if ( $nr->Get('Update') eq 1) {
my $newver = $nr->Get('Ver');
my $reldate = $nr->Get('Date');
# ユーザ通知 準備
require './module/gandalf.pl';
my $Notice = GANDALF->new;
$Notice->Load($Sys);
my $nid = 'verupnotif';
# 通知時刻
use Time::Local;
$_ = [split /\./, $reldate];
my $date = timelocal(0, 0, 0, $_->[2], $_->[1] - 1, $_->[0]);
my $limit = 0;
# 通知内容
my $note = join('
', @{$nr->Get('Detail')});
my $subject = "0ch+ New Version $newver is Released.";
my $content = " $note";
# 通知者 0ch+管理システム
my $from = '0000000000';
# 通知先 管理者権限を持つユーザ
require './module/elves.pl';
my $User = GLORFINDEL->new;
$User->Load($Sys);
my @toSet = ();
$User->GetKeySet('SYSAD', 1, \@toSet);
my $users = join(',', @toSet, 'nouser');
# 通知を追加
if ($Notice->Get('TEXT', $nid, '') =~ /\*Ver=(.+?)\*/ && $1 eq $newver) {
$Notice->{'TO'}->{$nid} = $users;
$Notice->{'TEXT'}->{$nid} = $content;
$Notice->{'DATE'}->{$nid} = $date;
}
else {
#$Notice->Add($users, $from, $subject, $content, $limit);
$Notice->{'TO'}->{$nid} = $users;
$Notice->{'FROM'}->{$nid} = $from;
$Notice->{'SUBJECT'}->{$nid} = $subject;
$Notice->{'TEXT'}->{$nid} = $content;
$Notice->{'DATE'}->{$nid} = $date;
$Notice->{'LIMIT'}->{$nid} = $limit;
$Notice->Save($Sys);
}
}
}
#============================================================================================================
# Module END
#============================================================================================================
1;
zerochplus_0.7.4/test/mordor/sys.user.pl 0000644 0000764 0001040 00000037755 12236106656 015357 0 ustar #============================================================================================================
#
# システム管理 - ユーザ モジュール
# sys.user.pl
# ---------------------------------------------------------------------------
# 2004.06.26 start
#
#============================================================================================================
package MODULE;
use strict;
#use warnings;
#------------------------------------------------------------------------------------------------------------
#
# コンストラクタ
# -------------------------------------------------------------------------------------
# @param なし
# @return モジュールオブジェクト
#
#------------------------------------------------------------------------------------------------------------
sub new
{
my $this = shift;
my ($obj, @LOG);
$obj = {
'LOG' => \@LOG
};
bless $obj, $this;
return $obj;
}
#------------------------------------------------------------------------------------------------------------
#
# 表示メソッド
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @param $Form SAMWISE
# @param $pSys 管理システム
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub DoPrint
{
my $this = shift;
my ($Sys, $Form, $pSys) = @_;
my ($subMode, $BASE, $BBS, $Page);
require './mordor/sauron.pl';
$BASE = SAURON->new;
# 管理マスタオブジェクトの生成
$Page = $BASE->Create($Sys, $Form);
$subMode = $Form->Get('MODE_SUB');
# メニューの設定
SetMenuList($BASE, $pSys);
if ($subMode eq 'LIST') { # スレッド一覧画面
PrintUserList($Page, $Sys, $Form);
}
elsif ($subMode eq 'CREATE') { # ユーザ作成画面
PrintUserSetting($Page, $Sys, $Form, 0);
}
elsif ($subMode eq 'EDIT') { # ユーザ編集画面
PrintUserSetting($Page, $Sys, $Form, 1);
}
elsif ($subMode eq 'DELETE') { # ユーザ削除確認画面
PrintUserDelete($Page, $Sys, $Form);
}
elsif ($subMode eq 'COMPLETE') { # ユーザ設定完了画面
$Sys->Set('_TITLE', 'Process Complete');
$BASE->PrintComplete('ユーザ処理', $this->{'LOG'});
}
elsif ($subMode eq 'FALSE') { # ユーザ設定失敗画面
$Sys->Set('_TITLE', 'Process Failed');
$BASE->PrintError($this->{'LOG'});
}
$BASE->Print($Sys->Get('_TITLE'), 1);
}
#------------------------------------------------------------------------------------------------------------
#
# 機能メソッド
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @param $Form SAMWISE
# @param $pSys 管理システム
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub DoFunction
{
my $this = shift;
my ($Sys, $Form, $pSys) = @_;
my ($subMode, $err);
$subMode = $Form->Get('MODE_SUB');
$err = 0;
if ($subMode eq 'CREATE') { # ユーザ作成
$err = FuncUserSetting($Sys, $Form, 0, $this->{'LOG'});
}
elsif ($subMode eq 'EDIT') { # ユーザ編集
$err = FuncUserSetting($Sys, $Form, 1, $this->{'LOG'});
}
elsif ($subMode eq 'DELETE') { # ユーザ削除
$err = FuncUserDelete($Sys, $Form, $this->{'LOG'});
}
# 処理結果表示
if ($err) {
$pSys->{'LOGGER'}->Put($Form->Get('UserName'), "USER($subMode)", "ERROR:$err");
push @{$this->{'LOG'}}, $err;
$Form->Set('MODE_SUB', 'FALSE');
}
else {
$pSys->{'LOGGER'}->Put($Form->Get('UserName'),"USER($subMode)", 'COMPLETE');
$Form->Set('MODE_SUB', 'COMPLETE');
}
$this->DoPrint($Sys, $Form, $pSys);
}
#------------------------------------------------------------------------------------------------------------
#
# メニューリスト設定
# -------------------------------------------------------------------------------------
# @param $Base SAURON
# @param $Sys MELKOR
# @param $pSys 管理システム
# @param $Form SAMWISE
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub SetMenuList
{
my ($Base, $pSys) = @_;
# 共通表示メニュー
$Base->SetMenu('ユーザー一覧', "'sys.user','DISP','LIST'");
# システム管理権限のみ
if ($pSys->{'SECINFO'}->IsAuthority($pSys->{'USER'}, $ZP::AUTH_SYSADMIN, '*')) {
$Base->SetMenu('ユーザー登録', "'sys.user','DISP','CREATE'");
}
}
#------------------------------------------------------------------------------------------------------------
#
# ユーザ一覧の表示
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintUserList
{
my ($Page, $Sys, $Form) = @_;
my ($User, @userSet, $name, $expl, $full, $id, $common);
my ($dispNum, $i, $dispSt, $dispEd, $userNum, $isAuth);
$Sys->Set('_TITLE', 'Users List');
require './module/elves.pl';
$User = GLORFINDEL->new;
# ユーザ情報の読み込み
$User->Load($Sys);
# ユーザ情報を取得
$User->GetKeySet('ALL', '', \@userSet);
# 表示数の設定
$userNum = @userSet;
$dispNum = ($Form->Get('DISPNUM') eq '' ? 10 : $Form->Get('DISPNUM'));
$dispSt = ($Form->Get('DISPST') eq '' ? 0 : $Form->Get('DISPST'));
$dispSt = ($dispSt < 0 ? 0 : $dispSt);
$dispEd = (($dispSt + $dispNum) > $userNum ? $userNum : ($dispSt + $dispNum));
$common = "DoSubmit('sys.user','DISP','LIST');";
$Page->Print("");
$Page->Print("
");
$Page->HTMLInput('hidden', 'DISPST', '');
}
#------------------------------------------------------------------------------------------------------------
#
# ユーザ設定の表示
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @param $mode 作成の場合:0, 編集の場合:1
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintUserSetting
{
my ($Page, $Sys, $Form, $mode) = @_;
my ($User, $id, $common, $name, $pass, $expl, $full, $sysad);
$Sys->Set('_TITLE', 'User Edit') if ($mode == 1);
$Sys->Set('_TITLE', 'User Create') if ($mode == 0);
require './module/elves.pl';
$User = GLORFINDEL->new;
# ユーザ情報の読み込み
$User->Load($Sys);
# 編集モードならユーザ情報を取得する
if ($mode) {
$name = $User->Get('NAME', $Form->Get('SELECT_USER'));
$pass = $User->Get('PASS', $Form->Get('SELECT_USER'));
$expl = $User->Get('EXPL', $Form->Get('SELECT_USER'));
$full = $User->Get('FULL', $Form->Get('SELECT_USER'));
$sysad = $User->Get('SYSAD', $Form->Get('SELECT_USER')) ? 'checked' : '';
}
else {
$Form->Set('SELECT_USER', '');
$name = '';
$pass = '';
$expl = '';
$full = '';
$sysad = '';
}
$Page->Print("Print(");$common\"><< PREV | Print("" . ($dispSt + $dispNum) . ");$common\">NEXT >>");
$Page->Print(" ");
$Page->Print("表\示数");
$Page->Print(" ");
$Page->Print("User Name ");
$Page->Print("User Full Name ");
$Page->Print("Explanation \n");
# 権限取得
$isAuth = $Sys->Get('ADMIN')->{'SECINFO'}->IsAuthority($Sys->Get('ADMIN')->{'USER'}, $ZP::AUTH_SYSADMIN, '*');
# ユーザ一覧を出力
for ($i = $dispSt ; $i < $dispEd ; $i++) {
$id = $userSet[$i];
$name = $User->Get('NAME', $id);
$full = $User->Get('FULL', $id);
$expl = $User->Get('EXPL', $id);
$common = "\"javascript:SetOption('SELECT_USER','$id');";
$common .= "DoSubmit('sys.user','DISP','EDIT')\"";
# システム権限有無による表示抑制
if ($isAuth) {
$Page->Print("");
$Page->Print(" $name ");
}
else{
$Page->Print("$name ");
}
$Page->Print("$full $expl ");
$Page->Print("");
$Page->Print(" ");
$Page->Print("
");
}
#------------------------------------------------------------------------------------------------------------
#
# ユーザ削除確認画面の表示
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintUserDelete
{
my ($Page, $SYS, $Form) = @_;
my ($User, $Group, @userSet, $id, $name, $grop, $expl, $full);
$SYS->Set('_TITLE', 'User Delete Confirm');
require './module/elves.pl';
$User = GLORFINDEL->new;
# ユーザ情報を取得
$User->Load($SYS);
@userSet = $Form->GetAtArray('USERS');
$Page->Print("各項目を設定して[設定]ボタンを押してください。 ユーザ名 ");
$Page->Print(" パスワード ");
$Page->Print(" ユーザフルネーム ");
$Page->Print(" 説明 ");
$Page->Print(" ");
$Page->Print("システム管理者権限 ");
$Page->Print(" ");
$Page->Print("
");
}
#------------------------------------------------------------------------------------------------------------
#
# ユーザ作成/編集
# -------------------------------------------------------------------------------------
# @param $Sys システム変数
# @param $Form フォーム変数
# @param $mode 編集:1, 作成:0
# @param $pLog ログ用
# @return エラーコード
#
#------------------------------------------------------------------------------------------------------------
sub FuncUserSetting
{
my ($Sys, $Form, $mode, $pLog) = @_;
my ($User, $name, $pass, $expl, $grop, $chg, $full, $sysad);
# 権限チェック
{
my $SEC = $Sys->Get('ADMIN')->{'SECINFO'};
my $chkID = $Sys->Get('ADMIN')->{'USER'};
if (($SEC->IsAuthority($chkID, $ZP::AUTH_SYSADMIN, '*')) == 0) {
return 1000;
}
}
# 入力チェック
{
my @inList = ('NAME', 'PASS');
if (! $Form->IsInput(\@inList)) {
return 1001;
}
if (! $Form->IsAlphabet(\@inList)) {
return 1002;
}
}
require './module/elves.pl';
$User = GLORFINDEL->new;
$User->Load($Sys);
# 設定入力情報を取得
$name = $Form->Get('NAME');
$pass = $Form->Get('PASS');
$expl = $Form->Get('EXPL');
$full = $Form->Get('FULL');
$sysad = $Form->Equal('SYSAD', 'on') ? 1 : 0;
$chg = 0;
if ($mode) { # 編集モード
# パスワードが変更されていたら再設定する
if ($pass ne $User->Get('PASS', $Form->Get('SELECT_USER'))) {
$User->Set($Form->Get('SELECT_USER'), 'PASS', $pass);
$chg = 1;
}
$User->Set($Form->Get('SELECT_USER'), 'NAME', $name);
$User->Set($Form->Get('SELECT_USER'), 'EXPL', $expl);
$User->Set($Form->Get('SELECT_USER'), 'FULL', $full);
$User->Set($Form->Get('SELECT_USER'), 'SYSAD', $sysad);
}
else { # 登録モード
$User->Add($name, $pass, $full, $expl, $sysad);
$chg = 1;
}
# 設定情報を保存
$User->Save($Sys);
# ログの設定
{
push @$pLog, "■ ユーザ [ $name ] " . ($mode ? '設定' : '作成');
push @$pLog, ' パスワード：' . ($chg ? $pass : '変更なし');
push @$pLog, " フルネーム：$full";
push @$pLog, " 説明：$expl";
push @$pLog, ' システム管理：' . ($sysad ? '有り' : '無し');
}
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# ユーザ削除
# -------------------------------------------------------------------------------------
# @param $Sys システム変数
# @param $Form フォーム変数
# @param $pLog ログ用
# @return エラーコード
#
#------------------------------------------------------------------------------------------------------------
sub FuncUserDelete
{
my ($Sys, $Form, $pLog) = @_;
my ($User, $Sec, @userSet, $id, $name);
# 権限チェック
{
my $SEC = $Sys->Get('ADMIN')->{'SECINFO'};
my $chkID = $Sys->Get('ADMIN')->{'USER'};
$id = $chkID;
if (($SEC->IsAuthority($chkID, $ZP::AUTH_SYSADMIN, '*')) == 0) {
return 1000;
}
}
require './module/elves.pl';
$User = GLORFINDEL->new;
$Sec = ARWEN->new;
$User->Load($Sys);
$Sec->Init($Sys);
@userSet = $Form->GetAtArray('USERS');
# 選択ユーザを全削除
foreach (@userSet) {
next if (! defined $User->Get('NAME', $_));
# Administratorは削除不可
if ($_ eq '0000000001') {
push @$pLog, '□ ユーザ [ Administrator ] は削除できませんでした。';
}
# 自分自身も削除不可
elsif ($_ eq $id) {
my $name = $User->Get('NAME', $id);
push @$pLog, "□ ユーザ [ $name ] は自分自身のため削除できませんでした。";
}
# それ以外は削除可
else {
my $name = $User->Get('NAME', $_);
push @$pLog, "■ ユーザ [ $name ] を削除しました。";
$User->Delete($_);
}
}
# 設定情報を保存
$User->Save($Sys);
return 0;
}
#============================================================================================================
# Module END
#============================================================================================================
1;
zerochplus_0.7.4/test/mordor/thread.del.pl 0000644 0000764 0001040 00000034445 12236106656 015567 0 ustar #============================================================================================================
#
# スレッド管理 - 削除レス モジュール
# thread.del.pl
# ---------------------------------------------------------------------------
# 2004.08.02 start
#
#============================================================================================================
package MODULE;
use strict;
#use warnings;
#------------------------------------------------------------------------------------------------------------
#
# コンストラクタ
# -------------------------------------------------------------------------------------
# @param なし
# @return モジュールオブジェクト
#
#------------------------------------------------------------------------------------------------------------
sub new
{
my $this = shift;
my ($obj, @LOG);
$obj = {
'LOG' => \@LOG
};
bless $obj, $this;
return $obj;
}
#------------------------------------------------------------------------------------------------------------
#
# 表示メソッド
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @param $Form SAMWISE
# @param $pSys 管理システム
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub DoPrint
{
my $this = shift;
my ($Sys, $Form, $pSys) = @_;
my ($subMode, $BASE, $BBS, $DAT, $Page);
require './mordor/sauron.pl';
$BASE = SAURON->new;
$BBS = $pSys->{'AD_BBS'};
$DAT = $pSys->{'AD_DAT'};
# 掲示板情報の読み込みとグループ設定
if (! defined $pSys->{'AD_BBS'}) {
require './module/nazguls.pl';
$BBS = NAZGUL->new;
$BBS->Load($Sys);
$Sys->Set('BBS', $BBS->Get('DIR', $Form->Get('TARGET_BBS')));
$pSys->{'SECINFO'}->SetGroupInfo($BBS->Get('DIR', $Form->Get('TARGET_BBS')));
}
# datの読み込み
if (! defined $pSys->{'AD_DAT'}) {
require './module/gondor.pl';
$DAT = ARAGORN->new;
$Sys->Set('KEY', $Form->Get('TARGET_THREAD'));
my $datPath = $Sys->Get('BBSPATH') . '/' . $Sys->Get('BBS') . '/log/del_' . $Sys->Get('KEY') . '.cgi';
$DAT->Load($Sys, $datPath, 1);
}
# 管理マスタオブジェクトの生成
$Page = $BASE->Create($Sys, $Form);
$subMode = $Form->Get('MODE_SUB');
# メニューの設定
SetMenuList($BASE, $pSys, $Form->Get('TARGET_BBS'));
if ($subMode eq 'LIST') { # レス一覧画面
PrintResList($Page, $Sys, $Form, $DAT);
}
elsif ($subMode eq 'COMPLETE') { # 完了画面
PrintComplete($Page, $Sys, $Form, $this->{'LOG'});
}
elsif ($subMode eq 'FALSE') { # 失敗画面
PrintError($Page, $Sys, $Form, $this->{'LOG'});
}
# 掲示板・スレッド情報を設定
$Page->HTMLInput('hidden', 'TARGET_BBS', $Form->Get('TARGET_BBS'));
$Page->HTMLInput('hidden', 'TARGET_THREAD', $Form->Get('TARGET_THREAD'));
$BASE->Print($Sys->Get('_TITLE') . ' - ' . $BBS->Get('NAME', $Form->Get('TARGET_BBS'))
. ' - 削除レス', 3);
}
#------------------------------------------------------------------------------------------------------------
#
# 機能メソッド
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @param $Form SAMWISE
# @param $pSys 管理システム
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub DoFunction
{
my $this = shift;
my ($Sys, $Form, $pSys) = @_;
my ($subMode, $err, $BBS, $DAT);
require './module/gondor.pl';
require './module/nazguls.pl';
$BBS = NAZGUL->new;
$DAT = ARAGORN->new;
# 掲示板情報の読み込みとグループ設定
$BBS->Load($Sys);
$Sys->Set('BBS', $BBS->Get('DIR', $Form->Get('TARGET_BBS')));
$pSys->{'SECINFO'}->SetGroupInfo($BBS->Get('DIR', $Form->Get('TARGET_BBS')));
# datの読み込み
$Sys->Set('KEY', $Form->Get('TARGET_THREAD'));
my $datPath = $Sys->Get('BBSPATH') . '/' . $Sys->Get('BBS') . '/log/del_' . $Sys->Get('KEY') . '.cgi';
$DAT->Load($Sys, $datPath, 1);
$subMode = $Form->Get('MODE_SUB');
$err = 9999;
if ($subMode eq 'DELETE') { # レス完全削除
$err = FunctionResDelete($Sys, $Form, $DAT, $this->{'LOG'});
}
# 処理結果表示
if ($err) {
$pSys->{'LOGGER'}->Put($Form->Get('UserName'),"DELETE_RES($subMode)", "ERROR:$err");
push @{$this->{'LOG'}}, $err;
$Form->Set('MODE_SUB', 'FALSE');
}
else {
$pSys->{'LOGGER'}->Put($Form->Get('UserName'),"DELETE_RES($subMode)", 'COMPLETE');
$Form->Set('MODE_SUB', 'COMPLETE');
}
$pSys->{'AD_BBS'} = $BBS;
$pSys->{'AD_DAT'} = $DAT;
$this->DoPrint($Sys, $Form, $pSys);
}
#------------------------------------------------------------------------------------------------------------
#
# メニューリスト設定
# -------------------------------------------------------------------------------------
# @param $Base SAURON
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub SetMenuList
{
my ($Base, $pSys, $bbs) = @_;
$Base->SetMenu('削除レス一覧', "'thread.del','DISP','LIST'");
$Base->SetMenu('以下のユーザを削除します。 ");
$Page->Print(" User Name ");
$Page->Print("User Full Name ");
$Page->Print("Explanation \n");
# ユーザリストを出力
foreach $id (@userSet) {
$name = $User->Get('NAME', $id);
$expl = $User->Get('EXPL', $id);
$full = $User->Get('FULL', $id);
$Page->Print("$name ");
$Page->Print("$full ");
$Page->Print("$expl ");
$Page->Print("※注：削除したユーザを元に戻すことはできません。
");
$Page->Print("※注：Administratorと自分自身は削除できません。Print("onclick=\"DoSubmit('sys.user','FUNC','DELETE')\" class=\"delete\">
', '');
$Base->SetMenu('掲示板管理へ戻る', "'bbs.thread','DISP','LIST'");
}
#------------------------------------------------------------------------------------------------------------
#
# レス一覧の表示
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @param $Dat dat変数
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintResList
{
my ($Page, $Sys, $Form, $Dat) = @_;
my (@elem, $resNum, $dispNum, $dispSt, $dispEd, $common, $i);
my ($pRes, $isAbone, $isEdit, $format);
$Sys->Set('_TITLE', 'Delete Res List');
# 表示書式の設定
$format = $Form->Get('DISP_FORMAT_DEL') eq '' ? '-10' : $Form->Get('DISP_FORMAT_DEL');
($dispSt, $dispEd) = AnalyzeFormat($format, $Dat);
$common = "DoSubmit('thread.del','DISP','LIST');";
$Page->Print("");
$Page->Print("
表\示書式：Print(" value=\"$format\">");
$Page->Print(" ");
$Page->Print("Deleted Contents ");
# レス削除権による表示抑制
if ($isAbone) {
$Page->Print(" ");
}
else {
$Page->Print("");
}
$common = ($elem[3] ? '【あぼーん】' : '【透明あぼーん】');
$Page->Print("
" . ($elem[2] + 1));
$Page->Print("：$elem[4][$elem[5]]");
$Page->Print("：$elem[6]");
$Page->Print(" ");
$Page->Print("
");
}
#------------------------------------------------------------------------------------------------------------
#
# レス削除確認の表示
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @param $Dat dat変数
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintResDelete
{
my ($Page, $Sys, $Form, $Dat, $mode) = @_;
my (@resSet, @elem, $pRes, $num, $common, $isAbone);
$Sys->Set('_TITLE', 'Res Delete Confirm');
# 選択レスを取得
@resSet = $Form->GetAtArray('DEL_RESS');
# 権限取得
$isAbone = $Sys->Get('ADMIN')->{'SECINFO'}->IsAuthority($Sys->Get('ADMIN')->{'USER'}, $ZP::AUTH_RESDELETE, $Sys->Get('BBS'));
$Page->Print("");
$Page->Print("
以下の削除レスを完全に削除します。 Contents ");
$Page->Print(" ");
$Page->Print("
");
}
#------------------------------------------------------------------------------------------------------------
#
# 完了画面の表示
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @param $pLog ログ用
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintComplete
{
my ($Page, $Sys, $Form, $pLog) = @_;
my ($text);
$Sys->Set('_TITLE', 'Process Complete');
$Page->Print("");
$Page->Print("
");
}
#------------------------------------------------------------------------------------------------------------
#
# エラーの表示
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintError
{
my ($Page, $Sys, $Form, $pLog) = @_;
my ($ecode);
$Sys->Set('_TITLE', 'Process Error');
# エラーコードの抽出
$ecode = pop @$pLog;
$Page->Print("レス設定を正常に完了しました。
");
$Page->Print("処理ログ");
# ログの表示
foreach $text (@$pLog) {
$Page->Print("$text
\n");
}
$Page->Print("");
$Page->Print("
");
}
#------------------------------------------------------------------------------------------------------------
#
# レス完全削除
# -------------------------------------------------------------------------------------
# @param $Sys システム変数
# @param $Form フォーム変数
# @param $Dat Dat変数
# @param $pLog ログ用
# @return エラーコード
#
#------------------------------------------------------------------------------------------------------------
sub FunctionResDelete
{
my ($Sys, $Form, $Dat, $pLog) = @_;
my (@resSet, $abone, $path, $delCnt);
# 権限チェック
{
my $SEC = $Sys->Get('ADMIN')->{'SECINFO'};
my $chkID = $Sys->Get('ADMIN')->{'USER'};
if (($SEC->IsAuthority($chkID, $ZP::AUTH_RESDELETE, $Sys->Get('BBS'))) == 0) {
return 1000;
}
}
# 各値を設定
@resSet = $Form->GetAtArray('DEL_RESS');
$path = $Sys->Get('BBSPATH') . '/' . $Sys->Get('BBS') . '/log/del_' . $Sys->Get('KEY') . '.cgi';
my @dellist = ();
$Dat->Close();
$Dat->Load($Sys, $path, 0);
foreach my $num (reverse sort @resSet) {
push @dellist, (split(/<>/, ${$Dat->Get($num)}, -1))[2];
$Dat->Delete($num);
}
$Dat->Save($Sys);
# ログの設定
$delCnt = 0;
$abone = '';
push @$pLog, '以下の削除レスを完全に削除しました。';
foreach (@dellist) {
if ($delCnt > 5) {
push @$pLog, $abone;
$abone = '';
$delCnt = 0;
}
else {
$abone .= ($_ + 1) . ', ';
$delCnt++;
}
}
push @$pLog, $abone;
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# 書式の解析
# -------------------------------------------------------------------------------------
# @param $format 書式文字列
# @param $Dat ARAGORNオブジェクト
# @return (開始番号, 終了番号)
#
#------------------------------------------------------------------------------------------------------------
sub AnalyzeFormat
{
my ($format, $Dat) = @_;
my ($start, $end, $max);
# 書式エラー
if ($format =~ /[^0-9\-l]/ || $format eq '') {
return (0, 0);
}
$max = $Dat->Size();
if ($max < 1) {
return (0, 0);
}
# 最新n件
if ($format =~ /l(\d+)/) {
$end = $max;
$start = ($max - $1 + 1) > 0 ? ($max - $1 + 1) : 1;
}
# n〜m
elsif ($format =~ /(\d+)-(\d+)/) {
$start = $1 > $max ? $max : $1;
$end = $2 > $max ? $max : $2;
}
# n以降すべて
elsif ($format =~ /(\d+)-/) {
$start = $1 > $max ? $max : $1;
$end = $max;
}
# n以前すべて
elsif ($format =~ /-(\d+)/) {
$start = 1;
$end = $1 > $max ? $max : $1;
}
# nのみ
elsif ($format =~ /(\d+)/) {
$start = $1 > $max ? $max : $1;
$end = $1 > $max ? $max : $1;
}
# 順序正規化
if ($start > $end) {
$max = $start;
$start = $end;
$end = $start;
}
return ($start - 1, $end);
}
#============================================================================================================
# Module END
#============================================================================================================
1;
zerochplus_0.7.4/test/mordor/thread.res.pl 0000644 0000764 0001040 00000055773 12236106656 015623 0 ustar #============================================================================================================
#
# スレッド管理 - レス モジュール
# thread.res.pl
# ---------------------------------------------------------------------------
# 2004.07.21 start
#
#============================================================================================================
package MODULE;
use strict;
#use warnings;
#------------------------------------------------------------------------------------------------------------
#
# コンストラクタ
# -------------------------------------------------------------------------------------
# @param なし
# @return モジュールオブジェクト
#
#------------------------------------------------------------------------------------------------------------
sub new
{
my $this = shift;
my ($obj, @LOG);
$obj = {
'LOG' => \@LOG
};
bless $obj, $this;
return $obj;
}
#------------------------------------------------------------------------------------------------------------
#
# 表示メソッド
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @param $Form SAMWISE
# @param $pSys 管理システム
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub DoPrint
{
my $this = shift;
my ($Sys, $Form, $pSys) = @_;
my ($subMode, $BASE, $BBS, $DAT, $Page,$Logger);
require './mordor/sauron.pl';
$BASE = SAURON->new;
$BBS = $pSys->{'AD_BBS'};
$DAT = $pSys->{'AD_DAT'};
# 掲示板情報の読み込みとグループ設定
if (! defined $pSys->{'AD_BBS'}) {
require './module/nazguls.pl';
$BBS = NAZGUL->new;
$BBS->Load($Sys);
$Sys->Set('BBS', $BBS->Get('DIR', $Form->Get('TARGET_BBS')));
$pSys->{'SECINFO'}->SetGroupInfo($BBS->Get('DIR', $Form->Get('TARGET_BBS')));
}
# datの読み込み
if (! defined $pSys->{'AD_DAT'}) {
require './module/gondor.pl';
$DAT = ARAGORN->new;
$Sys->Set('KEY', $Form->Get('TARGET_THREAD'));
my $datPath = $Sys->Get('BBSPATH') . '/' . $Sys->Get('BBS') . '/dat/' . $Sys->Get('KEY') . '.dat';
$DAT->Load($Sys, $datPath, 1);
}
#logの読み込み
require './module/imrahil.pl';
$Logger = IMRAHIL->new;
my $logPath = $Sys->Get('BBSPATH') . '/' . $Sys->Get('BBS') . '/log/' . $Sys->Get('KEY');
$Logger->Open($logPath, 0, 1 | 2);
# 管理マスタオブジェクトの生成
$Page = $BASE->Create($Sys, $Form);
$subMode = $Form->Get('MODE_SUB');
# メニューの設定
SetMenuList($BASE, $pSys, $Sys->Get('BBS'));
if ($subMode eq 'LIST') { # レス一覧画面
PrintResList($Page, $Sys, $Form, $DAT,$Logger);
}
elsif ($subMode eq 'EDIT') { # レス編集画面
PrintResEdit($Page, $Sys, $Form, $DAT);
}
elsif ($subMode eq 'ABONE') { # レス削除確認画面
PrintResDelete($Page, $Sys, $Form, $DAT, 1);
}
elsif ($subMode eq 'DELETE') { # レス削除確認画面
PrintResDelete($Page, $Sys, $Form, $DAT, 0);
}
elsif ($subMode eq 'DELLUMP') { # レス一括削除画面
PrintResLumpDelete($Page, $Sys, $Form, $DAT);
}
elsif ($subMode eq 'COMPLETE') { # 完了画面
$Sys->Set('_TITLE', 'Process Complete');
$BASE->PrintComplete('過去ログ処理', $this->{'LOG'});
}
elsif ($subMode eq 'FALSE') { # 失敗画面
$Sys->Set('_TITLE', 'Process Failed');
$BASE->PrintError($this->{'LOG'});
}
# 掲示板・スレッド情報を設定
$Page->HTMLInput('hidden', 'TARGET_BBS', $Form->Get('TARGET_BBS'));
$Page->HTMLInput('hidden', 'TARGET_THREAD', $Form->Get('TARGET_THREAD'));
$BASE->Print($Sys->Get('_TITLE') . ' - ' . $BBS->Get('NAME', $Form->Get('TARGET_BBS'))
. ' - ' . $DAT->GetSubject(), 3);
}
#------------------------------------------------------------------------------------------------------------
#
# 機能メソッド
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @param $Form SAMWISE
# @param $pSys 管理システム
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub DoFunction
{
my $this = shift;
my ($Sys, $Form, $pSys) = @_;
my ($subMode, $err, $BBS, $DAT);
require './module/gondor.pl';
require './module/nazguls.pl';
$BBS = NAZGUL->new;
$DAT = ARAGORN->new;
# 掲示板情報の読み込みとグループ設定
$BBS->Load($Sys);
$Sys->Set('BBS', $BBS->Get('DIR', $Form->Get('TARGET_BBS')));
$pSys->{'SECINFO'}->SetGroupInfo($BBS->Get('DIR', $Form->Get('TARGET_BBS')));
# datの読み込み
$Sys->Set('KEY', $Form->Get('TARGET_THREAD'));
my $datPath = $Sys->Get('BBSPATH') . '/' . $Sys->Get('BBS') . '/dat/' . $Sys->Get('KEY') . '.dat';
$DAT->Load($Sys, $datPath, 1);
$subMode = $Form->Get('MODE_SUB');
$err = 9999;
if ($subMode eq 'EDIT') { # レス編集
$err = FunctionResEdit($Sys, $Form, $DAT, $this->{'LOG'});
}
elsif ($subMode eq 'ABONE') { # レスあぼ〜ん
$err = FunctionResDelete($Sys, $Form, $DAT, $this->{'LOG'}, 1);
}
elsif ($subMode eq 'DELETE') { # レス削除
$err = FunctionResDelete($Sys, $Form, $DAT, $this->{'LOG'}, 0);
}
# 処理結果表示
if ($err) {
$pSys->{'LOGGER'}->Put($Form->Get('UserName'), "RESPONSE($subMode)", "ERROR:$err");
push @{$this->{'LOG'}}, $err;
$Form->Set('MODE_SUB', 'FALSE');
}
else {
$pSys->{'LOGGER'}->Put($Form->Get('UserName'), "RESPONSE($subMode)", 'COMPLETE');
$Form->Set('MODE_SUB', 'COMPLETE');
}
$pSys->{'AD_BBS'} = $BBS;
$pSys->{'AD_DAT'} = $DAT;
$this->DoPrint($Sys, $Form, $pSys);
}
#------------------------------------------------------------------------------------------------------------
#
# メニューリスト設定
# -------------------------------------------------------------------------------------
# @param $Base SAURON
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub SetMenuList
{
my ($Base, $pSys, $bbs) = @_;
$Base->SetMenu('レス一覧', "'thread.res','DISP','LIST'");
# レス削除権限のみ
if ($pSys->{'SECINFO'}->IsAuthority($pSys->{'USER'}, $ZP::AUTH_RESDELETE, $bbs)){
$Base->SetMenu('レス一括削除', "'thread.res','DISP','DELLUMP'");
}
# 管理グループ権限のみ
if ($pSys->{'SECINFO'}->IsAuthority($pSys->{'USER'}, $ZP::AUTH_USERGROUP, $bbs)){
# $Base->SetMenu('
");
$Page->Print("ERROR:$ecode\n");
if ($ecode == 1000) {
$Page->Print("レス操作を実行する権限がありません。");
}
elsif ($ecode == 1001) {
$Page->Print("入力必須項目が空欄になっています。");
}
else {
$Page->Print("不明なエラー
");
foreach (@$pLog) {
$Page->Print("$_
");
}
}
$Page->Print("
");
$Page->Print("
', '');
# $Base->SetMenu('書き込みログ', "'thread.res','DISP','LOG_THREAD_WRITE'");
}
$Base->SetMenu('
', '');
$Base->SetMenu('掲示板管理へ戻る', "'bbs.thread','DISP','LIST'");
}
#------------------------------------------------------------------------------------------------------------
#
# レス一覧の表示
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @param $Dat dat変数
# @return なし
#
# 2010.08.12 windyakin ★
# -> デフォルト表示最新１０に変更
#
#------------------------------------------------------------------------------------------------------------
sub PrintResList
{
my ($Page, $Sys, $Form, $Dat,$Logger) = @_;
my (@elem, $resNum, $dispNum, $dispSt, $dispEd, $common, $i);
my ($pRes, $isAbone, $isEdit, $isAccessUser, $format);
my ($log, @logs, $datsize, $logsize);
$Sys->Set('_TITLE', 'Res List');
# 表示書式の設定
$format = $Form->Get('DISP_FORMAT') eq '' ? 'l10' : $Form->Get('DISP_FORMAT');
($dispSt, $dispEd) = AnalyzeFormat($format, $Dat);
$common = "DoSubmit('thread.res','DISP','LIST');";
$Page->Print("");
$Page->Print("
表\示書式：Print(" value=\"$format\">");
$Page->Print(" ");
$Page->Print("Contents ");
# レス削除権による表示抑制
if ($isAbone) {
$Page->Print(" ");
}
else {
$Page->Print("");
}
$Page->Print("
HOST:$logs[5]
IP:$logs[6]
UA:$logs[8]") if (defined $log && $isAccessUser);
$Page->Print("");
$Page->Print(" ");
$Page->Print("");
$Page->Print("
");
}
#------------------------------------------------------------------------------------------------------------
#
# レス編集画面の表示
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @param $Dat dat変数
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintResEdit
{
my ($Page, $Sys, $Form, $Dat) = @_;
my (@elem, $pRes, $isEdit, $common);
$Sys->Set('_TITLE', 'Res Edit');
$isEdit = $Sys->Get('ADMIN')->{'SECINFO'}->IsAuthority($Sys->Get('ADMIN')->{'USER'}, $ZP::AUTH_RESEDIT, $Sys->Get('BBS'));
$pRes = $Dat->Get($Form->Get('SELECT_RES'));
@elem = split(/<>/, $$pRes);
$elem[3] =~ s/^ //;
$elem[3] =~ s/ $//;
$elem[3] =~ s/ ?
?/\n/g;
foreach (0 .. 3) {
$elem[$_] =~ s/&/&/g;
$elem[$_] =~ s/"/"/g;
$elem[$_] =~ s//>/g;
}
$Page->Print("");
$Page->Print("
名前 ");
$Page->Print(" メール ");
$Page->Print(" 日付・ID ");
$Page->Print(" 本文 ");
$Page->Print(" ");
$Page->Print(" ");
$Page->Print("
");
}
#------------------------------------------------------------------------------------------------------------
#
# レス削除確認の表示
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @param $Dat dat変数
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintResDelete
{
my ($Page, $Sys, $Form, $Dat, $mode) = @_;
my (@resSet, @elem, $pRes, $num, $common, $isAbone);
$Sys->Set('_TITLE', 'Res Delete Confirm');
# 選択レスを取得
@resSet = $Form->GetAtArray('RESS');
# 権限取得
$isAbone = $Sys->Get('ADMIN')->{'SECINFO'}->IsAuthority($Sys->Get('ADMIN')->{'USER'}, $ZP::AUTH_RESDELETE, $Sys->Get('BBS'));
$Page->Print("");
$Page->Print("
以下のレスを" . ($mode ? 'あぼ〜ん' : '削除') . "します。 Contents ");
$Page->Print(" ");
$Page->Print("
");
}
#------------------------------------------------------------------------------------------------------------
#
# レス一括削除の表示
# -------------------------------------------------------------------------------------
# @param $Page ページコンテキスト
# @param $SYS システム変数
# @param $Form フォーム変数
# @param $Dat dat変数
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintResLumpDelete
{
my ($Page, $Sys, $Form, $Dat) = @_;
my (@resSet, @elem, $pRes, $format, $num, $common, $isAbone);
$Sys->Set('_TITLE', 'Res Lump Delete');
# 書式の解析
$num = 0;
$format = $Form->Get('DEL_FORMAT');
if ($format ne '') {
AnalyzeDeleteFormat($format, $Dat, \@resSet);
$num = @resSet;
}
# 権限取得
$isAbone = $Sys->Get('ADMIN')->{'SECINFO'}->IsAuthority($Sys->Get('ADMIN')->{'USER'}, $ZP::AUTH_RESDELETE, $Sys->Get('BBS'));
$Page->Print("");
$Page->Print("
削除レス書式 ");
$Page->Print(" Delete Contents ");
$Page->Print(" ");
$Page->Print(" ");
$Page->Print(" ");
$Page->Print("
");
}
#------------------------------------------------------------------------------------------------------------
#
# レス編集
# -------------------------------------------------------------------------------------
# @param $Sys システム変数
# @param $Form フォーム変数
# @param $Dat Dat変数
# @param $pLog ログ用
# @return エラーコード
#
#------------------------------------------------------------------------------------------------------------
sub FunctionResEdit
{
my ($Sys, $Form, $Dat, $pLog) = @_;
my (@elem, $pRes, $data);
# 権限チェック
{
my $SEC = $Sys->Get('ADMIN')->{'SECINFO'};
my $chkID = $Sys->Get('ADMIN')->{'USER'};
if (($SEC->IsAuthority($chkID, $ZP::AUTH_RESEDIT, $Sys->Get('BBS'))) == 0) {
return 1000;
}
}
# 書き込みモードで読み直す
$Dat->ReLoad($Sys, 0);
$pRes = $Dat->Get($Form->Get('SELECT_RES'));
@elem = split(/<>/, $$pRes);
$elem[0] = $Form->Get('FROM');
$elem[1] = $Form->Get('mail');
$elem[2] = $Form->Get('_DATE_');
$elem[3] = $Form->Get('MESSAGE');
# 改行・禁則文字の変換
$elem[3] =~ s/\r\n|\r|\n/
/g;
$elem[3] =~ s/<>/<>/g;
$elem[3] = " $elem[3] ";
# データの連結
$data = join('<>', @elem);
# データの設定と保存
$Dat->Set($Form->Get('SELECT_RES'), $data);
$Dat->Save($Sys);
# ログの設定
push @$pLog, '番号[' . $Form->Get('SELECT_RES') . ']のレスを以下のように変更しました。';
foreach (@elem) {
push @$pLog, $_;
}
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# レス削除
# -------------------------------------------------------------------------------------
# @param $Sys システム変数
# @param $Form フォーム変数
# @param $Dat Dat変数
# @param $pLog ログ用
# @return エラーコード
#
#------------------------------------------------------------------------------------------------------------
sub FunctionResDelete
{
my ($Sys, $Form, $Dat, $pLog, $mode) = @_;
my (@resSet, $pRes, $abone, $path, $tm, $user, $delCnt, $num, $datPath, $LOG, $logsize, $lastnum);
# 権限チェック
{
my $SEC = $Sys->Get('ADMIN')->{'SECINFO'};
my $chkID = $Sys->Get('ADMIN')->{'USER'};
if (($SEC->IsAuthority($chkID, $ZP::AUTH_RESDELETE, $Sys->Get('BBS'))) == 0) {
return 1000;
}
}
# あぼ〜ん時は削除名を取得
if ($mode) {
my $Setting;
require './module/isildur.pl';
$Setting = ISILDUR->new;
$Setting->Load($Sys);
$abone = $Setting->Get('BBS_DELETE_NAME');
}
else {
require './module/peregrin.pl';
$LOG = PEREGRIN->new;
$LOG->Load($Sys, 'WRT', $Sys->Get('KEY'));
$logsize = $LOG->Size();
$lastnum = $Dat->Size() - 1;
}
# 各値を設定
@resSet = $Form->GetAtArray('RESS');
$datPath= $Sys->Get('BBSPATH') . '/' . $Sys->Get('BBS') . '/dat/' . $Sys->Get('KEY') . '.dat';
$path = $Sys->Get('BBSPATH') . '/' . $Sys->Get('BBS') . '/log/del_' . $Sys->Get('KEY') . '.cgi';
$tm = time;
$user = $Form->Get('UserName');
$delCnt = 0;
# datを書き込みモードで読み直す
$Dat->Close();
$Dat->Load($Sys, $datPath, 0);
# 削除と同時に削除ログへ削除した内容を保存する
chmod($Sys->Get('PM-LOG'), $path);
if (open(my $f_dellog, '>>', $path)) {
flock($f_dellog, 2);
binmode($f_dellog);
foreach $num (sort {$b <=> $a} @resSet) {
next if ($num == 0);
$pRes = $Dat->Get($num);
print $f_dellog "$tm<>$user<>$num<>$mode<>$$pRes";
if ($mode) {
$Dat->Set($num, "$abone<>$abone<>$abone<>$abone<>$abone\n");
}
else {
$Dat->Delete($num);
$_ = $logsize - 1 + $num - $lastnum;
if ($_ >= 0) {
$LOG->Delete($_);
$logsize --;
}
$lastnum --;
}
}
close($f_dellog);
chmod($Sys->Get('PM-LOG'), $path);
# 保存
$Dat->Save($Sys);
$LOG->Save($Sys) if (! $mode);
}
# ログの設定
$delCnt = 0;
$abone = '';
push @$pLog, '以下のレスを' . ($mode ? 'あぼ〜ん' : '削除') . 'しました。';
foreach (@resSet) {
next if ($_ == 0);
if ($delCnt > 5) {
push @$pLog, $abone;
$abone = '';
$delCnt = 0;
}
else {
$abone .= ($_ + 1) . ', ';
$delCnt ++;
}
}
push @$pLog, $abone;
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# 削除書式の解析
# -------------------------------------------------------------------------------------
# @param $format 書式文字列
# @param $Dat ARAGORNオブジェクト
# @param $pSet 結果格納配列の参照
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub AnalyzeDeleteFormat
{
my ($format, $Dat, $pSet) = @_;
my (%deleteTable, @elem, $i, $st, $ed);
# セパレータで分解
@elem = split(/\, /, $format);
# 1区分ずつ書式解析をしてハッシュ(二重登録防止のため)に格納
foreach (@elem){
($st, $ed) = AnalyzeFormat($_, $Dat);
if ($st != 0 || $ed != 0) {
for ($i = $st ; $i < $ed ; $i++) {
$deleteTable{$i} = 'true';
}
}
}
# 結果を配列に設定
foreach (sort {$a <=> $b} (keys %deleteTable)) {
push @$pSet, $_;
}
}
#------------------------------------------------------------------------------------------------------------
#
# 書式の解析
# -------------------------------------------------------------------------------------
# @param $format 書式文字列
# @param $Dat ARAGORNオブジェクト
# @return (開始番号, 終了番号)
#
#------------------------------------------------------------------------------------------------------------
sub AnalyzeFormat
{
my ($format, $Dat) = @_;
my ($start, $end, $max);
# 書式エラー
if ($format =~ /[^0-9\-l]/ || $format eq '') {
return (0, 0);
}
$max = $Dat->Size();
# 最新n件
if ($format =~ /l(\d+)/) {
$end = $max;
$start = ($max - $1 + 1) > 0 ? ($max - $1 + 1) : 1;
}
# n〜m
elsif ($format =~ /(\d+)-(\d+)/) {
$start = $1 > $max ? $max : $1;
$end = $2 > $max ? $max : $2;
}
# n以降すべて
elsif ($format =~ /(\d+)-/) {
$start = $1 > $max ? $max : $1;
$end = $max;
}
# n以前すべて
elsif ($format =~ /-(\d+)/) {
$start = 1;
$end = $1 > $max ? $max : $1;
}
# nのみ
elsif ($format =~ /(\d+)/) {
$start = $1 > $max ? $max : $1;
$end = $1 > $max ? $max : $1;
}
# 順序正規化
if ($start > $end) {
$max = $start;
$start = $end;
$end = $start;
}
return ($start - 1, $end);
}
#============================================================================================================
# Module END
#============================================================================================================
1;
zerochplus_0.7.4/test/perllib/index.html 0000644 0000764 0001040 00000000015 12145672440 015324 0 ustar 403 Forbidden zerochplus_0.7.4/test/perllib/CGI/Session.pm 0000644 0000764 0001040 00000027216 12142417733 015725 0 ustar package CGI::Session;use strict;use Carp;use CGI::Session::ErrorHandler;@CGI::Session::ISA=qw(CGI::Session::ErrorHandler);$CGI::Session::VERSION='4.48';$CGI::Session::NAME='CGISESSID';$CGI::Session::IP_MATCH=0;sub STATUS_UNSET(){1<<0}sub STATUS_NEW(){1<<1}sub STATUS_MODIFIED(){1<<2}sub STATUS_DELETED(){1<<3}sub STATUS_EXPIRED(){1<<4}sub import{my($class,@args)=@_;return unless@args;ARG:for my$arg(@args){if($arg eq '-ip_match'){$CGI::Session::IP_MATCH=1;last ARG;}}}sub new{my($class,@args)=@_;my$self;if(ref$class){$self=bless{%$class},ref($class);$class=ref$class;$self->_reset_status();}else{$class->set_error('');$self=$class->load(@args);if(not defined$self){return$class->set_error("new(): failed: ".$class->errstr);}}my$dataref=$self->{_DATA};unless($dataref->{_SESSION_ID}){my$id=$self->_id_generator()->generate_id($self->{_DRIVER_ARGS},$self->{_CLAIMED_ID});unless(defined$id){return$self->set_error("Couldn't generate new SESSION-ID");}$dataref->{_SESSION_ID}=$id;$dataref->{_SESSION_CTIME}=$dataref->{_SESSION_ATIME}=time();$dataref->{_SESSION_REMOTE_ADDR}=$ENV{REMOTE_ADDR}||"";$self->_set_status(STATUS_NEW);}return$self;}sub DESTROY{$_[0]->flush()}sub close{$_[0]->flush()}*param_hashref=\&dataref;my$avoid_single_use_warning=*param_hashref;sub dataref{$_[0]->{_DATA}}sub is_empty{!defined($_[0]->id)}sub is_expired{$_[0]->_test_status(STATUS_EXPIRED)}sub is_new{$_[0]->_test_status(STATUS_NEW)}sub id{return defined($_[0]->dataref)?$_[0]->dataref->{_SESSION_ID}:undef}sub atime{return defined($_[0]->dataref)?$_[0]->dataref->{_SESSION_ATIME}:undef}sub ctime{return defined($_[0]->dataref)?$_[0]->dataref->{_SESSION_CTIME}:undef}sub _driver{my$self=shift;defined($self->{_OBJECTS}->{driver})and return$self->{_OBJECTS}->{driver};my$pm="CGI::Session::Driver::".$self->{_DSN}->{driver};defined($self->{_OBJECTS}->{driver}=$pm->new($self->{_DRIVER_ARGS}))or die$pm->errstr();return$self->{_OBJECTS}->{driver};}sub _serializer{my$self=shift;defined($self->{_OBJECTS}->{serializer})and return$self->{_OBJECTS}->{serializer};return$self->{_OBJECTS}->{serializer}="CGI::Session::Serialize::".$self->{_DSN}->{serializer};}sub _id_generator{my$self=shift;defined($self->{_OBJECTS}->{id})and return$self->{_OBJECTS}->{id};return$self->{_OBJECTS}->{id}="CGI::Session::ID::".$self->{_DSN}->{id};}sub ip_matches{return($_[0]->{_DATA}->{_SESSION_REMOTE_ADDR}eq$ENV{REMOTE_ADDR});}sub parse_dsn{my$self=shift;my$dsn_str=shift;croak"parse_dsn(): usage error"unless$dsn_str;require Text::Abbrev;my$abbrev=Text::Abbrev::abbrev("driver","serializer","id");my%dsn_map=map{split/:/}(split/;/,$dsn_str);my%dsn=map{$abbrev->{lc$_},lc$dsn_map{$_}}keys%dsn_map;return\%dsn;}sub query{my$self=shift;if($self->{_QUERY}){return$self->{_QUERY};}require CGI;return$self->{_QUERY}=CGI->new();}sub name{my$self=shift;my$name=shift;if(ref$self){unless(defined$name){return$self->{_NAME}||$CGI::Session::NAME;}return$self->{_NAME}=$name;}$CGI::Session::NAME=$name if defined$name;return$CGI::Session::NAME;}sub dump{my$self=shift;require Data::Dumper;my$d=Data::Dumper->new([$self],[ref$self]);$d->Deepcopy(1);return$d->Dump();}sub _set_status{my$self=shift;croak"_set_status(): usage error"unless@_;$self->{_STATUS}|=$_[0];}sub _unset_status{my$self=shift;croak"_unset_status(): usage error"unless@_;$self->{_STATUS}&=~$_[0];}sub _reset_status{$_[0]->{_STATUS}=STATUS_UNSET;}sub _test_status{return$_[0]->{_STATUS}&$_[1];}sub flush{my$self=shift;return unless$self->id;return if!defined($self->{_STATUS})or$self->{_STATUS}==STATUS_UNSET;if($self->_test_status(STATUS_NEW)&&$self->_test_status(STATUS_DELETED)){$self->{_DATA}={};return$self->_unset_status(STATUS_NEW|STATUS_DELETED);}my$driver=$self->_driver();my$serializer=$self->_serializer();if($self->_test_status(STATUS_DELETED)){defined($driver->remove($self->id))or return$self->set_error("flush(): couldn't remove session data: ".$driver->errstr);$self->{_DATA}={};return$self->_unset_status(STATUS_DELETED);}if($self->_test_status(STATUS_NEW|STATUS_MODIFIED)){my$datastr=$serializer->freeze($self->dataref);unless(defined$datastr){return$self->set_error("flush(): couldn't freeze data: ".$serializer->errstr);}defined($driver->store($self->id,$datastr))or return$self->set_error("flush(): couldn't store datastr: ".$driver->errstr);$self->_unset_status(STATUS_NEW|STATUS_MODIFIED);}return 1;}sub trace{}sub tracemsg{}sub param{my($self,@args)=@_;if($self->_test_status(STATUS_DELETED)){carp"param(): attempt to read/write deleted session";}if(@args==0){return grep{!/^_SESSION_/}keys%{$self->{_DATA}};}elsif(@args==1){return$self->{_DATA}->{$args[0]}}my%args=@args;my($name,$value)=@args{qw(-name -value)};if(defined$name&&defined$value){if($name=~m/^_SESSION_/){carp"param(): attempt to write to private parameter";return undef;}$self->_set_status(STATUS_MODIFIED);return$self->{_DATA}->{$name}=$value;}return$self->{_DATA}->{$args{'-name'}}if defined$args{'-name'};if((@args%2)==0){my$modified_cnt=0;ARG_PAIR:while(my($name,$val)=each%args){if($name=~m/^_SESSION_/){carp"param(): attempt to write to private parameter";next ARG_PAIR;}$self->{_DATA}->{$name}=$val;++$modified_cnt;}$self->_set_status(STATUS_MODIFIED);return$modified_cnt;}croak"param(): usage error. Invalid syntax";}sub delete{$_[0]->_set_status(STATUS_DELETED)}*header=\&http_header;my$avoid_single_use_warning_again=*header;sub http_header{my$self=shift;return$self->query->header(-cookie=>$self->cookie,-type=>'text/html',@_);}sub cookie{my$self=shift;my$query=$self->query();my$cookie=undef;if($self->is_expired){$cookie=$query->cookie(-name=>$self->name,-value=>$self->id,-expires=>'-1d',@_);}elsif(my$t=$self->expire){$cookie=$query->cookie(-name=>$self->name,-value=>$self->id,-expires=>'+'.$t.'s',@_);}else{$cookie=$query->cookie(-name=>$self->name,-value=>$self->id,@_);}return$cookie;}sub save_param{my$self=shift;my($query,$params)=@_;$query||=$self->query();$params||=[$query->param];for my$p(@$params){my@values=$query->param($p)or next;if(@values>1){$self->param($p,\@values);}else{$self->param($p,$values[0]);}}$self->_set_status(STATUS_MODIFIED);}sub load_param{my$self=shift;my($query,$params)=@_;$query||=$self->query();$params||=[$self->param];for(@$params){$query->param(-name=>$_,-value=>$self->param($_));}}sub clear{my$self=shift;my$params=shift;if(defined$params){$params=[$params]unless ref$params;}else{$params=[$self->param];}for(grep{!/^_SESSION_/}@$params){delete$self->{_DATA}->{$_};}$self->_set_status(STATUS_MODIFIED);}sub find{my$class=shift;my($dsn,$coderef,$dsn_args);if(@_==1){$coderef=$_[0];}else{($dsn,$coderef,$dsn_args)=@_;}unless($coderef&&ref($coderef)&&(ref$coderef eq 'CODE')){croak"find(): usage error.";}my$driver;if($dsn){my$hashref=$class->parse_dsn($dsn);$driver=$hashref->{driver};}$driver||="file";my$pm="CGI::Session::Driver::".($driver=~/(.*)/)[0];eval"require $pm";if(my$errmsg=$@){return$class->set_error("find(): couldn't load driver.".$errmsg);}my$driver_obj=$pm->new($dsn_args);unless($driver_obj){return$class->set_error("find(): couldn't create driver object. ".$pm->errstr);}my$read_only=1;my$driver_coderef=sub{my($sid)=@_;my$session=$class->load($dsn,$sid,$dsn_args,$read_only);unless($session){return$class->set_error("find(): couldn't load session '$sid'. ".$class->errstr);}$coderef->($session);};defined($driver_obj->traverse($driver_coderef))or return$class->set_error("find(): traverse seems to have failed. ".$driver_obj->errstr);return 1;}sub load{my$class=shift;return$class->set_error("called as instance method")if ref$class;return$class->set_error("Too many arguments provided to load()")if@_>5;my$self=bless{_DATA=>{_SESSION_ID=>undef,_SESSION_CTIME=>undef,_SESSION_ATIME=>undef,_SESSION_REMOTE_ADDR=>$ENV{REMOTE_ADDR}||"",},_DSN=>{},_OBJECTS=>{},_DRIVER_ARGS=>{},_CLAIMED_ID=>undef,_STATUS=>STATUS_UNSET,_QUERY=>undef},$class;my($dsn,$query_or_sid,$dsn_args,$read_only,$params);if(@_==1){$self->_set_query_or_sid($_[0]);}elsif(@_>1){($dsn,$query_or_sid,$dsn_args,$read_only)=@_;if(ref$read_only and ref$read_only eq 'HASH'){$params={%$read_only};$read_only=$params->{'read_only'};if($params->{'name'}){$self->{_NAME}=$params->{'name'};}}if(defined$read_only and$read_only!='1'){return$class->set_error("Too many arguments to load(). First extra argument was: $read_only");}if(defined$dsn){$self->{_DSN}=$self->parse_dsn($dsn);}$self->_set_query_or_sid($query_or_sid);$self->{_DRIVER_ARGS}=$dsn_args if defined$dsn_args;}$self->_load_pluggables();return undef if$class->errstr;if(not defined$self->{_CLAIMED_ID}){my$query=$self->query();eval{$self->{_CLAIMED_ID}=$query->cookie($self->name)||$query->param($self->name);};if(my$errmsg=$@){return$class->set_error("query object $query does not support cookie() and param() methods: ".$errmsg);}}return$self unless$self->{_CLAIMED_ID};my$driver=$self->_driver();my$raw_data=$driver->retrieve($self->{_CLAIMED_ID});unless(defined$raw_data){return$self->set_error("load(): couldn't retrieve data: ".$driver->errstr);}return$self unless$raw_data;my$serializer=$self->_serializer();$self->{_DATA}=$serializer->thaw($raw_data);unless(defined$self->{_DATA}){return$self->set_error("load(): couldn't thaw() data using $serializer:".$serializer->errstr);}unless(defined($self->{_DATA})&&ref($self->{_DATA})&&(ref$self->{_DATA}eq 'HASH')&&defined($self->{_DATA}->{_SESSION_ID})){return$self->set_error("Invalid data structure returned from thaw()");}if($self->{_DATA}->{_SESSION_ETIME}){if(($self->{_DATA}->{_SESSION_ATIME}+$self->{_DATA}->{_SESSION_ETIME})<=time()){$self->_set_status(STATUS_EXPIRED|STATUS_DELETED);$self->flush();return$self;}}my@expired_params=();if($self->{_DATA}->{_SESSION_EXPIRE_LIST}){while(my($param,$max_exp_interval)=each%{$self->{_DATA}->{_SESSION_EXPIRE_LIST}}){if(($self->{_DATA}->{_SESSION_ATIME}+$max_exp_interval)<=time()){push@expired_params,$param;}}}$self->clear(\@expired_params)if@expired_params;if(not defined$read_only){if($CGI::Session::IP_MATCH){unless($self->ip_matches){$self->_set_status(STATUS_DELETED);$self->flush;return$self;}}$self->{_DATA}->{_SESSION_ATIME}=time();$self->_set_status(STATUS_MODIFIED);}return$self;}sub _set_query_or_sid{my$self=shift;my$query_or_sid=shift;if(ref$query_or_sid){$self->{_QUERY}=$query_or_sid}else{$self->{_CLAIMED_ID}=$query_or_sid}}sub _load_pluggables{my($self)=@_;my%DEFAULT_FOR=(driver=>"file",serializer=>"default",id=>"md5",);my%SUBDIR_FOR=(driver=>"Driver",serializer=>"Serialize",id=>"ID",);my$dsn=$self->{_DSN};for my$plug(qw(driver serializer id)){my$mod_name=$dsn->{$plug};if(not defined$mod_name){$mod_name=$DEFAULT_FOR{$plug};}if($mod_name=~/^(\w+)$/){$dsn->{$plug}=$mod_name=$1;my$prefix=join '::',(__PACKAGE__,$SUBDIR_FOR{$plug},q{});$mod_name=$prefix.$mod_name;eval"require $mod_name";if($@){my$msg=$@;return$self->set_error("couldn't load $mod_name: ".$msg);}}else{}}return;}*expires=\&expire;my$prevent_warning=\&expires;sub etime{$_[0]->expire()}sub expire{my$self=shift;if(not@_){return$self->{_DATA}->{_SESSION_ETIME};}elsif(@_==1){my$time=$_[0];if(defined$time&&($time=~m/^\d$/)&&($time==0)){$self->{_DATA}->{_SESSION_ETIME}=undef;$self->_set_status(STATUS_MODIFIED);}else{$self->{_DATA}->{_SESSION_ETIME}=$self->_str2seconds($time);$self->_set_status(STATUS_MODIFIED);}}else{my($param,$time)=@_;if(($time=~m/^\d$/)&&($time==0)){delete$self->{_DATA}->{_SESSION_EXPIRE_LIST}->{$param};$self->_set_status(STATUS_MODIFIED);}else{$self->{_DATA}->{_SESSION_EXPIRE_LIST}->{$param}=$self->_str2seconds($time);$self->_set_status(STATUS_MODIFIED);}}return 1;}sub _str2seconds{my$self=shift;my($str)=@_;return unless defined$str;return$str if$str=~m/^[-+]?\d+$/;my%_map=(s=>1,m=>60,h=>3600,d=>86400,w=>604800,M=>2592000,y=>31536000);my($koef,$d)=$str=~m/^([+-]?\d+)([smhdwMy])$/;unless(defined($koef)&&defined($d)){die"_str2seconds(): couldn't parse '$str' into \$koef and \$d parts. Possible invalid syntax";}return$koef*$_map{$d};}sub remote_addr{return$_[0]->{_DATA}->{_SESSION_REMOTE_ADDR}}1; zerochplus_0.7.4/test/perllib/CGI/Session/Driver.pm 0000644 0000764 0001040 00000001750 12142417733 017153 0 ustar package CGI::Session::Driver;use strict;use Carp;use CGI::Session::ErrorHandler;$CGI::Session::Driver::VERSION='4.43';@CGI::Session::Driver::ISA=qw(CGI::Session::ErrorHandler);sub new{my$class=shift;my$args=shift||{};unless(ref$args){croak"$class->new(): Invalid argument type passed to driver";}if(!$args->{TableName}){$args->{TableName}='sessions';}if(!$args->{IdColName}){$args->{IdColName}='id';}if(!$args->{DataColName}){$args->{DataColName}='a_session';}my$self=bless({%$args},$class);return$self if$self->init();return$self->set_error("$class->init() returned false");}sub init{1}sub retrieve{croak"retrieve(): ".ref($_[0])." failed to implement this method!";}sub store{croak"store(): ".ref($_[0])." failed to implement this method!";}sub remove{croak"remove(): ".ref($_[0])." failed to implement this method!";}sub traverse{croak"traverse(): ".ref($_[0])." failed to implement this method!";}sub dump{require Data::Dumper;my$d=Data::Dumper->new([$_[0]],[ref$_[0]]);return$d->Dump;}1;__END__
zerochplus_0.7.4/test/perllib/CGI/Session/ErrorHandler.pm 0000644 0000764 0001040 00000000526 12142417733 020307 0 ustar package CGI::Session::ErrorHandler;use strict;$CGI::Session::ErrorHandler::VERSION='4.43';sub set_error{my$class=shift;my$message=shift;$class=ref($class)||$class;no strict 'refs';${"$class\::errstr"}=$message||"";return;}*error=\&errstr;sub errstr{my$class=shift;$class=ref($class)||$class;no strict 'refs';return${"$class\::errstr"}||'';}1; zerochplus_0.7.4/test/perllib/CGI/Session/Driver/DBI.pm 0000644 0000764 0001040 00000006623 12142417733 017555 0 ustar package CGI::Session::Driver::DBI;use strict;use DBI;use Carp;use CGI::Session::Driver;@CGI::Session::Driver::DBI::ISA=("CGI::Session::Driver");$CGI::Session::Driver::DBI::VERSION='4.43';sub init{my$self=shift;if(defined$self->{Handle}){if(ref$self->{Handle}eq 'CODE'){$self->{Handle}=$self->{Handle}->();}else{}}else{$self->{Handle}=DBI->connect($self->{DataSource},$self->{User},$self->{Password},{RaiseError=>1,PrintError=>1,AutoCommit=>1});unless($self->{Handle}){return$self->set_error("init(): couldn't connect to database: ".DBI->errstr);}$self->{_disconnect}=1;}return 1;}sub table_name{my$self=shift;my$class=ref($self)||$self;if((@_==0)&&ref($self)&&($self->{TableName})){return$self->{TableName};}no strict 'refs';if(@_){$self->{TableName}=shift;}unless(defined$self->{TableName}){$self->{TableName}="sessions";}return$self->{TableName};}sub retrieve{my$self=shift;my($sid)=@_;croak"retrieve(): usage error"unless$sid;my$dbh=$self->{Handle};my$sth=$dbh->prepare_cached("SELECT $self->{DataColName} FROM ".$self->table_name." WHERE $self->{IdColName}=?",undef,3);unless($sth){return$self->set_error("retrieve(): DBI->prepare failed with error message ".$dbh->errstr);}$sth->execute($sid)or return$self->set_error("retrieve(): \$sth->execute failed with error message ".$sth->errstr);my($row)=$sth->fetchrow_array();$sth->finish;return 0 unless$row;return$row;}sub store{my$self=shift;my($sid,$datastr)=@_;croak"store(): usage error"unless$sid&&$datastr;my$dbh=$self->{Handle};my$sth=$dbh->prepare_cached("SELECT $self->{IdColName} FROM ".$self->table_name." WHERE $self->{IdColName}=?",undef,3);unless(defined$sth){return$self->set_error("store(): \$dbh->prepare failed with message ".$sth->errstr);}$sth->execute($sid)or return$self->set_error("store(): \$sth->execute failed with message ".$sth->errstr);my$rc=$sth->fetchrow_array;$sth->finish;my$action_sth;if($rc){$action_sth=$dbh->prepare_cached("UPDATE ".$self->table_name." SET $self->{DataColName}=? WHERE $self->{IdColName}=?",undef,3);}else{$action_sth=$dbh->prepare_cached("INSERT INTO ".$self->table_name." ($self->{DataColName}, $self->{IdColName}) VALUES(?, ?)",undef,3);}unless(defined$action_sth){return$self->set_error("store(): \$dbh->prepare failed with message ".$dbh->errstr);}$action_sth->execute($datastr,$sid)or return$self->set_error("store(): \$action_sth->execute failed ".$action_sth->errstr);$action_sth->finish;return 1;}sub remove{my$self=shift;my($sid)=@_;croak"remove(): usage error"unless$sid;my$rc=$self->{Handle}->do('DELETE FROM '.$self->table_name." WHERE $self->{IdColName}= ?",{},$sid);unless($rc){croak"remove(): \$dbh->do failed!";}return 1;}sub DESTROY{my$self=shift;unless(defined$self->{Handle}&&$self->{Handle}->ping){$self->set_error(__PACKAGE__.'::DESTROY(). Database handle has gone away');return;}unless($self->{Handle}->{AutoCommit}){$self->{Handle}->commit;}if($self->{_disconnect}){$self->{Handle}->disconnect;}}sub traverse{my$self=shift;my($coderef)=@_;unless($coderef&&ref($coderef)&&(ref$coderef eq 'CODE')){croak"traverse(): usage error";}my$tablename=$self->table_name();my$sth=$self->{Handle}->prepare_cached("SELECT $self->{IdColName} FROM $tablename",undef,3)or return$self->set_error("traverse(): couldn't prepare SQL statement. ".$self->{Handle}->errstr);$sth->execute()or return$self->set_error("traverse(): couldn't execute statement $sth->{Statement}. ".$sth->errstr);while(my($sid)=$sth->fetchrow_array){$coderef->($sid);}$sth->finish;return 1;}1; zerochplus_0.7.4/test/perllib/CGI/Session/Driver/db_file.pm 0000644 0000764 0001040 00000005730 12142417733 020541 0 ustar package CGI::Session::Driver::db_file;use strict;use Carp;use DB_File;use File::Spec;use File::Basename;use CGI::Session::Driver;use Fcntl qw(:DEFAULT :flock);use vars qw(@ISA $VERSION $FILE_NAME $UMask $NO_FOLLOW);@ISA=("CGI::Session::Driver");$VERSION='4.43';$FILE_NAME="cgisess.db";$UMask=0660;$NO_FOLLOW=eval{O_NOFOLLOW}||0;sub init{my$self=shift;$self->{FileName}||=$CGI::Session::Driver::db_file::FILE_NAME;unless($self->{Directory}){$self->{Directory}=dirname($self->{FileName});$self->{Directory}=File::Spec->tmpdir()if$self->{Directory}eq '.'&&substr($self->{FileName},0,1)ne '.';$self->{FileName}=basename($self->{FileName});}unless(-d$self->{Directory}){require File::Path;File::Path::mkpath($self->{Directory})or return$self->set_error("init(): couldn't mkpath: $!");}$self->{UMask}=$CGI::Session::Driver::db_file::UMask unless exists$self->{UMask};return 1;}sub retrieve{my$self=shift;my($sid)=@_;croak"retrieve(): usage error"unless$sid;return 0 unless-f$self->_db_file;my($dbhash,$unlock)=$self->_tie_db_file(O_RDONLY)or return;my$datastr=$dbhash->{$sid};untie(%$dbhash);$unlock->();return$datastr||0;}sub store{my$self=shift;my($sid,$datastr)=@_;croak"store(): usage error"unless$sid&&$datastr;my($dbhash,$unlock)=$self->_tie_db_file(O_RDWR,LOCK_EX)or return;$dbhash->{$sid}=$datastr;untie(%$dbhash);$unlock->();return 1;}sub remove{my$self=shift;my($sid)=@_;croak"remove(): usage error"unless$sid;my($dbhash,$unlock)=$self->_tie_db_file(O_RDWR,LOCK_EX)or return;delete$dbhash->{$sid};untie(%$dbhash);$unlock->();return 1;}sub DESTROY{}sub _lock{my$self=shift;my($db_file,$lock_type)=@_;croak"_lock(): usage error"unless$db_file;$lock_type||=LOCK_SH;my$lock_file=$db_file.'.lck';if(-l$lock_file){unlink($lock_file)or die$self->set_error("_lock(): '$lock_file' appears to be a symlink and I can't remove it: $!");}sysopen(LOCKFH,$lock_file,O_RDWR|O_CREAT|$NO_FOLLOW)or die"couldn't create lock file '$lock_file': $!";flock(LOCKFH,$lock_type)or die"couldn't lock '$lock_file': $!";return sub{close(LOCKFH);1;};}sub _tie_db_file{my$self=shift;my($o_mode,$lock_type)=@_;$o_mode||=O_RDWR|O_CREAT;my$db_file=$self->_db_file;my$unlock=$self->_lock($db_file,$lock_type);my%db;my$create=!-e$db_file;if(-l$db_file){$create=1;unlink($db_file)or return$self->set_error("_tie_db_file(): '$db_file' appears to be a symlink and I can't remove it: $!");}$o_mode=O_RDWR|O_CREAT|O_EXCL if$create;unless(tie%db,"DB_File",$db_file,$o_mode,$self->{UMask}){$unlock->();return$self->set_error("_tie_db_file(): couldn't tie '$db_file': $!");}return(\%db,$unlock);}sub _db_file{my$self=shift;return File::Spec->catfile($self->{Directory},$self->{FileName});}sub traverse{my$self=shift;my($coderef)=@_;unless($coderef&&ref($coderef)&&(ref$coderef eq 'CODE')){croak"traverse(): usage error";}my($dbhash,$unlock)=$self->_tie_db_file(O_RDWR,LOCK_SH);unless($dbhash){return$self->set_error("traverse(): couldn't get db handle, ".$self->errstr);}while(my($sid,undef)=each%$dbhash){$coderef->($sid);}untie(%$dbhash);$unlock->();return 1;}1;__END__
zerochplus_0.7.4/test/perllib/CGI/Session/Driver/file.pm 0000644 0000764 0001040 00000006055 12142417733 020075 0 ustar package CGI::Session::Driver::file;use strict;use Carp;use File::Spec;use Fcntl qw(:DEFAULT :flock :mode);use CGI::Session::Driver;use vars qw($FileName $NoFlock $UMask $NO_FOLLOW);BEGIN{no strict 'refs';*FileName=\$CGI::Session::File::FileName;}@CGI::Session::Driver::file::ISA=("CGI::Session::Driver");$CGI::Session::Driver::file::VERSION='4.43';$FileName="cgisess_%s";$NoFlock=0;$UMask=0660;$NO_FOLLOW=eval{O_NOFOLLOW}||0;sub init{my$self=shift;$self->{Directory}||=File::Spec->tmpdir();unless(-d$self->{Directory}){require File::Path;unless(File::Path::mkpath($self->{Directory})){return$self->set_error("init(): couldn't create directory path: $!");}}$self->{NoFlock}=$NoFlock unless exists$self->{NoFlock};$self->{UMask}=$UMask unless exists$self->{UMask};return 1;}sub _file{my($self,$sid)=@_;my$id=$sid;$id=~s|\\|/|g;if($id=~m|/|){return$self->set_error("_file(): Session ids cannot contain \\ or / chars: $sid");}return File::Spec->catfile($self->{Directory},sprintf($FileName,$sid));}sub retrieve{my$self=shift;my($sid)=@_;my$path=$self->_file($sid);return 0 unless-e$path;local*FH;if(-l$path){unlink($path)or return$self->set_error("retrieve(): '$path' appears to be a symlink and I couldn't remove it: $!");return 0;}sysopen(FH,$path,O_RDONLY|$NO_FOLLOW)||return$self->set_error("retrieve(): couldn't open '$path': $!");$self->{NoFlock}||flock(FH,LOCK_SH)or return$self->set_error("retrieve(): couldn't lock '$path': $!");my$rv="";while(\n(.+)<\/h1>/ ) {
my $name = $1;
$name =~ s|^.*◆([A-Za-z0-9\./]{10,12}).*$|$1|;
# 入力トリップとプロフのトリップの一致を調べる
if ( $trip eq $name ) {
my $point = 0;
# ポイント取得
if ( $content =~ m/
\n\n|i ) {
$Form->Set('MESSAGE', "sssp://img.2ch.net/ico/$1
".$Form->Get('MESSAGE'));
}
}
}
else {
#$Form->Set('BEID', "BE:認証エラー($trip:$name)");
$Sys->Set('CHK', "◆".$trip);
PrintBBSError( $Sys, $Form, 892 );
return 0;
}
}
else {
#$Form->Set('BEID', '取得エラー(-1)');
PrintBBSError( $Sys, $Form, 890 );
return 0;
}
}
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# BEプロフィールページ取得
# -------------------------------------------------------------------------------------
# @param $url BEプロフ
# @return $code HTTPステータス
# @return $cont BeプロフHTML
#
#------------------------------------------------------------------------------------------------------------
sub BeGet
{
my ( $url ) = @_;
require('./module/httpservice.pl');
my $proxy = HTTPSERVICE->new;
$proxy->setURI($url);
$proxy->setAgent('Mozilla/5.0 Plugin for 0ch+; 0ch_BE_HS.pl http://zerochplus.sourceforge.jp/');
$proxy->setTimeout(3);
# とってくるよ
$proxy->request();
my $cont = $proxy->getContent();
my $code = $proxy->getStatus();
return ( $code, $cont );
}
#------------------------------------------------------------------------------------------------------------
#
# BE会員ランク取得
# -------------------------------------------------------------------------------------
# @param $Form $Form
# @param $point ポイント
# @return ランク表示形式 2BP(0)
#
#------------------------------------------------------------------------------------------------------------
sub BeRank
{
my ( $Form, $point ) = @_;
if ( $point < 10000 ) {
$point = "2BP($point)";
$Form->Set('BERANK', 1);
}
elsif ( $point < 12000 ) {
$point = "BRZ($point)";
$Form->Set('BERANK', 2);
}
elsif ( $point < 100000 ) {
$point = "PLT($point)";
$Form->Set('BERANK', 3);
}
elsif ( $point < 500000 ) {
$point = "DIA($point)";
$Form->Set('BERANK', 4);
}
elsif ( $point >= 500000 ) {
$point = "S★($point)";
$Form->Set('BERANK', 5);
}
else {
$point = "2BP(0)";
$Form->Set('BERANK', 1);
}
return $point;
}
#------------------------------------------------------------------------------------------------------------
#
# BEID->基礎BE番号取得
# -------------------------------------------------------------------------------------
# @param $id BEID
# @return 基礎BE番号
#
#------------------------------------------------------------------------------------------------------------
sub ID2BASE
{
my ($id) = @_;
my ($base, $a, $b, $c, $d);
$base = 0;
if (($b = $id % 10) && ($a = ($id % 100 - $b) / 10) &&
! (($c = ($id - $id % 100) / 100 + $a - $b - 5) % ($d = $a * $b * 3))) {
$base = $c / $d;
}
return $base;
}
#------------------------------------------------------------------------------------------------------------
#
# 基礎BE番号->BEID取得
# -------------------------------------------------------------------------------------
# @param $base 基礎BE番号
# @return BEID配列
#
#------------------------------------------------------------------------------------------------------------
sub BASE2ID
{
my ($base) = @_;
my @id = ();
for my $a (1 .. 9) {
for my $b (1 .. 9) {
push @id, ($base * $a * $b * 3 - $a + $b + 5) * 100 + $a * 10 + $b;
}
}
return sort { $a <=> $b } @id;
}
#------------------------------------------------------------------------------------------------------------
#
# なんちゃってbbs.cgiエラーページ表示
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @param $Form SAMWISE
# @param $err エラー番号
# @return なし
# exit エラー番号
#
#------------------------------------------------------------------------------------------------------------
sub PrintBBSError
{
my ($Sys,$Form,$err) = @_;
my $CGI;
require('./module/radagast.pl');
require('./module/isildur.pl');
require('./module/thorin.pl');
$CGI->{'SYS'} = $Sys;
$CGI->{'FORM'} = $Form;
$CGI->{'COOKIE'} = RADAGAST->new;
$CGI->{'COOKIE'}->Init();
$CGI->{'SET'} = ISILDUR->new;
$CGI->{'SET'}->Load($Sys);
my $Page = THORIN->new;
require('./module/orald.pl');
$ERROR = ORALD->new;
$ERROR->Load($Sys);
$ERROR->Print($CGI,$Page,$err,$Sys->Get('AGENT'));
$Page->Flush('',0,0);
exit($err);
}
#============================================================================================================
# Module END
#============================================================================================================
1;
__END__
=pod
# 890〜 BEシステムエラー系
890<>Be情報取得失敗<>Beユーザー情報の取得に失敗しました。
890<>Beログイン失敗<>Beログインに失敗しました。
891<>Beログイン必須<>be.2ch.netでログインしてないと書けません。
892<>BE_TYPE2規制<>Beログインしてください(t)。be.2ch.net
=cut
zerochplus_0.7.4/test/plugin/0ch_be_icon.pl 0000644 0000764 0001040 00000006064 12236106656 015675 0 ustar #============================================================================================================
#
# 拡張機能 - BEアイコン表示プラグイン
# 0ch_be_icon.pl
#
# by ぜろちゃんねるプラス
# http://zerochplus.sourceforge.jp/
#
# ---------------------------------------------------------------------------
#
# 2010.09.18 start
#
#============================================================================================================
package ZPL_be_icon;
#------------------------------------------------------------------------------------------------------------
#
# コンストラクタ
# -------------------------------------------------------------------------------------
# @param なし
# @return オブジェクト
#
#------------------------------------------------------------------------------------------------------------
sub new
{
my $this = shift;
my $obj={};
bless($obj,$this);
return $obj;
}
#------------------------------------------------------------------------------------------------------------
#
# 拡張機能名称取得
# -------------------------------------------------------------------------------------
# @param なし
# @return 名称文字列
#
#------------------------------------------------------------------------------------------------------------
sub getName
{
my $this = shift;
return 'BEアイコン表示プラグイン';
}
#------------------------------------------------------------------------------------------------------------
#
# 拡張機能説明取得
# -------------------------------------------------------------------------------------
# @param なし
# @return 説明文字列
#
#------------------------------------------------------------------------------------------------------------
sub getExplanation
{
my $this = shift;
return 'BE(HS)で取得したアイコンを表示します';
}
#------------------------------------------------------------------------------------------------------------
#
# 拡張機能タイプ取得
# -------------------------------------------------------------------------------------
# @param なし
# @return 拡張機能タイプ(スレ立て:1,レス:2,read:4,index:8)
#
#------------------------------------------------------------------------------------------------------------
sub getType
{
my $this = shift;
return (4 | 8);
}
#------------------------------------------------------------------------------------------------------------
#
# 拡張機能実行インタフェイス
# -------------------------------------------------------------------------------------
# @param $sys MELKOR
# @param $form SAMWISE
# @return 正常終了の場合は0
#
#------------------------------------------------------------------------------------------------------------
sub execute
{
use strict;
use warnings;
my $this = shift;
my ($sys, $form) = @_;
$sys->Get('_DAT_')->[3] =~ s|sssp://img.2ch.net/([^ <"]+)|
/g;
$$text =~ s/(http:\/\/.*?\.gif)/
/g;
$$text =~ s/(http:\/\/.*?\.bmp)/
/g;
}
else{
$$text =~ s/
/g;
$$text =~ s/
/g;
$$text =~ s/
/g;
}
}
#============================================================================================================
# Module END
#============================================================================================================
1;
zerochplus_0.7.4/test/plugin/0ch_omikuji.pl 0000644 0000764 0001040 00000007124 12236106656 015744 0 ustar #============================================================================================================
#
# 拡張機能 - おみくじ機能
# 0ch_omikuji.pl
# ---------------------------------------------------------------------------
# 2005.02.19 start
#
#============================================================================================================
package ZPL_omikuji;
#------------------------------------------------------------------------------------------------------------
#
# コンストラクタ
# -------------------------------------------------------------------------------------
# @param なし
# @return オブジェクト
#
#------------------------------------------------------------------------------------------------------------
sub new
{
my $this = shift;
my $obj={};
bless($obj,$this);
return $obj;
}
#------------------------------------------------------------------------------------------------------------
#
# 拡張機能名称取得
# -------------------------------------------------------------------------------------
# @param なし
# @return 名称文字列
#
#------------------------------------------------------------------------------------------------------------
sub getName
{
my $this = shift;
return 'おみくじ機能\';
}
#------------------------------------------------------------------------------------------------------------
#
# 拡張機能説明取得
# -------------------------------------------------------------------------------------
# @param なし
# @return 説明文字列
#
#------------------------------------------------------------------------------------------------------------
sub getExplanation
{
my $this = shift;
return '名前欄に !omikuji を記入することでおみくじを行えます。';
}
#------------------------------------------------------------------------------------------------------------
#
# 拡張機能タイプ取得
# -------------------------------------------------------------------------------------
# @param なし
# @return 拡張機能タイプ(スレ立て:1,レス:2,read:4,index:8)
#
#------------------------------------------------------------------------------------------------------------
sub getType
{
my $this = shift;
return (1 | 2);
}
#------------------------------------------------------------------------------------------------------------
#
# 拡張機能実行インタフェイス
# -------------------------------------------------------------------------------------
# @param $sys MELKOR
# @param $form SAMWISE
# @return 正常終了の場合は0
#
#------------------------------------------------------------------------------------------------------------
sub execute
{
my $this = shift;
my ($sys,$form) = @_;
if($form->Contain('FROM','!omikuji')){
my $from = $form->Get('FROM');
my $res = OMIKUJI(time());
$from =~ s/!omikuji/<\/b>【$res】/;
$form->Set('FROM',$from);
}
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# おみくじ機能
# -------------------------------------------------------------------------------------
# @param $seed ランダムの種
# @return 結果文字列
#
#------------------------------------------------------------------------------------------------------------
sub OMIKUJI
{
my ($seed) = @_;
my (@results,$count);
@results = ('大吉','中吉','小吉','吉','末吉','凶','大凶');
$count = @results;
srand($seed);
return($results[int(rand(65535)) % $count]);
}
#============================================================================================================
# Module END
#============================================================================================================
1;
zerochplus_0.7.4/test/plugin/0ch_spamblock.pl 0000644 0000764 0001040 00000011035 12236106656 016244 0 ustar #============================================================================================================
#
# 拡張機能 - 出会いスパムキャンセラー！
# 0ch_spam_block.pl
#
# by windyakin ◆windyaking
#
# http://windyakin.net/
#
# ---------------------------------------------------------------------------
#
# 2010.06.17 start
#
#============================================================================================================
package ZPL_spamblock;
#------------------------------------------------------------------------------------------------------------
#
# コンストラクタ
# -------------------------------------------------------------------------------------
# @param なし
# @return オブジェクト
#
#------------------------------------------------------------------------------------------------------------
sub new
{
my $this = shift;
my $obj={};
bless($obj,$this);
return $obj;
}
#------------------------------------------------------------------------------------------------------------
#
# 拡張機能名称取得
# -------------------------------------------------------------------------------------
# @param なし
# @return 名称文字列
#
#------------------------------------------------------------------------------------------------------------
sub getName
{
my $this = shift;
return '出会いスパムキャンセラー';
}
#------------------------------------------------------------------------------------------------------------
#
# 拡張機能説明取得
# -------------------------------------------------------------------------------------
# @param なし
# @return 説明文字列
#
#------------------------------------------------------------------------------------------------------------
sub getExplanation
{
my $this = shift;
return 'URLを調べて解析します';
}
#------------------------------------------------------------------------------------------------------------
#
# 拡張機能タイプ取得
# -------------------------------------------------------------------------------------
# @param なし
# @return 拡張機能タイプ(スレ立て:1,レス:2,read:4,index:8)
#
#------------------------------------------------------------------------------------------------------------
sub getType
{
my $this = shift;
return (1 | 2);
}
#------------------------------------------------------------------------------------------------------------
#
# 拡張機能実行インタフェイス
# -------------------------------------------------------------------------------------
# @param $sys MELKOR
# @param $form SAMWISE
# @return 正常終了の場合は0
#
#------------------------------------------------------------------------------------------------------------
sub execute
{
my $this = shift;
my ($sys, $form) = @_;
my ( @ng_addr, $mes, $bin_addr, $result );
# 禁止IPアドレス
@ng_addr = ( '66.71.248.210', '174.122.102.1', '74.207.244.52', '74.207.242.227' );
# メッセージを取得
$mes = $form->Get('MESSAGE');
# Encode.pmの使い方わかんないんですぅ＞＜
require Encode;
Encode::from_to( $mes, "Shift_JIS", "UTF-8" );
while ( $mes =~ /(h?ttp:\/\/)?([0-9a-zA-Z\.\-]+\.(?:com|net|info|me|mobi|cc|asia|org|biz|co|in|tv|ch|at|mn|la|vg|ms|gs|vc|bz|ws|be|so))/ig )
{
# ホストを調査
$bin_addr = gethostbyname($2);
$result = sprintf("%vd", $bin_addr);
# エラーを返すよ
foreach ( @ng_addr ) {
if ( $_ eq $result ) {
PrintBBSError( $sys, $form, 205 );
}
}
}
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# なんちゃってbbs.cgiエラーページ表示
# -------------------------------------------------------------------------------------
# @param $sys MELKOR
# @param $form SAMWISE
# @param $err エラー番号
# @return なし
# exit エラー番号
#
#------------------------------------------------------------------------------------------------------------
sub PrintBBSError
{
my ($sys,$form,$err) = @_;
my $SYS;
require('./module/radagast.pl');
require('./module/isildur.pl');
require('./module/thorin.pl');
$SYS->{'SYS'} = $sys;
$SYS->{'FORM'} = $form;
$SYS->{'COOKIE'} = new RADAGAST;
$SYS->{'COOKIE'}->Init();
$SYS->{'SET'} = new ISILDUR;
$SYS->{'SET'}->Load($sys);
my $Page = new THORIN;
require('./module/orald.pl');
$ERROR = new ORALD;
$ERROR->Load($sys);
$ERROR->Print($SYS,$Page,$err,$sys->Get('AGENT'));
$Page->Flush('',0,0);
exit($err);
}
#============================================================================================================
# Module END
#============================================================================================================
1;
__END__
zerochplus_0.7.4/test/plugin/0ch_spamkiller.pl 0000644 0000764 0001040 00000020462 12236106656 016440 0 ustar #============================================================================================================
#
# 拡張機能 - スパムキラー
# 0ch_spamkiller.pl
#
#============================================================================================================
package ZPL_spamkiller;
#------------------------------------------------------------------------------------------------------------
# 拡張機能名称取得
#------------------------------------------------------------------------------------------------------------
sub getName
{
return 'スパムキラー';
}
#------------------------------------------------------------------------------------------------------------
# 拡張機能説明取得
#------------------------------------------------------------------------------------------------------------
sub getExplanation
{
return '英文スパムをベイジアンフィルタによって排除します。';
}
#------------------------------------------------------------------------------------------------------------
# 拡張機能タイプ取得
#------------------------------------------------------------------------------------------------------------
sub getType
{
return (1 | 2); # スレ立て・レス
}
#------------------------------------------------------------------------------------------------------------
# 設定リスト取得 (0ch+ Only)
#------------------------------------------------------------------------------------------------------------
sub getConfig
{
my $this = shift;
my %config;
%config = (
'name_ascii_point' => {
'default' => 2,
'valuetype' => 1,
'description' => '[加点]名前欄がASCIIのみ',
},
'mail_atsign_point' => {
'default' => 5,
'valuetype' => 1,
'description' => '[加点]メール欄に半角@を含む',
},
'nohost_point' => {
'default' => 7,
'valuetype' => 1,
'description' => '[加点]ホスト名が逆引き不可',
},
'tldomain_setting' => {
'default' => 'jp,com,net,org=2;*=3',
'valuetype' => 2,
'description' => '[指定]本文中リンクのTLドメインの種類ごとに加点
※text_url_pointが0の時のみ有効です',
},
'text_ascii_point' => {
'default' => 2,
'valuetype' => 1,
'description' => '[加点]本文のASCIIの割合が指定した％以上',
},
'text_ascii_ratio' => {
'default' => 95,
'valuetype' => 1,
'description' => '[しきい値]本文のASCIIの割合(％)',
},
'text_ahref_point' => {
'default' => 5,
'valuetype' => 1,
'description' => '[加点]本文に「<a href=」か「[url=」を含む',
},
'text_url_point' => {
'default' => 3,
'valuetype' => 1,
'description' => '[加点]本文にリンクを含む
※0にするとtldomain_settingが有効になります',
},
'threshold_point' => {
'default' => 10,
'valuetype' => 1,
'description' => '[しきい値]スパムと判定する点数',
},
);
return \%config;
}
#------------------------------------------------------------------------------------------------------------
# 拡張機能実行インタフェイス
# -------------------------------------------------------------------------------------
# @param $sys MELKOR
# @param $form SAMWISE
# @param $type 実行タイプ
# @return 正常終了の場合は0
#------------------------------------------------------------------------------------------------------------
sub execute
{
my $this = shift;
my ($sys, $form, $type) = @_;
if ($type & (1 | 2)) {
my $nohost_point = $this->GetConf('nohost_point');
my $tldomain_setting = $this->GetConf('tldomain_setting');
my $name_ascii_point = $this->GetConf('name_ascii_point');
my $mail_atsign_point = $this->GetConf('mail_atsign_point');
my $text_ascii_point = $this->GetConf('text_ascii_point');
my $text_ascii_ratio = $this->GetConf('text_ascii_ratio');
my $text_ahref_point = $this->GetConf('text_ahref_point');
my $text_url_point = $this->GetConf('text_url_point');
my $threshold_point = $this->GetConf('threshold_point');
require Encode;
my $name = $form->Get('FROM');
my $mail = $form->Get('mail');
my $text = $form->Get('MESSAGE');
$name = Encode::decode('sjis', $name);
$mail = Encode::decode('sjis', $mail);
$text = Encode::decode('sjis', $text);
my $point = 0;
if ($ENV{'REMOTE_HOST'} eq $ENV{'REMOTE_ADDR'}) {
$point += $nohost_point;
}
if ($name ne '' && $name !~ /[^\x09\x0a\x0d\x20-\x7e]/) {
$point += $name_ascii_point;
}
if ($mail =~ /@/) {
$point += $mail_atsign_point;
}
if ($text =~ /<a href=|\[url=/i) {
$point += $text_ahref_point;
}
if ($text =~ m|http://|) {
$point += $text_url_point;
}
if ('ASCII text') {
$text =~ s/
//gi;
$text =~ s/[\x00-\x1f\x7f\s]//g;
my $c_asc = @_ = $text =~ /[\x20-\x7e]/g;
my $c_nasc = @_ = $text =~ /[^\x20-\x7e]/g;
if ($c_asc * 100 >= ($c_asc + $c_nasc) * $text_ascii_ratio) {
$point += $text_ascii_point;
}
}
if ('TLD of links' && $text_url_point == 0) {
my %tld2pt = ('*' => 0);
my $r_num = '^-?[0-9]+$';
my $r_tld = '^[a-z](?:[a-z0-9\-](?:[a-z0-9])?)?$|^\*$';
# 設定文を解釈し点数マップを作成
foreach (split(/[^0-9a-zA-Z\-=,\*]/, $tldomain_setting)) {
my @buf = split(/[=,]/, $_);
my @num = grep { /$r_num/ } @buf;
if (scalar(@num) == 1) {
map { $tld2pt{$_} = $num[0] } grep { /$r_tld/i } @buf;
} elsif (scalar(@num) > 1) {
foreach (split(/,/, $_)) {
my @buf2 = split(/=/, $_);
next if (!defined (my $p = pop @{[grep { /$r_num/ } @buf2]}));
map { $tld2pt{$_} = $p } grep { /$r_tld/i } @buf2;
}
}
}
# 本文リンクからTLDを抽出し重複排除
my @tldlist = keys %{ {map { pop(@{[split(/\./, $_)]}), 1 }
($text =~ m|http://([a-z0-9\-\.]+)|gi)} };
# TLDの種類ごとに加点
foreach $tld (@tldlist) {
$tld = '*' if (!defined $tld2pt{$tld});
$point += $tld2pt{$tld};
}
}
if ($point >= $threshold_point) {
PrintBBSError($sys, $form, 205);
}
}
return 0;
}
#------------------------------------------------------------------------------------------------------------
# コンストラクタ
#------------------------------------------------------------------------------------------------------------
sub new
{
my $this = shift;
my ($Config) = @_;
my ($obj);
$obj = {};
bless $obj, $this;
if (defined $Config) {
$obj->{'PLUGINCONF'} = $Config;
$obj->{'is0ch+'} = 1;
}
else {
$obj->{'CONFIG'} = $this->getConfig();
$obj->{'is0ch+'} = 0;
}
return $obj;
}
#------------------------------------------------------------------------------------------------------------
# 設定値取得 (0ch+ Only)
#------------------------------------------------------------------------------------------------------------
sub GetConf
{
my $this = shift;
my ($key) = @_;
my ($val);
if ($this->{'is0ch+'}) {
$val = $this->{'PLUGINCONF'}->GetConfig($key);
}
else {
if (defined $this->{'CONFIG'}->{$key}) {
$val = $this->{'CONFIG'}->{$key}->{'default'};
}
else {
$val = undef;
}
}
return $val;
}
#------------------------------------------------------------------------------------------------------------
# 設定値設定 (0ch+ Only)
#------------------------------------------------------------------------------------------------------------
sub SetConf
{
my $this = shift;
my ($key, $val) = @_;
if ($this->{'is0ch+'}) {
$this->{'PLUGINCONF'}->SetConfig($key, $val);
}
else {
if (defined $this->{'CONFIG'}->{$key}) {
$this->{'CONFIG'}->{$key}->{'default'} = $val;
}
else {
$this->{'CONFIG'}->{$key} = { 'default' => $val };
}
}
}
#------------------------------------------------------------------------------------------------------------
# なんちゃってbbs.cgiエラーページ表示
#------------------------------------------------------------------------------------------------------------
sub PrintBBSError
{
my ($sys, $form, $err) = @_;
my $SYS;
require './module/radagast.pl';
require './module/isildur.pl';
require './module/thorin.pl';
$SYS->{'SYS'} = $sys;
$SYS->{'FORM'} = $form;
$SYS->{'COOKIE'} = RADAGAST->new;
$SYS->{'COOKIE'}->Init;
$SYS->{'SET'} = ISILDUR->new;
$SYS->{'SET'}->Load($sys);
my $Page = THORIN->new;
require('./module/orald.pl');
$ERROR = ORALD->new;
$ERROR->Load($sys);
$ERROR->Print($SYS, $Page, $err, $sys->Get('AGENT'));
$Page->Flush('', 0, 0);
exit($err);
}
#============================================================================================================
# Module END
#============================================================================================================
1;
zerochplus_0.7.4/test/plugin/0ch_stress.pl 0000644 0000764 0001040 00000007470 12236106656 015624 0 ustar #============================================================================================================
#
# 拡張機能 - 特殊強調表示機能
# 0ch_stress.pl
# ---------------------------------------------------------------------------
# 2005.02.19 start
#
#============================================================================================================
package ZPL_stress;
#------------------------------------------------------------------------------------------------------------
#
# コンストラクタ
# -------------------------------------------------------------------------------------
# @param なし
# @return オブジェクト
#
#------------------------------------------------------------------------------------------------------------
sub new
{
my $this = shift;
my $obj={};
bless($obj,$this);
return $obj;
}
#------------------------------------------------------------------------------------------------------------
#
# 拡張機能名称取得
# -------------------------------------------------------------------------------------
# @param なし
# @return 名称文字列
#
#------------------------------------------------------------------------------------------------------------
sub getName
{
my $this = shift;
return '特殊強調表\示機能\';
}
#------------------------------------------------------------------------------------------------------------
#
# 拡張機能説明取得
# -------------------------------------------------------------------------------------
# @param なし
# @return 説明文字列
#
#------------------------------------------------------------------------------------------------------------
sub getExplanation
{
my $this = shift;
return '先頭に ＞,＃,# の付いた行を強調表\示します。';
}
#------------------------------------------------------------------------------------------------------------
#
# 拡張機能タイプ取得
# -------------------------------------------------------------------------------------
# @param なし
# @return 拡張機能タイプ(スレ立て:1,レス:2,read:4,index:8)
#
#------------------------------------------------------------------------------------------------------------
sub getType
{
my $this = shift;
return (1 | 2);
}
#------------------------------------------------------------------------------------------------------------
#
# 拡張機能実行インタフェイス
# -------------------------------------------------------------------------------------
# @param $sys MELKOR
# @param $form SAMWISE
# @return 正常終了の場合は0
#
#------------------------------------------------------------------------------------------------------------
sub execute
{
my $this = shift;
my ($sys,$form) = @_;
my $content = $form->Get('MESSAGE');
STRESS(\$content);
$form->Set('MESSAGE',$content);
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# 特殊強調表示
# -------------------------------------------------------------------------------------
# @param $text 対象文字列
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub STRESS
{
my ($text) = @_;
$$text = '
' . $$text . '
';
# ＞引用変換
while($$text =~ /
＞(.*?)
/){
$$text =~ s/
＞(.*?)
/
＞$1<\/font>
/;
}
# ＃引用変換
while($$text =~ /
＃(.*?)
/){
$$text =~ s/
＃(.*?)
/
＃$1<\/font>
/;
}
# #引用変換
while($$text =~ /
#(.*?)
/){
$$text =~ s/
#(.*?)
/
#$1<\/font>
/;
}
# 最初につけた
を取り外す
$$text = substr($$text,4,length($$text) - 8);
}
#============================================================================================================
# Module END
#============================================================================================================
1;
zerochplus_0.7.4/test/plugin/0ch_tasukeruyo.pl 0000644 0000764 0001040 00000007256 12236106656 016516 0 ustar #============================================================================================================
#
# 拡張機能 - 助けるよ
# 0ch_tasukeruyo.pl
# ---------------------------------------------------------------------------
# 2010.08.14 start
#
#============================================================================================================
package ZPL_tasukeruyo;
#------------------------------------------------------------------------------------------------------------
#
# コンストラクタ
# -------------------------------------------------------------------------------------
# @param なし
# @return オブジェクト
#
#------------------------------------------------------------------------------------------------------------
sub new
{
my $this = shift;
my $obj={};
bless($obj,$this);
return $obj;
}
#------------------------------------------------------------------------------------------------------------
#
# 拡張機能名称取得
# -------------------------------------------------------------------------------------
# @param なし
# @return 名称文字列
#
#------------------------------------------------------------------------------------------------------------
sub getName
{
my $this = shift;
return '助けるよ';
}
#------------------------------------------------------------------------------------------------------------
#
# 拡張機能説明取得
# -------------------------------------------------------------------------------------
# @param なし
# @return 説明文字列
#
#------------------------------------------------------------------------------------------------------------
sub getExplanation
{
my $this = shift;
return '名前欄に tasukeruyo を記入するとUAを表\示します';
}
#------------------------------------------------------------------------------------------------------------
#
# 拡張機能タイプ取得
# -------------------------------------------------------------------------------------
# @param なし
# @return 拡張機能タイプ(スレ立て:1,レス:2,read:4,index:8)
#
#------------------------------------------------------------------------------------------------------------
sub getType
{
my $this = shift;
return (16);
}
#------------------------------------------------------------------------------------------------------------
#
# 拡張機能実行インタフェイス
# -------------------------------------------------------------------------------------
# @param $sys MELKOR
# @param $form SAMWISE
# @return 正常終了の場合は0
#
#------------------------------------------------------------------------------------------------------------
sub execute
{
my $this = shift;
my ($sys, $form, $type) = @_;
if ( $type & 16 ) {
my ($from, $koyuu, $agent, $tasuke, $mes, $ua);
$from = $form->Get('FROM');
$koyuu = $sys->Get('KOYUU');
$koyuu = $sys->Get('HOST') if (! defined $koyuu);
$agent = $sys->Get('AGENT');
$mes = $form->Get('MESSAGE');
$ua = $ENV{'HTTP_USER_AGENT'};
if ( $from =~ /^(?:[\x00-\x7f\xa1-\xdf]|[\x81-\x9f\xe0-\xef][\x40-\x7e\x80-\xfc])*?tasukeruyo/ ) {
if ( $agent eq 'O' || $agent eq 'P' || $agent eq 'i' ) {
$tasuke = "$ENV{'REMOTE_HOST'}($koyuu)";
}
else {
$tasuke = "$ENV{'REMOTE_HOST'}($ENV{'REMOTE_ADDR'})";
}
$from =~ s#^((?:[\x00-\x7f\xa1-\xdf]|[\x81-\x9f\xe0-\xef][\x40-\x7e\x80-\xfc])*?)tasukeruyo#$1$tasuke#g;
$form->Set('FROM', $from);
$ua =~ s//>/g;
$form->Set('MESSAGE',"$mes
$ua");
}
}
return 0;
}
#============================================================================================================
# Module END
#============================================================================================================
1;
zerochplus_0.7.4/test/plugin/0ch_templete.pl 0000644 0000764 0001040 00000012317 12236106656 016114 0 ustar #============================================================================================================
#
# 拡張機能 - テンプレート
# 0ch_templete.pl
# ---------------------------------------------------------------------------
# 201x.xx.xx start
#
#============================================================================================================
package ZPL_templete;
#------------------------------------------------------------------------------------------------------------
# コンストラクタ
#------------------------------------------------------------------------------------------------------------
sub new
{
my $this = shift;
my ($Config) = @_;
my ($obj);
$obj = {};
bless $obj, $this;
if (defined $Config) {
$obj->{'PLUGINCONF'} = $Config;
$obj->{'is0ch+'} = 1;
}
else {
$obj->{'CONFIG'} = $this->getConfig();
$obj->{'is0ch+'} = 0;
}
return $obj;
}
#------------------------------------------------------------------------------------------------------------
# 拡張機能名称取得
# -------------------------------------------------------------------------------------
# @return 名称文字列
#------------------------------------------------------------------------------------------------------------
sub getName
{
my $this = shift;
return 'テンプレート';
}
#------------------------------------------------------------------------------------------------------------
# 拡張機能説明取得
# -------------------------------------------------------------------------------------
# @return 説明文字列
#------------------------------------------------------------------------------------------------------------
sub getExplanation
{
my $this = shift;
return 'これはテンプレートです。有効にしても意味ないですよ。';
}
#------------------------------------------------------------------------------------------------------------
# 拡張機能タイプ取得
# -------------------------------------------------------------------------------------
# @return 拡張機能タイプ(スレ立て:1, レス:2, read:4, index:8, 書き込み前処理:16)
#------------------------------------------------------------------------------------------------------------
sub getType
{
my $this = shift;
return (1 | 2);
}
#------------------------------------------------------------------------------------------------------------
# 設定リスト取得 (0ch+ Only)
# -------------------------------------------------------------------------------------
# @param なし
# @return 設定ハッシュリファレンス
# \%config = (
# '設定名' => {
# 'default' => 初期値, # 真偽値の場合は on/true: 1, off/false: 0
# 'valuetype' => 値のタイプ, # 数値: 1, 文字列: 2, 真偽値: 3
# 'description' => '設定の説明', # 無くても構いません
# },
# );
#------------------------------------------------------------------------------------------------------------
sub getConfig
{
my $this = shift;
my %config;
%config = (
'testnum' => {
'default' => 123,
'valuetype' => 1,
},
# 'testtext' => {
# 'default' => 'test',
# 'valuetype' => 2,
# },
);
return \%config;
}
#------------------------------------------------------------------------------------------------------------
# 拡張機能実行インタフェイス
# -------------------------------------------------------------------------------------
# @param $sys MELKOR
# @param $form SAMWISE
# @param $type 実行タイプ
# @return 正常終了の場合は0
#------------------------------------------------------------------------------------------------------------
sub execute
{
my $this = shift;
my ($sys, $form, $type) = @_;
if ($type & (1 | 2)) {
# my $num = $this->GetConf('testnum');
# $this->SetConf('testnum', $num + 1);
}
return 0;
}
#------------------------------------------------------------------------------------------------------------
# 設定値取得 (0ch+ Only)
# -------------------------------------------------------------------------------------
# @param $key 設定名
# @return 設定値
#------------------------------------------------------------------------------------------------------------
sub GetConf
{
my $this = shift;
my ($key) = @_;
my ($val);
if ($this->{'is0ch+'}) {
$val = $this->{'PLUGINCONF'}->GetConfig($key);
}
else {
if (defined $this->{'CONFIG'}->{$key}) {
$val = $this->{'CONFIG'}->{$key}->{'default'};
}
else {
$val = undef;
}
}
return $val;
}
#------------------------------------------------------------------------------------------------------------
# 設定値設定 (0ch+ Only)
# -------------------------------------------------------------------------------------
# @param $key 設定名
# @param $val 設定値
# @return なし
#------------------------------------------------------------------------------------------------------------
sub SetConf
{
my $this = shift;
my ($key, $val) = @_;
if ($this->{'is0ch+'}) {
$this->{'PLUGINCONF'}->SetConfig($key, $val);
}
else {
if (defined $this->{'CONFIG'}->{$key}) {
$this->{'CONFIG'}->{$key}->{'default'} = $val;
}
else {
$this->{'CONFIG'}->{$key} = { 'default' => $val };
}
}
}
#============================================================================================================
# Module END
#============================================================================================================
1;
zerochplus_0.7.4/test/plugin/index.html 0000644 0000764 0001040 00000000015 12145672440 015171 0 ustar 403 Forbidden zerochplus_0.7.4/test/plugin_conf/index.html 0000644 0000764 0001040 00000000015 12145672440 016176 0 ustar 403 Forbidden