view release on metacpan or  search on metacpan

lib/Bot/IRC.pm  view on Meta::CPAN

package Bot::IRC;
# ABSTRACT: Yet Another IRC Bot

use 5.016;
use exact;

use Daemon::Device;
use Date::Format 'time2str';
use Encode qw( encode decode );
use IO::Socket::IP -register;
use IO::Socket::SSL;
use Time::Crontab;

our $VERSION = '1.48'; # VERSION

sub new {
    my $class = shift;
    my $self  = bless( {@_}, $class );

    croak('Odd number of elements passed to new()') if ( @_ % 2 );
    croak('connect/server not provided to new()')
        unless ( ref $self->{connect} eq 'HASH' and $self->{connect}{server} );

    $self->{spawn}    ||= 2;
    $self->{encoding} //= 'UTF-8';

    $self->{connect}{nick} //= 'bot';
    $self->{connect}{name} //= 'Yet Another IRC Bot';
    $self->{connect}{port} ||= ( $self->{connect}{ssl} ) ? 6670 : 6667;

    $self->{disconnect} //= sub {};

    $self->{daemon}           //= {};
    $self->{daemon}{name}     //= $self->{connect}{nick};
    $self->{daemon}{pid_file} //= $self->{daemon}{name} . '.pid';

    $self->{nick} = $self->{connect}{nick};

    $self->{hooks}    = [];
    $self->{ticks}    = [];
    $self->{helps}    = {};
    $self->{loaded}   = {};
    $self->{numerics} = [];

    $self->{send_user_nick} ||= 'on_parent';
    croak('"send_user_nick" optional value set to invalid value') if (
        $self->{send_user_nick} ne 'on_connect' and
        $self->{send_user_nick} ne 'on_parent' and
        $self->{send_user_nick} ne 'on_reply'
    );

    $self->load(
        ( ref $self->{plugins} eq 'ARRAY' ) ? @{ $self->{plugins} } : $self->{plugins}
    ) if ( $self->{plugins} );

    return $self;
}

sub run {
    my $self     = shift;
    my $commands = \@_;

    $self->{socket} = ( ( $self->{connect}{ssl} ) ? 'IO::Socket::SSL' : 'IO::Socket::IP' )->new(
        PeerAddr        => $self->{connect}{server},
        PeerPort        => $self->{connect}{port},
        Proto           => 'tcp',
        Family          => ( $self->{connect}{ipv6} ? AF_INET6 : AF_INET ),
        Type            => SOCK_STREAM,
        SSL_verify_mode => SSL_VERIFY_NONE,
    ) or die $!;

    if ( $self->{send_user_nick} eq 'on_connect' ) {
        $self->{socket}->print("PASS $self->{connect}{password}\r\n") if ( $self->{connect}{password} );
        $self->{socket}->print("NICK $self->{nick}\r\n");
        $self->{socket}->print("USER $self->{nick} 0 * :$self->{connect}{name}\r\n");
    }

    try {
        $self->{device} = Daemon::Device->new(
            parent     => \&_parent,
            child      => \&_child,
            on_message => \&_on_message,
            spawn      => $self->{spawn},
            daemon     => $self->{daemon},
            data       => {
                self     => $self,
                commands => $commands,
                passwd   => $self->{passwd},
            },
        );
    }
    catch ($e) {
        croak("Daemon device instantiation failure: $e");
    }

    $self->{device}->run;
}

sub note {
    my ( $self, $msg, $err ) = @_;
    chomp($msg);
    $msg = '[' . time2str( '%d/%b/%Y:%H:%M:%S %z', time() ) . '] ' . $msg . "\n";

    if ($err) {
        die $msg if ( $err eq 'die' );
        warn $msg;
    }
    else {
        print decode( $self->{encoding}, $msg );
    }

    return;
}

sub _parent {
    my ($device) = @_;
    my $self     = $device->data('self');
    my $session  = { start => time };
    my $delegate = sub {
        my $fresh_children = $device->children;
        $session->{children} = $fresh_children if (
            not $session->{children} or
            join( ',', sort @{ $session->{children} } ) ne join( ',', sort @$fresh_children )