diff -urN tiarra-20030804/ChangeLog tiarra-20030812/ChangeLog --- tiarra-20030804/ChangeLog 2003-08-06 10:12:58.000000000 +0900 +++ tiarra-20030812/ChangeLog 2003-08-15 12:08:57.000000000 +0900 @@ -1,3 +1,29 @@ +2003-08-12 phonohawk + + * main/FunctionalVariable.pm: + 追加。与えられた任意のハンドラを変数にtieする。 + 通常のtieとの違いは、ハンドラを変数毎に関数リファで指定する点。 + + * main/Hook.pm: + フックの一般的な定義。このファイルはクラスHookとクラスHookTargetを定義する。 + + * main/Configuration.pm: + リロードした時、フック`reloaded'を呼ぶ。 + + * main/Multicast.pm: + シングルサーバーモード対応。 + forward_to_serverやlocal_to_globalを動的スコープのフラグで乗っ取る等、 + 最早スパゲティどころではない。ジャングル。 + + * main/RunLoop.pm: + シングルサーバーモード対応。 + このモードでは、同時に接続出来るサーバーの数が一つに限定され、 + チャンネル名等にネットワーク名が付加されなくなる。 + + * main/IrcIO/Client.pm: + _inform_joinning_channelsをプライベートメソッドでなくした。 + 新しいメソッド名はinform_joinning_channels。 + 2003-08-04 phonohawk * makedoc: @@ -780,7 +806,7 @@ * これ以前のログは書いていません。 -# Id: $Id: ChangeLog,v 1.96 2003/08/04 09:29:21 admin Exp $ +# Id: $Id: ChangeLog,v 1.97 2003/08/12 01:45:35 admin Exp $ # Author: $Author: admin $ -# Date: $Date: 2003/08/04 09:29:21 $ -# Revision: $Revision: 1.96 $ +# Date: $Date: 2003/08/12 01:45:35 $ +# Revision: $Revision: 1.97 $ diff -urN tiarra-20030804/NEWS tiarra-20030812/NEWS --- tiarra-20030804/NEWS 2003-08-06 10:12:58.000000000 +0900 +++ tiarra-20030812/NEWS 2003-08-15 12:08:57.000000000 +0900 @@ -1,3 +1,10 @@ +2003-08-12 phonohawk + + * シングルサーバーモードを実装。 + networks/multi-server-modeを0に設定すると、シングルサーバーモードになります。 + この状態では同時に接続出来るサーバーの数が一つに制限され、クライアントから見た + チャンネル名にネットワーク名が付かなくなります。 + 2003-07-31 Topia * mask のチャンネル名にネットワーク名を必要とするように修正した。 @@ -86,4 +93,3 @@ * Auto/Random.pm: 設定ファイルの形式がかなり変わっています。 sample.conf を参照して書き換えをお願いします。 - diff -urN tiarra-20030804/main/Configuration.pm tiarra-20030812/main/Configuration.pm --- tiarra-20030804/main/Configuration.pm 2003-08-06 10:12:59.000000000 +0900 +++ tiarra-20030812/main/Configuration.pm 2003-08-15 12:08:57.000000000 +0900 @@ -1,5 +1,8 @@ # ----------------------------------------------------------------------------- -# $Id: Configuration.pm,v 1.20 2003/04/25 13:27:54 admin Exp $ +# $Id: Configuration.pm,v 1.21 2003/08/12 01:45:35 admin Exp $ +# ----------------------------------------------------------------------------- +# このクラスはフック`reloaded'を用意します。 +# フック`reloaded'は、設定ファイルがリロードされた時に呼ばれます。 # ----------------------------------------------------------------------------- package Configuration; # Configuration及びConfiguration::BlockはUTF-8バイト列でデータを保持します。 @@ -11,6 +14,8 @@ use Configuration::Preprocessor; use Configuration::Parser; use Configuration::Block; +use Hook; +our @ISA = 'HookTarget'; our $AUTOLOAD; our $_shared_instance; # 値を取得するにはgetメソッドを用いる他、エントリ名をそのままメソッドとして呼ぶ事も出来ます。 @@ -88,6 +93,7 @@ # ファイル名の代わりにIO::Handleのオブジェクトを渡しても良い。 # その場合はリロードは不可能になる。 my ($this,$conf_file) = @_; + my $this_is_reload = !defined $conf_file; if (defined $conf_file) { if (ref($conf_file) && UNIVERSAL::isa($conf_file,'IO::Handle')) { @@ -163,6 +169,11 @@ # $thisに登録する事で確定する。 $this->{blocks} = $blocks; $this->{modules} = $modules; + + # リロードした場合はフックを呼ぶ。 + if ($this_is_reload) { + $this->call_hooks('reloaded'); + } } @@ -179,6 +190,7 @@ networks => { 'name' => 'main', # defaultのデフォルト値は特殊なので後で別処理。 + 'multi-server-mode' => 1, 'channel-network-separator' => '@', 'action-when-disconnected' => 'part-and-join', }, @@ -302,4 +314,19 @@ return $this->get($key); } +# ----------------------------------------------------------------------------- +package Configuration::Hook; +use FunctionalVariable; +use base 'Hook'; + +our $HOOK_TARGET_NAME = 'Configuration'; +our @HOOK_NAME_CANDIDATES = 'reloaded'; +our $HOOK_TARGET_DEFAULT; +FunctionalVariable::tie( + \$HOOK_TARGET_DEFAULT, + FETCH => sub { + Configuration->shared; + }, +); + 1; diff -urN tiarra-20030804/main/FunctionalVariable.pm tiarra-20030812/main/FunctionalVariable.pm --- tiarra-20030804/main/FunctionalVariable.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20030812/main/FunctionalVariable.pm 2003-08-15 12:08:58.000000000 +0900 @@ -0,0 +1,98 @@ +# ----------------------------------------------------------------------------- +# $Id: FunctionalVariable.pm,v 1.1 2003/08/12 01:45:35 admin Exp $ +# ----------------------------------------------------------------------------- +# FunctionalVariableは、与えられた任意の関数リファレンスを呼ぶように +# 変数に処理関数をtieする事が出来ます。Tie::Scalarとの違いは、処理関数を +# コンパイル時ではなく、生成時に決められる事です。 +# ----------------------------------------------------------------------------- +# 使い方: +# +# スカラー変数に割り当てる場合: +# my $foo; +# FunctionalVariable::tie( +# \$foo, +# FETCH => sub { +# # FETCHは省略可能 +# return 500; +# }, +# STORE => sub { +# # STOREも省略可能 +# print shift; +# }, +# ); +# print "$foo\n"; # "500\n"を出力 +# $foo = 10; # "10"を出力 +# ----------------------------------------------------------------------------- +# 内部動作: +# +# FunctionalVariable::tieを実行すると、その変数にはFunctionalVariable型の +# オブジェクトがtieされる。FunctionalVariable::FETCHその他は、tie実行時に +# 指定された関数に実際の処理を委譲する。 +# ----------------------------------------------------------------------------- +package FunctionalVariable; +use strict; +use warnings; +use Carp; + +sub tie { + # $variable: tieする変数への参照 + # @functions: 関数群 + my ($variable, @functions) = @_; + + # @functionsの検査 + my $functions = eval { + my $funcs = {@functions}; + while (my ($key, $value) = each %$funcs) { + if (ref($value) ne 'CODE') { + die "FunctionalVariable->tie, Arg[1]{$key} is not a function ref.\n"; + } + } + $funcs; + }; if ($@) { + croak $@; + } + + my $this = { + variable => $variable, + type => ref($variable), + functions => $functions, + }; + + if ($this->{type} eq 'SCALAR') { + tie $$variable, 'FunctionalVariable', $this; + } + elsif ($this->{type} eq '') { + croak "FunctionalVariable->tie, Arg[0] was not a ref.\n"; + } + else { + croak "FunctionalVariable->tie, Arg[0] was bad ref: $this->{type}\n"; + } +} + +sub TIESCALAR { + my ($class, $this) = @_; + bless $this => $class; +} + +sub FETCH { + my ($this) = @_; + my $f = $this->{functions}{'FETCH'}; + if (defined $f) { + $f->(); + } + else { + # FETCHが定義されていないのなら、undefでも返す他無い。 + undef; + } +} + +sub STORE { + my ($this, $value) = @_; + my $f = $this->{functions}{'STORE'}; + if (defined $f) { + $f->($value); + } + # STOREが定義されていないのなら、何もしない。 +} + +1; diff -urN tiarra-20030804/main/Hook.pm tiarra-20030812/main/Hook.pm --- tiarra-20030804/main/Hook.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20030812/main/Hook.pm 2003-08-15 12:08:57.000000000 +0900 @@ -0,0 +1,220 @@ +# ----------------------------------------------------------------------------- +# $Id: Hook.pm,v 1.1 2003/08/12 01:45:35 admin Exp $ +# ----------------------------------------------------------------------------- +# Hook: あらゆるフックのベースクラス +# HookTarget: あらゆるフック先のベースクラス +# ----------------------------------------------------------------------------- +# Hookの使い方: +# +# パッケージ変数 $HOOK_TARGET_NAME, @HOOK_NAME_CANDIDATES, +# $HOOK_NAME_DEFAULT, $HOOK_TARGET_DEFAULT を定義する +# 各変数の意味は次の通り +# +# $HOOK_TARGET_NAME: +# このフックをかける先のパッケージ名。 +# +# @HOOK_NAME_CANDIDATES: +# フック名として許される名前の候補。 +# +# $HOOK_NAME_DEFAULT: +# フック名が省略された場合のデフォルト値。 +# これは省略可能で、省略した場合はフック名の候補の個数が +# 2つ以上である場合に限り、フック名の省略が不可能になる。 +# +# $HOOK_TARGET_DEFAULT: +# フックを掛ける対象のオブジェクトが省略された場合のデフォルト値。 +# これは省略可能で、 +# +# これらの変数を定義し、Hookを@ISAに入れたパッケージを作る。 +# ----------------------------------------------------------------------------- +# HookTargetの使い方: +# +# HookTargetを@ISAに入れたクラスを作る。コンストラクタでの配慮は不要。 +# $obj->call_hooks($hook_name)で、インストールされた全てのフックを呼ぶ。 +# +# 現在の実装では、HookTargetはオブジェクトをハッシュで持つクラスでのみ使用可能。 +# また、`installed-hooks'と云うキーを勝手に使う。 +# ----------------------------------------------------------------------------- +package Hook; +use strict; +use warnings; +use Carp; +use UNIVERSAL; + +sub new { + my ($class, $code) = @_; + my $this = { + target => undef, + target_package_name => undef, + hook_name => undef, + + code => $code, + }; + + if (!defined $code) { + croak $class."->new, Arg[0] was undef.\n"; + } + elsif (ref($code) ne 'CODE') { + croak $class."->new, Arg[0] was bad type.\n"; + } + + do { + no strict; + no warnings; + + local *symtable = eval "\*${class}::"; + if (defined ${$symtable{HOOK_TARGET_NAME}}) { + $this->{target_package_name} = ${$symtable{HOOK_TARGET_NAME}}; + } + else { + croak "${class}->new, \$${class}::HOOK_TARGET_NAME undefined.\n"; + } + + if (@{$symtable{HOOK_NAME_CANDIDATES}} == 0) { + croak "${class}->new, \@${class}::HOOK_NAME_CANDIDATES undefined.\n"; + } + }; + + bless $this, $class; +} + +sub install { + my ($this, $hook_name, $target) = @_; + + if (defined $this->{target}) { + croak ref($this)."->install, this hook is already installed.\n"; + } + + do { + no strict; + + local *symtable = eval "\*${\ref($this)}::"; + if (!defined $hook_name) { + # @HOOK_NAME_CANDIDATESの個数は1つか？ + # それとも$HOOK_NAME_DEFAULTは定義されているか？ + if (@{$symtable{HOOK_NAME_CANDIDATES}} == 1) { + $hook_name = $symtable{HOOK_NAME_CANDIDATES}->[0]; + } + elsif (defined ${$symtable{HOOK_NAME_DEFAULT}}) { + $hook_name = ${$symtable{HOOK_NAME_DEFAULT}}; + } + else { + croak ref($this)."->install, you can't omit the hook name.\n"; + } + } + + # $hook_nameは本当にフック名として許されているか？ + if (!{map {$_ => 1} @{$symtable{HOOK_NAME_CANDIDATES}}}->{$hook_name}) { + croak ref($this)."->install, hook `$hook_name' is not available.\n"; + } + + if (!defined $target) { + # $HOOK_TARGET_DEFAULTは定義されているか？ + if (defined ${$symtable{HOOK_TARGET_DEFAULT}}) { + $target = ${$symtable{HOOK_TARGET_DEFAULT}}; + } + else { + croak ref($this)."->install, you can't omit the hook target.\n"; + } + } + }; + + # $targetは本当にHookTargetを継承したオブジェクトか？ + if (!UNIVERSAL::isa($target, 'HookTarget')) { + croak ref($this)."->install, target is not a subclass of HookTarget: ". + ref($target)."\n"; + } + + # $targetは本当に$HOOK_TARGET_NAMEのオブジェクトか？ + if (!UNIVERSAL::isa($target, $this->{target_package_name})) { + croak ref($this)."->install, target is not a subclass of $this->{target_package_name}: ". + ref($target)."\n"; + } + + $this->{target} = $target; + $this->{hook_name} = $hook_name; + $target->install_hook($hook_name, $this); + + $this; +} + +sub uninstall { + my $this = shift; + + $this->{target}->uninstall_hook($this->{hook_name}, $this); + $this->{target} = undef; + $this->{hook_name} = undef; + + $this; +} + +sub call { + my $this = shift; + + my ($caller_pkg) = caller(2); + if ($caller_pkg->isa(ref $this->{target})) { + $this->{code}->($this); + } + else { + croak "Only ${\ref($this->{target})} can call ${\ref($this)}->call\n"; + } +} + +# ----------------------------------------------------------------------------- +package HookTarget; + +sub _get_hooks_hash { + my $this = shift; + my $ih = $this->{'installed-hooks'}; + if (defined $ih) { + $ih; + } + else { + $this->{'installed-hooks'} = {}; + } +} + +sub _get_hooks_array { + my ($this, $hook_name) = @_; + my $installed_hooks = $this->_get_hooks_hash; + my $ar = $installed_hooks->{$hook_name}; + if (defined $ar) { + $ar; + } + else { + $installed_hooks->{$hook_name} = []; + } +} + +sub install_hook { + my ($this, $hook_name, $hook) = @_; + my $array = $this->_get_hooks_array($hook_name); + + push @$array, $hook; + $this; +} + +sub uninstall_hook { + my ($this, $hook_name, $hook) = @_; + my $array = $this->_get_hooks_array($hook_name); + + @$array = grep { + $_ != $hook; + } @$array; + $this; +} + +sub call_hooks { + my ($this, $hook_name) = @_; + my $array = $this->_get_hooks_array($hook_name); + + foreach my $hook (@$array) { + eval { + $hook->call; + }; if ($@) { + die ref($this)."->call_hooks, exception occured: $@\n"; + } + } +} + +1; diff -urN tiarra-20030804/main/IrcIO/Client.pm tiarra-20030812/main/IrcIO/Client.pm --- tiarra-20030804/main/IrcIO/Client.pm 2003-08-06 10:12:58.000000000 +0900 +++ tiarra-20030812/main/IrcIO/Client.pm 2003-08-15 12:08:57.000000000 +0900 @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Client.pm,v 1.18 2003/06/03 15:27:42 admin Exp $ +# $Id: Client.pm,v 1.19 2003/08/12 01:45:34 admin Exp $ # ----------------------------------------------------------------------------- # IrcIO::Clientはクライアントからの接続を受け、 # IRCメッセージをやり取りするクラスです。 @@ -241,7 +241,7 @@ } # joinしている全てのチャンネルの情報をクライアント送る。 - $this->_inform_joinning_channels; + $this->inform_joinning_channels; # 各モジュールにクライアント追加の通知を出す。 RunLoop->shared->notify_modules('client_attached',$this); @@ -307,8 +307,9 @@ return $msg; } -sub _inform_joinning_channels { +sub inform_joinning_channels { my $this = shift; + my $multi = RunLoop->shared->multi_server_mode_p; my $local_nick = RunLoop->shared_loop->current_nick; map { my $network = $_; @@ -319,7 +320,14 @@ map { my $ch = $_; - my $ch_name = Multicast::attach($ch->name,$network->network_name); + my $ch_name = do { + if ($multi) { + Multicast::attach($ch->name, $network->network_name); + } + else { + $ch->name; + } + }; # まずJOIN $this->send_message( diff -urN tiarra-20030804/main/Multicast.pm tiarra-20030812/main/Multicast.pm --- tiarra-20030804/main/Multicast.pm 2003-08-06 10:12:59.000000000 +0900 +++ tiarra-20030812/main/Multicast.pm 2003-08-15 12:08:58.000000000 +0900 @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Multicast.pm,v 1.14 2003/07/24 06:11:05 topia Exp $ +# $Id: Multicast.pm,v 1.15 2003/08/12 01:45:34 admin Exp $ # ----------------------------------------------------------------------------- # サーバーからクライアントにメッセージが流れるとき、このクラスはフィルタとして # ネットワーク名を付加します。 @@ -18,13 +18,13 @@ sub _ISON_from_client { # nickをネットワーク毎に分類する。 - my ($message,$sender) = @_; + my ($message, $sender) = @_; my $networks = classify($message->params); while (my ($network_name,$params) = each %$networks) { my $network = $runloop->networks->{$network_name}; @$params = map( local_to_global($_,$network) ,@$params); - + forward_to_server(new IRCMessage( Command => $message->command, Params => $params), @@ -55,7 +55,7 @@ # カンマで区切られ複数のチャンネルが指定されていたとしても # それらの全てにネットワーク名を付加する。(まさか無いだろうが。) $message->nick(global_to_local($message->nick,$sender)); - + my @channels = split(/,/,$message->params->[0]); my $n_channels = @channels; for (my $i = 0; $i < $n_channels; $i++) { @@ -129,12 +129,17 @@ sub _LIST_from_client { my ($message,$sender) = @_; # チャンネルのネットワーク名で分類。 - my @targets = split(/,/,$message->params->[0]); - my $networks = classify(\@targets); + if (defined $message->params->[0]) { + my @targets = split(/,/,$message->params->[0]); + my $networks = classify(\@targets); - while (my ($network_name,$channels) = each %$networks) { - $message->params->[0] = join(',',@$channels); - forward_to_server($message,$network_name); + while (my ($network_name,$channels) = each %$networks) { + $message->params->[0] = join(',',@$channels); + forward_to_server($message,$network_name); + } + } + else { + forward_to_server($message, $default_network); } } @@ -280,6 +285,22 @@ $attach_cache->{$index}; } +my $detach_cache = {}; +sub _gen_detach_translator { + my $index = shift; + + if (!exists $detach_cache->{$index}) { + $detach_cache->{$index} = sub { + my ($message, $sender) = @_; + $message->param( + $index, + detach($message->param($index))); + forward_to_server($message, $sender); + }; + } + $detach_cache->{$index}; +} + my $server_sent = { 'INVITE' => \&_INVITE_from_server, 'JOIN' => \&_JOIN_from_server, @@ -333,7 +354,8 @@ 'NAMES' => \&_LIST_from_client, # LISTと同じ処理で良い。 'NICK' => \&_NICK_from_client, 'NOTICE' => \&_LIST_from_client, # LISTと同じ処理で良い。 - 'MODE' => \&_MODE_from_client, # MODEと同じ処理で良い。 + #'MODE' => \&_MODE_from_client, # MODEと同じ処理で良い。 + #↑意図不明。 'PART' => \&_LIST_from_client, # LISTと同じ処理で良い。 'PASS' => \&_MODE_from_client, # これを真面目に処理しないとSERVICE出来ない。MODEと同じで良い。 'PONG' => undef, @@ -368,50 +390,90 @@ 'RECONNECT' => undef, 'SERVER' => undef, 'WALLOPS' => \&_MODE_from_client, # クライアントからWALLOPSを発行出来るのかどうかは知らないが… + # 以下リプライ。これはdetach_network_nameの為だけにある。 + '322' => _gen_detach_translator(1), # LIST + '325' => _gen_detach_translator(1), # UNIQOPIS (INVITINGと同じ処理) + '324' => _gen_detach_translator(1), # CHANNELMODEIS + '331' => _gen_detach_translator(1), # NOTOPIC + '332' => _gen_detach_translator(1), # TOPIC + '341' => _gen_detach_translator(1), + '346' => _gen_detach_translator(1), # INVITELIST + '347' => _gen_detach_translator(1), # ENDOFINVITELIST + '348' => _gen_detach_translator(1), # EXCEPTLIST + '349' => _gen_detach_translator(1), # ENDOFEXCEPTLIST + '352' => _gen_detach_translator(1), + '353' => _gen_detach_translator(2), + '366' => _gen_detach_translator(1), # ENDOFNAMES + '367' => _gen_detach_translator(1), # BANLIST + '368' => _gen_detach_translator(1), # ENDOFBANLIST }; sub _update_cache { my $networks = Configuration->shared_conf->networks; - $default_network = $networks->default; + + if (RunLoop->shared->multi_server_mode_p) { + $default_network = $networks->default; + } + else { + $default_network = (RunLoop->shared->networks_list)[0]->network_name; + } + $separator = $networks->channel_network_separator; $runloop = RunLoop->shared_loop; } sub from_server_to_client { no warnings; - my ($message,$sender) = @_; - _update_cache(); + my ($message, $sender) = @_; + &_update_cache; # server -> clientの流れでは、一つのメッセージが複数に分割される事は無い。 # この関数は一つのIRCMessageを返す。 - + if ($message->command =~ /^\d+$/) { # ニューメリックリプライの0番目のパラメタは全てnick。 $message->params->[0] = global_to_local($message->params->[0],$sender); } - + eval { # フィルタが無かったり、フィルタの実行中に例外が起こったりした場合はそのまま返す。 - $message = $server_sent->{$message->command}->($message,$sender); + $message = $server_sent->{$message->command}->($message, $sender); }; if ($@) { $message->nick(global_to_local($message->nick,$sender)); } return $message; - use warnings; } sub from_client_to_server { no warnings; - my ($message,$sender) = @_; - _update_cache(); + my ($message, $sender) = @_; + &_update_cache; # client -> serverの流れでは、一つのメッセージが複数に分割される事がある。 # この関数はメッセージを鯖に直接送り、戻り値は返さない。 eval { - $client_sent->{$message->command}->($message,$sender); + $client_sent->{$message->command}->($message, $sender); }; if ($@) { forward_to_server($message,$default_network); } - use warnings; +} + +sub detach_network_name { + no strict; + no warnings; + my ($message, $sender) = @_; + &_update_cache; + my $result; + local $hijack_forward_to_server = sub { + my ($msg, $network_name) = @_; + $result = $msg; + }; + local $hijack_local_to_global = 1; + eval { + $client_sent->{$message->command}->($message, $sender); + }; if ($@) { + $hijack_forward_to_server->($message, $default_network); + } + $result; } *detatch = \&detach; # 勘違いしていた。detachが正しい。 @@ -503,10 +565,21 @@ } sub forward_to_server { - my ($msg,$network_name) = @_; - my $io = $runloop->network($network_name); - if (defined $io) { - $io->send_message($msg); + # この関数は、動的スコープに置かれた変数 + # $hijack_forward_to_serverが定義されていたら、 + # それを関数リファと見做してサーバーに送る代わりに呼ぶ。 + no strict; + my ($msg, $network_name) = @_; + + if (defined $hijack_forward_to_server) { + #::printmsg("forward_to_server HIJACKED"); + $hijack_forward_to_server->($msg, $network_name); + } + else { + my $io = $runloop->network($network_name); + if (defined $io) { + $io->send_message($msg); + } } } @@ -538,12 +611,21 @@ } sub local_to_global { - my ($str,$server) = @_; - if (defined($str) && $str eq $runloop->current_nick) { - return $server->current_nick; + # この関数は、動的スコープに置かれた変数 + # $hijack_local_to_globalが定義されていたら、 + # 何も変更せずに返す。 + no strict; + my ($str, $server) = @_; + if (defined $hijack_local_to_global) { + $str; } else { - return $str; + if (defined($str) && $str eq $runloop->current_nick) { + $server->current_nick; + } + else { + $str; + } } } diff -urN tiarra-20030804/main/RunLoop.pm tiarra-20030812/main/RunLoop.pm --- tiarra-20030804/main/RunLoop.pm 2003-08-06 10:12:59.000000000 +0900 +++ tiarra-20030812/main/RunLoop.pm 2003-08-15 12:08:58.000000000 +0900 @@ -1,5 +1,11 @@ # ----------------------------------------------------------------------------- -# $Id: RunLoop.pm,v 1.43 2003/06/06 13:50:17 admin Exp $ +# $Id: RunLoop.pm,v 1.44 2003/08/12 01:45:34 admin Exp $ +# ----------------------------------------------------------------------------- +# このクラスはTiarraのメインループを実装します。 +# select()を実行し、サーバーやクライアントとのI/Oを行うのはこのクラスです。 +# ----------------------------------------------------------------------------- +# フック`before-select'及び`after-select'が使用可能です。 +# これらのフックは、それぞれselect()実行直前と直後に呼ばれます。 # ----------------------------------------------------------------------------- package RunLoop; use strict; @@ -17,6 +23,8 @@ use Multicast; use Timer; use ControlPort; +use Hook; +our @ISA = 'HookTarget'; our $_shared_instance; BEGIN { @@ -38,7 +46,7 @@ sub _new { my $class = shift; - my $obj = { + my $this = { # 受信用セレクタ。あらゆるソケットは常に受信の必要があるため、あらゆるソケットが登録されている。 receive_selector => new IO::Select, @@ -71,16 +79,41 @@ } }, + multi_server_mode => 1, # マルチサーバーモードに入っているか否か + networks => {}, # ネットワーク名 → IrcIO::Server disconnected_networks => {}, # 切断されたネットワーク。 clients => [], # 接続されている全てのクライアント IrcIO::Client timers => [], # インストールされている全てのTimer external_sockets => [], # インストールされている全てのExternalSocket - hooks_before_select => [], # インストールされている全てのbefore-selectフック - hooks_after_select => [], # インストールされている全てのafter-selectフック + #hooks_before_select => [], # インストールされている全てのbefore-selectフック + #hooks_after_select => [], # インストールされている全てのafter-selectフック + + conf_reloaded_hook => undef, # この下でインストールするフック }; - bless $obj,$class; + bless $this, $class; + + $this->{conf_reloaded_hook} = Configuration::Hook->new( + sub { + # マルチサーバーモードのOn/Offが変わったか？ + my $old = $this->{multi_server_mode} ? 1 : 0; + my $new = Configuration->shared->networks->multi_server_mode ? 1 : 0; + if ($old != $new) { + # 変わった + $this->_multi_server_mode_changed; + } + }, + )->install; + + $this; +} + +sub DESTROY { + my $this = shift; + if (defined $this->{conf_reloaded_hook}) { + $this->{conf_reloaded_hook}->uninstall; + } } sub network { @@ -100,6 +133,10 @@ shift->{clients}; } +sub clients_list { + @{shift->{clients}}; +} + sub channel { # $ch_long: ネットワーク名修飾付きチャンネル名 # 見付かったらChannelInfo、見付からなければundefを返す。 @@ -128,7 +165,7 @@ sub change_nick { my ($this,$new_nick) = @_; - + foreach my $io (values %{$this->{networks}}) { $io->send_message( new IRCMessage( @@ -137,6 +174,10 @@ } } +sub multi_server_mode_p { + shift->{multi_server_mode}; +} + sub find_io_with_socket { my ($this,$sock) = @_; # networksとclientsの中から指定されたソケットを持つIrcIOを探します。 @@ -150,16 +191,73 @@ undef; } +sub _multi_server_mode_changed { + my $this = shift; + # 一旦全てのチャンネルについてPARTを発行した後、 + # モードを変え接続中ネットワークを更新し、今度はJOINを発行する。 + my $new = !$this->{multi_server_mode}; + + foreach my $string ( + 'Multi server mode *'.($new ? 'enabled' : 'disabled').'*', + q{It looks as if you would part all channels, but it's just an illusion.}) { + $this->broadcast_to_clients( + IRCMessage->new( + Command => 'NOTICE', + Params => [$this->current_nick, $string])); + } + + my $iterate = sub { + my $func = shift; + foreach my $network ($this->networks_list) { + foreach my $ch ($network->channels_list) { + foreach my $client ($this->clients_list) { + $func->($network, $ch, $client); + } + } + } + }; + + $iterate->( + sub { + my ($network, $ch, $client) = @_; + $client->send_message( + IRCMessage->new( + Prefix => $client->fullname, + Command => 'PART', + Params => [ + do { + if ($new) { + # これまではネットワーク名が付いていなかった。 + $ch->name; + } + else { + scalar Multicast::attach( + $ch->name, $network->network_name); + } + }, + '[Caused by Tiarra] Clients have to part all channels.', + ], + ) + ); + } + ); + $this->{multi_server_mode} = $new; + $this->update_networks; + foreach my $client ($this->clients_list) { + $client->inform_joinning_channels; + } +} + sub _update_send_selector { my $this = shift; # 送信する必要のあるIrcIOだけを抜き出し、そのソケットを送信セレクタに登録する。 - + #my $add_or_remove = sub { # my $io = shift; # my $action = ($io->need_to_send ? 'add' : 'remove'); # $this->{send_selector}->$action($io->sock); #}; - + #foreach my $io (values %{$this->{networks}}) { # $add_or_remove->($io); #} @@ -197,7 +295,7 @@ $networks_closed{$network_name} = $io unless $io->connected; } my $do_update_networks = 0; - while (my ($network_name,$io) = each %networks_closed) { + while (my ($network_name,$io) = each %networks_closed) { # セレクタから外す。 $this->{receive_selector}->remove($io->sock); $this->{send_selector}->remove($io->sock); @@ -214,7 +312,7 @@ }, )->install($this); } - + for (my $i = 0; $i < @{$this->{clients}}; $i++) { my $io = $this->{clients}->[$i]; unless ($io->connected) { @@ -270,7 +368,7 @@ my $network_name = $network->network_name; if ($event eq 'connected') { $this->_rejoin_all_channels($network); - + my $msg = IRCMessage->new( Prefix => 'Tiarra', Command => 'NOTICE', @@ -303,7 +401,7 @@ my @ch_without_key; # パスワードを持たないチャンネルの配列。要素は"チャンネル名" foreach my $ch (values %{$network->channels}) { next if $ch->remarks('kicked-out'); - + my $password = $ch->parameters('k'); if (defined $password && $password ne '') { push @ch_with_key,[$ch->name,$password]; @@ -360,6 +458,15 @@ my $do_update_networks_after = 0; # 秒数 my $do_cleanup_closed_links_after = 0; my $host_tried = {}; # {接続を試みたホスト名 => 1} + + # マルチサーバーモードでなければ、@net_namesの要素は一つに限られるべき。 + # そうでなければ警告を出し、先頭のものだけを残して後は捨てる。 + if (!$this->{multi_server_mode} && @net_names > 1) { + $this->notify_warn("In single server mode, Tiarra will connect to just a one network; `". + $net_names[0]."'"); + @net_names = $net_names[0]; + } + foreach my $net_name (@net_names) { my $net_conf = Configuration::shared_conf->get($net_name); @@ -372,7 +479,7 @@ } next; } - + # 切断されたネットワークかも知れない。 my $network = $this->{disconnected_networks}->{$net_name}; eval { @@ -391,7 +498,7 @@ } else { $host_tried->{$net_conf->host} = 1; - + $network = IrcIO::Server->new($net_name); $this->{networks}->{$net_name} = $network; # networksに登録 } @@ -405,7 +512,7 @@ $do_update_networks_after = 3; } } - + if ($do_update_networks_after) { Timer->new( After => $do_update_networks_after, @@ -418,7 +525,7 @@ if ($do_cleanup_closed_links_after) { $this->_cleanup_closed_link; } - + my @nets_to_disconnect; my @nets_to_forget; my $is_there_in_net_names = sub { @@ -430,10 +537,10 @@ return 0; }; # networksから不要なネットワークを削除 - while (my ($net_name,$server) = each %{$this->{networks}}) { + while (my ($net_name,$server) = each %{$this->{networks}}) { # 入っていなかったらselectorから外して切断する。 unless ($is_there_in_net_names->($net_name)) { - push @nets_to_disconnect,$net_name; + push @nets_to_disconnect,$net_name; } } foreach my $net_name (@nets_to_disconnect) { @@ -510,6 +617,7 @@ undef; } +=pod sub install_hook { my ($this,$hook_name,$hook) = @_; my $array = do { @@ -568,6 +676,8 @@ } } +=cut + sub install_timer { my ($this,$timer) = @_; push @{$this->{timers}},$timer; @@ -619,6 +729,10 @@ my $this = shift; my $conf_general = Configuration::shared_conf->get('general'); + # マルチサーバーモード + $this->{multi_server_mode} = + Configuration::shared->networks->multi_server_mode; + # まずはtiarra-portをlistenするソケットを作る。 # 省略されていたらlistenしない。 # この値が数値でなかったらdie。 @@ -836,6 +950,12 @@ Multicast::from_server_to_client($msg,$io); # モジュールを通す。 my $filtered_messages = $this->_apply_filters(\@received_messages,$io); + # シングルサーバーモードなら、ネットワーク名を取り外す。 + if (!$this->{multi_server_mode}) { + @$filtered_messages = map { + Multicast::detach_network_name($_, $io); + } @$filtered_messages; + } # 註釈do-not-send-to-clients => 1が付いていないメッセージを各クライアントに送る。 $this->broadcast_to_clients( grep { @@ -1048,10 +1168,24 @@ # })->install('after-select'); # select実行直後にこのフックを呼ぶ。 # ----------------------------------------------------------------------------- package RunLoop::Hook; -use strict; -use warnings; -use Carp; +#use strict; +#use warnings; +#use Carp; +use FunctionalVariable; +use base 'Hook'; + +our $HOOK_TARGET_NAME = 'RunLoop'; +our @HOOK_NAME_CANDIDATES = qw/before-select after-select/; +our $HOOK_NAME_DEFAULT = 'after-select'; +our $HOOK_TARGET_DEFAULT; +FunctionalVariable::tie( + \$HOOK_TARGET_DEFAULT, + FETCH => sub { + RunLoop->shared; + }, + ); +=pod sub new { my ($class,$code) = @_; my $this = { @@ -1067,7 +1201,7 @@ elsif (ref($code) ne 'CODE') { croak "RunLoop::Hook->new, Arg[0] was bad type.\n"; } - + bless $this,$class; } @@ -1082,7 +1216,7 @@ if (defined $this->{runloop}) { croak "RunLoop::Hook->install, this hook is already installed.\n"; } - + $this->{runloop} = $runloop; $this->{hook_name} = $hook_name; $runloop->install_hook($hook_name,$this); @@ -1112,4 +1246,6 @@ } } +=cut + 1; diff -urN tiarra-20030804/module/User/Kick.pm tiarra-20030812/module/User/Kick.pm --- tiarra-20030804/module/User/Kick.pm 2003-08-06 10:13:00.000000000 +0900 +++ tiarra-20030812/module/User/Kick.pm 2003-08-15 12:08:59.000000000 +0900 @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Kick.pm,v 1.1 2003/07/03 13:49:24 admin Exp $ +# $Id: Kick.pm,v 1.2 2003/08/12 01:45:34 admin Exp $ # ----------------------------------------------------------------------------- package User::Kick; use strict; @@ -30,7 +30,7 @@ my ($this, $msg, $sender) = @_; if ($sender->server_p && $msg->command eq 'JOIN' && defined $msg->nick) { - foreach (split /,/,$msg->param(0)) { + foreach (split m/,/,$msg->param(0)) { my ($ch_full,$mode) = (m/^(.+?)(?:\x07(.*))?$/); my $ch_short = Multicast::detatch($ch_full); my $ch = $sender->channel($ch_short); diff -urN tiarra-20030804/sample.conf tiarra-20030812/sample.conf --- tiarra-20030804/sample.conf 2003-08-06 10:12:58.000000000 +0900 +++ tiarra-20030812/sample.conf 2003-08-15 12:08:57.000000000 +0900 @@ -1,6 +1,6 @@ # -*- tiarra-conf -*- # ----------------------------------------------------------------------------- -# $Id: sample.conf,v 1.56 2003/08/04 09:29:21 admin Exp $ +# $Id: sample.conf,v 1.57 2003/08/12 01:45:35 admin Exp $ # ----------------------------------------------------------------------------- # tiarra.conf サンプル # @@ -151,6 +151,18 @@ # ----------------------------------------------------------------------------- networks { + # 複数のサーバーへの接続を可能にするかどうか。1(オン)と0(オフ)で指定。 + # これを1にすると、次のnameを複数個定義する事が可能になり、 + # 複数のサーバーに同時に接続出来るようになります。 + # その一方、これを1にしている時は、チャンネル名にネットワーク名が付加される等、 + # IRCの大部分のメッセージがTiarraによる改変を受けます。 + # これを0にしている間は、次のnameを複数個定義する事は出来なくなります。 + # マルチサーバーモードの設定を起動中に変えると、クライアントから見たチャンネル名が + # 変更になる為、全クライアントが一時的に全てのチャンネルからpartしたように見え、 + # その直後にjoinし直したように見えます。 + # デフォルトでは1です。 + multi-server-mode: 1 + # 接続するIRCネットワークに名前を付けます。この名前は後で使用します。 # 複数のネットワークに接続したい場合は多重定義して下さい。 name: ircnet diff -urN tiarra-20030804/tiarra tiarra-20030812/tiarra --- tiarra-20030804/tiarra 2003-08-06 10:12:58.000000000 +0900 +++ tiarra-20030812/tiarra 2003-08-15 12:08:57.000000000 +0900 @@ -5,7 +5,7 @@ # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # ----------------------------------------------------------------------------- -# $Id: tiarra,v 1.23 2003/07/26 14:00:38 admin Exp $ +# $Id: tiarra,v 1.24 2003/08/12 01:45:35 admin Exp $ # ----------------------------------------------------------------------------- require 5.006; use strict; @@ -210,11 +210,11 @@ $msg =~ s/\n*$//s; $msg = Unicode::Japanese->new($msg,'utf8')->conv( Configuration->shared_conf->get('general')->stdout_encoding); - + my ($sec,$min,$hour,$day,$mon,$year) = localtime(time); $mon++; $year += 1900; - + #printf("[%02d/%02d/%04d %02d:%02d:%02d] %s\n",$mon,$day,$year,$hour,$min,$sec,$msg); printf("[%02d/%02d %02d:%02d:%02d] %s\n",$mon,$day,$hour,$min,$sec,$msg); }