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

@@ -5,8 +5,10 @@ data/*.sqlite
 data/cache/**
 data/fortune/**
 data/friday/**
+data/image/**
 data/karma/**
 data/lat/**
+data/proverb/**
 TODO
 *.pid
 *.log

.perlcriticrc

@@ -1,4 +1,17 @@
 #!/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
 
@@ -98,3 +111,39 @@ lib_sections    = NAME | VERSION | DESCRIPTION | AUTHOR | LICENSE AND COPYRIGHT
 
 [-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

bin/aleesa-jabber-bot

@@ -1,6 +1,6 @@
 #!/usr/bin/perl
 
-use 5.018;
+use 5.018; ## no critic (ProhibitImplicitImport)
 use strict;
 use warnings;
 use utf8;
@@ -13,26 +13,28 @@ my $workdir;
 # before we run, change working dir
 BEGIN {
 	use Cwd qw (chdir abs_path);
-	my @CWD = split (/\//, abs_path ($PROGRAM_NAME));
+	my @CWD = split /\//, abs_path ($PROGRAM_NAME);
 
 	if ($#CWD > 1) {
 		$#CWD = $#CWD - 2;
 	}
 
-	$workdir = join ('/', @CWD);
+	$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 Log::Any::Adapter;
-use Log::Any::For::Std;
-use conf qw (loadConf);
-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 ();
@@ -42,13 +44,14 @@ local $OUTPUT_AUTOFLUSH = 1;
 my $runAsUid = $UID;
 
 my $piddir = '/var/run/' . basename (abs_path $PROGRAM_NAME);
-my $C = loadConf ();
+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 (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
@@ -61,8 +64,8 @@ if ($UID == 0) {
 		make_path (
 			$piddir, {
 				uid   => $uid,
-				group => $gid
-			}
+				group => $gid,
+			},
 		) or die "Unable to create $piddir: $OS_ERROR\n";
 	}
 
@@ -73,8 +76,8 @@ if ($UID == 0) {
 			make_path (
 				$logdir, {
 					uid   => $uid,
-					group => $gid
-				}
+					group => $gid,
+				},
 			) or die "Unable to create $logdir: $OS_ERROR\n";
 		}
 	}
@@ -87,9 +90,23 @@ if ($UID == 0) {
 }
 
 if (defined $logfile) {
-	Log::Any::Adapter->set ('File', $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 {
-	Log::Any::Adapter->set ('File', '/dev/null');
+	# 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
@@ -99,14 +116,24 @@ daemonize ();
 my $apath = abs_path $PROGRAM_NAME;
 
 unless (defined $apath) {
-	die "Unable to get abs_path: $OS_ERROR\n";
+	$log->fatal ("[FATAL] Unable to get abs_path: $OS_ERROR");
+	exit 1;
 }
 
 my $pidfile = sprintf '%s/%s.pid', $piddir, basename $apath;
-warn "Creating pidfile at $pidfile\n";
-open (my $pid, '>', $pidfile) or die "Error opening $pidfile: $OS_ERROR\n";
-print $pid $PID or die "Error writing to $pidfile: $OS_ERROR\n";
-close $pid;  ## no critic (InputOutput::RequireCheckedSyscalls)
+$log->info ("[INFO] Creating pidfile at $pidfile");
+
+open (my $pid, '>', $pidfile) or do {
+	$log->fatal ("[FATAL] Error opening $pidfile: $OS_ERROR");
+	exit 1;
+};
+
+print $pid $PID or do {
+	$log->fatal ("[FATAL] Error writing to $pidfile: $OS_ERROR");
+	exit 1;
+};
+
+close $pid;                              ## no critic (InputOutput::RequireCheckedSyscalls)
 
 local $SIG{INT}  = \&__signal_handler;
 local $SIG{TERM} = \&__signal_handler;
@@ -114,9 +141,9 @@ local $SIG{TERM} = \&__signal_handler;
 # set correct proctitle
 $PROGRAM_NAME = abs_path $PROGRAM_NAME;  ## no critic (Variables::RequireLocalizedPunctuationVars)
 
-run_jabberbot ();
+RunJabberBot ();
 
-if (-f $pidfile) {
+if (-e $pidfile) {
 	unlink $pidfile;
 }
 
@@ -125,10 +152,10 @@ exit 0;
 sub daemonize () {
 	__fork ();
 	POSIX::setsid ();
-	open (STDIN, '<', '/dev/null');   ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
+	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, '>', '/dev/null'); ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
-	#open (STDERR, '>', '/dev/null'); ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
+	#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;
@@ -138,20 +165,21 @@ sub __fork () {
 	my $pid = fork;
 
 	unless (defined $pid) {
-		die "Can't fork: $OS_ERROR\n";
+		$log->fatal ("[FATAL] Can't fork: $OS_ERROR");
+		exit 1;
 	}
 
 	if ($pid != 0) {
-		exit;
+		exit 0;
 	}
 
 	return;
 }
 
 sub __signal_handler ($) {
-	warn "Caught a signal $OS_ERROR\n";
+	$log->info ("[INFO] Caught a signal $OS_ERROR");
 
-	if (-f $pidfile) {
+	if (-e $pidfile) {
 		unlink $pidfile;
 	}
 

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

@@ -1,6 +1,6 @@
 #!/usr/bin/perl
 
-use 5.018;
+use 5.018; ## no critic (ProhibitImplicitImport)
 use strict;
 use warnings;
 use utf8;
@@ -21,8 +21,8 @@ BEGIN {
 }
 
 use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
-use fortune qw (seed);
+use BotLib::Fortune qw (Seed);
 
-seed ();
+Seed ();
 
 exit 0;

bin/friday_seed.pl

@@ -1,6 +1,6 @@
 #!/usr/bin/perl
 
-use 5.018;
+use 5.018; ## no critic (ProhibitImplicitImport)
 use strict;
 use warnings;
 use utf8;
@@ -20,8 +20,8 @@ BEGIN {
 }
 
 use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
-use friday qw (seed);
+use BotLib::Friday qw (Seed);
 
-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

@@ -1,6 +1,6 @@
 #!/usr/bin/perl
 
-use 5.018;
+use 5.018; ## no critic (ProhibitImplicitImport)
 use strict;
 use warnings;
 use utf8;
@@ -20,7 +20,7 @@ BEGIN {
 }
 
 use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
-use lat qw (train);
+use Lat qw (Train);
 
-train ();
+Train ();
 exit 0;

confcheck.pl

@@ -12,7 +12,7 @@ use JSON::PP;
 use version; our $VERSION = qw (1.0);
 
 my $c = 'data/config.json';
-open (my $C, '<', $c) || die "No conf at $c: $OS_ERROR\n"; ## no critic (InputOutput::RequireBriefOpen)
+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);

cpanfile

@@ -1,10 +1,15 @@
+## 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';
@@ -14,11 +19,13 @@ 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';

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,12 +17,19 @@
             "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"
     },
     "log" : "/var/log/aleesa-jabber-bot/aleesa-jabber-bot.log",
+    "loglevel": "info",
     "lat" : {
         "brain" : "data/lat/brain.sqlite",
         "src" : "lat.txt"
@@ -32,6 +41,10 @@
         "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

@@ -1,14 +1,19 @@
+## 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 vars qw($VERSION @Plugins);
-use Carp;
+use warnings;
+use utf8;
 
-$VERSION = "2.16";
+use vars qw($VERSION @Plugins); ## no critic (Variables::ProhibitPackageVars)
+use Carp qw (croak);
+
+$VERSION = '2.16';
 
 @Plugins = qw(
 	Authen::SASL::XS
@@ -21,9 +26,10 @@ sub import {
   shift;
   return unless @_;
 
-  local $SIG{__DIE__};
-  @Plugins = grep { /^[:\w]+$/ and eval "require $_" } map { /::/ ? $_ : "Authen::SASL::$_" } @_
-    or croak "no valid Authen::SASL plugins found";
+  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;
 }
 
 
@@ -44,13 +50,13 @@ sub new {
   $self->callback(pass => $opt{password}) if exists $opt{password};
   $self->callback(pass => $opt{response}) if exists $opt{response};
 
-  $self;
+  return $self;
 }
 
 
 sub mechanism {
   my $self = shift;
-  @_ ? $self->{mechanism} = shift
+  return @_ ? $self->{mechanism} = shift
      : $self->{mechanism};
 }
 
@@ -62,7 +68,7 @@ sub callback {
   my %new = @_;
   @{$self->{callback}}{keys %new} = values %new;
 
-  $self->{callback};
+  return $self->{callback};
 }
 
 # The list of packages should not really be hardcoded here
@@ -73,7 +79,7 @@ sub client_new { # $self, $service, $host, $secflags
 
   my $err;
   foreach my $pkg (@Plugins) {
-    if (eval "require $pkg" and $pkg->can("client_new")) {
+    if (eval "require $pkg" and $pkg->can('client_new')) { ## no critic (BuiltinFunctions::ProhibitStringyEval)
       if ($self->{conn} = eval { $pkg->client_new($self, @_) }) {
         return $self->{conn};
       }
@@ -81,7 +87,7 @@ sub client_new { # $self, $service, $host, $secflags
     }
   }
 
-  croak $err || "Cannot find a SASL Connection library";
+  croak $err || 'Cannot find a SASL Connection library';
 }
 
 sub server_new { # $self, $service, $host, $secflags
@@ -89,19 +95,19 @@ sub server_new { # $self, $service, $host, $secflags
 
   my $err;
   foreach my $pkg (@Plugins) {
-    if (eval "require $pkg" and $pkg->can("server_new")) {
+    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 = $@;
+      $err = $@; ## no critic (Variables::ProhibitPunctuationVars)
     }
   }
-  croak $err || "Cannot find a SASL Connection library for server-side authentication";
+  croak $err || 'Cannot find a SASL Connection library for server-side authentication';
 }
 
 sub error {
   my $self = shift;
-  $self->{conn} && $self->{conn}->error;
+  return $self->{conn} && $self->{conn}->error;
 }
 
 # Compat.
@@ -109,22 +115,22 @@ sub user {
   my $self = shift;
   my $user = $self->{callback}{user};
   $self->{callback}{user} = shift if @_;
-  $user;
+  return $user;
 }
 
 sub challenge {
   my $self = shift;
-  $self->{conn}->client_step(@_);
+  return $self->{conn}->client_step(@_);
 }
 
 sub initial {
   my $self = shift;
-  $self->client_new($self)->client_start;
+  return $self->client_new($self)->client_start;
 }
 
 sub name {
   my $self = shift;
-  $self->{conn} ? $self->{conn}->mechanism : ($self->{mechanism} =~ /(\S+)/)[0];
+  return $self->{conn} ? $self->{conn}->mechanism : ($self->{mechanism} =~ /(\S+)/)[0];
 }
 
 1;

lib/Authen/SASL/CRAM_MD5.pm

@@ -4,14 +4,20 @@
 
 package Authen::SASL::CRAM_MD5;
 
+use 5.018; ## no critic (ProhibitImplicitImport)
+use warnings;
 use strict;
+use utf8;
+
 use vars qw($VERSION);
 
-$VERSION = "2.14";
+$VERSION = '2.14';
+
+use Authen::SASL ();
 
 sub new {
   shift;
-  Authen::SASL->new(@_, mechanism => 'CRAM-MD5');
+  return Authen::SASL->new(@_, mechanism => 'CRAM-MD5');
 }
 
 1;

lib/Authen/SASL/EXTERNAL.pm

@@ -4,14 +4,19 @@
 
 package Authen::SASL::EXTERNAL;
 
+use 5.018; ## no critic (ProhibitImplicitImport)
 use strict;
+use warnings;
+use utf8;
+
 use vars qw($VERSION);
 
-$VERSION = "2.14";
+$VERSION = '2.14';
 
+use Authen::SASL ();
 sub new {
   shift;
-  Authen::SASL->new(@_, mechanism => 'EXTERNAL');
+  return Authen::SASL->new(@_, mechanism => 'EXTERNAL');
 }
 
 1;

lib/Authen/SASL/Perl/ANONYMOUS.pm

@@ -1,33 +1,38 @@
+## 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";
+$VERSION = '2.14';
 @ISA	 = qw(Authen::SASL::Perl);
 
 my %secflags = (
 	noplaintext => 1,
 );
 
-sub _order { 0 }
+sub _order { return 0 }
 sub _secflags {
   shift;
-  grep { $secflags{$_} } @_;
+  return grep { $secflags{$_} } @_;
 }
 
-sub mechanism { 'ANONYMOUS' }
+sub mechanism { return 'ANONYMOUS' }
 
 sub client_start {
-  shift->_call('authname')
+  return shift->_call('authname');
 }
 
 sub client_step {
-  shift->_call('authname')
+  return shift->_call('authname');
 }
 
 1;

lib/Authen/SASL/Perl/CRAM_MD5.pm

@@ -1,14 +1,19 @@
+## 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";
+$VERSION = '2.14';
 @ISA	 = qw(Authen::SASL::Perl);
 
 my %secflags = (
@@ -16,16 +21,16 @@ my %secflags = (
 	noanonymous => 1,
 );
 
-sub _order { 2 }
+sub _order { return 2 }
 sub _secflags {
   shift;
-  scalar grep { $secflags{$_} } @_;
+  return scalar grep { $secflags{$_} } @_;
 }
 
-sub mechanism { 'CRAM-MD5' }
+sub mechanism { return 'CRAM-MD5' }
 
 sub client_start {
-  '';
+  return '';
 }
 
 sub client_step {
@@ -35,7 +40,7 @@ sub client_step {
     defined($v) ? $v : ''
   } qw(user pass);
 
-  $user . " " . hmac_md5_hex($string,$pass);
+  return $user . ' ' . hmac_md5_hex($string,$pass);
 }
 
 1;

lib/Authen/SASL/Perl/DIGEST_MD5.pm

@@ -1,3 +1,4 @@
+## 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
@@ -7,15 +8,20 @@
 
 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);
+$VERSION = '2.14';
+@ISA = qw(Authen::SASL::Perl); ## no critic (ClassHierarchies::ProhibitExplicitISA)
 
 my %secflags = (
   noplaintext => 1,
@@ -56,7 +62,7 @@ my @ourciphers = (
         sub { goto &Crypt::RC4::RC4; };
       *Crypt::RC4::keysize   =  sub {128};
       *Crypt::RC4::blocksize =  sub {1};
-    }
+    },
   },
   {
     name  => '3des',
@@ -99,7 +105,7 @@ my @ourciphers = (
         sub { goto &Crypt::RC4::RC4; };
       *Crypt::RC4::keysize   =  sub {56};
       *Crypt::RC4::blocksize =  sub {1};
-    }
+    },
   },
   {
     name  => 'rc4-40',
@@ -114,27 +120,27 @@ my @ourciphers = (
         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}";
-    unless ($@) {
+    eval "require $_->{pkg}"; ## no critic (BuiltinFunctions::ProhibitStringyEval)
+    unless ($@) { ## no critic (Variables::ProhibitPunctuationVars)
         $NO_CRYPT_AVAILABLE = 0;
         last;
     }
 }
 
-sub _order { 3 }
+sub _order { return 3 }
 sub _secflags {
   shift;
-  scalar grep { $secflags{$_} } @_;
+  return scalar grep { $secflags{$_} } @_;
 }
 
-sub mechanism { 'DIGEST-MD5' }
+sub mechanism { return 'DIGEST-MD5' }
 
 sub _init {
   my ($pkg, $self) = @_;
@@ -146,14 +152,14 @@ sub _init {
   $self->property('maxbuf',      0xFFFFFF);         # maximum supported by GSSAPI mech
   $self->property('externalssf', 0);
 
-  $self;
+  return $self;
 }
 
 sub _init_server {
   my $server  = shift;
   my $options = shift || {};
-  if (!ref $options or ref $options ne 'HASH') {
-    warn "options for DIGEST_MD5 should be a hashref";
+  if (!ref $options || ref $options ne 'HASH') {
+    warn 'options for DIGEST_MD5 should be a hashref'; ## no critic (ErrorHandling::RequireCarping)
     $options = {};
   }
 
@@ -167,7 +173,7 @@ sub _init_server {
                              or $options->{no_confidentiality}
                              or $NO_CRYPT_AVAILABLE;
 
-  $server->{supported_qop} = { map { $_ => 1 } @qop };
+  return $server->{supported_qop} = { map { $_ => 1 } @qop };
 }
 
 sub init_sec_layer {
@@ -181,6 +187,7 @@ sub init_sec_layer {
   # reset properties for new session
   $self->property(maxout => undef);
   $self->property(ssf    => undef);
+  return;
 }
 
 # no initial value passed to the server
@@ -191,7 +198,7 @@ sub client_start {
   $self->{error}     = undef;
   $self->{state}     = 0;
   $self->init_sec_layer;
-  '';
+  return '';
 }
 
 sub server_start {
@@ -201,7 +208,7 @@ sub server_start {
 
   $self->{need_step} = 1;
   $self->{error}     = undef;
-  $self->{nonce}     = md5_hex($NONCE || join (":", $$, time, rand));
+  $self->{nonce}     = md5_hex($NONCE || join (':', $$, time, rand)); ## no critic (Variables::ProhibitPunctuationVars)
 
   $self->init_sec_layer;
 
@@ -243,9 +250,9 @@ sub client_step {   # $self, $server_sasl_credentials
 
   if ($self->{state} == 1) {
     # check server's `rspauth' response
-    return $self->set_error("Server did not send rspauth in step 2")
+    return $self->set_error('Server did not send rspauth in step 2')
       unless ($sparams{rspauth});
-    return $self->set_error("Invalid rspauth in step 2")
+    return $self->set_error('Invalid rspauth in step 2')
       unless ($self->{rspauth} eq $sparams{rspauth});
 
     # all is well
@@ -255,15 +262,15 @@ sub client_step {   # $self, $server_sasl_credentials
 
   # 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")
+    return $self->set_error("Server did not provide required field(s): @missing");
   }
 
   my %response = (
     nonce        => $sparams{'nonce'},
-    cnonce       => md5_hex($CNONCE || join (":", $$, time, rand)),
+    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'}}),
+    nc           => sprintf('%08d',     ++$self->{nonce_counts}{$sparams{'nonce'}}),
     charset      => $sparams{'charset'},
   );
 
@@ -273,7 +280,7 @@ sub client_step {   # $self, $server_sasl_credentials
   # let caller-provided fields override defaults: authorization ID, service name, realm
 
   my $s_realm = $sparams{realm} || [];
-  my $realm = $self->_call('realm', @$s_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];
@@ -293,12 +300,12 @@ sub client_step {   # $self, $server_sasl_credentials
   }
 
   my $user = $self->_call('user');
-  return $self->set_error("Username is required")
+  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")
+  return $self->set_error('Password is required')
     unless defined $password;
 
   $self->property('maxout', $sparams{maxbuf} || 65536);
@@ -313,7 +320,7 @@ sub client_step {   # $self, $server_sasl_credentials
   $self->{rspauth}    = $rspauth;
 
   # finally, return our response token
-  return _response(\%response, "is_client");
+  return _response(\%response, 'is_client');
 }
 
 sub _compute_digests_and_set_keys {
@@ -326,18 +333,18 @@ sub _compute_digests_and_set_keys {
   }
 
   my $realm = $params->{realm};
-  $realm = "" unless defined $realm;
+  $realm = '' unless defined $realm;
 
-  my $A1 = join (":",
-    md5(join (":", $params->{username}, $realm, $password)),
-    @$params{defined($params->{authzid})
+  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)) );
+  my $hdA1 = unpack('H*', (my $dA1 = md5($A1)) );
 
   # derive keys for layer encryption / integrity
   $self->{kic} = md5($dA1,
@@ -365,21 +372,21 @@ sub _compute_digests_and_set_keys {
     $self->{ivs} = $cipher->{iv}->($self->{kcs});
   }
 
-  my $A2 = "AUTHENTICATE:" . $params->{'digest-uri'};
-  $A2 .= ":00000000000000000000000000000000" if ($params->{qop} ne 'auth');
+  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))
+    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');
+  $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))
+    join (':', $hdA1, @{$params{qw(nonce nc cnonce qop)}}, md5_hex($A2)),
   );
 
   return ($response, $rspauth);
@@ -408,7 +415,7 @@ sub server_step {
     return $cb->();
   }
 
-  my $qop = $cparams{'qop'} || "auth";
+  my $qop = $cparams{'qop'} || 'auth';
   unless ($self->is_qop_supported($qop)) {
     $self->set_error("Client qop not supported (qop = '$qop')");
     return $cb->();
@@ -416,13 +423,13 @@ sub server_step {
 
   my $username = $cparams{'username'};
   unless ($username) {
-    $self->set_error("Client didn't provide a 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");
+      $self->set_error('authzid cannot be empty');
       return $cb->();
   }
   my $authzid = $cparams{authzid};
@@ -431,15 +438,15 @@ sub server_step {
   # 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;
+  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->(); 
+      $self->set_error('Incorrect digest-uri');
+      return $cb->();
   }
 
   unless (defined $self->callback('getsecret')) {
-    $self->set_error("a getsecret callback MUST be defined");
+    $self->set_error('a getsecret callback MUST be defined');
     $cb->();
     return;
   }
@@ -447,31 +454,31 @@ sub server_step {
   my $realm = $self->{client_params}->{'realm'};
   my $response_check = sub {
     my $password = shift;
-    return $self->set_error("Cannot get the passord for $username") 
+    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");
- 
+        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);
   };
 
-  $self->callback('getsecret')->(
+  return $self->callback('getsecret')->(
     $self,
     { user => $username, realm => $realm, authzid => $authzid },
     sub { $cb->( $response_check->( shift ) ) },
@@ -489,7 +496,7 @@ sub _response {
   my $is_client = shift;
 
   my @out;
-  for my $k (sort keys %$response) {
+  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
@@ -497,7 +504,7 @@ sub _response {
     # other way: comma separated list
     push @out, [$k, join (',', @values)];
   }
-  return join (",", map { _qdval($_->[0], $_->[1], $is_client) } @out);
+  return join (',', map { _qdval($_->[0], $_->[1], $is_client) } @out);
 }
 
 sub _parse_challenge {
@@ -506,13 +513,13 @@ sub _parse_challenge {
   my $type          = shift;
   my $params        = shift;
 
-  while($$challenge_ref =~
-           s/^(?:\s*,)*\s*            # remaining or crap
+  while(${$challenge_ref} =~
+           s{^(?:\s*,)*\s*            # remaining or crap
              ([\w-]+)                 # key, eg: qop
              =
              ("([^\\"]+|\\.)*"|[^,]+) # value, eg: auth-conf or "NoNcE"
              \s*(?:,\s*)*             # remaining
-           //x) {
+           }{}x) {
 
     my ($k, $v) = ($1,$2);
     if ($v =~ /^"(.*)"$/s) {
@@ -520,7 +527,7 @@ sub _parse_challenge {
     }
     if (exists $multi{$type}{$k}) {
       my $aref = $params->{$k} ||= [];
-      push @$aref, $v;
+      push @{$aref}, $v;
     }
     elsif (defined $params->{$k}) {
       return $self->set_error("Bad challenge: '$$challenge_ref'");
@@ -529,7 +536,7 @@ sub _parse_challenge {
       $params->{$k} = $v;
     }
   }
-  return length $$challenge_ref ? 0 : 1;
+  return length ${$challenge_ref} ? 0 : 1;
 }
 
 sub _qdval {
@@ -585,9 +592,9 @@ sub _client_layer {
   # qop in server challenge is optional: if not there "auth" is assumed
   my $smask = 0;
   map {
-    m/^auth$/      and $smask |= 1;
-    m/^auth-int$/  and $smask |= 2;
-    m/^auth-conf$/ and $smask |= 4;
+    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
@@ -639,13 +646,13 @@ sub _select_cipher {
   # compose a subset of candidate ciphers based on ssf and peer list
   my @a = map {
     my $c = $_;
-    (grep { $c->{name} eq $_ } @$ciphers and
+    (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}";
+    next unless eval {require $_->{pkg}};
     $self->{cipher} = $_;
     return 1;
   }
@@ -718,14 +725,14 @@ sub _crypt {  # input: op(decrypting=1/encrypting=0)), buffer
 
   if ($bs <= 1) {
     # stream cipher
-    return $d ? $self->{khs}->decrypt($_[0]) : $self->{khc}->encrypt($_[0])
+    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 $iv = ${$piv};
 
   my $result = join '', map {
     my $x = $d
@@ -736,7 +743,7 @@ sub _crypt {  # input: op(decrypting=1/encrypting=0)), buffer
   } unpack("a$bs "x(int(length($_[0])/$bs)), $_[0]);
 
   # store current IV
-  $$piv = $iv;
+  ${$piv} = $iv;
   return $result;
 }
 

lib/Authen/SASL/Perl/EXTERNAL.pm

@@ -1,3 +1,4 @@
+## 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
@@ -5,10 +6,14 @@
 
 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";
+$VERSION = '2.14';
 @ISA	 = qw(Authen::SASL::Perl);
 
 my %secflags = (
@@ -17,18 +22,18 @@ my %secflags = (
 	noanonymous  => 1,
 );
 
-sub _order { 2 }
+sub _order { return 2 }
 sub _secflags {
   shift;
-  grep { $secflags{$_} } @_;
+  return grep { $secflags{$_} } @_;
 }
 
-sub mechanism { 'EXTERNAL' }
+sub mechanism { return 'EXTERNAL' }
 
 sub client_start {
   my $self = shift;
   my $v = $self->_call('user');
-  defined($v) ? $v : ''
+  return defined($v) ? $v : '';
 }
 
 #sub client_step {

lib/Authen/SASL/Perl/GSSAPI.pm

@@ -1,15 +1,21 @@
+## 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 ();
+use GSSAPI::Name ();
+use GSSAPI::Context ();
 
-$VERSION= "0.05";
+$VERSION= '0.05';
 @ISA = qw(Authen::SASL::Perl);
 
 my %secflags = (
@@ -17,13 +23,13 @@ my %secflags = (
   noanonymous => 1,
 );
 
-sub _order { 4 }
+sub _order { return 4 }
 sub _secflags {
   shift;
-  scalar grep { $secflags{$_} } @_;
+  return scalar grep { $secflags{$_} } @_;
 }
 
-sub mechanism { 'GSSAPI' }
+sub mechanism { return 'GSSAPI' }
 
 sub _init {
   my ($pkg, $self) = @_;
@@ -38,7 +44,7 @@ sub _init {
   # layer selection mask in the client reply, we default to
   # compatibility with that bug
   $self->property('COMPAT_CYRUSLIB_REPLY_MASK_BUG', 1);
-  $self;
+  return $self;
 }
 
 sub client_start {

lib/Authen/SASL/Perl/LOGIN.pm

@@ -1,31 +1,36 @@
+## 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";
+$VERSION = '2.14';
 @ISA	 = qw(Authen::SASL::Perl);
 
 my %secflags = (
 	noanonymous => 1,
 );
 
-sub _order { 1 }
+sub _order { return 1 }
 sub _secflags {
   shift;
-  scalar grep { $secflags{$_} } @_;
+  return scalar grep { $secflags{$_} } @_;
 }
 
-sub mechanism { 'LOGIN' }
+sub mechanism { return 'LOGIN' }
 
 sub client_start {
   my $self = shift;
   $self->{stage} = 0;
-  '';
+  return '';
 }
 
 sub client_step {
@@ -47,7 +52,7 @@ sub client_step {
       return;
   }
   else {
-      return $self->set_error("Invalid sequence");
+      return $self->set_error('Invalid sequence');
   }
 }
 
@@ -73,24 +78,24 @@ sub server_step {
 
   if ($stage == 1) {
     unless (defined $response) {
-        $self->set_error("Invalid sequence (empty username)");
+        $self->set_error('Invalid sequence (empty username)');
         return $user_cb->();
     }
     $self->{answer}{user} = $response;
-    return $user_cb->("Password:");
+    return $user_cb->('Password:');
   }
   elsif ($stage == 2) {
     unless (defined $response) {
-        $self->set_error("Invalid sequence (empty pass)");
+        $self->set_error('Invalid sequence (empty pass)');
         return $user_cb->();
     }
     $self->{answer}{pass} = $response;
   }
   else {
-    $self->set_error("Invalid sequence (end)");
+    $self->set_error('Invalid sequence (end)');
     return $user_cb->();
   }
-  my $error = "Credentials don't match";
+  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 {
@@ -109,7 +114,7 @@ sub server_step {
   elsif (my $getsecret = $self->{callback}{getsecret}) {
     my $cb = sub {
       my $good_pass = shift;
-      if ($good_pass && $good_pass eq ($self->{answer}{pass} || "")) {
+      if ($good_pass && $good_pass eq ($self->{answer}{pass} || '')) {
         $self->set_success;
       }
       else {

lib/Authen/SASL/Perl/PLAIN.pm

@@ -1,14 +1,19 @@
+## 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);
+$VERSION = '2.14';
+@ISA	 = qw(Authen::SASL::Perl); ## no critic (ClassHierarchies::ProhibitExplicitISA)
 
 my %secflags = (
 	noanonymous => 1,
@@ -16,13 +21,13 @@ my %secflags = (
 
 my @tokens = qw(authname user pass);
 
-sub _order { 1 }
+sub _order { return 1 }
 sub _secflags {
   shift;
-  grep { $secflags{$_} } @_;
+  return grep { $secflags{$_} } @_;
 }
 
-sub mechanism { 'PLAIN' }
+sub mechanism { return 'PLAIN' }
 
 sub client_start {
   my $self = shift;
@@ -35,7 +40,7 @@ sub client_start {
     defined($v) ? $v : ''
   } @tokens;
 
-  join("\0", @parts);
+  return join("\0", @parts);
 }
 
 sub server_start {
@@ -44,16 +49,16 @@ sub server_start {
   my $user_cb   = shift || sub {};
 
   $self->{error} = undef;
-  return $self->set_error("No response: Credentials don't match")
+  return $self->set_error('No response: Credentials don\'t match')
     unless defined $response;
 
   my %parts;
-  @parts{@tokens} = split "\0", $response, scalar @tokens;
+  @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";
+  my $error = 'Credentials don\'t match';
 
   ## checkpass
   if (my $checkpass = $self->callback('checkpass')) {
@@ -75,7 +80,7 @@ sub server_start {
   elsif (my $getsecret = $self->callback('getsecret')) {
     my $cb = sub {
       my $good_pass = shift;
-      if ($good_pass && $good_pass eq ($parts{pass} || "")) {
+      if ($good_pass && $good_pass eq ($parts{pass} || '')) {
         $self->set_success;
       }
       else {
@@ -92,6 +97,8 @@ sub server_start {
     $self->set_error($error);
     $user_cb->();
   }
+
+  return;
 }
 
 1;

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

@@ -1,6 +1,6 @@
-package archeologist;
+package BotLib::Archeologist;
 
-use 5.018;
+use 5.018; ## no critic (ProhibitImplicitImport)
 use strict;
 use warnings;
 use utf8;
@@ -10,9 +10,9 @@ use Math::Random::Secure qw (irand);
 
 use version; our $VERSION = qw (1.0);
 use Exporter qw (import);
-our @EXPORT_OK = qw (dig);
+our @EXPORT_OK = qw (Dig);
 
-sub dig {
+sub Dig {
 	my $name = shift;
 
 	my @artifact = (

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

@@ -1,33 +1,36 @@
-package conf;
+package BotLib::Conf;
 # loads config
 
-use 5.018;
+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 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);
+use Exporter qw (import);
+our @EXPORT_OK = qw (LoadConf);
 
-sub 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
-		die "[FATA] Unable to read $c: $OS_ERROR\n";
+		$log->fata ("[FATA] Unable to read $c: $OS_ERROR");
 	}
 
 	if ($readlen != $len) {
 		close $CH;                                   ## no critic (InputOutput::RequireCheckedSyscalls
-		die "[FATA] File $c is $len bytes on disk, but we read only $readlen bytes\n";
+		$log->fata ("[FATA] File $c is $len bytes on disk, but we read only $readlen bytes");
 	}
 
 	close $CH;                                       ## no critic (InputOutput::RequireCheckedSyscalls

lib/BotLib/Drink.pm

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

@@ -1,6 +1,6 @@
-package fisher;
+package BotLib::Fisher;
 
-use 5.018;
+use 5.018; ## no critic (ProhibitImplicitImport)
 use strict;
 use warnings;
 use utf8;
@@ -10,10 +10,10 @@ use Math::Random::Secure qw (irand);
 
 use version; our $VERSION = qw (1.0);
 use Exporter qw (import);
-our @EXPORT_OK = qw (fish);
+our @EXPORT_OK = qw (Fish);
 
 
-sub fish {
+sub Fish {
 	my $name = shift;
 
 	my @artifact = (

lib/BotLib/Fortune.pm

@@ -1,35 +1,35 @@
-package fortune;
+package BotLib::Fortune;
 # Any fortune_mod sources are suitable. Text file with "\n%\n" sentence delimiters.
 
-use 5.018;
+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 carp);
-use SQLite_File;
-use Math::Random::Secure qw (irand);
-use MIME::Base64;
+use Carp qw (croak);
 use File::Path qw (make_path);
-use conf qw (loadConf);
+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);
+our @EXPORT_OK = qw (Seed Fortune);
 
-my $c = loadConf ();
+my $c = LoadConf ();
 my $dir = $c->{fortune}->{dir};
 my $srcdir = $c->{fortune}->{srcdir};
 
-sub seed () {
+sub Seed () {
 	unless (-d $dir) {
 		make_path ($dir)  ||  croak "Unable to create $dir: $OS_ERROR";
 	}
 
 	my $backingfile = sprintf '%s/fortune.sqlite', $dir;
 
-	if (-f $backingfile) {
+	if (-e $backingfile) {
 		unlink $backingfile   ||  croak "Unable to remove $backingfile: $OS_ERROR\n";
 	}
 
@@ -39,7 +39,7 @@ sub seed () {
 	while (my $fortunefile = readdir $srcdirhandle) {
 		my $srcfile = sprintf '%s/%s', $srcdir, $fortunefile;
 
-		unless (-f $srcfile) {
+		unless (-e $srcfile) {
 			next;
 		}
 
@@ -52,7 +52,7 @@ sub seed () {
 		local $INPUT_RECORD_SEPARATOR = "\n%\n";
 
 		while (readline $fh) {
-			my $phrase = substr $_, 0, -3;
+			my $phrase = substr $_, 0, length ("\n%\n");
 			push @fortune, $phrase;
 		}
 
@@ -65,11 +65,11 @@ sub seed () {
 }
 
 # just return answer
-sub fortune () {
+sub Fortune () {
 	my $backingfile = sprintf '%s/fortune.sqlite', $dir;
 
 	tie my @array, 'SQLite_File', $backingfile  ||  do {
-		carp "Unable to tie to $backingfile: $OS_ERROR\n";
+		$log->error ("[ERROR] Unable to tie to $backingfile: $OS_ERROR");
 		return '';
 	};
 

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

@@ -1,28 +1,29 @@
-package friday;
+package BotLib::Friday;
 # for friday data stolen from https://raw.githubusercontent.com/isida/vi/master/data/friday.txt
 
-use 5.018;
+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 croak);
+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 conf qw (loadConf);
+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);
+our @EXPORT_OK = qw (Seed Friday);
 
-my $c = loadConf ();
+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 () {
+sub Seed () {
 	unless (-d $dir) {
 		make_path ($dir)  ||  croak "Unable to create $dir: $OS_ERROR";
 	}
@@ -32,7 +33,7 @@ sub seed () {
 	for (0..$#dow) {
 		my $backingfile = sprintf '%s/%s.sqlite', $dir, $dow[$_];
 
-		if (-f $backingfile) {
+		if (-e $backingfile) {
 			unlink $backingfile   ||  croak "Unable to remove $backingfile: $OS_ERROR\n";
 		}
 
@@ -75,12 +76,12 @@ sub seed () {
 }
 
 # just return answer
-sub friday () {
+sub Friday () {
 	my $today = (localtime (time))[6] - 1;
 	my $backingfile = sprintf '%s/%s.sqlite', $dir, $dow[$today];
 
 	tie my @array, 'SQLite_File', $backingfile  ||  do {
-		carp "[ERROR] Unable to tie to $backingfile: $OS_ERROR\n";
+		$log->error ("[ERROR] Unable to tie to $backingfile: $OS_ERROR");
 		return '';
 	};
 

lib/BotLib/Image.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

@@ -1,27 +1,27 @@
-package karma;
+package BotLib::Karma;
 
-use 5.018;
+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 DB_File;
+use DB_File ();
 use File::Path qw (make_path);
-use conf qw (loadConf);
-use util qw (utf2sha1 trim);
+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);
+our @EXPORT_OK = qw (KarmaSet KarmaGet);
 
-my $c = loadConf ();
+my $c = LoadConf ();
 my $karmadir = $c->{karma}->{dir};
 my $max = 5;
 
 # swallow phrase and return answer
-sub karmaSet (@) {
+sub KarmaSet (@) {
 	my $chatid = shift;
 	my $phrase = shift;
 	my $action = shift;
@@ -34,14 +34,14 @@ sub karmaSet (@) {
 
 	unless (-d $karmadir) {
 		make_path ($karmadir) or do {
-			carp "Unable to create $karmadir: $OS_ERROR";
+			$log->error ("[ERROR] Unable to create $karmadir: $OS_ERROR");
 			return sprintf 'Карма %s составляет 0', $phrase;
 		};
 	}
 
 	# init hash, store phrase and score
 	tie my %karma, 'DB_File', $karmafile || do {
-		carp "[ERROR] Something nasty happen when karma ties to its data: $OS_ERROR";
+		$log->error ("[ERROR] Something nasty happen when karma ties to its data: $OS_ERROR");
 		return sprintf 'Карма %s составляет 0', $phrase;
 	};
 
@@ -84,7 +84,7 @@ sub karmaSet (@) {
 }
 
 # just return answer
-sub karmaGet (@) {
+sub KarmaGet (@) {
 	my $chatid = shift;
 	my $phrase = shift;
 	$phrase = trim $phrase;
@@ -94,14 +94,14 @@ sub karmaGet (@) {
 
 	unless (-d $karmadir) {
 		make_path ($karmadir) or do {
-			carp "Unable to create $karmadir: $OS_ERROR";
+			$log->error ("Unable to create $karmadir: $OS_ERROR");
 			return sprintf 'Карма %s составляет 0', $phrase;
 		};
 	}
 
 	# init hash, store phrase and score
 	tie my %karma, 'DB_File', $karmafile || do {
-		carp "[ERROR] Something nasty happen when karma ties to its data: $OS_ERROR";
+		$log->error ("[ERROR] Something nasty happen when karma ties to its data: $OS_ERROR");
 		return sprintf 'Карма %s составляет 0', $phrase;
 	};
 

lib/BotLib/Kitty.pm

@@ -1,20 +1,20 @@
-package kitty;
+package BotLib::Kitty;
 
-use 5.018;
+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 JSON::XS;
-use HTTP::Tiny;
+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);
+our @EXPORT_OK = qw (Kitty);
 
-sub kitty {
+sub Kitty {
 	my $r;
 	my $ret = 'Нету кошечек, все разбежались.';
 
@@ -34,15 +34,15 @@ sub kitty {
 			decode_json ($r->{content})
 		};
 
-		if ($EVAL_ERROR) {
-			carp "[ERROR] Unable to decode JSON: $EVAL_ERROR";
+		unless (defined $jcat) {
+			$log->error ("[ERROR] Unable to decode JSON: $EVAL_ERROR");
 		} else {
 			if ($jcat->[0]->{url}) {
 				$ret = $jcat->[0]->{url};
 			}
 		}
 	} else {
-		carp sprintf 'Server return status %s with message: %s', $r->{status}, $r->{reason};
+		$log->error (sprintf 'Server return status %s with message: %s', $r->{status}, $r->{reason});
 	}
 
 	return $ret;

lib/BotLib/Lat.pm

@@ -1,7 +1,7 @@
-package lat;
+package BotLib::Lat;
 # famous latin phases taken from https://ru.wikipedia.org/wiki/Список_крылатых_латинских_выражений
 
-use 5.018;
+use 5.018; ## no critic (ProhibitImplicitImport)
 use strict;
 use warnings;
 use utf8;
@@ -10,18 +10,19 @@ use English qw ( -no_match_vars );
 use Carp qw (carp);
 use File::Basename qw (dirname);
 use File::Path qw (make_path);
-use Hailo;
-use conf qw (loadConf);
+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 latAnswer);
+our @EXPORT_OK = qw (Train Lat);
 
-my $c = loadConf ();
+my $c = LoadConf ();
 my $brain = $c->{lat}->{brain};
 my $srcfile = $c->{lat}->{src};
 
-sub train () {
+sub Train () {
 	my $braindir = dirname $brain;
 
 	unless (-d $braindir) {
@@ -34,7 +35,7 @@ sub train () {
 	my $lat = Hailo->new (
 		brain => $brain,
 		# in our case mean amount of words in phase is 3
-		order => 2
+		order => 2,
 	);
 
 	$lat->train ($srcfile);
@@ -45,16 +46,16 @@ sub train () {
 }
 
 # just return answer
-sub latAnswer () {
+sub Lat () {
 	my $braindir = dirname $brain;
 
 	unless (-d $braindir) {
-		carp "[ERROR] No lat module data: $braindir is absent! Train lat first.";
+		$log->error ("[ERROR] No lat module data: $braindir is absent! Train lat first.");
 		return '';
 	}
 
-	unless (-f $brain) {
-		carp "[ERROR] No lat module data: $brain is absent! Train lat first.";
+	unless (-e $brain) {
+		$log->error ("[ERROR] No lat module data: $brain is absent! Train lat first.");
 		return '';
 	}
 
@@ -62,7 +63,7 @@ sub latAnswer () {
 		brain => $brain,
 		# in our case mean amount of words in phase is 3
 		order => 2,
-		save_on_exit => 0
+		save_on_exit => 0,
 	);
 
 	return $lat->reply ();

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

@@ -1,6 +1,6 @@
-package util;
+package BotLib::Util;
 
-use 5.018;
+use 5.018; ## no critic (ProhibitImplicitImport)
 use strict;
 use warnings;
 use utf8;
@@ -8,10 +8,10 @@ use open qw (:std :utf8);
 use English qw ( -no_match_vars );
 use Carp qw (cluck);
 use Digest::SHA qw (sha1_base64);
-use Encode;
-use MIME::Base64;
+use Encode qw (encode_utf8);
+use MIME::Base64 qw (encode_base64);
 use Text::Fuzzy qw (distance_edits);
-use URI::URL;
+use URI::URL qw (url);
 
 use version; our $VERSION = qw (1.0);
 use Exporter qw (import);
@@ -29,13 +29,8 @@ sub trim {
 		return $str;
 	}
 
-	while (substr ($str, 0, 1) =~ /^\s$/xms) {
-		$str = substr $str, 1;
-	}
-
-	while (substr ($str, -1, 1) =~ /^\s$/xms) {
-		chop $str;
-	}
+	$str =~ s/^\s+//u;
+	$str =~ s/\s+$//u;
 
 	return $str;
 }

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/Net/Jabber/Bot.pm

@@ -1,5 +1,11 @@
+## no critic (Subroutines::ProhibitCallsToUndeclaredSubs, RegularExpressions::ProhibitUselessTopic, Documentation::RequirePODUseEncodingUTF8, Variables::ProhibitPunctuationVars, Documentation::RequirePodSections, Documentation::RequirePodAtEnd, ErrorHandling::RequireCarping, RegularExpressions::ProhibitUnusedCapture)
+
 package Net::Jabber::Bot;
 
+use 5.018; ## no critic (ProhibitImplicitImport)
+use warnings;
+use utf8;
+
 use Moose;
 use MooseX::Types
     -declare => [qw( JabberClientObject PosInt PosNum HundredInt )];
@@ -8,11 +14,12 @@ use MooseX::Types
 use MooseX::Types::Moose qw/Int HashRef Str Maybe ArrayRef Bool CodeRef Object Num/;
 
 use version;
-use Net::Jabber;
-use Time::HiRes;
-use Sys::Hostname;
+use Net::Jabber ();
+use Time::HiRes ();
+use Sys::Hostname qw(hostname);
 use Log::Log4perl qw(:easy);
-use Mozilla::CA;
+use Mozilla::CA ();
+use Net::Jabber::Client ();
 
 coerce Bool, from Str,
     via {($_ =~ m/(^on$)|(^true$)/i) + 0}; # True if it's on or true. Otherwise false.
@@ -25,7 +32,7 @@ subtype HundredInt, as Num,  where { $_ > 100 };
 
 has jabber_client               => (isa => Maybe[JabberClientObject],
                                     is => 'rw',
-                                    default => sub {Net::Jabber::Client->new});
+                                    default => sub {Net::Jabber::Client->new},);
 #my %connection_hash : ATTR; # Keep track of connection options fed to client.
 
 has 'client_session_id'   => (isa => Str, is => 'rw');
@@ -43,7 +50,7 @@ has 'username'            => (isa => Str, is => 'rw');
 has 'password'            => (isa => Str, is => 'rw');
 has 'alias'               => (isa => Str, lazy => 1, is => 'rw', default => 'net_jabber_bot');
 # Resource defaults to alias_hostname_pid
-has 'resource'            => (isa => Str, lazy => 1, is => 'rw', default => sub{shift->alias . "_" . hostname . "_" . $$});
+has 'resource'            => (isa => Str, lazy => 1, is => 'rw', default => sub{shift->alias . '_' . hostname() . '_' . $$});
 has 'message_function'    => (isa => Maybe[CodeRef], is => 'rw', default => sub{undef});
 has 'background_function' => (isa => Maybe[CodeRef], is => 'rw', default => sub{undef});
 has 'loop_sleep_time'     => (isa => PosNum, is => 'rw', default => 5);
@@ -53,7 +60,7 @@ has 'from_full'           => (isa => Str, lazy => 1, is => 'rw', default => sub{
                                                                        '@' .
                                                                        $self->server || '' .
                                                                        '/' .
-                                                                       $self->alias || '' });
+                                                                       $self->alias || '' },);
 
 has 'safety_mode'            => (isa => Bool, is => 'rw', default => 1, coerce => 1);
 has 'ignore_server_messages' => (isa => Bool, is => 'rw', default => 1, coerce => 1);
@@ -315,13 +322,13 @@ sub BUILD {
 
     # Deal with legacy bug
     if($params->{background_activity} || $params->{message_callback}) {
-        my $warn_message = "\n\n" 
-                          . "*" x 70 . "\n"
+        my $warn_message = "\n\n"
+                          . '*' x 70 . "\n"
                           . "WARNING!!! You're using old parameters for your bot initialization\n"
                           . "'message_callback' should be changed to 'message_function'\n"
                           . "'background_activity' should be changed to 'background_function'\n"
                           . "I'm correcting this, but you should fix your code\n"
-                          . "*" x 70 . "\n"
+                          . '*' x 70 . "\n"
                           . "\n\n";
         warn($warn_message);
         WARN($warn_message);
@@ -331,8 +338,8 @@ sub BUILD {
         $self->message_function($params->{message_callback})
             if(!$self->message_function && $params->{message_callback});
         sleep 30;
-    } 
-    
+    }
+
     # Message delay is inverse of out_messages_per_second
     $self->message_delay(1/$self->out_messages_per_second);
 
@@ -352,7 +359,7 @@ sub BUILD {
     }
 
     #Initialize the connection.
-    $self->_init_jabber;
+    return $self->_init_jabber;
 }
 
 # Return a code reference that will pass self in addition to arguements passed to callback code ref.
@@ -371,15 +378,15 @@ sub _init_jabber {
     # Autocreate the jabber object (see has jabber_client)
     my $connection = $self->jabber_client;
 
-    DEBUG("Set the call backs.");
+    DEBUG('Set the call backs.');
     $connection->PresenceDB(); # Init presence DB.
     $connection->RosterDB(); # Init Roster DB.
     $connection->SetCallBacks( 'message'  => $self->_callback_maker(\&_process_jabber_message)
                               ,'presence' => $self->_callback_maker(\&_jabber_presence_message)
-                              ,'iq'       => $self->_callback_maker(\&_jabber_in_iq_message)
+                              ,'iq'       => $self->_callback_maker(\&_jabber_in_iq_message),
                               );
 
-    DEBUG("Connect. hostname => " . $self->server . ", port => " . $self->port);
+    DEBUG('Connect. hostname => ' . $self->server . ', port => ' . $self->port);
     my %client_connect_hash = (
         hostname => $self->server,
         port => $self->port,
@@ -397,8 +404,8 @@ sub _init_jabber {
        die("Jabber server is down or connection was not allowed: $!");
     }
 
-    DEBUG("Logging in... as user " . $self->username . " / " . $self->resource);
-    DEBUG("PW: " . $self->password);
+    DEBUG('Logging in... as user ' . $self->username . ' / ' . $self->resource);
+    DEBUG('PW: ' . $self->password);
 
 # Moved into connect hash via 'componentname'
 #    my $sid = $connection->{SESSION}->{id};
@@ -410,23 +417,23 @@ sub _init_jabber {
                                             resource => $self->resource,
                                             );
 
-    if(!defined $auth_result[0] || $auth_result[0] ne "ok") {
-        ERROR("Authorization failed: for " . $self->username . " / " . $self->resource);
+    if(!defined $auth_result[0] || $auth_result[0] ne 'ok') {
+        ERROR('Authorization failed: for ' . $self->username . ' / ' . $self->resource);
         foreach my $result (@auth_result) {
             ERROR("$result");
         }
-        die("Failed to re-connect: " . join("\n", @auth_result));
+        die('Failed to re-connect: ' . join("\n", @auth_result));
     }
 
     $connection->RosterRequest();
 
     $self->client_session_id($connection->{SESSION}->{id});
 
-    DEBUG("Sending presence to tell world that we are logged in");
+    DEBUG('Sending presence to tell world that we are logged in');
     $connection->PresenceSend();
     $self->Process(5);
 
-    DEBUG("Getting Roster to tell server to send presence info");
+    DEBUG('Getting Roster to tell server to send presence info');
     $connection->RosterGet();
     $self->Process(5);
 
@@ -434,7 +441,7 @@ sub _init_jabber {
         $self->JoinForum($forum);
     }
 
-    INFO("Connected to server '" . $self->server . "' successfully");
+    INFO('Connected to server \'' . $self->server . '\' successfully');
     $self->connect_time(time); # Track when we came online.
     return 1;
 }
@@ -453,7 +460,7 @@ sub JoinForum {
     my $self = shift;
     my $forum_name = shift;
 
-    DEBUG("Joining $forum_name on " . $self->conference_server . " as " . $self->alias);
+    DEBUG("Joining $forum_name on " . $self->conference_server . ' as ' . $self->alias);
 
     $self->jabber_client->MUCJoin(room    => $forum_name,
                                   server => $self->conference_server,
@@ -461,8 +468,9 @@ sub JoinForum {
                                   );
 
     $self->forum_join_time->{$forum_name} = time;
-    DEBUG("Sleeping " . $self->message_delay . " seconds");
+    DEBUG('Sleeping ' . $self->message_delay . ' seconds');
     Time::HiRes::sleep $self->message_delay;
+    return;
 }
 
 =item B<Process>
@@ -521,8 +529,8 @@ sub Start {
 
         if($@) { #Assume the connection is down...
             ERROR("Server error: $@");
-            my $message = "Disconnected from " . $self->server . ":" . $self->port
-                        . " as " . $self->username;
+            my $message = 'Disconnected from ' . $self->server . ':' . $self->port
+                        . ' as ' . $self->username;
 
             ERROR("$message Reconnecting...");
             sleep 5; # TODO: Make re-connect time flexible somehow
@@ -531,11 +539,12 @@ sub Start {
 
         # Call background function
         if(defined $background_subroutine && $last_background + $time_between_background_routines < time) {
-            &$background_subroutine($self, ++$counter);
+            &$background_subroutine($self, ++$counter); ## no critic (References::ProhibitDoubleSigils)
             $last_background = time;
         }
         Time::HiRes::sleep $message_delay;
     }
+    return;
 }
 
 =item B<ReconnectToServer>
@@ -562,9 +571,10 @@ sub ReconnectToServer {
         sleep $sleep_time;
         $sleep_time *= 2 if($sleep_time < 300);
         $self->InitJabber();
-        INFO("Running background routine.");
-        &$background_subroutine($self, 0); # call background proc so we can check for errors while down.
+        INFO('Running background routine.');
+        &$background_subroutine($self, 0); ## no critic (References::ProhibitDoubleSigils) # call background proc so we can check for errors while down.
     }
+    return;
 }
 
 =item B<Disconnect>
@@ -579,14 +589,14 @@ sub Disconnect {
 
     $self->connect_time('9' x 10); # Way in the future
 
-    INFO("Disconnecting from server");
+    INFO('Disconnecting from server');
     return if(!defined $self->jabber_client); # do not proceed, no object.
 
     $self->jabber_client->Disconnect();
     my $old_client = $self->jabber_client;
     $self->jabber_client(undef);
 
-    DEBUG("Disconnected.");
+    DEBUG('Disconnected.');
     return 1;
 }
 
@@ -599,7 +609,7 @@ Reports connect state (true/false) based on the status of client_start_time.
 sub IsConnected {
     my $self = shift;
 
-    DEBUG("REF = " . ref($self->jabber_client));
+    DEBUG('REF = ' . ref($self->jabber_client));
     return $self->connect_time;
 }
 
@@ -612,13 +622,13 @@ Handles incoming messages.
 
 sub _process_jabber_message {
     my $self = shift;
-    DEBUG("_process_jabber_message called");
+    DEBUG('_process_jabber_message called');
 
     my $session_id = shift;
     my $message = shift;
 
     my $type = $message->GetType();
-    my $fromJID = $message->GetFrom("jid");
+    my $fromJID = $message->GetFrom('jid');
     my $from_full = $message->GetFrom();
 
     my $from = $fromJID->GetUserID();
@@ -660,7 +670,6 @@ sub _process_jabber_message {
 
     # Are these my own messages?
     if($self->ignore_self_messages ) { # TODO: || $self->safety_mode (this breaks tests in 06?)
-        
         if(defined $resource && $resource eq $self->resource) { # Ignore my own messages.
             DEBUG("Ignoring message from self...\n");
             return;
@@ -676,11 +685,11 @@ sub _process_jabber_message {
         foreach my $address_type (@aliases_to_respond_to) {
             my $qm_address_type = quotemeta($address_type);
             next if($body !~ m/^\s*$qm_address_type\s*(\S.*)$/ms);
-            $request = $1;
+            $request = $1; ## no critic (RegularExpressions::ProhibitCaptureWithoutTest)
             $bot_address_from = $address_type;
             last; # do not need to loop any more.
         }
-        DEBUG("Message not relevant to bot");
+        DEBUG('Message not relevant to bot');
         return if(!defined $request);
         $body = $request;
     }
@@ -693,13 +702,14 @@ sub _process_jabber_message {
                                   type => $type,
                                   reply_to => $reply_to,
                                   bot_address_from => $bot_address_from,
-                                  message => $message
+                                  message => $message,
                                   );
         return;
     } else {
-        WARN("No handler for messages!");
+        WARN('No handler for messages!');
         INFO("New Message: $type from $from ($resource). sub=$subject -- $body");
     }
+    return;
 }
 
 =item B<get_responses>
@@ -716,7 +726,7 @@ sub get_responses {
     my $forum = shift;
 
     if(!defined $forum) {
-    WARN("No forum supplied for get_responses()");
+    WARN('No forum supplied for get_responses()');
     return;
     }
 
@@ -741,13 +751,13 @@ sub _jabber_in_iq_message {
     my $session_id = shift;
     my $iq = shift;
 
-    DEBUG("IQ Message:" . $iq->GetXML());
+    DEBUG('IQ Message:' . $iq->GetXML());
     my $from = $iq->GetFrom();
 #    my $type = $iq->GetType();DEBUG("Type=$type");
     my $query = $iq->GetQuery();#DEBUG("query=" . Dumper($query));
 
     if (!$query) {
-        DEBUG("iq->GetQuery() returned undef.");
+        DEBUG('iq->GetQuery() returned undef.');
         return;
     }
 
@@ -755,12 +765,12 @@ sub _jabber_in_iq_message {
     my $iqReply;
 
     # Respond to version requests with information about myself.
-    if($xmlns eq "jabber:iq:version") {
+    if($xmlns eq 'jabber:iq:version') {
         # convert 5.010000 to 5.10.0
         my $perl_version = $];
-        $perl_version =~ s/(\d{3})(?=\d)/$1./g; 
+        $perl_version =~ s/(\d{3})(?=\d)/$1./g;
         $perl_version =~ s/\.0+(\d)/.$1/;
-        
+
         $self->jabber_client
              ->VersionSend(to=> $from,
                            name=>__PACKAGE__,
@@ -771,11 +781,12 @@ sub _jabber_in_iq_message {
     }
 
     if($iqReply) {
-        DEBUG("Reply: ", $iqReply->GetXML());
+        DEBUG('Reply: ', $iqReply->GetXML());
         $self->jabber_client->Send($iqReply);
     }
 
 #    INFO("IQ from $from ($type). XMLNS: $xmlns");
+    return;
 }
 
 =item B<_jabber_presence_message> - DO NOT CALL
@@ -794,19 +805,19 @@ sub _jabber_presence_message {
     my $type = $presence->GetType();
     if($type eq 'subscribe') { # Always allow people to subscribe to us. Why wouldn't we?
         my $from = $presence->GetFrom();
-        $self->jabber_client->Subscription(type=>"subscribe",
+        $self->jabber_client->Subscription(type=>'subscribe',
                                               to=>$from);
-        $self->jabber_client->Subscription(type=>"subscribed",to=>$from);
+        $self->jabber_client->Subscription(type=>'subscribed',to=>$from);
         INFO("Processed subscription request from $from");
         return;
     } elsif($type eq 'unsubscribe') { # Always allow people to subscribe to us. Why wouldn't we?
         my $from = $presence->GetFrom();
-        $self->jabber_client->Subscription(type=>"unsubscribed",
+        $self->jabber_client->Subscription(type=>'unsubscribed',
                                               to=>$from);
         INFO("Processed unsubscribe request from $from");
         return;
     }
-    
+
     # Without explicitly setting a priority, XMPP::Protocol will store all JIDs with an empty
     # priority under the same key rather than in an array. 
     $presence->SetPriority(0) unless $presence->GetPriority();
@@ -814,13 +825,14 @@ sub _jabber_presence_message {
     $self->jabber_client->PresenceDBParse($presence); # Since we are always an object just throw it into the db.
 
     my $from = $presence->GetFrom();
-    $from = "." if(!defined $from);
+    $from = '.' if(!defined $from);
 
     my $status = $presence->GetStatus();
-    $status = "." if(!defined $status);
+    $status = '.' if(!defined $status);
 
     DEBUG("Presence From $from t=$type s=$status");
-    DEBUG("Presence XML: " . $presence->GetXML());
+    DEBUG('Presence XML: ' . $presence->GetXML());
+    return;
 }
 
 =item B<respond_to_self_messages>
@@ -876,7 +888,7 @@ sub get_safety_mode {
           && $self->max_messages_per_hour <= 166
           && $self->ignore_self_messages
          ;
-         
+
     return $mode || 0;
 }
 
@@ -971,12 +983,12 @@ sub _send_individual_message {
     my $subject = shift;
 
     if(!defined $message_type) {
-        ERROR("Undefined \$message_type");
+        ERROR('Undefined $message_type'); ## no critic (ValuesAndExpressions::RequireInterpolationOfMetachars)
         return "No message type!\n";
     }
 
     if(!defined $recipient) {
-        ERROR('$recipient not defined!');
+        ERROR('$recipient not defined!'); ## no critic (ValuesAndExpressions::RequireInterpolationOfMetachars)
         return "No recipient!\n";
     }
 
@@ -985,15 +997,15 @@ sub _send_individual_message {
     my $messages_this_hour = $self->messages_sent_today->{$yday}->{$hour} += 1;
 
     if($messages_this_hour > $self->max_messages_per_hour) {
-        $subject = "" if(!defined $subject); # Keep warning messages quiet.
-        $message_chunk = "" if(!defined $message_chunk); # Keep warning messages quiet.
+        $subject = '' if(!defined $subject); # Keep warning messages quiet.
+        $message_chunk = '' if(!defined $message_chunk); # Keep warning messages quiet.
 
         ERROR("Can't Send message because we've already tried to send $messages_this_hour of $self->max_messages_per_hour messages this hour.\n"
               . "To: $recipient\n"
               . "Subject: $subject\n"
               . "Type: $message_type\n"
               . "Message sent:\n"
-              . "$message_chunk"
+              . "$message_chunk",
               );
 
         # Send 1 panic message out to jabber if this is our last message before quieting down.
@@ -1001,15 +1013,15 @@ sub _send_individual_message {
     }
 
     if(!$self->IsConnected) {
-        $subject = "" if(!defined $subject); # Keep warning messages quiet.
-        $message_chunk = "" if(!defined $message_chunk); # Keep warning messages quiet.
+        $subject = '' if(!defined $subject); # Keep warning messages quiet.
+        $message_chunk = '' if(!defined $message_chunk); # Keep warning messages quiet.
 
         ERROR("Can't Jabber server is down. Tried to send: \n"
               . "To: $recipient\n"
               . "Subject: $subject\n"
               . "Type: $message_type\n"
               . "Message sent:\n"
-              . "$message_chunk"
+              . "$message_chunk",
               );
 
         # Send 1 panic message out to jabber if this is our last message before quieting down.
@@ -1026,17 +1038,17 @@ sub _send_individual_message {
                      , body => $message_chunk
                      , type => $message_type
 #                     , from => $connection_hash{$obj_ID}{'from_full'}
-                     , subject => $subject
+                     , subject => $subject,
                      );
 
-    DEBUG("Sleeping " . $self->message_delay . " after sending message.");
+    DEBUG('Sleeping ' . $self->message_delay . ' after sending message.');
     Time::HiRes::sleep $self->message_delay; #Throttle messages.
 
     if($messages_this_hour == $self->max_messages_per_hour) {
         $self->jabber_client->MessageSend(to => $recipient
-                         , body => "Cannot send more messages this hour. "
-                         . "$messages_this_hour of " . $self->max_messages_per_hour . " already sent."
-                         , type => $message_type
+                         , body => 'Cannot send more messages this hour. '
+                         . "$messages_this_hour of " . $self->max_messages_per_hour . ' already sent.'
+                         , type => $message_type,
                          );
     }
     return; # Means we succeeded!
@@ -1059,9 +1071,9 @@ sub SetForumSubject {
     if(length $subject > $self->max_message_size) {
     my $subject_len = length($subject);
     ERROR("Someone tried to send a subject message $subject_len bytes long!");
-    my $subject = substr($subject, 0, $self->max_message_size);
+    my $subject = substr($subject, 0, $self->max_message_size); ## no critic (Variables::ProhibitReusedNames)
     DEBUG("Truncated subject: $subject");
-    return "Subject is too long!";
+    return 'Subject is too long!';
     }
     $self->_send_individual_message($recipient, "Setting subject to $subject", 'groupchat', $subject);
 
@@ -1123,7 +1135,7 @@ sub GetStatus {
 
     if (!(defined($Pres))) {
 
-        return "unavailable" ;
+        return 'unavailable' ;
     }
 
     my $show = $Pres->GetShow();
@@ -1132,7 +1144,7 @@ sub GetStatus {
         return $show;
     }
 
-    return "available";
+    return 'available';
 
 }
 
@@ -1146,8 +1158,9 @@ sub AddUser {
     my $self = shift;
     my $user = shift;
 
-    $self->jabber_client->Subscription(type=>"subscribe", to=>$user);
-    $self->jabber_client->Subscription(type=>"subscribed",to=>$user);
+    $self->jabber_client->Subscription(type=>'subscribe', to=>$user);
+    $self->jabber_client->Subscription(type=>'subscribed',to=>$user);
+    return;
 }
 
 =item B<RmUser>
@@ -1160,8 +1173,9 @@ sub RmUser {
     my $self = shift;
     my $user = shift;
 
-    $self->jabber_client->Subscription(type=>"unsubscribe", to=>$user);
-    $self->jabber_client->Subscription(type=>"unsubscribed",to=>$user);
+    $self->jabber_client->Subscription(type=>'unsubscribe', to=>$user);
+    $self->jabber_client->Subscription(type=>'unsubscribed',to=>$user);
+    return;
 }
 =back
 

lib/botlib.pm

@@ -1,316 +0,0 @@
-package botlib;
-
-use 5.018;
-use strict;
-use warnings;
-use utf8;
-use open qw (:std :utf8);
-use English qw ( -no_match_vars );
-use Carp qw (carp);
-use Math::Random::Secure qw (irand);
-use archeologist qw (dig);
-use conf qw (loadConf);
-use fisher qw (fish);
-use fortune qw (fortune);
-use friday qw (friday);
-use karma qw (karmaGet);
-use kitty qw (kitty);
-use lat qw (latAnswer);
-use util qw (trim utf2sha1);
-use weather qw (weather);
-
-use version; our $VERSION = qw (1.0);
-use Exporter qw(import);
-our @EXPORT_OK = qw(command randomCommonPhrase 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;
-
-	if (substr ($text, 1, 3) eq 'rum' || substr ($text, 1, 3) eq 'ром') {
-		my $target;
-
-		if (($hash{'type'} eq 'groupchat') && (length ($text) > 5)) {
-			$target = trim (substr $text, 5);
-		}
-
-		if (! defined $target || ($target eq '')) {
-			$target = $chattername;
-		}
-
-		$reply = '/me притаскивает на подносе стопку рома для ' . $target . ', края стопки искрятся кристаллами соли.';
-	} elsif (substr ($text, 1, 5) eq 'vodka' || substr ($text, 1, 5) eq 'водка') {
-		my $target;
-
-		if (($hash{'type'} eq 'groupchat') && (length ($text) > 7)) {
-			$target = trim (substr $text, 7);
-		}
-
-		if (! defined $target || ($target eq '')) {
-			$target = $chattername;
-		}
-
-		$reply = '/me подаёт шот водки с небольшим маринованным огурчиком на блюдце для ' . $target . '. Из огурчика торчит небольшая вилочка.';
-	} elsif (substr ($text, 1, 4) eq 'beer' || substr ($text, 1, 4) eq 'пиво') {
-		my $target;
-
-		if (($hash{'type'} eq 'groupchat') && (length ($text) > 6)) {
-			$target = trim (substr $text, 6);
-		}
-
-		if (! defined $target || ($target eq '')) {
-			$target = $chattername;
-		}
-
-		$reply = '/me бахает об стол перед ' . $target . ' кружкой холодного пива, часть пенной шапки сползает по запотевшей стенке кружки.';
-	} elsif (substr ($text, 1, 7) eq 'tequila') {
-		my $target;
-
-		if (($hash{'type'} eq 'groupchat') && (length ($text) > 9)) {
-			$target = trim (substr $text, 9);
-		}
-
-		if (! defined $target || ($target eq '')) {
-			$target = $chattername;
-		}
-
-		$reply = '/me ставит рядом с ' . $target . ' шот текилы, аккуратно на ребро стопки насаживает дольку лайма и ставит кофейное блюдце с горочкой соли.';
-	} elsif (substr ($text, 1, 6) eq 'текила') {
-		my $target;
-
-		if (($hash{'type'} eq 'groupchat') && (length ($text) > 8)) {
-			$target = trim (substr $text, 8);
-		}
-
-		if (! defined $target || ($target eq '')) {
-			$target = $chattername;
-		}
-
-		$reply = '/me ставит рядом с ' . $target . ' шот текилы, аккуратно на ребро стопки насаживает дольку лайма и ставит кофейное блюдце с горочкой соли.';
-	} elsif (substr ($text, 1, 6) eq 'whisky') {
-		my $target;
-
-		if (($hash{'type'} eq 'groupchat') && (length ($text) > 8)) {
-			$target = trim (substr $text, 8);
-		}
-
-		if (! defined $target || ($target eq '')) {
-			$target = $chattername;
-		}
-
-		$reply = '/me демонстративно достаёт из морозилки пару кубических камушков, бросает их в толстодонный стакан и аккуратно наливает Jack Daniels. Запускает стакан вдоль барной стойки, он останавливается около ' . $target . '.';
-	} elsif (substr ($text, 1, 5) eq 'виски') {
-		my $target;
-
-		if (($hash{'type'} eq 'groupchat') && (length ($text) > 7)) {
-			$target = trim (substr $text, 7);
-		}
-
-		if (! defined $target || ($target eq '')) {
-			$target = $chattername;
-		}
-
-		$reply = '/me демонстративно достаёт из морозилки пару кубических камушков, бросает их в толстодонный стакан и аккуратно наливает Jack Daniels. Запускает стакан вдоль барной стойки, он останавливается около ' . $target . '.';
-	} elsif (substr ($text, 1, 8) eq 'absinthe') {
-		my $target;
-
-		if (($hash{'type'} eq 'groupchat') && (length ($text) > 10)) {
-			$target = trim (substr $text, 10);
-		}
-
-		if (! defined $target || ($target eq '')) {
-			$target = $chattername;
-		}
-
-		$reply = '/me наливает абсент в стопку. Смочив кубик сахара в абсенте кладёт его на дырявую ложечку и пожигает. Как только пламя потухнет, ' . $bot->{'alias'} . ' размешивает оплавившийся кубик в абсенте и подносит стопку ' . $target . '.';
-	} elsif (substr ($text, 1, 6) eq 'абсент') {
-		my $target;
-
-		if (($hash{'type'} eq 'groupchat') && (length ($text) > 8)) {
-			$target = trim (substr $text, 8);
-		}
-
-		if (! defined $target || ($target eq '')) {
-			$target = $chattername;
-		}
-
-		$reply = '/me наливает абсент в стопку. Смочив кубик сахара в абсенте кладёт его на дырявую ложечку и пожигает. Как только пламя потухнет, ' . $bot->{'alias'} . ' размешивает оплавившийся кубик в абсенте и подносит стопку ' . $target . '.';
-	} elsif (substr ($text, 1, 2) eq 'w '  ||  substr ($text, 1, 2) eq 'п ') {
-		my $city = substr $text, 2;
-		$reply = weather ($city) =~ tr/\n/ /r;
-	} elsif (substr ($text, 1) eq 'version'  ||  substr ($text, 1) eq 'ver') {
-		$reply = 'Версия нуль.чего-то_там.чего-то_там';
-	} elsif (substr ($text, 1) eq 'help'  ||  substr ($text, 1) eq 'помощь') {
-		$reply = <<"EOL";
-
-${csign}help | ${csign}помощь        - это сообщение
-${csign}cat | ${csign}кис            - кошечка
-${csign}dig | ${csign}копать         - заняться археологией
-${csign}fish | ${csign}fisher        - порыбачить
-${csign}рыба | ${csign}рыбка | ${csign}рыбалка - заняться археологией
-${csign}f | ${csign}ф                - рандомная фраза из сборника цитат fortune_mod
-${csign}fortune | ${csign}фортунка   - рандомная фраза из сборника цитат fortune_mod
-${csign}friday | ${csign}пятница     - а не пятница ли сегодня?
-${csign}karma фраза           - посмотреть карму фразы
-${csign}карма фраза           - посмотреть карму фразы
-фраза++ | фраза--      - повысить или понизить карму фразы
-${csign}lat | ${csign}лат            - сгенерировать фразу из крылатого латинского выражения
-${csign}ping | ${csign}пинг          - попинговать бота
-${csign}some_brew             - выдать соответствующий напиток, бармен может налить rum, ром, vodka, водку, beer, пиво, tequila, текила, whisky, виски, absinthe, абсент
-${csign}ver | ${csign}version        - написать что-то про версию ПО
-${csign}версия                - написать что-то про версию ПО
-${csign}w город | ${csign}п город    - погода в городе
-EOL
-
-	} elsif (substr ($text, 1) eq 'lat'  ||  substr ($text, 1) eq 'лат') {
-		$reply = latAnswer ();
-	} elsif (substr ($text, 1) eq 'cat'  ||  substr ($text, 1) eq 'кис') {
-		$reply = kitty ();
-	} elsif (substr ($text, 1) eq 'dig'  ||  substr ($text, 1) eq 'копать') {
-		$reply = dig ($chattername);
-	} elsif (substr ($text, 1) eq 'fish'  ||  substr ($text, 1) eq 'fisher'  ||  substr ($text, 1) eq 'рыба'  ||  substr ($text, 1) eq 'рыбка'  ||  substr ($text, 1) eq 'рыбалка') {
-		$reply = fish ($chattername);
-	} elsif ((length ($text) >= 6 && (substr ($text, 1, 6) eq 'karma ' || substr ($text, 1, 6) eq 'карма '))  ||  substr ($text, 1) eq 'karma'  ||  substr ($text, 1) eq 'карма') {
-		my $mytext = '';
-
-		if (length ($text) > 6) {
-			$mytext = substr $text, 7;
-			chomp $mytext;
-			$mytext = trim $mytext;
-		} else {
-			$mytext = '';
-		}
-
-		$reply = karmaGet ($chatid, $mytext);
-	} elsif (substr ($text, 1) eq 'friday'  ||  substr ($text, 1) eq 'пятница') {
-		$reply = friday ();
-	} elsif (substr ($text, 1) eq 'fortune'  ||  substr ($text, 1) eq 'фортунка'  ||  substr ($text, 1) eq 'f'  ||  substr ($text, 1) eq 'ф') {
-		my $phrase = fortune ();
-		# workaround Net::Jabber::Bot outgoing message ![:print:] replacement
-		$phrase =~ s/\s\s+\-\-/\n \-\-/xmsg;
-		$reply = $phrase;
-	} elsif (substr ($text, 1) eq 'ping') {
-		$reply = 'Pong.';
-	} elsif (substr ($text, 1) eq 'пинг') {
-		$reply = 'Понг.';
-	}
-
-	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/jabberbot.pm

@@ -1,178 +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;
-use utf8;
-use open qw (:std :utf8);
-use English qw ( -no_match_vars );
-use Carp qw(carp);
-use File::Path qw (make_path);
-use Hailo;
-use Net::Jabber::Bot;
-use botlib qw (command randomCommonPhrase realjid);
-use conf qw (loadConf);
-use karma qw (karmaSet);
-use util qw (trim utf2sha1);
-
-use version; our $VERSION = qw (1.0);
-use Exporter qw (import);
-our @EXPORT_OK = qw (run_jabberbot);
-
-my $c = loadConf ();
-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 {
-				carp "[ERROR] Unable to create $braindir: $OS_ERROR";
-				return;
-			};
-		}
-
-		$hailo->{$chatid} = Hailo->new (
-			brain => $brainname,
-			order => 2
-		);
-
-		if ($hash{'type'} eq 'groupchat') {
-			carp "[INFO] Initialized brain for chat $hash{'reply_to'}: $brainname";
-		} else {
-			carp "[INFO] Initialized brain for chat $jid{'jid'}: $brainname";
-		}
-	}
-
-	# parse messages
-	my $qname = quotemeta $bot->{'alias'};
-
-	if ($text =~ /^$qname\,?\s*$/) {
-		$reply = 'Чего тебе?';
-	} elsif (($text =~ /^$qname[\,|\:]? (.+)/) && ($hash{'type'} eq 'groupchat')) {
-		$reply = $hailo->{$chatid}->learn_reply ($1);
-	} elsif (substr ($text, 0, 1) eq $c->{jabberbot}->{aleesa}->{csign}) {
-		$reply = command %hash;
-	# karma adjustment
-	} elsif (substr ($text, -2) eq '++'  ||  substr ($text, -2) eq '--') {
-		my @arr = split /\n/, $text;
-
-		if ($#arr < 1) {
-			$reply = karmaSet ($chatid, trim (substr ($text, 0, -2)), substr ($text, -2));
-		} 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);
-			}
-		}
-	# just message in chat
-	} else {
-		# 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 run_jabberbot {
-	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/weather.pm

@@ -1,200 +0,0 @@
-package weather;
-
-use 5.018;
-use strict;
-use warnings;
-use utf8;
-use open qw (:std :utf8);
-use English qw ( -no_match_vars );
-use Carp qw (carp cluck);
-use DB_File;
-use Digest::MD5 qw (md5_base64);
-use File::Path qw (make_path);
-use HTTP::Tiny;
-use JSON::XS;
-use conf qw (loadConf);
-use 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 $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 $cachedir = $c->{openweathermap}->{cachedir};
-	my $cachetimefile = $cachedir . '/openweathermap.Id-Timestamp.db';
-	my $cachedatafile = $cachedir . '/openweathermap.Id-Data.db';
-	my $now = time ();
-	my $fc;
-	my $w;
-
-	unless (-d $cachedir) {
-		make_path ($cachedir)  ||  do {
-			carp "[ERROR] Unable to create $cachedir: $OS_ERROR";
-			return;
-		};
-	}
-
-	# attach to cache data
-	tie my %cachetime, 'DB_File', $cachetimefile or do {
-		carp "[ERROR] Something nasty happen when cachetime ties to its data: $OS_ERROR";
-		return undef;
-	};
-
-	tie my %cachedata, 'DB_File', $cachedatafile or do {
-		carp "[ERROR] Something nasty happen when cachedata ties to its data: $OS_ERROR";
-		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 (1..3) {
-			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));
-
-			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});
-			};
-
-			if ($EVAL_ERROR) {
-				carp "[WARN] openweathermap returns corrupted json: $EVAL_ERROR";
-				untie %cachetime;
-				untie %cachedata;
-				return undef;
-			};
-
-			$cachetime{$id} = $now;
-			$cachedata{$id} = encode_json ($fc);
-		} else {
-			carp sprintf 'Server return status %s with message: %s', $r->{status}, $r->{reason};
-			untie %cachetime;
-			untie %cachedata;
-			return undef;
-		}
-	}
-
-	untie %cachetime;
-	untie %cachedata;
-
-	# 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;
-}
-
-1;
-
-# vim: set ft=perl noet ai ts=4 sw=4 sts=4: