1 |
package Net::IRC3::Client::Connection; |
2 |
use base "Net::IRC3::Connection"; |
3 |
use Net::IRC3::Util qw/prefix_nick decode_ctcp/; |
4 |
use strict; |
5 |
no warnings; |
6 |
|
7 |
=head1 NAME |
8 |
|
9 |
Net::IRC3::Client::Connection - A highlevel IRC connection |
10 |
|
11 |
=head1 SYNOPSIS |
12 |
|
13 |
use AnyEvent; |
14 |
use Net::IRC3::Client::Connection; |
15 |
|
16 |
my $c = AnyEvent->condvar; |
17 |
|
18 |
my $timer; |
19 |
my $con = new Net::IRC3::Client::Connection; |
20 |
|
21 |
$con->reg_cb (registered => sub { print "I'm in!\n"; 0 }); |
22 |
$con->reg_cb (disconnect => sub { print "I'm out!\n"; 0 }); |
23 |
$con->reg_cb ( |
24 |
sent => sub { |
25 |
if ($_[2] eq 'PRIVMSG') { |
26 |
print "Sent message!\n"; |
27 |
$timer = AnyEvent->timer (after => 1, cb => sub { $c->broadcast }); |
28 |
} |
29 |
1 |
30 |
} |
31 |
); |
32 |
|
33 |
$con->send_srv (PRIVMSG => "Hello there i'm the cool Net::IRC3 test script!", 'elmex'); |
34 |
|
35 |
$con->connect ("localhost", 6667); |
36 |
$con->register (qw/testbot testbot testbot/); |
37 |
|
38 |
$c->wait; |
39 |
undef $timer; |
40 |
|
41 |
$con->disconnect; |
42 |
|
43 |
=head1 DESCRIPTION |
44 |
|
45 |
B<NOTE:> This module is B<DEPRECATED>, please use L<AnyEvent::IRC> for new programs, |
46 |
and possibly port existing L<Net::IRC3> applications to L<AnyEvent::IRC>. Though the |
47 |
API of L<AnyEvent::IRC> has incompatible changes, it's still fairly similar. |
48 |
|
49 |
|
50 |
L<Net::IRC3::Client::Connection> is a (nearly) highlevel client connection, |
51 |
that manages all the stuff that noone wants to implement again and again |
52 |
when handling with IRC. For example it PONGs the server or keeps track |
53 |
of the users on a channel. |
54 |
|
55 |
Please note that CTCP handling is still up to you. It will be decoded |
56 |
for you and events will be generated. But generating replies |
57 |
is up to you. |
58 |
|
59 |
=head2 A NOTE TO CASE MANAGEMENT |
60 |
|
61 |
The case insensitivity of channelnames and nicknames can lead to headaches |
62 |
when dealing with IRC in an automated client which tracks channels and nicknames. |
63 |
|
64 |
I tried to preserve the case in all channel and nicknames |
65 |
Net::IRC3::Client::Connection passes to his user. But in the internal |
66 |
structures i'm using lower case for the channel names. |
67 |
|
68 |
The returned hash from C<channel_list> for example has the lower case of the |
69 |
joined channels as keys. |
70 |
|
71 |
But i tried to preserve the case in all events that are emitted. |
72 |
Please keep this in mind when handling the events. |
73 |
|
74 |
For example a user might joins #TeSt and parts #test later. |
75 |
|
76 |
=head1 EVENTS |
77 |
|
78 |
The following events are emitted by L<Net::IRC3::Client::Connection>. |
79 |
Use C<reg_cb> as described in L<Net::IRC3::Connection> to register to such an |
80 |
event. |
81 |
|
82 |
=over 4 |
83 |
|
84 |
=item B<registered> |
85 |
|
86 |
Emitted when the connection got successfully registered. |
87 |
|
88 |
=item B<channel_add $msg, $channel @nicks> |
89 |
|
90 |
Emitted when C<@nicks> are added to the channel C<$channel>, |
91 |
this happens for example when someone JOINs a channel or when you |
92 |
get a RPL_NAMREPLY (see RFC2812). |
93 |
|
94 |
C<$msg> ist he IRC message hash that as returned by C<parse_irc_msg>. |
95 |
|
96 |
=item B<channel_remove $msg, $channel @nicks> |
97 |
|
98 |
Emitted when C<@nicks> are removed from the channel C<$channel>, |
99 |
happens for example when they PART, QUIT or get KICKed. |
100 |
|
101 |
C<$msg> ist he IRC message hash that as returned by C<parse_irc_msg> |
102 |
or undef if the reason for the removal was a disconnect on our end. |
103 |
|
104 |
=item B<channel_change $channel $old_nick $new_nick $is_myself> |
105 |
|
106 |
Emitted when a nickname on a channel changes. This is emitted when a NICK |
107 |
change occurs from C<$old_nick> to C<$new_nick> give the application a chance |
108 |
to quickly analyze what channels were affected. C<$is_myself> is true when |
109 |
youself was the one who changed the nick. |
110 |
|
111 |
=item B<channel_topic $channel $topic $who> |
112 |
|
113 |
This is emitted when the topic for a channel is discovered. C<$channel> |
114 |
is the channel for which C<$topic> is the current topic now. |
115 |
Which is set by C<$who>. C<$who> might be undefined when it's not known |
116 |
who set the channel topic. |
117 |
|
118 |
=item B<join $nick $channel $is_myself> |
119 |
|
120 |
Emitted when C<$nick> enters the channel C<$channel> by JOINing. |
121 |
C<$is_myself> is true if youself are the one who JOINs. |
122 |
|
123 |
=item B<part $nick $channel $is_myself $msg> |
124 |
|
125 |
Emitted when C<$nick> PARTs the channel C<$channel>. |
126 |
C<$is_myself> is true if youself are the one who PARTs. |
127 |
C<$msg> is the PART message. |
128 |
|
129 |
=item B<part $kicked_nick $channel $is_myself $msg> |
130 |
|
131 |
Emitted when C<$kicked_nick> is KICKed from the channel C<$channel>. |
132 |
C<$is_myself> is true if youself are the one who got KICKed. |
133 |
C<$msg> is the PART message. |
134 |
|
135 |
=item B<nick_change $old_nick $new_nick $is_myself> |
136 |
|
137 |
Emitted when C<$old_nick> is renamed to C<$new_nick>. |
138 |
C<$is_myself> is true when youself was the one who changed the nick. |
139 |
|
140 |
=item B<ctcp $src, $target, $tag, $msg, $type> |
141 |
|
142 |
Emitted when a CTCP message was found in either a NOTICE or PRIVMSG |
143 |
message. C<$tag> is the CTCP message tag. (eg. "PING", "VERSION", ...). |
144 |
C<$msg> is the CTCP message and C<$type> is either "NOTICE" or "PRIVMSG". |
145 |
|
146 |
C<$src> is the source nick the message came from. |
147 |
C<$target> is the target nickname (yours) or the channel the ctcp was sent |
148 |
on. |
149 |
|
150 |
=item B<"ctcp_$tag", $src, $target, $msg, $type> |
151 |
|
152 |
Emitted when a CTCP message was found in either a NOTICE or PRIVMSG |
153 |
message. C<$tag> is the CTCP message tag (in lower case). (eg. "ping", "version", ...). |
154 |
C<$msg> is the CTCP message and C<$type> is either "NOTICE" or "PRIVMSG". |
155 |
|
156 |
C<$src> is the source nick the message came from. |
157 |
C<$target> is the target nickname (yours) or the channel the ctcp was sent |
158 |
on. |
159 |
|
160 |
=item B<quit $nick $msg> |
161 |
|
162 |
Emitted when the nickname C<$nick> QUITs with the message C<$msg>. |
163 |
|
164 |
=item B<publicmsg $channel $ircmsg> |
165 |
|
166 |
Emitted for NOTICE and PRIVMSG where the target C<$channel> is a channel. |
167 |
C<$ircmsg> is the original IRC message hash like it is returned by C<parse_irc_msg>. |
168 |
|
169 |
The trailing part of the C<$ircmsg> will have all CTCP messages stripped off. |
170 |
|
171 |
=item B<privatemsg $nick $ircmsg> |
172 |
|
173 |
Emitted for NOTICE and PRIVMSG where the target C<$nick> (most of the time you) is a nick. |
174 |
C<$ircmsg> is the original IRC message hash like it is returned by C<parse_irc_msg>. |
175 |
|
176 |
The trailing part of the C<$ircmsg> will have all CTCP messages stripped off. |
177 |
|
178 |
=item B<error $code $message $ircmsg> |
179 |
|
180 |
Emitted when any error occurs. C<$code> is the 3 digit error id string from RFC |
181 |
2812 and C<$message> is a description of the error. C<$ircmsg> is the complete |
182 |
error irc message. |
183 |
|
184 |
You may use Net::IRC3::Util::rfc_code_to_name to convert C<$code> to the error |
185 |
name from the RFC 2812. eg.: |
186 |
|
187 |
rfc_code_to_name ('471') => 'ERR_CHANNELISFULL' |
188 |
|
189 |
=item B<debug_send $prefix $command $trailing @params> |
190 |
|
191 |
Is emitted everytime some command is sent. |
192 |
|
193 |
=item B<debug_recv $ircmsg> |
194 |
|
195 |
Is emitted everytime some command was received. |
196 |
|
197 |
=back |
198 |
|
199 |
=head1 METHODS |
200 |
|
201 |
=over 4 |
202 |
|
203 |
=item B<new> |
204 |
|
205 |
This constructor takes no arguments. |
206 |
|
207 |
=cut |
208 |
|
209 |
sub new { |
210 |
my $this = shift; |
211 |
my $class = ref($this) || $this; |
212 |
my $self = $class->SUPER::new (@_); |
213 |
|
214 |
$self->reg_cb ('irc_*' => \&debug_cb); |
215 |
$self->reg_cb (irc_001 => \&welcome_cb); |
216 |
$self->reg_cb (irc_join => \&join_cb); |
217 |
$self->reg_cb (irc_nick => \&nick_cb); |
218 |
$self->reg_cb (irc_part => \&part_cb); |
219 |
$self->reg_cb (irc_kick => \&kick_cb); |
220 |
$self->reg_cb (irc_quit => \&quit_cb); |
221 |
$self->reg_cb (irc_353 => \&namereply_cb); |
222 |
$self->reg_cb (irc_366 => \&endofnames_cb); |
223 |
$self->reg_cb (irc_ping => \&ping_cb); |
224 |
$self->reg_cb (irc_pong => \&pong_cb); |
225 |
|
226 |
$self->reg_cb (irc_privmsg => \&privmsg_cb); |
227 |
$self->reg_cb (irc_notice => \&privmsg_cb); |
228 |
|
229 |
$self->reg_cb ('irc_*' => \&anymsg_cb); |
230 |
|
231 |
$self->reg_cb (channel_remove => \&channel_remove_event_cb); |
232 |
$self->reg_cb (channel_add => \&channel_add_event_cb); |
233 |
$self->reg_cb (disconnect => \&disconnect_cb); |
234 |
|
235 |
$self->reg_cb (irc_437 => \&change_nick_login_cb); |
236 |
$self->reg_cb (irc_433 => \&change_nick_login_cb); |
237 |
|
238 |
$self->reg_cb (irc_332 => \&rpl_topic_cb); |
239 |
$self->reg_cb (irc_topic => \&topic_change_cb); |
240 |
|
241 |
$self->{def_nick_change} = $self->{nick_change} = |
242 |
sub { |
243 |
my ($old_nick) = @_; |
244 |
"${old_nick}_" |
245 |
}; |
246 |
|
247 |
return $self; |
248 |
} |
249 |
|
250 |
=item B<register ($nick, $user, $real, $server_pass)> |
251 |
|
252 |
Sends the IRC registration commands NICK and USER. |
253 |
If C<$server_pass> is passed also a PASS command is generated. |
254 |
|
255 |
=cut |
256 |
|
257 |
sub register { |
258 |
my ($self, $nick, $user, $real, $pass) = @_; |
259 |
|
260 |
$self->{nick} = $nick; |
261 |
$self->{user} = $user; |
262 |
$self->{real} = $real; |
263 |
$self->{server_pass} = $pass; |
264 |
|
265 |
$self->send_msg (undef, "PASS", undef, $pass) if defined $pass; |
266 |
$self->send_msg (undef, "NICK", undef, $nick); |
267 |
$self->send_msg (undef, "USER", $real || $nick, $user || $nick, "*", "0"); |
268 |
} |
269 |
|
270 |
=item B<set_nick_change_cb $callback> |
271 |
|
272 |
This method lets you modify the nickname renaming mechanism when registering |
273 |
the connection. C<$callback> is called with the current nickname as first |
274 |
argument when a ERR_NICKNAMEINUSE or ERR_UNAVAILRESOURCE error occurs on login. |
275 |
The returnvalue of C<$callback> will then be used to change the nickname. |
276 |
|
277 |
If C<$callback> is not defined the default nick change callback will be used |
278 |
again. |
279 |
|
280 |
The default callback appends '_' to the end of the nickname supplied in the |
281 |
C<register> routine. |
282 |
|
283 |
If the callback returns the same nickname that was given it the connection |
284 |
will be terminated. |
285 |
|
286 |
=cut |
287 |
|
288 |
sub set_nick_change_cb { |
289 |
my ($self, $cb) = @_; |
290 |
$cb = $self->{def_nick_change} unless defined $cb; |
291 |
$self->{nick_change} = $cb; |
292 |
} |
293 |
|
294 |
=item B<nick ()> |
295 |
|
296 |
Returns the current nickname, under which this connection |
297 |
is registered at the IRC server. It might be different from the |
298 |
one that was passed to C<register> as a nick-collision might happened |
299 |
on login. |
300 |
|
301 |
=cut |
302 |
|
303 |
sub nick { $_[0]->{nick} } |
304 |
|
305 |
=item B<registered ()> |
306 |
|
307 |
Returns a true value when the connection has been registered successfull and |
308 |
you can send commands. |
309 |
|
310 |
=cut |
311 |
|
312 |
sub registered { $_[0]->{registered} } |
313 |
|
314 |
=item B<channel_list ()> |
315 |
|
316 |
This returns a hash reference. The keys are the currently joined channels in lower case. |
317 |
The values are hash references which contain the joined nicks as key. |
318 |
|
319 |
NOTE: Future versions might preserve the case from the JOIN command to the channels. |
320 |
|
321 |
=cut |
322 |
|
323 |
sub channel_list { |
324 |
my ($self) = @_; |
325 |
return $self->{channel_list} || {}; |
326 |
} |
327 |
|
328 |
=item B<send_msg (...)> |
329 |
|
330 |
See also L<Net::IRC3::Connection>. |
331 |
|
332 |
=cut |
333 |
|
334 |
sub send_msg { |
335 |
my ($self, @a) = @_; |
336 |
$self->event (debug_send => @a); |
337 |
$self->SUPER::send_msg (@a); |
338 |
} |
339 |
|
340 |
=item B<send_srv ($command, $trailing, @params)> |
341 |
|
342 |
This function sends an IRC message that is constructed by C<mk_msg (undef, $command, $trailing, @params)> (see L<Net::IRC3::Util>). |
343 |
If the connection isn't yet registered (for example if the connection is slow) and hasn't got a |
344 |
welcome (IRC command 001) from the server yet, the IRC message is queued until it gets a welcome. |
345 |
|
346 |
=cut |
347 |
|
348 |
sub send_srv { |
349 |
my ($self, @msg) = @_; |
350 |
|
351 |
if ($self->registered) { |
352 |
$self->send_msg (undef, @msg); |
353 |
|
354 |
} else { |
355 |
push @{$self->{con_queue}}, \@msg; |
356 |
} |
357 |
} |
358 |
|
359 |
=item B<clear_srv_queue> |
360 |
|
361 |
Clears the server send queue. |
362 |
|
363 |
=cut |
364 |
|
365 |
sub clear_srv_queue { |
366 |
my ($self) = @_; |
367 |
$self->{con_queue} = []; |
368 |
} |
369 |
|
370 |
|
371 |
=item B<send_chan ($channel, $command, $trailing, @params))> |
372 |
|
373 |
This function sends a message (constructed by C<mk_msg (undef, $command, |
374 |
$trailing, @params)> to the server, like C<send_srv> only that it will queue |
375 |
the messages if it hasn't joined the channel C<$channel> yet. The queued |
376 |
messages will be send once the connection successfully JOINed the C<$channel>. |
377 |
|
378 |
C<$channel> will be lowercased so that any case that comes from the server matches. |
379 |
(Yes, IRC handles upper and lower case as equal :-( |
380 |
|
381 |
Be careful with this, there are chances you might not join the channel you |
382 |
wanted to join. You may wanted to join #bla and the server redirects that |
383 |
and sends you that you joined #blubb. You may use C<clear_chan_queue> to |
384 |
remove the queue after some timeout after joining, so that you don't end up |
385 |
with a memory leak. |
386 |
|
387 |
=cut |
388 |
|
389 |
sub send_chan { |
390 |
my ($self, $chan, @msg) = @_; |
391 |
|
392 |
if ($self->{channel_list}->{lc $chan}) { |
393 |
$self->send_msg (undef, @msg); |
394 |
|
395 |
} else { |
396 |
push @{$self->{chan_queue}->{lc $chan}}, \@msg; |
397 |
} |
398 |
} |
399 |
|
400 |
=item B<clear_chan_queue ($channel)> |
401 |
|
402 |
Clears the channel queue of the channel C<$channel>. |
403 |
|
404 |
=cut |
405 |
|
406 |
sub clear_chan_queue { |
407 |
my ($self, $chan) = @_; |
408 |
$self->{chan_queue}->{lc $chan} = []; |
409 |
} |
410 |
|
411 |
=item B<enable_ping ($interval, $cb)> |
412 |
|
413 |
This method enables a periodical ping to the server with an interval of |
414 |
C<$interval> seconds. If no PONG was received from the server until the next |
415 |
interval the connection will be terminated or the callback in C<$cb> will be called. |
416 |
|
417 |
(C<$cb> will have the connection object as it's first argument.) |
418 |
|
419 |
Make sure you call this method after the connection has been established. |
420 |
(eg. in the callback for the C<registered> event). |
421 |
|
422 |
=cut |
423 |
|
424 |
sub enable_ping { |
425 |
my ($self, $int, $cb) = @_; |
426 |
|
427 |
$self->{last_pong_recv} = 0; |
428 |
$self->{last_ping_sent} = time; |
429 |
|
430 |
$self->send_srv (PING => "Net::IRC3"); |
431 |
|
432 |
$self->{_ping_timer} = |
433 |
AnyEvent->timer (after => $int, cb => sub { |
434 |
if ($self->{last_pong_recv} < $self->{last_ping_sent}) { |
435 |
delete $self->{_ping_timer}; |
436 |
if ($cb) { |
437 |
$cb->($self); |
438 |
} else { |
439 |
$self->disconnect ("Server timeout"); |
440 |
} |
441 |
|
442 |
} else { |
443 |
$self->enable_ping ($int, $cb); |
444 |
} |
445 |
}); |
446 |
} |
447 |
|
448 |
################################################################################ |
449 |
# Private utility functions |
450 |
################################################################################ |
451 |
|
452 |
sub _was_me { |
453 |
my ($self, $msg) = @_; |
454 |
lc prefix_nick ($msg) eq lc $self->nick () |
455 |
} |
456 |
|
457 |
################################################################################ |
458 |
# Callbacks |
459 |
################################################################################ |
460 |
|
461 |
sub channel_remove_event_cb { |
462 |
my ($self, $msg, $chan, @nicks) = @_; |
463 |
|
464 |
for my $nick (@nicks) { |
465 |
if (lc ($nick) eq lc ($self->nick ())) { |
466 |
delete $self->{chan_queue}->{lc $chan}; |
467 |
delete $self->{channel_list}->{lc $chan}; |
468 |
last; |
469 |
} else { |
470 |
delete $self->{channel_list}->{lc $chan}->{$nick}; |
471 |
} |
472 |
} |
473 |
|
474 |
1; |
475 |
} |
476 |
|
477 |
sub channel_add_event_cb { |
478 |
my ($self, $msg, $chan, @nicks) = @_; |
479 |
|
480 |
for my $nick (@nicks) { |
481 |
if (lc ($nick) eq lc ($self->nick ())) { |
482 |
for (@{$self->{chan_queue}->{lc $chan}}) { |
483 |
$self->send_msg (undef, @$_); |
484 |
} |
485 |
$self->clear_chan_queue ($chan); |
486 |
} |
487 |
|
488 |
$self->{channel_list}->{lc $chan}->{$nick} = 1; |
489 |
} |
490 |
|
491 |
1; |
492 |
} |
493 |
|
494 |
sub _filter_new_nicks_from_channel { |
495 |
my ($self, $chan, @nicks) = @_; |
496 |
grep { not exists $self->{channel_list}->{lc $chan}->{$_} } @nicks; |
497 |
} |
498 |
|
499 |
sub anymsg_cb { |
500 |
my ($self, $msg) = @_; |
501 |
|
502 |
my $cmd = lc $msg->{command}; |
503 |
|
504 |
if ( $cmd ne "privmsg" |
505 |
and $cmd ne "notice" |
506 |
and $cmd ne "part" |
507 |
and $cmd ne "join" |
508 |
and not ($cmd >= 400 and $cmd <= 599) |
509 |
) |
510 |
{ |
511 |
$self->event (statmsg => $msg); |
512 |
} elsif ($cmd >= 400 and $cmd <= 599) { |
513 |
$self->event (error => $msg->{command}, $msg->{trailing}, $msg); |
514 |
} |
515 |
|
516 |
1; |
517 |
} |
518 |
|
519 |
sub privmsg_cb { |
520 |
my ($self, $msg) = @_; |
521 |
|
522 |
my ($trail, $ctcp) = decode_ctcp ($msg->{trailing}); |
523 |
|
524 |
for (@$ctcp) { |
525 |
$self->event (ctcp => prefix_nick ($msg), $msg->{params}->[0], $_->[0], $_->[1], $msg->{command}); |
526 |
$self->event ("ctcp_".lc ($_->[0]), prefix_nick ($msg), $msg->{params}->[0], $_->[1], $msg->{command}); |
527 |
} |
528 |
|
529 |
$msg->{trailing} = $trail; |
530 |
|
531 |
if ($msg->{trailing} ne '') { |
532 |
my $targ = $msg->{params}->[0]; |
533 |
if ($targ =~ m/^(?:[#+&]|![A-Z0-9]{5})/) { |
534 |
$self->event (publicmsg => $targ, $msg); |
535 |
|
536 |
} else { |
537 |
$self->event (privatemsg => $targ, $msg); |
538 |
} |
539 |
} |
540 |
|
541 |
1; |
542 |
} |
543 |
|
544 |
sub welcome_cb { |
545 |
my ($self, $msg) = @_; |
546 |
|
547 |
$self->{registered} = 1; |
548 |
|
549 |
for (@{$self->{con_queue}}) { |
550 |
$self->send_msg (undef, @$_); |
551 |
} |
552 |
$self->clear_srv_queue (); |
553 |
|
554 |
$self->event ('registered'); |
555 |
|
556 |
1; |
557 |
} |
558 |
|
559 |
sub ping_cb { |
560 |
my ($self, $msg) = @_; |
561 |
$self->send_msg (undef, "PONG", $msg->{params}->[0]); |
562 |
|
563 |
1; |
564 |
} |
565 |
|
566 |
sub pong_cb { |
567 |
my ($self, $msg) = @_; |
568 |
$self->{last_pong_recv} = time; |
569 |
1; |
570 |
} |
571 |
|
572 |
sub nick_cb { |
573 |
my ($self, $msg) = @_; |
574 |
my $nick = prefix_nick ($msg); |
575 |
my $newnick = $msg->{params}->[0]; |
576 |
my $wasme = $self->_was_me ($msg); |
577 |
|
578 |
if ($wasme) { $self->{nick} = $newnick } |
579 |
|
580 |
my @chans; |
581 |
|
582 |
for my $channame (keys %{$self->{channel_list}}) { |
583 |
my $chan = $self->{channel_list}->{$channame}; |
584 |
if (exists $chan->{$nick}) { |
585 |
delete $chan->{$nick}; |
586 |
$chan->{$newnick} = 1; |
587 |
|
588 |
push @chans, $channame; |
589 |
} |
590 |
} |
591 |
|
592 |
for (@chans) { |
593 |
$self->event (channel_change => $_, $nick, $newnick, $wasme); |
594 |
} |
595 |
$self->event (nick_change => $nick, $newnick, $wasme); |
596 |
|
597 |
1; |
598 |
} |
599 |
|
600 |
sub namereply_cb { |
601 |
my ($self, $msg) = @_; |
602 |
my @nicks = split / /, $msg->{trailing}; |
603 |
push @{$self->{_tmp_namereply}}, @nicks; |
604 |
|
605 |
1; |
606 |
} |
607 |
|
608 |
sub endofnames_cb { |
609 |
my ($self, $msg) = @_; |
610 |
my $chan = $msg->{params}->[1]; |
611 |
my @nicks = |
612 |
$self->_filter_new_nicks_from_channel ( |
613 |
$chan, map { s/^[~@\+%&]//; $_ } @{delete $self->{_tmp_namereply}} |
614 |
); |
615 |
|
616 |
$self->event (channel_add => $msg, $chan, @nicks) if @nicks; |
617 |
|
618 |
1; |
619 |
} |
620 |
|
621 |
sub join_cb { |
622 |
my ($self, $msg) = @_; |
623 |
my $chan = $msg->{params}->[0]; |
624 |
my $nick = prefix_nick ($msg); |
625 |
|
626 |
$self->event (channel_add => $msg, $chan, $nick); |
627 |
$self->event (join => $nick, $chan, $self->_was_me ($msg)); |
628 |
|
629 |
1; |
630 |
} |
631 |
|
632 |
sub part_cb { |
633 |
my ($self, $msg) = @_; |
634 |
my $chan = $msg->{params}->[0]; |
635 |
my $nick = prefix_nick ($msg); |
636 |
|
637 |
$self->event (part => $nick, $chan, $self->_was_me ($msg), $msg->{params}->[1]); |
638 |
$self->event (channel_remove => $msg, $chan, $nick); |
639 |
|
640 |
1; |
641 |
} |
642 |
|
643 |
sub kick_cb { |
644 |
my ($self, $msg) = @_; |
645 |
my $chan = $msg->{params}->[0]; |
646 |
my $kicked_nick = $msg->{params}->[1]; |
647 |
|
648 |
$self->event (kick => $kicked_nick, $chan, $self->_was_me ($msg), $msg->{params}->[1]); |
649 |
$self->event (channel_remove => $msg, $chan, $kicked_nick); |
650 |
|
651 |
1; |
652 |
} |
653 |
|
654 |
sub quit_cb { |
655 |
my ($self, $msg) = @_; |
656 |
my $nick = prefix_nick ($msg); |
657 |
|
658 |
$self->event (quit => $nick, $msg->{params}->[1]); |
659 |
|
660 |
for (keys %{$self->{channel_list}}) { |
661 |
$self->event (channel_remove => $msg, $_, $nick) |
662 |
if $self->{channel_list}->{$_}->{$nick}; |
663 |
} |
664 |
|
665 |
1; |
666 |
} |
667 |
|
668 |
sub debug_cb { |
669 |
my ($self, $msg) = @_; |
670 |
$self->event (debug_recv => $msg); |
671 |
#print "$self->{h}:$self->{p} > "; |
672 |
#print (join " ", map { $_ => $msg->{$_} } grep { $_ ne 'params' } sort keys %$msg); |
673 |
#print " params:"; |
674 |
#print (join ",", @{$msg->{params}}); |
675 |
#print "\n"; |
676 |
|
677 |
1; |
678 |
} |
679 |
|
680 |
sub change_nick_login_cb { |
681 |
my ($self, $msg) = @_; |
682 |
|
683 |
unless ($self->registered) { |
684 |
my $newnick = $self->{nick_change}->($self->nick); |
685 |
|
686 |
if (lc $newnick eq lc $self->{nick}) { |
687 |
$self->disconnect; |
688 |
return 0; |
689 |
} |
690 |
|
691 |
$self->{nick} = $newnick; |
692 |
$self->send_msg (undef, "NICK", undef, $newnick); |
693 |
} |
694 |
|
695 |
not ($self->registered) # kill the cb when registered |
696 |
} |
697 |
|
698 |
sub disconnect_cb { |
699 |
my ($self) = @_; |
700 |
|
701 |
for (keys %{$self->{channel_list}}) { |
702 |
$self->event (channel_remove => undef, $_, $self->nick) |
703 |
} |
704 |
|
705 |
1 |
706 |
} |
707 |
|
708 |
sub rpl_topic_cb { |
709 |
my ($self, $msg) = @_; |
710 |
my $chan = $msg->{params}->[1]; |
711 |
my $topic = $msg->{trailing}; |
712 |
|
713 |
$self->event (channel_topic => $chan, $topic); |
714 |
|
715 |
1 |
716 |
} |
717 |
|
718 |
sub topic_change_cb { |
719 |
my ($self, $msg) = @_; |
720 |
my $who = prefix_nick ($msg); |
721 |
my $chan = $msg->{params}->[0]; |
722 |
my $topic = $msg->{trailing}; |
723 |
|
724 |
$self->event (channel_topic => $chan, $topic, $who); |
725 |
|
726 |
1 |
727 |
} |
728 |
|
729 |
=back |
730 |
|
731 |
=head1 EXAMPLES |
732 |
|
733 |
See samples/netirc3cl and other samples in samples/ for some examples on how to use Net::IRC3::Client::Connection. |
734 |
|
735 |
=head1 AUTHOR |
736 |
|
737 |
Robin Redeker, C<< <elmex@ta-sa.org> >> |
738 |
|
739 |
=head1 SEE ALSO |
740 |
|
741 |
L<Net::IRC3::Connection> |
742 |
|
743 |
RFC 2812 - Internet Relay Chat: Client Protocol |
744 |
|
745 |
=head1 COPYRIGHT & LICENSE |
746 |
|
747 |
Copyright 2006 Robin Redeker, all rights reserved. |
748 |
|
749 |
This program is free software; you can redistribute it and/or modify it |
750 |
under the same terms as Perl itself. |
751 |
|
752 |
=cut |
753 |
|
754 |
1; |