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

Use perlcritic to lint the code, make it happy

Browse Source
This commit is contained in:
eleksir
2020-10-18 22:47:55 +03:00
parent 9abb221dac
commit 9c629a8dbc
8 changed files with 295 additions and 209 deletions
Download Patch File Download Diff File Expand all files Collapse all files

80
.percriticrc Normal file
View File

@@ -0,0 +1,80 @@
#!/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 ifelse chains
[-ControlStructures::ProhibitPostfixControls]
# in short lines we can afford ourselves to use postfix controls
# but ofcorse we shoul 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

89
bin/aleesa-telegram-bot
View File

@@ -2,19 +2,22 @@
use 5.018; use 5.018;
use strict; use strict;
use warnings "all"; use warnings;
use utf8; use utf8;
use open qw(:std :utf8); use open qw(:std :utf8);
use English qw( -no_match_vars );
use version; our $VERSION = qw(1.0);
my $workdir; my $workdir;
# before we run, change working dir # before we run, change working dir
BEGIN { BEGIN {
use Cwd qw(chdir abs_path); use Cwd qw(chdir abs_path);
my @CWD = split (/\//, abs_path ($0)); my @CWD = split /\//xms, abs_path ($PROGRAM_NAME);
if ($#CWD > 1) { $#CWD = $#CWD - 2; } if ($#CWD > 1) { $#CWD = $#CWD - 2; }
$workdir = join ('/', @CWD); $workdir = join '/', @CWD;
chdir ($workdir); chdir $workdir;
} }
use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5"); use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
@@ -27,20 +30,24 @@ use conf qw(loadConf);
use botlib qw(logger); use botlib qw(logger);
use telegrambot qw(run_telegrambot); use telegrambot qw(run_telegrambot);
sub daemonize (); sub daemonize;
sub __fork (); sub __fork;
$| = 1; local $OUTPUT_AUTOFLUSH = 1;
my $runAsUid = $<; my $runAsUid = $UID;
my $piddir = "/var/run/" . basename (abs_path ($0)); my $piddir = '/var/run/' . basename (abs_path ($PROGRAM_NAME));
my $C = loadConf (); 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 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}; 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]; unless (defined $user) {
die "Unable to run as root, please define unprivileged user in config.json\n";
}
my ($uid, $gid) = (getpwnam $user)[2,3];
unless (-d $piddir) { unless (-d $piddir) {
make_path ( make_path (
@@ -52,9 +59,9 @@ if ($< == 0) {
} }
if ($C->{'debug_log'}) { if ($C->{'debug_log'}) {
unless (-d dirname($C->{'debug_log'})) { unless (-d dirname ($C->{'debug_log'})) {
make_path ( make_path (
dirname($C->{'debug_log'}), { dirname ($C->{'debug_log'}), {
uid => $uid, uid => $uid,
group => $gid group => $gid
} }
@@ -63,8 +70,8 @@ if ($< == 0) {
} }
# drop privs # drop privs
setgid ($gid) or die "Unable to switch to group of $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($!)\n"; setuid ($uid) or die "Unable to switch to account $user($OS_ERROR)\n";
} else { } else {
$piddir = $workdir; $piddir = $workdir;
} }
@@ -73,42 +80,48 @@ if ($< == 0) {
daemonize (); daemonize ();
# write pidfile # write pidfile
my $apath = abs_path ($0); my $apath = abs_path $PROGRAM_NAME;
unless (defined($apath)) { unless (defined $apath) {
logger ("Unable to get abs_path: $!"); logger "Unable to get abs_path: $OS_ERROR";
die "Unable to get abs_path: $!\n"; die "Unable to get abs_path: $OS_ERROR\n";
}; };
# write pidfile # write pidfile
my $pidfile = sprintf ("%s/%s.pid", $piddir, basename ($apath)); my $pidfile = sprintf '%s/%s.pid', $piddir, basename $apath;
logger ("Creating pidfile at $pidfile"); logger "Creating pidfile at $pidfile";
open (PID, ">", $pidfile) or die "Error opening $pidfile: $!\n"; open my $MYPID, '>', $pidfile or die "Error opening $pidfile: $OS_ERROR\n";
print PID $$ or die "Error writing to $pidfile: $!\n"; print {$MYPID} $PID or die "Error writing to $pidfile: $OS_ERROR\n";
close PID; close $MYPID; ## no critic (InputOutput::RequireCheckedSyscalls
# set correct proctitle # set correct proctitle
$0 = abs_path ($0); $PROGRAM_NAME = abs_path $PROGRAM_NAME; ## no critic (Variables::RequireLocalizedPunctuationVars)
# run bot, at last # run bot, at last
run_telegrambot (); run_telegrambot ();
unlink ($pidfile) if (-f $pidfile);
exit 0;
sub daemonize () { if (-f $pidfile) {
__fork (); unlink $pidfile;
POSIX::setsid ();
open (STDIN, "<", "/dev/null");
open (STDOUT, ">", "/dev/null");
open (STDERR, ">", "/dev/null");
__fork ();
umask 0;
} }
sub __fork () { exit 0;
sub daemonize {
__fork ();
POSIX::setsid ();
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; my $pid = fork;
die "Can't fork: $!\n" unless (defined ($pid)); unless (defined $pid) { die "Can't fork: $OS_ERROR\n"; }
exit if ($pid != 0); exit if ($pid != 0);
return;
} }
__END__ __END__

2
bootstrap.sh
View File

@@ -2,4 +2,4 @@
cpanm -l vendor_perl --self-contained --force --update --installdeps . cpanm -l vendor_perl --self-contained --force --update --installdeps .
# vim: set ft=perl noet ai ts=4 sw=4 sts=4: # vim: set ft=sh noet ai ts=4 sw=4 sts=4:

27
confcheck.pl
View File

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

139
lib/botlib.pm
View File

@@ -1,10 +1,12 @@
package botlib; package botlib;
# store here utility functions that are not protocol-specified
use 5.018; use 5.018;
use strict; use strict;
use warnings "all"; use warnings;
use utf8; use utf8;
use open qw(:std :utf8); use open qw(:std :utf8);
use English qw( -no_match_vars );
use HTTP::Tiny; use HTTP::Tiny;
use URI::URL; use URI::URL;
@@ -17,18 +19,61 @@ use conf qw(loadConf);
use vars qw/$VERSION/; use vars qw/$VERSION/;
use Exporter qw(import); 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 __urlencode {
my $str = shift;
my $urlobj = url $str;
$str = $urlobj->as_string;
$urlobj = undef; undef $urlobj;
return $str;
}
sub logger {
my $msg = shift;
if ($c->{debug_log}) {
my @date = localtime();
my @month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
my $t = sprintf ('%02s %02d %02d:%02d:%02d ', $month[$date[4]], $date[3], $date[2], $date[1], $date[0]);
my $mode = '>';
$mode = '>>' if (-f $c->{debug_log});
if (open my $LOG, $mode, $c->{debug_log}) {
print $LOG $t . $msg . "\n"; ## no critic (InputOutput::RequireCheckedSyscalls)
close $LOG; ## no critic (InputOutput::RequireCheckedSyscalls)
}
}
return;
}
sub trim {
my $str = shift;
while (substr ($str, 0, 1) =~ /^\s$/xms) {
$str = substr ($str, 1);
}
while (substr ($str, -1, 1) =~ /^\s$/xms) {
chop ($str);
}
return $str;
}
sub weather {
my $city = shift; my $city = shift;
$city = trim ($city); $city = trim ($city);
return "Мне нужно ИМЯ города." if ($city eq ''); return 'Мне нужно ИМЯ города.' if ($city eq '');
return "Длинновато для названия города." if (length($city) > 80); return 'Длинновато для названия города.' if (length($city) > 80);
$city = ucfirst ($city); $city = ucfirst ($city);
my $w = __weather ($city); my $w = __weather ($city);
@@ -36,7 +81,7 @@ sub weather ($) {
if ($w) { if ($w) {
if ($w->{temperature_min} == $w->{temperature_max}) { if ($w->{temperature_min} == $w->{temperature_max}) {
$reply = sprintf ("Погода в городе %s, %s:\n%s, ветер %s %s м/c, температура %s°C, ощущается как %s°C, относительная влажность %s%%, давление %s мм.рт.ст", $reply = sprintf ("Погода в городе %s, %s:\n%s, ветер %s %s м/c, температура %s°C, ощущается как %s°C, относительная влажность %s%%, давление %s мм.рт.с",
$w->{name}, $w->{name},
$w->{country}, $w->{country},
ucfirst ($w->{description}), ucfirst ($w->{description}),
@@ -68,7 +113,7 @@ sub weather ($) {
return $reply; return $reply;
} }
sub __weather ($) { sub __weather {
my $city = shift; my $city = shift;
$city = __urlencode ($city); $city = __urlencode ($city);
my $id = md5_base64 ($city); my $id = md5_base64 ($city);
@@ -79,12 +124,12 @@ sub __weather ($) {
# attach to cache data # attach to cache data
tie my %cachetime, 'DB_File', $c->{openweathermap}->{cachetime} or do { tie my %cachetime, 'DB_File', $c->{openweathermap}->{cachetime} or do {
warn "Something nasty happen when cachetime ties to its data: $!"; logger "Something nasty happen when cachetime ties to its data: $OS_ERROR";
return undef; return undef;
}; };
tie my %cachedata, 'DB_File', $c->{openweathermap}->{cachedata} or do { tie my %cachedata, 'DB_File', $c->{openweathermap}->{cachedata} or do {
warn "Something nasty happen when cachedata ties to its data: $!"; logger "Something nasty happen when cachedata ties to its data: $OS_ERROR";
return undef; return undef;
}; };
@@ -95,10 +140,10 @@ sub __weather ($) {
my $r; my $r;
# try 3 times and giveup # try 3 times and giveup
for (my $counter = 0; $counter < 3; $counter++) { for (1..3) {
next if ($r->{success}); next if ($r->{success});
my $http = HTTP::Tiny->new (timeout => 3); my $http = HTTP::Tiny->new (timeout => 3);
$r = $http->get (sprintf ("http://api.openweathermap.org/data/2.5/weather?q=%s&lang=ru&APPID=%s", $city, $appid)); $r = $http->get (sprintf ('http://api.openweathermap.org/data/2.5/weather?q=%s&lang=ru&APPID=%s', $city, $appid));
sleep 2; sleep 2;
} }
@@ -106,8 +151,8 @@ sub __weather ($) {
if ($r->{success}) { if ($r->{success}) {
$fc = eval { decode_json ($r->{content}) }; $fc = eval { decode_json ($r->{content}) };
if ($@) { if ($EVAL_ERROR) {
warn "[WARN] openweathermap returns corrupted json: $@"; logger "[WARN] openweathermap returns corrupted json: $EVAL_ERROR";
untie %cachetime; untie %cachetime;
untie %cachedata; untie %cachedata;
return undef; return undef;
@@ -180,62 +225,22 @@ sub __weather ($) {
return $w; return $w;
} }
sub __urlencode ($) { sub randomCommonPhrase {
my $str = shift;
my $urlobj = url $str;
$str = $urlobj->as_string;
$urlobj = undef; undef $urlobj;
return $str;
}
sub logger {
my $msg = shift;
if ($c->{debug_log}) {
my @date = localtime();
my @month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
my $t = sprintf ("%02s %02d %02d:%02d:%02d ", $month[$date[4]], $date[3], $date[2], $date[1], $date[0]);
my $mode = '>';
$mode = '>>' if (-f $c->{debug_log});
if (open (LOG, $mode, $c->{debug_log})) {
print LOG $t . $msg . "\n";
close LOG;
}
}
}
sub trim ($) {
my $str = shift;
while (substr ($str, 0, 1) =~ /^\s$/) {
$str = substr ($str, 1);
}
while (substr ($str, -1, 1) =~ /^\s$/) {
chop ($str);
}
return $str;
}
sub randomCommonPhrase () {
my @myphrase = ( my @myphrase = (
"Так, блядь...", 'Так, блядь...',
"*Закатывает рукава* И ради этого ты меня позвал?", '*Закатывает рукава* И ради этого ты меня позвал?',
"Ну чего ты начинаешь, нормально же общались", 'Ну чего ты начинаешь, нормально же общались',
"Повтори свой вопрос, не поняла", 'Повтори свой вопрос, не поняла',
"Выйди и зайди нормально", 'Выйди и зайди нормально',
"Я подумаю", 'Я подумаю',
"Даже не знаю что на это ответить", 'Даже не знаю что на это ответить',
"Ты упал такие вопросы девочке задавать?", 'Ты упал такие вопросы девочке задавать?',
"Можно и так, но не уверена", 'Можно и так, но не уверена',
"А как ты думаешь?", 'А как ты думаешь?',
"А ви, таки, почему интересуетесь?" 'А ви, таки, почему интересуетесь?',
); );
return ($myphrase[rand ($#myphrase -1)]); return $myphrase[rand ($#myphrase -1)];
} }
1; 1;

54
lib/conf.pm
View File

@@ -1,69 +1,43 @@
package conf; package conf;
# loads config
use 5.018; use 5.018;
use strict; use strict;
use warnings "all"; use warnings;
use utf8; use utf8;
use open qw(:std :utf8); use open qw(:std :utf8);
use English qw( -no_match_vars );
use vars qw/$VERSION/; use vars qw/$VERSION/;
use Fcntl qw(O_WRONLY O_CREAT O_TRUNC); use JSON::XS;
use JSON::XS qw(decode_json encode_json);
use Exporter qw(import); use Exporter qw(import);
our @EXPORT = qw(loadConf saveConf); our @EXPORT_OK = qw(loadConf);
$VERSION = "1.0"; $VERSION = '1.0';
sub loadConf ();
sub saveConf ($);
sub loadConf () { sub loadConf {
my $c = "data/config.json"; my $c = 'data/config.json';
open (C, "<", $c) or die "[FATA] No conf at $c: $!\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;
my $readlen = read (C, $json, $len); my $readlen = read $CH, $json, $len;
unless ($readlen) { unless ($readlen) {
close C; close $CH; ## no critic (InputOutput::RequireCheckedSyscalls
die "[FATA] Unable to read $c: $!\n"; die "[FATA] Unable to read $c: $OS_ERROR\n";
} }
if ($readlen != $len) { 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"; 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; my $j = JSON::XS->new->utf8->relaxed;
return $j->decode ($json); 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; 1;
# vim: set ft=perl noet ai ts=4 sw=4 sts=4: # vim: set ft=perl noet ai ts=4 sw=4 sts=4:

99
lib/telegrambot.pm
View File

@@ -1,8 +1,9 @@
package telegrambot; package telegrambot;
# main bot gears are here
use 5.018; use 5.018;
use strict; use strict;
use warnings "all"; use warnings;
use vars qw/$VERSION/; use vars qw/$VERSION/;
use utf8; use utf8;
use Data::Dumper; use Data::Dumper;
@@ -12,14 +13,14 @@ use Hailo;
use Encode; use Encode;
use Mojo::Base 'Telegram::Bot::Brain'; use Mojo::Base 'Telegram::Bot::Brain';
use conf; use conf qw(loadConf);
use botlib; use botlib qw(weather logger trim randomCommonPhrase);
use telegramlib; use telegramlib qw(getChat getChatMember sendChatAction visavi);
use Exporter qw(import); use Exporter qw(import);
our @EXPORT = qw(run_telegrambot); our @EXPORT_OK = qw(run_telegrambot);
$VERSION = "1.0"; $VERSION = '1.0';
my $c = loadConf(); my $c = loadConf();
my $hailo; my $hailo;
@@ -33,7 +34,8 @@ my $can_talk = 0;
has token => $c->{telegrambot}->{token}; has token => $c->{telegrambot}->{token};
sub __cron { # i promise, i'll make use of this sub
sub __cron { ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
my $self = shift; my $self = shift;
# noop # noop
return; return;
@@ -116,7 +118,7 @@ sub __on_msg {
$can_talk = 1; $can_talk = 1;
} }
} else { } else {
logger "Unable to get chatid"; logger 'Unable to get chatid';
} }
# according api user must have username and/or first_name and/or last_name at least one of these fields # according api user must have username and/or first_name and/or last_name at least one of these fields
@@ -161,10 +163,10 @@ sub __on_msg {
# let's emulate real human and delay answer # let's emulate real human and delay answer
sleep (int ( rand (3) + 1)); sleep (int ( rand (3) + 1));
for (my $i = 0; $i <= (4 + int (rand (3))); $i++) { for (0..(4 + int (rand (3)))) {
sendChatAction($chatid); sendChatAction($chatid);
sleep(3); sleep(3);
sleep 3 unless ($i); sleep 3 unless ($_);
} }
sleep ( 3 + int ( rand (2))); sleep ( 3 + int ( rand (2)));
@@ -175,7 +177,7 @@ sub __on_msg {
# lazy init chat-bot brains # lazy init chat-bot brains
unless (defined ($hailo->{$chatid})) { unless (defined ($hailo->{$chatid})) {
my $brainname = sprintf ("%s/%s.brain.sqlite", $c->{telegrambot}->{braindir}, $chatid); my $brainname = sprintf ('%s/%s.brain.sqlite', $c->{telegrambot}->{braindir}, $chatid);
$hailo->{$chatid} = Hailo->new ( $hailo->{$chatid} = Hailo->new (
# we'll got file like this: data/telegrambot-brains/-1001332512695.brain.sqlite # we'll got file like this: data/telegrambot-brains/-1001332512695.brain.sqlite
@@ -196,21 +198,21 @@ sub __on_msg {
return unless ($msg->can ('text') && defined ($msg->text)); return unless ($msg->can ('text') && defined ($msg->text));
my $text = $msg->text; my $text = $msg->text;
logger sprintf ("Private chat %s say to bot: %s", $vis_a_vi, $text); logger sprintf ('Private chat %s say to bot: %s', $vis_a_vi, $text);
my $csign = quotemeta ($c->{telegrambot}->{csign}); my $csign = quotemeta ($c->{telegrambot}->{csign});
my $reply = "Давайте ещё пообщаемся, а то я ещё не научилась от вас плохому."; my $reply = 'Давайте ещё пообщаемся, а то я ещё не научилась от вас плохому.';
# TODO: Process commands in separate sub, they are same for public and private chats. # TODO: Process commands in separate sub, they are same for public and private chats.
if (substr ($text, 0, 1) eq $c->{telegrambot}->{csign}) { if (substr ($text, 0, 1) eq $c->{telegrambot}->{csign}) {
if (substr ($text, 1) eq "ping") { if (substr ($text, 1) eq 'ping') {
$reply = "Pong."; $reply = 'Pong.';
} elsif (substr ($text, 1) eq "пинг") { } elsif (substr ($text, 1) eq 'пинг') {
$reply = "Понг."; $reply = 'Понг.';
} 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); my $city = substr ($text, 2);
$reply = weather ($city); $reply = weather ($city);
} else { } else {
$reply = "Чего?"; $reply = 'Чего?';
} }
} else { } else {
my $str = $hailo->{$msg->chat->id}->learn_reply ($text); my $str = $hailo->{$msg->chat->id}->learn_reply ($text);
@@ -245,7 +247,7 @@ sub __on_msg {
# detect and log messages without text, noop here # detect and log messages without text, noop here
unless (defined ($msg->text)) { unless (defined ($msg->text)) {
logger sprintf("No text in message from %s", $vis_a_vi); logger sprintf('No text in message from %s', $vis_a_vi);
if ($msg->can ('document') && defined ($msg->document)) { if ($msg->can ('document') && defined ($msg->document)) {
if (defined ($msg->document->{'file_name'})) { if (defined ($msg->document->{'file_name'})) {
@@ -253,19 +255,19 @@ sub __on_msg {
$docsize = $msg->document->{'file_size'} if (defined ($msg->document->{'file_size'})); $docsize = $msg->document->{'file_size'} if (defined ($msg->document->{'file_size'}));
my $type = 'unknown'; my $type = 'unknown';
$type = $msg->document->{'mime_type'} if (defined ($msg->document->{'mime_type'})); $type = $msg->document->{'mime_type'} if (defined ($msg->document->{'mime_type'}));
logger sprintf ("In public chat %s (%s) %s send document type %s named %s, size %s bytes", $chatname, $chatid, $vis_a_vi, $type, $msg->document->{'file_name'}, $docsize); logger sprintf ('In public chat %s (%s) %s send document type %s named %s, size %s bytes', $chatname, $chatid, $vis_a_vi, $type, $msg->document->{'file_name'}, $docsize);
} else { } else {
logger sprintf ("In public chat %s (%s) %s send unknown document", $chatname, $chatid, $vis_a_vi); logger sprintf ('In public chat %s (%s) %s send unknown document', $chatname, $chatid, $vis_a_vi);
} }
} elsif ($msg->can ('sticker') && defined ($msg->sticker)) { } elsif ($msg->can ('sticker') && defined ($msg->sticker)) {
my $set_name = 'unknown'; my $set_name = 'unknown';
$set_name = $msg->sticker->set_name if ($msg->sticker->can ('set_name') && defined ($msg->sticker->set_name)); $set_name = $msg->sticker->set_name if ($msg->sticker->can ('set_name') && defined ($msg->sticker->set_name));
my $emoji = 'unknown'; my $emoji = 'unknown';
$emoji = $msg->sticker->emoji if ($msg->sticker->can ('emoji') && defined ($msg->sticker->emoji)); $emoji = $msg->sticker->emoji if ($msg->sticker->can ('emoji') && defined ($msg->sticker->emoji));
logger sprintf ("In public chat %s (%s) %s reacted with sticker %s from pack %s", $chatname, $chatid, $vis_a_vi, $emoji, $set_name); logger sprintf ('In public chat %s (%s) %s reacted with sticker %s from pack %s', $chatname, $chatid, $vis_a_vi, $emoji, $set_name);
} elsif ($msg->can ('photo') && defined ($msg->photo)) { } elsif ($msg->can ('photo') && defined ($msg->photo)) {
# actually it is an array! duh, hate arrays! # actually it is an array! duh, hate arrays!
logger sprintf ("In public chat %s (%s) %s send photo", $chatname, $chatid, $vis_a_vi); logger sprintf ('In public chat %s (%s) %s send photo', $chatname, $chatid, $vis_a_vi);
} else { } else {
logger Dumper ($msg); logger Dumper ($msg);
} }
@@ -275,7 +277,7 @@ sub __on_msg {
# we have text here! so potentially we can chit-chat # we have text here! so potentially we can chit-chat
my $text = $msg->text; my $text = $msg->text;
logger sprintf ("In public chat %s (%s) %s say: %s", $chatname, $chatid, $vis_a_vi, $text); logger sprintf ('In public chat %s (%s) %s say: %s', $chatname, $chatid, $vis_a_vi, $text);
my $qname = quotemeta ($c->{telegrambot}->{name}); my $qname = quotemeta ($c->{telegrambot}->{name});
my $qtname = quotemeta ($c->{telegrambot}->{tname}); my $qtname = quotemeta ($c->{telegrambot}->{tname});
my $csign = quotemeta ($c->{telegrambot}->{csign}); my $csign = quotemeta ($c->{telegrambot}->{csign});
@@ -285,7 +287,7 @@ sub __on_msg {
defined ($msg->reply_to_message->from) && defined ($msg->reply_to_message->from) &&
defined ($msg->reply_to_message->from->username) && defined ($msg->reply_to_message->from->username) &&
($msg->reply_to_message->from->username eq $myusername)) { ($msg->reply_to_message->from->username eq $myusername)) {
logger sprintf ("In public chat %s (%s) %s quote us!", $chatname, $chatid, $vis_a_vi); logger sprintf ('In public chat %s (%s) %s quote us!', $chatname, $chatid, $vis_a_vi);
# remove our name from users reply, just in case # remove our name from users reply, just in case
my $pat1 = quotemeta ('@' . $myusername); my $pat1 = quotemeta ('@' . $myusername);
my $pat2 = quotemeta ($myfullname); my $pat2 = quotemeta ($myfullname);
@@ -299,40 +301,44 @@ sub __on_msg {
# TODO: Process commands in separate sub, they are same for public and private chats. # TODO: Process commands in separate sub, they are same for public and private chats.
# TODO: Log commands and answers # TODO: Log commands and answers
} elsif (substr ($text, 0, 1) eq $c->{telegrambot}->{csign}) { } elsif (substr ($text, 0, 1) eq $c->{telegrambot}->{csign}) {
if (substr ($text, 1) eq "help") { if (substr ($text, 1) eq 'help') {
return unless ($can_talk); unless ($can_talk) {
return ;
}
my $send_args; my $send_args;
$send_args->{text} = '``` $send_args->{text} = << 'MYHELP';
```
!help | !помощь - список команд !help | !помощь - список команд
!w город | !п город - погода в указанном городе !w город | !п город - погода в указанном городе
!ping | !пинг - попинговать бота !ping | !пинг - попинговать бота
``` ```
Но на самом деле я бот больше для общения, чем для исполнения команд. Но на самом деле я бот больше для общения, чем для исполнения команд.
Поговоришь со мной? Поговоришь со мной?
'; MYHELP
$send_args->{parse_mode} = 'Markdown'; $send_args->{parse_mode} = 'Markdown';
$send_args->{chat_id} = $chatid; $send_args->{chat_id} = $chatid;
Telegram::Bot::Brain::sendMessage ($self, $send_args); Telegram::Bot::Brain::sendMessage ($self, $send_args);
return; return;
} elsif (substr ($text, 1) eq "ping") { } elsif (substr ($text, 1) eq 'ping') {
$reply = "Pong."; $reply = 'Pong.';
} elsif (substr ($text, 1) eq "пинг") { } elsif (substr ($text, 1) eq 'пинг') {
$reply = "Понг."; $reply = 'Понг.';
} elsif (substr ($text, 1) eq "pong") { } elsif (substr ($text, 1) eq 'pong') {
$reply = "Wat?"; $reply = 'Wat?';
} elsif (substr ($text, 1) eq "понг") { } elsif (substr ($text, 1) eq 'понг') {
$reply = "Шта?"; $reply = 'Шта?';
} 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, 3); my $city = substr ($text, 3);
$reply = weather ($city); $reply = weather ($city);
} }
} elsif ( } elsif (
($text eq $qname) or ($text eq $qname) or
($text eq sprintf ("%s", $qtname)) or ($text eq sprintf ('%s', $qtname)) or
($text eq sprintf ("@%s_bot", $qname)) or # :( ($text eq sprintf ("@%s_bot", $qname)) or # :(
($text eq sprintf ("%s ", $qtname)) ($text eq sprintf ('%s ', $qtname))
) { ) {
$reply = "Чего?"; $reply = 'Чего?';
} else { } else {
# phrase directed to bot # phrase directed to bot
if ((lc ($text) =~ /^${qname}[\,|\:]? (.+)/) or (lc ($text) =~ /^${qtname}[\,|\:]? (.+)/)){ if ((lc ($text) =~ /^${qname}[\,|\:]? (.+)/) or (lc ($text) =~ /^${qtname}[\,|\:]? (.+)/)){
@@ -372,13 +378,13 @@ sub __on_msg {
} }
sleep (int (rand (2))); sleep (int (rand (2)));
logger sprintf ("In public chat %s (%s) bot reply to %s: %s", $chatname, $chatid, $vis_a_vi, $reply); logger sprintf ('In public chat %s (%s) bot reply to %s: %s', $chatname, $chatid, $vis_a_vi, $reply);
$msg->reply ($reply); $msg->reply ($reply);
} else { } else {
if ($can_talk) { if ($can_talk) {
logger sprintf ("In public chat %s (%s) bot is not required to reply to %s", $chatname, $chatid, $vis_a_vi); logger sprintf ('In public chat %s (%s) bot is not required to reply to %s', $chatname, $chatid, $vis_a_vi);
} else { } else {
logger sprintf ("In public chat %s (%s) bot can't talk, but reply to %s is: %s", $chatname, $chatid, $vis_a_vi, $reply); logger sprintf ('In public chat %s (%s) bot can\'t talk, but reply to %s is: %s', $chatname, $chatid, $vis_a_vi, $reply);
} }
} }
@@ -393,20 +399,23 @@ sub __on_msg {
# setup our bot # setup our bot
sub init { sub init {
unless (-d $c->{telegrambot}->{braindir}) { unless (-d $c->{telegrambot}->{braindir}) {
mkpath ($c->{telegrambot}->{braindir}, 0, 0755); mkpath ($c->{telegrambot}->{braindir}, 0, 0755); ## no critic (ValuesAndExpressions::ProhibitLeadingZeros)
} }
my $self = shift; my $self = shift;
$self->add_listener (\&__on_msg); $self->add_listener (\&__on_msg);
# $self->add_repeating_task(900, \&__cron); # $self->add_repeating_task(900, \&__cron);
return;
} }
sub run_telegrambot { sub run_telegrambot {
while (sleep 3) { while (sleep 3) {
eval { eval { ## no critic (ErrorHandling::RequireCheckingReturnValueOfEval)
telegrambot->new->think; telegrambot->new->think;
} }
} }
return;
} }
1; 1;

14
lib/telegramlib.pm
View File

@@ -3,7 +3,7 @@ package telegramlib;
use 5.018; use 5.018;
use strict; use strict;
use warnings "all"; use warnings;
use utf8; use utf8;
use open qw(:std :utf8); use open qw(:std :utf8);
@@ -13,9 +13,9 @@ use Telegram::Bot::Brain;
# module shit # module shit
use vars qw/$VERSION/; use vars qw/$VERSION/;
use Exporter qw(import); use Exporter qw(import);
our @EXPORT = qw(getChat getChatMember sendChatAction visavi); our @EXPORT_OK = qw(getChat getChatMember sendChatAction visavi);
$VERSION = "1.0"; $VERSION = '1.0';
# complete framework with our getChat() # complete framework with our getChat()
sub getChat { sub getChat {
@@ -60,7 +60,7 @@ sub sendChatAction {
my $chatid = shift; my $chatid = shift;
my $send_args = {}; my $send_args = {};
$send_args->{chat_id} = $chatid; $send_args->{chat_id} = $chatid;
$send_args->{action} = "typing"; $send_args->{action} = 'typing';
my $token = $self->token; my $token = $self->token;
my $url = "https://api.telegram.org/bot${token}/sendChatAction"; my $url = "https://api.telegram.org/bot${token}/sendChatAction";
my $api_response = $self->_post_request ($url, $send_args); my $api_response = $self->_post_request ($url, $send_args);
@@ -69,7 +69,7 @@ sub sendChatAction {
return; return;
} }
sub visavi (@) { sub visavi {
my ($userid, $username, $fullname) = @_; my ($userid, $username, $fullname) = @_;
my $name = ''; my $name = '';
@@ -83,3 +83,7 @@ sub visavi (@) {
$name .= " ($userid)"; $name .= " ($userid)";
return $name; return $name;
} }
1;
# vim: ft=perl noet ai ts=4 sw=4 sts=4: