root/lang/perl/tiarra/trunk/module/Auto/Utils.pm @ 15704

Revision 11365, 9.4 kB (checked in by topia, 7 years ago)

* merge UTF-8 branch.

  • Property svn:mime-type set to text/x-perl; charset=UTF-8
  • Property svn:eol-style set to LF
  • Property svn:keywords set to Id URL Date Rev Author
Line 
1# -----------------------------------------------------------------------------
2# $Id$
3# -----------------------------------------------------------------------------
4package Auto::Utils;
5use strict;
6use warnings;
7use Module::Use qw(Auto::AliasDB);
8use Auto::AliasDB;
9use Multicast;
10use RunLoop;
11use base qw(Tiarra::IRC::NewMessageMixin);
12
13# get_ch_name は get_raw_ch_name のエイリアス(過去互換のため)
14*get_ch_name = \&get_raw_ch_name;
15sub get_raw_ch_name {
16    # ネットワーク名抜きの送信先(チャンネル/nick)名 or undef を得る
17    my ($msg, $ch_place) = @_;
18
19    if (defined($msg->param($ch_place)) && $msg->param($ch_place) ne '') {
20        return(scalar(Multicast::detach($msg->param($ch_place))));
21    } else {
22        return undef;
23    }
24}
25
26sub get_full_ch_name {
27    # ネットワーク名付きの送信先(チャンネル/nick)名 or undef を得る
28    my ($msg, $ch_place) = @_;
29
30    if (defined($msg->param($ch_place)) && $msg->param($ch_place) ne '') {
31        return($msg->param($ch_place));
32    } else {
33        return undef;
34    }
35}
36
37sub sendto_channel_closure {
38    # チャンネル等に PRIVMSG / NOTICE を送るクロージャを返します。
39
40    # - 引数 -
41    # $sendto   : チャンネル名 or ニック。ネットワーク名を付けて下さい。
42    # $command  : 'PRIVMSG' or 'NOTICE'。その他のコマンドも制限はしませんが意味が無いでしょう。
43    # $msg      : message_arrivedに渡ってきた$msg。エイリアス置換に使用されます。よって、
44    #               後述する $use_alias が false なら指定する必要はありません。
45    #               その場合は undef でも渡しておきましょう。
46    # $sender   : message_arrivedに渡ってきた$sender。送信に使います。ない場合は
47    #               $result とともに undef を指定してください。
48    # $result   : message_arrivedの返り値にする配列の参照。詳細は例を見ましょう。
49    # $use_alias        : エイリアス置き換えを行うかどうか。省略可で省略した場合は
50    #                       行うが、 $msg, $sender のどちらかが undef ならエイリアス
51    #                       置き換えを呼び出せないので行わない。
52    # $extra_callbacks
53    #           : 追加のエイリアス置換コールバック。省略可。
54    #
55    # エイリアス置換・コールバックに関しては Auto::AliasDB を参照してください。
56    #
57    # - 返り値 -
58    #   $send_message
59    # $send_message
60    #           : クロージャ。第一引数にメッセージ、第二引数以降に追加のエイリアス(省略可能)を指定して呼び出す。
61    #               メッセージとしてundefが渡された場合は、何もせずに終了する。
62    #
63    # - 使用例 -
64    #       sub message_arrived {
65    #           my ($this,$msg,$sender) = @_;
66    #           my @result = ($msg);
67    #           my $send_message =
68    #               sendto_channel_closure('#test@ircnet', 'NOTICE', $msg, $sender, \@result);
69    #           $send_message->('message', 'hoge' => 'moge');
70    #           return @result;
71    #       }
72    #
73
74    my ($sendto, $command, $msg, $sender, $result, $use_alias, $extra_callbacks) = @_;
75
76    $use_alias = 1 if (!defined $use_alias && defined $msg && defined $sender);
77    $extra_callbacks = [] unless defined $extra_callbacks;
78
79    return sub {
80        my ($line,%extra_replaces) = @_;
81        return if !defined $line;
82        foreach my $str ((ref($line) eq 'ARRAY') ? @$line : $line) {
83            my $msg_to_send = __PACKAGE__->construct_irc_message(
84                Command => $command,
85                Params => ['',  # 後で設定
86                           ($use_alias ? Auto::AliasDB->shared->stdreplace_add(
87                               $msg->prefix || $sender->fullname,
88                               $str,
89                               $extra_callbacks,
90                               $msg,
91                               $sender,
92                               %extra_replaces)
93                                : $str)]);
94            my ($rawname, $network_name, $specified_network) =
95                Multicast::detach($sendto);
96            my $get_network_name = sub {
97                $specified_network ? $network_name :
98                    Configuration->shared_conf->networks->default;
99            };
100            my $sendto_client = Multicast::attach_for_client($rawname, $network_name);
101            if (!defined $sender) {
102                # 鯖にはチャンネル名にネットワーク名を付けない。
103                my $for_server = $msg_to_send->clone;
104                $sender = RunLoop->shared_loop->network($get_network_name->());
105                if (defined $sender) {
106                    $for_server->param(0, $rawname);
107                    $sender->send_message($for_server);
108                }
109
110                # クライアントにはチャンネル名にネットワーク名を付ける。
111            # また、クライアントに送られる時にはPrefixがそのユーザーに設定されるよう註釈を付ける。
112                my $for_client = $msg_to_send->clone;
113                $for_client->param(0, $sendto_client);
114                $for_client->remark('fill-prefix-when-sending-to-client',1);
115                RunLoop->shared_loop->broadcast_to_clients($for_client);
116            } elsif ($sender->isa('IrcIO::Server')) {
117                # 鯖にはチャンネル名にネットワーク名を付けない。
118                my $for_server = $msg_to_send->clone;
119                $for_server->param(0, $rawname);
120                $sender->send_message($for_server);
121
122                # クライアントにはチャンネル名にネットワーク名を付ける。
123                # また、クライアントに送られる時にはPrefixがそのユーザーに設定されるよう註釈を付ける。
124                my $for_client = $msg_to_send->clone;
125                $for_client->param(0, $sendto_client);
126                $for_client->remark('fill-prefix-when-sending-to-client',1);
127                push @$result,$for_client;
128            } elsif ($sender->isa('IrcIO::Client')) {
129                # チャンネル名にネットワーク名を付ける。
130                my $for_server = $msg_to_send->clone;
131                $for_server->param(0, $sendto);
132                push @$result,$for_server;
133
134                my $for_client = $msg_to_send->clone;
135                $for_client->prefix($sender->fullname);
136                $for_client->param(0, $sendto_client);
137                $sender->send_message($for_client);
138            }
139        }
140    };
141}
142
143sub generate_reply_closures {
144    # 送信者に NOTICE で返答するクロージャを返します。
145
146    # - 引数 -
147    # $msg      : message_arrivedに渡ってきた$msg。
148    # $sender   : message_arrivedに渡ってきた$sender。
149    # $result   : message_arrivedの返り値にする配列の参照。詳細は例を見ましょう。
150    # $use_alias        : エイリアス置き換えを行うかどうか。省略可、省略した場合は行う。
151    # $extra_callbacks
152    #           : 追加のエイリアス置換コールバック。省略可。
153    # $ch_place : チャンネル名が存在する $msg->param 内部の位置を指定します。省略時は0(先頭)です。
154    #
155    # エイリアス置換・コールバックに関しては Auto::AliasDB を参照してください。
156    #
157    # - 返り値 -
158    #   ($get_raw_ch_name, $reply, $reply_as_priv, $reply_anywhere, $get_full_ch_name)
159    # $get_raw_ch_name  : クロージャ。ネットワーク名無しのチャンネル名 or undef を返します。
160    # $reply            : クロージャ。チャンネルに返答します。
161    # $reply_as_priv    : クロージャ。送信者に直接 priv で返答します。
162    # $reply_anywhere   : クロージャ。チャンネルが有効であれば $reply が、そうでなければ $reply_as_priv です。
163    # $get_full_ch_name : クロージャ。ネットワーク名付きのチャンネル名 or undef を返します。
164    #
165    # $reply* は第一引数にメッセージ、第二引数以降に追加のエイリアス(省略可能)を指定して呼び出します。
166    # 第一引数にundefが渡された場合は、何もせずに終了します。
167    #
168    # - 使用例 -
169    #       sub message_arrived {
170    #           my ($this,$msg,$sender) = @_;
171    #           my @result = ($msg);
172    #           my ($get_ch_name, $reply, $reply_as_priv, $reply_anywhere) =
173    #               generate_reply_closures($msg, $sender, \@result);
174    #           $reply_anywhere->('message', 'hoge' => 'moge');
175    #           return @result;
176    #       }
177    #
178    # - 備考 -
179    # $get_raw_ch_name がクロージャなのは過去との互換性のため、
180    # $get_full_ch_name がクロージャーなのは共通性のためです。
181
182    my ($msg, $sender, $result, $use_alias, $extra_callbacks, $ch_place) = @_;
183    $use_alias = 1 unless defined $use_alias;
184    $extra_callbacks = [] unless defined $extra_callbacks;
185    $ch_place = 0 unless defined $ch_place;
186
187    my $raw_ch_name = get_raw_ch_name($msg, $ch_place);
188    my $get_raw_ch_name = sub () {
189        $raw_ch_name;
190    };
191    my $full_ch_name = get_full_ch_name($msg, $ch_place);
192    my $get_full_ch_name = sub () {
193        $full_ch_name;
194    };
195    my $reply = sub {
196        sendto_channel_closure($msg->param($ch_place), 'NOTICE', $msg, $sender, $result,
197                               $use_alias, $extra_callbacks)->(@_, 'channel' => $raw_ch_name);
198    };
199    my $reply_as_priv = sub {
200        my ($line,%extra_replaces) = @_;
201        return if !defined $line;
202        foreach my $str ((ref($line) eq 'ARRAY') ? @$line : $line) {
203            $sender->send_message(__PACKAGE__->construct_irc_message(
204                Command => 'NOTICE',
205                Params => [$msg->nick,
206                           ($use_alias ? Auto::AliasDB->shared->stdreplace_add(
207                               $msg->prefix,
208                               $str,
209                               $extra_callbacks,
210                               $msg,
211                               $sender,
212                               %extra_replaces)
213                                : $str)]));
214        }
215    };
216    my $reply_anywhere = sub {
217        if (defined($raw_ch_name) && Multicast::nick_p($raw_ch_name)) {
218            return $reply_as_priv;
219        } else {
220            return $reply;
221        }
222    };
223    return ($get_raw_ch_name,$reply,$reply_as_priv,$reply_anywhere->(),$get_full_ch_name);
224}
225
2261;
Note: See TracBrowser for help on using the browser.