File Coverage

blib/lib/Irssi/Bot/BasicBot/Pluggable.pm

Criterion	Covered	Total	%
statement	55	436	12.6
branch	0	134	0.0
condition	0	47	0.0
subroutine	17	66	25.7
pod	3	35	8.5
total	75	718	10.4

# ABSTRACT: Run Bot::BasicBot::Pluggable::Module_s in Irssi
use strict;
use warnings;
use experimental 'signatures';

use Irssi::Log::Log4perl;
use Module::Pluggable
  sub_name    => '_available',
  search_path => 'Bot::BasicBot::Pluggable::Module',
  except      => 'Bot::BasicBot::Pluggable::Module::Base';

use Bot::BasicBot::Pluggable::Module;
use Bot::BasicBot::Pluggable::Store;
use Try::Tiny;
use Capture::Tiny 'capture';
use Text::Wrap ();

#use Carp::Always;

# POE::Session constants

    my $self = bless +{ @config } => $cls;

    print "These modules are available for loading: "
	. join( ", ", $self->available_modules );

    $self->init or die "init did not return a true value - dying";

    return $self;
}



    $self->init_logging();

    my $logger = Irssi::Log::Log4perl->get_logger( ref $self );
    $logger->info( 'Starting initialization of ' . ref $self );

    return 1;
}

    my $self   = shift;
    my $logger = Irssi::Log::Log4perl->get_logger( ref $self );
    for my $log_entry (@_) {
        chomp $log_entry;
        $logger->warn($log_entry);
    }
    return;
}

    my @modules = sort
      map {
        my $mod = $_;
        $mod =~ s/^Bot::BasicBot::Pluggable::Module:://;
        $mod;
      } $self->_available();
    return @modules;
}

    my $logger = Irssi::Log::Log4perl->get_logger( ref $self );

    $logger->info("Dispatching $method")
	unless $method eq 'tick';
    for my $who ( $self->modules ) {
        ## Otherwise we would see tick every five seconds
        if ( $method eq 'tick' ) {
            $logger->trace("Trying to dispatch $method to $who");
        }
        else {
            $logger->debug("Trying to dispatch $method to $who");
        }
        $logger->trace( "... with " . Dumper(@args) )
          if $logger->is_trace && @args;

        next unless $self->module($who)->can($method);
        try {
            $logger->trace(
                "Dispatching $method to $who with " . Dumper(@args) )
              if $logger->is_trace;
            $self->module($who)->$method(@args);
        }
        catch {
            $logger->warn($_);
        }
    }
    return;
}

    $self->dispatch('tick');
    return 5;
}

    my $response;
    my $who;

    my $logger = Irssi::Log::Log4perl->get_logger( ref $self );
    $logger->info("Dispatching $event event");

    for my $priority ( 0 .. 3 ) {
        for my $module ( $self->modules ) {
            my $response;
            $logger->debug(
                "Trying to dispatch $event to $module on priority $priority");
            $logger->trace( '... with arguments ' . Dumper($mess) )
              if $logger->is_trace and $mess;
            try {
                $response =
                  $self->module($module)->$event( $mess, $priority );
            }
            catch {
                $logger->warn($_);
            };
            if ( $priority and $response ) {
                $logger->debug("Response by $module on $priority");
                $logger->trace( 'Response is ' . Dumper($response) )
                  if $logger->is_trace;
                return if $response eq '1';
                $self->reply( $mess, $response );
                return;
            }
        }
    }
    return;
}

    $self->dispatch( 'replied', {%$mess}, @other );
    if ( $mess->{reply_hook} ) {
        return $mess->{reply_hook}->( $mess, @other );
    }
    else {
	my ($body) = @other;
	my %hash = %$mess;
	$hash{body} = $body;
	return $self->say(%hash);
    }
}

    # If we're called without an object ref, then we're handling saying
    # stuff from inside a forked subroutine, so we'll freeze it, and toss
    # it out on STDOUT so that POE::Wheel::Run's handler can pick it up.
    if (!ref $_[0]) {
        print $_[0], "\n";
        return 1;
    }

    # Otherwise, this is a standard object method

    my $self = shift;
    my $args;
    if (ref $_[0]) {
        $args = shift;
    }
    else {
        my %args = @_;
        $args = \%args;
    }

    my $body = $args->{body};

    # add the "Foo: bar" at the start
    if ($args->{channel} ne "msg" && defined $args->{address}) {
        $body = "$args->{who}: $body";
    }

    # work out who we're going to send the message to
    my $who = $args->{channel} eq "msg" ? $args->{who} : $args->{channel};

    if (!defined $who || !defined $body) {
        $self->log("Can't send a message without target and body\n"
              . " called from "
              . ( [caller]->[0] )
              . " line "
              . ( [caller]->[2] ) . "\n"
              . " who = '$who'\n body = '$body'\n");
        return;
    }

    # if we have a long body, split it up..
    #local $Text::Wrap::columns = 300;
    local $Text::Wrap::columns = 294;
    local $Text::Wrap::unexpand = 0; # no tabs
    my $wrapped = Text::Wrap::wrap('', '..', $body); #  =~ m!(.{1,300})!g;
    # I think the Text::Wrap docs lie - it doesn't do anything special
    # in list context
    my @bodies = split /\n+/, $wrapped;

    # Allows to override the default "PRIVMSG". Used by notice()
    my $irc_command = defined $args->{irc_command}
        && $args->{irc_command} eq 'notice'
        ? 'notice'
        : 'privmsg';

    # possibility to set the network
    local $self->{conn_tag} = $args->{network}
	if $args->{network};

    # post an event that will send the message
    my $last_color;
    for my $body (@bodies) {
	if (defined $last_color) {
	    $body = "..\cC$last_color".substr $body, 2;
	}
	if ((my $bcol = rindex $body, "\cC") > -1) {
	    $last_color = (substr $body, $bcol + 1) =~ /^(\d{1,2}(?:,\d{1,2})?)/ ? $1 : undef;
	}
	if ($who eq '@@@ local user @@@') {
	    $self->localresponse({ body => $body });
	} else {
	    $self->{irssi}->$irc_command($self, $who, $body);
	}
    }

    return;
}

    my $return;
    my $mess = {};
    return unless $nick && $address;
    $mess->{who} = $nick;
    $mess->{raw_nick} = "$nick!$address";

    $mess->{channel} = $channel;
    $mess->{body} = $received; #chanjoin or chanpart
    $mess->{address} = "chan";

    # okay, call the chanjoin/chanpart method
    $return = $self->$received($mess);

    ### what did we get back?

    # nothing? Say nothing then
    return if !defined $return;

    # a string?  Say it how we were addressed then
    if (!ref $return) {
        $mess->{body} = $return;
        $self->say($mess);
        return;
    }
}

    my $return;
    my $mess = {};

    # pass the raw body through
    $mess->{raw_body} = $body;

    # work out who it was from
    return unless $nick && $address;
    $mess->{who} = $nick;
    $mess->{raw_nick} = "$nick!$address";

    # right, get the list of places this message was
    # sent to and work out the first one that we're
    # either a memeber of is is our nick.
    # The IRC protocol allows messages to be sent to multiple
    # targets, which is pretty clever. However, noone actually
    # /does/ this, so we can get away with this:

    my $channel = $target;
    if (lc($channel) eq lc($self->nick)) {
        $mess->{channel} = "msg";
        $mess->{address} = "msg";
    }
    else {
        $mess->{channel} = $channel;
    }

    # okay, work out if we're addressed or not

    $mess->{body} = $body;
    if ($mess->{channel} ne "msg") {
        my $own_nick = $self->nick;

        if ($mess->{body} =~ s/^(\Q$own_nick\E)\s*[:,-]?\s*//i) {
          $mess->{address} = $1;
        }

        for my $alt_nick ($self->alt_nicks) {
            last if $mess->{address};
            if ($mess->{body} =~ s/^(\Q$alt_nick\E)\s*[:,-]?\s*//i) {
              $mess->{address} = $1;
            }
        }
    }

    # strip off whitespace before and after the message
    $mess->{body} =~ s/^\s+//;
    $mess->{body} =~ s/\s+$//;

    # check if someone was asking for help
    if ($mess->{address} && $mess->{body} =~ /^help/i) {
        $mess->{body} = $self->help($mess) or return;
        $self->say($mess);
        return;
    }

    # okay, call the said/emoted method
    $return = $self->$received($mess);

    ### what did we get back?

    # nothing? Say nothing then
    return if !defined $return;

    # a string?  Say it how we were addressed then
    if (!ref $return && length $return) {
        $mess->{body} = $return;
        $self->$respond($mess);
        return;
    }
}

    print "[ => ] " . ($self->{server} ? "[$self->{server}{tag}] " : "") . $mess->{body};
}

    local $self->{conn_tag} = $network
	if $network;
    $self->{irssi}->own_nick($self)
}

    local $self->{conn_tag} = $network
	if $network;
    $self->{irssi}->find_alternate_nicks($self)
}

    my $self = shift;
    my $args;

    if (ref($_[0])) {
        $args = shift;
    }
    else {
        my %args = @_;
        $args = \%args;
    }

    return if !$args->{run};

    $args->{handler}   = $args->{handler}   || "_fork_said";
    $args->{arguments} = $args->{arguments} || [];

    #$poe_kernel->state( $args->{handler}, $args->{callback} || $self  );

    my $run;
    $run = sub {
	my ($stdout, $stderr, $result) = capture {
	    return scalar $args->{run}->($args->{body}, @{ $args->{arguments} });
	};
	return $stdout || $result;
    };

    my $pt = $self->{irssi}->bg_do($run, $args->{handler});

    # store the wheel object in our bot, so we can retrieve/delete easily

    $self->{forks}{ $pt } = {
        args  => {
	    conn_tag => $self->{conn_tag},
            channel => $args->{channel},
            who     => $args->{who},
            address => $args->{address}
        }
    };
    return;
}

    my $func = $rhandler =~ /::/ ? $rhandler : "Bot::BasicBot::Pluggable::$rhandler";
    my $args = $self->{forks}{$pipetag};
    $args = $args->{args} if $args;
    local $self->{conn_tag} = $args->{conn_tag};
    local $self->{server} = Irssi::server_find_tag($args->{conn_tag})
	if $args->{conn_tag};

    my @args;
    $args[OBJECT] = $self;
    $args[ARG0] = $data;
    $args[ARG1] = $pipetag;
    {
	no strict 'refs';
	&$func(@args);
    }

    delete $self->{forks}{$pipetag};
}

    my ($bot, $body, $wheel_id) = @_[OBJECT, ARG0, ARG1];
    chomp $body;    # remove newline necessary to move data;

    # pick up the default arguments we squirreled away earlier
    my $args = $bot->{forks}{$wheel_id}{args};
    $args->{body} = $body;

    $bot->say($args);
    return;
}

BEGIN {
    my @dispatchable_events = (
        qw/
          connected chanjoin chanpart userquit nick_change
          topic kicked raw_in raw_out
          /
    );
    my @priority_events = (qw/ said emoted /);
    {
        ## no critic qw(ProhibitNoStrict)
        no strict 'refs';
        for my $event (@dispatchable_events) {
            *$event = sub {
                shift->dispatch( $event, @_ );
            };
        }
        for my $event (@priority_events) {
            *$event = sub {
                shift->dispatch_priorities( $event, @_ );
            };
        }
    }
}

    $mess->{body} =~ s/^help\s*//i;
    my $logger = Irssi::Log::Log4perl->get_logger( ref $self );

    unless ( $mess->{body} ) {
        return
            "Ask me for help about: "
          . join( ", ", $self->modules() )
          . " (say 'help <modulename>').";
    }
    else {
        if ( my $module = $self->module( $mess->{body} ) ) {
            try {
                return $module->help($mess);
            }
            catch {
                $logger->warn(
                    "Error calling help for module $mess->{body}: $_");
            }
        }
        else {
            return "I don't know anything about '$mess->{body}'.";
        }
    }
}

    return bless +{ bot => $self, irssi => $self->{irssi}, conn_tag => ($network // $self->{conn_tag}) }
	=> 'Irssi::Bot::BasicBot::Pluggable::PoCoIrc';
}

    my $logger = Irssi::Log::Log4perl->get_logger( ref $self );

    # it's safe to die here, mostly this call is eval'd.
    $logger->logdie("Cannot load module without a name") unless $module;
    $logger->logdie("Module $module already loaded") if $self->module($module);

    # This is possible a leeeetle bit evil.
    $logger->info("Loading module $module");
    my $filename = $module;
    $filename =~ s{::}{/}g;
    my $file = "Bot/BasicBot/Pluggable/Module/$filename.pm";
    $file = "Irssi/Bot/BasicBot/Pluggable/Module/Auth.pm"
	if lc $module eq 'auth';
    $logger->debug("Loading module $module from file $file");

    # force a reload of the file (in the event that we've already loaded it).
    no warnings 'redefine';
    delete $INC{$file};

    try { require $file } catch { die "Can't load $module: $_"; };

    # Ok, it's very evil. Don't bother me, I'm working.

    my $m = "Bot::BasicBot::Pluggable::Module::$module"->new(
        Bot   => $self,
    );

    $logger->logdie("->new didn't return an object") unless ( $m and ref($m) );
    $logger->logdie( ref($m) . " isn't a $module" )
      unless ref($m) =~ /\Q$module/;

    $self->add_module( $m, $module );

    return $m;
}

    my $logger = Irssi::Log::Log4perl->get_logger( ref $self );
    $logger->logdie("Cannot reload module without a name") unless $module;
    $self->remove_module($module) if $self->module($module);
    return $self->load($module);
}

    my $logger = Irssi::Log::Log4perl->get_logger( ref $self );
    $logger->logdie("Need name")  unless $module;
    $logger->logdie("Not loaded") unless $self->module($module);
    $logger->info("Unloading module $module");
    $self->remove_module($module);
}

    return $self->{store};
}

    return $self->{modules}{ lc($name) };
}

    my @keys = sort {
	my $xa = $self->module($a);
	my $xb = $self->module($b);
	(
	    ($xb->get('user_priority') || $xb->get('priority') || 0)
		<=>
	    ($xa->get('user_priority') || $xa->get('priority') || 0)
	) || ($a cmp $b)
    } keys( %{ $self->{modules} } );
    return @keys if wantarray;
    return \@keys;
}

# deprecated

    my $logger = Irssi::Log::Log4perl->get_logger( ref $self );
    $logger->logdie("Need a name for adding a module") unless $name;
    $logger->logdie("Can't load a module with a duplicate name $name")
      if $self->{modules}{ lc($name) };
    $self->{modules}{ lc($name) } = $module;
}

    my $logger = Irssi::Log::Log4perl->get_logger( ref $self );
    $logger->logdie("Need a name for removing a module") unless $name;
    $logger->logdie("Module $name not defined")
      unless $self->{modules}{ lc($name) };
    $self->{modules}{ lc($name) }->stop();
    delete $self->{modules}{ lc($name) };
}

    for my $module (reverse $self->modules) {
	$self->remove_module($module);
    }
    return;
}


1;

use strict;
use warnings;
use experimental 'signatures';

    return 0 unless $self->{conn_tag};
    my $server = Irssi::server_find_tag($self->{conn_tag})
	or return 0;
    my $ch = $server->channel_find($channel)
	or return 0;
    my $n = $ch->nick_find($nick)
	or return 0;
    return 1;
}

    warn "connection lost: $channel",
	return () unless $self->{conn_tag};
    my $server = Irssi::server_find_tag($self->{conn_tag})
	or warn "connection lost: $self->{conn_tag}", return ();
    my $ch = $server->channel_find($channel)
	or return ();
    return map { $_->{nick} } $ch->nicks;
}


1;