Bot::BasicBot - simple irc bot baseclass

  # with all defaults
  my $bot = Bot::BasicBot->new( channels => ["#bottest"] );
  $bot->run();

  # with all known options
  my $bot = Bot::BasicBot->new(

    server => "irc.example.com",
    port   => "6667",
    channels => ["#bottest"],

    nick      => "basicbot",
    alt_nicks => ["bbot", "simplebot"],
    username  => "bot",
    name      => "Yet Another Bot",

    ignore_list => [qw(dipsy dadadodo laotse)],

  );
  $bot->run();

  my $bot = Bot::BasicBot->new( nick => 'superbot', channels => [ '#superheroes' ] );

 $bot->shutdown( $bot->quit_message() );

  {
    from => "old_nick",
    to => "new_nick",
  }

  {
    channel => "#channel",
    who => "nick",
    kicked => "kicked",
    reason => "reason",
  }

    {
      who => "nick that quit",
      body => "quit message",
    }

    -nick- message here

    $bot->notice(
        channel => '#bot_basicbot_test',
        body => 'This is a notice'
    );

 $mess->{body} = $body;
 $self->say($mess);

    $bot->foo("bar");

    $poe_kernel->post(BASICBOT_ALIAS, "foo", "bar");

package Bot::BasicBot;
BEGIN {
  $Bot::BasicBot::AUTHORITY = 'cpan:HINRIK';
}
BEGIN {
  $Bot::BasicBot::VERSION = '0.87';
}

use strict;
use warnings;

use Carp;
use Encode qw(encode);
use Exporter;
use IRC::Utils qw(decode_irc);
use POE::Kernel;
use POE::Session;
use POE::Wheel::Run;
use POE::Filter::Line;
use POE::Component::IRC::State;
use POE::Component::IRC::Plugin::Connector;
use Text::Wrap ();

use base 'Exporter';
our @EXPORT = qw(say emote);

sub new {
    my $class = shift;
    my $self = bless {}, $class;

    $self->{IRCNAME} = 'wanna'.int(rand(100000));
    $self->{ALIASNAME} = 'pony'.int(rand(100000));

    # call the set methods
    my %args = @_;
    for my $method (keys %args) {
        if ($self->can($method)) {
            $self->$method($args{$method});
        }
        else {
            $self->{$method} = $args{$method};
            #croak "Invalid argument '$method'";
        }
    }
    $self->{charset} = 'utf8' if !defined $self->{charset};

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

    return $self;
}

sub run {
    my $self = shift;

    # create the callbacks to the object states
    POE::Session->create(
        object_states => [
            $self => {
                _start => "start_state",
                die    => "die_state",

                irc_001          => "irc_001_state",
                irc_msg          => "irc_said_state",
                irc_public       => "irc_said_state",
                irc_ctcp_action  => "irc_emoted_state",
                irc_notice       => "irc_noticed_state",

                irc_disconnected => "irc_disconnected_state",
                irc_error        => "irc_error_state",

                irc_join         => "irc_chanjoin_state",
                irc_part         => "irc_chanpart_state",
                irc_kick         => "irc_kicked_state",
                irc_nick         => "irc_nick_state",
                irc_quit         => "irc_quit_state",

                fork_close       => "fork_close_state",
                fork_error       => "fork_error_state",

                irc_366          => "names_done_state",

                irc_332          => "topic_raw_state",
                irc_topic        => "topic_state",

                irc_shutdown     => "shutdown_state",

                tick => "tick_state",
            }
        ]
    );

    # and say that we want to recive said messages
    $poe_kernel->post($self->{IRCNAME}, 'register', 'all');

    # run
    $poe_kernel->run() if !$self->{no_run};
    return;
}

sub init { return 1; }

sub said { return }

sub emoted {
    return shift->said(@_);
}

sub noticed {
    return shift->said(@_);
}

sub chanjoin { return }

sub chanpart { return }

sub got_names { return }

sub topic { return }

sub nick_change { return }

sub kicked { return }

sub tick { return 0; }

sub help { return "Sorry, this bot has no interactive help." }

sub connected { return }

sub userquit {
    my ($self, $mess) = @_;
    return;
}

sub schedule_tick {
    my $self = shift;
    my $time = shift || 5;
    $poe_kernel->delay('tick', $time);
    return;
}

sub forkit {
    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} || [];

    #install a new handler in the POE kernel pointing to
    # $self->{$args{handler}}
    $poe_kernel->state($args->{handler}, $self);

    my $run;
    if (ref($args->{run}) =~ /^CODE/) {
        $run = sub {
            $args->{run}->($args->{body}, @{ $args->{arguments} })
        };
    }
    else {
        $run = $args->{run};
    }

    my $wheel = POE::Wheel::Run->new(
        Program      => $run,
        StdoutFilter => POE::Filter::Line->new(),
        StderrFilter => POE::Filter::Line->new(),
        StdoutEvent  => "$args->{handler}",
        StderrEvent  => "fork_error",
        CloseEvent   => "fork_close"
    );

    # Use a signal handler to reap dead processes
    $poe_kernel->sig_child($wheel->PID, "got_sigchld");

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

    $self->{forks}{ $wheel->ID } = {
        wheel => $wheel,
        args  => {
            channel => $args->{channel},
            who     => $args->{who},
            address => $args->{address}
        }
    };
    return;
}

sub _fork_said {
    my ($self, $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 = $self->{forks}{$wheel_id}{args};
    $args->{body} = $body;

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

sub say {
    # 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::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';

    # post an event that will send the message
    for my $body (@bodies) {
        my ($enc_who, $enc_body) = $self->charset_encode($who, $body);
        #warn "$enc_who => $enc_body\n";
        $poe_kernel->post(
            $self->{IRCNAME},
            $irc_command,
            $enc_who,
            $enc_body,
        );
    }

    return;
}

sub emote {
    # If we're called without an object ref, then we're handling emoting
    # 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};

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

    # post an event that will send the message
    # if there's a better way of sending actions i'd love to know - jw
    # me too; i'll look at it in v0.5 - sb

    $poe_kernel->post(
        $self->{IRCNAME},
        'ctcp',
        $self->charset_encode($who, "ACTION $body"),
    );
    return;
}

sub notice {
    if (!ref $_[0]) {
        print $_[0], "\n";
        return 1;
    }

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

    # Don't modify '$args' hashref in-place, or we might
    # make all subsequent calls into notices
    return $self->say(
        %{ $args },
        irc_command => 'notice'
    );

}

sub pocoirc {
    my $self = shift;
    return $self->{IRCOBJ};
}

sub reply {
    my $self = shift;
    my ($mess, $body) = @_;
    my %hash = %$mess;
    $hash{body} = $body;
    return $self->say(%hash);
}

sub channel_data {
    my $self = shift;
    my $channel = shift or return;
    my $irc = $self->{IRCOBJ};
    my $channels = $irc->channels();
    return if !exists $channels->{$channel};

    return {
        map {
            $_ => {
                op    => $irc->is_channel_operator($channel, $_) || 0,
                voice => $irc->has_channel_voice($channel, $_) || 0,
            }
        } $irc->channel_list($channel)
    };
}

sub server {
    my $self = shift;
    $self->{server} = shift if @_;
    return $self->{server} || "irc.perl.org";
}

sub port {
    my $self = shift;
    $self->{port} = shift if @_;
    return $self->{port} || "6667";
}

sub password {
    my $self = shift;
    $self->{password} = shift if @_;
    return $self->{password} || undef;
}

sub ssl {
    my $self = shift;
    $self->{ssl} = shift if @_;
    return $self->{ssl} || 0;
}

sub nick {
    my $self = shift;
    $self->{nick} = shift if @_;
    return $self->{nick} if defined $self->{nick};
    return _random_nick();
}

sub _random_nick {
    my @things = ( 'a' .. 'z' );
    return join '', ( map { @things[ rand @things ] } 0 .. 4 ), "bot";
}

sub alt_nicks {
    my $self = shift;
    if (@_) {
        # make sure we copy
        my @args = ( ref $_[0] eq "ARRAY" ) ? @{ $_[0] } : @_;
        $self->{alt_nicks} = \@args;
    }
    return @{ $self->{alt_nicks} || [] };
}

sub username {
    my $self = shift;
    $self->{username} = shift if @_;
    return defined $self->{username} ? $self->{username} : $self->nick;
}

sub name {
    my $self = shift;
    $self->{name} = shift if @_;
    return defined $self->{name} ? $self->{name} : $self->nick . " bot";
}

sub channels {
    my $self = shift;
    if (@_) {
        # make sure we copy
        my @args = ( ref $_[0] eq "ARRAY" ) ? @{ $_[0] } : @_;
        $self->{channels} = \@args;
    }
    return @{ $self->{channels} || [] };
}

sub quit_message {
    my $self = shift;
    $self->{quit_message} = shift if @_;
    return defined $self->{quit_message} ? $self->{quit_message} : "Bye";
}

sub ignore_list {
    my $self = shift;
    if (@_) {
        # make sure we copy
        my @args = ( ref $_[0] eq "ARRAY" ) ? @{ $_[0] } : @_;
        $self->{ignore_list} = \@args;
    }
    return @{ $self->{ignore_list} || [] };
}

sub charset {
    my $self = shift;
    if (@_) {
        $self->{charset} = shift;
    }
    return $self->{charset};
}

sub flood {
    my $self = shift;
    $self->{flood} = shift if @_;
    return $self->{flood};
}

sub no_run {
    my $self = shift;
    $self->{no_run} = shift if @_;
    return $self->{no_run};
}

sub start_state {
    my ($self, $kernel, $session) = @_[OBJECT, KERNEL, SESSION];
    $kernel->sig('DIE', 'die');
    $self->{session} = $session;

    # Make an alias for our session, to keep it from getting GC'ed.
    $kernel->alias_set($self->{ALIASNAME});
    $kernel->delay('tick', 30);

    $self->{IRCOBJ} = POE::Component::IRC::State->spawn(
        alias => $self->{IRCNAME},
    );
    $self->{IRCOBJ}->plugin_add(
        'Connector',
        POE::Component::IRC::Plugin::Connector->new(),
    );
    $kernel->post($self->{IRCNAME}, 'register', 'all');

    $kernel->post(
        $self->{IRCNAME},
        'connect',
        {
            Nick     => $self->nick,
            Server   => $self->server,
            Port     => $self->port,
            Password => $self->password,
            UseSSL   => $self->ssl,
            Flood    => $self->flood,
            $self->charset_encode(
                Nick     => $self->nick,
                Username => $self->username,
                Ircname  => $self->name,
            ),
        },
    );

    return;
}

sub die_state {
    my ($kernel, $self, $ex) = @_[KERNEL, OBJECT, ARG1];
    warn $ex->{error_str};
    $self->{IRCOBJ}->yield('shutdown');
    $kernel->sig_handled();
    return;
}

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

    # ignore all messages from ourselves
    $kernel->post(
        $self->{IRCNAME},
        'ignore',
        $self->charset_encode($self->nick),
    );

    # connect to the channel
    for my $channel ($self->channels) {
        $self->log("Trying to connect to '$channel'\n");
        $kernel->post(
            $self->{IRCNAME},
            'join',
            $self->charset_encode($channel),
        );
    }

    $self->schedule_tick(5);
    $self->connected();
    return;
}

sub irc_disconnected_state {
    my ($self, $kernel, $server) = @_[OBJECT, KERNEL, ARG0];
    $self->log("Lost connection to server $server.\n");
    return;
}

sub irc_error_state {
    my ($self, $err, $kernel) = @_[OBJECT, ARG0, KERNEL];
    $self->log("Server error occurred! $err\n");
    return;
}

sub irc_kicked_state {
    my ($self, $kernel, $heap, $session) = @_[OBJECT, KERNEL, HEAP, SESSION];
    my ($nickstring, $channel, $kicked, $reason) = @_[ARG0..$#_];
    my $nick = $self->nick_strip($nickstring);
    $_[OBJECT]->_remove_from_channel( $channel, $kicked );
    $self->kicked(
        {
            channel => $channel,
            who     => $nick,
            kicked  => $kicked,
            reason  => $reason,
        }
    );
    return;
}

sub irc_join_state {
    my ($self, $nick) = @_[OBJECT, ARG0];
    return;
}

sub irc_nick_state {
    my ($self, $nick, $newnick) = @_[OBJECT, ARG0, ARG1];
    $nick = $self->nick_strip($nick);
    $self->nick_change($nick, $newnick);
    return;
}

sub irc_quit_state {
    my ($self, $kernel, $session) = @_[OBJECT, KERNEL, SESSION];
    my ($nick, $message) = @_[ARG0..$#_];

    $nick = $self->nick_strip($nick);
    $self->userquit({ who => $nick, body => $message });
    return;
}

sub irc_said_state {
    irc_received_state( 'said', 'say', @_ );
    return;
}

sub irc_emoted_state {
    irc_received_state( 'emoted', 'emote', @_ );
    return;
}

sub irc_noticed_state {
    irc_received_state( 'noticed', 'emote', @_ );
    return;
}

sub irc_received_state {
    my $received = shift;
    my $respond  = shift;
    my ($self, $nick, $to, $body) = @_[OBJECT, ARG0, ARG1, ARG2];

    ($nick, $to, $body) = $self->charset_decode($nick, $to, $body);

    my $return;
    my $mess = {};

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

    # work out who it was from
    $mess->{who} = $self->nick_strip($nick);
    $mess->{raw_nick} = $nick;

    # 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 = $to->[0];
    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;
    }
}

sub irc_chanjoin_state {
    my $self = $_[OBJECT];
    my ($channel, $nick) = @_[ ARG1, ARG0 ];
    $nick = $_[OBJECT]->nick_strip($nick);

    if ($self->nick eq $nick) {
      my @channels = $self->channels;
      push @channels, $channel unless grep { $_ eq $channel } @channels;
      $self->channels(\@channels);
    }
    irc_chan_received_state('chanjoin', 'say', @_);
    return;
}

sub irc_chanpart_state {
    my $self = $_[OBJECT];
    my ($channel, $nick) = @_[ ARG1, ARG0 ];
    $nick = $_[OBJECT]->nick_strip($nick);

    if ($self->nick eq $nick) {
      my @channels = $self->channels;
      @channels = grep { $_ ne $channel } @channels;
      $self->channels(\@channels);
    }
    irc_chan_received_state('chanpart', 'say', @_);
    return;
}

sub irc_chan_received_state {
    my $received = shift;
    my $respond  = shift;
    my ($self, $nick, $channel) = @_[OBJECT, ARG0, ARG1];

    my $return;
    my $mess = {};
    $mess->{who} = $self->nick_strip($nick);

    $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->$respond($mess);
        return;
    }
}


sub fork_close_state {
    my ($self, $wheel_id) = @_[OBJECT, ARG0];
    delete $self->{forks}{$wheel_id};
    return;
}

sub fork_error_state { }

sub tick_state {
    my ($self, $kernel, $heap) = @_[OBJECT, KERNEL, HEAP];
    my $delay = $self->tick();
    $self->schedule_tick($delay) if $delay;
    return;
}

sub names_done_state {
    my ($self, $kernel, $server, $message) = @_[OBJECT, KERNEL, ARG0, ARG1];
    my ($channel) = split /\s/, $message;
    $self->got_names(
        {
            channel => $channel,
            names   => $self->channel_data($channel),
        }
    );
  return;
}

sub topic_raw_state {
    my ($self, $kernel, $server, $raw) = @_[OBJECT, KERNEL, ARG0, ARG1];
    my ($channel, $topic) = split / :/, $raw, 2;
    $self->topic(
        {
            channel => $channel,
            who     => undef,
            topic   => $topic,
        }
    );
    return;
}

sub topic_state {
    my ($self, $kernel, $nickraw, $channel, $topic)
        = @_[OBJECT, KERNEL, ARG0, ARG1, ARG2];
    my $nick = $self->nick_strip($nickraw);
    $self->topic(
        {
            channel => $channel,
            who     => $nick,
            topic   => $topic,
        }
    );
    return;
}

sub shutdown_state {
    my ($kernel, $self) = @_[KERNEL, OBJECT];
    $kernel->delay('tick');
    $kernel->alias_remove($self->{ALIASNAME});
    for my $fork (values %{ $self->{forks} }) {
        $fork->{wheel}->kill();
    }
    return;
}

sub AUTOLOAD {
    my $self = shift;
    our $AUTOLOAD;
    $AUTOLOAD =~ s/.*:://;
    $poe_kernel->post(
        $self->{IRCNAME},
        $AUTOLOAD,
        $self->charset_encode(@_),
    );
    return;
}

sub log {
    my $self = shift;
    for (@_) {
      my $log_entry = $_;
      chomp $log_entry;
      print STDERR "$log_entry\n";
    }
    return;
}

sub ignore_nick {
    local $_ = undef;
    my $self = shift;
    my $nick = shift;
    return grep { $nick eq $_ } @{ $self->{ignore_list} };
}

sub nick_strip {
    my $self = shift;
    my $combined = shift || "";
    my ($nick) = $combined =~ m/(.*?)!/;
    return $nick;
}

sub charset_decode {
    my $self = shift;

    my @r;
    for (@_) {
        if (ref($_) eq 'ARRAY') {
            push @r, [ $self->charset_decode(@$_) ];
        }
        elsif (ref($_) eq "HASH") {
            push @r, { $self->charset_decode(%$_) };
        }
        elsif (ref($_)) {
            die "Can't decode object $_\n";
        }
        else {
            push @r, decode_irc($_);
        }
    }
    #warn Dumper({ decoded => \@r });
    return @r;
}

sub charset_encode {
    my $self = shift;

    my @r;
    for (@_) {
        if (ref($_) eq 'ARRAY') {
            push @r, [ $self->charset_encode(@$_) ];
        }
        elsif (ref($_) eq "HASH") {
            push @r, { $self->charset_encode(%$_) };
        }
        elsif (ref($_)) {
            die "Can't encode object $_\n";
        }
        else {
            push @r, encode($self->charset, $_);
        }
    }
    #warn Dumper({ encoded => \@r });
    return @r;
}

1;