File Coverage

blib/lib/App/Pocoirc.pm

Criterion	Covered	Total	%
statement	8	10	80.0
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	12	14	85.7

package App::Pocoirc;
BEGIN {
  $App::Pocoirc::AUTHORITY = 'cpan:HINRIK';
}
{
  $App::Pocoirc::VERSION = '0.47';
}

use strict;
use warnings FATAL => 'all';

use App::Pocoirc::Status;
use Class::Load qw(try_load_class);
use Fcntl qw(O_CREAT O_EXCL O_WRONLY);
use File::Glob ':glob';
use File::Spec::Functions 'rel2abs';
use IO::Handle;
use IRC::Utils qw(decode_irc);
use POE;
use POE::Component::Client::DNS;
use POSIX 'strftime';
use Scalar::Util 'looks_like_number';

sub new {
    my ($package, %args) = @_;
    return bless \%args, $package;
}

sub run {
    my ($self) = @_;

    # we print IRC output, which will be UTF-8
    binmode $_, ':utf8' for (*STDOUT, *STDERR);

    if ($self->{list_plugins}) {
        require Module::Pluggable;
        Module::Pluggable->import(
            sub_name    => '_available_plugins',
            search_path => 'POE::Component::IRC::Plugin',
        );
        for my $plugin (sort $self->_available_plugins()) {
            $plugin =~ s/^POE::Component::IRC::Plugin:://;
            print $plugin, "\n";
        }
        return;
    }

    $self->_setup();

    if ($self->{check_cfg}) {
        print "The configuration is valid and all modules could be compiled.\n";
        return;
    }

    if ($self->{daemonize}) {
        require Proc::Daemon;
        eval {
            Proc::Daemon::Init->();
            if (defined $self->{log_file}) {
                open STDOUT, '>>:encoding(utf8)', $self->{log_file}
                    or die "Can't open $self->{log_file}: $!\n";
                open STDERR, '>>&STDOUT' or die "Can't redirect STDERR: $!\n";
                STDOUT->autoflush(1);
            }
            $poe_kernel->has_forked();
        };
        chomp $@;
        die "Can't daemonize: $@\n" if $@;
    }

    if (defined $self->{pid_file}) {
        sysopen my $fh, $self->{pid_file}, O_CREAT|O_EXCL|O_WRONLY
            or die "Can't create pid file or it already exists. Pocoirc already running?\n";
        print $fh "$$\n";
        close $fh;
    }

    POE::Session->create(
        object_states => [
            $self => [qw(
                _start
                sig_die
                sig_int
                sig_term
                irc_plugin_add
                irc_plugin_del
                irc_plugin_error
                irc_plugin_status
                irc_network
                irc_shutdown
            )],
            $self => {
                irc_432 => 'irc_432_or_433',
                irc_433 => 'irc_432_or_433',
            },
        ],
    );

    $poe_kernel->run();
    unlink $self->{pid_file} if defined $self->{pid_file};
    return;
}

sub _setup {
    my ($self) = @_;

    if (defined $self->{cfg}{pid_file}) {
        $self->{pid_file} = rel2abs(bsd_glob(delete $self->{cfg}{pid_file}));
    }

    if (defined $self->{cfg}{log_file}) {
        my $log = rel2abs(bsd_glob(delete $self->{cfg}{log_file}));
        open my $fh, '>>', $log or die "Can't open $log: $!\n";
        close $fh;
        $self->{log_file} = $log;
    }

    if (!$self->{no_color}) {
        require Term::ANSIColor;
        Term::ANSIColor->import();
    }

    if (defined $self->{cfg}{lib}) {
        if (ref $self->{cfg}{lib} eq 'ARRAY' && @{ $self->{cfg}{lib} }) {
            unshift @INC, map { rel2abs(bsd_glob($_)) } @{ delete $self->{cfg}{lib} };
        }
        else {
            unshift @INC, rel2abs(bsd_glob(delete $self->{cfg}{lib}));
        }
    }

    $self->_load_classes();
    return;
}

sub _load_classes {
    my ($self) = @_;

    for my $plug_spec (@{ $self->{cfg}{global_plugins} || [] }) {
        $self->_load_plugin($plug_spec);
    }

    while (my ($network, $opts) = each %{ $self->{cfg}{networks} }) {
        while (my ($opt, $value) = each %{ $self->{cfg} }) {
            next if $opt =~ /^(?:networks|global_plugins|local_plugins)$/;
            $opts->{$opt} = $value if !defined $opts->{$opt};
        }

        for my $plug_spec (@{ $opts->{local_plugins} || [] }) {
            $self->_load_plugin($plug_spec);
        }

        if (!defined $opts->{server}) {
            die "Server for network '$network' not specified\n";
        }

        if (defined $opts->{class}) {
            $opts->{class} = _load_either_class(
                "POE::Component::IRC::$opts->{class}",
                $opts->{class},
            );
        }
        else {
            $opts->{class} = 'POE::Component::IRC::State';
            my ($success, $error) = try_load_class($opts->{class});
            chomp $error if defined $error;
            die "Can't load class $opts->{class}: $error\n" if !$success;
        }
    }

    return;
}

# create plugins, spawn components, and connect to IRC
sub _start {
    my ($kernel, $session, $self) = @_[KERNEL, SESSION, OBJECT];

    $kernel->sig(DIE => 'sig_die');
    $kernel->sig(INT => 'sig_int');
    $kernel->sig(TERM => 'sig_term');

    $self->_status(undef, 'normal', "Started (pid $$)");
    my ($own, $global, $local) = $self->_construct_objects();
    $self->_register_plugins($session->ID(), $own, $global, $local);
    $self->{own_plugins} = $own;

    for my $entry (@{ $self->{ircs} }) {
        my ($network, $irc) = @$entry;
        $self->_status($network, 'normal', 'Connecting to IRC ('.$irc->server.')');
        $irc->yield('connect');
    }

    return;
}

sub _construct_objects {
    my ($self) = @_;

    # create the shared DNS resolver
    $self->{resolver} = POE::Component::Client::DNS->spawn();

    # construct global plugins
    $self->_status(undef, 'normal', "Constructing global plugins");

    my $global_plugs = $self->_create_plugins(delete $self->{cfg}{global_plugins});

    my $own_plugs = [
        [
            'PocoircStatus',
            App::Pocoirc::Status->new(
                Pocoirc => $self,
                Trace   => $self->{trace},
                Verbose => $self->{verbose},
                Dynamic => (defined $self->{cfg_file} ? 1 : 0),
            ),
        ],
    ];

    if ($self->{interactive}) {
        require App::Pocoirc::ReadLine;
        push @$own_plugs, [
            'PocoircReadLine',
            App::Pocoirc::ReadLine->new(
                Pocoirc  => $self,
            ),
        ];
    }

    my $local_plugs;
    # construct IRC components
    while (my ($network, $opts) = each %{ $self->{cfg}{networks} }) {
        my $class = delete $opts->{class};

        # construct network-specific plugins
        $self->_status($network, 'normal', 'Constructing local plugins');
        $local_plugs->{$network} = $self->_create_plugins(delete $opts->{local_plugins});

        $self->_status($network, 'normal', "Spawning IRC component ($class)");
        my $irc = $class->spawn(
            %$opts,
            Resolver => $self->{resolver},
        );
        my $isa = eval { $irc->isa($class) };
        die "isa() test failed for component of class $class\n" if !$isa;
        push @{ $self->{ircs} }, [$network, $irc];
    }

    return $own_plugs, $global_plugs, $local_plugs;
}

sub _load_either_class {
    my ($primary, $secondary) = @_;

    my ($success, $error, @err);
    ($success, $error) = try_load_class($primary);
    return $primary if $success;

    push @err, $error;
    ($success, $error) = try_load_class($secondary);
    return $secondary if $success;

    chomp $error if defined $error;
    push @err, $error;

    my $class = "$primary or $secondary";
    if (@err == 2) {
        if ($err[0] =~ /^Can't locate / && $err[1] !~ /^Can't locate /) {
            $class = $secondary;
            shift @err;
        }
        elsif ($err[1] =~ /^Can't locate / && $err[0] !~ /^Can't locate /) {
            $class = $primary;
            pop @err;
        }
    }
    my $reason = join "\n", map { "  $_" } @err;
    die "Failed to load class $class:\n$reason\n";
}

sub _register_plugins {
    my ($self, $session_id, $own, $global, $local) = @_;

    for my $entry (@{ $self->{ircs} }) {
        my ($network, $irc) = @$entry;
        $self->_status($network, 'normal', 'Registering plugins');

        for my $plugin (@$own, @$global, @{ $local->{$network} }) {
            my ($name, $object) = @$plugin;
            $irc->plugin_add("${name}_$session_id", $object,
                network => $network,
            );
        }
    }

    return;
}

sub _dump {
    my ($arg) = @_;

    if (ref $arg eq 'ARRAY') {
        my @elems;
        for my $elem (@$arg) {
            push @elems, _dump($elem);
        }
        return '['. join(', ', @elems) .']';
    }
    elsif (ref $arg eq 'HASH') {
        my @pairs;
        for my $key (keys %$arg) {
            push @pairs, [$key, _dump($arg->{$key})];
        }
        return '{'. join(', ', map { "$_->[0] => $_->[1]" } @pairs) .'}';
    }
    elsif (ref $arg) {
        require overload;
        return overload::StrVal($arg);
    }
    elsif (defined $arg) {
        return $arg if looks_like_number($arg);
        return "'".decode_irc($arg)."'";
    }
    else {
        return 'undef';
    }
}

sub _event_debug {
    my ($self, $irc, $args, $event) = @_;

    if (!defined $event) {
        $event = (caller(1))[3];
        $event =~ s/.*:://;
    }

    my @output;
    for my $i (0..$#{ $args }) {
        push @output, "ARG$i: " . _dump($args->[$i]);
    }
    $self->_status($irc, 'debug', "$event: ".join(', ', @output));
    return;
}

# let's log this if it's preventing us from logging in
sub irc_432_or_433 {
    my $self = $_[OBJECT];
    my $irc = $_[SENDER]->get_heap();
    my $reason = decode_irc($_[ARG2]->[1]);
    return if $irc->logged_in();
    my $nick = $irc->nick_name();
    $self->_status($irc, 'normal', "Login attempt failed: $reason");
    return;
}

# fetch the server name if we're not using a config file
sub irc_network {
    my ($self, $sender, $network) = @_[OBJECT, SENDER, ARG0];
    my $irc = $sender->get_heap();

    for my $idx (0..$#{ $self->{ircs} }) {
        if ($self->{ircs}[$idx][1] == $irc) {
            $self->{ircs}[$idx][0] = $network;
            last;
        }
    }
    return;
}

# we handle plugin status messages here because the status plugin won't
# see these for previously added plugins or plugin_del for itself, etc
sub irc_plugin_add {
    my ($self, $alias) = @_[OBJECT, ARG0];
    my $irc = $_[SENDER]->get_heap();
    $self->_event_debug($irc, [@_[ARG0..$#_]], 'S_plugin_add') if $self->{trace};
    $self->_status($irc, 'normal', "Added plugin $alias");
    return;
}

sub irc_plugin_del {
    my ($self, $alias) = @_[OBJECT, ARG0];
    my $irc = $_[SENDER]->get_heap();
    $self->_event_debug($irc, [@_[ARG0..$#_]], 'S_plugin_del') if $self->{trace};
    $self->_status($irc, 'normal', "Deleted plugin $alias");
    return;
}

sub irc_plugin_error {
    my ($self, $error) = @_[OBJECT, ARG0];
    my $irc = $_[SENDER]->get_heap();
    $self->_event_debug($irc, [@_[ARG0..$#_]], 'S_plugin_error') if $self->{trace};
    $self->_status($irc, 'error', $error);
    return;
}

sub irc_plugin_status {
    my ($self, $plugin, @args) = @_[OBJECT, ARG0..$#_];
    my $irc        = $_[SENDER]->get_heap();
    my $plugins    = $irc->plugin_list();
    my %plug2alias = map { $plugins->{$_} => $_ } keys %$plugins;

    my $extension = ref $plugin eq 'App::Pocoirc::Status'
        ? ''
        : "/$plug2alias{$plugin}";
    $self->_status($self->_irc_to_network($irc).$extension, @args);
    return;
}

sub irc_shutdown {
    my ($self) = $_[OBJECT];
    my $irc = $_[SENDER]->get_heap();
    $self->_event_debug($irc, [@_[ARG0..$#_]], 'S_shutdown') if $self->{trace};
    $self->_status($irc, 'normal', 'IRC component shut down');
    return;
}

sub verbose {
    my ($self, $value) = @_;
    if (defined $value) {
        $self->{verbose} = $value;
        for my $plugin (@{ $self->{own_plugins} }) {
            $plugin->[1]->verbose($value) if $plugin->[1]->can('verbose');
        }
    }
    return $self->{verbose};
}

sub trace {
    my ($self, $value) = @_;
    if (defined $value) {
        $self->{trace} = $value;
        for my $plugin (@{ $self->{own_plugins} }) {
            $plugin->[1]->trace($value) if $plugin->[1]->can('trace');
        }
    }
    return $self->{trace};
}

sub _status {
    my ($self, $context, $type, $message) = @_;

    my $stamp = strftime('%Y-%m-%d %H:%M:%S', localtime);
    my $irc = eval { $context->isa('POE::Component::IRC') };
    $context = $self->_irc_to_network($context) if $irc;
    $context = defined $context ? " [$context]\t" : ' ';

    if (defined $type && $type eq 'error') {
        $message = "!!! $message";
    }

    my $log_line = "$stamp$context$message";
    my $term_line = $log_line;

    if (!$self->{no_color}) {
        if (defined $type && $type eq 'error') {
            $term_line = colored($term_line, 'red');
        }
        elsif (defined $type && $type eq 'debug') {
            $term_line = colored($term_line, 'yellow');
        }
        else {
            $term_line = colored($term_line, 'green');
        }
    }

    print $term_line, "\n" if !$self->{daemonize};
    if (defined $self->{log_file}) {
        if (open my $fh, '>>:encoding(utf8)', $self->{log_file}) {
            $fh->autoflush(1);
            print $fh $log_line, "\n";
            close $fh;
        }
        elsif (!$self->{daemonize}) {
            warn "Can't open $self->{log_file}: $!\n";
        }
    }
    return;
}

sub _irc_to_network {
    my ($self, $irc) = @_;

    for my $entry (@{ $self->{ircs} }) {
        my ($network, $object) = @$entry;
        return $network if $irc == $object;
    }

    return;
}

# find out the canonical class name for the plugin and load it
sub _load_plugin {
    my ($self, $plug_spec) = @_;

    return if defined $plug_spec->[2];
    my ($class, $args) = @$plug_spec;
    $args = {} if !defined $args;

    my $canonclass = _load_either_class(
        "POE::Component::IRC::Plugin::$class",
        $class,
    );

    $plug_spec->[1] = $args;
    $plug_spec->[2] = $canonclass;
    return;
}

sub _create_plugins {
    my ($self, $plugins) = @_;

    my @return;
    for my $plug_spec (@$plugins) {
        my ($class, $args, $canonclass) = @$plug_spec;
        my $obj = $canonclass->new(%$args);
        my $isa = eval { $obj->isa($canonclass) };
        die "isa() test failed for plugin of class $canonclass\n" if !$isa;
        push @return, [$class, $obj];
    }

    return \@return;
}

sub sig_die {
    my ($kernel, $self, $ex) = @_[KERNEL, OBJECT, ARG1];
    chomp $ex->{error_str};

    my $error = "Event $ex->{event} in session ".$ex->{dest_session}->ID
        ." raised exception:\n    $ex->{error_str}";

    $self->_status(undef, 'error', $error);
    $self->shutdown('Exiting due to an exception') if !$self->{shutdown};
    $kernel->sig_handled();
    return;
}

sub sig_int {
    my ($kernel, $self) = @_[KERNEL, OBJECT];
    $self->shutdown('Exiting due to SIGINT') if !$self->{shutdown};
    $kernel->sig_handled();
    return;
}

sub sig_term {
    my ($kernel, $self) = @_[KERNEL, OBJECT];

    $self->shutdown('Exiting due to SIGTERM') if !$self->{shutdown};
    $kernel->sig_handled();
    return;
}

sub shutdown {
    my ($self, $reason) = @_;

    $self->_status(undef, 'normal', $reason);

    my $logged_in;
    for my $irc (@{ $self->{ircs} }) {
        my ($network, $obj) = @$irc;

        if (!$logged_in && $obj->logged_in()) {
            $logged_in = 1;
            $self->_status(undef, 'normal',
                'Waiting up to 5 seconds for IRC server(s) to disconnect us');
        }
        $obj->yield('shutdown', $reason, 5);
    }

    $self->{resolver}->shutdown() if $self->{resolver};
    $self->{shutdown} = 1;
    return;
}

1;

=encoding utf8

=head1 NAME

App::Pocoirc - A command line tool for launching POE::Component::IRC clients

=head1 DESCRIPTION

This distribution provides a generic way to launch IRC clients which use
L. The main features are:

=over 4

=item * Prints useful status information (to your terminal and/or a log file)

=item * Will daemonize if you so wish

=item * Supports a configuration file

=item * Offers a user friendly way to pass arguments to POE::Component::IRC

=item * Supports multiple IRC components and lets you specify which plugins
to load locally (one object per component) or globally (single object)

=item * Has an interactive mode where you can issue issue commands and
call methods on the IRC component(s).

It can be used to launch IRC bots or proxies, loaded with plugins of your
choice. It is very useful for testing and debugging
L plugins as well as IRC servers.

=back

=head1 CONFIGURATION

 nick:     foobar1234
 username: foobar
 log_file: /my/log.file
 lib:      /my/modules

 global_plugins:
   - [CTCP]

 local_plugins:
   - [BotTraffic]

 networks:
   freenode:
     server: irc.freenode.net
     local_plugins:
       - [AutoJoin, { Channels: ['#foodsfdsf'] } ]
   magnet:
     server: irc.perl.org
     nick:   hlagherf32fr

The configuration file is in L or L format. It consists
of a hash containing C, C, C, C,
C, C, and default parameters to
L. Only C is
required.

C is either the name of a directory containing Perl modules (e.g.
plugins), or an array of such names. Kind of like Perl's I<-I>.

C is the path to a log file to which status messages will be written.

C is the IRC component class. Defaults to
L.

=head2 Networks

The C option should be a hash of network hashes. The keys are the
names of the networks. A network hash can contain C and
parameters to POE::Component::IRC. None are required, except C if not
defined at the top level. The POE::Component::IRC parameters specified in this
hash will override the ones specified at the top level.

=head2 Plugins

The C and C options should consist of an array
containing the short plugin class name (e.g. 'AutoJoin') and optionally a hash
of arguments to that plugin. When figuring out the correct package name,
App::Pocoirc will first try to load POE::Component::IRC::Plugin::I
before trying to load I.

The plugins in C will be instantiated once and then added to
all IRC components. B not all plugins are designed to be used with
multiple IRC components simultaneously.

If you specify C at the top level, it will serve as a default
list of local plugins, which can be overridden in a network hash.

=head1 OUTPUT

Here is some example output from the program:

 $ pocoirc -f example/config.yml
 2011-04-18 18:10:52 Started (pid 20105)
 2011-04-18 18:10:52 Constructing global plugins
 2011-04-18 18:10:52 [freenode]  Constructing local plugins
 2011-04-18 18:10:52 [freenode]  Spawning IRC component (POE::Component::IRC::State)
 2011-04-18 18:10:52 [magnet]    Constructing local plugins
 2011-04-18 18:10:52 [magnet]    Spawning IRC component (POE::Component::IRC::State)
 2011-04-18 18:10:52 [freenode]  Registering plugins
 2011-04-18 18:10:52 [magnet]    Registering plugins
 2011-04-18 18:10:52 [freenode]  Connecting to IRC (irc.freenode.net)
 2011-04-18 18:10:52 [magnet]    Connecting to IRC (irc.perl.org)
 2011-04-18 18:10:52 [freenode]  Added plugin Whois3
 2011-04-18 18:10:52 [freenode]  Added plugin ISupport3
 2011-04-18 18:10:52 [freenode]  Added plugin DCC3
 2011-04-18 18:10:52 [magnet]    Added plugin Whois5
 2011-04-18 18:10:52 [magnet]    Added plugin ISupport5
 2011-04-18 18:10:52 [magnet]    Added plugin DCC5
 2011-04-18 18:10:52 [freenode]  Added plugin CTCP1
 2011-04-18 18:10:52 [freenode]  Added plugin AutoJoin1
 2011-04-18 18:10:52 [freenode]  Added plugin PocoircStatus1
 2011-04-18 18:10:52 [magnet]    Added plugin CTCP1
 2011-04-18 18:10:52 [magnet]    Added plugin PocoircStatus1
 2011-04-18 18:10:52 [magnet]    Connected to server irc.perl.org
 2011-04-18 18:10:52 [magnet]    Server notice: *** Looking up your hostname...
 2011-04-18 18:10:52 [magnet]    Server notice: *** Checking Ident
 2011-04-18 18:10:52 [freenode]  Connected to server irc.freenode.net
 2011-04-18 18:10:53 [magnet]    Server notice: *** Found your hostname
 2011-04-18 18:10:53 [freenode]  Server notice: *** Looking up your hostname...
 2011-04-18 18:10:53 [freenode]  Server notice: *** Checking Ident
 2011-04-18 18:10:53 [freenode]  Server notice: *** Couldn't look up your hostname
 2011-04-18 18:11:03 [magnet]    Server notice: *** No Ident response
 2011-04-18 18:11:03 [magnet]    Logged in to server magnet.shadowcat.co.uk with nick hlagherf32fr
 2011-04-18 18:11:07 [freenode]  Server notice: *** No Ident response
 2011-04-18 18:11:07 [freenode]  Logged in to server niven.freenode.net with nick foobar1234
 2011-04-18 18:11:11 [freenode]  Joined channel #foodsfdsf
 ^C2011-04-18 18:11:22 Exiting due to SIGINT
 2011-04-18 18:11:22 Waiting up to 5 seconds for IRC server(s) to disconnect us
 2011-04-18 18:11:22 [magnet]    Error from IRC server: Closing Link: 212-30-192-157.static.simnet.is ()
 2011-04-18 18:11:22 [magnet]    Deleted plugin DCC5
 2011-04-18 18:11:22 [magnet]    Deleted plugin ISupport5
 2011-04-18 18:11:22 [magnet]    Deleted plugin CTCP1
 2011-04-18 18:11:22 [magnet]    Deleted plugin Whois5
 2011-04-18 18:11:22 [magnet]    Deleted plugin PocoircStatus1
 2011-04-18 18:11:22 [magnet]    IRC component shut down
 2011-04-18 18:11:22 [freenode]  Quit from IRC (Client Quit)
 2011-04-18 18:11:22 [freenode]  Error from IRC server: Closing Link: 212.30.192.157 (Client Quit)
 2011-04-18 18:11:22 [freenode]  Deleted plugin AutoJoin1
 2011-04-18 18:11:22 [freenode]  Deleted plugin CTCP1
 2011-04-18 18:11:22 [freenode]  Deleted plugin DCC3
 2011-04-18 18:11:22 [freenode]  Deleted plugin PocoircStatus1
 2011-04-18 18:11:22 [freenode]  Deleted plugin Whois3
 2011-04-18 18:11:22 [freenode]  Deleted plugin ISupport3
 2011-04-18 18:11:22 [freenode]  IRC component shut down

=head1 AUTHOR

Hinrik Ern SigurEsson, [e-mail]

=head1 LICENSE AND COPYRIGHT

Copyright 2010 Hinrik Ern SigurEsson

This program is free software, you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut