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 @params>

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<@params> is the complete
parameter list of the error command, including the C<$message> at the end of
C<@params>.

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->{params}});
   }

   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} > ";
   my $par = delete $msg->{params};
   print (join " ", map { $_ => $msg->{$_} } sort keys %$msg);
   print " params:";
   print (join ",", @$par);
   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.20
Committed:	Sun Mar 4 22:03:49 2007 UTC (19 years, 7 months ago) by elmex
Branch:	MAIN
Changes since 1.19:	+5 -6 lines
Log Message:	fixed a minor issue with the channel_add event
#	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.13	=item B<error $code $message @params>
130
131			Emitted when any error occurs. C<$code> is the 3 digit error id string from RFC
132			2812 and C<$message> is a description of the error. C<@params> is the complete
133			parameter list of the error command, including the C<$message> at the end of
134			C<@params>.
135
136			You may use Net::IRC3::Util::rfc_code_to_name to convert C<$code> to the error
137			name from the RFC 2812. eg.:
138
139			rfc_code_to_name ('471') => 'ERR_CHANNELISFULL'
140
141	elmex	1.2	=back
142
143			=head1 METHODS
144
145			=over 4
146	elmex	1.1
147	elmex	1.16	=item B<new>
148
149			This constructor takes no arguments.
150
151	elmex	1.1	=cut
152
153	elmex	1.2	sub new {
154			my $this = shift;
155			my $class = ref($this) \|\| $this;
156			my $self = $class->SUPER::new (@_);
157	elmex	1.1	$self->reg_cb (irc_001 => \&welcome_cb);
158			$self->reg_cb (irc_join => \&join_cb);
159	elmex	1.12	$self->reg_cb (irc_nick => \&nick_cb);
160	elmex	1.1	$self->reg_cb (irc_part => \&part_cb);
161	elmex	1.2	$self->reg_cb (irc_kick => \&kick_cb);
162			$self->reg_cb (irc_quit => \&quit_cb);
163	elmex	1.1	$self->reg_cb (irc_353 => \&namereply_cb);
164			$self->reg_cb (irc_366 => \&endofnames_cb);
165			$self->reg_cb (irc_ping => \&ping_cb);
166
167			$self->reg_cb (irc_privmsg => \&privmsg_cb);
168			$self->reg_cb (irc_notice => \&privmsg_cb);
169
170			$self->reg_cb ('irc_*' => \&debug_cb)
171			if $DEBUG;
172			$self->reg_cb ('irc_*' => \&anymsg_cb);
173
174	elmex	1.16	$self->reg_cb (channel_remove => \&channel_remove_event_cb);
175			$self->reg_cb (channel_add => \&channel_add_event_cb);
176			$self->reg_cb (disconnect => \&disconnect_cb);
177	elmex	1.2
178	elmex	1.16	$self->reg_cb (irc_437 => \&change_nick_login_cb);
179			$self->reg_cb (irc_433 => \&change_nick_login_cb);
180	elmex	1.13
181	elmex	1.17	$self->{def_nick_change} = $self->{nick_change} =
182			sub {
183			my ($old_nick) = @_;
184			"${old_nick}_"
185			};
186	elmex	1.13
187	elmex	1.2	return $self;
188			}
189
190			=item B<register ($nick, $user, $real)>
191
192			Sends the IRC registration commands NICK and USER.
193
194			=cut
195
196			sub register {
197			my ($self, $nick, $user, $real) = @_;
198
199	elmex	1.13	$self->{nick} = $nick;
200			$self->{user} = $user;
201			$self->{real} = $real;
202
203	elmex	1.1	$self->send_msg (undef, "NICK", undef, $nick);
204			$self->send_msg (undef, "USER", $real \|\| $nick, $user \|\| $nick, "*", "0");
205	elmex	1.13	}
206
207			=item B<set_nick_change_cb $callback>
208
209			This method lets you modify the nickname renaming mechanism when registering
210			the connection. C<$callback> is called with the current nickname as first
211			argument when a ERR_NICKNAMEINUSE or ERR_UNAVAILRESOURCE error occurs on login.
212			The returnvalue of C<$callback> will then be used to change the nickname.
213
214	elmex	1.17	If C<$callback> is not defined the default nick change callback will be used
215			again.
216
217	elmex	1.13	The default callback appends '_' to the end of the nickname supplied in the
218			C<register> routine.
219
220			If the callback returns the same nickname that was given it the connection
221			will be terminated.
222	elmex	1.1
223	elmex	1.13	=cut
224
225			sub set_nick_change_cb {
226			my ($self, $cb) = @_;
227	elmex	1.17	$cb = $self->{def_nick_change} unless defined $cb;
228	elmex	1.13	$self->{nick_change} = $cb;
229	elmex	1.1	}
230
231			=item B<nick ()>
232
233			Returns the current nickname, under which this connection
234			is registered at the IRC server. It might be different from the
235			one that was passed to C<register> as a nick-collision might happened
236			on login.
237
238			=cut
239
240			sub nick { $_[0]->{nick} }
241
242	elmex	1.17	=item B<registered ()>
243	elmex	1.13
244			Returns a true value when the connection has been registered successfull and
245			you can send commands.
246
247			=cut
248
249	elmex	1.17	sub registered { $_[0]->{registered} }
250	elmex	1.13
251	elmex	1.1	=item B<channel_list ()>
252
253	elmex	1.13	This returns a hash reference. The keys are the currently joined channels in lower case.
254			The values are hash references which contain the joined nicks as key.
255
256			NOTE: Future versions might preserve the case from the JOIN command to the channels.
257	elmex	1.1
258			=cut
259
260			sub channel_list {
261			my ($self) = @_;
262	elmex	1.12	return $self->{channel_list} \|\| {};
263	elmex	1.1	}
264
265	elmex	1.5	=item B<send_srv ($command, $trailing, @params)>
266	elmex	1.1
267	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>).
268	elmex	1.1	If the connection isn't yet registered (for example if the connection is slow) and hasn't got a
269			welcome (IRC command 001) from the server yet, the IRC message is queued until it gets a welcome.
270
271			=cut
272
273			sub send_srv {
274			my ($self, @msg) = @_;
275
276	elmex	1.17	if ($self->registered) {
277	elmex	1.1	$self->send_msg (undef, @msg);
278
279			} else {
280			push @{$self->{con_queue}}, \@msg;
281			}
282			}
283
284			=item B<clear_srv_queue>
285
286			Clears the server send queue.
287
288			=cut
289
290			sub clear_srv_queue {
291			my ($self) = @_;
292			$self->{con_queue} = [];
293			}
294
295
296	elmex	1.5	=item B<send_chan ($channel, $command, $trailing, @params))>
297
298	elmex	1.13	This function sends a message (constructed by C<mk_msg (undef, $command,
299			$trailing, @params)> to the server, like C<send_srv> only that it will queue
300			the messages if it hasn't joined the channel C<$channel> yet. The queued
301			messages will be send once the connection successfully JOINed the C<$channel>.
302	elmex	1.1
303	elmex	1.12	C<$channel> will be lowercased so that any case that comes from the server matches.
304			(Yes, IRC handles upper and lower case as equal :-(
305
306			Be careful with this, there are chances you might not join the channel you
307			wanted to join. You may wanted to join #bla and the server redirects that
308			and sends you that you joined #blubb. You may use C<clear_chan_queue> to
309			remove the queue after some timeout after joining, so that you don't end up
310			with a memory leak.
311
312	elmex	1.1	=cut
313
314			sub send_chan {
315			my ($self, $chan, @msg) = @_;
316
317	elmex	1.14	if ($self->{channel_list}->{lc $chan}) {
318	elmex	1.1	$self->send_msg (undef, @msg);
319
320			} else {
321			push @{$self->{chan_queue}->{lc $chan}}, \@msg;
322			}
323			}
324
325			=item B<clear_chan_queue ($channel)>
326
327			Clears the channel queue of the channel C<$channel>.
328
329			=cut
330
331			sub clear_chan_queue {
332			my ($self, $chan) = @_;
333			$self->{chan_queue}->{lc $chan} = [];
334			}
335
336			################################################################################
337	elmex	1.2	# Private utility functions
338			################################################################################
339
340			sub _was_me {
341			my ($self, $msg) = @_;
342	elmex	1.4	lc prefix_nick ($msg) eq lc $self->nick ()
343	elmex	1.2	}
344
345			################################################################################
346	elmex	1.1	# Callbacks
347			################################################################################
348
349	elmex	1.16	sub channel_remove_event_cb {
350	elmex	1.2	my ($self, $chan, @nicks) = @_;
351
352			for my $nick (@nicks) {
353	elmex	1.12	if (lc ($nick) eq lc ($self->nick ())) {
354			delete $self->{chan_queue}->{lc $chan};
355	elmex	1.13	delete $self->{channel_list}->{lc $chan};
356	elmex	1.2	last;
357			} else {
358	elmex	1.13	delete $self->{channel_list}->{lc $chan}->{$nick};
359	elmex	1.2	}
360			}
361
362			1;
363			}
364
365	elmex	1.16	sub channel_add_event_cb {
366	elmex	1.2	my ($self, $chan, @nicks) = @_;
367
368			for my $nick (@nicks) {
369	elmex	1.12	if (lc ($nick) eq lc ($self->nick ())) {
370			for (@{$self->{chan_queue}->{lc $chan}}) {
371	elmex	1.2	$self->send_msg (undef, @$_);
372			}
373	elmex	1.11	$self->clear_chan_queue ($chan);
374	elmex	1.2	}
375
376	elmex	1.13	$self->{channel_list}->{lc $chan}->{$nick} = 1;
377	elmex	1.2	}
378
379			1;
380			}
381
382	elmex	1.19	sub _filter_new_nicks_from_channel {
383			my ($self, $chan, @nicks) = @_;
384			grep { not exists $self->{channel_list}->{lc $chan}->{$_} } @nicks;
385			}
386
387	elmex	1.1	sub anymsg_cb {
388			my ($self, $msg) = @_;
389
390			my $cmd = lc $msg->{command};
391
392	elmex	1.13	if ( $cmd ne "privmsg"
393	elmex	1.1	and $cmd ne "notice"
394			and $cmd ne "part"
395			and $cmd ne "join"
396	elmex	1.13	and not ($cmd >= 400 and $cmd <= 599)
397			)
398	elmex	1.1	{
399			$self->event (statmsg => $msg);
400	elmex	1.13	} elsif ($cmd >= 400 and $cmd <= 599) {
401			$self->event (error => $msg->{command}, $msg->{trailing}, @{$msg->{params}});
402	elmex	1.1	}
403
404			1;
405			}
406
407			sub privmsg_cb {
408			my ($self, $msg) = @_;
409
410	elmex	1.3	my $targ = $msg->{params}->[0];
411			if ($targ =~ m/^(?:[#+&]\|![A-Z0-9]{5})/) {
412			$self->event (publicmsg => $targ, $msg);
413	elmex	1.1
414			} else {
415	elmex	1.3	$self->event (privatemsg => $targ, $msg);
416	elmex	1.1	}
417
418			1;
419			}
420
421			sub welcome_cb {
422			my ($self, $msg) = @_;
423
424	elmex	1.17	$self->{registered} = 1;
425	elmex	1.1
426			for (@{$self->{con_queue}}) {
427			$self->send_msg (undef, @$_);
428			}
429	elmex	1.11	$self->clear_srv_queue ();
430	elmex	1.1
431	elmex	1.12	$self->event ('registered');
432
433	elmex	1.1	1;
434			}
435
436			sub ping_cb {
437			my ($self, $msg) = @_;
438	elmex	1.8	$self->send_msg (undef, "PONG", $msg->{params}->[0]);
439	elmex	1.2
440			1;
441	elmex	1.1	}
442
443	elmex	1.12	sub nick_cb {
444			my ($self, $msg) = @_;
445			my $nick = prefix_nick ($msg);
446			my $newnick = $msg->{params}->[0];
447			my $wasme = $self->_was_me ($msg);
448
449	elmex	1.13	if ($wasme) { $self->{nick} = $newnick }
450	elmex	1.12
451	elmex	1.13	my @chans;
452	elmex	1.12
453	elmex	1.13	for my $channame (keys %{$self->{channel_list}}) {
454			my $chan = $self->{channel_list}->{$channame};
455	elmex	1.12	if (exists $chan->{$nick}) {
456			delete $chan->{$nick};
457			$chan->{$newnick} = 1;
458	elmex	1.13	push @chans, $channame;
459	elmex	1.12	}
460			}
461
462	elmex	1.13	for (@chans) {
463			$self->event (channel_change => $_, $nick, $newnick, $wasme);
464			}
465	elmex	1.12	$self->event (nick_change => $nick, $newnick, $wasme);
466			}
467
468	elmex	1.1	sub namereply_cb {
469			my ($self, $msg) = @_;
470	elmex	1.2	my @nicks = split / /, $msg->{trailing};
471			push @{$self->{_tmp_namereply}}, @nicks;
472	elmex	1.10
473			1;
474	elmex	1.1	}
475
476			sub endofnames_cb {
477			my ($self, $msg) = @_;
478	elmex	1.12	my $chan = $msg->{params}->[1];
479	elmex	1.20	my @nicks =
480	elmex	1.19	$self->_filter_new_nicks_from_channel (
481	elmex	1.20	$chan, map { s/^[@\+%&]//; $_ } @{delete $self->{_tmp_namereply}}
482			);
483
484			$self->event (channel_add => $chan, @nicks) if @nicks;
485	elmex	1.10
486			1;
487	elmex	1.1	}
488
489			sub join_cb {
490			my ($self, $msg) = @_;
491	elmex	1.2	my $chan = $msg->{params}->[0];
492	elmex	1.4	my $nick = prefix_nick ($msg);
493	elmex	1.1
494	elmex	1.12	$self->event (channel_add => $chan, $nick);
495	elmex	1.2	$self->event (join => $nick, $chan, $self->_was_me ($msg));
496	elmex	1.1
497	elmex	1.2	1;
498			}
499
500			sub part_cb {
501			my ($self, $msg) = @_;
502			my $chan = $msg->{params}->[0];
503	elmex	1.4	my $nick = prefix_nick ($msg);
504	elmex	1.1
505	elmex	1.2	$self->event (part => $nick, $chan, $self->_was_me ($msg), $msg->{params}->[1]);
506			$self->event (channel_remove => $chan, $nick);
507	elmex	1.1
508	elmex	1.2	1;
509			}
510	elmex	1.1
511	elmex	1.2	sub kick_cb {
512			my ($self, $msg) = @_;
513			my $chan = $msg->{params}->[0];
514			my $kicked_nick = $msg->{params}->[1];
515	elmex	1.1
516	elmex	1.2	$self->event (channel_remove => $chan, $kicked_nick);
517	elmex	1.1
518			1;
519			}
520
521	elmex	1.2	sub quit_cb {
522	elmex	1.1	my ($self, $msg) = @_;
523	elmex	1.4	my $nick = prefix_nick ($msg);
524	elmex	1.1
525	elmex	1.2	$self->event (quit => $nick, $msg->{params}->[1]);
526	elmex	1.1
527	elmex	1.12	for (keys %{$self->{channel_list}}) {
528	elmex	1.14	$self->event (channel_remove => $_, $nick)
529			if $self->{channel_list}->{$_}->{$nick};
530	elmex	1.1	}
531	elmex	1.10
532			1;
533	elmex	1.1	}
534
535			sub debug_cb {
536			my ($self, $msg) = @_;
537			print "$self->{h}:$self->{p} > ";
538			my $par = delete $msg->{params};
539			print (join " ", map { $_ => $msg->{$_} } sort keys %$msg);
540			print " params:";
541			print (join ",", @$par);
542			print "\n";
543	elmex	1.10
544			1;
545	elmex	1.1	}
546
547	elmex	1.16	sub change_nick_login_cb {
548	elmex	1.13	my ($self, $msg) = @_;
549
550	elmex	1.17	unless ($self->registered) {
551	elmex	1.13	my $newnick = $self->{nick_change}->($self->nick);
552
553			if (lc $newnick eq lc $self->{nick}) {
554			$self->disconnect;
555			return 0;
556			}
557
558			$self->{nick} = $newnick;
559			$self->send_msg (undef, "NICK", undef, $newnick);
560			}
561
562	elmex	1.17	not ($self->registered) # kill the cb when registered
563	elmex	1.13	}
564
565	elmex	1.15	sub disconnect_cb {
566			my ($self) = @_;
567
568			for (keys %{$self->{channel_list}}) {
569			$self->event (channel_remove => $_, $self->nick)
570			}
571
572			1
573			}
574
575	elmex	1.1	=back
576
577			=head1 EXAMPLES
578
579			See samples/netirc3cl and other samples in samples/ for some examples on how to use Net::IRC3::Client::Connection.
580
581			=head1 AUTHOR
582
583			Robin Redeker, C<< <elmex@ta-sa.org> >>
584
585			=head1 SEE ALSO
586
587	elmex	1.7	L<Net::IRC3::Connection>
588	elmex	1.1
589			RFC 2812 - Internet Relay Chat: Client Protocol
590
591			=head1 COPYRIGHT & LICENSE
592
593	elmex	1.6	Copyright 2006 Robin Redeker, all rights reserved.
594	elmex	1.1
595			This program is free software; you can redistribute it and/or modify it
596			under the same terms as Perl itself.
597
598			=cut
599
600			1;