diff --git a/bin/aleesa-irc-bot b/bin/aleesa-irc-bot index 2e502d5..b2635df 100755 --- a/bin/aleesa-irc-bot +++ b/bin/aleesa-irc-bot @@ -30,7 +30,7 @@ use POSIX qw (setgid setuid); use File::Path qw (make_path); use File::Basename qw (dirname); use BotLib::Conf qw (LoadConf); -use IRCBot qw (RunIRCBot); +use IRCBot2 qw (RunIRCBot); # if we run under root, create pid dir and set correct owner for it, same for debug log if it is defined if ($UID == 0) { diff --git a/cpanfile b/cpanfile index 115d02a..7e0d8c6 100644 --- a/cpanfile +++ b/cpanfile @@ -1,8 +1,9 @@ -requires "Bot::IRC"; +requires "AnyEvent::IRC"; requires "CHI"; requires "CHI::Driver::BerkeleyDB"; requires "Cwd"; requires "Cwd::utf8"; +requires "Date::Format::ISO8601"; requires "DateTime"; requires "DB_File"; requires "Digest::HMAC_SHA1"; diff --git a/data/sample_config.json b/data/sample_config.json index 34cbeb7..858ef7a 100644 --- a/data/sample_config.json +++ b/data/sample_config.json @@ -1,32 +1,40 @@ { -# all cached will go there, they named after module name + # where to connect "server" : "127.0.0.1", "port" : "6667", "ssl" : 0, "nick" : "aleesa", - "connect_cmd" : "/join #a\n/join #b", -# where caches go + # join to at least one channel + "channels": [ + "#a", + "#b" + ], + + # identify with nickserv + "identify": "password", + + # where caches go "cachedir" : "data/cache", -# unprivileged system user to run bot as + # unprivileged system user to run bot as "user" : "nobody", -# where to store brains + # where to store brains "braindir": "data/brains", -# bot commands will begin with this symbol + # bot commands will begin with this symbol "csign": "!", -# stderr + # stderr "log" : "/var/log/aleesa-irc-bot/error.log", -# stdout + # stdout "debug_log" : "/dev/null", -# ditto + # ditto "pid" : "/var/run/aleesa-irc-bot/aleesa-irc-bot.pid", -# where to store brain with generated latin mumble + # where to store brain with generated latin mumble "lat" : { "brain" : "data/lat/brain.sqlite", "src" : "data/lat.txt" diff --git a/lib/Bot/IRC.pm b/lib/Bot/IRC.pm deleted file mode 100644 index 52829d3..0000000 --- a/lib/Bot/IRC.pm +++ /dev/null @@ -1,1461 +0,0 @@ -package Bot::IRC; -# ABSTRACT: Yet Another IRC Bot - -use 5.014; -use exact; - -use Encode qw (_utf8_on _utf8_off); -use Daemon::Device; -use Date::Format 'time2str'; -use IO::Socket::IP -register; -use IO::Socket::SSL; -use Time::Crontab; - -our $VERSION = '1.35'; # 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->{connect}{nick} //= 'bot'; - $self->{connect}{name} //= 'Yet Another IRC Bot'; - $self->{connect}{port} ||= 6667; - - $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->{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("USER $self->{nick} 0 * :$self->{connect}{name}\r\n"); - $self->{socket}->print("NICK $self->{nick}\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 { - my $e = $_ || $@; - croak("Daemon device instantiation failure: $e"); - }; - - $self->{device}->run; -} - -sub note { - my ( $self, $msg, $err ) = @_; - _utf8_on $msg; - 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 $msg; - } - - return; -} - -sub _parent { - my ($device) = @_; - my $self = $device->data('self'); - my $session = { start => time }; - my $delegate = sub { - my ($random_child) = - map { $_->[0] } - sort { $a->[1] <=> $b->[1] } - map { [ $_, rand() ] } - @{ $device->children }; - - $device->message( $random_child, @_ ); - }; - - local $SIG{ALRM} = sub { - alarm 1; - my $time = time; - - for ( - grep { - ref $_->{timing} and ( $time % 60 == 0 ) and $_->{timing}->match($time) or - not ref $_->{timing} and ( ( $time - $session->{start} ) % $_->{timing} == 0 ) - } @{ $self->{ticks} } - ) { - try { - $_->{code}->($self); - } - catch { - my $e = $_ || $@; - warn "Tick execution failure: $e\n"; - }; - } - }; - - local $SIG{__WARN__} = sub { note( undef, $_[0], 'warn' ) }; - local $SIG{__DIE__} = sub { note( undef, $_[0], 'die' ) }; - - srand(); - my @lines; - - try { - if ( $self->{send_user_nick} eq 'on_parent' ) { - $self->say("USER $self->{nick} 0 * :$self->{connect}{name}"); - $self->say("NICK $self->{nick}"); - } - - while ( my $line = $self->{socket}->getline ) { - $line =~ s/\003\d{2}(?:,\d{2})?//g; # remove IRC color codes - $line =~ tr/\000-\037//d; # remove all control characters - - $self->note($line); - chomp($line); - - if ( not $session->{established} ) { - if ( not $session->{user} ) { - if ( $self->{send_user_nick} eq 'on_reply' ) { - $self->say("USER $self->{nick} 0 * :$self->{connect}{name}"); - $self->say("NICK $self->{nick}"); - } - elsif ( $self->{send_user_nick} eq 'on_connect' ) { - $self->note("<<< USER $self->{nick} 0 * :$self->{connect}{name}\r\n"); - $self->note("<<< NICK $self->{nick}\r\n"); - } - $session->{user} = 1; - } - if ( $line =~ /^ERROR.+onnect\w+ too fast/ ) { - warn "$line\n"; - warn "Sleeping 20 and retrying...\n"; - sleep 20; - $device->daemon->do_restart; - } - elsif ( $line =~ /^ERROR\s/ ) { - warn "$line\n"; - $device->daemon->do_stop; - } - elsif ( $line =~ /^:\S+\s433\s/ ) { - $self->nick( $self->{nick} . '_' ); - } - elsif ( $line =~ /^:\S+\s001\s/ ) { - $self->say($_) for ( map { - my $command = $_; - $command =~ s|^/msg |PRIVMSG |; - $command =~ s|^/(\w+)|uc($1)|e; - $command; - } @{ $device->data('commands') } ); - - $self->join; - $session->{established} = 1; - alarm 1 if ( @{ $self->{ticks} } ); - } - } - - shift @lines while ( @lines > 10 ); - my $now = time(); - - unless ( grep { $_->{line} eq $line and $_->{time} + 1 > $now } @lines ) { - $delegate->($line); - } - else { - $self->note("### Skipped repeated line: $line"); - } - - push @lines, { line => $line, time => $now }; - } - } - catch { - my $e = $_ || $@; - warn "Daemon parent loop failure: $e\n"; - kill( 'KILL', $_ ) for ( @{ $device->children } ); - }; -} - -sub _child { - local $SIG{__WARN__} = sub { note( undef, $_[0], 'warn' ) }; - local $SIG{__DIE__} = sub { note( undef, $_[0], 'die' ) }; - - srand(); - sleep 1 while (1); -} - -sub _on_message { - my $device = shift; - my $self = $device->data('self'); - my $passwd = $device->data('passwd'); - - for my $line (@_) { - if ( $line =~ /^>>>\sNICK\s(.*)/ ) { - $self->{nick} = $1; - next; - } - elsif ( $line =~ /^:\S+\s433\s/ ) { - $self->nick( $self->{nick} . '_' ); - next; - } - - $self->{in} = { map { $_ => '' } qw( line source nick user server command forum text ) }; - $self->{in}{$_} = 0 for ( qw( private to_me ) ); - $self->{in}{line} = $line; - - if ( $line =~ /^(ERROR)\s/ ) { - warn $line . "\n"; - } - elsif ( $line =~ /^:(\S+?)!~?(\S+?)@(\S+?)\s(\S+)\s(\S+)\s:(.*)/ ) { - @{ $self->{in} }{ qw( nick user server command forum text ) } = ( $1, $2, $3, $4, $5, $6 ); - $self->{in}{full_text} = $self->{in}{text}; - } - elsif ( $line =~ /^:(\S+?)!~?(\S+?)@(\S+?)\s(\S+)\s:(.*)/ ) { - @{ $self->{in} }{ qw( nick user server command text ) } = ( $1, $2, $3, $4, $5 ); - ( $self->{in}{forum} = $self->{in}{text} ) =~ s/^:// - if ( $self->{in}{command} eq 'JOIN' or $self->{in}{command} eq 'PART' ); - } - elsif ( $line =~ /^:(\S+?)!~?(\S+?)@(\S+?)\s(\S+)\s(\S+)\s(.*)/ ) { - @{ $self->{in} }{ qw( nick user server command forum text ) } = ( $1, $2, $3, $4, $5, $6 ); - } - elsif ( $line =~ /^:(\S+?)!~?(\S+?)@(\S+?)\s(\S+)\s(\S+)/ ) { - @{ $self->{in} }{ qw( nick user server command forum ) } = ( $1, $2, $3, $4, $5, $6 ); - } - elsif ( $line =~ /^(PING)\s(.+)/ ) { - @{ $self->{in} }{ qw( command text ) } = ( $1, $2 ); - $self->say( 'PONG ' . $self->{in}{text} ); - next; - } - elsif ( $line =~ /^:(\S+)\s([A-Z]+|\d+)\s(\S+)\s(.*)/ ) { - @{ $self->{in} }{ qw( source command forum text ) } = ( $1, $2, $3, $4 ); - } - else { - warn 'Unparsed line (probably a bug in Bot::IRC; please report it): ', $line . "\n"; - } - - next unless ( $self->{in}{nick} ne $self->{nick} ); - - if ( $self->{in}{command} eq 'PRIVMSG' ) { - $self->{in}{private} = 1 if ( $self->{in}{forum} and $self->{in}{forum} eq $self->{nick} ); - $self->{in}{to_me} = 1 if ( - $self->{in}{text} =~ s/^\s*\b$self->{nick}\b[\s\W]*//i or - $self->{in}{text} =~ s/[\s\W]*\b$self->{nick}\b[\s\W]*$//i or - $self->{in}{private} - ); - } - - if ( $self->{in}{to_me} ) { - if ( $self->{in}{text} =~ /^\s*help\W*$/i ) { - $self->reply_to( - 'Ask me for help with "help topic" where the topic is one of the following: ' . - $self->list( ', ', 'and', sort keys %{ $self->{helps} } ) . '.' - ); - next; - } - elsif ( $self->{in}{text} =~ /^\s*help\s+(.+?)\W*$/i ) { - $self->reply_to( - ( $self->{helps}{$1} || "Couldn't find the help topic: $1." ) - ); - next; - } - elsif ( $self->{in}{text} =~ /Sorry. I don't understand./ ) { - next; - } - } - - hook: for my $hook ( - @{ $self->{hooks} }, - - { - when => { - to_me => 1, - text => qr/^\s*cmd\s+(?\S+)\s+(?.+)$/i, - }, - code => sub { - my ( $bot, $in, $m ) = @_; - - if ( $m->{passwd} and $passwd and $m->{passwd} eq $passwd ) { - $bot->say($_) for ( - map { - my $command = $_; - $command =~ s|^/msg |PRIVMSG |; - $command =~ s|^/(\w+)|uc($1)|e; - $command; - } split( /\s*;\s*/, $m->{cmd} ) - ); - } - - return 1; - }, - }, - - { - when => { - full_text => qr/^\s*$self->{nick}\s*[!\?]\W*$/i, - }, - code => sub { - my ($bot) = @_; - $bot->reply_to('Yes?'); - }, - }, - - { - when => { - to_me => 1, - text => qr/^(?hello|greetings|hi|good\s+\w+)\W*$/i, - }, - code => sub { - my ( $bot, $in, $m ) = @_; - $bot->reply_to( ucfirst( lc( $m->{word} ) ) . '.' ); - }, - }, - - ( map { - { - when => $_, - code => sub { - my ($bot) = @_; - $bot->reply_to(qq{Sorry. I don't understand. (Try "$self->{nick} help" for help.)}); - }, - }, - } ( - { - private => 0, - full_text => qr/^\s*$self->{nick}\s*[,:\->~=]/i, - }, - { - private => 1, - }, - ) ), - - ) { - my $captured_matches = {}; - - for my $type ( keys %{ $hook->{when} } ) { - next hook unless ( - ref( $hook->{when}{$type} ) eq 'Regexp' and - $self->{in}{$type} and $self->{in}{$type} =~ $hook->{when}{$type} or - ref( $hook->{when}{$type} ) eq 'CODE' and $hook->{when}{$type}->( - $self, - $self->{in}{$type}, - { %{ $self->{in} } }, - ) or - ( - defined $self->{in}{$type} and defined $hook->{when}{$type} and - $self->{in}{$type} eq $hook->{when}{$type} - ) - ); - - $captured_matches = { %$captured_matches, %+ } if ( keys %+ ); - } - - my $rv; - try { - $rv = $hook->{code}->( - $self, - { %{ $self->{in} } }, - $captured_matches, - ); - } - catch { - my $e = $_ || $@; - warn "Plugin hook execution failure: $e\n"; - }; - - last if ($rv); - } - } -} - -sub load { - my $self = shift; - - for my $plugin (@_) { - unless ( ref $plugin ) { - if ( $plugin =~ /^:core$/i ) { - $self->load( - 'Ping', - 'Join', - 'Seen', - 'Greeting', - 'Infobot', - 'Functions', - 'Convert', - 'Karma', - 'Math', - 'History', - ); - next; - } - - my $namespace; - for ( - $plugin, - __PACKAGE__ . "::Y::$plugin", - __PACKAGE__ . "::X::$plugin", - __PACKAGE__ . "::$plugin", - ) { - ( my $path = $_ ) =~ s|::|/|g; - - eval "require $_"; - unless ($@) { - $namespace = $_; - last; - } - else { - croak("Plugin load failure: $@") unless ( $@ =~ /^Can't locate $path/ ); - } - } - croak("Unable to find or properly load $plugin") unless ($namespace); - - next if ( $self->{loaded}{$namespace} ); - - $namespace->import if ( $namespace->can('import') ); - croak("$namespace does not implement init()") unless ( $namespace->can('init') ); - - eval "${namespace}::init(\$self)"; - die("Plugin init failure: $@\n") if ($@); - - $self->{loaded}{$namespace} = time; - } - else { - $self->$_( @{ $plugin->{$_} } ) for ( qw( hooks ticks ) ); - $self->$_( $plugin->{$_} ) for ( qw( helps subs ) ); - } - } - - return $self; -} - -sub reload { - my $self = shift; - delete $self->{loaded}{$_} for (@_); - return $self->load(@_); -} - -sub hook { - my ( $self, $when, $code, $attr ) = @_; - - push( - @{ $self->{hooks} }, - { - when => $when, - code => $code, - attr => ( $attr // {} ), - }, - ); - - $self->subs( %{ $attr->{subs} } ) if ( ref $attr->{subs} eq 'HASH' ); - $self->helps( %{ $attr->{helps} } ) if ( ref $attr->{helps} eq 'HASH' ); - - return $self; -} - -sub hooks { - my $self = shift; - $self->hook(@$_) for (@_); - return $self; -} - -sub helps { - my ( $self, @input ) = @_; - - try { - $self->{helps} = { %{ $self->{helps} }, @input }; - } - catch { - $self->note('Plugin helps called but not properly implemented'); - }; - - return $self; -} - -sub tick { - my ( $self, $timing, $code ) = @_; - - push( @{ $self->{ticks} }, { - timing => ( $timing =~ /^\d+$/ ) ? $timing : Time::Crontab->new($timing), - code => $code, - } ); - return $self; -} - -sub ticks { - my $self = shift; - $self->tick(@$_) for (@_); - return $self; -} - -sub subs { - my $self = shift; - - if ( @_ % 2 ) { - $self->note('Plugin helps called but not properly implemented'); - return $self; - } - - my $subs = {@_}; - - for my $name ( keys %$subs ) { - no strict 'refs'; - no warnings 'redefine'; - *{ __PACKAGE__ . '::' . $name } = $subs->{$name}; - } - - return $self; -} - -sub register { - my $self = shift; - $self->{loaded}{$_} = time for (@_); - return $self; -} - -sub vars { - my ( $self, $name ) = @_; - ( $name = lc( substr( ( caller() )[0], length(__PACKAGE__) + 2 ) ) ) =~ s/::/\-/g unless ($name); - return ( defined $self->{vars}{$name} ) ? $self->{vars}{$name} : {}; -} - -sub settings { - my ( $self, $name ) = @_; - return ( defined $name ) ? $self->{$name} : { %$self }; -} - -sub reply { - my ( $self, $message ) = @_; - - if ( $self->{in}{forum} ) { - $self->msg( - ( ( $self->{in}{forum} eq $self->{nick} ) ? $self->{in}{nick} : $self->{in}{forum} ), - $message, - ); - } - else { - warn "Didn't have a target to send reply to.\n"; - } - return $self; -} - -sub reply_to { - my ( $self, $message ) = @_; - return $self->reply( ( ( not $self->{in}{private} ) ? "$self->{in}{nick}: " : '' ) . $message ); -} - -sub msg { - my ( $self, $target, $message ) = @_; - $self->say( "PRIVMSG $target :" . ( ( $message =~ s/^\/me\s+// ) ? "\001ACTION $message\001" : $message ) ); - return $self; -} - -sub say { - my $self = shift; - - for my $s (@_) { - if ($s =~ /^PRIVMSG /) { - foreach my $buf (split_irc_msg ($self, $s)) { - my $string = $buf; - _utf8_off ($buf); - $self->{socket}->syswrite( $buf . "\r\n"); - $self->note("<<< $string"); - sleep 1; - } - } else { - my $string = $s; - _utf8_off ($s); - $self->{socket}->syswrite( $s . "\r\n"); - $self->note("<<< $string"); - } - } - - return $self; -} - -sub nick { - my ( $self, $nick ) = @_; - - if ($nick) { - $self->{nick} = $nick; - $self->{device}->message( $_, ">>> NICK $self->{nick}" ) - for ( grep { $_ != $$ } $self->{device}->ppid, @{ $self->{device}->children } ); - $self->say("NICK $self->{nick}"); - } - return $self->{nick}; -} - -sub join { - my $self = shift; - - $self->say("JOIN $_") for ( - ( not @_ and $self->{connect}{join} ) - ? ( - ( ref $self->{connect}{join} eq 'ARRAY' ) - ? @{ $self->{connect}{join} } - : $self->{connect}{join} - ) - : @_ - ); - - return $self; -} - -sub part { - my $self = shift; - $self->say("PART $_") for (@_); - return $self; -} - -sub list { - my ( $self, $separator, $conjunction ) = ( shift, shift, shift ); - my @list = @_; - - if ( @list > 2 ) { - return CORE::join( $separator, @list[ 0 .. @list - 2 ], $conjunction . ' ' . $list[-1] ); - } - elsif ( @list > 1 ) { - return $list[0] . ' ' . $conjunction . ' ' . $list[1]; - } - else { - return $list[0]; - } -} - -sub health { - my ($self) = @_; - - return { - nick => $self->{nick}, - server => $self->{connect}{server}, - port => $self->{connect}{port}, - ssl => $self->{connect}{ssl}, - spawn => $self->{spawn}, - hooks => scalar( @{ $self->{hooks} } ), - ticks => scalar( @{ $self->{ticks} } ), - plugins => scalar( keys %{ $self->{loaded} } ), - }; -} - -sub split_irc_msg { - my $self = shift; - my $str = shift; - chomp $str; - - # as per https://www.ietf.org/rfc/rfc1459.txt#:~:text=IRC%20messages%20are%20always%20lines,the%20command%20and%20its%20parameters - # we must split string into array of 512 characters including \r\n at the end of the string, in case of utf-8 - my $MAXLEN = 510; - my @ret; - my $prefix = ''; - - my @message = split /:/, $str, 3; - $str = pop @message; - - while (substr($str, 0, 1) eq ' ') { - $str = substr($str, 1); - } - - if ($#message < 1) { - $prefix = CORE::join ':', @message; - $prefix .= ':'; - } else { - if ($message [1] eq $self->{nick} || $message [1] eq $self->{in}->{nick}) { - $prefix = CORE::join ':', @message; - $prefix .= ', '; - } else { - $prefix = CORE::join ':', @message; - $prefix .= ':'; - } - } - - $MAXLEN = $MAXLEN - bytes::length ($prefix) - 100; - - { - do { - my $buflen = bytes::length ($str); - - if ($buflen <= int($MAXLEN)) { - push @ret, sprintf ("%s%s", $prefix, $str); - last; - } - - for (my $len = $MAXLEN; $len > 2; $len--) { - my $buf = substr ($str, 0, $len); - my $strip_offset = length $buf; - - while (substr($buf, 0, 1) eq ' ') { - $buf = substr($buf, 1); - } - - while (substr ($buf, -1, 1) eq ' ') { - chop $buf; - } - - if (bytes::length($buf) <= $MAXLEN) { - push @ret, sprintf ("%s%s", $prefix, $buf); - $str = substr ($str, $strip_offset); - last; - } - } - } while (1); - } - - return @ret; -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Bot::IRC - Yet Another IRC Bot - -=head1 VERSION - -version 1.35 - -=for markdown [![test](https://github.com/gryphonshafer/Bot-IRC/workflows/test/badge.svg)](https://github.com/gryphonshafer/Bot-IRC/actions?query=workflow%3Atest) -[![codecov](https://codecov.io/gh/gryphonshafer/Bot-IRC/graph/badge.svg)](https://codecov.io/gh/gryphonshafer/Bot-IRC) - -=head1 SYNOPSIS - - use Bot::IRC; - - # minimal bot instance that does basically nothing except join a channel - Bot::IRC->new( - connect => { - server => 'irc.perl.org', - join => '#test', - }, - )->run; - - # illustrative example of most settings and various ways to get at them - my $bot = Bot::IRC->new( - spawn => 2, - daemon => { - name => 'bot', - lsb_sdesc => 'Yet Another IRC Bot', - pid_file => 'bot.pid', - stderr_file => 'bot.err', - stdout_file => 'bot.log', - }, - connect => { - server => 'irc.perl.org', - port => '6667', - nick => 'yabot', - name => 'Yet Another IRC Bot', - join => [ '#test', '#perl' ], - ssl => 0, - ipv6 => 0, - }, - plugins => [ - ':core', - ], - vars => { - store => 'bot.yaml', - }, - send_user_nick => 'on_parent', # or 'on_connect' or 'on_reply' - ); - - $bot->load( 'Infobot', 'Karma' ); - - ## Example inline plugin structure - # $bot->load({ - # hooks => [ [ {}, sub {}, {} ] ], - # helps => { name => 'String' }, - # subs => { name => sub {} }, - # ticks => [ [ '0 * * * *', sub {} ] ], - # }); - - $bot->run; - -=head1 DESCRIPTION - -Yet another IRC bot. Why? There are so many good bots and bot frameworks to -select from, but I wanted a bot framework that worked like a Unix service -out-of-the-box, operated in a pre-fork way to serve multiple concurrent -requests, and has a dirt-simple and highly extendable plugin mechanism. I also -wanted to keep the direct dependencies and core bot minimalistic, allowing as -much functionality as possible to be defined as optional plugins. - -=head2 Minimal Bot - -You can have a running IRC bot with as little as: - - use Bot::IRC; - - Bot::IRC->new( - connect => { - server => 'irc.perl.org', - }, - )->run; - -This won't actually do much apart from connecting to the server and responding -to pings, but it's useful to understand how this works. Let's say you place the -above code into a "bot.pl" file. You start the bot with: - - ./bot.pl start - -This will startup the bot. Command-line commands include: start, stop, restart, -reload, status, help, and so on. (See L for more details.) - -=head2 Pre-Forking Device - -When the bot is started, the parent process will fork or spawn a given number -of children workers. You can control their number along with setting locations -for things like PID file, log files, and so on. - - Bot::IRC->new( - spawn => 2, - daemon => { - name => 'bot', - lsb_sdesc => 'Yet Another IRC Bot', - pid_file => 'bot.pid', - stderr_file => 'bot.err', - stdout_file => 'bot.log', - }, - )->run; - -(See L for more details.) - -=head1 MAIN METHODS - -The following are the main or primary available methods from this class. - -=head2 new - -This method instantiates a bot object that's potentially ready to start running. -All bot settings can be specified to the C constructor, but some can be -set or added to through other methods off the instantiated object. - - Bot::IRC->new( - spawn => 2, - daemon => {}, - connect => { - server => 'irc.perl.org', - port => '6667', - nick => 'yabot', - name => 'Yet Another IRC Bot', - join => [ '#test', '#perl' ], - ssl => 0, - ipv6 => 0, - }, - plugins => [], - vars => {}, - )->run; - -C will default to 2. Under C, C will default to 6667. -C can be either a string or an arrayref of strings representing channels -to join after connnecting. C is a true/false setting for whether to -connect to the server over SSL. C is also true/false setting for whether -to forcibly connect to the server over IPv6. - -Read more about plugins below for more information about C and C. -Consult L and L for more details about C -and C. - -There's also an optional C parameter, which you probably won't -need to use, which defines when the bot will send the C and initial -C commands to the IRC server. There are 3 options: C, -C (the default), and C. C sends the C -and initial C immediately upon establishing a connection to the IRC -server, prior to the parent runtime loop and prior to children creation. -C (the default) sends the 2 commands within the parent runtime loop -prior to any responses from the IRC server. C (the only option in -versions <= 1.23 of this module) sends the 2 commands after the IRC server -replies with some sort of content after connection. - -=head2 run - -This should be the last call you make, which will cause your program to operate -like a Unix service from the command-line. (See L for -additional details.) - -C can optionally be passed a list of strings that will be executed after -connection to the IRC server. These should be string commands similar to what -you'd type in an IRC client. For example: - - Bot::IRC->new( connect => { server => 'irc.perl.org' } )->run( - '/msg nickserv identify bot_password', - '/msg operserv identify bot_password', - '/oper bot_username bot_password', - '/msg chanserv identify #bot_talk bot_password', - '/join #bot_talk', - '/msg chanserv op #bot_talk', - ); - -=head1 PLUGINS - -To do anything useful with a bot, you have to load plugins. You can do this -either by specifying a list of plugins with the C key passed to -C or by calling C. - -Plugins are just simple packages (or optionally a hashref, but more on that -later). The only requirement for plugins is that they provide an C -method. This will get called by the bot prior to forking its worker children. -It will be passed the bot object. Within C, you can call any number of -plugin methods (see the list of methods below) to setup desired functionality. - - package Your::Plugin; - use strict; - use warnings; - - sub init { - my ($bot) = @_; - - $bot->hook( - { - to_me => 1, - text => qr/\b(?w00t|[l1][e3]{2}[t7])\b/i, - }, - sub { - my ( $bot, $in, $m ) = @_; - $bot->reply("$in->{nick}, don't use the word: $m->{word}."); - }, - ); - } - - 1; - -When you load plugins, you can specify their packages a few different ways. When -attempting to load a plugin, the bot will start by looking for the name you -provided as a sub-class of itself. Then it will look for the plugin under the -assumption you provided it's full name. - - plugins => [ - 'Store', # matches "Bot::IRC::Store" - 'Random', # matches "Bot::IRC::X::Random" - 'Thing', # matches "Bot::IRC::Y::Thing" - 'My::Own::Plugin', # matches "My::Own::Plugin" - ], - -An unenforced convention for public/shared plugins is to have non-core plugins -(all plugins not provided directly by this CPAN library) subclasses of -"Bot::IRC::X". For private/unshared plugins, you can specify whatever name you -want, but maybe consider something like "Bot::IRC::Y". Plugins set in the X or -Y subclass namespaces will get matched just like core plugins. "Y" plugins will -have precedence over "X" which in turn will have precedence over core. - -If you need to allow for variables to get passed to your plugins, an unenforced -convention is to do so via the C key to C. - -=head2 Core Plugins - -If you specify ":core" as a plugin name, it will be expanded to load all the -core plugins. Core plugins are all the plugins that are bundled and -distributed with L. - -=over 4 - -=item * - -L - -=item * - -L - -=item * - -L - -=item * - -L - -=item * - -L - -=item * - -L - -=item * - -L - -=item * - -L - -=item * - -L - -=item * - -L - -=back - -Some core plugins require a storage plugin. If you don't specify one in your -plugins list, then the default L will be used, which is -probably not what you want (for performance reasons). Try -L instead. - - plugins => [ - 'Store::SQLite', - ':core', - ], - -=head1 PLUGIN METHODS - -The following are methods available from this class related to plugins. - -=head2 load - -This method loads plugins. It is the exact equivalent of passing strings to the -C key in C. If a plugin has already been loaded, it'll get -skipped. - - my $bot = Bot::IRC->new( - connect => { server => 'irc.perl.org' }, - plugins => [ 'Store', 'Infobot', 'Karma' ], - ); - - $bot->load( 'Infobot', 'Seen' ); - -From within your plugins, you can call C to specify plugin dependencies -in your plugins. - - sub init { - my ($bot) = @_; - $bot->load('Dependency'); - } - -=head2 reload - -If you need to actually reload a plugin, call C. It operates in the same -was as C, only it won't skip already-loaded plugins. - -=head2 hook - -This is the method you'll call to add a hook, which is basically a message -response handler. A hook includes a conditions trigger, some code to run -when the trigger fires, and an optional additional attributes hashref. - - $bot->hook( - { - to_me => 1, - text => qr/\b(?w00t|[l1][e3]{2}[t7])\b/i, - }, - sub { - my ( $bot, $in, $m ) = @_; - $bot->reply("$in->{nick}, don't use the word: $m->{word}."); - }, - { - subs => [], - helps => [], - }, - ); - -The conditions trigger is a hashref of key-value pairs where the key is a -component of the message and the value is either a value to exact match or a -regular expression to match. - -The code block will receive a copy of the bot, a hashref of key-value pairs -representing the message the hook is responding to, and an optionally-available -hashref of any named matches from the regexes in the trigger. - -The hashref representing the message the hook will have the following keys: - -=over 4 - -=item * - -C: text component of the message - -=item * - -C: IRC "command" like PRIVMSG, MODE, etc. - -=item * - -C: origin location like #channel or the nick who privately messaged - -=item * - -C: 1 or 0 representing if the message is private or in a channel - -=item * - -C: 1 or 0 representing if the message is addressing the bot or not - -=item * - -C: nick of the sender of the message - -=item * - -C: the source server's label/name - -=item * - -C: username of the sender of the message - -=item * - -C: server of the sender of the message - -=item * - -C: full message line/text - -=item * - -C: text component of the message with nick included - -=back - -B If you return a positive -value, all additional hooks are skipped because it will be assumed that this -hook properly responded to the message and no additional work needs to be done. -If the code block returns a false value, additional hooks will be checked as if -this hook's trigger caused the code block to be skipped. - -The optional additional attributes hashref supports a handful of keys. -You can specify C and C, which are exactly equivalent to -calling C and C. (See below.) - -=head2 hooks - -This method accepts a list of arrayrefs, each containing a trigger, code, and -attribute value and calls C for each set. - - ## Example hooks call structure - # $bot->hooks( - # [ {}, sub {}, {} ], - # [ {}, sub {}, {} ], - # ); - -=head2 helps - -This method is how you'd setup any help text you'd like the bot to provide to -users. It expects some number of key-value pairs where the key is the topic -title of the set of functionality and the value is the string of instructions. - - $bot->helps( - seen => 'Tracks when and where people were seen. Usage: seen , hide, unhide.', - join => 'Join and leave channels. Usage: join , leave , channels.', - ); - -In the example above, let's say your bot had the nick of "bot" and you were in -the same channel as your bot and you typed "bot, help" in your IRC channel. The -bot would respond with a list of available topics. Then if you typed "bot, help -seen" in the channel, the bot would reply with the "seen" string of -instructions. If typing directly to the bot (in a private message directly to -the bot), you don't need to specify the bot's name. - -=head2 tick - -Sometimes you'll want the bot to do something at a specific time or at some sort -of interval. You can cause this to happen by filing ticks. A tick is similar to -a hook in that it's a bit of code that gets called, but not based on a message -but based on time. C expects two values. The first is either an integer -representing the number of seconds of interval between calls to the code or a -crontab-like time expression. The second value is the code to call, which will -receive a copy of the bot object. - - $bot->tick( - 10, - sub { - my ($bot) = @_; - $bot->msg( '#test', '10-second interval.' ); - }, - ); - - $bot->tick( - '0 0 * * *', - sub { - my ($bot) = @_; - $bot->msg( '#test', "It's midnight!" ); - }, - ); - -=head2 ticks - -This method accepts a list of arrayrefs, each containing a time value and code -block and calls C for each set. - - $bot->ticks( - [ 10, sub {} ], - [ '0 0 * * *', sub {} ], - ); - -=head2 subs - -A plugin can also provide functionality to the bot for use in other plugins. -It can also override core methods of the bot. You do this with the C -method. - - $bot->subs( - incr => sub { - my ( $bot, $int ) = @_; - return ++$int; - }, - ); - - my $value = $bot->incr(42); # value is 43 - -=head2 register - -There are rare cases when you're writing your plugin where you want to claim -that your plugin satisfies the requirements for a different plugin. In other -words, you want to prevent the future loading of a specific plugin or plugins. -You can do this by calling C with the list of plugins (by full -namespace) that you want to skip. - - $bot->register('Bot::IRC::Storage'); - -Note that this will not block the reloading of plugins with C. - -=head2 vars - -When you are within a plugin, you can call C to get the variables for -the plugin by it's lower-case "simplified" name, which is the plugin's class -name all lower-case, without the preceding "Bot::IRC::" bit, and with "::"s -replaced with dashes. For example, let's say you were writing a -"Bot::IRC::X::Something" plugin. You would have users set variables in their -instantiation like so: - - Bot::IRC->new - plugins => ['Something'], - vars => { x-something => { answer => 42 } }, - )->run; - -Then from within the "Bot::IRC::X::Something" plugin, you would access these -variables like so: - - my $my_vars = $bot->vars; - say 'The answer to life, the universe, and everything is ' . $my_vars->{answer}; - -If you want to access the variables for a different namespace, pass into -C the "simplified" name you want to access. - - my $my_other_vars = $bot->vars('x-something-else'); - -=head2 settings - -If you need access to the bot's settings, you can do so with C. -Supply the setting name/key to get that setting, or provide no name/key to get -all settings as a hashref. - - my $connection_settings_hashref = $bot->settings('connect'); - -=head1 INLINE PLUGINS - -You can optionally inject inline plugins by providing them as hashref. This -works both with C and the C key. - - ## Example inline plugin structure - # $bot->load( - # { - # hooks => [ [ {}, sub {}, {} ], [ {}, sub {}, {} ] ], - # ticks => [ [ 10, sub {} ], [ '0 0 * * *', sub {} ] ], - # helps => { title => 'Description.' }, - # subs => { name => sub {} }, - # }, - # { - # hooks => [ [ {}, sub {}, {} ], [ {}, sub {}, {} ] ], - # ticks => [ [ 10, sub {} ], [ '0 0 * * *', sub {} ] ], - # helps => { title => 'Description.' }, - # subs => { name => sub {} }, - # }, - # ); - -=head1 OPERATIONAL METHODS - -The following are operational methods available from this class, expected to be -used inside various code blocks passed to plugin methds. - -=head2 reply - -If you're inside a hook, you can usually respond to most messages with the -C method, which accepts the text the bot should reply with. The method -returns the bot object. - - $bot->reply('This is a reply. Impressive, huh?'); - -If you want to emote something back or use any other IRC command, type it just -as you would in your IRC client. - - $bot->reply('/me feels something, which for a bot is rather impressive.'); - -=head2 reply_to - -C is exactly like C except that if the forum for the reply is -a channel instead of to a specific person, the bot will prepend the message -by addressing the nick who was the source of the response the bot is responding -to. - -=head2 msg - -Use C when you don't have a forum to reply to or want to reply in a -different forum (i.e. to a different user or channel). The method accepts the -forum for the message and the message text. - - $bot->msg( '#test', 'This is a message for everybody in #test.'); - -=head2 say - -Use C to write low-level lines to the IRC server. The method expects a -string that's a properly IRC message. - - $bot->say('JOIN #help'); - $bot->say('PRIVMSG #help :I need some help.'); - -=head2 nick - -Use C to change the bot's nick. If the nick is already in use, the bot -will try appending "_" to it until it finds an open nick. - -=head2 join - -Use C to join channels. - - $bot->join('#help'); - -If some sort of persistent storage plugin is loaded, the bot will remember the -channels it has joined or parted and use that as it's initial join on restart. - -=head2 part - -Use C to part channels. - - $bot->part('#help'); - -If some sort of persistent storage plugin is loaded, the bot will remember the -channels it has joined or parted and use that as it's initial join on restart. - -=head1 RANDOM HELPFUL METHODS - -The following are random additional methods that might be helpful in your -plugins. - -=head2 list - -This method is a simple string method that takes a list and crafts it for -readability. It expects a separator string, a final item conjunction string, -and a list of items. - - $bot->list( ', ', 'and', 'Alpha', 'Beta', 'Delta', 'Gamma' ); - # returns "Alpha, Beta, Delta, and Gamma" - - $bot->list( ', ', 'and', 'Alpha', 'Beta' ); - # returns "Alpha and Beta" - -=head2 health - -This method returns a hashref of simple key value pairs for different "health" -aspects (or current state) of the bot. It includes things like server and port -connection, number of children, and so on. - -=head2 note - -While in theory you shouldn't ever need to use it, there is a method called -"note" which is a handler for writing to the log and error files. If you -C or C, this handler steps in automatically. If you'd like to -C to STDOUT, which you really shouldn't need to do, then it's best to -call this method instead. The reason being is that the log file is designed to -be parsed in a specific way. If you write whatever you want to it, it will -corrupt the log file. That said, if you really, really want to, here's how you -use C: - - $bot->note('Message'); # writes a message to the log file - $bot->note( 'Message', 'warn' ); # writes a message to the error file - $bot->note( 'Message', 'die' ); # writes a message to the error file the dies - -=head1 SEE ALSO - -You can look for additional information at: - -=over 4 - -=item * - -L - -=item * - -L - -=item * - -L - -=item * - -L - -=item * - -L - -=item * - -L - -=back - -=head1 AUTHOR - -Gryphon Shafer - -=head1 COPYRIGHT AND LICENSE - -This software is Copyright (c) 2016-2021 by Gryphon Shafer. - -This is free software, licensed under: - - The Artistic License 2.0 (GPL Compatible) - -=cut diff --git a/lib/Bot/IRC/OnMessage.pm b/lib/Bot/IRC/OnMessage.pm deleted file mode 100644 index 0541332..0000000 --- a/lib/Bot/IRC/OnMessage.pm +++ /dev/null @@ -1,207 +0,0 @@ -package Bot::IRC::OnMessage; - -use 5.018; -use strict; -use warnings; -use utf8; -use open qw (:std :utf8); -use English qw ( -no_match_vars ); -use Math::Random::Secure qw (irand); -use BotLib qw (Command RandomCommonPhrase); -use BotLib::Conf qw (LoadConf); -use BotLib::Karma qw (KarmaSet); -use BotLib::Util qw (trim utf2sha1); -use Encode qw (_utf8_on); -use Hailo; -our $VERSION = '1.35'; # VERSION - -# Most gears are spinning here. -sub init { - my ($bot) = @_; - my $c = LoadConf (); - my $hailo; - - $bot->hook ( - { - command => 'PRIVMSG', - }, - - sub { - my $bot = shift; - my $msg = shift; - my $text = shift; - - # fix some utf8 flags, that are lost - _utf8_on $msg->{forum}; - _utf8_on $msg->{full_text}; - _utf8_on $msg->{user}; - my $chatid = $msg->{forum}; - - # The main idea is to find out if message contains command. - # I know that this framework contains nifty way to guess commands - # but it detects command when bot mentiond, but'd like to send - # commands via command sign (say, exclamation mark). - if ($msg->{full_text} =~ qr/^\s*\Q$bot->{nick}\E[\,|\:]?\s*$/i) { - # Someone call bot, but says only name, nothing more - $bot->reply_to ('Чего тебе?'); - } elsif ($msg->{full_text} =~ /^\Q$bot->{nick}\E[\,|\:]?\s+(.+)/i) { - # Someone wants to chit-chat with bot, lets use our brain to make an answer. - my $phrase = trim ($1); - - unless (defined $hailo->{$chatid}) { - my $cid = utf2sha1 ($chatid); - $cid =~ s/\//-/xmsg; - my $brainname = sprintf '%s/%s.sqlite', $c->{braindir}, $cid; - - $hailo->{$chatid} = eval { - Hailo->new ( - brain => $brainname, - order => 3 - ); - }; - - unless (defined $hailo->{$chatid}) { - $bot->note ($EVAL_ERROR); - return; - } - } - - my $answer = eval { - $hailo->{$chatid}->learn_reply ($phrase); - }; - - unless (defined $answer) { - $bot->note ($EVAL_ERROR); - $answer = RandomCommonPhrase (); - } - - $bot->reply_to ($answer); - } elsif (substr ($msg->{full_text}, -2) eq '++' || substr ($msg->{full_text}, -2) eq '--') { - # Looks like someone wants to adjust karma of the phrase - my @arr = split /\n/, $msg->{full_text}; - - if ($#arr < 1) { - my $answer = eval { - KarmaSet ( - $chatid, - trim ( - substr ( - $msg->{full_text}, - 0, - -2 - ) - ), - substr ($msg->{full_text}, -2) - ); - }; - - if (defined $answer) { - $bot->reply ($answer); - } else { - $bot->note ($EVAL_ERROR); - } - } - } elsif (substr ($msg->{full_text}, 0, 1) eq $c->{csign}) { - my $answer = Command ($msg->{forum}, $msg->{user}, $msg->{full_text}); - - if (defined $answer && $answer ne '') { - foreach my $str (split /\n/, $answer) { - chomp $str; - $str = trim ($str); - - if ($str ne '') { - $bot->reply ($str); - sleep 1; - } - } - } - } else { - # Default action - add phrase to brain reactor as is - unless (defined $hailo->{$chatid}) { - my $cid = utf2sha1 ($chatid); - $cid =~ s/\//-/xmsg; - my $brainname = sprintf '%s/%s.sqlite', $c->{braindir}, $cid; - - $hailo->{$chatid} = Hailo->new ( - brain => $brainname, - order => 3 - ); - - unless (defined $hailo->{$chatid}) { - $bot->note ($EVAL_ERROR); - return; - } - } - - $hailo->{$chatid}->learn ($msg->{full_text}); - } - - return 1; - }, - ); - - $bot->helps ( - anek => "$c->{csign}anek - рандомный анекдот с anekdot.ru", - анек => "$c->{csign}анек - рандомный анекдот с anekdot.ru", - анекдот => "$c->{csign}анекдот - рандомный анекдот с anekdot.ru", - buni => "$c->{csign}buni - комикс-стрип hapi buni", - bunny => "$c->{csign}bunny - рандомный кролик", - rabbit => "$c->{csign}rabbit - рандомный кролик", - кролик => "$c->{csign}кролик - рандомный кролик", - cat => "$c->{csign}cat - рандомная кошечка", - coin => "$c->{csign}cat - подбросить монетку - орёл или решка?", - монетка => "$c->{csign}cat - подбросить монетку - орёл или решка?", - кис => "$c->{csign}кис - рандомная кошечка", - dice => "$c->{csign}dice - бросить кости", - roll => "$c->{csign}roll - бросить кости", - кости => "$c->{csign}кости - бросить кости", - dig => "$c->{csign}dig - заняться археологией", - копать => "$c->{csign}копать - заняться археологией", - drink => "$c->{csign}drink - какой сегодня праздник?", - пословица => "$c->{csign}пословица - рандомная русская пословица", - proverb => "$c->{csign}proverb - рандомная русская пословица", - праздник => "$c->{csign}праздник - какой сегодня праздник?", - fish => "$c->{csign}fish - порыбачить", - fisher => "$c->{csign}fisher - порыбачить", - рыба => "$c->{csign}рыба - порыбачить", - рыбка => "$c->{csign}рыбка - порыбачить", - рыбалка => "$c->{csign}рыбалка - порыбачить", - f => "$c->{csign}f - рандомная фраза из сборника цитат fortune_mod", - fortune => "$c->{csign}fortune - рандомная фраза из сборника цитат fortune_mod", - фортунка => "$c->{csign}фортунка - рандомная фраза из сборника цитат fortune_mod", - fox => "$c->{csign}fox - рандомная лисичка", - лис => "$c->{csign}лис - рандомная лисичка", - friday => "$c->{csign}friday - а не пятница ли сегодня?", - пятница => "$c->{csign}пятница - а не пятница ли сегодня?", - frog => "$c->{csign}frog - рандомная лягушка", - лягушка => "$c->{csign}лягушка - рандомная лягушка", - horse => "$c->{csign}horse - рандомная лошадка", - лошадь => "$c->{csign}лошадь - рандомная лошадка", - лошадка => "$c->{csign}лошадка - лошадка", - karma => "$c->{csign}karma фраза - посмотреть карму фразы", - карма => "$c->{csign}карма фраза - посмотреть карму фразы", - lat => "$c->{csign}lat - сгенерировать фразу из крылатого латинского выражения", - лат => "$c->{csign}лат - сгенерировать фразу из крылатого латинского выражения", - monkeyuser => "$c->{csign}monkeyuser - комикс-стрип MonkeyUser", - owl => "$c->{csign}owl - рандомная сова", - сова => "$c->{csign}сова - рандомная сова", - ping => "$c->{csign}ping - попинговать бота", - пинг => "$c->{csign}пинг - попинговать бота", - snail => "$c->{csign}snail - рандомная улитка", - улитка => "$c->{csign}улитка - рандомная улитка", - ver => "$c->{csign}ver - написать что-то про версию ПО", - version => "$c->{csign}version - написать что-то про версию ПО", - версия => "$c->{csign}версия - написать что-то про версию ПО", - w => "$c->{csign}w Город - погода в городе", - п => "$c->{csign}п Город - погода в городе", - xkcd => "$c->{csign}xkcd - комикс-стрип с xkcb.ru", - ); - - return 1; -} - -1; - -__END__ - -# vim: set ft=perl noet ai ts=4 sw=4 sts=4: \ No newline at end of file diff --git a/lib/Bot/IRC/ReJoin.pm b/lib/Bot/IRC/ReJoin.pm deleted file mode 100644 index 7912756..0000000 --- a/lib/Bot/IRC/ReJoin.pm +++ /dev/null @@ -1,52 +0,0 @@ -package Bot::IRC::ReJoin; -# Re-Join to channel on /kick - -use 5.018; -use strict; -use warnings; -use utf8; -use open qw (:std :utf8); -use English qw ( -no_match_vars ); -use Encode qw (_utf8_on); - -our $VERSION = '1.35'; # VERSION - -# Most gears are spinning here. -sub init { - my ($bot) = @_; - - $bot->hook ( - { - command => 'KICK', - }, - - sub { - my $bot = shift; - my $msg = shift; - - # fix some utf8 flags, that are lost - _utf8_on $msg->{forum}; - _utf8_on $msg->{full_text}; - _utf8_on $msg->{user}; - - my ($who, $why) = split / \:/, $msg->{text}, 2; - - if ($who eq $bot->{nick}) { - $bot->note ("I was kicked from $msg->{forum} by $msg->{nick} with reason $why"); - sleep 5; - $bot->join ($msg->{forum}); - $bot->note ("Re-joining to $msg->{forum}"); - } - - return 1; - }, - ); - - return 1; -} - -1; - -__END__ - -# vim: set ft=perl noet ai ts=4 sw=4 sts=4: \ No newline at end of file diff --git a/lib/BotLib.pm b/lib/BotLib.pm index 6823c02..4e714c4 100644 --- a/lib/BotLib.pm +++ b/lib/BotLib.pm @@ -8,6 +8,7 @@ use open qw (:std :utf8); use English qw ( -no_match_vars ); use Carp qw (carp); use Math::Random::Secure qw (irand); +use BotLib::Anek qw (Anek); use BotLib::Archeologist qw (Dig); use BotLib::Buni qw (Buni); use BotLib::Conf qw (LoadConf); diff --git a/lib/IRCBot.pm b/lib/IRCBot.pm deleted file mode 100644 index 8e5fb31..0000000 --- a/lib/IRCBot.pm +++ /dev/null @@ -1,58 +0,0 @@ -package IRCBot; - -use 5.018; -use strict; -use warnings; -use utf8; -use open qw (:std :utf8); -use English qw ( -no_match_vars ); -use Bot::IRC; -use BotLib::Conf qw (LoadConf); - -use version; our $VERSION = qw (1.0); -use Exporter qw (import); -our @EXPORT_OK = qw (RunIRCBot); - - -sub RunIRCBot { - my $c = LoadConf (); - - my $bot = Bot::IRC->new ( - spawn => 2, - daemon => { - name => 'aleesa-irc-bot', - lsb_sdesc => 'Aleesa IRC Bot', - pid_file => $c->{pid}, - stderr_file => $c->{log}, - stdout_file => $c->{debug_log}, - }, - connect => { - server => $c->{server}, - port => $c->{port}, - nick => $c->{nick}, - name => 'Aleesa IRC Bot', - ssl => $c->{ssl}, - ipv6 => 0, - }, - ); - - $bot->load ('OnMessage', 'ReJoin'); # our main plugin that handles all the incomming messages, mostly - $bot->helps( - about => 'I am just another chatty bot.', - ); - - # finally, run bot - if (defined $c->{'connect_cmd'} && $c->{'connect_cmd'} ne '') { - my @connect_cmd = map {chomp; $_} split (/\n/, $c->{'connect_cmd'}); - $bot->run (@connect_cmd); - } else { - $bot->run; - } - - return; -} - - -1; - -# vim: set ft=perl noet ai ts=4 sw=4 sts=4: diff --git a/lib/IRCBot2.pm b/lib/IRCBot2.pm new file mode 100644 index 0000000..c5ec9a5 --- /dev/null +++ b/lib/IRCBot2.pm @@ -0,0 +1,282 @@ +package IRCBot2; + +use 5.018; +use strict; +use warnings; +use utf8; +use open qw (:std :utf8); +use English qw ( -no_match_vars ); +use AnyEvent; +use AnyEvent::IRC; +use AnyEvent::IRC::Client; +use Date::Format::ISO8601 qw (gmtime_to_iso8601_datetime); +use Encode qw (_utf8_on _utf8_off decode encode); +use Hailo; +use BotLib qw (Command RandomCommonPhrase); +use BotLib::Conf qw (LoadConf); +use BotLib::Karma qw (KarmaSet); +use BotLib::Util qw (trim utf2sha1); + +use version; our $VERSION = qw (1.0); +use Exporter qw (import); +our @EXPORT_OK = qw (RunIRCBot); + + +sub RunIRCBot { + my $c = LoadConf (); + my $hailo; + my $cv = AnyEvent->condvar; + my $irc = new AnyEvent::IRC::Client; + + $irc->reg_cb ( + irc_privmsg => sub { + my ($self, $msg) = @_; + my $botnick = $irc->nick (); + my $chatid = $msg->{params}->[0]; + my $text = decode('utf8', $msg->{params}->[-1]); + my $nick = (split /!/, $msg->{prefix})[0]; + my $answer; + + unless (defined $text) { return; } + + # The main idea is to find out if message contains command. + # I know that this framework contains nifty way to guess commands + # but it detects command when bot mentiond, but'd like to send + # commands via command sign (say, exclamation mark). + if ($text =~ qr/^\s*\Q$botnick\E[\,|\:]?\s*$/i) { + # Someone call bot, but says only name, nothing more + $answer = sprintf '%s, чего тебе?', $nick; + } elsif ($text =~ /^\Q$botnick\E[\,|\:]?\s+(.+)/i) { + # Someone wants to chit-chat with bot, lets use our brain to make an answer. + my $phrase = trim ($1); + + unless (defined $hailo->{$chatid}) { + my $cid = utf2sha1 ($chatid); + $cid =~ s/\//-/xmsg; + my $brainname = sprintf '%s/%s.sqlite', $c->{braindir}, $cid; + + $hailo->{$chatid} = eval { + Hailo->new ( + brain => $brainname, + order => 3 + ); + }; + + unless (defined $hailo->{$chatid}) { + warn ($EVAL_ERROR); + return; + } + } + + $answer = eval { + sprintf '%s, %s', $nick, lcfirst ($hailo->{$chatid}->learn_reply ($phrase)); + }; + + unless (defined $answer) { + warn ($EVAL_ERROR); + $answer = sprintf '%s, %s', $nick, RandomCommonPhrase (); + } + } elsif (substr ($text, -2) eq '++' || substr ($text, -2) eq '--') { + # Looks like someone wants to adjust karma of the phrase + my @arr = split /\n/, $text; + + if ($#arr < 1) { + my $answer = eval { + KarmaSet ( + $chatid, + trim ( substr ($text, 0, -2) ), + substr ($text, -2) + ); + }; + + unless (defined $answer) { + warn ($EVAL_ERROR); + return; + } + } + } elsif (substr ($text, 0, 1) eq $c->{csign}) { + $answer = Command ($chatid, $nick, $text); + + unless (defined $answer && $answer ne '') { + return; + } + } else { + # Default action - add phrase to brain reactor as is + unless (defined $hailo->{$chatid}) { + my $cid = utf2sha1 ($chatid); + $cid =~ s/\//-/xmsg; + my $brainname = sprintf '%s/%s.sqlite', $c->{braindir}, $cid; + + $hailo->{$chatid} = Hailo->new ( + brain => $brainname, + order => 3 + ); + + unless (defined $hailo->{$chatid}) { + warn ($EVAL_ERROR); + return; + } + } + + $hailo->{$chatid}->learn ($text); + } + + if (defined $answer) { + foreach my $string (split /\n/, $answer) { + if ($string ne '') { + _utf8_off ($string); + $irc->send_chan ($chatid, "PRIVMSG", $chatid, $string); + } + } + } + + return; + }, + + connect => sub { + my ($pc, $err) = @_; + if (defined $err) { + warn "Couldn't connect to server: $err\n"; + } + + if (defined ($c->{identify}) && $c->{identify} ne '') { + # freenode/libera.chat identification style + $irc->send_srv ( + PRIVMSG => 'NickServ', + sprintf ('identify %s %s', $c->{nick}, $c->{identify}) + ); + } + + for my $chan (@{$c->{channels}}) { + $irc->send_srv ("JOIN", $chan); + } + + return; + }, + + connfail => sub { + warn "Connection failed, trying again"; + sleep 5; + + $irc->connect( + $c->{server}, + $c->{port}, + { + nick => $c->{nick}, + user => $c->{nick}, + real => $c->{nick} + } + ); + }, + + registered => sub { + my ($self) = @_; + print "registered!\n"; + $irc->enable_ping (60); + return; + }, + + disconnect => sub { + print "disconnected: $_[1]!\n"; + sleep 5; + + $irc->connect( + $c->{server}, + $c->{port}, + { + nick => $c->{nick}, + user => $c->{nick}, + real => $c->{nick} + } + ); + + return; + }, + + kick => sub { + my ($self, $kicked_nick, $channel, $is_myself, $msg, $kicker_nick) = @_; + + if ($is_myself) { + warn sprintf ('%s kicked me from %s with reason: %s', $kicker_nick, $channel, decode('utf8', $msg)); + sleep 3; + $irc->send_srv ("JOIN", $channel); + } + + return; + }, + + nick_change => sub { + my ($self, $old_nick, $new_nick, $is_myself) = @_; + + if ($is_myself) { + warn sprintf ('my nick have been changed from %s to %s', $old_nick, $new_nick); + } + + return; + }, + + part => sub { + my ($self, $nick, $channel, $is_myself, $msg) = @_; + + if ($is_myself) { + warn sprintf ('I left %s channel', $channel); + } + + return; + }, + + join => sub { + my ($self, $nick, $channel, $is_myself) = @_; + + if ($is_myself) { + warn sprintf ('I joined to %s channel', $channel); + } + + return; + }, + ); + + # these commands will queue until the connection + # is completly registered and has a valid nick etc. + $irc->ctcp_auto_reply ('CLIENTINFO', ['CLIENTINFO', 'CLIENTINFO ACTION FINGER PING SOURCE TIME USERINFO VERSION']); + $irc->ctcp_auto_reply ('ACTION', + sub { + my ($cl, $src, $target, $tag, $msg, $type) = @_; + return ['ACTION', $msg]; + } + ); + $irc->ctcp_auto_reply ('FINGER', ['FINGER', $c->{nick}]); + $irc->ctcp_auto_reply ('PING', + sub { + my ($cl, $src, $target, $tag, $msg, $type) = @_; + return ['PING', $msg]; + } + ); + $irc->ctcp_auto_reply ('SOURCE', ['SOURCE', 'https://github.com/eleksir/aleesa-irc-bot']); + $irc->ctcp_auto_reply ('USERINFO', ['USERINFO', $c->{nick}]); + $irc->ctcp_auto_reply ('VERSION', ['VERSION', 'Aleesa IRC Bot/1.0']); + $irc->ctcp_auto_reply ('TIME', ['TIME', gmtime_to_iso8601_datetime (time ()) ]); + + if ($c->{ssl}) { + $irc->enable_ssl (); + } + + $irc->connect ( + $c->{server}, + $c->{port}, + { + nick => $c->{nick}, + user => $c->{nick}, + real => $c->{nick} + } + ); + + $cv->wait; + $irc->disconnect; + return; +} + + +1; + +# vim: set ft=perl noet ai ts=4 sw=4 sts=4: