IRC3/Client/Connection.pm

package Net::IRC3::Client::Connection;
use base "Net::IRC3::Connection";
use Net::IRC3::Util qw/prefix_nick/;
use strict;
no warnings;

our $DEBUG;

=head1 NAME

Net::IRC3::Client::Connection - A highlevel IRC connection

=head1 SYNOPSIS

   use AnyEvent;
   use Net::IRC3::Client::Connection;

   my $c = AnyEvent->condvar;

   my $timer;
   my $con = new Net::IRC3::Client::Connection;

   $con->reg_cb (registered => sub { print "I'm in!\n"; 0 });
   $con->reg_cb (disconnect => sub { print "I'm out!\n"; 0 });
   $con->reg_cb (
      sent => sub {
         if ($_[2] eq 'PRIVMSG') {
            print "Sent message!\n";
            $timer = AnyEvent->timer (after => 1, cb => sub { $c->broadcast });
         }
         1
      }
   );

   $con->send_srv (PRIVMSG => "Hello there i'm the cool Net::IRC3 test script!", 'elmex');

   $con->connect ("localhost", 6667);
   $con->register (qw/testbot testbot testbot/);

   $c->wait;
   undef $timer;

   $con->disconnect;

=head1 DESCRIPTION

L<Net::IRC3::Client::Connection> is a highlevel client connection,
that manages all the stuff that noone wants to implement again and again
when handling with IRC. For example it PONGs the server or keeps track
of the users on a channel.

=head2 A NOTE TO CASE MANAGEMENT

The case insensitivity of channelnames and nicknames can lead to headaches
when dealing with IRC in an automated client which tracks channels and nicknames.

I tried to preserve the case in all channel and nicknames
Net::IRC3::Client::Connection passes to his user. But in the internal
structures i'm using lower case for the channel names.

The returned hash from C<channel_list> for example has the lower case of the
joined channels as keys.

But i tried to preserve the case in all events that are emitted.
Please keep this in mind when handling the events.

For example a user might joins #TeSt and parts #test later.

=head1 EVENTS

The following events are emitted by L<Net::IRC3::Client::Connection>.
Use C<reg_cb> as described in L<Net::IRC3::Connection> to register to such an
event.

=over 4

=item B<registered>

Emitted when the connection got successfully registered.

=item B<channel_add $channel @nicks>

Emitted when C<@nicks> are added to the channel C<$channel>,
this happens for example when someone JOINs a channel or when you
get a RPL_NAMREPLY (see RFC2812).

=item B<channel_remove $channel @nicks>

Emitted when C<@nicks> are removed from the channel C<$channel>,
happens for example when they PART, QUIT or get KICKed.

=item B<channel_change $channel $old_nick $new_nick $is_myself>

Emitted when a nickname on a channel changes. This is emitted when a NICK
change occurs from C<$old_nick> to C<$new_nick> give the application a chance
to quickly analyze what channels were affected.  C<$is_myself> is true when
youself was the one who changed the nick.

=item B<join $nick $channel $is_myself>

Emitted when C<$nick> enters the channel C<$channel> by JOINing.
C<$is_myself> is true if youself are the one who JOINs.

=item B<part $nick $channel $is_myself $msg>

Emitted when C<$nick> PARTs the channel C<$channel>.
C<$is_myself> is true if youself are the one who PARTs.
C<$msg> is the PART message.

=item B<nick_change $old_nick $new_nick $is_myself>

Emitted when C<$old_nick> is renamed to C<$new_nick>.
C<$is_myself> is true when youself was the one who changed the nick.

=item B<quit $nick $msg>

Emitted when the nickname C<$nick> QUITs with the message C<$msg>.

=item B<publicmsg $channel $ircmsg>

Emitted for NOTICE and PRIVMSG where the target C<$channel> is a channel.
C<$ircmsg> is the original IRC message hash like it is returned by C<parse_irc_msg>.

=item B<privatemsg $nick $ircmsg>

Emitted for NOTICE and PRIVMSG where the target C<$nick> (most of the time you) is a nick.
C<$ircmsg> is the original IRC message hash like it is returned by C<parse_irc_msg>.

=item B<error $code $message $ircmsg>

Emitted when any error occurs. C<$code> is the 3 digit error id string from RFC
2812 and C<$message> is a description of the error. C<$ircmsg> is the complete
error irc message.

You may use Net::IRC3::Util::rfc_code_to_name to convert C<$code> to the error
name from the RFC 2812. eg.:

   rfc_code_to_name ('471') => 'ERR_CHANNELISFULL'

=back

=head1 METHODS

=over 4

=item B<new>

This constructor takes no arguments.

=cut

sub new {
   my $this = shift;
   my $class = ref($this) || $this;
   my $self = $class->SUPER::new (@_);
   $self->reg_cb (irc_001     => \&welcome_cb);
   $self->reg_cb (irc_join    => \&join_cb);
   $self->reg_cb (irc_nick    => \&nick_cb);
   $self->reg_cb (irc_part    => \&part_cb);
   $self->reg_cb (irc_kick    => \&kick_cb);
   $self->reg_cb (irc_quit    => \&quit_cb);
   $self->reg_cb (irc_353     => \&namereply_cb);
   $self->reg_cb (irc_366     => \&endofnames_cb);
   $self->reg_cb (irc_ping    => \&ping_cb);

   $self->reg_cb (irc_privmsg => \&privmsg_cb);
   $self->reg_cb (irc_notice  => \&privmsg_cb);

   $self->reg_cb ('irc_*'     => \&debug_cb)
      if $DEBUG;
   $self->reg_cb ('irc_*'     => \&anymsg_cb);

   $self->reg_cb (channel_remove => \&channel_remove_event_cb);
   $self->reg_cb (channel_add    => \&channel_add_event_cb);
   $self->reg_cb (disconnect     => \&disconnect_cb);

   $self->reg_cb (irc_437        => \&change_nick_login_cb);
   $self->reg_cb (irc_433        => \&change_nick_login_cb);

   $self->{def_nick_change} = $self->{nick_change} =
      sub {
         my ($old_nick) = @_;
         "${old_nick}_"
      };

   return $self;
}

=item B<register ($nick, $user, $real)>

Sends the IRC registration commands NICK and USER.

=cut

sub register {
   my ($self, $nick, $user, $real) = @_;

   $self->{nick} = $nick;
   $self->{user} = $user;
   $self->{real} = $real;

   $self->send_msg (undef, "NICK", undef, $nick);
   $self->send_msg (undef, "USER", $real || $nick, $user || $nick, "*", "0");
}

=item B<set_nick_change_cb $callback>

This method lets you modify the nickname renaming mechanism when registering
the connection. C<$callback> is called with the current nickname as first
argument when a ERR_NICKNAMEINUSE or ERR_UNAVAILRESOURCE error occurs on login.
The returnvalue of C<$callback> will then be used to change the nickname.

If C<$callback> is not defined the default nick change callback will be used
again.

The default callback appends '_' to the end of the nickname supplied in the
C<register> routine.

If the callback returns the same nickname that was given it the connection
will be terminated.

=cut

sub set_nick_change_cb {
   my ($self, $cb) = @_;
   $cb = $self->{def_nick_change} unless defined $cb;
   $self->{nick_change} = $cb;
}

=item B<nick ()>

Returns the current nickname, under which this connection
is registered at the IRC server. It might be different from the
one that was passed to C<register> as a nick-collision might happened
on login.

=cut

sub nick { $_[0]->{nick} }

=item B<registered ()>

Returns a true value when the connection has been registered successfull and
you can send commands.

=cut

sub registered { $_[0]->{registered} }

=item B<channel_list ()>

This returns a hash reference. The keys are the currently joined channels in lower case.
The values are hash references which contain the joined nicks as key.

NOTE: Future versions might preserve the case from the JOIN command to the channels.

=cut

sub channel_list {
   my ($self) = @_;
   return $self->{channel_list} || {};
}

=item B<send_srv ($command, $trailing, @params)>

This function sends an IRC message that is constructed by C<mk_msg (undef, $command, $trailing, @params)> (see L<Net::IRC3::Util>).
If the connection isn't yet registered (for example if the connection is slow) and hasn't got a
welcome (IRC command 001) from the server yet, the IRC message is queued until it gets a welcome.

=cut

sub send_srv {
   my ($self, @msg) = @_;

   if ($self->registered) {
      $self->send_msg (undef, @msg);

   } else {
      push @{$self->{con_queue}}, \@msg;
   }
}

=item B<clear_srv_queue>

Clears the server send queue.

=cut

sub clear_srv_queue {
   my ($self) = @_;
   $self->{con_queue} = [];
}


=item B<send_chan ($channel, $command, $trailing, @params))>

This function sends a message (constructed by C<mk_msg (undef, $command,
$trailing, @params)> to the server, like C<send_srv> only that it will queue
the messages if it hasn't joined the channel C<$channel> yet. The queued
messages will be send once the connection successfully JOINed the C<$channel>.

C<$channel> will be lowercased so that any case that comes from the server matches.
(Yes, IRC handles upper and lower case as equal :-(

Be careful with this, there are chances you might not join the channel you
wanted to join. You may wanted to join #bla and the server redirects that
and sends you that you joined #blubb. You may use C<clear_chan_queue> to
remove the queue after some timeout after joining, so that you don't end up
with a memory leak.

=cut

sub send_chan {
   my ($self, $chan, @msg) = @_;

   if ($self->{channel_list}->{lc $chan}) {
      $self->send_msg (undef, @msg);

   } else {
      push @{$self->{chan_queue}->{lc $chan}}, \@msg;
   }
}

=item B<clear_chan_queue ($channel)>

Clears the channel queue of the channel C<$channel>.

=cut

sub clear_chan_queue {
   my ($self, $chan) = @_;
   $self->{chan_queue}->{lc $chan} = [];
}

################################################################################
# Private utility functions
################################################################################

sub _was_me {
   my ($self, $msg) = @_;
   lc prefix_nick ($msg) eq lc $self->nick ()
}

################################################################################
# Callbacks
################################################################################

sub channel_remove_event_cb {
   my ($self, $chan, @nicks) = @_;

   for my $nick (@nicks) {
      if (lc ($nick) eq lc ($self->nick ())) {
         delete $self->{chan_queue}->{lc $chan};
         delete $self->{channel_list}->{lc $chan};
         last;
      } else {
         delete $self->{channel_list}->{lc $chan}->{$nick};
      }
   }

   1;
}

sub channel_add_event_cb {
   my ($self, $chan, @nicks) = @_;

   for my $nick (@nicks) {
      if (lc ($nick) eq lc ($self->nick ())) {
         for (@{$self->{chan_queue}->{lc $chan}}) {
            $self->send_msg (undef, @$_);
         }
         $self->clear_chan_queue ($chan);
      }

      $self->{channel_list}->{lc $chan}->{$nick} = 1;
   }

   1;
}

sub _filter_new_nicks_from_channel {
   my ($self, $chan, @nicks) = @_;
   grep { not exists $self->{channel_list}->{lc $chan}->{$_} } @nicks;
}

sub anymsg_cb {
   my ($self, $msg) = @_;

   my $cmd = lc $msg->{command};

   if (    $cmd ne "privmsg"
       and $cmd ne "notice"
       and $cmd ne "part"
       and $cmd ne "join"
       and not ($cmd >= 400 and $cmd <= 599)
      )
   {
      $self->event (statmsg => $msg);
   } elsif ($cmd >= 400 and $cmd <= 599) {
      $self->event (error => $msg->{command}, $msg->{trailing}, $msg);
   }

   1;
}

sub privmsg_cb {
   my ($self, $msg) = @_;

   my $targ = $msg->{params}->[0];
   if ($targ =~ m/^(?:[#+&]|![A-Z0-9]{5})/) {
      $self->event (publicmsg => $targ, $msg);

   } else {
      $self->event (privatemsg => $targ, $msg);
   }

   1;
}

sub welcome_cb {
   my ($self, $msg) = @_;

   $self->{registered} = 1;

   for (@{$self->{con_queue}}) {
      $self->send_msg (undef, @$_);
   }
   $self->clear_srv_queue ();

   $self->event ('registered');

   1;
}

sub ping_cb {
   my ($self, $msg) = @_;
   $self->send_msg (undef, "PONG", $msg->{params}->[0]);

   1;
}

sub nick_cb {
   my ($self, $msg) = @_;
   my $nick = prefix_nick ($msg);
   my $newnick = $msg->{params}->[0];
   my $wasme = $self->_was_me ($msg);

   if ($wasme) { $self->{nick} = $newnick }

   my @chans;

   for my $channame (keys %{$self->{channel_list}}) {
      my $chan = $self->{channel_list}->{$channame};
      if (exists $chan->{$nick}) {
         delete $chan->{$nick};
         $chan->{$newnick} = 1;
         push @chans, $channame;
      }
   }

   for (@chans) {
      $self->event (channel_change => $_, $nick, $newnick, $wasme);
   }
   $self->event (nick_change => $nick, $newnick, $wasme);
}

sub namereply_cb {
   my ($self, $msg) = @_;
   my @nicks = split / /, $msg->{trailing};
   push @{$self->{_tmp_namereply}}, @nicks;

   1;
}

sub endofnames_cb {
   my ($self, $msg) = @_;
   my $chan = $msg->{params}->[1];
   my @nicks =
      $self->_filter_new_nicks_from_channel (
         $chan, map { s/^[@\+%&]//; $_ } @{delete $self->{_tmp_namereply}}
      );

   $self->event (channel_add => $chan, @nicks) if @nicks;

   1;
}

sub join_cb {
   my ($self, $msg) = @_;
   my $chan = $msg->{params}->[0];
   my $nick = prefix_nick ($msg);

   $self->event (channel_add => $chan, $nick);
   $self->event (join        => $nick, $chan, $self->_was_me ($msg));

   1;
}

sub part_cb {
   my ($self, $msg) = @_;
   my $chan = $msg->{params}->[0];
   my $nick = prefix_nick ($msg);

   $self->event (part           => $nick, $chan, $self->_was_me ($msg), $msg->{params}->[1]);
   $self->event (channel_remove => $chan, $nick);

   1;
}

sub kick_cb {
   my ($self, $msg) = @_;
   my $chan        = $msg->{params}->[0];
   my $kicked_nick = $msg->{params}->[1];

   $self->event (channel_remove => $chan, $kicked_nick);

   1;
}

sub quit_cb {
   my ($self, $msg) = @_;
   my $nick = prefix_nick ($msg);

   $self->event (quit => $nick, $msg->{params}->[1]);

   for (keys %{$self->{channel_list}}) {
      $self->event (channel_remove => $_, $nick)
         if $self->{channel_list}->{$_}->{$nick};
   }

   1;
}

sub debug_cb {
   my ($self, $msg) = @_;
   print "$self->{h}:$self->{p} > ";
   print (join " ", map { $_ => $msg->{$_} } sort keys %$msg);
   print " params:";
   print (join ",", @{$msg->{params}});
   print "\n";

   1;
}

sub change_nick_login_cb {
   my ($self, $msg) = @_;

   unless ($self->registered) {
      my $newnick = $self->{nick_change}->($self->nick);

      if (lc $newnick eq lc $self->{nick}) {
         $self->disconnect;
         return 0;
      }

      $self->{nick} = $newnick;
      $self->send_msg (undef, "NICK", undef, $newnick);
   }

   not ($self->registered) # kill the cb when registered
}

sub disconnect_cb {
   my ($self) = @_;

   for (keys %{$self->{channel_list}}) {
      $self->event (channel_remove => $_, $self->nick)
   }

   1
}

=back

=head1 EXAMPLES

See samples/netirc3cl and other samples in samples/ for some examples on how to use Net::IRC3::Client::Connection.

=head1 AUTHOR

Robin Redeker, C<< <elmex@ta-sa.org> >>

=head1 SEE ALSO

L<Net::IRC3::Connection>

RFC 2812 - Internet Relay Chat: Client Protocol

=head1 COPYRIGHT & LICENSE

Copyright 2006 Robin Redeker, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1;
Revision:	1.21
Committed:	Mon Mar 5 00:17:18 2007 UTC (19 years, 7 months ago) by elmex
Branch:	MAIN
Changes since 1.20:	+5 -7 lines
Log Message:	fixed a weirdness in the error event and fixed a bug with debugging events.
#	User	Rev	Content
1	elmex	1.1	package Net::IRC3::Client::Connection;
2	elmex	1.4	use base "Net::IRC3::Connection";
3			use Net::IRC3::Util qw/prefix_nick/;
4	elmex	1.12	use strict;
5	elmex	1.17	no warnings;
6	elmex	1.1
7	elmex	1.4	our $DEBUG;
8	elmex	1.1
9			=head1 NAME
10
11			Net::IRC3::Client::Connection - A highlevel IRC connection
12
13			=head1 SYNOPSIS
14
15	elmex	1.5	use AnyEvent;
16			use Net::IRC3::Client::Connection;
17	elmex	1.1
18	elmex	1.5	my $c = AnyEvent->condvar;
19	elmex	1.1
20	elmex	1.5	my $timer;
21			my $con = new Net::IRC3::Client::Connection;
22	elmex	1.1
23	elmex	1.5	$con->reg_cb (registered => sub { print "I'm in!\n"; 0 });
24			$con->reg_cb (disconnect => sub { print "I'm out!\n"; 0 });
25			$con->reg_cb (
26			sent => sub {
27			if ($_[2] eq 'PRIVMSG') {
28			print "Sent message!\n";
29			$timer = AnyEvent->timer (after => 1, cb => sub { $c->broadcast });
30			}
31			1
32			}
33			);
34
35			$con->send_srv (PRIVMSG => "Hello there i'm the cool Net::IRC3 test script!", 'elmex');
36
37			$con->connect ("localhost", 6667);
38			$con->register (qw/testbot testbot testbot/);
39	elmex	1.1
40	elmex	1.5	$c->wait;
41			undef $timer;
42
43			$con->disconnect;
44	elmex	1.1
45			=head1 DESCRIPTION
46
47	elmex	1.5	L<Net::IRC3::Client::Connection> is a highlevel client connection,
48			that manages all the stuff that noone wants to implement again and again
49			when handling with IRC. For example it PONGs the server or keeps track
50			of the users on a channel.
51	elmex	1.1
52	elmex	1.13	=head2 A NOTE TO CASE MANAGEMENT
53
54			The case insensitivity of channelnames and nicknames can lead to headaches
55			when dealing with IRC in an automated client which tracks channels and nicknames.
56
57			I tried to preserve the case in all channel and nicknames
58			Net::IRC3::Client::Connection passes to his user. But in the internal
59			structures i'm using lower case for the channel names.
60
61			The returned hash from C<channel_list> for example has the lower case of the
62			joined channels as keys.
63
64			But i tried to preserve the case in all events that are emitted.
65			Please keep this in mind when handling the events.
66
67			For example a user might joins #TeSt and parts #test later.
68
69	elmex	1.2	=head1 EVENTS
70
71			The following events are emitted by L<Net::IRC3::Client::Connection>.
72			Use C<reg_cb> as described in L<Net::IRC3::Connection> to register to such an
73			event.
74	elmex	1.1
75			=over 4
76
77	elmex	1.3	=item B<registered>
78
79			Emitted when the connection got successfully registered.
80
81	elmex	1.2	=item B<channel_add $channel @nicks>
82
83			Emitted when C<@nicks> are added to the channel C<$channel>,
84			this happens for example when someone JOINs a channel or when you
85			get a RPL_NAMREPLY (see RFC2812).
86
87			=item B<channel_remove $channel @nicks>
88
89			Emitted when C<@nicks> are removed from the channel C<$channel>,
90			happens for example when they PART, QUIT or get KICKed.
91
92	elmex	1.13	=item B<channel_change $channel $old_nick $new_nick $is_myself>
93
94			Emitted when a nickname on a channel changes. This is emitted when a NICK
95			change occurs from C<$old_nick> to C<$new_nick> give the application a chance
96			to quickly analyze what channels were affected. C<$is_myself> is true when
97			youself was the one who changed the nick.
98
99	elmex	1.2	=item B<join $nick $channel $is_myself>
100
101			Emitted when C<$nick> enters the channel C<$channel> by JOINing.
102			C<$is_myself> is true if youself are the one who JOINs.
103
104			=item B<part $nick $channel $is_myself $msg>
105
106			Emitted when C<$nick> PARTs the channel C<$channel>.
107			C<$is_myself> is true if youself are the one who PARTs.
108			C<$msg> is the PART message.
109	elmex	1.1
110	elmex	1.13	=item B<nick_change $old_nick $new_nick $is_myself>
111	elmex	1.12
112			Emitted when C<$old_nick> is renamed to C<$new_nick>.
113			C<$is_myself> is true when youself was the one who changed the nick.
114
115	elmex	1.3	=item B<quit $nick $msg>
116
117			Emitted when the nickname C<$nick> QUITs with the message C<$msg>.
118
119			=item B<publicmsg $channel $ircmsg>
120
121			Emitted for NOTICE and PRIVMSG where the target C<$channel> is a channel.
122			C<$ircmsg> is the original IRC message hash like it is returned by C<parse_irc_msg>.
123
124			=item B<privatemsg $nick $ircmsg>
125
126			Emitted for NOTICE and PRIVMSG where the target C<$nick> (most of the time you) is a nick.
127			C<$ircmsg> is the original IRC message hash like it is returned by C<parse_irc_msg>.
128
129	elmex	1.21	=item B<error $code $message $ircmsg>
130	elmex	1.13
131			Emitted when any error occurs. C<$code> is the 3 digit error id string from RFC
132	elmex	1.21	2812 and C<$message> is a description of the error. C<$ircmsg> is the complete
133			error irc message.
134	elmex	1.13
135			You may use Net::IRC3::Util::rfc_code_to_name to convert C<$code> to the error
136			name from the RFC 2812. eg.:
137
138			rfc_code_to_name ('471') => 'ERR_CHANNELISFULL'
139
140	elmex	1.2	=back
141
142			=head1 METHODS
143
144			=over 4
145	elmex	1.1
146	elmex	1.16	=item B<new>
147
148			This constructor takes no arguments.
149
150	elmex	1.1	=cut
151
152	elmex	1.2	sub new {
153			my $this = shift;
154			my $class = ref($this) \|\| $this;
155			my $self = $class->SUPER::new (@_);
156	elmex	1.1	$self->reg_cb (irc_001 => \&welcome_cb);
157			$self->reg_cb (irc_join => \&join_cb);
158	elmex	1.12	$self->reg_cb (irc_nick => \&nick_cb);
159	elmex	1.1	$self->reg_cb (irc_part => \&part_cb);
160	elmex	1.2	$self->reg_cb (irc_kick => \&kick_cb);
161			$self->reg_cb (irc_quit => \&quit_cb);
162	elmex	1.1	$self->reg_cb (irc_353 => \&namereply_cb);
163			$self->reg_cb (irc_366 => \&endofnames_cb);
164			$self->reg_cb (irc_ping => \&ping_cb);
165
166			$self->reg_cb (irc_privmsg => \&privmsg_cb);
167			$self->reg_cb (irc_notice => \&privmsg_cb);
168
169			$self->reg_cb ('irc_*' => \&debug_cb)
170			if $DEBUG;
171			$self->reg_cb ('irc_*' => \&anymsg_cb);
172
173	elmex	1.16	$self->reg_cb (channel_remove => \&channel_remove_event_cb);
174			$self->reg_cb (channel_add => \&channel_add_event_cb);
175			$self->reg_cb (disconnect => \&disconnect_cb);
176	elmex	1.2
177	elmex	1.16	$self->reg_cb (irc_437 => \&change_nick_login_cb);
178			$self->reg_cb (irc_433 => \&change_nick_login_cb);
179	elmex	1.13
180	elmex	1.17	$self->{def_nick_change} = $self->{nick_change} =
181			sub {
182			my ($old_nick) = @_;
183			"${old_nick}_"
184			};
185	elmex	1.13
186	elmex	1.2	return $self;
187			}
188
189			=item B<register ($nick, $user, $real)>
190
191			Sends the IRC registration commands NICK and USER.
192
193			=cut
194
195			sub register {
196			my ($self, $nick, $user, $real) = @_;
197
198	elmex	1.13	$self->{nick} = $nick;
199			$self->{user} = $user;
200			$self->{real} = $real;
201
202	elmex	1.1	$self->send_msg (undef, "NICK", undef, $nick);
203			$self->send_msg (undef, "USER", $real \|\| $nick, $user \|\| $nick, "*", "0");
204	elmex	1.13	}
205
206			=item B<set_nick_change_cb $callback>
207
208			This method lets you modify the nickname renaming mechanism when registering
209			the connection. C<$callback> is called with the current nickname as first
210			argument when a ERR_NICKNAMEINUSE or ERR_UNAVAILRESOURCE error occurs on login.
211			The returnvalue of C<$callback> will then be used to change the nickname.
212
213	elmex	1.17	If C<$callback> is not defined the default nick change callback will be used
214			again.
215
216	elmex	1.13	The default callback appends '_' to the end of the nickname supplied in the
217			C<register> routine.
218
219			If the callback returns the same nickname that was given it the connection
220			will be terminated.
221	elmex	1.1
222	elmex	1.13	=cut
223
224			sub set_nick_change_cb {
225			my ($self, $cb) = @_;
226	elmex	1.17	$cb = $self->{def_nick_change} unless defined $cb;
227	elmex	1.13	$self->{nick_change} = $cb;
228	elmex	1.1	}
229
230			=item B<nick ()>
231
232			Returns the current nickname, under which this connection
233			is registered at the IRC server. It might be different from the
234			one that was passed to C<register> as a nick-collision might happened
235			on login.
236
237			=cut
238
239			sub nick { $_[0]->{nick} }
240
241	elmex	1.17	=item B<registered ()>
242	elmex	1.13
243			Returns a true value when the connection has been registered successfull and
244			you can send commands.
245
246			=cut
247
248	elmex	1.17	sub registered { $_[0]->{registered} }
249	elmex	1.13
250	elmex	1.1	=item B<channel_list ()>
251
252	elmex	1.13	This returns a hash reference. The keys are the currently joined channels in lower case.
253			The values are hash references which contain the joined nicks as key.
254
255			NOTE: Future versions might preserve the case from the JOIN command to the channels.
256	elmex	1.1
257			=cut
258
259			sub channel_list {
260			my ($self) = @_;
261	elmex	1.12	return $self->{channel_list} \|\| {};
262	elmex	1.1	}
263
264	elmex	1.5	=item B<send_srv ($command, $trailing, @params)>
265	elmex	1.1
266	elmex	1.5	This function sends an IRC message that is constructed by C<mk_msg (undef, $command, $trailing, @params)> (see L<Net::IRC3::Util>).
267	elmex	1.1	If the connection isn't yet registered (for example if the connection is slow) and hasn't got a
268			welcome (IRC command 001) from the server yet, the IRC message is queued until it gets a welcome.
269
270			=cut
271
272			sub send_srv {
273			my ($self, @msg) = @_;
274
275	elmex	1.17	if ($self->registered) {
276	elmex	1.1	$self->send_msg (undef, @msg);
277
278			} else {
279			push @{$self->{con_queue}}, \@msg;
280			}
281			}
282
283			=item B<clear_srv_queue>
284
285			Clears the server send queue.
286
287			=cut
288
289			sub clear_srv_queue {
290			my ($self) = @_;
291			$self->{con_queue} = [];
292			}
293
294
295	elmex	1.5	=item B<send_chan ($channel, $command, $trailing, @params))>
296
297	elmex	1.13	This function sends a message (constructed by C<mk_msg (undef, $command,
298			$trailing, @params)> to the server, like C<send_srv> only that it will queue
299			the messages if it hasn't joined the channel C<$channel> yet. The queued
300			messages will be send once the connection successfully JOINed the C<$channel>.
301	elmex	1.1
302	elmex	1.12	C<$channel> will be lowercased so that any case that comes from the server matches.
303			(Yes, IRC handles upper and lower case as equal :-(
304
305			Be careful with this, there are chances you might not join the channel you
306			wanted to join. You may wanted to join #bla and the server redirects that
307			and sends you that you joined #blubb. You may use C<clear_chan_queue> to
308			remove the queue after some timeout after joining, so that you don't end up
309			with a memory leak.
310
311	elmex	1.1	=cut
312
313			sub send_chan {
314			my ($self, $chan, @msg) = @_;
315
316	elmex	1.14	if ($self->{channel_list}->{lc $chan}) {
317	elmex	1.1	$self->send_msg (undef, @msg);
318
319			} else {
320			push @{$self->{chan_queue}->{lc $chan}}, \@msg;
321			}
322			}
323
324			=item B<clear_chan_queue ($channel)>
325
326			Clears the channel queue of the channel C<$channel>.
327
328			=cut
329
330			sub clear_chan_queue {
331			my ($self, $chan) = @_;
332			$self->{chan_queue}->{lc $chan} = [];
333			}
334
335			################################################################################
336	elmex	1.2	# Private utility functions
337			################################################################################
338
339			sub _was_me {
340			my ($self, $msg) = @_;
341	elmex	1.4	lc prefix_nick ($msg) eq lc $self->nick ()
342	elmex	1.2	}
343
344			################################################################################
345	elmex	1.1	# Callbacks
346			################################################################################
347
348	elmex	1.16	sub channel_remove_event_cb {
349	elmex	1.2	my ($self, $chan, @nicks) = @_;
350
351			for my $nick (@nicks) {
352	elmex	1.12	if (lc ($nick) eq lc ($self->nick ())) {
353			delete $self->{chan_queue}->{lc $chan};
354	elmex	1.13	delete $self->{channel_list}->{lc $chan};
355	elmex	1.2	last;
356			} else {
357	elmex	1.13	delete $self->{channel_list}->{lc $chan}->{$nick};
358	elmex	1.2	}
359			}
360
361			1;
362			}
363
364	elmex	1.16	sub channel_add_event_cb {
365	elmex	1.2	my ($self, $chan, @nicks) = @_;
366
367			for my $nick (@nicks) {
368	elmex	1.12	if (lc ($nick) eq lc ($self->nick ())) {
369			for (@{$self->{chan_queue}->{lc $chan}}) {
370	elmex	1.2	$self->send_msg (undef, @$_);
371			}
372	elmex	1.11	$self->clear_chan_queue ($chan);
373	elmex	1.2	}
374
375	elmex	1.13	$self->{channel_list}->{lc $chan}->{$nick} = 1;
376	elmex	1.2	}
377
378			1;
379			}
380
381	elmex	1.19	sub _filter_new_nicks_from_channel {
382			my ($self, $chan, @nicks) = @_;
383			grep { not exists $self->{channel_list}->{lc $chan}->{$_} } @nicks;
384			}
385
386	elmex	1.1	sub anymsg_cb {
387			my ($self, $msg) = @_;
388
389			my $cmd = lc $msg->{command};
390
391	elmex	1.13	if ( $cmd ne "privmsg"
392	elmex	1.1	and $cmd ne "notice"
393			and $cmd ne "part"
394			and $cmd ne "join"
395	elmex	1.13	and not ($cmd >= 400 and $cmd <= 599)
396			)
397	elmex	1.1	{
398			$self->event (statmsg => $msg);
399	elmex	1.13	} elsif ($cmd >= 400 and $cmd <= 599) {
400	elmex	1.21	$self->event (error => $msg->{command}, $msg->{trailing}, $msg);
401	elmex	1.1	}
402
403			1;
404			}
405
406			sub privmsg_cb {
407			my ($self, $msg) = @_;
408
409	elmex	1.3	my $targ = $msg->{params}->[0];
410			if ($targ =~ m/^(?:[#+&]\|![A-Z0-9]{5})/) {
411			$self->event (publicmsg => $targ, $msg);
412	elmex	1.1
413			} else {
414	elmex	1.3	$self->event (privatemsg => $targ, $msg);
415	elmex	1.1	}
416
417			1;
418			}
419
420			sub welcome_cb {
421			my ($self, $msg) = @_;
422
423	elmex	1.17	$self->{registered} = 1;
424	elmex	1.1
425			for (@{$self->{con_queue}}) {
426			$self->send_msg (undef, @$_);
427			}
428	elmex	1.11	$self->clear_srv_queue ();
429	elmex	1.1
430	elmex	1.12	$self->event ('registered');
431
432	elmex	1.1	1;
433			}
434
435			sub ping_cb {
436			my ($self, $msg) = @_;
437	elmex	1.8	$self->send_msg (undef, "PONG", $msg->{params}->[0]);
438	elmex	1.2
439			1;
440	elmex	1.1	}
441
442	elmex	1.12	sub nick_cb {
443			my ($self, $msg) = @_;
444			my $nick = prefix_nick ($msg);
445			my $newnick = $msg->{params}->[0];
446			my $wasme = $self->_was_me ($msg);
447
448	elmex	1.13	if ($wasme) { $self->{nick} = $newnick }
449	elmex	1.12
450	elmex	1.13	my @chans;
451	elmex	1.12
452	elmex	1.13	for my $channame (keys %{$self->{channel_list}}) {
453			my $chan = $self->{channel_list}->{$channame};
454	elmex	1.12	if (exists $chan->{$nick}) {
455			delete $chan->{$nick};
456			$chan->{$newnick} = 1;
457	elmex	1.13	push @chans, $channame;
458	elmex	1.12	}
459			}
460
461	elmex	1.13	for (@chans) {
462			$self->event (channel_change => $_, $nick, $newnick, $wasme);
463			}
464	elmex	1.12	$self->event (nick_change => $nick, $newnick, $wasme);
465			}
466
467	elmex	1.1	sub namereply_cb {
468			my ($self, $msg) = @_;
469	elmex	1.2	my @nicks = split / /, $msg->{trailing};
470			push @{$self->{_tmp_namereply}}, @nicks;
471	elmex	1.10
472			1;
473	elmex	1.1	}
474
475			sub endofnames_cb {
476			my ($self, $msg) = @_;
477	elmex	1.12	my $chan = $msg->{params}->[1];
478	elmex	1.20	my @nicks =
479	elmex	1.19	$self->_filter_new_nicks_from_channel (
480	elmex	1.20	$chan, map { s/^[@\+%&]//; $_ } @{delete $self->{_tmp_namereply}}
481			);
482
483			$self->event (channel_add => $chan, @nicks) if @nicks;
484	elmex	1.10
485			1;
486	elmex	1.1	}
487
488			sub join_cb {
489			my ($self, $msg) = @_;
490	elmex	1.2	my $chan = $msg->{params}->[0];
491	elmex	1.4	my $nick = prefix_nick ($msg);
492	elmex	1.1
493	elmex	1.12	$self->event (channel_add => $chan, $nick);
494	elmex	1.2	$self->event (join => $nick, $chan, $self->_was_me ($msg));
495	elmex	1.1
496	elmex	1.2	1;
497			}
498
499			sub part_cb {
500			my ($self, $msg) = @_;
501			my $chan = $msg->{params}->[0];
502	elmex	1.4	my $nick = prefix_nick ($msg);
503	elmex	1.1
504	elmex	1.2	$self->event (part => $nick, $chan, $self->_was_me ($msg), $msg->{params}->[1]);
505			$self->event (channel_remove => $chan, $nick);
506	elmex	1.1
507	elmex	1.2	1;
508			}
509	elmex	1.1
510	elmex	1.2	sub kick_cb {
511			my ($self, $msg) = @_;
512			my $chan = $msg->{params}->[0];
513			my $kicked_nick = $msg->{params}->[1];
514	elmex	1.1
515	elmex	1.2	$self->event (channel_remove => $chan, $kicked_nick);
516	elmex	1.1
517			1;
518			}
519
520	elmex	1.2	sub quit_cb {
521	elmex	1.1	my ($self, $msg) = @_;
522	elmex	1.4	my $nick = prefix_nick ($msg);
523	elmex	1.1
524	elmex	1.2	$self->event (quit => $nick, $msg->{params}->[1]);
525	elmex	1.1
526	elmex	1.12	for (keys %{$self->{channel_list}}) {
527	elmex	1.14	$self->event (channel_remove => $_, $nick)
528			if $self->{channel_list}->{$_}->{$nick};
529	elmex	1.1	}
530	elmex	1.10
531			1;
532	elmex	1.1	}
533
534			sub debug_cb {
535			my ($self, $msg) = @_;
536			print "$self->{h}:$self->{p} > ";
537			print (join " ", map { $_ => $msg->{$_} } sort keys %$msg);
538			print " params:";
539	elmex	1.21	print (join ",", @{$msg->{params}});
540	elmex	1.1	print "\n";
541	elmex	1.10
542			1;
543	elmex	1.1	}
544
545	elmex	1.16	sub change_nick_login_cb {
546	elmex	1.13	my ($self, $msg) = @_;
547
548	elmex	1.17	unless ($self->registered) {
549	elmex	1.13	my $newnick = $self->{nick_change}->($self->nick);
550
551			if (lc $newnick eq lc $self->{nick}) {
552			$self->disconnect;
553			return 0;
554			}
555
556			$self->{nick} = $newnick;
557			$self->send_msg (undef, "NICK", undef, $newnick);
558			}
559
560	elmex	1.17	not ($self->registered) # kill the cb when registered
561	elmex	1.13	}
562
563	elmex	1.15	sub disconnect_cb {
564			my ($self) = @_;
565
566			for (keys %{$self->{channel_list}}) {
567			$self->event (channel_remove => $_, $self->nick)
568			}
569
570			1
571			}
572
573	elmex	1.1	=back
574
575			=head1 EXAMPLES
576
577			See samples/netirc3cl and other samples in samples/ for some examples on how to use Net::IRC3::Client::Connection.
578
579			=head1 AUTHOR
580
581			Robin Redeker, C<< <elmex@ta-sa.org> >>
582
583			=head1 SEE ALSO
584
585	elmex	1.7	L<Net::IRC3::Connection>
586	elmex	1.1
587			RFC 2812 - Internet Relay Chat: Client Protocol
588
589			=head1 COPYRIGHT & LICENSE
590
591	elmex	1.6	Copyright 2006 Robin Redeker, all rights reserved.
592	elmex	1.1
593			This program is free software; you can redistribute it and/or modify it
594			under the same terms as Perl itself.
595
596			=cut
597
598			1;