AnyEvent-IRC
view release on metacpan or search on metacpan
lib/AnyEvent/IRC/Client.pm view on Meta::CPAN
package AnyEvent::IRC::Client;
use common::sense;
use Scalar::Util qw/weaken/;
use Encode;
use AnyEvent::Socket;
use AnyEvent::Handle;
use AnyEvent::IRC::Util
qw/prefix_nick decode_ctcp split_prefix
is_nick_prefix join_prefix encode_ctcp
split_unicode_string mk_msg/;
use base AnyEvent::IRC::Connection::;
=head1 NAME
AnyEvent::IRC::Client - A highlevel IRC connection
=head1 SYNOPSIS
use AnyEvent;
use AnyEvent::IRC::Client;
my $c = AnyEvent->condvar;
my $timer;
my $con = new AnyEvent::IRC::Client;
$con->reg_cb (connect => sub {
my ($con, $err) = @_;
if (defined $err) {
warn "connect error: $err\n";
return;
}
});
$con->reg_cb (registered => sub { print "I'm in!\n"; });
$con->reg_cb (disconnect => sub { print "I'm out!\n"; $c->broadcast });
$con->reg_cb (
sent => sub {
my ($con) = @_;
if ($_[2] eq 'PRIVMSG') {
print "Sent message!\n";
$timer = AnyEvent->timer (
after => 1,
cb => sub {
undef $timer;
$con->disconnect ('done')
}
);
}
}
);
$con->send_srv (
PRIVMSG => 'elmex',
"Hello there I'm the cool AnyEvent::IRC test script!"
);
$con->connect ("localhost", 6667, { nick => 'testbot' });
$c->wait;
$con->disconnect;
=head1 DESCRIPTION
L<AnyEvent::IRC::Client> 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.
This module also implements the ISUPPORT (command 005) extension of the IRC protocol
(see http://www.irc.org/tech_docs/005.html) and will enable the NAMESX and UHNAMES
extensions when supported by the server.
Also CTCP support is implemented, all CTCP messages will be decoded and events
for them will be generated. You can configure auto-replies to certain CTCP commands
with the C<ctcp_auto_reply> method, or you can generate the replies yourself.
=head2 A NOTE TO CASE MANAGEMENT
The case insensitivity of channel names 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
AnyEvent::IRC::Client 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<AnyEvent::IRC::Client>.
Use C<reg_cb> as described in L<Object::Event> to register to such an event.
=over 4
=item registered
Emitted when the connection got successfully registered and the end of the MOTD
(IRC command 376 or 422 (No MOTD file found)) was seen, so you can start sending
commands and all ISUPPORT/PROTOCTL handshaking has been done.
lib/AnyEvent/IRC/Client.pm view on Meta::CPAN
C<$reason> is a human readable string indicating the reason for the end of
the DCC request.
=item dcc_chat_msg => $id, $msg
This event is emitted for a DCC CHAT message. C<$id> is the DCC connection
ID we received the message on. And C<$msg> is the message he sent us.
=item quit => $nick, $msg
Emitted when the nickname C<$nick> QUITs with the message C<$msg>.
=item 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 last parameter of the C<$ircmsg> will have all CTCP messages stripped off.
=item 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 last parameter of the C<$ircmsg> will have all CTCP messages stripped off.
=item error => $code, $message, $ircmsg
Emitted when any error occurs. C<$code> is the 3 digit error id string from RFC
1459 or the string 'ERROR'. C<$message> is a description of the error.
C<$ircmsg> is the complete error irc message.
You may use AnyEvent::IRC::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'
NOTE: This event is also emitted when a 'ERROR' message is received.
=item debug_send => $command, @params
Is emitted everytime some command is sent.
=item debug_recv => $ircmsg
Is emitted everytime some command was received.
=back
=head1 METHODS
=over 4
=item $cl = AnyEvent::IRC::Client->new (%args)
This is the constructor of a L<AnyEvent::IRC::Client> object,
which stands logically for a client connected to ONE IRC server.
You can reuse it and call C<connect> once it disconnected.
B<NOTE:> You are free to use the hash member C<heap> to store any associated
data with this object. For example retry timers or anything else.
C<%args> may contain these options:
=over 4
=item send_initial_whois => $bool
If this option is enabled an initial C<WHOIS> command is sent to your own
NICKNAME to determine your own I<ident>. See also the method C<nick_ident>.
This is necessary to ensure that the information about your own nickname
is available as early as possible for the C<send_long_message> method.
C<$bool> is C<false> by default.
=back
=cut
my %LOWER_CASEMAP = (
rfc1459 => sub { tr/A-Z[]\\\^/a-z{}|~/ },
'strict-rfc1459' => sub { tr/A-Z[]\\/a-z{}|/ },
ascii => sub { tr/A-Z/a-z/ },
);
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_376 => \&welcome_cb);
$self->reg_cb (irc_422 => \&welcome_cb);
$self->reg_cb (irc_005 => \&isupport_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_mode => \&mode_cb);
$self->reg_cb (irc_353 => \&namereply_cb);
$self->reg_cb (irc_366 => \&endofnames_cb);
$self->reg_cb (irc_352 => \&whoreply_cb);
$self->reg_cb (irc_311 => \&whoisuser_cb);
$self->reg_cb (irc_305 => \&away_change_cb);
$self->reg_cb (irc_306 => \&away_change_cb);
$self->reg_cb (irc_ping => \&ping_cb);
$self->reg_cb (irc_pong => \&pong_cb);
$self->reg_cb (irc_privmsg => \&privmsg_cb);
$self->reg_cb (irc_notice => \&privmsg_cb);
$self->reg_cb ('irc_*' => \&debug_cb);
$self->reg_cb ('irc_*' => \&anymsg_cb);
$self->reg_cb ('irc_*' => \&update_ident_cb);
$self->reg_cb (disconnect => \&disconnect_cb);
$self->reg_cb (irc_332 => \&rpl_topic_cb);
$self->reg_cb (irc_topic => \&topic_change_cb);
$self->reg_cb (ctcp => \&ctcp_auto_reply_cb);
$self->reg_cb (registered => \®istered_cb);
$self->reg_cb (nick_change => \&update_ident_nick_change_cb);
$self->{def_nick_change} = $self->{nick_change} =
sub {
my ($old_nick) = @_;
"${old_nick}_"
};
$self->_setup_internal_dcc_handlers;
$self->cleanup;
return $self;
}
sub cleanup {
my ($self) = @_;
$self->{channel_list} = { };
$self->{isupport} = { };
$self->{casemap_func} = $LOWER_CASEMAP{rfc1459};
$self->{prefix_chars} = '@+';
$self->{prefix2mode} = { '@' => 'o', '+' => 'v' };
$self->{channel_chars} = '#&';
$self->{change_nick_cb_guard} =
$self->reg_cb (
irc_437 => \&change_nick_login_cb,
irc_433 => \&change_nick_login_cb,
);
delete $self->{away_status};
delete $self->{dcc};
delete $self->{dcc_id};
delete $self->{_tmp_namereply};
delete $self->{last_pong_recv};
delete $self->{last_ping_sent};
delete $self->{_ping_timer};
delete $self->{con_queue};
delete $self->{chan_queue};
delete $self->{registered};
delete $self->{idents};
delete $self->{nick};
delete $self->{user};
delete $self->{real};
delete $self->{server_pass};
delete $self->{register_cb_guard};
}
=item $cl->connect ($host, $port)
=item $cl->connect ($host, $port, $info)
This method does the same as the C<connect> method of L<AnyEvent::Connection>,
but if the C<$info> parameter is passed it will automatically register with the
IRC server upon connect for you, and you won't have to call the C<register>
method yourself. If C<$info> only contains the timeout value it will not
automatically connect, this way you can pass a custom connect timeout value
without having to register.
The keys of the hash reference you can pass in C<$info> are:
nick - the nickname you want to register as
user - your username
real - your realname
password - the server password
timeout - the TCP connect timeout
All keys, except C<nick> are optional.
=cut
sub connect {
my ($self, $host, $port, $info) = @_;
my $timeout = delete $info->{timeout};
if (defined $info and keys %$info) {
$self->{register_cb_guard} = $self->reg_cb (
ext_before_connect => sub {
my ($self, $err) = @_;
unless ($err) {
$self->register (
$info->{nick}, $info->{user}, $info->{real}, $info->{password}
);
}
delete $self->{register_cb_guard};
}
);
}
$self->SUPER::connect ($host, $port, $timeout);
}
=item $cl->register ($nick, $user, $real, $server_pass)
lib/AnyEvent/IRC/Client.pm view on Meta::CPAN
my $ctcp;
($cmd, $ctcp) = split /\001/, $cmd;
my $id = $self->nick_ident ($self->nick);
if ($id eq '') {
$id = "X" x 60; # just in case the ident is not available...
}
my $init_len = length mk_msg ($id, $cmd, @params, " "); # i know off by 1
if ($ctcp ne '') {
$init_len += length ($ctcp) + 3; # CTCP cmd + " " + "\001" x 2
}
my $max_len = 500; # give 10 bytes extra margin
my $line_len = $max_len - $init_len;
# split up the multiple lines in the message:
my @lines = split /\n/, $msg;
# splitup long lines into multiple ones:
@lines =
map split_unicode_string ($encoding, $_, $line_len), @lines;
# send lines line-by-line:
for my $line (@lines) {
my $smsg = encode ($encoding, $line);
if ($ctcp ne '') {
$smsg = encode_ctcp ([$ctcp, $smsg])
}
$self->send_srv ($cmd => @params, $smsg);
}
@lines
}
=item $cl->enable_ping ($interval, $cb)
This method enables a periodical ping to the server with an interval of
C<$interval> seconds. If no PONG was received from the server until the next
interval the connection will be terminated or the callback in C<$cb> will be called.
(C<$cb> will have the connection object as it's first argument.)
Make sure you call this method after the connection has been established.
(eg. in the callback for the C<registered> event).
=cut
sub enable_ping {
my ($self, $int, $cb) = @_;
$self->{last_pong_recv} = 0;
$self->{last_ping_sent} = time;
$self->send_srv (PING => "AnyEvent::IRC");
$self->{_ping_timer} =
AE::timer $int, 0, sub {
if ($self->{last_pong_recv} < $self->{last_ping_sent}) {
delete $self->{_ping_timer};
if ($cb) {
$cb->($self);
} else {
$self->disconnect ("Server timeout");
}
} else {
$self->enable_ping ($int, $cb);
}
};
}
=item $cl->lower_case ($str)
Converts the given string to lowercase according to CASEMAPPING setting given by
the IRC server. If none was sent, the default - rfc1459 - will be used.
=cut
sub lower_case {
my($self, $str) = @_;
local $_ = $str;
$self->{casemap_func}->();
return $_;
}
=item $cl->eq_str ($str1, $str2)
This function compares two strings, whether they are describing the same
IRC entity. They are lower cased by the networks case rules and compared then.
=cut
sub eq_str {
my ($self, $a, $b) = @_;
$self->lower_case ($a) eq $self->lower_case ($b)
}
=item $cl->isupport ()
=item $cl->isupport ($key)
Provides access to the ISUPPORT variables sent by the IRC server. If $key is
given this method will return its value only, otherwise a hashref with all values
is returned
=cut
sub isupport {
my($self, $key) = @_;
if (defined ($key)) {
return $self->{isupport}->{$key};
} else {
return $self->{isupport};
}
}
=item $cl->split_nick_mode ($prefixed_nick)
This method splits the C<$prefix_nick> (eg. '+elmex') up into the
lib/AnyEvent/IRC/Client.pm view on Meta::CPAN
$self->event (dcc_chat_msg => $id, $line);
});
});
}
});
$self->reg_cb (dcc_connected => sub {
my ($self, $id, $type, $hdl) = @_;
if ($type eq 'chat') {
$hdl->on_read (sub {
my ($hdl) = @_;
$hdl->push_read (line => sub {
my ($hdl, $line) = @_;
$self->event (dcc_chat_msg => $id, $line);
});
});
}
});
}
=item $cl->dcc_initiate ($dest, $type, $timeout, $local_ip, $local_port)
This function will initiate a DCC TCP connection to C<$dest> of type C<$type>.
It will setup a listening TCP socket on C<$local_port>, or a random port if
C<$local_port> is undefined. C<$local_ip> is the IP that is being sent to the
receiver of the DCC connection. If it is undef the local socket will be bound
to 0 (or "::" in case of IPv6) and C<$local_ip> will probably be something like
"0.0.0.0". It is always advisable to set C<$local_ip> to a (from the "outside",
what ever that might be) reachable IP Address.
C<$timeout> is the time in seconds after which the listening socket will be
closed if the receiver didn't connect yet. The default is 300 (5 minutes).
When the local listening socket has been setup the C<dcc_ready> event is
emitted. When the receiver connects to the socket the C<dcc_accepted> event is
emitted. And whenever a dcc connection is closed the C<dcc_close> event is
emitted.
For canceling the DCC offer or closing the connection see C<dcc_disconnect> below.
The return value of this function will be the ID of the initiated DCC connection,
which can be used for functions such as C<dcc_disconnect>, C<send_dcc_chat> or
C<dcc_handle>.
=cut
sub dcc_initiate {
my ($self, $dest, $type, $timeout, $local_ip, $local_port) = @_;
$dest = $self->lower_case ($dest);
$type = lc $type;
my $id = ++$self->{dcc_id};
my $dcc = $self->{dcc}->{$id} = { id => $id, type => $type, dest => $dest };
weaken $dcc;
weaken $self;
$dcc->{timeout} = AnyEvent->timer (after => $timeout || 5 * 60, cb => sub {
$self->dcc_disconnect ($id, "TIMEOUT") if $self;
});
$dcc->{listener} = tcp_server undef, $local_port, sub {
my ($fh, $h, $p) = @_;
return unless $dcc && $self;
$dcc->{handle} = AnyEvent::Handle->new (
fh => $fh,
on_eof => sub {
$self->dcc_disconnect ($id, "EOF");
},
on_error => sub {
$self->dcc_disconnect ($id, "ERROR: $!");
}
);
$self->event (dcc_accepted => $id, $type, $dcc->{handle});
delete $dcc->{listener};
delete $dcc->{timeout};
}, sub {
my ($fh, $host, $port) = @_;
return unless $dcc && $self;
$local_ip = $host unless defined $local_ip;
$local_port = $port;
$dcc->{local_ip} = $local_ip;
$dcc->{local_port} = $local_port;
$self->event (dcc_ready => $id, $dest, $type, $local_ip, $local_port);
};
$id
}
=item $cl->dcc_disconnect ($id, $reason)
In case you want to withdraw a DCC offer sent by C<start_dcc> or close
a DCC connection you call this function.
C<$id> is the DCC connection ID. C<$reason> should be a human readable reason
why you ended the dcc offer, but it's only used for local logging purposes (see
C<dcc_close> event).
=cut
sub dcc_disconnect {
my ($self, $id, $reason) = @_;
if (my $dcc = delete $self->{dcc}->{$id}) {
delete $dcc->{handle};
$self->event (dcc_close => $id, $dcc->{type}, $reason);
}
}
=item $cl->dcc_accept ($id, $timeout)
This will accept an incoming DCC request as received by the C<dcc_request>
event. The C<dcc_connected> event will be emitted when we successfully
connected. And the C<dcc_close> event when the connection was disconnected.
C<$timeout> is the connection try timeout in seconds. The default is 300 (5 minutes).
=cut
sub dcc_accept {
my ($self, $id, $timeout) = @_;
my $dcc = $self->{dcc}->{$id}
or return;
weaken $dcc;
weaken $self;
$dcc->{timeout} = AnyEvent->timer (after => $timeout || 5 * 60, cb => sub {
$self->dcc_disconnect ($id, "CONNECT TIMEOUT") if $self;
});
$dcc->{connect} = tcp_connect $dcc->{ip}, $dcc->{port}, sub {
my ($fh) = @_;
return unless $dcc && $self;
delete $dcc->{timeout};
delete $dcc->{connect};
unless ($fh) {
$self->dcc_disconnect ($id, "CONNECT ERROR: $!");
return;
}
$dcc->{handle} = AnyEvent::Handle->new (
fh => $fh,
on_eof => sub {
delete $dcc->{handle};
$self->dcc_disconnect ($id, "EOF");
},
on_error => sub {
delete $dcc->{handle};
$self->dcc_disconnect ($id, "ERROR: $!");
}
);
$self->event (dcc_connected => $id, $dcc->{type}, $dcc->{handle});
};
$id
}
sub dcc_handle {
my ($self, $id) = @_;
if (my $dcc = $self->{dcc}->{$id}) {
return $dcc->{handle}
}
return;
}
sub send_dcc_chat {
my ($self, $id, $msg) = @_;
if (my $dcc = $self->{dcc}->{$id}) {
if ($dcc->{handle}) {
$dcc->{handle}->push_write ("$msg\015\012");
}
}
}
################################################################################
# Private utility functions
################################################################################
sub _was_me {
my ($self, $msg) = @_;
$self->lower_case (prefix_nick ($msg)) eq $self->lower_case ($self->nick ())
}
( run in 0.744 second using v1.01-cache-2.11-cpan-39bf76dae61 )