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<channel_topic $channel $topic $who>

This is emitted when the topic for a channel is discovered. C<$channel>
is the channel for which C<$topic> is the current topic now.
Which is set by C<$who>. C<$who> might be undefined when it's not known
who set the channel topic.

=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->reg_cb (irc_332        => \&rpl_topic_cb);
   $self->reg_cb (irc_topic      => \&topic_change_cb);

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

   return $self;
}

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

Sends the IRC registration commands NICK and USER.
If C<$server_pass> is passed also a PASS command is generated.

=cut

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

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

   $self->send_msg (undef, "PASS", undef, $pass) if defined $pass;
   $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);

   1;
}

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->{$_} } grep { $_ ne 'params' } 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
}

sub rpl_topic_cb {
   my ($self, $msg) = @_;
   my $chan  = $msg->{params}->[1];
   my $topic = $msg->{trailing};

   $self->event (channel_topic => $chan, $topic);

   1
}

sub topic_change_cb {
   my ($self, $msg) = @_;
   my $who   = prefix_nick ($msg);
   my $chan  = $msg->{params}->[0];
   my $topic = $msg->{trailing};

   $self->event (channel_topic => $chan, $topic, $who);

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