diff -urN tiarra-20030817/ChangeLog tiarra-20030920/ChangeLog --- tiarra-20030817/ChangeLog 2003-08-18 00:48:41.000000000 +0900 +++ tiarra-20030920/ChangeLog 2003-09-20 20:11:20.000000000 +0900 @@ -1,3 +1,29 @@ +2003-09-20 phonohawk + + * main/ChannelInfo.pm, main/IRCMessage.pm, + main/PersonInChannel.pm, main/PersonalInfo.pm, + main/Configuration/Block.pm: + これらのクラスはオブジェクトが大量に作られるので、 + メモリの節約のためにインスタンス型を配列に変更。 + + * main/IrcIO.pm: + メソッド remarks を remark のエイリアスに。 + $io->remark(foo => undef); のように明示的にundefを設定すると + その註釈を削除。 + + * IrcIO/Server.pm: + remarkをIrcIO.pmに移動したので、こちらは削除。 + + * main/L10N.pm: + * main/LocalChannelManager.pm: + 未完成であり、まだ使われてもいないが、存在しても害は無い。 + それぞれ多言語メッセージとTiarra内部チャンネルを扱う。 + + * main/Mask.pm: + マスク文字列から変換した正規表現のコンパイル結果をキャッシュとして保存するように。 + 大量のマスクを扱う条件下で動作が非常に重くなる問題を回避する。 + ベンチマークの結果では、62.5%のマッチング速度の向上が見られた。 + 2003-08-18 Topia * main/Multicast.pm: @@ -814,7 +840,7 @@ * これ以前のログは書いていません。 -# Id: $Id: ChangeLog,v 1.98 2003/08/17 15:18:53 topia Exp $ -# Author: $Author: topia $ -# Date: $Date: 2003/08/17 15:18:53 $ -# Revision: $Revision: 1.98 $ +# Id: $Id: ChangeLog,v 1.99 2003/09/20 11:06:20 admin Exp $ +# Author: $Author: admin $ +# Date: $Date: 2003/09/20 11:06:20 $ +# Revision: $Revision: 1.99 $ diff -urN tiarra-20030817/main/ChannelInfo.pm tiarra-20030920/main/ChannelInfo.pm --- tiarra-20030817/main/ChannelInfo.pm 2003-08-18 00:48:41.000000000 +0900 +++ tiarra-20030920/main/ChannelInfo.pm 2003-09-20 20:11:20.000000000 +0900 @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: ChannelInfo.pm,v 1.11 2003/07/19 05:15:57 admin Exp $ +# $Id: ChannelInfo.pm,v 1.12 2003/09/20 11:06:20 admin Exp $ # ----------------------------------------------------------------------------- # チャンネル情報を保持 # ----------------------------------------------------------------------------- @@ -18,19 +18,19 @@ name => $name, network_name => $network_name, topic => '', - names => {}, # nick => PersonInChannel - switches => {}, # aやsなどのチャンネルモード。キーがaやsで、値は常に1。 - parameters => {}, # lやkなどのチャンネルモード。 - banlist => [], # +bリスト。知らなければ空。 - exceptionlist => [], # +eリスト。知らなければ空。 - invitelist => [], # +Iリスト。知らなければ空。 - remarks => {}, # Tiarraが内部的に使用する備考。 + names => undef, # hash; nick => PersonInChannel + switches => undef, # hash; aやsなどのチャンネルモード。キーがaやsで、値は常に1。 + parameters => undef, # hash; lやkなどのチャンネルモード。 + banlist => undef, # array; +bリスト。知らなければ空。 + exceptionlist => undef, # array; +eリスト。知らなければ空。 + invitelist => undef, # array; +Iリスト。知らなければ空。 + remarks => undef, # hash; Tiarraが内部的に使用する備考。 }; - + unless (defined $name) { croak "ChannelInfo->new requires name parameter.\n"; } - + bless $obj,$class; } @@ -62,7 +62,7 @@ sub AUTOLOAD { my ($this,@args) = @_; (my $key = $AUTOLOAD) =~ s/^.+?:://g; - + if ($key eq 'DESTROY') { return; } @@ -70,12 +70,12 @@ if ($key eq 'name' || $key eq 'network_name') { return $this->{$key}; } - + my $type = $types->{$key}; if (!defined($type)) { croak "ChannelInfo doesn't have the parameter $key\n"; } - + if ($type eq 'scalar') { # $info->topic; # $info->topic('NEW-TOPIC'); @@ -93,35 +93,39 @@ # $info->names(undef,undef,'size'); # $info->names(undef,undef,'keys'); # $info->names(undef,undef,'values'); + my $hash = $this->{$key}; + if (!defined $args[0] && !defined $args[2]) { # HASH*を返す。 - return $this->{$key}; + $this->{$key} = $hash = {} if !$hash; + return $hash; } - + if (defined $args[1]) { - $this->{$key}->{$args[0]} = $args[1]; + $this->{$key} = $hash = {} if !$hash; + $hash->{$args[0]} = $args[1]; } if (defined $args[2]) { if ($args[2] eq 'delete') { - delete $this->{$key}->{$args[0]}; + delete $hash->{$args[0]} if $hash; } elsif ($args[2] eq 'clear') { - $this->{$key} = {}; + $this->{$key} = undef; } elsif ($args[2] eq 'size') { - return scalar(keys %{$this->{$key}}); + return $hash ? scalar(keys %$hash) : 0; } elsif ($args[2] eq 'keys') { - return keys %{$this->{$key}}; + return $hash ? keys %$hash : (); } elsif ($args[2] eq 'values') { - return values %{$this->{$key}}; + return $hash ? values %$hash : (); } else { croak '[array]->([key],[value],'.$args[2].") is invalid\n"; } } - return $this->{$key}->{$args[0]}; + return ($hash and $args[0]) ? $hash->{$args[0]} : undef; } elsif ($type eq 'array') { # $info->banlist; @@ -131,22 +135,27 @@ my $array = $this->{$key}; if (@args == 0) { # ARRAY*を返す。 + $this->{$key} = $array = [] if !$array; return $array; } if ($args[0] eq 'set') { + $this->{$key} = $array = [] if !$array; @$array = @args[1 .. $#args]; } elsif ($args[0] eq 'add') { croak "'add' requires a value to add\n" unless defined $args[1]; + $this->{$key} = $array = [] if !$array; push @$array,$args[1]; } elsif ($args[0] eq 'delete') { croak "'delete' requires a value to remove\n" unless defined $args[1]; - for (my $i = 0; $i < @$array; $i++) { - if ($array->[$i] eq $args[1]) { - splice @$array,$i,1; - $i--; + if ($array) { + for (my $i = 0; $i < @$array; $i++) { + if ($array->[$i] eq $args[1]) { + splice @$array,$i,1; + $i--; + } } } } diff -urN tiarra-20030817/main/Configuration/Block.pm tiarra-20030920/main/Configuration/Block.pm --- tiarra-20030817/main/Configuration/Block.pm 2003-08-18 00:48:42.000000000 +0900 +++ tiarra-20030920/main/Configuration/Block.pm 2003-09-20 20:11:20.000000000 +0900 @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Block.pm,v 1.8 2003/07/03 13:49:24 admin Exp $ +# $Id: Block.pm,v 1.9 2003/09/20 11:06:18 admin Exp $ # ----------------------------------------------------------------------------- package Configuration::Block; use strict; @@ -34,33 +34,35 @@ # reinterpret-encoding,AUTOLOADといった属性はget()でしか読めない。 # また、属性名にアンダースコアを持つ属性もget()でしか読めない。 +use constant BLOCK_NAME => 0; +use constant TABLE => 1; + sub new { my ($class,$block_name) = @_; - my $obj = { - block_name => $block_name, - table => {}, # ラベル -> 値(配列リファもしくはスカラー) - }; - bless $obj,$class; + my $obj = bless [] => $class; + $obj->[BLOCK_NAME] = $block_name; + $obj->[TABLE] = {}; # ラベル -> 値(配列リファもしくはスカラー) + $obj; } sub block_name { my ($this,$newvalue) = @_; if (defined $newvalue) { - $this->{block_name} = $newvalue; + $this->[BLOCK_NAME] = $newvalue; } - $this->{block_name}; + $this->[BLOCK_NAME]; } sub equals { # 二つのConfiguration::Blockが完全に等価なら1を返す。 my ($this,$that) = @_; # ブロック名 - if ($this->{block_name} ne $that->{block_name}) { + if ($this->[BLOCK_NAME] ne $that->[BLOCK_NAME]) { return undef; } # キーの数 - my @this_keys = keys %{$this->{table}}; - my @that_keys = keys %{$that->{table}}; + my @this_keys = keys %{$this->[TABLE]}; + my @that_keys = keys %{$that->[TABLE]}; if (@this_keys != @that_keys) { return undef; } @@ -72,8 +74,8 @@ return undef; } # 値の型 - my $this_value = $this->{table}->{$this_keys[$i]}; - my $that_value = $that->{table}->{$that_keys[$i]}; + my $this_value = $this->[TABLE]->{$this_keys[$i]}; + my $that_value = $that->[TABLE]->{$that_keys[$i]}; if (ref($this_value) ne ref($that_value)) { return undef; } @@ -118,7 +120,7 @@ use warnings; use strict; if ($@) { die "\%CODE{ }EDOC\% interpretation error.\n". - "block: $this->{block_name}\n". + "block: ".$this->[BLOCK_NAME]."\n". "origianl: $str\n". "$@\n"; } @@ -131,7 +133,7 @@ sub get { my ($this,$key,$option) = @_; - unless (exists $this->{table}->{$key}) { + unless (exists $this->[TABLE]->{$key}) { # そのような値は定義されていない。 if ($option && $option eq 'all') { return (); @@ -141,7 +143,7 @@ } } - my $value = $this->{table}->{$key}; + my $value = $this->[TABLE]->{$key}; if ($option && $option eq 'all') { if (ref($value) eq 'ARRAY') { return map { @@ -175,27 +177,27 @@ sub set { # 古い値があれば上書きする。 my ($this,$key,$value) = @_; - $this->{table}->{$key} = $value; + $this->[TABLE]->{$key} = $value; $this; } sub add { # 古い値があればそれに追加する。 my ($this,$key,$value) = @_; - if (defined $this->{table}->{$key}) { + if (defined $this->[TABLE]->{$key}) { # 定義済み。 - if (ref($this->{table}->{$key}) eq 'ARRAY') { + if (ref($this->[TABLE]->{$key}) eq 'ARRAY') { # 既に複数の値を持っているのでただ追加する。 - push @{$this->{table}->{$key}},$value; + push @{$this->[TABLE]->{$key}},$value; } else { # 配列に変更する。 - $this->{table}->{$key} = [$this->{table}->{$key},$value]; + $this->[TABLE]->{$key} = [$this->[TABLE]->{$key},$value]; } } else { # 定義済みでない。 - $this->{table}->{$key} = $value; + $this->[TABLE]->{$key} = $value; } } @@ -206,7 +208,7 @@ my $unicode = Unicode::Japanese->new; my $newtable = {}; - while (my ($key,$value) = each %{$this->{table}}) { + while (my ($key,$value) = each %{$this->[TABLE]}) { my $newkey = $unicode->set($key,$encoding)->utf8; my $newvalue = do { if (ref($value) eq 'ARRAY') { @@ -227,7 +229,7 @@ $newtable->{$newkey} = $newvalue; } - $this->{table} = $newtable; + $this->[TABLE] = $newtable; $this; } diff -urN tiarra-20030817/main/IRCMessage.pm tiarra-20030920/main/IRCMessage.pm --- tiarra-20030817/main/IRCMessage.pm 2003-08-18 00:48:41.000000000 +0900 +++ tiarra-20030920/main/IRCMessage.pm 2003-09-20 20:11:20.000000000 +0900 @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: IRCMessage.pm,v 1.12 2003/05/15 12:11:12 admin Exp $ +# $Id: IRCMessage.pm,v 1.13 2003/09/20 11:06:20 admin Exp $ # ----------------------------------------------------------------------------- # IRCMessageはIRCのメッセージを表わすクラスです。実際のメッセージはUTF-8で保持します。 # 生のメッセージのパース、シリアライズ、そしてメッセージの生成をサポートします。 @@ -36,20 +36,28 @@ use Carp; use Unicode::Japanese; +use constant PREFIX => 0; +use constant COMMAND => 1; +use constant PARAMS => 2; + +use constant NICK => 3; +use constant NAME => 4; +use constant HOST => 5; + +use constant REMARKS => 6; + sub new { my ($class,%args) = @_; - my $obj = { - prefix => undef, - command => undef, - params => undef, - - nick => undef, - name => undef, - host => undef, + my $obj = bless [] => $class; + $obj->[PREFIX] = undef; + $obj->[COMMAND] = undef; + $obj->[PARAMS] = undef; + + $obj->[NICK] = undef; + $obj->[NAME] = undef; + $obj->[HOST] = undef; - remarks => undef, - }; - bless $obj,$class; + $obj->[REMARKS] = undef; if (exists $args{'Line'}) { $args{'Line'} =~ s/\x0d\x0a$//s; # 行末のcrlfは消去。 @@ -57,24 +65,24 @@ } else { if (exists $args{'Prefix'}) { - $obj->{prefix} = $args{'Prefix'}; # prefixが指定された + $obj->[PREFIX] = $args{'Prefix'}; # prefixが指定された } elsif (exists $args{'Server'}) { - $obj->{prefix} = $args{'Server'}; # prefix決定 + $obj->[PREFIX] = $args{'Server'}; # prefix決定 } elsif (exists $args{'Nick'}) { - $obj->{prefix} = $args{'Nick'}; # まずはnickがあることが分かった + $obj->[PREFIX] = $args{'Nick'}; # まずはnickがあることが分かった if (exists $args{'User'}) { - $obj->{prefix} .= '!'.$args{'User'}; # userもあった。 + $obj->[PREFIX] .= '!'.$args{'User'}; # userもあった。 } if (exists $args{'Host'}) { - $obj->{prefix} .= '@'.$args{'Host'}; # hostもあった。 + $obj->[PREFIX] .= '@'.$args{'Host'}; # hostもあった。 } } # Commandは絶対に無ければならない。 if (exists $args{'Command'}) { - ($obj->{command} = $args{'Command'}) =~ tr/a-z/A-Z/; + ($obj->[COMMAND] = $args{'Command'}) =~ tr/a-z/A-Z/; } else { die "You can't make IRCMessage without a COMMAND.\n"; @@ -85,21 +93,21 @@ my $params = $args{'Params'}; my $type = ref($params); if ($type eq '') { - $obj->{params} = [$params]; + $obj->[PARAMS] = [$params]; } elsif ($type eq 'ARRAY') { my @copy_of_params = @{$params}; - $obj->{params} = \@copy_of_params; # コピーを格納 + $obj->[PARAMS] = \@copy_of_params; # コピーを格納 } } elsif (exists $args{'Param'}) { # Paramがあった。型はスカラーのみ - $obj->{params} = [$args{'Param'}]; + $obj->[PARAMS] = [$args{'Param'}]; } } if (exists $args{'Remarks'}) { my %copy_of_remarks = %{$args{'Remarks'}}; - $obj->{remarks} = \%copy_of_remarks; + $obj->[REMARKS] = \%copy_of_remarks; } $obj->_parse_prefix; $obj; @@ -107,22 +115,22 @@ sub clone { my $this = shift; - my %new = %{$this}; - bless \%new,ref($this); + my @new = @$this; + bless \@new => ref($this); } sub _parse { my ($this,$line,$encoding) = @_; - delete $this->{prefix}; - delete $this->{command}; - delete $this->{params}; + delete $this->[PREFIX]; + delete $this->[COMMAND]; + delete $this->[PARAMS]; my $pos = 0; # prefix if (substr($line,0,1) eq ':') { # :で始まっていたら my $pos_space = index($line,' '); - $this->{prefix} = substr($line,1,$pos_space - 1); + $this->[PREFIX] = substr($line,1,$pos_space - 1); $pos = $pos_space + 1; # スペースの次から解釈再開 } # command & params @@ -131,18 +139,18 @@ my $value_raw = shift; my $value = $unicode->set($value_raw,$encoding)->utf8; - if ($this->{command}) { + if ($this->[COMMAND]) { # commandはもう設定済み。次はパラメータだ。 - if ($this->{params}) { - push @{$this->{params}},$value; + if ($this->[PARAMS]) { + push @{$this->[PARAMS]},$value; } else { - $this->{params} = [$value]; + $this->[PARAMS] = [$value]; } } else { # まだコマンドが設定されていない。 - ($this->{command} = $value) =~ tr/a-z/A-Z/; + ($this->[COMMAND] = $value) =~ tr/a-z/A-Z/; } }; while (1) { @@ -178,39 +186,39 @@ # 解釈結果の正当性をチェック。 # commandが無かったらdie。 - unless ($this->{command}) { + unless ($this->[COMMAND]) { die "IRCMessage parsed unvalid one, which doesn't have command.\n $line\n"; } } sub _parse_prefix { my $this = shift; - if (defined $this->{prefix}) { - $this->{prefix} =~ m/^(.+?)!(.+?)@(.+)$/; + if (defined $this->[PREFIX]) { + $this->[PREFIX] =~ m/^(.+?)!(.+?)@(.+)$/; if (!defined($1)) { - $this->{nick} = $this->{prefix}; + $this->[NICK] = $this->[PREFIX]; } else { - $this->{nick} = $1; - $this->{name} = $2; - $this->{host} = $3; + $this->[NICK] = $1; + $this->[NAME] = $2; + $this->[HOST] = $3; } } } sub _update_prefix { my $this = shift; - if (defined $this->{nick}) { - if (defined $this->{name}) { - $this->{prefix} = - $this->{nick}.'!'.$this->{name}.'@'.$this->{host}; + if (defined $this->[NICK]) { + if (defined $this->[NAME]) { + $this->[PREFIX] = + $this->[NICK].'!'.$this->[NAME].'@'.$this->[HOST]; } else { - $this->{prefix} = $this->{nick}; + $this->[PREFIX] = $this->[NICK]; } } else { - delete $this->{nick}; + delete $this->[NICK]; } } @@ -220,26 +228,26 @@ $encoding = 'utf8' unless defined $encoding; my $result = ''; - if ($this->{prefix}) { - $result .= ':'.$this->{prefix}.' '; + if ($this->[PREFIX]) { + $result .= ':'.$this->[PREFIX].' '; } - $result .= $this->{command}.' '; + $result .= $this->[COMMAND].' '; - if ($this->{params}) { + if ($this->[PARAMS]) { my $unicode = new Unicode::Japanese; - my $n_params = scalar @{$this->{params}}; + my $n_params = scalar @{$this->[PARAMS]}; for (my $i = 0;$i < $n_params;$i++) { if ($i == $n_params - 1) { # 最後のパラメタなら頭にコロンを付けて後にはスペースを置かない。 # 但し半角スペースが一つも無ければコロンを付けない。 - my $arg = $unicode->set($this->{params}->[$i])->conv($encoding); + my $arg = $unicode->set($this->[PARAMS]->[$i])->conv($encoding); $result .= (index($arg,' ') != -1 ? ':' : '').$arg; # 本当はCTCPメッセージを外してエンコードすべきかも知れない。 } else { # 最後のパラメタでなければ後にスペースを置く。 - $result .= $unicode->set($this->{params}->[$i])->conv($encoding).' '; + $result .= $unicode->set($this->[PARAMS]->[$i])->conv($encoding).' '; } } } @@ -249,59 +257,59 @@ sub prefix { my ($this,$new_val) = @_; - $this->{prefix} = $new_val if defined($new_val); - $this->{prefix}; + $this->[PREFIX] = $new_val if defined($new_val); + $this->[PREFIX]; } sub nick { my ($this,$new_val) = @_; if (defined $new_val) { - $this->{nick} = $new_val; + $this->[NICK] = $new_val; $this->_update_prefix; } - $this->{nick}; + $this->[NICK]; } sub name { my ($this,$new_val) = @_; if (defined $new_val) { - $this->{name} = $new_val; + $this->[NAME] = $new_val; $this->_update_prefix; } - $this->{name}; + $this->[NAME]; } sub host { my ($this,$new_val) = @_; if (defined $new_val) { - $this->{host} = $new_val; + $this->[HOST] = $new_val; $this->_update_prefix; } - $this->{host}; + $this->[HOST]; } sub command { my ($this,$new_val) = @_; - $this->{command} = $new_val if defined($new_val); - $this->{command}; + $this->[COMMAND] = $new_val if defined($new_val); + $this->[COMMAND]; } sub params { croak "Parameter specified to params(). You must mistaked with param().\n" if (@_ > 1); - $_[0]->{params}; + $_[0]->[PARAMS]; } sub n_params { - scalar @{$_[0]->{params}}; + scalar @{$_[0]->[PARAMS]}; } sub param { my ($this,$index,$new_value) = @_; croak "Parameter index wasn't specified to param(). You must be mistaken with params().\n" if (@_ <= 1); if (defined $new_value) { - $this->{params}->[$index] = $new_value; + $this->[PARAMS]->[$index] = $new_value; } - $this->{params}->[$index]; + $this->[PARAMS]->[$index]; } sub remark { @@ -310,19 +318,19 @@ # remark('key') -> SCALAR # remark('key','value') -> 'value' if (!defined($key)) { - $this->{remarks} || {}; + $this->[REMARKS] || {}; } else { if (defined $value) { - if (defined $this->{remarks}) { - $this->{remarks}->{$key} = $value; + if (defined $this->[REMARKS]) { + $this->[REMARKS]->{$key} = $value; } else { - $this->{remarks} = {$key => $value}; + $this->[REMARKS] = {$key => $value}; } } - defined $this->{remarks} ? - $this->{remarks}->{$key} : undef; + defined $this->[REMARKS] ? + $this->[REMARKS]->{$key} : undef; } } diff -urN tiarra-20030817/main/IrcIO/Client.pm tiarra-20030920/main/IrcIO/Client.pm --- tiarra-20030817/main/IrcIO/Client.pm 2003-08-18 00:48:41.000000000 +0900 +++ tiarra-20030920/main/IrcIO/Client.pm 2003-09-20 20:11:20.000000000 +0900 @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Client.pm,v 1.19 2003/08/12 01:45:34 admin Exp $ +# $Id: Client.pm,v 1.20 2003/09/20 11:06:18 admin Exp $ # ----------------------------------------------------------------------------- # IrcIO::Clientはクライアントからの接続を受け、 # IRCメッセージをやり取りするクラスです。 @@ -14,6 +14,7 @@ use Configuration; use Multicast; use Mask; +use LocalChannelManager; use SelfLoader; SelfLoader->load_stubs; # このクラスには親クラスがあるから。(SelfLoaderのpodを参照) @@ -304,6 +305,10 @@ # これは鯖に送らない。 $msg = undef; } + else { + $msg = LocalChannelManager->shared + ->message_arrived($msg, $this); + } return $msg; } diff -urN tiarra-20030817/main/IrcIO/Server.pm tiarra-20030920/main/IrcIO/Server.pm --- tiarra-20030817/main/IrcIO/Server.pm 2003-08-18 00:48:41.000000000 +0900 +++ tiarra-20030920/main/IrcIO/Server.pm 2003-09-20 20:11:20.000000000 +0900 @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Server.pm,v 1.44 2003/07/28 12:35:58 admin Exp $ +# $Id: Server.pm,v 1.45 2003/09/20 11:06:18 admin Exp $ # ----------------------------------------------------------------------------- # IrcIO::ServerはIRCサーバーに接続し、IRCメッセージをやり取りするクラスです。 # このクラスはサーバーからメッセージを受け取ってチャンネル情報や現在のnickなどを保持しますが、 @@ -26,7 +26,6 @@ $obj->{logged_in} = 0; # このサーバーへのログインに成功しているかどうか。 $obj->{new_connection} = 1; - $obj->{remarks} = {}; # {key => value} $obj->{receiving_namreply} = {}; # RPL_NAMREPLYを受け取ると<チャンネル名,1>になり、RPL_ENDOFNAMESを受け取るとそのチャンネルの要素が消える。 $obj->{receiving_banlist} = {}; # 同上。RPL_BANLIST @@ -118,14 +117,6 @@ $this->{user_realname} = $def->($conf->name,$general->name); } -sub remark { - my ($this,$key,$newvalue) = @_; - if (defined $newvalue) { - $this->{remarks}{$key} = $newvalue; - } - $this->{remarks}{$key}; -} - sub person { # nick以外は全て省略可能。 # 未知のnickが指定された場合は新規に追加する。 diff -urN tiarra-20030817/main/IrcIO.pm tiarra-20030920/main/IrcIO.pm --- tiarra-20030817/main/IrcIO.pm 2003-08-18 00:48:41.000000000 +0900 +++ tiarra-20030920/main/IrcIO.pm 2003-09-20 20:11:20.000000000 +0900 @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: IrcIO.pm,v 1.18 2003/06/03 17:49:47 topia Exp $ +# $Id: IrcIO.pm,v 1.19 2003/09/20 11:06:19 admin Exp $ # ----------------------------------------------------------------------------- # IrcIOはIRCサーバー又はクライアントと接続し、IRCメッセージをやり取りする抽象クラスです。 # ----------------------------------------------------------------------------- @@ -58,14 +58,18 @@ $_[0]->{sendbuf} eq '' ? undef : 1; } +*remarks = \&remark; sub remark { my ($this,$key,$newvalue) = @_; if (!defined $key) { croak "IrcIO->remark, Arg[1] is undef.\n"; } - if (defined $newvalue) { + elsif (defined $newvalue) { $this->{remarks}->{$key} = $newvalue; } + elsif (@_ >= 3) { + delete $this->{remarks}{$key}; + } $this->{remarks}->{$key}; } diff -urN tiarra-20030817/main/L10N.pm tiarra-20030920/main/L10N.pm --- tiarra-20030817/main/L10N.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20030920/main/L10N.pm 2003-09-20 20:11:21.000000000 +0900 @@ -0,0 +1,121 @@ +# ----------------------------------------------------------------------------- +# $Id: L10N.pm,v 1.1 2003/09/20 11:06:19 admin Exp $ +# ----------------------------------------------------------------------------- +# メッセージのローカライズを行う為のクラス。 +# このクラスはTiarraの他のクラスに依存しません。 +# ----------------------------------------------------------------------------- +# 使い方: +# +# ----------------------------------------------------------------------------- +package L10N; +use strict; +use warnings; +use Carp; +# 指定された言語が見付からない場合に、優先して選ばれる言語。 +our $secondary_language = 'en'; + +# {パッケージ名 => L10N} +our %instances; +sub _instance { + my $this = shift; + if (ref $this) { + # そのまま + $this; + } + else { + # 二つ前のcallerのパッケージに対してのインスタンスを返す。 + my ($pkg) = caller(1); + my $in = $instances{$pkg}; + if (!defined $in) { + $in = $instances{$pkg} = L10N->new($pkg); + } + $in; + } +} + +# 言語名省略時に選ばれる言語 +our $default_language = 'ja'; +sub default_language { + if (@_ == 0) { + $default_language; + } + elsif (@_ == 1) { + $default_language = $_[0]; + } + else { + $default_language = $_[1]; + } +} + +sub instance { + my $this = _instance(shift); +} + +*reg = \®ister; +sub register { + my ($this, %args) = @_; + $this = _instance($this); + + while (my ($key, $value) = each %args) { + $this->{messages}{$key} = $value; + } + $this; +} + +sub new { + my ($class, $pkg_name) = @_; + my $this = { + pkg_name => $pkg_name, + messages => {}, # {メッセージ名 => {言語名 => メッセージ}} + }; + bless $this => $class; +} + +sub get { + my ($this, $key, $lang) = @_; + $this = _instance($this); + if (!defined $key) { + return $this->_new_autoload; + } + + $lang = $default_language if !defined $lang; + + my $msg_langs = $this->{messages}{$key}; + if (defined $msg_langs) { + my $msg = $msg_langs->{$lang}; + if (defined $msg) { + $msg; + } + elsif (defined($_ = $msg_langs->{$secondary_language})) { + $_; + } + else { + (values %$msg_langs)[0]; + } + } + else { + undef; + } +} + +# ----------------------------------------------------------------------------- +package L10N::Autoload; +our $AUTOLOAD; + +sub AUTOLOAD { + my ($this, $lang) = @_; + if ($AUTOLOAD =~ /::DESTROY$/) { + return; + } + + (my $key = $AUTOLOAD) =~ s/.+?:://g; + $this->{l10n}->get($key, $lang); +} + +package L10N; +sub _new_autoload { + my $this = shift; + bless {l10n => $this} => 'L10N::Autoload'; +} + +1; diff -urN tiarra-20030817/main/LocalChannelManager.pm tiarra-20030920/main/LocalChannelManager.pm --- tiarra-20030817/main/LocalChannelManager.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20030920/main/LocalChannelManager.pm 2003-09-20 20:11:21.000000000 +0900 @@ -0,0 +1,146 @@ +# ----------------------------------------------------------------------------- +# $Id: LocalChannelManager.pm,v 1.1 2003/09/20 11:06:19 admin Exp $ +# ----------------------------------------------------------------------------- +# このクラスはTiarraローカルなチャンネルを管理します。 +# 各クライアントに、そのクライアントが入っているTiarraローカルチャンネルを +# 註釈`tiarra-local-channels'として持たせます。 +# この註釈はチャンネル名の配列です。 +# ----------------------------------------------------------------------------- +# 使い方: +# +# ----------------------------------------------------------------------------- +package LocalChannelManager; +use strict; +use warnings; +use Carp; +our $_shared_instance; + +sub shared { + if (!defined $_shared_instance) { + $_shared_instance = LocalChannelManager->_new; + } + $_shared_instance; +} + +sub _new { + my $class = shift; + my $this = { + registered => {}, # {チャンネル名 => [トピック(文字列), ハンドラ(クロージャ)]} + }; + bless $this => $class; +} + +sub register { + # Name => チャンネル名 + # Topic => トピック + # Handler => ハンドラ; $handler->($client, $msg)のように呼ばれる。 + my ($this, %args) = @_; + + foreach my $arg (qw/Name Topic Handler/) { + if (!defined $args{$arg}) { + croak "LocalChannelManager->register, Arg{Name} is undef.\n"; + } + } + if (ref($args{Handler}) ne 'CODE') { + croak "LocalChannelManager->register, Arg{Handler} is not a function.\n"; + } + + if (defined $this->{registered}{$args{Name}}) { + croak "LocalChannelManager->register, channel `$args{Name}' is already registered.\n"; + } + + $this->{registered}{$args{Name}} = [@args{'Topic', 'Handler'}]; + $this; +} + +sub unregister { + my ($this, $channel) = @_; + delete $this->{registered}{$channel}; + $this; +} + +sub registered_p { + my ($this, $channel) = @_; + defined $this->{registered}{$channel}; +} + +sub message_arrived { + # IRCMessageまたはundefを返す。 + my ($this, $msg, $sender) = @_; + + my $method = '_'.$msg->command; + if ($this->can($method)) { + $this->$method($msg, $sender); + } + else { + $msg; + } +} + +sub _JOIN { + my ($this, $msg, $sender) = @_; + + # チャンネル名のリストから、Tiarraローカルチャンネルを抜き取る。 + my @new_list; + foreach my $ch_name (split m/,/, $msg->param(0)) { + if ($this->registered_p($ch_name)) { + my ($topic, $handler) = @{$this->{registered}{$ch_name}}; + + # このクライアントの`tiarra-local-channels'に入っているか？ + my $list = $sender->remark('tiarra-local-channels'); + if (!defined $list) { + $list = []; + $sender->remark('tiarra-local-channels', $list); + } + if (!{map {$_ => 1} @$list}->{$ch_name}) { + # 入っていないのでJOIN処理を行う。 + push @$list, $ch_name; + + my $local_nick = RunLoop->shared->current_nick; + # まずJOIN + $sender->send_message( + IRCMessage->new( + Prefix => $sender->fullname, + Command => 'JOIN', + Param => $ch_name)); + # 次にRPL_TOPIC(あれば) + if ($topic ne '') { + $sender->send_message( + IRCMessage->new( + Prefix => 'Tiarra', + Command => '332', + Params => [ + $local_nick, + $ch_name, + $topic, + ])); + } + # 次にRPL_NAMREPLY。この本人だけ。 + $sender->send_message( + IRCMessage->new( + Prefix => 'Tiarra', + Command => '353', + Params => [$local_nick, + '=', + $ch_name, + $local_nick])); + # そしてRPL_ENOFNAMES + $sender->send_message( + IRCMessage->new( + Prefix => 'Tiarra', + Command => '366', + Params => [$local_nick, + $ch_name, + 'End of NAMES list'])); + } + } + else { + push @new_list, $ch_name; + } + } + $msg->param(0, join(',', @new_list)); + + $msg; +} + +1; diff -urN tiarra-20030817/main/Mask.pm tiarra-20030920/main/Mask.pm --- tiarra-20030817/main/Mask.pm 2003-08-18 00:48:42.000000000 +0900 +++ tiarra-20030920/main/Mask.pm 2003-09-20 20:11:20.000000000 +0900 @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Mask.pm,v 1.10 2003/07/31 07:34:13 topia Exp $ +# $Id: Mask.pm,v 1.11 2003/09/20 11:06:19 admin Exp $ # ----------------------------------------------------------------------------- # $Clovery: tiarra/main/Mask.pm,v 1.10 2003/07/24 03:08:26 topia Exp $ package Mask; @@ -223,15 +223,35 @@ } # support functions +my $cache_limit = 300; +my @cache_keys; +my %cache_table; sub make_regex { - my ($str) = @_; + my $str = $_[0]; - # マスク文字列 - $str =~ s/(\W)/\\$1/g; - $str =~ s/\\\?/\./g; - $str =~ s/\\\*/\.\*/g; - $str = "^$str\$"; - return $str; + if (my $cached = $cache_table{$str}) { + $cached; + } + else { + # キャッシュされていない。 + if (@cache_keys >= $cache_limit) { + # キャッシュされている値をランダムに一つ消す。 + my $to_delete = scalar(splice @cache_keys, int(rand @cache_keys), 1); + delete $cache_table{$to_delete}; + } + + my $regex = $str; + $regex =~ s/(\W)/\\$1/g; + $regex =~ s/\\\?/\./g; + $regex =~ s/\\\*/\.\*/g; + $regex = "^$regex\$"; + + my $compiled = qr/$regex/; + push @cache_keys, $str; + $cache_table{$str} = $compiled; + + $compiled; + } } sub _split { diff -urN tiarra-20030817/main/PersonInChannel.pm tiarra-20030920/main/PersonInChannel.pm --- tiarra-20030817/main/PersonInChannel.pm 2003-08-18 00:48:42.000000000 +0900 +++ tiarra-20030920/main/PersonInChannel.pm 2003-09-20 20:11:20.000000000 +0900 @@ -1,8 +1,8 @@ # ----------------------------------------------------------------------------- -# $Id: PersonInChannel.pm,v 1.4 2003/06/06 13:50:17 admin Exp $ +# $Id: PersonInChannel.pm,v 1.5 2003/09/20 11:06:19 admin Exp $ # -*- cperl -*- # ----------------------------------------------------------------------------- -# $Id: PersonInChannel.pm,v 1.4 2003/06/06 13:50:17 admin Exp $ +# $Id: PersonInChannel.pm,v 1.5 2003/09/20 11:06:19 admin Exp $ # ----------------------------------------------------------------------------- # なるとや発言権を持っているかどうかの情報とPersonalInfoのセット。 # ----------------------------------------------------------------------------- @@ -12,53 +12,73 @@ use Carp; use PersonalInfo; +use constant PERSON => 0; +use constant HAS_O => 1; +use constant HAS_V => 2; +use constant REMARKS => 3; + sub new { my ($class,$person,$has_o,$has_v) = @_; croak "PersonInChannel->new requires 3 parameters.\n" if @_ != 4; - my $obj = { - person => $person, - has_o => $has_o, - has_v => $has_v, - remarks => {}, - }; - bless $obj,$class; + my $obj = bless [] => $class; + $obj->[PERSON] = $person; + $obj->[HAS_O] = $has_o; + $obj->[HAS_V] = $has_v; + $obj->[REMARKS] = undef; + $obj; } sub person { - shift->{person}; + shift->[PERSON]; } sub info { - shift->{person}->info; + shift->[PERSON]->info; } sub has_o { my ($this,$option) = @_; - $this->{has_o} = $option if defined $option; - $this->{has_o}; + $this->[HAS_O] = $option if defined $option; + $this->[HAS_O]; } sub has_v { my ($this,$option) = @_; - $this->{has_v} = $option if defined $option; - $this->{has_v}; + $this->[HAS_V] = $option if defined $option; + $this->[HAS_V]; } *remarks = \&remark; sub remark { my ($this,$key,$value) = @_; + my $remarks = $this->[REMARKS]; + if (defined $value) { - $this->{remarks}->{$key} = $value; + if (!$remarks) { + $remarks = $this->[REMARKS] = {}; + } + + $remarks->{$key} = $value; } elsif (@_ >= 3) { - delete $this->{remarks}{$key}; + if ($remarks) { + delete $remarks->{$key}; + } + } + + if ($remarks) { + $remarks->{$key}; + } + else { + undef; } - $this->{remarks}->{$key}; } sub delete_remark { my ($this,$key) = @_; - delete $this->{remarks}->{$key}; + if ($_ = $this->[REMARKS]) { + delete $_->{$key}; + } } 1; diff -urN tiarra-20030817/main/PersonalInfo.pm tiarra-20030920/main/PersonalInfo.pm --- tiarra-20030817/main/PersonalInfo.pm 2003-08-18 00:48:42.000000000 +0900 +++ tiarra-20030920/main/PersonalInfo.pm 2003-09-20 20:11:21.000000000 +0900 @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: PersonalInfo.pm,v 1.5 2003/06/03 15:27:42 admin Exp $ +# $Id: PersonalInfo.pm,v 1.6 2003/09/20 11:06:19 admin Exp $ # ----------------------------------------------------------------------------- # nick,username,userhost等を持つ個人情報保持クラス。 # このオブジェクトはIrcIO::Serverが管理する。 @@ -14,23 +14,28 @@ use Carp; our $AUTOLOAD; +use constant NICK => 0; +use constant USERNAME => 1; +use constant USERHOST => 2; +use constant REALNAME => 3; +use constant SERVER => 4; + sub new { my ($class,%args) = @_; - my $def_or_null = sub{ defined $_[0] ? $_[0] : '' }; - my $obj = { - nick => $def_or_null->($args{Nick}), - username => $def_or_null->($args{UserName}), - userhost => $def_or_null->($args{UserHost}), - realname => $def_or_null->($args{RealName}), - server => $def_or_null->($args{Server}), - }; - bless $obj,$class; # 最低限Nickさえ指定されていれば良い。 - unless (defined $obj->{nick}) { + unless (defined $args{Nick}) { croak "PersonalInfo must be created with Nick parameter.\n"; } + my $def_or_null = sub{ defined $_[0] ? $_[0] : '' }; + my $obj = bless [] => $class; + $obj->[NICK] = $def_or_null->($args{Nick}); + $obj->[USERNAME] = $def_or_null->($args{UserName}); + $obj->[USERHOST] = $def_or_null->($args{UserHost}); + $obj->[REALNAME] = $def_or_null->($args{RealName}); + $obj->[SERVER] = $def_or_null->($args{Server}); + $obj; } @@ -40,21 +45,27 @@ } sub AUTOLOAD { - my ($this,$option) = @_; + my ($this, $option) = @_; (my $key = $AUTOLOAD) =~ s/^.*?:://g; if ($key eq 'DESTROY') { return; } - - unless (defined $this->{$key}) { + + my $idx; + my $constname = uc($key); + if ($this->can($constname)) { + $idx = $this->$constname; + } + + if (!defined $idx or !defined $this->[$idx]) { croak "PersonalInfo doesn't have the information $key.\n"; } if (defined $option) { - $this->{$key} = $option; + $this->[$idx] = $option; } - return $this->{$key}; + return $this->[$idx]; } 1; diff -urN tiarra-20030817/main/RunLoop.pm tiarra-20030920/main/RunLoop.pm --- tiarra-20030817/main/RunLoop.pm 2003-08-18 00:48:42.000000000 +0900 +++ tiarra-20030920/main/RunLoop.pm 2003-09-20 20:11:21.000000000 +0900 @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: RunLoop.pm,v 1.44 2003/08/12 01:45:34 admin Exp $ +# $Id: RunLoop.pm,v 1.45 2003/09/20 11:06:19 admin Exp $ # ----------------------------------------------------------------------------- # このクラスはTiarraのメインループを実装します。 # select()を実行し、サーバーやクライアントとのI/Oを行うのはこのクラスです。 @@ -38,7 +38,7 @@ *shared = \&shared_loop; sub shared_loop { - unless (defined $_shared_instance) { + if (!defined $_shared_instance) { $_shared_instance = _new RunLoop; } $_shared_instance;