Use dedicated geo api instead of builtin for openweathermap api requests

* Make logging use features of Log::Any and log as it should be done via this module
+ Add loglevel parameter to sample config
+ Implement !horse !лошадка !frog !лягушка !snail !улитка commands

.gitignore

@@ -1,4 +1,17 @@
 vendor_perl/**
+data/brains/**
 data/config.json
 data/*.sqlite
-data/cache
+data/cache/**
+data/fortune/**
+data/friday/**
+data/image/**
+data/karma/**
+data/lat/**
+data/proverb/**
+TODO
+*.pid
+*.log
+_Deparsed_XSubs.pm
+.idea/**
+.vstags

.perlcriticrc

@@ -0,0 +1,149 @@
+#!/usr/bin/env perlcritic
+#
+# Задействованные модули критика:
+#
+# Perl::Critic::More
+# Perl::Critic::Pulp
+# Perl::Critic::TooMuchCode
+# Perl::Critic::Lax
+# Perl::Critic::CognitiveComplexity
+# Perl::Critic::Policy::CompileTime
+# Perl::Critic::Policy::ProhibitImplicitImport
+# Perl::Critic::Policy::Dynamic::NoIndirect
+# Perl::Critic::StricterSubs
+
+severity    = 5
+verbose     = 8
+
+# minorify some of warnings that are not really critical
+[-InputOutput::RequireCheckedClose]
+# What can we handle in case of error?
+
+[-Modules::ProhibitExcessMainComplexity]
+# Noone cares
+
+[-Subroutines::ProhibitExcessComplexity]
+# Noone cares
+
+[-Subroutines::ProhibitExplicitReturnUndef]
+# But it's very handy sometimes!
+
+[-ValuesAndExpressions::ProhibitMagicNumbers]
+# this policy makes too much false positives
+
+[-RegularExpressions::RequireLineBoundaryMatching]
+# We use /m as needed
+
+[-RegularExpressions::RequireExtendedFormatting]
+# We do not use extended formatting of regex, they still not THAT complex
+
+[-RegularExpressions::RequireDotMatchAnything]
+# huh?
+
+[-RegularExpressions::ProhibitEscapedMetacharacters]
+# Looks like it pointless
+
+[-ControlStructures::ProhibitCascadingIfElse]
+# I like long if..else chains
+
+[-ControlStructures::ProhibitPostfixControls]
+# In short lines we can afford ourselves to use postfix controls
+# but of course we should avoid such constructions in long lines.
+
+[-Subroutines::ProhibitSubroutinePrototypes]
+# Contrary to  Perl::Critic  we consider prototypes as useful, even if
+# the compile-time checks of Perl are not perfect,  Perl may give some
+# hints.
+
+[-CodeLayout::RequireTidyCode]
+# Impossible to complete, because of on higher linting levels "## no critic..."
+# require be per-case on same line where critique is, but tidy align them
+# one line down.
+
+[-CodeLayout::ProhibitParensWithBuiltins]
+# duh...
+
+[-ValuesAndExpressions::ProhibitEmptyQuotes]
+# cause we consider following correct and useful:  my $var = '';
+# the recommended use of q{} looks too complex:     my $var = q{};
+
+[-ValuesAndExpressions::ProhibitNoisyQuotes]
+# Other people, other opinions: ","  is better readable than qw(,)
+
+[-BuiltinFunctions::ProhibitSleepViaSelect]
+# We do not wish to use too much external modules.
+# select undef, undef, undef, 0.25; # actually is okay if you add comment that
+# it is sleep for 0.25 seconds
+
+[-NamingConventions::Capitalization]
+# duh...
+# Noone cares, really
+
+[-ControlStructures::ProhibitUnlessBlocks]
+# They should not be too complex - only one condition should be checked,
+# that's all
+
+[-Miscellanea::ProhibitTies]
+# Just allow it. It's very handy stuff and extremely simple and safe enough to use.
+
+[-ValuesAndExpressions::RequireNumberSeparators]
+# Not really
+
+[-InputOutput::RequireBracedFileHandleWithPrint]
+# We prefer not to use braced file handles
+
+[-Documentation::PodSpelling]
+# It doesn't help, but emits annoying errors
+
+[Documentation::RequirePodSections]
+# Considering this as "soft" requirement. For modules that is (or will be)
+# stand-alone libs well formed documentation is highly desired.
+lib_sections    = NAME | VERSION | DESCRIPTION | AUTHOR | LICENSE AND COPYRIGHT
+
+[-ErrorHandling::RequireCheckingReturnValueOfEval]
+# In this app eval is not critical to error, so there is no need to check for it
+
+[-InputOutput::RequireBriefOpen]
+# Yes, i do!
+
+[-ControlStructures::ProhibitNegativeExpressionsInUnlessAndUntilConditions]
+# used only in botlib.pm, in this particular case it makes more clean code
+
+[-ControlStructures::ProhibitDeepNests]
+# jabber bot lib have very nested structures that a bit fiddle to navigate :(
+
+[-Miscellanea::ProhibitUnrestrictedNoCritic]
+# to avoid critic cpanfile
+
+[-Editor::RequireEmacsFileVariables]
+# i don't use emacs
+
+[-TooMuchCode::ProhibitUnnecessaryUTF8Pragma]
+# oh, c'mon, man!
+
+[-ValuesAndExpressions::RequireConstantOnLeftSideOfEquality]
+# i prefer readability... but point is strong
+
+[-Lax::RequireConstantOnLeftSideOfEquality::ExceptEq]
+# same as previous
+
+[-ErrorHandling::RequireUseOfExceptions]
+# nope
+
+[-TooMuchCode::ProhibitDuplicateLiteral]
+# :( but i like magic numbers all over the code!
+
+[-Subroutines::ProhibitCallsToUnexportedSubs]
+# i have to do that!
+
+[-CodeLayout::RequireASCII]
+# kek!
+
+[-Lax::ProhibitEmptyQuotes::ExceptAsFallback]
+# i prefer '' for readability rather than $empty
+
+[-ValuesAndExpressions::RestrictLongStrings]
+# don't care about long strings until they are REALLY long
+
+[-TooMuchCode::ProhibitLargeBlock]
+# no, just no

README.md

@@ -19,7 +19,7 @@ You'll need "Development Tools" or similar group of packages, perl, perl-devel,
 perl-local-lib, perl-app-cpanm, sqlite-devel, zlib-devel, openssl-devel,
 libdb4-devel (Berkeley DB devel), make.
 
-After installng required dependencies it is possible to run:
+After installing required dependencies it is possible to run:
 
 ```bash
 bash bootstrap.sh

bin/aleesa-jabber-bot

@@ -1,113 +1,189 @@
 #!/usr/bin/perl
 
-use 5.018;
+use 5.018; ## no critic (ProhibitImplicitImport)
 use strict;
-use warnings "all";
+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 (/\//, abs_path ($0));
-	if ($#CWD > 1) { $#CWD = $#CWD - 2; }
-	$workdir = join ('/', @CWD);
-	chdir ($workdir);
+	my @CWD = split /\//, 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");
 no Cwd;
 use Cwd::utf8 qw (chdir abs_path);
-use POSIX qw(setgid setuid setsid);
+use POSIX qw (setgid setuid);
 use File::Path qw (make_path);
 use File::Basename qw (basename dirname);
-use conf qw(loadConf);
-use botlib qw(logger);
-use jabberbot qw(run_jabberbot);
+use File::Spec ();
+use Log::Any qw ($log);
+use Log::Any::Adapter ();
+use Log::Any::For::Std ();
+use BotLib::Conf qw (LoadConf);
+use JabberBot qw (RunJabberBot);
 
 sub daemonize ();
 sub __fork ();
+sub __signal_handler;
 
-$| = 1;
-my $runAsUid = $<;
+local $OUTPUT_AUTOFLUSH = 1;
+my $runAsUid = $UID;
 
-my $piddir = "/var/run/" . basename (abs_path ($0));
-my $C = loadConf ();
+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};
+}
 
 # if we run under root, create pid dir and set correct owner for it, same for debug log if it is defined
-if ($< == 0) {
+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];
+	my ($uid, $gid) = (getpwnam $user)[2,3];
 
 	unless (-d $piddir) {
 		make_path (
 			$piddir, {
 				uid   => $uid,
-				group => $gid
-			}
-		);
+				group => $gid,
+			},
+		) or die "Unable to create $piddir: $OS_ERROR\n";
 	}
 
-	if ($C->{'debug_log'}) {
-		unless (-d dirname($C->{'debug_log'})) {
+	if (defined $logfile) {
+		my $logdir = dirname $logfile;
+
+		unless (-d $logdir) {
 			make_path (
-				dirname($C->{'debug_log'}), {
+				$logdir, {
 					uid   => $uid,
-					group => $gid
-				}
-			);
+					group => $gid,
+				},
+			) or die "Unable to create $logdir: $OS_ERROR\n";
 		}
 	}
 
 # drop privs
-	setgid ($gid) or die "Unable to switch to group of $user($!)\n";
-	setuid ($uid) or die "Unable to switch to account $user($!)\n";
+	setgid ($gid) or die "Unable to switch to group of $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', File::Spec->devnull, 'log_level'=>'emergency');
+}
+
 # double fork attach to /dev/null all stdio and go background
 daemonize ();
 
 # write pidfile
-my $apath = abs_path ($0);
+my $apath = abs_path $PROGRAM_NAME;
 
-unless (defined($apath)) {
-	logger ("Unable to get abs_path: $!");
-	die "Unable to get abs_path: $!\n";
+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;
 };
 
-my $pidfile = sprintf ("%s/%s.pid", $piddir, basename ($apath));
-logger ("Creating pidfile at $pidfile");
-open (PID, ">", $pidfile) or die "Error opening $pidfile: $!\n";
-print PID $$ or die "Error writing to $pidfile: $!\n";
-close PID;
+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
-$0 = abs_path ($0);
+$PROGRAM_NAME = abs_path $PROGRAM_NAME;  ## no critic (Variables::RequireLocalizedPunctuationVars)
+
+RunJabberBot ();
+
+if (-e $pidfile) {
+	unlink $pidfile;
+}
 
-# run bot, at last
-run_jabberbot ();
-unlink ($pidfile) if (-f $pidfile);
 exit 0;
 
 sub daemonize () {
 	__fork ();
 	POSIX::setsid ();
-	open (STDIN, "<", "/dev/null");
-	open (STDOUT, ">", "/dev/null");
-	open (STDERR, ">", "/dev/null");
+	open (STDIN, '<', File::Spec->devnull);   ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
+	# we handle STDOUT && STDERR via Log::Any::For::Std, so do not close them explicitly
+	#open (STDOUT, '>', File::Spec->devnull); ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
+	#open (STDERR, '>', File::Spec->devnull); ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
 	__fork ();
 	umask 0;
+	return;
 }
 
 sub __fork () {
 	my $pid = fork;
-	die "Can't fork: $!\n" unless (defined ($pid));
-	exit if ($pid != 0);
+
+	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 (-e $pidfile) {
+		unlink $pidfile;
+	}
+
+	exit 0;
 }
 
 __END__

bin/flickr_init.pl

@@ -0,0 +1,29 @@
+#!/usr/bin/perl
+
+use 5.018; ## no critic (ProhibitImplicitImport)
+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::Image::Flickr qw (FlickrInit);
+
+if (FlickrInit ()) {
+	exit 0;
+} else {
+	exit 1;
+}

bin/fortune_seed.pl

@@ -0,0 +1,28 @@
+#!/usr/bin/perl
+
+use 5.018; ## no critic (ProhibitImplicitImport)
+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::Fortune qw (Seed);
+
+Seed ();
+
+exit 0;

bin/friday_seed.pl

@@ -0,0 +1,27 @@
+#!/usr/bin/perl
+
+use 5.018; ## no critic (ProhibitImplicitImport)
+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::Friday qw (Seed);
+
+Seed ();
+
+exit 0;

bin/proverb_seed.pl

@@ -0,0 +1,26 @@
+#!/usr/bin/perl
+
+use 5.018; ## no critic (ProhibitImplicitImport)
+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;

bin/train_lat.pl

@@ -0,0 +1,26 @@
+#!/usr/bin/perl
+
+use 5.018; ## no critic (ProhibitImplicitImport)
+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 Lat qw (Train);
+
+Train ();
+exit 0;

confcheck.pl

@@ -2,34 +2,35 @@
 
 use 5.018;
 use strict;
-use warnings "all";
+use warnings;
 use utf8;
 use open qw (:std :utf8);
-
-use lib ("./lib", "./vendor_perl", "./vendor_perl/lib/perl5");
-
+use English qw ( -no_match_vars );
+use lib qw (./lib ./vendor_perl ./vendor_perl/lib/perl5);
 use JSON::PP;
 
-my $c = "data/config.json";
-open (C, "<", $c) or die "No conf at $c: $!\n";
-my $len = (stat ($c)) [7];
+use version; our $VERSION = qw (1.0);
+
+my $c = 'data/config.json';
+open (my $C, '<', $c) || die "No conf at $c: $OS_ERROR\n";
+my $len = (stat $c) [7];
 my $json;
-my $readlen = read (C, $json, $len);
+my $readlen = read ($C, $json, $len);
 
 unless ($readlen) {
-	close C;
-	die "Unable to read $c: $!\n";
+	close C;                                         ## no critic (InputOutput::RequireCheckedSyscalls)
+	die "Unable to read $c: $OS_ERROR\n";
 }
 
 if ($readlen != $len) {
-	close C;
+	close C;                                         ## no critic (InputOutput::RequireCheckedSyscalls)
 	die "File $c is $len bytes on disk, but we read only $readlen bytes\n";
 }
 
-close C;
+close C;                                             ## no critic (InputOutput::RequireCheckedSyscalls)
 $c = decode_json ($json);
 
-my $j = JSON::PP->new->pretty->canonical->indent_length (4);
-print $j->encode ($c);
+my $j = JSON::PP->new->pretty->canonical->indent_length (4); ## no critic (ValuesAndExpressions::ProhibitLongChainsOfMethodCalls)
+print $j->encode ($c);                               ## no critic (InputOutput::RequireCheckedSyscalls)
 
 # vim: set ft=perl noet ai ts=4 sw=4 sts=4:

cpanfile

@@ -1,14 +1,38 @@
+## no critic
+requires 'CHI';
+requires 'CHI::Driver::BerkeleyDB';
 requires 'Cwd::utf8';
+requires 'DateTime';
 requires 'DB_File';
+requires 'SQLite_File';
 requires 'Digest::MD5';
+requires 'Digest::SHA';
 requires 'File::Basename';
 requires 'File::Path';
+requires 'File::Spec';
 requires 'HTTP::Tiny';
 requires 'Hailo';
 requires 'JSON';
 requires 'JSON::XS';
 requires 'JSON::PP';
-requires 'Net::Jabber::Bot';
+requires 'IO::Socket::SSL';
 requires 'POSIX';
+requires 'Text::Fuzzy';
 requires 'URI::URL';
+requires 'URI::Encode::XS';
 requires 'local::lib';
+requires 'Log::Any';
+requires 'Log::Any::Adapter';
+requires 'Log::Any::For::Std';
+requires 'Math::Random::Secure';
+requires 'HTML::TokeParser';
+
+# Bundled Net::Jabber::Bot deps
+# requires 'Net::Jabber::Bot';
+requires 'Moose';
+requires 'MooseX::Types';
+requires 'Net::Jabber';
+requires 'Time::HiRes';
+requires 'Sys::Hostname';
+requires 'Log::Log4perl';
+requires 'Mozilla::CA';

data/fortune_src/citates

@@ -0,0 +1,521 @@
+Что сказал Берлиоз своей музыкой? - ничего; но как потрясающе он это
+сказал.
+		-- Джеймс Гиббонз Хьюнекер
+%
+Музыка будет по-немецки, вы не поймете.
+		-- Оскар Уайльд
+%
+Четвертый раз смотрю этот фильм и должна вам сказать, что сегодня актеры
+играли как никогда.
+		-- Фаина Раневская
+%
+Продолжительность фильма определяется выносливостью мочевого пузыря
+обычного зрителя.
+		-- Альфред Хичкок
+%
+А что, если наша Земля - ад какой-нибудь другой планеты?
+		-- Олдос Хаксли
+%
+Если видишь женщину голой достаточно долго, опять начинаешь обращать
+внимание на ее лицо.
+		-- Генри Миллер
+%
+Самое главное - выглядеть совершенно естественно; но для этого нужно очень
+много косметики.
+		-- Кельвин Кляйн
+%
+Любовь - лучшая косметика. Но косметику купить легче.
+		-- Ив Сен-Лоран
+%
+Людей без лишнего веса больше всего на кладбище.
+		-- Биверли Силлз
+%
+Лучше быть молодым навозным жуков, чем старой райской птицей.
+		-- Марк Твен
+%
+К старости недостатки ума становятся все заметнее, как и недостатки
+внешности.
+		-- Франсуа Ларошфуко
+%
+Лучше быть старой, чем мертвой.
+		-- Бриджит Бардо
+%
+Вечеринка с коктейлями: место, где можно встретить людей, которые пьют так
+много, что вы не можете вспомнить их имена.
+		-- Космо Сардо
+%
+Средство от похмелья: выжать сок из двух бутылок виски...
+		-- Эдди Кондон
+%
+Дважды два уже четыре, а будет еще лучше.
+		-- Хенрик Ягодзинский
+%
+Я сидел на диете 14 дней и потерял всего две недели.
+		-- Тоти Филдс
+%
+В жизни можно полагаться только на себя самого. Да и то не советую!
+		-- Тристан Бернар
+%
+Источник нашей мудрости - наш опыт. Источник нашего опыта - наша глупость.
+		-- Саша Гитри
+%
+Уходя на тот свет, не забудь выключить этот.
+		-- Виктор Коваль
+%
+Я не верю ни единому слову из того, что вы говорите... или я вам.
+		-- Оскар Уайльд
+%
+Я думаю, мы должны говорить правду или хотя бы говорить то, что мы думаем.
+		-- Юрий Лужков
+%
+Нельзя иметь все. Куда вы это положите?
+		-- Стивен Райт
+%
+Сначала забываешь имена, потом забываешь лица, потом забываешь застегивать
+ширинку, потом забываешь расстегивать ширинку.
+		-- Лео Розенберг
+%
+Время - лучший учитель, но, к сожалению, оно убивает своих учеников.
+		-- Гектор Берлиоз
+%
+Прошлое - чужая страна, там все по-другому.
+		-- Лесли Хартли
+%
+Помните о бедняках - это не требует никаких расходов.
+		-- Генри Уиллер Шоу
+%
+Я люблю своих детей, но некоторые мне не нравятся.
+		-- Лилиан Картер, мать президента США Д.Картера
+%
+Дружба - это когда можно ни с того ни с сего приехать к человеку
+и поселиться у него.
+		-- Давид Самойлов
+%
+Врагов я забрасываю цветами - в гробу!
+		-- Сальвадор Дали
+%
+Я не боюсь умереть. Я просто не хочу при этом присутствовать.
+		-- Вуди Аллен
+%
+Какой замечательный некролог! С таким бы жить и жить!
+		-- М.Генин
+%
+Твои шансы выиграть в лотерею возрастут, если ты купишь билет.
+		-- Уинстон Грум из "Правил Фореста Гампа"
+%
+Пока вы ищете, кого бы стоило полюбить, вам нужен кто-то, кто любит вас.
+		-- Шейла Делейни
+%
+Если двое любят друг друга, это не может счастливо кончиться.
+		-- Э.Хемингуэй
+%
+Я порвала с ним через три года. Это была типичная любовь-ненависть. Мы оба
+любили его и ненавидели меня.
+		-- Кэрол Зискинд
+%
+В тех кругах, в которых я вращаюсь, переспать с женщиной - недостаточный
+повод для того, чтобы быть ей представленным.
+		-- Вирджиния Маклауд
+%
+Она говорила на восемнадцати языках и ни на одном из них не умела сказать
+"нет".
+		-- Дороти Паркер
+%
+Помни: в пяти случаях из шести свет в конце туннеля - это свет
+надвигающегося поезда.
+		-- Пол Диксон
+%
+Все соседи плохи, но верхние хуже нижних.
+		-- Константин Мелихан
+%
+Америка - единственный матриархат, под сенью которого женщины ведут борьбу
+за равные права.
+		-- А. Рот
+%
+Брак - это лотерея, но в случае проигрыша вы не можете порвать свой билет.
+		-- Ф. Ноулз
+%
+Британский солдат устоит против кого угодно, только не против Британского
+министерства обороны.
+		-- Бернард Шоу
+%
+Век наш таков, что он гордится машинами, умеющими думать, и побаивается
+людей, которые пытаются проявить ту же способность.
+		-- Г.Мамфорд Джонс
+%
+Военная мудрость есть понятие, заключающее противоречие в самом себе.
+Война - слишком серьезное дело, чтобы доверять его военным.
+		-- Талейран
+%
+Выход из беды найти не столь просто, как попасть в нее.
+		-- Эд Хау
+%
+Граница в политической географии - воображаемая линия между двумя
+государствами, отделяющая воображаемые права одного от воображаемых прав
+другого.
+		-- А.Бирс
+%
+Да не устрашит тебя величие: одни рождаются великими, другие достигают
+величия, третьим его навязывают.
+		-- Уильям Шекспир
+%
+Две тысячи лет нам поставляли примеры для подражания, и теперь ничто нас
+не извиняет, если мы, воюя, воем плохо.
+		-- Т.Э. Лоуренс
+%
+Дипломная работа среднего выпускника университета есть не что иное, как
+кости, перенесенные из одной могилы в другую.
+		-- Дж. Фрэнк Доуби
+%
+Для любой волнующей человека проблемы всегда легко найти решение -
+простое, достижимое и ошибочное.
+		-- Г.Л. Менкен
+%
+Добрым словом и револьвером вы можете добиться гораздо большего, чем одним
+только добрым словом.
+		-- Аль Капоне
+%
+Если вы не восходящий, значит, вы ниспадающий.
+		-- Стивен Поттер
+%
+Если честолюбивая мечта не заставляет вас страдать, значит, ее у вас нет.
+		-- К. Норрис
+%
+Идеалист тот, кто, заметив, что роза пахнет лучше капусты, заключает, что
+и суп из нее будет лучше.
+		-- Г. Менкен
+%
+Жизнь что луковица - вы чистите ее, снимая слой за слоем, и иногда
+плачете.
+		-- С. Сандберг
+%
+Когда люди вольны поступать как угодно, они обычно подражают друг другу.
+		-- Э. Хоффер
+%
+Коли все думают одинаково, значит, никто особенно и не думает.
+		-- У.Липпман
+%
+Компьютеры бесподобны: за несколько минут они могут совершить такую
+грандиозную ошибку, какую не в состоянии сделать множество людей за многие
+месяцы.
+		-- М. Мичэм
+%
+Логика - это искусство ошибаться с уверенностью в своей правоте.
+		-- Дж. У. Крач
+%
+Любовь - вещь идеальная, супружество - реальная; смешение реального с
+идеальным никогда не проходит безнаказанно.
+		-- И. Гете
+%
+Любое ваше решение - это ошибка.
+		-- Эдуард Далберг
+%
+Мой способ шутить - это говорить правду. На свете нет ничего
+смешнее.
+		-- Бернард Шоу
+%
+На моем веку было очень много прогресса, но, боюсь, не в том направлении.
+		-- О. Нэш
+%
+Нам мало добиться успеха. Надо еще, чтобы друзья наши потерпели крах.
+		-- Ларошфуко
+%
+Невеста - женщина, у которой виды на счастье остались позади.
+		-- А. Бирс
+%
+Нужно учредить Нобелевскую премию за остроумие. Без физиков, химиков,
+экономистов мы, если прижмет, как-нибудь обойдемся. Без мира обычно тоже
+обходимся. Без остроумия - пропадем.
+		-- Джордж Ф. Уилл
+%
+О несчастном случае мой подзащитный впервые узнал лишь тогда, когда этот
+случай произошел.
+		-- Из речи адвоката
+%
+Первый и наихудший из всех подвохов - обмануть самого себя. Потом уже
+легко впасть в любой грех.
+		-- Дж. Бэйли
+%
+По самой своей природе человек, чем старше он становится, тем больше
+противится переменам, особенно переменам к лучшему.
+		-- Дж. Стейнбек
+%
+Поиск истины способен изрядно позабавить.
+		-- Вернон Говард
+%
+Полицейский находится на своем месте не для того, чтобы создавать
+беспорядок; полицейский находится там, чтобы поддерживать беспорядок.
+		-- Ричард Дж. Дейли, мэр Чикаго
+%
+Посредственность - добродетель в глазах посредственных людей.
+		-- Ж. Жобер
+%
+Посредственный учитель излагает. Хороший учитель объясняет. Выдающийся
+учитель показывает. Великий учитель вдохновляет.
+		-- Уильям Артур Уорд
+%
+Президенту в его окружении не нужны мужчины и женщины, умеющие только
+поддакивать. Если он говорит "нет", мы все говорим "нет".
+		-- Элизабет Доул, помощница президента Рейгана
+%
+"Радость моя, мы живем в переходную эпоху", говорил Адам Еве по дороге из
+рая.
+		-- У. Инге
+%
+"С нами такого случиться не может" - это фраза номер один в списке
+знаменитых последних слов.
+		-- Дэвид Кросби
+%
+Самая большая ложь - это неверно понятая правда.
+		-- Уильям Джеймс
+%
+Скрипка - инструмент для щекотания человеческих ушей при помощи трения
+лошадиного хвоста о внутренности кошки.
+		-- Амброз Бирс
+%
+Среди преподавателей большинство составляют те, кто не прервет чтение
+своих лекций по навигации, даже если корабль уже тонет. Следствие:
+путешествие длиною в тысячу миль завершается одним-единственным шагом.
+		-- Джеймс Г. Борен
+%
+Творческое мышление, возможно, означает всего-навсего понимание, что нет
+никакой особой добродетели в том, чтобы вести дела так, как их всегда вели до
+нас.
+		-- Рудольф Флеш
+%
+Технический прогресс лишь снабдил нас действенными средствами для движения
+назад.
+		-- О. Хаксли
+%
+То, что мы называем прогрессом, представляет собой замену одной
+неприятности другою.
+		-- Г. Эллис
+%
+Учитель прикасается к вечности: никто не может сказать, где кончается его
+влияние.
+		-- Генри Адамс
+%
+Человеку надлежит жить с самим собой и постоянно заботиться, чтобы это
+была хорошая кампания.
+		-- С.И. Хьюз
+%
+Эксперт - это человек, знающий все больше и больше о все меньшем и
+меньшем. Следствие: колледж не может обеспечить компетентность; он может
+обеспечить диплом.
+		-- Николас Батлер
+%
+Эксперт - это человек, который больше уже не думает; он знает.
+		-- К. Хаббард
+%
+Я не верю в коллективную мудрость невежественных индивидуумов.
+		-- Т. Карлейль
+%
+Я не против полиции, я просто боюсь ее.
+		-- Альфред Хичкок
+%
+Я никогда не мог взять в толк, почему из-за того только, что я выражаюсь
+невразумительно, никто меня не понимает.
+		-- Милтон Мейер
+%
+Пожилые люди думают, что с тех пор, как они постарели, мир только теряет,
+но ничего не приобретает.
+		-- Жеремена Сталь
+%
+Меня интересует мнение не тех людей, которые разбираются в данном вопросе,
+а тех, которые сами кое-что сделали в одной из областей знания.
+		-- Hорберт Винер
+%
+Случайные открытия совершают только подготовленные умы.
+		-- Паскаль
+%
+Бывают услуги настолько большие, что рассчитаться за них можно только
+неблагодарностью.
+		-- Дюма-отец
+%
+"Тоже неплохо!" - сказал зять, бросив камнем в собаку, а попав в тещу.
+		-- Плутарх. "Пир семи мудрецов".
+%
+Не ковыряй в носу перочинным ножиком. Лезвие легко ржавеет.
+		-- Из книги "Пи"
+%
+Очень много - иногда вполне достаточно для женщины.
+		-- Из книги "Ву"
+%
+В жизни можно рассчитывать только на самих себя. И то не всегда.
+		-- Тристан Бернар
+%
+Все было бы очень хорошо, если бы все наши поступки можно было бы совершать
+дважды.
+		-- Гете
+%
+E = mC
+		-- Альберт Эйнштейн
+%
+Человек бывает таким, каким его создал бог, но преимущественно немного хуже.
+		-- Сервантес
+%
+Две параллельных линии полюбили друг друга. Трагедия!
+		-- Из книги "Пи"
+%
+Я знаток всех "и т. д., и т. п." и я знаю, когда за ними ничего больше
+не скрывается.
+		-- Гомес де ля Серна
+%
+Одна туча может погрузить в темноту весь парк, одно слово может затемнить
+самое большое счастье.
+		-- Гомес де ля Серна
+%
+Тот факт, что будильник не прозвенел, изменило уже много человеческих судеб.
+		-- Агата Кристи
+%
+Заполнять жизнь - это еще не значит обогащать ее.
+		-- Из книги "Пи"
+%
+Самым серьезным достоинством современного искусства является то, что, когда
+эти произведения смотрят дети, они не задают таких вопросов, на которые
+обычно бывает трудно отвечать.
+		-- Лорд Галлюкс
+%
+Замужних женщин значительно больше, чем женатых мужчин.
+		-- По данным американской статистики
+%
+Совесть - это тот голос, который говорит тебе, что не надо делать именно то,
+что ты только что сделал.
+		-- Из книги "Пи"
+%
+И мелкие неприятности могут отравить жизнь, если нет крупных.
+		-- Р. Гомес де ля Серна
+%
+Счастлив тот, кто ни о чем не думает.
+		-- Софокл
+%
+Я не читаю газет. Все, о чем там стоит знать, всегда кто-нибудь расскажет.
+		-- Лорд Галлюкс
+%
+Недостаточно встать рано, надо еще и проснуться.
+		-- Из книги "Ву"
+%
+Высохшую реку не благодарят за ее прошлое.
+		-- Рабиндранат Тагор
+%
+Давать советы всегда плохо, но хорошего совета тебе никто не простит.
+		-- Оскар Уайльд
+%
+Устарели не только ответы, но даже сами вопросы.
+		-- Хемингуэй
+%
+Друзья, как арбузы: случается, что из десяти ни одного хорошего не выбрать.
+		-- Из книги "Пи"
+%
+Пока слушатели во время лекции поглядывают на часы, все в порядке. Страшно,
+когда они начинают удивленно подносить часы к уху.
+		-- Из книги "Пи"
+%
+Нет правила, которого нельзя было бы нарушить ради более прекрасного.
+		-- Л. Бетховен
+%
+Прекрасна молодость, когда она в движении и знает, куда приложить свои силы.
+		-- Менандр
+%
+Простим горячке юных лет
+И юный жар, и юный бред.
+		-- А. С. Пушкин
+%
+Грустно думать, что напрасно
+Была нам молодость дана.
+		-- А. С. Пушкин
+%
+Всего больнее знать, что счастье было так близко - и ты сам его отверг.
+		-- Софокл
+%
+Настоящий художник настолько владеет искусством, насколько оно владеет им.
+		-- Г. Флобер
+%
+Великие люди сами сооружают себе пьедестал; статую воздвигнет будущее.
+		-- В. Гюго
+%
+...заслуги отца на сына не распространяются.
+		-- М. Сервантес
+%
+Давайте жить так, чтобы даже гробовщику стало жалко, когда мы умрем.
+		-- Марк Твен
+%
+ - Обладаешь ли ты разумом?
+ - Обладаю.
+ - Почему же ты не пользуешься им?
+ 		-- Марк Авелий
+%
+Нет такой глупости, которой нельзя было бы исправить при помощи ума,
+и нет такой мудрости, которой нельзя было бы испортить при помощи глупости.
+		-- В. Гёте
+%
+Оптимист верит, что мы живем в лучшем из миров.
+Пессимист боится, что так оно и есть.
+%
+Пессимист видит темный туннель.
+Оптимист видит свет в конце туннеля.
+Реалист видит, что это на них мчится поезд.
+И только машинист видит трех мудаков, тупящих на рельсах.
+%
+Мы познаем человека не по тому, что он знает, а по тому, чему он радуется.
+		-- Р.Тагор
+%
+Если вы уверены в победе вашей национальной сборной на Евро 2004, то вы либо
+дурак, либо немец.
+		-- М.Задорнов
+%
+Нет некрасивых женщин - есть только женщины, не знающие, что они красивы.
+		-- Вивьен Ли
+%
+Любая сложная технология неотличима от волшебства.
+		-- Артур Кларк
+%
+Я люблю тебя не за то, кто ты, а за то, кто я, когда я с тобой.
+		-- Габриэль Гарсиа
+%
+Ни один человек не заслуживает твоих слез, а те, кто заслуживают,
+не заставят тебя плакать.
+		-- Габриэль Гарсиа
+%
+Только потому что кто-то не любит тебя так, как тебе хочется, не значит,
+что он не любит тебя всей душой.
+		-- Габриэль Гарсиа
+%
+Настоящий друг – это тот, кто будет держать тебя за руку
+и чувствовать твоё сердце.
+		-- Габриэль Гарсиа
+%
+Худший способ скучать по человеку – это быть с ним и понимать,
+что он никогда не будет твоим.
+		-- Габриэль Гарсиа
+%
+Никогда не переставай улыбаться, даже когда тебе грустно: кто-то может влюбиться
+в твою улыбку.
+		-- Габриэль Гарсиа
+%
+Возможно, в этом мире ты всего лишь человек, но для кого-то ты – весь мир.
+		-- Габриэль Гарсиа
+%
+Не трать время на человека, который не стремится провести его с тобой.
+		-- Габриэль Гарсиа
+%
+Возможно, Бог хочет, чтобы мы встречали не тех людей до того, как встретим того
+единственного человека. Чтобы, когда это случится, мы были благодарны.
+		-- Габриэль Гарсиа
+%
+Не плачь, потому что это закончилось. Улыбнись, потому что это было.
+		-- Габриэль Гарсиа
+%
+Всегда найдутся люди, которые причинят тебе боль. Нужно продолжать верить людям,
+просто быть чуть осторожнее.
+		-- Габриэль Гарсиа
+%
+Стань лучше и сам пойми, кто ты, прежде чем встретишь нового человека и будешь
+надеяться, что он тебя поймет.
+		-- Габриэль Гарсиа
+%
+Не прилагай столько усилий, все самое лучшее случается неожиданно.
+		-- Габриэль Гарсиа
+%
+Всё, что случаеется, имеет причину.
+		-- Габриэль Гарсиа

data/friday.txt

@@ -0,0 +1,106 @@
+А пятница-то не настоящая!!! || 34
+Спасибо, кэп! || 5
+А за пивом сегодня идет user || 5
+user, ты пиво купил? || 5
+Пятница хоть и небольшой праздник, НО ЗАТО ПОСТОЯННЫЙ! || 45
+Мечта о пятнице — самая распространенная среди работающего населения. Она начинается уже в понедельник и продолжается четыре дня в неделю || 123
+Господи дай мне сил не напиться! А если напьюсь, то сделай так чтобы я не плясала, если сил твоих не хватит и я все-таки запляшу, постарайся хотя бы сделать так, что бы не пела! А если и это не удастся, сломай к чертям сервер Ю-тюба! || 5
+К пятнице готова! Мобильный заряжен, баланс пополнен, в кармане записка с моим адресом || 5
+ПРЕДУПРЕЖДЕНИЕ: Чрезмерное употребление… Алкоголя. делает ВАШУ пятницу… ОФИГИТЕЛЬНОЙ || 5
+Сломай систему! Порви шаблоны! Начни новую жизнь с пятницы! || 5
+В пятницу совесть доживает только до обеда… || 5
+Сколько работнику не плати, всё равно пятницы ждёт || 1234
+Робинзооон!!! || 5
+В пятницу чаще всего хочется выпить. В понедельник чаще всего хочется пятницу. || 15
+Здравствуй Пятница, здравствуй, любимая, наконец-то ты пришла! || 5
+Зарплата в пятницу — удар по печени. || 5
+Вот и пятница пришла, счастье, радость принесла! || 5
+Все мы — пятницофилы и понедельникофобы. || 15
+Люблю понедельник — всего три дня до пятницы. || 1
+Ну здравствуй, пятница. Я дополз к тебе. || 5
+Пятница. Улыбните Улыбальник. || 5
+Чувствуете? Выходными пахнет! || 5
+До пятницы осталось…. пережить четверг! || 4
+Если пятый день подряд опаздываешь на работу, значит сегодня пятница. || 5
+От понедельника до пятницы очень далеко, а от пятницы до понедельника рукой подать. || 123467
+Жизнь начинается в пятницу вечером… В остальное время — выживание. || 5
+Пятница… белочки следят за тобой. || 5
+Примета: Если утром жена с вами не разговаривает, значит, вчера была пятница. || 6
+Чем ближе пятница, тем добрее утро! || 1234
+Пятница — лучший день недели, особенно её вечер, так как выходные еще не начались, а работа уже закончилась. || 5
+Отличной была пятница! Особенно запомнились русские народные катания на полицейских бобиках! || 1
+Четверг это маленькая пятница, а пятницу можно считать выходным. || 4
+Пятница традиционно начиналась легким ужином в четверг и заканчивалась плотным завтраком в понедельник. || 4
+Уже с пятницы начинаешь бояться, что скоро понедельник! || 67
+Каждую пятницу жизнь начинается сначала. || 5
+С пятницами надо быть осторожней. Они обещают слишком уж многое. Они словно рецензия на кинофильм: лишь в редких случаях предсказанное ими сбывается. || 5
+Русские в понедельник не работают — у них тяжелый день. || 1
+Все мы просто дети, изображающие на работе профессионалов, а на самом деле ждущие пятницы, чтобы быть сами собой! || 5
+Почему-то в пятницу хочется ничего не делать. Хотя в другие дни тоже хочется, но в пятницу ничего не делать хочется особенно сильно. || 5
+Хочешь жить завтрашним днем — устрой себе семь пятниц на неделе. || 5
+Что мне снег, что мне зной, что мне вермут разливной, когда мои друзья со мной! || 5
+Каждую пятницу количество довольных жизнью людей увеличивается на пару миллиардов. Этот эффект длится вплоть до понедельника. || 123467
+Так, Понедельник, Вторник, Среда, Четверг, проходим, проходим, не задерживаем Пятницу! || 1234
+Четверг. Смотрю на часы — 16.00. Еле сдерживаюсь, чтобы не закричать — Ура! Во Владивостоке Пятница! || 4
+Пятница — друг человека! || 5
+В пятницу вечером понимаешь, что в принципе — жить можно. || 5
+Ничто так не портит пятницу, как новость о том, что сегодня четверг. || 4
+Жить нужно так, как будто каждый день пятница. || 123467
+Только настроился на работу ― и вдруг снова пятница, снова отдых… Вот так всегда! || 5
+Хорошо, что пятница! Плохо, что еще только утро… || 5
+Уходя вечером с работы, он был рад, что сегодня пятница и можно спрятаться в уикенде. Он накроется субботой и воскресеньем как двумя толстыми одеялами. Ему ничего не хотелось делать; у него даже не хватало мужества читать. || 5
+Понедельник ― отходим от выходных, вторник ― готовимся к работе, среда ― работаем, четверг ― отдыхаем от работы, пятница ― готовимся к выходным. Вывод: может, хватит уже работать по средам! || 3
+Неделя тянется со скоростью улитки. Но в пятницу вечером улитка превращается в Феррари. || 5
+Прогноз погоды на пятницу: облачно, вечером осадки в виде алкоголя, возможен секс. || 5
+А пятница всё ближе. Печень в ужасе, попа в предвкушении! || 5
+Люди, с кем я вчера пила? Объясните, откуда у меня кот и почему люди в магазине мне хлопают… Кстати… никому кот не нужен? || 6
+ПЯТНИЦА — это старинный народный праздник, который начинают праздновать в ПЯТНИЦУ, а заканчивают — в ПОНЕДЕЛЬНИК || 567
+Вчера была пятница, завтра суббота, а сегодня тогда что? || 1
+Сегодня… ПЯТНИЧКА !!! Из хороших новостей пока… ВСЁ… Всем ДОБРА!!! || 5
+Надену-ка я сегодня красное платье… Под цвет глаз… || 5
+Вчера был yesterday || 235
+Вчера была yesterday || 467
+Вчера было yesterday || 1
+Никогда еще ожидание пятницы не было столь актуальным… || 4
+Завтра будет tomorrow || 1234567
+Четверг - это "завтра пятница". И помнить об этом надо в среду || 34
+Понедельник - это не начало новой недели, это задница предыдущей( || 1
+Я, признаться, очень завидую Робинзону Крузо. Живет на острове, никто мозги не е@ет и ПЯТНИЦА, ПЯТНИЦА, ПЯТНИЦА!!! Каждый день ПЯТНИЦА!!! || 1234
+Наступила пятница — значит мечты начинают сбываться || 5
+Вечером в пятницу девчонки должны быть алкоголенькими… || 5
+Позвони мне в субботу рано утром, часов в пятнадцать || 5
+Ну, вот и пятница пришла… Граждане и гражданки! Следите за своей белкой, чтобы она не разгорячилась! || 5
+Ага, вчера был понедельник, а сегодня сразу ПЯТНИЦА! ЩАС! || 2
+Вот пятница пролетела, наступил понедельник, но не все, не все вернулись на свои рабочие места || 1
+Работа не волк… В лес не убежит?.. А вдруг убежит… Так, за раздумьями и мечтами, и проходит рабочий день… || 12345
+Какой бы долгой и увлекательной ни была вечеринка, сделайте все, чтобы завтра проснуться в собственной спальне || 5
+Тяжелое воскресное засыпание объясняется вполне объективной причиной — организм на подсознательном уровне пытается продлить выходной… || 7
+Воскресенье — день недели с привкусом разочарования. Вроде и выходной, но все равно что-то не то || 7
+У воскресного дня есть только один существенный недостаток — он почему-то кончается в два раза быстрее, чем любой понедельник или четверг. || 7
+Первое правило хороших выходных - не вставать рано с постели || 67
+Понедельник — это такой день, когда вместо бейджика хочется повесить табличку: "Осторожно, злая собака" || 1
+Нас тупило утро понедельника || 1
+Бедный понедельник. Его ж никто не любит! || 1
+Вот выйду на пенсию — буду каждый понедельник выходить на улицу в семь утра и смотреть, как люди идут на работу и страдают || 1
+Если бы понедельник имел лицо… я бы его… ударила... || 1
+Завтра во всех домах страны: психологическая драма "утро понедельника" || 7
+Надеюсь, когда-нибудь я проснусь утром, включу новости и услышу: "Понедельник отменен, продолжайте спать…" || 1
+Хороший день словом Моndау не назовут! || 1
+Люди, почему вы злитесь только на понедельник? Как будто в другие дни работать хочется || 1
+Лучше утро пятницы, чем вечер понедельника || 15
+Если вы проживете 70 лет, то проживете 10 лет понедельников… || 1
+Берите пример с понедельника: его никто не ждёт, а ему по)(уй, он все равно приходит… || 1
+Завтра будет лучше, чем вчера! А, нет, завтра ПОНЕДЕЛЬНИК || 7
+Три ужасные новости: 1. Сегодня не пятница. 2. И даже завтра не пятница. 3. И даже послезавтра не пятница || 12
+В понедельник утром, очень сильно завидуешь… безработным || 1
+Понедельник — удобный повод чего-нибудь понеделать... || 1
+Дамы и господа! Предлагаю почтить утро понедельника минутой ворчания || 1
+Вот и начались трудо выебудни || 5
+Каждый понедельник меня мучает вопрос: выходные, вы вообще были? || 1
+На улице вторник, а на душе — вечер пятницы… || 2
+Наступил долгожданный вторник — послезавтра предпоследний день рабочей недели… || 2
+Если второй день не охота идти на работу, значит сегодня вторник || 2
+Предлагаю переименовать четверг в "завтра пятница"! || 4
+Говорят, при Сталине все субботы были рабочие, должно быть он и вправду был садист и тиран! || 6
+Остановись, воскресенье! Ты прекрасно!!! || 7
+Воскресенье — день трагичный. Суббота маячит далеко позади, а до понедельника уже рукой подать || 7

data/sample_config.json

@@ -1,4 +1,6 @@
 {
+# all cached will go there, they named after module name
+    "cachedir" : "data/cache",
     "user" : "nobody",
     "jabberbot": {
 # maybe onece it will be multi-instance of bot
@@ -15,10 +17,36 @@
             "csign": "!"
         },
     },
+    "image": {
+        "dir" : "data/image",
+        "flickr" : {
+            "consumer_key" : "md5-like_hash",
+            "consumer_secret" : "some_hash-like_string",
+            "verifier": "some_hash-like_string"
+        }
+    },
     "openweathermap" : {
-        "cachetime": "data/cache/openweathermap.Id-Timestamp.db",
-        "cachedata": "data/cache/openweathermap.Id-Data.db",
         "appid": "get_it_on_openweathermap.org"
     },
-    "debug_log" : "/var/log/aleesa-telegram-bot/debug.log"
+    "log" : "/var/log/aleesa-jabber-bot/aleesa-jabber-bot.log",
+    "loglevel": "info",
+    "lat" : {
+        "brain" : "data/lat/brain.sqlite",
+        "src" : "lat.txt"
+    },
+    "karma" : {
+        "dir" : "data/karma"
+    },
+    "friday" : {
+        "dir" : "data/friday",
+        "src" : "data/friday.txt"
+    },
+    "proverb" : {
+        "dir" : "data/proverb",
+        "srcdir" : "data/proverb_src"
+    },
+    "fortune" : {
+        "dir" : "data/fortune",
+        "srcdir" : "data/fortune_src"
+    }
 }

lib/Authen/SASL.pm

@@ -0,0 +1,136 @@
+## no critic (Variables::ProhibitPunctuationVars)
+# Copyright (c) 2004-2006 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Authen::SASL;
+
+use 5.018; ## no critic (ProhibitImplicitImport)
+use strict;
+use warnings;
+use utf8;
+
+use vars qw($VERSION @Plugins); ## no critic (Variables::ProhibitPackageVars)
+use Carp qw (croak);
+
+$VERSION = '2.16';
+
+@Plugins = qw(
+	Authen::SASL::XS
+	Authen::SASL::Cyrus
+	Authen::SASL::Perl
+);
+
+
+sub import {
+  shift;
+  return unless @_;
+
+  local $SIG{__DIE__}; ## no critic (Variables::RequireInitializationForLocalVars)
+  @Plugins = grep { /^[:\w]+$/ and eval "require $_" } map { /::/ ? $_ : "Authen::SASL::$_" } @_ ## no critic (BuiltinFunctions::ProhibitStringyEval)
+    or croak 'no valid Authen::SASL plugins found';
+  return;
+}
+
+
+sub new {
+  my $pkg = shift;
+  my %opt = ((@_ % 2 ? 'mechanism' : ()), @_);
+
+  my $self = bless {
+    mechanism => $opt{mechanism} || $opt{mech},
+    callback  => {},
+    debug => $opt{debug},
+  }, $pkg;
+
+  $self->callback(%{$opt{callback}}) if ref($opt{callback}) eq 'HASH';
+
+  # Compat
+  $self->callback(user => ($self->{user} = $opt{user})) if exists $opt{user};
+  $self->callback(pass => $opt{password}) if exists $opt{password};
+  $self->callback(pass => $opt{response}) if exists $opt{response};
+
+  return $self;
+}
+
+
+sub mechanism {
+  my $self = shift;
+  return @_ ? $self->{mechanism} = shift
+     : $self->{mechanism};
+}
+
+sub callback {
+  my $self = shift;
+
+  return $self->{callback}{$_[0]} if @_ == 1;
+
+  my %new = @_;
+  @{$self->{callback}}{keys %new} = values %new;
+
+  return $self->{callback};
+}
+
+# The list of packages should not really be hardcoded here
+# We need some way to discover what plugins are installed
+
+sub client_new { # $self, $service, $host, $secflags
+  my $self = shift;
+
+  my $err;
+  foreach my $pkg (@Plugins) {
+    if (eval "require $pkg" and $pkg->can('client_new')) { ## no critic (BuiltinFunctions::ProhibitStringyEval)
+      if ($self->{conn} = eval { $pkg->client_new($self, @_) }) {
+        return $self->{conn};
+      }
+      $err = $@;
+    }
+  }
+
+  croak $err || 'Cannot find a SASL Connection library';
+}
+
+sub server_new { # $self, $service, $host, $secflags
+  my $self = shift;
+
+  my $err;
+  foreach my $pkg (@Plugins) {
+    if (eval "require $pkg" and $pkg->can('server_new')) { ## no critic (BuiltinFunctions::ProhibitStringyEval)
+      if ($self->{conn} = eval { $pkg->server_new($self, @_) } ) {
+        return $self->{conn};
+      }
+      $err = $@; ## no critic (Variables::ProhibitPunctuationVars)
+    }
+  }
+  croak $err || 'Cannot find a SASL Connection library for server-side authentication';
+}
+
+sub error {
+  my $self = shift;
+  return $self->{conn} && $self->{conn}->error;
+}
+
+# Compat.
+sub user {
+  my $self = shift;
+  my $user = $self->{callback}{user};
+  $self->{callback}{user} = shift if @_;
+  return $user;
+}
+
+sub challenge {
+  my $self = shift;
+  return $self->{conn}->client_step(@_);
+}
+
+sub initial {
+  my $self = shift;
+  return $self->client_new($self)->client_start;
+}
+
+sub name {
+  my $self = shift;
+  return $self->{conn} ? $self->{conn}->mechanism : ($self->{mechanism} =~ /(\S+)/)[0];
+}
+
+1;

lib/Authen/SASL.pod

@@ -0,0 +1,241 @@
+
+=head1 NAME
+
+Authen::SASL - SASL Authentication framework
+
+=head1 SYNOPSIS
+
+ use Authen::SASL;
+
+ $sasl = Authen::SASL->new(
+   mechanism => 'CRAM-MD5 PLAIN ANONYMOUS',
+   callback => {
+     pass => \&fetch_password,
+     user => $user,
+   }
+ );
+
+=head1 DESCRIPTION
+
+SASL is a generic mechanism for authentication used by several
+network protocols. B<Authen::SASL> provides an implementation
+framework that all protocols should be able to share.
+
+The framework allows different implementations of the connection
+class to be plugged in. At the time of writing there were two such
+plugins.
+
+=over 4
+
+=item Authen::SASL::Perl
+
+This module implements several mechanisms and is implemented
+entirely in Perl.
+
+=item Authen::SASL::XS
+
+This module uses the Cyrus SASL C-library (both version 1 and 2 
+are supported).
+
+=item Authen::SASL::Cyrus
+
+This module is the predecessor to L<Authen::SASL::XS>. It is reccomended
+to use L<Authen::SASL::XS>
+
+=back
+
+By default the order in which these plugins are selected is 
+Authen::SASL::XS, Authen::SASL::Cyrus and then Authen::SASL::Perl.
+
+If you want to change it or want to specifically use one
+implementation only simply do
+
+ use Authen::SASL qw(Perl);
+
+or if you have another plugin module that supports the Authen::SASL API
+
+ use Authen::SASL qw(My::SASL::Plugin);
+
+=head2 CONTRUCTOR
+
+=over 4
+
+=item new ( OPTIONS )
+
+The constructor may be called with or without arguments. Passing arguments is
+just a short cut to calling the C<mechanism> and C<callback> methods.
+
+=over 4
+
+=item callback =E<gt> { NAME => VALUE, NAME => VALUE, ... }
+
+Set the callbacks.
+See the L<callback|/callback> method for details.
+
+=item mechanism =E<gt> NAMES
+
+=item mech =E<gt> NAMES
+
+Set the list of mechanisms to choose from.
+See the L<mechanism|/mechanism> method for details.
+
+=item debug =E<gt> VALUE
+
+Set the debug level bit-value to C<VALUE> 
+
+Debug output will be sent to C<STDERR>. The
+bits of this value are:
+
+ 1   Show debug messages in the Perl modules for the mechanisms.
+     (Currently only used in GSSAPI)
+ 4   With security layers in place show information on packages read.
+ 8   With security layers in place show information on packages written.
+
+The default value is 0.
+
+=back
+
+=back
+
+=head2 METHODS
+
+=over 4
+
+=item mechanism ( )
+
+Returns the current list of mechanisms
+
+=item mechanism ( NAMES )
+
+Set the list of mechanisms to choose from. C<NAMES> should be a space separated string
+of the names.
+
+=item callback ( NAME )
+
+Returns the current callback associated with C<NAME>.
+
+=item callback ( NAME => VALUE, NAME => VALUE, ... )
+
+Sets the given callbacks to the given values
+
+=item client_new ( SERVICE, HOST, SECURITY )
+
+Creates and returns a new connection object for a client-side connection.
+
+=item server_new ( SERVICE, HOST, OPTIONS )
+
+Creates and returns a new connection object for a server-side connection.
+
+=item error ( )
+
+Returns any error from the last connection
+
+=back
+
+=head1 The Connection Class
+
+=over 4
+
+=item server_start ( CHALLENGE )
+
+server_start begins the authentication using the chosen mechanism.
+If the mechanism is not supported by the installed SASL it fails.
+Because for some mechanisms the client has to start the negotiation,
+you can give the client challenge as a parameter.
+
+=item server_step ( CHALLENGE )
+
+server_step performs the next step in the negotiation process. The
+first parameter you give is the clients challenge/response.
+
+=item client_start ( )
+
+The initial step to be performed. Returns the initial value to pass to the server
+or an empty list on error.
+
+=item client_step ( CHALLENGE )
+
+This method is called when a response from the server requires it. CHALLENGE
+is the value from the server. Returns the next value to pass to the server or an
+empty list on error.
+
+=item need_step ( )
+
+Returns true if the selected mechanism requires another step before completion
+(error or success).
+
+=item answer ( NAME )
+
+The method will return the value returned from the last call to the callback NAME
+
+=item property ( NAME )
+
+Returns the property value associated with C<NAME>.
+
+=item property ( NAME => VALUE, NAME => VALUE, ... )
+
+Sets the named properties to their associated values.
+
+=item service ( )
+
+Returns the service argument that was passed to *_new-methods.
+
+=item host ( )
+
+Returns the host argument that was passed to *_new-methods.
+
+=item mechanism ( )
+
+Returns the name of the chosen mechanism.
+
+=item is_success ( )
+
+Once need_step() returns false, then you can check if the authentication
+succeeded by calling this method which returns a boolean value.
+
+=back
+
+=head2 Callbacks
+
+There are three different ways in which a callback may be passed
+
+=over
+
+=item CODEREF
+
+If the value passed is a code reference then, when needed, it will be called
+and the connection object will be passed as the first argument. In addition
+some callbacks may be passed additional arguments.
+
+=item ARRAYREF
+
+If the value passed is an array reference, the first element in the array
+must be a code reference. When the callback is called the code reference
+will be called with the connection object passed as the first argument
+and all other values from the array passed after.
+
+=item SCALAR
+
+All other values passed will be used directly. ie it is the same as
+passing an code reference that, when called, returns the value.
+
+=back
+
+=head1 SEE ALSO
+
+L<Authen::SASL::Perl>, L<Authen::SASL::XS>, L<Authen::SASL::Cyrus>
+
+=head1 AUTHOR
+
+Graham Barr <gbarr@pobox.com>
+
+Please report any bugs, or post any suggestions, to the perl-ldap mailing list
+<perl-ldap@perl.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1998-2005 Graham Barr. All rights reserved. This program is
+free software; you can redistribute it and/or modify it under the same
+terms as Perl itself.
+
+=cut

lib/Authen/SASL/CRAM_MD5.pm

@@ -0,0 +1,24 @@
+# Copyright (c) 2002 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Authen::SASL::CRAM_MD5;
+
+use 5.018; ## no critic (ProhibitImplicitImport)
+use warnings;
+use strict;
+use utf8;
+
+use vars qw($VERSION);
+
+$VERSION = '2.14';
+
+use Authen::SASL ();
+
+sub new {
+  shift;
+  return Authen::SASL->new(@_, mechanism => 'CRAM-MD5');
+}
+
+1;
+

lib/Authen/SASL/EXTERNAL.pm

@@ -0,0 +1,23 @@
+# Copyright (c) 2002 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Authen::SASL::EXTERNAL;
+
+use 5.018; ## no critic (ProhibitImplicitImport)
+use strict;
+use warnings;
+use utf8;
+
+use vars qw($VERSION);
+
+$VERSION = '2.14';
+
+use Authen::SASL ();
+sub new {
+  shift;
+  return Authen::SASL->new(@_, mechanism => 'EXTERNAL');
+}
+
+1;
+

lib/Authen/SASL/Perl.pm

@@ -0,0 +1,344 @@
+# Copyright (c) 2002 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Authen::SASL::Perl;
+
+use strict;
+use vars qw($VERSION);
+use Carp;
+
+$VERSION = "2.14";
+
+my %secflags = (
+	noplaintext  => 1,
+	noanonymous  => 1,
+	nodictionary => 1,
+);
+my %have;
+
+sub server_new {
+  my ($pkg, $parent, $service, $host, $options) = @_;
+
+  my $self = {
+    callback  => { %{$parent->callback} },
+    service   => $service  || '',
+    host      => $host     || '',
+    debug     => $parent->{debug} || 0,
+    need_step => 1,
+  };
+
+  my $mechanism = $parent->mechanism
+    or croak "No server mechanism specified";
+  $mechanism =~ s/^\s*\b(.*)\b\s*$/$1/g;
+  $mechanism =~ s/-/_/g;
+  $mechanism =  uc $mechanism;
+  my $mpkg   = __PACKAGE__ . "::$mechanism";
+  eval "require $mpkg;"
+    or croak "Cannot use $mpkg for " . $parent->mechanism;
+  my $server = $mpkg->_init($self);
+  $server->_init_server($options);
+  return $server;
+}
+
+sub client_new {
+  my ($pkg, $parent, $service, $host, $secflags) = @_;
+
+  my @sec = grep { $secflags{$_} } split /\W+/, lc($secflags || '');
+
+  my $self = {
+    callback  => { %{$parent->callback} },
+    service   => $service  || '',
+    host      => $host     || '',
+    debug     => $parent->{debug} || 0,
+    need_step => 1,
+  };
+
+  my @mpkg = sort {
+    $b->_order <=> $a->_order
+  } grep {
+    my $have = $have{$_} ||= (eval "require $_;" and $_->can('_secflags')) ? 1 : -1;
+    $have > 0 and $_->_secflags(@sec) == @sec
+  } map {
+    (my $mpkg = __PACKAGE__ . "::$_") =~ s/-/_/g;
+    $mpkg;
+  } split /[^-\w]+/, $parent->mechanism
+    or croak "No SASL mechanism found\n";
+
+  $mpkg[0]->_init($self);
+}
+
+sub _init_server {}
+
+sub _order   { 0 }
+sub code     { defined(shift->{error}) || 0 }
+sub error    { shift->{error}    }
+sub service  { shift->{service}  }
+sub host     { shift->{host}     }
+
+sub need_step {
+    my $self = shift;
+    return 0 if $self->{error};
+    return $self->{need_step};
+}
+
+## I think I need to rename that to end()?
+## It doesn't mean that SASL is successful, but that
+## that the negotiation is over, no more step necessary
+## at least for the client
+sub set_success {
+    my $self = shift;
+    $self->{need_step} = 0;
+}
+
+sub is_success {
+    my $self = shift;
+    return !$self->code && !$self->need_step;
+}
+
+sub set_error {
+  my $self = shift;
+  $self->{error} = shift;
+  return;
+}
+
+# set/get property
+sub property {
+  my $self = shift;
+  my $prop = $self->{property} ||= {};
+  return $prop->{ $_[0] } if @_ == 1;
+  my %new = @_;
+  @{$prop}{keys %new} = values %new;
+  1;
+}
+
+sub callback {
+  my $self = shift;
+
+  return $self->{callback}{$_[0]} if @_ == 1;
+
+  my %new = @_;
+  @{$self->{callback}}{keys %new} = values %new;
+
+  $self->{callback};
+}
+
+# Should be defined in the mechanism sub-class
+sub mechanism    { undef }
+sub client_step  { undef }
+sub client_start { undef }
+sub server_step  { undef }
+sub server_start { undef }
+
+# Private methods used by Authen::SASL::Perl that
+# may be overridden in mechanism sub-calsses
+
+sub _init {
+  my ($pkg, $href) = @_;
+
+  bless $href, $pkg;
+}
+
+sub _call {
+  my ($self, $name) = splice(@_,0,2);
+
+  my $cb = $self->{callback}{$name};
+
+  return undef unless defined $cb;
+
+  my $value;
+
+  if (ref($cb) eq 'ARRAY') {
+    my @args = @$cb;
+    $cb = shift @args;
+    $value = $cb->($self, @args);
+  }
+  elsif (ref($cb) eq 'CODE') {
+    $value = $cb->($self, @_);
+  }
+  else {
+    $value = $cb;
+  }
+
+  $self->{answer}{$name} = $value
+    unless $name eq 'pass'; # Do not store password
+
+  return $value;
+}
+
+# TODO: Need a better name than this
+sub answer {
+  my ($self, $name) = @_;
+  $self->{answer}{$name};
+}
+
+sub _secflags { 0 }
+
+sub securesocket {
+  my $self = shift;
+  return $_[0] unless (defined($self->property('ssf')) && $self->property('ssf') > 0);
+
+  local *GLOB; # avoid used only once warning
+  my $glob = \do { local *GLOB; };
+  tie(*$glob, 'Authen::SASL::Perl::Layer', $_[0], $self);
+  $glob;
+}
+
+{
+
+#
+# Add SASL encoding/decoding to a filehandle
+#
+
+  package Authen::SASL::Perl::Layer;
+
+  use bytes;
+
+  require Tie::Handle;
+  our @ISA = qw(Tie::Handle);
+
+  sub TIEHANDLE {
+    my ($class, $fh, $conn) = @_;
+    my $self;
+
+    warn __PACKAGE__ . ': non-blocking handle may not work'
+      if ($fh->can('blocking') and not $fh->blocking());
+
+    $self->{fh}         = $fh;
+    $self->{conn}       = $conn;
+    $self->{readbuflen} = 0;
+    $self->{sndbufsz}   = $conn->property('maxout');
+    $self->{rcvbufsz}   = $conn->property('maxbuf');
+
+    return bless($self, $class);
+  }
+
+  sub CLOSE {
+    my ($self) = @_;
+
+    # forward close to the inner handle
+    close($self->{fh});
+    delete $self->{fh};
+  }
+
+  sub DESTROY {
+    my ($self) = @_;
+    delete $self->{fh};
+    undef $self;
+  }
+
+  sub FETCH {
+    my ($self) = @_;
+    return $self->{fh};
+  }
+
+  sub FILENO {
+    my ($self) = @_;
+    return fileno($self->{fh});
+  }
+
+
+  sub READ {
+    my ($self, $buf, $len, $offset) = @_;
+    my $debug = $self->{conn}->{debug};
+
+    $buf = \$_[1];
+
+    my $avail = $self->{readbuflen};
+
+    print STDERR " [READ(len=$len,offset=$offset)] avail=$avail;\n"
+      if ($debug & 4);
+
+    # Check if there's leftovers from a previous READ
+    if ($avail <= 0) {
+      $avail = $self->_getbuf();
+      return undef unless ($avail > 0);
+    }
+
+    # if there's more than we need right now, leave the rest for later
+    if ($avail >= $len) {
+      print STDERR "   GOT ALL: avail=$avail; need=$len\n"
+        if ($debug & 4);
+      substr($$buf, $offset, $len) = substr($self->{readbuf}, 0, $len, '');
+      $self->{readbuflen} -= $len;
+      return ($len);
+    }
+
+    # there's not enough; take all we have, read more on next call
+    print STDERR "   GOT PARTIAL: avail=$avail; need=$len\n"
+      if ($debug & 4);
+    substr($$buf, $offset || 0, $avail) = $self->{readbuf};
+    $self->{readbuf}    = '';
+    $self->{readbuflen} = 0;
+
+    return ($avail);
+  }
+
+  # retrieve and decode a buffer of cipher text in SASL format
+  sub _getbuf {
+    my ($self) = @_;
+    my $debug  = $self->{conn}->{debug};
+    my $fh     = $self->{fh};
+    my $buf    = '';
+
+    # first, read 4-octet buffer size
+    my $n = 0;
+    while ($n < 4) {
+      my $rv = sysread($fh, $buf, 4 - $n, $n);
+      print STDERR "    [getbuf: sysread($fh,$buf,4-$n,$n)=$rv: $!\n"
+        if ($debug & 4);
+      return $rv unless $rv > 0;
+      $n += $rv;
+    }
+
+    # size is encoded in network byte order
+    my ($bsz) = unpack('N', $buf);
+    print STDERR "    [getbuf: cipher buffer sz=$bsz]\n" if ($debug & 4);
+    return undef unless ($bsz <= $self->{rcvbufsz});
+
+    # next, read actual cipher text
+    $buf = '';
+    $n   = 0;
+    while ($n < $bsz) {
+      my $rv = sysread($fh, $buf, $bsz - $n, $n);
+      print STDERR "    [getbuf: got o=$n,n=", $bsz - $n, ",rv=$rv,bl=" . length($buf) . "]\n"
+        if ($debug & 4);
+      return $rv unless $rv > 0;
+      $n += $rv;
+    }
+
+    # call mechanism specific decoding routine
+    $self->{readbuf} = $self->{conn}->decode($buf, $bsz);
+    $n = length($self->{readbuf});
+    print STDERR "    [getbuf: clear text buffer sz=$n]\n" if ($debug & 4);
+    $self->{readbuflen} = $n;
+  }
+
+
+  # Encrypting a write() to a filehandle is much easier than reading, because
+  # all the data to be encrypted is immediately available
+  sub WRITE {
+    my ($self, undef, $len, $offset) = @_;
+    my $debug = $self->{conn}->{debug};
+
+    my $fh = $self->{fh};
+
+    # put on wire in peer-sized chunks
+    my $bsz = $self->{sndbufsz};
+    while ($len > 0) {
+      print STDERR " [WRITE: chunk $bsz/$len]\n"
+        if ($debug & 8);
+
+      # call mechanism specific encoding routine
+      my $x = $self->{conn}->encode(substr($_[1], $offset || 0, $bsz));
+      print $fh pack('N', length($x)), $x;
+      $len -= $bsz;
+      $offset += $bsz;
+    }
+
+    return $_[2];
+  }
+
+}
+
+1;

lib/Authen/SASL/Perl.pod

@@ -0,0 +1,154 @@
+# Copyright (c) 2004 Peter Marschall <peter@adpm.de>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+=head1 NAME
+
+Authen::SASL::Perl -- Perl implementation of the SASL Authentication framework
+
+=head1 SYNOPSIS
+
+ use Authen::SASL qw(Perl);
+
+ $sasl = Authen::SASL->new(
+   mechanism => 'CRAM-MD5 PLAIN ANONYMOUS',
+   callback => {
+     user => $user,
+     pass => \&fetch_password
+   }
+ );
+
+=head1 DESCRIPTION
+
+B<Authen::SASL::Perl> is the pure Perl implementation of SASL mechanisms
+in the B<Authen::SASL> framework.
+
+At the time of this writing it provides the client part implementation
+for the following SASL mechanisms:
+
+=over 4
+
+=item ANONYMOUS
+
+The Anonymous SASL Mechanism as defined in RFC 2245 resp. 
+in IETF Draft draft-ietf-sasl-anon-03.txt from February 2004
+provides a method to anonymously access internet services.
+
+Since it does no authentication it does not need to send 
+any confidential information such as passwords in plain text
+over the network.
+
+
+=item CRAM-MD5
+
+The CRAM-MD5 SASL Mechanism as defined in RFC2195 resp.
+in IETF Draft draft-ietf-sasl-crammd5-XX.txt
+offers a simple challenge-response authentication mechanism.
+
+Since it is a challenge-response authentication mechanism
+no passwords are transferred in clear-text over the wire.
+
+Due to the simplicity of the protocol CRAM-MD5 is susceptible
+to replay and dictionary attacks, so DIGEST-MD5 should be used
+in preferrence.
+
+
+=item DIGEST-MD5
+
+The DIGEST-MD5 SASL Mechanism as defined in RFC 2831 resp.
+in IETF Draft draft-ietf-sasl-rfc2831bis-XX.txt
+offers the HTTP Digest Access Authentication as SASL mechanism.
+
+Like CRAM-MD5 it is a challenge-response authentication
+method that does not send plain text passwords over the network.
+
+Compared to CRAM-MD5, DIGEST-MD5 prevents chosen plaintext
+attacks, and permits the use of third party authentication servers,
+so that it is recommended to use DIGEST-MD5 instead of CRAM-MD5
+when possible.
+
+
+=item EXTERNAL
+
+The EXTERNAL SASL mechanism as defined in RFC 2222
+allows the use of external authentication systems as SASL mechanisms.
+
+
+=item GSSAPI
+
+The GSSAPI SASL mechanism as defined in RFC 2222 resp. IETF Draft
+draft-ietf-sasl-gssapi-XX.txt allows using the Generic Security Service
+Application Program Interface [GSSAPI] KERBEROS V5 as as SASL mechanism.
+
+Although GSSAPI is a general mechanism for authentication it is almost
+exlusively used for Kerberos 5.
+
+
+=item LOGIN
+
+The LOGIN SASL Mechanism as defined in IETF Draft
+draft-murchison-sasl-login-XX.txt allows  the
+combination of username and clear-text password to be used
+in a SASL mechanism.
+
+It does does not provide a security layer and sends the credentials
+in clear over the wire.
+Thus this mechanism should not be used without adequate security
+protection.
+
+
+=item PLAIN
+
+The Plain SASL Mechanism as defined in RFC 2595 resp. IETF Draft
+draft-ietf-sasl-plain-XX.txt is another SASL mechanism that allows
+username and clear-text password combinations in SASL environments.
+
+Like LOGIN it sends the credentials in clear over the network
+and should not be used without sufficient security protection.
+
+=back
+
+As for server support, only I<PLAIN>, I<LOGIN> and I<DIGEST-MD5> are supported
+at the time of this writing.
+
+C<server_new> OPTIONS is a hashref that is only relevant for I<DIGEST-MD5> for
+now and it supports the following options:
+
+=over 4
+
+=item - no_integrity
+
+=item - no_confidentiality
+
+=back
+
+which configures how the security layers are negotiated with the client (or
+rather imposed to the client).
+
+
+=head1 SEE ALSO
+
+L<Authen::SASL>,
+L<Authen::SASL::Perl::ANONYMOUS>,
+L<Authen::SASL::Perl::CRAM_MD5>,
+L<Authen::SASL::Perl::DIGEST_MD5>,
+L<Authen::SASL::Perl::EXTERNAL>,
+L<Authen::SASL::Perl::GSSAPI>,
+L<Authen::SASL::Perl::LOGIN>,
+L<Authen::SASL::Perl::PLAIN>
+
+=head1 AUTHOR
+
+Peter Marschall <peter@adpm.de>
+
+Please report any bugs, or post any suggestions, to the perl-ldap mailing list
+<perl-ldap@perl.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2004-2006 Peter Marschall.
+All rights reserved. This document is distributed, and may be redistributed,
+under the same terms as Perl itself.
+
+=cut
+

lib/Authen/SASL/Perl/ANONYMOUS.pm

@@ -0,0 +1,98 @@
+## no critic (ClassHierarchies::ProhibitExplicitISA, Documentation::RequirePODUseEncodingUTF8, Documentation::RequirePodSections)
+# Copyright (c) 2002 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Authen::SASL::Perl::ANONYMOUS;
+
+use 5.018; ## no critic (ProhibitImplicitImport)
+use strict;
+use warnings;
+use utf8;
+
+use vars qw($VERSION @ISA);
+
+$VERSION = '2.14';
+@ISA	 = qw(Authen::SASL::Perl);
+
+my %secflags = (
+	noplaintext => 1,
+);
+
+sub _order { return 0 }
+sub _secflags {
+  shift;
+  return grep { $secflags{$_} } @_;
+}
+
+sub mechanism { return 'ANONYMOUS' }
+
+sub client_start {
+  return shift->_call('authname');
+}
+
+sub client_step {
+  return shift->_call('authname');
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Authen::SASL::Perl::ANONYMOUS - Anonymous Authentication class
+
+=head1 SYNOPSIS
+
+  use Authen::SASL qw(Perl);
+
+  $sasl = Authen::SASL->new(
+    mechanism => 'ANONYMOUS',
+    callback  => {
+      authname => $mailaddress
+    },
+  );
+
+=head1 DESCRIPTION
+
+This method implements the client part of the ANONYMOUS SASL algorithm,
+as described in RFC 2245 resp. in IETF Draft draft-ietf-sasl-anon-XX.txt.
+
+=head2 CALLBACK
+
+The callbacks used are:
+
+=over 4
+
+=item authname
+
+email address or UTF-8 encoded string to be used as
+trace information for the server
+
+=back
+
+=head1 SEE ALSO
+
+L<Authen::SASL>,
+L<Authen::SASL::Perl>
+
+=head1 AUTHORS
+
+Software written by Graham Barr <gbarr@pobox.com>,
+documentation written by Peter Marschall <peter@adpm.de>.
+
+Please report any bugs, or post any suggestions, to the perl-ldap mailing list
+<perl-ldap@perl.org>
+
+=head1 COPYRIGHT 
+
+Copyright (c) 2002-2004 Graham Barr.
+All rights reserved. This program is free software; you can redistribute 
+it and/or modify it under the same terms as Perl itself.
+
+Documentation Copyright (c) 2004 Peter Marschall.
+All rights reserved.  This documentation is distributed,
+and may be redistributed, under the same terms as Perl itself. 
+
+=cut

lib/Authen/SASL/Perl/CRAM_MD5.pm

@@ -0,0 +1,110 @@
+## no critic (ClassHierarchies::ProhibitExplicitISA, Documentation::RequirePodSections, Documentation::RequirePODUseEncodingUTF8)
+# Copyright (c) 2002 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Authen::SASL::Perl::CRAM_MD5;
+
+use 5.018; ## no critic (ProhibitImplicitImport)
+use strict;
+use warnings;
+use utf8;
+
+use vars qw($VERSION @ISA);
+use Digest::HMAC_MD5 qw(hmac_md5_hex);
+
+$VERSION = '2.14';
+@ISA	 = qw(Authen::SASL::Perl);
+
+my %secflags = (
+	noplaintext => 1,
+	noanonymous => 1,
+);
+
+sub _order { return 2 }
+sub _secflags {
+  shift;
+  return scalar grep { $secflags{$_} } @_;
+}
+
+sub mechanism { return 'CRAM-MD5' }
+
+sub client_start {
+  return '';
+}
+
+sub client_step {
+  my ($self, $string) = @_;
+  my ($user, $pass) = map {
+    my $v = $self->_call($_);
+    defined($v) ? $v : ''
+  } qw(user pass);
+
+  return $user . ' ' . hmac_md5_hex($string,$pass);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Authen::SASL::Perl::CRAM_MD5 - CRAM MD5 Authentication class
+
+=head1 SYNOPSIS
+
+  use Authen::SASL qw(Perl);
+
+  $sasl = Authen::SASL->new(
+    mechanism => 'CRAM-MD5',
+    callback  => {
+      user => $user,
+      pass => $pass
+    },
+  );
+
+=head1 DESCRIPTION
+
+This method implements the client part of the CRAM-MD5 SASL algorithm,
+as described in RFC 2195 resp. in IETF Draft draft-ietf-sasl-crammd5-XX.txt.
+
+=head2 CALLBACK
+
+The callbacks used are:
+
+=over 4
+
+=item user
+
+The username to be used for authentication
+
+=item pass
+
+The user's password to be used for authentication
+
+=back
+
+=head1 SEE ALSO
+
+L<Authen::SASL>,
+L<Authen::SASL::Perl>
+
+=head1 AUTHORS
+
+Software written by Graham Barr <gbarr@pobox.com>,
+documentation written by Peter Marschall <peter@adpm.de>.
+
+Please report any bugs, or post any suggestions, to the perl-ldap mailing list
+<perl-ldap@perl.org>
+
+=head1 COPYRIGHT 
+
+Copyright (c) 2002-2004 Graham Barr.
+All rights reserved. This program is free software; you can redistribute 
+it and/or modify it under the same terms as Perl itself.
+
+Documentation Copyright (c) 2004 Peter Marschall.
+All rights reserved.  This documentation is distributed,
+and may be redistributed, under the same terms as Perl itself. 
+
+=cut

lib/Authen/SASL/Perl/DIGEST_MD5.pm

@@ -0,0 +1,884 @@
+## no critic (Documentation::RequirePodSections, Documentation::RequirePODUseEncodingUTF8)
+# Copyright (c) 2003-2009 Graham Barr, Djamel Boudjerda, Paul Connolly, Julian
+# Onions, Nexor and Yann Kerherve.
+# All rights reserved. This program is free software; you can redistribute
+# it and/or modify it under the same terms as Perl itself.
+
+# See http://www.ietf.org/rfc/rfc2831.txt for details
+
+package Authen::SASL::Perl::DIGEST_MD5;
+
+use 5.018; ## no critic (ProhibitImplicitImport)
+use strict;
+use warnings;
+use utf8;
+
+use vars qw($VERSION @ISA $CNONCE $NONCE);
+use Digest::MD5 qw(md5_hex md5);
+use Digest::HMAC_MD5 qw(hmac_md5);
+use Crypt::RC4 ();
+
+# TODO: complete qop support in server, should be configurable
+
+$VERSION = '2.14';
+@ISA = qw(Authen::SASL::Perl); ## no critic (ClassHierarchies::ProhibitExplicitISA)
+
+my %secflags = (
+  noplaintext => 1,
+  noanonymous => 1,
+);
+
+# some have to be quoted - some don't - sigh!
+my (%cqdval, %sqdval);
+@cqdval{qw(
+  username authzid realm nonce cnonce digest-uri
+)} = ();
+
+## ...and server behaves different than client - double sigh!
+@sqdval{keys %cqdval, qw(qop cipher)} = ();
+#  username authzid realm nonce cnonce digest-uri qop cipher
+#)} = ();
+
+my %multi;
+@{$multi{server}}{qw(realm auth-param)} = ();
+@{$multi{client}}{qw()} = ();
+
+my @server_required = qw(algorithm nonce);
+my @client_required = qw(username nonce cnonce nc qop response);
+
+# available ciphers
+my @ourciphers = (
+  {
+    name  => 'rc4',
+    ssf   => 128,
+    bs    => 1,
+    ks    => 16,
+    pkg   => 'Crypt::RC4',
+    key   => sub { $_[0] },
+    iv    => sub {},
+    fixup => sub {
+      # retrofit the Crypt::RC4 module with standard subs
+      *Crypt::RC4::encrypt   = *Crypt::RC4::decrypt =
+        sub { goto &Crypt::RC4::RC4; };
+      *Crypt::RC4::keysize   =  sub {128};
+      *Crypt::RC4::blocksize =  sub {1};
+    },
+  },
+  {
+    name  => '3des',
+    ssf   => 112,
+    bs    => 8,
+    ks    => 16,
+    pkg   => 'Crypt::DES3',
+    key   => sub {
+      pack('B8' x 16,
+        map { $_ . '0' }
+        map { unpack('a7' x 16, $_); }
+        unpack('B*', substr($_[0], 0, 14)) );
+    },
+    iv => sub { substr($_[0], -8, 8) },
+  },
+  {
+    name  => 'des',
+    ssf   => 56,
+    bs    => 8,
+    ks    => 16,
+    pkg   => 'Crypt::DES',
+    key   => sub {
+      pack('B8' x 8,
+        map { $_ . '0' }
+        map { unpack('a7' x 8, $_); }
+        unpack('B*',substr($_[0], 0, 7)) );
+    },
+    iv => sub { substr($_[0], -8, 8) },
+  },
+  {
+    name  => 'rc4-56',
+    ssf   => 56,
+    bs    => 1,
+    ks    => 7,
+    pkg   => 'Crypt::RC4',
+    key   => sub { $_[0] },
+    iv    => sub {},
+    fixup => sub {
+      *Crypt::RC4::encrypt   = *Crypt::RC4::decrypt =
+        sub { goto &Crypt::RC4::RC4; };
+      *Crypt::RC4::keysize   =  sub {56};
+      *Crypt::RC4::blocksize =  sub {1};
+    },
+  },
+  {
+    name  => 'rc4-40',
+    ssf   => 40,
+    bs    => 1,
+    ks    => 5,
+    pkg   => 'Crypt::RC4',
+    key   => sub { $_[0] },
+    iv    => sub {},
+    fixup => sub {
+      *Crypt::RC4::encrypt   = *Crypt::RC4::decrypt =
+        sub { goto &Crypt::RC4::RC4; };
+      *Crypt::RC4::keysize   =  sub {40};
+      *Crypt::RC4::blocksize =  sub {1};
+    },
+  },
+);
+
+## The system we are on, might not be able to crypt the stream
+our $NO_CRYPT_AVAILABLE = 1;
+for (@ourciphers) {
+    eval "require $_->{pkg}"; ## no critic (BuiltinFunctions::ProhibitStringyEval)
+    unless ($@) { ## no critic (Variables::ProhibitPunctuationVars)
+        $NO_CRYPT_AVAILABLE = 0;
+        last;
+    }
+}
+
+sub _order { return 3 }
+sub _secflags {
+  shift;
+  return scalar grep { $secflags{$_} } @_;
+}
+
+sub mechanism { return 'DIGEST-MD5' }
+
+sub _init {
+  my ($pkg, $self) = @_;
+  bless $self, $pkg;
+
+  # set default security properties
+  $self->property('minssf',      0);
+  $self->property('maxssf',      int 2**31 - 1);    # XXX - arbitrary "high" value
+  $self->property('maxbuf',      0xFFFFFF);         # maximum supported by GSSAPI mech
+  $self->property('externalssf', 0);
+
+  return $self;
+}
+
+sub _init_server {
+  my $server  = shift;
+  my $options = shift || {};
+  if (!ref $options || ref $options ne 'HASH') {
+    warn 'options for DIGEST_MD5 should be a hashref'; ## no critic (ErrorHandling::RequireCarping)
+    $options = {};
+  }
+
+  ## new server, means new nonce_counts
+  $server->{nonce_counts} = {};
+
+  ## determine supported qop
+  my   @qop = ('auth');
+  push @qop, 'auth-int'  unless $options->{no_integrity};
+  push @qop, 'auth-conf' unless $options->{no_integrity}
+                             or $options->{no_confidentiality}
+                             or $NO_CRYPT_AVAILABLE;
+
+  return $server->{supported_qop} = { map { $_ => 1 } @qop };
+}
+
+sub init_sec_layer {
+  my $self           = shift;
+  $self->{cipher}    = undef;
+  $self->{khc}       = undef;
+  $self->{khs}       = undef;
+  $self->{sndseqnum} = 0;
+  $self->{rcvseqnum} = 0;
+
+  # reset properties for new session
+  $self->property(maxout => undef);
+  $self->property(ssf    => undef);
+  return;
+}
+
+# no initial value passed to the server
+sub client_start {
+  my $self = shift;
+
+  $self->{need_step} = 1;
+  $self->{error}     = undef;
+  $self->{state}     = 0;
+  $self->init_sec_layer;
+  return '';
+}
+
+sub server_start {
+  my $self       = shift;
+  my $challenge  = shift;
+  my $cb         = shift || sub {};
+
+  $self->{need_step} = 1;
+  $self->{error}     = undef;
+  $self->{nonce}     = md5_hex($NONCE || join (':', $$, time, rand)); ## no critic (Variables::ProhibitPunctuationVars)
+
+  $self->init_sec_layer;
+
+  my $qop = [ sort keys %{$self->{supported_qop}} ];
+
+  ## get the realm using callbacks but default to the host specified
+  ## during the instanciation of the SASL object
+  my $realm = $self->_call('realm');
+  $realm  ||= $self->host;
+
+  my %response = (
+    nonce         => $self->{nonce},
+    charset       => 'utf-8',
+    algorithm     => 'md5-sess',
+    realm         => $realm,
+    maxbuf        => $self->property('maxbuf'),
+
+## IN DRAFT ONLY:
+# If this directive is present multiple times the client MUST treat
+# it as if it received a single qop directive containing a comma
+# separated value from all instances. I.e.,
+# 'qop="auth",qop="auth-int"' is the same as 'qop="auth,auth-int"
+
+    'qop'         => $qop,
+    'cipher'      => [ map { $_->{name} } @ourciphers ],
+  );
+  my $final_response = _response(\%response);
+  $cb->($final_response);
+  return;
+}
+
+sub client_step {   # $self, $server_sasl_credentials
+  my ($self, $challenge) = @_;
+  $self->{server_params} = \my %sparams;
+
+  # Parse response parameters
+  $self->_parse_challenge(\$challenge, server => $self->{server_params})
+    or return $self->set_error("Bad challenge: '$challenge'");
+
+  if ($self->{state} == 1) {
+    # check server's `rspauth' response
+    return $self->set_error('Server did not send rspauth in step 2')
+      unless ($sparams{rspauth});
+    return $self->set_error('Invalid rspauth in step 2')
+      unless ($self->{rspauth} eq $sparams{rspauth});
+
+    # all is well
+    $self->set_success;
+    return '';
+  }
+
+  # check required fields in server challenge
+  if (my @missing = grep { !exists $sparams{$_} } @server_required) {
+    return $self->set_error("Server did not provide required field(s): @missing");
+  }
+
+  my %response = (
+    nonce        => $sparams{'nonce'},
+    cnonce       => md5_hex($CNONCE || join (':', $$, time, rand)), ## no critic (Variables::ProhibitPunctuationVars)
+    'digest-uri' => $self->service . '/' . $self->host,
+    # calc how often the server nonce has been seen; server expects "00000001"
+    nc           => sprintf('%08d',     ++$self->{nonce_counts}{$sparams{'nonce'}}),
+    charset      => $sparams{'charset'},
+  );
+
+  return $self->set_error("Server qop too weak (qop = $sparams{'qop'})")
+    unless ($self->_client_layer(\%sparams,\%response));
+
+  # let caller-provided fields override defaults: authorization ID, service name, realm
+
+  my $s_realm = $sparams{realm} || [];
+  my $realm = $self->_call('realm', @{$s_realm});
+  unless (defined $realm) {
+    # If the user does not pick a realm, use the first from the server
+    $realm = $s_realm->[0];
+  }
+  if (defined $realm) {
+    $response{realm} = $realm;
+  }
+
+  my $authzid = $self->_call('authname');
+#  if (defined $authzid) {
+#    $response{authzid} = $authzid;
+#  }
+
+  my $serv_name = $self->_call('serv');
+  if (defined $serv_name) {
+    $response{'digest-uri'} .= '/' . $serv_name;
+  }
+
+  my $user = $self->_call('user');
+  return $self->set_error('Username is required')
+    unless defined $user;
+  $response{username} = $user;
+
+  my $password = $self->_call('pass');
+  return $self->set_error('Password is required')
+    unless defined $password;
+
+  $self->property('maxout', $sparams{maxbuf} || 65536);
+
+  # Generate the response value
+  $self->{state} = 1;
+
+  my ($response, $rspauth)
+    = $self->_compute_digests_and_set_keys($password, \%response);
+
+  $response{response} = $response;
+  $self->{rspauth}    = $rspauth;
+
+  # finally, return our response token
+  return _response(\%response, 'is_client');
+}
+
+sub _compute_digests_and_set_keys {
+  my $self     = shift;
+  my $password = shift;
+  my $params   = shift;
+
+  if (defined $params->{realm} and ref $params->{realm} eq 'ARRAY') {
+    $params->{realm} = $params->{realm}[0];
+  }
+
+  my $realm = $params->{realm};
+  $realm = '' unless defined $realm;
+
+  my $A1 = join (':',
+    md5(join (':', $params->{username}, $realm, $password)),
+    @{$params{defined($params->{authzid})
+      ? qw(nonce cnonce authzid)
+      : qw(nonce cnonce)
+    }},
+  );
+
+  # pre-compute MD5(A1) and HEX(MD5(A1)); these are used multiple times below
+  my $hdA1 = unpack('H*', (my $dA1 = md5($A1)) );
+
+  # derive keys for layer encryption / integrity
+  $self->{kic} = md5($dA1,
+    'Digest session key to client-to-server signing key magic constant');
+
+  $self->{kis} = md5($dA1,
+    'Digest session key to server-to-client signing key magic constant');
+
+  if (my $cipher = $self->{cipher}) {
+    &{ $cipher->{fixup} || sub{} };
+
+    # compute keys for encryption
+    my $ks = $cipher->{ks};
+    $self->{kcc} = md5(substr($dA1,0,$ks),
+      'Digest H(A1) to client-to-server sealing key magic constant');
+    $self->{kcs} = md5(substr($dA1,0,$ks),
+      'Digest H(A1) to server-to-client sealing key magic constant');
+
+    # get an encryption and decryption handle for the chosen cipher
+    $self->{khc} = $cipher->{pkg}->new($cipher->{key}->($self->{kcc}));
+    $self->{khs} = $cipher->{pkg}->new($cipher->{key}->($self->{kcs}));
+
+    # initialize IVs
+    $self->{ivc} = $cipher->{iv}->($self->{kcc});
+    $self->{ivs} = $cipher->{iv}->($self->{kcs});
+  }
+
+  my $A2 = 'AUTHENTICATE:' . $params->{'digest-uri'};
+  $A2 .= ':00000000000000000000000000000000' if ($params->{qop} ne 'auth');
+
+  my $response = md5_hex(
+    join (':', $hdA1, @{$params{qw(nonce nc cnonce qop)}}, md5_hex($A2)),
+  );
+
+  # calculate server `rspauth' response, so we can check in step 2
+  # the only difference here is in the A2 string which from which
+  # `AUTHENTICATE' is omitted in the calculation of `rspauth'
+  $A2 = ':' . $params->{'digest-uri'};
+  $A2 .= ':00000000000000000000000000000000' if ($params->{qop} ne 'auth');
+
+  my $rspauth = md5_hex(
+    join (':', $hdA1, @{$params{qw(nonce nc cnonce qop)}}, md5_hex($A2)),
+  );
+
+  return ($response, $rspauth);
+}
+
+sub server_step {
+  my $self      = shift;
+  my $challenge = shift;
+  my $cb        = shift || sub {};
+
+  $self->{client_params} = \my %cparams;
+  unless ( $self->_parse_challenge(\$challenge, client => $self->{client_params}) ) {
+   $self->set_error("Bad challenge: '$challenge'");
+   return $cb->();
+  }
+
+  # check required fields in server challenge
+  if (my @missing = grep { !exists $cparams{$_} } @client_required) {
+    $self->set_error("Client did not provide required field(s): @missing");
+    return $cb->();
+  }
+
+  my $count = hex ($cparams{'nc'} || 0);
+  unless ($count == ++$self->{nonce_counts}{$cparams{nonce}}) {
+    $self->set_error("nonce-count doesn't match: $count");
+    return $cb->();
+  }
+
+  my $qop = $cparams{'qop'} || 'auth';
+  unless ($self->is_qop_supported($qop)) {
+    $self->set_error("Client qop not supported (qop = '$qop')");
+    return $cb->();
+  }
+
+  my $username = $cparams{'username'};
+  unless ($username) {
+    $self->set_error('Client didn\'t provide a username');
+    return $cb->();
+  }
+
+  # "The authzid MUST NOT be an empty string."
+  if (exists $cparams{authzid} && $cparams{authzid} eq '') {
+      $self->set_error('authzid cannot be empty');
+      return $cb->();
+  }
+  my $authzid = $cparams{authzid};
+
+  # digest-uri: "Servers SHOULD check that the supplied value is correct.
+  # This will detect accidental connection to the incorrect server, as well as
+  # some redirection attacks"
+  my $digest_uri = $cparams{'digest-uri'};
+  my ($cservice, $chost, $cservname) = split /\//, $digest_uri, 3;
+  if ($cservice ne $self->service or $chost ne $self->host) {
+      # XXX deal with serv_name
+      $self->set_error('Incorrect digest-uri');
+      return $cb->();
+  }
+
+  unless (defined $self->callback('getsecret')) {
+    $self->set_error('a getsecret callback MUST be defined');
+    $cb->();
+    return;
+  }
+
+  my $realm = $self->{client_params}->{'realm'};
+  my $response_check = sub {
+    my $password = shift;
+    return $self->set_error("Cannot get the passord for $username")
+        unless defined $password;
+
+    ## configure the security layer
+    $self->_server_layer($qop)
+        or return $self->set_error('Cannot negociate the security layer');
+
+    my ($expected, $rspauth)
+        = $self->_compute_digests_and_set_keys($password, $self->{client_params});
+
+    return $self->set_error("Incorrect response $self->{client_params}->{response} <> $expected")
+        unless $expected eq $self->{client_params}->{response};
+
+    my %response = (
+        rspauth => $rspauth,
+    );
+
+    # I'm not entirely sure of what I am doing
+    $self->{answer}{$_} = $self->{client_params}->{$_} for qw/username authzid realm serv/;
+
+    $self->set_success;
+    return _response(\%response);
+  };
+
+  return $self->callback('getsecret')->(
+    $self,
+    { user => $username, realm => $realm, authzid => $authzid },
+    sub { $cb->( $response_check->( shift ) ) },
+  );
+}
+
+sub is_qop_supported {
+    my $self = shift;
+    my $qop  = shift;
+    return $self->{supported_qop}{$qop};
+}
+
+sub _response {
+  my $response  = shift;
+  my $is_client = shift;
+
+  my @out;
+  for my $k (sort keys %{$response}) {
+    my $is_array = ref $response->{$k} && ref $response->{$k} eq 'ARRAY';
+    my @values = $is_array ? @{$response->{$k}} : ($response->{$k});
+    # Per spec, one way of doing it: multiple k=v
+    #push @out, [$k, $_] for @values;
+    # other way: comma separated list
+    push @out, [$k, join (',', @values)];
+  }
+  return join (',', map { _qdval($_->[0], $_->[1], $is_client) } @out);
+}
+
+sub _parse_challenge {
+  my $self          = shift;
+  my $challenge_ref = shift;
+  my $type          = shift;
+  my $params        = shift;
+
+  while(${$challenge_ref} =~
+           s{^(?:\s*,)*\s*            # remaining or crap
+             ([\w-]+)                 # key, eg: qop
+             =
+             ("([^\\"]+|\\.)*"|[^,]+) # value, eg: auth-conf or "NoNcE"
+             \s*(?:,\s*)*             # remaining
+           }{}x) {
+
+    my ($k, $v) = ($1,$2);
+    if ($v =~ /^"(.*)"$/s) {
+      ($v = $1) =~ s/\\(.)/$1/g;
+    }
+    if (exists $multi{$type}{$k}) {
+      my $aref = $params->{$k} ||= [];
+      push @{$aref}, $v;
+    }
+    elsif (defined $params->{$k}) {
+      return $self->set_error("Bad challenge: '$$challenge_ref'");
+    }
+    else {
+      $params->{$k} = $v;
+    }
+  }
+  return length ${$challenge_ref} ? 0 : 1;
+}
+
+sub _qdval {
+  my ($k, $v, $is_client) = @_;
+
+  my $qdval = $is_client ? \%cqdval : \%sqdval;
+
+  if (!defined $v) {
+    return;
+  }
+  elsif (exists $qdval->{$k}) {
+    $v =~ s/([\\"])/\\$1/g;
+    return qq{$k="$v"};
+  }
+
+  return "$k=$v";
+}
+
+sub _server_layer {
+  my ($self, $auth) = @_;
+
+  # XXX dupe
+  # construct our qop mask
+  my $maxssf = $self->property('maxssf') - $self->property('externalssf');
+  $maxssf = 0 if ($maxssf < 0);
+  my $minssf = $self->property('minssf') - $self->property('externalssf');
+  $minssf = 0 if ($minssf < 0);
+
+  return undef if ($maxssf < $minssf); # sanity check
+
+  my $ciphers = [ map { $_->{name} } @ourciphers ];
+  if ((     $auth eq 'auth-conf')
+        and $self->_select_cipher($minssf, $maxssf, $ciphers )) {
+    $self->property('ssf', $self->{cipher}->{ssf});
+    return 1;
+  }
+  if ($auth eq 'auth-int') {
+    $self->property('ssf', 1);
+    return 1;
+  }
+  if ($auth eq 'auth') {
+    $self->property('ssf', 0);
+    return 1;
+  }
+
+  return undef;
+}
+
+sub _client_layer {
+  my ($self, $sparams, $response) = @_;
+
+  # construct server qop mask
+  # qop in server challenge is optional: if not there "auth" is assumed
+  my $smask = 0;
+  map {
+    m/^auth$/      and $smask |= 1; ## no critic (RegularExpressions::ProhibitFixedStringMatches)
+    m/^auth-int$/  and $smask |= 2; ## no critic (RegularExpressions::ProhibitFixedStringMatches)
+    m/^auth-conf$/ and $smask |= 4; ## no critic (RegularExpressions::ProhibitFixedStringMatches)
+  } split(/,/, $sparams->{qop}||'auth'); # XXX I think we might have a bug here bc. of LWS
+
+  # construct our qop mask
+  my $cmask = 0;
+  my $maxssf = $self->property('maxssf') - $self->property('externalssf');
+  $maxssf = 0 if ($maxssf < 0);
+  my $minssf = $self->property('minssf') - $self->property('externalssf');
+  $minssf = 0 if ($minssf < 0);
+
+  return undef if ($maxssf < $minssf); # sanity check
+
+  # ssf values > 1 mean integrity and confidentiality 
+  # ssf == 1 means integrity but no confidentiality
+  # ssf < 1 means neither integrity nor confidentiality
+  # no security layer can be had if buffer size is 0
+  $cmask |= 1 if ($minssf < 1);
+  $cmask |= 2 if ($minssf <= 1 and $maxssf >= 1);
+  $cmask |= 4 if ($maxssf > 1);
+
+  # find common bits
+  $cmask &= $smask;
+
+  # parse server cipher options
+  my @sciphers = split(/,/, $sparams->{'cipher-opts'}||$sparams->{cipher}||'');
+
+  if (($cmask & 4) and $self->_select_cipher($minssf,$maxssf,\@sciphers)) {
+    $response->{qop} = 'auth-conf';
+    $response->{cipher} = $self->{cipher}->{name};
+    $self->property('ssf', $self->{cipher}->{ssf});
+    return 1;
+  }
+  if ($cmask & 2) {
+    $response->{qop} = 'auth-int';
+    $self->property('ssf', 1);
+    return 1;
+  }
+  if ($cmask & 1) {
+    $response->{qop} = 'auth';
+    $self->property('ssf', 0);
+    return 1;
+  }
+
+  return undef;
+}
+
+sub _select_cipher {
+  my ($self, $minssf, $maxssf, $ciphers) = @_;
+
+  # compose a subset of candidate ciphers based on ssf and peer list
+  my @a = map {
+    my $c = $_;
+    (grep { $c->{name} eq $_ } @{$ciphers} and
+      $c->{ssf} >= $minssf and $c->{ssf} <= $maxssf) ? $_ : ()
+  } @ourciphers;
+
+  # from these, select the first one we can create an instance of
+  for (@a) {
+    next unless eval {require $_->{pkg}};
+    $self->{cipher} = $_;
+    return 1;
+  }
+
+  return 0;
+}
+
+use Digest::HMAC_MD5 qw(hmac_md5);
+
+sub encode {  # input: self, plaintext buffer,length (length not used here)
+  my $self   = shift;
+  my $seqnum = pack('N', $self->{sndseqnum}++);
+  my $mac    = substr(hmac_md5($seqnum . $_[0], $self->{kic}), 0, 10);
+
+  # if integrity only, return concatenation of buffer, MAC, TYPE and SEQNUM
+  return $_[0] . $mac.pack('n',1) . $seqnum unless ($self->{khc});
+
+  # must encrypt, block ciphers need padding bytes
+  my $pad = '';
+  my $bs = $self->{cipher}->{bs};
+  if ($bs > 1) {
+    # padding is added in between BUF and MAC
+    my $n = $bs - ((length($_[0]) + 10) & ($bs - 1));
+    $pad = chr($n) x $n;
+  }
+
+  # XXX - for future AES cipher support, the currently used common _crypt()
+  # function probably wont do; we might to switch to per-cipher routines
+  # like so:
+  #  return $self->{khc}->encrypt($_[0] . $pad . $mac) . pack('n', 1) . $seqnum;
+  return $self->_crypt(0, $_[0] . $pad . $mac) . pack('n', 1) . $seqnum;
+}
+
+sub decode {  # input: self, cipher buffer,length
+  my ($self, $buf, $len) = @_;
+
+  return if ($len <= 16);
+
+  # extract TYPE/SEQNUM from end of buffer
+  my ($type,$seqnum) = unpack('na[4]', substr($buf, -6, 6, ''));
+
+  # decrypt remaining buffer, if necessary
+  if ($self->{khs}) {
+    # XXX - see remark above in encode() #$buf = $self->{khs}->decrypt($buf);
+    $buf = $self->_crypt(1, $buf);
+  }
+  return unless ($buf);
+
+  # extract 10-byte MAC from the end of (decrypted) buffer
+  my ($mac) = unpack('a[10]', substr($buf, -10, 10, ''));
+
+  if ($self->{khs} and $self->{cipher}->{bs} > 1) {
+    # remove padding
+    my $n = ord(substr($buf, -1, 1));
+    substr($buf, -$n, $n, '');
+  }
+
+  # check the MAC
+  my $check = substr(hmac_md5($seqnum . $buf, $self->{kis}), 0, 10);
+  return if ($mac ne $check);
+  return if (unpack('N', $seqnum) != $self->{rcvseqnum});
+  $self->{rcvseqnum}++;
+
+  return $buf;
+}
+
+sub _crypt {  # input: op(decrypting=1/encrypting=0)), buffer
+  my ($self,$d) = (shift,shift);
+  my $bs = $self->{cipher}->{bs};
+
+  if ($bs <= 1) {
+    # stream cipher
+    return $d ? $self->{khs}->decrypt($_[0]) : $self->{khc}->encrypt($_[0]);
+  }
+
+  # the remainder of this sub is for block ciphers
+
+  # get current IV
+  my $piv = \$self->{$d ? 'ivs' : 'ivc'};
+  my $iv = ${$piv};
+
+  my $result = join '', map {
+    my $x = $d
+      ? $iv ^ $self->{khs}->decrypt($_)
+      : $self->{khc}->encrypt($iv ^ $_);
+    $iv = $d ? $_ : $x;
+    $x;
+  } unpack("a$bs "x(int(length($_[0])/$bs)), $_[0]);
+
+  # store current IV
+  ${$piv} = $iv;
+  return $result;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Authen::SASL::Perl::DIGEST_MD5 - Digest MD5 Authentication class
+
+=head1 SYNOPSIS
+
+  use Authen::SASL qw(Perl);
+
+  $sasl = Authen::SASL->new(
+    mechanism => 'DIGEST-MD5',
+    callback  => {
+      user => $user, 
+      pass => $pass,
+      serv => $serv
+    },
+  );
+
+=head1 DESCRIPTION
+
+This method implements the client and server parts of the DIGEST-MD5 SASL
+algorithm, as described in RFC 2831.
+
+=head2 CALLBACK
+
+The callbacks used are:
+
+=head3 client
+
+=over 4
+
+=item authname
+
+The authorization id to use after successful authentication
+
+=item user
+
+The username to be used in the response
+
+=item pass
+
+The password to be used to compute the response.
+
+=item serv
+
+The service name when authenticating to a replicated service
+
+=item realm
+
+The authentication realm when overriding the server-provided default.
+If not given the server-provided value is used.
+
+The callback will be passed the list of realms that the server provided
+in the initial response.
+
+=back
+
+=head3 server
+
+=over4
+
+=item realm
+
+The default realm to provide to the client
+
+=item getsecret(username, realm, authzid)
+
+returns the password associated with C<username> and C<realm>
+
+=back
+
+=head2 PROPERTIES
+
+The properties used are:
+
+=over 4
+
+=item maxbuf
+
+The maximum buffer size for receiving cipher text
+
+=item minssf
+
+The minimum SSF value that should be provided by the SASL security layer.
+The default is 0
+
+=item maxssf
+
+The maximum SSF value that should be provided by the SASL security layer.
+The default is 2**31
+
+=item externalssf
+
+The SSF value provided by an underlying external security layer.
+The default is 0
+
+=item ssf
+
+The actual SSF value provided by the SASL security layer after the SASL
+authentication phase has been completed. This value is read-only and set
+by the implementation after the SASL authentication phase has been completed.
+
+=item maxout
+
+The maximum plaintext buffer size for sending data to the peer.
+This value is set by the implementation after the SASL authentication
+phase has been completed and a SASL security layer is in effect.
+
+=back
+
+
+=head1 SEE ALSO
+
+L<Authen::SASL>,
+L<Authen::SASL::Perl>
+
+=head1 AUTHORS
+
+Graham Barr, Djamel Boudjerda (NEXOR), Paul Connolly, Julian Onions (NEXOR),
+Yann Kerherve.
+
+Please report any bugs, or post any suggestions, to the perl-ldap mailing list
+<perl-ldap@perl.org>
+
+=head1 COPYRIGHT 
+
+Copyright (c) 2003-2009 Graham Barr, Djamel Boudjerda, Paul Connolly,
+Julian Onions, Nexor, Peter Marschall and Yann Kerherve.
+All rights reserved. This program is free software; you can redistribute 
+it and/or modify it under the same terms as Perl itself.
+
+=cut

lib/Authen/SASL/Perl/EXTERNAL.pm

@@ -0,0 +1,102 @@
+## no critic (ClassHierarchies::ProhibitExplicitISA, Documentation::RequirePodSections, Documentation::RequirePODUseEncodingUTF8)
+# Copyright (c) 1998-2002 Graham Barr <gbarr@pobox.com> and 2001 Chris Ridd
+# <chris.ridd@isode.com>.  All rights reserved.  This program
+# is free software; you can redistribute it and/or modify it under the
+# same terms as Perl itself.
+
+package Authen::SASL::Perl::EXTERNAL;
+
+use 5.018; ## no critic (ProhibitImplicitImport)
+use strict;
+use warnings;
+use utf8;
+
+use vars qw($VERSION @ISA);
+
+$VERSION = '2.14';
+@ISA	 = qw(Authen::SASL::Perl);
+
+my %secflags = (
+	noplaintext  => 1,
+	nodictionary => 1,
+	noanonymous  => 1,
+);
+
+sub _order { return 2 }
+sub _secflags {
+  shift;
+  return grep { $secflags{$_} } @_;
+}
+
+sub mechanism { return 'EXTERNAL' }
+
+sub client_start {
+  my $self = shift;
+  my $v = $self->_call('user');
+  return defined($v) ? $v : '';
+}
+
+#sub client_step {
+#  shift->_call('user');
+#}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Authen::SASL::Perl::EXTERNAL - External Authentication class
+
+=head1 SYNOPSIS
+
+  use Authen::SASL qw(Perl);
+
+  $sasl = Authen::SASL->new(
+    mechanism => 'EXTERNAL',
+    callback  => {
+      user => $user
+    },
+  );
+
+=head1 DESCRIPTION
+
+This method implements the client part of the EXTERNAL SASL algorithm,
+as described in RFC 2222.
+
+=head2 CALLBACK
+
+The callbacks used are:
+
+=over 4
+
+=item user
+
+The username to be used for authentication
+
+=back
+
+=head1 SEE ALSO
+
+L<Authen::SASL>,
+L<Authen::SASL::Perl>
+
+=head1 AUTHORS
+
+Software written by Graham Barr <gbarr@pobox.com>,
+documentation written by Peter Marschall <peter@adpm.de>.
+
+Please report any bugs, or post any suggestions, to the perl-ldap mailing list
+<perl-ldap@perl.org>
+
+=head1 COPYRIGHT 
+
+Copyright (c) 1998-2004 Graham Barr.
+All rights reserved. This program is free software; you can redistribute 
+it and/or modify it under the same terms as Perl itself.
+
+Documentation Copyright (c) 2004 Peter Marschall.
+All rights reserved.  This documentation is distributed,
+and may be redistributed, under the same terms as Perl itself. 
+
+=cut

lib/Authen/SASL/Perl/GSSAPI.pm

@@ -0,0 +1,381 @@
+## no critic (ClassHierarchies::ProhibitExplicitISA, Documentation::RequirePodSections, Documentation::RequirePODUseEncodingUTF8)
+# Copyright (c) 2006 Simon Wilkinson
+# All rights reserved. This program is free software; you can redistribute
+# it and/or modify it under the same terms as Perl itself.
+
+package Authen::SASL::Perl::GSSAPI;
+
+use 5.018; ## no critic (ProhibitImplicitImport)
+use strict;
+use warnings;
+use utf8;
+
+use vars qw($VERSION @ISA);
+use GSSAPI ();
+use GSSAPI::Name ();
+use GSSAPI::Context ();
+
+$VERSION= '0.05';
+@ISA = qw(Authen::SASL::Perl);
+
+my %secflags = (
+  noplaintext => 1,
+  noanonymous => 1,
+);
+
+sub _order { return 4 }
+sub _secflags {
+  shift;
+  return scalar grep { $secflags{$_} } @_;
+}
+
+sub mechanism { return 'GSSAPI' }
+
+sub _init {
+  my ($pkg, $self) = @_;
+  bless $self, $pkg;
+
+  # set default security properties
+  $self->property('minssf',      0);
+  $self->property('maxssf',      int 2**31 - 1);    # XXX - arbitrary "high" value
+  $self->property('maxbuf',      0xFFFFFF);         # maximum supported by GSSAPI mech
+  $self->property('externalssf', 0);
+  # the cyrus sasl library allows only one bit to be set in the
+  # layer selection mask in the client reply, we default to
+  # compatibility with that bug
+  $self->property('COMPAT_CYRUSLIB_REPLY_MASK_BUG', 1);
+  return $self;
+}
+
+sub client_start {
+  my $self = shift;
+  my $status;
+  my $principal = $self->service.'@'.$self->host;
+
+  # GSSAPI::Name->import is the *constructor*,
+  # storing the new GSSAPI::Name into $target.
+  # GSSAPI::Name->import is not the standard
+  # import() method as used in Perl normally
+  my $target;
+  $status = GSSAPI::Name->import($target, $principal, gss_nt_service_name)
+    or return $self->set_error("GSSAPI Error : ".$status);
+  $self->{gss_name}  = $target;
+  $self->{gss_ctx}   = new GSSAPI::Context;
+  $self->{gss_state} = 0;
+  $self->{gss_layer} = undef;
+  my $cred = $self->_call('pass');
+  $self->{gss_cred}  = (ref($cred) && $cred->isa('GSSAPI::Cred')) ? $cred : GSS_C_NO_CREDENTIAL;
+  $self->{gss_mech}  = $self->_call('gssmech') || gss_mech_krb5;
+
+  # reset properties for new session
+  $self->property(maxout => undef);
+  $self->property(ssf    => undef);
+
+  return $self->client_step('');
+}
+
+sub client_step {
+  my ($self, $challenge) = @_;
+  my $debug = $self->{debug};
+
+  my $status;
+
+  if ($self->{gss_state} == 0) {
+    my $outtok;
+    my $inflags = GSS_C_INTEG_FLAG | GSS_C_MUTUAL_FLAG;#todo:set according to ssf props
+    my $outflags;
+    $status = $self->{gss_ctx}->init($self->{gss_cred}, $self->{gss_name}, 
+			     $self->{gss_mech},
+			     $inflags, 
+			     0, GSS_C_NO_CHANNEL_BINDINGS, $challenge, undef, 
+			     $outtok, $outflags, undef);
+
+    print STDERR "state(0): ".
+		$status->generic_message.';'.$status->specific_message.
+		"; output token sz: ".length($outtok)."\n"
+      if ($debug & 1);
+
+    if (GSSAPI::Status::GSS_ERROR($status->major)) {
+      return $self->set_error("GSSAPI Error (init): ".$status);
+    }
+    if ($status->major == GSS_S_COMPLETE) {
+      $self->{gss_state} = 1;
+    }
+    return $outtok;
+  }
+  elsif ($self->{gss_state} == 1) {
+    # If the server has an empty output token when it COMPLETEs, Cyrus SASL
+    # kindly sends us that empty token. We need to ignore it, which introduces
+    # another round into the process. 
+    print STDERR "  state(1): challenge is EMPTY\n"
+      if ($debug and $challenge eq '');
+    return '' if ($challenge eq '');
+ 
+    my $unwrapped;
+    $status = $self->{gss_ctx}->unwrap($challenge, $unwrapped, undef, undef)
+      or return $self->set_error("GSSAPI Error (unwrap challenge): ".$status);
+
+    return $self->set_error("GSSAPI Error : invalid security layer token")
+      if (length($unwrapped) != 4);
+
+    # the security layers the server supports: bitmask of
+    #   1 = no security layer,
+    #   2 = integrity protection,
+    #   4 = confidelity protection
+    # which is encoded in the first octet of the response;
+    # the remote maximum buffer size is encoded in the next three octets
+    #
+    my $layer = ord(substr($unwrapped, 0, 1, chr(0)));
+    my ($rsz) = unpack('N',$unwrapped);
+
+    # get local receive buffer size
+    my $lsz = $self->property('maxbuf');
+
+    # choose security layer
+    my $choice = $self->_layer($layer,$rsz,$lsz);
+    return $self->set_error("GSSAPI Error: security too weak") unless $choice;
+
+    $self->{gss_layer} = $choice;
+
+    if ($choice > 1) {
+	# determine maximum plain text message size for peer's cipher buffer
+	my $psz;
+	$status = $self->{gss_ctx}->wrap_size_limit($choice & 4, 0, $rsz, $psz)
+	    or return $self->set_error("GSSAPI Error (wrap size): ".$status);
+	return $self->set_error("GSSAPI wrap size = 0") unless ($psz);
+	$self->property(maxout => $psz);
+	# set SSF property; if we have just integrity protection SSF is set
+	# to 1. If we have confidentiality, SSF would be an estimate of the
+	# strength of the actual encryption ciphers in use which is not
+	# available through the GSSAPI interface; for now just set it to
+	# the lowest value that signifies confidentiality.
+	$self->property(ssf => (($choice & 4) ? 2 : 1));
+    } else {
+	# our advertised buffer size should be 0 if no layer selected
+	$lsz = 0;
+	$self->property(ssf => 0);
+    }
+
+    print STDERR "state(1): layermask $layer,rsz $rsz,lsz $lsz,choice $choice\n"
+	if ($debug & 1);
+
+    my $message = pack('CCCC', $choice,
+			($lsz >> 16)&0xff, ($lsz >> 8)&0xff, $lsz&0xff);
+
+    # append authorization identity if we have one
+    my $authz = $self->_call('authname');
+    $message .= $authz if ($authz);
+
+    my $outtok;
+    $status = $self->{gss_ctx}->wrap(0, 0, $message, undef, $outtok)
+      or return $self->set_error("GSSAPI Error (wrap token): ".$status);
+    
+    $self->{gss_state} = 0;
+    return $outtok;
+  }
+}
+
+# default layer selection
+sub _layer {
+  my ($self, $theirmask, $rsz, $lsz) = @_;
+  my $maxssf = $self->property('maxssf') - $self->property('externalssf');
+  $maxssf = 0 if ($maxssf < 0);
+
+  my $minssf = $self->property('minssf') - $self->property('externalssf');
+  $minssf = 0 if ($minssf < 0);
+
+  return undef if ($maxssf < $minssf);    # sanity check
+
+  # ssf values > 1 mean integrity and confidentiality
+  # ssf == 1 means integrity but no confidentiality
+  # ssf < 1 means neither integrity nor confidentiality
+  # no security layer can be had if buffer size is 0
+  my $ourmask = 0;
+  $ourmask |= 1 if ($minssf < 1);
+  $ourmask |= 2 if ($minssf <= 1 and $maxssf >= 1);
+  $ourmask |= 4 if ($maxssf > 1);
+  $ourmask &= 1 unless ($rsz and $lsz);
+
+  # mask the bits they dont have
+  $ourmask &= $theirmask;
+
+  return $ourmask unless $self->property('COMPAT_CYRUSLIB_REPLY_MASK_BUG');
+	
+  # in cyrus sasl bug compat mode, select the highest bit set
+  return 4 if ($ourmask & 4);
+  return 2 if ($ourmask & 2);
+  return 1 if ($ourmask & 1);
+  return undef;
+}
+
+sub encode {  # input: self, plaintext buffer,length (length not used here)
+  my $self = shift;
+  my $wrapped;
+  my $status = $self->{gss_ctx}->wrap($self->{gss_layer} & 4, 0, $_[0], undef, $wrapped);
+  $self->set_error("GSSAPI Error (encode): " . $status), return
+    unless ($status);
+  return $wrapped;
+}
+
+sub decode {  # input: self, cipher buffer,length (length not used here)
+  my $self = shift;
+  my $unwrapped;
+  my $status = $self->{gss_ctx}->unwrap($_[0], $unwrapped, undef, undef);
+  $self->set_error("GSSAPI Error (decode): " . $status), return
+    unless ($status);
+  return $unwrapped;
+}
+
+__END__
+
+=head1 NAME
+
+Authen::SASL::Perl::GSSAPI - GSSAPI (Kerberosv5) Authentication class
+
+=head1 SYNOPSIS
+
+  use Authen::SASL qw(Perl);
+
+  $sasl = Authen::SASL->new( mechanism => 'GSSAPI' );
+
+  $sasl = Authen::SASL->new( mechanism => 'GSSAPI',
+ 			     callback => { pass => $mycred });
+
+  $sasl->client_start( $service, $host );
+
+=head1 DESCRIPTION
+
+This method implements the client part of the GSSAPI SASL algorithm,
+as described in RFC 2222 section 7.2.1 resp. draft-ietf-sasl-gssapi-XX.txt.
+
+With a valid Kerberos 5 credentials cache (aka TGT) it allows
+to connect to I<service>@I<host> given as the first two parameters
+to Authen::SASL's client_start() method.  Alternatively, a GSSAPI::Cred
+object can be passed in via the Authen::SASL callback hash using
+the `pass' key.
+
+Please note that this module does not currently implement a SASL
+security layer following authentication. Unless the connection is
+protected by other means, such as TLS, it will be vulnerable to
+man-in-the-middle attacks. If security layers are required, then the
+L<Authen::SASL::XS> GSSAPI module should be used instead.
+
+=head2 CALLBACK
+
+The callbacks used are:
+
+=over 4
+
+=item authname
+
+The authorization identity to be used in SASL exchange
+
+=item gssmech
+
+The GSS mechanism to be used in the connection
+
+=item pass 
+
+The GSS credentials to be used in the connection (optional)
+
+=back
+
+
+=head1 EXAMPLE
+
+ #! /usr/bin/perl -w
+
+ use strict;
+
+ use Net::LDAP 0.33;
+ use Authen::SASL 2.10;
+
+ # -------- Adjust to your environment --------
+ my $adhost      = 'theserver.bla.net';
+ my $ldap_base   = 'dc=bla,dc=net';
+ my $ldap_filter = '(&(sAMAccountName=BLAAGROL))';
+
+ my $sasl = Authen::SASL->new(mechanism => 'GSSAPI');
+ my $ldap;
+
+ eval {
+     $ldap = Net::LDAP->new($adhost,
+                            onerror => 'die')
+       or  die "Cannot connect to LDAP host '$adhost': '$@'";
+     $ldap->bind(sasl => $sasl);
+ };
+
+ if ($@) {
+     chomp $@;
+     die   "\nBind error         : $@",
+           "\nDetailed SASL error: ", $sasl->error,
+           "\nTerminated";
+ }
+
+ print "\nLDAP bind() succeeded, working in authenticated state";
+
+ my $mesg = $ldap->search(base   => $ldap_base,
+                          filter => $ldap_filter);
+
+ # -------- evaluate $mesg 
+
+=head2 PROPERTIES
+
+The properties used are:
+
+=over 4
+
+=item maxbuf
+
+The maximum buffer size for receiving cipher text
+
+=item minssf
+
+The minimum SSF value that should be provided by the SASL security layer.
+The default is 0
+
+=item maxssf
+
+The maximum SSF value that should be provided by the SASL security layer.
+The default is 2**31
+
+=item externalssf
+
+The SSF value provided by an underlying external security layer.
+The default is 0
+
+=item ssf
+
+The actual SSF value provided by the SASL security layer after the SASL
+authentication phase has been completed. This value is read-only and set
+by the implementation after the SASL authentication phase has been completed.
+
+=item maxout
+
+The maximum plaintext buffer size for sending data to the peer.
+This value is set by the implementation after the SASL authentication
+phase has been completed and a SASL security layer is in effect.
+
+=back
+
+
+=head1 SEE ALSO
+
+L<Authen::SASL>,
+L<Authen::SASL::Perl>
+
+=head1 AUTHORS
+
+Written by Simon Wilkinson, with patches and extensions by Achim Grolms
+and Peter Marschall.
+
+Please report any bugs, or post any suggestions, to the perl-ldap mailing list
+<perl-ldap@perl.org>
+
+=head1 COPYRIGHT 
+
+Copyright (c) 2006 Simon Wilkinson, Achim Grolms and Peter Marschall.
+All rights reserved. This program is free software; you can redistribute 
+it and/or modify it under the same terms as Perl itself.
+
+=cut

lib/Authen/SASL/Perl/LOGIN.pm

@@ -0,0 +1,221 @@
+## no critic (ClassHierarchies::ProhibitExplicitISA, Documentation::RequirePODUseEncodingUTF8, Documentation::RequirePodSections)
+# Copyright (c) 2002 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Authen::SASL::Perl::LOGIN;
+
+use 5.018; ## no critic (ProhibitImplicitImport)
+use strict;
+use warnings;
+use utf8;
+
+use vars qw($VERSION @ISA);
+
+$VERSION = '2.14';
+@ISA	 = qw(Authen::SASL::Perl);
+
+my %secflags = (
+	noanonymous => 1,
+);
+
+sub _order { return 1 }
+sub _secflags {
+  shift;
+  return scalar grep { $secflags{$_} } @_;
+}
+
+sub mechanism { return 'LOGIN' }
+
+sub client_start {
+  my $self = shift;
+  $self->{stage} = 0;
+  return '';
+}
+
+sub client_step {
+  my ($self, $string) = @_;
+
+  # XXX technically this is wrong. I might want to change that.
+  # spec say it's "staged" and that the content of the challenge doesn't
+  # matter
+  # actually, let's try
+  my $stage = ++$self->{stage};
+  if ($stage == 1) {
+      return $self->_call('user');
+  }
+  elsif ($stage == 2) {
+      return $self->_call('pass');
+  }
+  elsif ($stage == 3) {
+      $self->set_success;
+      return;
+  }
+  else {
+      return $self->set_error('Invalid sequence');
+  }
+}
+
+sub server_start {
+  my $self      = shift;
+  my $response  = shift;
+  my $user_cb   = shift || sub {};
+
+  $self->{answer}    = {};
+  $self->{stage}     = 0;
+  $self->{need_step} = 1;
+  $self->{error}     = undef;
+  $user_cb->('Username:');
+  return;
+}
+
+sub server_step {
+  my $self      = shift;
+  my $response  = shift;
+  my $user_cb   = shift || sub {};
+
+  my $stage = ++$self->{stage};
+
+  if ($stage == 1) {
+    unless (defined $response) {
+        $self->set_error('Invalid sequence (empty username)');
+        return $user_cb->();
+    }
+    $self->{answer}{user} = $response;
+    return $user_cb->('Password:');
+  }
+  elsif ($stage == 2) {
+    unless (defined $response) {
+        $self->set_error('Invalid sequence (empty pass)');
+        return $user_cb->();
+    }
+    $self->{answer}{pass} = $response;
+  }
+  else {
+    $self->set_error('Invalid sequence (end)');
+    return $user_cb->();
+  }
+  my $error = 'Credentials don\'t match';
+  my $answers = { user => $self->{answer}{user}, pass => $self->{answer}{pass} };
+  if (my $checkpass = $self->{callback}{checkpass}) {
+    my $cb = sub {
+      my $result = shift;
+      unless ($result) {
+        $self->set_error($error);
+      }
+      else {
+        $self->set_success;
+      }
+      $user_cb->();
+    };
+    $checkpass->($self => $answers => $cb );
+    return;
+  }
+  elsif (my $getsecret = $self->{callback}{getsecret}) {
+    my $cb = sub {
+      my $good_pass = shift;
+      if ($good_pass && $good_pass eq ($self->{answer}{pass} || '')) {
+        $self->set_success;
+      }
+      else {
+        $self->set_error($error);
+      }
+      $user_cb->();
+    };
+    $getsecret->($self => $answers => $cb );
+    return;
+  }
+  else {
+    $self->set_error($error);
+    $user_cb->();
+  }
+  return;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Authen::SASL::Perl::LOGIN - Login Authentication class
+
+=head1 SYNOPSIS
+
+  use Authen::SASL qw(Perl);
+
+  $sasl = Authen::SASL->new(
+    mechanism => 'LOGIN',
+    callback  => {
+      user => $user,
+      pass => $pass
+    },
+  );
+
+=head1 DESCRIPTION
+
+This method implements the client and server part of the LOGIN SASL algorithm,
+as described in IETF Draft draft-murchison-sasl-login-XX.txt.
+
+=head2 CALLBACK
+
+The callbacks used are:
+
+=head3 Client
+
+=over 4
+
+=item user
+
+The username to be used for authentication
+
+=item pass
+
+The user's password to be used for authentication
+
+=back
+
+=head3 Server
+
+=over4
+
+=item getsecret(username)
+
+returns the password associated with C<username>
+
+=item checkpass(username, password)
+
+returns true and false depending on the validity of the credentials passed
+in arguments.
+
+=back
+
+=head1 SEE ALSO
+
+L<Authen::SASL>,
+L<Authen::SASL::Perl>
+
+=head1 AUTHORS
+
+Software written by Graham Barr <gbarr@pobox.com>,
+documentation written by Peter Marschall <peter@adpm.de>.
+Server support by Yann Kerherve <yannk@cpan.org>
+
+Please report any bugs, or post any suggestions, to the perl-ldap mailing list
+<perl-ldap@perl.org>
+
+=head1 COPYRIGHT 
+
+Copyright (c) 2002-2004 Graham Barr.
+All rights reserved. This program is free software; you can redistribute 
+it and/or modify it under the same terms as Perl itself.
+
+Documentation Copyright (c) 2004 Peter Marschall.
+All rights reserved.  This documentation is distributed,
+and may be redistributed, under the same terms as Perl itself. 
+
+Server support Copyright (c) 2009 Yann Kerherve.
+All rights reserved. This program is free software; you can redistribute 
+it and/or modify it under the same terms as Perl itself.
+
+=cut

lib/Authen/SASL/Perl/PLAIN.pm

@@ -0,0 +1,189 @@
+## no critic (Documentation::RequirePODUseEncodingUTF8, Documentation::RequirePodSections)
+# Copyright (c) 2002 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Authen::SASL::Perl::PLAIN;
+
+use 5.018; ## no critic (ProhibitImplicitImport)
+use strict;
+use warnings;
+use utf8;
+
+use vars qw($VERSION @ISA);
+
+$VERSION = '2.14';
+@ISA	 = qw(Authen::SASL::Perl); ## no critic (ClassHierarchies::ProhibitExplicitISA)
+
+my %secflags = (
+	noanonymous => 1,
+);
+
+my @tokens = qw(authname user pass);
+
+sub _order { return 1 }
+sub _secflags {
+  shift;
+  return grep { $secflags{$_} } @_;
+}
+
+sub mechanism { return 'PLAIN' }
+
+sub client_start {
+  my $self = shift;
+
+  $self->{error}     = undef;
+  $self->{need_step} = 0;
+
+  my @parts = map {
+    my $v = $self->_call($_);
+    defined($v) ? $v : ''
+  } @tokens;
+
+  return join("\0", @parts);
+}
+
+sub server_start {
+  my $self      = shift;
+  my $response  = shift;
+  my $user_cb   = shift || sub {};
+
+  $self->{error} = undef;
+  return $self->set_error('No response: Credentials don\'t match')
+    unless defined $response;
+
+  my %parts;
+  @parts{@tokens} = split "\0", $response, scalar @tokens; ## no critic (BuiltinFunctions::ProhibitStringySplit)
+
+
+  # I'm not entirely sure of what I am doing
+  $self->{answer}{$_} = $parts{$_} for qw/authname user/;
+  my $error = 'Credentials don\'t match';
+
+  ## checkpass
+  if (my $checkpass = $self->callback('checkpass')) {
+    my $cb = sub {
+      my $result = shift;
+      unless ($result) {
+        $self->set_error($error);
+      }
+      else {
+        $self->set_success;
+      }
+      $user_cb->();
+    };
+    $checkpass->($self => { %parts } => $cb );
+    return;
+  }
+
+  ## getsecret
+  elsif (my $getsecret = $self->callback('getsecret')) {
+    my $cb = sub {
+      my $good_pass = shift;
+      if ($good_pass && $good_pass eq ($parts{pass} || '')) {
+        $self->set_success;
+      }
+      else {
+        $self->set_error($error);
+      }
+      $user_cb->();
+    };
+    $getsecret->( $self, { map { $_ => $parts{$_ } } qw/user authname/ }, $cb );
+    return;
+  }
+
+  ## error by default
+  else {
+    $self->set_error($error);
+    $user_cb->();
+  }
+
+  return;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Authen::SASL::Perl::PLAIN - Plain Login Authentication class
+
+=head1 SYNOPSIS
+
+  use Authen::SASL qw(Perl);
+
+  $sasl = Authen::SASL->new(
+    mechanism => 'PLAIN',
+    callback  => {
+      user => $user,
+      pass => $pass
+    },
+  );
+
+=head1 DESCRIPTION
+
+This method implements the client and server part of the PLAIN SASL algorithm,
+as described in RFC 2595 resp. IETF Draft draft-ietf-sasl-plain-XX.txt
+
+=head2 CALLBACK
+
+The callbacks used are:
+
+=head3 Client
+
+=over 4
+
+=item authname
+
+The authorization id to use after successful authentication (client)
+
+=item user
+
+The username to be used for authentication (client)
+
+=item pass
+
+The user's password to be used for authentication.
+
+=back
+
+=head3 Server
+
+=over4
+
+=item checkpass(username, password, realm)
+
+returns true and false depending on the validity of the credentials passed
+in arguments.
+
+=back
+
+=head1 SEE ALSO
+
+L<Authen::SASL>,
+L<Authen::SASL::Perl>
+
+=head1 AUTHORS
+
+Software written by Graham Barr <gbarr@pobox.com>,
+documentation written by Peter Marschall <peter@adpm.de>.
+
+Please report any bugs, or post any suggestions, to the perl-ldap mailing list
+<perl-ldap@perl.org>
+
+=head1 COPYRIGHT 
+
+Copyright (c) 2002-2004 Graham Barr.
+All rights reserved. This program is free software; you can redistribute 
+it and/or modify it under the same terms as Perl itself.
+
+Documentation Copyright (c) 2004 Peter Marschall.
+All rights reserved.  This documentation is distributed,
+and may be redistributed, under the same terms as Perl itself. 
+
+Server support Copyright (c) 2009 Yann Kerherve.
+All rights reserved. This program is free software; you can redistribute
+it and/or modify it under the same terms as Perl itself.
+
+=cut

lib/BotLib.pm

@@ -0,0 +1,387 @@
+package BotLib;
+
+use 5.018; ## no critic (ProhibitImplicitImport)
+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::Anek qw (Anek);
+use BotLib::Archeologist qw (Dig);
+use BotLib::Buni qw (Buni);
+use BotLib::Conf qw (LoadConf);
+use BotLib::Drink qw (Drink);
+use BotLib::Fisher qw (Fish);
+use BotLib::Fortune qw (Fortune);
+use BotLib::Fox qw (Fox);
+use BotLib::Friday qw (Friday);
+use BotLib::Image qw (Rabbit Owl Frog Horse Snail);
+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);
+
+use version; our $VERSION = qw (1.0);
+use Exporter qw (import);
+our @EXPORT_OK = qw (Command RandomCommonPhrase RealJID);
+
+sub RandomCommonPhrase ();
+sub Command;
+sub RealJID(%);
+
+my $c = LoadConf ();
+
+sub RandomCommonPhrase () {
+	my @myphrase = (
+		'Так, блядь...',
+		'*Закатывает рукава* И ради этого ты меня позвал?',
+		'Ну чего ты начинаешь, нормально же общались',
+		'Повтори свой вопрос, не поняла',
+		'Выйди и зайди нормально',
+		'Я подумаю',
+		'Даже не знаю что на это ответить',
+		'Ты упал такие вопросы девочке задавать?',
+		'Можно и так, но не уверена',
+		'А как ты думаешь?',
+	);
+
+	return $myphrase[irand ($#myphrase + 1)];
+}
+
+sub Command {
+	my %hash = @_;
+	my $bot = $hash{bot_object};
+	my $text = $hash{body};
+	my %jid = RealJID (%hash);
+	my $chattername = $jid{'name'};
+	my $chatid;
+
+	if ($hash{'type'} eq 'groupchat') {
+		$chatid = utf2sha1 $hash{'reply_to'};
+	} else {
+		$chatid = utf2sha1 $jid{'name'};
+	}
+
+	$chatid =~ s/\//-/xmsg;
+	%jid = (); undef %jid;
+	my $csign = $c->{jabberbot}->{aleesa}->{csign};
+
+	my $reply;
+	my $cmd = substr $text, length ($csign);
+
+	if (($cmd =~ /rum\s?/u)  ||  ($cmd =~ /ром\s?/u)) {
+		my $target = $chattername;
+
+		if ($hash{'type'} eq 'groupchat') {
+			if ($cmd =~ /rum\s+(.*)/u) {
+				$target = $1 if ($1 ne '');
+			} elsif ($cmd =~ /ром\s+(.*)/u) {
+				$target = $1 if ($1 ne '');
+			}
+		}
+
+		$reply = '/me притаскивает на подносе стопку рома для ' . $target . ', края стопки искрятся кристаллами соли.';
+	} elsif (($cmd =~ /vodka\s?/u)  ||  ($cmd =~ /водка\s?/u)) {
+		my $target = $chattername;
+
+		if ($hash{'type'} eq 'groupchat') {
+			if ($cmd =~ /vodka\s+(.*)/u) {
+				$target = $1 if ($1 ne '');
+			} elsif ($cmd =~ /водка\s+(.*)/u) {
+				$target = $1 if ($1 ne '');
+			}
+		}
+
+		$reply = '/me подаёт шот водки с небольшим маринованным огурчиком на блюдце для ' . $target . '. Из огурчика торчит небольшая вилочка.';
+	} elsif (($cmd =~ /^beer\s?/u)  ||  ($cmd =~ /^пиво\s?/u)) {
+		my $target = $chattername;
+
+		if ($hash{'type'} eq 'groupchat') {
+			if ($cmd =~ /^beer\s+(.*)/u) {
+				$target = $1 if ($1 ne '');
+			} elsif ($cmd =~ /^пиво\s+(.*)/u) {
+				$target = $1 if ($1 ne '');
+			}
+		}
+
+		$reply = '/me бахает об стол перед ' . $target . ' кружкой холодного пива, часть пенной шапки сползает по запотевшей стенке кружки.';
+	} elsif ($cmd =~ /^tequila\s?/u) {
+		my $target = $chattername;
+
+		if ($hash{'type'} eq 'groupchat') {
+			if ($cmd =~ /^tequila\s+(.*)/u) {
+				$target = $1 if ($1 ne '');
+			}
+		}
+
+		$reply = '/me ставит рядом с ' . $target . ' шот текилы, аккуратно на ребро стопки насаживает дольку лайма и ставит кофейное блюдце с горочкой соли.';
+	} elsif ($cmd =~ /^текила\s?/u) {
+		my $target = $chattername;
+
+		if ($hash{'type'} eq 'groupchat') {
+			if ($cmd =~ /^текила\s+(.*)/u) {
+				$target = $1 if ($1 ne '');
+			}
+		}
+
+		$reply = '/me ставит рядом с ' . $target . ' шот текилы, аккуратно на ребро стопки насаживает дольку лайма и ставит кофейное блюдце с горочкой соли.';
+	} elsif ($cmd =~ /^whisky\s?/u) {
+		my $target = $chattername;
+
+		if ($hash{'type'} eq 'groupchat') {
+			if ($cmd =~ /^whisky\s+(.*)/u) {
+				$target = $1 if ($1 ne '');
+			}
+		}
+
+		$reply = '/me демонстративно достаёт из морозилки пару кубических камушков, бросает их в толстодонный стакан и аккуратно наливает Jack Daniels. Запускает стакан вдоль барной стойки, он останавливается около ' . $target . '.';
+	} elsif ($cmd =~ /^виски\s?/u) {
+		my $target = $chattername;
+
+		if ($hash{'type'} eq 'groupchat') {
+			if ($cmd =~ /^виски\s+(.*)/u) {
+				$target = $1 if ($1 ne '');
+			}
+		}
+
+		$reply = '/me демонстративно достаёт из морозилки пару кубических камушков, бросает их в толстодонный стакан и аккуратно наливает Jack Daniels. Запускает стакан вдоль барной стойки, он останавливается около ' . $target . '.';
+	} elsif ($cmd =~ /^absinthe\s?/u) {
+		my $target = $chattername;
+
+		if ($hash{'type'} eq 'groupchat') {
+			if ($cmd =~ /^absinthe\s+(.*)/u) {
+				$target = $1 if ($1 ne '');
+			}
+		}
+
+		$reply = '/me наливает абсент в стопку. Смочив кубик сахара в абсенте кладёт его на дырявую ложечку и пожигает. Как только пламя потухнет, ' . $bot->{'alias'} . ' размешивает оплавившийся кубик в абсенте и подносит стопку ' . $target . '.';
+	} elsif ($cmd =~ /^абсент\s?/u) {
+		my $target = $chattername;
+
+		if ($hash{'type'} eq 'groupchat') {
+			if ($cmd =~ /^абсент\s+(.*)/u) {
+				$target = $1 if ($1 ne '');
+			}
+		}
+
+		$reply = '/me наливает абсент в стопку. Смочив кубик сахара в абсенте кладёт его на дырявую ложечку и пожигает. Как только пламя потухнет, ' . $bot->{'alias'} . ' размешивает оплавившийся кубик в абсенте и подносит стопку ' . $target . '.';
+	} elsif ($cmd =~ /^[wп]\s+.+/u) {
+		$cmd =~ /^[wп]\s+(.*)/;
+		my $city = $1; ## no critic (RegularExpressions::ProhibitCaptureWithoutTest)
+		$reply = Weather ($city) =~ tr/\n/ /r;
+	} elsif ($cmd eq 'anek'  ||  $cmd eq 'анек' || $cmd eq 'анекдот' ) {
+		$reply = Anek ();
+	} elsif ($cmd eq 'coin' || $cmd eq 'монетка') {
+		if (rand (101) < 0.016) {
+			$reply = 'ребро';
+		} else {
+			if (irand (2) == 0) {
+				if (irand (2) == 0) {
+					$reply = 'орёл';
+				} else {
+					$reply = 'аверс';
+				}
+			} else {
+				if (irand (2) == 0) {
+					$reply = 'решка';
+				} else {
+					$reply = 'реверс';
+				}
+			}
+		}
+	} elsif ($cmd eq 'roll'  ||  $cmd eq 'dice'  ||  $cmd eq 'кости') {
+		$reply = sprintf 'На первой кости выпало %d, а на второй — %d.', irand (6) + 1, irand (6) + 1;
+	} elsif ($cmd eq 'version'  ||  $cmd eq 'ver'  ||  $cmd eq 'версия') {
+		$reply = 'Версия три.чего-то_там.чего-то_там';
+	} elsif ($cmd eq 'help'  ||  $cmd eq 'помощь') {
+		$reply = <<"EOL";
+
+${csign}help | ${csign}помощь             - это сообщение
+${csign}anek | ${csign}анек | ${csign}анекдот    - рандомный анекдот с anekdot.ru
+${csign}buni                       - комикс-стрип hapi buni
+${csign}bunny                      - кролик
+${csign}rabbit | ${csign}кролик           - кролик
+${csign}cat | ${csign}кис                 - кошечка
+${csign}coin | ${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}roll | ${csign}dice | ${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
+EOL
+
+	} elsif ($cmd eq 'lat'  ||  $cmd eq 'лат') {
+		$reply = Lat ();
+	} elsif ($cmd eq 'cat'  ||  $cmd eq 'кис') {
+		$reply = Kitty ();
+	} elsif ($cmd eq 'fox'  ||  $cmd eq 'лис') {
+		$reply = Fox ();
+	} elsif ($cmd eq 'frog'  ||  $cmd eq 'лягушка') {
+		$reply = Frog ();
+	} elsif ($cmd eq 'horse'  ||  $cmd eq 'лошадь'  || $cmd eq 'лошадка') {
+		$reply = Horse ();
+	} elsif ($cmd eq 'snail'  ||  $cmd eq 'улитка') {
+		$reply = Snail ();
+	} elsif ($cmd eq 'dig'  ||  $cmd eq 'копать') {
+		$reply = Dig ($chattername);
+	} elsif ($cmd eq 'fish'  ||  $cmd eq 'fisher'  ||  $cmd eq 'рыба'  ||  $cmd eq 'рыбка'  ||  $cmd eq 'рыбалка') {
+		$reply = Fish ($chattername);
+	} elsif ($cmd eq 'buni') {
+		$reply = Buni ();
+	} elsif ($cmd eq 'xkcd') {
+		$reply = Xkcd ();
+	} elsif ($cmd eq 'monkeyuser') {
+		$reply = Monkeyuser ();
+	} elsif ($cmd eq 'drink' || $cmd eq 'праздник') {
+		$reply = Drink ();
+	} elsif ($cmd eq 'bunny' || $cmd eq 'rabbit' || $cmd eq 'кролик') {
+		$reply = Rabbit ();
+	} elsif ($cmd eq 'owl' || $cmd eq 'сова') {
+		$reply = Owl ();
+	} elsif ($cmd =~ /^karma\s*/  ||  $cmd =~ /^карма\s*/) {
+		my $mytext = '';
+
+		if (length ($cmd) > length ('karma')) {
+			$mytext = substr $cmd, length ('karma');
+			while ($mytext =~ /\n$/) { chomp $mytext }
+			$mytext = trim $mytext;
+		} elsif (length ($cmd) > length ('карма')) {
+			$mytext = substr $cmd, length ('карма');
+			while ($mytext =~ /\n$/) { chomp $mytext }
+			$mytext = trim $mytext;
+		} else {
+			$mytext = '';
+		}
+
+		$reply = KarmaGet ($chatid, $mytext);
+	} elsif ($cmd eq 'friday'  ||  $cmd eq 'пятница') {
+		$reply = Friday ();
+	} elsif ($cmd eq 'proverb'  ||  $cmd eq 'пословица') {
+		$reply = Proverb ();
+	} elsif ($cmd eq 'fortune'  ||  $cmd eq 'фортунка'  ||  $cmd eq 'f'  ||  $cmd eq 'ф') {
+		my $phrase = Fortune ();
+		# workaround Net::Jabber::Bot outgoing message ![:print:] replacement
+		$phrase =~ s/\s\s+\-\-/\n \-\-/xmsg;
+		$reply = $phrase;
+	} elsif ($cmd eq 'ping') {
+		$reply = 'Pong.';
+	} elsif ($cmd eq 'пинг') {
+		$reply = 'Понг.';
+	} elsif ($cmd eq 'kde' || $cmd eq 'кде') {
+		my @phrases = (
+			'Нет, я не буду поднимать вам плазму.',
+			'Повторяйте эту мантру по утрам не менее 5 раз: "Плазма не падает." И, возможно, она перестанет у вас падать.',
+		);
+
+		$reply = $phrases[irand ($#phrases + 1)];
+	}
+
+	return $reply;
+}
+
+# in this particular case real jid is really hidden :) and i hope that i found where it is hiding.
+sub RealJID (%) {
+	my %hash = @_;
+	my $bot = $hash{'bot_object'};
+	my $myjid = $hash{'from_full'}; # in case of real jid myjid is name@server/resource in case of "groupchat" jid it is group@conf_server/name
+	my $presencedb = $bot->{'jabber_client'}->{'PRESENCEDB'};
+	my %result;
+
+	# there is missing case where user' name part of jid same as chat name (sic!)
+
+	# in case of groupchat we have to compare reply_to and 1-st part of myjid (one that before slash)
+	# in case 1-on-1 chat we have to compare 2-nd component of myjid (that between @ and /) and conference server
+	#    assuming that bot sits only on same conference server where bot is registered
+	if (
+			(($hash{'reply_to'} eq (split (/\//, $myjid))[0]) && ($hash{'type'} eq 'groupchat')) ||
+			(($bot->{'conference_server'} eq (split (/\@/, (split (/\//, $myjid))[0]))[1]) && ($hash{'type'} eq 'chat'))
+		) {
+		foreach my $knownjid (keys %{$presencedb}) {
+			foreach my $prionum (keys %{$presencedb->{$knownjid}->{'priorities'}}) {
+				foreach my $presence (@{$presencedb->{$knownjid}->{'priorities'}->{$prionum}}) {
+					if ($presence->{'presence'}->{'TREE'}->{'ATTRIBS'}->{'from'} eq $myjid) {
+						foreach my $child (@{$presence->{'presence'}->{'TREE'}->{'CHILDREN'}}) {
+							() = eval {
+								$child->{'CHILDREN'};
+							};
+
+							unless ($EVAL_ERROR) {
+								foreach my $subchild ($child->{'CHILDREN'}) {
+									foreach my $elem (@{$subchild}) {
+										() = eval {
+											$elem->{'ATTRIBS'};
+										};
+
+										unless ($EVAL_ERROR) {
+											() = eval {
+												$elem->{'ATTRIBS'}->{'jid'};
+											};
+
+											unless ($EVAL_ERROR) {
+												if (defined $elem->{'ATTRIBS'}->{'jid'}) {
+													%result = (
+														'fulljid' => $elem->{'ATTRIBS'}->{'jid'},
+														'jid' => (split (/\//, $elem->{'ATTRIBS'}->{'jid'})) [0],
+														'name' => (split (/\@/, $elem->{'ATTRIBS'}->{'jid'})) [0],
+													);
+
+													return %result;
+												}
+											}
+										}
+									}
+								}
+							}
+						}
+					}
+				}
+			}
+		}
+
+		# we tried hard :( and if we here, assume that we have no permissions to to guess real jid in chat
+		%result = (
+			'fulljid' => $myjid,
+			'jid' => $myjid,
+			'name' => (split (/\//, $myjid))[1],
+		);
+	} else {
+		# looks like it is correct real jid, assume that conference server and main server reside on different domains
+		# at least i hope that this assumption correct
+		%result = (
+			'fulljid' => $myjid,
+			'jid' => (split (/\//, $myjid))[0],
+			'name' => (split (/\@/, $myjid))[0],
+		);
+	}
+
+	return %result;
+}
+
+1;
+
+# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

lib/BotLib/Anek.pm

@@ -0,0 +1,89 @@
+package BotLib::Anek;
+
+use 5.018;  ## no critic (ProhibitImplicitImport)
+use strict;
+use warnings;
+use utf8;
+use open qw (:std :utf8);
+use English qw ( -no_match_vars );
+use Encode qw (decode);
+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);
+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');
+
+			if ($r->{success}) {
+				last;
+			}
+
+			sleep 2;
+		}
+
+		if ($r->{success}) {
+			my $json;
+			my $response_text = decode ('UTF-8', $r->{content});
+			my @text = split /\n/, $response_text;
+
+			while (my $str = pop @text) {
+				if ($str =~ /^var anekdot_texts \= JSON/) {
+					$str = (split /JSON\.parse\(\'/, $str, 2)[1];
+
+					if (defined $str && length ($str) > 10) {
+						$json = (split /\';\)/, $str, 2)[0];
+						last;
+					}
+				}
+			}
+
+			if (defined $json && length ($json) > 10) {
+				$json =~ s/\\"/"/g;
+				$json =~ s/\\\\"/\\"/g;
+				$json = substr $json, 0, -3;
+
+				my $anek = eval { ${JSON::XS->new->relaxed->decode ($json)}[0] };
+
+				if (defined $anek) {
+					my @anek = split /<br>/, $anek;
+					$ret = join "\n", @anek;
+
+					if (length ($ret) > 1) {
+						$got_anek = 1;
+					}
+				} else {
+					$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 {
+			$log->warn (sprintf '[WARN] anekdot.ru server return status %s with message: %s', $r->code, $r->message);
+		}
+
+		if ($got_anek) {
+			last;
+		}
+	}
+
+	return $ret;
+}
+
+1;
+
+# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

lib/BotLib/Archeologist.pm

@@ -0,0 +1,126 @@
+package BotLib::Archeologist;
+
+use 5.018; ## no critic (ProhibitImplicitImport)
+use strict;
+use warnings;
+use utf8;
+use open qw (:std :utf8);
+use English qw ( -no_match_vars );
+use Math::Random::Secure qw (irand);
+
+use version; our $VERSION = qw (1.0);
+use Exporter qw (import);
+our @EXPORT_OK = qw (Dig);
+
+sub Dig {
+	my $name = shift;
+
+	my @artifact = (
+		'амулет Мерлина',
+		'библиотеку Ивана Грозного',
+		'деревянную плошку',
+		'диплока',
+		'доски Ноева Ковчега',
+		'древний презерватив из бараньей кишки',
+		'икону',
+		'инсталятор Windows 3.11',
+		'истлевший гроб',
+		'каменный топор',
+		'клад со златом-серебром',
+		'кривой нож',
+		'ледяную глыбу',
+		'лунный грунт',
+		'мамонта',
+		'мамонтенка',
+		'метеорит',
+		'мумию фараона Тутанхамона',
+		'носки прапорщика (поставит в угол)',
+		'обломки грузинской керамики',
+		'птеродактиля',
+		'рубль с Лениным',
+		'рыцарские доспехи',
+		'синий мох',
+		'скелет',
+		'скелет собаки по кличке Беня',
+		'тиранозавтра',
+		'тотем индейцев',
+		'трубу с туркменским газом',
+		'скорбь еврейского народа',
+		'залежи активированного угля',
+		'не очень новый завет',
+		'мать леннарта поттеринга',
+		'руководство "начинающему археологу"',
+		'слово о полку игореве и дело о полку игореве, вместе с игорем',
+		'телепрограмму канала A-one',
+		'могилу искателя могил',
+		'заплесневевший кусок хлеба',
+		'преемник радиоприемника',
+		'глушитель от ВАЗ-2106',
+		'чувство удовлетворения',
+		'крота',
+		'воспоминания о былой любви',
+		'грязистор',
+		'египетское мумиё',
+		'окаменелый камень',
+		'кладку яиц рептилоида',
+		'яму',
+		'чеснок и стрелы',
+		'доллар по 30',
+		'несмазанные скрижали',
+		'четырелобита',
+		'чучело тролля',
+		'целое ничего',
+	);
+
+	my @location = (
+		'в архивах',
+		'в гималаях',
+		'в интернете',
+		'в кармане',
+		'в клумбе',
+		'в лунном кратере',
+		'во льдах арктики',
+		'в морге',
+		'в окрестностях погоста',
+		'в песочнице',
+		'в пустыне Гоби',
+		'в пустыне Сахаре',
+		'в русле высохшей реки',
+		'в собственной памяти',
+		'в старом сортире',
+		'в углу',
+		'в цветочном горшке',
+		'на бабушкином огороде',
+		'на винчестере',
+		'на горе Арарат',
+		'на горном плато',
+		'на дне моря',
+		'на необитаемом острове',
+		'на первом слое сумрака',
+		'на просторах Украины',
+	);
+
+	my $find_probability = irand 100;
+	my $success_probability = irand 100;
+	my $artifact_age = irand 15000;
+
+	if ($find_probability <= 20) {
+		return sprintf 'По уши закопавшись %s, %s, нифига вы не выкопали! Может повезет в другом месте?', $location[irand ($#location + 1)], $name;
+	}
+
+	my $phrase = sprintf "Вы начали раскопки %s и усиленно роете лопатами, экскаватором...\n", $location[irand ($#location + 1)];
+	$phrase .= "Вам кажется что ваш совочек ударился обо что-то твердое. Может, это клад?!\n\n";
+
+	if ($success_probability <= 25) {
+		$phrase .= sprintf '%s стал лучшим археологом, выкопав %s! возраст артефакта - %s лет!', $name, $artifact[irand ($#artifact + 1)], $artifact_age;
+	} else {
+		$phrase .= sprintf "Поздравляю, %s! Вы только что выкопали %s, возраст - %s лет!\n", $name, $artifact[irand ($#artifact + 1)], $artifact_age;
+		$phrase .= sprintf 'Извини %s, но на артефакт это не тянет! Однако, попытка хорошая!', $name;
+	}
+
+	return $phrase;
+}
+
+1;
+
+# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

lib/BotLib/Buni.pm

@@ -0,0 +1,58 @@
+package BotLib::Buni;
+
+use 5.018; ## no critic (ProhibitImplicitImport)
+use strict;
+use warnings;
+use utf8;
+use open qw (:std :utf8);
+use English qw ( -no_match_vars );
+use HTTP::Tiny ();
+use HTML::TokeParser ();
+use Log::Any qw ($log);
+
+use version; our $VERSION = qw (1.0);
+use Exporter qw (import);
+our @EXPORT_OK = qw (Buni);
+
+sub Buni {
+	my $r;
+	my $ret = 'Нету Buni';
+
+	for (1..3) {
+		my $http = HTTP::Tiny->new (timeout => 3);
+		$r = $http->get ('http://www.bunicomic.com/?random&nocache=1');
+
+		if ($r->{success}) {
+			last;
+		}
+
+		sleep 2;
+	}
+
+	if ($r->{success}) {
+		my $p = HTML::TokeParser->new(\$r->{content});
+		my @a;
+
+		# additional {} required in order "last" to work properly :)
+		{
+			do {
+				$#a = -1;
+				@a = $p->get_tag ('meta'); ## no critic (Variables::RequireLocalizedPunctuationVars)
+
+				if (defined $a[0][1]->{property} && $a[0][1]->{property} eq 'og:image') {
+					$ret = $a[0][1]->{content};
+					last;
+				}
+
+			} while ($#{$a[0]} > 1);
+		}
+	} else {
+		$log->warn (sprintf '[WARN] Server return status %s with message: %s', $r->{status}, $r->{reason});
+	}
+
+	return $ret;
+}
+
+1;
+
+# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

lib/BotLib/Conf.pm

@@ -0,0 +1,43 @@
+package BotLib::Conf;
+# loads config
+
+use 5.018; ## no critic (ProhibitImplicitImport)
+use strict;
+use warnings;
+use utf8;
+use open qw (:std :utf8);
+use English qw ( -no_match_vars );
+use JSON::XS ();
+use Log::Any qw ($log);
+
+use version; our $VERSION = qw (1.0);
+use Exporter qw (import);
+our @EXPORT_OK = qw (LoadConf);
+
+sub LoadConf {
+	my $c = 'data/config.json';
+	open my $CH, '<', $c or die "[FATA] No conf at $c: $OS_ERROR\n";
+	my $len = (stat $c) [7];
+	my $json;
+	use bytes;
+	my $readlen = read $CH, $json, $len;
+	no bytes;
+
+	unless ($readlen) {
+		close $CH;                                   ## no critic (InputOutput::RequireCheckedSyscalls
+		$log->fata ("[FATA] Unable to read $c: $OS_ERROR");
+	}
+
+	if ($readlen != $len) {
+		close $CH;                                   ## no critic (InputOutput::RequireCheckedSyscalls
+		$log->fata ("[FATA] File $c is $len bytes on disk, but we read only $readlen bytes");
+	}
+
+	close $CH;                                       ## no critic (InputOutput::RequireCheckedSyscalls
+	my $j = JSON::XS->new->utf8->relaxed;
+	return $j->decode ($json);
+}
+
+1;
+
+# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

lib/BotLib/Drink.pm

@@ -0,0 +1,128 @@
+package BotLib::Drink;
+
+use 5.018; ## no critic (ProhibitImplicitImport)
+use strict;
+use warnings;
+use utf8;
+use open qw (:std :utf8);
+use English qw ( -no_match_vars );
+use Encode qw (decode);
+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);
+
+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 = 'https://prazdniki-segodnya.ru/';
+		my $r;
+
+		for (1..3) {
+			my $http = HTTP::Tiny->new (timeout => 3);
+			$r = $http->get ($url, {'Accept-Charset' => 'utf-8', 'Accept-Language' => 'ru-RU'});
+
+			if ($r->{success}) {
+				last;
+			}
+
+			sleep 2;
+		}
+
+		if ($r->{success}) {
+			my $p = HTML::TokeParser->new (\$r->{content});
+			my @a;
+			my %holiday;
+
+			do {
+				$#a = -1;
+				@a = $p->get_tag ('div'); ## no critic (Variables::RequireLocalizedPunctuationVars)
+
+				if ($#{$a[0]} > 2) {
+					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 (int (keys %holiday) > 0) {
+				$ret = join "\n", sort (keys %holiday);
+			}
+		} else {
+			$log->warn (sprintf '[WARN] Server return status %s with message: %s', $r->{status}, $r->{reason});
+			return undef;
+		}
+
+		return $ret;
+	};
+
+	my $cache = CHI->new (
+		driver => 'BerkeleyDB',
+		root_dir => $c->{cachedir},
+		namespace => __PACKAGE__,
+	);
+
+	# Those POSIX assholes just forgot to add unix timestamps without TZ offset, so...
+	my ($mday, $mon, $year) = (gmtime ())[3, 4, 5];
+	my $offset = strftime ('%z', gmtime ());
+	my $offsetMinutes = (substr $offset, -2) * 60;
+	my $offsetHours = (substr $offset, 1, 2) * 60 * 60;
+	my $offsetSign;
+
+	if ((substr $offset, 0, 1) eq '+') {
+		$offsetSign = 1;
+	}
+
+	my $expirationDate = DateTime->new (
+		year => $year + 1900,
+		month => $mon + 1,
+		day => $mday,
+		hour => 0,
+		minute => 0,
+		second => 0,
+	)->add (days => 1)->strftime ('%s');
+
+	if ((substr $offset, 0, 1) eq '+') {
+		$expirationDate = $expirationDate - $offsetHours - $offsetMinutes;
+	} else {
+		$expirationDate = $expirationDate + $offsetHours + $offsetMinutes;
+	}
+
+	# Okay, now we have correct unix timestamp, heh
+	my $res = $cache->compute (
+		'Holiday',
+		{ expires_at => $expirationDate },
+		$drinkCallBack,
+	);
+
+	if (defined $res && $res ne '') {
+		return $res;
+	} else {
+		return 'Не знаю праздников - вджобываю весь день на шахтах, как проклятая.';
+	}
+}
+
+1;
+
+# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

lib/BotLib/Fisher.pm

@@ -0,0 +1,133 @@
+package BotLib::Fisher;
+
+use 5.018; ## no critic (ProhibitImplicitImport)
+use strict;
+use warnings;
+use utf8;
+use open qw (:std :utf8);
+use English qw ( -no_match_vars );
+use Math::Random::Secure qw (irand);
+
+use version; our $VERSION = qw (1.0);
+use Exporter qw (import);
+our @EXPORT_OK = qw (Fish);
+
+
+sub Fish {
+	my $name = shift;
+
+	my @artifact = (
+		'семикрылого чешуйчатого пятихуя',
+		'разумного конденсатора',
+		'сальмонеллу',
+		'селёдку',
+		'желтоперого тунца',
+		'розовую сальмонеллу',
+		'голавля',
+		'барбуса',
+		'окуня',
+		'верхоплавку',
+		'коричневую форель',
+		'полярника',
+		'плотву',
+		'зубатку',
+		'солнечную рыбу',
+		'старую шину',
+		'скользкую корягу',
+		'лампу джина',
+		'любовное послание в бутылке',
+		'старое бревно',
+		'резиновый сапог',
+		'труп',
+		'Лох-Несское чудовище',
+		'старую рыбацкую приманку',
+		'кусок Титаника',
+		'обломок Атлантиды',
+		'кита',
+		'кальмара',
+		'дельфина',
+		'ската',
+		'подводную лодку',
+		'медузу',
+		'морскую звезду',
+		'электрического угря',
+		'большую белую акулу',
+		'аквалангиста',
+		'монстра',
+		'вируса',
+		'сырую пачку сигарет',
+		'водоросли',
+		'якорь от лодки',
+		'водяного',
+		'русалку',
+		'палтуса',
+		'труп собаки по кличке Беня',
+		'олигофрена Проню',
+		'огеймера Фишкина',
+	);
+
+	my @location = (
+		'в поток',
+		'в озеро',
+		'в реку',
+		'в северерный ледовитый океан',
+		'в индийский океан',
+		'в биде',
+		'в детский плавательный бассейн',
+		'в туалет',
+		'в кучу рвоты',
+		'в лужу мочи',
+		'в раковину',
+		'в слив ванной',
+		'в лужу грязи',
+		'в ведро воды',
+		'в бутылку с водкой',
+		'в ванную',
+		'в бочку с дождевой водой',
+		'в аквариум',
+		'в сугроб',
+		'в водопад',
+		'в чашку кофе',
+		'в стакан молока',
+		'в черную дыру',
+		'дно Удомельского реактора',
+		'на Марс',
+		'в соседнюю галактуку',
+		'к соседу на балкон',
+		'далеко-далеко',
+		'далеко и надолго',
+		'на крышу дома',
+	);
+
+	my @material = (
+		'бамбуковую',
+		'фиберглассовую',
+		'карбоновую',
+		'композитную',
+	);
+
+	my $find_probability = irand 100;
+	my $success_probability = irand 100;
+	my $weight = irand 7000;
+
+	my $phrase = sprintf "Вы забрасываете %s удочку %s.\nВы чувствуете поклевку и начинаете быстро тащить что-то.\n", $material[irand ($#material + 1)], $location[irand ($#location + 1)];
+
+	if ($find_probability <= 20) {
+		$phrase .= sprintf 'Черт, твоя рыбка сорвалась, %s! Не беда, может потом повезет?', $name;
+		return $phrase;
+	}
+
+	$phrase .= sprintf "Поздравляю, %s! Вы только что поймали %s! аж на %d кило!\n\n", $name, $artifact[irand ($#artifact + 1)], $weight;
+
+	if ($success_probability <= 25) {
+		$phrase .= sprintf 'Ё-мое!!! А это ведь новый рекорд! Продолжай в том же духе, %s!', $name;
+	} else {
+		$phrase .= sprintf 'Извини %s, но это не новый рекорд! Однако, хорошая попытка!', $name;
+	}
+
+	return $phrase;
+}
+
+1;
+
+# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

lib/BotLib/Fortune.pm

@@ -0,0 +1,85 @@
+package BotLib::Fortune;
+# Any fortune_mod sources are suitable. Text file with "\n%\n" sentence delimiters.
+
+use 5.018; ## no critic (ProhibitImplicitImport)
+use strict;
+use warnings;
+use utf8;
+use open qw (:std :utf8);
+use English qw ( -no_match_vars );
+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);
+
+use version; our $VERSION = qw (1.0);
+use Exporter qw (import);
+our @EXPORT_OK = qw (Seed Fortune);
+
+my $c = LoadConf ();
+my $dir = $c->{fortune}->{dir};
+my $srcdir = $c->{fortune}->{srcdir};
+
+sub Seed () {
+	unless (-d $dir) {
+		make_path ($dir)  ||  croak "Unable to create $dir: $OS_ERROR";
+	}
+
+	my $backingfile = sprintf '%s/fortune.sqlite', $dir;
+
+	if (-e $backingfile) {
+		unlink $backingfile   ||  croak "Unable to remove $backingfile: $OS_ERROR\n";
+	}
+
+	tie my @fortune, 'SQLite_File', $backingfile  ||  croak "Unable to tie to $backingfile: $OS_ERROR\n";
+	opendir (my $srcdirhandle, $srcdir)  ||  croak "Unable to open $srcdir: $OS_ERROR";
+
+	while (my $fortunefile = readdir $srcdirhandle) {
+		my $srcfile = sprintf '%s/%s', $srcdir, $fortunefile;
+
+		unless (-e $srcfile) {
+			next;
+		}
+
+		if ($fortunefile =~ m/\./) {
+			next ;
+		}
+
+		open (my $fh, '<', $srcfile)  ||  croak "Unable to open $srcfile, $OS_ERROR\n";
+		# set correct phrase delimiter
+		local $INPUT_RECORD_SEPARATOR = "\n%\n";
+
+		while (readline $fh) {
+			my $phrase = substr $_, 0, length ("\n%\n");
+			push @fortune, $phrase;
+		}
+
+		close $fh;  ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
+	}
+
+	closedir $srcdirhandle;
+	untie @fortune;
+	return;
+}
+
+# just return answer
+sub Fortune () {
+	my $backingfile = sprintf '%s/fortune.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/Fox.pm

@@ -0,0 +1,54 @@
+package BotLib::Fox;
+
+use 5.018;  ## no critic (ProhibitImplicitImport)
+use strict;
+use warnings;
+use utf8;
+use open qw (:std :utf8);
+use English qw ( -no_match_vars );
+use JSON::XS qw (decode_json);
+use HTTP::Tiny ();
+use Log::Any qw ($log);
+
+use version; our $VERSION = qw (1.0);
+use Exporter qw (import);
+our @EXPORT_OK = qw (Fox);
+
+sub Fox {
+	my $r;
+	my $ret = 'Нету лисичек, все разбежались.';
+
+	for (1..3) {
+		my $http = HTTP::Tiny->new (timeout => 3);
+		$r = $http->get ('https://randomfox.ca/floof/');
+
+		if ($r->{success}) {
+			last;
+		}
+
+		sleep 2;
+	}
+
+	if ($r->{success}) {
+		my $jfox = eval {
+			decode_json ($r->{content})
+		};
+
+		unless (defined $jfox) {
+			$log->warn ("[WARN] Unable to decode JSON: $EVAL_ERROR");
+		} else {
+			if ($jfox->{image}) {
+				$jfox->{image} =~ s/\\//xmsg;
+				$ret = $jfox->{image};
+			}
+		}
+	} else {
+		$log->warn (sprintf '[WARN] Server return status %s with message: %s', $r->{status}, $r->{reason});
+	}
+
+	return $ret;
+}
+
+1;
+
+# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

lib/BotLib/Friday.pm

@@ -0,0 +1,97 @@
+package BotLib::Friday;
+# for friday data stolen from https://raw.githubusercontent.com/isida/vi/master/data/friday.txt
+
+use 5.018; ## no critic (ProhibitImplicitImport)
+use strict;
+use warnings;
+use utf8;
+use open qw (:std :utf8);
+use English qw ( -no_match_vars );
+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);
+
+use version; our $VERSION = qw (1.0);
+use Exporter qw (import);
+our @EXPORT_OK = qw (Seed Friday);
+
+my $c = LoadConf ();
+my $dir = $c->{friday}->{dir};
+my $srcfile = $c->{friday}->{src};
+my @dow = qw (monday tuesday wednesday thursday friday saturday sunday);
+
+sub Seed () {
+	unless (-d $dir) {
+		make_path ($dir)  ||  croak "Unable to create $dir: $OS_ERROR";
+	}
+
+	my $friday;
+
+	for (0..$#dow) {
+		my $backingfile = sprintf '%s/%s.sqlite', $dir, $dow[$_];
+
+		if (-e $backingfile) {
+			unlink $backingfile   ||  croak "Unable to remove $backingfile: $OS_ERROR\n";
+		}
+
+		tie @{$friday->[$_]}, 'SQLite_File', $backingfile  ||  croak "Unable to tie to $backingfile: $OS_ERROR\n";
+	}
+
+	open (my $fh, '<', $srcfile)  ||  croak "Unable to open $srcfile, $OS_ERROR\n";
+
+	while (readline $fh) {
+		unless  (m/ \|\| /xmsg) {
+			next;
+		}
+
+		chomp ();
+		my ($phrase, $days) = split (/ \|\| /);
+		my @daylist = split (//, $days);
+
+		foreach my $day (@daylist) {
+			unless (defined $day) {
+				next ;
+			}
+
+			unless ($day =~ /^\d$/) {
+				next ;
+			}
+
+			if (defined ($phrase) && ($phrase ne '') && ($phrase !~ m/^\s+$/xmsg)) {
+				push @{$friday->[$day - 1]}, $phrase;
+			}
+		}
+	}
+
+	close $fh;  ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
+
+	for (0..$#dow) {
+		untie $friday->[$_];
+	}
+
+	return;
+}
+
+# just return answer
+sub Friday () {
+	my $today = (localtime (time))[6] - 1;
+	my $backingfile = sprintf '%s/%s.sqlite', $dir, $dow[$today];
+
+	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/Image.pm

@@ -0,0 +1,70 @@
+package BotLib::Image;
+
+use 5.018;  ## no critic (ProhibitImplicitImport)
+use strict;
+use warnings;
+use utf8;
+use open qw (:std :utf8);
+use BotLib::Image::Flickr qw (FlickrByTags);
+
+use version; our $VERSION = qw (1.0);
+use Exporter qw (import);
+our @EXPORT_OK = qw (Rabbit Owl Frog Horse Snail);
+
+sub Rabbit {
+	# rabbit, but bunny
+	my $url = FlickrByTags ('animal,bunny');
+
+	if (defined $url) {
+		return $url;
+	} else {
+		return 'Нету кроликов, все разбежались.';
+	}
+}
+
+sub Owl {
+	my $url = FlickrByTags ('bird,owl');
+
+	if (defined $url) {
+		return $url;
+	} else {
+		return 'Нету сов, все разлетелись.';
+	}
+}
+
+sub Frog {
+	# unable to find any one-line ascii art for frog :(
+	my $url = FlickrByTags ('frog,toad,amphibian');
+
+	if (defined $url) {
+		return $url;
+	} else {
+		return 'Нету лягушек, все свалили.';
+	}
+}
+
+sub Horse {
+	# unable to find any one-line ascii art for frog :(
+	my $url = FlickrByTags ('horse,equine,mammal');
+
+	if (defined $url) {
+		return $url;
+	} else {
+		return 'Нету коняшек, все разбежались.';
+	}
+}
+
+sub Snail {
+	# unable to find any one-line ascii art for frog :(
+	my $url = FlickrByTags ('snail,slug');
+
+	if (defined $url) {
+		return $url;
+	} else {
+		return 'Нету улиток, все расползлись.';
+	}
+}
+
+1;
+
+# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

lib/BotLib/Image/Flickr.pm

@@ -0,0 +1,638 @@
+package BotLib::Image::Flickr;
+
+use 5.018; ## no critic (ProhibitImplicitImport)
+use strict;
+use warnings;
+use utf8;
+use open qw (:std :utf8);
+use English qw ( -no_match_vars );
+use Digest::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 qw (encode_base64);
+use SQLite_File ();
+use URI::Encode::XS qw (uri_encode);
+
+use BotLib::Conf qw (LoadConf);
+
+use Data::Dumper qw (Dumper);
+
+use version; our $VERSION = qw (1.0);
+use Exporter qw (import);
+our @EXPORT_OK = qw (FlickrInit FlickrByTags FlickrByText FlickrTestLogin);
+
+my $c = LoadConf ();
+my $dir = $c->{image}->{dir};
+
+my $flickr_consumer_key      = $c->{image}->{flickr}->{consumer_key};
+my $flickr_consumer_secret   = $c->{image}->{flickr}->{consumer_secret};
+my $flickr_verifier          = $c->{image}->{flickr}->{verifier};
+my $flickr_request_token_url = 'https://www.flickr.com/services/oauth/request_token';
+my $flickr_authorization_url = 'https://www.flickr.com/services/oauth/authorize';
+my $flickr_access_token_url  = 'https://www.flickr.com/services/oauth/access_token';
+my $flickr_callback_url      = 'http://www.example.com';
+my $flickr_api_url           = 'https://www.flickr.com/services/rest/';
+
+sub mknonce {
+	# make random number, 8 symbols in length
+	my $nonce = sprintf '%08d', irand (99999999);
+	return $nonce;
+}
+
+sub flickrSignReq {
+	my %p = @_;
+	my $string;
+	my $hmac;
+
+	if ($p{type} eq 'request_token') {
+		my @parameters;
+		delete $p{type};
+		push @parameters, 'oauth_signature_method=HMAC-SHA1';
+		push @parameters, 'oauth_version=1.0';
+		push @parameters, sprintf 'oauth_callback=%s', uri_encode ($flickr_callback_url);
+		push @parameters, sprintf 'oauth_consumer_key=%s', $flickr_consumer_key;
+
+		foreach my $param (keys %p) {
+			push @parameters, sprintf ('%s=%s', $param, $p{$param});
+		}
+
+		$string = sprintf 'GET&%s&', uri_encode ($flickr_request_token_url);
+		$string .= uri_encode (join '&', sort (@parameters));
+		# Thanks to twitter api dev portal, they explain this particular case: while we requesting this token
+		# we do not yet know access_token secret, so we just omit it in this signature
+		# https://developer.twitter.com/en/docs/authentication/oauth-1-0a/creating-a-signature
+		$hmac = Digest::HMAC_SHA1->new (sprintf '%s&', uri_encode ($flickr_consumer_secret));
+	} elsif ($p{type} eq 'access_token') {
+		my @parameters;
+		my $flickr_request_token_secret = $p{oauth_token_secret};
+		delete $p{oauth_token_secret};
+		delete $p{type};
+		push @parameters, 'oauth_signature_method=HMAC-SHA1';
+		push @parameters, 'oauth_version=1.0';
+		push @parameters, sprintf 'oauth_consumer_key=%s', $flickr_consumer_key;
+
+		foreach my $param (keys %p) {
+			push @parameters, sprintf ('%s=%s', $param, $p{$param});
+		}
+
+		$string = sprintf 'GET&%s&', uri_encode ($flickr_access_token_url);
+		$string .= uri_encode (join '&', sort (@parameters));
+		$hmac = Digest::HMAC_SHA1->new (sprintf '%s&%s', uri_encode ($flickr_consumer_secret), uri_encode ($flickr_request_token_secret));
+	} elsif ($p{type} eq 'test_login' || $p{type} eq 'search_text' ||  $p{type} eq 'search_tags') {
+		my @parameters;
+		my $flickr_request_token_secret = $p{oauth_token_secret};
+		delete $p{oauth_token_secret};
+		delete $p{type};
+
+		foreach my $param (keys %p) {
+			push @parameters, sprintf ('%s=%s', $param, $p{$param});
+		}
+
+		$string = sprintf 'GET&%s&', uri_encode ($flickr_api_url);
+		$string .= uri_encode (join '&', sort (@parameters));
+		$hmac = Digest::HMAC_SHA1->new (sprintf '%s&%s', uri_encode ($flickr_consumer_secret), uri_encode ($flickr_request_token_secret));
+	}
+
+	$hmac->add ($string);
+	return encode_base64 ($hmac->digest, '');
+}
+
+sub flickrRequestToken {
+	my $oauth_timestamp = time ();
+	my $oauth_nonce = mknonce ();
+
+	my $oauth_signature = flickrSignReq (
+		type => 'request_token',
+		oauth_timestamp => $oauth_timestamp,
+		oauth_nonce => $oauth_nonce,
+	);
+
+	my $url = $flickr_request_token_url . sprintf (
+		'?oauth_nonce=%s&oauth_timestamp=%s&oauth_consumer_key=%s&oauth_signature_method=HMAC-SHA1&oauth_version=1.0&&oauth_signature=%s&oauth_callback=%s',
+		$oauth_nonce,
+		$oauth_timestamp,
+		$flickr_consumer_key,
+		uri_encode ($oauth_signature),
+		uri_encode ($flickr_callback_url),
+	);
+
+	my $http = HTTP::Tiny->new (timeout => 5);
+	my $r = $http->get ($url);
+	my %params;
+
+	if ($r->{success}) {
+		# they ignore format=json, so...
+		%params = map {split /=/} split /&/, $r->{content};
+	} else {
+		say "Something bad returns from flickr api: $r->{status} $r->{content}"; ## no critic (InputOutput::RequireCheckedSyscalls)
+	}
+
+	return %params;
+}
+
+sub flickrAccessToken {
+	my $flickr_request_token = shift;
+	my $flickr_request_token_secret = shift;
+	my $flickr_verifier = shift; ## no critic (Variables::ProhibitReusedNames)
+
+	my $oauth_timestamp = time ();
+	my $oauth_nonce = mknonce ();
+
+	my $oauth_signature = flickrSignReq (
+		type => 'access_token',
+		oauth_timestamp => $oauth_timestamp,
+		oauth_nonce => $oauth_nonce,
+		oauth_token => $flickr_request_token,
+		oauth_token_secret => $flickr_request_token_secret,
+		oauth_verifier => $flickr_verifier,
+	);
+
+	my $url = $flickr_access_token_url . sprintf (
+		'?oauth_nonce=%s&oauth_timestamp=%s&oauth_verifier=%s&oauth_consumer_key=%s&oauth_signature_method=HMAC-SHA1&oauth_version=1.0&oauth_token=%s&oauth_signature=%s',
+		$oauth_nonce,
+		$oauth_timestamp,
+		$flickr_verifier,
+		$flickr_consumer_key,
+		$flickr_request_token,
+		uri_encode ($oauth_signature),
+	);
+
+	my $http = HTTP::Tiny->new (timeout => 5);
+	my $r = $http->get ($url);
+	my %params;
+
+	if ($r->{success}) {
+		# they ignore format=json
+		%params = map {split /=/} split /&/, $r->{content};
+	} else {
+		say "Something bad returns from flickr api: $r->{status} $r->{content}"; ## no critic (InputOutput::RequireCheckedSyscalls)
+	}
+
+	return %params;
+}
+
+sub flickrAuthorization {
+	my $flickr_request_token = shift;
+
+	my $url = $flickr_authorization_url . sprintf (
+		'?oauth_token=%s&perms=read',
+		$flickr_request_token,
+	);
+
+	my $http = HTTP::Tiny->new (timeout => 5);
+	my $r = $http->get ($url);
+
+	if ($r->{success}) {
+		return $r->{url};
+	} else {
+		say "Something went wrong: $r->{status} $r->{content}"; ## no critic (InputOutput::RequireCheckedSyscalls)
+		return;
+	}
+}
+
+sub flickrTestLogin {
+	my $flickr_access_token = shift;
+	my $flickr_access_token_secret = shift;
+
+	my $oauth_timestamp = time ();
+	my $oauth_nonce = mknonce ();
+
+	my $oauth_signature = flickrSignReq (
+		nojsoncallback => 1,
+		oauth_nonce => $oauth_nonce,
+		format => 'json',
+		oauth_consumer_key => $flickr_consumer_key,
+		oauth_timestamp => $oauth_timestamp,
+		type => 'test_login',
+		method => 'flickr.test.login',
+		oauth_token => $flickr_access_token,
+		oauth_token_secret => $flickr_access_token_secret,
+		oauth_signature_method => 'HMAC-SHA1',
+		oauth_version => '1.0',
+	);
+
+	my $url = $flickr_api_url . sprintf (
+		'?nojsoncallback=1&oauth_nonce=%s&format=json&oauth_consumer_key=%s&oauth_timestamp=%s&oauth_signature_method=HMAC-SHA1&oauth_version=1.0&oauth_token=%s&oauth_signature=%s&method=flickr.test.login',
+		$oauth_nonce,
+		$flickr_consumer_key,
+		$oauth_timestamp,
+		$flickr_access_token,
+		uri_encode ($oauth_signature),
+	);
+
+	my $http = HTTP::Tiny->new (timeout => 5);
+	my $r = $http->get ($url);
+
+	if ($r->{success}) {
+		my $response = eval {
+			my $j = JSON::XS->new->utf8->relaxed;
+			return $j->decode ($r->{content});
+		};
+
+		if (defined $response) {
+			say Dumper $response; ## no critic (InputOutput::RequireCheckedSyscalls)
+			return 1;
+		} else {
+			say "Flickr api returns incorrect json: $r->{content}"; ## no critic (InputOutput::RequireCheckedSyscalls)
+			return 0;
+		}
+	} else {
+		say "HTTP status code not 200: $r->{status}, $r>{contenr}"; ## no critic (InputOutput::RequireCheckedSyscalls)
+		return 0;
+	}
+}
+
+sub flickrSearchByText {
+	my $flickr_access_token = shift;
+	my $flickr_access_token_secret = shift;
+	my $text = shift;
+
+	my $oauth_timestamp = time ();
+	my $oauth_nonce = mknonce ();
+
+	my $oauth_signature = flickrSignReq (
+		nojsoncallback => 1,
+		oauth_nonce => $oauth_nonce,
+		format => 'json',
+		oauth_consumer_key => $flickr_consumer_key,
+		oauth_timestamp => $oauth_timestamp,
+		type => 'search_text',
+		content_type => 1,
+		media => 'photos',
+		method => 'flickr.photos.search',
+		text => $text,
+		per_page => 1,
+		oauth_token => $flickr_access_token,
+		oauth_token_secret => $flickr_access_token_secret,
+		oauth_signature_method => 'HMAC-SHA1',
+		oauth_version => '1.0',
+	);
+
+	my $url = $flickr_api_url . sprintf (
+		'?nojsoncallback=1&oauth_nonce=%s&format=json&oauth_consumer_key=%s&oauth_timestamp=%s&oauth_signature_method=HMAC-SHA1&oauth_version=1.0&oauth_token=%s&oauth_signature=%s&method=flickr.photos.search&content_type=1&media=photos&per_page=1&text=%s',
+		$oauth_nonce,
+		$flickr_consumer_key,
+		$oauth_timestamp,
+		$flickr_access_token,
+		uri_encode ($oauth_signature),
+		uri_encode ($text),
+	);
+
+	my $http = HTTP::Tiny->new (timeout => 5);
+	my $r = $http->get ($url);
+
+	if ($r->{success}) {
+		my $response = eval {
+			my $j = JSON::XS->new->utf8->relaxed;
+			return $j->decode ($r->{content});
+		};
+
+		if (defined $response) {
+			# lets make another query, this time with random picture
+			my $page = irand (int $response->{photos}->{total} / 500);
+			$oauth_timestamp = time ();
+			$oauth_nonce = mknonce ();
+			$oauth_signature = flickrSignReq (
+				nojsoncallback => 1,
+				oauth_nonce => $oauth_nonce,
+				format => 'json',
+				oauth_consumer_key => $flickr_consumer_key,
+				oauth_timestamp => $oauth_timestamp,
+				type => 'search_text',
+				content_type => 1,
+				media => 'photos',
+				method => 'flickr.photos.search',
+				text => $text,
+				page => $page,
+				per_page => 500,
+				oauth_token => $flickr_access_token,
+				oauth_token_secret => $flickr_access_token_secret,
+				oauth_signature_method => 'HMAC-SHA1',
+				oauth_version => '1.0',
+			);
+
+			$url = $flickr_api_url . sprintf (
+				'?nojsoncallback=1&oauth_nonce=%s&format=json&oauth_consumer_key=%s&oauth_timestamp=%s&oauth_signature_method=HMAC-SHA1&oauth_version=1.0&oauth_token=%s&oauth_signature=%s&method=flickr.photos.search&content_type=1&media=photos&per_page=500&page=%d&text=%s',
+				$oauth_nonce,
+				$flickr_consumer_key,
+				$oauth_timestamp,
+				$flickr_access_token,
+				uri_encode ($oauth_signature),
+				$page,
+				uri_encode ($text),
+			);
+
+			$http = HTTP::Tiny->new (timeout => 5);
+			$r = $http->get ($url);
+
+			if ($r->{success}) {
+				$response = eval {
+					my $j = JSON::XS->new->utf8->relaxed;
+					return $j->decode ($r->{content});
+				};
+
+				if (defined $response) {
+					return $response;
+				} else {
+					$log->warn ("[WARN] Flickr api returns incorrect json: $r->{content}");
+					return undef;
+				}
+			} else {
+				$log->warn ("[WARN] Flickr api returns incorrect json: $r->{content}");
+				return undef;
+			}
+		} else {
+			$log->warn ("[WARN] Flickr api returns incorrect json: $r->{content}");
+			return undef;
+		}
+	} else {
+		$log->warn ("[WARN] HTTP status code not 200: $r->{status}, $r->{content}");
+		return undef;
+	}
+}
+
+sub flickrSearchByTags {
+	my $flickr_access_token = shift;
+	my $flickr_access_token_secret = shift;
+	my $tags = shift;
+
+	my $oauth_timestamp = time ();
+	my $oauth_nonce = mknonce ();
+
+	my $oauth_signature = flickrSignReq (
+		nojsoncallback => 1,
+		oauth_nonce => $oauth_nonce,
+		format => 'json',
+		oauth_consumer_key => $flickr_consumer_key,
+		oauth_timestamp => $oauth_timestamp,
+		type => 'search_tags',
+		content_type => 1,
+		media => 'photos',
+		method => 'flickr.photos.search',
+		tags => $tags,
+		per_page => 1,
+		oauth_token => $flickr_access_token,
+		oauth_token_secret => $flickr_access_token_secret,
+		oauth_signature_method => 'HMAC-SHA1',
+		oauth_version => '1.0',
+	);
+
+	my $url = $flickr_api_url . sprintf (
+		'?nojsoncallback=1&oauth_nonce=%s&format=json&oauth_consumer_key=%s&oauth_timestamp=%s&oauth_signature_method=HMAC-SHA1&oauth_version=1.0&oauth_token=%s&oauth_signature=%s&method=flickr.photos.search&content_type=1&media=photos&per_page=1&tags=%s&tag_mode=all',
+		$oauth_nonce,
+		$flickr_consumer_key,
+		$oauth_timestamp,
+		$flickr_access_token,
+		uri_encode ($oauth_signature),
+		uri_encode ($tags),
+	);
+
+	my $http = HTTP::Tiny->new (timeout => 5);
+	my $r = $http->get ($url);
+
+	if ($r->{success}) {
+		my $response = eval {
+			my $j = JSON::XS->new->utf8->relaxed;
+			return $j->decode ($r->{content});
+		};
+
+		if (defined $response) {
+			# lets make another query, this time with random picture
+			my $page = irand int ($response->{photos}->{total} / 500);
+			$oauth_timestamp = time ();
+			$oauth_nonce = mknonce ();
+			$oauth_signature = flickrSignReq (
+				nojsoncallback => 1,
+				oauth_nonce => $oauth_nonce,
+				format => 'json',
+				oauth_consumer_key => $flickr_consumer_key,
+				oauth_timestamp => $oauth_timestamp,
+				type => 'search_text',
+				content_type => 1,
+				media => 'photos',
+				method => 'flickr.photos.search',
+				tags => $tags,
+				page => $page,
+				per_page => 500,
+				oauth_token => $flickr_access_token,
+				oauth_token_secret => $flickr_access_token_secret,
+				oauth_signature_method => 'HMAC-SHA1',
+				oauth_version => '1.0',
+			);
+
+			$url = $flickr_api_url . sprintf (
+				'?nojsoncallback=1&oauth_nonce=%s&format=json&oauth_consumer_key=%s&oauth_timestamp=%s&oauth_signature_method=HMAC-SHA1&oauth_version=1.0&oauth_token=%s&oauth_signature=%s&method=flickr.photos.search&content_type=1&media=photos&per_page=500&page=%d&tags=%s&tag_mode=all',
+				$oauth_nonce,
+				$flickr_consumer_key,
+				$oauth_timestamp,
+				$flickr_access_token,
+				uri_encode ($oauth_signature),
+				$page,
+				uri_encode ($tags),
+			);
+
+			$http = HTTP::Tiny->new (timeout => 5);
+			$r = $http->get ($url);
+
+			if ($r->{success}) {
+				$response = eval {
+					my $j = JSON::XS->new->utf8->relaxed;
+					return $j->decode ($r->{content});
+				};
+
+				if (defined $response) {
+					return $response;
+				} else {
+					$log->warn ("[WARN] Flickr api returns incorrect json: $r->{content}");
+					return undef;
+				}
+			} else {
+				$log->warn ("[WARN] Flickr api returns incorrect json: $r->{content}");
+				return undef;
+			}
+		} else {
+			$log->warn ("[WARN] Flickr api returns incorrect json: $r->{content}");
+			return undef;
+		}
+	} else {
+		$log->warn ("[WARN] HTTP status code not 200: $r->{status}, $r>{content}");
+		return undef;
+	}
+}
+
+sub FlickrInit {
+	my $backingfile = sprintf '%s/secrets.sqlite', $dir;
+
+	unless (-d $dir) {
+		make_path ($dir) or do {
+			say "Unable to create $dir: $OS_ERROR"; ## no critic (InputOutput::RequireCheckedSyscalls)
+			return 0;
+		};
+	}
+
+	tie my %secret, 'SQLite_File', $backingfile  ||  do {
+		say "[ERROR] Unable to tie to $backingfile: $OS_ERROR"; ## no critic (InputOutput::RequireCheckedSyscalls)
+		return 0;
+	};
+
+	if (defined $flickr_verifier && $flickr_verifier) {
+		my $flickr_request_token = $secret{flickr_request_token};
+		my $flickr_request_token_secret = $secret{flickr_request_token_secret};
+
+		unless (defined $flickr_request_token || defined $flickr_request_token_secret) {
+			say "Looks like there is no request token or request token secret in $backingfile"; ## no critic (InputOutput::RequireCheckedSyscalls)
+			say 'Please remove verifier settings from config.json and run this script again';   ## no critic (InputOutput::RequireCheckedSyscalls)
+			untie %secret;
+			return 0;
+		}
+
+		my %accessToken = flickrAccessToken ($flickr_request_token, $flickr_request_token_secret, $flickr_verifier);
+
+		if (defined ($accessToken{oauth_token}) && defined ($accessToken{oauth_token_secret})) {
+			$secret{flickr_access_token} = $accessToken{oauth_token};
+			$secret{flickr_access_token_secret} = $accessToken{oauth_token_secret};
+
+			say sprintf ( ## no critic (InputOutput::RequireCheckedSyscalls)
+				'Access token (%s) and access token secret (%s) are in %s',
+				$accessToken{oauth_token},
+				$accessToken{oauth_token_secret},
+				$backingfile,
+			);
+
+			untie %secret;
+			return 1;
+		}
+	} else {
+		my %req = flickrRequestToken ();
+		if (defined ($req{oauth_token}) && defined ($req{oauth_token_secret}) && defined ($req{oauth_token})) {
+			$secret{flickr_request_token} = $req{oauth_token};
+			$secret{flickr_request_token_secret} = $req{oauth_token_secret};
+			my $confirm_url = flickrAuthorization ($req{oauth_token});
+
+			if (defined $confirm_url) {
+				say "Please open this url in your browser and grant access for this app:\n$confirm_url"; ## no critic (InputOutput::RequireCheckedSyscalls)
+				say 'Do not forget to put oauth_verifier to config.json file and re-run this script to get access token'; ## no critic (InputOutput::RequireCheckedSyscalls)
+				say 'Note that you should be logged off from flickr account.'; ## no critic (InputOutput::RequireCheckedSyscalls)
+				untie %secret;
+				return 1;
+			}
+		}
+	}
+
+	untie %secret;
+	return 0;
+}
+
+sub FlickrTestLogin {
+	my $text = shift;
+	my $backingfile = sprintf '%s/secrets.sqlite', $dir;
+
+	unless (-d $dir) {
+		make_path ($dir) or do {
+			say "Unable to create $dir: $OS_ERROR"; ## no critic (InputOutput::RequireCheckedSyscalls)
+			return 0;
+		};
+	}
+
+	tie my %secret, 'SQLite_File', $backingfile  ||  do {
+		say "Unable to tie to $backingfile: $OS_ERROR"; ## no critic (InputOutput::RequireCheckedSyscalls)
+		return 0;
+	};
+
+	my $flickr_access_token = $secret{flickr_access_token};
+	my $flickr_access_token_secret = $secret{flickr_access_token_secret};
+	untie %secret;
+
+	if (flickrTestLogin ($flickr_access_token, $flickr_access_token_secret)) {
+		return 1;
+	} else {
+		return 0;
+	}
+}
+
+sub FlickrByTags {
+	my $text = shift;
+	my $backingfile = sprintf '%s/secrets.sqlite', $dir;
+
+	unless (-d $dir) {
+		make_path ($dir) or do {
+			$log->error ("[ERROR] Unable to create $dir: $OS_ERROR");
+			return 0;
+		};
+	}
+
+	tie my %secret, 'SQLite_File', $backingfile  ||  do {
+		$log->error ("[ERROR] Unable to tie to $backingfile: $OS_ERROR");
+		return 0;
+	};
+
+	my $flickr_access_token = $secret{flickr_access_token};
+	my $flickr_access_token_secret = $secret{flickr_access_token_secret};
+	untie %secret;
+
+	# NB: I honestly query random page (among number of pages) of results from api, but always got first page,
+	# no matter what is shown in response' "page" parameter. Looks like bug in API. Try to little bit mitigate
+	# this bug via query 500 results per page, then we can select random result in this heap. But anyway, let's
+	# make this thing future proof and leave randomizer in page select.
+	my $result = flickrSearchByTags ($flickr_access_token, $flickr_access_token_secret, $text);
+
+	if ($result) {
+		if (defined ($result->{photos}) && defined ($result->{photos}->{photo})) {
+			my $item = irand int @{$result->{photos}->{photo}};
+			$item = ${$result->{photos}->{photo}}[$item];
+			$item = sprintf 'https://live.staticflickr.com/%s/%s_%s_z.jpg', $item->{server}, $item->{id}, $item->{secret};
+			return $item;
+		} else {
+			$log->notice ('[NOTICE] Flickr api returns empty search result list');
+			return;
+		}
+	} else {
+		return;
+	}
+}
+
+sub FlickrByText {
+	my $text = shift;
+	my $backingfile = sprintf '%s/secrets.sqlite', $dir;
+
+	unless (-d $dir) {
+		make_path ($dir) or do {
+			$log->error ("[ERROR] Unable to create $dir: $OS_ERROR");
+			return 0;
+		};
+	}
+
+	tie my %secret, 'SQLite_File', $backingfile  ||  do {
+		$log->error ("[ERROR] Unable to tie to $backingfile: $OS_ERROR");
+		return 0;
+	};
+
+	my $flickr_access_token = $secret{flickr_access_token};
+	my $flickr_access_token_secret = $secret{flickr_access_token_secret};
+	untie %secret;
+
+	# NB: I honestly query random page (among number of pages) of results from api, but always got first page,
+	# no matter what is shown in response' "page" parameter. Looks like bug in API. Try to little bit mitigate
+	# this bug via query 500 results per page, then we can select random result in this heap. But anyway, let's
+	# make this thing future proof and leave randomizer in page select.
+	my $result = flickrSearchByText ($flickr_access_token, $flickr_access_token_secret, $text);
+
+	if ($result) {
+		if (defined ($result->{photos}) && defined ($result->{photos}->{photo})) {
+			my $item = irand (int (@{$result->{photos}->{photo}}));
+			$item = ${$result->{photos}->{photo}}[$item];
+			$item = sprintf 'https://live.staticflickr.com/%s/%s_%s_z.jpg', $item->{server}, $item->{id}, $item->{secret};
+			return $item;
+		} else {
+			$log->notice ('[NOTICE] Flickr api returns empty search result list');
+			return;
+		}
+	} else {
+		return;
+	}
+}
+
+1;

lib/BotLib/Karma.pm

@@ -0,0 +1,125 @@
+package BotLib::Karma;
+
+use 5.018; ## no critic (ProhibitImplicitImport)
+use strict;
+use warnings;
+use utf8;
+use open qw (:std :utf8);
+use English qw ( -no_match_vars );
+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);
+
+use version; our $VERSION = qw (1.0);
+use Exporter qw (import);
+our @EXPORT_OK = qw (KarmaSet KarmaGet);
+
+my $c = LoadConf ();
+my $karmadir = $c->{karma}->{dir};
+my $max = 5;
+
+# swallow phrase and return answer
+sub KarmaSet (@) {
+	my $chatid = shift;
+	my $phrase = shift;
+	my $action = shift;
+	$phrase = trim $phrase;
+	my $score = 0;
+	# sha1* does not understand utf8, so explicitly construct string cost of decimal numbers only 
+	my $karmafile = utf2sha1 $chatid;
+	$karmafile =~ s/\//-/xmsg;
+	$karmafile = sprintf '%s/%s.db', $karmadir, $karmafile;
+
+	unless (-d $karmadir) {
+		make_path ($karmadir) or do {
+			$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 {
+		$log->error ("[ERROR] Something nasty happen when karma ties to its data: $OS_ERROR");
+		return sprintf 'Карма %s составляет 0', $phrase;
+	};
+
+	# bdb does not understand utf8, so tied hash too, we do not want store original phrase anyway
+	my $sha1_phrase = utf2sha1 $phrase;
+
+	if (defined $karma{$sha1_phrase}) {
+		if ($action eq '++') {
+			$score = $karma{$sha1_phrase} + 1;
+			$karma{$sha1_phrase} = $score;
+		} else {
+			$score = $karma{$sha1_phrase} - 1;
+			$karma{$sha1_phrase} = $score;
+		}
+	} else {
+		if ($action eq '++') {
+			$karma{$sha1_phrase} = 1;
+			$score = 1;
+		} else {
+			$karma{$sha1_phrase} = -1;
+			$score = -1;
+		}
+	}
+
+	untie %karma;
+
+	if ($score < -1 && (($score % (0 - $max)) + 1) == 0) {
+		if ($phrase eq '') {
+			return sprintf 'Зарегистрировано пробитие дна, карма пустоты составляет %d', $score;
+		} else {
+			return sprintf 'Зарегистрировано пробитие дна, карма %s составляет %d', $phrase, $score;
+		}
+	} else {
+		if ($phrase eq '') {
+			return sprintf 'Карма пустоты составляет %d', $score;
+		} else {
+			return sprintf 'Карма %s составляет %d', $phrase, $score;
+		}
+	}
+}
+
+# just return answer
+sub KarmaGet (@) {
+	my $chatid = shift;
+	my $phrase = shift;
+	$phrase = trim $phrase;
+	my $karmafile = utf2sha1 $chatid;
+	$karmafile =~ s/\//-/xmsg;
+	$karmafile = sprintf '%s/%s.db', $karmadir, $karmafile;
+
+	unless (-d $karmadir) {
+		make_path ($karmadir) or do {
+			$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 {
+		$log->error ("[ERROR] Something nasty happen when karma ties to its data: $OS_ERROR");
+		return sprintf 'Карма %s составляет 0', $phrase;
+	};
+
+	my $sha1_phrase = utf2sha1 $phrase;
+	my $score = $karma{$sha1_phrase};
+	untie %karma;
+
+	unless (defined $score) {
+		$score = 0;
+	}
+
+	if ($phrase eq '') {
+		return sprintf 'Карма пустоты составляет %d', $score;
+	} else {
+		return sprintf 'Карма %s составляет %d', $phrase, $score;
+	}
+}
+
+1;
+
+# vim: ft=perl noet ai ts=4 sw=4 sts=4:

lib/BotLib/Kitty.pm

@@ -0,0 +1,53 @@
+package BotLib::Kitty;
+
+use 5.018; ## no critic (ProhibitImplicitImport)
+use strict;
+use warnings;
+use utf8;
+use open qw (:std :utf8);
+use English qw ( -no_match_vars );
+use JSON::XS qw (decode_json);
+use HTTP::Tiny ();
+use Log::Any qw ($log);
+
+use version; our $VERSION = qw (1.0);
+use Exporter qw (import);
+our @EXPORT_OK = qw (Kitty);
+
+sub Kitty {
+	my $r;
+	my $ret = 'Нету кошечек, все разбежались.';
+
+	for (1..3) {
+		my $http = HTTP::Tiny->new (timeout => 3);
+		$r = $http->get ('https://api.thecatapi.com/v1/images/search');
+
+		if ($r->{success}) {
+			last;
+		}
+
+		sleep 2;
+	}
+
+	if ($r->{success}) {
+		my $jcat = eval {
+			decode_json ($r->{content})
+		};
+
+		unless (defined $jcat) {
+			$log->error ("[ERROR] Unable to decode JSON: $EVAL_ERROR");
+		} else {
+			if ($jcat->[0]->{url}) {
+				$ret = $jcat->[0]->{url};
+			}
+		}
+	} else {
+		$log->error (sprintf 'Server return status %s with message: %s', $r->{status}, $r->{reason});
+	}
+
+	return $ret;
+}
+
+1;
+
+# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

lib/BotLib/Lat.pm

@@ -0,0 +1,74 @@
+package BotLib::Lat;
+# famous latin phases taken from https://ru.wikipedia.org/wiki/Список_крылатых_латинских_выражений
+
+use 5.018; ## no critic (ProhibitImplicitImport)
+use strict;
+use warnings;
+use utf8;
+use open qw (:std :utf8);
+use English qw ( -no_match_vars );
+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);
+use Exporter qw (import);
+our @EXPORT_OK = qw (Train Lat);
+
+my $c = LoadConf ();
+my $brain = $c->{lat}->{brain};
+my $srcfile = $c->{lat}->{src};
+
+sub Train () {
+	my $braindir = dirname $brain;
+
+	unless (-d $braindir) {
+		make_path ($braindir) or do {
+			carp "Unable to create $braindir: $OS_ERROR";
+			exit 1;
+		};
+	}
+
+	my $lat = Hailo->new (
+		brain => $brain,
+		# in our case mean amount of words in phase is 3
+		order => 2,
+	);
+
+	$lat->train ($srcfile);
+	my ($tokens, $expressions) = ($lat->stats ())[0,1];
+	printf "Total tokens: %s\nTotal expressions: %s\n", $tokens, $expressions;
+	$lat->save ();
+	return;
+}
+
+# just return answer
+sub Lat () {
+	my $braindir = dirname $brain;
+
+	unless (-d $braindir) {
+		$log->error ("[ERROR] No lat module data: $braindir is absent! Train lat first.");
+		return '';
+	}
+
+	unless (-e $brain) {
+		$log->error ("[ERROR] No lat module data: $brain is absent! Train lat first.");
+		return '';
+	}
+
+	my $lat = Hailo->new (
+		brain => $brain,
+		# in our case mean amount of words in phase is 3
+		order => 2,
+		save_on_exit => 0,
+	);
+
+	return $lat->reply ();
+}
+
+1;
+
+# vim: ft=perl noet ai ts=4 sw=4 sts=4:

lib/BotLib/Monkeyuser.pm

@@ -0,0 +1,62 @@
+package BotLib::Monkeyuser;
+
+use 5.018; ## no critic (ProhibitImplicitImport)
+use strict;
+use warnings;
+use utf8;
+use open qw (:std :utf8);
+use English qw ( -no_match_vars );
+use HTTP::Tiny ();
+use HTML::TokeParser ();
+use Log::Any qw ($log);
+use Math::Random::Secure qw (irand);
+
+use version; our $VERSION = qw (1.0);
+use Exporter qw (import);
+our @EXPORT_OK = qw (Monkeyuser);
+
+sub Monkeyuser {
+	my $r;
+	my $ret = 'Нету Monkey User-ов, они все спрятались.';
+	my @link;
+
+	for (1..3) {
+		my $http = HTTP::Tiny->new (timeout => 3);
+		$r = $http->get ('https://www.monkeyuser.com/toc/');
+
+		if ($r->{success}) {
+			last;
+		}
+
+		sleep 2;
+	}
+
+	if ($r->{success}) {
+		my $p = HTML::TokeParser->new(\$r->{content});
+		my @a;
+
+		do {
+			$#a = -1;
+			@a = $p->get_tag ('a'); ## no critic (Variables::RequireLocalizedPunctuationVars)
+
+			if (defined $a[0][1]->{class} && $a[0][1]->{class} eq 'lazyload small-image') {
+				if (defined $a[0][1]->{'data-src'} && ($a[0][1]->{'data-src'} !~ /adlitteram/)) {
+					push @link, $a[0][1]->{'data-src'};
+				}
+			}
+
+		} while ($#{$a[0]} > 1);
+
+		if ($#link > 0) {
+			$ret = sprintf 'https://www.monkeyuser.com%s', $link[irand (1 + $#link)];
+		}
+	} else {
+		$log->warn (sprintf '[WARN] Monkeyuser server return status %s with message: %s', $r->{status}, $r->{reason});
+	}
+
+	return $ret;
+}
+
+1;
+
+# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

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; ## no critic (ProhibitImplicitImport)
+use strict;
+use warnings;
+use utf8;
+use open qw (:std :utf8);
+use English qw ( -no_match_vars );
+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);
+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 (-e $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 (-e $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/Util.pm

@@ -0,0 +1,111 @@
+package BotLib::Util;
+
+use 5.018; ## no critic (ProhibitImplicitImport)
+use strict;
+use warnings;
+use utf8;
+use open qw (:std :utf8);
+use English qw ( -no_match_vars );
+use Carp qw (cluck);
+use Digest::SHA qw (sha1_base64);
+use Encode qw (encode_utf8);
+use MIME::Base64 qw (encode_base64);
+use Text::Fuzzy qw (distance_edits);
+use URI::URL qw (url);
+
+use version; our $VERSION = qw (1.0);
+use Exporter qw (import);
+our @EXPORT_OK = qw (trim urlencode fmatch utf2b64 utf2sha1);
+
+sub trim {
+	my $str = shift;
+
+	unless (defined $str) {
+		cluck '[ERROR] Str is undefined';
+		return '';
+	}
+
+	if ($str eq '') {
+		return $str;
+	}
+
+	$str =~ s/^\s+//u;
+	$str =~ s/\s+$//u;
+
+	return $str;
+}
+
+sub urlencode {
+	my $str = shift;
+
+	unless (defined $str) {
+		cluck '[ERROR] Str is undefined';
+		return '';
+	}
+
+	my $urlobj = url $str;
+	return $urlobj->as_string;
+}
+
+sub fmatch {
+	my $srcphrase = shift;
+	my $answer = shift;
+
+	if ((! defined $srcphrase) || (! defined $answer)) {
+		if (defined $srcphrase) {
+			cluck '[ERROR] Answer undefined';
+		} elsif (defined $answer) {
+			cluck '[ERROR] Srcphrase undefined';
+		} else {
+			cluck '[ERROR] Both srcphrase and answer are undefined';
+		}
+
+		return 0;
+	}
+
+	my ($distance, undef) = distance_edits ($srcphrase, $answer);
+	my $srcphraselen = length $srcphrase;
+	my $distance_max = int ($srcphraselen - ($srcphraselen * (100 - (90 / ($srcphraselen ** 0.5))) * 0.01));
+
+	if ($distance >= $distance_max) {
+		return 0;
+	} else {
+		return 1;
+	}
+}
+
+sub utf2b64 {
+	my $string = shift;
+
+	unless (defined $string) {
+		cluck '[ERROR] String is undefined';
+		return sha1_base64 '';
+	}
+
+	if ($string eq '') {
+		return encode_base64 '';
+	}
+
+	my $bytes = encode_utf8 $string;
+	return encode_base64 $bytes;
+}
+
+sub utf2sha1 {
+	my $string = shift;
+
+	unless (defined $string) {
+		cluck '[ERROR] String is undefined';
+		return sha1_base64 '';
+	}
+
+	if ($string eq '') {
+		return sha1_base64 '';
+	}
+
+	my $bytes = encode_utf8 $string;
+	return sha1_base64 $bytes;
+}
+
+1;
+
+# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

lib/BotLib/Weather.pm

@@ -0,0 +1,252 @@
+package BotLib::Weather;
+
+use 5.018; ## no critic (ProhibitImplicitImport)
+use strict;
+use warnings;
+use utf8;
+use open         qw (:std :utf8);
+use English      qw ( -no_match_vars );
+use CHI             ();
+use CHI::Driver::BerkeleyDB ();
+use HTTP::Tiny      ();
+use JSON::XS     qw (decode_json);
+use Log::Any     qw ($log);
+use BotLib::Conf qw (LoadConf);
+use BotLib::Util qw (trim urlencode);
+
+use version; our $VERSION = qw (1.0);
+use Exporter qw (import);
+our @EXPORT_OK = qw (Weather);
+
+my $c = LoadConf ();
+
+sub Weather {
+	my $city = shift;
+	$city = trim $city;
+
+	return 'Мне нужно ИМЯ города.' if ($city eq '');
+	return 'Длинновато для названия города.' if (length ($city) > 80);
+
+	$city = ucfirst $city;
+
+	my $cache = CHI->new (
+		driver => 'BerkeleyDB',
+		root_dir => $c->{cachedir},
+		namespace => __PACKAGE__,
+	);
+
+	my $geoCallBack = sub {
+		my $appid = $c->{openweathermap}->{appid};
+		my $geo;
+
+		my $r;
+
+		# Try 3 times and giveup
+		for (1..3) {
+			my $http = HTTP::Tiny->new (timeout => 3);
+			$r = $http->get (
+				sprintf (
+					'http://api.openweathermap.org/geo/1.0/direct?q=%s&limit=1&APPID=%s',
+					urlencode ($city),
+					$appid,
+				),
+			);
+
+			if ($r->{success}) {
+				last;
+			}
+
+			sleep 2;
+		}
+
+		# All 3 times it can give us error, so check this case here
+		if ($r->{success}) {
+			$geo = eval {
+				decode_json ($r->{content});
+			};
+
+			unless ($geo) {
+				$log->warn ("[WARN] openweathermap geo api returns corrupted json: $EVAL_ERROR");
+				return undef;
+			}
+		} else {
+			$log->warn (
+				sprintf (
+					'[WARN] Server api.openweathermap.org return status %s with message: %s in request to geo',
+					$r->{status},
+					$r->{reason},
+				),
+			);
+
+			return undef;
+		}
+
+		if (defined ($geo->[0]->{lat}) && defined ($geo->[0]->{lon})) {
+			# Success
+			return $geo->[0];
+		} else {
+			# Error, no coordinates
+			$log->warn ('[WARN] Server api.openweathermap.org does not return coordinates in response to geo request');
+			return undef;
+		}
+	};
+
+	my $geo = $cache->compute (
+		$city,
+		'2 months',
+		$geoCallBack,
+	);
+
+	my $weatherCallBack = sub {
+		my $appid = $c->{openweathermap}->{appid};
+
+		unless (defined $appid) {
+			$log->warn ('[WARN] No appid specified for openweathermap');
+			return undef;
+		}
+
+		my $fc;
+		my $w;
+		my $r;
+
+		if (defined $geo) {
+			# try 3 times and giveup
+			for (1..3) {
+				my $http = HTTP::Tiny->new (timeout => 3);
+				$r = $http->get (
+					sprintf (
+						'http://api.openweathermap.org/data/2.5/weather?lat=%s&lon=%s&lang=ru&APPID=%s',
+						$geo->{lat},
+						$geo->{lon},
+						$appid,
+					),
+				);
+
+				if ($r->{success}) {
+					last;
+				}
+
+				sleep 2;
+			}
+
+			# all 3 times can give error, so check it here
+			if ($r->{success}) {
+				$fc = eval {
+					decode_json ($r->{content});
+				};
+
+				unless (defined $fc) {
+					$log->warn ("[WARN] openweathermap returns corrupted json: $EVAL_ERROR");
+					return undef;
+				}
+			} else {
+				$log->warn (sprintf 'Server return status %s with message: %s', $r->{status}, $r->{reason});
+				return undef;
+			}
+
+			# TODO: check all of this for existence
+			$w->{'name'} = $fc->{name};
+			$w->{'state'} = $fc->{state};
+			$w->{'country'} = $fc->{sys}->{country};
+			$w->{'longitude'} = $fc->{coord}->{lon};
+			$w->{'latitude'} = $fc->{coord}->{lat};
+			$w->{'temperature_min'} = int ($fc->{main}->{temp_min} - 273.15);
+			$w->{'temperature_max'} = int ($fc->{main}->{temp_max} - 273.15);
+			$w->{'temperature_feelslike'} = int ($fc->{main}->{feels_like} - 273.15);
+			$w->{'humidity'} = $fc->{main}->{humidity};
+			$w->{'pressure'} = int ($fc->{main}->{pressure} * 0.75006375541921);
+			$w->{'description'} = $fc->{weather}->[0]->{description};
+			$w->{'wind_speed'} = $fc->{wind}->{speed};
+			$w->{'wind_direction'} = 'разный';
+			my $dir = int ($fc->{wind}->{deg} + 0);
+
+			if ($dir == 0) {
+				$w->{'wind_direction'} = 'северный';
+			} elsif ($dir > 0   && $dir <= 30) {
+				$w->{'wind_direction'} = 'северо-северо-восточный';
+			} elsif ($dir > 30  && $dir <= 60) {
+				$w->{'wind_direction'} = 'северо-восточный';
+			} elsif ($dir > 60  && $dir <  90) {
+				$w->{'wind_direction'} = 'восточно-северо-восточный';
+			} elsif ($dir == 90) {
+				$w->{'wind_direction'} = 'восточный';
+			} elsif ($dir > 90  && $dir <= 120) {
+				$w->{'wind_direction'} = 'восточно-юго-восточный';
+			} elsif ($dir > 120 && $dir <= 150) {
+				$w->{'wind_direction'} = 'юговосточный';
+			} elsif ($dir > 150 && $dir <  180) {
+				$w->{'wind_direction'} = 'юго-юго-восточный';
+			} elsif ($dir == 180) {
+				$w->{'wind_direction'} = 'южный';
+			} elsif ($dir > 180 && $dir <= 210) {
+				$w->{'wind_direction'} = 'юго-юго-западный';
+			} elsif ($dir > 210 && $dir <= 240) {
+				$w->{'wind_direction'} = 'юго-западный';
+			} elsif ($dir > 240 && $dir <  270) {
+				$w->{'wind_direction'} = 'западно-юго-западный';
+			} elsif ($dir == 270) {
+				$w->{'wind_direction'} = 'западный';
+			} elsif ($dir > 270 && $dir <= 300) {
+				$w->{'wind_direction'} = 'западно-северо-западный';
+			} elsif ($dir > 300 && $dir <= 330) {
+				$w->{'wind_direction'} = 'северо-западный';
+			} elsif ($dir > 330 && $dir <  360) {
+				$w->{'wind_direction'} = 'северо-северо-западный';
+			} elsif ($dir == 360) {
+				$w->{'wind_direction'} = 'северный';
+			}
+
+			return $w;
+		} else {
+			# No geo, no weather :'(
+			return undef;
+		}
+	};
+
+	my $w = $cache->compute (
+		"$geo->{lat}+$geo->{lon}",
+		'3 hours',
+		$weatherCallBack,
+	);
+
+	my $reply;
+
+	if ($w) {
+		if ($w->{temperature_min} == $w->{temperature_max}) {
+			$reply = sprintf (
+				"Погода в городе %s, %s:\n%s, ветер %s %s м/c, температура %s°C, ощущается как %s°C, относительная влажность %s%%, давление %s мм.рт.с",
+				$city,
+				$w->{country},
+				ucfirst ($w->{description}),
+				$w->{wind_direction},
+				$w->{wind_speed},
+				$w->{temperature_min},
+				$w->{temperature_feelslike},
+				$w->{humidity},
+				$w->{pressure},
+			);
+		} else {
+			$reply = sprintf (
+				"Погода в городе %s, %s:\n%s, ветер %s %s м/c, температура %s-%s°C, ощущается как %s°C, относительная влажность %s%%, давление %s мм.рт.ст",
+				$city,
+				$w->{country},
+				ucfirst ($w->{description}),
+				$w->{wind_direction},
+				$w->{wind_speed},
+				$w->{temperature_min},
+				$w->{temperature_max},
+				$w->{temperature_feelslike},
+				$w->{humidity},
+				$w->{pressure},
+			);
+		}
+	} else {
+		$reply = "Я не знаю, какая погода в $city";
+	}
+
+	return $reply;
+}
+
+1;
+
+# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

lib/BotLib/Xkcd.pm

@@ -0,0 +1,42 @@
+package BotLib::Xkcd;
+
+use 5.018; ## no critic (ProhibitImplicitImport)
+use strict;
+use warnings;
+use utf8;
+use open qw (:std :utf8);
+use HTTP::Tiny ();
+
+use version; our $VERSION = qw (1.0);
+use Exporter qw (import);
+our @EXPORT_OK = qw (Xkcd);
+
+sub Xkcd {
+	my $http = HTTP::Tiny->new (timeout => 5, max_redirect => 0);
+	my $location;
+	my $status = 400;
+	my $c = 0;
+
+	do {
+		my $r = $http->get ('https://xkcd.ru/random/');
+
+		if (defined $r->{headers} && defined $r->{headers}->{location} && $r->{headers}->{location} ne '') {
+			$location = substr ($r->{headers}->{location}, 1, -1);
+			$location = sprintf 'https://xkcd.ru/i/%s_v1.png', $location;
+			$r = $http->head ($location);
+		}
+
+		$c++;
+		$status = $r->{status};
+	} while ($c < 3 || $status >= 404);
+
+	if ($status == 200) {
+		return $location;
+	}
+
+	return 'Комикс-стрип нарисовать не так-то просто :(';
+}
+
+1;
+
+# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

lib/JabberBot.pm

@@ -0,0 +1,207 @@
+# note http://www.gentoo.ru/node/21449
+# необходимо закомментировать строку $response{authzid} = $authzid;
+# в vendor_perl/5.24.3/Authen/SASL/Perl/DIGEST_MD5.pm
+package JabberBot;
+
+use 5.018; ## no critic (ProhibitImplicitImport)
+use strict;
+use warnings;
+use utf8;
+use open qw (:std :utf8);
+use English qw ( -no_match_vars );
+use File::Path qw (make_path);
+use Hailo ();
+use Log::Any qw ($log);
+use Net::Jabber::Bot ();
+use BotLib qw (Command RealJID);
+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 (RunJabberBot);
+
+my $c = LoadConf ();
+my $csign = $c->{jabberbot}->{aleesa}->{csign};
+my $hailo;
+my $imonline = 0;
+
+sub __background_checks {
+	my $bot = shift;
+
+	unless ($imonline) {
+		$bot->ChangeStatus ('Available', 'I\'m here');
+		$imonline = 1;
+	}
+
+	return;
+}
+
+sub __new_bot_message {
+	my %hash = @_;
+	my $bot = $hash{bot_object};
+
+	# ignore self messages
+	if ($hash{from_full} eq $bot->{from_full}) {
+		return;
+	}
+
+	my $text = $hash{body};
+	my %jid = RealJID (%hash);
+	my $chattername = $jid{name};
+	my $chatid;
+
+	if ($hash{type} eq 'groupchat') {
+		$chatid = utf2sha1 $hash{reply_to};
+	} else {
+		$chatid = utf2sha1 $jid{name};
+	}
+
+	$chatid =~ s/\//-/xmsg;
+
+	my $reply;
+
+	# lazy init chat-bot brains
+	unless (defined $hailo->{$chatid}) {
+		my $braindir = $c->{jabberbot}->{braindir};
+		my $brainname = sprintf '%s/%s.sqlite', $braindir, $chatid;
+
+		unless (-d $braindir) {
+			make_path ($braindir) or do {
+				$log->error ("[ERROR] Unable to create $braindir: $OS_ERROR");
+				return;
+			};
+		}
+
+		$hailo->{$chatid} = Hailo->new (
+			brain => $brainname,
+			order => 2,
+		);
+
+		if ($hash{type} eq 'groupchat') {
+			$log->info ("[INFO] Initialized brain for chat $hash{'reply_to'}: $brainname");
+		} else {
+			$log->info ("[INFO] Initialized brain for chat $jid{'jid'}: $brainname");
+		}
+	}
+
+	# parse messages
+	my $qname = quotemeta $bot->{alias};
+
+	if ($text =~ /^$qname\,?\s*$/u) {
+		$reply = 'Чего тебе?';
+	} elsif (($text =~ /^$qname[\,|\:]? (.+)/u) && ($hash{type} eq 'groupchat')) {
+		$reply = $hailo->{$chatid}->learn_reply ($1);
+	# karma adjustment
+	} elsif ($text =~ /(\+\+|\-\-)$/u) {
+		my @arr = split /\n/, $text;
+
+		if ($#arr < 1) {
+			$text =~ /(.*)(\+\+|\-\-)$/u;
+			$reply = KarmaSet ($chatid, trim ($1), $2); ## no critic (RegularExpressions::ProhibitCaptureWithoutTest)
+		} else {
+			# just message in chat
+			# in groupchat we answer only to phrases that mention us
+			if ($hash{type} eq 'groupchat') {
+				$hailo->{$chatid}->learn ($text);
+			# in tet-a-tet chat we must always answer, if possible
+			} elsif ($hash{type} eq 'chat') {
+				$reply = $hailo->{$chatid}->learn_reply ($text);
+			}
+		}
+	} elsif ((length ($text) > length ($csign)) && (substr ($text, 0, length ($csign)) eq $csign)) {
+		$reply = Command (%hash);
+	# just message in chat
+	} else {
+		my @smiles = ('=(', ':(', '):');
+		my $done = 0;
+
+		while (my $smile = pop @smiles) {
+			if ($text eq $smile) {
+				$reply = ':)';
+				$done = 1;
+				last;
+			}
+		}
+
+		unless ($done) {
+			$#smiles = -1;
+			@smiles = ('=)', ':)', '(:');
+
+			while (my $smile = pop @smiles) {
+				if ($text eq $smile) {
+					$reply = ':D';
+					$done = 1;
+					last;
+				}
+			}
+		}
+
+		unless ($done) {
+			# in groupchat we answer only to phrases that mention us
+			if ($hash{type} eq 'groupchat') {
+				$hailo->{$chatid}->learn ($text);
+			# in tet-a-tet chat we must always answer, if possible
+			} elsif ($hash{'type'} eq 'chat') {
+				$reply = $hailo->{$chatid}->learn_reply ($text);
+			}
+		}
+	}
+
+	if (defined $reply && ($reply ne '')) {
+		if ($hash{'type'} eq 'groupchat') {
+			$bot->SendGroupMessage ($hash{'reply_to'}, $reply);
+		} elsif ($hash{'type'} eq 'chat') {
+			$bot->SendPersonalMessage ($hash{'reply_to'}, $reply);
+		}
+	}
+
+	return;
+}
+
+
+sub RunJabberBot {
+	my %conflist = ();
+	$conflist{$c->{jabberbot}->{aleesa}->{room}} = [];
+	my $qname = quotemeta $c->{jabberbot}->{aleesa}->{mucname};
+
+	my $bot = Net::Jabber::Bot->new (
+		server              => $c->{jabberbot}->{aleesa}->{host},
+		server_host         => $c->{jabberbot}->{aleesa}->{host},
+		conference_server   => $c->{jabberbot}->{aleesa}->{confsrv},
+		tls                 => 1,
+		ssl_verify          => 0,
+		username            => $c->{jabberbot}->{aleesa}->{authname},
+
+		# threre is some nasty bug in module, so we have to set from_full explicitly
+		from_full           => sprintf (
+			'%s@%s/%s',
+			$c->{jabberbot}->{aleesa}->{room},
+			$c->{jabberbot}->{aleesa}->{confsrv},
+			$c->{jabberbot}->{aleesa}->{authname},
+		),
+		password            => $c->{jabberbot}->{aleesa}->{password},
+		alias               => $c->{jabberbot}->{aleesa}->{mucname}, # name on confs
+		resource            => 'bot',
+		safety_mode         => 1,
+		message_function    => \&__new_bot_message,
+		background_function => \&__background_checks,
+		loop_sleep_time     => 60,
+		forums_and_responses => \%conflist,
+	);
+
+	while (sleep 3) {
+		eval {
+			$imonline = 0;
+			$bot->Start ();
+		};
+	}
+
+	return;
+}
+
+
+1;
+
+# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

lib/botlib.pm

@@ -1,238 +0,0 @@
-package botlib;
-
-use 5.018;
-use strict;
-use warnings "all";
-use utf8;
-use open qw(:std :utf8);
-
-use HTTP::Tiny;
-use URI::URL;
-use JSON::XS qw(decode_json encode_json);
-use Digest::MD5 qw(md5_base64);
-use DB_File;
-
-use conf qw(loadConf);
-
-use vars qw/$VERSION/;
-
-use Exporter qw(import);
-our @EXPORT = qw(weather logger trim randomCommonPhrase);
-
-$VERSION = "1.0";
-
-my $c = loadConf();
-
-sub weather($) {
-	my $city = shift;
-	$city = trim($city);
-
-	return "Мне нужно ИМЯ города." if ($city eq '');
-	return "Длинновато для названия города." if (length($city) > 80);
-
-	$city = ucfirst($city);
-	my $w = __weather($city);
-	my $reply;
-
-	if ($w) {
-		if ($w->{temperature_min} == $w->{temperature_max}) {
-			$reply = sprintf ("Погода в городе %s, %s:\n%s, ветер %s %s м/c, температура %s°C, ощущается как %s°C, относительная влажность %s%%, давление %s мм.рт.ст",
-				$w->{name},
-				$w->{country},
-				ucfirst($w->{description}),
-				$w->{wind_direction},
-				$w->{wind_speed},
-				$w->{temperature_min},
-				$w->{temperature_feelslike},
-				$w->{humidity},
-				$w->{pressure}
-			);
-		} else {
-			$reply = sprintf ("Погода в городе %s, %s:\n%s, ветер %s %s м/c, температура %s-%s°C, ощущается как %s°C, относительная влажность %s%%, давление %s мм.рт.ст",
-				$w->{name},
-				$w->{country},
-				ucfirst($w->{description}),
-				$w->{wind_direction},
-				$w->{wind_speed},
-				$w->{temperature_min},
-				$w->{temperature_max},
-				$w->{temperature_feelslike},
-				$w->{humidity},
-				$w->{pressure}
-			);
-		}
-	} else {
-		$reply = "Я не знаю, какая погода в $city";
-	}
-
-	return $reply;
-}
-
-sub __weather($) {
-	my $city = shift;
-	$city = __urlencode($city);
-	my $id = md5_base64($city);
-	my $appid = $c->{openweathermap}->{appid};
-	my $now = time();
-	my $fc;
-	my $w;
-
-# attach to cache data
-	tie my %cachetime, 'DB_File', $c->{openweathermap}->{cachetime} or do {
-		warn "Something nasty happen when cachetime ties to its data: $!";
-		return undef;
-	};
-
-	tie my %cachedata, 'DB_File', $c->{openweathermap}->{cachedata} or do {
-		warn "Something nasty happen when cachedata ties to its data: $!";
-		return undef;
-	};
-
-# lookup cache
-	if (defined ($cachetime{$id}) && ($now - $cachetime{$id}) < 10800) {
-		$fc = decode_json($cachedata{$id});
-	} else {
-		my $r;
-
-# try 3 times and giveup
-		for (my $counter = 0; $counter < 3; $counter++) {
-			next if ($r->{success});
-			my $http = HTTP::Tiny->new(timeout => 3);
-			$r = $http->get(sprintf("http://api.openweathermap.org/data/2.5/weather?q=%s&lang=ru&APPID=%s", $city, $appid));
-			sleep 2;
-		}
-
-# all 3 times can give error, so check it here
-		if ($r->{success}) {
-			$fc = eval { decode_json($r->{content}) };
-
-			if ($@) {
-				warn "[WARN] openweathermap returns corrupted json: $@";
-				untie %cachetime;
-				untie %cachedata;
-				return undef;
-			};
-
-			$cachetime{$id} = $now;
-			$cachedata{$id} = encode_json($fc);
-		} else {
-			untie %cachetime;
-			untie %cachedata;
-			return undef;
-		}
-	}
-
-	untie %cachetime;
-	untie %cachedata;
-
-# TODO: check all of this for existance
-	$w->{'name'} = $fc->{name};
-	$w->{'state'} = $fc->{state};
-	$w->{'country'} = $fc->{sys}->{country};
-	$w->{'longitude'} = $fc->{coord}->{lon};
-	$w->{'latitude'} = $fc->{coord}->{lat};
-	$w->{'temperature_min'} = int($fc->{main}->{temp_min} - 273.15);
-	$w->{'temperature_max'} = int($fc->{main}->{temp_max} - 273.15);
-	$w->{'temperature_feelslike'} = int($fc->{main}->{feels_like} - 273.15);
-	$w->{'humidity'} = $fc->{main}->{humidity};
-	$w->{'pressure'} = int($fc->{main}->{pressure} * 0.75006375541921);
-	$w->{'description'} = $fc->{weather}->[0]->{description};
-	$w->{'wind_speed'} = $fc->{wind}->{speed};
-	$w->{'wind_direction'} = 'разный';
-	my $dir = int($fc->{wind}->{deg} + 0);
-
-	if ($dir == 0) {
-		$w->{'wind_direction'} = 'северный';
-	} elsif ($dir > 0   && $dir <= 30) {
-		$w->{'wind_direction'} = 'северо-северо-восточный';
-	} elsif ($dir > 30  && $dir <= 60) {
-		$w->{'wind_direction'} = 'северо-восточный';
-	} elsif ($dir > 60  && $dir <  90) {
-		$w->{'wind_direction'} = 'восточно-северо-восточный';
-	} elsif ($dir == 90) {
-		$w->{'wind_direction'} = 'восточный';
-	} elsif ($dir > 90  && $dir <= 120) {
-		$w->{'wind_direction'} = 'восточно-юго-восточный';
-	} elsif ($dir > 120 && $dir <= 150) {
-		$w->{'wind_direction'} = 'юговосточный';
-	} elsif ($dir > 150 && $dir <  180) {
-		$w->{'wind_direction'} = 'юго-юго-восточный';
-	} elsif ($dir == 180) {
-		$w->{'wind_direction'} = 'южный';
-	} elsif ($dir > 180 && $dir <= 210) {
-		$w->{'wind_direction'} = 'юго-юго-западный';
-	} elsif ($dir > 210 && $dir <= 240) {
-		$w->{'wind_direction'} = 'юго-западный';
-	} elsif ($dir > 240 && $dir <  270) {
-		$w->{'wind_direction'} = 'западно-юго-западный';
-	} elsif ($dir == 270) {
-		$w->{'wind_direction'} = 'западный';
-	} elsif ($dir > 270 && $dir <= 300) {
-		$w->{'wind_direction'} = 'западно-северо-западный';
-	} elsif ($dir > 300 && $dir <= 330) {
-		$w->{'wind_direction'} = 'северо-западный';
-	} elsif ($dir > 330 && $dir <  360) {
-		$w->{'wind_direction'} = 'северо-северо-западный';
-	} elsif ($dir == 360) {
-		$w->{'wind_direction'} = 'северный';
-	}
-
-	return $w;
-}
-
-sub __urlencode($) {
-	my $str = shift;
-	my $urlobj = url $str;
-	$str = $urlobj->as_string;
-	$urlobj = undef; undef $urlobj;
-	return $str;
-}
-
-sub logger {
-	my $msg = shift;
-
-	if ($c->{debug_log}) {
-		my $mode = '>';
-		$mode = '>>' if (-f $c->{debug_log});
-
-		if (open (LOG, $mode, $c->{debug_log})) {
-			print LOG $msg . "\n";
-			close LOG;
-		}
-	}
-}
-
-sub trim($) {
-	my $str = shift;
-
-	while (substr ($str, 0, 1) =~ /^\s$/) {
-		$str = substr($str, 1);
-	}
-
-	while (substr ($str, -1, 1) =~ /^\s$/) {
-		chop ($str);
-	}
-
-	return $str;
-}
-
-sub randomCommonPhrase() {
-	my @myphrase = (
-		"Так, блядь...",
-		"*Закатывает рукава* И ради этого ты меня позвал?",
-		"Ну чего ты начинаешь, нормально же общались",
-		"Повтори свой вопрос, не поняла",
-		"Выйди и зайди нормально",
-		"Я подумаю",
-		"Даже не знаю что на это ответить",
-		"Ты упал такие вопросы девочке задавать?",
-		"Можно и так, но не уверена",
-		"А как ты думаешь?"
-	);
-
-	return ($myphrase[rand($#myphrase -1)]);
-}
-
-1;
-
-# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

lib/conf.pm

@@ -1,69 +0,0 @@
-package conf;
-
-use 5.018;
-use strict;
-use warnings "all";
-use utf8;
-use open qw(:std :utf8);
-
-use vars qw/$VERSION/;
-use Fcntl qw(O_WRONLY O_CREAT O_TRUNC);
-use JSON::XS qw(decode_json encode_json);
-
-use Exporter qw(import);
-our @EXPORT = qw(loadConf saveConf);
-
-$VERSION = "1.0";
-sub loadConf ();
-sub saveConf ($);
-
-sub loadConf () {
-	my $c = "data/config.json";
-	open (C, "<", $c) or die "[FATA] No conf at $c: $!\n";
-	my $len = (stat ($c)) [7];
-	my $json;
-	my $readlen = read (C, $json, $len);
-
-	unless ($readlen) {
-		close C;
-		die "[FATA] Unable to read $c: $!\n";
-	}
-
-	if ($readlen != $len) {
-		close C;
-		die "[FATA] File $c is $len bytes on disk, but we read only $readlen bytes\n";
-	}
-
-	close C;
-	my $j = JSON::XS->new->utf8->relaxed;
-	return $j->decode ($json);
-}
-
-sub saveConf($) {
-	my $c = shift;
-	my $file = "data/myapi.json";
-	my $j = JSON::XS->new->pretty->canonical->indent (1);
-	my $json = $j->encode ($c);
-	$j = undef; undef $j;
-	use bytes;
-	my $len = length ($json);
-	no bytes;
-	# TODO: make it transactional
-	sysopen (C, $file, O_WRONLY|O_CREAT|O_TRUNC) or die "[FATA] Unable to open $file: $!\n";
-
-	my $written = syswrite (C, $json, $len);
-
-	unless (defined ($written)) {
-		die "[FATA] Unable to write to $file: $!";
-	}
-
-	unless ($written != $len) {
-		die "[FATA] We wrote $written bytes to $file, bu buffer length id $len bytes\n";
-	}
-
-	close C;
-}
-
-1;
-
-# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

lib/jabberbot.pm

@@ -1,172 +0,0 @@
-# note http://www.gentoo.ru/node/21449
-# необходимо закомменировать строку $response{authzid} = $authzid;
-# в vendor_perl/5.24.3/Authen/SASL/Perl/DIGEST_MD5.pm
-package jabberbot;
-
-use 5.018;
-use strict;
-use warnings "all";
-use utf8;
-use open qw(:std :utf8);
-
-use Net::Jabber::Bot;
-use Hailo;
-
-use conf;
-use botlib;
-
-use Exporter qw(import);
-use vars qw/$VERSION/;
-$VERSION = "1.0";
-our @EXPORT = qw(run_jabberbot);
-
-my $c = loadConf();
-my $hailo;
-my $imonline = 0;
-
-sub __background_checks {
-	my $bot = shift;
-
-	unless ($imonline) {
-		$bot->ChangeStatus('Chat', 'I\'m here');
-		$imonline = 1;
-	}
-
-	return;
-}
-
-sub __new_bot_message {
-	my %hash = @_;
-	my $bot = $hash{bot_object};
-#	my $text = encode('utf-8', $hash{body});
-	my $text = $hash{body};
-
-	if ($hash{'type'} eq "groupchat") {
-		# ignore self messages
-		return if ($hash{'from_full'} eq $bot->{'from_full'});
-		# parse messages
-		my $qname = quotemeta($c->{jabberbot}->{aleesa}->{mucname});
-		if ($text =~ /^$qname$/) {
-			$bot->SendGroupMessage($hash{'reply_to'}, "Чего тебе?");
-		} elsif ($text =~ /^$qname[\,|\:]? (.+)/) {
-#			$bot->SendGroupMessage($hash{'reply_to'}, $hailo->learn_reply(decode('utf-8', $1)));
-			$bot->SendGroupMessage($hash{'reply_to'}, $hailo->learn_reply($1));
-		} elsif ($text eq "$c->{jabberbot}->{aleesa}->{csign}пинг") {
-			$bot->SendGroupMessage($hash{'reply_to'}, "Понг.");
-		} elsif ($text eq "$c->{jabberbot}->{aleesa}->{csign}ping") {
-			$bot->SendGroupMessage($hash{'reply_to'}, "Pong.");
-		} elsif (substr($text, 0, 1) eq $c->{jabberbot}->{aleesa}->{csign}) {
-#			$text = decode('utf-8', $text);
-
-			if (substr($text, 1, 3) eq "rum") {
-				eval {
-					$bot->SendGroupMessage(
-						$hash{'reply_to'},
-						"/me притаскивает на подносе стопку рома для ". (split(/\//,$hash{from_full}))[1] . ", края стопки искрятся кристаллами соли."
-					);
-				};
-			} elsif (substr($text, 1, 5) eq "vodka") {
-				eval {
-					$bot->SendGroupMessage(
-						$hash{'reply_to'},
-						"/me подаёт водку с маринованным огурчиком для " . (split(/\//,$hash{from_full}))[1]
-					);
-				};
-			} elsif (substr($text, 1, 4) eq "beer") {
-				eval {
-					$bot->SendGroupMessage(
-						$hash{'reply_to'},
-						"/me бахает об стол перед " . (split(/\//,$hash{from_full}))[1] . " кружкой холодного пива, часть пенной шапки сползает по запотевшей спенке кружки."
-					);
-				};
-			} elsif (substr($text, 1, 7) eq "tequila") {
-				eval {
-					$bot->SendGroupMessage(
-						$hash{'reply_to'},
-						"/me ставит рядом с " . (split(/\//,$hash{from_full}))[1] . " шот текилы, аккуратно на ребро стопки насаживает дольку лайма и ставит кофейное блюдце с горочкой соли."
-					);
-				};
-			} elsif (substr($text, 1, 6) eq "whisky") {
-				eval {
-					$bot->SendGroupMessage(
-						$hash{'reply_to'},
-						"/me демонстративно достаёт из морозилки пару кубических камушков, бросает их в толстодонный стакан и аккуратно наливает Jack Daniels. Запускает стакан вдоль барной стойки, он останавливается около " . (split(/\//,$hash{from_full}))[1] . "."
-					);
-				};
-			} elsif (substr($text, 1, 8) eq "absinthe") {
-				eval {
-					$bot->SendGroupMessage(
-						$hash{'reply_to'},
-						"/me наливает абсент в стопку. Смочив кубик сахара в абсенте кладёт его на дырявую ложечку и пожигает. Как только пламя потухнет, $c->{jabberbot}->{aleesa}->{mucname} размешивает оплавившийся кубик в абсенте и подносит стопку " .(split(/\//,$hash{from_full}))[1] . "."
-					);
-				};
-			} elsif ((substr($text, 1, 2) eq "w ") || (substr($text, 1, 2) eq "п ")) {
-				my $city = substr($text, 2);
-
-				eval {
-					$bot->SendGroupMessage(
-						$hash{'reply_to'},
-						weather($city) =~ tr/\n/ /r
-					);
-				};
-			} else {
-				#$hailo->learn($text);
-				return;
-			}
-		} else {
-			#$hailo->learn($text);
-			return;
-		}
-	} elsif ($hash{'type'} eq "chat") {
-		$bot->SendPersonalMessage($hash{'reply_to'}, "Я вас не знаю, идите нахуй.");
-		return;
-	}
-
-	return;
-}
-
-
-sub run_jabberbot {
-	$hailo = Hailo->new(
-		brain => $c->{jabberbot}->{aleesa}->{brain},
-		order => 3
-	);
-
-	my %conflist = ();
-	$conflist{$c->{jabberbot}->{aleesa}->{room}} = [];
-	my $qname = quotemeta($c->{jabberbot}->{aleesa}->{mucname});
-
-	my $bot = Net::Jabber::Bot->new(
-		server => $c->{jabberbot}->{aleesa}->{host},
-		server_host => $c->{jabberbot}->{aleesa}->{host},
-		conference_server => $c->{jabberbot}->{aleesa}->{confsrv},
-		tls => 0,
-		username => $c->{jabberbot}->{aleesa}->{authname},
-# threre is some nasty bug in module, so we have to set from_full explicitly
-		from_full => sprintf(
-			"%s@%s/%s",
-			$c->{jabberbot}->{aleesa}->{room},
-			$c->{jabberbot}->{aleesa}->{confsrv},
-			$c->{jabberbot}->{aleesa}->{authname}
-		),
-		password => $c->{jabberbot}->{aleesa}->{password},
-		alias => $c->{jabberbot}->{aleesa}->{mucname}, # name on confs
-		resource => 'bot',
-		safety_mode => 1,
-		message_function => \&__new_bot_message,
-		background_function => \&__background_checks,
-		loop_sleep_time => 60,
-		forums_and_responses => \%conflist,
-	);
-
-	while (sleep 3) {
-		eval {
-			$imonline = 0;
-			$bot->Start();
-		};
-	}
-}
-
-1;
-
-# vim: set ft=perl noet ai ts=4 sw=4 sts=4: