1# ----------------------------------------------------------------------------- 2# $Id: RunLoop.pm 36720 2010-02-11 18:13:54Z topia $ 3# ----------------------------------------------------------------------------- 4# このクラスはTiarraのメインループを実装します。 5# select()を実行し、サーバーやクライアントとのI/Oを行うのはこのクラスです。 6# ----------------------------------------------------------------------------- 7# フック`before-select'及び`after-select'が使用可能です。 8# これらのフックは、それぞれselect()実行直前と直後に呼ばれます。 9# ----------------------------------------------------------------------------- 10package RunLoop; 11use strict; 12use warnings; 13use UNIVERSAL; 14use Carp; 15use IO::Socket::INET; 16use IO::Select; 17use Configuration; 18use IrcIO::Server; 19use IrcIO::Client; 20use Mask; 21use ModuleManager; 22use Multicast; 23use Timer; 24use Hook; 25use base qw(HookTarget); 26use base qw(Tiarra::IRC::NewMessageMixin); 27use Tiarra::OptionalModules; 28use Tiarra::ShorthandConfMixin; 29use Tiarra::SharedMixin qw(shared shared_loop); 30use Tiarra::Utils; 31use Tiarra::TerminateManager; 32our $_shared_instance; 33#use ControlPort; # lazy load 34 35BEGIN { 36 # Time::HiResは使えるか? 37 eval q{ 38 use Time::HiRes qw(time); 39 }; if ($@) { 40 # 使えない。 41 } 42} 43 44sub _new { 45 shift->new(Configuration->shared); 46} 47 48sub new { 49 my ($class, $conf) = @_; 50 carp 'conf is not specified!' unless defined $conf; 51 # early initialization 52 my $this = { 53 conf => $conf, 54 mod_manager => undef, 55 }; 56 bless $this, $class; 57 58 # update 59 %$this = ( 60 %$this, 61 62 # 受信用セレクタ。あらゆるソケットは常に受信の必要があるため、あらゆるソケットが登録されている。 63 receive_selector => new IO::Select, 64 65 # 送信用セレクタ。ソケットに対して送信すべきデータがある場合は限られていて、その場合にのみ登録されて終わり次第削除される。 66 send_selector => new IO::Select, 67 68 # Tiarraがリスニングしてクライアントを受け付けるためのソケット。IO::Socket。 69 tiarra_server_socket => undef, 70 71 # 現在のnick。全てのサーバーとクライアントの間で整合性を保ちつつnickを変更する手段を、RunLoopが用意する。 72 current_nick => $this->_conf_general->nick, 73 74 # 鯖から切断された時の動作。 75 action_on_disconnected => do { 76 my $actions = { 77 'part-and-join' => \&_action_part_and_join, 78 'one-message' => \&_action_one_message, 79 'message-for-each' => \&_action_message_for_each, 80 }; 81 my $action_name = $this->_conf_networks->action_when_disconnected; 82 unless (defined $action_name) { 83 $action_name = 'part-and-join'; 84 } 85 my $act = $actions->{$action_name}; 86 if (defined $act) { 87 $act; 88 } 89 else { 90 die "Unknown action specified as networks/action-when-disconnected: $action_name\n"; 91 } 92 }, 93 94 multi_server_mode => 1, # マルチサーバーモードに入っているか否か 95 96 default_network => undef, # デフォルトのネットワーク名 97 networks => {}, # ネットワーク名 → IrcIO::Server 98 clients => [], # 接続されている全てのクライアント IrcIO::Client 99 100 timers => [], # インストールされている全てのTimer 101 sockets => [], # インストールされている全てのTiarra::Socket 102 socks_to_cleanup => [], # クリーンアップ予定のSocket(not Tiarra::Socket) 103 104 conf_reloaded_hook => undef, # この下でインストールするフック 105 106 terminating => 0, # 正のときは終了処理中。 107 ); 108 109 $this->{conf_reloaded_hook} = Configuration::Hook->new( 110 sub { 111 $this->_config_changed(0); 112 }, 113 )->install(undef, $this->_conf); 114 115 $this->{default_network} = $this->_conf_networks->default; 116 117 $this; 118} 119 120sub DESTROY { 121 my $this = shift; 122 if (defined $this->{conf_reloaded_hook}) { 123 $this->{conf_reloaded_hook}->uninstall; 124 } 125} 126 127sub network { 128 my ($class_or_this,$network_name) = @_; 129 my $this = $class_or_this->_this; 130 return $this->{networks}->{$network_name}; 131} 132 133sub networks { 134 my ($class_or_this,@options) = @_; 135 my $this = $class_or_this->_this; 136 137 if (defined $options[0] && $options[0] eq 'even-if-not-connected') { 138 $this->{networks}; 139 } else { 140 my $hash = $this->{networks}; 141 $hash = { 142 map { $_ => $hash->{$_} } 143 grep { $hash->{$_}->connected } 144 keys %$hash}; 145 } 146} 147 148utils->define_attr_getter(1, qw(default_network clients), 149 [qw(multi_server_mode_p multi_server_mode)], 150 [qw(mod_manager mod_manager)], 151 [qw(config conf)]); 152 153# クライアントから見た、現在のnick。 154# このnickは実際に使われているnickとは異なっている場合がある。 155# すなわち、希望のnickが既に使われていた場合である。 156utils->define_attr_getter(1, qw(current_nick)); 157 158sub networks_list { values %{shift->networks(@_)}; } 159sub clients_list { @{shift->clients}; } 160 161sub channel { 162 # $ch_long: ネットワーク名修飾付きチャンネル名 163 # 見付かったらChannelInfo、見付からなければundefを返す。 164 my ($class_or_this,$ch_long) = @_; 165 my $this = $class_or_this->_this; 166 167 my ($ch_short,$net_name) = Multicast::detach($ch_long); 168 my $network = $this->{networks}->{$net_name}; 169 if (!defined $network) { 170 return undef; 171 } 172 173 $network->channel($ch_short); 174} 175 176sub set_current_nick { 177 my ($class_or_this,$new_nick) = @_; 178 my $this = $class_or_this->_this; 179 $this->{current_nick} = $new_nick; 180 $this->call_hooks('set-current-nick'); 181} 182 183sub change_nick { 184 my ($class_or_this,$new_nick) = @_; 185 my $this = $class_or_this->_this; 186 187 foreach my $io ($this->networks_list) { 188 $io->send_message( 189 $this->construct_irc_message( 190 Command => 'NICK', 191 Param => $new_nick)); 192 } 193} 194 195sub _runloop { shift->_this; } 196 197sub sysmsg_prefix { 198 my ($class_or_this,$purpose,$category) = @_; 199 my $this = $class_or_this->_this; 200 $category = (caller)[0] . (defined $category ? "::$category" : ''); 201 # $purpose は、この関数で得た prefix を何に使うかを示す。 202 # いまのところ system(NumericReply など)/priv/channel 203 # $category は、大まかなカテゴリ。 204 # いまのところ log/system/notify があるが、 205 # 明確な仕様はまだない。 206 207 if (Mask::match_array([ 208 $this->_conf_general->sysmsg_prefix_use_masks('block')-> 209 get($purpose, 'all')], $category)) { 210 $this->_conf_general->sysmsg_prefix; 211 } else { 212 undef 213 } 214} 215 216 217sub _config_changed { 218 my ($this, $init) = @_; 219 220 my ($old, $new); 221 # マルチサーバーモードのOn/Offが変わったか? 222 $old = $this->{multi_server_mode}; 223 $new = utils->cond_yesno($this->_conf_networks->multi_server_mode); 224 if ($old != $new) { 225 # 変わった 226 if ($init) { 227 $this->{multi_server_mode} = $new; 228 } else { 229 $this->_multi_server_mode_changed; 230 } 231 } 232} 233 234sub _multi_server_mode_changed { 235 my $this = shift; 236 # 一旦全てのチャンネルについてPARTを発行した後、 237 # モードを変え接続中ネットワークを更新し、NICKとJOINを発行する。 238 my $new = !$this->{multi_server_mode}; 239 240 foreach my $string ( 241 'Multi server mode *'.($new ? 'enabled' : 'disabled').'*', 242 q{It looks as if you would part all channels, but it's just an illusion.}) { 243 $this->broadcast_to_clients( 244 $this->construct_irc_message( 245 Prefix => $this->sysmsg_prefix(qw(priv system)), 246 Command => 'NOTICE', 247 Params => [$this->current_nick, $string])); 248 } 249 250 my $iterate = sub { 251 my $func = shift; 252 foreach my $network ($this->networks_list) { 253 foreach my $ch ($network->channels_list) { 254 foreach my $client ($this->clients_list) { 255 $func->($network, $ch, $client); 256 } 257 } 258 } 259 }; 260 261 $iterate->( 262 sub { 263 my ($network, $ch, $client) = @_; 264 $client->send_message( 265 $this->construct_irc_message( 266 Prefix => $client->fullname, 267 Command => 'PART', 268 Params => [ 269 do { 270 if ($new) { 271 # これまではネットワーク名が付いていなかった。 272 $ch->name; 273 } 274 else { 275 scalar Multicast::attach( 276 $ch->name, $network->network_name); 277 } 278 }, 279 '[Caused by Tiarra] Clients have to part all channels.', 280 ], 281 ) 282 ); 283 } 284 ); 285 $this->{multi_server_mode} = $new; 286 $this->update_networks; 287 my $global_nick = (($this->networks_list)[0])->current_nick; 288 if ($global_nick ne $this->current_nick) { 289 $this->broadcast_to_clients( 290 $this->construct_irc_message( 291 Command => 'NICK', 292 Param => $global_nick, 293 Remarks => {'fill-prefix-when-sending-to-client' => 1 294 })); 295 296 $this->set_current_nick($global_nick); 297 } 298 foreach my $client ($this->clients_list) { 299 $client->inform_joinning_channels; 300 } 301} 302 303sub _update_send_selector { 304 my $this = shift; 305 # 送信する必要のあるTiarra::Socketだけを抜き出し、そのソケットを送信セレクタに登録する。 306 307 my $sel = $this->{send_selector} = IO::Select->new; 308 foreach my $socket (@{$this->{sockets}}) { 309 if ($socket->want_to_write) { 310 $sel->add($socket->sock); 311 } 312 } 313} 314 315sub _cleanup_closed_link { 316 # networksとclientsの中から切断されたリンクを探し、 317 # そのソケットをセレクタから外す。 318 # networksならクライアントに然るべき通知をし、再接続するタイマーをインストールする。 319 my $this = shift; 320 321 my $do_update_networks_after = 0; 322 while (my ($network_name,$io) = each %{$this->networks('even-if-not-connected')}) { 323 next if $io->connected || $io->connecting; 324 if ($io->state_finalized) { 325 delete $this->{networks}->{$network_name}; 326 } elsif ($io->state_terminated) { 327 $do_update_networks_after = 1; 328 } 329 } 330 if ($do_update_networks_after) { 331 Timer->new( 332 After => $do_update_networks_after, 333 Code => sub { 334 $this->update_networks; 335 }, 336 )->install($this); 337 } 338 339 for (my $i = 0; $i < @{$this->{clients}}; $i++) { 340 my $io = $this->{clients}->[$i]; 341 unless ($io->connected) { 342 #::printmsg("Connection with ".$io->fullname." has been closed."); 343 #$this->unregister_receive_socket($io->sock); 344 splice @{$this->{clients}},$i,1; 345 $i--; 346 } 347 } 348} 349 350sub _action_part_and_join { 351 # $event: 'connected' 若しくは 'disconnected' 352 # 今のところ、このメソッドはconfからの削除による切断時にも流用されている。 353 my ($this,$network,$event) = @_; 354 my $network_name = $network->network_name; 355 if ($event eq 'connected') { 356 $this->_rejoin_all_channels($network); 357 } 358 elsif ($event eq 'disconnected') { 359 foreach my $client (@{$this->clients}) { 360 foreach my $ch (values %{$network->channels}) { 361 $client->send_message( 362 $this->construct_irc_message( 363 Prefix => $client->fullname, 364 Command => 'PART', 365 Params => [Multicast::attach_for_client($ch->name,$network_name), 366 $network->host." closed the connection."])); 367 } 368 } 369 } 370} 371sub _action_one_message { 372 my ($this,$network,$event) = @_; 373 my $network_name = $network->network_name; 374 if ($event eq 'connected') { 375 $this->_rejoin_all_channels($network); 376 $this->broadcast_to_clients( 377 $this->construct_irc_message( 378 Prefix => $this->sysmsg_prefix(qw(priv system)), 379 Command => 'NOTICE', 380 Params => [$this->current_nick, 381 '*** The connection has been revived between '.$network->network_name.'.'])); 382 } 383 elsif ($event eq 'disconnected') { 384 $this->broadcast_to_clients( 385 $this->construct_irc_message( 386 Prefix => $this->sysmsg_prefix(qw(priv system)), 387 Command => 'NOTICE', 388 Params => [$this->current_nick, 389 '*** The connection has been broken between '.$network->network_name.'.'])); 390 } 391} 392sub _action_message_for_each { 393 my ($this,$network,$event) = @_; 394 my $network_name = $network->network_name; 395 if ($event eq 'connected') { 396 $this->_rejoin_all_channels($network); 397 398 my $msg = $this->construct_irc_message( 399 Prefix => $this->sysmsg_prefix(qw(channel system)), 400 Command => 'NOTICE', 401 Params => ['', # チャンネル名は後で設定。 402 '*** The connection has been revived between '.$network->network_name.'.']); 403 foreach my $ch (values %{$network->channels}) { 404 $msg->param(0,Multicast::attach_for_client($ch->name,$network_name)); 405 $this->broadcast_to_clients($msg); 406 } 407 } 408 elsif ($event eq 'disconnected') { 409 my $msg = $this->construct_irc_message( 410 Prefix => $this->sysmsg_prefix(qw(channel system)), 411 Command => 'NOTICE', 412 Params => ['', # チャンネル名は後で設定。 413 '*** The connection has been broken between '.$network->network_name.'.']); 414 foreach my $ch (values %{$network->channels}) { 415 $msg->param(0,Multicast::attach_for_client($ch->name,$network_name)); 416 $this->broadcast_to_clients($msg); 417 } 418 } 419} 420sub _rejoin_all_channels { 421 my ($this,$network) = @_; 422 $network->rejoin_all_channels(); 423} 424 425sub update_networks { 426 my $this = shift; 427 # networks/nameを読み、その中にまだ接続していないネットワークがあればそれを接続し、 428 # 接続中のネットワークで既にnetworks/nameに列挙されていないものがあればそれを切断する。 429 my @net_names = $this->_conf_networks->name('all'); 430 my $do_update_networks_after = 0; # 秒数 431 my $do_cleanup_closed_links_after = 0; 432 my $host_tried = {}; # {接続を試みたホスト名 => 1} 433 434 $this->{default_network} = $this->_conf_networks->default; 435 436 # マルチサーバーモードでなければ、@net_namesの要素は一つに限られるべき。 437 # そうでなければ警告を出し、先頭のものだけを残して後は捨てる。 438 if (!$this->{multi_server_mode}) { 439 if (@net_names > 1) { 440 $this->notify_warn( 441 "In single server mode, Tiarra will connect to just a one network; `". 442 $net_names[0]."'"); 443 @net_names = $net_names[0]; 444 } 445 if (@net_names > 0) { 446 $this->{default_network} = $net_names[0]; 447 } 448 } 449 450 my ($net_conf, $network, $genre); 451 foreach my $net_name (@net_names) { 452 $net_conf = $this->_conf->get($net_name); 453 454 $network = $this->network($net_name); 455 eval { 456 if (!defined $network) { 457 # 新しいネットワーク 458 $network = IrcIO::Server->new($this, $net_name); 459 $this->{networks}->{$net_name} = $network; # networksに登録 460 } 461 else { 462 if ($network->state_connected || $network->state_connecting) { 463 # 既に接続されている。 464 # このサーバーについての設定が変わっていたら、一旦接続を切る。 465 if (!$net_conf->equals($network->config)) { 466 $network->state_reconnecting(1); 467 $network->quit( 468 $this->_conf_messages->quit->netconf_changed_reconnect); 469 } 470 } elsif ($network->state_terminated) { 471 # 終了している 472 # このサーバーについての設定が変わっていたら、接続する。 473 if (!$net_conf->equals($network->config)) { 474 $this->reconnect_server($net_name); 475 } 476 } 477 } 478 }; if ($@) { 479 if ($@ =~ /^[Cc]ouldn't connect to /i) { 480 ::printmsg($@); 481 } else { 482 $this->notify_error($@); 483 } 484 # タイマー作り直し。 485 $do_update_networks_after = 3; 486 } 487 } 488 489 if ($do_cleanup_closed_links_after) { 490 $this->_cleanup_closed_link; 491 } 492 493 my @nets_to_disconnect; 494 my @nets_to_forget; 495 my $is_there_in_net_names = sub { 496 my $network_name = shift; 497 # このネットワークは@net_names内に列挙されているか? 498 foreach my $enumerated_net (@net_names) { 499 return 1 if $network_name eq $enumerated_net; 500 } 501 return 0; 502 }; 503 # networksから不要なネットワークを削除 504 while (my ($net_name,$server) = each %{$this->{networks}}) { 505 # 入っていなかったらselectorから外して切断する。 506 unless ($is_there_in_net_names->($net_name)) { 507 push @nets_to_disconnect,$net_name; 508 } 509 } 510 foreach my $net_name (@nets_to_disconnect) { 511 my $server = $this->{networks}->{$net_name}; 512 $server->finalize( 513 $this->_conf_messages->quit->netconf_changed_disconnect); 514 } 515 516 if ($do_update_networks_after) { 517 Timer->new( 518 After => $do_update_networks_after, 519 Code => sub { 520 $this->update_networks; 521 }, 522 )->install($this); 523 } 524} 525 526sub terminate_server { 527 my ($class_or_this,$network, $msg) = @_; 528 my $this = $class_or_this->_this; 529 530 $network->terminate($msg); 531} 532 533sub reconnect_server { 534 # terminate/disconnect(サーバから)されたサーバへ接続しなおす。 535 my ($class_or_this,$network_name) = @_; 536 my $this = $class_or_this->_this; 537 my $network = $this->network($network_name); 538 539 $network->reconnect if defined $network; 540} 541 542sub disconnect_server { 543 # 指定されたサーバーとの接続を切る。 544 # fdの監視をやめてしまうので、この後IrcIO::Serverのreceiveはもう呼ばれない事に注意。 545 # $server: IrcIO::Server 546 my ($class_or_this,$server) = @_; 547 my $this = $class_or_this; 548 $server->terminate(''); 549} 550 551sub close_client { 552 # 指定したクライアントとの接続を切る。 553 # $client: IrcIO::Client 554 my ($class_or_this, $client, $message) = @_; 555 my $this = $class_or_this->_this; 556 $client->send_message( 557 $this->construct_irc_message( 558 Command => 'ERROR', 559 Param => 'Closing Link: ['.$client->fullname_from_client. 560 '] ('.$message.')', 561 Remarks => {'send-error-as-is-to-client' => 1}, 562 )); 563 $client->disconnect_after_writing; 564} 565 566sub reconnected_server { 567 my ($class_or_this,$network) = @_; 568 my $this = $class_or_this->_this; 569 # 再接続だった場合の処理 570 $this->{action_on_disconnected}->($this,$network,'connected'); 571} 572 573sub disconnected_server { 574 my ($class_or_this,$network) = @_; 575 my $this = $class_or_this->_this; 576 $this->{action_on_disconnected}->($this,$network,'disconnected'); 577} 578 579sub install_socket { 580 my ($this,$socket) = @_; 581 if (!defined $socket) { 582 croak "RunLoop->install_socket, Arg[1] was undef.\n"; 583 } 584 585 push @{$this->{sockets}},$socket; 586 $this->register_receive_socket($socket->sock); # 受信セレクタに登録 587 undef; 588} 589 590sub uninstall_socket { 591 my ($this,$socket) = @_; 592 if (!defined $socket) { 593 croak "RunLoop->uninstall_socket, Arg[1] was undef.\n"; 594 } 595 596 for (my $i = 0; $i < @{$this->{sockets}}; $i++) { 597 if ($this->{sockets}->[$i] == $socket) { 598 splice @{$this->{sockets}},$i,1; 599 $this->unregister_receive_socket($socket->sock); # 受信セレクタから登録解除 600 push @{$this->{socks_to_cleanup}},$socket->sock; 601 $i--; 602 } 603 } 604 $this; 605} 606 607sub register_receive_socket { 608 # 内部 API です。外部から使うときは Tiarra::Socket または 609 # ExternalSocket を使用してください。 610 shift->{receive_selector}->add(@_); 611} 612 613sub unregister_receive_socket { 614 # 内部 API です。外部から使うときは Tiarra::Socket または 615 # ExternalSocket を使用してください。 616 shift->{receive_selector}->remove(@_); 617} 618 619sub find_socket_with_sock { 620 my ($this,$sock) = @_; 621 foreach my $socket (@{$this->{sockets}}) { 622 if (!defined $socket->sock) { 623 warn 'Socket '.$socket->name.': uninitialized sock!'; 624 } elsif ($socket->sock == $sock) { 625 return $socket; 626 } 627 } 628 undef; 629} 630 631sub install_timer { 632 my ($this,$timer) = @_; 633 push @{$this->{timers}},$timer; 634 $this; 635} 636 637sub uninstall_timer { 638 my ($this,$timer) = @_; 639 for (my $i = 0; $i < scalar(@{$this->{timers}}); $i++) { 640 if ($this->{timers}->[$i] == $timer) { 641 splice @{$this->{timers}},$i,1; 642 $i--; 643 } 644 } 645 $this; 646} 647 648sub get_earliest_timer { 649 # 登録されている中で最も起動時間の早いタイマーを返す。 650 # タイマーが一つも無ければundefを返す。 651 my $this = shift; 652 return undef if (scalar(@{$this->{timers}}) == 0); 653 654 my $eariest = $this->{timers}->[0]; 655 foreach my $timer (@{$this->{timers}}) { 656 if ($timer->time_to_fire < $eariest->time_to_fire) { 657 $eariest = $timer; 658 } 659 } 660 return $eariest; 661} 662 663sub _execute_all_timers_to_fire { 664 my $this = shift; 665 666 # executeすべきタイマーを集める 667 my @timers_to_execute = (); 668 foreach my $timer (@{$this->{timers}}) { 669 push @timers_to_execute,$timer if $timer->time_to_fire <= time; 670 } 671 672 # 実行 673 foreach my $timer (@timers_to_execute) { 674 $timer->execute; 675 } 676} 677 678sub run { 679 my $this = shift->_this; 680 my $conf_general = $this->_conf_general; 681 682 # config から初期化 683 $this->_config_changed(1); 684 685 # FIXME: only shared 686 $this->{mod_manager} = 687 ModuleManager->shared($this); 688 689 # まずはtiarra-portをlistenするソケットを作る。 690 # 省略されていたらlistenしない。 691 # この値が数値でなかったらdie。 692 my $tiarra_port = $conf_general->tiarra_port; 693 if (defined $tiarra_port) { 694 if ($tiarra_port !~ /^\d+/) { 695 die "general/tiarra-port must be integer. '$tiarra_port' is invalid.\n"; 696 } 697 698 # v4とv6の何れを使うか? 699 my @serversocket_args = ( 700 LocalPort => $tiarra_port, 701 Proto => 'tcp', 702 Reuse => 1, 703 Listen => 0); 704 my $ip_version = $conf_general->tiarra_ip_version || 'v4'; 705 my $tiarra_server_socket = do { 706 if ($ip_version eq 'v4') { 707 my $bind_addr = $conf_general->tiarra_ipv4_bind_addr; 708 my @args = do { 709 if (defined $bind_addr) { 710 @serversocket_args,LocalAddr => $bind_addr; 711 } 712 else { 713 @serversocket_args; 714 } 715 }; 716 IO::Socket::INET->new(@args); 717 } 718 elsif ($ip_version eq 'v6') { 719 if (!Tiarra::OptionalModules->ipv6) { 720 ::printmsg("*** IPv6 support is not enabled ***"); 721 ::printmsg("Set general/tiarra-ip-version to 'v4' or install Socket6.pm if possible.\n"); 722 die; 723 } 724 my $bind_addr = $conf_general->tiarra_ipv6_bind_addr; 725 my @args = do { 726 if (defined $bind_addr) { 727 @serversocket_args,LocalAddr => $bind_addr; 728 } 729 else { 730 @serversocket_args; 731 } 732 }; 733 IO::Socket::INET6->new(@args); 734 } 735 else { 736 die "Unknown ip-version '$ip_version' specified as general/tiarra-ip-version.\n"; 737 } 738 }; 739 if (defined $tiarra_server_socket) { 740 $tiarra_server_socket->autoflush(1); 741 $this->{tiarra_server_socket} = $tiarra_server_socket; 742 $this->register_receive_socket($tiarra_server_socket); # セレクタに登録。 743 main::printmsg("Tiarra started listening ${tiarra_port}/tcp. (IP$ip_version)"); 744 } 745 else { 746 # ソケット作れなかった。 747 die "Couldn't make server socket to listen ${tiarra_port}/tcp. (IP$ip_version)\n"; 748 } 749 } 750 751 # 鯖に接続 752 $this->update_networks; 753 754 # 3分毎に全ての鯖とクライアントにPINGを送るタイマーをインストール。 755 # これはtcp接続の切断に気付かない事があるため。 756 # 応答のPONGは捨てる。このためにPONG破棄カウンタをインクリメントする。 757 # PONG破棄カウンタはIrcIO::Serverのremarkで、キーは'pong-drop-counter' 758 Timer->new( 759 Interval => 3 * 60, 760 Code => sub { 761 foreach my $network ($this->networks_list) { 762 $network->send_message( 763 $this->construct_irc_message( 764 Command => 'PING', 765 Param => $network->server_hostname)); 766 767 my $cntr = $network->remark('pong-drop-counter'); 768 $network->remark('pong-drop-counter', 769 utils->get_first_defined($cntr,0) + 1); 770 } 771 772 my $prefix = $this->_runloop->sysmsg_prefix('system'); 773 foreach my $client ($this->clients_list) { 774 $client->send_message( 775 $this->construct_irc_message( 776 Command => 'PING', 777 Param => $prefix)); 778 779 my $cntr = $client->remark('pong-drop-counter'); 780 $client->remark('pong-drop-counter', 781 utils->get_first_defined($cntr,0) + 1); 782 } 783 }, 784 Repeat => 1, 785 Name => __PACKAGE__ . '/send ping', 786 )->install; 787 788 # control-socket-nameが指定されていたら、ControlPortを開く。 789 if ($conf_general->control_socket_name) { 790 require ControlPort; 791 eval { 792 $this->{control_port} = ControlPort->new($conf_general->control_socket_name); 793 }; if ($@) { 794 ::printmsg($@); 795 } 796 } 797 798 my $zerotime = { 799 limit => 300, 800 minimum_to_reset => 2, 801 interval => 10, 802 803 count => 0, 804 last_warned => 0, 805 }; 806 my $zerotime_warn = sub { 807 my $elapsed = shift; 808 809 if ($elapsed == 0) { 810 $zerotime->{count}++; 811 if ($zerotime->{count} >= $zerotime->{limit}) { 812 $zerotime->{count} = 0; 813 814 if ($zerotime->{last_warned} + $zerotime->{interval} < CORE::time) { 815 $zerotime->{last_warned} = CORE::time; 816 817 $this->notify_warn("Tiarra seems to be slowing down your system!"); 818 } 819 } 820 } 821 elsif ($elapsed > $zerotime->{minimum_to_reset}) { 822 $zerotime->{count} = 0; 823 } 824 }; 825 826 while (1) { 827 # 処理の流れ 828 # 829 # 書きこみ可能なソケットを集めて、必要があれば書き込む。 830 # 次に読み込み可能なソケットを集めて、(読む必要は常にあるので)読む。 831 # 読んだ場合は通常Tiarra::IRC::Messageの配列が返ってくるので、 832 # 必要な全てのプラグインに順番に通す。(プラグインはフィルターとして考える。) 833 # それがサーバーから読んだメッセージだったなら、プラグインを通した後、接続されている全てのクライアントにそれを転送する。 834 # クライアントが一つも接続されていなければ、そのTiarra::IRC::Message群は捨てる。 835 # クライアントから読んだメッセージだったなら、プラグインを通した後、渡すべきサーバーに転送する。 836 # 837 # selectにおけるタイムアウトは次のようにする。 838 # (普段は何かしら登録されていると思うが)タイマーが一つも登録されていなければ、タイムアウトはundefである。すなわちタイムアウトしない。 839 # タイマーが一つでも登録されていた場合は、全てのタイマーの中で最も発動時間が早いものを調べ、 840 # それが発動するまでの時間をselectのタイムアウト時間とする。 841 842 # select前フックを呼ぶ 843 $this->call_hooks('before-select'); 844 845 # フック内でタイマーをinstall/発動時刻変更をした場合に備え、 846 # タイムアウトの計算はbefore-selectフックの実行後にする。 847 my $timeout = undef; 848 my $eariest_timer = $this->get_earliest_timer; 849 if (defined $eariest_timer) { 850 $timeout = $eariest_timer->time_to_fire - time; 851 } 852 if ($timeout < 0) { 853 $timeout = 0; 854 } 855 # Windowsだと, select()中にCtrl-Cが効かなくなるので, 856 # !defined($timeout) || $timeout > 閾値 and $timeout = 閾値. 857 # とかで時々ブロック解除した方がよいのかもしれない. 858 859 # 書き込むべきデータがあるソケットだけをsend_selectorに登録する。そうでないソケットは除外。 860 $this->_update_send_selector; 861 862 # select実行 863 my $time_before_select = CORE::time; 864 my ($readable_socks,$writable_socks,$has_exception_socks) = 865 IO::Select->select($this->{receive_selector},$this->{send_selector},$this->{receive_selector},$timeout); 866 $zerotime_warn->(CORE::time - $time_before_select); 867 # select後フックを呼ぶ 868 $this->call_hooks('after-select'); 869 870 foreach my $sock ($this->{receive_selector}->can_read(0)) { 871 if (defined $this->{tiarra_server_socket} && 872 $sock == $this->{tiarra_server_socket}) { 873 874 # クライアントからの新規の接続 875 my $new_sock = $sock->accept; 876 if (defined $new_sock) { 877 if (!$this->{terminating}) { 878 eval { 879 my $client = new IrcIO::Client($this, $new_sock); 880 push @{$this->{clients}},$client; 881 }; if ($@) { 882 $this->notify_msg($@); 883 } 884 } else { 885 $new_sock->shutdown(2); 886 } 887 } else { 888 $this->notify_error('unknown readable on listen sock'); 889 } 890 } 891 elsif (my $socket = $this->find_socket_with_sock($sock)) { 892 eval { 893 $socket->read; 894 895 if (UNIVERSAL::isa($socket, 'IrcIO')) { 896 while (1) { 897 my $msg = eval { 898 $socket->pop_queue; 899 }; if ($@) { 900 if (ref($@) && 901 UNIVERSAL::isa($@,'QueueIsEmptyException')) { 902 last; 903 } 904 else { 905 ::printmsg($@); 906 last; 907 } 908 } 909 910 if (!defined $msg) { 911 next; 912 } 913 914 # このメッセージがPONGであればpong-drop-counterを見る。 915 if ($msg->command eq 'PONG') { 916 my $cntr = $socket->remark('pong-drop-counter'); 917 if (defined $cntr && $cntr > 0) { 918 # このPONGは捨てる。 919 $cntr--; 920 $socket->remark('pong-drop-counter',$cntr); 921 next; 922 } 923 } 924 925 if ($socket->isa("IrcIO::Server")) { 926 # メッセージをMulticastのフィルタに通す。 927 my @received_messages = 928 Multicast::from_server_to_client($msg,$socket); 929 # モジュールを通す。 930 my $filtered_messages = $this->_apply_filters(\@received_messages,$socket); 931 # シングルサーバーモードなら、ネットワーク名を取り外す。 932 if (!$this->{multi_server_mode}) { 933 @$filtered_messages = map { 934 Multicast::detach_network_name($_, $socket); 935 } @$filtered_messages; 936 } 937 # 註釈do-not-send-to-clients => 1が付いていないメッセージを各クライアントに送る。 938 $this->broadcast_to_clients( 939 grep { 940 !($_->remark('do-not-send-to-clients')); 941 } @$filtered_messages); 942 } 943 else { 944 # シングルサーバーモードなら、メッセージをMulticastのフィルタに通す。 945 my @received_messages = 946 (!$this->{multi_server_mode}) ? Multicast::from_server_to_client($msg,$this->networks_list) : $msg; 947 948 # モジュールを通す。 949 my $filtered_messages = $this->_apply_filters(\@received_messages,$socket); 950 # 対象となる鯖に送る。 951 # NOTICE及びPRIVMSGは返答が返ってこないので、同時にこれ以外のクライアントに転送する。 952 # 註釈do-not-send-to-servers => 1が付いているメッセージはここで破棄する。 953 foreach my $msg (@$filtered_messages) { 954 if ($msg->remark('do-not-send-to-servers')) { 955 next; 956 } 957 958 my $cmd = $msg->command; 959 if (!$msg->remark('do-not-broadcast-to-clients') && 960 $cmd eq 'PRIVMSG' || $cmd eq 'NOTICE') { 961 my $new_msg = undef; # 本当に必要になったら作る。 962 foreach my $client (@{$this->{clients}}) { 963 if ($client != $socket) { 964 unless (defined $new_msg) { 965 # まだ作ってなかった 966 $new_msg = $msg->clone; 967 $new_msg->prefix($socket->fullname); 968 # シングルサーバーモードなら、ネットワーク名を取り外す。 969 if (!$this->{multi_server_mode}) { 970 Multicast::detach_network_name($new_msg,$this->networks_list); 971 } 972 973 } 974 $client->send_message($new_msg); 975 } 976 } 977 } 978 979 if (!$msg->remark('do-not-send-to-server')) { 980 Multicast::from_client_to_server($msg,$socket); 981 } 982 } 983 } 984 } 985 } 986 }; if ($@) { 987 $this->notify_error($@); 988 } 989 } elsif (grep { $sock == $_ } @{$this->{socks_to_cleanup}}) { 990 # cleanup socket; ignore 991 } else { 992 $this->notify_error('unknown readable socket: '.$sock); 993 } 994 } 995 996 foreach my $sock ($this->{send_selector}->can_write(0)) { 997 if (my $socket = $this->find_socket_with_sock($sock)) { 998 next unless $socket->want_to_write; 999 1000 eval { 1001 $socket->write; 1002 }; if ($@) { 1003 $this->notify_error($@); 1004 } 1005 } elsif (grep { $sock == $_ } @{$this->{socks_to_cleanup}}) { 1006 # cleanup socket; ignore 1007 } else { 1008 $this->notify_error('unknown writable socket: '.$sock); 1009 } 1010 } 1011 1012 foreach my $sock ($this->{receive_selector}->has_exception(0)) { 1013 if (my $socket = $this->find_socket_with_sock($sock)) { 1014 eval { 1015 $socket->exception; 1016 }; if ($@) { 1017 $this->notify_error($@); 1018 } 1019 } elsif (grep { $sock == $_ } @{$this->{socks_to_cleanup}}) { 1020 # cleanup socket; ignore 1021 } else { 1022 $this->notify_error('unknown has-exception socket: '.$sock); 1023 } 1024 } 1025 1026 # 切断されたソケットを探して、然るべき処理を行なう。 1027 $this->_cleanup_closed_link; 1028 1029 # 発動すべき全てのタイマーを発動させる 1030 $this->_execute_all_timers_to_fire; 1031 1032 # Tiarra::Socket のクリーンアップ 1033 $this->{socks_to_cleanup} = []; 1034 1035 # 終了処理中でサーバもクライアントもいなくなればループ終了。 1036 if ($this->{terminating}) { 1037 if ((scalar $this->networks_list('even-if-not-connected') <= 0) && 1038 (scalar $this->clients_list <= 0) 1039 ) { 1040 last; 1041 } else { 1042 ++$this->{terminating}; 1043 if ($this->{terminating} >= 400) { 1044 # quit loop でそんなに回るとは思えない。 1045 $this->notify_error( 1046 "very long terminating loop!". 1047 "(".$this->{terminating}." count(s))\n". 1048 "maybe something is wrong; exit force..."); 1049 $this->notify_error( 1050 join ("\n", 1051 map {$_->network_name.": ".$_->state } 1052 $this->networks_list('even-if-not-connected'))); 1053 last; 1054 } 1055 } 1056 } 1057 } 1058 1059 # 終了処理 1060 if (defined $this->{tiarra_server_socket}) { 1061 $this->{tiarra_server_socket}->close; 1062 $this->unregister_receive_socket($this->{tiarra_server_socket}); # 受信セレクタから登録解除 1063 } 1064 undef $this->{control_port}; 1065 $this->mod_manager->terminate; 1066} 1067 1068sub terminate { 1069 my ($class_or_this, $message) = @_; 1070 my $this = $class_or_this->_this; 1071 1072 $this->{terminating} = 1; 1073 map { $_->finalize($message) } $this->networks_list('even-if-not-connected'); 1074 map { $this->close_client($_, $message) } $this->clients_list; 1075 if (defined $this->{tiarra_server_socket}) { 1076 #buggy, close on final 1077 #$this->{tiarra_server_socket}->shutdown(2); 1078 } 1079} 1080 1081sub broadcast_to_clients { 1082 # Tiarra::IRC::Messageをログイン中でない全てのクライアントに送信する。 1083 # fill-prefix-when-sending-to-clientという註釈が付いていたら、 1084 # Prefixをそのクライアントのfullnameに設定する。 1085 my ($class_or_this,@messages) = @_; 1086 my $this = $class_or_this->_this; 1087 foreach my $client (@{$this->{clients}}) { 1088 next if $client->logging_in; 1089 next unless $client->connected; 1090 1091 foreach my $msg (@messages) { 1092 if ($msg->remark('fill-prefix-when-sending-to-client')) { 1093 $msg = $msg->clone; 1094 $msg->prefix($client->fullname); 1095 } 1096 $client->send_message($msg); 1097 } 1098 } 1099} 1100 1101sub broadcast_to_servers { 1102 # IRCメッセージを全てのサーバーに送信する。 1103 my ($class_or_this,@messages) = @_; 1104 my $this = $class_or_this->_this; 1105 foreach my $network ($this->networks_list) { 1106 foreach my $msg (@messages) { 1107 $network->send_message($msg); 1108 } 1109 } 1110} 1111 1112sub notify_modules { 1113 my ($class_or_this,$method,@args) = @_; 1114 my $this = $class_or_this->_this; 1115 foreach my $mod (@{$this->mod_manager->get_modules}) { 1116 eval { 1117 $mod->$method(@args); 1118 }; if ($@) { 1119 $this->notify_error("Exception in ".ref($mod).".\n". 1120 "when calling $method.\n". 1121 " $@"); 1122 } 1123 } 1124} 1125 1126sub apply_filters { 1127 # @extra_args: モジュールに送られる第二引数以降。第一引数は常にTiarra::IRC::Message。 1128 my ($this, $src_messages, $method, @extra_args) = @_; 1129 1130 my $source = $src_messages; 1131 my $filtered = []; 1132 foreach my $mod (@{$this->mod_manager->get_modules}) { 1133 # (普通ないはずだが) $mod が undef だったらこのモジュールをとばす。 1134 next unless defined $mod; 1135 # sourceが空だったらここで終わり。 1136 if (scalar(@$source) == 0) { 1137 return $source; 1138 } 1139 1140 foreach my $src (@$source) { 1141 my @reply = (); 1142 # 実行 1143 eval { 1144 @reply = $mod->$method($src, @extra_args); 1145 }; if ($@) { 1146 my $modname = ref($mod); 1147 my $error = $@; 1148 # ブラックリストに入れておく 1149 $this->mod_manager->add_to_blacklist($modname); 1150 $this->notify_error( 1151 "Exception in ".$modname.".\n". 1152 "This module added to blacklist!\n". 1153 "The message was '".$src->serialize."'.\n". 1154 " $error"); 1155 $this->mod_manager->remove_from_blacklist($modname); 1156 @reply = ($src); 1157 } 1158 1159 if (defined $reply[0]) { 1160 # 値が一つ以上返ってきた。 1161 # 全てTiarra::IRC::Messageのオブジェクトなら良いが、そうでなければエラー。 1162 foreach my $msg_reply (@reply) { 1163 unless (UNIVERSAL::isa($msg_reply,$this->irc_message_class)) { 1164 $this->notify_error( 1165 "Reply of ".ref($mod)."::${method} contains illegal value.\n". 1166 "It is ".ref($msg_reply)."."); 1167 return $source; 1168 } 1169 } 1170 1171 # これをfilteredに追加。 1172 push @$filtered,@reply; 1173 } 1174 } 1175 1176 # 次のsourceはfilteredに。filteredは空の配列に。 1177 $source = $filtered; 1178 $filtered = []; 1179 } 1180 return $source; 1181} 1182 1183sub _apply_filters { 1184 # src_messagesは変更しない。 1185 my ($this, $src_messages, $sender) = @_; 1186 $this->apply_filters( 1187 $src_messages, 'message_arrived', $sender); 1188} 1189 1190sub notify_error { 1191 my ($class_or_this,$str) = @_; 1192 $class_or_this->notify_msg("===== ERROR =====\n$str"); 1193} 1194sub notify_warn { 1195 my ($class_or_this,$str) = @_; 1196 $class_or_this->notify_msg(":: WARNING :: $str"); 1197} 1198sub notify_msg { 1199 # 渡された文字列をSTDOUTに出力すると同時に全クライアントにNOTICEする。 1200 # 改行コードLFで行を分割する。 1201 # 文字コードはUTF-8でなければならない。 1202 my ($class_or_this,$str) = @_; 1203 my $this = $class_or_this->_this; 1204 $str =~ s/\n+$//s; # 末尾のLFは消去 1205 1206 # STDOUTへ 1207 ::printmsg($str); 1208 1209 # クライアントへ 1210 my $needed_sending = $this->_conf_general->notice_error_messages; 1211 if ($needed_sending) { 1212 my $client_charset = $this->_conf_general->client_out_encoding; 1213 if (@{$this->clients} > 0) { 1214 $this->broadcast_to_clients( 1215 map { 1216 $this->construct_irc_message( 1217 Prefix => $this->sysmsg_prefix(qw(priv notify)), 1218 Command => 'NOTICE', 1219 Params => [$this->current_nick, 1220 "*** $_"]); 1221 } split /\n/,$str 1222 ); 1223 } 1224 } 1225} 1226 1227# ----------------------------------------------------------------------------- 1228# RunLoopが一回実行される度に呼ばれるフック。 1229# 1230# my $hook = RunLoop::Hook->new(sub { 1231# my $hook_itself = shift; 1232# # 何らかの処理を行なう。 1233# })->install('after-select'); # select実行直後にこのフックを呼ぶ。 1234# ----------------------------------------------------------------------------- 1235package RunLoop::Hook; 1236use FunctionalVariable; 1237use base 'Hook'; 1238 1239our $HOOK_TARGET_NAME = 'RunLoop'; 1240our @HOOK_NAME_CANDIDATES = qw(before-select after-select set-current-nick); 1241our $HOOK_NAME_DEFAULT = 'after-select'; 1242our $HOOK_TARGET_DEFAULT; 1243FunctionalVariable::tie( 1244 \$HOOK_TARGET_DEFAULT, 1245 FETCH => sub { 1246 $HOOK_TARGET_NAME->shared_loop; 1247 }, 1248 ) unless defined $HOOK_TARGET_DEFAULT; 1249 12501; 1251