diff -urN tiarra-20030728/ChangeLog tiarra-20030731/ChangeLog --- tiarra-20030728/ChangeLog 2003-07-31 04:40:13.000000000 +0900 +++ tiarra-20030731/ChangeLog 2003-07-31 18:29:13.000000000 +0900 @@ -1,3 +1,68 @@ +2003-07-31 Topia + + * 全般: + ・インデントの変更 + ・コメントの整備 + ・mask で使うチャンネル名をネットワーク付きに修正(a) + ・不要な use のクリーンアップ(b) + ・不要な変数のクリーンアップ(c) + + * Auto/Oper.pm: + (a) + + * Auto/Random.pm: + (a)(b) + + * Auto/Reply.pm: + (a)(b)(c) + + * Auto/MesMail.pm: + (b)(c) + + * Auto/Alias.pm: + (c) + + * Auto/Response.pm: + (a)(c) + + * Auto/Utils.pm: + get_ch_name -> (get_raw_ch_name): ネットワーク名無しの(server 的に raw な)チャンネル名 or undef を得る。 + (get_full_ch_name): ネットワーク名付きのチャンネル名 or undef を得る。 + (generate_reply_closures): 返り値に $get_full_ch_name を追加。 + 中身としては、$msg->param(place) 以上の意味は無いが、値の指定場所は一ヶ所にした方が良い。 + + * Tools/DateConvert.pm: + use_posix を import/unimport を使って再実装した。 + + * Tools/FileCache/EachFile.pm: + (can_remove): 実装。 + (AUTOLOAD): eval して関数コールするのではなく、その場でメソッドを定義して飛ぶようにした。 + + * Tools/FileCache.pm: + (main_loop): refcount を使ったチェックの代わりに、 can_remove を使ったチェックにした。 + + * Tools/HashDB.pm: + Module::Use を追加。 + + * Tools/HashTools.pm: + (get_array): 見付からなかった場合に () を返していたが、 undef を返すべきなので修正。 + (replace_recursive): こっかの補完処理を修正 + (_format): regexp の修正( %. -> %(.) )。バグでした。 + + * Tools/MailSend/EachServer.pm + ::printmsg -> RunLoop->shared->notify_warn 。 + LinedINETSocket を生成するときに $E_MAIL_EOL を使っていなかった。修正。 + MessageID の作られ方をコメントとして記述。 + + * Tools/MailSend.pm + (b) + + * Mask.pm: + s/exclude/include/ 。無意味な三項演算子を消した。 + + * sample.conf: + mask 関連を修正。 + 2003-07-28 phonohawk * main/IrcIO/Server.pm (person_list): @@ -685,7 +750,7 @@ * これ以前のログは書いていません。 -# Id: $Id: ChangeLog,v 1.94 2003/07/28 12:35:59 admin Exp $ -# Author: $Author: admin $ -# Date: $Date: 2003/07/28 12:35:59 $ -# Revision: $Revision: 1.94 $ +# Id: $Id: ChangeLog,v 1.95 2003/07/31 07:34:12 topia Exp $ +# Author: $Author: topia $ +# Date: $Date: 2003/07/31 07:34:12 $ +# Revision: $Revision: 1.95 $ diff -urN tiarra-20030728/NEWS tiarra-20030731/NEWS --- tiarra-20030728/NEWS 2003-07-31 04:40:13.000000000 +0900 +++ tiarra-20030731/NEWS 2003-07-31 18:29:13.000000000 +0900 @@ -1,3 +1,15 @@ +2003-07-31 Topia + + * mask のチャンネル名にネットワーク名を必要とするように修正した。 + 影響を受けるモジュールは + - Auto::Oper + - Auto::Random + - Auto::Reply + - Auto::MesMail + - Auto::Alias + - Auto::Response + です。変更よろしくお願いします。(^^;; + 2003-07-10 phonohawk * Channel::Freeze diff -urN tiarra-20030728/main/Mask.pm tiarra-20030731/main/Mask.pm --- tiarra-20030728/main/Mask.pm 2003-07-31 04:40:16.000000000 +0900 +++ tiarra-20030731/main/Mask.pm 2003-07-31 18:29:14.000000000 +0900 @@ -1,7 +1,7 @@ # ----------------------------------------------------------------------------- -# $Id: Mask.pm,v 1.9 2003/03/28 09:49:13 topia Exp $ +# $Id: Mask.pm,v 1.10 2003/07/31 07:34:13 topia Exp $ # ----------------------------------------------------------------------------- -# $Clovery: tiarra/main/Mask.pm,v 1.9 2003/03/23 02:56:11 topia Exp $ +# $Clovery: tiarra/main/Mask.pm,v 1.10 2003/07/24 03:08:26 topia Exp $ package Mask; use strict; use warnings; @@ -18,7 +18,7 @@ # 引数名 : [既定値] - 説明 - # $match_type : [0] 0: 最後にマッチした値を返します。 1: 最初にマッチした値を返します。 - # $use_re : [1] 0: 正規表現マッチを使用しません。 1: 使用します。 + # $use_re : [1] 0: 正規表現マッチを使用しません。 1: 使用します。 # $use_flag : [1] 0: +や-を使用しません。 1: 使用します。 # 返り値 : { 1 (true) => + にマッチ, @@ -33,18 +33,14 @@ } sub match_deep { - # match_deepはコンマで区切られた配列についてマッチングを行います。 + # match_deepは次のようなマスクの解釈に使います。 - # この関数は - # mask: -example1* - # mask: +* - # と - # mask: +*,-example1* - # の指定がどちらも同じ意味を示す様なマッチングを可能にします。 + # mask: +*!*@* + # mask: -example!* # 引数名 : [既定値] - 説明 - - # $masks_array : [無し] maskを行単位の配列にして参照を渡します。 - # Mask::match_deep([defined($this->config->mask) ? $this->config->mask('all') : '*!*@*'], $msg->prefix) + # $masks_array : [無し] マスク配列の参照を渡します。 + # Mask::match_deep([Mask::mask_array_or_all($this->config->mask('all'))], $msg->prefix) # : のように使います。 # $global_match_type : [1] 0: 最後にマッチした行の値を返します。 1: 最初にマッチした行の値を返します。 my ($masks_array, $str, $g_match_type, $match_type, $use_re, $use_flag) = @_; @@ -67,6 +63,9 @@ } sub match_array { + # match_arrayは、matchから呼ばれる内部関数ですが、普通に呼び出して使うこともできます。 + # match との違いは、マスクをマスク配列の参照として渡す点です。 + # $match_type: 0: last matching rule, 1: first matching rule # $use_re : use 're:' feature. # $use_flag : use [+-] match flag. @@ -87,22 +86,22 @@ my $matched = undef; foreach my $part (@$mask_array) { my $work = $part; - my $first = substr($part, 0, 1); - my $exclude = 0; + my $first = substr($work, 0, 1); + my $include = 1; if (!$use_flag) { # noop } elsif ($first eq '+') { substr($work, 0, 1) = ''; } elsif ($first eq '-') { - $exclude = 1; + $include = 0; substr($work, 0, 1) = ''; } if ($use_re && substr($work, 0, 3) eq 're:') { # 正規表現 $work = substr($work,3); - $work = eval { - qr/$work/; + $work = eval { + qr/$work/; }; if ($@) { $work = ''; carp "error in regex: $@"; @@ -113,11 +112,10 @@ if ($str =~ m/$work/i) { # マッチした - $matched = ($exclude ? 0 : 1); - return $matched if $match_type == 1; + $matched = $include; + return $matched if $match_type == 1; } } - return $matched; } @@ -237,39 +235,41 @@ } sub _split { - my $mask = shift; + # ',' でわけられたマスクを配列にする。 + my $mask = shift; - return map { - s/\\,/,/g; - $_; - } split /(?prefix || - Mask::match_deep([Mask::array_or_all($this->config->modifier('all'))], - $msg->prefix); - }; - if ($msg->command eq 'PRIVMSG') { if (Mask::match($this->config->confirm,$msg->param(1))) { # その人のエイリアスがあればprivで返す。 - my ($get_ch_name,undef,$reply_as_priv,undef) + my (undef,undef,$reply_as_priv,undef,undef) = Auto::Utils::generate_reply_closures($msg,$sender,\@result, 0); # Alias conversion disable. my $alias = Auto::AliasDB->shared->find_alias_prefix($msg->prefix); @@ -46,9 +40,15 @@ } } else { - my ($get_ch_name,undef,undef,$reply_anywhere) + my (undef,undef,undef,$reply_anywhere,undef) = Auto::Utils::generate_reply_closures($msg,$sender,\@result, 1); + my $msg_from_modifier_p = sub { + !defined $msg->prefix || + Mask::match_deep([Mask::array_or_all($this->config->modifier('all'))], + $msg->prefix); + }; + my ($temp) = $msg->param(1); $temp =~ s/^\s*(.+)\s*$/$1/; my ($keyword,$key,$value) diff -urN tiarra-20030728/module/Auto/MesMail.pm tiarra-20030731/module/Auto/MesMail.pm --- tiarra-20030728/module/Auto/MesMail.pm 2003-07-31 04:40:17.000000000 +0900 +++ tiarra-20030731/module/Auto/MesMail.pm 2003-07-31 18:29:15.000000000 +0900 @@ -1,5 +1,5 @@ # -*- cperl -*- -# $Clovery: tiarra/module/Auto/MesMail.pm,v 1.6 2003/03/03 13:32:47 topia Exp $ +# $Clovery: tiarra/module/Auto/MesMail.pm,v 1.7 2003/07/27 07:24:44 topia Exp $ # copyright (C) 2003 Topia . all rights reserved. package Auto::MesMail; use strict; @@ -11,13 +11,8 @@ use Tools::DateConvert; use Tools::MailSend; use Mask; -use Multicast; -use LinedINETSocket; -use Carp; -my $E_MAIL_EOL = "\x0d\x0a"; - -# pref +# デフォルト設定 my $DATE_FORMAT = '%H:%M'; my $FORMAT = '#(date) << #(from.name|from.nick|from.nick.now) >> #(message)'; my $SUBJECT = 'Message from IRC'; diff -urN tiarra-20030728/module/Auto/Oper.pm tiarra-20030731/module/Auto/Oper.pm --- tiarra-20030728/module/Auto/Oper.pm 2003-07-31 04:40:17.000000000 +0900 +++ tiarra-20030731/module/Auto/Oper.pm 2003-07-31 18:29:15.000000000 +0900 @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Oper.pm,v 1.9 2003/07/03 13:49:24 admin Exp $ +# $Id: Oper.pm,v 1.10 2003/07/31 07:34:13 topia Exp $ # ----------------------------------------------------------------------------- package Auto::Oper; use strict; @@ -20,13 +20,13 @@ my ($this,$msg,$sender) = @_; my @result = ($msg); - my ($get_ch_name,$reply,$reply_as_priv) + my ($get_raw_ch_name,$reply,$reply_as_priv,$reply_anywhere,$get_full_ch_name) = Auto::Utils::generate_reply_closures($msg,$sender,\@result); my $op = sub { $sender->send_message(IRCMessage->new( Command => 'MODE', - Params => [$get_ch_name->(),'+o',$msg->nick])); + Params => [$get_raw_ch_name->(),'+o',$msg->nick])); }; # 鯖からクライアントへのPRIVMSGで、かつrequestにマッチしているか？ @@ -41,7 +41,7 @@ # 指定されたチャンネルに、要求者は入っているか？ if (defined $ch->names($msg->nick)) { # なるとを渡しても良いのなら渡す。 - if (Mask::match_deep_chan([$this->config->mask('all')],$msg->prefix,$msg->param(0))) { + if (Mask::match_deep_chan([$this->config->mask('all')],$msg->prefix,$get_full_ch_name->())) { # 自分はなるとを持ってるか？ my $myself = $ch->names($sender->current_nick); if ($myself->has_o) { diff -urN tiarra-20030728/module/Auto/Random.pm tiarra-20030731/module/Auto/Random.pm --- tiarra-20030728/module/Auto/Random.pm 2003-07-31 04:40:17.000000000 +0900 +++ tiarra-20030731/module/Auto/Random.pm 2003-07-31 18:29:15.000000000 +0900 @@ -1,7 +1,7 @@ # ----------------------------------------------------------------------------- -# $Id: Random.pm,v 1.5 2003/03/28 09:49:13 topia Exp $ +# $Id: Random.pm,v 1.6 2003/07/31 07:34:13 topia Exp $ # ----------------------------------------------------------------------------- -# $Clovery: tiarra/module/Auto/Random.pm,v 1.9 2003/03/18 16:14:14 topia Exp $ +# $Clovery: tiarra/module/Auto/Random.pm,v 1.12 2003/07/27 07:29:22 topia Exp $ package Auto::Random; use strict; use warnings; @@ -11,7 +11,6 @@ use Auto::Utils; use Tools::FileCache; use Mask; -use Multicast; sub new { my ($class) = @_; @@ -65,13 +64,13 @@ my ($this,$msg,$sender) = @_; my @result = ($msg); - my ($get_ch_name,undef,undef,$reply_anywhere) + my (undef,undef,undef,$reply_anywhere,$get_full_ch_name) = Auto::Utils::generate_reply_closures($msg,$sender,\@result); if ($msg->command eq 'PRIVMSG') { foreach my $block (@{$this->{config}}) { if (Mask::match_deep($block->{request}, $msg->param(1))) { - if (Mask::match_deep_chan($block->{mask}, $msg->prefix, $get_ch_name->())) { + if (Mask::match_deep_chan($block->{mask}, $msg->prefix, $get_full_ch_name->())) { # ランダムな発言を行なう。 my $rate_rand = int(rand() * hex('0xffffffff')) % 100; if ($rate_rand < ($block->{rate} || 100)) { @@ -82,7 +81,7 @@ } } } elsif (Mask::match_deep($block->{count_query}, $msg->param(1))) { - if (Mask::match_deep_chan($block->{mask}, $msg->prefix, $get_ch_name->())) { + if (Mask::match_deep_chan($block->{mask}, $msg->prefix, $get_full_ch_name->())) { # 登録数を求める my $count = $block->{database}->length(); map { @@ -92,7 +91,7 @@ } else { my $msg_from_modifier_p = sub { !defined $msg->prefix || - Mask::match_deep_chan($block->{modifier}, $msg->prefix, $get_ch_name->()); + Mask::match_deep_chan($block->{modifier}, $msg->prefix, $get_full_ch_name->()); }; my ($keyword,$param) = $msg->param(1) =~ /^\s*(.+?)\s+(.+?)\s*$/; if (defined $keyword && defined $param) { diff -urN tiarra-20030728/module/Auto/Reply.pm tiarra-20030731/module/Auto/Reply.pm --- tiarra-20030728/module/Auto/Reply.pm 2003-07-31 04:40:18.000000000 +0900 +++ tiarra-20030731/module/Auto/Reply.pm 2003-07-31 18:29:15.000000000 +0900 @@ -1,5 +1,5 @@ # -*- cperl -*- -# $Clovery: tiarra/module/Auto/Reply.pm,v 1.2 2003/05/23 11:59:49 topia Exp $ +# $Clovery: tiarra/module/Auto/Reply.pm,v 1.4 2003/07/27 07:32:51 topia Exp $ # copyright (C) 2003 Topia . all rights reserved. package Auto::Reply; use strict; @@ -10,159 +10,163 @@ use Auto::AliasDB::CallbackUtils; use Tools::HashDB; use Mask; -use Multicast; sub new { - my ($class) = @_; - my $this = $class->SUPER::new; - $this->{config} = []; + my ($class) = @_; + my $this = $class->SUPER::new; + $this->{config} = []; - $this->_load; - return $this; + $this->_load; + return $this; } sub _load { - my $this = shift; + my $this = shift; - my $BLOCKS_NAME = 'blocks'; + my $BLOCKS_NAME = 'blocks'; - foreach my $blockname ($this->config->get($BLOCKS_NAME, 'all')) { - die "$blockname block name is reserved!" if $blockname eq $BLOCKS_NAME; - my $block = $this->config->get($blockname); - die "$blockname isn't block!" unless UNIVERSAL::isa($block, 'Configuration::Block'); - push(@{$this->{config}}, - { - mask => [Mask::array_or_all_chan($block->mask('all'))], - request => [$block->request('all')], - reply_format => [$block->reply_format('all')], - max_reply => $block->max_reply, - rate => $block->rate, - count_query => [$block->count_query('all')], - count_format => [$block->count_format('all')], - add => [$block->get('add', 'all')], - added_format => [$block->added_format('all')], - remove => [$block->remove('all')], - removed_format => [$block->removed_format('all')], - modifier => [$block->modifier('all')], - use_re => $block->use_re, - database => Tools::HashDB->new($block->file, - $block->file_encoding, - $block->use_re, - ($block->ignore_comment ? undef : sub {0;})), - }); - } + foreach my $blockname ($this->config->get($BLOCKS_NAME, 'all')) { + die "$blockname block name is reserved!" if $blockname eq $BLOCKS_NAME; + my $block = $this->config->get($blockname); + die "$blockname isn't block!" unless UNIVERSAL::isa($block, 'Configuration::Block'); + push(@{$this->{config}}, { + mask => [Mask::array_or_all_chan($block->mask('all'))], + request => [$block->request('all')], + reply_format => [$block->reply_format('all')], + max_reply => $block->max_reply, + rate => $block->rate, + count_query => [$block->count_query('all')], + count_format => [$block->count_format('all')], + add => [$block->get('add', 'all')], + added_format => [$block->added_format('all')], + remove => [$block->remove('all')], + removed_format => [$block->removed_format('all')], + modifier => [$block->modifier('all')], + use_re => $block->use_re, + database => Tools::HashDB->new( + $block->file, + $block->file_encoding, + $block->use_re, + ($block->ignore_comment ? undef : sub {0;})), + }); + } } sub message_arrived { - my ($this,$msg,$sender) = @_; - my @result = ($msg); - - my $return_value = sub { - return @result; - }; - - my ($get_ch_name,undef,undef,$reply_anywhere) - = Auto::Utils::generate_reply_closures($msg,$sender,\@result); - - if ($msg->command eq 'PRIVMSG') { - foreach my $block (@{$this->{config}}) { - # count - if (Mask::match_deep($block->{count_query}, $msg->param(1))) { - if (Mask::match_deep_chan($block->{mask}, $msg->prefix, $get_ch_name->())) { - # 登録数を求める - my $count = scalar $block->{database}->keys; - map { - $reply_anywhere->($_, 'count' => $count); - } @{$block->{count_format}}; - } - return $return_value->(); - } + my ($this,$msg,$sender) = @_; + my @result = ($msg); - my $msg_from_modifier_p = do { - !defined $msg->prefix || - Mask::match_deep_chan($block->{modifier}, $msg->prefix, $get_ch_name->()); - }; - - my $tail = $msg->param(1); - $tail =~ s/^\s*(.*)\s*$/$1/; - my $keyword; - ($keyword, $tail) = split(/\s+/, $tail, 2); - - if ($msg_from_modifier_p) { - # request - if (Mask::match_deep($block->{request}, $keyword)) { - foreach my $key (_search($block, $tail, $block->{max_reply})) { - foreach my $message (@{$block->{database}->get_array($key)}) { - map { - $reply_anywhere->($_, 'key' => $key, 'message' => $message); - } @{$block->{reply_format}}; + my $return_value = sub { + return @result; + }; + + my (undef,undef,undef,$reply_anywhere,$get_full_ch_name) + = Auto::Utils::generate_reply_closures($msg,$sender,\@result); + + if ($msg->command eq 'PRIVMSG') { + foreach my $block (@{$this->{config}}) { + # count : 登録数の計算 + if (Mask::match_deep($block->{count_query}, $msg->param(1))) { + if (Mask::match_deep_chan($block->{mask}, $msg->prefix, $get_full_ch_name->())) { + # 登録数を求める + my $count = scalar $block->{database}->keys; + map { + $reply_anywhere->($_, 'count' => $count); + } @{$block->{count_format}}; + } + return $return_value->(); } - } - return $return_value->(); - } - # add and remove - if (defined $tail) { - my ($key, $param) = split(/\s+/, $tail, 2); - if (Mask::match_deep($block->{add}, $keyword)) { - # 発言の追加 - # この人は変更を許可されている。 - if (defined $key && defined $param) { - $block->{database}->add_value($key, $param); - map { - $reply_anywhere->($_, 'key' => $key, 'message' => $param); - } @{$block->{added_format}}; + my $msg_from_modifier_p = do { + !defined $msg->prefix || + Mask::match_deep_chan($block->{modifier}, $msg->prefix, $get_full_ch_name->()); + }; + + my $tail = $msg->param(1); + $tail =~ s/^\s*(.*)\s*$/$1/; + my $keyword; + ($keyword, $tail) = split(/\s+/, $tail, 2); + + if ($msg_from_modifier_p) { + # request + if (Mask::match_deep($block->{request}, $keyword)) { + # 一致する反応をリストする + foreach my $key (_search($block, $tail, $block->{max_reply})) { + foreach my $message (@{$block->{database}->get_array($key)}) { + map { + $reply_anywhere->($_, 'key' => $key, 'message' => $message); + } @{$block->{reply_format}}; + } + } + return $return_value->(); + } + + # add and remove + if (defined $tail) { + my ($key, $param) = split(/\s+/, $tail, 2); + if (Mask::match_deep($block->{add}, $keyword)) { + # 発言の追加 + # この人は変更を許可されている。 + if (defined $key && defined $param) { + $block->{database}->add_value($key, $param); + map { + $reply_anywhere->($_, 'key' => $key, 'message' => $param); + } @{$block->{added_format}}; + } + return $return_value->(); + } elsif (Mask::match_deep($block->{remove}, $keyword)) { + # 発言の削除 + # この人は削除を許可されている。 + if (defined $key) { + my $count = $block->{database}->del_value($key, $param); + map { + $reply_anywhere->( + $_, + 'key' => $key, + 'message' => $param, + 'count' => $count); + } @{$block->{removed_format}}; + } + return $return_value->(); + } + } } - return $return_value->(); - } elsif (Mask::match_deep($block->{remove}, $keyword)) { - # 発言の削除 - # この人は削除を許可されている。 + + # match + my $key = (_search($block, $msg->param(1), 1, $block->{rate}))[0]; if (defined $key) { - my $count = $block->{database}->del_value($key, $param); - map { - $reply_anywhere->($_, 'key' => $key, 'message' => $param, 'count' => $count); - } @{$block->{removed_format}}; + $reply_anywhere->($block->{database}->get_value_random($key)); } - return $return_value->(); - } } - } - - # match - my $key = (_search($block, $msg->param(1), 1, $block->{rate}))[0]; - if (defined $key) { - $reply_anywhere->($block->{database}->get_value_random($key)); - } } - } - return @result; + return @result; } sub _search { - # key を検索する関数。 + # key を検索する関数。 - # $block : 検索対象のブロック - # $key : 検索するキー - # $count : 最大発見個数。省略すると全て。 - # $rate : 発見してもランダムに忘れる(笑)確率(パーセント)。省略すると100%。 - my ($block, $str, $count, $rate) = @_; - - my @masks; - foreach my $mask ($block->{database}->keys) { - if (Mask::match_array([$mask], $str, 1, $block->{use_re}, 0)) { - # match - if (!defined $rate || (int(rand() * hex('0xffffffff')) % 100) < $rate) { - push(@masks, $mask); - if (defined $count && $count <= scalar(@masks)) { - # $count 分発見したので終了。 - last; + # $block : 検索対象のブロック + # $key : 検索するキー + # $count : 最大発見個数。省略すると全て。 + # $rate : 発見してもランダムに忘れる(笑)確率(パーセント)。省略すると100%。 + my ($block, $str, $count, $rate) = @_; + + my @masks; + foreach my $mask ($block->{database}->keys) { + if (Mask::match_array([$mask], $str, 1, $block->{use_re}, 0)) { + # match + if (!defined $rate || (int(rand() * hex('0xffffffff')) % 100) < $rate) { + push(@masks, $mask); + if (defined $count && $count <= scalar(@masks)) { + # $count 分発見したので終了。 + last; + } + } } - } } - } - return @masks; + return @masks; } 1; diff -urN tiarra-20030728/module/Auto/Response.pm tiarra-20030731/module/Auto/Response.pm --- tiarra-20030728/module/Auto/Response.pm 2003-07-31 04:40:18.000000000 +0900 +++ tiarra-20030731/module/Auto/Response.pm 2003-07-31 18:29:15.000000000 +0900 @@ -1,5 +1,5 @@ # -*- cperl -*- -# $Clovery: tiarra/module/Auto/Response.pm,v 1.6 2003/03/23 06:11:44 topia Exp $ +# $Clovery: tiarra/module/Auto/Response.pm,v 1.7 2003/07/27 07:09:52 topia Exp $ # copyright (C) 2003 Topia . all rights reserved. package Auto::Response; use strict; @@ -32,15 +32,15 @@ if (@matches) { my ($callbacks) = []; Auto::AliasDB::CallbackUtils::register_extcallbacks($callbacks, $msg, $sender); - my ($get_ch_name,undef,undef,$reply_anywhere) + my (undef,undef,undef,$reply_anywhere,$get_full_ch_name) = Auto::Utils::generate_reply_closures($msg, $sender, \@result, undef, $callbacks); - if (Mask::match_deep_chan([$this->config->mask('all')],$msg->prefix, $get_ch_name->())) { + if (Mask::match_deep_chan([$this->config->mask('all')],$msg->prefix, $get_full_ch_name->())) { # 一致していた。 foreach my $match (@matches) { # maskが一致しなければ実行しない。飛ばす。 - my @mask = Tools::GroupDB::get_array($match, 'mask'); - next if (@mask && !Mask::match_deep_chan([@mask], $msg->prefix, $get_ch_name->())); + my $mask = Tools::GroupDB::get_array($match, 'mask'); + next if ($mask && !Mask::match_deep_chan($mask, $msg->prefix, $get_full_ch_name->())); # rate以下ならば実行しない。飛ばす。 my $rate = Tools::GroupDB::get_value($match, 'rate'); next unless !defined($rate) || (int(rand(100)) < $rate); diff -urN tiarra-20030728/module/Auto/Utils.pm tiarra-20030731/module/Auto/Utils.pm --- tiarra-20030728/module/Auto/Utils.pm 2003-07-31 04:40:18.000000000 +0900 +++ tiarra-20030731/module/Auto/Utils.pm 2003-07-31 18:29:15.000000000 +0900 @@ -1,7 +1,7 @@ # ----------------------------------------------------------------------------- -# $Id: Utils.pm,v 1.9 2003/07/03 13:49:24 admin Exp $ +# $Id: Utils.pm,v 1.10 2003/07/31 07:34:14 topia Exp $ # ----------------------------------------------------------------------------- -# $Clovery: tiarra/module/Auto/Utils.pm,v 1.12 2003/05/17 08:15:06 topia Exp $ +# $Clovery: tiarra/module/Auto/Utils.pm,v 1.16 2003/07/27 07:02:47 topia Exp $ package Auto::Utils; use strict; use warnings; @@ -10,170 +10,188 @@ use Multicast; use IRCMessage; -sub get_ch_name { - my ($msg, $ch_place) = @_; +# get_ch_name は get_raw_ch_name のエイリアス(過去互換のため) +*get_ch_name = \&get_raw_ch_name; +sub get_raw_ch_name { + # ネットワーク名抜きの送信先(チャンネル/nick)名 or undef を得る + my ($msg, $ch_place) = @_; - if (defined($msg->param($ch_place)) && $msg->param($ch_place) ne '') { - return(scalar(Multicast::detach($msg->param($ch_place)))); - } else { - return undef; - } + if (defined($msg->param($ch_place)) && $msg->param($ch_place) ne '') { + return(scalar(Multicast::detach($msg->param($ch_place)))); + } else { + return undef; + } } -sub sendto_channel_closure { - # チャンネル等に PRIVMSG / NOTICE を送るクロージャを返します。 +sub get_full_ch_name { + # ネットワーク名付きの送信先(チャンネル/nick)名 or undef を得る + my ($msg, $ch_place) = @_; - # - 引数 - - # $sendto : チャンネル名 or ニック。ネットワーク名を付けて下さい。 - # $command : 'PRIVMSG' or 'NOTICE'。その他のコマンドも制限はしませんが意味が無いでしょう。 - # $msg : message_arrivedに渡ってきた$msg。エイリアス置換に使用されます。よって、 - # 後述する $use_alias が false なら指定する必要はありません。 - # その場合は undef でも渡しておきましょう。 - # $sender : message_arrivedに渡ってきた$sender。送信に使います。必須。 - # $result : message_arrivedの返り値にする配列の参照。詳細は例を見ましょう。 - # $use_alias : エイリアス置き換えを行うかどうか。省略可、省略した場合は行う。 - # $extra_callbacks - # : 追加のエイリアス置換コールバック。省略可。 - # - # エイリアス置換・コールバックに関しては Auto::AliasDB を参照してください。 - # - # - 返り値 - - # $send_message - # $send_message - # : クロージャ。第一引数にメッセージ、第二引数以降に追加のエイリアス(省略可能)を指定して呼び出す。メッセージとしてundefが渡された場合は、何もせずに終了する。 - # - # - 使用例 - - # sub message_arrived { - # my ($this,$msg,$sender) = @_; - # my @result = ($msg); - # my $send_message = - # sendto_channel_closure('#test@ircnet', 'NOTICE', $msg, $sender, \@result); - # $send_message->('message', 'hoge' => 'moge'); - # return @result; - # } - # - - my ($sendto, $command, $msg, $sender, $result, $use_alias, $extra_callbacks) = @_; - - $use_alias = 1 unless defined $use_alias; - $extra_callbacks = [] unless defined $extra_callbacks; - - return sub { - my ($str,%extra_replaces) = @_; - return if !defined $str; - my $msg_to_send = - IRCMessage->new( - Command => $command, - Params => ['', # 後で設定 - ($use_alias ? Auto::AliasDB->shared->stdreplace_add( - $msg->prefix || $sender->fullname, - $str, - $extra_callbacks, - $msg, - $sender, - %extra_replaces) - : $str)]); - if ($sender->isa('IrcIO::Server')) { - # 鯖にはチャンネル名にネットワーク名を付けない。 - my $for_server = $msg_to_send->clone; - $for_server->param(0, scalar(Multicast::detach($sendto))); - $sender->send_message($for_server); - - # クライアントにはチャンネル名にネットワーク名を付ける。 - # また、クライアントに送られる時にはPrefixがそのユーザーに設定されるよう註釈を付ける。 - my $for_client = $msg_to_send->clone; - $for_client->param(0, $sendto); - $for_client->remark('fill-prefix-when-sending-to-client',1); - push @$result,$for_client; - } - elsif ($sender->isa('IrcIO::Client')) { - # チャンネル名にネットワーク名を付ける。 - my $for_server = $msg_to_send->clone; - $for_server->param(0, $sendto); - push @$result,$for_server; - - my $for_client = $msg_to_send->clone; - $for_client->prefix($sender->fullname); - $for_client->param(0, $sendto); - $sender->send_message($for_client); + if (defined($msg->param($ch_place)) && $msg->param($ch_place) ne '') { + return($msg->param($ch_place)); + } else { + return undef; } - }; +} + +sub sendto_channel_closure { + # チャンネル等に PRIVMSG / NOTICE を送るクロージャを返します。 + + # - 引数 - + # $sendto : チャンネル名 or ニック。ネットワーク名を付けて下さい。 + # $command : 'PRIVMSG' or 'NOTICE'。その他のコマンドも制限はしませんが意味が無いでしょう。 + # $msg : message_arrivedに渡ってきた$msg。エイリアス置換に使用されます。よって、 + # 後述する $use_alias が false なら指定する必要はありません。 + # その場合は undef でも渡しておきましょう。 + # $sender : message_arrivedに渡ってきた$sender。送信に使います。必須。 + # $result : message_arrivedの返り値にする配列の参照。詳細は例を見ましょう。 + # $use_alias : エイリアス置き換えを行うかどうか。省略可、省略した場合は行う。 + # $extra_callbacks + # : 追加のエイリアス置換コールバック。省略可。 + # + # エイリアス置換・コールバックに関しては Auto::AliasDB を参照してください。 + # + # - 返り値 - + # $send_message + # $send_message + # : クロージャ。第一引数にメッセージ、第二引数以降に追加のエイリアス(省略可能)を指定して呼び出す。 + # メッセージとしてundefが渡された場合は、何もせずに終了する。 + # + # - 使用例 - + # sub message_arrived { + # my ($this,$msg,$sender) = @_; + # my @result = ($msg); + # my $send_message = + # sendto_channel_closure('#test@ircnet', 'NOTICE', $msg, $sender, \@result); + # $send_message->('message', 'hoge' => 'moge'); + # return @result; + # } + # + + my ($sendto, $command, $msg, $sender, $result, $use_alias, $extra_callbacks) = @_; + + $use_alias = 1 unless defined $use_alias; + $extra_callbacks = [] unless defined $extra_callbacks; + + return sub { + my ($str,%extra_replaces) = @_; + return if !defined $str; + my $msg_to_send = IRCMessage->new( + Command => $command, + Params => ['', # 後で設定 + ($use_alias ? Auto::AliasDB->shared->stdreplace_add( + $msg->prefix || $sender->fullname, + $str, + $extra_callbacks, + $msg, + $sender, + %extra_replaces) + : $str)]); + if ($sender->isa('IrcIO::Server')) { + # 鯖にはチャンネル名にネットワーク名を付けない。 + my $for_server = $msg_to_send->clone; + $for_server->param(0, scalar(Multicast::detach($sendto))); + $sender->send_message($for_server); + + # クライアントにはチャンネル名にネットワーク名を付ける。 + # また、クライアントに送られる時にはPrefixがそのユーザーに設定されるよう註釈を付ける。 + my $for_client = $msg_to_send->clone; + $for_client->param(0, $sendto); + $for_client->remark('fill-prefix-when-sending-to-client',1); + push @$result,$for_client; + } elsif ($sender->isa('IrcIO::Client')) { + # チャンネル名にネットワーク名を付ける。 + my $for_server = $msg_to_send->clone; + $for_server->param(0, $sendto); + push @$result,$for_server; + + my $for_client = $msg_to_send->clone; + $for_client->prefix($sender->fullname); + $for_client->param(0, $sendto); + $sender->send_message($for_client); + } + }; } sub generate_reply_closures { - # 送信者に NOTICE で返答するクロージャを返します。 + # 送信者に NOTICE で返答するクロージャを返します。 - # - 引数 - - # $msg : message_arrivedに渡ってきた$msg。 - # $sender : message_arrivedに渡ってきた$sender。 - # $result : message_arrivedの返り値にする配列の参照。詳細は例を見ましょう。 - # $use_alias : エイリアス置き換えを行うかどうか。省略可、省略した場合は行う。 - # $extra_callbacks - # : 追加のエイリアス置換コールバック。省略可。 - # $ch_place : チャンネル名が存在する $msg->param 内部の位置を指定します。省略時は0(先頭)です。 - # - # エイリアス置換・コールバックに関しては Auto::AliasDB を参照してください。 - # - # - 返り値 - - # ($get_ch_name, $reply, $reply_as_priv, $reply_anywhere) - # $get_ch_name : クロージャ。ネットワーク名無しのチャンネル名 or undef を返します。 - # $reply : クロージャ。チャンネルに返答します。 - # $reply_as_priv : クロージャ。送信者に直接 priv で返答します。 - # $reply_anywhere : クロージャ。チャンネルが有効であれば $reply が、そうでなければ $reply_as_priv です。 - # - # $reply* は第一引数にメッセージ、第二引数以降に追加のエイリアス(省略可能)を指定して呼び出します。 - # 第一引数にundefが渡された場合は、何もせずに終了します。 - # - # - 使用例 - - # sub message_arrived { - # my ($this,$msg,$sender) = @_; - # my @result = ($msg); - # my ($get_ch_name, $reply, $reply_as_priv, $reply_anywhere) = - # sendto_channel_closure($msg, $sender, \@result); - # $reply_anywhere->('message', 'hoge' => 'moge'); - # return @result; - # } - # - # - 備考 - - # $get_ch_name がクロージャなのは過去との互換性のためです。 - - my ($msg, $sender, $result, $use_alias, $extra_callbacks, $ch_place) = @_; - $use_alias = 1 unless defined $use_alias; - $extra_callbacks = [] unless defined $extra_callbacks; - $ch_place = 0 unless defined $ch_place; - - my $ch_name = get_ch_name($msg, $ch_place); - my $get_ch_name = sub { - $ch_name; - }; - my $reply = sub { - sendto_channel_closure($msg->param($ch_place), 'NOTICE', $msg, $sender, $result, - $use_alias, $extra_callbacks)->(@_, 'channel' => $ch_name); - }; - my $reply_as_priv = sub { - my ($str, %extra_replaces) = @_; - return if !defined $str; - $sender->send_message( - IRCMessage->new( - Command => 'NOTICE', - Params => [$msg->nick, - ($use_alias ? Auto::AliasDB->shared->stdreplace_add( - $msg->prefix, - $str, - $extra_callbacks, - $msg, - $sender, - %extra_replaces) + # - 引数 - + # $msg : message_arrivedに渡ってきた$msg。 + # $sender : message_arrivedに渡ってきた$sender。 + # $result : message_arrivedの返り値にする配列の参照。詳細は例を見ましょう。 + # $use_alias : エイリアス置き換えを行うかどうか。省略可、省略した場合は行う。 + # $extra_callbacks + # : 追加のエイリアス置換コールバック。省略可。 + # $ch_place : チャンネル名が存在する $msg->param 内部の位置を指定します。省略時は0(先頭)です。 + # + # エイリアス置換・コールバックに関しては Auto::AliasDB を参照してください。 + # + # - 返り値 - + # ($get_raw_ch_name, $reply, $reply_as_priv, $reply_anywhere, $get_full_ch_name) + # $get_raw_ch_name : クロージャ。ネットワーク名無しのチャンネル名 or undef を返します。 + # $reply : クロージャ。チャンネルに返答します。 + # $reply_as_priv : クロージャ。送信者に直接 priv で返答します。 + # $reply_anywhere : クロージャ。チャンネルが有効であれば $reply が、そうでなければ $reply_as_priv です。 + # $get_full_ch_name : クロージャ。ネットワーク名付きのチャンネル名 or undef を返します。 + # + # $reply* は第一引数にメッセージ、第二引数以降に追加のエイリアス(省略可能)を指定して呼び出します。 + # 第一引数にundefが渡された場合は、何もせずに終了します。 + # + # - 使用例 - + # sub message_arrived { + # my ($this,$msg,$sender) = @_; + # my @result = ($msg); + # my ($get_ch_name, $reply, $reply_as_priv, $reply_anywhere) = + # sendto_channel_closure($msg, $sender, \@result); + # $reply_anywhere->('message', 'hoge' => 'moge'); + # return @result; + # } + # + # - 備考 - + # $get_raw_ch_name がクロージャなのは過去との互換性のため、 + # $get_full_ch_name がクロージャーなのは共通性のためです。 + + my ($msg, $sender, $result, $use_alias, $extra_callbacks, $ch_place) = @_; + $use_alias = 1 unless defined $use_alias; + $extra_callbacks = [] unless defined $extra_callbacks; + $ch_place = 0 unless defined $ch_place; + + my $raw_ch_name = get_raw_ch_name($msg, $ch_place); + my $get_raw_ch_name = sub { + $raw_ch_name; + }; + my $full_ch_name = get_full_ch_name($msg, $ch_place); + my $get_full_ch_name = sub { + $full_ch_name; + }; + my $reply = sub { + sendto_channel_closure($msg->param($ch_place), 'NOTICE', $msg, $sender, $result, + $use_alias, $extra_callbacks)->(@_, 'channel' => $raw_ch_name); + }; + my $reply_as_priv = sub { + my ($str, %extra_replaces) = @_; + return if !defined $str; + $sender->send_message(IRCMessage->new( + Command => 'NOTICE', + Params => [$msg->nick, + ($use_alias ? Auto::AliasDB->shared->stdreplace_add( + $msg->prefix, + $str, + $extra_callbacks, + $msg, + $sender, + %extra_replaces) : $str)])); - }; - my $reply_anywhere = sub { - if (defined($ch_name) && Multicast::nick_p($ch_name)) { - return $reply_as_priv; - } else { - return $reply; - } - }; - return ($get_ch_name,$reply,$reply_as_priv,$reply_anywhere->()); + }; + my $reply_anywhere = sub { + if (defined($raw_ch_name) && Multicast::nick_p($raw_ch_name)) { + return $reply_as_priv; + } else { + return $reply; + } + }; + return ($get_raw_ch_name,$reply,$reply_as_priv,$reply_anywhere->(),$get_full_ch_name); } 1; diff -urN tiarra-20030728/module/Tools/DateConvert.pm tiarra-20030731/module/Tools/DateConvert.pm --- tiarra-20030728/module/Tools/DateConvert.pm 2003-07-31 04:40:19.000000000 +0900 +++ tiarra-20030731/module/Tools/DateConvert.pm 2003-07-31 18:29:15.000000000 +0900 @@ -1,10 +1,10 @@ # ----------------------------------------------------------------------------- -# $Id: DateConvert.pm,v 1.1 2003/02/13 04:26:52 topia Exp $ +# $Id: DateConvert.pm,v 1.2 2003/07/31 07:34:14 topia Exp $ # ----------------------------------------------------------------------------- # これはTiarraモジュールではありません。 # %Yや%mなどを置換する機能を提供します。 # ----------------------------------------------------------------------------- -# $Clovery: tiarra/module/Tools/DateConvert.pm,v 1.3 2003/02/13 04:25:09 topia Exp $ +# $Clovery: tiarra/module/Tools/DateConvert.pm,v 1.4 2003/07/24 02:59:30 topia Exp $ # copyright (C) 2003 Topia . all rights reserved. # This module is supports POSIX strftime; based NetBSD libc strftime. @@ -16,14 +16,14 @@ use warnings; use Carp; -my $use_posix; +my ($can_use_posix, $use_posix); eval 'use POSIX'; unless ($@) { # successful loading POSIX; - $use_posix = 1; + $use_posix = $can_use_posix = 1; } else { - $use_posix = 0; - print "------can't use POSIX...\n$@\n------\n"; + $use_posix = $can_use_posix = 0; + print "------can't use POSIX...\n$@\n------\n"; } #constants; @@ -52,178 +52,199 @@ my ($TIMEZONE_OFFSET) = '+0900'; my (@AM_PM) = qw(AM PM); +sub import { + my $pkg = shift; + foreach (@_) { + if ($_ eq 'PurePerl') { + $use_posix = 0; + } + } +} + +sub unimport { + my $pkg = shift; + foreach (@_) { + if ($_ eq 'PurePerl') { + $use_posix = $can_use_posix; + carp 'can\'t use posix. no longer effective.' unless $use_posix; + } + } +} + sub force { - my ($posix) = @_; + my ($posix) = @_; - if (defined($posix)) { - if ($posix == 1) { # force use POSIX - $use_posix = 1; - } elsif ($posix == 0) { - $use_posix = 0; - } else { - croak 'force(posix) is only (0,1,undef) value.'; + carp 'this is old interface. use "use Tools::DateConvert qw(PurePerl);" instead.'; + + if (defined($posix)) { + if ($posix == 1) { # force use POSIX + $use_posix = 1; + } elsif ($posix == 0) { + $use_posix = 0; + } else { + croak 'force(posix) is only (0,1,undef) value.'; + } } - } } sub replace { - my ($str, $time) = @_; - $time = time() unless defined $time; - my (@times) = localtime($time); - my ($temp) = $time; + my ($str, $time) = @_; + $time = time() unless defined $time; + my (@times) = localtime($time); + my ($temp) = $time; - $str =~ s/%([+-]\d+[Oo]|.)/_replace_real($1, $time, \$temp, \@times)/eg; - return $str; + $str =~ s/%([+-]\d+[Oo]|.)/_replace_real($1, $time, \$temp, \@times)/eg; + return $str; } sub _replace_real { - my ($tag, $origtime, $time, $times) = @_; - my ($fmt) = '%02d'; - my ($data) = ''; - - if ($tag eq '%') { - $fmt = ''; - $data = $tag; - } elsif ($tag =~ /([+-]\d)?([Oo])/) { - # change times array.... - my ($number, $each); - $number = $1; - $each = $2; - $number = 0 unless defined $number; - - if ($each eq 'O') { # each day - $$time = $origtime + $number * 3600; - } else { # 'o', each second - $$time = $origtime + $number; - } - - @$times = localtime($$time); - $fmt = ''; - $data = ''; - } elsif ($use_posix == 1) { - $fmt = ''; - $data = POSIX::strftime('%' . $tag, @$times); - } else { - if ($tag eq 'A') { - $fmt = ''; - $data = @DAYS[$$times[$TIME_WDAY]] . 'day'; - } elsif ($tag eq 'a') { - $fmt = ''; - $data = substr(@DAYS[$$times[$TIME_WDAY]], 0, 3); - } elsif ($tag eq 'B') { - $fmt = ''; - $data = @MONTHS[$$times[$TIME_MON]]; - } elsif ($tag eq 'b' || $tag eq 'h') { - $fmt = ''; - $data = substr(@MONTHS[$$times[$TIME_MON]], 0, 3); - } elsif ($tag eq 'C') { - $data = ($$times[$TIME_YEAR] + $YEAROFFSET) / 100; - } elsif ($tag eq 'c') { - $fmt = ''; - $data = replace($FORMAT, $$time); - } elsif ($tag eq 'D') { - $fmt = ''; - $data = replace('%m/%d/%y', $$time); - } elsif ($tag eq 'd') { - $data = $$times[$TIME_DAY]; -# C99 locale modifiers: 'Ox' and 'Ex' is ommited. - } elsif ($tag eq 'e') { - $fmt = '%2d'; - $data = $$times[$TIME_DAY]; - } elsif ($tag eq 'F') { - $fmt = ''; - $data = replace('%Y-%m-%d', $$time); - } elsif ($tag eq 'H') { - $data = $$times[$TIME_HOUR]; - } elsif ($tag eq 'I') { - $data = $$times[$TIME_HOUR] % $HALF_HOURSPERDAY; - $data = 12 if $data == 0; - } elsif ($tag eq 'j') { - $fmt = '%03d'; - $data = $$times[$TIME_YDAY] + 1; - } elsif ($tag eq 'k') { - $fmt = '%2d'; - $data = $$times[$TIME_HOUR]; - } elsif ($tag eq 'l') { - $fmt = '%2d'; - $data = $$times[$TIME_HOUR] % $HALF_HOURSPERDAY; - $data = $HALF_HOURSPERDAY if $data == 0; - } elsif ($tag eq 'M') { - $data = $$times[$TIME_MIN]; - } elsif ($tag eq 'm') { - $data = $$times[$TIME_MON] + 1; - } elsif ($tag eq 'n') { - $fmt = ''; - $data = "\n"; - } elsif ($tag eq 'p') { - $fmt = ''; - if ($$times[$TIME_HOUR] < $HALF_HOURSPERDAY) { - $data = $AM_PM[0]; - } else { - $data = $AM_PM[1]; - } - } elsif ($tag eq 'R') { - $fmt = ''; - $data = replace('%H:%M', $$time); - } elsif ($tag eq 'r') { - $fmt = ''; - $data = replace('%I:%M:%S %p', $$time); - } elsif ($tag eq 'S') { - $data = $$times[$TIME_SEC]; - } elsif ($tag eq 's') { - $fmt = '%d'; - $data = $$time; - } elsif ($tag eq 'T') { - $fmt = ''; - $data = replace('%H:%M:%S', $$time); - } elsif ($tag eq 't') { - $fmt = ''; - $data = "\t"; - } elsif ($tag eq 'U') { - $data = ($$times[$TIME_YDAY] + $DAYSPERWEEK - $$times[$TIME_WDAY]) / $DAYSPERWEEK; - } elsif ($tag eq 'u') { - $fmt = '%d'; - $data = $$times[$TIME_WDAY]; - $data = $DAYSPERWEEK if $data == 0; - } elsif ($tag eq 'V' || $tag eq 'G' || $tag eq 'g') { - # not supported - $fmt = ''; - $data = ''; - } elsif ($tag eq 'v') { - $fmt = ''; - $data = replace('%e-%b-%Y', $$time); - } elsif ($tag eq 'W') { - $data = $$times[$TIME_WDAY]; - $data = $DAYSPERWEEK if $data == 0; - $data = ($$times[$TIME_YDAY] + $DAYSPERWEEK - $data - 1) / $DAYSPERWEEK; - } elsif ($tag eq 'w') { - $fmt = '%d'; - $data = $$times[$TIME_WDAY]; - } elsif ($tag eq 'X') { - $fmt = ''; - $data = replace($TIME_FORMAT, $$time); - } elsif ($tag eq 'x') { - $fmt = ''; - $data = replace($DATE_FORMAT, $$time); - } elsif ($tag eq 'y') { - $data = $$times[$TIME_YEAR] % 100; - } elsif ($tag eq 'Y') { - $fmt = '%d'; - $data = $$times[$TIME_YEAR] + $YEAROFFSET; - } elsif ($tag eq 'Z') { - $fmt = ''; - $data = $TIMEZONE_NAME; - } elsif ($tag eq 'z') { - $fmt = ''; - $data = $TIMEZONE_OFFSET; + my ($tag, $origtime, $time, $times) = @_; + my ($fmt) = '%02d'; + my ($data) = ''; + + if ($tag eq '%') { + $fmt = ''; + $data = $tag; + } elsif ($tag =~ /([+-]\d)?([Oo])/) { + # change times array.... + my ($number, $each); + $number = $1; + $each = $2; + $number = 0 unless defined $number; + + if ($each eq 'O') { # each day + $$time = $origtime + $number * 3600; + } else { # 'o', each second + $$time = $origtime + $number; + } + + @$times = localtime($$time); + $fmt = ''; + $data = ''; + } elsif ($use_posix == 1) { + $fmt = ''; + $data = POSIX::strftime('%' . $tag, @$times); } else { - $fmt = ''; - $data = ''; + if ($tag eq 'A') { + $fmt = ''; + $data = @DAYS[$$times[$TIME_WDAY]] . 'day'; + } elsif ($tag eq 'a') { + $fmt = ''; + $data = substr(@DAYS[$$times[$TIME_WDAY]], 0, 3); + } elsif ($tag eq 'B') { + $fmt = ''; + $data = @MONTHS[$$times[$TIME_MON]]; + } elsif ($tag eq 'b' || $tag eq 'h') { + $fmt = ''; + $data = substr(@MONTHS[$$times[$TIME_MON]], 0, 3); + } elsif ($tag eq 'C') { + $data = ($$times[$TIME_YEAR] + $YEAROFFSET) / 100; + } elsif ($tag eq 'c') { + $fmt = ''; + $data = replace($FORMAT, $$time); + } elsif ($tag eq 'D') { + $fmt = ''; + $data = replace('%m/%d/%y', $$time); + } elsif ($tag eq 'd') { + $data = $$times[$TIME_DAY]; + # C99 locale modifiers: 'Ox' and 'Ex' is ommited. + } elsif ($tag eq 'e') { + $fmt = '%2d'; + $data = $$times[$TIME_DAY]; + } elsif ($tag eq 'F') { + $fmt = ''; + $data = replace('%Y-%m-%d', $$time); + } elsif ($tag eq 'H') { + $data = $$times[$TIME_HOUR]; + } elsif ($tag eq 'I') { + $data = $$times[$TIME_HOUR] % $HALF_HOURSPERDAY; + $data = 12 if $data == 0; + } elsif ($tag eq 'j') { + $fmt = '%03d'; + $data = $$times[$TIME_YDAY] + 1; + } elsif ($tag eq 'k') { + $fmt = '%2d'; + $data = $$times[$TIME_HOUR]; + } elsif ($tag eq 'l') { + $fmt = '%2d'; + $data = $$times[$TIME_HOUR] % $HALF_HOURSPERDAY; + $data = $HALF_HOURSPERDAY if $data == 0; + } elsif ($tag eq 'M') { + $data = $$times[$TIME_MIN]; + } elsif ($tag eq 'm') { + $data = $$times[$TIME_MON] + 1; + } elsif ($tag eq 'n') { + $fmt = ''; + $data = "\n"; + } elsif ($tag eq 'p') { + $fmt = ''; + if ($$times[$TIME_HOUR] < $HALF_HOURSPERDAY) { + $data = $AM_PM[0]; + } else { + $data = $AM_PM[1]; + } + } elsif ($tag eq 'R') { + $fmt = ''; + $data = replace('%H:%M', $$time); + } elsif ($tag eq 'r') { + $fmt = ''; + $data = replace('%I:%M:%S %p', $$time); + } elsif ($tag eq 'S') { + $data = $$times[$TIME_SEC]; + } elsif ($tag eq 's') { + $fmt = '%d'; + $data = $$time; + } elsif ($tag eq 'T') { + $fmt = ''; + $data = replace('%H:%M:%S', $$time); + } elsif ($tag eq 't') { + $fmt = ''; + $data = "\t"; + } elsif ($tag eq 'U') { + $data = ($$times[$TIME_YDAY] + $DAYSPERWEEK - $$times[$TIME_WDAY]) / $DAYSPERWEEK; + } elsif ($tag eq 'u') { + $fmt = '%d'; + $data = $$times[$TIME_WDAY]; + $data = $DAYSPERWEEK if $data == 0; + } elsif ($tag eq 'V' || $tag eq 'G' || $tag eq 'g') { + # not supported + $fmt = ''; + $data = ''; + } elsif ($tag eq 'v') { + $fmt = ''; + $data = replace('%e-%b-%Y', $$time); + } elsif ($tag eq 'W') { + $data = $$times[$TIME_WDAY]; + $data = $DAYSPERWEEK if $data == 0; + $data = ($$times[$TIME_YDAY] + $DAYSPERWEEK - $data - 1) / $DAYSPERWEEK; + } elsif ($tag eq 'w') { + $fmt = '%d'; + $data = $$times[$TIME_WDAY]; + } elsif ($tag eq 'X') { + $fmt = ''; + $data = replace($TIME_FORMAT, $$time); + } elsif ($tag eq 'x') { + $fmt = ''; + $data = replace($DATE_FORMAT, $$time); + } elsif ($tag eq 'y') { + $data = $$times[$TIME_YEAR] % 100; + } elsif ($tag eq 'Y') { + $fmt = '%d'; + $data = $$times[$TIME_YEAR] + $YEAROFFSET; + } elsif ($tag eq 'Z') { + $fmt = ''; + $data = $TIMEZONE_NAME; + } elsif ($tag eq 'z') { + $fmt = ''; + $data = $TIMEZONE_OFFSET; + } else { + $fmt = ''; + $data = ''; + } } - } - return sprintf($fmt, $data) if $fmt ne ''; - return $data; + return sprintf($fmt, $data) if $fmt ne ''; + return $data; } 1; diff -urN tiarra-20030728/module/Tools/FileCache/EachFile.pm tiarra-20030731/module/Tools/FileCache/EachFile.pm --- tiarra-20030728/module/Tools/FileCache/EachFile.pm 2003-07-31 04:40:19.000000000 +0900 +++ tiarra-20030731/module/Tools/FileCache/EachFile.pm 2003-07-31 18:29:15.000000000 +0900 @@ -1,5 +1,5 @@ # -*- cperl -*- -# $Clovery: tiarra/module/Tools/FileCache/EachFile.pm,v 1.2 2003/03/14 06:17:18 topia Exp $ +# $Clovery: tiarra/module/Tools/FileCache/EachFile.pm,v 1.3 2003/07/24 03:03:29 topia Exp $ # copyright (C) 2003 Topia . all rights reserved. package Tools::FileCache::EachFile; use strict; @@ -12,115 +12,120 @@ my $timeout = 2.5 * 60; sub new { - my ($class, $parent, $fpath, $mode, $charset) = @_; + my ($class, $parent, $fpath, $mode, $charset) = @_; - my ($this) = - { - parent => $parent, - mode => undef, - database => undef, - refcount => 0, - expire => undef, + my ($this) = { + parent => $parent, + mode => undef, + database => undef, + refcount => 0, + expire => undef, }; - if ($mode =~ /raw/i) { - $this->{mode} = 'raw'; - $this->{database} = - Tools::LinedDB->new( - FilePath => $fpath, - Charset => $charset, - ); - } elsif ($mode =~ /std/i) { - $this->{mode} = 'std'; - $this->{database} = - Tools::LinedDB->new( - FilePath => $fpath, - Charset => $charset, - Parse => sub { - my ($line) = @_; - $line =~ s/^\s+//; - return () if $line =~ /^[\#\;]/; - $line =~ s/\s+$//; - return () if $line eq ''; - return $line; - }, - ); - } else { - croak 'can\'t understand type "' . $mode . '"'; - } + if ($mode =~ /raw/i) { + $this->{mode} = 'raw'; + $this->{database} = + Tools::LinedDB->new( + FilePath => $fpath, + Charset => $charset, + ); + } elsif ($mode =~ /std/i) { + $this->{mode} = 'std'; + $this->{database} = + Tools::LinedDB->new( + FilePath => $fpath, + Charset => $charset, + Parse => sub { + my ($line) = @_; + $line =~ s/^\s+//; + return () if $line =~ /^[\#\;]/; + $line =~ s/\s+$//; + return () if $line eq ''; + return $line; + }, + ); + } else { + croak 'can\'t understand type "' . $mode . '"'; + } - bless $this, $class; + bless $this, $class; - return $this; + return $this; } sub register { - my ($this) = @_; + my ($this) = @_; - $this->add_refcount(); - return $this; + $this->add_refcount(); + return $this; } sub unregister { - my ($this) = @_; + my ($this) = @_; - $this->del_refcount(); - return $this; + $this->del_refcount(); + return $this; } sub add_refcount { - my ($this) = @_; + my ($this) = @_; - return ++($this->{refcount}); + return ++($this->{refcount}); } sub del_refcount { - my ($this) = @_; + my ($this) = @_; - return --($this->{refcount}); + return --($this->{refcount}); } sub refcount { - my ($this) = @_; + my ($this) = @_; - return $this->{refcount}; + return $this->{refcount}; +} + +sub can_remove { + my $this = shift; + + return ($this->{refcount} <= 0); } sub set_expire { - my ($this) = @_; + my ($this) = @_; - $this->{expire} = time() + $timeout; - return $this; + $this->{expire} = time() + $timeout; + return $this; } sub expire { - my ($this) = @_; + my ($this) = @_; - return $this->{expire}; + return $this->{expire}; } sub clean { - my ($this) = @_; + my ($this) = @_; - $this->{database} = undef; + $this->{database} = undef; } sub AUTOLOAD { - my ($this, @args) = @_; + my ($this, @args) = @_; + + if ($AUTOLOAD =~ /::DESTROY$/) { + # DESTROYは伝達させない。 + return; + } + + (my $method = $AUTOLOAD) =~ s/.+?:://g; + + # define method + eval "sub $method { shift->{database}->$method(\@_); }"; - if ($AUTOLOAD =~ /::DESTROY$/) { - # DESTROYは伝達させない。 - return; - } - - (my $method = $AUTOLOAD) =~ s/.+?:://g; - if ($this->{database}->can($method)) { - $this->set_expire(); - return eval('$this->{database}->' . $method . '(@args)'); - } else { - croak 'Tools::LinedDB::' . $method . ' is can\'t call.'; - } + no strict 'refs'; + goto &$AUTOLOAD; } 1; diff -urN tiarra-20030728/module/Tools/FileCache.pm tiarra-20030731/module/Tools/FileCache.pm --- tiarra-20030728/module/Tools/FileCache.pm 2003-07-31 04:40:19.000000000 +0900 +++ tiarra-20030731/module/Tools/FileCache.pm 2003-07-31 18:29:15.000000000 +0900 @@ -1,6 +1,6 @@ # -*- cperl -*- # Tools::FileCache, Data shared file cache service. -# $Clovery: tiarra/module/Tools/FileCache.pm,v 1.2 2003/03/14 06:46:55 topia Exp $ +# $Clovery: tiarra/module/Tools/FileCache.pm,v 1.3 2003/07/24 03:06:34 topia Exp $ # copyright (C) 2003 Topia . all rights reserved. package Tools::FileCache; use strict; @@ -11,139 +11,144 @@ our $_shared; sub shared { - if (!defined $_shared) { - $_shared = Tools::FileCache->_new; - } + if (!defined $_shared) { + $_shared = Tools::FileCache->_new; + } - return $_shared; + return $_shared; } sub _new { - my ($class) = @_; - my ($this) = - { - files => {}, + my $class = shift; + my ($this) = { + files => {}, - timer => undef, + timer => undef, }; - bless $this, $class; + bless $this, $class; - return $this; + return $this; } sub find_file { - my ($this, $fpath, $mode, $charset) = @_; + my ($this, $fpath, $mode, $charset) = @_; - my $file = $this->{files}->{$fpath}; - if (defined($file)) { - my $obj = $file->{$mode}; - if (defined($obj)) { - return $obj; + my $file = $this->{files}->{$fpath}; + if (defined($file)) { + # とりあえずファイルは存在した。 + my $obj = $file->{$mode}; + if (defined($obj)) { + # そのモードも存在した。オブジェクトを返す。 + return $obj; + } else { + # そのモードは存在しなかった。登録して返す。 + return $this->_register_inner($fpath, $mode, $charset); + } } else { - return $this->_register_inner($fpath, $mode, $charset); + # ファイルは存在しない。登録して返す。 + return $this->_register_inner($fpath, $mode, $charset); } - } else { - return $this->_register_inner($fpath, $mode, $charset); - } } sub register { - my ($this, $fpath, $mode, $charset) = @_; + my ($this, $fpath, $mode, $charset) = @_; - my $file = $this->find_file($fpath, $mode, $charset); - if (defined $file) { - $file->register(); - return $file; - } else { - return undef; - } + my $file = $this->find_file($fpath, $mode, $charset); + if (defined $file) { + # ファイルがあった or ファイルを登録した。 + # 参照回数を増やして返す。 + $file->register(); + return $file; + } else { + # ファイルの登録が出来なかった。 + return undef; + } } sub unregister { - my ($this, $fpath) = @_; + my ($this, $fpath) = @_; - my $file = $this->{files}->{$fpath}; - if (defined($file)) { - $file->unregister(); - return 0; - } else { - croak('file "' . $fpath . '" has not registered yet!'); - } + my $file = $this->{files}->{$fpath}; + if (defined($file)) { + $file->unregister(); + return 0; + } else { + croak('file "' . $fpath . '" has not registered yet!'); + } } sub _register_inner { - my ($this, $fpath, $mode, $charset) = @_; + my ($this, $fpath, $mode, $charset) = @_; - my $obj = Tools::FileCache::EachFile->new($this, $fpath, $mode, $charset); - if (defined $obj) { - $this->{files}->{$fpath} = {} unless (defined($this->{files}->{$fpath})); - $this->{files}->{$fpath}->{$mode} = $obj; - $this->_install_timer(); - return $obj; - } else { - return undef; - } + my $obj = Tools::FileCache::EachFile->new($this, $fpath, $mode, $charset); + if (defined $obj) { + $this->{files}->{$fpath} = {} unless (defined($this->{files}->{$fpath})); + $this->{files}->{$fpath}->{$mode} = $obj; + $this->_install_timer(); + return $obj; + } else { + return undef; + } } sub main_loop { - my ($this) = @_; + my $this = shift; - # check expire - foreach my $key (keys(%{$this->{files}})) { - my $file = $this->{files}->{$key}; - foreach my $mode (keys(%$file)) { - my $obj = $file->{$mode}; - if ($obj->refcount() <= 0 && ($obj->expire() < time())) { - # expired. - $obj->clean(); - delete $this->{files}->{$key}->{$mode}; - } - } - if (scalar(keys(%$file)) == 0) { - delete $this->{files}->{$key}; - } - } - - # check struct-size - if (scalar(keys(%{$this->{files}})) == 0) { - $this->_uninstall_timer(); - } + # check expire + foreach my $key (keys(%{$this->{files}})) { + my $file = $this->{files}->{$key}; + foreach my $mode (keys(%$file)) { + my $obj = $file->{$mode}; + if ($obj->can_remove() && ($obj->expire() < time())) { + # expired. + $obj->clean(); + delete $this->{files}->{$key}->{$mode}; + } + } + if (scalar(keys(%$file)) == 0) { + delete $this->{files}->{$key}; + } + } + + # check struct-size + if (scalar(keys(%{$this->{files}})) == 0) { + $this->_uninstall_timer(); + } } # misc/timer sub _check_timer { - my ($this) = @_; + my $this = shift; - return defined($this->{timer}); + return defined($this->{timer}); } sub _install_timer { - my ($this) = @_; + my $this = shift; - unless ($this->_check_timer) { - $this->{timer} = - Timer->new( - Interval => 30, - Repeat => 1, - Code => sub { - my ($timer) = @_; - $this->main_loop(); - }, - )->install(); - } + unless ($this->_check_timer) { + $this->{timer} = Timer->new( + Interval => 30, + Repeat => 1, + Code => sub { + my $timer = shift; + $this->main_loop(); + }, + )->install(); + } - return 0; + return 0; } sub _uninstall_timer { - my ($this) = @_; + my $this = shift; - if ($this->_check_timer()) { - $this->{timer}->uninstall; - $this->{timer} = undef; - } + if ($this->_check_timer()) { + $this->{timer}->uninstall; + $this->{timer} = undef; + } - return 0; + return 0; } 1; diff -urN tiarra-20030728/module/Tools/HashDB.pm tiarra-20030731/module/Tools/HashDB.pm --- tiarra-20030728/module/Tools/HashDB.pm 2003-07-31 04:40:18.000000000 +0900 +++ tiarra-20030731/module/Tools/HashDB.pm 2003-07-31 18:29:15.000000000 +0900 @@ -1,5 +1,5 @@ # -*- cperl -*- -# $Clovery: tiarra/module/Tools/HashDB.pm,v 1.1 2003/05/23 11:29:41 topia Exp $ +# $Clovery: tiarra/module/Tools/HashDB.pm,v 1.2 2003/07/24 03:05:47 topia Exp $ # copyright (C) 2003 Topia . all rights reserved. # GroupDB の1レコード分のデータを保持する。 @@ -31,243 +31,242 @@ use Unicode::Japanese; use Mask; use Carp; +use Module::Use qw(Tools::HashTools); use Tools::HashTools; sub new { - # コンストラクタ + # コンストラクタ - # - 引数 - - # $fpath : 保存するファイルのパス。空ファイル or undef でファイルに関連付けられないDBが作成されます。 - # $charset : ファイルの文字セットを指定します。省略すれば UTF-8 になります。 - # $use_re : 値の検索/一致判定に正規表現拡張を使うかどうか。省略されれば使いません。 - # $ignore_proc - # : 無視する行を指定するクロージャ。行を引数に呼び出され、 true が返ればその行を無視します。 - # ここで ignore された行は解析さえ行いませんので、 - # $split_primary=0でも区切りと認識されたりはしません。 - # 一般的な注意として、この状態のデータベースが保存された場合は ignore された行は全て消滅します。 - - my ($class,$fpath,$charset,$use_re,$ignore_proc) = @_; - - my $obj = - { - time => undef, # ファイルの最終読み込み時刻 - fpath => $fpath, - charset => $charset || 'utf8', # ファイルの文字コード - use_re => $use_re || 0, - ignore_proc => $ignore_proc || sub { $_[0] =~ /^\s*#/; }, + # - 引数 - + # $fpath : 保存するファイルのパス。空ファイル or undef でファイルに関連付けられないDBが作成されます。 + # $charset : ファイルの文字セットを指定します。省略すれば UTF-8 になります。 + # $use_re : 値の検索/一致判定に正規表現拡張を使うかどうか。省略されれば使いません。 + # $ignore_proc + # : 無視する行を指定するクロージャ。行を引数に呼び出され、 true が返ればその行を無視します。 + # ここで ignore された行は解析さえ行いませんので、 + # $split_primary=0でも区切りと認識されたりはしません。 + # 一般的な注意として、この状態のデータベースが保存された場合は ignore された行は全て消滅します。 + + my ($class,$fpath,$charset,$use_re,$ignore_proc) = @_; + + my $obj = { + time => undef, # ファイルの最終読み込み時刻 + fpath => $fpath, + charset => $charset || 'utf8', # ファイルの文字コード + use_re => $use_re || 0, + ignore_proc => $ignore_proc || sub { $_[0] =~ /^\s*#/; }, - database => undef, # HASH + database => undef, # HASH }; - bless $obj,$class; - $obj->_load; + bless $obj,$class; + $obj->_load; } sub _load { - my $this = shift; - $this->{database} = {}; + my $this = shift; + $this->{database} = {}; - if (defined $this->{fpath} && $this->{fpath} ne '') { - my $fh = IO::File->new($this->{fpath},'r'); - if (defined $fh) { - my $unicode = Unicode::Japanese->new; - foreach (<$fh>) { - my $line = $unicode->set($_, $this->{charset})->get; - next if $this->{ignore_proc}->($line); - my ($key,$value) = grep {defined($_)} ($line =~ /^\s*(?:([^:]+?)\s*|:([^:]+?)):\s*(.+?)\s*$/); - if (!defined $key || $key eq '' || - !defined $value || $value eq '') { - # ignore + if (defined $this->{fpath} && $this->{fpath} ne '') { + my $fh = IO::File->new($this->{fpath},'r'); + if (defined $fh) { + my $unicode = Unicode::Japanese->new; + foreach (<$fh>) { + my $line = $unicode->set($_, $this->{charset})->get; + next if $this->{ignore_proc}->($line); + my ($key,$value) = grep {defined($_)} ($line =~ /^\s*(?:([^:]+?)\s*|:([^:]+?)):\s*(.+?)\s*$/); + if (!defined $key || $key eq '' || + !defined $value || $value eq '') { + # ignore + } else { + $key =~ s/ /:/g; # can use colon(:) on key, but cannot use space( ). + push(@{$this->{database}->{$key}}, $value); + } + } + $this->{time} = time(); } - else { - $key =~ s/ /:/g; # can use colon(:) on key, but cannot use space( ). - push(@{$this->{database}->{$key}}, $value); - } - } - $this->{time} = time(); } - } - return $this; + return $this; } sub checkupdate { - my $this = shift; + my $this = shift; - if (defined $this->{fpath} && $this->{fpath} ne '') { - my $stat = stat($this->{fpath}); + if (defined $this->{fpath} && $this->{fpath} ne '') { + my $stat = stat($this->{fpath}); - if (defined $stat && $stat->mtime > $this->{time}) { - $this->_load(); - return 1; + if (defined $stat && $stat->mtime > $this->{time}) { + $this->_load(); + return 1; + } } - } - return 0; + return 0; } sub synchronize { - my $this = shift; - if (defined $this->{fpath} && $this->{fpath} ne '') { - my $fh = IO::File->new($this->{fpath},'w'); - if (defined $fh) { - my $unicode = Unicode::Japanese->new; - while (my ($key,$values) = each %{$this->{database}}) { - $key =~ s/:/ /g; # can use colon(:) on key, but cannot use space( ). - # \s が先頭/最後にあった場合読み込みで消え去るのでそれを防止。 - $key = ':' . $key if ($key =~ /^\s/ || $key =~ /\s$/); - map { - my $line = "$key: " . $_ . "\n"; - $fh->print($unicode->set($line)->conv($this->{charset})); - } @$values - } - $this->{time} = time(); + my $this = shift; + if (defined $this->{fpath} && $this->{fpath} ne '') { + my $fh = IO::File->new($this->{fpath},'w'); + if (defined $fh) { + my $unicode = Unicode::Japanese->new; + while (my ($key,$values) = each %{$this->{database}}) { + $key =~ s/:/ /g; # can use colon(:) on key, but cannot use space( ). + # \s が先頭/最後にあった場合読み込みで消え去るのでそれを防止。 + $key = ':' . $key if ($key =~ /^\s/ || $key =~ /\s$/); + map { + my $line = "$key: " . $_ . "\n"; + $fh->print($unicode->set($line)->conv($this->{charset})); + } @$values + } + $this->{time} = time(); + } } - } - return $this; + return $this; } sub to_hashref { - my $this = shift; + my $this = shift; - $this->checkupdate(); + $this->checkupdate(); - return $this->{database}; + return $this->{database}; } sub keys { - my $this = shift; + my $this = shift; - $this->checkupdate(); + $this->checkupdate(); - return CORE::keys(%{$this->to_hashref}); + return CORE::keys(%{$this->to_hashref}); } sub values { - my $this = shift; + my $this = shift; - $this->checkupdate(); + $this->checkupdate(); - return CORE::values(%{$this->to_hashref}); + return CORE::values(%{$this->to_hashref}); } sub add_value { - # 値を追加する。 - # 成功すれば 1(true) が返る。 - # 不正なキーのため失敗した場合は 0(false) が返る。 + # 値を追加する。 + # 成功すれば 1(true) が返る。 + # 不正なキーのため失敗した場合は 0(false) が返る。 - my ($this, $key, $value) = @_; + my ($this, $key, $value) = @_; - return 0 if $key =~ / /; + return 0 if $key =~ / /; - $this->checkupdate(); + $this->checkupdate(); - my $values = $this->{database}->{$key}; - if (!defined $values) { - $values = []; - $this->{database}->{$key} = $values; - } - push @$values,$value; + my $values = $this->{database}->{$key}; + if (!defined $values) { + $values = []; + $this->{database}->{$key} = $values; + } + push @$values,$value; - $this->synchronize(); + $this->synchronize(); - return 1; + return 1; } sub del_value { - my ($this, $key, $value) = @_; + my ($this, $key, $value) = @_; - $this->checkupdate(); + $this->checkupdate(); - my $values = $this->{database}->{$key}; - if (defined $values) { - # あった。 - my ($count) = scalar @$values; - if (defined $value) { - @$values = grep { - $_ ne $value; - } @$values; - $count -= scalar(@$values); - # この項目が空になったら項目自体を削除 - if (@$values == 0) { - delete $this->{database}->{$key}; - } - } else { - # $value が指定されていない場合は項目削除 - delete $this->{database}->{$key}; - } + my $values = $this->{database}->{$key}; + if (defined $values) { + # あった。 + my ($count) = scalar @$values; + if (defined $value) { + @$values = grep { + $_ ne $value; + } @$values; + $count -= scalar(@$values); + # この項目が空になったら項目自体を削除 + if (@$values == 0) { + delete $this->{database}->{$key}; + } + } else { + # $value が指定されていない場合は項目削除 + delete $this->{database}->{$key}; + } - $this->synchronize(); + $this->synchronize(); - return $count; # deleted - } - return 0; # not deleted + return $count; # deleted + } + return 0; # not deleted } sub get_value_random { - my ($this, $key) = @_; + my ($this, $key) = @_; - $this->checkupdate(); - return Tools::HashTools::get_value_random($this->{database}, $key); + $this->checkupdate(); + return Tools::HashTools::get_value_random($this->{database}, $key); } sub get_value { - my ($this, $key) = @_; + my ($this, $key) = @_; - $this->checkupdate(); - return Tools::HashTools::get_value($this->{database}, $key); + $this->checkupdate(); + return Tools::HashTools::get_value($this->{database}, $key); } sub get_array { - my ($this, $key) = @_; + my ($this, $key) = @_; - $this->checkupdate(); - return Tools::HashTools::get_array($this->{database}, $key); + $this->checkupdate(); + return Tools::HashTools::get_array($this->{database}, $key); } # group misc functions sub dup_group { - # グループの複製を行います。 + # グループの複製を行います。 - my ($group) = @_; - my ($new_group) = {}; + my ($group) = @_; + my ($new_group) = {}; - return undef unless defined($group); + return undef unless defined($group); - map { - $new_group->{$_} = $group->{$_}; - } CORE::keys(%$group); + map { + $new_group->{$_} = $group->{$_}; + } CORE::keys(%$group); - return $new_group; + return $new_group; } sub concat_string_to_key { - # prefix や suffix を group の key に付加します。 + # prefix や suffix を group の key に付加します。 - # - 引数 - - # $group : グループ。 - # $prefix : prefix 文字列 ('to.' とか 'from.' とか) - # $suffix : suffix 文字列 - my ($group, $prefix, $suffix) = @_; - my ($new_group) = {}; - - $prefix = '' unless defined($prefix); - $suffix = '' unless defined($suffix); - - map { - $new_group->{$prefix . $_ . $suffix} = $group->{$_}; - } CORE::keys(%$group); + # - 引数 - + # $group : グループ。 + # $prefix : prefix 文字列 ('to.' とか 'from.' とか) + # $suffix : suffix 文字列 + my ($group, $prefix, $suffix) = @_; + my ($new_group) = {}; + + $prefix = '' unless defined($prefix); + $suffix = '' unless defined($suffix); + + map { + $new_group->{$prefix . $_ . $suffix} = $group->{$_}; + } CORE::keys(%$group); - return $new_group; + return $new_group; } # replace support functions sub replace_with_callbacks { - # マクロの置換を行なう。%optionalは置換に追加するキーと値の組みで、省略可。 - # $callbacksはgroup/optionalで置換できなかった際に呼び出されるコールバック関数のリファレンス。 - # optionalの値はSCALARでもARRAYでも良い。 - my ($this,$str,$callbacks,%optional) = @_; - my $main_table = %{$this->to_hashref}; - return Tools::HashTools::replace_recursive($str,[$main_table,\%optional],$callbacks); + # マクロの置換を行なう。%optionalは置換に追加するキーと値の組みで、省略可。 + # $callbacksはgroup/optionalで置換できなかった際に呼び出されるコールバック関数のリファレンス。 + # optionalの値はSCALARでもARRAYでも良い。 + my ($this,$str,$callbacks,%optional) = @_; + my $main_table = %{$this->to_hashref}; + return Tools::HashTools::replace_recursive($str,[$main_table,\%optional],$callbacks); } 1; diff -urN tiarra-20030728/module/Tools/HashTools.pm tiarra-20030731/module/Tools/HashTools.pm --- tiarra-20030728/module/Tools/HashTools.pm 2003-07-31 04:40:19.000000000 +0900 +++ tiarra-20030731/module/Tools/HashTools.pm 2003-07-31 18:29:15.000000000 +0900 @@ -1,5 +1,5 @@ # -*- cperl -*- -# $Clovery: tiarra/module/Tools/HashTools.pm,v 1.1 2003/05/23 11:22:54 topia Exp $ +# $Clovery: tiarra/module/Tools/HashTools.pm,v 1.2 2003/07/16 04:15:18 topia Exp $ # copyright (C) 2003 Topia . all rights reserved. # ハッシュをフォーマットする関数群。 @@ -7,153 +7,153 @@ package Tools::HashTools; sub get_value_random { - my ($hash, $key) = @_; + my ($hash, $key) = @_; - my $values = get_array($hash, $key); - if ($values) { - # 発見. どれか一つ選ぶ。 - my $idx = int(rand() * hex('0xffffffff')) % @$values; - return $values->[$idx]; - } - return undef; + my $values = get_array($hash, $key); + if ($values) { + # 発見. どれか一つ選ぶ。 + my $idx = int(rand() * hex('0xffffffff')) % @$values; + return $values->[$idx]; + } + return undef; } sub get_value { - my ($hash, $key) = @_; + my ($hash, $key) = @_; - my $values = get_array($hash, $key); - if ($values) { - # 発見. - return $values->[0]; - } - return undef; + my $values = get_array($hash, $key); + if ($values) { + # 発見. + return $values->[0]; + } + return undef; } sub get_array { - my ($hash, $key) = @_; + my ($hash, $key) = @_; - my $value = $hash->{$key}; - if (defined $value) { - # 発見 - if (ref($value) eq 'ARRAY') { - return $value; - } - else { - return [$value]; - } - last; - } - return (); + my $value = $hash->{$key}; + if (defined $value) { + # 発見 + if (ref($value) eq 'ARRAY') { + return $value; + } else { + return [$value]; + } + last; + } + return undef; } sub replace_recursive { - # ()がネスト可能な_replace. + # ()がネスト可能な_replace. - # ていうか ad hoc 過ぎる気がするなあ。良い解析方法無いかな。 + # ていうか ad hoc 過ぎる気がするなあ。良い解析方法無いかな。 - my ($str,$hashtables,$callbacks) = @_; + my ($str,$hashtables,$callbacks) = @_; - return '' if !defined($str) || ($str eq ''); + return '' if !defined($str) || ($str eq ''); - my $start = 0; - my $end; - my $pos; - while (($pos = $start = index($str, '#(', $start)) != -1) { - # 検索開始。 - my $level = 1; - do { - # こっかを探す。 - $end = index($str, ')', $pos + 1); - if ($end == -1) { - # こっかが無い。困ったことになったが、終わった後にこっかがあったことにして誤魔化そう。 - $str .= ')' x $level; - $end = length($str); - last; - } + my $start = 0; + my $end; + my $pos; + while (($pos = $start = index($str, '#(', $start)) != -1) { + # 検索開始。 + my $level = 1; + do { + # こっかを探す。 + $end = index($str, ')', $pos + 1); + if ($end == -1) { + # こっかが無い。困ったことになったが、終わった後にこっかがあったことにして誤魔化そう。 + $str .= ')'; + $end = length($str); + last; + } - # かっこを探す。 - my $next = index($str, '(', $pos + 2); - if ($next == -1 || $next > $end) { - # かっこが無かったか、こっかより後。階層レベルを減らして検索位置を次のこっかに移す。 - $pos = $end; - $level--; - } else { - # こっかより前にかっこがあった。階層レベルを増やして繰り返す。 - $pos = $next; - $level++; - } - } while ($level > 0); # 階層レベルが0になるまで繰り返し。 - # こっかの前までを抽出範囲とする。 - $end--; - #proc $start to $end - my $work = substr($str, $start + 2, $end - $start - 1); - $work = _replace($work,$hashtables,$callbacks); - substr($str, $start, $end - $start + 2) = $work; - $start = $start + length($work); - } + # かっこを探す。 + my $next = index($str, '(', $pos + 2); + if ($next == -1 || $next > $end) { + # かっこが無かったか、こっかより後。階層レベルを減らして検索位置を次のこっかに移す。 + $pos = $end; + $level--; + } else { + # こっかより前にかっこがあった。階層レベルを増やして繰り返す。 + $pos = $next; + $level++; + } + } while ($level > 0); # 階層レベルが0になるまで繰り返し。 + # こっかの前までを抽出範囲とする。 + $end--; + #proc $start to $end + my $work = substr($str, $start + 2, $end - $start - 1); + $work = _replace($work,$hashtables,$callbacks); + substr($str, $start, $end - $start + 2) = $work; + $start = $start + length($work); + } - return $str; + return $str; } sub _replace { - my ($str,$hashtables,$callbacks) = @_; + my ($str,$hashtables,$callbacks) = @_; - foreach my $variable (split /\|/,$str) { - my ($key, $format) = split(/;/,$variable,2); - my ($ret) = undef; - if (defined($key) && $key ne '') { - foreach my $table (@$hashtables) { - $ret = get_value($table, $key); - last if (defined $ret); - } - if (!defined $ret) { - # not found. - foreach my $callback (@$callbacks) { - if (defined $callback) { - # callback function definition: func($key, [hashtables], [callbacks]); - my $value = $callback->($key, $hashtables, $callbacks); - if (defined $value) { - $ret = $value; - last; + # variables := variable ( '|' variable )* + # variable := key ( ';' format )? + foreach my $variable (split /\|/,$str) { + my ($key, $format) = split(/;/,$variable,2); + my ($ret) = undef; + if (defined($key) && $key ne '') { + foreach my $table (@$hashtables) { + $ret = get_value($table, $key); + last if (defined $ret); + } + if (!defined $ret) { + # not found. + foreach my $callback (@$callbacks) { + if (defined $callback) { + # callback function definition: func($key, [hashtables], [callbacks]); + my $value = $callback->($key, $hashtables, $callbacks); + if (defined $value) { + $ret = $value; + last; + } + } + } + } + } else { + # callback等がエラーを吐くので強制的に''を入れる。 + $ret = ''; + } + if (defined $ret) { + if (defined $format) { + return _format($format,$ret,$hashtables,$callbacks); + } else { + return $ret; } - } } - } - } else { - # callback等がエラーを吐くので強制的に''を入れる。 - $ret = ''; } - if (defined $ret) { - if (defined $format) { - return _format($format,$ret,$hashtables,$callbacks); - } - else { - return $ret; - } - } - } - # 最終的に見付からなければ$strそのものを返す。 - return $str; + # 最終的に見付からなければ$strそのものを返す。 + return $str; } sub _format { - # %s形式の値をフォーマットする。 - # replace_recursiveを呼び出して再帰変換も行う。 - my ($str,$value,$hashtables,$callbacks) = @_; - - $str = replace_recursive($str,$hashtables,$callbacks); - $str =~ s/%./_format_percent($1, $value)/eg; - return $str; + # %s形式の値をフォーマットする。 + # replace_recursiveを呼び出して再帰変換も行う。 + my ($str,$value,$hashtables,$callbacks) = @_; + + $str = replace_recursive($str,$hashtables,$callbacks); + $str =~ s/%(.)/_format_percent($1, $value)/eg; + return $str; } sub _format_percent { - $char = shift; + $char = shift; - if ($char eq 's') { - return @_[0]; - } else { - return $char; - } + if ($char eq 's') { + return $_[0]; + } else { + return $char; + } } 1; diff -urN tiarra-20030728/module/Tools/MailSend/EachServer.pm tiarra-20030731/module/Tools/MailSend/EachServer.pm --- tiarra-20030728/module/Tools/MailSend/EachServer.pm 2003-07-31 04:40:19.000000000 +0900 +++ tiarra-20030731/module/Tools/MailSend/EachServer.pm 2003-07-31 18:29:15.000000000 +0900 @@ -1,5 +1,5 @@ # -*- cperl -*- -# $Clovery: tiarra/module/Tools/MailSend/EachServer.pm,v 1.4 2003/03/10 01:30:20 topia Exp $ +# $Clovery: tiarra/module/Tools/MailSend/EachServer.pm,v 1.6 2003/07/27 08:09:04 topia Exp $ # copyright (C) 2003 Topia . all rights reserved. package Tools::MailSend::EachServer; use strict; @@ -20,113 +20,110 @@ my $DATA_TYPE_INNER_ITER = 1; sub new { - my ($class, %data) = @_; + my ($class, %data) = @_; - return undef unless defined($data{'cleaner'}); + return undef unless defined($data{'cleaner'}); - my $this = - { - use_pop3 => 0, - pop3_host => 'localhost', - pop3_port => getservbyname('pop3', 'tcp') || 110, - pop3_user => (getpwuid($>))[0], - pop3_pass => '', - pop3_expire => 0, + my $this = { + use_pop3 => 0, + pop3_host => 'localhost', + pop3_port => getservbyname('pop3', 'tcp') || 110, + pop3_user => (getpwuid($>))[0], + pop3_pass => '', + pop3_expire => 0, - smtp_host => 'localhost', - smtp_port => getservbyname('smtp', 'tcp') || 25, - smtp_fqdn => 'localhost', + smtp_host => 'localhost', + smtp_port => getservbyname('smtp', 'tcp') || 25, + smtp_fqdn => 'localhost', - # cleaner is destruction function. - cleaner => undef, + # cleaner is destruction function. + cleaner => undef, - # parent local datas - local => undef, + # parent local datas + local => undef, - expire_time => undef, - state => undef, - # undef: not found - # other: $STATE_* + expire_time => undef, + state => undef, + # undef: not found + # other: $STATE_* - local_state => undef, - # undef: not found - # other: unknown. + local_state => undef, + # undef: not found + # other: unknown. - queue => [], + queue => [], - sock => undef, + sock => undef, - esmtp_capable => [], + esmtp_capable => [], - hook => undef, + hook => undef, - timer => undef, + timer => undef, }; - # failsafe timer - $this->{timer} = - Timer->new( - Interval => 5, - Repeat => 1, - Code => sub { - my ($timer) = @_; - $this->main_loop(); - } - )->install; + # failsafe timer + $this->{timer} = + Timer->new( + Interval => 5, + Repeat => 1, + Code => sub { + my ($timer) = @_; + $this->main_loop(); + } + )->install; - bless $this, $class; + bless $this, $class; - foreach my $key (keys %data) { - $this->_set_data($key, $data{$key}); - } + foreach my $key (keys %data) { + $this->_set_data($key, $data{$key}); + } - return $this; + return $this; } #--- constant --- sub DATA_TYPES { - return - { - array => $DATA_TYPE_ARRAY, - inner_iter => $DATA_TYPE_INNER_ITER, + return { + array => $DATA_TYPE_ARRAY, # data に送信行の raw data を渡す。 + inner_iter => $DATA_TYPE_INNER_ITER, # data にコールバック関数を渡す。 }; } #--- server info --- sub get_data { - my ($this, $name) = @_; + my ($this, $name) = @_; - return undef unless - grep {$name eq $_} - (qw(local cleaner use_pop3), - (map { 'pop3_' . $_ } qw(host port user pass expire)), - (map { 'smtp_' . $_ } qw(host port fqdn))); - return $this->{$name}; + return undef unless + grep {$name eq $_} + (qw(local cleaner use_pop3), + (map { 'pop3_' . $_ } qw(host port user pass expire)), + (map { 'smtp_' . $_ } qw(host port fqdn))); + return $this->{$name}; } sub _set_data { - my ($this, $name, $value) = @_; + my ($this, $name, $value) = @_; - return undef unless - grep {$name eq $_} - (qw(local cleaner use_pop3), - (map { 'pop3_' . $_ } qw(host port user pass expire)), - (map { 'smtp_' . $_ } qw(host port fqdn))); + return undef unless + grep {$name eq $_} + (qw(local cleaner use_pop3), + (map { 'pop3_' . $_ } qw(host port user pass expire)), + (map { 'smtp_' . $_ } qw(host port fqdn))); - $this->{$name} = $value; - return 1; + $this->{$name} = $value; + return 1; } sub mail_send_reserve { - my ($this, %arg) = @_; + my ($this, %arg) = @_; - return 1 unless $arg{'env_from'}; - return 1 unless $arg{'env_to'}; - return 1 unless $arg{'data'}; + return 1 unless $arg{'env_from'}; + return 1 unless $arg{'env_to'}; + return 1 unless $arg{'data'}; - push(@{$this->{queue}}, - { + push(@{$this->{queue}}, { # local local => $arg{'local'}, @@ -165,377 +162,388 @@ # reply fatal reply_fatal => $arg{'reply_fatal'} || \&_do_nothing, - }); - # if state is undef (not processing), start. - $this->{state} = $STATE_NONE unless defined($this->{state}); - # continue_loop - $this->main_loop(); + }); + # if state is undef (not processing), start. + $this->{state} = $STATE_NONE unless defined($this->{state}); + # continue_loop + $this->main_loop(); - return 0; + return 0; } sub _do_nothing { - # noop func + # noop func } sub clean { - my ($this) = @_; + my ($this) = @_; - $this->{cleaner}->($this); - undef $this->{cleaner}; - $this->{hook}->uninstall if defined($this->{hook}); - $this->{hook} = undef; - $this->{timer}->uninstall if defined($this->{timer}); - $this->{timer} = undef; + $this->{cleaner}->($this); + undef $this->{cleaner}; + $this->{hook}->uninstall if defined($this->{hook}); + $this->{hook} = undef; + $this->{timer}->uninstall if defined($this->{timer}); + $this->{timer} = undef; } sub main_loop { - my ($this) = @_; - my ($state) = $this->{state}; + my ($this) = @_; + my ($state) = $this->{state}; - if (!defined($state)) { - # if undef, nothing to process - if (!defined($this->{expire_time}) || $this->{expire_time} < time()) { - return $this->clean(); + if (!defined($state)) { + # if undef, nothing to process + if (!defined($this->{expire_time}) || $this->{expire_time} < time()) { + return $this->clean(); + } + return; } - return; - } - # activate hook - if (!defined($this->{hook})) { - $this->{hook} = - RunLoop::Hook-> - new(sub { + # activate hook + if (!defined($this->{hook})) { + $this->{hook} = RunLoop::Hook->new( + sub { my ($hook) = @_; $this->main_loop(); - })->install('before-select'); - } + })->install('before-select'); + } - if ($state == $STATE_NONE) { - $state = $STATE_SMTP; # fallback - if ($this->{use_pop3} && !defined($this->{expire_time})) { - $state = $STATE_POP3; + if ($state == $STATE_NONE) { + $state = $STATE_SMTP; # fallback + if ($this->{use_pop3} && !defined($this->{expire_time})) { + $state = $STATE_POP3; + } } - } - $this->{state} = $state; + $this->{state} = $state; - if ($state == $STATE_POP3) { - $this->_state_pop3(); - } elsif ($state == $STATE_SMTP) { - $this->_state_smtp(); - } + if ($state == $STATE_POP3) { + $this->_state_pop3(); + } elsif ($state == $STATE_SMTP) { + $this->_state_smtp(); + } } # --- pop3 --- sub _state_pop3 { - my ($this) = @_; + my ($this) = @_; - if (!defined($this->{sock})) { - $this->{sock} = $this->_open_pop3(); if (!defined($this->{sock})) { - ::printmsg('mesmail: warn: cannot connect pop3, but start smtp :-)'); - $this->{state} = $STATE_SMTP; - return; - } else { - $this->{local_state} = 'FIRST'; + $this->{sock} = $this->_open_pop3(); + if (!defined($this->{sock})) { + RunLoop->shared->notify_warn('mesmail: cannot connect pop3, but start smtp.'); + $this->{state} = $STATE_SMTP; + return; + } else { + $this->{local_state} = 'FIRST'; + } } - } - while ($this->_do_pop3()) { - # noop - }; + while ($this->_do_pop3()) { + # noop + }; } sub _open_pop3 { - my ($this) = @_; - my ($host, $port, $sock); + my ($this) = @_; + my ($host, $port, $sock); - $host = $this->{pop3_host}; - $port = $this->{pop3_port}; + $host = $this->{pop3_host}; + $port = $this->{pop3_port}; - $sock = LinedINETSocket->new->connect($host, $port); + $sock = LinedINETSocket->new($E_MAIL_EOL)->connect($host, $port); - return undef unless (defined $sock); - return $sock; + return undef unless (defined $sock); + return $sock; } sub _do_pop3 { - my ($this) = @_; - my ($local_state) = $this->{local_state}; - my ($sock) = $this->{sock}; - - # wait +OK - my ($line) = $sock->pop_queue(); - return 0 unless defined($line); # none data received - if (substr($line, 0, 3) ne '+OK') { - # error - ::printmsg('mesmail: warn: pop3 send command "' . $local_state . '" reply is not OK...'); - ::printmsg('mesmail: warn: message is ' . $line); - ::printmsg('mesmail: warn: but start smtp :-)'); - $this->_close_pop3(); - return undef; - } else { - if ($local_state eq 'FIRST') { - # send USER - $this->{local_state} = 'USER'; - $sock->send_reserve('USER ' . $this->{pop3_user}); - } elsif ($local_state eq 'USER') { - # send PASS - $this->{local_state} = 'PASS'; - $sock->send_reserve('PASS ' . $this->{pop3_pass}); - } elsif ($local_state eq 'PASS') { - # send STAT - $this->{local_state} = 'STAT'; - $sock->send_reserve("STAT"); - } elsif ($local_state eq 'STAT') { - # close pop3 - $this->{expire_time} = time() + ($this->{pop3_expire} * 60); - $this->_close_pop3(); - return 0; + my ($this) = @_; + my ($local_state) = $this->{local_state}; + my ($sock) = $this->{sock}; + + # wait +OK + my ($line) = $sock->pop_queue(); + return 0 unless defined($line); # none data received + if (substr($line, 0, 3) ne '+OK') { + # error + RunLoop->shared->notify_warn('mesmail: pop3 send command "'.$local_state.'" reply is not OK...'); + RunLoop->shared->notify_warn('mesmail: message is ' . $line); + RunLoop->shared->notify_warn('mesmail: but start smtp.'); + $this->_close_pop3(); + return undef; + } else { + if ($local_state eq 'FIRST') { + # send USER + $this->{local_state} = 'USER'; + $sock->send_reserve('USER ' . $this->{pop3_user}); + } elsif ($local_state eq 'USER') { + # send PASS + $this->{local_state} = 'PASS'; + $sock->send_reserve('PASS ' . $this->{pop3_pass}); + } elsif ($local_state eq 'PASS') { + # send STAT + $this->{local_state} = 'STAT'; + $sock->send_reserve("STAT"); + } elsif ($local_state eq 'STAT') { + # close pop3 + $this->{expire_time} = time() + ($this->{pop3_expire} * 60); + $this->_close_pop3(); + return 0; + } + return 1; } - return 1; - } - return 0; # this return is not used + return 0; # this return is not used } sub _close_pop3 { - my ($this) = @_; - my ($sock) = $this->{sock}; + my ($this) = @_; + my ($sock) = $this->{sock}; - $sock->send_reserve('QUIT'); - $sock->disconnect_after_writing(); - $sock->flush(); # flush - $this->{sock} = undef; - $this->{local_state} = undef; - $this->{state} = $STATE_SMTP; + $sock->send_reserve('QUIT'); + $sock->disconnect_after_writing(); + $sock->flush(); # flush + $this->{sock} = undef; + $this->{local_state} = undef; + $this->{state} = $STATE_SMTP; - $this->main_loop(); + $this->main_loop(); - return undef; + return undef; } # --- smtp --- sub _state_smtp { - my ($this) = @_; + my ($this) = @_; - if (!defined($this->{sock})) { - $this->{sock} = $this->_open_smtp(); if (!defined($this->{sock})) { - $this->_reply_smtp_error(undef, 'CONNECT'); # undef is all - $this->{state} = undef; - return; - } else { - $this->{local_state} = 'FIRST'; + $this->{sock} = $this->_open_smtp(); + if (!defined($this->{sock})) { + $this->_reply_smtp_error(undef, 'CONNECT'); # undef is all + $this->{state} = undef; + return; + } else { + $this->{local_state} = 'FIRST'; + } + } + while ($this->_do_smtp()) { + # noop } - } - while ($this->_do_smtp()) { - # noop - } } sub _open_smtp { - my ($this) = @_; - my ($host, $port, $sock); + my ($this) = @_; + my ($host, $port, $sock); - $host = $this->{smtp_host}; - $port = $this->{smtp_port}; + $host = $this->{smtp_host}; + $port = $this->{smtp_port}; - $sock = LinedINETSocket->new->connect($host, $port); + $sock = LinedINETSocket->new($E_MAIL_EOL)->connect($host, $port); - return undef unless (defined $sock); - return $sock; + return undef unless (defined $sock); + return $sock; } sub _do_smtp { - my ($this, $input) = @_; - my ($local_state) = $this->{local_state}; - my ($sock) = $this->{sock}; - my $line; + my ($this, $input) = @_; + my ($local_state) = $this->{local_state}; + my ($sock) = $this->{sock}; + my $line; - if (defined($input)) { - $line = $input; - } else { - $line = $sock->pop_queue(); - } - return 1 unless defined($line); # queue is empty - my ($reply) = substr($line, 0, 4); - if ($local_state eq 'FIRST') { - # first reply: server info. - if ($reply eq '220 ') { - # message end - $this->{local_state} = 'EHLO'; - $sock->send_reserve('EHLO ' . $this->{smtp_fqdn}); - } else { - # error - $this->_reply_smtp_error(undef, $local_state, $line); # all stack - $this->_close_smtp(); - $this->clean(); - } - } elsif ($local_state eq 'EHLO') { - if ($reply eq '250-') { - push(@{$this->{esmtp_capable}}, substr($line, 5)); - } elsif ($reply eq '250 ') { - # end of esmtp capable - push(@{$this->{esmtp_capable}}, substr($line, 5)); - # ここでHELOと処理を一本化するためにSTART_MAILとしてrecursive. - $this->{local_state} = 'START_MAIL'; - return $this->_do_smtp('THROUGH'); + if (defined($input)) { + $line = $input; } else { - # error. use HELO instead of EHLO - $this->{local_state} = 'HELO'; - $sock->send_reserve('HELO ' . $this->{smtp_fqdn}); - } - } elsif ($local_state eq 'HELO') { - if ($reply eq '250 ') { - # ここでEHLOと処理を一本化するためにSTART_MAILとしてrecursive. - $this->{local_state} = 'START_MAIL'; - return $this->_do_smtp('THROUGH'); - } else { - # error - $this->_reply_smtp_error(undef, $local_state, $line); # all stack - $this->_close_smtp(); - $this->clean(); - } - } elsif ($local_state eq 'START_MAIL') { - # initialize mail - - $this->{queue}->[0]->{rcpt_ok_addrs} = 0; - $this->{queue}->[0]->{to_seps} = [@{$this->{queue}->[0]->{env_to}}]; # duplicate - - $this->{local_state} = 'MAILFROM'; - $sock->send_reserve('MAIL FROM:<' . $this->{queue}->[0]->{env_from} . '>'); - } elsif ($local_state eq 'MAILFROM') { - if ($reply eq '250 ') { - # initialize rcpt - my ($newaddr) = shift(@{$this->{queue}->[0]->{to_seps}}); - $this->{local_state} = 'RCPTTO'; - $sock->send_reserve('RCPT TO:<' . $newaddr . '>'); - } else { - #error - $this->_reply_smtp_error(0, $local_state, $line); - return $this->_smtp_send_final(); # smtp mail send が終了したものとみなす。 - } - } elsif ($local_state eq 'RCPTTO') { - my ($newaddr); - if ($reply eq '551 ') { - # more simple - $line =~ /\<([^\<\>]*)\>/; - $newaddr = $1; - } elsif ($reply =~ /25[01] /) { - $this->{queue}->[0]->{rcpt_ok_addrs}++; - $newaddr = shift(@{$this->{queue}->[0]->{to_seps}}); - } else { - # error - $line =~ /\<([^\<\>]*)\>/; # use mail_address entry for error msg. - $this->_reply_smtp_error(0, $local_state, $line, $1); - # 無視して次へ。 - $newaddr = shift(@{$this->{queue}->[0]->{to_seps}}); - } - if (defined($newaddr)) { - $sock->send_reserve('RCPT TO:<' . $newaddr . '>'); - } else { - if ($this->{queue}->[0]->{rcpt_ok_addrs}) { - # ok. - $this->{local_state} = 'DATA'; - $sock->send_reserve('DATA'); - } else { - # no rcpt addrs. - # error は既にメッセージを返している。 - $this->_reply_smtp_error(0, 'NORCPTTO'); - return $this->_smtp_send_final(); # smtp mail send が終了したものとみなす。 - } + $line = $sock->pop_queue(); } - } elsif ($local_state eq 'DATA') { - if ($reply eq '354 ') { - # go ahead - my ($struct) = $this->{queue}->[0]; - - $sock->send_reserve('To: ' . $struct->{to}); - foreach my $send_line - (&mime_unstructured_header_array("Subject: " . - Unicode::Japanese->new($struct->{subject})->euc)) { - $sock->send_reserve($send_line); - } - $sock->send_reserve('MIME-Version: 1.0'); - $sock->send_reserve('Content-Type: text/plain; charset=iso-2022-jp'); - $sock->send_reserve('Content-Transfer-Encoding: 7bit'); - $sock->send_reserve('Message-Id: <'.time().int(rand()*1000000).".$$.".$struct->{env_from}.'>'); - $sock->send_reserve('Date: ' . Tools::DateConvert::replace('%a, %d %b %Y %H:%M:%S %z', time())); - $sock->send_reserve('From: ' . $struct->{from}) if defined($struct->{from}); - $sock->send_reserve(''); - - my ($socksend) = sub { - foreach my $send_line (@_) { - $send_line =~ s/[\x0d\x0a]+//; - $send_line = '..=' if $send_line eq '.'; - $sock->send_reserve(Unicode::Japanese->new($send_line)->h2zKana->jis); - } - $sock->flush(); - }; - - if ($struct->{data_type} == $DATA_TYPE_ARRAY) { - $socksend->(@$struct->{data}); - } elsif ($struct->{data_type} == $DATA_TYPE_INNER_ITER) { - $struct->{data}->($struct, $socksend); - } + return 1 unless defined($line); # queue is empty + my ($reply) = substr($line, 0, 4); + if ($local_state eq 'FIRST') { + # first reply: server info. + if ($reply eq '220 ') { + # message end + $this->{local_state} = 'EHLO'; + $sock->send_reserve('EHLO ' . $this->{smtp_fqdn}); + } else { + # error + $this->_reply_smtp_error(undef, $local_state, $line); # all stack + $this->_close_smtp(); + $this->clean(); + } + } elsif ($local_state eq 'EHLO') { + if ($reply eq '250-') { + push(@{$this->{esmtp_capable}}, substr($line, 5)); + } elsif ($reply eq '250 ') { + # end of esmtp capable + push(@{$this->{esmtp_capable}}, substr($line, 5)); + # ここでHELOと処理を一本化するためにSTART_MAILとしてrecursive. + $this->{local_state} = 'START_MAIL'; + return $this->_do_smtp('THROUGH'); + } else { + # error. use HELO instead of EHLO + $this->{local_state} = 'HELO'; + $sock->send_reserve('HELO ' . $this->{smtp_fqdn}); + } + } elsif ($local_state eq 'HELO') { + if ($reply eq '250 ') { + # ここでEHLOと処理を一本化するためにSTART_MAILとしてrecursive. + $this->{local_state} = 'START_MAIL'; + return $this->_do_smtp('THROUGH'); + } else { + # error + $this->_reply_smtp_error(undef, $local_state, $line); # all stack + $this->_close_smtp(); + $this->clean(); + } + } elsif ($local_state eq 'START_MAIL') { + # initialize mail - $sock->send_reserve('.'); - $this->{local_state} = 'FINISH'; - } else { - $this->_reply_smtp_error(0, $local_state, $line); - } - } elsif ($local_state eq 'FINISH') { - if ($reply eq '250 ') { - # finalize - $this->_reply_smtp_ok(0); - return $this->_smtp_send_final(); + $this->{queue}->[0]->{rcpt_ok_addrs} = 0; + $this->{queue}->[0]->{to_seps} = [@{$this->{queue}->[0]->{env_to}}]; # duplicate + + $this->{local_state} = 'MAILFROM'; + $sock->send_reserve('MAIL FROM:<' . $this->{queue}->[0]->{env_from} . '>'); + } elsif ($local_state eq 'MAILFROM') { + if ($reply eq '250 ') { + # initialize rcpt + my ($newaddr) = shift(@{$this->{queue}->[0]->{to_seps}}); + $this->{local_state} = 'RCPTTO'; + $sock->send_reserve('RCPT TO:<' . $newaddr . '>'); + } else { + #error + $this->_reply_smtp_error(0, $local_state, $line); + return $this->_smtp_send_final(); # smtp mail send が終了したものとみなす。 + } + } elsif ($local_state eq 'RCPTTO') { + my ($newaddr); + if ($reply eq '551 ') { + # more simple + $line =~ /\<([^\<\>]*)\>/; + $newaddr = $1; + } elsif ($reply =~ /25[01] /) { + $this->{queue}->[0]->{rcpt_ok_addrs}++; + $newaddr = shift(@{$this->{queue}->[0]->{to_seps}}); + } else { + # error + $line =~ /\<([^\<\>]*)\>/; # use mail_address entry for error msg. + $this->_reply_smtp_error(0, $local_state, $line, $1); + # 無視して次へ。 + $newaddr = shift(@{$this->{queue}->[0]->{to_seps}}); + } + if (defined($newaddr)) { + $sock->send_reserve('RCPT TO:<' . $newaddr . '>'); + } else { + if ($this->{queue}->[0]->{rcpt_ok_addrs}) { + # ok. + $this->{local_state} = 'DATA'; + $sock->send_reserve('DATA'); + } else { + # no rcpt addrs. + # error は既にメッセージを返している。 + $this->_reply_smtp_error(0, 'NORCPTTO'); + return $this->_smtp_send_final(); # smtp mail send が終了したものとみなす。 + } + } + } elsif ($local_state eq 'DATA') { + if ($reply eq '354 ') { + # go ahead + my ($struct) = $this->{queue}->[0]; + + $sock->send_reserve('To: ' . $struct->{to}); + foreach my $send_line + (&mime_unstructured_header_array( + "Subject: " . Unicode::Japanese->new($struct->{subject})->euc)) { + $sock->send_reserve($send_line); + } + $sock->send_reserve('MIME-Version: 1.0'); + $sock->send_reserve('Content-Type: text/plain; charset=iso-2022-jp'); + $sock->send_reserve('Content-Transfer-Encoding: 7bit'); + $sock->send_reserve('Message-Id: ' . do { + # message-id := '<' time(epoc) rand-value '.' pid '.' envelope-from '>' + # time := epoc time (now) + # rand-value := [0-9]{,6} + # pid := [1-9][0-9]* + # envelope-from := email-addr + # example: Message-Id: <1046695839413024.2151.topia@clovery.jp> + '<' . time().int(rand()*1000000).".$$.".$struct->{env_from}.'>'; + }); + $sock->send_reserve('Date: ' . do { + # example: Tue, 04 Mar 2003 11:10:24 +0900 + Tools::DateConvert::replace('%a, %d %b %Y %H:%M:%S %z', time()); + }); + $sock->send_reserve('From: ' . $struct->{from}) if defined($struct->{from}); + $sock->send_reserve(''); + + my ($socksend) = sub { + foreach my $send_line (@_) { + $send_line =~ s/[\x0d\x0a]+//; + $send_line = '..=' if $send_line eq '.'; + $sock->send_reserve(Unicode::Japanese->new($send_line)->h2zKana->jis); + } + $sock->flush(); + }; + + if ($struct->{data_type} == $DATA_TYPE_ARRAY) { + $socksend->(@$struct->{data}); + } elsif ($struct->{data_type} == $DATA_TYPE_INNER_ITER) { + $struct->{data}->($struct, $socksend); + } + + $sock->send_reserve('.'); + $this->{local_state} = 'FINISH'; + } else { + $this->_reply_smtp_error(0, $local_state, $line); + } + } elsif ($local_state eq 'FINISH') { + if ($reply eq '250 ') { + # finalize + $this->_reply_smtp_ok(0); + return $this->_smtp_send_final(); + } else { + # error + $this->_reply_smtp_error(0, $local_state, $line); + return $this->_smtp_send_final(); + } } else { - # error - $this->_reply_smtp_error(0, $local_state, $line); - return $this->_smtp_send_final(); + die 'unknown LOCAL_STATE "' . $local_state . '".'; } - } else { - die 'unknown LOCAL_STATE "' . $local_state . '".'; - } - return 1; + + return 1; } sub _smtp_send_final { - my ($this) = @_; + my ($this) = @_; - shift(@{$this->{queue}}); - if (@{$this->{queue}}) { - # more queue. - if (scalar(@{$this->{queue}}) != 1 && (grep {$_->{priority} != 0} @{$this->{queue}})) { - # have key having priority. and queue isn't single. - @{$this->{queue}} = sort { $a->{priority} <=> $b->{priority}} @{$this->{queue}}; - } - # START_MAILにしてrecursive. - $this->{local_state} = 'START_MAIL'; - return $this->_do_smtp('THROUGH'); - } else { - # close smtp - $this->_close_smtp(); - $this->{hook}->uninstall; - $this->{hook} = undef; - } + shift(@{$this->{queue}}); + if (@{$this->{queue}}) { + # more queue. + if (scalar(@{$this->{queue}}) != 1 && (grep {$_->{priority} != 0} @{$this->{queue}})) { + # have key having priority. and queue isn't single. + @{$this->{queue}} = sort { $a->{priority} <=> $b->{priority}} @{$this->{queue}}; + } + # START_MAILにしてrecursive. + $this->{local_state} = 'START_MAIL'; + return $this->_do_smtp('THROUGH'); + } else { + # close smtp + $this->_close_smtp(); + $this->{hook}->uninstall; + $this->{hook} = undef; + } } sub _close_smtp { - my ($this) = @_; - my ($sock) = $this->{sock}; + my ($this) = @_; + my ($sock) = $this->{sock}; - $sock->send_reserve('QUIT'); - $sock->disconnect_after_writing(); - $sock->flush(); # flush - $this->{sock} = undef; - $this->{local_state} = undef; - $this->{state} = undef; - $this->{esmtp_capable} = []; + $sock->send_reserve('QUIT'); + $sock->disconnect_after_writing(); + $sock->flush(); # flush + $this->{sock} = undef; + $this->{local_state} = undef; + $this->{state} = undef; + $this->{esmtp_capable} = []; - return undef; + return undef; } sub _reply_smtp_error { diff -urN tiarra-20030728/module/Tools/MailSend.pm tiarra-20030731/module/Tools/MailSend.pm --- tiarra-20030728/module/Tools/MailSend.pm 2003-07-31 04:40:19.000000000 +0900 +++ tiarra-20030731/module/Tools/MailSend.pm 2003-07-31 18:29:15.000000000 +0900 @@ -1,13 +1,15 @@ # -*- cperl -*- -# $Clovery: tiarra/module/Tools/MailSend.pm,v 1.1 2003/03/03 13:32:25 topia Exp $ +# $Clovery: tiarra/module/Tools/MailSend.pm,v 1.2 2003/07/24 03:05:20 topia Exp $ # copyright (C) 2003 Topia . all rights reserved. + +# メール送信ラッパ。複数のサーバに非同期で送信する。 +# 実体は Tools::MailSend::EachServer に記述してあり、これはコントロールクラスである。 + package Tools::MailSend; use strict; use warnings; -use Module::Use qw(Tools::DateConvert Tools::MailSend::EachServer); -use Tools::DateConvert; +use Module::Use qw(Tools::MailSend::EachServer); use Tools::MailSend::EachServer; -use LinedINETSocket; our $_shared; sub shared { @@ -34,6 +36,9 @@ } sub mail_send { + # メール送信を行う。 + # 既存のサーバを探し(なければ作る)、それに丸投げします。 + my ($this, %arg) = @_; my ($server) = $this->_get_server(%arg); diff -urN tiarra-20030728/sample.conf tiarra-20030731/sample.conf --- tiarra-20030728/sample.conf 2003-07-31 04:40:13.000000000 +0900 +++ tiarra-20030731/sample.conf 2003-07-31 18:29:13.000000000 +0900 @@ -1,6 +1,6 @@ # -*- tiarra-conf -*- # ----------------------------------------------------------------------------- -# $Id: sample.conf,v 1.54 2003/07/24 05:01:29 admin Exp $ +# $Id: sample.conf,v 1.55 2003/07/31 07:34:13 topia Exp $ # ----------------------------------------------------------------------------- # tiarra.conf サンプル # @@ -564,8 +564,9 @@ # 実際の削除方法は「 <削除するキーワード>」です。 remove: ゐみくじ削除 - # addとremoveを許可する人。省略された場合は「*!*@*」と見做します。 - modifier: *!*@* + # addとremoveを許可する人。省略された場合は誰も変更できません。 + modifier: * *!*@* + # plum: modifier: *!*@* } } @@ -642,7 +643,8 @@ # データファイルのフォーマット # | pattern: re:^(こん(に)?ちは) # | rate: 90 - # | mask: *!*@* + # | mask: * *!*@* + # | #plum: mask: *!*@* # | response: こんにちは。 # | response: いらっしゃいませ。 # | @@ -661,7 +663,7 @@ # 使用を許可する人&チャンネルのマスク。 mask: * *!*@* - # [plum-mode] mask: +*!*@* + # plum: mask: +*!*@* } - Channel::Freeze {