Fix !drink command

.gitignore

@@ -8,6 +8,7 @@ data/friday/**
 data/image/**
 data/karma/**
 data/lat/**
+data/proverb/**
 TODO
 *.pid
 *.log

.perlcriticrc

@@ -101,3 +101,6 @@ lib_sections    = NAME | VERSION | DESCRIPTION | AUTHOR | LICENSE AND COPYRIGHT
 
 [-BuiltinFunctions::ProhibitComplexMappings]
 # so how I suppose to chomp() every damn string in array?
+
+[-ValuesAndExpressions::ProhibitEscapedCharacters]
+# lets follow example of AnyEvent::IRC::Client, and do not complicate this stuff

README.md

@@ -5,10 +5,6 @@
 It is based on Perl modules [Bot::IRC][1] and [Hailo][2] as
 conversation generator.
 
-Module [Bot::IRC][1] is vendored and tailored to this particular bot because
-of utf-8 issues in original source which are fix by hacking (yes, it is not
-canonical/convinient way fix it, what done is already done).
-
 Config located in **data/config.json**, sample config provided as
 **data/sample_config.json**.
 

bin/aleesa-irc-bot

@@ -25,23 +25,39 @@ BEGIN {
 
 use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
 no Cwd;
-use Cwd::utf8 qw (abs_path);
+use Cwd::utf8 qw (chdir abs_path);
-use POSIX qw (setgid setuid);
+use POSIX qw (setgid setuid setsid);
 use File::Path qw (make_path);
-use File::Basename qw (dirname);
+use File::Basename qw (basename dirname);
+use Log::Any qw ($log);
+use Log::Any::Adapter;
+use Log::Any::For::Std;
 use BotLib::Conf qw (LoadConf);
 use IRCBot qw (RunIRCBot);
 
-# if we run under root, create pid dir and set correct owner for it, same for debug log if it is defined
+sub daemonize ();
-if ($UID == 0) {
+sub __fork ();
-	my $C = LoadConf ();
+sub __signal_handler;
 
-	unless (defined $C->{user}) {
+local $OUTPUT_AUTOFLUSH = 1;
-		die "Unable to run as root, please define unprivileged user in config.json\n";
+my $runAsUid = $UID;
+
+my $piddir = '/var/run/' . basename (abs_path $PROGRAM_NAME);
+my $C = LoadConf ();
+my $loglevel = $C->{'loglevel'} // 'notice';
+my $logfile;
+
+if (defined $C->{'log'}) {
+	$logfile = $C->{'log'};
+} elsif (defined $C->{'debug_log'}) {
+	$logfile = $C->{'debug_log'};
 }
 
-	my ($uid, $gid) = (getpwnam $C->{user})[2,3];
+# if we run under root, create pid dir and set correct owner for it, same for debug log if it is defined
-	my $piddir = dirname $C->{pid};
+if ($UID == 0) {
+	my $user = $C->{user};
+	die "Unable to run as root, please define unprivileged user in config.json\n" unless (defined ($user));
+	my ($uid, $gid) = (getpwnam $user)[2,3];
 
 	unless (-d $piddir) {
 		make_path (
@@ -52,14 +68,6 @@ if ($UID == 0) {
 		) or die "Unable to create $piddir: $OS_ERROR\n";
 	}
 
-	my $logfile;
-
-	if (defined $C->{'log'}) {
-		$logfile = $C->{'log'};
-	} elsif (defined $C->{'debug_log'}) {
-		$logfile = $C->{'debug_log'};
-	}
-
 	if (defined $logfile) {
 		my $logdir = dirname $logfile;
 
@@ -74,16 +82,108 @@ if ($UID == 0) {
 	}
 
 # drop privs
-	setgid ($gid) or die "Unable to switch to group of $C->{user}: $OS_ERROR\n";
+	setgid ($gid) or die "Unable to switch to group of $user: $OS_ERROR\n";
-	setuid ($uid) or die "Unable to switch to account $C->{user}: $OS_ERROR\n";
+	setuid ($uid) or die "Unable to switch to account $user: $OS_ERROR\n";
+} else {
+	$piddir = $workdir;
 }
 
+if (defined $logfile) {
+	# loglevel warning suppresses logging from CHI.
+	Log::Any::Adapter->set ('File', $logfile, log_level => $loglevel);
+
+	# Some annoying CHI logging events come with category set to CHI::Driver and log_level set to debug.
+	# Until we use start using Log::Any native features and set whole loglevel accordingly, lets lower
+	# verbosity paticulary for CHI.
+	Log::Any::Adapter->set (
+		{
+			category => 'CHI::Driver'
+		},
+		'File',
+		$logfile,
+		log_level => 'warn'
+	);
+} else {
+	# no log defined so set loglevel to the least verbose
+	Log::Any::Adapter->set ('File', '/dev/null', 'log_level'=>'emergency');
+}
+
+# double fork attach to /dev/null all stdio and go background
+daemonize ();
+
+# write pidfile
+my $apath = abs_path $PROGRAM_NAME;
+
+unless (defined $apath) {
+	$log->fatal ("[FATAL] Unable to get abs_path: $OS_ERROR");
+	exit 1;
+}
+
+my $pidfile = sprintf '%s/%s.pid', $piddir, basename $apath;
+$log->info ("[INFO] Creating pidfile at $pidfile");
+
+open (my $pid, '>', $pidfile) or do {
+	$log->fatal ("[FATAL] Error opening $pidfile: $OS_ERROR");
+	exit 1;
+};
+
+print $pid $PID or do {
+	$log->fatal ("[FATAL] Error writing to $pidfile: $OS_ERROR");
+	exit 1;
+};
+
+close $pid;                              ## no critic (InputOutput::RequireCheckedSyscalls)
+
+local $SIG{INT}  = \&__signal_handler;
+local $SIG{TERM} = \&__signal_handler;
+
 # set correct proctitle
 $PROGRAM_NAME = abs_path $PROGRAM_NAME;  ## no critic (Variables::RequireLocalizedPunctuationVars)
 
 RunIRCBot ();
 
+if (-f $pidfile) {
+	unlink $pidfile;
+}
+
 exit 0;
 
+sub daemonize () {
+	__fork ();
+	POSIX::setsid ();
+	open (STDIN, '<', '/dev/null');   ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
+	# we handle STDOUT && STDERR via Log::Any::For::Std, so do not close them explicitly
+	#open (STDOUT, '>', '/dev/null'); ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
+	#open (STDERR, '>', '/dev/null'); ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
+	__fork ();
+	umask 0;
+	return;
+}
+
+sub __fork () {
+	my $pid = fork;
+
+	unless (defined $pid) {
+		$log->fatal ("[FATAL] Can't fork: $OS_ERROR");
+		exit 1;
+	}
+
+	if ($pid != 0) {
+		exit 0;
+	}
+
+	return;
+}
+
+sub __signal_handler ($) {
+	$log->info ("[INFO] Caught a signal $OS_ERROR");
+
+	if (-f $pidfile) {
+		unlink $pidfile;
+	}
+
+	exit 0;
+}
+
 __END__
 # vim: set ft=perl noet ai ts=4 sw=4 sts=4:

bin/proverb_seed.pl

@@ -0,0 +1,26 @@
+#!/usr/bin/perl
+
+use 5.018;
+use strict;
+use warnings;
+use utf8;
+use open qw (:std :utf8);
+use English qw ( -no_match_vars );
+use version; our $VERSION = qw (1.0);
+
+my $workdir;
+
+# before we run, change working dir
+BEGIN {
+	use Cwd qw (chdir abs_path);
+	my @CWD = split /\//xms, abs_path ($PROGRAM_NAME);
+	if ($#CWD > 1) { $#CWD = $#CWD - 2; }
+	$workdir = join '/', @CWD;
+	chdir $workdir;
+}
+
+use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
+use BotLib::Proverb qw (Seed);
+
+Seed ();
+exit 0;

cpanfile

@@ -1,25 +1,30 @@
-requires "Bot::IRC";
+requires "AnyEvent::IRC",           "==0.97";
-requires "CHI";
+requires "CHI",                     "==0.61";
-requires "CHI::Driver::BerkeleyDB";
+requires "CHI::Driver::BerkeleyDB", "==0.05";
-requires "Cwd";
+requires "Cwd",                     "==3.75";
-requires "Cwd::utf8";
+requires "Cwd::utf8",               "==0.011";
-requires "DateTime";
+requires "Date::Format::ISO8601",   "==0.010";
-requires "DB_File";
+requires "DateTime",                "==1.58";
-requires "Digest::HMAC_SHA1";
+requires "DB_File",                 "==1.858";
-requires "Digest::SHA";
+requires "Digest::HMAC_SHA1",       "==1.04";
-requires "Encode";
+requires "Digest::SHA",             "==6.02";
-requires "English";
+requires "Encode",                  "==3.17";
-requires "File::Basename";
+requires "English",                 "0";
-requires "File::Path";
+requires "File::Basename",          "==2.85";
-requires "Hailo";
+requires "File::Path",              "==2.18";
-requires "HTML::TokeParser";
+requires "Hailo",                   "==0.75";
-requires "HTTP::Tiny";
+requires "HTML::TokeParser",        "==3.78";
-requires "JSON::XS";
+requires "HTTP::Tiny",              "==0.080";
-requires "JSON::PP";
+requires "IO::Socket::SSL",         "==2.074";
-requires "Math::Random::Secure";
+requires "JSON::XS",                "==4.03";
-requires "MIME::Base64";
+requires "JSON::PP",                "==4.09";
-requires "POSIX";
+requires "Log::Any",                "==1.710";
-requires "SQLite_File";
+requires "Log::Any::Adapter",       "==1.710";
-requires "Text::Fuzzy";
+requires "Log::Any::For::Std",      "==0.05";
-requires "URI::Encode::XS";
+requires "Math::Random::Secure",    "==0.080001";
-requires "URI::URL";
+requires "MIME::Base64",            "==3.16";
+requires "POSIX",                   "0";
+requires "SQLite_File",             "==0.1006";
+requires "Text::Fuzzy",             "==0.29";
+requires "URI::Encode::XS",         "==0.11";
+requires "URI::URL",                "==5.10";

data/sample_config.json

@@ -1,10 +1,18 @@
 {
-# 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",
+
+    # join to at least one channel
+    "channels": [
+        "#a",
+        "#b"
+    ],
+
+    # identify with nickserv
+    "identify": "password",
 
     # where caches go
     "cachedir" : "data/cache",
@@ -18,10 +26,9 @@
     # bot commands will begin with this symbol
     "csign": "!",
 
-# stderr
+    # log settings
-    "log" : "/var/log/aleesa-irc-bot/error.log",
+    "log" : "/var/log/aleesa-irc-bot/aleesa-irc-bot.log",
-# stdout
+    "loglevel" : "notice";
-    "debug_log" : "/dev/null",
 
     # ditto
     "pid" : "/var/run/aleesa-irc-bot/aleesa-irc-bot.pid",
@@ -46,6 +53,11 @@
         "srcdir" : "data/fortune_src"
     },
 
+    "proverb" : {
+        "dir" : "data/proverb",
+        "srcdir" : "data/proverb_src"
+    },
+
     "openweathermap" : {
         "appid": "get_it_on_openweathermap.org"
     },

lib/Bot/IRC/OnMessage.pm

@@ -1,205 +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}праздник - какой сегодня праздник?",
-		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:

lib/Bot/IRC/ReJoin.pm

@@ -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:

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);
@@ -21,6 +22,7 @@ use BotLib::Karma qw (KarmaGet);
 use BotLib::Kitty qw (Kitty);
 use BotLib::Lat qw (Lat);
 use BotLib::Monkeyuser qw (Monkeyuser);
+use BotLib::Proverb qw (Proverb);
 use BotLib::Util qw (trim utf2sha1);
 use BotLib::Weather qw (Weather);
 use BotLib::Xkcd qw (Xkcd);
@@ -49,20 +51,147 @@ sub RandomCommonPhrase () {
 }
 
 sub Command {
+	my $bot = shift;
 	my $chatid = shift;
 	my $chattername = shift;
 	my $text = shift;
 
 	my $reply;
 
-	if (substr ($text, 1, 2) eq 'w '  ||  substr ($text, 1, 2) eq 'п ') {
+	if (substr ($text, 1, 3) eq 'rum' || substr ($text, 1, 3) eq 'ром') {
+		my $target;
+
+		if ((length ($text) > 5)) {
+			$target = trim (substr $text, 5);
+		}
+
+		if (! defined $target || ($target eq '')) {
+			$target = $chattername;
+		}
+
+		$reply = 'притаскивает на подносе стопку рома для ' . $target . ', края стопки искрятся кристаллами соли.';
+		$bot->send_long_message ('utf8', 0, "PRIVMSG\001ACTION", $chatid, $reply);
+		return;
+	} elsif (substr ($text, 1, 5) eq 'vodka' || substr ($text, 1, 5) eq 'водка') {
+		my $target;
+
+		if ((length ($text) > 7)) {
+			$target = trim (substr $text, 7);
+		}
+
+		if (! defined $target || ($target eq '')) {
+			$target = $chattername;
+		}
+
+		$reply = 'подаёт шот водки с небольшим маринованным огурчиком на блюдце для ' . $target . '. Из огурчика торчит небольшая вилочка.';
+		$bot->send_long_message ('utf8', 0, "PRIVMSG\001ACTION", $chatid, $reply);
+		return;
+	} elsif (substr ($text, 1, 4) eq 'beer' || substr ($text, 1, 4) eq 'пиво') {
+		my $target;
+
+		if ((length ($text) > 6)) {
+			$target = trim (substr $text, 6);
+		}
+
+		if (! defined $target || ($target eq '')) {
+			$target = $chattername;
+		}
+
+		$reply = 'бахает об стол перед ' . $target . ' кружкой холодного пива, часть пенной шапки сползает по запотевшей стенке кружки.';
+		$bot->send_long_message ('utf8', 0, "PRIVMSG\001ACTION", $chatid, $reply);
+		return;
+	} elsif (substr ($text, 1, 7) eq 'tequila') {
+		my $target;
+
+		if ((length ($text) > 9)) {
+			$target = trim (substr $text, 9);
+		}
+
+		if (! defined $target || ($target eq '')) {
+			$target = $chattername;
+		}
+
+		$reply = 'ставит рядом с ' . $target . ' шот текилы, аккуратно на ребро стопки насаживает дольку лайма и ставит кофейное блюдце с горочкой соли.';
+		$bot->send_long_message ('utf8', 0, "PRIVMSG\001ACTION", $chatid, $reply);
+		return;
+	} elsif (substr ($text, 1, 6) eq 'текила') {
+		my $target;
+
+		if ((length ($text) > 8)) {
+			$target = trim (substr $text, 8);
+		}
+
+		if (! defined $target || ($target eq '')) {
+			$target = $chattername;
+		}
+
+		$reply = 'ставит рядом с ' . $target . ' шот текилы, аккуратно на ребро стопки насаживает дольку лайма и ставит кофейное блюдце с горочкой соли.';
+		$bot->send_long_message ('utf8', 0, "PRIVMSG\001ACTION", $chatid, $reply);
+		return;
+	} elsif (substr ($text, 1, 6) eq 'whisky') {
+		my $target;
+
+		if ((length ($text) > 8)) {
+			$target = trim (substr $text, 8);
+		}
+
+		if (! defined $target || ($target eq '')) {
+			$target = $chattername;
+		}
+
+		$reply = 'демонстративно достаёт из морозилки пару кубических камушков, бросает их в толстодонный стакан и аккуратно наливает Jack Daniels. Запускает стакан вдоль барной стойки, он останавливается около ' . $target . '.';
+		$bot->send_long_message ('utf8', 0, "PRIVMSG\001ACTION", $chatid, $reply);
+		return;
+	} elsif (substr ($text, 1, 5) eq 'виски') {
+		my $target;
+
+		if ((length ($text) > 7)) {
+			$target = trim (substr $text, 7);
+		}
+
+		if (! defined $target || ($target eq '')) {
+			$target = $chattername;
+		}
+
+		$reply = 'демонстративно достаёт из морозилки пару кубических камушков, бросает их в толстодонный стакан и аккуратно наливает Jack Daniels. Запускает стакан вдоль барной стойки, он останавливается около ' . $target . '.';
+		$bot->send_long_message ('utf8', 0, "PRIVMSG\001ACTION", $chatid, $reply);
+		return;
+	} elsif (substr ($text, 1, 8) eq 'absinthe') {
+		my $target;
+
+		if ((length ($text) > 10)) {
+			$target = trim (substr $text, 10);
+		}
+
+		if (! defined $target || ($target eq '')) {
+			$target = $chattername;
+		}
+
+		$reply = 'наливает абсент в стопку. Смочив кубик сахара в абсенте кладёт его на дырявую ложечку и пожигает. Как только пламя потухнет, ' . $c->{nick} . ' размешивает оплавившийся кубик в абсенте и подносит стопку ' . $target . '.';
+		$bot->send_long_message ('utf8', 0, "PRIVMSG\001ACTION", $chatid, $reply);
+		return;
+	} elsif (substr ($text, 1, 6) eq 'абсент') {
+		my $target;
+
+		if ((length ($text) > 8)) {
+			$target = trim (substr $text, 8);
+		}
+
+		if (! defined $target || ($target eq '')) {
+			$target = $chattername;
+		}
+
+		$reply = 'наливает абсент в стопку. Смочив кубик сахара в абсенте кладёт его на дырявую ложечку и пожигает. Как только пламя потухнет, ' . $c->{nick} . ' размешивает оплавившийся кубик в абсенте и подносит стопку ' . $target . '.';
+		$bot->send_long_message ('utf8', 0, "PRIVMSG\001ACTION", $chatid, $reply);
+		return;
+	} elsif (substr ($text, 1, 2) eq 'w '  ||  substr ($text, 1, 2) eq 'п ') {
 		my $city = substr $text, 2;
 		$reply = Weather ($city) =~ tr/\n/ /r;
 	} elsif (substr ($text, 1) eq 'anek'  ||  substr ($text, 1) eq 'анек' || substr ($text, 1) eq 'анекдот' ) {
 		$reply = Anek ();
 	} elsif (substr ($text, 1) eq 'coin' || substr ($text, 1) eq 'монетка') {
 		if (rand (101) < 0.016) {
-			$reply = "ребро";
+			$reply = 'ребро';
 		} else {
 			if (irand (2) == 0) {
 				if (irand (2) == 0) {
@@ -79,11 +208,9 @@ sub Command {
 			}
 		}
 	} elsif (substr ($text, 1) eq 'roll' || substr ($text, 1) eq 'dice' || substr ($text, 1) eq 'кости') {
-		$reply = sprintf "На первой кости выпало %d, а на второй — %d.", irand (6) + 1, irand (6) + 1;
+		$reply = sprintf 'На первой кости выпало %d, а на второй — %d.', irand (6) + 1, irand (6) + 1;
 	} elsif (substr ($text, 1) eq 'version'  ||  substr ($text, 1) eq 'ver') {
 		$reply = 'Версия нуль.чего-то_там.чего-то_там';
-	} elsif (substr ($text, 1) eq 'help'  ||  substr ($text, 1) eq 'помощь') {
-		$reply = "Попробуй '$c->{nick}, help' без кавычек, должно помочь.";
 	} elsif (substr ($text, 1) eq 'lat'  ||  substr ($text, 1) eq 'лат') {
 		$reply = Lat ();
 	} elsif (substr ($text, 1) eq 'cat'  ||  substr ($text, 1) eq 'кис') {
@@ -126,6 +253,8 @@ sub Command {
 		$reply = KarmaGet ($chatid, $mytext);
 	} elsif (substr ($text, 1) eq 'friday'  ||  substr ($text, 1) eq 'пятница') {
 		$reply = Friday ();
+	} elsif (substr ($text, 1) eq 'proverb'  ||  substr ($text, 1) eq 'пословица') {
+		$reply = Proverb ();
 	} elsif (substr ($text, 1) eq 'fortune'  ||  substr ($text, 1) eq 'фортунка'  ||  substr ($text, 1) eq 'f'  ||  substr ($text, 1) eq 'ф') {
 		my $phrase = Fortune ();
 		$reply = $phrase;

lib/BotLib/Anek.pm

@@ -6,11 +6,11 @@ use warnings;
 use utf8;
 use open qw (:std :utf8);
 use English qw ( -no_match_vars );
-use Carp qw (carp);
 use Encode;
 use HTML::TokeParser;
 use HTTP::Tiny;
 use JSON::XS;
+use Log::Any qw ($log);
 
 use version; our $VERSION = qw (1.0);
 use Exporter qw (import);
@@ -19,6 +19,11 @@ our @EXPORT_OK = qw (Anek);
 sub Anek {
 	my $r;
 	my $ret = 'Все рассказчики анекдотов отдыхают';
+	my $got_anek = 0;
+
+	# time to time anekdot.ru can give valid but unparsable response
+	# i've no clue where's err, just fetch another response and try again :)
+	for (1..3) {
 		for (1..3) {
 			my $ua = HTTP::Tiny->new (timeout => 3);
 			$r = $ua->get ('https://www.anekdot.ru/rss/randomu.html');
@@ -49,23 +54,31 @@ sub Anek {
 			if (defined $json && length ($json) > 10) {
 				$json =~ s/\\"/"/g;
 				$json =~ s/\\\\"/\\"/g;
-			chop $json;
+				$json = substr $json, 0, -3;
-			chop $json;
+
-			chop $json;
 				my $anek = eval { ${JSON::XS->new->relaxed->decode ($json)}[0] };
 
 				if (defined $anek) {
-				my @anek = split (/<br>/, $anek);
+					my @anek = split /<br>/, $anek;
-				$ret = join ("\n", @anek);
+					$ret = join "\n", @anek;
-			} else {
+
-				carp (sprintf "[WARN] anekdot.ru server returns incorrect json, full response text message: %s\n", $response_text);
+					if (length ($ret) > 1) {
+						$got_anek = 1;
 					}
 				} else {
-			carp (sprintf "[WARN] anekdot.ru server returns unexpected response text: %s\n", $response_text);
+					$log->warn (sprintf '[WARN] anekdot.ru server returns incorrect json, full response text message: %s', $response_text);
+				}
+			} else {
+				$log->warn (sprintf '[WARN] anekdot.ru server returns unexpected response text: %s', $response_text);
 			}
 
 		} else {
-		carp (sprintf "[WARN] anekdot.ru server return status %s with message: %s\n", $r->code, $r->message);
+			$log->warn (sprintf '[WARN] anekdot.ru server return status %s with message: %s', $r->code, $r->message);
+		}
+
+		if ($got_anek) {
+			last;
+		}
 	}
 
 	return $ret;

lib/BotLib/Buni.pm

@@ -6,9 +6,9 @@ use warnings;
 use utf8;
 use open qw (:std :utf8);
 use English qw ( -no_match_vars );
-use Carp qw (carp);
 use HTTP::Tiny;
 use HTML::TokeParser;
+use Log::Any qw ($log);
 
 use version; our $VERSION = qw (1.0);
 use Exporter qw (import);
@@ -47,7 +47,7 @@ sub Buni {
 			} while ($#{$a[0]} > 1);
 		}
 	} else {
-		carp (sprintf "[WARN] Server return status %s with message: %s\n", $r->{status}, $r->{reason});
+		$log->warn (sprintf '[WARN] Server return status %s with message: %s', $r->{status}, $r->{reason});
 	}
 
 	return $ret;

lib/BotLib/Conf.pm

@@ -7,8 +7,8 @@ use warnings;
 use utf8;
 use open qw (:std :utf8);
 use English qw ( -no_match_vars );
-use Carp qw (carp);
 use JSON::XS;
+use Log::Any qw ($log);
 
 use version; our $VERSION = qw (1.0);
 use Exporter qw (import);
@@ -23,12 +23,12 @@ sub LoadConf {
 
 	unless ($readlen) {
 		close $CH;                                   ## no critic (InputOutput::RequireCheckedSyscalls
-		carp ("[FATA] Unable to read $c: $OS_ERROR\n");
+		$log->fata ("[FATA] Unable to read $c: $OS_ERROR");
 	}
 
 	if ($readlen != $len) {
 		close $CH;                                   ## no critic (InputOutput::RequireCheckedSyscalls
-		carp ("[FATA] File $c is $len bytes on disk, but we read only $readlen bytes\n");
+		$log->fata ("[FATA] File $c is $len bytes on disk, but we read only $readlen bytes");
 	}
 
 	close $CH;                                       ## no critic (InputOutput::RequireCheckedSyscalls

lib/BotLib/Drink.pm

@@ -6,13 +6,13 @@ use warnings;
 use utf8;
 use open qw (:std :utf8);
 use English qw ( -no_match_vars );
-use Carp qw (carp);
 use Encode;
 use CHI;
 use CHI::Driver::BerkeleyDB;
 use DateTime;
 use HTTP::Tiny;
 use HTML::TokeParser;
+use Log::Any qw ($log);
 use POSIX qw (strftime);
 use BotLib::Conf qw (LoadConf);
 
@@ -20,14 +20,13 @@ use version; our $VERSION = qw (1.0);
 use Exporter qw (import);
 our @EXPORT_OK = qw (Drink);
 
-my @MONTH = qw (yanvar fevral mart aprel may iyun iyul avgust sentyabr oktyabr noyabr dekabr);
 my $c = LoadConf ();
 
 sub Drink {
 	my $drinkCallBack = sub {
 		my $ret;
 		my ($dayNum, $monthNum) = (localtime ())[3, 4];
-		my $url = sprintf 'https://kakoysegodnyaprazdnik.ru/baza/%s/%s', $MONTH[$monthNum], $dayNum;
+		my $url = 'https://prazdniki-segodnya.ru/';
 		my $r;
 
 		for (1..3) {
@@ -42,31 +41,35 @@ sub Drink {
 		}
 
 		if ($r->{success}) {
-			# TODO: Handle unexpected content
 			my $p = HTML::TokeParser->new(\$r->{content});
 			my @a;
-			my @holiday;
+			my %holiday;
 
 			do {
 				$#a = -1;
-				@a = $p->get_tag ('span'); ## no critic (Variables::RequireLocalizedPunctuationVars)
+				@a = $p->get_tag ('div'); ## no critic (Variables::RequireLocalizedPunctuationVars)
 
-				if ($#{$a[0]} > 2 && defined $a[0][1]->{itemprop} && $a[0][1]->{itemprop} eq 'text') {
+				if ($#{$a[0]} > 2) {
-					push @holiday,'* ' . decode ('UTF-8', $p->get_trimmed_text ('/span'));
+					my @shitty_array = $a[0];
+					foreach my $item (@shitty_array) {
+						if (ref $item) {
+							foreach my $item1 (@{$item}) {
+								my %h = eval { %{$item1} };
+								
+								if (defined ($h{class}) && $h{class} eq 'list-group-item text-monospace') {
+									$holiday {'* ' . decode ('UTF-8', $p->get_trimmed_text ('/div'))} = 1;
+								}
+							}
+						}
+					}
 				}
-
 			} while ($#{$a[0]} > 1);
 
-			if ($#holiday > 0) {
+			if (int (keys %holiday) > 0) {
-				# cut off something weird, definely not a "holyday"
+				$ret = join "\n", sort (keys %holiday);
-				$#holiday = $#holiday - 1;
-			}
-
-			if ($#holiday > 0) {
-				$ret = join "\n", @holiday;
 			}
 		} else {
-			carp (sprintf "[WARN] Server return status %s with message: %s\n", $r->{status}, $r->{reason});
+			$log->warn (sprintf '[WARN] Server return status %s with message: %s', $r->{status}, $r->{reason});
 			return undef;
 		}
 

lib/BotLib/Fortune.pm

@@ -7,8 +7,9 @@ use warnings;
 use utf8;
 use open qw (:std :utf8);
 use English qw ( -no_match_vars );
-use Carp qw (croak carp);
+use Carp qw (croak);
 use File::Path qw (make_path);
+use Log::Any qw ($log);
 use Math::Random::Secure qw (irand);
 use MIME::Base64;
 use SQLite_File;
@@ -69,7 +70,7 @@ sub Fortune () {
 	my $backingfile = sprintf '%s/fortune.sqlite', $dir;
 
 	tie my @array, 'SQLite_File', $backingfile  ||  do {
-		carp ("[ERROR] Unable to tie to $backingfile: $OS_ERROR\n");
+		$log->error ("[ERROR] Unable to tie to $backingfile: $OS_ERROR");
 		return '';
 	};
 

lib/BotLib/Fox.pm

@@ -6,9 +6,9 @@ use warnings;
 use utf8;
 use open qw (:std :utf8);
 use English qw ( -no_match_vars );
-use Carp qw (carp);
 use JSON::XS;
 use HTTP::Tiny;
+use Log::Any qw ($log);
 
 use version; our $VERSION = qw (1.0);
 use Exporter qw (import);
@@ -35,7 +35,7 @@ sub Fox {
 		};
 
 		unless (defined $jfox) {
-			carp ("[WARN] Unable to decode JSON: $EVAL_ERROR\n");
+			$log->warn ("[WARN] Unable to decode JSON: $EVAL_ERROR");
 		} else {
 			if ($jfox->{image}) {
 				$jfox->{image} =~ s/\\//xmsg;
@@ -43,7 +43,7 @@ sub Fox {
 			}
 		}
 	} else {
-		carp (sprintf "[WARN] Server return status %s with message: %s\n", $r->{status}, $r->{reason});
+		$log->warn (sprintf '[WARN] Server return status %s with message: %s', $r->{status}, $r->{reason});
 	}
 
 	return $ret;

lib/BotLib/Friday.pm

@@ -7,8 +7,9 @@ use warnings;
 use utf8;
 use open qw (:std :utf8);
 use English qw ( -no_match_vars );
-use Carp qw (croak carp);
+use Carp qw (croak);
 use File::Path qw (make_path);
+use Log::Any qw ($log);
 use Math::Random::Secure qw (irand);
 use SQLite_File;
 use BotLib::Conf qw (LoadConf);
@@ -80,7 +81,7 @@ sub Friday () {
 	my $backingfile = sprintf '%s/%s.sqlite', $dir, $dow[$today];
 
 	tie my @array, 'SQLite_File', $backingfile  ||  do {
-		carp ("[ERROR] Unable to tie to $backingfile: $OS_ERROR\n");
+		$log->error ("[ERROR] Unable to tie to $backingfile: $OS_ERROR");
 		return '';
 	};
 

lib/BotLib/Image/Flickr.pm

@@ -6,11 +6,11 @@ use warnings;
 use utf8;
 use open qw (:std :utf8);
 use English qw ( -no_match_vars );
-use Carp qw (carp);
 use Digest::HMAC_SHA1 qw (hmac_sha1);
 use File::Path qw (make_path);
 use JSON::XS;
 use HTTP::Tiny;
+use Log::Any qw ($log);
 use Math::Random::Secure qw (irand);
 use MIME::Base64;
 use SQLite_File;
@@ -338,19 +338,19 @@ sub flickrSearchByText {
 				if (defined $response) {
 					return $response;
 				} else {
-					carp ("[WARN] Flickr api returns incorrect json: $r->{content}\n");
+					$log->warn ("[WARN] Flickr api returns incorrect json: $r->{content}");
 					return undef;
 				}
 			} else {
-				carp ("[WARN] Flickr api returns incorrect json: $r->{content}\n");
+				$log->warn ("[WARN] Flickr api returns incorrect json: $r->{content}");
 				return undef;
 			}
 		} else {
-			carp ("[WARN] Flickr api returns incorrect json: $r->{content}\n");
+			$log->warn ("[WARN] Flickr api returns incorrect json: $r->{content}");
 			return undef;
 		}
 	} else {
-		carp ("[WARN] HTTP status code not 200: $r->{status}, $r->{content}\n");
+		$log->warn ("[WARN] HTTP status code not 200: $r->{status}, $r->{content}");
 		return undef;
 	}
 }
@@ -447,19 +447,19 @@ sub flickrSearchByTags {
 				if (defined $response) {
 					return $response;
 				} else {
-					carp ("[WARN] Flickr api returns incorrect json: $r->{content}\n");
+					$log->warn ("[WARN] Flickr api returns incorrect json: $r->{content}");
 					return undef;
 				}
 			} else {
-				carp ("[WARN] Flickr api returns incorrect json: $r->{content}\n");
+				$log->warn ("[WARN] Flickr api returns incorrect json: $r->{content}");
 				return undef;
 			}
 		} else {
-			carp ("[WARN] Flickr api returns incorrect json: $r->{content}\n");
+			$log->warn ("[WARN] Flickr api returns incorrect json: $r->{content}");
 			return undef;
 		}
 	} else {
-		carp ("[WARN] HTTP status code not 200: $r->{status}, $r>{content}\n");
+		$log->warn ("[WARN] HTTP status code not 200: $r->{status}, $r>{content}");
 		return undef;
 	}
 }
@@ -560,13 +560,13 @@ sub FlickrByTags {
 
 	unless (-d $dir) {
 		make_path ($dir) or do {
-			carp ("[ERROR] Unable to create $dir: $OS_ERROR\n");
+			$log->error ("[ERROR] Unable to create $dir: $OS_ERROR");
 			return 0;
 		};
 	}
 
 	tie my %secret, 'SQLite_File', $backingfile  ||  do {
-		carp ("[ERROR] Unable to tie to $backingfile: $OS_ERROR\n");
+		$log->error ("[ERROR] Unable to tie to $backingfile: $OS_ERROR");
 		return 0;
 	};
 
@@ -587,7 +587,7 @@ sub FlickrByTags {
 			$item = sprintf 'https://live.staticflickr.com/%s/%s_%s_z.jpg', $item->{server}, $item->{id}, $item->{secret};
 			return $item;
 		} else {
-			carp ("[NOTICE] Flickr api returns empty search result list\n");
+			$log->notice ('[NOTICE] Flickr api returns empty search result list');
 			return;
 		}
 	} else {
@@ -601,13 +601,13 @@ sub FlickrByText {
 
 	unless (-d $dir) {
 		make_path ($dir) or do {
-			carp ("[ERROR] Unable to create $dir: $OS_ERROR\n");
+			$log->error ("[ERROR] Unable to create $dir: $OS_ERROR");
 			return 0;
 		};
 	}
 
 	tie my %secret, 'SQLite_File', $backingfile  ||  do {
-		carp ("[ERROR] Unable to tie to $backingfile: $OS_ERROR\n");
+		$log->error ("[ERROR] Unable to tie to $backingfile: $OS_ERROR");
 		return 0;
 	};
 
@@ -628,7 +628,7 @@ sub FlickrByText {
 			$item = sprintf 'https://live.staticflickr.com/%s/%s_%s_z.jpg', $item->{server}, $item->{id}, $item->{secret};
 			return $item;
 		} else {
-			carp ("[NOTICE] Flickr api returns empty search result list\n");
+			$log->notice ('[NOTICE] Flickr api returns empty search result list');
 			return;
 		}
 	} else {

lib/BotLib/Karma.pm

@@ -6,9 +6,9 @@ use warnings;
 use utf8;
 use open qw (:std :utf8);
 use English qw ( -no_match_vars );
-use Carp qw (carp);
 use DB_File;
 use File::Path qw (make_path);
+use Log::Any qw ($log);
 use BotLib::Conf qw (LoadConf);
 use BotLib::Util qw (utf2sha1 trim);
 
@@ -34,14 +34,14 @@ sub KarmaSet (@) {
 
 	unless (-d $karmadir) {
 		make_path ($karmadir) or do {
-			carp ("[ERROR] Unable to create $karmadir: $OS_ERROR\n");
+			$log->error ("[ERROR] Unable to create $karmadir: $OS_ERROR");
 			return sprintf 'Карма %s составляет 0', $phrase;
 		};
 	}
 
 	# init hash, store phrase and score
 	tie my %karma, 'DB_File', $karmafile || do {
-		carp ("[ERROR] Something nasty happen when karma ties to its data: $OS_ERROR\n");
+		$log->error ("[ERROR] Something nasty happen when karma ties to its data: $OS_ERROR");
 		return sprintf 'Карма %s составляет 0', $phrase;
 	};
 
@@ -94,14 +94,14 @@ sub KarmaGet (@) {
 
 	unless (-d $karmadir) {
 		make_path ($karmadir) or do {
-			carp ("Unable to create $karmadir: $OS_ERROR\n");
+			$log->error ("Unable to create $karmadir: $OS_ERROR");
 			return sprintf 'Карма %s составляет 0', $phrase;
 		};
 	}
 
 	# init hash, store phrase and score
 	tie my %karma, 'DB_File', $karmafile || do {
-		carp ("[ERROR] Something nasty happen when karma ties to its data: $OS_ERROR\n");
+		$log->error ("[ERROR] Something nasty happen when karma ties to its data: $OS_ERROR");
 		return sprintf 'Карма %s составляет 0', $phrase;
 	};
 

lib/BotLib/Kitty.pm

@@ -6,9 +6,9 @@ use warnings;
 use utf8;
 use open qw (:std :utf8);
 use English qw ( -no_match_vars );
-use Carp qw (carp);
 use JSON::XS;
 use HTTP::Tiny;
+use Log::Any qw ($log);
 
 use version; our $VERSION = qw (1.0);
 use Exporter qw (import);
@@ -35,14 +35,14 @@ sub Kitty {
 		};
 
 		unless (defined $jcat) {
-			carp ("[ERROR] Unable to decode JSON: $EVAL_ERROR\n");
+			$log->error ("[ERROR] Unable to decode JSON: $EVAL_ERROR");
 		} else {
 			if ($jcat->[0]->{url}) {
 				$ret = $jcat->[0]->{url};
 			}
 		}
 	} else {
-		carp (sprintf "Server return status %s with message: %s\n", $r->{status}, $r->{reason});
+		$log->error (sprintf 'Server return status %s with message: %s', $r->{status}, $r->{reason});
 	}
 
 	return $ret;

lib/BotLib/Lat.pm

@@ -11,6 +11,7 @@ use Carp qw (carp);
 use File::Basename qw (dirname);
 use File::Path qw (make_path);
 use Hailo;
+use Log::Any qw ($log);
 use BotLib::Conf qw (LoadConf);
 
 use version; our $VERSION = qw (1.0);
@@ -49,12 +50,12 @@ sub Lat () {
 	my $braindir = dirname $brain;
 
 	unless (-d $braindir) {
-		carp ("[ERROR] No lat module data: $braindir is absent! Train lat first.\n");
+		$log->error ("[ERROR] No lat module data: $braindir is absent! Train lat first.");
 		return '';
 	}
 
 	unless (-f $brain) {
-		carp ("[ERROR] No lat module data: $brain is absent! Train lat first.\n");
+		$log->error ("[ERROR] No lat module data: $brain is absent! Train lat first.");
 		return '';
 	}
 

lib/BotLib/Monkeyuser.pm

@@ -6,9 +6,9 @@ use warnings;
 use utf8;
 use open qw (:std :utf8);
 use English qw ( -no_match_vars );
-use Carp qw (carp);
 use HTTP::Tiny;
 use HTML::TokeParser;
+use Log::Any qw ($log);
 use Math::Random::Secure qw (irand);
 
 use version; our $VERSION = qw (1.0);
@@ -51,7 +51,7 @@ sub Monkeyuser {
 			$ret = sprintf 'https://www.monkeyuser.com%s', $link[irand (1 + $#link)];
 		}
 	} else {
-		carp (sprintf "[WARN] Monkeyuser server return status %s with message: %s\n", $r->{status}, $r->{reason});
+		$log->warn (sprintf '[WARN] Monkeyuser server return status %s with message: %s', $r->{status}, $r->{reason});
 	}
 
 	return $ret;

lib/BotLib/Proverb.pm

@@ -0,0 +1,88 @@
+package BotLib::Proverb;
+# Any fortune_mod sources are suitable. Text file with "\n%\n" sentence delimeter.
+
+use 5.018;
+use strict;
+use warnings;
+use utf8;
+use open qw (:std :utf8);
+use English qw ( -no_match_vars );
+use Carp qw (cluck croak);
+use File::Path qw (make_path);
+use Log::Any qw ($log);
+use Math::Random::Secure qw (irand);
+use SQLite_File;
+use BotLib::Conf qw (LoadConf);
+use BotLib::Util qw (trim);
+
+use version; our $VERSION = qw (1.0);
+use Exporter qw (import);
+our @EXPORT_OK = qw (Seed Proverb);
+
+my $c = LoadConf ();
+my $dir = $c->{proverb}->{dir};
+my $srcdir = $c->{proverb}->{srcdir};
+
+sub Seed () {
+	unless (-d $dir) {
+		make_path ($dir)  ||  croak "Unable to create $dir: $OS_ERROR";
+	}
+
+	my $backingfile = sprintf '%s/proverb.sqlite', $dir;
+
+	if (-f $backingfile) {
+		unlink $backingfile   ||  croak "Unable to remove $backingfile: $OS_ERROR";
+	}
+
+	tie my @proverb, 'SQLite_File', $backingfile  ||  croak "Unable to tie to $backingfile: $OS_ERROR";
+	opendir (my $srcdirhandle, $srcdir)  ||  croak "Unable to open $srcdir: $OS_ERROR";
+
+	while (my $proverbfile = readdir ($srcdirhandle)) {
+		my $srcfile = sprintf '%s/%s', $srcdir, $proverbfile;
+
+		unless (-f $srcfile) {
+			next;
+		}
+
+		if ($proverbfile =~ m/^\.+$/) {
+			next;
+		}
+
+		open (my $fh, '<', $srcfile)  ||  croak "Unable to open $srcfile, $OS_ERROR";
+
+		while (readline $fh) {
+			chomp;
+			my $str = trim ($_);
+
+			if ($str ne '') {
+				push @proverb, $str;
+			}
+		}
+
+		close $fh;  ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
+	}
+
+	closedir $srcdirhandle;
+	untie @proverb;
+	return;
+}
+
+# just return answer
+sub Proverb () {
+	my $backingfile = sprintf '%s/proverb.sqlite', $dir;
+
+	tie my @array, 'SQLite_File', $backingfile  ||  do {
+		$log->error ("[ERROR] Unable to tie to $backingfile: $OS_ERROR");
+		return '';
+	};
+
+	my $phrase = $array[irand ($#array + 1)];
+	# decode?
+	utf8::decode $phrase;
+	untie @array;
+	return $phrase;
+}
+
+1;
+
+# vim: ft=perl noet ai ts=4 sw=4 sts=4:

lib/BotLib/Weather.pm

@@ -6,11 +6,11 @@ use warnings;
 use utf8;
 use open qw (:std :utf8);
 use English qw ( -no_match_vars );
-use Carp qw (carp cluck);
 use CHI;
 use CHI::Driver::BerkeleyDB;
 use HTTP::Tiny;
 use JSON::XS;
+use Log::Any qw ($log);
 use BotLib::Conf qw (LoadConf);
 use BotLib::Util qw (trim urlencode);
 
@@ -33,7 +33,7 @@ sub Weather {
 		my $appid = $c->{openweathermap}->{appid};
 
 		unless (defined $appid) {
-			carp ("[WARN] No appid specified for openweathermap\n");
+			$log->warn ('[WARN] No appid specified for openweathermap');
 			return undef;
 		}
 
@@ -60,11 +60,11 @@ sub Weather {
 			};
 
 			unless (defined $fc) {
-				carp ("[WARN] openweathermap returns corrupted json: $EVAL_ERROR\n");
+				$log->warn ("[WARN] openweathermap returns corrupted json: $EVAL_ERROR");
 				return undef;
 			};
 		} else {
-			carp (sprintf "Server return status %s with message: %s\n", $r->{status}, $r->{reason});
+			$log->warn (sprintf 'Server return status %s with message: %s', $r->{status}, $r->{reason});
 			return undef;
 		}
 

lib/IRCBot.pm

@@ -6,8 +6,19 @@ use warnings;
 use utf8;
 use open qw (:std :utf8);
 use English qw ( -no_match_vars );
-use Bot::IRC;
+use AnyEvent;
+use AnyEvent::IRC;
+use AnyEvent::IRC::Client;
+use AnyEvent::IRC::Util qw (prefix_nick);
+use Date::Format::ISO8601 qw (gmtime_to_iso8601_datetime);
+use Encode qw (decode);
+use Hailo;
+use Log::Any qw ($log);
+use BotLib qw (Command RandomCommonPhrase);
 use BotLib::Conf qw (LoadConf);
+use BotLib::Karma qw (KarmaSet);
+use BotLib::Util qw (trim utf2sha1);
+use Data::Dumper;
 
 use version; our $VERSION = qw (1.0);
 use Exporter qw (import);
@@ -16,42 +27,305 @@ our @EXPORT_OK = qw (RunIRCBot);
 
 sub RunIRCBot {
 	my $c = LoadConf ();
+	my $hailo;
+	my $cv = AnyEvent->condvar;
+	my $irc = AnyEvent::IRC::Client->new(send_initial_whois => 1);
 
-	my $bot = Bot::IRC->new (
+	$irc->reg_cb (
-		spawn  => 2,
+		irc_privmsg => sub {
-		daemon => {
+			my ($self, $msg) = @_;
-			name        => 'aleesa-irc-bot',
+			my $botnick = $irc->nick ();
-			lsb_sdesc   => 'Aleesa IRC Bot',
+			my $chatid = $msg->{params}->[0];
-			pid_file    => $c->{pid},
+			my $text = decode ('utf8', $msg->{params}->[-1]);
-			stderr_file => $c->{log},
+			my $nick = prefix_nick ($msg->{prefix});
-			stdout_file => $c->{debug_log},
+			my $answer;
-		},
+
-		connect => {
+			unless (defined $text) { return; }
-			server => $c->{server},
+
-			port   => $c->{port},
+			# The main idea is to find out if message contains command.
-			nick   => $c->{nick},
+			# I know that this framework contains nifty way to guess commands
-			name   => 'Aleesa IRC Bot',
+			# but it detects command when bot mentiond, but'd like to send
-			ssl    => $c->{ssl},
+			# commands via command sign (say, exclamation mark).
-			ipv6   => 0,
+			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
 						);
+					};
 
-	$bot->load ('OnMessage', 'ReJoin');  # our main plugin that handles all the incomming messages, mostly
+					unless (defined $hailo->{$chatid}) {
-	$bot->helps(
+						$log->warn ($EVAL_ERROR);
-		about => 'I am just another chatty bot.',
+						return;
-	);
+					}
+				}
 
-	# finally, run bot
+				$answer = $hailo->{$chatid}->learn_reply ($phrase);
-	if (defined $c->{'connect_cmd'} && $c->{'connect_cmd'} ne '') {
+
-		my @connect_cmd = map {chomp; $_} split (/\n/, $c->{'connect_cmd'});
+				if (defined $answer) {
-		$bot->run (@connect_cmd);
+					$answer = sprintf '%s, %s', $nick, lcfirst ($answer);
 				} else {
-		$bot->run;
+					$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) {
+					$answer = eval {
+						KarmaSet (
+							$chatid,
+							trim ( substr ($text, 0, -2) ),
+							substr ($text, -2)
+						);
+					};
+
+					unless (defined $answer) {
+						$log->warn ($EVAL_ERROR);
+						return;
+					}
+				}
+			} elsif (substr ($text, 0, 1) eq $c->{csign}) {
+				if (substr ($text, 1) eq 'help' || substr ($text, 1) eq 'помощь') {
+					my $csign = $c->{csign};
+					$answer = << "EOA";
+${csign}help | ${csign}помощь             - это сообщение
+${csign}anek | ${csign}анек | ${csign}анекдот    - рандомный анекдот с anekdot.ru
+${csign}buni                       - комикс-стрип hapi buni
+${csign}bunny                      - кролик
+${csign}rabbit | ${csign}кролик           - кролик
+${csign}cat | ${csign}кис                 - кошечка
+${csign}dice | ${csign}roll | ${csign}кости      - бросить кости
+${csign}dig | ${csign}копать              - заняться археологией
+${csign}drink | ${csign}праздник          - какой сегодня праздник?
+${csign}fish | ${csign}fisher             - порыбачить
+${csign}рыба | ${csign}рыбка | ${csign}рыбалка   - порыбачить
+${csign}f | ${csign}ф                     - рандомная фраза из сборника цитат fortune_mod
+${csign}fortune | ${csign}фортунка        - рандомная фраза из сборника цитат fortune_mod
+${csign}fox | ${csign}лис                 - лисичка
+${csign}friday | ${csign}пятница          - а не пятница ли сегодня?
+${csign}frog | ${csign}лягушка            - лягушка
+${csign}horse | ${csign}лошадь | ${csign}лошадка - лошадка
+${csign}karma фраза                - посмотреть карму фразы
+${csign}карма фраза                - посмотреть карму фразы
+фраза++ | фраза--           - повысить или понизить карму фразы
+${csign}lat | ${csign}лат                 - сгенерировать фразу из крылатого латинского выражения
+${csign}monkeyuser                 - комикс-стрип MonkeyUser
+${csign}owl | ${csign}сова                - сова
+${csign}ping | ${csign}пинг               - попинговать бота
+${csign}proverb | ${csign}пословица       - рандомная русская пословица
+${csign}snail | ${csign}улитк а           - улитка
+${csign}some_brew                  - выдать соответствующий напиток, бармен может налить rum, ром, vodka, водку, beer, пиво, tequila, текила, whisky, виски, absinthe, абсент
+${csign}ver | ${csign}version             - написать что-то про версию ПО
+${csign}версия                     - написать что-то про версию ПО
+${csign}w город | ${csign}п город         - погода в городе
+${csign}xkcd                       - комикс-стрип с xkcb.ru
+EOA
+					foreach my $string (split /\n/, $answer) {
+						if ($string ne '') {
+							$irc->send_long_message ('utf8', 0, "PRIVMSG\001ACTION", $nick, $string);
+						}
 					}
 
 					return;
 				}
 
+				$answer = Command ($self, $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}) {
+						$log->warn ($EVAL_ERROR);
+						return;
+					}
+				}
+
+				$hailo->{$chatid}->learn ($text);
+			}
+
+			if (defined $answer) {
+					foreach my $string (split /\n/, $answer) {
+						if ($string ne '') {
+							if ($irc->is_my_nick ($chatid)) {
+								# private chat
+								$irc->send_long_message ('utf8', 0, 'PRIVMSG', $nick, $string);
+							} else {
+								# chat in channel
+								$irc->send_long_message ('utf8', 0, 'PRIVMSG', $chatid, $string);
+							}
+						}
+					}
+			}
+
+			return;
+		},
+
+		connect => sub {
+			my ($pc, $err) = @_;
+			if (defined $err) {
+				$log->err ("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 {
+			$log->err ('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) = @_;
+			$log->info ('Registered on server');
+			$irc->enable_ping (60);
+			return;
+		},
+
+		disconnect => sub {
+			$log->err ("Disconnected: $_[1]");
+			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) {
+				$log->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) {
+				$log->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) {
+				$log->warn (sprintf 'I left %s channel', $channel);
+			}
+
+			return;
+		},
+
+		join => sub {
+			my ($self, $nick, $channel, $is_myself) = @_;
+
+			if ($is_myself) {
+				$log->info (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;