aleesa-bot/aleesa-telegram
0
Fork 0
Code Pull Requests Projects Releases Activity

Refactor code

Browse Source 
* move plugins out of botlib.pm
* use make_path instead of mkpath
* squash some bugs
* update .gitignore
* use more correct randomizer, rather than perl own rand()
* coding style fixes
This commit is contained in:
eleksir
2021-01-05 13:42:41 +03:00
parent 8a521d3f3b
commit a1d238949f
20 changed files with 582 additions and 406 deletions
Download Patch File Download Diff File Expand all files Collapse all files

17
.gitignore vendored
View File

@@ -1,7 +1,12 @@
vendor_perl .idea/**
data/config.json .vscode/**
data/cache
data/telegrambot-brains
data/lat
aleesa-telegram-bot.pid aleesa-telegram-bot.pid
TODO data/cache/**
data/config.json
data/fortune/**
data/friday/**
data/karma/**
data/telegrambot-brains/**
data/lat/**
vendor_perl
_Deparsed_XSubs.pm

8
README.md
View File

@@ -6,9 +6,9 @@ It is based on Perl modules [Telegram::Bot][1] and [Hailo][2] as conversation
generator. generator.
I have to fork [Telegram::Bot][1] and add some of new methods that are already I have to fork [Telegram::Bot][1] and add some of new methods that are already
appear in [Telegram API][3], but author seems to abandon lib. Also i decide to appear in [Telegram API][3], but author seems to abandon lib. Also, I decide to
rename it to avoid collision in future, now it is Teapot::Bot and is bundled rename it to avoid collision in the future, now it is Teapot::Bot and is bundled
with bot. When lib become mature enough, maybe i release it separately. with bot. When lib become mature enough, maybe I release it separately.
Bot config located in **data/config.json**, sample config provided as Bot config located in **data/config.json**, sample config provided as
**data/sample_config.json**. **data/sample_config.json**.
@@ -24,7 +24,7 @@ You'll need "Development Tools" or similar group of packages, perl, perl-devel,
perl-local-lib, perl-app-cpanm, sqlite-devel, zlib-devel, openssl-devel, perl-local-lib, perl-app-cpanm, sqlite-devel, zlib-devel, openssl-devel,
libdb4-devel (Berkeley DB devel), make. libdb4-devel (Berkeley DB devel), make.
After installng required dependencies it is possible to run: After installing required dependencies it is possible to run:
```bash ```bash
bash bootstrap.sh bash bootstrap.sh

39
bin/aleesa-telegram-bot
View File

@@ -15,7 +15,11 @@ my $workdir;
BEGIN { BEGIN {
use Cwd qw (chdir abs_path); use Cwd qw (chdir abs_path);
my @CWD = split /\//xms, abs_path ($PROGRAM_NAME); 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;
} }
@@ -23,11 +27,11 @@ 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 File::Path qw(make_path);
use File::Basename qw (basename dirname); use File::Basename qw (basename dirname);
use File::Path qw (make_path);
use Log::Any::Adapter; use Log::Any::Adapter;
use Log::Any::For::Std; use Log::Any::For::Std;
use POSIX qw (setgid setuid setsid);
use conf qw (loadConf); use conf qw (loadConf);
use telegrambot qw (run_telegrambot); use telegrambot qw (run_telegrambot);
@@ -41,8 +45,12 @@ 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 $logfile; 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 # if we run under root, create pid dir and set correct owner for it, same for debug log if it is defined
if ($UID == 0) { if ($UID == 0) {
@@ -72,10 +80,8 @@ if ($UID == 0) {
uid => $uid, uid => $uid,
group => $gid group => $gid
} }
); ) or die "Unable to create $logdir: $OS_ERROR\n";
} }
die "Unable to create $logdir" unless (-d $logdir); ## no critic (ErrorHandling::RequireCarping)
} }
# drop privs # drop privs
@@ -137,14 +143,25 @@ sub daemonize {
sub __fork { sub __fork {
my $pid = fork; my $pid = fork;
unless (defined $pid) { die "[FATAL] Can't fork: $OS_ERROR\n"; }
exit if ($pid != 0); unless (defined $pid) {
die "[FATAL] Can't fork: $OS_ERROR\n";
}
if ($pid != 0) {
exit;
}
return; return;
} }
sub __signal_handler { sub __signal_handler {
warn "[INFO] Caught a signal $OS_ERROR\n"; warn "[INFO] Caught a signal $OS_ERROR\n";
unlink $pidfile if (-f $pidfile);
if (-f $pidfile) {
unlink $pidfile;
}
exit 0; exit 0;
} }

3
bin/fortune_seed.pl
View File

@@ -6,8 +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 vars qw/$VERSION/; use version; our $VERSION = qw (1.0);
$VERSION = '1.0';
my $workdir; my $workdir;

3
bin/friday_seed.pl
View File

@@ -6,8 +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 vars qw/$VERSION/; use version; our $VERSION = qw (1.0);
$VERSION = '1.0';
my $workdir; my $workdir;

3
bin/train_lat.pl
View File

@@ -6,8 +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 vars qw/$VERSION/; use version; our $VERSION = qw (1.0);
$VERSION = '1.0';
my $workdir; my $workdir;

2
confcheck.pl
View File

@@ -9,7 +9,7 @@ use English qw( -no_match_vars );
use lib qw(./lib ./vendor_perl ./vendor_perl/lib/perl5); use lib qw(./lib ./vendor_perl ./vendor_perl/lib/perl5);
use JSON::XS; use JSON::XS;
use version; our $VERSION = qv(1.0); use version; our $VERSION = qw (1.0);
my $c = 'data/config.json'; my $c = 'data/config.json';
open (my $C, '<', $c) or die "No conf at $c: $OS_ERROR\n"; open (my $C, '<', $c) or die "No conf at $c: $OS_ERROR\n";

1
cpanfile
View File

@@ -17,6 +17,7 @@ requires 'local::lib';
requires 'Log::Any'; requires 'Log::Any';
requires 'Log::Any::Adapter'; requires 'Log::Any::Adapter';
requires 'Log::Any::For::Std'; requires 'Log::Any::For::Std';
requires 'Math::Random::Secure';
requires 'Mojo::Base'; requires 'Mojo::Base';
requires 'Mojo::IOLoop'; requires 'Mojo::IOLoop';
requires 'Mojo::UserAgent'; requires 'Mojo::UserAgent';

7
data/sample_config.json
View File

@@ -10,16 +10,13 @@
"srcdir" : "data/fortune_src" "srcdir" : "data/fortune_src"
}, },
"telegrambot" : { "telegrambot" : {
"name" : "mybot",
"tname" : "@my_bot",
"csign" : "!", "csign" : "!",
"token" : "get_it_from_botfather", "token" : "get_it_from_botfather",
"braindir": "data/telegrambot-brains" "braindir": "data/telegrambot-brains"
}, },
"openweathermap" : { "openweathermap" : {
"cachetime": "data/cache/openweathermap.Id-Timestamp.db", "appid": "get_it_on_openweathermap.org",
"cachedata": "data/cache/openweathermap.Id-Data.db", "cachedir" : "data/cache"
"appid": "get_it_on_openweathermap.org"
}, },
"lat" : { "lat" : {
"brain": "data/lat/lat.sqlite", "brain": "data/lat/lat.sqlite",

20
lib/archeologist.pm
View File

@@ -6,11 +6,11 @@ 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 Math::Random::Secure qw (irand);
use vars qw/$VERSION/; use version; our $VERSION = qw (1.0);
use Exporter qw (import); use Exporter qw (import);
our @EXPORT_OK = qw (dig); our @EXPORT_OK = qw (dig);
$VERSION = '1.0';
sub dig { sub dig {
my $name = shift; my $name = shift;
@@ -100,21 +100,21 @@ sub dig {
'на просторах Украины', 'на просторах Украины',
); );
my $find_probability = int (rand 100); my $find_probability = irand 101;
my $success_probability = int (rand 100); my $success_probability = irand 101;
my $artifact_age = int (rand 15000); my $artifact_age = irand 15001;
if ($find_probability <= 20) { if ($find_probability <= 20) {
return sprintf 'По уши закопавшись %s, %s, нифига вы не выкопали! Может повезет в другом месте?', $location[int (rand ($#location + 1))], $name; return sprintf 'По уши закопавшись %s, %s, нифига вы не выкопали! Может повезет в другом месте?', $location[irand ($#location + 1)], $name;
} }
my $phrase = sprintf "Вы начали раскопки %s и усиленно роете лопатами, экскаватором...\n", $location[int (rand ($#location + 1))]; my $phrase = sprintf "Вы начали раскопки %s и усиленно роете лопатами, экскаватором...\n", $location[irand ($#location + 1)];
$phrase .= "Вам кажется что ваш совочек ударился обо что-то твердое. Может, это клад?!\n\n"; $phrase .= "Вам кажется что ваш совочек ударился обо что-то твердое. Может, это клад?!\n\n";
if ($success_probability <= 20) { if ($success_probability <= 25) {
$phrase .= sprintf '%s стал лучшим археологом, выкопав %s! возраст артефакта - %s лет!', $name, $artifact[int (rand ($#artifact + 1))], $artifact_age; $phrase .= sprintf '%s стал лучшим археологом, выкопав %s! возраст артефакта - %s лет!', $name, $artifact[irand ($#artifact + 1)], $artifact_age;
} else { } else {
$phrase .= sprintf "Поздравляю, %s! Вы только что выкопали %s, возраст - %s лет!\n", $name, $artifact[int (rand ($#artifact + 1))], $artifact_age; $phrase .= sprintf "Поздравляю, %s! Вы только что выкопали %s, возраст - %s лет!\n", $name, $artifact[irand ($#artifact + 1)], $artifact_age;
$phrase .= sprintf 'Извини %s, но на артефакт это не тянет! Однако, попытка хорошая!', $name; $phrase .= sprintf 'Извини %s, но на артефакт это не тянет! Однако, попытка хорошая!', $name;
} }

301
lib/botlib.pm
View File

@@ -8,207 +8,24 @@ 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 Carp qw (carp);
use HTTP::Tiny; use Math::Random::Secure qw (irand);
use URI::URL;
use JSON::XS qw(decode_json encode_json);
use Digest::MD5 qw(md5_base64);
use DB_File;
use Text::Fuzzy qw(distance_edits);
use conf qw(loadConf);
use lat qw(latAnswer);
use karma qw(karmaSet karmaGet);
use friday qw(friday);
use fortune qw(fortune fortune_toggle fortune_status);
use archeologist qw (dig);
use vars qw/$VERSION/; use conf qw (loadConf);
use archeologist qw (dig);
use fortune qw (fortune fortune_toggle fortune_status);
use friday qw (friday);
use karma qw (karmaSet karmaGet);
use kitty qw (kitty);
use lat qw (latAnswer);
use util qw (trim);
use weather qw (weather);
use version; our $VERSION = qw (1.0);
use Exporter qw (import); use Exporter qw (import);
our @EXPORT_OK = qw(weather trim randomCommonPhrase command highlight botsleep fmatch); our @EXPORT_OK = qw (randomCommonPhrase command highlight botsleep);
$VERSION = '1.0';
my $c = loadConf (); my $c = loadConf ();
my $csign = $c->{telegrambot}->{csign};
sub __urlencode {
my $str = shift;
my $urlobj = url $str;
$str = $urlobj->as_string;
$urlobj = undef; undef $urlobj;
return $str;
}
sub trim {
my $str = shift;
return $str if ($str eq '');
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;
$city = trim ($city);
return 'Мне нужно ИМЯ города.' if ($city eq '');
return 'Длинновато для названия города.' if (length($city) > 80);
$city = ucfirst ($city);
my $w = __weather ($city);
my $reply;
if ($w) {
if ($w->{temperature_min} == $w->{temperature_max}) {
$reply = sprintf ("Погода в городе %s, %s:\n%s, ветер %s %s м/c, температура %s°C, ощущается как %s°C, относительная влажность %s%%, давление %s мм.рт.с",
$w->{name},
$w->{country},
ucfirst ($w->{description}),
$w->{wind_direction},
$w->{wind_speed},
$w->{temperature_min},
$w->{temperature_feelslike},
$w->{humidity},
$w->{pressure}
);
} else {
$reply = sprintf ("Погода в городе %s, %s:\n%s, ветер %s %s м/c, температура %s-%s°C, ощущается как %s°C, относительная влажность %s%%, давление %s мм.рт.ст",
$w->{name},
$w->{country},
ucfirst ($w->{description}),
$w->{wind_direction},
$w->{wind_speed},
$w->{temperature_min},
$w->{temperature_max},
$w->{temperature_feelslike},
$w->{humidity},
$w->{pressure}
);
}
} else {
$reply = "Я не знаю, какая погода в $city";
}
return $reply;
}
sub __weather {
my $city = shift;
$city = __urlencode ($city);
my $id = md5_base64 ($city);
my $appid = $c->{openweathermap}->{appid};
my $now = time ();
my $fc;
my $w;
# attach to cache data
tie my %cachetime, 'DB_File', $c->{openweathermap}->{cachetime} or do {
carp "[ERROR] Something nasty happen when cachetime ties to its data: $OS_ERROR";
return undef;
};
tie my %cachedata, 'DB_File', $c->{openweathermap}->{cachedata} or do {
carp "[ERROR] Something nasty happen when cachedata ties to its data: $OS_ERROR";
return undef;
};
# lookup cache
if (defined ($cachetime{$id}) && ($now - $cachetime{$id}) < 10800) {
$fc = decode_json ($cachedata{$id});
} else {
my $r;
# try 3 times and giveup
for (1..3) {
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));
sleep 2;
}
# all 3 times can give error, so check it here
if ($r->{success}) {
$fc = eval { decode_json ($r->{content}) };
if ($EVAL_ERROR) {
carp "[WARN] openweathermap returns corrupted json: $EVAL_ERROR";
untie %cachetime;
untie %cachedata;
return undef;
};
$cachetime{$id} = $now;
$cachedata{$id} = encode_json ($fc);
} else {
untie %cachetime;
untie %cachedata;
return undef;
}
}
untie %cachetime;
untie %cachedata;
# TODO: check all of this for existance
$w->{'name'} = $fc->{name};
$w->{'state'} = $fc->{state};
$w->{'country'} = $fc->{sys}->{country};
$w->{'longitude'} = $fc->{coord}->{lon};
$w->{'latitude'} = $fc->{coord}->{lat};
$w->{'temperature_min'} = int ($fc->{main}->{temp_min} - 273.15);
$w->{'temperature_max'} = int ($fc->{main}->{temp_max} - 273.15);
$w->{'temperature_feelslike'} = int ($fc->{main}->{feels_like} - 273.15);
$w->{'humidity'} = $fc->{main}->{humidity};
$w->{'pressure'} = int ($fc->{main}->{pressure} * 0.75006375541921);
$w->{'description'} = $fc->{weather}->[0]->{description};
$w->{'wind_speed'} = $fc->{wind}->{speed};
$w->{'wind_direction'} = 'разный';
my $dir = int ($fc->{wind}->{deg} + 0);
if ($dir == 0) {
$w->{'wind_direction'} = 'северный';
} elsif ($dir > 0 && $dir <= 30) {
$w->{'wind_direction'} = 'северо-северо-восточный';
} elsif ($dir > 30 && $dir <= 60) {
$w->{'wind_direction'} = 'северо-восточный';
} elsif ($dir > 60 && $dir < 90) {
$w->{'wind_direction'} = 'восточно-северо-восточный';
} elsif ($dir == 90) {
$w->{'wind_direction'} = 'восточный';
} elsif ($dir > 90 && $dir <= 120) {
$w->{'wind_direction'} = 'восточно-юго-восточный';
} elsif ($dir > 120 && $dir <= 150) {
$w->{'wind_direction'} = 'юговосточный';
} elsif ($dir > 150 && $dir < 180) {
$w->{'wind_direction'} = 'юго-юго-восточный';
} elsif ($dir == 180) {
$w->{'wind_direction'} = 'южный';
} elsif ($dir > 180 && $dir <= 210) {
$w->{'wind_direction'} = 'юго-юго-западный';
} elsif ($dir > 210 && $dir <= 240) {
$w->{'wind_direction'} = 'юго-западный';
} elsif ($dir > 240 && $dir < 270) {
$w->{'wind_direction'} = 'западно-юго-западный';
} elsif ($dir == 270) {
$w->{'wind_direction'} = 'западный';
} elsif ($dir > 270 && $dir <= 300) {
$w->{'wind_direction'} = 'западно-северо-западный';
} elsif ($dir > 300 && $dir <= 330) {
$w->{'wind_direction'} = 'северо-западный';
} elsif ($dir > 330 && $dir < 360) {
$w->{'wind_direction'} = 'северо-северо-западный';
} elsif ($dir == 360) {
$w->{'wind_direction'} = 'северный';
}
return $w;
}
sub randomCommonPhrase { sub randomCommonPhrase {
my @myphrase = ( my @myphrase = (
@@ -225,7 +42,7 @@ sub randomCommonPhrase {
'А ви, таки, почему интересуетесь?', 'А ви, таки, почему интересуетесь?',
); );
return $myphrase[rand ($#myphrase -1)]; return $myphrase[irand ($#myphrase + 1)];
} }
sub command { sub command {
@@ -251,6 +68,10 @@ sub command {
$reply = weather ($city); $reply = weather ($city);
} elsif (substr ($text, 1) eq 'cat' || substr ($text, 1) eq 'кис') { } elsif (substr ($text, 1) eq 'cat' || substr ($text, 1) eq 'кис') {
$reply = kitty (); $reply = kitty ();
$msg->typing ();
sleep (int ( rand (2) + 1));
$msg->replyMd ($reply);
return;
} elsif (substr ($text, 1) eq 'lat' || substr ($text, 1) eq 'лат') { } elsif (substr ($text, 1) eq 'lat' || substr ($text, 1) eq 'лат') {
$reply = latAnswer (); $reply = latAnswer ();
} 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 ((length ($text) >= 6 && (substr ($text, 1, 6) eq 'karma ' || substr ($text, 1, 6) eq 'карма ')) || substr ($text, 1) eq 'karma' || substr ($text, 1) eq 'карма') {
@@ -282,23 +103,23 @@ sub command {
$msg->replyMd ($reply); $msg->replyMd ($reply);
return; return;
} elsif (substr ($text, 1) eq 'help' || substr ($text, 1) eq 'помощь') { } elsif (substr ($text, 1) eq 'help' || substr ($text, 1) eq 'помощь') {
$reply = << 'MYHELP'; $reply = << "MYHELP";
``` ```
!help | !помощь - список команд ${csign}help | ${csign}помощь - список команд
!cat | !кис - кошечка ${csign}cat | ${csign}кис - кошечка
!dig | !копать - заняться археологией ${csign}dig | ${csign}копать - заняться археологией
!f | !ф - рандомная фраза из сборника цитат fortune_mod ${csign}f | ${csign}ф - рандомная фраза из сборника цитат fortune_mod
!fortune | !фортунка - рандомная фраза из сборника цитат fortune_mod ${csign}fortune | ${csign}фортунка - рандомная фраза из сборника цитат fortune_mod
!f # | !ф # - где 1 - вкл, 0 - выкл фортунку с утра ${csign}f # | ${csign}ф # - где 1 - вкл, 0 - выкл фортунку с утра
!fortune # | !фортунка # - где 1 - вкл, 0 - выкл фортунку с утра ${csign}fortune # | ${csign}фортунка # - где 1 - вкл, 0 - выкл фортунку с утра
!f ? | !ф ? - показываем ли с утра фортунку для чата ${csign}f ? | ${csign}ф ? - показываем ли с утра фортунку для чата
!fortune ? | !фортунка ? - показываем ли с утра фортунку для чата ${csign}fortune ? | ${csign}фортунка ? - показываем ли с утра фортунку для чата
!friday | !пятница - а не пятница ли сегодня? ${csign}friday | ${csign}пятница - а не пятница ли сегодня?
!lat | !лат - сгенерить фразу из крылатых латинских выражений ${csign}lat | ${csign}лат - сгенерить фразу из крылатых латинских выражений
!ping | !пинг - попинговать бота ${csign}ping | ${csign}пинг - попинговать бота
!ver | !version | !версия - что-то про версию ПО ${csign}ver | ${csign}version | ${csign}версия - что-то про версию ПО
!w город | !п город - погода в указанном городе ${csign}w город | ${csign}п город - погода в указанном городе
!karma фраза | !карма фраза - посмотреть карму фразы ${csign}karma фраза | ${csign}карма фраза - посмотреть карму фразы
фраза-- | фраза++ - убавить или добавить карму фразе фраза-- | фраза++ - убавить или добавить карму фразе
``` ```
Но на самом деле я бот больше для общения, чем для исполнения команд. Но на самом деле я бот больше для общения, чем для исполнения команд.
@@ -319,15 +140,18 @@ sub highlight {
my $username; my $username;
my $visavi = ''; my $visavi = '';
my $userid = $msg->from->id; my $userid = $msg->from->id;
$username = $msg->from->username if ($msg->from->can ('username') && defined($msg->from->username));
if ($msg->from->can ('first_name') && defined ($msg->from->first_name)) { if ($msg->from->can ('username') && defined $msg->from->username ) {
$username = $msg->from->username;
}
if ($msg->from->can ('first_name') && defined $msg->from->first_name) {
$fullname = $msg->from->first_name; $fullname = $msg->from->first_name;
if ($msg->from->can ('last_name') && defined ($msg->from->last_name)) { if ($msg->from->can ('last_name') && defined $msg->from->last_name) {
$fullname .= ' ' . $msg->from->last_name; $fullname .= ' ' . $msg->from->last_name;
} }
} elsif ($msg->from->can ('last_name') && defined ($msg->from->last_name)) { } elsif ($msg->from->can ('last_name') && defined $msg->from->last_name) {
$fullname .= $msg->from->last_name; $fullname .= $msg->from->last_name;
} }
@@ -358,7 +182,7 @@ sub botsleep {
for (0..(4 + int (rand (3)))) { for (0..(4 + int (rand (3)))) {
$msg->typing (); $msg->typing ();
sleep(3); sleep 3;
sleep 3 unless ($_); sleep 3 unless ($_);
} }
@@ -366,45 +190,6 @@ sub botsleep {
return; return;
} }
sub fmatch {
my $srcphrase = shift;
my $answer = shift;
my ($distance, undef) = distance_edits ($srcphrase, $answer);
my $srcphraselen = length $srcphrase;
my $distance_max = int ($srcphraselen - ($srcphraselen * (100 - (90 / ($srcphraselen ** 0.5))) * 0.01));
if ($distance >= $distance_max) {
return 0;
} else {
return 1;
}
}
sub kitty {
my $r;
for (1..3) {
my $http = HTTP::Tiny->new (timeout => 3);
$r = $http->get ('https://api.thecatapi.com/v1/images/search');
last if ($r->{success});
sleep 2;
}
if ($r->{success}) {
my $jcat = eval { decode_json ($r->{content}) };
if ($jcat->[0]->{url}) {
my @cats = ('龴ↀ◡ↀ龴', '=^..^=', '≧◔◡◔≦ ','^ↀᴥↀ^' );
return sprintf '[%s](%s)', $cats[int(rand($#cats))], $jcat->[0]->{url};
} else {
return 'Нету кошечек, все разбежались.';
}
} else {
return 'Нету кошечек, все разбежались.';
}
}
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:

5
lib/conf.pm
View File

@@ -9,15 +9,14 @@ use open qw(:std :utf8);
use English qw ( -no_match_vars ); use English qw ( -no_match_vars );
use JSON::XS; use JSON::XS;
use vars qw/$VERSION/; use version; our $VERSION = qw (1.0);
use Exporter qw (import); use Exporter qw (import);
our @EXPORT_OK = qw (loadConf); our @EXPORT_OK = qw (loadConf);
$VERSION = '1.0';
sub loadConf { sub loadConf {
my $c = 'data/config.json'; my $c = 'data/config.json';
open my $CH, '<', $c or die "[FATAL] No conf at $c: $OS_ERROR\n"; open my $CH, '<', $c or die "[FATAL] No conf at $c: $OS_ERROR\n";
my $len = (stat ($c)) [7]; my $len = (stat $c) [7];
my $json; my $json;
my $readlen = read $CH, $json, $len; my $readlen = read $CH, $json, $len;

32
lib/fortune.pm
View File

@@ -8,15 +8,14 @@ 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 (cluck croak);
use File::Path qw (make_path);
use Math::Random::Secure qw (irand);
use SQLite_File; use SQLite_File;
use MIME::Base64;
use File::Path qw(mkpath);
use conf qw (loadConf); use conf qw (loadConf);
use vars qw/$VERSION/; use version; our $VERSION = qw (1.0);
use Exporter qw(import); use Exporter qw(import);
our @EXPORT_OK = qw(seed fortune fortune_toggle fortune_toggle_list fortune_status); our @EXPORT_OK = qw(seed fortune fortune_toggle fortune_toggle_list fortune_status);
$VERSION = '1.0';
my $c = loadConf(); my $c = loadConf();
my $dir = $c->{fortune}->{dir}; my $dir = $c->{fortune}->{dir};
@@ -24,7 +23,7 @@ my $srcdir = $c->{fortune}->{srcdir};
sub seed () { sub seed () {
unless (-d $dir) { unless (-d $dir) {
mkpath ($dir) || croak "Unable to create $dir: $OS_ERROR"; make_path ($dir) || croak "Unable to create $dir: $OS_ERROR";
} }
my $backingfile = sprintf '%s/fortune.sqlite', $dir; my $backingfile = sprintf '%s/fortune.sqlite', $dir;
@@ -39,14 +38,21 @@ 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;
next unless (-f $srcfile);
next if ($fortunefile =~ m/\./); unless (-f $srcfile) {
next;
}
if ($fortunefile =~ m/\./) {
next;
}
open (my $fh, '<', $srcfile) || croak "Unable to open $srcfile, $OS_ERROR"; open (my $fh, '<', $srcfile) || croak "Unable to open $srcfile, $OS_ERROR";
# set correct phrase delimiter # set correct phrase delimiter
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, -3;
push @fortune, $phrase; push @fortune, $phrase;
} }
@@ -67,7 +73,7 @@ sub fortune () {
return ''; return '';
}; };
my $phrase = $array[int (rand ($#array - 1))]; my $phrase = $array[irand ($#array + 1)];
# decode? # decode?
utf8::decode $phrase; utf8::decode $phrase;
untie @array; untie @array;
@@ -80,7 +86,7 @@ sub fortune_toggle (@) {
my $phrase = 'Фортунка с утра '; my $phrase = 'Фортунка с утра ';
unless (-d $dir) { unless (-d $dir) {
mkpath ($dir) || do { make_path ($dir) || do {
cluck "[ERROR] Unable to create $dir: $OS_ERROR"; cluck "[ERROR] Unable to create $dir: $OS_ERROR";
return; return;
}; };
@@ -125,7 +131,7 @@ sub fortune_status ($) {
my $phrase = 'Фортунка с утра '; my $phrase = 'Фортунка с утра ';
unless (-d $dir) { unless (-d $dir) {
mkpath ($dir) || do { make_path ($dir) || do {
cluck "[ERROR] Unable to create $dir: $OS_ERROR"; cluck "[ERROR] Unable to create $dir: $OS_ERROR";
return; return;
}; };
@@ -141,7 +147,7 @@ sub fortune_status ($) {
my $state = $toggle{$chatid}; my $state = $toggle{$chatid};
if (defined $state && $state) { if (defined $state && $state) {
$phrase .= 'показываtтся.'; $phrase .= 'показывается.';
} else { } else {
$phrase .= 'не показывается.'; $phrase .= 'не показывается.';
} }
@@ -152,7 +158,7 @@ sub fortune_status ($) {
sub fortune_toggle_list () { sub fortune_toggle_list () {
unless (-d $dir) { unless (-d $dir) {
mkpath ($dir) || do { make_path ($dir) || do {
cluck "[ERROR] Unable to create $dir: $OS_ERROR"; cluck "[ERROR] Unable to create $dir: $OS_ERROR";
my @empty = (); my @empty = ();
return @empty; return @empty;

36
lib/friday.pm
View File

@@ -8,15 +8,14 @@ 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 (cluck croak);
use File::Path qw (make_path);
use Math::Random::Secure qw (irand);
use SQLite_File; use SQLite_File;
use MIME::Base64;
use File::Path qw(mkpath);
use conf qw (loadConf); use conf qw (loadConf);
use vars qw/$VERSION/; use version; our $VERSION = qw (1.0);
use Exporter qw (import); use Exporter qw (import);
our @EXPORT_OK = qw (seed friday); our @EXPORT_OK = qw (seed friday);
$VERSION = '1.0';
my $c = loadConf (); my $c = loadConf ();
my $dir = $c->{friday}->{dir}; my $dir = $c->{friday}->{dir};
@@ -25,7 +24,7 @@ my @dow = qw (monday tuesday wednesday thursday friday saturday sunday);
sub seed () { sub seed () {
unless (-d $dir) { unless (-d $dir) {
mkpath ($dir) || croak "Unable to create $dir: $OS_ERROR"; make_path ($dir) || croak "Unable to create $dir: $OS_ERROR";
} }
my $friday; my $friday;
@@ -43,20 +42,34 @@ sub seed () {
open (my $fh, '<', $srcfile) || croak "Unable to open $srcfile, $OS_ERROR\n"; open (my $fh, '<', $srcfile) || croak "Unable to open $srcfile, $OS_ERROR\n";
while (readline $fh) { while (readline $fh) {
next unless m/ \|\| /xmsg; unless (m/ \|\| /xmsg) {
next;
}
chomp(); chomp();
my ($phrase, $days) = split(/ \|\| /); my ($phrase, $days) = split(/ \|\| /);
my @daylist = split(//, $days); my @daylist = split(//, $days);
foreach my $day (@daylist) { foreach my $day (@daylist) {
next unless (defined $day); unless (defined $day) {
next unless ($day =~ /^\d$/); next;
push @{$friday->[$day - 1]}, $phrase if (defined $phrase && ($phrase ne '') && ($phrase !~ m/^\s+$/xmsg)); }
unless ($day =~ /^\d$/) {
next;
}
if (defined $phrase && ($phrase ne '') && ($phrase !~ m/^\s+$/xmsg)) {
push @{$friday->[$day - 1]}, $phrase;
}
} }
} }
close $fh; ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen) close $fh; ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
for (0..$#dow) { untie $friday->[$_]; }
for (0..$#dow) {
untie $friday->[$_];
}
return; return;
} }
@@ -71,8 +84,7 @@ sub friday () {
return ''; return '';
}; };
my $phrase = $array[int (rand ($#array - 1))]; my $phrase = $array[irand ($#array + 1)];
# decode?
utf8::decode $phrase; utf8::decode $phrase;
untie @array; untie @array;
return $phrase; return $phrase;

24
lib/karma.pm
View File

@@ -6,15 +6,15 @@ 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::SHA qw (sha1_base64); use Digest::SHA qw (sha1_base64);
use DB_File; use DB_File;
use Carp qw(cluck); use File::Path qw (make_path);
use conf qw (loadConf); use conf qw (loadConf);
use vars qw/$VERSION/; use version; our $VERSION = qw (1.0);
use Exporter qw (import); use Exporter qw (import);
our @EXPORT_OK = qw(karmaSet karmaGet); our @EXPORT_OK = qw(karmaSet karmaGet);
$VERSION = '1.0';
my $c = loadConf(); my $c = loadConf();
my $karmadir = $c->{karma}->{dir}; my $karmadir = $c->{karma}->{dir};
@@ -28,7 +28,7 @@ sub karmaSet (@) {
my $score = 0; my $score = 0;
# sha1* does not understand utf8, so explicitly construct string cost of decimal numbers only # sha1* does not understand utf8, so explicitly construct string cost of decimal numbers only
my $karmafile = join ('', unpack ('C*', $chatid)); my $karmafile = join ('', unpack ('C*', $chatid));
$karmafile = sha1_base64 ($karmafile); $karmafile = sha1_base64 $karmafile;
# sha1 string can contain slashes, so make a bit longer string consist of only decimal numbers # sha1 string can contain slashes, so make a bit longer string consist of only decimal numbers
$karmafile = join ('', unpack ('C*', $karmafile)); $karmafile = join ('', unpack ('C*', $karmafile));
$karmafile = sprintf '%s/%s.db', $karmadir, $karmafile; $karmafile = sprintf '%s/%s.db', $karmadir, $karmafile;
@@ -37,6 +37,13 @@ sub karmaSet (@) {
$phrase = ''; $phrase = '';
} }
unless (-d $karmadir) {
make_path ($karmadir) or do {
cluck "Unable to create $karmadir: $OS_ERROR";
return sprintf 'Карма %s составляет 0', $phrase;
};
}
# init hash, store phrase and score # init hash, store phrase and score
tie my %karma, 'DB_File', $karmafile || do { tie my %karma, 'DB_File', $karmafile || do {
cluck "[ERROR] Something nasty happen when cachedata ties to its data: $OS_ERROR"; cluck "[ERROR] Something nasty happen when cachedata ties to its data: $OS_ERROR";
@@ -87,7 +94,7 @@ sub karmaGet (@) {
my $phrase = shift; my $phrase = shift;
# sha1* does not understand utf8, so explicitly construct string cost of decimal numbers only # sha1* does not understand utf8, so explicitly construct string cost of decimal numbers only
my $karmafile = join ('', unpack ('C*', $chatid)); my $karmafile = join ('', unpack ('C*', $chatid));
$karmafile = sha1_base64 ($karmafile); $karmafile = sha1_base64 $karmafile;
# sha1 string can contain slashes, so make a bit longer string consist of only decimal numbers # sha1 string can contain slashes, so make a bit longer string consist of only decimal numbers
$karmafile = join ('', unpack ('C*', $karmafile)); $karmafile = join ('', unpack ('C*', $karmafile));
$karmafile = sprintf '%s/%s.db', $karmadir, $karmafile; $karmafile = sprintf '%s/%s.db', $karmadir, $karmafile;
@@ -96,6 +103,13 @@ sub karmaGet (@) {
$phrase = ''; $phrase = '';
} }
unless (-d $karmadir) {
make_path ($karmadir) or do {
cluck "Unable to create $karmadir: $OS_ERROR";
return sprintf 'Карма %s составляет 0', $phrase;
};
}
# init hash, store phrase and score # init hash, store phrase and score
tie my %karma, 'DB_File', $karmafile || do { tie my %karma, 'DB_File', $karmafile || do {
cluck "[ERROR] Something nasty happen when karma ties to its data: $OS_ERROR"; cluck "[ERROR] Something nasty happen when karma ties to its data: $OS_ERROR";

55
lib/kitty.pm Normal file
View File

@@ -0,0 +1,55 @@
package kitty;
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use Carp qw (cluck);
use JSON::XS;
use HTTP::Tiny;
use Math::Random::Secure qw (irand);
use version; our $VERSION = qw (1.0);
use Exporter qw (import);
our @EXPORT_OK = qw (kitty);
sub kitty {
my $r;
my $ret = 'Нету кошечек, все разбежались.';
for (1..3) {
my $http = HTTP::Tiny->new (timeout => 3);
$r = $http->get ('https://api.thecatapi.com/v1/images/search');
if ($r->{success}) {
last;
}
sleep 2;
}
if ($r->{success}) {
my $jcat = eval {
decode_json ($r->{content})
};
if ($EVAL_ERROR) {
cluck "[ERROR] Unable to decode JSON: $EVAL_ERROR";
} else {
if ($jcat->[0]->{url}) {
my @cats = ('龴ↀ◡ↀ龴', '=^..^=', '≧◔◡◔≦ ','^ↀᴥↀ^' );
$ret = sprintf '[%s](%s)', $cats[irand ($#cats + 1)], $jcat->[0]->{url};
}
}
} else {
cluck sprintf 'Server return status %s with message: %s', $r->{status}, $r->{reason};
}
return $ret;
}
1;
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

13
lib/lat.pm
View File

@@ -8,25 +8,24 @@ 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 Carp qw (cluck);
use Hailo;
use File::Basename qw (dirname); use File::Basename qw (dirname);
use File::Path qw(mkpath); use File::Path qw (make_path);
use Hailo;
use conf qw (loadConf); use conf qw (loadConf);
use vars qw/$VERSION/; use version; our $VERSION = qw (1.0);
use Exporter qw (import); use Exporter qw (import);
our @EXPORT_OK = qw (train latAnswer); our @EXPORT_OK = qw (train latAnswer);
$VERSION = '1.0';
my $c = loadConf (); my $c = loadConf ();
my $brain = $c->{lat}->{brain}; my $brain = $c->{lat}->{brain};
my $srcfile = $c->{lat}->{src}; my $srcfile = $c->{lat}->{src};
sub train () { sub train () {
my $braindir = dirname ($brain); my $braindir = dirname $brain;
unless (-d $braindir) { unless (-d $braindir) {
mkpath ($braindir) or do { make_path ($braindir) or do {
cluck "Unable to create $braindir: $OS_ERROR"; cluck "Unable to create $braindir: $OS_ERROR";
exit 1; exit 1;
}; };
@@ -47,7 +46,7 @@ sub train () {
# just return answer # just return answer
sub latAnswer () { sub latAnswer () {
my $braindir = dirname ($brain); my $braindir = dirname $brain;
unless (-d $braindir) { unless (-d $braindir) {
cluck "[ERROR] No lat module data: $braindir is absent! Train lat first."; cluck "[ERROR] No lat module data: $braindir is absent! Train lat first.";

26
lib/telegrambot.pm
View File

@@ -7,19 +7,20 @@ use warnings;
use utf8; use utf8;
use Data::Dumper; use Data::Dumper;
use open qw (:std :utf8); use open qw (:std :utf8);
use Carp qw(carp); use English qw ( -no_match_vars );
use File::Path qw(mkpath); use Carp qw (cluck carp);
use File::Path qw (make_path);
use Hailo; use Hailo;
use Mojo::Base 'Teapot::Bot::Brain'; use Mojo::Base 'Teapot::Bot::Brain';
use botlib qw (randomCommonPhrase command highlight botsleep);
use conf qw (loadConf); use conf qw (loadConf);
use botlib qw(weather trim randomCommonPhrase command highlight botsleep fmatch);
use karma qw(karmaSet);
use fortune qw (fortune fortune_toggle_list); use fortune qw (fortune fortune_toggle_list);
use karma qw (karmaSet);
use util qw (trim fmatch);
use vars qw/$VERSION/; use version; our $VERSION = qw (1.0);
use Exporter qw (import); use Exporter qw (import);
our @EXPORT_OK = qw (run_telegrambot); our @EXPORT_OK = qw (run_telegrambot);
$VERSION = '1.0';
my $c = loadConf (); my $c = loadConf ();
my $hailo; my $hailo;
@@ -241,7 +242,7 @@ sub __on_msg {
} elsif ((lc ($text) =~ /.+ ${qtname}[\,|\!|\?|\.| ]/) or (lc ($text) =~ / $qtname$/)) { } elsif ((lc ($text) =~ /.+ ${qtname}[\,|\!|\?|\.| ]/) or (lc ($text) =~ / $qtname$/)) {
$phrase = $text; $phrase = $text;
$reply = $hailo->{$msg->chat->id}->reply ($phrase); $reply = $hailo->{$msg->chat->id}->reply ($phrase);
# karma agjustment # karma adjustment
} elsif (substr ($text, -2) eq '++' || substr ($text, -2) eq '--') { } elsif (substr ($text, -2) eq '++' || substr ($text, -2) eq '--') {
my @arr = split(/\n/, $text); my @arr = split(/\n/, $text);
@@ -289,11 +290,16 @@ sub __on_msg {
# setup our bot # setup our bot
sub init { sub init {
unless (-d $c->{telegrambot}->{braindir}) { my $self = shift;
mkpath ($c->{telegrambot}->{braindir}, 0, 0755); ## no critic (ValuesAndExpressions::ProhibitLeadingZeros) my $braindir = $c->{telegrambot}->{braindir};
unless (-d $braindir) {
make_path ($braindir, 0, 0755) or do { ## no critic (ValuesAndExpressions::ProhibitLeadingZeros)
cluck "Unable to create $braindir: $OS_ERROR";
exit 1;
};
} }
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; return;

83
lib/util.pm Normal file
View File

@@ -0,0 +1,83 @@
package util;
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use Digest::SHA qw (sha1_base64);
use Encode;
use MIME::Base64;
use Text::Fuzzy qw (distance_edits);
use URI::URL;
use version; our $VERSION = qw (1.0);
use Exporter qw (import);
our @EXPORT_OK = qw (trim urlencode fmatch utf2b64 utf2sha1);
sub trim {
my $str = shift;
if ($str eq '') {
return $str;
}
while (substr ($str, 0, 1) =~ /^\s$/xms) {
$str = substr $str, 1;
}
while (substr ($str, -1, 1) =~ /^\s$/xms) {
chop $str;
}
return $str;
}
sub urlencode {
my $str = shift;
my $urlobj = url $str;
return $urlobj->as_string;
}
sub fmatch {
my $srcphrase = shift;
my $answer = shift;
my ($distance, undef) = distance_edits ($srcphrase, $answer);
my $srcphraselen = length $srcphrase;
my $distance_max = int ($srcphraselen - ($srcphraselen * (100 - (90 / ($srcphraselen ** 0.5))) * 0.01));
if ($distance >= $distance_max) {
return 0;
} else {
return 1;
}
}
sub utf2b64 {
my $string = shift;
if ($string eq '') {
return encode_base64 '';
}
my $bytes = encode_utf8 $string;
return encode_base64 $bytes;
}
sub utf2sha1 {
my $string = shift;
if ($string eq '') {
return sha1_base64 '';
}
my $bytes = encode_utf8 $string;
return sha1_base64 $bytes;
}
1;
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

200
lib/weather.pm Normal file
View File

@@ -0,0 +1,200 @@
package weather;
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use Carp qw (carp cluck);
use DB_File;
use Digest::MD5 qw (md5_base64);
use File::Path qw (make_path);
use HTTP::Tiny;
use JSON::XS;
use conf qw (loadConf);
use util qw (trim urlencode);
use version; our $VERSION = qw (1.0);
use Exporter qw (import);
our @EXPORT_OK = qw (weather);
my $c = loadConf ();
sub weather {
my $city = shift;
$city = trim $city;
return 'Мне нужно ИМЯ города.' if ($city eq '');
return 'Длинновато для названия города.' if (length ($city) > 80);
$city = ucfirst $city;
my $w = __weather ($city);
my $reply;
if ($w) {
if ($w->{temperature_min} == $w->{temperature_max}) {
$reply = sprintf ("Погода в городе %s, %s:\n%s, ветер %s %s м/c, температура %s°C, ощущается как %s°C, относительная влажность %s%%, давление %s мм.рт.с",
$w->{name},
$w->{country},
ucfirst ($w->{description}),
$w->{wind_direction},
$w->{wind_speed},
$w->{temperature_min},
$w->{temperature_feelslike},
$w->{humidity},
$w->{pressure}
);
} else {
$reply = sprintf ("Погода в городе %s, %s:\n%s, ветер %s %s м/c, температура %s-%s°C, ощущается как %s°C, относительная влажность %s%%, давление %s мм.рт.ст",
$w->{name},
$w->{country},
ucfirst ($w->{description}),
$w->{wind_direction},
$w->{wind_speed},
$w->{temperature_min},
$w->{temperature_max},
$w->{temperature_feelslike},
$w->{humidity},
$w->{pressure}
);
}
} else {
$reply = "Я не знаю, какая погода в $city";
}
return $reply;
}
sub __weather {
my $city = shift;
$city = urlencode $city;
my $id = md5_base64 $city;
my $appid = $c->{openweathermap}->{appid};
my $cachedir = $c->{openweathermap}->{cachedir};
my $cachetimefile = $cachedir . '/openweathermap.Id-Timestamp.db';
my $cachedatafile = $cachedir . '/openweathermap.Id-Data.db';
my $now = time ();
my $fc;
my $w;
unless (-d $cachedir) {
make_path ($cachedir) || do {
cluck "[ERROR] Unable to create $cachedir: $OS_ERROR";
return;
};
}
# attach to cache data
tie my %cachetime, 'DB_File', $cachetimefile or do {
carp "[ERROR] Something nasty happen when cachetime ties to its data: $OS_ERROR";
return undef;
};
tie my %cachedata, 'DB_File', $cachedatafile or do {
carp "[ERROR] Something nasty happen when cachedata ties to its data: $OS_ERROR";
return undef;
};
# lookup cache
if (defined ($cachetime{$id}) && ($now - $cachetime{$id}) < 10800) {
$fc = decode_json $cachedata{$id};
} else {
my $r;
# try 3 times and giveup
for (1..3) {
my $http = HTTP::Tiny->new (timeout => 3);
$r = $http->get (sprintf ('http://api.openweathermap.org/data/2.5/weather?q=%s&lang=ru&APPID=%s', $city, $appid));
if ($r->{success}) {
last;
}
sleep 2;
}
# all 3 times can give error, so check it here
if ($r->{success}) {
$fc = eval {
decode_json $r->{content};
};
if ($EVAL_ERROR) {
cluck "[WARN] openweathermap returns corrupted json: $EVAL_ERROR";
untie %cachetime;
untie %cachedata;
return undef;
};
$cachetime{$id} = $now;
$cachedata{$id} = encode_json $fc;
} else {
cluck sprintf 'Server return status %s with message: %s', $r->{status}, $r->{reason};
untie %cachetime;
untie %cachedata;
return undef;
}
}
untie %cachetime;
untie %cachedata;
# TODO: check all of this for existance
$w->{'name'} = $fc->{name};
$w->{'state'} = $fc->{state};
$w->{'country'} = $fc->{sys}->{country};
$w->{'longitude'} = $fc->{coord}->{lon};
$w->{'latitude'} = $fc->{coord}->{lat};
$w->{'temperature_min'} = int ($fc->{main}->{temp_min} - 273.15);
$w->{'temperature_max'} = int ($fc->{main}->{temp_max} - 273.15);
$w->{'temperature_feelslike'} = int ($fc->{main}->{feels_like} - 273.15);
$w->{'humidity'} = $fc->{main}->{humidity};
$w->{'pressure'} = int ($fc->{main}->{pressure} * 0.75006375541921);
$w->{'description'} = $fc->{weather}->[0]->{description};
$w->{'wind_speed'} = $fc->{wind}->{speed};
$w->{'wind_direction'} = 'разный';
my $dir = int ($fc->{wind}->{deg} + 0);
if ($dir == 0) {
$w->{'wind_direction'} = 'северный';
} elsif ($dir > 0 && $dir <= 30) {
$w->{'wind_direction'} = 'северо-северо-восточный';
} elsif ($dir > 30 && $dir <= 60) {
$w->{'wind_direction'} = 'северо-восточный';
} elsif ($dir > 60 && $dir < 90) {
$w->{'wind_direction'} = 'восточно-северо-восточный';
} elsif ($dir == 90) {
$w->{'wind_direction'} = 'восточный';
} elsif ($dir > 90 && $dir <= 120) {
$w->{'wind_direction'} = 'восточно-юго-восточный';
} elsif ($dir > 120 && $dir <= 150) {
$w->{'wind_direction'} = 'юговосточный';
} elsif ($dir > 150 && $dir < 180) {
$w->{'wind_direction'} = 'юго-юго-восточный';
} elsif ($dir == 180) {
$w->{'wind_direction'} = 'южный';
} elsif ($dir > 180 && $dir <= 210) {
$w->{'wind_direction'} = 'юго-юго-западный';
} elsif ($dir > 210 && $dir <= 240) {
$w->{'wind_direction'} = 'юго-западный';
} elsif ($dir > 240 && $dir < 270) {
$w->{'wind_direction'} = 'западно-юго-западный';
} elsif ($dir == 270) {
$w->{'wind_direction'} = 'западный';
} elsif ($dir > 270 && $dir <= 300) {
$w->{'wind_direction'} = 'западно-северо-западный';
} elsif ($dir > 300 && $dir <= 330) {
$w->{'wind_direction'} = 'северо-западный';
} elsif ($dir > 330 && $dir < 360) {
$w->{'wind_direction'} = 'северо-северо-западный';
} elsif ($dir == 360) {
$w->{'wind_direction'} = 'северный';
}
return $w;
}
1;
# vim: set ft=perl noet ai ts=4 sw=4 sts=4: