| 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; |
