IRC3/Client/Connection.pm

package Net::IRC3::Client::Connection;
use base "Net::IRC3::Connection";
use Net::IRC3::Util qw/prefix_nick decode_ctcp/;
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 (nearly) 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.

Please note that CTCP handling is still up to you. It will be decoded
for you and events will be generated. But generating replies
is up to you.

=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<ctcp $src, $target, $tag, $msg, $type>

Emitted when a CTCP message was found in either a NOTICE or PRIVMSG
message. C<$tag> is the CTCP message tag. (eg. "PING", "VERSION", ...).
C<$msg> is the CTCP message and C<$type> is either "NOTICE" or "PRIVMSG".

C<$src> is the source nick the message came from.
C<$target> is the target nickname (yours) or the channel the ctcp was sent
on.

=item B<"ctcp_$tag", $src, $target, $msg, $type>

Emitted when a CTCP message was found in either a NOTICE or PRIVMSG
message. C<$tag> is the CTCP message tag. (eg. "PING", "VERSION", ...).
C<$msg> is the CTCP message and C<$type> is either "NOTICE" or "PRIVMSG".

C<$src> is the source nick the message came from.
C<$target> is the target nickname (yours) or the channel the ctcp was sent
on.

=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>.

The trailing part of the C<$ircmsg> will have all CTCP messages stripped off.

=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>.

The trailing part of the C<$ircmsg> will have all CTCP messages stripped off.

=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 ($trail, $ctcp) = decode_ctcp ($msg->{trailing});

   for (@$ctcp) {
      $self->event (ctcp => prefix_nick ($msg), $msg->{params}->[0], $_->[0], $_->[1], $msg->{command});
      $self->event ("ctcp_$_->[0]", prefix_nick ($msg), $msg->{params}->[0], $_->[1], $msg->{command});
   }

   $msg->{trailing} = $trail;

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