From f18544a798f763e80491d88a84c46a94dcb0f697 Mon Sep 17 00:00:00 2001 From: eleksir Date: Sun, 3 Apr 2022 13:45:02 +0300 Subject: [PATCH] More heavy perlcritic policies, more careful work with strings/substr --- .perlcriticrc | 49 +++++++++ bin/aleesa-jabber-bot | 43 ++++---- bin/flickr_init.pl | 2 +- bin/fortune_seed.pl | 2 +- bin/friday_seed.pl | 2 +- bin/proverb_seed.pl | 2 +- bin/train_lat.pl | 2 +- cpanfile | 2 + lib/BotLib.pm | 219 ++++++++++++++++++------------------- lib/BotLib/Anek.pm | 2 +- lib/BotLib/Conf.pm | 2 + lib/BotLib/Drink.pm | 8 +- lib/BotLib/Fortune.pm | 7 +- lib/BotLib/Fox.pm | 2 +- lib/BotLib/Friday.pm | 2 +- lib/BotLib/Image/Flickr.pm | 38 +++---- lib/BotLib/Kitty.pm | 2 +- lib/BotLib/Lat.pm | 6 +- lib/BotLib/Proverb.pm | 6 +- lib/BotLib/Util.pm | 15 +-- lib/BotLib/Weather.pm | 13 +-- lib/JabberBot.pm | 72 ++++++------ 22 files changed, 271 insertions(+), 227 deletions(-) diff --git a/.perlcriticrc b/.perlcriticrc index d7e31fa..dea1e92 100644 --- a/.perlcriticrc +++ b/.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 \ No newline at end of file diff --git a/bin/aleesa-jabber-bot b/bin/aleesa-jabber-bot index 642ce51..c1aa316 100755 --- a/bin/aleesa-jabber-bot +++ b/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; @@ -26,12 +26,13 @@ BEGIN { 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 File::Spec (); use Log::Any qw ($log); -use Log::Any::Adapter; -use Log::Any::For::Std; +use Log::Any::Adapter (); +use Log::Any::For::Std (); use BotLib::Conf qw (LoadConf); use JabberBot qw (RunJabberBot); @@ -44,13 +45,13 @@ my $runAsUid = $UID; my $piddir = '/var/run/' . basename (abs_path $PROGRAM_NAME); my $C = LoadConf (); -my $loglevel = $C->{'loglevel'} // 'notice'; +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 @@ -63,8 +64,8 @@ if ($UID == 0) { make_path ( $piddir, { uid => $uid, - group => $gid - } + group => $gid, + }, ) or die "Unable to create $piddir: $OS_ERROR\n"; } @@ -75,8 +76,8 @@ if ($UID == 0) { make_path ( $logdir, { uid => $uid, - group => $gid - } + group => $gid, + }, ) or die "Unable to create $logdir: $OS_ERROR\n"; } } @@ -97,15 +98,15 @@ if (defined $logfile) { # verbosity paticulary for CHI. Log::Any::Adapter->set ( { - category => 'CHI::Driver' + category => 'CHI::Driver', }, 'File', $logfile, - log_level => 'warn' + log_level => 'warn', ); } else { # 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 @@ -142,7 +143,7 @@ $PROGRAM_NAME = abs_path $PROGRAM_NAME; ## no critic (Variables::RequireLocaliz RunJabberBot (); -if (-f $pidfile) { +if (-e $pidfile) { unlink $pidfile; } @@ -151,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; @@ -178,7 +179,7 @@ sub __fork () { sub __signal_handler ($) { $log->info ("[INFO] Caught a signal $OS_ERROR"); - if (-f $pidfile) { + if (-e $pidfile) { unlink $pidfile; } diff --git a/bin/flickr_init.pl b/bin/flickr_init.pl index 0d58b19..154c96a 100644 --- a/bin/flickr_init.pl +++ b/bin/flickr_init.pl @@ -1,6 +1,6 @@ #!/usr/bin/perl -use 5.018; +use 5.018; ## no critic (ProhibitImplicitImport) use strict; use warnings; use utf8; diff --git a/bin/fortune_seed.pl b/bin/fortune_seed.pl index 43f6006..23ab16a 100644 --- a/bin/fortune_seed.pl +++ b/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; diff --git a/bin/friday_seed.pl b/bin/friday_seed.pl index 20f55d7..c49f6c7 100644 --- a/bin/friday_seed.pl +++ b/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; diff --git a/bin/proverb_seed.pl b/bin/proverb_seed.pl index 9c9a01f..0092fa4 100644 --- a/bin/proverb_seed.pl +++ b/bin/proverb_seed.pl @@ -1,6 +1,6 @@ #!/usr/bin/perl -use 5.018; +use 5.018; ## no critic (ProhibitImplicitImport) use strict; use warnings; use utf8; diff --git a/bin/train_lat.pl b/bin/train_lat.pl index 84c501e..dd09331 100644 --- a/bin/train_lat.pl +++ b/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; diff --git a/cpanfile b/cpanfile index e41c038..1f636b4 100644 --- a/cpanfile +++ b/cpanfile @@ -1,3 +1,4 @@ +## no critic requires 'CHI'; requires 'CHI::Driver::BerkeleyDB'; requires 'Cwd::utf8'; @@ -8,6 +9,7 @@ requires 'Digest::MD5'; requires 'Digest::SHA'; requires 'File::Basename'; requires 'File::Path'; +requires 'File::Spec'; requires 'HTTP::Tiny'; requires 'Hailo'; requires 'JSON'; diff --git a/lib/BotLib.pm b/lib/BotLib.pm index 2b8bb8a..dc7a367 100644 --- a/lib/BotLib.pm +++ b/lib/BotLib.pm @@ -6,7 +6,6 @@ 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 BotLib::Anek qw (Anek); use BotLib::Archeologist qw (Dig); @@ -31,6 +30,10 @@ 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 () { @@ -69,123 +72,113 @@ sub Command { my $csign = $c->{jabberbot}->{aleesa}->{csign}; my $reply; + my $cmd = substr $text, length ($csign); - if (substr ($text, 1, 3) eq 'rum' || substr ($text, 1, 3) eq 'ром') { - my $target; + if (($cmd =~ /rum\s?/u) || ($cmd =~ /ром\s?/u)) { + my $target = $chattername; - if (($hash{'type'} eq 'groupchat') && (length ($text) > 5)) { - $target = trim (substr $text, 5); - } - - if (! defined $target || ($target eq '')) { - $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 (substr ($text, 1, 5) eq 'vodka' || substr ($text, 1, 5) eq 'водка') { - my $target; + } elsif (($cmd =~ /vodka\s?/u) || ($cmd =~ /водка\s?/u)) { + my $target = $chattername; - if (($hash{'type'} eq 'groupchat') && (length ($text) > 7)) { - $target = trim (substr $text, 7); - } - - if (! defined $target || ($target eq '')) { - $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 (substr ($text, 1, 4) eq 'beer' || substr ($text, 1, 4) eq 'пиво') { - my $target; + } elsif (($cmd =~ /^beer\s?/u) || ($cmd =~ /^пиво\s?/u)) { + my $target = $chattername; - if (($hash{'type'} eq 'groupchat') && (length ($text) > 6)) { - $target = trim (substr $text, 6); - } - - if (! defined $target || ($target eq '')) { - $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 (substr ($text, 1, 7) eq 'tequila') { - my $target; + } elsif ($cmd =~ /^tequila\s?/u) { + my $target = $chattername; - if (($hash{'type'} eq 'groupchat') && (length ($text) > 9)) { - $target = trim (substr $text, 9); - } - - if (! defined $target || ($target eq '')) { - $target = $chattername; + if ($hash{'type'} eq 'groupchat') { + if ($cmd =~ /^tequila\s+(.*)/u) { + $target = $1 if ($1 ne ''); + } } $reply = '/me ставит рядом с ' . $target . ' шот текилы, аккуратно на ребро стопки насаживает дольку лайма и ставит кофейное блюдце с горочкой соли.'; - } elsif (substr ($text, 1, 6) eq 'текила') { - my $target; + } elsif ($cmd =~ /^текила\s?/u) { + my $target = $chattername; - if (($hash{'type'} eq 'groupchat') && (length ($text) > 8)) { - $target = trim (substr $text, 8); - } - - if (! defined $target || ($target eq '')) { - $target = $chattername; + if ($hash{'type'} eq 'groupchat') { + if ($cmd =~ /^текила\s+(.*)/u) { + $target = $1 if ($1 ne ''); + } } $reply = '/me ставит рядом с ' . $target . ' шот текилы, аккуратно на ребро стопки насаживает дольку лайма и ставит кофейное блюдце с горочкой соли.'; - } elsif (substr ($text, 1, 6) eq 'whisky') { - my $target; + } elsif ($cmd =~ /^whisky\s?/u) { + my $target = $chattername; - if (($hash{'type'} eq 'groupchat') && (length ($text) > 8)) { - $target = trim (substr $text, 8); - } - - if (! defined $target || ($target eq '')) { - $target = $chattername; + if ($hash{'type'} eq 'groupchat') { + if ($cmd =~ /^whisky\s+(.*)/u) { + $target = $1 if ($1 ne ''); + } } $reply = '/me демонстративно достаёт из морозилки пару кубических камушков, бросает их в толстодонный стакан и аккуратно наливает Jack Daniels. Запускает стакан вдоль барной стойки, он останавливается около ' . $target . '.'; - } elsif (substr ($text, 1, 5) eq 'виски') { - my $target; + } elsif ($cmd =~ /^виски\s?/u) { + my $target = $chattername; - if (($hash{'type'} eq 'groupchat') && (length ($text) > 7)) { - $target = trim (substr $text, 7); - } - - if (! defined $target || ($target eq '')) { - $target = $chattername; + if ($hash{'type'} eq 'groupchat') { + if ($cmd =~ /^виски\s+(.*)/u) { + $target = $1 if ($1 ne ''); + } } $reply = '/me демонстративно достаёт из морозилки пару кубических камушков, бросает их в толстодонный стакан и аккуратно наливает Jack Daniels. Запускает стакан вдоль барной стойки, он останавливается около ' . $target . '.'; - } elsif (substr ($text, 1, 8) eq 'absinthe') { - my $target; + } elsif ($cmd =~ /^absinthe\s?/u) { + my $target = $chattername; - if (($hash{'type'} eq 'groupchat') && (length ($text) > 10)) { - $target = trim (substr $text, 10); - } - - if (! defined $target || ($target eq '')) { - $target = $chattername; + if ($hash{'type'} eq 'groupchat') { + if ($cmd =~ /^absinthe\s+(.*)/u) { + $target = $1 if ($1 ne ''); + } } $reply = '/me наливает абсент в стопку. Смочив кубик сахара в абсенте кладёт его на дырявую ложечку и пожигает. Как только пламя потухнет, ' . $bot->{'alias'} . ' размешивает оплавившийся кубик в абсенте и подносит стопку ' . $target . '.'; - } elsif (substr ($text, 1, 6) eq 'абсент') { - my $target; + } elsif ($cmd =~ /^абсент\s?/u) { + my $target = $chattername; - if (($hash{'type'} eq 'groupchat') && (length ($text) > 8)) { - $target = trim (substr $text, 8); - } - - if (! defined $target || ($target eq '')) { - $target = $chattername; + if ($hash{'type'} eq 'groupchat') { + if ($cmd =~ /^абсент\s+(.*)/u) { + $target = $1 if ($1 ne ''); + } } $reply = '/me наливает абсент в стопку. Смочив кубик сахара в абсенте кладёт его на дырявую ложечку и пожигает. Как только пламя потухнет, ' . $bot->{'alias'} . ' размешивает оплавившийся кубик в абсенте и подносит стопку ' . $target . '.'; - } elsif (substr ($text, 1, 2) eq 'w ' || substr ($text, 1, 2) eq 'п ') { - my $city = substr $text, 2; + } elsif ($cmd =~ /^[wп]\s+.+/u) { + $cmd =~ /^[wп]\s+(.*)/; + my $city = $1; ## no critic (RegularExpressions::ProhibitCaptureWithoutTest) $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 (); - } elsif (substr ($text, 1) eq 'coin' || substr ($text, 1) eq 'монетка') { + } elsif ($cmd eq 'coin' || $cmd eq 'монетка') { if (rand (101) < 0.016) { - $reply = "ребро"; + $reply = 'ребро'; } else { 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 'кости') { - $reply = sprintf "На первой кости выпало %d, а на второй — %d.", irand (6) + 1, irand (6) + 1; - } elsif (substr ($text, 1) eq 'version' || substr ($text, 1) eq 'ver') { - $reply = 'Версия нуль.чего-то_там.чего-то_там'; - } elsif (substr ($text, 1) eq 'help' || substr ($text, 1) eq 'помощь') { + } 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}помощь - это сообщение @@ -242,77 +235,77 @@ ${csign}w город | ${csign}п город - погода в горо ${csign}xkcd - комикс-стрип с xkcb.ru EOL - } elsif (substr ($text, 1) eq 'lat' || substr ($text, 1) eq 'лат') { + } elsif ($cmd eq 'lat' || $cmd eq 'лат') { $reply = Lat (); - } elsif (substr ($text, 1) eq 'cat' || substr ($text, 1) eq 'кис') { + } elsif ($cmd eq 'cat' || $cmd eq 'кис') { $reply = Kitty (); - } elsif (substr ($text, 1) eq 'fox' || substr ($text, 1) eq 'лис') { + } elsif ($cmd eq 'fox' || $cmd eq 'лис') { $reply = Fox (); - } elsif (substr ($text, 1) eq 'frog' || substr ($text, 1) eq 'лягушка') { + } elsif ($cmd eq 'frog' || $cmd eq 'лягушка') { $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 (); - } elsif (substr ($text, 1) eq 'snail' || substr ($text, 1) eq 'улитка') { + } elsif ($cmd eq 'snail' || $cmd eq 'улитка') { $reply = Snail (); - } elsif (substr ($text, 1) eq 'dig' || substr ($text, 1) eq 'копать') { + } elsif ($cmd eq 'dig' || $cmd 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 'рыбалка') { + } elsif ($cmd eq 'fish' || $cmd eq 'fisher' || $cmd eq 'рыба' || $cmd eq 'рыбка' || $cmd eq 'рыбалка') { $reply = Fish ($chattername); - } elsif (substr ($text, 1) eq 'buni') { + } elsif ($cmd eq 'buni') { $reply = Buni (); - } elsif (substr ($text, 1) eq 'xkcd') { + } elsif ($cmd eq 'xkcd') { $reply = Xkcd (); - } elsif (substr ($text, 1) eq 'monkeyuser') { + } elsif ($cmd eq 'monkeyuser') { $reply = Monkeyuser (); - } elsif (substr ($text, 1) eq 'drink' || substr ($text, 1) eq 'праздник') { + } elsif ($cmd eq 'drink' || $cmd eq 'праздник') { $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 (); - } elsif (substr ($text, 1) eq 'owl' || substr ($text, 1) eq 'сова') { + } elsif ($cmd eq 'owl' || $cmd eq 'сова') { $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 = ''; - if (length ($text) > 6) { - $mytext = substr $text, 7; - chomp $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 (substr ($text, 1) eq 'friday' || substr ($text, 1) eq 'пятница') { + } elsif ($cmd eq 'friday' || $cmd eq 'пятница') { $reply = Friday (); - } elsif (substr ($text, 1) eq 'proverb' || substr ($text, 1) eq 'пословица') { + } elsif ($cmd eq 'proverb' || $cmd eq 'пословица') { $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 (); # workaround Net::Jabber::Bot outgoing message ![:print:] replacement $phrase =~ s/\s\s+\-\-/\n \-\-/xmsg; $reply = $phrase; - } elsif (substr ($text, 1) eq 'ping') { + } elsif ($cmd eq 'ping') { $reply = 'Pong.'; - } elsif (substr ($text, 1) eq 'пинг') { + } elsif ($cmd eq 'пинг') { $reply = 'Понг.'; - } elsif (substr ($text, 1) eq 'kde' || substr ($text, 1) eq 'кде') { + } elsif ($cmd eq 'kde' || $cmd eq 'кде') { my @phrases = ( 'Нет, я не буду поднимать вам плазму.', - 'Повторяйте эту мантру по утрам не менее 5 раз: "Плазма не падает." И, возможно, она перестанет у вас падать.' + 'Повторяйте эту мантру по утрам не менее 5 раз: "Плазма не падает." И, возможно, она перестанет у вас падать.', ); $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; } # 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 $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 diff --git a/lib/BotLib/Anek.pm b/lib/BotLib/Anek.pm index 8916b4c..bbf60fa 100644 --- a/lib/BotLib/Anek.pm +++ b/lib/BotLib/Anek.pm @@ -6,7 +6,7 @@ use warnings; use utf8; use open qw (:std :utf8); use English qw ( -no_match_vars ); -use Encode; +use Encode qw (decode); use HTML::TokeParser; use HTTP::Tiny; use JSON::XS; diff --git a/lib/BotLib/Conf.pm b/lib/BotLib/Conf.pm index 0624101..2df70cd 100644 --- a/lib/BotLib/Conf.pm +++ b/lib/BotLib/Conf.pm @@ -19,7 +19,9 @@ sub LoadConf { 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 diff --git a/lib/BotLib/Drink.pm b/lib/BotLib/Drink.pm index 65c91c2..6d04c54 100644 --- a/lib/BotLib/Drink.pm +++ b/lib/BotLib/Drink.pm @@ -6,7 +6,7 @@ use warnings; use utf8; use open qw (:std :utf8); use English qw ( -no_match_vars ); -use Encode; +use Encode qw (decode); use CHI; use CHI::Driver::BerkeleyDB; use DateTime; @@ -76,7 +76,7 @@ sub Drink { my $cache = CHI->new ( driver => 'BerkeleyDB', root_dir => $c->{cachedir}, - namespace => __PACKAGE__ + namespace => __PACKAGE__, ); # Those POSIX assholes just forgot to add unix timestamps without TZ offset, so... @@ -96,7 +96,7 @@ sub Drink { day => $mday, hour => 0, minute => 0, - second => 0 + second => 0, )->add (days => 1)->strftime ('%s'); if ((substr $offset, 0, 1) eq '+') { @@ -109,7 +109,7 @@ sub Drink { my $res = $cache->compute ( 'Holiday', { expires_at => $expirationDate }, - $drinkCallBack + $drinkCallBack, ); if (defined $res && $res ne '') { diff --git a/lib/BotLib/Fortune.pm b/lib/BotLib/Fortune.pm index 4e5de18..dc0660e 100644 --- a/lib/BotLib/Fortune.pm +++ b/lib/BotLib/Fortune.pm @@ -11,7 +11,6 @@ use Carp qw (croak); use File::Path qw (make_path); use Log::Any qw ($log); use Math::Random::Secure qw (irand); -use MIME::Base64; use SQLite_File; use BotLib::Conf qw (LoadConf); @@ -30,7 +29,7 @@ sub Seed () { my $backingfile = sprintf '%s/fortune.sqlite', $dir; - if (-f $backingfile) { + if (-e $backingfile) { unlink $backingfile || croak "Unable to remove $backingfile: $OS_ERROR\n"; } @@ -40,7 +39,7 @@ sub Seed () { while (my $fortunefile = readdir $srcdirhandle) { my $srcfile = sprintf '%s/%s', $srcdir, $fortunefile; - unless (-f $srcfile) { + unless (-e $srcfile) { next; } @@ -53,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; } diff --git a/lib/BotLib/Fox.pm b/lib/BotLib/Fox.pm index 7f6b2d7..eba05b0 100644 --- a/lib/BotLib/Fox.pm +++ b/lib/BotLib/Fox.pm @@ -6,7 +6,7 @@ use warnings; use utf8; use open qw (:std :utf8); use English qw ( -no_match_vars ); -use JSON::XS; +use JSON::XS qw (decode_json); use HTTP::Tiny; use Log::Any qw ($log); diff --git a/lib/BotLib/Friday.pm b/lib/BotLib/Friday.pm index 8fa4ac9..6a7eea2 100644 --- a/lib/BotLib/Friday.pm +++ b/lib/BotLib/Friday.pm @@ -33,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"; } diff --git a/lib/BotLib/Image/Flickr.pm b/lib/BotLib/Image/Flickr.pm index da40752..ee06290 100644 --- a/lib/BotLib/Image/Flickr.pm +++ b/lib/BotLib/Image/Flickr.pm @@ -6,21 +6,19 @@ use warnings; use utf8; use open qw (:std :utf8); use English qw ( -no_match_vars ); -use Carp qw (cluck); -use Digest::HMAC_SHA1 qw (hmac_sha1); +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; +use MIME::Base64 qw (encode_base64); use SQLite_File; use URI::Encode::XS qw (uri_encode); 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 Exporter qw (import); @@ -109,7 +107,7 @@ sub flickrRequestToken { my $oauth_signature = flickrSignReq ( type => 'request_token', oauth_timestamp => $oauth_timestamp, - oauth_nonce => $oauth_nonce + oauth_nonce => $oauth_nonce, ); my $url = $flickr_request_token_url . sprintf ( @@ -118,7 +116,7 @@ sub flickrRequestToken { $oauth_timestamp, $flickr_consumer_key, uri_encode ($oauth_signature), - uri_encode ($flickr_callback_url) + uri_encode ($flickr_callback_url), ); my $http = HTTP::Tiny->new (timeout => 5); @@ -149,7 +147,7 @@ sub flickrAccessToken { oauth_nonce => $oauth_nonce, oauth_token => $flickr_request_token, oauth_token_secret => $flickr_request_token_secret, - oauth_verifier => $flickr_verifier + oauth_verifier => $flickr_verifier, ); my $url = $flickr_access_token_url . sprintf ( @@ -159,7 +157,7 @@ sub flickrAccessToken { $flickr_verifier, $flickr_consumer_key, $flickr_request_token, - uri_encode ($oauth_signature) + uri_encode ($oauth_signature), ); my $http = HTTP::Tiny->new (timeout => 5); @@ -213,7 +211,7 @@ sub flickrTestLogin { oauth_token => $flickr_access_token, oauth_token_secret => $flickr_access_token_secret, oauth_signature_method => 'HMAC-SHA1', - oauth_version => '1.0' + oauth_version => '1.0', ); my $url = $flickr_api_url . sprintf ( @@ -222,7 +220,7 @@ sub flickrTestLogin { $flickr_consumer_key, $oauth_timestamp, $flickr_access_token, - uri_encode ($oauth_signature) + uri_encode ($oauth_signature), ); my $http = HTTP::Tiny->new (timeout => 5); @@ -270,7 +268,7 @@ sub flickrSearchByText { oauth_token => $flickr_access_token, oauth_token_secret => $flickr_access_token_secret, oauth_signature_method => 'HMAC-SHA1', - oauth_version => '1.0' + oauth_version => '1.0', ); my $url = $flickr_api_url . sprintf ( @@ -280,7 +278,7 @@ sub flickrSearchByText { $oauth_timestamp, $flickr_access_token, uri_encode ($oauth_signature), - uri_encode ($text) + uri_encode ($text), ); my $http = HTTP::Tiny->new (timeout => 5); @@ -313,7 +311,7 @@ sub flickrSearchByText { oauth_token => $flickr_access_token, oauth_token_secret => $flickr_access_token_secret, oauth_signature_method => 'HMAC-SHA1', - oauth_version => '1.0' + oauth_version => '1.0', ); $url = $flickr_api_url . sprintf ( @@ -324,7 +322,7 @@ sub flickrSearchByText { $flickr_access_token, uri_encode ($oauth_signature), $page, - uri_encode ($text) + uri_encode ($text), ); $http = HTTP::Tiny->new (timeout => 5); @@ -379,7 +377,7 @@ sub flickrSearchByTags { oauth_token => $flickr_access_token, oauth_token_secret => $flickr_access_token_secret, oauth_signature_method => 'HMAC-SHA1', - oauth_version => '1.0' + oauth_version => '1.0', ); my $url = $flickr_api_url . sprintf ( @@ -389,7 +387,7 @@ sub flickrSearchByTags { $oauth_timestamp, $flickr_access_token, uri_encode ($oauth_signature), - uri_encode ($tags) + uri_encode ($tags), ); my $http = HTTP::Tiny->new (timeout => 5); @@ -422,7 +420,7 @@ sub flickrSearchByTags { oauth_token => $flickr_access_token, oauth_token_secret => $flickr_access_token_secret, oauth_signature_method => 'HMAC-SHA1', - oauth_version => '1.0' + oauth_version => '1.0', ); $url = $flickr_api_url . sprintf ( @@ -433,7 +431,7 @@ sub flickrSearchByTags { $flickr_access_token, uri_encode ($oauth_signature), $page, - uri_encode ($tags) + uri_encode ($tags), ); $http = HTTP::Tiny->new (timeout => 5); @@ -501,7 +499,7 @@ sub FlickrInit { 'Access token (%s) and access token secret (%s) are in %s', $accessToken{oauth_token}, $accessToken{oauth_token_secret}, - $backingfile + $backingfile, ); untie %secret; diff --git a/lib/BotLib/Kitty.pm b/lib/BotLib/Kitty.pm index 3825e2b..3bc636b 100644 --- a/lib/BotLib/Kitty.pm +++ b/lib/BotLib/Kitty.pm @@ -6,7 +6,7 @@ use warnings; use utf8; use open qw (:std :utf8); use English qw ( -no_match_vars ); -use JSON::XS; +use JSON::XS qw (decode_json); use HTTP::Tiny; use Log::Any qw ($log); diff --git a/lib/BotLib/Lat.pm b/lib/BotLib/Lat.pm index f8ef84f..d9af9a8 100644 --- a/lib/BotLib/Lat.pm +++ b/lib/BotLib/Lat.pm @@ -35,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); @@ -54,7 +54,7 @@ sub Lat () { return ''; } - unless (-f $brain) { + unless (-e $brain) { $log->error ("[ERROR] No lat module data: $brain is absent! Train lat first."); return ''; } @@ -63,7 +63,7 @@ sub Lat () { 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 (); diff --git a/lib/BotLib/Proverb.pm b/lib/BotLib/Proverb.pm index 46b90b8..d2ebdfd 100644 --- a/lib/BotLib/Proverb.pm +++ b/lib/BotLib/Proverb.pm @@ -7,7 +7,7 @@ use warnings; use utf8; use open qw (:std :utf8); use English qw ( -no_match_vars ); -use Carp qw (cluck croak); +use Carp qw (croak); use File::Path qw (make_path); use Log::Any qw ($log); use Math::Random::Secure qw (irand); @@ -30,7 +30,7 @@ sub Seed () { my $backingfile = sprintf '%s/proverb.sqlite', $dir; - if (-f $backingfile) { + if (-e $backingfile) { unlink $backingfile || croak "Unable to remove $backingfile: $OS_ERROR"; } @@ -40,7 +40,7 @@ sub Seed () { while (my $proverbfile = readdir ($srcdirhandle)) { my $srcfile = sprintf '%s/%s', $srcdir, $proverbfile; - unless (-f $srcfile) { + unless (-e $srcfile) { next; } diff --git a/lib/BotLib/Util.pm b/lib/BotLib/Util.pm index 70a6a36..6fac680 100644 --- a/lib/BotLib/Util.pm +++ b/lib/BotLib/Util.pm @@ -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; } diff --git a/lib/BotLib/Weather.pm b/lib/BotLib/Weather.pm index caaede8..5e43cda 100644 --- a/lib/BotLib/Weather.pm +++ b/lib/BotLib/Weather.pm @@ -6,11 +6,10 @@ use warnings; use utf8; use open qw (:std :utf8); use English qw ( -no_match_vars ); -use Carp qw (carp cluck); use CHI; use CHI::Driver::BerkeleyDB; use HTTP::Tiny; -use JSON::XS; +use JSON::XS qw (decode_json); use Log::Any qw ($log); use BotLib::Conf qw (LoadConf); use BotLib::Util qw (trim urlencode); @@ -63,7 +62,7 @@ sub Weather { 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; @@ -127,13 +126,13 @@ sub Weather { my $cache = CHI->new ( driver => 'BerkeleyDB', root_dir => $c->{cachedir}, - namespace => __PACKAGE__ + namespace => __PACKAGE__, ); my $w = $cache->compute ( $city, '3 hours', - $weatherCallBack + $weatherCallBack, ); my $reply; @@ -149,7 +148,7 @@ sub Weather { $w->{temperature_min}, $w->{temperature_feelslike}, $w->{humidity}, - $w->{pressure} + $w->{pressure}, ); } else { $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_feelslike}, $w->{humidity}, - $w->{pressure} + $w->{pressure}, ); } } else { diff --git a/lib/JabberBot.pm b/lib/JabberBot.pm index 941d4ba..c4ec5e5 100644 --- a/lib/JabberBot.pm +++ b/lib/JabberBot.pm @@ -10,10 +10,10 @@ use utf8; use open qw (:std :utf8); use English qw ( -no_match_vars ); use File::Path qw (make_path); -use Hailo; +use Hailo (); use Log::Any qw ($log); -use Net::Jabber::Bot; -use BotLib qw (Command RandomCommonPhrase RealJID); +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); @@ -23,6 +23,7 @@ use Exporter qw (import); our @EXPORT_OK = qw (RunJabberBot); my $c = LoadConf (); +my $csign = $c->{jabberbot}->{aleesa}->{csign}; my $hailo; my $imonline = 0; @@ -42,19 +43,19 @@ sub __new_bot_message { my $bot = $hash{bot_object}; # ignore self messages - if ($hash{'from_full'} eq $bot->{'from_full'}) { + if ($hash{from_full} eq $bot->{from_full}) { return; } my $text = $hash{body}; my %jid = RealJID (%hash); - my $chattername = $jid{'name'}; + my $chattername = $jid{name}; my $chatid; - if ($hash{'type'} eq 'groupchat') { - $chatid = utf2sha1 $hash{'reply_to'}; + if ($hash{type} eq 'groupchat') { + $chatid = utf2sha1 $hash{reply_to}; } else { - $chatid = utf2sha1 $jid{'name'}; + $chatid = utf2sha1 $jid{name}; } $chatid =~ s/\//-/xmsg; @@ -75,10 +76,10 @@ sub __new_bot_message { $hailo->{$chatid} = Hailo->new ( 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"); } else { $log->info ("[INFO] Initialized brain for chat $jid{'jid'}: $brainname"); @@ -86,34 +87,39 @@ sub __new_bot_message { } # parse messages - my $qname = quotemeta $bot->{'alias'}; + my $qname = quotemeta $bot->{alias}; - if ($text =~ /^$qname\,?\s*$/) { + if ($text =~ /^$qname\,?\s*$/u) { $reply = 'Чего тебе?'; - } elsif (($text =~ /^$qname[\,|\:]? (.+)/) && ($hash{'type'} eq 'groupchat')) { + } elsif (($text =~ /^$qname[\,|\:]? (.+)/u) && ($hash{type} eq 'groupchat')) { $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 - } elsif (substr ($text, -2) eq '++' || substr ($text, -2) eq '--') { + } elsif ($text =~ /(\+\+|\-\-)$/) { my @arr = split /\n/, $text; 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 { # just message in chat # in groupchat we answer only to phrases that mention us - if ($hash{'type'} eq 'groupchat') { + 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') { + } elsif ($hash{type} eq 'chat') { $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); # just message in chat } else { # in groupchat we answer only to phrases that mention us - if ($hash{'type'} eq 'groupchat') { + 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') { @@ -139,27 +145,27 @@ sub RunJabberBot { 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}, + 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 ( + from_full => sprintf ( '%s@%s/%s', $c->{jabberbot}->{aleesa}->{room}, $c->{jabberbot}->{aleesa}->{confsrv}, - $c->{jabberbot}->{aleesa}->{authname} + $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, + 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, + loop_sleep_time => 60, forums_and_responses => \%conflist, );