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

Use perlcritic to lint code

Browse Source
This commit is contained in:
eleksir
2020-11-14 13:51:17 +03:00
parent 1780c94ede
commit 7443882c84
6 changed files with 212 additions and 136 deletions
Download Patch File Download Diff File Expand all files Collapse all files

91
.perlcriticrc Normal file
View File

@@ -0,0 +1,91 @@
#!/usr/bin/env perlcritic
severity = 5
verbose = 8
# minorify some of warnings that are not really critical
[-InputOutput::RequireCheckedClose]
# What can we handle in case of error?
[-Modules::ProhibitExcessMainComplexity]
# Noone cares
[-Subroutines::ProhibitExcessComplexity]
# Noone cares
[-Subroutines::ProhibitExplicitReturnUndef]
# But it's very handy sometimes!
[-ValuesAndExpressions::ProhibitMagicNumbers]
# this policy makes too much false positives
[-RegularExpressions::RequireLineBoundaryMatching]
# We use /m as needed
[-RegularExpressions::RequireExtendedFormatting]
# We do not use extended formatting of regex, they still not THAT complex
[-RegularExpressions::RequireDotMatchAnything]
# huh?
[-RegularExpressions::ProhibitEscapedMetacharacters]
# Looks like it pointless
[-ControlStructures::ProhibitCascadingIfElse]
# I like long if..else chains
[-ControlStructures::ProhibitPostfixControls]
# In short lines we can afford ourselves to use postfix controls
# but ofcorse we should avoid such constructions in long lines.
[-Subroutines::ProhibitSubroutinePrototypes]
# Contrary to Perl::Critic we consider prototypes as useful, even if
# the compile-time checks of Perl are not perfect, Perl may give some
# hints.
[-CodeLayout::RequireTidyCode]
# Impossible to complete, because of on higher linting levels "## no critic..."
# require be per-case on same line where critique is, but tidy align them
# one line down.
[-CodeLayout::ProhibitParensWithBuiltins]
# duh...
[-ValuesAndExpressions::ProhibitEmptyQuotes]
# cause we consider following correct and useful: my $var = '';
# the recomended use of q{} looks too complex: my $var = q{};
[-ValuesAndExpressions::ProhibitNoisyQuotes]
# Other people, other opinions: "," is better readable than qw(,)
[-BuiltinFunctions::ProhibitSleepViaSelect]
# We do not wish to use too much external modules.
# select undef, undef, undef, 0.25; # actually is okay if you add comment that
# it is sleep for 0.25 seconds
[-NamingConventions::Capitalization]
# duh...
# Noone care, really
[-ControlStructures::ProhibitUnlessBlocks]
# They should not be too complex - only one condition should be checked,
# that's all
[-Miscellanea::ProhibitTies]
# Just allow it. It's very handy stuff and extremely simple and safe enugh to use.
[-ValuesAndExpressions::RequireNumberSeparators]
# Not really
[-InputOutput::RequireBracedFileHandleWithPrint]
# We prefer not to use braced file handles
[-Documentation::PodSpelling]
# It doesn't help, but emits annoying errors
[Documentation::RequirePodSections]
# Considering this as "soft" requirement. For modules that is (or will be)
# stand-alone libs well formed documentation is highly desired.
lib_sections = NAME | VERSION | DESCRIPTION | AUTHOR | LICENSE AND COPYRIGHT
[-ErrorHandling::RequireCheckingReturnValueOfEval]
# In this app eval is not critical to error, so there is no need to check for it

45
bin/aleesa-jabber-bot
View File

@@ -2,16 +2,19 @@
use 5.018;
use strict;
use warnings "all";
use warnings;
use utf8;
use open qw(:std :utf8);
use English qw( -no_match_vars );
use version; our $VERSION = qw(1.0);
my $workdir;
# before we run, change working dir
BEGIN {
use Cwd qw(chdir abs_path);
my @CWD = split (/\//, abs_path ($0));
my @CWD = split (/\//, abs_path ($PROGRAM_NAME));
if ($#CWD > 1) { $#CWD = $#CWD - 2; }
$workdir = join ('/', @CWD);
chdir ($workdir);
@@ -30,14 +33,14 @@ use jabberbot qw(run_jabberbot);
sub daemonize ();
sub __fork ();
$| = 1;
my $runAsUid = $<;
local $OUTPUT_AUTOFLUSH = 1;
my $runAsUid = $UID;
my $piddir = "/var/run/" . basename (abs_path ($0));
my $piddir = '/var/run/' . basename (abs_path ($PROGRAM_NAME));
my $C = loadConf ();
# if we run under root, create pid dir and set correct owner for it, same for debug log if it is defined
if ($< == 0) {
if ($UID == 0) {
my $user = $C->{user};
die "Unable to run as root, please define unprivileged user in config.json\n" unless (defined ($user));
my ($uid, $gid) = (getpwnam ($user))[2,3];
@@ -63,8 +66,8 @@ if ($< == 0) {
}
# drop privs
setgid ($gid) or die "Unable to switch to group of $user($!)\n";
setuid ($uid) or die "Unable to switch to account $user($!)\n";
setgid ($gid) or die "Unable to switch to group of $user($OS_ERROR)\n";
setuid ($uid) or die "Unable to switch to account $user($OS_ERROR)\n";
} else {
$piddir = $workdir;
}
@@ -73,21 +76,21 @@ if ($< == 0) {
daemonize ();
# write pidfile
my $apath = abs_path ($0);
my $apath = abs_path ($PROGRAM_NAME);
unless (defined($apath)) {
logger ("Unable to get abs_path: $!");
die "Unable to get abs_path: $!\n";
logger ("Unable to get abs_path: $OS_ERROR");
die "Unable to get abs_path: $OS_ERROR\n";
};
my $pidfile = sprintf ("%s/%s.pid", $piddir, basename ($apath));
my $pidfile = sprintf ('%s/%s.pid', $piddir, basename ($apath));
logger ("Creating pidfile at $pidfile");
open (PID, ">", $pidfile) or die "Error opening $pidfile: $!\n";
print PID $$ or die "Error writing to $pidfile: $!\n";
close PID;
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
# set correct proctitle
$0 = abs_path ($0);
$PROGRAM_NAME = abs_path ($PROGRAM_NAME); ## no critic (Variables::RequireLocalizedPunctuationVars)
# run bot, at last
run_jabberbot ();
@@ -97,17 +100,19 @@ exit 0;
sub daemonize () {
__fork ();
POSIX::setsid ();
open (STDIN, "<", "/dev/null");
open (STDOUT, ">", "/dev/null");
open (STDERR, ">", "/dev/null");
open (STDIN, '<', '/dev/null'); ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
open (STDOUT, '>', '/dev/null'); ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
open (STDERR, '>', '/dev/null'); ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
__fork ();
umask 0;
return;
}
sub __fork () {
my $pid = fork;
die "Can't fork: $!\n" unless (defined ($pid));
die "Can't fork: $OS_ERROR\n" unless (defined ($pid));
exit if ($pid != 0);
return;
}
__END__

27
confcheck.pl
View File

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

81
lib/botlib.pm
View File

@@ -2,10 +2,11 @@ package botlib;
use 5.018;
use strict;
use warnings "all";
use warnings;
use utf8;
use open qw(:std :utf8);
use English qw( -no_match_vars );
use Carp qw(carp);
use HTTP::Tiny;
use URI::URL;
use JSON::XS qw(decode_json encode_json);
@@ -17,21 +18,21 @@ use conf qw(loadConf);
use vars qw/$VERSION/;
use Exporter qw(import);
our @EXPORT = qw(weather logger trim randomCommonPhrase);
our @EXPORT_OK = qw(weather logger trim randomCommonPhrase);
$VERSION = "1.0";
$VERSION = '1.0';
my $c = loadConf();
my $c = loadConf ();
sub weather($) {
sub weather ($) {
my $city = shift;
$city = trim($city);
$city = trim ($city);
return "Мне нужно ИМЯ города." if ($city eq '');
return "Длинновато для названия города." if (length($city) > 80);
return 'Мне нужно ИМЯ города.' if ($city eq '');
return 'Длинновато для названия города.' if (length ($city) > 80);
$city = ucfirst($city);
my $w = __weather($city);
$city = ucfirst ($city);
my $w = __weather ($city);
my $reply;
if ($w) {
@@ -39,7 +40,7 @@ sub weather($) {
$reply = sprintf ("Погода в городе %s, %s:\n%s, ветер %s %s м/c, температура %s°C, ощущается как %s°C, относительная влажность %s%%, давление %s мм.рт.ст",
$w->{name},
$w->{country},
ucfirst($w->{description}),
ucfirst ($w->{description}),
$w->{wind_direction},
$w->{wind_speed},
$w->{temperature_min},
@@ -51,7 +52,7 @@ sub weather($) {
$reply = sprintf ("Погода в городе %s, %s:\n%s, ветер %s %s м/c, температура %s-%s°C, ощущается как %s°C, относительная влажность %s%%, давление %s мм.рт.ст",
$w->{name},
$w->{country},
ucfirst($w->{description}),
ucfirst ($w->{description}),
$w->{wind_direction},
$w->{wind_speed},
$w->{temperature_min},
@@ -68,23 +69,23 @@ sub weather($) {
return $reply;
}
sub __weather($) {
sub __weather ($) {
my $city = shift;
$city = __urlencode($city);
my $id = md5_base64($city);
$city = __urlencode ($city);
my $id = md5_base64 ($city);
my $appid = $c->{openweathermap}->{appid};
my $now = time();
my $now = time ();
my $fc;
my $w;
# attach to cache data
tie my %cachetime, 'DB_File', $c->{openweathermap}->{cachetime} or do {
warn "Something nasty happen when cachetime ties to its data: $!";
carp "Something nasty happen when cachetime ties to its data: $OS_ERROR";
return undef;
};
tie my %cachedata, 'DB_File', $c->{openweathermap}->{cachedata} or do {
warn "Something nasty happen when cachedata ties to its data: $!";
carp "Something nasty happen when cachedata ties to its data: $OS_ERROR";
return undef;
};
@@ -95,10 +96,10 @@ sub __weather($) {
my $r;
# try 3 times and giveup
for (my $counter = 0; $counter < 3; $counter++) {
for (1..3) {
next if ($r->{success});
my $http = HTTP::Tiny->new(timeout => 3);
$r = $http->get(sprintf("http://api.openweathermap.org/data/2.5/weather?q=%s&lang=ru&APPID=%s", $city, $appid));
$r = $http->get(sprintf('http://api.openweathermap.org/data/2.5/weather?q=%s&lang=ru&APPID=%s', $city, $appid));
sleep 2;
}
@@ -106,8 +107,8 @@ sub __weather($) {
if ($r->{success}) {
$fc = eval { decode_json($r->{content}) };
if ($@) {
warn "[WARN] openweathermap returns corrupted json: $@";
if ($EVAL_ERROR) {
carp "[WARN] openweathermap returns corrupted json: $EVAL_ERROR";
untie %cachetime;
untie %cachedata;
return undef;
@@ -195,14 +196,16 @@ sub logger {
my $mode = '>';
$mode = '>>' if (-f $c->{debug_log});
if (open (LOG, $mode, $c->{debug_log})) {
print LOG $msg . "\n";
close LOG;
if (open (my $LOG, $mode, $c->{debug_log})) {
print $LOG $msg . "\n"; ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
close $LOG; ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
}
}
return;
}
sub trim($) {
sub trim ($) {
my $str = shift;
while (substr ($str, 0, 1) =~ /^\s$/) {
@@ -216,21 +219,21 @@ sub trim($) {
return $str;
}
sub randomCommonPhrase() {
sub randomCommonPhrase () {
my @myphrase = (
"Так, блядь...",
"*Закатывает рукава* И ради этого ты меня позвал?",
"Ну чего ты начинаешь, нормально же общались",
"Повтори свой вопрос, не поняла",
"Выйди и зайди нормально",
"Я подумаю",
"Даже не знаю что на это ответить",
"Ты упал такие вопросы девочке задавать?",
"Можно и так, но не уверена",
"А как ты думаешь?"
'Так, блядь...',
'*Закатывает рукава* И ради этого ты меня позвал?',
'Ну чего ты начинаешь, нормально же общались',
'Повтори свой вопрос, не поняла',
'Выйди и зайди нормально',
'Я подумаю',
'Даже не знаю что на это ответить',
'Ты упал такие вопросы девочке задавать?',
'Можно и так, но не уверена',
'А как ты думаешь?',
);
return ($myphrase[rand($#myphrase -1)]);
return $myphrase[rand($#myphrase -1)];
}
1;

54
lib/conf.pm
View File

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

50
lib/jabberbot.pm
View File

@@ -5,20 +5,20 @@ package jabberbot;
use 5.018;
use strict;
use warnings "all";
use warnings;
use utf8;
use open qw(:std :utf8);
use Net::Jabber::Bot;
use Hailo;
use conf;
use botlib;
use conf qw(loadConf);
use botlib qw(weather logger trim randomCommonPhrase);
use Exporter qw(import);
use vars qw/$VERSION/;
$VERSION = "1.0";
our @EXPORT = qw(run_jabberbot);
$VERSION = '1.0';
our @EXPORT_OK = qw(run_jabberbot);
my $c = loadConf();
my $hailo;
@@ -41,66 +41,66 @@ sub __new_bot_message {
# my $text = encode('utf-8', $hash{body});
my $text = $hash{body};
if ($hash{'type'} eq "groupchat") {
if ($hash{'type'} eq 'groupchat') {
# ignore self messages
return if ($hash{'from_full'} eq $bot->{'from_full'});
# parse messages
my $qname = quotemeta($c->{jabberbot}->{aleesa}->{mucname});
if ($text =~ /^$qname$/) {
$bot->SendGroupMessage($hash{'reply_to'}, "Чего тебе?");
$bot->SendGroupMessage($hash{'reply_to'}, 'Чего тебе?');
} elsif ($text =~ /^$qname[\,|\:]? (.+)/) {
# $bot->SendGroupMessage($hash{'reply_to'}, $hailo->learn_reply(decode('utf-8', $1)));
$bot->SendGroupMessage($hash{'reply_to'}, $hailo->learn_reply($1));
} elsif ($text eq "$c->{jabberbot}->{aleesa}->{csign}пинг") {
$bot->SendGroupMessage($hash{'reply_to'}, "Понг.");
$bot->SendGroupMessage($hash{'reply_to'}, 'Понг.');
} elsif ($text eq "$c->{jabberbot}->{aleesa}->{csign}ping") {
$bot->SendGroupMessage($hash{'reply_to'}, "Pong.");
$bot->SendGroupMessage($hash{'reply_to'}, 'Pong.');
} elsif (substr($text, 0, 1) eq $c->{jabberbot}->{aleesa}->{csign}) {
# $text = decode('utf-8', $text);
if (substr($text, 1, 3) eq "rum") {
if (substr($text, 1, 3) eq 'rum') {
eval {
$bot->SendGroupMessage(
$hash{'reply_to'},
"/me притаскивает на подносе стопку рома для ". (split(/\//,$hash{from_full}))[1] . ", края стопки искрятся кристаллами соли."
'/me притаскивает на подносе стопку рома для ' . (split(/\//,$hash{from_full}))[1] . ', края стопки искрятся кристаллами соли.'
);
};
} elsif (substr($text, 1, 5) eq "vodka") {
} elsif (substr($text, 1, 5) eq 'vodka') {
eval {
$bot->SendGroupMessage(
$hash{'reply_to'},
"/me подаёт водку с маринованным огурчиком для " . (split(/\//,$hash{from_full}))[1]
'/me подаёт водку с маринованным огурчиком для ' . (split(/\//,$hash{from_full}))[1]
);
};
} elsif (substr($text, 1, 4) eq "beer") {
} elsif (substr($text, 1, 4) eq 'beer') {
eval {
$bot->SendGroupMessage(
$hash{'reply_to'},
"/me бахает об стол перед " . (split(/\//,$hash{from_full}))[1] . " кружкой холодного пива, часть пенной шапки сползает по запотевшей спенке кружки."
'/me бахает об стол перед ' . (split(/\//,$hash{from_full}))[1] . ' кружкой холодного пива, часть пенной шапки сползает по запотевшей спенке кружки.'
);
};
} elsif (substr($text, 1, 7) eq "tequila") {
} elsif (substr($text, 1, 7) eq 'tequila') {
eval {
$bot->SendGroupMessage(
$hash{'reply_to'},
"/me ставит рядом с " . (split(/\//,$hash{from_full}))[1] . " шот текилы, аккуратно на ребро стопки насаживает дольку лайма и ставит кофейное блюдце с горочкой соли."
'/me ставит рядом с ' . (split(/\//,$hash{from_full}))[1] . ' шот текилы, аккуратно на ребро стопки насаживает дольку лайма и ставит кофейное блюдце с горочкой соли.'
);
};
} elsif (substr($text, 1, 6) eq "whisky") {
} elsif (substr($text, 1, 6) eq 'whisky') {
eval {
$bot->SendGroupMessage(
$hash{'reply_to'},
"/me демонстративно достаёт из морозилки пару кубических камушков, бросает их в толстодонный стакан и аккуратно наливает Jack Daniels. Запускает стакан вдоль барной стойки, он останавливается около " . (split(/\//,$hash{from_full}))[1] . "."
'/me демонстративно достаёт из морозилки пару кубических камушков, бросает их в толстодонный стакан и аккуратно наливает Jack Daniels. Запускает стакан вдоль барной стойки, он останавливается около ' . (split(/\//,$hash{from_full}))[1] . '.'
);
};
} elsif (substr($text, 1, 8) eq "absinthe") {
} elsif (substr($text, 1, 8) eq 'absinthe') {
eval {
$bot->SendGroupMessage(
$hash{'reply_to'},
"/me наливает абсент в стопку. Смочив кубик сахара в абсенте кладёт его на дырявую ложечку и пожигает. Как только пламя потухнет, $c->{jabberbot}->{aleesa}->{mucname} размешивает оплавившийся кубик в абсенте и подносит стопку " .(split(/\//,$hash{from_full}))[1] . "."
"/me наливает абсент в стопку. Смочив кубик сахара в абсенте кладёт его на дырявую ложечку и пожигает. Как только пламя потухнет, $c->{jabberbot}->{aleesa}->{mucname} размешивает оплавившийся кубик в абсенте и подносит стопку " .(split(/\//,$hash{from_full}))[1] . '.'
);
};
} elsif ((substr($text, 1, 2) eq "w ") || (substr($text, 1, 2) eq "п ")) {
} elsif ((substr($text, 1, 2) eq 'w ') || (substr($text, 1, 2) eq 'п ')) {
my $city = substr($text, 2);
eval {
@@ -117,8 +117,8 @@ sub __new_bot_message {
#$hailo->learn($text);
return;
}
} elsif ($hash{'type'} eq "chat") {
$bot->SendPersonalMessage($hash{'reply_to'}, "Я вас не знаю, идите нахуй.");
} elsif ($hash{'type'} eq 'chat') {
$bot->SendPersonalMessage($hash{'reply_to'}, 'Я вас не знаю, идите нахуй.');
return;
}
@@ -165,6 +165,8 @@ sub run_jabberbot {
$bot->Start();
};
}
return;
}
1;