eleksir/aleesa-jabber-bot
1
Fork 0
Code Activity

More heavy perlcritic policies, more careful work with strings/substr

Browse Source
This commit is contained in:
eleksir
2022-04-03 13:45:02 +03:00
parent 5e53450221
commit f18544a798
22 changed files with 271 additions and 227 deletions
Download Patch File Download Diff File Expand all files Collapse all files

49
.perlcriticrc
View File

@@ -1,4 +1,17 @@
#!/usr/bin/env perlcritic #!/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 severity = 5
verbose = 8 verbose = 8
@@ -98,3 +111,39 @@ lib_sections = NAME | VERSION | DESCRIPTION | AUTHOR | LICENSE AND COPYRIGHT
[-ControlStructures::ProhibitDeepNests] [-ControlStructures::ProhibitDeepNests]
# jabber bot lib have very nested structures that a bit fiddle to navigate :( # 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

43
bin/aleesa-jabber-bot
View File

@@ -1,6 +1,6 @@
#!/usr/bin/perl #!/usr/bin/perl
use 5.018; use 5.018; ## no critic (ProhibitImplicitImport)
use strict; use strict;
use warnings; use warnings;
use utf8; use utf8;
@@ -26,12 +26,13 @@ BEGIN {
use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5"); use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
no Cwd; no Cwd;
use Cwd::utf8 qw (chdir abs_path); 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::Path qw (make_path);
use File::Basename qw (basename dirname); use File::Basename qw (basename dirname);
use File::Spec ();
use Log::Any qw ($log); use Log::Any qw ($log);
use Log::Any::Adapter; use Log::Any::Adapter ();
use Log::Any::For::Std; use Log::Any::For::Std ();
use BotLib::Conf qw (LoadConf); use BotLib::Conf qw (LoadConf);
use JabberBot qw (RunJabberBot); use JabberBot qw (RunJabberBot);
@@ -44,13 +45,13 @@ my $runAsUid = $UID;
my $piddir = '/var/run/' . basename (abs_path $PROGRAM_NAME); my $piddir = '/var/run/' . basename (abs_path $PROGRAM_NAME);
my $C = LoadConf (); my $C = LoadConf ();
my $loglevel = $C->{'loglevel'} // 'notice'; my $loglevel = $C->{loglevel} // 'notice';
my $logfile; my $logfile;
if (defined $C->{'log'}) { if (defined $C->{log}) {
$logfile = $C->{'log'}; $logfile = $C->{log};
} elsif (defined $C->{'debug_log'}) { } elsif (defined $C->{debug_log}) {
$logfile = $C->{'debug_log'}; $logfile = $C->{debug_log};
} }
# if we run under root, create pid dir and set correct owner for it, same for debug log if it is defined # if we run under root, create pid dir and set correct owner for it, same for debug log if it is defined
@@ -63,8 +64,8 @@ if ($UID == 0) {
make_path ( make_path (
$piddir, { $piddir, {
uid => $uid, uid => $uid,
group => $gid group => $gid,
} },
) or die "Unable to create $piddir: $OS_ERROR\n"; ) or die "Unable to create $piddir: $OS_ERROR\n";
} }
@@ -75,8 +76,8 @@ if ($UID == 0) {
make_path ( make_path (
$logdir, { $logdir, {
uid => $uid, uid => $uid,
group => $gid group => $gid,
} },
) or die "Unable to create $logdir: $OS_ERROR\n"; ) or die "Unable to create $logdir: $OS_ERROR\n";
} }
} }
@@ -97,15 +98,15 @@ if (defined $logfile) {
# verbosity paticulary for CHI. # verbosity paticulary for CHI.
Log::Any::Adapter->set ( Log::Any::Adapter->set (
{ {
category => 'CHI::Driver' category => 'CHI::Driver',
}, },
'File', 'File',
$logfile, $logfile,
log_level => 'warn' log_level => 'warn',
); );
} else { } else {
# no log defined so set loglevel to the least verbose # no log defined so set loglevel to the least verbose
Log::Any::Adapter->set ('File', '/dev/null', 'log_level'=>'emergency'); Log::Any::Adapter->set ('File', File::Spec->devnull, 'log_level'=>'emergency');
} }
# double fork attach to /dev/null all stdio and go background # double fork attach to /dev/null all stdio and go background
@@ -142,7 +143,7 @@ $PROGRAM_NAME = abs_path $PROGRAM_NAME; ## no critic (Variables::RequireLocaliz
RunJabberBot (); RunJabberBot ();
if (-f $pidfile) { if (-e $pidfile) {
unlink $pidfile; unlink $pidfile;
} }
@@ -151,10 +152,10 @@ exit 0;
sub daemonize () { sub daemonize () {
__fork (); __fork ();
POSIX::setsid (); 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 # 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 (STDOUT, '>', File::Spec->devnull); ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
#open (STDERR, '>', '/dev/null'); ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen) #open (STDERR, '>', File::Spec->devnull); ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
__fork (); __fork ();
umask 0; umask 0;
return; return;
@@ -178,7 +179,7 @@ sub __fork () {
sub __signal_handler ($) { sub __signal_handler ($) {
$log->info ("[INFO] Caught a signal $OS_ERROR"); $log->info ("[INFO] Caught a signal $OS_ERROR");
if (-f $pidfile) { if (-e $pidfile) {
unlink $pidfile; unlink $pidfile;
} }

2
bin/flickr_init.pl
View File

@@ -1,6 +1,6 @@
#!/usr/bin/perl #!/usr/bin/perl
use 5.018; use 5.018; ## no critic (ProhibitImplicitImport)
use strict; use strict;
use warnings; use warnings;
use utf8; use utf8;

2
bin/fortune_seed.pl
View File

@@ -1,6 +1,6 @@
#!/usr/bin/perl #!/usr/bin/perl
use 5.018; use 5.018; ## no critic (ProhibitImplicitImport)
use strict; use strict;
use warnings; use warnings;
use utf8; use utf8;

2
bin/friday_seed.pl
View File

@@ -1,6 +1,6 @@
#!/usr/bin/perl #!/usr/bin/perl
use 5.018; use 5.018; ## no critic (ProhibitImplicitImport)
use strict; use strict;
use warnings; use warnings;
use utf8; use utf8;

2
bin/proverb_seed.pl
View File

@@ -1,6 +1,6 @@
#!/usr/bin/perl #!/usr/bin/perl
use 5.018; use 5.018; ## no critic (ProhibitImplicitImport)
use strict; use strict;
use warnings; use warnings;
use utf8; use utf8;

2
bin/train_lat.pl
View File

@@ -1,6 +1,6 @@
#!/usr/bin/perl #!/usr/bin/perl
use 5.018; use 5.018; ## no critic (ProhibitImplicitImport)
use strict; use strict;
use warnings; use warnings;
use utf8; use utf8;

2
cpanfile
View File

@@ -1,3 +1,4 @@
## no critic
requires 'CHI'; requires 'CHI';
requires 'CHI::Driver::BerkeleyDB'; requires 'CHI::Driver::BerkeleyDB';
requires 'Cwd::utf8'; requires 'Cwd::utf8';
@@ -8,6 +9,7 @@ requires 'Digest::MD5';
requires 'Digest::SHA'; requires 'Digest::SHA';
requires 'File::Basename'; requires 'File::Basename';
requires 'File::Path'; requires 'File::Path';
requires 'File::Spec';
requires 'HTTP::Tiny'; requires 'HTTP::Tiny';
requires 'Hailo'; requires 'Hailo';
requires 'JSON'; requires 'JSON';

201
lib/BotLib.pm
View File

@@ -6,7 +6,6 @@ use warnings;
use utf8; use utf8;
use open qw (:std :utf8); use open qw (:std :utf8);
use English qw ( -no_match_vars ); use English qw ( -no_match_vars );
use Carp qw (carp);
use Math::Random::Secure qw (irand); use Math::Random::Secure qw (irand);
use BotLib::Anek qw (Anek); use BotLib::Anek qw (Anek);
use BotLib::Archeologist qw (Dig); use BotLib::Archeologist qw (Dig);
@@ -31,6 +30,10 @@ use version; our $VERSION = qw (1.0);
use Exporter qw (import); use Exporter qw (import);
our @EXPORT_OK = qw (Command RandomCommonPhrase RealJID); our @EXPORT_OK = qw (Command RandomCommonPhrase RealJID);
sub RandomCommonPhrase ();
sub Command;
sub RealJID(%);
my $c = LoadConf (); my $c = LoadConf ();
sub RandomCommonPhrase () { sub RandomCommonPhrase () {
@@ -69,123 +72,113 @@ sub Command {
my $csign = $c->{jabberbot}->{aleesa}->{csign}; my $csign = $c->{jabberbot}->{aleesa}->{csign};
my $reply; my $reply;
my $cmd = substr $text, length ($csign);
if (substr ($text, 1, 3) eq 'rum' || substr ($text, 1, 3) eq 'ром') { if (($cmd =~ /rum\s?/u) || ($cmd =~ /ром\s?/u)) {
my $target; my $target = $chattername;
if (($hash{'type'} eq 'groupchat') && (length ($text) > 5)) { if ($hash{'type'} eq 'groupchat') {
$target = trim (substr $text, 5); if ($cmd =~ /rum\s+(.*)/u) {
$target = $1 if ($1 ne '');
} elsif ($cmd =~ /ром\s+(.*)/u) {
$target = $1 if ($1 ne '');
} }
if (! defined $target || ($target eq '')) {
$target = $chattername;
} }
$reply = '/me притаскивает на подносе стопку рома для ' . $target . ', края стопки искрятся кристаллами соли.'; $reply = '/me притаскивает на подносе стопку рома для ' . $target . ', края стопки искрятся кристаллами соли.';
} elsif (substr ($text, 1, 5) eq 'vodka' || substr ($text, 1, 5) eq 'водка') { } elsif (($cmd =~ /vodka\s?/u) || ($cmd =~ /водка\s?/u)) {
my $target; my $target = $chattername;
if (($hash{'type'} eq 'groupchat') && (length ($text) > 7)) { if ($hash{'type'} eq 'groupchat') {
$target = trim (substr $text, 7); if ($cmd =~ /vodka\s+(.*)/u) {
$target = $1 if ($1 ne '');
} elsif ($cmd =~ /водка\s+(.*)/u) {
$target = $1 if ($1 ne '');
} }
if (! defined $target || ($target eq '')) {
$target = $chattername;
} }
$reply = '/me подаёт шот водки с небольшим маринованным огурчиком на блюдце для ' . $target . '. Из огурчика торчит небольшая вилочка.'; $reply = '/me подаёт шот водки с небольшим маринованным огурчиком на блюдце для ' . $target . '. Из огурчика торчит небольшая вилочка.';
} elsif (substr ($text, 1, 4) eq 'beer' || substr ($text, 1, 4) eq 'пиво') { } elsif (($cmd =~ /^beer\s?/u) || ($cmd =~ /^пиво\s?/u)) {
my $target; my $target = $chattername;
if (($hash{'type'} eq 'groupchat') && (length ($text) > 6)) { if ($hash{'type'} eq 'groupchat') {
$target = trim (substr $text, 6); if ($cmd =~ /^beer\s+(.*)/u) {
$target = $1 if ($1 ne '');
} elsif ($cmd =~ /^пиво\s+(.*)/u) {
$target = $1 if ($1 ne '');
} }
if (! defined $target || ($target eq '')) {
$target = $chattername;
} }
$reply = '/me бахает об стол перед ' . $target . ' кружкой холодного пива, часть пенной шапки сползает по запотевшей стенке кружки.'; $reply = '/me бахает об стол перед ' . $target . ' кружкой холодного пива, часть пенной шапки сползает по запотевшей стенке кружки.';
} elsif (substr ($text, 1, 7) eq 'tequila') { } elsif ($cmd =~ /^tequila\s?/u) {
my $target; my $target = $chattername;
if (($hash{'type'} eq 'groupchat') && (length ($text) > 9)) { if ($hash{'type'} eq 'groupchat') {
$target = trim (substr $text, 9); if ($cmd =~ /^tequila\s+(.*)/u) {
$target = $1 if ($1 ne '');
} }
if (! defined $target || ($target eq '')) {
$target = $chattername;
} }
$reply = '/me ставит рядом с ' . $target . ' шот текилы, аккуратно на ребро стопки насаживает дольку лайма и ставит кофейное блюдце с горочкой соли.'; $reply = '/me ставит рядом с ' . $target . ' шот текилы, аккуратно на ребро стопки насаживает дольку лайма и ставит кофейное блюдце с горочкой соли.';
} elsif (substr ($text, 1, 6) eq 'текила') { } elsif ($cmd =~ /^текила\s?/u) {
my $target; my $target = $chattername;
if (($hash{'type'} eq 'groupchat') && (length ($text) > 8)) { if ($hash{'type'} eq 'groupchat') {
$target = trim (substr $text, 8); if ($cmd =~ /^текила\s+(.*)/u) {
$target = $1 if ($1 ne '');
} }
if (! defined $target || ($target eq '')) {
$target = $chattername;
} }
$reply = '/me ставит рядом с ' . $target . ' шот текилы, аккуратно на ребро стопки насаживает дольку лайма и ставит кофейное блюдце с горочкой соли.'; $reply = '/me ставит рядом с ' . $target . ' шот текилы, аккуратно на ребро стопки насаживает дольку лайма и ставит кофейное блюдце с горочкой соли.';
} elsif (substr ($text, 1, 6) eq 'whisky') { } elsif ($cmd =~ /^whisky\s?/u) {
my $target; my $target = $chattername;
if (($hash{'type'} eq 'groupchat') && (length ($text) > 8)) { if ($hash{'type'} eq 'groupchat') {
$target = trim (substr $text, 8); if ($cmd =~ /^whisky\s+(.*)/u) {
$target = $1 if ($1 ne '');
} }
if (! defined $target || ($target eq '')) {
$target = $chattername;
} }
$reply = '/me демонстративно достаёт из морозилки пару кубических камушков, бросает их в толстодонный стакан и аккуратно наливает Jack Daniels. Запускает стакан вдоль барной стойки, он останавливается около ' . $target . '.'; $reply = '/me демонстративно достаёт из морозилки пару кубических камушков, бросает их в толстодонный стакан и аккуратно наливает Jack Daniels. Запускает стакан вдоль барной стойки, он останавливается около ' . $target . '.';
} elsif (substr ($text, 1, 5) eq 'виски') { } elsif ($cmd =~ /^виски\s?/u) {
my $target; my $target = $chattername;
if (($hash{'type'} eq 'groupchat') && (length ($text) > 7)) { if ($hash{'type'} eq 'groupchat') {
$target = trim (substr $text, 7); if ($cmd =~ /^виски\s+(.*)/u) {
$target = $1 if ($1 ne '');
} }
if (! defined $target || ($target eq '')) {
$target = $chattername;
} }
$reply = '/me демонстративно достаёт из морозилки пару кубических камушков, бросает их в толстодонный стакан и аккуратно наливает Jack Daniels. Запускает стакан вдоль барной стойки, он останавливается около ' . $target . '.'; $reply = '/me демонстративно достаёт из морозилки пару кубических камушков, бросает их в толстодонный стакан и аккуратно наливает Jack Daniels. Запускает стакан вдоль барной стойки, он останавливается около ' . $target . '.';
} elsif (substr ($text, 1, 8) eq 'absinthe') { } elsif ($cmd =~ /^absinthe\s?/u) {
my $target; my $target = $chattername;
if (($hash{'type'} eq 'groupchat') && (length ($text) > 10)) { if ($hash{'type'} eq 'groupchat') {
$target = trim (substr $text, 10); if ($cmd =~ /^absinthe\s+(.*)/u) {
$target = $1 if ($1 ne '');
} }
if (! defined $target || ($target eq '')) {
$target = $chattername;
} }
$reply = '/me наливает абсент в стопку. Смочив кубик сахара в абсенте кладёт его на дырявую ложечку и пожигает. Как только пламя потухнет, ' . $bot->{'alias'} . ' размешивает оплавившийся кубик в абсенте и подносит стопку ' . $target . '.'; $reply = '/me наливает абсент в стопку. Смочив кубик сахара в абсенте кладёт его на дырявую ложечку и пожигает. Как только пламя потухнет, ' . $bot->{'alias'} . ' размешивает оплавившийся кубик в абсенте и подносит стопку ' . $target . '.';
} elsif (substr ($text, 1, 6) eq 'абсент') { } elsif ($cmd =~ /^абсент\s?/u) {
my $target; my $target = $chattername;
if (($hash{'type'} eq 'groupchat') && (length ($text) > 8)) { if ($hash{'type'} eq 'groupchat') {
$target = trim (substr $text, 8); if ($cmd =~ /^абсент\s+(.*)/u) {
$target = $1 if ($1 ne '');
} }
if (! defined $target || ($target eq '')) {
$target = $chattername;
} }
$reply = '/me наливает абсент в стопку. Смочив кубик сахара в абсенте кладёт его на дырявую ложечку и пожигает. Как только пламя потухнет, ' . $bot->{'alias'} . ' размешивает оплавившийся кубик в абсенте и подносит стопку ' . $target . '.'; $reply = '/me наливает абсент в стопку. Смочив кубик сахара в абсенте кладёт его на дырявую ложечку и пожигает. Как только пламя потухнет, ' . $bot->{'alias'} . ' размешивает оплавившийся кубик в абсенте и подносит стопку ' . $target . '.';
} elsif (substr ($text, 1, 2) eq 'w ' || substr ($text, 1, 2) eq 'п ') { } elsif ($cmd =~ /^[wп]\s+.+/u) {
my $city = substr $text, 2; $cmd =~ /^[wп]\s+(.*)/;
my $city = $1; ## no critic (RegularExpressions::ProhibitCaptureWithoutTest)
$reply = Weather ($city) =~ tr/\n/ /r; $reply = Weather ($city) =~ tr/\n/ /r;
} elsif (substr ($text, 1) eq 'anek' || substr ($text, 1) eq 'анек' || substr ($text, 1) eq 'анекдот' ) { } elsif ($cmd eq 'anek' || $cmd eq 'анек' || $cmd eq 'анекдот' ) {
$reply = Anek (); $reply = Anek ();
} elsif (substr ($text, 1) eq 'coin' || substr ($text, 1) eq 'монетка') { } elsif ($cmd eq 'coin' || $cmd eq 'монетка') {
if (rand (101) < 0.016) { if (rand (101) < 0.016) {
$reply = "ребро"; $reply = 'ребро';
} else { } else {
if (irand (2) == 0) { if (irand (2) == 0) {
if (irand (2) == 0) { if (irand (2) == 0) {
@@ -201,11 +194,11 @@ sub Command {
} }
} }
} }
} elsif (substr ($text, 1) eq 'roll' || substr ($text, 1) eq 'dice' || substr ($text, 1) eq 'кости') { } elsif ($cmd eq 'roll' || $cmd eq 'dice' || $cmd eq 'кости') {
$reply = sprintf "На первой кости выпало %d, а на второй — %d.", irand (6) + 1, irand (6) + 1; $reply = sprintf 'На первой кости выпало %d, а на второй — %d.', irand (6) + 1, irand (6) + 1;
} elsif (substr ($text, 1) eq 'version' || substr ($text, 1) eq 'ver') { } elsif ($cmd eq 'version' || $cmd eq 'ver' || $cmd eq 'версия') {
$reply = 'Версия нуль.чего-то_там.чего-то_там'; $reply = 'Версия три.чего-то_там.чего-то_там';
} elsif (substr ($text, 1) eq 'help' || substr ($text, 1) eq 'помощь') { } elsif ($cmd eq 'help' || $cmd eq 'помощь') {
$reply = <<"EOL"; $reply = <<"EOL";
${csign}help | ${csign}помощь - это сообщение ${csign}help | ${csign}помощь - это сообщение
@@ -242,77 +235,77 @@ ${csign}w город | ${csign}п город - погода в горо
${csign}xkcd - комикс-стрип с xkcb.ru ${csign}xkcd - комикс-стрип с xkcb.ru
EOL EOL
} elsif (substr ($text, 1) eq 'lat' || substr ($text, 1) eq 'лат') { } elsif ($cmd eq 'lat' || $cmd eq 'лат') {
$reply = Lat (); $reply = Lat ();
} elsif (substr ($text, 1) eq 'cat' || substr ($text, 1) eq 'кис') { } elsif ($cmd eq 'cat' || $cmd eq 'кис') {
$reply = Kitty (); $reply = Kitty ();
} elsif (substr ($text, 1) eq 'fox' || substr ($text, 1) eq 'лис') { } elsif ($cmd eq 'fox' || $cmd eq 'лис') {
$reply = Fox (); $reply = Fox ();
} elsif (substr ($text, 1) eq 'frog' || substr ($text, 1) eq 'лягушка') { } elsif ($cmd eq 'frog' || $cmd eq 'лягушка') {
$reply = Frog (); $reply = Frog ();
} elsif (substr ($text, 1) eq 'horse' || substr ($text, 1) eq 'лошадь' || substr ($text, 1) eq 'лошадка') { } elsif ($cmd eq 'horse' || $cmd eq 'лошадь' || $cmd eq 'лошадка') {
$reply = Horse (); $reply = Horse ();
} elsif (substr ($text, 1) eq 'snail' || substr ($text, 1) eq 'улитка') { } elsif ($cmd eq 'snail' || $cmd eq 'улитка') {
$reply = Snail (); $reply = Snail ();
} elsif (substr ($text, 1) eq 'dig' || substr ($text, 1) eq 'копать') { } elsif ($cmd eq 'dig' || $cmd eq 'копать') {
$reply = Dig ($chattername); $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 'рыбалка') { } elsif ($cmd eq 'fish' || $cmd eq 'fisher' || $cmd eq 'рыба' || $cmd eq 'рыбка' || $cmd eq 'рыбалка') {
$reply = Fish ($chattername); $reply = Fish ($chattername);
} elsif (substr ($text, 1) eq 'buni') { } elsif ($cmd eq 'buni') {
$reply = Buni (); $reply = Buni ();
} elsif (substr ($text, 1) eq 'xkcd') { } elsif ($cmd eq 'xkcd') {
$reply = Xkcd (); $reply = Xkcd ();
} elsif (substr ($text, 1) eq 'monkeyuser') { } elsif ($cmd eq 'monkeyuser') {
$reply = Monkeyuser (); $reply = Monkeyuser ();
} elsif (substr ($text, 1) eq 'drink' || substr ($text, 1) eq 'праздник') { } elsif ($cmd eq 'drink' || $cmd eq 'праздник') {
$reply = Drink (); $reply = Drink ();
} elsif (substr ($text, 1) eq 'bunny' || substr ($text, 1) eq 'rabbit' || substr ($text, 1) eq 'кролик') { } elsif ($cmd eq 'bunny' || $cmd eq 'rabbit' || $cmd eq 'кролик') {
$reply = Rabbit (); $reply = Rabbit ();
} elsif (substr ($text, 1) eq 'owl' || substr ($text, 1) eq 'сова') { } elsif ($cmd eq 'owl' || $cmd eq 'сова') {
$reply = Owl (); $reply = Owl ();
} elsif ((length ($text) >= 6 && (substr ($text, 1, 6) eq 'karma ' || substr ($text, 1, 6) eq 'карма ')) || substr ($text, 1) eq 'karma' || substr ($text, 1) eq 'карма') { } elsif ($cmd =~ /^karma\s*/ || $cmd =~ /^карма\s*/) {
my $mytext = ''; my $mytext = '';
if (length ($text) > 6) { if (length ($cmd) > length ('karma')) {
$mytext = substr $text, 7; $mytext = substr $cmd, length ('karma');
chomp $mytext; while ($mytext =~ /\n$/) { chomp $mytext }
$mytext = trim $mytext;
} elsif (length ($cmd) > length ('карма')) {
$mytext = substr $cmd, length ('карма');
while ($mytext =~ /\n$/) { chomp $mytext }
$mytext = trim $mytext; $mytext = trim $mytext;
} else { } else {
$mytext = ''; $mytext = '';
} }
$reply = KarmaGet ($chatid, $mytext); $reply = KarmaGet ($chatid, $mytext);
} elsif (substr ($text, 1) eq 'friday' || substr ($text, 1) eq 'пятница') { } elsif ($cmd eq 'friday' || $cmd eq 'пятница') {
$reply = Friday (); $reply = Friday ();
} elsif (substr ($text, 1) eq 'proverb' || substr ($text, 1) eq 'пословица') { } elsif ($cmd eq 'proverb' || $cmd eq 'пословица') {
$reply = Proverb (); $reply = Proverb ();
} elsif (substr ($text, 1) eq 'fortune' || substr ($text, 1) eq 'фортунка' || substr ($text, 1) eq 'f' || substr ($text, 1) eq 'ф') { } elsif ($cmd eq 'fortune' || $cmd eq 'фортунка' || $cmd eq 'f' || $cmd eq 'ф') {
my $phrase = Fortune (); my $phrase = Fortune ();
# workaround Net::Jabber::Bot outgoing message ![:print:] replacement # workaround Net::Jabber::Bot outgoing message ![:print:] replacement
$phrase =~ s/\s\s+\-\-/\n \-\-/xmsg; $phrase =~ s/\s\s+\-\-/\n \-\-/xmsg;
$reply = $phrase; $reply = $phrase;
} elsif (substr ($text, 1) eq 'ping') { } elsif ($cmd eq 'ping') {
$reply = 'Pong.'; $reply = 'Pong.';
} elsif (substr ($text, 1) eq 'пинг') { } elsif ($cmd eq 'пинг') {
$reply = 'Понг.'; $reply = 'Понг.';
} elsif (substr ($text, 1) eq 'kde' || substr ($text, 1) eq 'кде') { } elsif ($cmd eq 'kde' || $cmd eq 'кде') {
my @phrases = ( my @phrases = (
'Нет, я не буду поднимать вам плазму.', 'Нет, я не буду поднимать вам плазму.',
'Повторяйте эту мантру по утрам не менее 5 раз: "Плазма не падает." И, возможно, она перестанет у вас падать.' 'Повторяйте эту мантру по утрам не менее 5 раз: "Плазма не падает." И, возможно, она перестанет у вас падать.',
); );
$reply = $phrases[irand ($#phrases + 1)]; $reply = $phrases[irand ($#phrases + 1)];
} elsif (substr ($text, 1) eq '=(' || substr ($text, 1) eq ':(' || substr ($text, 1) eq '):') {
$reply = ':)';
} elsif (substr ($text, 1) eq '=)' || substr ($text, 1) eq ':)' || substr ($text, 1) eq '(:') {
$reply = ':D';
} }
return $reply; return $reply;
} }
# in this particular case real jid is really hidden :) and i hope that i found where it is hiding. # in this particular case real jid is really hidden :) and i hope that i found where it is hiding.
sub RealJID { sub RealJID (%) {
my %hash = @_; my %hash = @_;
my $bot = $hash{'bot_object'}; 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 $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

2
lib/BotLib/Anek.pm
View File

@@ -6,7 +6,7 @@ use warnings;
use utf8; use utf8;
use open qw (:std :utf8); use open qw (:std :utf8);
use English qw ( -no_match_vars ); use English qw ( -no_match_vars );
use Encode; use Encode qw (decode);
use HTML::TokeParser; use HTML::TokeParser;
use HTTP::Tiny; use HTTP::Tiny;
use JSON::XS; use JSON::XS;

2
lib/BotLib/Conf.pm
View File

@@ -19,7 +19,9 @@ sub LoadConf {
open my $CH, '<', $c or die "[FATA] No conf at $c: $OS_ERROR\n"; open my $CH, '<', $c or die "[FATA] No conf at $c: $OS_ERROR\n";
my $len = (stat $c) [7]; my $len = (stat $c) [7];
my $json; my $json;
use bytes;
my $readlen = read $CH, $json, $len; my $readlen = read $CH, $json, $len;
no bytes;
unless ($readlen) { unless ($readlen) {
close $CH; ## no critic (InputOutput::RequireCheckedSyscalls close $CH; ## no critic (InputOutput::RequireCheckedSyscalls

8
lib/BotLib/Drink.pm
View File

@@ -6,7 +6,7 @@ use warnings;
use utf8; use utf8;
use open qw (:std :utf8); use open qw (:std :utf8);
use English qw ( -no_match_vars ); use English qw ( -no_match_vars );
use Encode; use Encode qw (decode);
use CHI; use CHI;
use CHI::Driver::BerkeleyDB; use CHI::Driver::BerkeleyDB;
use DateTime; use DateTime;
@@ -76,7 +76,7 @@ sub Drink {
my $cache = CHI->new ( my $cache = CHI->new (
driver => 'BerkeleyDB', driver => 'BerkeleyDB',
root_dir => $c->{cachedir}, root_dir => $c->{cachedir},
namespace => __PACKAGE__ namespace => __PACKAGE__,
); );
# Those POSIX assholes just forgot to add unix timestamps without TZ offset, so... # Those POSIX assholes just forgot to add unix timestamps without TZ offset, so...
@@ -96,7 +96,7 @@ sub Drink {
day => $mday, day => $mday,
hour => 0, hour => 0,
minute => 0, minute => 0,
second => 0 second => 0,
)->add (days => 1)->strftime ('%s'); )->add (days => 1)->strftime ('%s');
if ((substr $offset, 0, 1) eq '+') { if ((substr $offset, 0, 1) eq '+') {
@@ -109,7 +109,7 @@ sub Drink {
my $res = $cache->compute ( my $res = $cache->compute (
'Holiday', 'Holiday',
{ expires_at => $expirationDate }, { expires_at => $expirationDate },
$drinkCallBack $drinkCallBack,
); );
if (defined $res && $res ne '') { if (defined $res && $res ne '') {

7
lib/BotLib/Fortune.pm
View File

@@ -11,7 +11,6 @@ use Carp qw (croak);
use File::Path qw (make_path); use File::Path qw (make_path);
use Log::Any qw ($log); use Log::Any qw ($log);
use Math::Random::Secure qw (irand); use Math::Random::Secure qw (irand);
use MIME::Base64;
use SQLite_File; use SQLite_File;
use BotLib::Conf qw (LoadConf); use BotLib::Conf qw (LoadConf);
@@ -30,7 +29,7 @@ sub Seed () {
my $backingfile = sprintf '%s/fortune.sqlite', $dir; my $backingfile = sprintf '%s/fortune.sqlite', $dir;
if (-f $backingfile) { if (-e $backingfile) {
unlink $backingfile || croak "Unable to remove $backingfile: $OS_ERROR\n"; unlink $backingfile || croak "Unable to remove $backingfile: $OS_ERROR\n";
} }
@@ -40,7 +39,7 @@ sub Seed () {
while (my $fortunefile = readdir $srcdirhandle) { while (my $fortunefile = readdir $srcdirhandle) {
my $srcfile = sprintf '%s/%s', $srcdir, $fortunefile; my $srcfile = sprintf '%s/%s', $srcdir, $fortunefile;
unless (-f $srcfile) { unless (-e $srcfile) {
next; next;
} }
@@ -53,7 +52,7 @@ sub Seed () {
local $INPUT_RECORD_SEPARATOR = "\n%\n"; local $INPUT_RECORD_SEPARATOR = "\n%\n";
while (readline $fh) { while (readline $fh) {
my $phrase = substr $_, 0, -3; my $phrase = substr $_, 0, length ("\n%\n");
push @fortune, $phrase; push @fortune, $phrase;
} }

2
lib/BotLib/Fox.pm
View File

@@ -6,7 +6,7 @@ use warnings;
use utf8; use utf8;
use open qw (:std :utf8); use open qw (:std :utf8);
use English qw ( -no_match_vars ); use English qw ( -no_match_vars );
use JSON::XS; use JSON::XS qw (decode_json);
use HTTP::Tiny; use HTTP::Tiny;
use Log::Any qw ($log); use Log::Any qw ($log);

2
lib/BotLib/Friday.pm
View File

@@ -33,7 +33,7 @@ sub Seed () {
for (0..$#dow) { for (0..$#dow) {
my $backingfile = sprintf '%s/%s.sqlite', $dir, $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"; unlink $backingfile || croak "Unable to remove $backingfile: $OS_ERROR\n";
} }

38
lib/BotLib/Image/Flickr.pm
View File

@@ -6,21 +6,19 @@ use warnings;
use utf8; use utf8;
use open qw (:std :utf8); use open qw (:std :utf8);
use English qw ( -no_match_vars ); use English qw ( -no_match_vars );
use Carp qw (cluck); use Digest::HMAC_SHA1 ();
use Digest::HMAC_SHA1 qw (hmac_sha1);
use File::Path qw (make_path); use File::Path qw (make_path);
use JSON::XS; use JSON::XS;
use HTTP::Tiny; use HTTP::Tiny;
use Log::Any qw ($log); use Log::Any qw ($log);
use Math::Random::Secure qw (irand); use Math::Random::Secure qw (irand);
use MIME::Base64; use MIME::Base64 qw (encode_base64);
use SQLite_File; use SQLite_File;
use URI::Encode::XS qw (uri_encode); use URI::Encode::XS qw (uri_encode);
use BotLib::Conf qw (LoadConf); use BotLib::Conf qw (LoadConf);
use BotLib::Util qw (urlencode);
use Data::Dumper; use Data::Dumper qw (Dumper);
use version; our $VERSION = qw (1.0); use version; our $VERSION = qw (1.0);
use Exporter qw (import); use Exporter qw (import);
@@ -109,7 +107,7 @@ sub flickrRequestToken {
my $oauth_signature = flickrSignReq ( my $oauth_signature = flickrSignReq (
type => 'request_token', type => 'request_token',
oauth_timestamp => $oauth_timestamp, oauth_timestamp => $oauth_timestamp,
oauth_nonce => $oauth_nonce oauth_nonce => $oauth_nonce,
); );
my $url = $flickr_request_token_url . sprintf ( my $url = $flickr_request_token_url . sprintf (
@@ -118,7 +116,7 @@ sub flickrRequestToken {
$oauth_timestamp, $oauth_timestamp,
$flickr_consumer_key, $flickr_consumer_key,
uri_encode ($oauth_signature), uri_encode ($oauth_signature),
uri_encode ($flickr_callback_url) uri_encode ($flickr_callback_url),
); );
my $http = HTTP::Tiny->new (timeout => 5); my $http = HTTP::Tiny->new (timeout => 5);
@@ -149,7 +147,7 @@ sub flickrAccessToken {
oauth_nonce => $oauth_nonce, oauth_nonce => $oauth_nonce,
oauth_token => $flickr_request_token, oauth_token => $flickr_request_token,
oauth_token_secret => $flickr_request_token_secret, oauth_token_secret => $flickr_request_token_secret,
oauth_verifier => $flickr_verifier oauth_verifier => $flickr_verifier,
); );
my $url = $flickr_access_token_url . sprintf ( my $url = $flickr_access_token_url . sprintf (
@@ -159,7 +157,7 @@ sub flickrAccessToken {
$flickr_verifier, $flickr_verifier,
$flickr_consumer_key, $flickr_consumer_key,
$flickr_request_token, $flickr_request_token,
uri_encode ($oauth_signature) uri_encode ($oauth_signature),
); );
my $http = HTTP::Tiny->new (timeout => 5); my $http = HTTP::Tiny->new (timeout => 5);
@@ -213,7 +211,7 @@ sub flickrTestLogin {
oauth_token => $flickr_access_token, oauth_token => $flickr_access_token,
oauth_token_secret => $flickr_access_token_secret, oauth_token_secret => $flickr_access_token_secret,
oauth_signature_method => 'HMAC-SHA1', oauth_signature_method => 'HMAC-SHA1',
oauth_version => '1.0' oauth_version => '1.0',
); );
my $url = $flickr_api_url . sprintf ( my $url = $flickr_api_url . sprintf (
@@ -222,7 +220,7 @@ sub flickrTestLogin {
$flickr_consumer_key, $flickr_consumer_key,
$oauth_timestamp, $oauth_timestamp,
$flickr_access_token, $flickr_access_token,
uri_encode ($oauth_signature) uri_encode ($oauth_signature),
); );
my $http = HTTP::Tiny->new (timeout => 5); my $http = HTTP::Tiny->new (timeout => 5);
@@ -270,7 +268,7 @@ sub flickrSearchByText {
oauth_token => $flickr_access_token, oauth_token => $flickr_access_token,
oauth_token_secret => $flickr_access_token_secret, oauth_token_secret => $flickr_access_token_secret,
oauth_signature_method => 'HMAC-SHA1', oauth_signature_method => 'HMAC-SHA1',
oauth_version => '1.0' oauth_version => '1.0',
); );
my $url = $flickr_api_url . sprintf ( my $url = $flickr_api_url . sprintf (
@@ -280,7 +278,7 @@ sub flickrSearchByText {
$oauth_timestamp, $oauth_timestamp,
$flickr_access_token, $flickr_access_token,
uri_encode ($oauth_signature), uri_encode ($oauth_signature),
uri_encode ($text) uri_encode ($text),
); );
my $http = HTTP::Tiny->new (timeout => 5); my $http = HTTP::Tiny->new (timeout => 5);
@@ -313,7 +311,7 @@ sub flickrSearchByText {
oauth_token => $flickr_access_token, oauth_token => $flickr_access_token,
oauth_token_secret => $flickr_access_token_secret, oauth_token_secret => $flickr_access_token_secret,
oauth_signature_method => 'HMAC-SHA1', oauth_signature_method => 'HMAC-SHA1',
oauth_version => '1.0' oauth_version => '1.0',
); );
$url = $flickr_api_url . sprintf ( $url = $flickr_api_url . sprintf (
@@ -324,7 +322,7 @@ sub flickrSearchByText {
$flickr_access_token, $flickr_access_token,
uri_encode ($oauth_signature), uri_encode ($oauth_signature),
$page, $page,
uri_encode ($text) uri_encode ($text),
); );
$http = HTTP::Tiny->new (timeout => 5); $http = HTTP::Tiny->new (timeout => 5);
@@ -379,7 +377,7 @@ sub flickrSearchByTags {
oauth_token => $flickr_access_token, oauth_token => $flickr_access_token,
oauth_token_secret => $flickr_access_token_secret, oauth_token_secret => $flickr_access_token_secret,
oauth_signature_method => 'HMAC-SHA1', oauth_signature_method => 'HMAC-SHA1',
oauth_version => '1.0' oauth_version => '1.0',
); );
my $url = $flickr_api_url . sprintf ( my $url = $flickr_api_url . sprintf (
@@ -389,7 +387,7 @@ sub flickrSearchByTags {
$oauth_timestamp, $oauth_timestamp,
$flickr_access_token, $flickr_access_token,
uri_encode ($oauth_signature), uri_encode ($oauth_signature),
uri_encode ($tags) uri_encode ($tags),
); );
my $http = HTTP::Tiny->new (timeout => 5); my $http = HTTP::Tiny->new (timeout => 5);
@@ -422,7 +420,7 @@ sub flickrSearchByTags {
oauth_token => $flickr_access_token, oauth_token => $flickr_access_token,
oauth_token_secret => $flickr_access_token_secret, oauth_token_secret => $flickr_access_token_secret,
oauth_signature_method => 'HMAC-SHA1', oauth_signature_method => 'HMAC-SHA1',
oauth_version => '1.0' oauth_version => '1.0',
); );
$url = $flickr_api_url . sprintf ( $url = $flickr_api_url . sprintf (
@@ -433,7 +431,7 @@ sub flickrSearchByTags {
$flickr_access_token, $flickr_access_token,
uri_encode ($oauth_signature), uri_encode ($oauth_signature),
$page, $page,
uri_encode ($tags) uri_encode ($tags),
); );
$http = HTTP::Tiny->new (timeout => 5); $http = HTTP::Tiny->new (timeout => 5);
@@ -501,7 +499,7 @@ sub FlickrInit {
'Access token (%s) and access token secret (%s) are in %s', 'Access token (%s) and access token secret (%s) are in %s',
$accessToken{oauth_token}, $accessToken{oauth_token},
$accessToken{oauth_token_secret}, $accessToken{oauth_token_secret},
$backingfile $backingfile,
); );
untie %secret; untie %secret;

2
lib/BotLib/Kitty.pm
View File

@@ -6,7 +6,7 @@ use warnings;
use utf8; use utf8;
use open qw (:std :utf8); use open qw (:std :utf8);
use English qw ( -no_match_vars ); use English qw ( -no_match_vars );
use JSON::XS; use JSON::XS qw (decode_json);
use HTTP::Tiny; use HTTP::Tiny;
use Log::Any qw ($log); use Log::Any qw ($log);

6
lib/BotLib/Lat.pm
View File

@@ -35,7 +35,7 @@ sub Train () {
my $lat = Hailo->new ( my $lat = Hailo->new (
brain => $brain, brain => $brain,
# in our case mean amount of words in phase is 3 # in our case mean amount of words in phase is 3
order => 2 order => 2,
); );
$lat->train ($srcfile); $lat->train ($srcfile);
@@ -54,7 +54,7 @@ sub Lat () {
return ''; return '';
} }
unless (-f $brain) { unless (-e $brain) {
$log->error ("[ERROR] No lat module data: $brain is absent! Train lat first."); $log->error ("[ERROR] No lat module data: $brain is absent! Train lat first.");
return ''; return '';
} }
@@ -63,7 +63,7 @@ sub Lat () {
brain => $brain, brain => $brain,
# in our case mean amount of words in phase is 3 # in our case mean amount of words in phase is 3
order => 2, order => 2,
save_on_exit => 0 save_on_exit => 0,
); );
return $lat->reply (); return $lat->reply ();

6
lib/BotLib/Proverb.pm
View File

@@ -7,7 +7,7 @@ use warnings;
use utf8; use utf8;
use open qw (:std :utf8); use open qw (:std :utf8);
use English qw ( -no_match_vars ); use English qw ( -no_match_vars );
use Carp qw (cluck croak); use Carp qw (croak);
use File::Path qw (make_path); use File::Path qw (make_path);
use Log::Any qw ($log); use Log::Any qw ($log);
use Math::Random::Secure qw (irand); use Math::Random::Secure qw (irand);
@@ -30,7 +30,7 @@ sub Seed () {
my $backingfile = sprintf '%s/proverb.sqlite', $dir; my $backingfile = sprintf '%s/proverb.sqlite', $dir;
if (-f $backingfile) { if (-e $backingfile) {
unlink $backingfile || croak "Unable to remove $backingfile: $OS_ERROR"; unlink $backingfile || croak "Unable to remove $backingfile: $OS_ERROR";
} }
@@ -40,7 +40,7 @@ sub Seed () {
while (my $proverbfile = readdir ($srcdirhandle)) { while (my $proverbfile = readdir ($srcdirhandle)) {
my $srcfile = sprintf '%s/%s', $srcdir, $proverbfile; my $srcfile = sprintf '%s/%s', $srcdir, $proverbfile;
unless (-f $srcfile) { unless (-e $srcfile) {
next; next;
} }

15
lib/BotLib/Util.pm
View File

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

13
lib/BotLib/Weather.pm
View File

@@ -6,11 +6,10 @@ use warnings;
use utf8; use utf8;
use open qw (:std :utf8); use open qw (:std :utf8);
use English qw ( -no_match_vars ); use English qw ( -no_match_vars );
use Carp qw (carp cluck);
use CHI; use CHI;
use CHI::Driver::BerkeleyDB; use CHI::Driver::BerkeleyDB;
use HTTP::Tiny; use HTTP::Tiny;
use JSON::XS; use JSON::XS qw (decode_json);
use Log::Any qw ($log); use Log::Any qw ($log);
use BotLib::Conf qw (LoadConf); use BotLib::Conf qw (LoadConf);
use BotLib::Util qw (trim urlencode); use BotLib::Util qw (trim urlencode);
@@ -63,7 +62,7 @@ sub Weather {
unless (defined $fc) { unless (defined $fc) {
$log->warn ("[WARN] openweathermap returns corrupted json: $EVAL_ERROR"); $log->warn ("[WARN] openweathermap returns corrupted json: $EVAL_ERROR");
return undef; return undef;
}; }
} else { } else {
$log->warn (sprintf 'Server return status %s with message: %s', $r->{status}, $r->{reason}); $log->warn (sprintf 'Server return status %s with message: %s', $r->{status}, $r->{reason});
return undef; return undef;
@@ -127,13 +126,13 @@ sub Weather {
my $cache = CHI->new ( my $cache = CHI->new (
driver => 'BerkeleyDB', driver => 'BerkeleyDB',
root_dir => $c->{cachedir}, root_dir => $c->{cachedir},
namespace => __PACKAGE__ namespace => __PACKAGE__,
); );
my $w = $cache->compute ( my $w = $cache->compute (
$city, $city,
'3 hours', '3 hours',
$weatherCallBack $weatherCallBack,
); );
my $reply; my $reply;
@@ -149,7 +148,7 @@ sub Weather {
$w->{temperature_min}, $w->{temperature_min},
$w->{temperature_feelslike}, $w->{temperature_feelslike},
$w->{humidity}, $w->{humidity},
$w->{pressure} $w->{pressure},
); );
} else { } else {
$reply = sprintf ("Погода в городе %s, %s:\n%s, ветер %s %s м/c, температура %s-%s°C, ощущается как %s°C, относительная влажность %s%%, давление %s мм.рт.ст", $reply = sprintf ("Погода в городе %s, %s:\n%s, ветер %s %s м/c, температура %s-%s°C, ощущается как %s°C, относительная влажность %s%%, давление %s мм.рт.ст",
@@ -162,7 +161,7 @@ sub Weather {
$w->{temperature_max}, $w->{temperature_max},
$w->{temperature_feelslike}, $w->{temperature_feelslike},
$w->{humidity}, $w->{humidity},
$w->{pressure} $w->{pressure},
); );
} }
} else { } else {

46
lib/JabberBot.pm
View File

@@ -10,10 +10,10 @@ use utf8;
use open qw (:std :utf8); use open qw (:std :utf8);
use English qw ( -no_match_vars ); use English qw ( -no_match_vars );
use File::Path qw (make_path); use File::Path qw (make_path);
use Hailo; use Hailo ();
use Log::Any qw ($log); use Log::Any qw ($log);
use Net::Jabber::Bot; use Net::Jabber::Bot ();
use BotLib qw (Command RandomCommonPhrase RealJID); use BotLib qw (Command RealJID);
use BotLib::Conf qw (LoadConf); use BotLib::Conf qw (LoadConf);
use BotLib::Karma qw (KarmaSet); use BotLib::Karma qw (KarmaSet);
use BotLib::Util qw (trim utf2sha1); use BotLib::Util qw (trim utf2sha1);
@@ -23,6 +23,7 @@ use Exporter qw (import);
our @EXPORT_OK = qw (RunJabberBot); our @EXPORT_OK = qw (RunJabberBot);
my $c = LoadConf (); my $c = LoadConf ();
my $csign = $c->{jabberbot}->{aleesa}->{csign};
my $hailo; my $hailo;
my $imonline = 0; my $imonline = 0;
@@ -42,19 +43,19 @@ sub __new_bot_message {
my $bot = $hash{bot_object}; my $bot = $hash{bot_object};
# ignore self messages # ignore self messages
if ($hash{'from_full'} eq $bot->{'from_full'}) { if ($hash{from_full} eq $bot->{from_full}) {
return; return;
} }
my $text = $hash{body}; my $text = $hash{body};
my %jid = RealJID (%hash); my %jid = RealJID (%hash);
my $chattername = $jid{'name'}; my $chattername = $jid{name};
my $chatid; my $chatid;
if ($hash{'type'} eq 'groupchat') { if ($hash{type} eq 'groupchat') {
$chatid = utf2sha1 $hash{'reply_to'}; $chatid = utf2sha1 $hash{reply_to};
} else { } else {
$chatid = utf2sha1 $jid{'name'}; $chatid = utf2sha1 $jid{name};
} }
$chatid =~ s/\//-/xmsg; $chatid =~ s/\//-/xmsg;
@@ -75,10 +76,10 @@ sub __new_bot_message {
$hailo->{$chatid} = Hailo->new ( $hailo->{$chatid} = Hailo->new (
brain => $brainname, brain => $brainname,
order => 2 order => 2,
); );
if ($hash{'type'} eq 'groupchat') { if ($hash{type} eq 'groupchat') {
$log->info ("[INFO] Initialized brain for chat $hash{'reply_to'}: $brainname"); $log->info ("[INFO] Initialized brain for chat $hash{'reply_to'}: $brainname");
} else { } else {
$log->info ("[INFO] Initialized brain for chat $jid{'jid'}: $brainname"); $log->info ("[INFO] Initialized brain for chat $jid{'jid'}: $brainname");
@@ -86,34 +87,39 @@ sub __new_bot_message {
} }
# parse messages # parse messages
my $qname = quotemeta $bot->{'alias'}; my $qname = quotemeta $bot->{alias};
if ($text =~ /^$qname\,?\s*$/) { if ($text =~ /^$qname\,?\s*$/u) {
$reply = 'Чего тебе?'; $reply = 'Чего тебе?';
} elsif (($text =~ /^$qname[\,|\:]? (.+)/) && ($hash{'type'} eq 'groupchat')) { } elsif (($text =~ /^$qname[\,|\:]? (.+)/u) && ($hash{type} eq 'groupchat')) {
$reply = $hailo->{$chatid}->learn_reply ($1); $reply = $hailo->{$chatid}->learn_reply ($1);
} elsif ($text =~ /^=\($/u || $text =~ /^\:\($/u || $text eq /^\)\:$/u) {
$reply = ':)';
} elsif ($text =~ /^=\)$/u || $text =~ /^\:\)$/u || $text =~ /^\(\:$/u) {
$reply = ':D';
# karma adjustment # karma adjustment
} elsif (substr ($text, -2) eq '++' || substr ($text, -2) eq '--') { } elsif ($text =~ /(\+\+|\-\-)$/) {
my @arr = split /\n/, $text; my @arr = split /\n/, $text;
if ($#arr < 1) { if ($#arr < 1) {
$reply = KarmaSet ($chatid, trim (substr ($text, 0, -2)), substr ($text, -2)); $text =~ /(.*)(\+\+|\-\-)$/u;
$reply = KarmaSet ($chatid, trim ($1), $2); ## no critic (RegularExpressions::ProhibitCaptureWithoutTest)
} else { } else {
# just message in chat # just message in chat
# in groupchat we answer only to phrases that mention us # in groupchat we answer only to phrases that mention us
if ($hash{'type'} eq 'groupchat') { if ($hash{type} eq 'groupchat') {
$hailo->{$chatid}->learn ($text); $hailo->{$chatid}->learn ($text);
# in tet-a-tet chat we must always answer, if possible # in tet-a-tet chat we must always answer, if possible
} elsif ($hash{'type'} eq 'chat') { } elsif ($hash{type} eq 'chat') {
$reply = $hailo->{$chatid}->learn_reply ($text); $reply = $hailo->{$chatid}->learn_reply ($text);
} }
} }
} elsif (substr ($text, 0, 1) eq $c->{jabberbot}->{aleesa}->{csign}) { } elsif ((length ($text) > length ($csign)) && (substr ($text, 0, length ($csign)) eq $csign)) {
$reply = Command (%hash); $reply = Command (%hash);
# just message in chat # just message in chat
} else { } else {
# in groupchat we answer only to phrases that mention us # in groupchat we answer only to phrases that mention us
if ($hash{'type'} eq 'groupchat') { if ($hash{type} eq 'groupchat') {
$hailo->{$chatid}->learn ($text); $hailo->{$chatid}->learn ($text);
# in tet-a-tet chat we must always answer, if possible # in tet-a-tet chat we must always answer, if possible
} elsif ($hash{'type'} eq 'chat') { } elsif ($hash{'type'} eq 'chat') {
@@ -151,7 +157,7 @@ sub RunJabberBot {
'%s@%s/%s', '%s@%s/%s',
$c->{jabberbot}->{aleesa}->{room}, $c->{jabberbot}->{aleesa}->{room},
$c->{jabberbot}->{aleesa}->{confsrv}, $c->{jabberbot}->{aleesa}->{confsrv},
$c->{jabberbot}->{aleesa}->{authname} $c->{jabberbot}->{aleesa}->{authname},
), ),
password => $c->{jabberbot}->{aleesa}->{password}, password => $c->{jabberbot}->{aleesa}->{password},
alias => $c->{jabberbot}->{aleesa}->{mucname}, # name on confs alias => $c->{jabberbot}->{aleesa}->{mucname}, # name on confs