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

Refactor code. Fix some bugs.

Browse Source 
+ Use lazy brain init.
* Move plugin code out of botlib.pm.
+ Now bot can private chatting
* Properly detect real jid if can, extract username from jid
* Change chatid generation, so all previously generated brains will be lost
+ Add !dig and !копать commands
+ Add !cat and !кис commands
* Some other minor changes
This commit is contained in:
eleksir
2021-01-07 16:13:29 +03:00
parent 4c7cf8ceca
commit b4a1bf66cf
15 changed files with 1038 additions and 428 deletions
Download Patch File Download Diff File Expand all files Collapse all files

126
lib/archeologist.pm Normal file
View File

@@ -0,0 +1,126 @@
package archeologist;
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use vars qw/$VERSION/;
use Exporter qw (import);
our @EXPORT_OK = qw (dig);
$VERSION = '1.0';
sub dig {
my $name = shift;
my @artifact = (
'амулет Мерлина',
'библиотеку Ивана Грозного',
'деревянную плошку',
'диплока',
'доски Ноева Ковчега',
'древний презерватив из бараньей кишки',
'икону',
'инсталятор Windows 3.11',
'истлевший гроб',
'каменный топор',
'клад со златом-серебром',
'кривой нож',
'ледяную глыбу',
'лунный грунт',
'мамонта',
'мамонтенка',
'метеорит',
'мумию фараона Тутанхамона',
'носки прапорщика (поставит в угол)',
'обломки грузинской керамики',
'птеродактиля',
'рубль с Лениным',
'рыцарские доспехи',
'синий мох',
'скелет',
'скелет собаки по кличке Беня',
'тиранозавтра',
'тотем индейцев',
'трубу с туркменским газом',
'скорбь еврейского народа',
'залежи активированного угля',
'не очень новый завет',
'мать леннарта поттеринга',
'руководство "начинающему археологу"',
'слово о полку игореве и дело о полку игореве, вместе с игорем',
'телепрограмму канала A-one',
'могилу искателя могил',
'заплесневевший кусок хлеба',
'преемник радиоприемника',
'глушитель от ВАЗ-2106',
'чувство удовлетворения',
'крота',
'воспоминания о былой любви',
'грязистор',
'египетское мумиё',
'окаменелый камень',
'кладку яиц рептилоида',
'яму',
'чеснок и стрелы',
'доллар по 30',
'несмазанные скрижали',
'четырелобита',
'чучело тролля',
'целое ничего',
);
my @location = (
'в архивах',
'в гималаях',
'в интернете',
'в кармане',
'в клумбе',
'в лунном кратере',
'во льдах арктики',
'в морге',
'в окрестностях погоста',
'в песочнице',
'в пустыне Гоби',
'в пустыне Сахаре',
'в русле высохшей реки',
'в собственной памяти',
'в старом сортире',
'в углу',
'в цветочном горшке',
'на бабушкином огороде',
'на винчестере',
'на горе Арарат',
'на горном плато',
'на дне моря',
'на необитаемом острове',
'на первом слое сумрака',
'на просторах Украины',
);
my $find_probability = int (rand 100);
my $success_probability = int (rand 100);
my $artifact_age = int (rand 15000);
if ($find_probability <= 20) {
return sprintf 'По уши закопавшись %s, %s, нифига вы не выкопали! Может повезет в другом месте?', $location[int (rand ($#location + 1))], $name;
}
my $phrase = sprintf "Вы начали раскопки %s и усиленно роете лопатами, экскаватором...\n", $location[int (rand ($#location + 1))];
$phrase .= "Вам кажется что ваш совочек ударился обо что-то твердое. Может, это клад?!\n\n";
if ($success_probability <= 25) {
$phrase .= sprintf '%s стал лучшим археологом, выкопав %s! возраст артефакта - %s лет!', $name, $artifact[int (rand ($#artifact + 1))], $artifact_age;
} else {
$phrase .= sprintf "Поздравляю, %s! Вы только что выкопали %s, возраст - %s лет!\n", $name, $artifact[int (rand ($#artifact + 1))], $artifact_age;
$phrase .= sprintf 'Извини %s, но на артефакт это не тянет! Однако, попытка хорошая!', $name;
}
return $phrase;
}
1;
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

469
lib/botlib.pm
View File

@@ -4,202 +4,26 @@ use 5.018;
use strict;
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);
use Digest::MD5 qw(md5_base64);
use DB_File;
use conf qw(loadConf);
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use Carp qw (carp);
use archeologist qw (dig);
use conf qw (loadConf);
use fortune qw (fortune);
use friday qw (friday);
use karma qw (karmaGet);
use kitty qw (kitty);
use lat qw (latAnswer);
use util qw (trim utf2sha1);
use weather qw (weather);
use vars qw/$VERSION/;
use Exporter qw(import);
our @EXPORT_OK = qw(weather trim randomCommonPhrase);
our @EXPORT_OK = qw(command randomCommonPhrase realjid);
$VERSION = '1.0';
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 $now = time ();
my $fc;
my $w;
# attach to cache data
tie my %cachetime, 'DB_File', $c->{openweathermap}->{cachetime} or do {
carp "Something nasty happen when cachetime ties to its data: $OS_ERROR";
return undef;
};
tie my %cachedata, 'DB_File', $c->{openweathermap}->{cachedata} or do {
carp "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 __urlencode($) {
my $str = shift;
my $urlobj = url $str;
$str = $urlobj->as_string;
$urlobj = undef; undef $urlobj;
return $str;
}
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 = (
'Так, блядь...',
@@ -214,7 +38,272 @@ sub randomCommonPhrase () {
'А как ты думаешь?',
);
return $myphrase[rand($#myphrase -1)];
return $myphrase[int (rand ($#myphrase + 1))];
}
sub command {
my %hash = @_;
my $bot = $hash{bot_object};
my $text = $hash{body};
my %jid = realjid (%hash);
my $chattername = $jid{'name'};
my $chatid;
if ($hash{'type'} eq 'groupchat') {
$chatid = utf2sha1 $hash{'reply_to'};
} else {
$chatid = utf2sha1 $jid{'name'};
}
$chatid =~ s/\//-/xmsg;
%jid = (); undef %jid;
my $csign = $c->{jabberbot}->{aleesa}->{csign};
my $reply;
if (substr ($text, 1, 3) eq 'rum' || substr ($text, 1, 3) eq 'ром') {
my $target;
if (($hash{'type'} eq 'groupchat') && (length ($text) > 5)) {
$target = trim (substr $text, 5);
}
if (! defined $target || ($target eq '')) {
$target = $chattername;
}
$reply = '/me притаскивает на подносе стопку рома для ' . $target . ', края стопки искрятся кристаллами соли.';
} elsif (substr ($text, 1, 5) eq 'vodka' || substr ($text, 1, 5) eq 'водка') {
my $target;
if (($hash{'type'} eq 'groupchat') && (length ($text) > 7)) {
$target = trim (substr $text, 7);
}
if (! defined $target || ($target eq '')) {
$target = $chattername;
}
$reply = '/me подаёт шот водки с небольшим маринованным огурчиком на блюдце для ' . $target . '. Из огурчика торчит небольшая вилочка.';
} elsif (substr ($text, 1, 4) eq 'beer' || substr ($text, 1, 4) eq 'пиво') {
my $target;
if (($hash{'type'} eq 'groupchat') && (length ($text) > 6)) {
$target = trim (substr $text, 6);
}
if (! defined $target || ($target eq '')) {
$target = $chattername;
}
$reply = '/me бахает об стол перед ' . $target . ' кружкой холодного пива, часть пенной шапки сползает по запотевшей стенке кружки.';
} elsif (substr ($text, 1, 7) eq 'tequila') {
my $target;
if (($hash{'type'} eq 'groupchat') && (length ($text) > 9)) {
$target = trim (substr $text, 9);
}
if (! defined $target || ($target eq '')) {
$target = $chattername;
}
$reply = '/me ставит рядом с ' . $target . ' шот текилы, аккуратно на ребро стопки насаживает дольку лайма и ставит кофейное блюдце с горочкой соли.';
} elsif (substr ($text, 1, 6) eq 'текила') {
my $target;
if (($hash{'type'} eq 'groupchat') && (length ($text) > 8)) {
$target = trim (substr $text, 8);
}
if (! defined $target || ($target eq '')) {
$target = $chattername;
}
$reply = '/me ставит рядом с ' . $target . ' шот текилы, аккуратно на ребро стопки насаживает дольку лайма и ставит кофейное блюдце с горочкой соли.';
} elsif (substr ($text, 1, 6) eq 'whisky') {
my $target;
if (($hash{'type'} eq 'groupchat') && (length ($text) > 8)) {
$target = trim (substr $text, 8);
}
if (! defined $target || ($target eq '')) {
$target = $chattername;
}
$reply = '/me демонстративно достаёт из морозилки пару кубических камушков, бросает их в толстодонный стакан и аккуратно наливает Jack Daniels. Запускает стакан вдоль барной стойки, он останавливается около ' . $target . '.';
} elsif (substr ($text, 1, 5) eq 'виски') {
my $target;
if (($hash{'type'} eq 'groupchat') && (length ($text) > 7)) {
$target = trim (substr $text, 7);
}
if (! defined $target || ($target eq '')) {
$target = $chattername;
}
$reply = '/me демонстративно достаёт из морозилки пару кубических камушков, бросает их в толстодонный стакан и аккуратно наливает Jack Daniels. Запускает стакан вдоль барной стойки, он останавливается около ' . $target . '.';
} elsif (substr ($text, 1, 8) eq 'absinthe') {
my $target;
if (($hash{'type'} eq 'groupchat') && (length ($text) > 10)) {
$target = trim (substr $text, 10);
}
if (! defined $target || ($target eq '')) {
$target = $chattername;
}
$reply = '/me наливает абсент в стопку. Смочив кубик сахара в абсенте кладёт его на дырявую ложечку и пожигает. Как только пламя потухнет, ' . $bot->{'alias'} . ' размешивает оплавившийся кубик в абсенте и подносит стопку ' . $target . '.';
} elsif (substr ($text, 1, 6) eq 'абсент') {
my $target;
if (($hash{'type'} eq 'groupchat') && (length ($text) > 8)) {
$target = trim (substr $text, 8);
}
if (! defined $target || ($target eq '')) {
$target = $chattername;
}
$reply = '/me наливает абсент в стопку. Смочив кубик сахара в абсенте кладёт его на дырявую ложечку и пожигает. Как только пламя потухнет, ' . $bot->{'alias'} . ' размешивает оплавившийся кубик в абсенте и подносит стопку ' . $target . '.';
} elsif (substr ($text, 1, 2) eq 'w ' || substr ($text, 1, 2) eq 'п ') {
my $city = substr $text, 2;
$reply = weather ($city) =~ tr/\n/ /r;
} elsif (substr ($text, 1) eq 'version' || substr ($text, 1) eq 'ver') {
$reply = 'Версия нуль.чего-то_там.чего-то_там';
} elsif (substr ($text, 1) eq 'help' || substr ($text, 1) eq 'помощь') {
$reply = <<"EOL";
${csign}help | ${csign}помощь - это сообщение
${csign}cat | ${csign}кис - кошечка
${csign}dig | ${csign}копать - заняться археологией
${csign}f | ${csign}ф - рандомная фраза из сборника цитат fortune_mod
${csign}fortune | ${csign}фортунка - рандомная фраза из сборника цитат fortune_mod
${csign}friday | ${csign}пятница - а не пятница ли сегодня?
${csign}karma фраза - посмотреть карму фразы
${csign}карма фраза - посмотреть карму фразы
фраза++ | фраза-- - повысить или понизить карму фразы
${csign}lat | ${csign}лат - сгенерировать фразу из крылатого латинского выражения
${csign}ping | ${csign}пинг - попинговать бота
${csign}some_brew - выдать соответствующий напиток, бармен может налить rum, ром, vodka, водку, beer, пиво, tequila, текила, whisky, виски, absinthe, абсент
${csign}ver | ${csign}version - написать что-то про версию ПО
${csign}версия - написать что-то про версию ПО
${csign}w город | ${csign}п город - погода в городе
EOL
} elsif (substr ($text, 1) eq 'lat' || substr ($text, 1) eq 'лат') {
$reply = latAnswer ();
} elsif (substr ($text, 1) eq 'cat' || substr ($text, 1) eq 'кис') {
$reply = kitty ();
} elsif (substr ($text, 1) eq 'dig' || substr ($text, 1) eq 'копать') {
$reply = dig ($chattername);
} elsif ((length ($text) >= 6 && (substr ($text, 1, 6) eq 'karma ' || substr ($text, 1, 6) eq 'карма ')) || substr ($text, 1) eq 'karma' || substr ($text, 1) eq 'карма') {
my $mytext = '';
if (length ($text) > 6) {
$mytext = substr $text, 7;
chomp $mytext;
$mytext = trim $mytext;
} else {
$mytext = '';
}
$reply = karmaGet ($chatid, $mytext);
} elsif (substr ($text, 1) eq 'friday' || substr ($text, 1) eq 'пятница') {
$reply = friday ();
} elsif (substr ($text, 1) eq 'fortune' || substr ($text, 1) eq 'фортунка' || substr ($text, 1) eq 'f' || substr ($text, 1) eq 'ф') {
my $phrase = fortune ();
# workaround Net::Jabber::Bot outgoing message ![:print:] replacement
$phrase =~ s/\s\s+\-\-/\n \-\-/xmsg;
$reply = $phrase;
} elsif (substr ($text, 1) eq 'ping') {
$reply = 'Pong.';
} elsif (substr ($text, 1) eq 'пинг') {
$reply = 'Понг.';
}
return $reply;
}
# in this particular case real jid is really hidden :) and i hope that i found where it is seaking.
sub realjid {
my %hash = @_;
my $bot = $hash{'bot_object'};
my $myjid = $hash{'from_full'}; # in case of real jid myjid is name@server/resource in case of "groupchat" jid it is group@conf_server/name
my $presencedb = $bot->{'jabber_client'}->{'PRESENCEDB'};
my %result;
# there is missing case where user' name part of jid same as chat name (sic!)
# in case of groupchat we have to compare reply_to and 1-st part of myjid (one that before slash)
# in case 1-on-1 chat we have to compare 2-nd component of myjid (that between @ and /) and conference server
# assuming that bot sits only on same conference server where bot is registered
if (
(($hash{'reply_to'} eq (split (/\//, $myjid))[0]) && ($hash{'type'} eq 'groupchat')) ||
(($bot->{'conference_server'} eq (split (/\@/, (split (/\//, $myjid))[0]))[1]) && ($hash{'type'} eq 'chat'))
) {
foreach my $knownjid (keys %{$presencedb}) {
foreach my $prionum (keys %{$presencedb->{$knownjid}->{'priorities'}}) {
foreach my $presence (@{$presencedb->{$knownjid}->{'priorities'}->{$prionum}}) {
if ($presence->{'presence'}->{'TREE'}->{'ATTRIBS'}->{'from'} eq $myjid) {
foreach my $child (@{$presence->{'presence'}->{'TREE'}->{'CHILDREN'}}) {
() = eval {
$child->{'CHILDREN'};
};
unless ($EVAL_ERROR) {
foreach my $subchild ($child->{'CHILDREN'}) {
foreach my $elem (@{$subchild}) {
() = eval {
$elem->{'ATTRIBS'};
};
unless ($EVAL_ERROR) {
() = eval {
$elem->{'ATTRIBS'}->{'jid'};
};
unless ($EVAL_ERROR) {
if (defined $elem->{'ATTRIBS'}->{'jid'}) {
%result = (
'fulljid' => $elem->{'ATTRIBS'}->{'jid'},
'jid' => (split (/\//, $elem->{'ATTRIBS'}->{'jid'})) [0],
'name' => (split (/\@/, $elem->{'ATTRIBS'}->{'jid'})) [0],
);
return %result;
}
}
}
}
}
}
}
}
}
}
}
# we tried hard :( and if we here, assume that we have no permissions to to guess real jid in chat
%result = (
'fulljid' => $myjid,
'jid' => $myjid,
'name' => (split (/\//, $myjid))[1],
);
} else {
# looks like it is correct real jid, assume that conference server and main server are woking on different domains
# at least i hope that this assumption correct
%result = (
'fulljid' => $myjid,
'jid' => (split (/\//, $myjid))[0],
'name' => (split (/\@/, $myjid))[0],
);
}
return %result;
}
1;

2
lib/conf.pm
View File

@@ -17,7 +17,7 @@ $VERSION = '1.0';
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 $len = (stat $c) [7];
my $json;
my $readlen = read $CH, $json, $len;

30
lib/fortune.pm
View File

@@ -5,26 +5,26 @@ use 5.018;
use strict;
use warnings;
use utf8;
use open qw(:std :utf8);
use English qw( -no_match_vars );
use Carp qw(cluck croak);
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use Carp qw (croak carp);
use SQLite_File;
use MIME::Base64;
use File::Path qw(mkpath);
use conf qw(loadConf);
use File::Path qw (make_path);
use conf qw (loadConf);
use vars qw/$VERSION/;
use Exporter qw(import);
our @EXPORT_OK = qw(seed fortune);
$VERSION = '1.0';
my $c = loadConf();
my $c = loadConf ();
my $dir = $c->{fortune}->{dir};
my $srcdir = $c->{fortune}->{srcdir};
sub seed () {
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;
@@ -34,19 +34,25 @@ sub seed () {
}
tie my @fortune, 'SQLite_File', $backingfile || croak "Unable to tie to $backingfile: $OS_ERROR\n";
opendir (my $srcdirhandle, $srcdir) || croak "Unable to open $srcdir: $OS_ERROR";
while (my $fortunefile = readdir ($srcdirhandle)) {
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\n";
# set correct phrase delimiter
local $INPUT_RECORD_SEPARATOR = "\n%\n";
while (readline $fh) {
my $phrase = substr($_, 0, -3);
my $phrase = substr $_, 0, -3;
push @fortune, $phrase;
}
@@ -63,7 +69,7 @@ sub fortune () {
my $backingfile = sprintf '%s/fortune.sqlite', $dir;
tie my @array, 'SQLite_File', $backingfile || do {
cluck "Unable to tie to $backingfile: $OS_ERROR\n";
carp "Unable to tie to $backingfile: $OS_ERROR\n";
return '';
};

47
lib/friday.pm
View File

@@ -5,27 +5,26 @@ use 5.018;
use strict;
use warnings;
use utf8;
use open qw(:std :utf8);
use English qw( -no_match_vars );
use Carp qw(cluck croak);
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use Carp qw (carp croak);
use File::Path qw (make_path);
use SQLite_File;
use MIME::Base64;
use File::Path qw(mkpath);
use conf qw(loadConf);
use conf qw (loadConf);
use vars qw/$VERSION/;
use Exporter qw(import);
our @EXPORT_OK = qw(seed friday);
use Exporter qw (import);
our @EXPORT_OK = qw (seed friday);
$VERSION = '1.0';
my $c = loadConf();
my $c = loadConf ();
my $dir = $c->{friday}->{dir};
my $srcfile = $c->{friday}->{src};
my @dow = qw (monday tuesday wednesday thursday friday saturday sunday);
sub seed () {
unless (-d $dir) {
mkpath ($dir) || croak "Unable to create $dir: $OS_ERROR";
make_path ($dir) || croak "Unable to create $dir: $OS_ERROR";
}
my $friday;
@@ -43,31 +42,45 @@ sub seed () {
open (my $fh, '<', $srcfile) || croak "Unable to open $srcfile, $OS_ERROR\n";
while (readline $fh) {
next unless m/ \|\| /xmsg;
unless (m/ \|\| /xmsg) {
next;
}
chomp();
my ($phrase, $days) = split(/ \|\| /);
my @daylist = split(//, $days);
foreach my $day (@daylist) {
next unless (defined $day);
next unless ($day =~ /^\d$/);
push @{$friday->[$day - 1]}, $phrase if (defined $phrase && ($phrase ne '') && ($phrase !~ m/^\s+$/xmsg));
unless (defined $day) {
next ;
}
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)
for (0..$#dow) { untie $friday->[$_]; }
for (0..$#dow) {
untie $friday->[$_];
}
return;
}
# just return answer
sub friday () {
my $today = (localtime(time))[6] - 1;
my $today = (localtime (time))[6] - 1;
my $backingfile = sprintf '%s/%s.sqlite', $dir, $dow[$today];
tie my @array, 'SQLite_File', $backingfile || do {
cluck "Unable to tie to $backingfile: $OS_ERROR\n";
carp "[ERROR] Unable to tie to $backingfile: $OS_ERROR\n";
return '';
};

223
lib/jabberbot.pm
View File

@@ -7,22 +7,23 @@ use 5.018;
use strict;
use warnings;
use utf8;
use open qw(:std :utf8);
use Net::Jabber::Bot;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use Carp qw(carp);
use File::Path qw (make_path);
use Hailo;
use conf qw(loadConf);
use botlib qw(weather trim randomCommonPhrase);
use lat qw(latAnswer);
use karma qw(karmaSet karmaGet);
use friday qw(friday);
use fortune qw(fortune);
use Net::Jabber::Bot;
use botlib qw (command randomCommonPhrase realjid);
use conf qw (loadConf);
use karma qw (karmaSet);
use util qw (trim utf2sha1);
use Exporter qw(import);
use Exporter qw (import);
use vars qw/$VERSION/;
$VERSION = '1.0';
our @EXPORT_OK = qw(run_jabberbot);
our @EXPORT_OK = qw (run_jabberbot);
my $c = loadConf();
my $c = loadConf ();
my $hailo;
my $imonline = 0;
@@ -40,128 +41,94 @@ sub __background_checks {
sub __new_bot_message {
my %hash = @_;
my $bot = $hash{bot_object};
# ignore self messages
if ($hash{'from_full'} eq $bot->{'from_full'}) {
return;
}
my $text = $hash{body};
my %jid = realjid (%hash);
my $chattername = $jid{'name'};
my $chatid;
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'}, 'Чего тебе?');
} elsif ($text =~ /^$qname[\,|\:]? (.+)/) {
$bot->SendGroupMessage ($hash{'reply_to'}, $hailo->learn_reply($1));
} elsif ($text eq "$c->{jabberbot}->{aleesa}->{csign}пинг") {
$bot->SendGroupMessage ($hash{'reply_to'}, 'Понг.');
} elsif ($text eq "$c->{jabberbot}->{aleesa}->{csign}ping") {
$bot->SendGroupMessage ($hash{'reply_to'}, 'Pong.');
} elsif (substr ($text, 0, 1) eq $c->{jabberbot}->{aleesa}->{csign}) {
if (substr ($text, 1, 3) eq 'rum') {
eval {
$bot->SendGroupMessage (
$hash{'reply_to'},
'/me притаскивает на подносе стопку рома для ' . (split (/\//,$hash{from_full}))[1] . ', края стопки искрятся кристаллами соли.'
);
};
} elsif (substr ($text, 1, 5) eq 'vodka') {
eval {
$bot->SendGroupMessage (
$hash{'reply_to'},
'/me подаёт водку с маринованным огурчиком для ' . (split (/\//,$hash{from_full}))[1]
);
};
} elsif (substr($text, 1, 4) eq 'beer') {
eval {
$bot->SendGroupMessage (
$hash{'reply_to'},
'/me бахает об стол перед ' . (split (/\//,$hash{from_full}))[1] . ' кружкой холодного пива, часть пенной шапки сползает по запотевшей спенке кружки.'
);
};
} elsif (substr($text, 1, 7) eq 'tequila') {
eval {
$bot->SendGroupMessage (
$hash{'reply_to'},
'/me ставит рядом с ' . (split (/\//,$hash{from_full}))[1] . ' шот текилы, аккуратно на ребро стопки насаживает дольку лайма и ставит кофейное блюдце с горочкой соли.'
);
};
} elsif (substr ($text, 1, 6) eq 'whisky') {
eval {
$bot->SendGroupMessage (
$hash{'reply_to'},
'/me демонстративно достаёт из морозилки пару кубических камушков, бросает их в толстодонный стакан и аккуратно наливает Jack Daniels. Запускает стакан вдоль барной стойки, он останавливается около ' . (split (/\//,$hash{from_full}))[1] . '.'
);
};
} elsif (substr ($text, 1, 8) eq 'absinthe') {
eval {
$bot->SendGroupMessage (
$hash{'reply_to'},
"/me наливает абсент в стопку. Смочив кубик сахара в абсенте кладёт его на дырявую ложечку и пожигает. Как только пламя потухнет, $c->{jabberbot}->{aleesa}->{mucname} размешивает оплавившийся кубик в абсенте и подносит стопку " .(split (/\//,$hash{from_full}))[1] . '.'
);
};
} elsif (substr ($text, 1, 2) eq 'w ' || substr ($text, 1, 2) eq 'п ') {
my $city = substr ($text, 2);
$chatid = utf2sha1 $hash{'reply_to'};
} else {
$chatid = utf2sha1 $jid{'name'};
}
eval {
$bot->SendGroupMessage (
$hash{'reply_to'},
weather($city) =~ tr/\n/ /r
);
};
} elsif (substr ($text, 1) eq 'version' || substr ($text, 1) eq 'ver') {
$bot->SendGroupMessage ($hash{'reply_to'}, 'Версия нуль.чего-то_там.чего-то_там');
} elsif (substr ($text, 1) eq 'help' || substr ($text, 1) eq 'помощь') {
$bot->SendGroupMessage ($hash{'reply_to'}, <<"EOL" );
!help | !помощь - это сообщение
!f | !ф | !fortune | !фортунка - рандомная фраза из сборника цитат fortune_mod
!friday | !пятница - а не пятница ли сегодня?
!lat | !лат - сгенерировать фразу из крылатого латинского выражения
!ping | !пинг - попинговать бота
!some_brew - выдать соответсвующий напиток, бармен может налить rum, vodka, beer, tequila, whisky, absinthe
!ver | !version | !версия - написать что-то про версию ПО
!w город | !п город - погода в городе
!karma фраза | !карма фраза - посмотреть карму фразы
фраза++ | фраза-- - повысить или понизить карму фразы
EOL
$chatid =~ s/\//-/xmsg;
} elsif (substr ($text, 1) eq 'lat' || substr ($text, 1) eq 'лат') {
$bot->SendGroupMessage ($hash{'reply_to'}, latAnswer ());
} elsif (substr ($text, 1, 6) eq 'karma ' || substr($text, 1, 6) eq 'карма ' || substr ($text, 1) eq 'karma' || substr ($text, 1) eq 'карма') {
my $mytext = substr ($text, 7);
my $reply;
if ($mytext ne '') {
chomp $mytext;
$mytext = trim $mytext;
}
# lazy init chat-bot brains
unless (defined ($hailo->{$chatid})) {
my $braindir = $c->{jabberbot}->{braindir};
my $brainname = sprintf '%s/%s.sqlite', $braindir, $chatid;
$bot->SendGroupMessage ($hash{'reply_to'}, karmaGet ($hash{'reply_to'}, $mytext));
} elsif (substr ($text, 1) eq 'friday' || substr ($text, 1) eq 'пятница') {
$bot->SendGroupMessage ($hash{'reply_to'}, friday ());
} elsif (substr ($text, 1) eq 'fortune' || substr ($text, 1) eq 'фортунка' || substr ($text, 1) eq 'f' || substr ($text, 1) eq 'ф') {
my $phrase = fortune ();
# workaround Net::Jabber::Bot outgoing message ![:print:] replacement
$phrase =~ s/\s\s+\-\-/\n \-\-/xmsg;
$bot->SendGroupMessage ($hash{'reply_to'}, $phrase);
} else {
$hailo->learn ($text);
unless (-d $braindir) {
make_path ($braindir) or do {
carp "[ERROR] Unable to create $braindir: $OS_ERROR";
return;
}
} elsif ((substr ($text, -2) eq '++') || (substr ($text, -2) eq '--')) {
my @arr = split (/\n/, $text);
if ($#arr < 1) {
my $reply = karmaSet($hash{'reply_to'}, substr ($text, 0, -2), substr ($text, -2));
$bot->SendGroupMessage ($hash{'reply_to'}, $reply);
} else {
# just message in chat
$hailo->learn ($text);
}
} else {
$hailo->learn ($text);
return;
};
}
$hailo->{$chatid} = Hailo->new (
brain => $brainname,
order => 2
);
if ($hash{'type'} eq 'groupchat') {
carp "[INFO] Initialized brain for chat $hash{'reply_to'}: $brainname";
} else {
carp "[INFO] Initialized brain for chat $jid{'jid'}: $brainname";
}
}
# parse messages
my $qname = quotemeta ($bot->{'alias'});
if ($text =~ /^$qname\,?\s*$/) {
$reply = 'Чего тебе?';
} elsif (($text =~ /^$qname[\,|\:]? (.+)/) && ($hash{'type'} eq 'groupchat')) {
$reply = $hailo->{$chatid}->learn_reply ($1);
} elsif (substr ($text, 0, 1) eq $c->{jabberbot}->{aleesa}->{csign}) {
$reply = command (%hash);
# karma agjustment
} elsif (substr ($text, -2) eq '++' || substr ($text, -2) eq '--') {
my @arr = split(/\n/, $text);
if ($#arr < 1) {
$reply = karmaSet ($chatid, trim (substr ($text, 0, -2)), substr ($text, -2));
} else {
# just message in chat
# in groupchat we answer only to phrases that mention us
if ($hash{'type'} eq 'groupchat') {
$hailo->{$chatid}->learn ($text);
# in tet-a-tet chat we must always answer, if possible
} elsif ($hash{'type'} eq 'chat') {
$reply = $hailo->{$chatid}->learn_reply ($text);
}
}
# just message in chat
} else {
# in groupchat we answer only to phrases that mention us
if ($hash{'type'} eq 'groupchat') {
$hailo->{$chatid}->learn ($text);
# in tet-a-tet chat we must always answer, if possible
} elsif ($hash{'type'} eq 'chat') {
$reply = $hailo->{$chatid}->learn_reply ($text);
}
}
if (defined $reply && ($reply ne '')) {
if ($hash{'type'} eq 'groupchat') {
$bot->SendGroupMessage ($hash{'reply_to'}, $reply);
} elsif ($hash{'type'} eq 'chat') {
$bot->SendPersonalMessage ($hash{'reply_to'}, $reply);
}
} elsif ($hash{'type'} eq 'chat') {
$bot->SendPersonalMessage ($hash{'reply_to'}, 'Я вас не знаю, идите нахуй.');
return;
}
return;
@@ -169,11 +136,6 @@ EOL
sub run_jabberbot {
$hailo = Hailo->new (
brain => $c->{jabberbot}->{aleesa}->{brain},
order => 2
);
my %conflist = ();
$conflist{$c->{jabberbot}->{aleesa}->{room}} = [];
my $qname = quotemeta ($c->{jabberbot}->{aleesa}->{mucname});
@@ -182,7 +144,8 @@ sub run_jabberbot {
server => $c->{jabberbot}->{aleesa}->{host},
server_host => $c->{jabberbot}->{aleesa}->{host},
conference_server => $c->{jabberbot}->{aleesa}->{confsrv},
tls => 0,
tls => 1,
ssl_verify => 0,
username => $c->{jabberbot}->{aleesa}->{authname},
# threre is some nasty bug in module, so we have to set from_full explicitly
from_full => sprintf (

51
lib/karma.pm
View File

@@ -4,16 +4,17 @@ 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 open qw (:std :utf8);
use English qw ( -no_match_vars );
use Carp qw (carp);
use DB_File;
use Carp qw(cluck);
use conf qw(loadConf);
use File::Path qw (make_path);
use conf qw (loadConf);
use util qw (utf2sha1);
use vars qw/$VERSION/;
use Exporter qw(import);
our @EXPORT_OK = qw(karmaSet karmaGet);
use Exporter qw (import);
our @EXPORT_OK = qw (karmaSet karmaGet);
$VERSION = '1.0';
my $c = loadConf ();
@@ -27,24 +28,29 @@ sub karmaSet (@) {
my $action = shift;
my $score = 0;
# sha1* does not understand utf8, so explicitly construct string cost of decimal numbers only
my $karmafile = join ('', unpack ('C*', $chatid));
$karmafile = sha1_base64 ($karmafile);
# sha1 string can contain slashes, so make a bit longer string consist of only decimal numbers
$karmafile = join ('', unpack ('C*', $karmafile));
my $karmafile = utf2sha1 $chatid;
$karmafile =~ s/\//-/xmsg;
$karmafile = sprintf '%s/%s.db', $karmadir, $karmafile;
if (($phrase eq '') || ($phrase =~ /^ +$/)) {
$phrase = '';
}
unless (-d $karmadir) {
make_path ($karmadir) or do {
carp "Unable to create $karmadir: $OS_ERROR";
return sprintf 'Карма %s составляет 0', $phrase;
};
}
# init hash, store phrase and score
tie my %karma, 'DB_File', $karmafile || do {
cluck "Something nasty happen when cachedata ties to its data: $OS_ERROR";
carp "[ERROR] Something nasty happen when cachedata ties to its data: $OS_ERROR";
return sprintf 'Карма %s составляет 0', $phrase;
};
# bdb does not understand utf8, so tied hash too, we do not want store original phrase anyway
my $sha1_phrase = sha1_base64 (join ('', unpack ('C*', $phrase)));
my $sha1_phrase = utf2sha1 $phrase;
if (defined $karma{$sha1_phrase}) {
if ($action eq '++') {
@@ -85,25 +91,28 @@ sub karmaSet (@) {
sub karmaGet (@) {
my $chatid = shift;
my $phrase = shift;
# sha1* does not understand utf8, so explicitly construct string cost of decimal numbers only
my $karmafile = join ('', unpack ('C*', $chatid));
$karmafile = sha1_base64 ($karmafile);
# sha1 string can contain slashes, so make a bit longer string consist of only decimal numbers
$karmafile = join ('', unpack ('C*', $karmafile));
my $karmafile = utf2sha1 $chatid;
$karmafile =~ s/\//-/xmsg;
$karmafile = sprintf '%s/%s.db', $karmadir, $karmafile;
if (($phrase eq '') || ($phrase =~ /^ +$/)) {
$phrase = '';
}
unless (-d $karmadir) {
make_path ($karmadir) or do {
carp "Unable to create $karmadir: $OS_ERROR";
return sprintf 'Карма %s составляет 0', $phrase;
};
}
# init hash, store phrase and score
tie my %karma, 'DB_File', $karmafile || do {
cluck "Something nasty happen when karma ties to its data: $OS_ERROR";
carp "[ERROR] Something nasty happen when karma ties to its data: $OS_ERROR";
return sprintf 'Карма %s составляет 0', $phrase;
};
# bdb does not understand utf8, so tied hash too, we do not want store original phrase anyway
my $sha1_phrase = sha1_base64 (join ('', unpack ('C*', $phrase)));
my $sha1_phrase = utf2sha1 $phrase;
my $score = $karma{$sha1_phrase};
untie %karma;

54
lib/kitty.pm Normal file
View File

@@ -0,0 +1,54 @@
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 (carp);
use JSON::XS;
use HTTP::Tiny;
use vars qw/$VERSION/;
use Exporter qw (import);
our @EXPORT_OK = qw (kitty);
$VERSION = '1.0';
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) {
carp "[ERROR] Unable to decode JSON: $EVAL_ERROR";
} else {
if ($jcat->[0]->{url}) {
$ret = $jcat->[0]->{url};
}
}
} else {
carp 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:

39
lib/lat.pm
View File

@@ -5,30 +5,29 @@ 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 open qw (:std :utf8);
use English qw ( -no_match_vars );
use Carp qw (carp);
use File::Basename qw (dirname);
use File::Path qw (make_path);
use Hailo;
use File::Basename qw(dirname);
use File::Path qw(mkpath);
use conf qw(loadConf);
use conf qw (loadConf);
use vars qw/$VERSION/;
use Exporter qw(import);
our @EXPORT_OK = qw(train latAnswer);
use Exporter qw (import);
our @EXPORT_OK = qw (train latAnswer);
$VERSION = '1.0';
my $c = loadConf();
my $c = loadConf ();
my $brain = $c->{lat}->{brain};
my $srcfile = $c->{lat}->{src};
# swallow phrase and return answer
sub train () {
my $braindir = dirname ($brain);
my $braindir = dirname $brain;
unless (-d $braindir) {
mkpath ($braindir) or do {
cluck "Unable to create $braindir: $OS_ERROR";
make_path ($braindir) or do {
carp "Unable to create $braindir: $OS_ERROR";
exit 1;
};
}
@@ -39,24 +38,24 @@ sub train () {
order => 2
);
$lat->train($srcfile);
my ($tokens, $expressions) = ($lat->stats())[0,1];
$lat->train ($srcfile);
my ($tokens, $expressions) = ($lat->stats ())[0,1];
printf "Total tokens: %s\nTotal expressins: %s\n", $tokens, $expressions;
$lat->save();
$lat->save ();
return;
}
# just return answer
sub latAnswer () {
my $braindir = dirname ($brain);
my $braindir = dirname $brain;
unless (-d $braindir) {
cluck "No lat module data: $braindir is absent! Train lat first.";
carp "[ERROR] No lat module data: $braindir is absent! Train lat first.";
return '';
}
unless (-f $brain) {
cluck "No lat module data: $brain is absent! Train lat first.";
carp "[ERROR] No lat module data: $brain is absent! Train lat first.";
return '';
}
@@ -67,7 +66,7 @@ sub latAnswer () {
save_on_exit => 0
);
return $lat->reply();
return $lat->reply ();
}
1;

117
lib/util.pm Normal file
View File

@@ -0,0 +1,117 @@
package util;
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 Digest::SHA qw (sha1_base64);
use Encode;
use MIME::Base64;
use Text::Fuzzy qw (distance_edits);
use URI::URL;
use vars qw /$VERSION/;
use Exporter qw (import);
our @EXPORT_OK = qw (trim urlencode fmatch utf2b64 utf2sha1);
$VERSION = '1.0';
sub trim {
my $str = shift;
unless (defined $str) {
cluck '[ERROR] Str is undefined';
return '';
}
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;
unless (defined $str) {
cluck '[ERROR] Str is undefined';
return '';
}
my $urlobj = url $str;
return $urlobj->as_string;
}
sub fmatch {
my $srcphrase = shift;
my $answer = shift;
if ((! defined $srcphrase) || (! defined $answer)) {
if (defined $srcphrase) {
cluck '[ERROR] Answer undefined';
} elsif (defined $answer) {
cluck '[ERROR] Srcphrase undefined';
} else {
cluck '[ERROR] Both srcphrase and answer are undefined';
}
return 0;
}
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;
unless (defined $string) {
cluck '[ERROR] String is undefined';
return sha1_base64 '';
}
if ($string eq '') {
return encode_base64 '';
}
my $bytes = encode_utf8 $string;
return encode_base64 $bytes;
}
sub utf2sha1 {
my $string = shift;
unless (defined $string) {
cluck '[ERROR] String is undefined';
return sha1_base64 '';
}
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:

201
lib/weather.pm Normal file
View File

@@ -0,0 +1,201 @@
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 vars qw/$VERSION/;
use Exporter qw (import);
our @EXPORT_OK = qw (weather);
$VERSION = '1.0';
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 {
carp "[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) {
carp "[WARN] openweathermap returns corrupted json: $EVAL_ERROR";
untie %cachetime;
untie %cachedata;
return undef;
};
$cachetime{$id} = $now;
$cachedata{$id} = encode_json ($fc);
} else {
carp 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: