{
$POEx::IRC::Client::Lite::VERSION = '0.002002';
}
use strictures 1;
use Carp 'confess';
use POE;
use IRC::Message::Object 'ircmsg';
use Scalar::Util 'blessed';
use Types::Standard -all;
use Moo;
has server => (
required => 1,
is => 'ro',
isa => Str,
writer => 'set_server',
);
has nick => (
required => 1,
is => 'ro',
isa => Str,
writer => 'set_nick',
);
after set_nick => sub {
my ($self, $nick) = @_;
if ($self->_has_conn && $self->conn->has_wheel) {
## Try to change IRC nickname as well.
$self->nick($nick)
}
};
has bindaddr => (
lazy => 1,
is => 'ro',
isa => Defined,
writer => 'set_bindaddr',
predicate => 'has_bindaddr',
default => sub {
my ($self) = @_;
return '::0' if $self->has_ipv6 and $self->ipv6;
'0.0.0.0'
},
);
has ipv6 => (
lazy => 1,
is => 'ro',
isa => Bool,
writer => 'set_ipv6',
predicate => 'has_ipv6',
default => sub { 0 },
);
has pass => (
lazy => 1,
is => 'ro',
isa => Str,
writer => 'set_pass',
predicate => 'has_pass',
clearer => 'clear_pass',
default => sub { '' },
);
has port => (
lazy => 1,
is => 'ro',
isa => Num,
writer => 'set_port',
predicate => 'has_port',
default => sub { 6667 },
);
has realname => (
lazy => 1,
is => 'ro',
isa => Str,
writer => 'set_realname',
predicate => 'has_realname',
default => sub { __PACKAGE__ },
);
has reconnect => (
lazy => 1,
is => 'ro',
isa => Num,
writer => 'set_reconnect',
default => sub { 120 },
);
has username => (
lazy => 1,
is => 'ro',
isa => Str,
writer => 'set_username',
predicate => 'has_username',
default => sub { 'ircplug' },
);
### Typically internal:
has backend => (
lazy => 1,
is => 'ro',
isa => InstanceOf['POEx::IRC::Backend'],
builder => '_build_backend',
);
sub _build_backend {
my ($self) = @_;
my $filter = POE::Filter::IRCv3->new(colonify => 0);
POEx::IRC::Backend->new(filter_irc => $filter)
}
has conn => (
lazy => 1,
weak_ref => 1,
is => 'ro',
isa => Object,
writer => '_set_conn',
predicate => '_has_conn',
clearer => '_clear_conn',
);
sub BUILD {
my ($self) = @_;
$self->set_object_states(
[
$self => [ qw/
ircsock_input
ircsock_connector_open
ircsock_connector_failure
ircsock_disconnect
/ ],
$self => {
emitter_started => '_emitter_started',
connect => '_connect',
disconnect => '_disconnect',
send => '_send',
privmsg => '_privmsg',
ctcp => '_ctcp',
notice => '_notice',
mode => '_mode',
join => '_join',
part => '_part',
},
(
$self->has_object_states ? @{ $self->object_states } : ()
),
],
);
$self->_start_emitter;
}
sub _emitter_started {
my ($kernel, $self) = @_[KERNEL, OBJECT];
$kernel->post( $self->backend->spawn->session_id => 'register' );
}
sub stop {
my ($self) = @_;
$poe_kernel->post( $self->backend->session_id => 'shutdown' );
$self->_shutdown_emitter;
}
### ircsock_*
sub ircsock_connector_open {
my (undef, $self, $conn) = @_[KERNEL, OBJECT, ARG0];
$self->_set_conn( $conn );
if ($self->process( preregister => $conn ) == EAT_ALL) {
$self->_clear_conn;
$self->emit( irc_connector_killed => $conn );
return
}
my @pre;
if ($self->has_pass && (my $pass = $self->pass)) {
push @pre, ircmsg(
command => 'pass',
params => [
$pass
],
)
}
$self->send(
@pre,
ircmsg(
command => 'user',
params => [
$self->username,
'*', '*',
$self->realname
],
),
ircmsg(
command => 'nick',
params => [ $self->nick ],
),
);
$self->emit( irc_connected => $conn );
}
sub ircsock_connector_failure {
my (undef, $self) = @_[KERNEL, OBJECT];
#my $connector = $_[ARG0];
#my ($op, $errno, $errstr) = @_[ARG1 .. ARG3];
$self->_clear_conn if $self->_has_conn;
$self->emit( irc_connector_failed => @_[ARG0 .. $#_] );
$self->timer( $self->reconnect => 'connect') unless !$self->reconnect;
}
sub ircsock_disconnect {
my (undef, $self) = @_[KERNEL, OBJECT];
my ($conn, $str) = @_[ARG0, ARG1];
$self->_clear_conn if $self->_has_conn;
$self->emit( irc_disconnected => $str, $conn );
}
sub ircsock_input {
my (undef, $self, $ircev) = @_[KERNEL, OBJECT, ARG1];
return unless $ircev->command;
$self->emit( 'irc_'.lc($ircev->command) => $ircev)
}
### Our IRC-related handlers.
sub N_irc_433 {
## Nickname in use.
my (undef, $self) = splice @_, 0, 2;
my $ircev = ${ $_[0] };
my $taken = $ircev->params->[1] || $self->nick;
$self->send(
ircmsg(
command => 'nick',
params => [ $taken . '_' ],
)
);
EAT_NONE
}
sub N_irc_ping {
my (undef, $self) = splice @_, 0, 2;
my $ircev = ${ $_[0] };
$self->send(
ircmsg(
command => 'pong',
params => [ @{ $ircev->params } ],
)
);
EAT_NONE
}
sub N_irc_privmsg {
my (undef, $self) = splice @_, 0, 2;
my $ircev = ${ $_[0] };
if (my $ctcp_ev = ctcp_extract($ircev)) {
$self->emit_now( 'irc_'.$ctcp_ev->command => $ctcp_ev );
return EAT_ALL
}
if ($ircev->has_tags && $ircev->get_tag('intent') eq 'ACTION') {
$self->emit_now( irc_ctcp_action => $ircev );
return EAT_ALL
}
my $prefix = substr $ircev->params->[0], 0, 1;
if (grep {; $_ eq $prefix } ('#', '&', '+') ) {
$self->emit_now( irc_public_msg => $ircev )
} else {
$self->emit_now( irc_private_msg => $ircev )
}
EAT_ALL
}
sub N_irc_notice {
my (undef, $self) = splice @_, 0, 2;
my $ircev = ${ $_[0] };
if (my $ctcp_ev = ctcp_extract($ircev)) {
$self->emit_now( 'irc_'.$ctcp_ev->command => $ctcp_ev );
return EAT_ALL
}
EAT_NONE
}
### Public
## Since the retval of yield() is $self, many of these can be chained:
## $client->connect->join(@channels)->privmsg(
## join(',', @channels), 'hello!'
## );
sub connect {
my $self = shift;
$self->yield( connect => @_ )
}
sub _connect {
my (undef, $self) = @_[KERNEL, OBJECT];
$self->backend->create_connector(
remoteaddr => $self->server,
remoteport => $self->port,
(
$self->has_ipv6 ? (ipv6 => $self->ipv6) : ()
),
(
$self->has_bindaddr ? (bindaddr => $self->bindaddr) : ()
),
);
}
sub disconnect {
my $self = shift;
$self->yield( disconnect => @_ )
}
sub _disconnect {
my (undef, $self) = @_[KERNEL, OBJECT];
my $message = $_[ARG0] // 'Leaving';
$self->backend->send(
ircmsg(
command => 'quit',
params => [ $message ],
),
$self->conn->wheel_id
);
$self->backend->disconnect( $self->conn->wheel->ID )
if $self->_has_conn and $self->conn->has_wheel;
}
sub send_raw_line {
my ($self, $line) = @_;
confess "Expected a raw line" unless defined $line;
$self->send( ircmsg(raw_line => $line) );
}
sub send {
my $self = shift;
$self->yield( send => @_ )
}
sub _send {
my (undef, $self) = @_[KERNEL, OBJECT];
for my $outev (@_[ARG0 .. $#_]) {
if ($self->process( outgoing => $outev ) == EAT_ALL) {
next
}
$self->backend->send( $outev, $self->conn->wheel_id )
}
}
## Sugar, and POE-dispatchable counterparts.
sub notice {
my $self = shift;
$self->yield( notice => @_ )
}
sub _notice {
my (undef, $self) = @_[KERNEL, OBJECT];
my ($target, @data) = @_[ARG0 .. $#_];
$self->send(
ircmsg(
command => 'notice',
params => [ $target, join ' ', @data ]
)
)
}
sub privmsg {
my $self = shift;
$self->yield( privmsg => @_ )
}
sub _privmsg {
my (undef, $self) = @_[KERNEL, OBJECT];
my ($target, @data) = @_[ARG0 .. $#_];
$self->send(
ircmsg(
command => 'privmsg',
params => [ $target, join ' ', @data ]
)
)
}
sub ctcp {
my $self = shift;
$self->yield( ctcp => @_ )
}
sub _ctcp {
my (undef, $self) = @_[KERNEL, OBJECT];
my ($type, $target, @data) = @_[ARG0 .. $#_];
my $line = join ' ', uc($type), @data;
my $quoted = ctcp_quote($line);
$self->send(
ircmsg(
command => 'privmsg',
params => [ $target, $quoted ]
)
)
}
sub mode {
my $self = shift;
$self->yield( mode => @_ )
}
sub _mode {
my (undef, $self) = @_[KERNEL, OBJECT];
my ($target, $mode) = @_[ARG0, ARG1];
if (blessed $mode && $mode->isa('IRC::Mode::Set')) {
## FIXME tests for same
## FIXME accept an opt to allow passing in MODES= ?
## don't really want to parse/store isupport here
## (stateful subclasses should worry about it)
for my $set ($mode->split_mode_set(4)) {
$self->mode( $target, $set->mode_string )
}
return $self
}
$self->send(
ircmsg(
command => 'mode',
params => [ $target, $mode ],
)
)
}
sub join {
my $self = shift;
$self->yield( join => @_ )
}
sub _join {
my (undef, $self) = @_[KERNEL, OBJECT];
my $join_to = CORE::join ',', @_[ARG0 .. $#_];
$self->send(
ircmsg(
command => 'join',
params => [ $join_to ],
)
)
}
sub part {
my $self = shift;
$self->yield( part => @_ )
}
sub _part {
my (undef, $self) = @_[KERNEL, OBJECT];
my ($channel, $msg) = @_[ARG0, ARG1];
$self->send(
ircmsg(
command => 'part',
params => [ $channel, $msg ],
)
);
}
1;
=pod
=head1 NAME
POEx::IRC::Client::Lite - Minimalist POE IRC interface
=head1 SYNOPSIS
package MyClient;
use POE;
use POEx::IRC::Client::Lite;
use IRC::Toolkit;
our @channels = ( '#otw', '#eris' );
POE::Session->create(
package_states => [
MyClient => [ qw/
_start
recv_irc_001
recv_irc_public_msg
recv_irc_ctcp_version
/ ],
],
);
sub _start {
my ($kern, $heap) = @_[KERNEL, HEAP];
$heap->{irc} = POEx::IRC::Client::Lite->new(
event_prefix => 'recv_',
server => "irc.perl.org",
nick => "MyNick",
username => "myuser",
);
$heap->{irc}->connect;
}
sub recv_irc_001 {
my ($kern, $heap) = @_[KERNEL, HEAP];
$heap->{irc}->join(@channels)->privmsg(
join(',', @channels), "hello!"
);
}
sub recv_irc_public_msg {
my ($kern, $heap) = @_[KERNEL, HEAP];
my $event = $_[ARG0];
my ($target, $string) = @{ $event->params };
my $from = parse_user( $event->prefix );
if (lc($string||'') eq 'hello') {
$heap->{irc}->privmsg($target, "hello there, $from")
}
}
sub recv_irc_ctcp_version {
my ($kern, $heap) = @_[KERNEL, HEAP];
my $event = $_[ARG0];
my $from = parse_user( $event->prefix );
$heap->{irc}->notice( $from =>
ctcp_quote("VERSION a silly Client::Lite example")
);
}
=head1 DESCRIPTION
A light-weight, pluggable IRC client library using L<POEx::IRC::Backend> and
L<IRC::Toolkit>.
No state is maintained; POEx::IRC::Client::Lite provides a
minimalist interface to IRC and serves as a base class for stateful clients.
This is early development software pulled out of a much larger in-progress
project.
B<< See L<POE::Component::IRC> for a more mature POE IRC client library. >>
=head2 new
my $irc = POEx::IRC::Client::Lite->new(
event_prefix => $prefix,
server => $server,
nick => $nickname,
username => $username,
);
Create a new Client::Lite instance. Optional arguments are:
=over
=item bindaddr
Local address to bind to.
=item ipv6
Boolean value indicating whether to prefer IPv6.
=item port
Remote port to use (defaults to 6667).
=item reconnect
Reconnection attempt delay, in seconds.
=back
=head2 stop
$irc->stop;
Disconnect, stop the Emitter, and purge the plugin pipeline.
=head2 IRC Methods
IRC-related methods can be called via normal method dispatch or sent as a POE
event:
## These are equivalent:
$irc->send( $ircevent );
$irc->yield( 'send', $ircevent );
$poe_kernel->post( $irc->session_id, 'send', $ircevent );
Methods that dispatch to IRC return C<$self>, so they can be chained:
$irc->connect->join(@channels)->privmsg(
join(',', @channels),
'hello there!'
);
=head3 connect
$irc->connect;
Attempt an outgoing connection.
=head3 disconnect
$irc->disconnect($message);
Quit IRC and shut down the wheel.
=head3 send
use IRC::Message::Object 'ircmsg';
$irc->send(
ircmsg(
command => 'oper',
params => [ $user, $passwd ],
)
);
## ... or a raw HASH:
$irc->send(
{
command => 'oper',
params => [ $user, $passwd ],
}
)
## ... or a raw line:
$irc->send_raw_line('PRIVMSG avenj :some things');
Use C<send()> to send an L<IRC::Message::Object> or a compatible
HASH; this method will also take a list of events in either of those formats.
=head3 send_raw_line
Use C<send_raw_line()> to send a single raw IRC line. This is rarely a good
idea; L<POEx::IRC::Backend> provides an IRCv3-capable filter.
=head3 set_nick
$irc->set_nick( $new_nick );
Attempt to change the current nickname.
=head3 privmsg
$irc->privmsg( $target, $string );
Sends a PRIVMSG to the specified target.
=head3 notice
$irc->notice( $target, $string );
Sends a NOTICE to the specified target.
=head3 ctcp
$irc->ctcp( $target, $type, @params );
Encodes and sends a CTCP B<request> to the target.
(To send a CTCP B<reply>, send a L</notice> that has been quoted via
L<IRC::Toolkit::CTCP/"ctcp_quote">.)
=head3 mode
$irc->mode( $channel, $modestring );
Sends a MODE for the specified target.
Takes a channel name as a string and a mode change as either a string or an
L<IRC::Mode::Set>.
=head3 join
$irc->join( $channel );
Attempts to join the specified channel.
=head3 part
$irc->part( $channel, $message );
Attempts to leave the specified channel with an optional PART message.
=head2 Attributes
=head3 conn
The L<POEx::IRC::Backend::Connect> instance for our connection.
=head3 nick
The nickname we were spawned with.
This class doesn't track nick changes; if our nick is changed later, ->nick()
is not updated.
=head3 server
The server we were instructed to connect to.
=head1 Emitted Events
All IRC events are emitted as 'irc_$cmd' e.g. 'irc_005' (ISUPPORT) or
'irc_mode' with a few notable exceptions, detailed below.
C<$_[ARG0]> is the L<IRC::Message::Object>.
=head2 irc_connector_killed
Emitted if a connection is terminated during L</preregister>.
C<$_[ARG0]> is the L<POEx::IRC::Backend::Connect> object.
=head2 irc_private_message
Emitted for PRIVMSG-type messages not covered by L</irc_public_message>.
=head2 irc_public_message
Emitted for PRIVMSG-type messages that appear to be destined for a channel
target.
=head2 irc_ctcp_TYPE
Emitted for incoming CTCP requests. TYPE is the request type, such as
'version'
C<$_[ARG0]> is the L<IRC::Message::Object> produced by
L<IRC::Toolkit::CTCP/ctcp_extract>.
An example of sending a CTCP reply lives in L</SYNOPSIS>.
See L<IRC::Toolkit::CTCP> for CTCP-related helpers.
=head2 irc_ctcpreply_TYPE
Emitted for incoming CTCP replies.
Mirrors the behavior of L</irc_ctcp_TYPE>
=head2 irc_disconnected
Emitted when an IRC connection has been disconnected at the backend.
C<$_[ARG0]> is the disconnect string from L<POEx::IRC::Backend>.
C<$_[ARG1]> is the L<POEx::IRC::Backend::Connect> that was disconnected.
=head1 Pluggable Events
These are events explicitly dispatched to plugins
via L<MooX::Role::POE::Emitter/process>;
see L<MooX::Role::POE::Emitter> and L<MooX::Role::Pluggable> for more on
making use of plugins.
=head2 preregister
Dispatched to plugins when an outgoing connection has been established,
but prior to registration.
The first argument is the L<POEx::IRC::Backend::Connect> object.
Returning EAT_ALL (see L<MooX::Role::Pluggable::Constants>) to Client::Lite
will terminate the connection without registering.
=head2 outgoing
Dispatched to plugins prior to sending output.
The first argument is the item being sent. Note that no sanity checks are
performed on the item(s) at this stage (this is done after items are passed to
the L<POEx::IRC::Backend> instance) -- your plugin's handler could receive a
HASH, an L<IRC::Message::Object>, a raw line, or something invalid.
Returning EAT_ALL will skip sending the item.
=head1 SEE ALSO
L<POE::Component::IRC>, a fully-featured POE IRC client library
L<IRC::Toolkit>
L<POEx::IRC::Backend>
L<POE::Filter::IRCv3>
L<MooX::Role::POE::Emitter>
L<MooX::Role::Pluggable>
=head1 AUTHOR
Jon Portnoy <avenj@cobaltirc.org>
=begin Pod::Coverage
BUILD
N_(?i:[A-Z0-9_])+
ircsock_(?i:[A-Z_])+
=end Pod::Coverage
=cut