"); } # 看板画像にリンクはなし else { $Page->Print("
"); } } $Page->Print("
$ver
名前： $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('
READ.CGI - $ver
READ.CGI - $var\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
|
ぜろちゃんねる プラス
SEARCH.CGI - $ver
HTML
}
#------------------------------------------------------------------------------------------------------------
#
# 検索結果出力 - Search
# ------------------------------------------------
# 引 数：なし
# 戻り値：なし
#
#------------------------------------------------------------------------------------------------------------
sub Search
{
my ($Sys, $Form, $Page, $BBS) = @_;;
my ($Search, $Mode, $Result, @elem, $n, $base, $word);
my (@types, $Type);
require './module/balrogs.pl';
$Search = new BALROGS;
$Mode = 0 if ($Form->Equal('MODE', 'ALL'));
$Mode = 1 if ($Form->Equal('MODE', 'BBS'));
$Mode = 2 if ($Form->Equal('MODE', 'THREAD'));
@types = $Form->GetAtArray('TYPE', 0);
$Type = ($types[0] || 0) | ($types[1] || 0) | ($types[2] || 0);
# 検索オブジェクトの設定と検索の実行
$Search->Create($Sys, $Mode, $Type, $Form->Get('BBS', ''), $Form->Get('KEY', ''));
$Search->Run($Form->Get('WORD'));
if ($@ ne '') {
PrintSystemError($Page, $@);
return;
}
# 検索結果セット取得
$Result = $Search->GetResultSet();
$n = $Result ? @$Result : 0;
$base = $Sys->Get('BBSPATH');
$word = $Form->Get('WORD');
PrintResultHead($Page, $n);
# 検索ヒットが1件以上あり
if ($n > 0) {
require './module/galadriel.pl';
my $Conv = new GALADRIEL;
$n = 1;
foreach (@$Result) {
@elem = split(/<>/);
PrintResult($Page, $BBS, $Conv, $n, $base, \@elem);
$n++;
}
}
# 検索ヒット無し
else {
PrintNoHit($Page);
}
PrintResultFoot($Page);
}
#------------------------------------------------------------------------------------------------------------
#
# 検索結果ヘッダ出力 - PrintResultHead
# ------------------------------------------------
# 引 数：Page : 出力モジュール
# 戻り値：なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintResultHead
{
my ($Page, $n) = @_;
$Page->Print(<
【ヒット数：0】システムエラー
|
･転んでも泣かないzerochplus_dev-r364/test/datas/default_img.gif 0000644 0000764 0001040 00000044014 11601364027 016547 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､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_dev-r364/test/info/users.cgi 0000644 0000764 0001040 00000000130 11601364026 015252 0 ustar 0000000001<>Administrator<>431XyHmErk<>システムアドミニストレータ<>システム管理者。<>1
zerochplus_dev-r364/test/module/athelas.pl 0000644 0000764 0001040 00000035557 12042721615 015763 0 ustar #============================================================================================================
#
# プラグイン管理モジュール
#
#============================================================================================================
package ATHELAS;
use strict;
#use warnings;
#------------------------------------------------------------------------------------------------------------
#
# コンストラクタ
# -------------------------------------------------------------------------------------
# @param なし
# @return モジュールオブジェクト
#
#------------------------------------------------------------------------------------------------------------
sub new
{
my $class = shift;
my $obj = {
'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->{'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;
}
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->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) = @_;
if (! -d './plugin_conf') {
if (! -e './plugin_conf') {
mkdir './plugin_conf';
}
else {
warn "can't mkdir: ./plugin_conf";
warn "can't save plugin config";
return;
}
}
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) {
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";
}
}
else {
unlink $path;
}
}
#------------------------------------------------------------------------------------------------------------
#
# プラグイン個別設定初期値設定
# -------------------------------------------------------------------------------------
# @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';
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";
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_dev-r364/test/module/baggins.pl 0000644 0000764 0001040 00000054600 12042721615 015742 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,
};
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);
}
elsif (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;
#chmod $Sys->Get('PM-TXT'), $path;
}
#------------------------------------------------------------------------------------------------------------
#
# スレッド情報読み込み
# -------------------------------------------------------------------------------------
# @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;
}
#------------------------------------------------------------------------------------------------------------
#
# スレッド情報保存
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Save
{
my $this = shift;
my ($Sys) = @_;
my $fh = $this->Open($Sys) or return;
my $subject = $this->{'SUBJECT'};
foreach (@{$this->{'SORT'}}) {
next if (!defined $subject->{$_});
print $fh "$_.dat<>$subject->{$_} ($this->{'RES'}->{$_})\n";
}
truncate($fh, tell($fh));
$this->Close();
}
#------------------------------------------------------------------------------------------------------------
#
# オンデマンド式レス数更新
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @param $id スレッドID
# @param $val レス数
# @param $age ageるなら1
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub OnDemand
{
my $this = shift;
my ($Sys, $id, $val, $age) = @_;
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 ($age) {
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;
}
}
}
# 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();
}
#------------------------------------------------------------------------------------------------------------
#
# スレッド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'};
}
#------------------------------------------------------------------------------------------------------------
#
# 最後のスレッドID取得
# -------------------------------------------------------------------------------------
# @param なし
# @return スレッドID
#
#------------------------------------------------------------------------------------------------------------
sub GetLastID
{
my $this = shift;
my $sort = $this->{'SORT'};
return $sort->[$#$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, $sort->[$i];
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, $sort->[$i];
last;
}
}
}
#------------------------------------------------------------------------------------------------------------
#
# スレッド情報更新
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Update
{
my $this = shift;
my ($Sys) = @_;
my $base = $Sys->Get('BBSPATH') . '/' . $Sys->Get('BBS') . '/dat';
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;
}
}
#------------------------------------------------------------------------------------------------------------
#
# スレッド位置取得
# -------------------------------------------------------------------------------------
# @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,
};
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;
}
}
#------------------------------------------------------------------------------------------------------------
#
# スレッド情報保存
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Save
{
my $this = shift;
my ($Sys) = @_;
my $path = $Sys->Get('BBSPATH') . '/' .$Sys->Get('BBS') . '/pool/subject.cgi';
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-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};
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'};
}
#------------------------------------------------------------------------------------------------------------
#
# スレッド情報更新
# -------------------------------------------------------------------------------------
# @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_dev-r364/test/module/balrogs.pl 0000644 0000764 0001040 00000013366 12042721615 015765 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_dev-r364/test/module/celeborn.pl 0000644 0000764 0001040 00000031140 12042721615 016113 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';
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');
Add($this, 0, 0, 0, $dir);
foreach my $file (@fileList) {
my @elem = split(/\./, $file);
my $subj = GetThreadSubject("$path/$dir/$file");
if ($subj ne '') {
Add($this, $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);
}
}
#------------------------------------------------------------------------------------------------------------
#
# サブフォルダを取得する
# -------------------------------------------------------------------------------------
# @param $base 親フォルダパス
# @param $pDirs ディレクトリ名の配列
# @param $pList サブフォルダ格納配列
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub GetSubFolders
{
my ($base, $pDirs, $pList) = @_;
foreach my $dir (@$pDirs) {
if ($dir =~ s|^\Q$base/\E|| && $dir !~ m|/|) {
push @$pList, $dir;
}
}
}
#------------------------------------------------------------------------------------------------------------
#
# 過去ログタイトルの取得
# -------------------------------------------------------------------------------------
# @param $path 取得するファイルのパス
# @return タイトル
#
#------------------------------------------------------------------------------------------------------------
sub GetThreadSubject
{
my ($path) = @_;
my $title = '';
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(<
HTML
# index.htmlを出力する
$Page->Flush(1, 0666, "$base/kako$path/index.html");
}
#============================================================================================================
# モジュール終端
#============================================================================================================
1;
zerochplus_dev-r364/test/module/cidr_list.pl 0000644 0000764 0001040 00000020746 12042721615 016310 0 ustar #============================================================================================================
#
# 携帯IPのCIDRチェック
# cidr_list.pl
#
# by ぜろちゃんねるプラス
# http://zerochplus.sourceforge.jp/
#
# ---------------------------------------------------------------------------
#
# 2011.01.01 start
#
# 2011.06.13 last up
#
#============================================================================================================
package ZP_CIDR;
use strict;
#use warnings;
our $cidr = ();
#------------------------------------------------------------------------------------------------------------
#
# CIDRリスト
# -------------------------------------------------------------------------------------
# ただ我武者羅に資料を集めて配列化しただけ
# どう使うかはあなた次第だ
#
#------------------------------------------------------------------------------------------------------------
{
# NTT docomo [ docomo.ne.jp ]
my @docomo = (
# http://www.nttdocomo.co.jp/service/developer/make/content/ip/
'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',
);
$cidr->{'docomo'} = \@docomo;
# iモードフルブラウザ(docomo)
my @docomo_pc = (
'210.153.87.0/24',
);
$cidr->{'docomo_pc'} = \@docomo_pc;
# Vodafone というか SoftBank というか J-PHONE というか… [ jp-[a-z].jp, softbank.ne.jp, vodafone.ne.jp ]
my @vodafone = (
# http://creation.mb.softbank.jp/web/web_ip.html
'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',
);
$cidr->{'vodafone'} = \@vodafone;
# PCサイトブラウザ(Softbank)
my @vodafone_pc = (
# http://creation.mb.softbank.jp/web/web_ip.html
'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',
);
$cidr->{'vodafone_pc'} = \@vodafone_pc;
# au by KDDI [ ezweb.ne.jp ]
my @ezweb = (
# http://www.au.kddi.com/ezfactory/tec/spec/ezsava_ip.html
'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', '121.111.231.0/25',
'121.111.227.0/25', '118.152.214.192/26', '118.159.133.0/25',
'118.159.132.160/27', '111.86.142.0/26', '111.86.141.64/26', '111.86.141.128/26',
'111.86.141.192/26', '118.159.133.192/26', '111.86.143.192/27', '111.86.143.224/27',
'111.86.147.0/27', '111.86.142.128/27', '111.86.142.160/27', '111.86.142.192/27',
'111.86.142.224/27', '111.86.143.0/27', '111.86.143.32/27', '111.86.147.32/27',
'111.86.147.64/27', '111.86.147.96/27', '111.86.147.128/27', '111.86.147.160/27',
'111.86.147.192/27', '111.86.147.224/27',
# 2011年秋冬モデル以降の一部機種のEZサーバ
'111.107.116.64/26', '111.107.116.192/28',
# 2012年11月廃止予定
'121.111.227.160/27', '222.5.62.128/25', '59.135.38.128/25', '219.108.157.0/25',
'219.125.145.0/25', '118.159.131.0/25',
);
$cidr->{'ezweb'} = \@ezweb;
# PCサイトビューア(ezweb)
my @ezweb_pc = (
# http://www.au.kddi.com/ezfactory/tec/spec/ezsava_ip.html
'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',
);
$cidr->{'ezweb_pc'} = \@ezweb_pc;
# イー・モバイル [ emobile.ad.jp ]
my @emobile = (
# http://developer.emnet.ne.jp/ipaddress.html
'117.55.1.224/27'
);
$cidr->{'emobile'} = \@emobile;
# WILLCOM [ prin.ne.jp ]
my @willcom = (
# http://www.willcom-inc.com/ja/service/contents_service/create/center_info/
'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.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.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',
);
$cidr->{'willcom'} = \@willcom;
# ibisブラウザ
my @ibis = (
# http://ibis.ne.jp/support/browserIP.jsp
'59.106.88.0/24',
);
$cidr->{'ibis'} = \@ibis;
# jigブラウザ
my @jig = (
# http://br.jig.jp/pc/ip_br.html
'82.48.6.10/31', '82.48.6.12/30', '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.207.38/31',
'112.78.207.40/29', '112.78.207.48/29', '112.78.207.56/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.198/31',
'112.78.215.200/29', '112.78.215.208/29', '112.78.215.216/31', '112.78.215.230/31',
'112.78.215.232/29', '112.78.215.240/29', '112.78.215.248/31', '182.48.5.134/31',
'182.48.5.136/29', '182.48.5.144/29', '182.48.5.152/31', '182.48.5.166/31',
'182.48.5.168/29', '182.48.5.176/29', '182.48.5.184/31', '182.48.5.198/31',
'182.48.5.200/29', '182.48.5.208/29', '182.48.5.216/31', '182.48.5.230/31',
'182.48.5.232/29', '182.48.6.6/31', '182.48.6.8/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',
# jigブラウザWEB
'124.83.159.0/24', '124.83.190.0/24', '210.188.204.0/23', '210.188.205.0/24',
);
$cidr->{'jig'} = \@jig;
# iPhone/iPad
my @iphone = (
# 非公式情報 (基本放置でいきましょう 2012.06 じ)
# 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',
# openmobile.ne.jp
#'126.192.0.0/15', '126.243.0.0/16',
);
$cidr->{'iphone'} = \@iphone;
# p2
my @p2 = (
# cw43.razil.jp
'210.135.98.43',
# p202.razil.jp
'210.135.100.132',
);
$cidr->{'p2'} = \@p2;
}
1;
zerochplus_dev-r364/test/module/constant.pl 0000644 0000764 0001040 00000004110 12042721615 016150 0 ustar #============================================================================================================
#
# 定数モジュール(ZP)
# constant.pl
#
# by ぜろちゃんねるプラス
# http://zerochplus.sourceforge.jp/
#
# ---------------------------------------------
#
# 2011.01.02 start
# 2011.12.03 iPhoneがフルブラウザになっていたのを修正
# 固有IDが取れそうなC_MOBILE_IDGETを新規設定
#
#============================================================================================================
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;
our $RE_SJIS = '(?:[\x00-\x7f\xa1-\xdf]|[\x81-\x9f\xe0-\xef][\x40-\x7e\x80-\xfc])';
#============================================================================================================
# モジュール終端
#============================================================================================================
1;
zerochplus_dev-r364/test/module/denethor.pl 0000644 0000764 0001040 00000014545 12042721615 016144 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'} = '
$version
なるほど告知欄じゃねーの なるほど告知欄じゃねーの
') 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_dev-r364/test/module/earendil.pl 0000644 0000764 0001040 00000016423 12042721615 016114 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);
# パーミッション設定
my $perm = (stat $src)[2];
chmod $perm, $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) = @_;
while (1) {
if (-d $path) {
return;
}
else {
if (mkdir($path, 0777)) {
return;
}
# ディレクトリ作成失敗時は再帰的に1つ下の階層を作成する
else {
my $upath = $path;
$upath =~ s|[\\\/][^\\\/]*$||;
CreateFolderHierarchy($upath);
}
}
}
}
#------------------------------------------------------------------------------------------------------------
#
# ディレクトリ検索
# -------------------------------------------------------------------------------------
# @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 (keys(%folders) > 0) {
$pHash->{$elem} = \%folders;
}
else {
delete $pHash->{$elem};
}
}
}
}
#------------------------------------------------------------------------------------------------------------
#
# ディレクトリリスト取得
# 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_dev-r364/test/module/elves.pl 0000644 0000764 0001040 00000047071 12042721615 015452 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';
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';
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 '';
}
#============================================================================================================
#
# セキュリティ管理パッケージ
# ARWEN
# -------------------------------------------------------------------------------------
# 2004.02.07 start
#
#============================================================================================================
package ARWEN;
use strict;
#use warnings;
#------------------------------------------------------------------------------------------------------------
#
# コンストラクタ
# -------------------------------------------------------------------------------------
# @param なし
# @return モジュールオブジェクト
#
#------------------------------------------------------------------------------------------------------------
sub new
{
my $class = shift;
my $obj = {
'SYS' => undef,
'USER' => undef,
'GROUP' => undef,
'BBS' => 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'} = new GLORFINDEL;
$this->{'GROUP'} = new GILDOR;
$this->{'USER'}->Load($Sys);
}
}
#------------------------------------------------------------------------------------------------------------
#
# ログイン判定
# -------------------------------------------------------------------------------------
# @param $name ユーザ名
# @param $pass パスワード
# @return 正式なユーザなら1を返す
#
#------------------------------------------------------------------------------------------------------------
sub IsLogin
{
my $this = shift;
my ($name, $pass) = @_;
my $User = $this->{'USER'};
# ユーザ名でユーザIDセットを取得
my @keySet = ();
$User->GetKeySet('NAME', $name, \@keySet);
# 取得したIDセットからユーザ名とパスワードが同じものを検索
foreach my $id (@keySet) {
my $lPass = $User->Get('PASS', $id);
my $hash = $User->GetStrictPass($pass, $id);
if ($lPass eq $hash) {
return $id;
}
}
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# 権限判定前グループ情報準備
# -------------------------------------------------------------------------------------
# @param $bbs 適応個所
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub SetGroupInfo
{
my $this = shift;
my ($bbs) = @_;
my $oldBBS = $this->{'SYS'}->Get('BBS');
$this->{'SYS'}->Set('BBS', $bbs);
$this->{'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->{'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, -1);
foreach my $auth (@authors) {
if ($auth eq $author) {
return 1;
}
}
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# 所属掲示板リスト取得
# -------------------------------------------------------------------------------------
# @param $id ユーザID
# @param $oBBS NAZGULオブジェクト
# @param $pBBS 結果格納用配列の参照
# @return 所属掲示板数
#
#------------------------------------------------------------------------------------------------------------
sub GetBelongBBSList
{
my $this = shift;
my ($id, $oBBS, $pBBS) = @_;
my $n = 0;
# システム管理ユーザは全てのBBSに所属とする
if ($this->{'USER'}->Get('SYSAD', $id)) {
$oBBS->GetKeySet('ALL', '', $pBBS);
$n = scalar @$pBBS;
}
# 一般ユーザは所属グループから判断する
else {
my $origBBS = $this->{'BBS'};
my @keySet = ();
$oBBS->GetKeySet('ALL', '', \@keySet);
foreach my $bbsID (@keySet) {
my $bbsDir = $oBBS->Get('DIR', $bbsID);
SetGroupInfo($this, $bbsDir);
if ($this->{'GROUP'}->GetBelong($id) ne '') {
$n += push @$pBBS, $bbsID;
}
}
# 後処理
if (defined $origBBS) {
SetGroupInfo($this, $origBBS);
}
}
return $n;
}
#============================================================================================================
# Module END
#============================================================================================================
1;
zerochplus_dev-r364/test/module/faramir.pl 0000644 0000764 0001040 00000014601 12042721615 015746 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";
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_dev-r364/test/module/galadriel.pl 0000644 0000764 0001040 00000100301 12042721615 016242 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|$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;
}
#------------------------------------------------------------------------------------------------------------
#
# トリップ作成関数 - 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 : エージェント
# $bbs : BBSキー
# $key : スレッドキー
# $opt : オプション
# 戻り値：生成されたパス
#
#------------------------------------------------------------------------------------------------------------
sub CreatePath
{
my $this = shift;
my ($Sys, $mode, $bbs, $key, $opt) = @_;
my $path = $Sys->Get('SERVER') . $Sys->Get('CGIPATH') . ($mode ne 'O' ? '/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
# --------------------------------------
# 引 数：$oSet : SETTING.TXT
# $msect : msec on/off
# 戻り値：日付文字列
#
#------------------------------------------------------------------------------------------------------------
sub GetDate
{
my $this = shift;
my ($oSet, $msect) = @_;
$ENV{'TZ'} = 'JST-9';
my @info = localtime time;
$info[5] += 1900;
$info[4] += 1;
# 曜日の取得
my $week = ('日', '月', '火', '水', '木', '金', '土')[$info[6]];
if (defined $oSet && ! $oSet->Equal('BBS_YMD_WEEKS', '')) {
$week = (split(/\//, $oSet->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) {
use 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 $agent エージェント
# @return ID部分文字列
# @see 優先順位：HOST > NOID > FORCE > PASS
#
#------------------------------------------------------------------------------------------------------------
sub GetIDPart
{
my $this = shift;
my ($Set, $Form, $Sec, $id, $capID, $koyuu, $agent) = @_;
my $mode = '';
# PC・携帯識別番号付加
if ($Set->Equal('BBS_SLIP', 'checked')) {
$mode = $agent;
$id .= $mode;
}
# ホスト表示
if ($Set->Equal('BBS_DISP_IP', 'checked')) {
# ID非表示権限有り
if ($Sec->IsAuthority($capID, 14, $Form->Get('bbs'))) {
return " ID:???$mode";
}
if ( $mode eq 'O' ) {
return " HOST:$koyuu $ENV{'REMOTE_HOST'}".( $mode ne '' ? " $mode" : '' );
}
elsif ( $mode eq 'P' ) {
return " HOST:$koyuu $ENV{'REMOTE_HOST'} ($ENV{'REMOTE_ADDR'})".( $mode ne '' ? " $mode" : '' );
}
else {
return " HOST:$koyuu".( $mode ne '' ? " $mode" : '' );
}
}
# IP表示 Ver.Siberia
if ($Set->Equal('BBS_DISP_IP', 'siberia')){
# ID非表示権限有り
if ($Sec->IsAuthority($capID, 14, $Form->Get('bbs'))) {
return " 発信元:???$mode";
}
if ( $mode eq 'P' ) {
return " 発信元:$ENV{'REMOTE_P2'}".( $mode ne '' ? " $mode" : '' );
}
else {
return " 発信元:$ENV{'REMOTE_ADDR'}".( $mode ne '' ? " $mode" : '' );
}
}
# IP表示 Ver.Sakhalin
if ($Set->Equal('BBS_DISP_IP', 'sakhalin')) {
# ID非表示権限有り
if ($Sec->IsAuthority($capID, 14, $Form->Get('bbs'))) {
return " 発信元:???".( $mode ne '' ? " $mode" : '' );
}
if ( $mode eq 'P' ) {
return " 発信元:$ENV{'HTTP_X_P2_CLIENT_IP'} ($koyuu)".( $mode ne '' ? " $mode" : '' );
}
elsif ( $mode eq 'O' ) {
return " 発信元:$ENV{'REMOTE_ADDR'} ($koyuu)".( $mode ne '' ? " $mode" : '' );
}
else {
return " 発信元:$ENV{'REMOTE_ADDR'}".( $mode ne '' ? " $mode" : '' );
}
}
# ID表示無しならそのままリターン
if ($Set->Equal('BBS_NO_ID', 'checked')) {
return ( $mode ne '' ? " $mode" : '' );
}
# ID非表示権限有り
if ($Sec->IsAuthority($capID, 14, $Form->Get('bbs'))) {
return " ID:???$mode";
}
# 強制IDの場合
if ($Set->Equal('BBS_FORCE_ID', 'checked')) {
return " ID:$id";
}
# 任意IDの場合
if (! $Form->IsInput(['mail'])) {
return " ID:$id";
}
return " ID:???$mode";
}
#------------------------------------------------------------------------------------------------------------
#
# 特殊文字変換 - 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
# $oForm :
# $from : 名前欄
# $mode : エージェント
# 戻り値：プロクシなら対象ポート番号
#
#------------------------------------------------------------------------------------------------------------
sub IsProxy
{
my $this = shift;
my ($Sys, $oForm, $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'));
push(@dnsbls, 'dnsbl.spam-champuru.livedoor.com') if($Sys->Get('SPAMCH'));
# DNSBL問い合わせ
my $addr = join('.', reverse( split(/\./, $ENV{'REMOTE_ADDR'})));
foreach my $dnsbl (@dnsbls) {
if (CheckDNSBL("$addr.$dnsbl") eq '127.0.0.2') {
$oForm->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
# --------------------------------------
# 引 数：$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_dev-r364/test/module/gandalf.pl 0000644 0000764 0001040 00000020776 12042721616 015734 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';
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_dev-r364/test/module/gondor.pl 0000644 0000764 0001040 00000030137 12042721616 015620 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 0777, $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];
}
#------------------------------------------------------------------------------------------------------------
#
# スレッド停止
# -------------------------------------------------------------------------------------
# @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;
}
#------------------------------------------------------------------------------------------------------------
#
# スレッド開始
# -------------------------------------------------------------------------------------
# @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) ne $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] % 01000 : 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;
}
#------------------------------------------------------------------------------------------------------------
#
# 停止検査
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @return boolean
#
#------------------------------------------------------------------------------------------------------------
sub IsStopped
{
my $this = shift;
my ($Sys) = @_;
return $this->{'PERM'} eq $Sys->Get('PM-STOP');
}
#============================================================================================================
# Module END
#============================================================================================================
1;
zerochplus_dev-r364/test/module/httpservice.pl 0000644 0000764 0001040 00000031260 12042721616 016666 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_dev-r364/test/module/melkor.pl 0000644 0000764 0001040 00000025174 12042721616 015626 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'};
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 0700, $this->{'SYS'}->{'SYSFILE'};
}
#------------------------------------------------------------------------------------------------------------
#
# システム設定値取得
# -------------------------------------------------------------------------------------
# @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 dev-r364 20121027', # CGIバージョン
'PM-DAT' => 0644, # datパーミション(*)
'PM-TXT' => 0644, # TXTパーミション(*)
'PM-LOG' => 0770, # LOGパーミション(*)
'PM-ADM' => 0770, # 管理ファイル群(*)
'PM-ADIR' => 0770, # 管理DIRパーミション(*)
'PM-BDIR' => 0755, # 板DIRパーミション(*)
'PM-LDIR' => 0770, # ログDIRパーミション(*)
'PM-STOP' => 0604, # スレストパーミション(*)
'ERRMAX' => 500, # エラーログ最大保持数
'SUBMAX' => 500, # subject最大保持数
'RESMAX' => 1000, # レス最大書き込み数
'ADMMAX' => 500, # 管理操作ログ最大保持数
'HISMAX' => 20, # 書き込み履歴最大保持数
'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' => '1002000420550000', # 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' => 1, # BBX(bbx.2ch.net)
'SPAMCH' => 1, # スパムちゃんぷるー
);
while (my ($key, $val) = each(%sys)) {
$pSys->{$key} = $val;
}
# 情報保持キー
my @key = qw(
SERVER CGIPATH INFO DATA BBSPATH
PM-DAT PM-TXT PM-LOG PM-ADM PM-ADIR PM-BDIR PM-LDIR PM-STOP
ERRMAX SUBMAX RESMAX ADMMAX HISMAX ANKERS URLLINK
LINKST LINKED PATHKIND HEADTEXT HEADURL FASTMODE
SAMBATM DEFSAMBA DEFHOUSHI
BANNER KAKIKO COUNTER PRTEXT PRLINK TRIP12 MSEC BBSGET
CONFVER
BBQ BBX SPAMCH UPCHECK
);
splice @$pKey, 0, scalar(@$pKey);
push @$pKey, @key;
}
#------------------------------------------------------------------------------------------------------------
#
# システム変数正規化 - NormalizeConf
# -------------------------------------------
# 引 数：
# 戻り値：なし
#
# 2011.02.12 色々
#
#------------------------------------------------------------------------------------------------------------
sub NormalizeConf
{
my $this = shift;
my ($path, $buf, $perm, $server, $cgipath);
$this->Set('CONFVER', $this->Get('VERSION'));
if ($this->Get('SERVER', '') eq '') {
my $path = $ENV{'SCRIPT_NAME'};
$path =~ s|/[^/]+\.cgi([\/\?].*)?$||;
$this->Set('SERVER', 'http://' . $ENV{'HTTP_HOST'});
$this->Set('CGIPATH', $path);
}
{
my $buf = (int rand 900000) + 100000;
$buf++ while (-e "$buf.dat");
open(my $fh, '>', "$buf.dat");
close($fh);
my $perm = $this->Get('PM-STOP', 0604);
chmod $perm, "$buf.dat";
if (((stat "$buf.dat")[2] & 0777) != $perm) {
$this->Set('PM-STOP', 0444);
}
unlink "$buf.dat";
}
{
my $server = $this->Get('SERVER', '');
my $cgipath = $this->Get('CGIPATH', '');
$server =~ s|/+$||;
if ($server =~ m|^(http://[^/]+)(/.+)$|) {
$server = $1;
$cgipath = $2 . $cgipath;
}
$this->Set('SERVER', $server);
$this->Set('CGIPATH', $cgipath);
}
}
#============================================================================================================
# Module END
#============================================================================================================
1;
zerochplus_dev-r364/test/module/nazguls.pl 0000644 0000764 0001040 00000035600 12042721616 016013 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';
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';
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_dev-r364/test/module/newrelease.pl 0000644 0000764 0001040 00000012777 12042721616 016474 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_dev-r364/test/module/orald.pl 0000644 0000764 0001040 00000013056 12042721616 015432 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};
# エラーメッセージの置換
$message =~ s/\\n/\n/g;
$message =~ s/{!(.*?)!}/$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);
if ($mode eq 'O') {
my $subject = $this->{'SUBJECT'}->{$err};
$Page->Print("Content-type: text/html\n\n
");
$Page->Print("$message
こちら");
$Page->Print("から戻ってください");
}
else {
my $Cookie = $CGI->{'COOKIE'};
my $Set = $CGI->{'SET'};
my $name = $Form->Get('NAME');
my $mail = $Form->Get('MAIL');
my $msg = $Form->Get('MESSAGE');
# cookie情報の出力
if ($Set->Equal('BBS_NAMECOOKIE_CHECK', 'checked')) {
$Cookie->Set('NAME', $name);
}
if ($Set->Equal('BBS_MAILCOOKIE_CHECK', 'checked')) {
$Cookie->Set('MAIL', $mail);
}
$Cookie->Out($Page, $Set->Get('BBS_COOKIEPATH'), 60 * 24 * 30);
$Page->Print("Content-type: text/html\n\n");
if ($err < 505 || $err > 508) {
$Page->Print(<
ＥＲＲＯＲ：$message
ホスト$koyuu
名前： $name
E-mail： $mail
内容：
$msg
こちらでリロードしてください。 GO!
$version
HTML
}
else {
my $sambaerr = {
'505' => '593',
'506' => '599',
'507' => '594',
'508' => '594',
}->{$err};
$Page->Print(<
ＥＲＲＯＲ - $sambaerr $message
(Samba24-2.13互換)
$version
HTML
}
}
}
#============================================================================================================
# モジュール終端
#============================================================================================================
1;
zerochplus_dev-r364/test/module/peregrin.pl 0000644 0000764 0001040 00000027512 12042721616 016146 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('HISMAX');
$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 0666, $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 == 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];
$key = $1 if ($key =~ /\((.*)\)/);
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_dev-r364/test/module/radagast.pl 0000644 0000764 0001040 00000013314 12042721616 016114 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;
Encode::from_to($value, 'utf8', 'sjis');
$this->{'COOKIE'}->{$name} = $value;
}
return 1;
}
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# cookie値設定
# -------------------------------------------------------------------------------------
# @param $key キー
# @param $value 設定値
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Set
{
my $this = shift;
my ($key, $value) = @_;
$this->{'COOKIE'}->{$key} = $value;
}
#------------------------------------------------------------------------------------------------------------
#
# cookie値取得
# -------------------------------------------------------------------------------------
# @param $key キー
# $default : デフォルト
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Get
{
my $this = shift;
my ($key, $default) = @_;
my $val = $this->{'COOKIE'}->{$key};
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 $oOut 出力モジュール
# @param $path cookieパス
# @param $limit 有効期限
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Out
{
my $this = shift;
my ($oOut, $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};
Encode::from_to($value, 'sjis', 'utf8');
$value =~ s/([^\w])/'%'.unpack('H2', $1)/eg;
$oOut->Print("Set-Cookie: $key=\"$value\"; expires=$date; path=$path\n");
}
}
#------------------------------------------------------------------------------------------------------------
#
# cookie取得用javascript出力
# -------------------------------------------------------------------------------------
# @param $oOut 出力モジュール
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub Print
{
my $this = shift;
my ($oOut) = @_;
$oOut->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_dev-r364/test/module/session.pl 0000644 0000764 0001040 00000016645 12042721616 016023 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_dev-r364/test/module/thorin.pl 0000644 0000764 0001040 00000006733 12042721616 015640 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) {
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_dev-r364/test/module/ungoliants.pl 0000644 0000764 0001040 00000051045 12042721616 016514 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,
};
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') . '/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) {
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') . '/caps.cgi';
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'}->{$_}
);
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 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';
}
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 eq $author);
}
return 0;
}
#============================================================================================================
# Module END
#============================================================================================================
1;
zerochplus_dev-r364/test/module/vara.pl 0000644 0000764 0001040 00000057210 12042721616 015262 0 ustar #============================================================================================================
#
# 掲示板書き込み支援モジュール
#
#============================================================================================================
package VARA;
use strict;
#use warnings;
no warnings qw(once);
#------------------------------------------------------------------------------------------------------------
#
# コンストラクタ
# -------------------------------------------------------------------------------------
# @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, $Thread, $Conv) = @_;
$this->{'SYS'} = $Sys;
$this->{'FORM'} = $Form;
$this->{'SET'} = $Set;
$this->{'THREADS'} = $Thread;
$this->{'CONV'} = $Conv;
# モジュールが用意されてない場合はここで生成する
if (!defined $Set) {
require './module/isildur.pl';
$this->{'SET'} = ISILDUR->new;
$this->{'SET'}->Load($Sys);
}
if (!defined $Thread) {
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 = 0;
# 入力内容チェック(名前、メール)
return $err if ($err = $this->NormalizationNameMail());
# 入力内容チェック(本文)
return $err if ($err = $this->NormalizationContents());
# 規制チェック
return $err if ($err = $this->IsRegulation());
# データの書き込み
require './module/gondor.pl';
my $oSys = $this->{'SYS'};
my $oSet = $this->{'SET'};
my $oForm = $this->{'FORM'};
my $oConv = $this->{'CONV'};
my $oThread = $this->{'THREADS'};
# 書き込み直前処理
$err = $this->ReadyBeforeWrite(ARAGORN::GetNumFromFile($oSys->Get('DATPATH')) + 1);
return $err if ($err);
# レス要素の取得
my @elem = ();
$oForm->GetListData(\@elem, 'subject', 'FROM', 'mail', 'MESSAGE');
$err = 0;
my $id = $oConv->MakeID($oSys->Get('SERVER'), $oSys->Get('CLIENT'), $oSys->Get('KOYUU'), $oSys->Get('BBS'), 8);
my $date = $oConv->GetDate($oSet, $oSys->Get('MSEC'));
$date .= $oConv->GetIDPart($oSet, $oForm, $this->{'SECURITY'}, $id, $oSys->Get('CAPID'), $oSys->Get('KOYUU'), $oSys->Get('AGENT'));
# プラグイン「 BE(HS)っぽいもの 」ver.0.x.x
my $beid = $oForm->Get('BEID', '');
$date .= " $beid" if ($beid ne '');
my $data = join('<>', $elem[1], $elem[2], $date, $elem[3], $elem[0]);
my $data2 = "$data\n";
my $datPath = $oSys->Get('DATPATH');
# ログ書き込み
require './module/peregrin.pl';
my $LOG = PEREGRIN->new;
$LOG->Load($oSys, 'WRT', $oSys->Get('KEY'));
$LOG->Set($oSet, length($oForm->Get('MESSAGE')), $oSys->Get('VERSION'), $oSys->Get('KOYUU'), $data, $oSys->Get('AGENT', 0));
$LOG->Save($oSys);
# リモートホスト保存(SETTING.TXT変更により、常に保存)
SaveHost($oSys, $oForm);
# datファイルへ直接書き込み
my $resNum = 0;
$err = ARAGORN::DirectAppend($oSys, $datPath, $data2);
if ($err == 0) {
# レス数が最大数を超えたらover設定をする
$resNum = ARAGORN::GetNumFromFile($datPath);
if ($resNum >= $oSys->Get('RESMAX')) {
# datにOVERスレッドレスを書き込む
Get1001Data($oSys, \$data2);
ARAGORN::DirectAppend($oSys, $datPath, $data2);
$resNum++;
}
# 履歴保存
SaveHistory($oSys, $oForm, ARAGORN::GetNumFromFile($datPath));
}
# datファイル追記失敗
else {
$err = 999 if ($err == 1);
$err = 200 if ($err == 2);
}
if ($err == 0) {
# subject.txtの更新
# スレッド作成モードなら新規に追加する
if ($oSys->Equal('MODE', 1)) {
require './module/earendil.pl';
my $path = $oSys->Get('BBSPATH') . '/' . $oSys->Get('BBS');
my $oPools = FRODO->new;
$oPools->Load($oSys);
$oThread->Add($oSys->Get('KEY'), $elem[0], 1);
while ($oThread->GetNum() > $oSys->Get('SUBMAX')) {
my $lid = $oThread->GetLastID();
$oPools->Add($lid, $oThread->Get('SUBJECT', $lid), $oThread->Get('RES', $lid));
$oThread->Delete($lid);
EARENDIL::Copy("$path/dat/$lid.dat", "$path/pool/$lid.cgi");
unlink "$path/dat/$lid.dat";
}
$oPools->Save($oSys);
$oThread->Save($oSys);
}
# 書き込みモードならレス数の更新
else {
my $sage = (!$oForm->Contain('mail', 'sage') ? 1 : 0);
$oThread->OnDemand($oSys, $oSys->Get('KEY'), $resNum, $sage);
}
}
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 $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ワードチェック
{
# 規制ユーザ
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 601;
}
elsif ($check == 2) {
return 601 if ($from !~ /$host/i); # $hostは正規表現
$Form->Set('FROM', "
/
/g;
$Form->Set('MESSAGE', " $text ");
# 名無し設定
$from = $Form->Get('FROM');
if (!$from) {
$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 $oSYS = $this->{'SYS'};
my $oSET = $this->{'SET'};
my $oSEC = $this->{'SECURITY'};
my $bbs = $this->{'FORM'}->Get('bbs');
my $from = $this->{'FORM'}->Get('FROM');
my $capID = $oSYS->Get('CAPID', '');
my $datPath = $oSYS->Get('DATPATH');
my $client = $oSYS->Get('CLIENT');
my $mode = $oSYS->Get('AGENT');
my $koyuu = $oSYS->Get('KOYUU');
my $host = $ENV{'REMOTE_HOST'};
my $addr = $ENV{'REMOTE_ADDR'};
my $islocalip = 0;
$islocalip = 1 if ($addr =~ /^(127|172|192|10)\./);
# レス書き込みモード時のみ
if ($oSYS->Equal('MODE', 2)) {
require './module/gondor.pl';
# 移転スレッド
return 202 if (ARAGORN::IsMoved($datPath));
# レス最大数
return 201 if ($oSYS->Get('RESMAX') < ARAGORN::GetNumFromFile($datPath));
# datファイルサイズ制限
if ($oSET->Get('BBS_DATMAX')) {
my $datSize = int((stat $datPath)[7] / 1024);
if ($oSET->Get('BBS_DATMAX') < $datSize) {
return 206;
}
}
}
# REFERERチェック
if ($oSET->Equal('BBS_REFERER_CHECK', 'checked')) {
if ($this->{'CONV'}->IsReferer($this->{'SYS'}, \%ENV)) {
return 998;
}
}
# PROXYチェック
if (!$islocalip && !$oSET->Equal('BBS_PROXY_CHECK', 'checked')) {
if ($this->{'CONV'}->IsProxy($this->{'SYS'}, $this->{'FORM'}, $from, $mode)) {
#$this->{'FORM'}->Set('FROM', " [―\{}\@{}\@{}-] $from");
if (!$oSEC->IsAuthority($capID, 19, $bbs)) {
return 997;
}
}
}
# 読取専用
if (!$oSET->Equal('BBS_READONLY', 'none')) {
if (!$oSEC->IsAuthority($capID, 13, $bbs)) {
return 203;
}
}
# JPホスト以外規制
if (!$islocalip && $oSET->Equal('BBS_JP_CHECK', 'checked')) {
if ($host !~ /\.jp$/i) {
return 207;
}
}
# スレッド作成モード
if ($oSYS->Equal('MODE', 1)) {
# スレッドキーが重複しないようにする
my $tPath = $oSYS->Get('BBSPATH') . '/' . $oSYS->Get('BBS') . '/dat/';
my $key = $oSYS->Get('KEY');
$key++ while (-e "$tPath$key.dat");
$oSYS->Set('KEY', $key);
$datPath = "$tPath$key.dat";
# スレッド作成(携帯から)
if ($client & $ZP::C_MOBILE) {
if (!$oSEC->IsAuthority($capID, 16, $bbs)) {
return 204;
}
}
# スレッド作成(キャップのみ)
if ($oSET->Equal('BBS_THREADCAPONLY', 'checked')) {
if (!$oSEC->IsAuthority($capID, 9, $bbs)) {
return 504;
}
}
# スレッド作成(スレッド立てすぎ)
require './module/peregrin.pl';
my $LOG = PEREGRIN->new;
$LOG->Load($oSYS, 'THR');
if (!$oSEC->IsAuthority($capID, 8, $bbs)) {
my $tateHour = $oSET->Get('BBS_TATESUGI_HOUR', '0') - 0;
my $tateCount = $oSET->Get('BBS_TATESUGI_COUNT', '0') - 0;
my $checkCount = $oSET->Get('BBS_THREAD_TATESUGI', '0') - 0;
if ($tateHour ne 0 && $LOG->IsTatesugi($tateHour) ge $tateCount) {
return 500;
}
if ($LOG->Search($koyuu, 3, $mode, $host, $checkCount)) {
return 500;
}
}
$LOG->Set($oSET, $oSYS->Get('KEY'), $oSYS->Get('VERSION'), $koyuu, undef, $mode);
$LOG->Save($oSYS);
# Sambaログ
if (!$oSEC->IsAuthority($capID, 18, $bbs) || !$oSEC->IsAuthority($capID, 12, $bbs)) {
my $LOGs = PEREGRIN->new;
$LOGs->Load($oSYS, 'SMB');
$LOGs->Set($oSET, $oSYS->Get('KEY'), $oSYS->Get('VERSION'), $koyuu);
$LOGs->Save($oSYS);
}
}
# レス書き込みモード
else {
require './module/peregrin.pl';
if (!$oSEC->IsAuthority($capID, 18, $bbs) || !$oSEC->IsAuthority($capID, 12, $bbs)) {
my $LOGs = PEREGRIN->new;
$LOGs->Load($oSYS, 'SMB');
my $LOGh = PEREGRIN->new;
$LOGh->Load($oSYS, 'SBH');
my $n = 0;
my $tm = 0;
my $Samba = int($oSET->Get('BBS_SAMBATIME', '') eq '' ? $oSYS->Get('DEFSAMBA') : $oSET->Get('BBS_SAMBATIME'));
my $Houshi = int($oSET->Get('BBS_HOUSHITIME', '') eq '' ? $oSYS->Get('DEFHOUSHI') : $oSET->Get('BBS_HOUSHITIME'));
my $Holdtm = int($oSYS->Get('SAMBATM'));
# Samba
if ($Samba && !$oSEC->IsAuthority($capID, 18, $bbs)) {
if ($Houshi) {
my ($ishoushi, $htm) = $LOGh->IsHoushi($Houshi, $koyuu);
if ($ishoushi) {
$oSYS->Set('WAIT', $htm);
return 507;
}
}
($n, $tm) = $LOGs->IsSamba($Samba, $koyuu);
}
# 短時間投稿 (Samba優先)
if (!$n && $Holdtm && !$oSEC->IsAuthority($capID, 12, $bbs)) {
$tm = $LOGs->IsTime($Holdtm, $koyuu);
}
$LOGs->Set($oSET, $oSYS->Get('KEY'), $oSYS->Get('VERSION'), $koyuu);
$LOGs->Save($oSYS);
if ($n >= 6 && $Houshi) {
$LOGh->Set($oSET, $oSYS->Get('KEY'), $oSYS->Get('VERSION'), $koyuu);
$LOGh->Save($oSYS);
$oSYS->Set('WAIT', $Houshi);
return 507;
}
elsif ($n) {
$oSYS->Set('SAMBATIME', $Samba);
$oSYS->Set('WAIT', $tm);
$oSYS->Set('SAMBA', $n);
return ($n > 3 && $Houshi ? 506 : 505);
}
elsif ($tm > 0) {
$oSYS->Set('WAIT', $tm);
return 503;
}
}
# レス書き込み(連続投稿)
if (!$oSEC->IsAuthority($capID, 10, $bbs)) {
if ($oSET->Get('timeclose') && $oSET->Get('timecount') ne '') {
my $LOG = PEREGRIN->new;
$LOG->Load($oSYS, 'HST');
my $cnt = $LOG->Search($koyuu, 2, $mode, $host, $oSET->Get('timecount'));
if ($cnt >= $oSET->Get('timeclose')) {
return 501;
}
}
}
# レス書き込み(二重投稿)
if (!$oSEC->IsAuthority($capID, 11, $bbs)) {
if ($this->{'SYS'}->Get('KAKIKO') eq 1) {
my $LOG = PEREGRIN->new;
$LOG->Load($oSYS, 'WRT', $oSYS->Get('KEY'));
if ($LOG->Search($koyuu, 1) - 2 == length($this->{'FORM'}->Get('MESSAGE'))) {
return 502;
}
}
}
#$LOG->Set($oSET, length($this->{'FORM'}->Get('MESSAGE')), $oSYS->Get('VERSION'), $koyuu, $datas, $mode);
#$LOG->Save($oSYS);
}
# パスを保存
$oSYS->Set('DATPATH', $datPath);
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# 名前・メール欄の正規化
# -------------------------------------------------------------------------------------
# @param なし
# @return 規制通過なら0を返す
# 規制チェックにかかったらエラーコードを返す
#
#------------------------------------------------------------------------------------------------------------
sub NormalizationNameMail
{
my $this = shift;
my $Sys = $this->{'SYS'};
my $Form = $this->{'FORM'};
my $oSEC = $this->{'SECURITY'};
my $oSET = $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 && $oSEC->IsAuthority($capID, 17, $bbs)) {
$capName = $oSEC->Get($capID, 'NAME', 1, '');
$capColor = $oSEC->Get($oSEC->{'GROUP'}->GetBelong($capID), 'COLOR', 0, '');
$capColor = $oSET->Get('BBS_CAP_COLOR', '') if ($capColor eq '');
}
# ＃ -> #
$this->{'CONV'}->ConvertCharacter0(\$name);
# トリップ変換
my $trip = '';
if ($name =~ /\#(.*)$/x) {
$trip = $this->{'CONV'}->ConvertTrip(\$1, $oSET->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 150 if ($subject eq '');
# サブジェクト欄の文字数確認
if (!$oSEC->IsAuthority($capID, 1, $bbs)) {
if ($oSET->Get('BBS_SUBJECT_COUNT') < length($subject)) {
return 101;
}
}
}
# 名前欄の文字数確認
if (!$oSEC->IsAuthority($capID, 2, $bbs)) {
if ($oSET->Get('BBS_NAME_COUNT') < length($name)) {
return 101;
}
}
# メール欄の文字数確認
if (!$oSEC->IsAuthority($capID, 3, $bbs)) {
if ($oSET->Get('BBS_MAIL_COUNT') < length($mail)) {
return 102;
}
}
# 名前欄の入力確認
if (!$oSEC->IsAuthority($capID, 7, $bbs)) {
if ($oSET->Equal('NANASHI_CHECK', 'checked') && $name eq '') {
return 152;
}
}
# 正規化した内容を再度設定
$Form->Set('FROM', $name);
$Form->Set('mail', $mail);
$Form->Set('subject', $subject);
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# テキスト欄の正規化
# -------------------------------------------------------------------------------------
# @param なし
# @return 規制通過なら0を返す
# 規制チェックにかかったらエラーコードを返す
#
#------------------------------------------------------------------------------------------------------------
sub NormalizationContents
{
my $this = shift;
my $Form = $this->{'FORM'};
my $oSEC = $this->{'SECURITY'};
my $oSET = $this->{'SET'};
my $oSYS = $this->{'SYS'};
my $oConv = $this->{'CONV'};
my $bbs = $Form->Get('bbs');
my $text = $Form->Get('MESSAGE');
my $host = $Form->Get('HOST');
my $capID = $this->{'SYS'}->Get('CAPID', '');
# 禁則文字変換
$oConv->ConvertCharacter2(\$text, 2);
my ($ln, $cl) = $oConv->GetTextInfo(\$text);
# 本文が無い
return 151 if ($text eq '');
# 本文が長すぎ
if (!$oSEC->IsAuthority($capID, 4, $bbs)) {
if ($oSET->Get('BBS_MESSAGE_COUNT') < length($text)) {
return 103;
}
}
# 改行が多すぎ
if (!$oSEC->IsAuthority($capID, 5, $bbs)) {
if (($oSET->Get('BBS_LINE_NUMBER') * 2) < $ln) {
return 105;
}
}
# 1行が長すぎ
if (!$oSEC->IsAuthority($capID, 6, $bbs)) {
if ($oSET->Get('BBS_COLUMN_NUMBER') < $cl) {
return 104;
}
}
# アンカーが多すぎ
if ($oSYS->Get('ANKERS')) {
if ($oConv->IsAnker(\$text, $oSYS->Get('ANKERS'))) {
return 106;
}
}
# 本文ホスト表示
if (!$oSEC->IsAuthority($capID, 15, $bbs)) {
if ($oSET->Equal('BBS_RAWIP_CHECK', 'checked') && $oSYS->Equal('MODE', 1)) {
$text .= '
';
$text .= "$ENV{'REMOTE_ADDR'} , $host ,
";
}
}
$Form->Set('MESSAGE', $text);
return 0;
}
#------------------------------------------------------------------------------------------------------------
#
# 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", 500, 2 | 4) == 0) {
$Logger->Put($host, $Sys->Get('KEY'), $Sys->Get('MODE'));
$Logger->Write();
}
}
#------------------------------------------------------------------------------------------------------------
#
# 履歴ログを出力する
# -------------------------------------------------------------------------------------
# @param $Sys MELKOR
# @param $Form SAMWISE
# @param $resNum 書き込みレス番
#
#------------------------------------------------------------------------------------------------------------
sub SaveHistory
{
my ($Sys, $Form, $resNum) = @_;
my $bbs = $Sys->Get('BBSPATH') . '/' . $Sys->Get('BBS');
my $threadInfo = $Sys->Get('BBS') . ',' . $Sys->Get('KEY');
my $name = $Form->Get('FROM');
my $content = $Form->Get('MESSAGE');
require './module/imrahil.pl';
my $Logger = IMRAHIL->new;
if ($Logger->Open("$bbs/info/history", $Sys->Get('HISMAX'), 2 | 4) == 0) {
$Logger->Put($threadInfo, $resNum, $content, $name);
$Logger->Write();
}
}
#============================================================================================================
# Module END
#============================================================================================================
1;
zerochplus_dev-r364/test/module/varda.pl 0000644 0000764 0001040 00000052532 12042721616 015430 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 $bbsSetting = $this->{'SET'};
my $oConv = $this->{'CONV'};
my $bbs = $Sys->Get('BBS');
# HTMLヘッダの出力
my $title = $bbsSetting->Get('BBS_TITLE');
my $code = $this->{'CODE'};
$Page->Print("
');
# 全スレッドを取得
my @threadSet = ();
$Threads->GetKeySet('ALL', '', \@threadSet);
# スレッド分だけループをまわす
my $menuNum = $bbsSetting->Get('BBS_MAX_MENU_THREAD');
my $i = 0;
foreach my $key (@threadSet) {
last if (++$i > $menuNum);
my $name = $Threads->Get('SUBJECT', $key);
my $res = $Threads->Get('RES', $key);
my $path = $oConv->CreatePath($Sys, 1, $bbs, $key, 'l10');
$Page->Print("$i: $name($res)
\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 $bbsSetting = $this->{'SET'};
my $oConv = $this->{'CONV'};
require './module/legolas.pl';
my $Caption = LEGOLAS->new;
$Caption->Load($Sys, 'META');
# HTMLヘッダの出力
my $title = $bbsSetting->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 = $oConv->CreatePath($Sys, 0, $bbs, $key, 'l50');
$Page->Print("$i: $name($res) \n");
}
# フッタ部分の出力
my $cgipath = $Sys->Get('CGIPATH');
my $version = $Sys->Get('VERSION');
$Page->Print(<
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(<
$version
");
# 看板画像表示あり
if ($image ne '') {
# 看板画像からのリンクあり
if ($link ne '') {
$Page->Print("\n");
}
# 看板画像にリンクはなし
else {
$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);
$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 $oDat = 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 $oConv = $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";
$oDat->Load($this->{'SYS'}, $datPath, 1);
$this->{'SYS'}->Set('KEY', $key);
PrintThreadPreviewOne($this, $Page, $oDat, \@commands);
$oDat->Close();
# フッタ部分の表示
my $allPath = $oConv->CreatePath($this->{'SYS'}, 0, $this->{'SYS'}->Get('BBS'), $key, '');
my $lastPath = $oConv->CreatePath($this->{'SYS'}, 0, $this->{'SYS'}->Get('BBS'), $key, 'l50');
my $numPath = $oConv->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：
内容：
ぜろちゃんねる プラス
BBS.CGI - $ver (Perl)
@{[ $Sys->Get('BBQ') ? '+BBQ' : '' ]}
@{[ $Sys->Get('BBX') ? '+BBX' : '' ]}
@{[ $Sys->Get('SPAMCH') ? '+スパムちゃんぷるー' : '' ]}
+Samba24=$samba
ページのおしまいだよ。。と
FOOT
$Page->Print("\n\n");
}
#------------------------------------------------------------------------------------------------------------
#
# index.html生成(スレッドプレビュー部分)
# -------------------------------------------------------------------------------------
# @param $Page
# @param $oDat
# @param $commands
# @return なし
#
#------------------------------------------------------------------------------------------------------------
sub PrintThreadPreviewOne
{
my $this = shift;
my ($Page, $oDat, $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, $oDat, 1, $contNum, $contNum);
$start++ if ($start == 1);
# 1の表示
PrintResponse($this, $Page, $oDat, $commands, 1);
# 残りの表示
for (my $i = $start; $i <= $end; $i++) {
PrintResponse($this, $Page, $oDat, $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_dev-r364/test/mordor/sys.bbs.pl 0000644 0000764 0001040 00000077274 12042721617 015746 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'}, 0, '*')) {
$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'}, 0, '*');
# 掲示板情報を取得
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')\"> ");
$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 = $SEC->IsLogin($Form->Get('UserName'), $Form->Get('PassWord'));
if (($SEC->IsAuthority($chkID, 1, '*')) == 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");
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);
my $createPath2 = $Sys->Get('CGIPATH') . "/$createPath";
{
my @pathparse = split /\//, $createPath2;
for (my $i = 0 ; $i <= $#pathparse ; $i++) {
if ($pathparse[$i] eq '.') {
splice @pathparse, $i, 1;
redo if ($i <= $#pathparse);
}
if ($pathparse[$i] eq '..' && $i > 0 && $pathparse[$i - 1] ne '..') {
splice @pathparse, $i - 1, 2;
redo if ($i <= $#pathparse);
}
}
$createPath2 = join '/', @pathparse;
}
$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->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')\">
以下の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 = $SEC->IsLogin($Form->Get('UserName'), $Form->Get('PassWord'));
if (($SEC->IsAuthority($chkID, 1, '*')) == 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 = $SEC->IsLogin($Form->Get('UserName'), $Form->Get('PassWord'));
if (($SEC->IsAuthority($chkID, 1, '*')) == 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 = $SEC->IsLogin($Form->Get('UserName'), $Form->Get('PassWord'));
if (($SEC->IsAuthority($chkID, 1, '*')) == 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 = $SEC->IsLogin($Form->Get('UserName'), $Form->Get('PassWord'));
if (($SEC->IsAuthority($chkID, 1, '*')) == 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 = $SEC->IsLogin($Form->Get('UserName'), $Form->Get('PassWord'));
if (($SEC->IsAuthority($chkID, 1, '*')) == 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_dev-r364/test/mordor/sys.cap.pl 0000644 0000764 0001040 00000037217 12042721617 015734 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'}, 0, '*')) {
$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);
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);
$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' : '';
}
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("Explanation \n");
# 権限取得
$isAuth = $Sys->Get('ADMIN')->{'SECINFO'}->IsAuthority($Sys->Get('ADMIN')->{'USER'}, 0, '*');
# キャップ一覧を出力
for ($i = $dispSt ; $i < $dispEd ; $i++) {
$id = $userSet[$i];
$name = $Cap->Get('NAME', $id);
$full = $Cap->Get('FULL', $id);
$expl = $Cap->Get('EXPL', $id);
$common = "\"javascript:SetOption('SELECT_CAP','$id');";
$common .= "DoSubmit('sys.cap','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 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(" ");
$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);
# 権限チェック
{
my $SEC = $Sys->Get('ADMIN')->{'SECINFO'};
my $chkID = $SEC->IsLogin($Form->Get('UserName'), $Form->Get('PassWord'));
if (($SEC->IsAuthority($chkID, 0, '*')) == 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');
$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);
}
else { # 登録モード
$Cap->Add($name, $pass, $full, $expl, $sysad);
$chg = 1;
}
# 設定情報を保存
$Cap->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 FuncCapDelete
{
my ($Sys, $Form, $pLog) = @_;
my ($Cap, @userSet);
# 権限チェック
{
my $SEC = $Sys->Get('ADMIN')->{'SECINFO'};
my $chkID = $SEC->IsLogin($Form->Get('UserName'), $Form->Get('PassWord'));
if (($SEC->IsAuthority($chkID, 0, '*')) == 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_dev-r364/test/mordor/sys.capg.pl 0000644 0000764 0001040 00000046052 12042721617 016100 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'}, 0, '*')) {
$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')\"> ");
$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 < 19 ; $i++) {
$authNum[$i] = '';
}
foreach $num (@auth) {
$authNum[$num - 1] = 'checked';
}
}
else {
$Form->Set('SELECT_CAPGROUP', '');
$name = '';
$expl = '';
$color = '';
for ($i = 0 ; $i < 19 ; $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("強制ホスト表\示規制解除
");
$Page->Print("携帯からのスレッド作成
");
$Page->Print("コテハン★表\示
");
$Page->Print("Samba規制解除
");
$Page->Print("プロキシ規制解除
");
$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 = $SEC->IsLogin($Form->Get('UserName'), $Form->Get('PassWord'));
if (($SEC->IsAuthority($chkID, 1, $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;
# 権限情報の生成
$auth = '';
$authNum[0] = $Form->Equal('C_SUBJECT', 'on') ? 1 : 0;
$authNum[1] = $Form->Equal('C_NAME', 'on') ? 1 : 0;
$authNum[2] = $Form->Equal('C_MAIL', 'on') ? 1 : 0;
$authNum[3] = $Form->Equal('C_CONTENTS', 'on') ? 1 : 0;
$authNum[4] = $Form->Equal('C_CONTLINE', 'on') ? 1 : 0;
$authNum[5] = $Form->Equal('C_LINECOUNT', 'on') ? 1 : 0;
$authNum[6] = $Form->Equal('C_NONAME', 'on') ? 1 : 0;
$authNum[7] = $Form->Equal('C_THREAD', 'on') ? 1 : 0;
$authNum[8] = $Form->Equal('C_THREADCAP', 'on') ? 1 : 0;
$authNum[9] = $Form->Equal('C_CONTINUAS', 'on') ? 1 : 0;
$authNum[10] = $Form->Equal('C_DUPLICATE', 'on') ? 1 : 0;
$authNum[11] = $Form->Equal('C_SHORTWRITE', 'on') ? 1 : 0;
$authNum[12] = $Form->Equal('C_READONLY', 'on') ? 1 : 0;
$authNum[13] = $Form->Equal('C_IDDISP', 'on') ? 1 : 0;
$authNum[14] = $Form->Equal('C_HOSTDISP', 'on') ? 1 : 0;
$authNum[15] = $Form->Equal('C_MOBILETHREAD', 'on') ? 1 : 0;
$authNum[16] = $Form->Equal('C_FIXHANLDLE', 'on') ? 1 : 0;
$authNum[17] = $Form->Equal('C_SAMBA', 'on') ? 1 : 0;
$authNum[18] = $Form->Equal('C_PROXY', 'on') ? 1 : 0;
for ($i = 1 ; $i < 20 ; $i++) {
if ($authNum[$i - 1]){
$auth .= "$i,";
}
}
$auth = substr($auth, 0, length($auth) - 1);
# 所属ユーザ情報の生成
@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 = $SEC->IsLogin($Form->Get('UserName'), $Form->Get('PassWord'));
if (($SEC->IsAuthority($chkID, 1, $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_dev-r364/test/mordor/sys.edit.pl 0000644 0000764 0001040 00000031176 12042721617 016114 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')\"> ");
$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(" ");
$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 = $SEC->IsLogin($Form->Get('UserName'), $Form->Get('PassWord'));
if (($SEC->IsAuthority($chkID, 0, '*')) == 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_dev-r364/test/mordor/sys.setting.pl 0000644 0000764 0001040 00000135232 12042721617 016642 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'}, 0, '*')) {
$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');
require Module::CoreList;
my $version = $];
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 $core = $Module::CoreList::version{$version};
my @checklist = (qw(
Encode
Time::HiRes
Time::Local
Socket
), qw(
Digest::SHA::PurePerl
Net::DNS::Lite
List::MoreUtils
LWP::UserAgent
XML::Simple
), qw(
Net::DNS
));
$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("■Perl Version Version $version 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) = @_;
my ($datP, $txtP, $logP, $admP, $stopP, $admDP, $bbsDP, $logDP);
my ($common);
$SYS->Set('_TITLE', 'System Permission Setting');
$datP = sprintf("%o", $SYS->Get('PM-DAT'));
$txtP = sprintf("%o", $SYS->Get('PM-TXT'));
$logP = sprintf("%o", $SYS->Get('PM-LOG'));
$admP = sprintf("%o", $SYS->Get('PM-ADM'));
$stopP = sprintf("%o", $SYS->Get('PM-STOP'));
$admDP = sprintf("%o", $SYS->Get('PM-ADIR'));
$bbsDP = sprintf("%o", $SYS->Get('PM-BDIR'));
$logDP = sprintf("%o", $SYS->Get('PM-LDIR'));
$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('HISMAX');
$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("
");
}
#------------------------------------------------------------------------------------------------------------
#
# その他設定画面の表示
# -------------------------------------------------------------------------------------
# @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) = @_;
my ($Banner, $Counter, $Prtext, $Prlink, $Msec);
my ($banner, $msec);
my ($common);
$SYS->Set('_TITLE', 'System View Setting');
$Banner = $SYS->Get('BANNER');
$Counter = $SYS->Get('COUNTER');
$Prtext = $SYS->Get('PRTEXT');
$Prlink = $SYS->Get('PRLINK');
$Msec = $SYS->Get('MSEC');
$banner = ($Banner == 1 ? 'checked' : '');
$msec = ($Msec == 1 ? 'checked' : '');
$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, $SpamCh);
my ($kakiko, $trip12, $bbq, $bbx, $spamch);
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');
$SpamCh = $SYS->Get('SPAMCH');
$kakiko = ($Kakiko == 1 ? 'checked' : '');
$trip12 = ($Trip12 == 1 ? 'checked' : '');
$bbq = ($BBQ == 1 ? 'checked' : '');
$bbx = ($BBX == 1 ? 'checked' : '');
$spamch = ($SpamCh == 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("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("スパムちゃんぷるー\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'}, 0, '*');
$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 ");
$Page->Print("Print("DoSubmit('sys.setting','DISP','PLUGINCONF');\">個別設定 ");
$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, $plugin, $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";
$plugin = new $className;
if ($className->can('getConfig')) {
$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 = $SEC->IsLogin($Form->Get('UserName'), $Form->Get('PassWord'));
if (($SEC->IsAuthority($chkID, 0, '*')) == 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 = $SEC->IsLogin($Form->Get('UserName'), $Form->Get('PassWord'));
if (($SEC->IsAuthority($chkID, 0, '*')) == 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 = $SEC->IsLogin($Form->Get('UserName'), $Form->Get('PassWord'));
if (($SEC->IsAuthority($chkID, 0, '*')) == 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->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');
}
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 = $SEC->IsLogin($Form->Get('UserName'), $Form->Get('PassWord'));
if (($SEC->IsAuthority($chkID, 0, '*')) == 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('HISMAX', $Form->Get('HISMAX'));
$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('HISMAX');
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 = $SEC->IsLogin($Form->Get('UserName'), $Form->Get('PassWord'));
if (($SEC->IsAuthority($chkID, 0, '*')) == 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 = $SEC->IsLogin($Form->Get('UserName'), $Form->Get('PassWord'));
if (($SEC->IsAuthority($chkID, 0, '*')) == 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'));
$SYSTEM->Set('BANNER', ($Form->Equal('BANNER', 'on') ? 1 : 0));
$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 = $SEC->IsLogin($Form->Get('UserName'), $Form->Get('PassWord'));
if (($SEC->IsAuthority($chkID, 0, '*')) == 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->Set('SPAMCH', ($Form->Equal('SPAMCH', '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');
push @$pLog, ' スパムちゃんぷるー：' . $SYSTEM->Get('SPAMCH');
}
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 = $SEC->IsLogin($Form->Get('UserName'), $Form->Get('PassWord'));
if (($SEC->IsAuthority($chkID, 0, '*')) == 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 = $SEC->IsLogin($Form->Get('UserName'), $Form->Get('PassWord'));
if (($SEC->IsAuthority($chkID, 0, '*')) == 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_dev-r364/test/mordor/sys.top.pl 0000644 0000764 0001040 00000043410 12042721617 015763 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'}, 0, '*')) {
$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'}, 0, '*');
# 表示数の設定
$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 = $SEC->IsLogin($Form->Get('UserName'), $Form->Get('PassWord'));
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 = $SEC->IsLogin($Form->Get('UserName'), $Form->Get('PassWord'));
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 '*') {
my $subj = $Notice->Get('SUBJECT', $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 = $SEC->IsLogin($Form->Get('UserName'), $Form->Get('PassWord'));
if (($SEC->IsAuthority($chkID, 0, '*')) == 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_dev-r364/test/mordor/sys.user.pl 0000644 0000764 0001040 00000040000 12042721617 016127 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'}, 0, '*')) {
$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'}, 0, '*');
# ユーザ一覧を出力
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 = $SEC->IsLogin($Form->Get('UserName'), $Form->Get('PassWord'));
if (($SEC->IsAuthority($chkID, 0, '*')) == 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 = $SEC->IsLogin($Form->Get('UserName'), $Form->Get('PassWord'));
if (($SEC->IsAuthority($chkID, 0, '*')) == 0) {
return 1000;
}
}
require './module/elves.pl';
$User = GLORFINDEL->new;
$Sec = ARWEN->new;
$User->Load($Sys);
$Sec->Init($Sys);
@userSet = $Form->GetAtArray('USERS');
$id = $Sec->IsLogin($Form->Get('UserName'), $Form->Get('PassWord'));
# 選択ユーザを全削除
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_dev-r364/test/mordor/thread.del.pl 0000644 0000764 0001040 00000035011 12042721617 016354 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 'REPARE') { # 削除レス復活
$err = FunctionResRepare($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')\">
', '');
$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 PrintResReapre
{
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'}, 12, $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 FunctionResRepare
{
my ($Sys, $Form, $Dat, $pLog) = @_;
my (@resSet, $pRes, $abone, $path, $tm, $user, $delCnt, $num);
# 権限チェック
{
my $SEC = $Sys->Get('ADMIN')->{'SECINFO'};
my $chkID = $Sys->Get('ADMIN')->{'USER'};
if (($SEC->IsAuthority($chkID, 12, $Sys->Get('BBS'))) == 0) {
return 1000;
}
}
# 各値を設定
@resSet = $Form->GetAtArray('RESS');
$path = $Sys->Get('BBSPATH') . '/' . $Sys->Get('BBS') . '/log/del_' . $Sys->Get('KEY') . '.cgi';
$tm = time;
$user = $Form->Get('UserName');
$delCnt = 0;
=pod
# 削除と同時に削除ログへ削除した内容を保存する
if (open(my $f_dellog, '>>', $path)) {
flock($f_dellog, 2);
foreach $num (@resSet){
$pRes = $Dat->Get($num - $delCnt);
print $f_dellog "$tm<>$user<>$num<>$$pRes";
if ($mode){
$Dat->Set($num, "$abone<>$abone<>$abone<>$abone<>$abone\n");
}
else {
$Dat->Delete($num - $delCnt);
$delCnt ++;
}
}
close($f_dellog);
# 保存
#$Dat->Save($Sys);
}
=cut
# ログの設定
$delCnt = 0;
$abone = '';
push @$pLog, '以下のレスを復活しました。';
foreach (@resSet) {
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_dev-r364/test/mordor/thread.res.pl 0000644 0000764 0001040 00000053626 12042721617 016415 0 ustar #============================================================================================================
#
# スレッド管理 - レス モジュール
# thread.res.pl
# ---------------------------------------------------------------------------
# 2004.07.21 start
#
#============================================================================================================
package MODULE;
#use CGI::Carp qw(fatalsToBrowser);
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'}, 12, $bbs)){
$Base->SetMenu('レス一括削除', "'thread.res','DISP','DELLUMP'");
}
# 管理グループ権限のみ
if ($pSys->{'SECINFO'}->IsAuthority($pSys->{'USER'}, 1, $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, $format);
my ($log, @logs, $lastnum, $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("
");
$Page->Print("
HOST:$logs[5]
IP:$logs[6]
UA:$logs[8]") if (defined $log);
$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'}, 13, $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'}, 12, $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'}, 12, $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, 13, $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, 12, $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);
# 削除と同時に削除ログへ削除した内容を保存する
if (open(my $f_dellog, '>>', $path)) {
flock($f_dellog, 2);
binmode($f_dellog);
foreach $num (@resSet) {
next if ($num == 0);
$pRes = $Dat->Get($num - $delCnt);
print $f_dellog "$tm<>$user<>$num<>$mode<>$$pRes";
if ($mode) {
$Dat->Set($num, "$abone<>$abone<>$abone<>$abone<>$abone\n");
}
else {
$Dat->Delete($num - $delCnt);
$LOG->Delete($logsize - 1 + ($num - $delCnt) - $lastnum);
$delCnt ++;
$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_dev-r364/test/perllib/Digest/SHA/PurePerl.pm 0000644 0000764 0001040 00000127746 12030156420 020072 0 ustar package Digest::SHA::PurePerl;
require 5.003000;
use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
use Fcntl;
use integer;
use FileHandle;
$VERSION = '5.72';
require Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = (); # see "SHA and HMAC-SHA functions" below
# If possible, inherit from Digest::base
eval {
require Digest::base;
push(@ISA, 'Digest::base');
};
*addfile = \&_Addfile;
*hexdigest = \&_Hexdigest;
*b64digest = \&_B64digest;
# ref. src/sha.c and sha/sha64bit.c from Digest::SHA
my $MAX32 = 0xffffffff;
my $TWO32 = 4294967296;
my $uses64bit = (((1 << 16) << 16) << 16) << 15;
my @H01 = ( # SHA-1 initial hash value
0x67452301, 0xefcdab89, 0x98badcfe, 0x10325476,
0xc3d2e1f0
);
my @H0224 = ( # SHA-224 initial hash value
0xc1059ed8, 0x367cd507, 0x3070dd17, 0xf70e5939,
0xffc00b31, 0x68581511, 0x64f98fa7, 0xbefa4fa4
);
my @H0256 = ( # SHA-256 initial hash value
0x6a09e667, 0xbb67ae85, 0x3c6ef372, 0xa54ff53a,
0x510e527f, 0x9b05688c, 0x1f83d9ab, 0x5be0cd19
);
my(@H0384, @H0512, @H0512224, @H0512256); # filled in later if $uses64bit
# Routines with a "_c_" prefix return Perl code-fragments which are
# eval'ed at initialization. This technique emulates the behavior
# of the C preprocessor, allowing the optimized transform code from
# Digest::SHA to be more easily translated into Perl.
sub _c_SL32 { # code to shift $x left by $n bits
my($x, $n) = @_;
"($x << $n)"; # even works for 64-bit integers
# since the upper 32 bits are
# eventually discarded in _digcpy
}
sub _c_SR32 { # code to shift $x right by $n bits
my($x, $n) = @_;
my $mask = (1 << (32 - $n)) - 1;
"(($x >> $n) & $mask)"; # "use integer" does arithmetic
# shift, so clear upper bits
}
sub _c_Ch { my($x, $y, $z) = @_; "($z ^ ($x & ($y ^ $z)))" }
sub _c_Pa { my($x, $y, $z) = @_; "($x ^ $y ^ $z)" }
sub _c_Ma { my($x, $y, $z) = @_; "(($x & $y) | ($z & ($x | $y)))" }
sub _c_ROTR { # code to rotate $x right by $n bits
my($x, $n) = @_;
"(" . _c_SR32($x, $n) . " | " . _c_SL32($x, 32 - $n) . ")";
}
sub _c_ROTL { # code to rotate $x left by $n bits
my($x, $n) = @_;
"(" . _c_SL32($x, $n) . " | " . _c_SR32($x, 32 - $n) . ")";
}
sub _c_SIGMA0 { # ref. NIST SHA standard
my($x) = @_;
"(" . _c_ROTR($x, 2) . " ^ " . _c_ROTR($x, 13) . " ^ " .
_c_ROTR($x, 22) . ")";
}
sub _c_SIGMA1 {
my($x) = @_;
"(" . _c_ROTR($x, 6) . " ^ " . _c_ROTR($x, 11) . " ^ " .
_c_ROTR($x, 25) . ")";
}
sub _c_sigma0 {
my($x) = @_;
"(" . _c_ROTR($x, 7) . " ^ " . _c_ROTR($x, 18) . " ^ " .
_c_SR32($x, 3) . ")";
}
sub _c_sigma1 {
my($x) = @_;
"(" . _c_ROTR($x, 17) . " ^ " . _c_ROTR($x, 19) . " ^ " .
_c_SR32($x, 10) . ")";
}
sub _c_M1Ch { # ref. Digest::SHA sha.c (sha1 routine)
my($a, $b, $c, $d, $e, $k, $w) = @_;
"$e += " . _c_ROTL($a, 5) . " + " . _c_Ch($b, $c, $d) .
" + $k + $w; $b = " . _c_ROTL($b, 30) . ";\n";
}
sub _c_M1Pa {
my($a, $b, $c, $d, $e, $k, $w) = @_;
"$e += " . _c_ROTL($a, 5) . " + " . _c_Pa($b, $c, $d) .
" + $k + $w; $b = " . _c_ROTL($b, 30) . ";\n";
}
sub _c_M1Ma {
my($a, $b, $c, $d, $e, $k, $w) = @_;
"$e += " . _c_ROTL($a, 5) . " + " . _c_Ma($b, $c, $d) .
" + $k + $w; $b = " . _c_ROTL($b, 30) . ";\n";
}
sub _c_M11Ch { my($k, $w) = @_; _c_M1Ch('$a', '$b', '$c', '$d', '$e', $k, $w) }
sub _c_M11Pa { my($k, $w) = @_; _c_M1Pa('$a', '$b', '$c', '$d', '$e', $k, $w) }
sub _c_M11Ma { my($k, $w) = @_; _c_M1Ma('$a', '$b', '$c', '$d', '$e', $k, $w) }
sub _c_M12Ch { my($k, $w) = @_; _c_M1Ch('$e', '$a', '$b', '$c', '$d', $k, $w) }
sub _c_M12Pa { my($k, $w) = @_; _c_M1Pa('$e', '$a', '$b', '$c', '$d', $k, $w) }
sub _c_M12Ma { my($k, $w) = @_; _c_M1Ma('$e', '$a', '$b', '$c', '$d', $k, $w) }
sub _c_M13Ch { my($k, $w) = @_; _c_M1Ch('$d', '$e', '$a', '$b', '$c', $k, $w) }
sub _c_M13Pa { my($k, $w) = @_; _c_M1Pa('$d', '$e', '$a', '$b', '$c', $k, $w) }
sub _c_M13Ma { my($k, $w) = @_; _c_M1Ma('$d', '$e', '$a', '$b', '$c', $k, $w) }
sub _c_M14Ch { my($k, $w) = @_; _c_M1Ch('$c', '$d', '$e', '$a', '$b', $k, $w) }
sub _c_M14Pa { my($k, $w) = @_; _c_M1Pa('$c', '$d', '$e', '$a', '$b', $k, $w) }
sub _c_M14Ma { my($k, $w) = @_; _c_M1Ma('$c', '$d', '$e', '$a', '$b', $k, $w) }
sub _c_M15Ch { my($k, $w) = @_; _c_M1Ch('$b', '$c', '$d', '$e', '$a', $k, $w) }
sub _c_M15Pa { my($k, $w) = @_; _c_M1Pa('$b', '$c', '$d', '$e', '$a', $k, $w) }
sub _c_M15Ma { my($k, $w) = @_; _c_M1Ma('$b', '$c', '$d', '$e', '$a', $k, $w) }
sub _c_W11 { my($s) = @_; '$W[' . (($s + 0) & 0xf) . ']' }
sub _c_W12 { my($s) = @_; '$W[' . (($s + 13) & 0xf) . ']' }
sub _c_W13 { my($s) = @_; '$W[' . (($s + 8) & 0xf) . ']' }
sub _c_W14 { my($s) = @_; '$W[' . (($s + 2) & 0xf) . ']' }
sub _c_A1 {
my($s) = @_;
my $tmp = _c_W11($s) . " ^ " . _c_W12($s) . " ^ " .
_c_W13($s) . " ^ " . _c_W14($s);
"((\$tmp = $tmp), (" . _c_W11($s) . " = " . _c_ROTL('$tmp', 1) . "))";
}
# The following code emulates the "sha1" routine from Digest::SHA sha.c
my $sha1_code = '
my($K1, $K2, $K3, $K4) = ( # SHA-1 constants
0x5a827999, 0x6ed9eba1, 0x8f1bbcdc, 0xca62c1d6
);
sub _sha1 {
my($self, $block) = @_;
my(@W, $a, $b, $c, $d, $e, $tmp);
@W = unpack("N16", $block);
($a, $b, $c, $d, $e) = @{$self->{H}};
' .
_c_M11Ch('$K1', '$W[ 0]' ) . _c_M12Ch('$K1', '$W[ 1]' ) .
_c_M13Ch('$K1', '$W[ 2]' ) . _c_M14Ch('$K1', '$W[ 3]' ) .
_c_M15Ch('$K1', '$W[ 4]' ) . _c_M11Ch('$K1', '$W[ 5]' ) .
_c_M12Ch('$K1', '$W[ 6]' ) . _c_M13Ch('$K1', '$W[ 7]' ) .
_c_M14Ch('$K1', '$W[ 8]' ) . _c_M15Ch('$K1', '$W[ 9]' ) .
_c_M11Ch('$K1', '$W[10]' ) . _c_M12Ch('$K1', '$W[11]' ) .
_c_M13Ch('$K1', '$W[12]' ) . _c_M14Ch('$K1', '$W[13]' ) .
_c_M15Ch('$K1', '$W[14]' ) . _c_M11Ch('$K1', '$W[15]' ) .
_c_M12Ch('$K1', _c_A1( 0) ) . _c_M13Ch('$K1', _c_A1( 1) ) .
_c_M14Ch('$K1', _c_A1( 2) ) . _c_M15Ch('$K1', _c_A1( 3) ) .
_c_M11Pa('$K2', _c_A1( 4) ) . _c_M12Pa('$K2', _c_A1( 5) ) .
_c_M13Pa('$K2', _c_A1( 6) ) . _c_M14Pa('$K2', _c_A1( 7) ) .
_c_M15Pa('$K2', _c_A1( 8) ) . _c_M11Pa('$K2', _c_A1( 9) ) .
_c_M12Pa('$K2', _c_A1(10) ) . _c_M13Pa('$K2', _c_A1(11) ) .
_c_M14Pa('$K2', _c_A1(12) ) . _c_M15Pa('$K2', _c_A1(13) ) .
_c_M11Pa('$K2', _c_A1(14) ) . _c_M12Pa('$K2', _c_A1(15) ) .
_c_M13Pa('$K2', _c_A1( 0) ) . _c_M14Pa('$K2', _c_A1( 1) ) .
_c_M15Pa('$K2', _c_A1( 2) ) . _c_M11Pa('$K2', _c_A1( 3) ) .
_c_M12Pa('$K2', _c_A1( 4) ) . _c_M13Pa('$K2', _c_A1( 5) ) .
_c_M14Pa('$K2', _c_A1( 6) ) . _c_M15Pa('$K2', _c_A1( 7) ) .
_c_M11Ma('$K3', _c_A1( 8) ) . _c_M12Ma('$K3', _c_A1( 9) ) .
_c_M13Ma('$K3', _c_A1(10) ) . _c_M14Ma('$K3', _c_A1(11) ) .
_c_M15Ma('$K3', _c_A1(12) ) . _c_M11Ma('$K3', _c_A1(13) ) .
_c_M12Ma('$K3', _c_A1(14) ) . _c_M13Ma('$K3', _c_A1(15) ) .
_c_M14Ma('$K3', _c_A1( 0) ) . _c_M15Ma('$K3', _c_A1( 1) ) .
_c_M11Ma('$K3', _c_A1( 2) ) . _c_M12Ma('$K3', _c_A1( 3) ) .
_c_M13Ma('$K3', _c_A1( 4) ) . _c_M14Ma('$K3', _c_A1( 5) ) .
_c_M15Ma('$K3', _c_A1( 6) ) . _c_M11Ma('$K3', _c_A1( 7) ) .
_c_M12Ma('$K3', _c_A1( 8) ) . _c_M13Ma('$K3', _c_A1( 9) ) .
_c_M14Ma('$K3', _c_A1(10) ) . _c_M15Ma('$K3', _c_A1(11) ) .
_c_M11Pa('$K4', _c_A1(12) ) . _c_M12Pa('$K4', _c_A1(13) ) .
_c_M13Pa('$K4', _c_A1(14) ) . _c_M14Pa('$K4', _c_A1(15) ) .
_c_M15Pa('$K4', _c_A1( 0) ) . _c_M11Pa('$K4', _c_A1( 1) ) .
_c_M12Pa('$K4', _c_A1( 2) ) . _c_M13Pa('$K4', _c_A1( 3) ) .
_c_M14Pa('$K4', _c_A1( 4) ) . _c_M15Pa('$K4', _c_A1( 5) ) .
_c_M11Pa('$K4', _c_A1( 6) ) . _c_M12Pa('$K4', _c_A1( 7) ) .
_c_M13Pa('$K4', _c_A1( 8) ) . _c_M14Pa('$K4', _c_A1( 9) ) .
_c_M15Pa('$K4', _c_A1(10) ) . _c_M11Pa('$K4', _c_A1(11) ) .
_c_M12Pa('$K4', _c_A1(12) ) . _c_M13Pa('$K4', _c_A1(13) ) .
_c_M14Pa('$K4', _c_A1(14) ) . _c_M15Pa('$K4', _c_A1(15) ) .
' $self->{H}->[0] += $a; $self->{H}->[1] += $b; $self->{H}->[2] += $c;
$self->{H}->[3] += $d; $self->{H}->[4] += $e;
}
';
eval($sha1_code);
sub _c_M2 { # ref. Digest::SHA sha.c (sha256 routine)
my($a, $b, $c, $d, $e, $f, $g, $h, $w) = @_;
"\$T1 = $h + " . _c_SIGMA1($e) . " + " . _c_Ch($e, $f, $g) .
" + \$K256[\$i++] + $w; $h = \$T1 + " . _c_SIGMA0($a) .
" + " . _c_Ma($a, $b, $c) . "; $d += \$T1;\n";
}
sub _c_M21 { _c_M2('$a', '$b', '$c', '$d', '$e', '$f', '$g', '$h', $_[0]) }
sub _c_M22 { _c_M2('$h', '$a', '$b', '$c', '$d', '$e', '$f', '$g', $_[0]) }
sub _c_M23 { _c_M2('$g', '$h', '$a', '$b', '$c', '$d', '$e', '$f', $_[0]) }
sub _c_M24 { _c_M2('$f', '$g', '$h', '$a', '$b', '$c', '$d', '$e', $_[0]) }
sub _c_M25 { _c_M2('$e', '$f', '$g', '$h', '$a', '$b', '$c', '$d', $_[0]) }
sub _c_M26 { _c_M2('$d', '$e', '$f', '$g', '$h', '$a', '$b', '$c', $_[0]) }
sub _c_M27 { _c_M2('$c', '$d', '$e', '$f', '$g', '$h', '$a', '$b', $_[0]) }
sub _c_M28 { _c_M2('$b', '$c', '$d', '$e', '$f', '$g', '$h', '$a', $_[0]) }
sub _c_W21 { my($s) = @_; '$W[' . (($s + 0) & 0xf) . ']' }
sub _c_W22 { my($s) = @_; '$W[' . (($s + 14) & 0xf) . ']' }
sub _c_W23 { my($s) = @_; '$W[' . (($s + 9) & 0xf) . ']' }
sub _c_W24 { my($s) = @_; '$W[' . (($s + 1) & 0xf) . ']' }
sub _c_A2 {
my($s) = @_;
"(" . _c_W21($s) . " += " . _c_sigma1(_c_W22($s)) . " + " .
_c_W23($s) . " + " . _c_sigma0(_c_W24($s)) . ")";
}
# The following code emulates the "sha256" routine from Digest::SHA sha.c
my $sha256_code = '
my @K256 = ( # SHA-224/256 constants
0x428a2f98, 0x71374491, 0xb5c0fbcf, 0xe9b5dba5,
0x3956c25b, 0x59f111f1, 0x923f82a4, 0xab1c5ed5,
0xd807aa98, 0x12835b01, 0x243185be, 0x550c7dc3,
0x72be5d74, 0x80deb1fe, 0x9bdc06a7, 0xc19bf174,
0xe49b69c1, 0xefbe4786, 0x0fc19dc6, 0x240ca1cc,
0x2de92c6f, 0x4a7484aa, 0x5cb0a9dc, 0x76f988da,
0x983e5152, 0xa831c66d, 0xb00327c8, 0xbf597fc7,
0xc6e00bf3, 0xd5a79147, 0x06ca6351, 0x14292967,
0x27b70a85, 0x2e1b2138, 0x4d2c6dfc, 0x53380d13,
0x650a7354, 0x766a0abb, 0x81c2c92e, 0x92722c85,
0xa2bfe8a1, 0xa81a664b, 0xc24b8b70, 0xc76c51a3,
0xd192e819, 0xd6990624, 0xf40e3585, 0x106aa070,
0x19a4c116, 0x1e376c08, 0x2748774c, 0x34b0bcb5,
0x391c0cb3, 0x4ed8aa4a, 0x5b9cca4f, 0x682e6ff3,
0x748f82ee, 0x78a5636f, 0x84c87814, 0x8cc70208,
0x90befffa, 0xa4506ceb, 0xbef9a3f7, 0xc67178f2
);
sub _sha256 {
my($self, $block) = @_;
my(@W, $a, $b, $c, $d, $e, $f, $g, $h, $i, $T1);
@W = unpack("N16", $block);
($a, $b, $c, $d, $e, $f, $g, $h) = @{$self->{H}};
' .
_c_M21('$W[ 0]' ) . _c_M22('$W[ 1]' ) . _c_M23('$W[ 2]' ) .
_c_M24('$W[ 3]' ) . _c_M25('$W[ 4]' ) . _c_M26('$W[ 5]' ) .
_c_M27('$W[ 6]' ) . _c_M28('$W[ 7]' ) . _c_M21('$W[ 8]' ) .
_c_M22('$W[ 9]' ) . _c_M23('$W[10]' ) . _c_M24('$W[11]' ) .
_c_M25('$W[12]' ) . _c_M26('$W[13]' ) . _c_M27('$W[14]' ) .
_c_M28('$W[15]' ) .
_c_M21(_c_A2( 0)) . _c_M22(_c_A2( 1)) . _c_M23(_c_A2( 2)) .
_c_M24(_c_A2( 3)) . _c_M25(_c_A2( 4)) . _c_M26(_c_A2( 5)) .
_c_M27(_c_A2( 6)) . _c_M28(_c_A2( 7)) . _c_M21(_c_A2( 8)) .
_c_M22(_c_A2( 9)) . _c_M23(_c_A2(10)) . _c_M24(_c_A2(11)) .
_c_M25(_c_A2(12)) . _c_M26(_c_A2(13)) . _c_M27(_c_A2(14)) .
_c_M28(_c_A2(15)) . _c_M21(_c_A2( 0)) . _c_M22(_c_A2( 1)) .
_c_M23(_c_A2( 2)) . _c_M24(_c_A2( 3)) . _c_M25(_c_A2( 4)) .
_c_M26(_c_A2( 5)) . _c_M27(_c_A2( 6)) . _c_M28(_c_A2( 7)) .
_c_M21(_c_A2( 8)) . _c_M22(_c_A2( 9)) . _c_M23(_c_A2(10)) .
_c_M24(_c_A2(11)) . _c_M25(_c_A2(12)) . _c_M26(_c_A2(13)) .
_c_M27(_c_A2(14)) . _c_M28(_c_A2(15)) . _c_M21(_c_A2( 0)) .
_c_M22(_c_A2( 1)) . _c_M23(_c_A2( 2)) . _c_M24(_c_A2( 3)) .
_c_M25(_c_A2( 4)) . _c_M26(_c_A2( 5)) . _c_M27(_c_A2( 6)) .
_c_M28(_c_A2( 7)) . _c_M21(_c_A2( 8)) . _c_M22(_c_A2( 9)) .
_c_M23(_c_A2(10)) . _c_M24(_c_A2(11)) . _c_M25(_c_A2(12)) .
_c_M26(_c_A2(13)) . _c_M27(_c_A2(14)) . _c_M28(_c_A2(15)) .
' $self->{H}->[0] += $a; $self->{H}->[1] += $b; $self->{H}->[2] += $c;
$self->{H}->[3] += $d; $self->{H}->[4] += $e; $self->{H}->[5] += $f;
$self->{H}->[6] += $g; $self->{H}->[7] += $h;
}
';
eval($sha256_code);
sub _sha512_placeholder { return }
my $sha512 = \&_sha512_placeholder;
my $_64bit_code = '
my $w_flag;
BEGIN {
$w_flag = $^W; # suppress compiler warnings about
$^W = 0; # non-portable 64-bit constants
}
my @K512 = (
0x428a2f98d728ae22, 0x7137449123ef65cd, 0xb5c0fbcfec4d3b2f,
0xe9b5dba58189dbbc, 0x3956c25bf348b538, 0x59f111f1b605d019,
0x923f82a4af194f9b, 0xab1c5ed5da6d8118, 0xd807aa98a3030242,
0x12835b0145706fbe, 0x243185be4ee4b28c, 0x550c7dc3d5ffb4e2,
0x72be5d74f27b896f, 0x80deb1fe3b1696b1, 0x9bdc06a725c71235,
0xc19bf174cf692694, 0xe49b69c19ef14ad2, 0xefbe4786384f25e3,
0x0fc19dc68b8cd5b5, 0x240ca1cc77ac9c65, 0x2de92c6f592b0275,
0x4a7484aa6ea6e483, 0x5cb0a9dcbd41fbd4, 0x76f988da831153b5,
0x983e5152ee66dfab, 0xa831c66d2db43210, 0xb00327c898fb213f,
0xbf597fc7beef0ee4, 0xc6e00bf33da88fc2, 0xd5a79147930aa725,
0x06ca6351e003826f, 0x142929670a0e6e70, 0x27b70a8546d22ffc,
0x2e1b21385c26c926, 0x4d2c6dfc5ac42aed, 0x53380d139d95b3df,
0x650a73548baf63de, 0x766a0abb3c77b2a8, 0x81c2c92e47edaee6,
0x92722c851482353b, 0xa2bfe8a14cf10364, 0xa81a664bbc423001,
0xc24b8b70d0f89791, 0xc76c51a30654be30, 0xd192e819d6ef5218,
0xd69906245565a910, 0xf40e35855771202a, 0x106aa07032bbd1b8,
0x19a4c116b8d2d0c8, 0x1e376c085141ab53, 0x2748774cdf8eeb99,
0x34b0bcb5e19b48a8, 0x391c0cb3c5c95a63, 0x4ed8aa4ae3418acb,
0x5b9cca4f7763e373, 0x682e6ff3d6b2b8a3, 0x748f82ee5defb2fc,
0x78a5636f43172f60, 0x84c87814a1f0ab72, 0x8cc702081a6439ec,
0x90befffa23631e28, 0xa4506cebde82bde9, 0xbef9a3f7b2c67915,
0xc67178f2e372532b, 0xca273eceea26619c, 0xd186b8c721c0c207,
0xeada7dd6cde0eb1e, 0xf57d4f7fee6ed178, 0x06f067aa72176fba,
0x0a637dc5a2c898a6, 0x113f9804bef90dae, 0x1b710b35131c471b,
0x28db77f523047d84, 0x32caab7b40c72493, 0x3c9ebe0a15c9bebc,
0x431d67c49c100d4c, 0x4cc5d4becb3e42b6, 0x597f299cfc657e2a,
0x5fcb6fab3ad6faec, 0x6c44198c4a475817);
@H0384 = (
0xcbbb9d5dc1059ed8, 0x629a292a367cd507, 0x9159015a3070dd17,
0x152fecd8f70e5939, 0x67332667ffc00b31, 0x8eb44a8768581511,
0xdb0c2e0d64f98fa7, 0x47b5481dbefa4fa4);
@H0512 = (
0x6a09e667f3bcc908, 0xbb67ae8584caa73b, 0x3c6ef372fe94f82b,
0xa54ff53a5f1d36f1, 0x510e527fade682d1, 0x9b05688c2b3e6c1f,
0x1f83d9abfb41bd6b, 0x5be0cd19137e2179);
@H0512224 = (
0x8c3d37c819544da2, 0x73e1996689dcd4d6, 0x1dfab7ae32ff9c82,
0x679dd514582f9fcf, 0x0f6d2b697bd44da8, 0x77e36f7304c48942,
0x3f9d85a86a1d36c8, 0x1112e6ad91d692a1);
@H0512256 = (
0x22312194fc2bf72c, 0x9f555fa3c84c64c2, 0x2393b86b6f53b151,
0x963877195940eabd, 0x96283ee2a88effe3, 0xbe5e1e2553863992,
0x2b0199fc2c85b8aa, 0x0eb72ddc81c52ca2);
BEGIN { $^W = $w_flag } # restore prior warning state
sub _c_SL64 { my($x, $n) = @_; "($x << $n)" }
sub _c_SR64 {
my($x, $n) = @_;
my $mask = (1 << (64 - $n)) - 1;
"(($x >> $n) & $mask)";
}
sub _c_ROTRQ {
my($x, $n) = @_;
"(" . _c_SR64($x, $n) . " | " . _c_SL64($x, 64 - $n) . ")";
}
sub _c_SIGMAQ0 {
my($x) = @_;
"(" . _c_ROTRQ($x, 28) . " ^ " . _c_ROTRQ($x, 34) . " ^ " .
_c_ROTRQ($x, 39) . ")";
}
sub _c_SIGMAQ1 {
my($x) = @_;
"(" . _c_ROTRQ($x, 14) . " ^ " . _c_ROTRQ($x, 18) . " ^ " .
_c_ROTRQ($x, 41) . ")";
}
sub _c_sigmaQ0 {
my($x) = @_;
"(" . _c_ROTRQ($x, 1) . " ^ " . _c_ROTRQ($x, 8) . " ^ " .
_c_SR64($x, 7) . ")";
}
sub _c_sigmaQ1 {
my($x) = @_;
"(" . _c_ROTRQ($x, 19) . " ^ " . _c_ROTRQ($x, 61) . " ^ " .
_c_SR64($x, 6) . ")";
}
my $sha512_code = q/
sub _sha512 {
my($self, $block) = @_;
my(@N, @W, $a, $b, $c, $d, $e, $f, $g, $h, $T1, $T2);
@N = unpack("N32", $block);
($a, $b, $c, $d, $e, $f, $g, $h) = @{$self->{H}};
for ( 0 .. 15) { $W[$_] = (($N[2*$_] << 16) << 16) | $N[2*$_+1] }
for (16 .. 79) { $W[$_] = / .
_c_sigmaQ1(q/$W[$_- 2]/) . q/ + $W[$_- 7] + / .
_c_sigmaQ0(q/$W[$_-15]/) . q/ + $W[$_-16] }
for ( 0 .. 79) {
$T1 = $h + / . _c_SIGMAQ1(q/$e/) .
q/ + (($g) ^ (($e) & (($f) ^ ($g)))) +
$K512[$_] + $W[$_];
$T2 = / . _c_SIGMAQ0(q/$a/) .
q/ + ((($a) & ($b)) | (($c) & (($a) | ($b))));
$h = $g; $g = $f; $f = $e; $e = $d + $T1;
$d = $c; $c = $b; $b = $a; $a = $T1 + $T2;
}
$self->{H}->[0] += $a; $self->{H}->[1] += $b; $self->{H}->[2] += $c;
$self->{H}->[3] += $d; $self->{H}->[4] += $e; $self->{H}->[5] += $f;
$self->{H}->[6] += $g; $self->{H}->[7] += $h;
}
/;
eval($sha512_code);
$sha512 = \&_sha512;
';
eval($_64bit_code) if $uses64bit;
sub _SETBIT {
my($self, $pos) = @_;
my @c = unpack("C*", $self->{block});
$c[$pos >> 3] = 0x00 unless defined $c[$pos >> 3];
$c[$pos >> 3] |= (0x01 << (7 - $pos % 8));
$self->{block} = pack("C*", @c);
}
sub _CLRBIT {
my($self, $pos) = @_;
my @c = unpack("C*", $self->{block});
$c[$pos >> 3] = 0x00 unless defined $c[$pos >> 3];
$c[$pos >> 3] &= ~(0x01 << (7 - $pos % 8));
$self->{block} = pack("C*", @c);
}
sub _BYTECNT {
my($bitcnt) = @_;
$bitcnt > 0 ? 1 + (($bitcnt - 1) >> 3) : 0;
}
sub _digcpy {
my($self) = @_;
my @dig;
for (@{$self->{H}}) {
push(@dig, (($_>>16)>>16) & $MAX32) if $self->{alg} >= 384;
push(@dig, $_ & $MAX32);
}
$self->{digest} = pack("N" . ($self->{digestlen}>>2), @dig);
}
sub _sharewind {
my($self) = @_;
my $alg = $self->{alg};
$self->{block} = ""; $self->{blockcnt} = 0;
$self->{blocksize} = $alg <= 256 ? 512 : 1024;
for (qw(lenll lenlh lenhl lenhh)) { $self->{$_} = 0 }
$self->{digestlen} = $alg == 1 ? 20 : ($alg % 1000)/8;
if ($alg == 1) { $self->{sha} = \&_sha1; $self->{H} = [@H01] }
elsif ($alg == 224) { $self->{sha} = \&_sha256; $self->{H} = [@H0224] }
elsif ($alg == 256) { $self->{sha} = \&_sha256; $self->{H} = [@H0256] }
elsif ($alg == 384) { $self->{sha} = $sha512; $self->{H} = [@H0384] }
elsif ($alg == 512) { $self->{sha} = $sha512; $self->{H} = [@H0512] }
elsif ($alg == 512224) { $self->{sha}=$sha512; $self->{H}=[@H0512224] }
elsif ($alg == 512256) { $self->{sha}=$sha512; $self->{H}=[@H0512256] }
push(@{$self->{H}}, 0) while scalar(@{$self->{H}}) < 8;
$self;
}
sub _shaopen {
my($alg) = @_;
my($self);
return unless grep { $alg == $_ } (1,224,256,384,512,512224,512256);
return if ($alg >= 384 && !$uses64bit);
$self->{alg} = $alg;
_sharewind($self);
}
sub _shadirect {
my($bitstr, $bitcnt, $self) = @_;
my $savecnt = $bitcnt;
my $offset = 0;
my $blockbytes = $self->{blocksize} >> 3;
while ($bitcnt >= $self->{blocksize}) {
&{$self->{sha}}($self, substr($bitstr, $offset, $blockbytes));
$offset += $blockbytes;
$bitcnt -= $self->{blocksize};
}
if ($bitcnt > 0) {
$self->{block} = substr($bitstr, $offset, _BYTECNT($bitcnt));
$self->{blockcnt} = $bitcnt;
}
$savecnt;
}
sub _shabytes {
my($bitstr, $bitcnt, $self) = @_;
my($numbits);
my $savecnt = $bitcnt;
if ($self->{blockcnt} + $bitcnt >= $self->{blocksize}) {
$numbits = $self->{blocksize} - $self->{blockcnt};
$self->{block} .= substr($bitstr, 0, $numbits >> 3);
$bitcnt -= $numbits;
$bitstr = substr($bitstr, $numbits >> 3, _BYTECNT($bitcnt));
&{$self->{sha}}($self, $self->{block});
$self->{block} = "";
$self->{blockcnt} = 0;
_shadirect($bitstr, $bitcnt, $self);
}
else {
$self->{block} .= substr($bitstr, 0, _BYTECNT($bitcnt));
$self->{blockcnt} += $bitcnt;
}
$savecnt;
}
sub _shabits {
my($bitstr, $bitcnt, $self) = @_;
my($i, @buf);
my $numbytes = _BYTECNT($bitcnt);
my $savecnt = $bitcnt;
my $gap = 8 - $self->{blockcnt} % 8;
my @c = unpack("C*", $self->{block});
my @b = unpack("C" . $numbytes, $bitstr);
$c[$self->{blockcnt}>>3] &= (~0 << $gap);
$c[$self->{blockcnt}>>3] |= $b[0] >> (8 - $gap);
$self->{block} = pack("C*", @c);
$self->{blockcnt} += ($bitcnt < $gap) ? $bitcnt : $gap;
return($savecnt) if $bitcnt < $gap;
if ($self->{blockcnt} == $self->{blocksize}) {
&{$self->{sha}}($self, $self->{block});
$self->{block} = "";
$self->{blockcnt} = 0;
}
return($savecnt) if ($bitcnt -= $gap) == 0;
for ($i = 0; $i < $numbytes - 1; $i++) {
$buf[$i] = (($b[$i] << $gap) & 0xff) | ($b[$i+1] >> (8 - $gap));
}
$buf[$numbytes-1] = ($b[$numbytes-1] << $gap) & 0xff;
_shabytes(pack("C*", @buf), $bitcnt, $self);
$savecnt;
}
sub _shawrite {
my($bitstr, $bitcnt, $self) = @_;
return(0) unless $bitcnt > 0;
no integer;
if (($self->{lenll} += $bitcnt) >= $TWO32) {
$self->{lenll} -= $TWO32;
if (++$self->{lenlh} >= $TWO32) {
$self->{lenlh} -= $TWO32;
if (++$self->{lenhl} >= $TWO32) {
$self->{lenhl} -= $TWO32;
if (++$self->{lenhh} >= $TWO32) {
$self->{lenhh} -= $TWO32;
}
}
}
}
use integer;
my $blockcnt = $self->{blockcnt};
return(_shadirect($bitstr, $bitcnt, $self)) if $blockcnt == 0;
return(_shabytes ($bitstr, $bitcnt, $self)) if $blockcnt % 8 == 0;
return(_shabits ($bitstr, $bitcnt, $self));
}
my $MWS = 16384;
sub _shaWrite {
my($bytestr_r, $bytecnt, $self) = @_;
return(0) unless $bytecnt > 0;
return(_shawrite($$bytestr_r, $bytecnt<<3, $self)) if $bytecnt <= $MWS;
my $offset = 0;
while ($bytecnt > $MWS) {
_shawrite(substr($$bytestr_r, $offset, $MWS), $MWS<<3, $self);
$offset += $MWS;
$bytecnt -= $MWS;
}
_shawrite(substr($$bytestr_r, $offset, $bytecnt), $bytecnt<<3, $self);
}
sub _shafinish {
my($self) = @_;
my $LENPOS = $self->{alg} <= 256 ? 448 : 896;
_SETBIT($self, $self->{blockcnt}++);
while ($self->{blockcnt} > $LENPOS) {
if ($self->{blockcnt} < $self->{blocksize}) {
_CLRBIT($self, $self->{blockcnt}++);
}
else {
&{$self->{sha}}($self, $self->{block});
$self->{block} = "";
$self->{blockcnt} = 0;
}
}
while ($self->{blockcnt} < $LENPOS) {
_CLRBIT($self, $self->{blockcnt}++);
}
if ($self->{blocksize} > 512) {
$self->{block} .= pack("N", $self->{lenhh} & $MAX32);
$self->{block} .= pack("N", $self->{lenhl} & $MAX32);
}
$self->{block} .= pack("N", $self->{lenlh} & $MAX32);
$self->{block} .= pack("N", $self->{lenll} & $MAX32);
&{$self->{sha}}($self, $self->{block});
}
sub _shadigest { my($self) = @_; _digcpy($self); $self->{digest} }
sub _shahex {
my($self) = @_;
_digcpy($self);
join("", unpack("H*", $self->{digest}));
}
sub _shabase64 {
my($self) = @_;
_digcpy($self);
my $b64 = pack("u", $self->{digest});
$b64 =~ s/^.//mg;
$b64 =~ s/\n//g;
$b64 =~ tr|` -_|AA-Za-z0-9+/|;
my $numpads = (3 - length($self->{digest}) % 3) % 3;
$b64 =~ s/.{$numpads}$// if $numpads;
$b64;
}
sub _shadsize { my($self) = @_; $self->{digestlen} }
sub _shacpy {
my($to, $from) = @_;
$to->{alg} = $from->{alg};
$to->{sha} = $from->{sha};
$to->{H} = [@{$from->{H}}];
$to->{block} = $from->{block};
$to->{blockcnt} = $from->{blockcnt};
$to->{blocksize} = $from->{blocksize};
for (qw(lenhh lenhl lenlh lenll)) { $to->{$_} = $from->{$_} }
$to->{digestlen} = $from->{digestlen};
$to;
}
sub _shadup { my($self) = @_; my($copy); _shacpy($copy, $self) }
sub _shadump {
my $file = shift;
my $fh = (!defined($file) || $file eq "")
? FileHandle->new("> -")
: FileHandle->new($file, "w") or return;
my $self = shift;
my $is32bit = $self->{alg} <= 256;
my $fmt = $is32bit ? ":%08x" : ":%016x";
printf $fh "alg:%d\n", $self->{alg};
printf $fh "H";
for (@{$self->{H}}) { printf $fh $fmt, $is32bit ? $_ & $MAX32 : $_ }
printf $fh "\nblock";
my @c = unpack("C*", $self->{block});
push(@c, 0x00) while scalar(@c) < ($self->{blocksize} >> 3);
for (@c) { printf $fh ":%02x", $_ }
printf $fh "\nblockcnt:%u\n", $self->{blockcnt};
printf $fh "lenhh:%lu\n", $self->{lenhh} & $MAX32;
printf $fh "lenhl:%lu\n", $self->{lenhl} & $MAX32;
printf $fh "lenlh:%lu\n", $self->{lenlh} & $MAX32;
printf $fh "lenll:%lu\n", $self->{lenll} & $MAX32;
close($fh);
$self;
}
sub _match {
my($fh, $tag) = @_;
my @f;
while (<$fh>) {
s/^\s+//;
s/\s+$//;
next if (/^(#|$)/);
@f = split(/[:\s]+/);
last;
}
shift(@f) eq $tag or return;
return(@f);
}
sub _shaload {
my $file = shift;
my $fh = (!defined($file) || $file eq "")
? FileHandle->new("< -")
: FileHandle->new($file, "r") or return;
my @f = _match($fh, "alg") or return;
my $self = _shaopen(shift(@f)) or return;
@f = _match($fh, "H") or return;
my $numxdigits = $self->{alg} <= 256 ? 8 : 16;
for (@f) { $_ = "0" . $_ while length($_) < $numxdigits }
for (@f) { $_ = substr($_, 1) while length($_) > $numxdigits }
@{$self->{H}} = map { $self->{alg} <= 256 ? hex($_) :
((hex(substr($_, 0, 8)) << 16) << 16) |
hex(substr($_, 8)) } @f;
@f = _match($fh, "block") or return;
for (@f) { $self->{block} .= chr(hex($_)) }
@f = _match($fh, "blockcnt") or return;
$self->{blockcnt} = shift(@f);
$self->{block} = substr($self->{block},0,_BYTECNT($self->{blockcnt}));
@f = _match($fh, "lenhh") or return;
$self->{lenhh} = shift(@f);
@f = _match($fh, "lenhl") or return;
$self->{lenhl} = shift(@f);
@f = _match($fh, "lenlh") or return;
$self->{lenlh} = shift(@f);
@f = _match($fh, "lenll") or return;
$self->{lenll} = shift(@f);
close($fh);
$self;
}
# ref. src/hmac.c from Digest::SHA
sub _hmacopen {
my($alg, $key) = @_;
my($self);
$self->{isha} = _shaopen($alg) or return;
$self->{osha} = _shaopen($alg) or return;
if (length($key) > $self->{osha}->{blocksize} >> 3) {
$self->{ksha} = _shaopen($alg) or return;
_shawrite($key, length($key) << 3, $self->{ksha});
_shafinish($self->{ksha});
$key = _shadigest($self->{ksha});
}
$key .= chr(0x00)
while length($key) < $self->{osha}->{blocksize} >> 3;
my @k = unpack("C*", $key);
for (@k) { $_ ^= 0x5c }
_shawrite(pack("C*", @k), $self->{osha}->{blocksize}, $self->{osha});
for (@k) { $_ ^= (0x5c ^ 0x36) }
_shawrite(pack("C*", @k), $self->{isha}->{blocksize}, $self->{isha});
$self;
}
sub _hmacWrite {
my($bytestr_r, $bytecnt, $self) = @_;
_shaWrite($bytestr_r, $bytecnt, $self->{isha});
}
sub _hmacfinish {
my($self) = @_;
_shafinish($self->{isha});
_shawrite(_shadigest($self->{isha}),
$self->{isha}->{digestlen} << 3, $self->{osha});
_shafinish($self->{osha});
}
sub _hmacdigest { my($self) = @_; _shadigest($self->{osha}) }
sub _hmachex { my($self) = @_; _shahex($self->{osha}) }
sub _hmacbase64 { my($self) = @_; _shabase64($self->{osha}) }
# SHA and HMAC-SHA functions
my @suffix_extern = ("", "_hex", "_base64");
my @suffix_intern = ("digest", "hex", "base64");
my($i, $alg);
for $alg (1, 224, 256, 384, 512, 512224, 512256) {
for $i (0 .. 2) {
my $fcn = 'sub sha' . $alg . $suffix_extern[$i] . ' {
my $state = _shaopen(' . $alg . ') or return;
for (@_) { _shaWrite(\$_, length($_), $state) }
_shafinish($state);
_sha' . $suffix_intern[$i] . '($state);
}';
eval($fcn);
push(@EXPORT_OK, 'sha' . $alg . $suffix_extern[$i]);
$fcn = 'sub hmac_sha' . $alg . $suffix_extern[$i] . ' {
my $state = _hmacopen(' . $alg . ', pop(@_)) or return;
for (@_) { _hmacWrite(\$_, length($_), $state) }
_hmacfinish($state);
_hmac' . $suffix_intern[$i] . '($state);
}';
eval($fcn);
push(@EXPORT_OK, 'hmac_sha' . $alg . $suffix_extern[$i]);
}
}
# OOP methods
sub hashsize { my $self = shift; _shadsize($self) << 3 }
sub algorithm { my $self = shift; $self->{alg} }
sub add {
my $self = shift;
for (@_) { _shaWrite(\$_, length($_), $self) }
$self;
}
sub digest {
my $self = shift;
_shafinish($self);
my $rsp = _shadigest($self);
_sharewind($self);
$rsp;
}
sub _Hexdigest {
my $self = shift;
_shafinish($self);
my $rsp = _shahex($self);
_sharewind($self);
$rsp;
}
sub _B64digest {
my $self = shift;
_shafinish($self);
my $rsp = _shabase64($self);
_sharewind($self);
$rsp;
}
sub new {
my($class, $alg) = @_;
$alg =~ s/\D+//g if defined $alg;
if (ref($class)) { # instance method
unless (defined($alg) && ($alg != $class->algorithm)) {
_sharewind($class);
return($class);
}
my $self = _shaopen($alg) or return;
return(_shacpy($class, $self));
}
$alg = 1 unless defined $alg;
my $self = _shaopen($alg) or return;
bless($self, $class);
$self;
}
sub clone {
my $self = shift;
my $copy = _shadup($self) or return;
bless($copy, ref($self));
return($copy);
}
*reset = \&new;
sub add_bits {
my($self, $data, $nbits) = @_;
unless (defined $nbits) {
$nbits = length($data);
$data = pack("B*", $data);
}
$nbits = length($data) * 8 if $nbits > length($data) * 8;
_shawrite($data, $nbits, $self);
return($self);
}
sub _bail {
my $msg = shift;
$msg .= ": $!";
require Carp;
Carp::croak($msg);
}
sub _addfile {
my ($self, $handle) = @_;
my $n;
my $buf = "";
while (($n = read($handle, $buf, 4096))) {
$self->add($buf);
}
_bail("Read failed") unless defined $n;
$self;
}
sub _Addfile {
my ($self, $file, $mode) = @_;
return(_addfile($self, $file)) unless ref(\$file) eq 'SCALAR';
$mode = defined($mode) ? $mode : "";
my ($binary, $portable, $BITS) = map { $_ eq $mode } ("b", "p", "0");
## Always interpret "-" to mean STDIN; otherwise use
## sysopen to handle full range of POSIX file names
local *FH;
$file eq '-' and open(FH, '< -')
or sysopen(FH, $file, O_RDONLY)
or _bail('Open failed');
if ($BITS) {
my ($n, $buf) = (0, "");
while (($n = read(FH, $buf, 4096))) {
$buf =~ s/[^01]//g;
$self->add_bits($buf);
}
_bail("Read failed") unless defined $n;
close(FH);
return($self);
}
binmode(FH) if $binary || $portable;
unless ($portable && -T $file) {
$self->_addfile(*FH);
close(FH);
return($self);
}
my ($n1, $n2);
my ($buf1, $buf2) = ("", "");
while (($n1 = read(FH, $buf1, 4096))) {
while (substr($buf1, -1) eq "\015") {
$n2 = read(FH, $buf2, 4096);
_bail("Read failed") unless defined $n2;
last unless $n2;
$buf1 .= $buf2;
}
$buf1 =~ s/\015?\015\012/\012/g; # DOS/Windows
$buf1 =~ s/\015/\012/g; # early MacOS
$self->add($buf1);
}
_bail("Read failed") unless defined $n1;
close(FH);
$self;
}
sub dump {
my $self = shift;
my $file = shift || "";
_shadump($file, $self) or return;
return($self);
}
sub load {
my $class = shift;
my $file = shift || "";
if (ref($class)) { # instance method
my $self = _shaload($file) or return;
return(_shacpy($class, $self));
}
my $self = _shaload($file) or return;
bless($self, $class);
return($self);
}
1;
__END__
=head1 NAME
Digest::SHA::PurePerl - Perl implementation of SHA-1/224/256/384/512
=head1 SYNOPSIS
In programs:
# Functional interface
use Digest::SHA::PurePerl qw(sha1 sha1_hex sha1_base64 ...);
$digest = sha1($data);
$digest = sha1_hex($data);
$digest = sha1_base64($data);
$digest = sha256($data);
$digest = sha384_hex($data);
$digest = sha512_base64($data);
# Object-oriented
use Digest::SHA::PurePerl;
$sha = Digest::SHA::PurePerl->new($alg);
$sha->add($data); # feed data into stream
$sha->addfile(*F);
$sha->addfile($filename);
$sha->add_bits($bits);
$sha->add_bits($data, $nbits);
$sha_copy = $sha->clone; # if needed, make copy of
$sha->dump($file); # current digest state,
$sha->load($file); # or save it on disk
$digest = $sha->digest; # compute digest
$digest = $sha->hexdigest;
$digest = $sha->b64digest;
From the command line:
$ shasum files
$ shasum --help
=head1 SYNOPSIS (HMAC-SHA)
# Functional interface only
use Digest::SHA::PurePerl qw(hmac_sha1 hmac_sha1_hex ...);
$digest = hmac_sha1($data, $key);
$digest = hmac_sha224_hex($data, $key);
$digest = hmac_sha256_base64($data, $key);
=head1 ABSTRACT
Digest::SHA::PurePerl is a complete implementation of the NIST Secure
Hash Standard. It gives Perl programmers a convenient way to calculate
SHA-1, SHA-224, SHA-256, SHA-384, SHA-512, SHA-512/224, and SHA-512/256
message digests. The module can handle all types of input, including
partial-byte data.
=head1 DESCRIPTION
Digest::SHA::PurePerl is written entirely in Perl. If your platform
has a C compiler, you should install the functionally equivalent
(but much faster) L