Compare commits
30 Commits
f1ad32d5ae
...
redis
| Author | SHA1 | Date | |
|---|---|---|---|
|
e135ef7d7c | ||
|
|
731d707baa | ||
|
|
6840e6d5d0 | ||
|
|
ba14f6e619 | ||
|
|
00a82dd2cd | ||
|
|
6554879b19 | ||
|
|
9a5b899a42 | ||
|
|
3a061078d4 | ||
|
|
ca946c7e7b | ||
|
|
c68f716cbb | ||
|
|
31e077c219 | ||
|
|
ae553d8aa5 | ||
|
|
1d287f853f | ||
|
|
e74a3e46c1 | ||
|
|
186b112eba | ||
|
|
f223ba04ae | ||
|
|
17bd260a45 | ||
|
|
7cac72d5b9 | ||
|
|
f33e05a91c | ||
|
|
ab89105168 | ||
|
|
8d35bb2452 | ||
|
|
71a2471725 | ||
|
|
e93c9f9131 | ||
|
|
1abb95622a | ||
|
|
bb399a5051 | ||
|
|
c5014a8f77 | ||
|
|
f83a2d3436 | ||
|
|
2134edd841 | ||
|
|
3dd565c658 | ||
|
|
7147b785e7 |
1
.gitignore
vendored
1
.gitignore
vendored
@@ -11,5 +11,6 @@ data/gamestat/**
|
|||||||
data/image/**
|
data/image/**
|
||||||
data/karma/**
|
data/karma/**
|
||||||
data/lat/**
|
data/lat/**
|
||||||
|
data/proverb/**
|
||||||
data/telegrambot-brains/**
|
data/telegrambot-brains/**
|
||||||
vendor_perl/**
|
vendor_perl/**
|
||||||
|
|||||||
@@ -52,7 +52,7 @@ verbose = 8
|
|||||||
|
|
||||||
[-ValuesAndExpressions::ProhibitEmptyQuotes]
|
[-ValuesAndExpressions::ProhibitEmptyQuotes]
|
||||||
# cause we consider following correct and useful: my $var = '';
|
# cause we consider following correct and useful: my $var = '';
|
||||||
# the recomended use of q{} looks too complex: my $var = q{};
|
# the recommended use of q{} looks too complex: my $var = q{};
|
||||||
|
|
||||||
[-ValuesAndExpressions::ProhibitNoisyQuotes]
|
[-ValuesAndExpressions::ProhibitNoisyQuotes]
|
||||||
# Other people, other opinions: "," is better readable than qw(,)
|
# Other people, other opinions: "," is better readable than qw(,)
|
||||||
@@ -93,3 +93,6 @@ lib_sections = NAME | VERSION | DESCRIPTION | AUTHOR | LICENSE AND COPYRIGHT
|
|||||||
[-ControlStructures::ProhibitDeepNests]
|
[-ControlStructures::ProhibitDeepNests]
|
||||||
# Have to use it, so fuckoff
|
# Have to use it, so fuckoff
|
||||||
|
|
||||||
|
[-ControlStructures::ProhibitUntilBlocks]
|
||||||
|
# Until is really useful if condition is simple, so let's assume condition is
|
||||||
|
# always simple to read
|
||||||
@@ -1,30 +0,0 @@
|
|||||||
Migration procedure.
|
|
||||||
|
|
||||||
When you require to perform this procedure?
|
|
||||||
- When perl version is changed
|
|
||||||
- When migration to other OS or distribution occurs
|
|
||||||
|
|
||||||
Why do i have to perform this procedure?
|
|
||||||
- Some modules are vendored with bot
|
|
||||||
- BDB can vary its on-disk format depending on dbd version that linked with
|
|
||||||
perl interpreter itself and its apropriate module.
|
|
||||||
|
|
||||||
How can i guess that i miss to perform this procedure?
|
|
||||||
Most notable sympthom is 'BDB0091 DB_VERSION_MISMATCH' in logs and bot admin settings are lost.
|
|
||||||
|
|
||||||
|
|
||||||
Procedure steps.
|
|
||||||
|
|
||||||
On source system perform following steps:
|
|
||||||
1. stop the bot, to unlock and close all files.
|
|
||||||
2. make a backup
|
|
||||||
3. prepare target system and copy bot to target system
|
|
||||||
|
|
||||||
On target system perform these steps:
|
|
||||||
1. remove vendor_perl dir in bot' directory
|
|
||||||
2. run "bash bootstrap.sh" (no quotes) and wait until it suscessfuly build and
|
|
||||||
installl required modules.
|
|
||||||
3. run perl bin/cache_import.pl script. It should create cache and exit
|
|
||||||
silently.
|
|
||||||
|
|
||||||
Now it is possible to run bot without settings loss.
|
|
||||||
69
README.md
69
README.md
@@ -13,17 +13,18 @@ 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**.
|
||||||
|
|
||||||
Bot can be run via **bin/aleesa-telegram-bot** and acts as daemon (double fork()
|
Bot can be run via **bin/aleesa-telegram-bot** and acts as daemon (double
|
||||||
and detaches stdio).
|
fork() and detaches stdio).
|
||||||
|
|
||||||
## Installation
|
## Installation
|
||||||
|
|
||||||
In order to run this application, you need to "bootstrap" it - download and build
|
In order to run this application, you need to "bootstrap" it - download and
|
||||||
all required dependencies and libraries.
|
build all required dependencies and libraries.
|
||||||
|
|
||||||
You'll need perl-5.18 or newer, "Development Tools" or similar group of
|
You'll need perl-5.18 or newer, "Development Tools" or similar group of
|
||||||
packages, perl, perl-devel, perl-local-lib, perl-app-cpanm, sqlite-devel,
|
packages, perl, perl-devel, perl-local-lib, perl-app-cpanm, sqlite-devel,
|
||||||
zlib-devel, openssl-devel, libdb4-devel (Berkeley DB devel), make.
|
zlib-devel, openssl-devel, libdb4-devel (Berkeley DB devel), make,
|
||||||
|
hiredis-devel.
|
||||||
|
|
||||||
After installing required dependencies it is possible to run:
|
After installing required dependencies it is possible to run:
|
||||||
|
|
||||||
@@ -38,66 +39,10 @@ and all libraries should be downloaded, built, tested and installed.
|
|||||||
## Running
|
## Running
|
||||||
|
|
||||||
This bot does not [ultilize][4] webhooks, so in order to run it only well
|
This bot does not [ultilize][4] webhooks, so in order to run it only well
|
||||||
internet connection is requied, no public-available ip address is needed.
|
internet connection is required, no public-available ip address is needed.
|
||||||
|
|
||||||
### Additional Settings to be performed in order to run bot as it designed
|
|
||||||
|
|
||||||
There are some "plugins" that requires registration on thrird party services
|
|
||||||
and API keys and secrets in order to work.
|
|
||||||
|
|
||||||
#### OpenWeatherMap
|
|
||||||
|
|
||||||
You should [register][5], [login][6] and [create][7] api key. Free plan have
|
|
||||||
all required features to run this "plugin".
|
|
||||||
|
|
||||||
Once key is created you should put it in **config.json** under openweathermap
|
|
||||||
section as appid. Thats it.
|
|
||||||
|
|
||||||
It is still impossible to disable this plugin, but "I'm working on it".
|
|
||||||
|
|
||||||
#### Imgur
|
|
||||||
|
|
||||||
This plugin "just exists" and is actually used nowhere around the code.
|
|
||||||
Anyway, to make use of it besides registering apropriate handler in code, you
|
|
||||||
should sign in imgur and get access token.
|
|
||||||
|
|
||||||
Actually at this time this "plugin" can be stub-ed with default config values.
|
|
||||||
|
|
||||||
Anyway, to fetch access token you should [login][8] and perform [registration][9]
|
|
||||||
of your app. Then you should authorise your app according to [this][10] manual. Or
|
|
||||||
[this][11] one.
|
|
||||||
|
|
||||||
#### Flickr
|
|
||||||
|
|
||||||
This "plugin" is really used to implement random picture link retrival plugins.
|
|
||||||
|
|
||||||
There is helper script in **bin/flickr_init.pl** that helps to get all required keys
|
|
||||||
and secrets from flickr api.
|
|
||||||
|
|
||||||
Before using it bot must be bootstrapped via **`bootstrap.sh`**.
|
|
||||||
|
|
||||||
[Login][11] and create an [app][12] in your flickr account. Then *logout* flickr account.
|
|
||||||
(It is required in order to properly get "verfier" parameter later).
|
|
||||||
|
|
||||||
Put your [app key and secret][13] to **config.json**. Ensure that "verifier" parameter
|
|
||||||
in Flickr-related part of config either absent or commented out.
|
|
||||||
|
|
||||||
Run **bin/flickr_init.pl** first time and follow on screen instuctions - copy and
|
|
||||||
paste given link to browser login to flickr account adn yo'll be redirected to
|
|
||||||
example.com. Check address bar in browser to get so-called "verifier", put it in
|
|
||||||
**config.json**. Then run **bin/flickr_init.pl** again to store API access token in db
|
|
||||||
under data/image directory (in default config). You're done.
|
|
||||||
|
|
||||||
[1]: https://metacpan.org/pod/Telegram::Bot
|
[1]: https://metacpan.org/pod/Telegram::Bot
|
||||||
[2]: https://metacpan.org/pod/Hailo
|
[2]: https://metacpan.org/pod/Hailo
|
||||||
[3]: https://core.telegram.org/bots/api
|
[3]: https://core.telegram.org/bots/api
|
||||||
[4]: https://core.telegram.org/bots/api#getting-updates
|
[4]: https://core.telegram.org/bots/api#getting-updates
|
||||||
[5]: https://home.openweathermap.org/users/sign_up
|
|
||||||
[6]: https://home.openweathermap.org/users/sign_in
|
|
||||||
[7]: https://home.openweathermap.org/api_keys
|
|
||||||
[8]: https://imgur.com/signin
|
|
||||||
[9]: https://api.imgur.com/oauth2/addclient
|
|
||||||
[10]: https://apidocs.imgur.com/#authorization-and-oauth
|
|
||||||
[11]: https://identity.flickr.com/login
|
|
||||||
[12]: https://www.flickr.com/services/apps/create/apply/
|
|
||||||
[13]: https://www.flickr.com/services/api/keys/
|
|
||||||
|
|||||||
74
README_RU.md
74
README_RU.md
@@ -2,19 +2,19 @@
|
|||||||
|
|
||||||
## Что это такое
|
## Что это такое
|
||||||
|
|
||||||
Это бот основанный на перловых модулях [Telegram::Bot][1] для работы в
|
Это бот, основанный на перловых модулях [Telegram::Bot][1] для работы в
|
||||||
мессенджере Telegram и [Hailo][2] для генерации "умной" беседы.
|
мессенджере Telegram и [Hailo][2] для генерации "умной" беседы.
|
||||||
|
|
||||||
Для корректной работы пришлось форкнуть [Telegram::Bot][1] чтобы обновить
|
Для корректной работы, пришлось форкнуть [Telegram::Bot][1], чтобы обновить
|
||||||
интерфейс API до [Telegram Bot API v5][3]. Для избежания неоднозначностей модуль
|
интерфейс API до [Telegram Bot API v5][3]. Для избежания неоднозначностей, модуль
|
||||||
пришлось переименовать и теперь он идёт в составе бота. Возможно, когда модуль
|
пришлось переименовать и теперь он идёт в составе бота. Возможно, когда модуль
|
||||||
отлежится и будет похож на стабильный, он стнет самостоятельным и поселится на
|
отлежится и будет похож на стабильный, он стнет самостоятельным и поселится на
|
||||||
metacpan.org
|
metacpan.org
|
||||||
|
|
||||||
Конфиг бота должен лежать в **data/config.json**, пример конфига расположен в
|
Конфиг бота должен лежать в **data/config.json**. Пример конфига расположен в
|
||||||
**data/sample_config.json**.
|
**data/sample_config.json**.
|
||||||
|
|
||||||
Бота можно запустить через **bin/aleesa-telegram-bot** и он взлетит как юниксовый
|
Бота можно запустить через **bin/aleesa-telegram-bot** и он взлетит, как юниксовый
|
||||||
демон (сделает двойной fork() и отцепится от stdio).
|
демон (сделает двойной fork() и отцепится от stdio).
|
||||||
|
|
||||||
## Установка
|
## Установка
|
||||||
@@ -22,11 +22,11 @@ metacpan.org
|
|||||||
Чтобы запустить приложение, его надо "забурстрапить" - загрузить и собрать все
|
Чтобы запустить приложение, его надо "забурстрапить" - загрузить и собрать все
|
||||||
необходимые зависимости.
|
необходимые зависимости.
|
||||||
|
|
||||||
Понадобится perl-5.18 а желательно новее, "Development Tools" или подобная
|
Понадобится perl-5.18, а желательно новее, "Development Tools" или подобная
|
||||||
группа пакетов , perl, perl-devel, perl-local-lib, perl-app-cpanm, sqlite-devel,
|
группа пакетов , perl, perl-devel, perl-local-lib, perl-app-cpanm, sqlite-devel,
|
||||||
zlib-devel, openssl-devel, libdb4-devel (Berkeley DB devel), make.
|
zlib-devel, openssl-devel, libdb4-devel (Berkeley DB devel), make, hiredis-devel.
|
||||||
|
|
||||||
После установки этих пакетов можно будет запустить:
|
После установки этих пакетов, можно будет запустить:
|
||||||
|
|
||||||
```bash
|
```bash
|
||||||
|
|
||||||
@@ -34,71 +34,15 @@ bash bootstrap.sh
|
|||||||
|
|
||||||
```
|
```
|
||||||
|
|
||||||
и по идее всё что нужно будет выкачено, собрано и разложено куда надо.
|
и, по идее, всё что нужно будет выкачено, собрано и разложено куда надо.
|
||||||
|
|
||||||
## Запуск и работа
|
## Запуск и работа
|
||||||
|
|
||||||
Бот не использует [вебхуки][4], поэтому ничего дополнительного, кроме хорошего
|
Бот не использует [вебхуки][4], поэтому ничего дополнительного, кроме хорошего
|
||||||
подключения к интернету ему не нужно.
|
подключения к интернету ему не нужно.
|
||||||
|
|
||||||
### Дополнительные настройки
|
|
||||||
|
|
||||||
Некоторые "плагины" требуют регистрации в сторонних сервисах (API keys, secrets
|
|
||||||
итд), чтобы бот не сыпал ошибками в логи (возможно, в дальнейшем возможно будет
|
|
||||||
отключить эти плагины).
|
|
||||||
|
|
||||||
#### OpenWeatherMap
|
|
||||||
|
|
||||||
Для работы погодного плагина надо [заргистрироваться][5], [залогиниться][6] и
|
|
||||||
[создать][7] api key. Free plan предлагает всё необхдимое для работы "плагина".
|
|
||||||
|
|
||||||
Когда api key будет создан, его нужно вписать в **config.json** "секцию"
|
|
||||||
openweathermap в качестве appid. На этом всё.
|
|
||||||
|
|
||||||
#### Imgur
|
|
||||||
|
|
||||||
Этот плагин "просто есть" и его на самом деле ничто и никто не использует. И в
|
|
||||||
этой связи все настройки плагина можно оставить "как есть" в примере конфига.
|
|
||||||
|
|
||||||
Тем не менее, если есть большое желание, то можно [залогиниться][8] и
|
|
||||||
[зарегистрировать][9] бота как приложение, а потом разрешить приложению
|
|
||||||
пользоваться API-шкой, как описано в [этом][10] или [этом][11] мануале.
|
|
||||||
|
|
||||||
#### Flickr
|
|
||||||
|
|
||||||
Этот "плагин" действительно используется для добычи ссылок на картинки в разных
|
|
||||||
"картиночных" командах бота.
|
|
||||||
|
|
||||||
Есть скрипт, который поможет с регистрацией приложения в api Flickr -
|
|
||||||
**bin/flickr_init.pl** он достанет все нужные ключи и секреты к ним.
|
|
||||||
|
|
||||||
До запуска этого скрипта, бот должен быть забутстраплен через **`bootstrap.sh`**.
|
|
||||||
|
|
||||||
[Залогиньтесь][11] и создайте [app][12] in своём Flicker-овском аккаунте. Далее,
|
|
||||||
*разлогиньтесь*, это нужно, чтобы потом проще было достать параметр verifier.
|
|
||||||
|
|
||||||
Запишите [app key и secret][13] в **config.json**. Удостоверьтесь, что параметр
|
|
||||||
"verifier" в конфиге либо закоменчен либо отсутствует.
|
|
||||||
|
|
||||||
Запустите **bin/flickr_init.pl** и следуте предлагаемым инструкциям - в итоге
|
|
||||||
будет дана ссылка, которую надо скопипастить в браузер. По ссылке предложат
|
|
||||||
залогиниться, далее надо будет разрешить приложению просматривать профиль и
|
|
||||||
через один-два редиректа вы попадёте на example.com. Из адресной строки браузера
|
|
||||||
надо скопировать параметр "verifier" и вписать его в **config.json**.
|
|
||||||
|
|
||||||
Чтобы сохранить в бд плагина API access token для нормальной работы "плагина",
|
|
||||||
второй раз запустите **bin/flickr_init.pl**. На этом всё.
|
|
||||||
|
|
||||||
[1]: https://metacpan.org/pod/Telegram::Bot
|
[1]: https://metacpan.org/pod/Telegram::Bot
|
||||||
[2]: https://metacpan.org/pod/Hailo
|
[2]: https://metacpan.org/pod/Hailo
|
||||||
[3]: https://core.telegram.org/bots/api
|
[3]: https://core.telegram.org/bots/api
|
||||||
[4]: https://core.telegram.org/bots/api#getting-updates
|
[4]: https://core.telegram.org/bots/api#getting-updates
|
||||||
[5]: https://home.openweathermap.org/users/sign_up
|
|
||||||
[6]: https://home.openweathermap.org/users/sign_in
|
|
||||||
[7]: https://home.openweathermap.org/api_keys
|
|
||||||
[8]: https://imgur.com/signin
|
|
||||||
[9]: https://api.imgur.com/oauth2/addclient
|
|
||||||
[10]: https://apidocs.imgur.com/#authorization-and-oauth
|
|
||||||
[11]: https://identity.flickr.com/login
|
|
||||||
[12]: https://www.flickr.com/services/apps/create/apply/
|
|
||||||
[13]: https://www.flickr.com/services/api/keys/
|
|
||||||
|
|||||||
@@ -144,6 +144,11 @@ local $SIG{TERM} = \&__signal_handler;
|
|||||||
# set correct proctitle
|
# set correct proctitle
|
||||||
$PROGRAM_NAME = abs_path $PROGRAM_NAME; ## no critic (Variables::RequireLocalizedPunctuationVars)
|
$PROGRAM_NAME = abs_path $PROGRAM_NAME; ## no critic (Variables::RequireLocalizedPunctuationVars)
|
||||||
|
|
||||||
|
# make some global vars for telegram and redis context
|
||||||
|
our $TGM;
|
||||||
|
our $REDIS;
|
||||||
|
our $RCONN;
|
||||||
|
|
||||||
# run bot, at last
|
# run bot, at last
|
||||||
RunTelegramBot ();
|
RunTelegramBot ();
|
||||||
|
|
||||||
|
|||||||
@@ -1,106 +0,0 @@
|
|||||||
#!/usr/bin/perl
|
|
||||||
|
|
||||||
use 5.018;
|
|
||||||
use strict;
|
|
||||||
use warnings;
|
|
||||||
use utf8;
|
|
||||||
use open qw (:std :utf8);
|
|
||||||
use English qw ( -no_match_vars );
|
|
||||||
use version; our $VERSION = qw (1.0);
|
|
||||||
|
|
||||||
my $workdir;
|
|
||||||
|
|
||||||
# before we run, change working dir
|
|
||||||
BEGIN {
|
|
||||||
use Cwd qw (chdir abs_path);
|
|
||||||
my @CWD = split /\//xms, abs_path ($PROGRAM_NAME);
|
|
||||||
if ($#CWD > 1) { $#CWD = $#CWD - 2; }
|
|
||||||
$workdir = join '/', @CWD;
|
|
||||||
chdir $workdir;
|
|
||||||
}
|
|
||||||
|
|
||||||
use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
|
|
||||||
use CHI;
|
|
||||||
use CHI::Driver::BerkeleyDB;
|
|
||||||
use File::Basename qw (dirname);
|
|
||||||
use File::Path qw (make_path);
|
|
||||||
use JSON::XS;
|
|
||||||
use Encode;
|
|
||||||
|
|
||||||
use BotLib::Conf qw (LoadConf);
|
|
||||||
|
|
||||||
my $c = LoadConf ();
|
|
||||||
my $cachedir = $c->{cachedir};
|
|
||||||
my $datadir = dirname $cachedir;
|
|
||||||
my $export = 0;
|
|
||||||
my $exportInst = 0;
|
|
||||||
|
|
||||||
sub dumpCache {
|
|
||||||
my $namespace = shift;
|
|
||||||
my $cacheExportDir = sprintf '%s/cacheexport', $datadir;
|
|
||||||
|
|
||||||
unless (-d $cacheExportDir) {
|
|
||||||
make_path ($cacheExportDir) || die "Unable to create $cacheExportDir: $OS_ERROR\n";
|
|
||||||
}
|
|
||||||
|
|
||||||
my $filename = sprintf '%s/%s', $cacheExportDir, $exportInst;
|
|
||||||
|
|
||||||
my $cache = CHI->new (
|
|
||||||
driver => 'BerkeleyDB',
|
|
||||||
root_dir => $cachedir,
|
|
||||||
namespace => $namespace
|
|
||||||
);
|
|
||||||
|
|
||||||
my $j;
|
|
||||||
my $writefile = 0;
|
|
||||||
|
|
||||||
foreach my $k ($cache->get_keys ()) {
|
|
||||||
$k = decode ('UTF-8', $k);
|
|
||||||
$j->{$k} = decode ('UTF-8', $cache->get ($k));
|
|
||||||
$writefile = 1;
|
|
||||||
}
|
|
||||||
|
|
||||||
if ($writefile) {
|
|
||||||
say "Dumping $namespace"; ## no critic (InputOutput::RequireCheckedSyscalls)
|
|
||||||
my $jsonencoder = JSON::XS->new->pretty ();
|
|
||||||
open (my $FILE, '>', $filename) or die "Unable to dump cache namespace $namespace to $filename: $OS_ERROR\n";
|
|
||||||
print $FILE $jsonencoder->encode ($j) or die "Unable to dump cache namespace $namespace to $filename: $OS_ERROR\n";;
|
|
||||||
close $FILE; ## no critic (InputOutput::RequireCheckedSyscalls)
|
|
||||||
my $EXPORTFD;
|
|
||||||
|
|
||||||
if ($export) {
|
|
||||||
open ($EXPORTFD, '>>', "$cacheExportDir/exportfiles.txt") or die "Unable to open for appending $cacheExportDir/exportfiles.txt: $OS_ERROR\n";
|
|
||||||
} else {
|
|
||||||
open ($EXPORTFD, '>', "$cacheExportDir/exportfiles.txt") or die "Unable to create $cacheExportDir/exportfiles.txt: $OS_ERROR\n";
|
|
||||||
$export = 1;
|
|
||||||
}
|
|
||||||
|
|
||||||
printf ($EXPORTFD "%s,%s\n", $namespace, $filename) or die "Unable to write to $cacheExportDir/exportfiles.txt: $OS_ERROR\n";
|
|
||||||
close $EXPORTFD; ## no critic (InputOutput::RequireCheckedSyscalls)
|
|
||||||
$exportInst++;
|
|
||||||
}
|
|
||||||
|
|
||||||
return;
|
|
||||||
}
|
|
||||||
|
|
||||||
opendir (my $DIR, $cachedir) or die "Unable to open $cachedir: $OS_ERROR\n";
|
|
||||||
|
|
||||||
while (readdir $DIR) {
|
|
||||||
if (/^BotLib\+3a\+3aAdmin_censor_(.+)\.db$/) {
|
|
||||||
dumpCache ("BotLib::Admin_censor_$1");
|
|
||||||
} elsif (/^BotLib\+3a\+3aAdmin_fortune.db$/) {
|
|
||||||
dumpCache ('BotLib::Admin_fortune');
|
|
||||||
} elsif (/BotLib\+3a\+3aAdmin_plugin_(.+)\.db$/) {
|
|
||||||
dumpCache ("BotLib::Admin_plugin_$1");
|
|
||||||
} elsif (/BotLib\+3a\+3aAdmin_(.+)\.db$/) {
|
|
||||||
dumpCache ("BotLib::Admin_$1");
|
|
||||||
} elsif (/^BotLib\+3a\+3aImage\+3a\+3aFlickr\.db$/) {
|
|
||||||
dumpCache ('BotLib::Image::Flickr');
|
|
||||||
} elsif (/^BotLib\+3a\+3aKarma_(.+)\.db$/) {
|
|
||||||
dumpCache ("BotLib::Karma_$1");
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
closedir $DIR;
|
|
||||||
exit 0;
|
|
||||||
|
|
||||||
@@ -1,86 +0,0 @@
|
|||||||
#!/usr/bin/perl
|
|
||||||
|
|
||||||
use 5.018;
|
|
||||||
use strict;
|
|
||||||
use warnings;
|
|
||||||
use utf8;
|
|
||||||
use open qw (:std :utf8);
|
|
||||||
use English qw ( -no_match_vars );
|
|
||||||
use version; our $VERSION = qw (1.0);
|
|
||||||
|
|
||||||
my $workdir;
|
|
||||||
|
|
||||||
# before we run, change working dir
|
|
||||||
BEGIN {
|
|
||||||
use Cwd qw (chdir abs_path);
|
|
||||||
my @CWD = split /\//xms, abs_path ($PROGRAM_NAME);
|
|
||||||
if ($#CWD > 1) { $#CWD = $#CWD - 2; }
|
|
||||||
$workdir = join '/', @CWD;
|
|
||||||
chdir $workdir;
|
|
||||||
}
|
|
||||||
|
|
||||||
use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
|
|
||||||
use CHI;
|
|
||||||
use CHI::Driver::BerkeleyDB;
|
|
||||||
use File::Basename qw (dirname);
|
|
||||||
use File::Path qw (make_path);
|
|
||||||
use JSON::XS;
|
|
||||||
use Encode;
|
|
||||||
|
|
||||||
use BotLib::Conf qw (LoadConf);
|
|
||||||
|
|
||||||
my $c = LoadConf ();
|
|
||||||
my $cachedir = $c->{cachedir};
|
|
||||||
my $datadir = dirname $cachedir;
|
|
||||||
my $export = 0;
|
|
||||||
|
|
||||||
sub createCache {
|
|
||||||
my $namespace = shift;
|
|
||||||
my $filename = shift;
|
|
||||||
say "Creating $namespace from $filename"; ## no critic (InputOutput::RequireCheckedSyscalls)
|
|
||||||
|
|
||||||
my $cache = CHI->new (
|
|
||||||
driver => 'BerkeleyDB',
|
|
||||||
root_dir => $cachedir,
|
|
||||||
namespace => $namespace
|
|
||||||
);
|
|
||||||
|
|
||||||
open my $FH, '<', $filename or die "Unable to open $filename: $OS_ERROR\n";
|
|
||||||
binmode $FH;
|
|
||||||
my $len = (stat $filename) [7];
|
|
||||||
my $json;
|
|
||||||
use bytes;
|
|
||||||
my $readlen = read $FH, $json, $len;
|
|
||||||
no bytes;
|
|
||||||
|
|
||||||
unless ($readlen) {
|
|
||||||
close $FH; ## no critic (InputOutput::RequireCheckedSyscalls
|
|
||||||
die "Unable to read $filename: $OS_ERROR\n";
|
|
||||||
}
|
|
||||||
|
|
||||||
if ($readlen != $len) {
|
|
||||||
close $FH; ## no critic (InputOutput::RequireCheckedSyscalls
|
|
||||||
die "File $filename is $len bytes on disk, but we read only $readlen bytes\n";
|
|
||||||
}
|
|
||||||
|
|
||||||
close $FH; ## no critic (InputOutput::RequireCheckedSyscalls
|
|
||||||
my $j = JSON::XS->new->utf8->relaxed;
|
|
||||||
my $dump = $j->decode ($json);
|
|
||||||
|
|
||||||
foreach my $key (keys (%{$dump})) {
|
|
||||||
$cache->set ($key, $dump->{$key}, 'never');
|
|
||||||
}
|
|
||||||
|
|
||||||
return;
|
|
||||||
}
|
|
||||||
|
|
||||||
open (my $FH, '<', "$datadir/cacheexport/exportfiles.txt") or die "Unable to open $datadir/cacheexport/exportfiles.txt: $OS_ERROR\n";
|
|
||||||
|
|
||||||
while (<$FH>) {
|
|
||||||
chomp;
|
|
||||||
my ($namespace, $filename) = split /\,/, $_, 2;
|
|
||||||
createCache ($namespace, $filename);
|
|
||||||
}
|
|
||||||
|
|
||||||
close $FH; ## no critic (InputOutput::RequireCheckedSyscalls)
|
|
||||||
exit 0;
|
|
||||||
@@ -1,32 +0,0 @@
|
|||||||
#!/usr/bin/perl
|
|
||||||
|
|
||||||
use 5.018;
|
|
||||||
use strict;
|
|
||||||
use warnings;
|
|
||||||
use utf8;
|
|
||||||
use open qw (:std :utf8);
|
|
||||||
use English qw ( -no_match_vars );
|
|
||||||
use version; our $VERSION = qw (1.0);
|
|
||||||
|
|
||||||
my $workdir;
|
|
||||||
|
|
||||||
# before we run, change working dir
|
|
||||||
BEGIN {
|
|
||||||
use Cwd qw (chdir abs_path);
|
|
||||||
my @CWD = split /\//xms, abs_path ($PROGRAM_NAME);
|
|
||||||
if ($#CWD > 1) { $#CWD = $#CWD - 2; }
|
|
||||||
$workdir = join '/', @CWD;
|
|
||||||
chdir $workdir;
|
|
||||||
}
|
|
||||||
|
|
||||||
use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
|
|
||||||
use BotLib::Image::Flickr qw (FlickrByTags);
|
|
||||||
|
|
||||||
my $url = FlickrByTags ('bird,owl');
|
|
||||||
|
|
||||||
if ($url) {
|
|
||||||
say $url; ## no critic (InputOutput::RequireCheckedSyscalls)
|
|
||||||
exit 0;
|
|
||||||
} else {
|
|
||||||
exit 1;
|
|
||||||
}
|
|
||||||
@@ -1,29 +0,0 @@
|
|||||||
#!/usr/bin/perl
|
|
||||||
|
|
||||||
use 5.018;
|
|
||||||
use strict;
|
|
||||||
use warnings;
|
|
||||||
use utf8;
|
|
||||||
use open qw (:std :utf8);
|
|
||||||
use English qw ( -no_match_vars );
|
|
||||||
use version; our $VERSION = qw (1.0);
|
|
||||||
|
|
||||||
my $workdir;
|
|
||||||
|
|
||||||
# before we run, change working dir
|
|
||||||
BEGIN {
|
|
||||||
use Cwd qw (chdir abs_path);
|
|
||||||
my @CWD = split /\//xms, abs_path ($PROGRAM_NAME);
|
|
||||||
if ($#CWD > 1) { $#CWD = $#CWD - 2; }
|
|
||||||
$workdir = join '/', @CWD;
|
|
||||||
chdir $workdir;
|
|
||||||
}
|
|
||||||
|
|
||||||
use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
|
|
||||||
use BotLib::Image::Flickr qw (FlickrInit);
|
|
||||||
|
|
||||||
if (FlickrInit ()) {
|
|
||||||
exit 0;
|
|
||||||
} else {
|
|
||||||
exit 1;
|
|
||||||
}
|
|
||||||
@@ -1,29 +0,0 @@
|
|||||||
#!/usr/bin/perl
|
|
||||||
|
|
||||||
use 5.018;
|
|
||||||
use strict;
|
|
||||||
use warnings;
|
|
||||||
use utf8;
|
|
||||||
use open qw (:std :utf8);
|
|
||||||
use English qw ( -no_match_vars );
|
|
||||||
use version; our $VERSION = qw (1.0);
|
|
||||||
|
|
||||||
my $workdir;
|
|
||||||
|
|
||||||
# before we run, change working dir
|
|
||||||
BEGIN {
|
|
||||||
use Cwd qw (chdir abs_path);
|
|
||||||
my @CWD = split /\//xms, abs_path ($PROGRAM_NAME);
|
|
||||||
if ($#CWD > 1) { $#CWD = $#CWD - 2; }
|
|
||||||
$workdir = join '/', @CWD;
|
|
||||||
chdir $workdir;
|
|
||||||
}
|
|
||||||
|
|
||||||
use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
|
|
||||||
use BotLib::Image::Flickr qw (FlickrTestLogin);
|
|
||||||
|
|
||||||
if (FlickrTestLogin ()) {
|
|
||||||
exit 0;
|
|
||||||
} else {
|
|
||||||
exit 1;
|
|
||||||
}
|
|
||||||
@@ -1,26 +0,0 @@
|
|||||||
#!/usr/bin/perl
|
|
||||||
|
|
||||||
use 5.018;
|
|
||||||
use strict;
|
|
||||||
use warnings;
|
|
||||||
use utf8;
|
|
||||||
use open qw (:std :utf8);
|
|
||||||
use English qw ( -no_match_vars );
|
|
||||||
use version; our $VERSION = qw (1.0);
|
|
||||||
|
|
||||||
my $workdir;
|
|
||||||
|
|
||||||
# before we run, change working dir
|
|
||||||
BEGIN {
|
|
||||||
use Cwd qw (chdir abs_path);
|
|
||||||
my @CWD = split /\//xms, abs_path ($PROGRAM_NAME);
|
|
||||||
if ($#CWD > 1) { $#CWD = $#CWD - 2; }
|
|
||||||
$workdir = join '/', @CWD;
|
|
||||||
chdir $workdir;
|
|
||||||
}
|
|
||||||
|
|
||||||
use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
|
|
||||||
use BotLib::Fortune qw (Seed);
|
|
||||||
|
|
||||||
Seed ();
|
|
||||||
exit 0;
|
|
||||||
@@ -1,26 +0,0 @@
|
|||||||
#!/usr/bin/perl
|
|
||||||
|
|
||||||
use 5.018;
|
|
||||||
use strict;
|
|
||||||
use warnings;
|
|
||||||
use utf8;
|
|
||||||
use open qw (:std :utf8);
|
|
||||||
use English qw ( -no_match_vars );
|
|
||||||
use version; our $VERSION = qw (1.0);
|
|
||||||
|
|
||||||
my $workdir;
|
|
||||||
|
|
||||||
# before we run, change working dir
|
|
||||||
BEGIN {
|
|
||||||
use Cwd qw (chdir abs_path);
|
|
||||||
my @CWD = split /\//xms, abs_path ($PROGRAM_NAME);
|
|
||||||
if ($#CWD > 1) { $#CWD = $#CWD - 2; }
|
|
||||||
$workdir = join '/', @CWD;
|
|
||||||
chdir $workdir;
|
|
||||||
}
|
|
||||||
|
|
||||||
use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
|
|
||||||
use BotLib::Friday qw (Seed);
|
|
||||||
|
|
||||||
Seed ();
|
|
||||||
exit 0;
|
|
||||||
@@ -1,26 +0,0 @@
|
|||||||
#!/usr/bin/perl
|
|
||||||
|
|
||||||
use 5.018;
|
|
||||||
use strict;
|
|
||||||
use warnings;
|
|
||||||
use utf8;
|
|
||||||
use open qw (:std :utf8);
|
|
||||||
use English qw ( -no_match_vars );
|
|
||||||
use version; our $VERSION = qw (1.0);
|
|
||||||
|
|
||||||
my $workdir;
|
|
||||||
|
|
||||||
# before we run, change working dir
|
|
||||||
BEGIN {
|
|
||||||
use Cwd qw (chdir abs_path);
|
|
||||||
my @CWD = split /\//xms, abs_path ($PROGRAM_NAME);
|
|
||||||
if ($#CWD > 1) { $#CWD = $#CWD - 2; }
|
|
||||||
$workdir = join '/', @CWD;
|
|
||||||
chdir $workdir;
|
|
||||||
}
|
|
||||||
|
|
||||||
use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
|
|
||||||
use BotLib::Gamestat qw (SeedArtifacts);
|
|
||||||
|
|
||||||
SeedArtifacts ();
|
|
||||||
exit 0;
|
|
||||||
@@ -1,26 +0,0 @@
|
|||||||
#!/usr/bin/perl
|
|
||||||
|
|
||||||
use 5.018;
|
|
||||||
use strict;
|
|
||||||
use warnings;
|
|
||||||
use utf8;
|
|
||||||
use open qw (:std :utf8);
|
|
||||||
use English qw ( -no_match_vars );
|
|
||||||
use version; our $VERSION = qw (1.0);
|
|
||||||
|
|
||||||
my $workdir;
|
|
||||||
|
|
||||||
# before we run, change working dir
|
|
||||||
BEGIN {
|
|
||||||
use Cwd qw (chdir abs_path);
|
|
||||||
my @CWD = split /\//xms, abs_path ($PROGRAM_NAME);
|
|
||||||
if ($#CWD > 1) { $#CWD = $#CWD - 2; }
|
|
||||||
$workdir = join '/', @CWD;
|
|
||||||
chdir $workdir;
|
|
||||||
}
|
|
||||||
|
|
||||||
use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
|
|
||||||
use BotLib::Lat qw (Train);
|
|
||||||
|
|
||||||
Train ();
|
|
||||||
exit 0;
|
|
||||||
3
cpanfile
3
cpanfile
@@ -1,4 +1,5 @@
|
|||||||
requires 'Carp';
|
requires 'Carp';
|
||||||
|
requires 'Clone';
|
||||||
requires 'CHI';
|
requires 'CHI';
|
||||||
requires 'CHI::Driver::BerkeleyDB';
|
requires 'CHI::Driver::BerkeleyDB';
|
||||||
requires 'Cwd::utf8';
|
requires 'Cwd::utf8';
|
||||||
@@ -26,8 +27,10 @@ requires 'Log::Any::For::Std';
|
|||||||
requires 'Math::Random::Secure';
|
requires 'Math::Random::Secure';
|
||||||
requires 'Mojo::Base';
|
requires 'Mojo::Base';
|
||||||
requires 'Mojo::IOLoop';
|
requires 'Mojo::IOLoop';
|
||||||
|
requires 'Mojo::Redis';
|
||||||
requires 'Mojo::UserAgent';
|
requires 'Mojo::UserAgent';
|
||||||
requires 'Mojo::UserAgent::Cached';
|
requires 'Mojo::UserAgent::Cached';
|
||||||
|
requires 'Protocol::Redis::XS';
|
||||||
requires 'String::Random';
|
requires 'String::Random';
|
||||||
requires 'Text::Fuzzy';
|
requires 'Text::Fuzzy';
|
||||||
requires 'URI::Encode::XS';
|
requires 'URI::Encode::XS';
|
||||||
|
|||||||
@@ -1,54 +0,0 @@
|
|||||||
амулет Мерлина
|
|
||||||
библиотеку Ивана Грозного
|
|
||||||
деревянную плошку
|
|
||||||
диплока
|
|
||||||
доски Ноева Ковчега
|
|
||||||
древний презерватив из бараньей кишки
|
|
||||||
икону
|
|
||||||
инсталятор Windows 3.11
|
|
||||||
истлевший гроб
|
|
||||||
каменный топор
|
|
||||||
клад со златом-серебром
|
|
||||||
кривой нож
|
|
||||||
ледяную глыбу
|
|
||||||
лунный грунт
|
|
||||||
мамонта
|
|
||||||
мамонтёнка
|
|
||||||
метеорит
|
|
||||||
мумию фараона Тутанхамона
|
|
||||||
носки прапорщика (поставит в угол)
|
|
||||||
обломки грузинской керамики
|
|
||||||
птеродактиля
|
|
||||||
рубль с Лениным
|
|
||||||
рыцарские доспехи
|
|
||||||
синий мох
|
|
||||||
скелет
|
|
||||||
скелет собаки по кличке Беня
|
|
||||||
тиранозавтра
|
|
||||||
тотем индейцев
|
|
||||||
трубу с туркменским газом
|
|
||||||
скорбь еврейского народа
|
|
||||||
залежи активированного угля
|
|
||||||
не очень новый завет
|
|
||||||
мать леннарта поттеринга
|
|
||||||
руководство "начинающему археологу"
|
|
||||||
слово о полку игореве и дело о полку игореве, вместе с игорем
|
|
||||||
телепрограмму канала A-one
|
|
||||||
могилу искателя могил
|
|
||||||
заплесневевший кусок хлеба
|
|
||||||
преемник радиоприемника
|
|
||||||
глушитель от ВАЗ-2106
|
|
||||||
чувство удовлетворения
|
|
||||||
крота
|
|
||||||
воспоминания о былой любви
|
|
||||||
грязистор
|
|
||||||
египетское мумиё
|
|
||||||
окаменелый камень
|
|
||||||
кладку яиц рептилоида
|
|
||||||
яму
|
|
||||||
чеснок и стрелы
|
|
||||||
доллар по 30
|
|
||||||
несмазанные скрижали
|
|
||||||
четырелобита
|
|
||||||
чучело тролля
|
|
||||||
целое ничего
|
|
||||||
@@ -1,47 +0,0 @@
|
|||||||
семикрылого чешуйчатого пятихуя
|
|
||||||
разумного конденсатора
|
|
||||||
сальмонеллу
|
|
||||||
селёдку
|
|
||||||
желтоперого тунца
|
|
||||||
розовую сальмонеллу
|
|
||||||
голавля
|
|
||||||
барбуса
|
|
||||||
окуня
|
|
||||||
верхоплавку
|
|
||||||
коричневую форель
|
|
||||||
полярника
|
|
||||||
плотву
|
|
||||||
зубатку
|
|
||||||
солнечную рыбу
|
|
||||||
старую шину
|
|
||||||
скользкую корягу
|
|
||||||
лампу джина
|
|
||||||
любовное послание в бутылке
|
|
||||||
старое бревно
|
|
||||||
резиновый сапог
|
|
||||||
труп
|
|
||||||
Лох-Несское чудовище
|
|
||||||
старую рыбацкую приманку
|
|
||||||
кусок Титаника
|
|
||||||
обломок Атлантиды
|
|
||||||
кита
|
|
||||||
кальмара
|
|
||||||
дельфина
|
|
||||||
ската
|
|
||||||
подводную лодку
|
|
||||||
медузу
|
|
||||||
морскую звезду
|
|
||||||
электрического угря
|
|
||||||
большую белую акулу
|
|
||||||
аквалангиста
|
|
||||||
монстра
|
|
||||||
вируса
|
|
||||||
сырую пачку сигарет
|
|
||||||
водоросли
|
|
||||||
якорь от лодки
|
|
||||||
водяного
|
|
||||||
русалку
|
|
||||||
палтуса
|
|
||||||
труп собаки по кличке Беня
|
|
||||||
олигофрена Проню
|
|
||||||
огеймера Фишкина
|
|
||||||
@@ -1,521 +0,0 @@
|
|||||||
Что сказал Берлиоз своей музыкой? - ничего; но как потрясающе он это
|
|
||||||
сказал.
|
|
||||||
-- Джеймс Гиббонз Хьюнекер
|
|
||||||
%
|
|
||||||
Музыка будет по-немецки, вы не поймете.
|
|
||||||
-- Оскар Уайльд
|
|
||||||
%
|
|
||||||
Четвертый раз смотрю этот фильм и должна вам сказать, что сегодня актеры
|
|
||||||
играли как никогда.
|
|
||||||
-- Фаина Раневская
|
|
||||||
%
|
|
||||||
Продолжительность фильма определяется выносливостью мочевого пузыря
|
|
||||||
обычного зрителя.
|
|
||||||
-- Альфред Хичкок
|
|
||||||
%
|
|
||||||
А что, если наша Земля - ад какой-нибудь другой планеты?
|
|
||||||
-- Олдос Хаксли
|
|
||||||
%
|
|
||||||
Если видишь женщину голой достаточно долго, опять начинаешь обращать
|
|
||||||
внимание на ее лицо.
|
|
||||||
-- Генри Миллер
|
|
||||||
%
|
|
||||||
Самое главное - выглядеть совершенно естественно; но для этого нужно очень
|
|
||||||
много косметики.
|
|
||||||
-- Кельвин Кляйн
|
|
||||||
%
|
|
||||||
Любовь - лучшая косметика. Но косметику купить легче.
|
|
||||||
-- Ив Сен-Лоран
|
|
||||||
%
|
|
||||||
Людей без лишнего веса больше всего на кладбище.
|
|
||||||
-- Биверли Силлз
|
|
||||||
%
|
|
||||||
Лучше быть молодым навозным жуков, чем старой райской птицей.
|
|
||||||
-- Марк Твен
|
|
||||||
%
|
|
||||||
К старости недостатки ума становятся все заметнее, как и недостатки
|
|
||||||
внешности.
|
|
||||||
-- Франсуа Ларошфуко
|
|
||||||
%
|
|
||||||
Лучше быть старой, чем мертвой.
|
|
||||||
-- Бриджит Бардо
|
|
||||||
%
|
|
||||||
Вечеринка с коктейлями: место, где можно встретить людей, которые пьют так
|
|
||||||
много, что вы не можете вспомнить их имена.
|
|
||||||
-- Космо Сардо
|
|
||||||
%
|
|
||||||
Средство от похмелья: выжать сок из двух бутылок виски...
|
|
||||||
-- Эдди Кондон
|
|
||||||
%
|
|
||||||
Дважды два уже четыре, а будет еще лучше.
|
|
||||||
-- Хенрик Ягодзинский
|
|
||||||
%
|
|
||||||
Я сидел на диете 14 дней и потерял всего две недели.
|
|
||||||
-- Тоти Филдс
|
|
||||||
%
|
|
||||||
В жизни можно полагаться только на себя самого. Да и то не советую!
|
|
||||||
-- Тристан Бернар
|
|
||||||
%
|
|
||||||
Источник нашей мудрости - наш опыт. Источник нашего опыта - наша глупость.
|
|
||||||
-- Саша Гитри
|
|
||||||
%
|
|
||||||
Уходя на тот свет, не забудь выключить этот.
|
|
||||||
-- Виктор Коваль
|
|
||||||
%
|
|
||||||
Я не верю ни единому слову из того, что вы говорите... или я вам.
|
|
||||||
-- Оскар Уайльд
|
|
||||||
%
|
|
||||||
Я думаю, мы должны говорить правду или хотя бы говорить то, что мы думаем.
|
|
||||||
-- Юрий Лужков
|
|
||||||
%
|
|
||||||
Нельзя иметь все. Куда вы это положите?
|
|
||||||
-- Стивен Райт
|
|
||||||
%
|
|
||||||
Сначала забываешь имена, потом забываешь лица, потом забываешь застегивать
|
|
||||||
ширинку, потом забываешь расстегивать ширинку.
|
|
||||||
-- Лео Розенберг
|
|
||||||
%
|
|
||||||
Время - лучший учитель, но, к сожалению, оно убивает своих учеников.
|
|
||||||
-- Гектор Берлиоз
|
|
||||||
%
|
|
||||||
Прошлое - чужая страна, там все по-другому.
|
|
||||||
-- Лесли Хартли
|
|
||||||
%
|
|
||||||
Помните о бедняках - это не требует никаких расходов.
|
|
||||||
-- Генри Уиллер Шоу
|
|
||||||
%
|
|
||||||
Я люблю своих детей, но некоторые мне не нравятся.
|
|
||||||
-- Лилиан Картер, мать президента США Д.Картера
|
|
||||||
%
|
|
||||||
Дружба - это когда можно ни с того ни с сего приехать к человеку
|
|
||||||
и поселиться у него.
|
|
||||||
-- Давид Самойлов
|
|
||||||
%
|
|
||||||
Врагов я забрасываю цветами - в гробу!
|
|
||||||
-- Сальвадор Дали
|
|
||||||
%
|
|
||||||
Я не боюсь умереть. Я просто не хочу при этом присутствовать.
|
|
||||||
-- Вуди Аллен
|
|
||||||
%
|
|
||||||
Какой замечательный некролог! С таким бы жить и жить!
|
|
||||||
-- М.Генин
|
|
||||||
%
|
|
||||||
Твои шансы выиграть в лотерею возрастут, если ты купишь билет.
|
|
||||||
-- Уинстон Грум из "Правил Фореста Гампа"
|
|
||||||
%
|
|
||||||
Пока вы ищете, кого бы стоило полюбить, вам нужен кто-то, кто любит вас.
|
|
||||||
-- Шейла Делейни
|
|
||||||
%
|
|
||||||
Если двое любят друг друга, это не может счастливо кончиться.
|
|
||||||
-- Э.Хемингуэй
|
|
||||||
%
|
|
||||||
Я порвала с ним через три года. Это была типичная любовь-ненависть. Мы оба
|
|
||||||
любили его и ненавидели меня.
|
|
||||||
-- Кэрол Зискинд
|
|
||||||
%
|
|
||||||
В тех кругах, в которых я вращаюсь, переспать с женщиной - недостаточный
|
|
||||||
повод для того, чтобы быть ей представленным.
|
|
||||||
-- Вирджиния Маклауд
|
|
||||||
%
|
|
||||||
Она говорила на восемнадцати языках и ни на одном из них не умела сказать
|
|
||||||
"нет".
|
|
||||||
-- Дороти Паркер
|
|
||||||
%
|
|
||||||
Помни: в пяти случаях из шести свет в конце туннеля - это свет
|
|
||||||
надвигающегося поезда.
|
|
||||||
-- Пол Диксон
|
|
||||||
%
|
|
||||||
Все соседи плохи, но верхние хуже нижних.
|
|
||||||
-- Константин Мелихан
|
|
||||||
%
|
|
||||||
Америка - единственный матриархат, под сенью которого женщины ведут борьбу
|
|
||||||
за равные права.
|
|
||||||
-- А. Рот
|
|
||||||
%
|
|
||||||
Брак - это лотерея, но в случае проигрыша вы не можете порвать свой билет.
|
|
||||||
-- Ф. Ноулз
|
|
||||||
%
|
|
||||||
Британский солдат устоит против кого угодно, только не против Британского
|
|
||||||
министерства обороны.
|
|
||||||
-- Бернард Шоу
|
|
||||||
%
|
|
||||||
Век наш таков, что он гордится машинами, умеющими думать, и побаивается
|
|
||||||
людей, которые пытаются проявить ту же способность.
|
|
||||||
-- Г.Мамфорд Джонс
|
|
||||||
%
|
|
||||||
Военная мудрость есть понятие, заключающее противоречие в самом себе.
|
|
||||||
Война - слишком серьезное дело, чтобы доверять его военным.
|
|
||||||
-- Талейран
|
|
||||||
%
|
|
||||||
Выход из беды найти не столь просто, как попасть в нее.
|
|
||||||
-- Эд Хау
|
|
||||||
%
|
|
||||||
Граница в политической географии - воображаемая линия между двумя
|
|
||||||
государствами, отделяющая воображаемые права одного от воображаемых прав
|
|
||||||
другого.
|
|
||||||
-- А.Бирс
|
|
||||||
%
|
|
||||||
Да не устрашит тебя величие: одни рождаются великими, другие достигают
|
|
||||||
величия, третьим его навязывают.
|
|
||||||
-- Уильям Шекспир
|
|
||||||
%
|
|
||||||
Две тысячи лет нам поставляли примеры для подражания, и теперь ничто нас
|
|
||||||
не извиняет, если мы, воюя, воем плохо.
|
|
||||||
-- Т.Э. Лоуренс
|
|
||||||
%
|
|
||||||
Дипломная работа среднего выпускника университета есть не что иное, как
|
|
||||||
кости, перенесенные из одной могилы в другую.
|
|
||||||
-- Дж. Фрэнк Доуби
|
|
||||||
%
|
|
||||||
Для любой волнующей человека проблемы всегда легко найти решение -
|
|
||||||
простое, достижимое и ошибочное.
|
|
||||||
-- Г.Л. Менкен
|
|
||||||
%
|
|
||||||
Добрым словом и револьвером вы можете добиться гораздо большего, чем одним
|
|
||||||
только добрым словом.
|
|
||||||
-- Аль Капоне
|
|
||||||
%
|
|
||||||
Если вы не восходящий, значит, вы ниспадающий.
|
|
||||||
-- Стивен Поттер
|
|
||||||
%
|
|
||||||
Если честолюбивая мечта не заставляет вас страдать, значит, ее у вас нет.
|
|
||||||
-- К. Норрис
|
|
||||||
%
|
|
||||||
Идеалист тот, кто, заметив, что роза пахнет лучше капусты, заключает, что
|
|
||||||
и суп из нее будет лучше.
|
|
||||||
-- Г. Менкен
|
|
||||||
%
|
|
||||||
Жизнь что луковица - вы чистите ее, снимая слой за слоем, и иногда
|
|
||||||
плачете.
|
|
||||||
-- С. Сандберг
|
|
||||||
%
|
|
||||||
Когда люди вольны поступать как угодно, они обычно подражают друг другу.
|
|
||||||
-- Э. Хоффер
|
|
||||||
%
|
|
||||||
Коли все думают одинаково, значит, никто особенно и не думает.
|
|
||||||
-- У.Липпман
|
|
||||||
%
|
|
||||||
Компьютеры бесподобны: за несколько минут они могут совершить такую
|
|
||||||
грандиозную ошибку, какую не в состоянии сделать множество людей за многие
|
|
||||||
месяцы.
|
|
||||||
-- М. Мичэм
|
|
||||||
%
|
|
||||||
Логика - это искусство ошибаться с уверенностью в своей правоте.
|
|
||||||
-- Дж. У. Крач
|
|
||||||
%
|
|
||||||
Любовь - вещь идеальная, супружество - реальная; смешение реального с
|
|
||||||
идеальным никогда не проходит безнаказанно.
|
|
||||||
-- И. Гете
|
|
||||||
%
|
|
||||||
Любое ваше решение - это ошибка.
|
|
||||||
-- Эдуард Далберг
|
|
||||||
%
|
|
||||||
Мой способ шутить - это говорить правду. На свете нет ничего
|
|
||||||
смешнее.
|
|
||||||
-- Бернард Шоу
|
|
||||||
%
|
|
||||||
На моем веку было очень много прогресса, но, боюсь, не в том направлении.
|
|
||||||
-- О. Нэш
|
|
||||||
%
|
|
||||||
Нам мало добиться успеха. Надо еще, чтобы друзья наши потерпели крах.
|
|
||||||
-- Ларошфуко
|
|
||||||
%
|
|
||||||
Невеста - женщина, у которой виды на счастье остались позади.
|
|
||||||
-- А. Бирс
|
|
||||||
%
|
|
||||||
Нужно учредить Нобелевскую премию за остроумие. Без физиков, химиков,
|
|
||||||
экономистов мы, если прижмет, как-нибудь обойдемся. Без мира обычно тоже
|
|
||||||
обходимся. Без остроумия - пропадем.
|
|
||||||
-- Джордж Ф. Уилл
|
|
||||||
%
|
|
||||||
О несчастном случае мой подзащитный впервые узнал лишь тогда, когда этот
|
|
||||||
случай произошел.
|
|
||||||
-- Из речи адвоката
|
|
||||||
%
|
|
||||||
Первый и наихудший из всех подвохов - обмануть самого себя. Потом уже
|
|
||||||
легко впасть в любой грех.
|
|
||||||
-- Дж. Бэйли
|
|
||||||
%
|
|
||||||
По самой своей природе человек, чем старше он становится, тем больше
|
|
||||||
противится переменам, особенно переменам к лучшему.
|
|
||||||
-- Дж. Стейнбек
|
|
||||||
%
|
|
||||||
Поиск истины способен изрядно позабавить.
|
|
||||||
-- Вернон Говард
|
|
||||||
%
|
|
||||||
Полицейский находится на своем месте не для того, чтобы создавать
|
|
||||||
беспорядок; полицейский находится там, чтобы поддерживать беспорядок.
|
|
||||||
-- Ричард Дж. Дейли, мэр Чикаго
|
|
||||||
%
|
|
||||||
Посредственность - добродетель в глазах посредственных людей.
|
|
||||||
-- Ж. Жобер
|
|
||||||
%
|
|
||||||
Посредственный учитель излагает. Хороший учитель объясняет. Выдающийся
|
|
||||||
учитель показывает. Великий учитель вдохновляет.
|
|
||||||
-- Уильям Артур Уорд
|
|
||||||
%
|
|
||||||
Президенту в его окружении не нужны мужчины и женщины, умеющие только
|
|
||||||
поддакивать. Если он говорит "нет", мы все говорим "нет".
|
|
||||||
-- Элизабет Доул, помощница президента Рейгана
|
|
||||||
%
|
|
||||||
"Радость моя, мы живем в переходную эпоху", говорил Адам Еве по дороге из
|
|
||||||
рая.
|
|
||||||
-- У. Инге
|
|
||||||
%
|
|
||||||
"С нами такого случиться не может" - это фраза номер один в списке
|
|
||||||
знаменитых последних слов.
|
|
||||||
-- Дэвид Кросби
|
|
||||||
%
|
|
||||||
Самая большая ложь - это неверно понятая правда.
|
|
||||||
-- Уильям Джеймс
|
|
||||||
%
|
|
||||||
Скрипка - инструмент для щекотания человеческих ушей при помощи трения
|
|
||||||
лошадиного хвоста о внутренности кошки.
|
|
||||||
-- Амброз Бирс
|
|
||||||
%
|
|
||||||
Среди преподавателей большинство составляют те, кто не прервет чтение
|
|
||||||
своих лекций по навигации, даже если корабль уже тонет. Следствие:
|
|
||||||
путешествие длиною в тысячу миль завершается одним-единственным шагом.
|
|
||||||
-- Джеймс Г. Борен
|
|
||||||
%
|
|
||||||
Творческое мышление, возможно, означает всего-навсего понимание, что нет
|
|
||||||
никакой особой добродетели в том, чтобы вести дела так, как их всегда вели до
|
|
||||||
нас.
|
|
||||||
-- Рудольф Флеш
|
|
||||||
%
|
|
||||||
Технический прогресс лишь снабдил нас действенными средствами для движения
|
|
||||||
назад.
|
|
||||||
-- О. Хаксли
|
|
||||||
%
|
|
||||||
То, что мы называем прогрессом, представляет собой замену одной
|
|
||||||
неприятности другою.
|
|
||||||
-- Г. Эллис
|
|
||||||
%
|
|
||||||
Учитель прикасается к вечности: никто не может сказать, где кончается его
|
|
||||||
влияние.
|
|
||||||
-- Генри Адамс
|
|
||||||
%
|
|
||||||
Человеку надлежит жить с самим собой и постоянно заботиться, чтобы это
|
|
||||||
была хорошая кампания.
|
|
||||||
-- С.И. Хьюз
|
|
||||||
%
|
|
||||||
Эксперт - это человек, знающий все больше и больше о все меньшем и
|
|
||||||
меньшем. Следствие: колледж не может обеспечить компетентность; он может
|
|
||||||
обеспечить диплом.
|
|
||||||
-- Николас Батлер
|
|
||||||
%
|
|
||||||
Эксперт - это человек, который больше уже не думает; он знает.
|
|
||||||
-- К. Хаббард
|
|
||||||
%
|
|
||||||
Я не верю в коллективную мудрость невежественных индивидуумов.
|
|
||||||
-- Т. Карлейль
|
|
||||||
%
|
|
||||||
Я не против полиции, я просто боюсь ее.
|
|
||||||
-- Альфред Хичкок
|
|
||||||
%
|
|
||||||
Я никогда не мог взять в толк, почему из-за того только, что я выражаюсь
|
|
||||||
невразумительно, никто меня не понимает.
|
|
||||||
-- Милтон Мейер
|
|
||||||
%
|
|
||||||
Пожилые люди думают, что с тех пор, как они постарели, мир только теряет,
|
|
||||||
но ничего не приобретает.
|
|
||||||
-- Жеремена Сталь
|
|
||||||
%
|
|
||||||
Меня интересует мнение не тех людей, которые разбираются в данном вопросе,
|
|
||||||
а тех, которые сами кое-что сделали в одной из областей знания.
|
|
||||||
-- Hорберт Винер
|
|
||||||
%
|
|
||||||
Случайные открытия совершают только подготовленные умы.
|
|
||||||
-- Паскаль
|
|
||||||
%
|
|
||||||
Бывают услуги настолько большие, что рассчитаться за них можно только
|
|
||||||
неблагодарностью.
|
|
||||||
-- Дюма-отец
|
|
||||||
%
|
|
||||||
"Тоже неплохо!" - сказал зять, бросив камнем в собаку, а попав в тещу.
|
|
||||||
-- Плутарх. "Пир семи мудрецов".
|
|
||||||
%
|
|
||||||
Не ковыряй в носу перочинным ножиком. Лезвие легко ржавеет.
|
|
||||||
-- Из книги "Пи"
|
|
||||||
%
|
|
||||||
Очень много - иногда вполне достаточно для женщины.
|
|
||||||
-- Из книги "Ву"
|
|
||||||
%
|
|
||||||
В жизни можно рассчитывать только на самих себя. И то не всегда.
|
|
||||||
-- Тристан Бернар
|
|
||||||
%
|
|
||||||
Все было бы очень хорошо, если бы все наши поступки можно было бы совершать
|
|
||||||
дважды.
|
|
||||||
-- Гете
|
|
||||||
%
|
|
||||||
E = mC
|
|
||||||
-- Альберт Эйнштейн
|
|
||||||
%
|
|
||||||
Человек бывает таким, каким его создал бог, но преимущественно немного хуже.
|
|
||||||
-- Сервантес
|
|
||||||
%
|
|
||||||
Две параллельных линии полюбили друг друга. Трагедия!
|
|
||||||
-- Из книги "Пи"
|
|
||||||
%
|
|
||||||
Я знаток всех "и т. д., и т. п." и я знаю, когда за ними ничего больше
|
|
||||||
не скрывается.
|
|
||||||
-- Гомес де ля Серна
|
|
||||||
%
|
|
||||||
Одна туча может погрузить в темноту весь парк, одно слово может затемнить
|
|
||||||
самое большое счастье.
|
|
||||||
-- Гомес де ля Серна
|
|
||||||
%
|
|
||||||
Тот факт, что будильник не прозвенел, изменило уже много человеческих судеб.
|
|
||||||
-- Агата Кристи
|
|
||||||
%
|
|
||||||
Заполнять жизнь - это еще не значит обогащать ее.
|
|
||||||
-- Из книги "Пи"
|
|
||||||
%
|
|
||||||
Самым серьезным достоинством современного искусства является то, что, когда
|
|
||||||
эти произведения смотрят дети, они не задают таких вопросов, на которые
|
|
||||||
обычно бывает трудно отвечать.
|
|
||||||
-- Лорд Галлюкс
|
|
||||||
%
|
|
||||||
Замужних женщин значительно больше, чем женатых мужчин.
|
|
||||||
-- По данным американской статистики
|
|
||||||
%
|
|
||||||
Совесть - это тот голос, который говорит тебе, что не надо делать именно то,
|
|
||||||
что ты только что сделал.
|
|
||||||
-- Из книги "Пи"
|
|
||||||
%
|
|
||||||
И мелкие неприятности могут отравить жизнь, если нет крупных.
|
|
||||||
-- Р. Гомес де ля Серна
|
|
||||||
%
|
|
||||||
Счастлив тот, кто ни о чем не думает.
|
|
||||||
-- Софокл
|
|
||||||
%
|
|
||||||
Я не читаю газет. Все, о чем там стоит знать, всегда кто-нибудь расскажет.
|
|
||||||
-- Лорд Галлюкс
|
|
||||||
%
|
|
||||||
Недостаточно встать рано, надо еще и проснуться.
|
|
||||||
-- Из книги "Ву"
|
|
||||||
%
|
|
||||||
Высохшую реку не благодарят за ее прошлое.
|
|
||||||
-- Рабиндранат Тагор
|
|
||||||
%
|
|
||||||
Давать советы всегда плохо, но хорошего совета тебе никто не простит.
|
|
||||||
-- Оскар Уайльд
|
|
||||||
%
|
|
||||||
Устарели не только ответы, но даже сами вопросы.
|
|
||||||
-- Хемингуэй
|
|
||||||
%
|
|
||||||
Друзья, как арбузы: случается, что из десяти ни одного хорошего не выбрать.
|
|
||||||
-- Из книги "Пи"
|
|
||||||
%
|
|
||||||
Пока слушатели во время лекции поглядывают на часы, все в порядке. Страшно,
|
|
||||||
когда они начинают удивленно подносить часы к уху.
|
|
||||||
-- Из книги "Пи"
|
|
||||||
%
|
|
||||||
Нет правила, которого нельзя было бы нарушить ради более прекрасного.
|
|
||||||
-- Л. Бетховен
|
|
||||||
%
|
|
||||||
Прекрасна молодость, когда она в движении и знает, куда приложить свои силы.
|
|
||||||
-- Менандр
|
|
||||||
%
|
|
||||||
Простим горячке юных лет
|
|
||||||
И юный жар, и юный бред.
|
|
||||||
-- А. С. Пушкин
|
|
||||||
%
|
|
||||||
Грустно думать, что напрасно
|
|
||||||
Была нам молодость дана.
|
|
||||||
-- А. С. Пушкин
|
|
||||||
%
|
|
||||||
Всего больнее знать, что счастье было так близко - и ты сам его отверг.
|
|
||||||
-- Софокл
|
|
||||||
%
|
|
||||||
Настоящий художник настолько владеет искусством, насколько оно владеет им.
|
|
||||||
-- Г. Флобер
|
|
||||||
%
|
|
||||||
Великие люди сами сооружают себе пьедестал; статую воздвигнет будущее.
|
|
||||||
-- В. Гюго
|
|
||||||
%
|
|
||||||
...заслуги отца на сына не распространяются.
|
|
||||||
-- М. Сервантес
|
|
||||||
%
|
|
||||||
Давайте жить так, чтобы даже гробовщику стало жалко, когда мы умрем.
|
|
||||||
-- Марк Твен
|
|
||||||
%
|
|
||||||
- Обладаешь ли ты разумом?
|
|
||||||
- Обладаю.
|
|
||||||
- Почему же ты не пользуешься им?
|
|
||||||
-- Марк Авелий
|
|
||||||
%
|
|
||||||
Нет такой глупости, которой нельзя было бы исправить при помощи ума,
|
|
||||||
и нет такой мудрости, которой нельзя было бы испортить при помощи глупости.
|
|
||||||
-- В. Гёте
|
|
||||||
%
|
|
||||||
Оптимист верит, что мы живем в лучшем из миров.
|
|
||||||
Пессимист боится, что так оно и есть.
|
|
||||||
%
|
|
||||||
Пессимист видит темный туннель.
|
|
||||||
Оптимист видит свет в конце туннеля.
|
|
||||||
Реалист видит, что это на них мчится поезд.
|
|
||||||
И только машинист видит трех мудаков, тупящих на рельсах.
|
|
||||||
%
|
|
||||||
Мы познаем человека не по тому, что он знает, а по тому, чему он радуется.
|
|
||||||
-- Р.Тагор
|
|
||||||
%
|
|
||||||
Если вы уверены в победе вашей национальной сборной на Евро 2004, то вы либо
|
|
||||||
дурак, либо немец.
|
|
||||||
-- М.Задорнов
|
|
||||||
%
|
|
||||||
Нет некрасивых женщин - есть только женщины, не знающие, что они красивы.
|
|
||||||
-- Вивьен Ли
|
|
||||||
%
|
|
||||||
Любая сложная технология неотличима от волшебства.
|
|
||||||
-- Артур Кларк
|
|
||||||
%
|
|
||||||
Я люблю тебя не за то, кто ты, а за то, кто я, когда я с тобой.
|
|
||||||
-- Габриэль Гарсиа
|
|
||||||
%
|
|
||||||
Ни один человек не заслуживает твоих слез, а те, кто заслуживают,
|
|
||||||
не заставят тебя плакать.
|
|
||||||
-- Габриэль Гарсиа
|
|
||||||
%
|
|
||||||
Только потому что кто-то не любит тебя так, как тебе хочется, не значит,
|
|
||||||
что он не любит тебя всей душой.
|
|
||||||
-- Габриэль Гарсиа
|
|
||||||
%
|
|
||||||
Настоящий друг – это тот, кто будет держать тебя за руку
|
|
||||||
и чувствовать твоё сердце.
|
|
||||||
-- Габриэль Гарсиа
|
|
||||||
%
|
|
||||||
Худший способ скучать по человеку – это быть с ним и понимать,
|
|
||||||
что он никогда не будет твоим.
|
|
||||||
-- Габриэль Гарсиа
|
|
||||||
%
|
|
||||||
Никогда не переставай улыбаться, даже когда тебе грустно: кто-то может влюбиться
|
|
||||||
в твою улыбку.
|
|
||||||
-- Габриэль Гарсиа
|
|
||||||
%
|
|
||||||
Возможно, в этом мире ты всего лишь человек, но для кого-то ты – весь мир.
|
|
||||||
-- Габриэль Гарсиа
|
|
||||||
%
|
|
||||||
Не трать время на человека, который не стремится провести его с тобой.
|
|
||||||
-- Габриэль Гарсиа
|
|
||||||
%
|
|
||||||
Возможно, Бог хочет, чтобы мы встречали не тех людей до того, как встретим того
|
|
||||||
единственного человека. Чтобы, когда это случится, мы были благодарны.
|
|
||||||
-- Габриэль Гарсиа
|
|
||||||
%
|
|
||||||
Не плачь, потому что это закончилось. Улыбнись, потому что это было.
|
|
||||||
-- Габриэль Гарсиа
|
|
||||||
%
|
|
||||||
Всегда найдутся люди, которые причинят тебе боль. Нужно продолжать верить людям,
|
|
||||||
просто быть чуть осторожнее.
|
|
||||||
-- Габриэль Гарсиа
|
|
||||||
%
|
|
||||||
Стань лучше и сам пойми, кто ты, прежде чем встретишь нового человека и будешь
|
|
||||||
надеяться, что он тебя поймет.
|
|
||||||
-- Габриэль Гарсиа
|
|
||||||
%
|
|
||||||
Не прилагай столько усилий, все самое лучшее случается неожиданно.
|
|
||||||
-- Габриэль Гарсиа
|
|
||||||
%
|
|
||||||
Всё, что случаеется, имеет причину.
|
|
||||||
-- Габриэль Гарсиа
|
|
||||||
106
data/friday.txt
106
data/friday.txt
@@ -1,106 +0,0 @@
|
|||||||
А пятница-то не настоящая!!! || 34
|
|
||||||
Спасибо, кэп! || 5
|
|
||||||
А за пивом сегодня идет user || 5
|
|
||||||
user, ты пиво купил? || 5
|
|
||||||
Пятница хоть и небольшой праздник, НО ЗАТО ПОСТОЯННЫЙ! || 45
|
|
||||||
Мечта о пятнице — самая распространенная среди работающего населения. Она начинается уже в понедельник и продолжается четыре дня в неделю || 123
|
|
||||||
Господи дай мне сил не напиться! А если напьюсь, то сделай так чтобы я не плясала, если сил твоих не хватит и я все-таки запляшу, постарайся хотя бы сделать так, что бы не пела! А если и это не удастся, сломай к чертям сервер Ю-тюба! || 5
|
|
||||||
К пятнице готова! Мобильный заряжен, баланс пополнен, в кармане записка с моим адресом || 5
|
|
||||||
ПРЕДУПРЕЖДЕНИЕ: Чрезмерное употребление… Алкоголя. делает ВАШУ пятницу… ОФИГИТЕЛЬНОЙ || 5
|
|
||||||
Сломай систему! Порви шаблоны! Начни новую жизнь с пятницы! || 5
|
|
||||||
В пятницу совесть доживает только до обеда… || 5
|
|
||||||
Сколько работнику не плати, всё равно пятницы ждёт || 1234
|
|
||||||
Робинзооон!!! || 5
|
|
||||||
В пятницу чаще всего хочется выпить. В понедельник чаще всего хочется пятницу. || 15
|
|
||||||
Здравствуй Пятница, здравствуй, любимая, наконец-то ты пришла! || 5
|
|
||||||
Зарплата в пятницу — удар по печени. || 5
|
|
||||||
Вот и пятница пришла, счастье, радость принесла! || 5
|
|
||||||
Все мы — пятницофилы и понедельникофобы. || 15
|
|
||||||
Люблю понедельник — всего три дня до пятницы. || 1
|
|
||||||
Ну здравствуй, пятница. Я дополз к тебе. || 5
|
|
||||||
Пятница. Улыбните Улыбальник. || 5
|
|
||||||
Чувствуете? Выходными пахнет! || 5
|
|
||||||
До пятницы осталось…. пережить четверг! || 4
|
|
||||||
Если пятый день подряд опаздываешь на работу, значит сегодня пятница. || 5
|
|
||||||
От понедельника до пятницы очень далеко, а от пятницы до понедельника рукой подать. || 123467
|
|
||||||
Жизнь начинается в пятницу вечером… В остальное время — выживание. || 5
|
|
||||||
Пятница… белочки следят за тобой. || 5
|
|
||||||
Примета: Если утром жена с вами не разговаривает, значит, вчера была пятница. || 6
|
|
||||||
Чем ближе пятница, тем добрее утро! || 1234
|
|
||||||
Пятница — лучший день недели, особенно её вечер, так как выходные еще не начались, а работа уже закончилась. || 5
|
|
||||||
Отличной была пятница! Особенно запомнились русские народные катания на полицейских бобиках! || 1
|
|
||||||
Четверг это маленькая пятница, а пятницу можно считать выходным. || 4
|
|
||||||
Пятница традиционно начиналась легким ужином в четверг и заканчивалась плотным завтраком в понедельник. || 4
|
|
||||||
Уже с пятницы начинаешь бояться, что скоро понедельник! || 67
|
|
||||||
Каждую пятницу жизнь начинается сначала. || 5
|
|
||||||
С пятницами надо быть осторожней. Они обещают слишком уж многое. Они словно рецензия на кинофильм: лишь в редких случаях предсказанное ими сбывается. || 5
|
|
||||||
Русские в понедельник не работают — у них тяжелый день. || 1
|
|
||||||
Все мы просто дети, изображающие на работе профессионалов, а на самом деле ждущие пятницы, чтобы быть сами собой! || 5
|
|
||||||
Почему-то в пятницу хочется ничего не делать. Хотя в другие дни тоже хочется, но в пятницу ничего не делать хочется особенно сильно. || 5
|
|
||||||
Хочешь жить завтрашним днем — устрой себе семь пятниц на неделе. || 5
|
|
||||||
Что мне снег, что мне зной, что мне вермут разливной, когда мои друзья со мной! || 5
|
|
||||||
Каждую пятницу количество довольных жизнью людей увеличивается на пару миллиардов. Этот эффект длится вплоть до понедельника. || 123467
|
|
||||||
Так, Понедельник, Вторник, Среда, Четверг, проходим, проходим, не задерживаем Пятницу! || 1234
|
|
||||||
Четверг. Смотрю на часы — 16.00. Еле сдерживаюсь, чтобы не закричать — Ура! Во Владивостоке Пятница! || 4
|
|
||||||
Пятница — друг человека! || 5
|
|
||||||
В пятницу вечером понимаешь, что в принципе — жить можно. || 5
|
|
||||||
Ничто так не портит пятницу, как новость о том, что сегодня четверг. || 4
|
|
||||||
Жить нужно так, как будто каждый день пятница. || 123467
|
|
||||||
Только настроился на работу ― и вдруг снова пятница, снова отдых… Вот так всегда! || 5
|
|
||||||
Хорошо, что пятница! Плохо, что еще только утро… || 5
|
|
||||||
Уходя вечером с работы, он был рад, что сегодня пятница и можно спрятаться в уикенде. Он накроется субботой и воскресеньем как двумя толстыми одеялами. Ему ничего не хотелось делать; у него даже не хватало мужества читать. || 5
|
|
||||||
Понедельник ― отходим от выходных, вторник ― готовимся к работе, среда ― работаем, четверг ― отдыхаем от работы, пятница ― готовимся к выходным. Вывод: может, хватит уже работать по средам! || 3
|
|
||||||
Неделя тянется со скоростью улитки. Но в пятницу вечером улитка превращается в Феррари. || 5
|
|
||||||
Прогноз погоды на пятницу: облачно, вечером осадки в виде алкоголя, возможен секс. || 5
|
|
||||||
А пятница всё ближе. Печень в ужасе, попа в предвкушении! || 5
|
|
||||||
Люди, с кем я вчера пила? Объясните, откуда у меня кот и почему люди в магазине мне хлопают… Кстати… никому кот не нужен? || 6
|
|
||||||
ПЯТНИЦА — это старинный народный праздник, который начинают праздновать в ПЯТНИЦУ, а заканчивают — в ПОНЕДЕЛЬНИК || 567
|
|
||||||
Вчера была пятница, завтра суббота, а сегодня тогда что? || 1
|
|
||||||
Сегодня… ПЯТНИЧКА !!! Из хороших новостей пока… ВСЁ… Всем ДОБРА!!! || 5
|
|
||||||
Надену-ка я сегодня красное платье… Под цвет глаз… || 5
|
|
||||||
Вчера был yesterday || 235
|
|
||||||
Вчера была yesterday || 467
|
|
||||||
Вчера было yesterday || 1
|
|
||||||
Никогда еще ожидание пятницы не было столь актуальным… || 4
|
|
||||||
Завтра будет tomorrow || 1234567
|
|
||||||
Четверг - это "завтра пятница". И помнить об этом надо в среду || 34
|
|
||||||
Понедельник - это не начало новой недели, это задница предыдущей( || 1
|
|
||||||
Я, признаться, очень завидую Робинзону Крузо. Живет на острове, никто мозги не е@ет и ПЯТНИЦА, ПЯТНИЦА, ПЯТНИЦА!!! Каждый день ПЯТНИЦА!!! || 1234
|
|
||||||
Наступила пятница — значит мечты начинают сбываться || 5
|
|
||||||
Вечером в пятницу девчонки должны быть алкоголенькими… || 5
|
|
||||||
Позвони мне в субботу рано утром, часов в пятнадцать || 5
|
|
||||||
Ну, вот и пятница пришла… Граждане и гражданки! Следите за своей белкой, чтобы она не разгорячилась! || 5
|
|
||||||
Ага, вчера был понедельник, а сегодня сразу ПЯТНИЦА! ЩАС! || 2
|
|
||||||
Вот пятница пролетела, наступил понедельник, но не все, не все вернулись на свои рабочие места || 1
|
|
||||||
Работа не волк… В лес не убежит?.. А вдруг убежит… Так, за раздумьями и мечтами, и проходит рабочий день… || 12345
|
|
||||||
Какой бы долгой и увлекательной ни была вечеринка, сделайте все, чтобы завтра проснуться в собственной спальне || 5
|
|
||||||
Тяжелое воскресное засыпание объясняется вполне объективной причиной — организм на подсознательном уровне пытается продлить выходной… || 7
|
|
||||||
Воскресенье — день недели с привкусом разочарования. Вроде и выходной, но все равно что-то не то || 7
|
|
||||||
У воскресного дня есть только один существенный недостаток — он почему-то кончается в два раза быстрее, чем любой понедельник или четверг. || 7
|
|
||||||
Первое правило хороших выходных - не вставать рано с постели || 67
|
|
||||||
Понедельник — это такой день, когда вместо бейджика хочется повесить табличку: "Осторожно, злая собака" || 1
|
|
||||||
Нас тупило утро понедельника || 1
|
|
||||||
Бедный понедельник. Его ж никто не любит! || 1
|
|
||||||
Вот выйду на пенсию — буду каждый понедельник выходить на улицу в семь утра и смотреть, как люди идут на работу и страдают || 1
|
|
||||||
Если бы понедельник имел лицо… я бы его… ударила... || 1
|
|
||||||
Завтра во всех домах страны: психологическая драма "утро понедельника" || 7
|
|
||||||
Надеюсь, когда-нибудь я проснусь утром, включу новости и услышу: "Понедельник отменен, продолжайте спать…" || 1
|
|
||||||
Хороший день словом Моndау не назовут! || 1
|
|
||||||
Люди, почему вы злитесь только на понедельник? Как будто в другие дни работать хочется || 1
|
|
||||||
Лучше утро пятницы, чем вечер понедельника || 15
|
|
||||||
Если вы проживете 70 лет, то проживете 10 лет понедельников… || 1
|
|
||||||
Берите пример с понедельника: его никто не ждёт, а ему по)(уй, он все равно приходит… || 1
|
|
||||||
Завтра будет лучше, чем вчера! А, нет, завтра ПОНЕДЕЛЬНИК || 7
|
|
||||||
Три ужасные новости: 1. Сегодня не пятница. 2. И даже завтра не пятница. 3. И даже послезавтра не пятница || 12
|
|
||||||
В понедельник утром, очень сильно завидуешь… безработным || 1
|
|
||||||
Понедельник — удобный повод чего-нибудь понеделать... || 1
|
|
||||||
Дамы и господа! Предлагаю почтить утро понедельника минутой ворчания || 1
|
|
||||||
Вот и начались трудо выебудни || 5
|
|
||||||
Каждый понедельник меня мучает вопрос: выходные, вы вообще были? || 1
|
|
||||||
На улице вторник, а на душе — вечер пятницы… || 2
|
|
||||||
Наступил долгожданный вторник — послезавтра предпоследний день рабочей недели… || 2
|
|
||||||
Если второй день не охота идти на работу, значит сегодня вторник || 2
|
|
||||||
Предлагаю переименовать четверг в "завтра пятница"! || 4
|
|
||||||
Говорят, при Сталине все субботы были рабочие, должно быть он и вправду был садист и тиран! || 6
|
|
||||||
Остановись, воскресенье! Ты прекрасно!!! || 7
|
|
||||||
Воскресенье — день трагичный. Суббота маячит далеко позади, а до понедельника уже рукой подать || 7
|
|
||||||
1336
data/lat.txt
1336
data/lat.txt
File diff suppressed because it is too large
Load Diff
@@ -7,37 +7,6 @@
|
|||||||
"gamestatdir" : "data/gamestat"
|
"gamestatdir" : "data/gamestat"
|
||||||
},
|
},
|
||||||
|
|
||||||
"fortune" : {
|
|
||||||
"dir" : "data/fortune",
|
|
||||||
"srcdir" : "data/fortune_src"
|
|
||||||
},
|
|
||||||
|
|
||||||
"friday" : {
|
|
||||||
"dir" : "data/friday",
|
|
||||||
"src" : "data/friday.txt"
|
|
||||||
},
|
|
||||||
|
|
||||||
"image": {
|
|
||||||
"imgur" : {
|
|
||||||
# See README.md about these settings - auth'ed search settings.
|
|
||||||
"client-id" : "imgur api client id",
|
|
||||||
"secret" : "secret for client id",
|
|
||||||
"access_token" : "access token for querying imgur api",
|
|
||||||
"refresh_token" : "token for refreshing access token"
|
|
||||||
},
|
|
||||||
"flickr" : {
|
|
||||||
# See README.md about these settings - auth'ed search settings.
|
|
||||||
"consumer_key" : "md5-like_hash",
|
|
||||||
"consumer_secret" : "some_hash-like_string",
|
|
||||||
"verifier": "some_hash-like_string"
|
|
||||||
}
|
|
||||||
},
|
|
||||||
|
|
||||||
"lat" : {
|
|
||||||
"brain": "data/lat/brain.sqlite",
|
|
||||||
"src": "data/lat.txt"
|
|
||||||
},
|
|
||||||
|
|
||||||
# Required for debugging reasons, if commented out or not exist, no debug logging appears at all.
|
# Required for debugging reasons, if commented out or not exist, no debug logging appears at all.
|
||||||
"log" : "/var/log/aleesa-telegram-bot/aleesa.log",
|
"log" : "/var/log/aleesa-telegram-bot/aleesa.log",
|
||||||
|
|
||||||
@@ -45,11 +14,6 @@
|
|||||||
# Currently implemented debug, info, notice, warn, error, fatal. Notice is default logging level.
|
# Currently implemented debug, info, notice, warn, error, fatal. Notice is default logging level.
|
||||||
"loglevel": "notice",
|
"loglevel": "notice",
|
||||||
|
|
||||||
# Openwatermap plugin.
|
|
||||||
"openweathermap" : {
|
|
||||||
"appid" : "md5sum-like_string",
|
|
||||||
},
|
|
||||||
|
|
||||||
# Stuff for telegram itself.
|
# Stuff for telegram itself.
|
||||||
"telegrambot" : {
|
"telegrambot" : {
|
||||||
|
|
||||||
@@ -64,5 +28,12 @@
|
|||||||
},
|
},
|
||||||
|
|
||||||
# Unprivileged user to run this bot from.
|
# Unprivileged user to run this bot from.
|
||||||
"user" : "unit",
|
"user" : "nobody",
|
||||||
|
|
||||||
|
"redis_server": "127.0.0.1",
|
||||||
|
"redis_port" : "6379",
|
||||||
|
"redis_channels" : [
|
||||||
|
"telegram"
|
||||||
|
],
|
||||||
|
"redis_router_channel" : "misc"
|
||||||
}
|
}
|
||||||
|
|||||||
315
lib/BotLib.pm
315
lib/BotLib.pm
@@ -7,210 +7,150 @@ 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 (carp);
|
use Carp qw (carp);
|
||||||
|
use Clone qw (clone);
|
||||||
use Math::Random::Secure qw (irand);
|
use Math::Random::Secure qw (irand);
|
||||||
|
use Data::Dumper;
|
||||||
|
use Log::Any qw ($log);
|
||||||
|
|
||||||
use BotLib::Conf qw (LoadConf);
|
use BotLib::Conf qw (LoadConf);
|
||||||
use BotLib::Admin qw (@ForbiddenMessageTypes GetForbiddenTypes AddForbiddenType
|
use BotLib::Admin qw (@ForbiddenMessageTypes GetForbiddenTypes AddForbiddenType
|
||||||
DelForbiddenType ListForbidden FortuneToggle FortuneStatus
|
DelForbiddenType ListForbidden FortuneToggle FortuneStatus
|
||||||
PluginToggle PluginStatus PluginEnabled);
|
PluginToggle PluginStatus PluginEnabled ChanMsgToggle ChanMsgStatus);
|
||||||
use BotLib::Archeologist qw (Dig);
|
|
||||||
use BotLib::Buni qw (Buni);
|
|
||||||
use BotLib::Drink qw (Drink);
|
|
||||||
use BotLib::Fisher qw (Fish);
|
|
||||||
use BotLib::Fortune qw (Fortune);
|
|
||||||
use BotLib::Friday qw (Friday);
|
|
||||||
use BotLib::Image qw (Kitty Fox Oboobs Obutts Rabbit Owl Frog Horse Snail);
|
|
||||||
use BotLib::Karma qw (KarmaSet KarmaGet);
|
|
||||||
use BotLib::Lat qw (Lat);
|
|
||||||
use BotLib::Monkeyuser qw (Monkeyuser);
|
|
||||||
use BotLib::Util qw (trim);
|
use BotLib::Util qw (trim);
|
||||||
use BotLib::Weather qw (Weather);
|
|
||||||
use BotLib::Xkcd qw (Xkcd);
|
|
||||||
|
|
||||||
use version; our $VERSION = qw (1.0);
|
use version; our $VERSION = qw (1.0);
|
||||||
use Exporter qw (import);
|
use Exporter qw (import);
|
||||||
our @EXPORT_OK = qw (RandomCommonPhrase Command Highlight BotSleep IsCensored);
|
our @EXPORT_OK = qw (Command Highlight BotSleep IsCensored);
|
||||||
|
|
||||||
my $c = LoadConf ();
|
my $c = LoadConf ();
|
||||||
my $csign = $c->{telegrambot}->{csign};
|
my $csign = $c->{telegrambot}->{csign};
|
||||||
|
my $redismsg->{from} = 'telegram';
|
||||||
sub RandomCommonPhrase {
|
$redismsg->{plugin} = 'telegram';
|
||||||
my @myphrase = (
|
$redismsg->{misc}->{answer} = 1;
|
||||||
'Так, блядь...',
|
$redismsg->{misc}->{csign} = $c->{telegrambot}->{csign};
|
||||||
'*Закатывает рукава* И ради этого ты меня позвал?',
|
$redismsg->{misc}->{msg_format} = 0;
|
||||||
'Ну чего ты начинаешь, нормально же общались',
|
$redismsg->{misc}->{fwd_cnt} = 1;
|
||||||
'Повтори свой вопрос, не поняла',
|
|
||||||
'Выйди и зайди нормально',
|
|
||||||
'Я подумаю',
|
|
||||||
'Даже не знаю что на это ответить',
|
|
||||||
'Ты упал такие вопросы девочке задавать?',
|
|
||||||
'Можно и так, но не уверена',
|
|
||||||
'А как ты думаешь?',
|
|
||||||
'А ви, таки, почему интересуетесь?',
|
|
||||||
);
|
|
||||||
|
|
||||||
return $myphrase[irand ($#myphrase + 1)];
|
|
||||||
}
|
|
||||||
|
|
||||||
sub Command {
|
sub Command {
|
||||||
my $self = shift;
|
my $self = shift;
|
||||||
my $msg = shift;
|
my $msg = shift;
|
||||||
my $text = shift;
|
my $text = shift;
|
||||||
my $chatid = shift;
|
my $chatid = shift;
|
||||||
|
|
||||||
my $reply;
|
my $reply;
|
||||||
my ($userid, $username, $fullname, $highlight, $visavi) = Highlight ($msg);
|
my ($userid, $username, $fullname, $highlight, $visavi) = Highlight ($msg);
|
||||||
|
my $rmsg = clone ($redismsg);
|
||||||
|
$rmsg->{userid} = $userid;
|
||||||
|
$rmsg->{chatid} = $chatid;
|
||||||
|
|
||||||
if (substr ($text, 1) eq 'ping') {
|
if ($chatid >= 0) {
|
||||||
$reply = 'Pong.';
|
$rmsg->{mode} = 'private';
|
||||||
} elsif (substr ($text, 1) eq 'пинг') {
|
} else {
|
||||||
$reply = 'Понг.';
|
$rmsg->{mode} = 'public';
|
||||||
} elsif (substr ($text, 1) eq 'pong') {
|
}
|
||||||
$reply = 'Wat?';
|
|
||||||
} elsif (substr ($text, 1) eq 'понг') {
|
|
||||||
$reply = 'Шта?';
|
|
||||||
} elsif (substr ($text, 1) eq 'ver' || substr ($text, 1) eq 'version' || substr ($text, 1) eq 'версия') {
|
|
||||||
$reply = 'Версия: Нуль.Чего-то_там.Чего-то_там';
|
|
||||||
} elsif (length ($text) >= 2 && (substr ($text, 1, 2) eq 'w ' || substr ($text, 1, 2) eq 'п ')) {
|
|
||||||
my $city = substr $text, 3;
|
|
||||||
$reply = Weather $city;
|
|
||||||
} elsif (substr ($text, 1) eq 'buni') {
|
|
||||||
$msg->typing ();
|
|
||||||
$reply = Buni ();
|
|
||||||
sleep (irand (2) + 1);
|
|
||||||
$msg->replyMd ($reply);
|
|
||||||
return;
|
|
||||||
} elsif (substr ($text, 1) eq 'monkeyuser') {
|
|
||||||
$msg->typing ();
|
|
||||||
$reply = Monkeyuser ();
|
|
||||||
sleep (irand (2) + 1);
|
|
||||||
$msg->replyMd ($reply);
|
|
||||||
return;
|
|
||||||
} elsif (substr ($text, 1) eq 'cat' || substr ($text, 1) eq 'кис') {
|
|
||||||
$msg->typing ();
|
|
||||||
$reply = Kitty ();
|
|
||||||
sleep (irand (2) + 1);
|
|
||||||
$msg->replyMd ($reply);
|
|
||||||
return;
|
|
||||||
} elsif (substr ($text, 1) eq 'frog' || substr ($text, 1) eq 'toad' || substr ($text, 1) eq 'лягушка') {
|
|
||||||
$msg->typing ();
|
|
||||||
$reply = Frog ();
|
|
||||||
sleep (irand (2) + 1);
|
|
||||||
$msg->replyMd ($reply);
|
|
||||||
return;
|
|
||||||
} elsif (substr ($text, 1) eq 'horse' || substr ($text, 1) eq 'лошадка') {
|
|
||||||
$msg->typing ();
|
|
||||||
$reply = Horse ();
|
|
||||||
sleep (irand (2) + 1);
|
|
||||||
$msg->replyMd ($reply);
|
|
||||||
return;
|
|
||||||
} elsif (substr ($text, 1) eq 'snail' || substr ($text, 1) eq 'улитка') {
|
|
||||||
$msg->typing ();
|
|
||||||
$reply = Snail ();
|
|
||||||
sleep (irand (2) + 1);
|
|
||||||
$msg->replyMd ($reply);
|
|
||||||
return;
|
|
||||||
} elsif (substr ($text, 1) eq 'lat' || substr ($text, 1) eq 'лат') {
|
|
||||||
$reply = Lat ();
|
|
||||||
} 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) {
|
my $cmd = substr $text, 1;
|
||||||
$mytext = substr $text, 7;
|
|
||||||
chomp $mytext;
|
# Проверка #1 на админское разрешение некоторых команд
|
||||||
$mytext = trim $mytext;
|
my @cmds = qw (tits boobs tities boobies сиси сисечки);
|
||||||
} else {
|
|
||||||
$mytext = '';
|
while (my $check = pop @cmds) {
|
||||||
|
if ($cmd eq $check) {
|
||||||
|
unless (PluginEnabled $chatid, 'oboobs') {
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
# Проверка #2 на админское разрешение некоторых команд
|
||||||
|
$#cmds = -1;
|
||||||
|
@cmds = qw (butt booty ass попа попка);
|
||||||
|
|
||||||
|
while (my $check = pop @cmds) {
|
||||||
|
if ($cmd eq $check) {
|
||||||
|
unless (PluginEnabled $chatid, 'obutts') {
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
# Полноценный поиск простой команды во входящем сообщении
|
||||||
|
$#cmds = -1;
|
||||||
|
@cmds = qw (ping пинг пинх pong понг понх coin монетка roll dice кости ver version версия хэлп halp kde кде lat
|
||||||
|
лат friday пятница proverb пословица fortune фортунка f ф anek анек анекдот buni cat кис drink праздник fox лис
|
||||||
|
frog лягушка horse лошадь лошадка monkeyuser owl сова сыч rabbit bunny кролик snail улитка tits boobs tities
|
||||||
|
boobies сиси сисечки butt booty ass попа попка xkcd dig копать fish fishing рыба рыбка рыбалка);
|
||||||
|
|
||||||
|
my $bingo = 0;
|
||||||
|
|
||||||
|
while (my $check = pop @cmds) {
|
||||||
|
if ($cmd eq $check) {
|
||||||
|
$bingo = 1;
|
||||||
|
last;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
# Поиск "сложных" команд во входящем сообщении
|
||||||
|
if (($cmd =~ /^w\s/u) || ($cmd =~ /^п\s/u) || ($cmd =~ /^weather\s/u) || ($cmd =~ /^погода\s/u) ||
|
||||||
|
($cmd =~ /^погодка\s/u) || ($cmd =~ /^погадка\s/u) || ($cmd =~ /^karma\s/u) || ($cmd =~ /карма\s/u)) {
|
||||||
|
$bingo = 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
# Если команда найдена...
|
||||||
|
if ($bingo) {
|
||||||
|
$rmsg->{message} = $text;
|
||||||
|
$self->log->debug ('[DEBUG] Sending message to redis ' . Dumper ($rmsg));
|
||||||
|
|
||||||
|
# Для некоторых команд мы хотим получать форматированный вывод
|
||||||
|
$#cmds = -1;
|
||||||
|
@cmds = qw (fortune фортунка f ф anek анек анекдот buni cat кис fox лис frog лягушка horse лошадь
|
||||||
|
лошадка monkeyuser owl сова сыч rabbit bunny кролик snail улитка tits boobs tities boobies сиси сисечки
|
||||||
|
butt booty ass попа попка xkcd);
|
||||||
|
|
||||||
|
while (my $check = pop @cmds) {
|
||||||
|
if ($cmd eq $check) {
|
||||||
|
$rmsg->{misc}->{msg_format} = 1;
|
||||||
|
last;
|
||||||
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
$reply = KarmaGet ($chatid, $mytext);
|
# Для других команд, хотим, чтобы было упоминание пользователя в ответе, чтобы подсветить его
|
||||||
} elsif (substr ($text, 1) eq 'xkcd') {
|
$#cmds = -1;
|
||||||
$msg->typing ();
|
@cmds = qw (dig копать fish fishing рыба рыбка рыбалка);
|
||||||
$reply = Xkcd ();
|
|
||||||
sleep (irand (2) + 1);
|
while (my $check = pop @cmds) {
|
||||||
$msg->replyMd ($reply);
|
if ($cmd eq $check) {
|
||||||
return;
|
$rmsg->{misc}->{msg_format} = 1;
|
||||||
} elsif (substr ($text, 1) eq 'fox' || substr ($text, 1) eq 'лис') {
|
$rmsg->{misc}->{username} = $highlight;
|
||||||
$msg->typing ();
|
last;
|
||||||
$reply = Fox ();
|
}
|
||||||
sleep (irand (2) + 1);
|
|
||||||
$msg->replyMd ($reply);
|
|
||||||
return;
|
|
||||||
} elsif (substr ($text, 1) eq 'rabbit' || substr ($text, 1) eq 'bunny' || substr ($text, 1) eq 'кролик') {
|
|
||||||
$msg->typing ();
|
|
||||||
$reply = Rabbit ();
|
|
||||||
$msg->replyMd ($reply);
|
|
||||||
return;
|
|
||||||
} elsif (substr ($text, 1) eq 'owl' || substr ($text, 1) eq 'сова') {
|
|
||||||
$msg->typing ();
|
|
||||||
$reply = Owl ();
|
|
||||||
$msg->replyMd ($reply);
|
|
||||||
return;
|
|
||||||
} elsif (
|
|
||||||
substr ($text, 1) eq 'tits' ||
|
|
||||||
substr ($text, 1) eq 'boobs' ||
|
|
||||||
substr ($text, 1) eq 'tities' ||
|
|
||||||
substr ($text, 1) eq 'boobies' ||
|
|
||||||
substr ($text, 1) eq 'сиси' ||
|
|
||||||
substr ($text, 1) eq 'сисечки'
|
|
||||||
) {
|
|
||||||
if (PluginEnabled $chatid, 'oboobs') {
|
|
||||||
$msg->typing ();
|
|
||||||
$reply = Oboobs ();
|
|
||||||
sleep (irand (2) + 1);
|
|
||||||
$msg->replyMd ($reply);
|
|
||||||
}
|
}
|
||||||
|
|
||||||
return;
|
# Если соединения с редиской нету, ждём, пока оно появится. Своего рода костыль на всякий случай.
|
||||||
} elsif (
|
{
|
||||||
substr ($text, 1) eq 'butt' ||
|
do {
|
||||||
substr ($text, 1) eq 'booty' ||
|
my $ready = eval { $main::RCONN->is_connected; };
|
||||||
substr ($text, 1) eq 'ass' ||
|
last if ($ready);
|
||||||
substr ($text, 1) eq 'попа' ||
|
} while (sleep 1);
|
||||||
substr ($text, 1) eq 'попка'
|
|
||||||
) {
|
|
||||||
if (PluginEnabled $chatid, 'obutts') {
|
|
||||||
$msg->typing ();
|
|
||||||
$reply = Obutts ();
|
|
||||||
sleep (irand (2) + 1);
|
|
||||||
$msg->replyMd ($reply);
|
|
||||||
}
|
}
|
||||||
|
|
||||||
return;
|
my $pubsub = $main::REDIS->pubsub;
|
||||||
} elsif (substr ($text, 1) eq 'friday' || substr ($text, 1) eq 'пятница') {
|
|
||||||
$reply = Friday ();
|
$pubsub->json ($c->{'redis_router_channel'})->notify (
|
||||||
} elsif (substr ($text, 1) eq 'fortune' || substr ($text, 1) eq 'фортунка' || substr ($text, 1) eq 'f' || substr ($text, 1) eq 'ф') {
|
$c->{'redis_router_channel'} => $rmsg
|
||||||
$reply = sprintf "```\n%s\n```\n", trim (Fortune ());
|
);
|
||||||
$msg->replyMd ($reply);
|
# Если команда не найдена, но строка подозрительно напоминает команду help
|
||||||
return;
|
|
||||||
} elsif (substr ($text, 1) eq 'drink' || substr ($text, 1) eq 'праздник') {
|
|
||||||
$msg->typing ();
|
|
||||||
$reply = Drink ();
|
|
||||||
sleep (irand (2) + 1);
|
|
||||||
} elsif (substr ($text, 1) eq 'dig' || substr ($text, 1) eq 'копать') {
|
|
||||||
$msg->typing ();
|
|
||||||
$reply = Dig $highlight;
|
|
||||||
sleep (irand (2) + 1);
|
|
||||||
$msg->replyMd ($reply);
|
|
||||||
return;
|
|
||||||
} elsif (substr ($text, 1) eq 'fish' || substr ($text, 1) eq 'fishing' || substr ($text, 1) eq 'рыба' || substr ($text, 1) eq 'рыбка' || substr ($text, 1) eq 'рыбалка' ) {
|
|
||||||
$msg->typing ();
|
|
||||||
$reply = Fish $highlight;
|
|
||||||
sleep (irand (2) + 1);
|
|
||||||
$msg->replyMd ($reply);
|
|
||||||
return;
|
|
||||||
} elsif (substr ($text, 1) eq 'хэлп' || substr ($text, 1) eq 'хелп') {
|
|
||||||
$reply = 'HALP!!!11';
|
|
||||||
} elsif (substr ($text, 1) eq 'help' || substr ($text, 1) eq 'помощь') {
|
} elsif (substr ($text, 1) eq 'help' || substr ($text, 1) eq 'помощь') {
|
||||||
$reply = << "MYHELP";
|
$reply = << "MYHELP";
|
||||||
```
|
```
|
||||||
${csign}help | ${csign}помощь - список команд
|
${csign}help | ${csign}помощь - список команд
|
||||||
|
${csign}anek | ${csign}анек | ${csign}анекдот - рандомный анекдот с anekdot.ru
|
||||||
${csign}buni - рандомный стрип hapi buni
|
${csign}buni - рандомный стрип hapi buni
|
||||||
${csign}bunny | ${csign}rabbit | ${csign}кролик - кролик
|
${csign}bunny | ${csign}rabbit | ${csign}кролик - кролик
|
||||||
${csign}cat | ${csign}кис - кошечка
|
${csign}cat | ${csign}кис - кошечка
|
||||||
|
${csign}coin | ${csign}монетка - подбросить монетку - орёл или решка?
|
||||||
${csign}dig | ${csign}копать - заняться археологией
|
${csign}dig | ${csign}копать - заняться археологией
|
||||||
${csign}drink | ${csign}праздник - какой сегодня праздник?
|
${csign}drink | ${csign}праздник - какой сегодня праздник?
|
||||||
${csign}fish | ${csign}рыба | ${csign}рыбка - порыбачить
|
${csign}fish | ${csign}рыба | ${csign}рыбка - порыбачить
|
||||||
@@ -223,11 +163,17 @@ ${csign}frog | ${csign}лягушка - лягушка
|
|||||||
${csign}horse | ${csign}лошадка - лошадка
|
${csign}horse | ${csign}лошадка - лошадка
|
||||||
${csign}lat | ${csign}лат - сгенерить фразу из крылатых латинских выражений
|
${csign}lat | ${csign}лат - сгенерить фразу из крылатых латинских выражений
|
||||||
${csign}monkeyuser - рандомный стрип MonkeyUser
|
${csign}monkeyuser - рандомный стрип MonkeyUser
|
||||||
${csign}owl | ${csign}сова - сова
|
${csign}owl | ${csign}сова | ${csign}сыч - сова
|
||||||
|
${csign}proverb | ${csign}пословица - рандомная русская пословица
|
||||||
${csign}ping | ${csign}пинг - попинговать бота
|
${csign}ping | ${csign}пинг - попинговать бота
|
||||||
|
${csign}roll | ${csign}dice | ${csign}кости - бросить кости
|
||||||
${csign}snail | ${csign}улитка - улитка
|
${csign}snail | ${csign}улитка - улитка
|
||||||
${csign}ver | ${csign}version | ${csign}версия - что-то про версию ПО
|
${csign}ver | ${csign}version | ${csign}версия - что-то про версию ПО
|
||||||
${csign}w город | ${csign}п город - погода в указанном городе
|
${csign}w город | ${csign}п город - погода в указанном городе
|
||||||
|
${csign}weather город - погода в указанном городе
|
||||||
|
${csign}погода город - погода в указанном городе
|
||||||
|
${csign}погодка город - погода в указанном городе
|
||||||
|
${csign}погадка город - погода в указанном городе
|
||||||
${csign}xkcd - рандомный стрип с сайта xkcd.ru
|
${csign}xkcd - рандомный стрип с сайта xkcd.ru
|
||||||
${csign}karma фраза | ${csign}карма фраза - посмотреть карму фразы
|
${csign}karma фраза | ${csign}карма фраза - посмотреть карму фразы
|
||||||
фраза-- | фраза++ - убавить или добавить карму фразе
|
фраза-- | фраза++ - убавить или добавить карму фразе
|
||||||
@@ -237,10 +183,11 @@ ${csign}karma фраза | ${csign}карма фраза - посмотреть
|
|||||||
MYHELP
|
MYHELP
|
||||||
$msg->replyMd ($reply);
|
$msg->replyMd ($reply);
|
||||||
return;
|
return;
|
||||||
|
# Если строка не найдена, но это команда admin
|
||||||
} elsif (substr ($text, 1) eq 'admin' || substr ($text, 1) eq 'админ') {
|
} elsif (substr ($text, 1) eq 'admin' || substr ($text, 1) eq 'админ') {
|
||||||
my $member = $self->getChatMember ({ 'chat_id' => $msg->chat->id, 'user_id' => $msg->from->id });
|
my $member = $self->getChatMember ({ 'chat_id' => $msg->chat->id, 'user_id' => $msg->from->id });
|
||||||
|
|
||||||
# this msg should be shown only if admins of chat request it
|
# Это должно показываться только админам чата
|
||||||
if (($member->status eq 'administrator') || ($member->status eq 'creator')) {
|
if (($member->status eq 'administrator') || ($member->status eq 'creator')) {
|
||||||
$reply = << "MYADMIN";
|
$reply = << "MYADMIN";
|
||||||
```
|
```
|
||||||
@@ -256,6 +203,8 @@ ${csign}admin oboobs # - где 1 - вкл, 0 - выкл плагина obo
|
|||||||
${csign}admin oboobs - показываем ли сисечки по просьбе участников чата (команды ${csign}tits, ${csign}tities, ${csign}boobs, ${csign}boobies, ${csign}сиси, ${csign}сисечки)
|
${csign}admin oboobs - показываем ли сисечки по просьбе участников чата (команды ${csign}tits, ${csign}tities, ${csign}boobs, ${csign}boobies, ${csign}сиси, ${csign}сисечки)
|
||||||
${csign}admin obutts # - где 1 - вкл, 0 - выкл плагина obutts
|
${csign}admin obutts # - где 1 - вкл, 0 - выкл плагина obutts
|
||||||
${csign}admin obutts - показываем ли попки по просьбе участников чата (команды ${csign}ass, ${csign}butt, ${csign}booty, ${csign}попа, ${csign}попка)
|
${csign}admin obutts - показываем ли попки по просьбе участников чата (команды ${csign}ass, ${csign}butt, ${csign}booty, ${csign}попа, ${csign}попка)
|
||||||
|
${csign}admin chan_msg - оставляем ли сообщения присланные от имени (других) каналов
|
||||||
|
${csign}admin chan_msg # - где 1 - оставляем, 0 - удаляем
|
||||||
```
|
```
|
||||||
Типы сообщений:
|
Типы сообщений:
|
||||||
audio voice photo video animation sticker dice game poll document
|
audio voice photo video animation sticker dice game poll document
|
||||||
@@ -265,17 +214,24 @@ MYADMIN
|
|||||||
}
|
}
|
||||||
|
|
||||||
return;
|
return;
|
||||||
|
# Если строка не найдена, но это команда admin с параметрами
|
||||||
} elsif ((substr ($text, 1, 5) eq 'admin' || substr ($text, 1, 5) eq 'админ') && (length ($text) >= 8)) {
|
} elsif ((substr ($text, 1, 5) eq 'admin' || substr ($text, 1, 5) eq 'админ') && (length ($text) >= 8)) {
|
||||||
my $member = $self->getChatMember ({ 'chat_id' => $msg->chat->id, 'user_id' => $msg->from->id });
|
my $member = $self->getChatMember ({ 'chat_id' => $msg->chat->id, 'user_id' => $msg->from->id });
|
||||||
|
|
||||||
# this msg should be shown only if admins of chat request it
|
# Это должно показываться только админам чата
|
||||||
if (($member->status eq 'administrator') || ($member->status eq 'creator')) {
|
if (($member->status eq 'administrator') || ($member->status eq 'creator')) {
|
||||||
|
# Вынем субкоманду, это первый аргумент команды admin
|
||||||
my $command = trim (substr $text, 7);
|
my $command = trim (substr $text, 7);
|
||||||
my ($cmd, $args) = split /\s+/, $command, 2;
|
$cmd = undef;
|
||||||
|
my $args;
|
||||||
|
($cmd, $args) = split /\s+/, $command, 2;
|
||||||
|
|
||||||
|
# Субкоманды не нашлось, ну и какбэ досвидонья
|
||||||
if ($cmd eq '') {
|
if ($cmd eq '') {
|
||||||
return;
|
return;
|
||||||
|
# Субкоманда censor...
|
||||||
} elsif ($cmd eq 'censor' || $cmd eq 'ценз') {
|
} elsif ($cmd eq 'censor' || $cmd eq 'ценз') {
|
||||||
|
# Censor с аргументами
|
||||||
if (defined ($args) && ($args ne '')) {
|
if (defined ($args) && ($args ne '')) {
|
||||||
my ($msgType, $toggle) = split /\s/, $args, 2;
|
my ($msgType, $toggle) = split /\s/, $args, 2;
|
||||||
|
|
||||||
@@ -292,9 +248,11 @@ MYADMIN
|
|||||||
}
|
}
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
# Censor без аргументов, выдаёт список типов сообщений и будут ли они автоматически удаляться
|
||||||
} else {
|
} else {
|
||||||
$reply = ListForbidden ($chatid);
|
$reply = ListForbidden ($chatid);
|
||||||
}
|
}
|
||||||
|
# Хотим ли мы показывать фортунку с утра
|
||||||
} elsif ($cmd eq 'fortune' || $cmd eq 'фортунка') {
|
} elsif ($cmd eq 'fortune' || $cmd eq 'фортунка') {
|
||||||
if (defined $args) {
|
if (defined $args) {
|
||||||
if ($args == 1) {
|
if ($args == 1) {
|
||||||
@@ -305,6 +263,18 @@ MYADMIN
|
|||||||
} else {
|
} else {
|
||||||
$reply = FortuneStatus ($chatid);
|
$reply = FortuneStatus ($chatid);
|
||||||
}
|
}
|
||||||
|
# Хотим ли мы удалять "сообщения от каналов"
|
||||||
|
} elsif ($cmd eq 'chan_msg') {
|
||||||
|
if (defined $args) {
|
||||||
|
if ($args == 1) {
|
||||||
|
$reply = ChanMsgToggle ($chatid, 1);
|
||||||
|
} elsif ($args == 0) {
|
||||||
|
$reply = ChanMsgToggle ($chatid, 0);
|
||||||
|
}
|
||||||
|
} else {
|
||||||
|
$reply = ChanMsgStatus ($chatid);
|
||||||
|
}
|
||||||
|
# Работает ли плагин oboobs в чатике
|
||||||
} elsif ($cmd eq 'oboobs') {
|
} elsif ($cmd eq 'oboobs') {
|
||||||
if (defined $args) {
|
if (defined $args) {
|
||||||
if ($args == 1) {
|
if ($args == 1) {
|
||||||
@@ -315,6 +285,7 @@ MYADMIN
|
|||||||
} else {
|
} else {
|
||||||
$reply = PluginStatus ($chatid, 'oboobs');
|
$reply = PluginStatus ($chatid, 'oboobs');
|
||||||
}
|
}
|
||||||
|
# Работает ли плагин obutts в чатике
|
||||||
} elsif ($cmd eq 'obutts') {
|
} elsif ($cmd eq 'obutts') {
|
||||||
if (defined $args) {
|
if (defined $args) {
|
||||||
if ($args == 1) {
|
if ($args == 1) {
|
||||||
|
|||||||
@@ -18,7 +18,7 @@ use Exporter qw (import);
|
|||||||
our @ISA = qw / Exporter /; ## no critic (ClassHierarchies::ProhibitExplicitISA)
|
our @ISA = qw / Exporter /; ## no critic (ClassHierarchies::ProhibitExplicitISA)
|
||||||
our @EXPORT_OK = qw (@ForbiddenMessageTypes @PluginList GetForbiddenTypes AddForbiddenType DelForbiddenType
|
our @EXPORT_OK = qw (@ForbiddenMessageTypes @PluginList GetForbiddenTypes AddForbiddenType DelForbiddenType
|
||||||
ListForbidden FortuneToggle FortuneToggleList FortuneStatus PluginToggle PluginStatus
|
ListForbidden FortuneToggle FortuneToggleList FortuneStatus PluginToggle PluginStatus
|
||||||
PluginEnabled);
|
PluginEnabled ChanMsgToggle ChanMsgStatus ChanMsgEnabled);
|
||||||
|
|
||||||
my $c = LoadConf ();
|
my $c = LoadConf ();
|
||||||
my $cachedir = $c->{cachedir};
|
my $cachedir = $c->{cachedir};
|
||||||
@@ -176,6 +176,107 @@ sub FortuneToggleList () {
|
|||||||
return $cache->get_keys ();
|
return $cache->get_keys ();
|
||||||
}
|
}
|
||||||
|
|
||||||
|
sub ChanMsgToggle (@) {
|
||||||
|
my $chatid = shift;
|
||||||
|
my $action = shift // undef;
|
||||||
|
my $phrase = 'Сообщения, пришедшие от имени каналов ';
|
||||||
|
|
||||||
|
my $cache = CHI->new (
|
||||||
|
driver => 'BerkeleyDB',
|
||||||
|
root_dir => $cachedir,
|
||||||
|
namespace => __PACKAGE__ . '_' . 'chan_msg'
|
||||||
|
);
|
||||||
|
|
||||||
|
my $state = $cache->get ($chatid);
|
||||||
|
|
||||||
|
if (defined $action) {
|
||||||
|
if ($action) {
|
||||||
|
$cache->set ($chatid, 1, 'never');
|
||||||
|
$phrase .= 'не будут удаляться.';
|
||||||
|
} else {
|
||||||
|
if (defined $state && $state) {
|
||||||
|
$cache->set ($chatid, 0, 'never');
|
||||||
|
$phrase .= 'будут удаляться.';
|
||||||
|
} else {
|
||||||
|
$cache->set ($chatid, 1, 'never');
|
||||||
|
$phrase .= 'не будут удаляться.';
|
||||||
|
}
|
||||||
|
}
|
||||||
|
} else {
|
||||||
|
if (defined $state){
|
||||||
|
if ($state) {
|
||||||
|
$cache->set ($chatid, 0, 'never');
|
||||||
|
$phrase .= 'будут удаляться.';
|
||||||
|
} else {
|
||||||
|
$cache->set ($chatid, 1, 'never');
|
||||||
|
$phrase .= 'не будут удаляться.';
|
||||||
|
}
|
||||||
|
} else {
|
||||||
|
$cache->set ($chatid, 1, 'never');
|
||||||
|
$phrase .= 'не будут удаляться.';
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
return $phrase;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub ChanMsgStatus ($) {
|
||||||
|
my $chatid = shift;
|
||||||
|
my $phrase = 'Сообщения, пришедшие от имени каналов ';
|
||||||
|
|
||||||
|
my $cache = CHI->new (
|
||||||
|
driver => 'BerkeleyDB',
|
||||||
|
root_dir => $cachedir,
|
||||||
|
namespace => __PACKAGE__ . '_' . 'chan_msg'
|
||||||
|
);
|
||||||
|
|
||||||
|
my $state = $cache->get ($chatid);
|
||||||
|
|
||||||
|
if (defined $state) {
|
||||||
|
if ($state) {
|
||||||
|
$phrase .= 'не удаляются.';
|
||||||
|
} else {
|
||||||
|
$phrase .= 'удаляются.';
|
||||||
|
}
|
||||||
|
} else {
|
||||||
|
$phrase .= 'не удаляются.';
|
||||||
|
}
|
||||||
|
|
||||||
|
return $phrase;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub ChanMsgEnabled ($) {
|
||||||
|
my $chatid = shift;
|
||||||
|
|
||||||
|
my $cache = CHI->new (
|
||||||
|
driver => 'BerkeleyDB',
|
||||||
|
root_dir => $cachedir,
|
||||||
|
namespace => __PACKAGE__ . '_' . 'chan_msg'
|
||||||
|
);
|
||||||
|
|
||||||
|
my $state = $cache->get ($chatid);
|
||||||
|
|
||||||
|
if (defined $state) {
|
||||||
|
if ($state) {
|
||||||
|
return 1;
|
||||||
|
} else {
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
} else {
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
sub ChanMsgToggleList () {
|
||||||
|
my $cache = CHI->new (
|
||||||
|
driver => 'BerkeleyDB',
|
||||||
|
root_dir => $cachedir,
|
||||||
|
namespace => __PACKAGE__ . '_' . 'chan_msg'
|
||||||
|
);
|
||||||
|
|
||||||
|
return $cache->get_keys ();
|
||||||
|
}
|
||||||
|
|
||||||
sub PluginStatus (@) {
|
sub PluginStatus (@) {
|
||||||
my $chatid = shift;
|
my $chatid = shift;
|
||||||
my $plugin = shift;
|
my $plugin = shift;
|
||||||
@@ -206,6 +307,11 @@ sub PluginEnabled (@) {
|
|||||||
my $chatid = shift;
|
my $chatid = shift;
|
||||||
my $plugin = shift;
|
my $plugin = shift;
|
||||||
|
|
||||||
|
# seems that we have point to return always true if chat is private
|
||||||
|
if ($chatid > 0) {
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
|
||||||
my $cache = CHI->new (
|
my $cache = CHI->new (
|
||||||
driver => 'BerkeleyDB',
|
driver => 'BerkeleyDB',
|
||||||
root_dir => $cachedir,
|
root_dir => $cachedir,
|
||||||
|
|||||||
@@ -1,108 +0,0 @@
|
|||||||
package BotLib::Archeologist;
|
|
||||||
|
|
||||||
use 5.018;
|
|
||||||
use strict;
|
|
||||||
use warnings;
|
|
||||||
use utf8;
|
|
||||||
use open qw (:std :utf8);
|
|
||||||
use English qw ( -no_match_vars );
|
|
||||||
use DBI;
|
|
||||||
use Log::Any qw ($log);
|
|
||||||
use Math::Random::Secure qw (irand);
|
|
||||||
|
|
||||||
use BotLib::Conf qw (LoadConf);
|
|
||||||
|
|
||||||
use version; our $VERSION = qw (1.0);
|
|
||||||
use Exporter qw (import);
|
|
||||||
our @EXPORT_OK = qw (Dig);
|
|
||||||
|
|
||||||
my $c = LoadConf ();
|
|
||||||
my $gamestatdir = $c->{gamestat}->{gamestatdir};
|
|
||||||
my $dbfile = sprintf '%s/gamestat.sqlite', $gamestatdir;
|
|
||||||
|
|
||||||
|
|
||||||
sub getRandomArtifact {
|
|
||||||
my $dbh;
|
|
||||||
$dbh = DBI->connect ("dbi:SQLite:$dbfile", '', '') or do {
|
|
||||||
$log->error (sprintf '[ERROR] Unable to get random artifact, sqlite error: %s', $dbh->errstr);
|
|
||||||
return undef;
|
|
||||||
};
|
|
||||||
|
|
||||||
$dbh->{sqlite_unicode} = 1;
|
|
||||||
|
|
||||||
my $rows_affected = $dbh->do ('PRAGMA foreign_keys=ON') or do {
|
|
||||||
$log->error (sprintf '[ERROR] Unable to get random artifact, sqlite error: %s', $dbh->errstr);
|
|
||||||
return undef;
|
|
||||||
};
|
|
||||||
|
|
||||||
$rows_affected = $dbh->do ('PRAGMA journal_mode=WAL') or do {
|
|
||||||
$log->error (sprintf '[ERROR] Unable to get random artifact, sqlite error: %s', $dbh->errstr);
|
|
||||||
return undef;
|
|
||||||
};
|
|
||||||
|
|
||||||
my $ary_ref = $dbh->selectall_arrayref ('SELECT name FROM artifacts WHERE id > 0 AND id < 10000') or do {
|
|
||||||
$log->error (sprintf '[ERROR] Unable to get random artifact, sqlite error: %s', $dbh->errstr);
|
|
||||||
return undef;
|
|
||||||
};
|
|
||||||
|
|
||||||
$dbh->disconnect or $log->warn (sprintf '[WARN] Unable to close gamestat db, sqlite error: %s', $dbh->errstr);
|
|
||||||
|
|
||||||
return $ary_ref->[irand ($#{ $ary_ref } + 1)]->[0];
|
|
||||||
}
|
|
||||||
|
|
||||||
sub Dig {
|
|
||||||
my $name = shift;
|
|
||||||
|
|
||||||
my @location = (
|
|
||||||
'в архивах',
|
|
||||||
'в гималаях',
|
|
||||||
'в интернете',
|
|
||||||
'в кармане',
|
|
||||||
'в клумбе',
|
|
||||||
'в лунном кратере',
|
|
||||||
'во льдах арктики',
|
|
||||||
'в морге',
|
|
||||||
'в окрестностях погоста',
|
|
||||||
'в песочнице',
|
|
||||||
'в пустыне Гоби',
|
|
||||||
'в пустыне Сахаре',
|
|
||||||
'в русле высохшей реки',
|
|
||||||
'в собственной памяти',
|
|
||||||
'в старом сортире',
|
|
||||||
'в углу',
|
|
||||||
'в цветочном горшке',
|
|
||||||
'на бабушкином огороде',
|
|
||||||
'на винчестере',
|
|
||||||
'на горе Арарат',
|
|
||||||
'на горном плато',
|
|
||||||
'на дне моря',
|
|
||||||
'на необитаемом острове',
|
|
||||||
'на первом слое сумрака',
|
|
||||||
'на просторах Украины',
|
|
||||||
);
|
|
||||||
|
|
||||||
my $find_probability = irand 100;
|
|
||||||
my $success_probability = irand 100;
|
|
||||||
my $artifact_age = irand 15000;
|
|
||||||
|
|
||||||
if ($find_probability <= 20) {
|
|
||||||
return sprintf 'По уши закопавшись %s, %s, нифига вы не выкопали! Может повезет в другом месте?', $location[irand ($#location + 1)], $name;
|
|
||||||
}
|
|
||||||
|
|
||||||
my $phrase = sprintf "Вы начали раскопки %s и усиленно роете лопатами, экскаватором...\n", $location[irand ($#location + 1)];
|
|
||||||
$phrase .= "Вам кажется что ваш совочек ударился обо что-то твердое. Может, это клад?!\n\n";
|
|
||||||
my $artifact = getRandomArtifact();
|
|
||||||
|
|
||||||
if ($success_probability <= 25) {
|
|
||||||
$phrase .= sprintf '%s стал лучшим археологом, выкопав %s! возраст артефакта - %s лет!', $name, $artifact, $artifact_age;
|
|
||||||
} else {
|
|
||||||
$phrase .= sprintf "Поздравляю, %s! Вы только что выкопали %s, возраст - %s лет!\n", $name, $artifact, $artifact_age;
|
|
||||||
$phrase .= sprintf 'Извини, %s, но на артефакт это не тянет! Однако, попытка хорошая!', $name;
|
|
||||||
}
|
|
||||||
|
|
||||||
return $phrase;
|
|
||||||
}
|
|
||||||
|
|
||||||
1;
|
|
||||||
|
|
||||||
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
|
||||||
@@ -1,60 +0,0 @@
|
|||||||
package BotLib::Buni;
|
|
||||||
|
|
||||||
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 HTML::TokeParser;
|
|
||||||
use Log::Any qw ($log);
|
|
||||||
use Mojo::UserAgent;
|
|
||||||
|
|
||||||
use version; our $VERSION = qw (1.0);
|
|
||||||
use Exporter qw (import);
|
|
||||||
our @EXPORT_OK = qw (Buni);
|
|
||||||
|
|
||||||
sub Buni {
|
|
||||||
my $r;
|
|
||||||
my $ret = 'Нету Buni';
|
|
||||||
|
|
||||||
for (1..3) {
|
|
||||||
my $ua = Mojo::UserAgent->new->connect_timeout (3);
|
|
||||||
$ua->max_redirects(3);
|
|
||||||
$r = $ua->get ('http://www.bunicomic.com/?random&nocache=1')->result;
|
|
||||||
|
|
||||||
if ($r->is_success) {
|
|
||||||
last;
|
|
||||||
}
|
|
||||||
|
|
||||||
sleep 2;
|
|
||||||
}
|
|
||||||
|
|
||||||
if ($r->is_success) {
|
|
||||||
my $p = HTML::TokeParser->new(\$r->body);
|
|
||||||
my @a;
|
|
||||||
|
|
||||||
# additional {} required in order "last" to work properly :)
|
|
||||||
{
|
|
||||||
do {
|
|
||||||
$#a = -1;
|
|
||||||
@a = $p->get_tag('meta'); ## no critic (Variables::RequireLocalizedPunctuationVars)
|
|
||||||
|
|
||||||
if (defined $a[0][1]->{property} && $a[0][1]->{property} eq 'og:image') {
|
|
||||||
$ret = sprintf '[buni](%s)', $a[0][1]->{content};
|
|
||||||
last;
|
|
||||||
}
|
|
||||||
|
|
||||||
} while ($#{$a[0]} > 1);
|
|
||||||
}
|
|
||||||
} else {
|
|
||||||
$log->warn (sprintf '[WARN] Bunicomic server return status %s with message: %s', $r->code, $r->message);
|
|
||||||
}
|
|
||||||
|
|
||||||
return $ret;
|
|
||||||
}
|
|
||||||
|
|
||||||
1;
|
|
||||||
|
|
||||||
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
|
||||||
@@ -1,115 +0,0 @@
|
|||||||
package BotLib::Drink;
|
|
||||||
|
|
||||||
use 5.018;
|
|
||||||
use strict;
|
|
||||||
use warnings;
|
|
||||||
use utf8;
|
|
||||||
use open qw (:std :utf8);
|
|
||||||
use CHI;
|
|
||||||
use CHI::Driver::BerkeleyDB;
|
|
||||||
use DateTime;
|
|
||||||
use English qw ( -no_match_vars );
|
|
||||||
use Encode;
|
|
||||||
use Carp qw (cluck);
|
|
||||||
use HTML::TokeParser;
|
|
||||||
use Log::Any qw ($log);
|
|
||||||
use Mojo::Log;
|
|
||||||
use Mojo::UserAgent::Cached;
|
|
||||||
use POSIX qw (strftime);
|
|
||||||
use BotLib::Conf qw (LoadConf);
|
|
||||||
|
|
||||||
use version; our $VERSION = qw (1.0);
|
|
||||||
use Exporter qw (import);
|
|
||||||
our @EXPORT_OK = qw (Drink);
|
|
||||||
|
|
||||||
my @MONTH = qw (yanvar fevral mart aprel may iyun iyul avgust sentyabr oktyabr noyabr dekabr);
|
|
||||||
my $c = LoadConf ();
|
|
||||||
my $cachedir = $c->{cachedir};
|
|
||||||
|
|
||||||
sub Drink {
|
|
||||||
my $r;
|
|
||||||
my $ret = 'Не знаю праздников - вджобываю весь день на шахтах, как проклятая.';
|
|
||||||
my ($dayNum, $monthNum) = (localtime ())[3, 4];
|
|
||||||
my $url = sprintf 'https://kakoysegodnyaprazdnik.ru/baza/%s/%s', $MONTH[$monthNum], $dayNum;
|
|
||||||
|
|
||||||
# Those POSIX assholes just forgot to add unix timestamps without TZ offset, so...
|
|
||||||
my ($mday, $mon, $year) = (gmtime ())[3, 4, 5];
|
|
||||||
my $offset = strftime ('%z', gmtime ());
|
|
||||||
my $offsetMinutes = (substr $offset, -2) * 60;
|
|
||||||
my $offsetHours = (substr $offset, 1, 2) * 60 * 60;
|
|
||||||
my $offsetSign;
|
|
||||||
|
|
||||||
if ((substr $offset, 0, 1) eq '+') {
|
|
||||||
$offsetSign = 1;
|
|
||||||
}
|
|
||||||
|
|
||||||
my $expirationDate = DateTime->new (
|
|
||||||
year => $year + 1900,
|
|
||||||
month => $mon + 1,
|
|
||||||
day => $mday,
|
|
||||||
hour => 0,
|
|
||||||
minute => 0,
|
|
||||||
second => 0
|
|
||||||
)->add (days => 1)->strftime ('%s');
|
|
||||||
|
|
||||||
if ((substr $offset, 0, 1) eq '+') {
|
|
||||||
$expirationDate = $expirationDate - $offsetHours - $offsetMinutes;
|
|
||||||
} else {
|
|
||||||
$expirationDate = $expirationDate + $offsetHours + $offsetMinutes;
|
|
||||||
}
|
|
||||||
|
|
||||||
for (1..3) {
|
|
||||||
my $ua = Mojo::UserAgent::Cached->new->connect_timeout (3);
|
|
||||||
$ua->cache_agent(
|
|
||||||
CHI->new (
|
|
||||||
driver => 'BerkeleyDB',
|
|
||||||
root_dir => $cachedir,
|
|
||||||
namespace => __PACKAGE__,
|
|
||||||
expires_at => $expirationDate,
|
|
||||||
expires_on_backend => 1,
|
|
||||||
)
|
|
||||||
);
|
|
||||||
# just to make Mojo::UserAgent::Cached happy
|
|
||||||
$ua->logger (Mojo::Log->new (path => '/dev/null', level => 'error'));
|
|
||||||
$r = $ua->get ($url => {'Accept-Language' => 'ru-RU', 'Accept-Charset' => 'utf-8'})->result;
|
|
||||||
|
|
||||||
if ($r->is_success) {
|
|
||||||
last;
|
|
||||||
}
|
|
||||||
|
|
||||||
sleep 2;
|
|
||||||
}
|
|
||||||
|
|
||||||
if ($r->is_success) {
|
|
||||||
my $p = HTML::TokeParser->new(\$r->body);
|
|
||||||
my @a;
|
|
||||||
my @holyday;
|
|
||||||
|
|
||||||
do {
|
|
||||||
$#a = -1;
|
|
||||||
@a = $p->get_tag('span'); ## no critic (Variables::RequireLocalizedPunctuationVars)
|
|
||||||
|
|
||||||
if ($#{$a[0]} > 2 && defined $a[0][1]->{itemprop} && $a[0][1]->{itemprop} eq 'text') {
|
|
||||||
push @holyday,'* ' . decode ('UTF-8', $p->get_trimmed_text ('/span'));
|
|
||||||
}
|
|
||||||
|
|
||||||
} while ($#{$a[0]} > 1);
|
|
||||||
|
|
||||||
if ($#holyday > 0) {
|
|
||||||
# cut off something weird, definely not a "holyday"
|
|
||||||
$#holyday = $#holyday - 1;
|
|
||||||
}
|
|
||||||
|
|
||||||
if ($#holyday > 0) {
|
|
||||||
$ret = join "\n", @holyday;
|
|
||||||
}
|
|
||||||
} else {
|
|
||||||
$log->warn (sprintf '[WARN] Kakoysegodnyaprazdnik server return status %s with message: %s', $r->code, $r->message);
|
|
||||||
}
|
|
||||||
|
|
||||||
return $ret;
|
|
||||||
}
|
|
||||||
|
|
||||||
1;
|
|
||||||
|
|
||||||
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
|
||||||
@@ -1,122 +0,0 @@
|
|||||||
package BotLib::Fisher;
|
|
||||||
|
|
||||||
use 5.018;
|
|
||||||
use strict;
|
|
||||||
use warnings;
|
|
||||||
use utf8;
|
|
||||||
use open qw (:std :utf8);
|
|
||||||
use English qw ( -no_match_vars );
|
|
||||||
use DBI;
|
|
||||||
use Log::Any qw ($log);
|
|
||||||
use Math::Random::Secure qw (irand);
|
|
||||||
|
|
||||||
use BotLib::Conf qw (LoadConf);
|
|
||||||
|
|
||||||
use version; our $VERSION = qw (1.0);
|
|
||||||
use Exporter qw (import);
|
|
||||||
our @EXPORT_OK = qw (Fish);
|
|
||||||
|
|
||||||
my $c = LoadConf ();
|
|
||||||
my $gamestatdir = $c->{gamestat}->{gamestatdir};
|
|
||||||
my $dbfile = sprintf '%s/gamestat.sqlite', $gamestatdir;
|
|
||||||
|
|
||||||
|
|
||||||
sub getRandomArtifact {
|
|
||||||
my $dbh;
|
|
||||||
$dbh = DBI->connect ("dbi:SQLite:$dbfile", '', '') or do {
|
|
||||||
$log->error (sprintf '[ERROR] Unable to get random artifact, sqlite error: %s', $dbh->errstr);
|
|
||||||
return undef;
|
|
||||||
};
|
|
||||||
|
|
||||||
$dbh->{sqlite_unicode} = 1;
|
|
||||||
|
|
||||||
my $rows_affected = $dbh->do ('PRAGMA foreign_keys=ON') or do {
|
|
||||||
$log->error (sprintf '[ERROR] Unable to get random artifact, sqlite error: %s', $dbh->errstr);
|
|
||||||
return undef;
|
|
||||||
};
|
|
||||||
|
|
||||||
$rows_affected = $dbh->do ('PRAGMA journal_mode=WAL') or do {
|
|
||||||
$log->error (sprintf '[ERROR] Unable to get random artifact, sqlite error: %s', $dbh->errstr);
|
|
||||||
return undef;
|
|
||||||
};
|
|
||||||
|
|
||||||
my $ary_ref = $dbh->selectall_arrayref ('SELECT name FROM artifacts WHERE id > 9999 AND id < 20000') or do {
|
|
||||||
$log->error (sprintf '[ERROR] Unable to get random artifact, sqlite error: %s', $dbh->errstr);
|
|
||||||
return undef;
|
|
||||||
};
|
|
||||||
|
|
||||||
$dbh->disconnect or $log->warn (sprintf '[WARN] Unable to close gamestat db, sqlite error: %s', $dbh->errstr);
|
|
||||||
|
|
||||||
return $ary_ref->[irand ($#{ $ary_ref } + 1)]->[0];
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
sub Fish {
|
|
||||||
my $name = shift;
|
|
||||||
|
|
||||||
my @location = (
|
|
||||||
'в поток',
|
|
||||||
'в озеро',
|
|
||||||
'в реку',
|
|
||||||
'в северный ледовитый океан',
|
|
||||||
'в индийский океан',
|
|
||||||
'в биде',
|
|
||||||
'в детский плавательный бассейн',
|
|
||||||
'в туалет',
|
|
||||||
'в кучу рвоты',
|
|
||||||
'в лужу мочи',
|
|
||||||
'в раковину',
|
|
||||||
'в слив ванной',
|
|
||||||
'в лужу грязи',
|
|
||||||
'в ведро воды',
|
|
||||||
'в бутылку с водкой',
|
|
||||||
'в ванную',
|
|
||||||
'в бочку с дождевой водой',
|
|
||||||
'в аквариум',
|
|
||||||
'в сугроб',
|
|
||||||
'в водопад',
|
|
||||||
'в чашку кофе',
|
|
||||||
'в стакан молока',
|
|
||||||
'в черную дыру',
|
|
||||||
'дно Удомельского реактора',
|
|
||||||
'на Марс',
|
|
||||||
'в соседнюю галактику',
|
|
||||||
'к соседу на балкон',
|
|
||||||
'далеко-далеко',
|
|
||||||
'далеко и надолго',
|
|
||||||
'на крышу дома',
|
|
||||||
);
|
|
||||||
|
|
||||||
my @material = (
|
|
||||||
'бамбуковую',
|
|
||||||
'фибергласовую',
|
|
||||||
'карбоновую',
|
|
||||||
'композитную',
|
|
||||||
);
|
|
||||||
|
|
||||||
my $find_probability = irand 100;
|
|
||||||
my $success_probability = irand 100;
|
|
||||||
my $weight = irand 7000;
|
|
||||||
|
|
||||||
my $phrase = sprintf "Вы забрасываете %s удочку %s.\nВы чувствуете поклёвку и начинаете быстро тащить что-то.\n", $material[irand ($#material + 1)], $location[irand ($#location + 1)];
|
|
||||||
|
|
||||||
if ($find_probability <= 20) {
|
|
||||||
$phrase .= sprintf 'Черт, твоя рыбка сорвалась, %s! Не беда, может потом повезет?', $name;
|
|
||||||
return $phrase;
|
|
||||||
}
|
|
||||||
|
|
||||||
my $artifact = getRandomArtifact ();
|
|
||||||
$phrase .= sprintf "Поздравляю, %s! Вы только что поймали %s! аж на %d кило!\n\n", $name, $artifact, $weight;
|
|
||||||
|
|
||||||
if ($success_probability <= 25) {
|
|
||||||
$phrase .= sprintf 'Ё-мое!!! А это ведь новый рекорд! Продолжай в том же духе, %s!', $name;
|
|
||||||
} else {
|
|
||||||
$phrase .= sprintf 'Извини, %s, но это не новый рекорд! Однако, хорошая попытка!', $name;
|
|
||||||
}
|
|
||||||
|
|
||||||
return $phrase;
|
|
||||||
}
|
|
||||||
|
|
||||||
1;
|
|
||||||
|
|
||||||
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
|
||||||
@@ -1,86 +0,0 @@
|
|||||||
package BotLib::Fortune;
|
|
||||||
# Any fortune_mod sources are suitable. Text file with "\n%\n" sentence delimeter.
|
|
||||||
|
|
||||||
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 File::Path qw (make_path);
|
|
||||||
use Log::Any qw ($log);
|
|
||||||
use Math::Random::Secure qw (irand);
|
|
||||||
use SQLite_File;
|
|
||||||
use BotLib::Conf qw (LoadConf);
|
|
||||||
|
|
||||||
use version; our $VERSION = qw (1.0);
|
|
||||||
use Exporter qw (import);
|
|
||||||
our @EXPORT_OK = qw (Seed Fortune);
|
|
||||||
|
|
||||||
my $c = LoadConf ();
|
|
||||||
my $dir = $c->{fortune}->{dir};
|
|
||||||
my $srcdir = $c->{fortune}->{srcdir};
|
|
||||||
|
|
||||||
sub Seed () {
|
|
||||||
unless (-d $dir) {
|
|
||||||
make_path ($dir) || croak "Unable to create $dir: $OS_ERROR";
|
|
||||||
}
|
|
||||||
|
|
||||||
my $backingfile = sprintf '%s/fortune.sqlite', $dir;
|
|
||||||
|
|
||||||
if (-f $backingfile) {
|
|
||||||
unlink $backingfile || croak "Unable to remove $backingfile: $OS_ERROR";
|
|
||||||
}
|
|
||||||
|
|
||||||
tie my @fortune, 'SQLite_File', $backingfile || croak "Unable to tie to $backingfile: $OS_ERROR";
|
|
||||||
|
|
||||||
opendir (my $srcdirhandle, $srcdir) || croak "Unable to open $srcdir: $OS_ERROR";
|
|
||||||
|
|
||||||
while (my $fortunefile = readdir ($srcdirhandle)) {
|
|
||||||
my $srcfile = sprintf '%s/%s', $srcdir, $fortunefile;
|
|
||||||
|
|
||||||
unless (-f $srcfile) {
|
|
||||||
next;
|
|
||||||
}
|
|
||||||
|
|
||||||
if ($fortunefile =~ m/^\.+$/) {
|
|
||||||
next;
|
|
||||||
}
|
|
||||||
|
|
||||||
open (my $fh, '<', $srcfile) || croak "Unable to open $srcfile, $OS_ERROR";
|
|
||||||
# set correct phrase delimiter
|
|
||||||
local $INPUT_RECORD_SEPARATOR = "\n%\n";
|
|
||||||
|
|
||||||
while (readline $fh) {
|
|
||||||
my $phrase = substr $_, 0, -3;
|
|
||||||
push @fortune, $phrase;
|
|
||||||
}
|
|
||||||
|
|
||||||
close $fh; ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
|
|
||||||
}
|
|
||||||
|
|
||||||
closedir $srcdirhandle;
|
|
||||||
untie @fortune;
|
|
||||||
return;
|
|
||||||
}
|
|
||||||
|
|
||||||
# just return answer
|
|
||||||
sub Fortune () {
|
|
||||||
my $backingfile = sprintf '%s/fortune.sqlite', $dir;
|
|
||||||
|
|
||||||
tie my @array, 'SQLite_File', $backingfile || do {
|
|
||||||
$log->error ("[ERROR] Unable to tie to $backingfile: $OS_ERROR");
|
|
||||||
return '';
|
|
||||||
};
|
|
||||||
|
|
||||||
my $phrase = $array[irand ($#array + 1)];
|
|
||||||
# decode?
|
|
||||||
utf8::decode $phrase;
|
|
||||||
untie @array;
|
|
||||||
return $phrase;
|
|
||||||
}
|
|
||||||
|
|
||||||
1;
|
|
||||||
|
|
||||||
# vim: ft=perl noet ai ts=4 sw=4 sts=4:
|
|
||||||
@@ -1,96 +0,0 @@
|
|||||||
package BotLib::Friday;
|
|
||||||
# for friday data stolen from https://raw.githubusercontent.com/isida/vi/master/data/friday.txt
|
|
||||||
|
|
||||||
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 File::Path qw (make_path);
|
|
||||||
use Log::Any qw ($log);
|
|
||||||
use Math::Random::Secure qw (irand);
|
|
||||||
use SQLite_File;
|
|
||||||
use BotLib::Conf qw (LoadConf);
|
|
||||||
|
|
||||||
use version; our $VERSION = qw (1.0);
|
|
||||||
use Exporter qw (import);
|
|
||||||
our @EXPORT_OK = qw (Seed Friday);
|
|
||||||
|
|
||||||
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) {
|
|
||||||
make_path ($dir) || croak "Unable to create $dir: $OS_ERROR";
|
|
||||||
}
|
|
||||||
|
|
||||||
my $friday;
|
|
||||||
|
|
||||||
for (0..$#dow) {
|
|
||||||
my $backingfile = sprintf '%s/%s.sqlite', $dir, $dow[$_];
|
|
||||||
|
|
||||||
if (-f $backingfile) {
|
|
||||||
unlink $backingfile || croak "Unable to remove $backingfile: $OS_ERROR\n";
|
|
||||||
}
|
|
||||||
|
|
||||||
tie @{$friday->[$_]}, 'SQLite_File', $backingfile || croak "Unable to tie to $backingfile: $OS_ERROR\n";
|
|
||||||
}
|
|
||||||
|
|
||||||
open (my $fh, '<', $srcfile) || croak "Unable to open $srcfile, $OS_ERROR\n";
|
|
||||||
|
|
||||||
while (readline $fh) {
|
|
||||||
unless (m/ \|\| /xmsg) {
|
|
||||||
next;
|
|
||||||
}
|
|
||||||
|
|
||||||
chomp();
|
|
||||||
my ($phrase, $days) = split(/ \|\| /);
|
|
||||||
my @daylist = split(//, $days);
|
|
||||||
|
|
||||||
foreach my $day (@daylist) {
|
|
||||||
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->[$_];
|
|
||||||
}
|
|
||||||
|
|
||||||
return;
|
|
||||||
}
|
|
||||||
|
|
||||||
# just return answer
|
|
||||||
sub Friday () {
|
|
||||||
my $today = (localtime (time))[6] - 1;
|
|
||||||
my $backingfile = sprintf '%s/%s.sqlite', $dir, $dow[$today];
|
|
||||||
|
|
||||||
tie my @array, 'SQLite_File', $backingfile || do {
|
|
||||||
$log->error ("[ERROR] Unable to tie to $backingfile: $OS_ERROR\n");
|
|
||||||
return '';
|
|
||||||
};
|
|
||||||
|
|
||||||
my $phrase = $array[irand ($#array + 1)];
|
|
||||||
utf8::decode $phrase;
|
|
||||||
untie @array;
|
|
||||||
return $phrase;
|
|
||||||
}
|
|
||||||
|
|
||||||
1;
|
|
||||||
|
|
||||||
# vim: ft=perl noet ai ts=4 sw=4 sts=4:
|
|
||||||
@@ -1,115 +0,0 @@
|
|||||||
package BotLib::Gamestat;
|
|
||||||
# Stores and calculates player stats for games
|
|
||||||
|
|
||||||
use 5.018;
|
|
||||||
use strict;
|
|
||||||
use warnings;
|
|
||||||
use utf8;
|
|
||||||
use open qw (:std :utf8);
|
|
||||||
use DBI;
|
|
||||||
use English qw ( -no_match_vars );
|
|
||||||
use File::Path qw (make_path);
|
|
||||||
use String::Random qw (random_string);
|
|
||||||
|
|
||||||
use BotLib::Conf qw (LoadConf);
|
|
||||||
use BotLib::Util qw (trim utf2sha1);
|
|
||||||
|
|
||||||
use version; our $VERSION = qw (1.0);
|
|
||||||
use Exporter qw (import);
|
|
||||||
our @EXPORT_OK = qw (SeedArtifacts);
|
|
||||||
|
|
||||||
|
|
||||||
my $c = LoadConf ();
|
|
||||||
my $dir = $c->{gamestat}->{dir};
|
|
||||||
my $gamestatdir = $c->{gamestat}->{gamestatdir};
|
|
||||||
my $dbfile = sprintf '%s/gamestat.sqlite', $gamestatdir;
|
|
||||||
|
|
||||||
# assume that there is not too much artifacts.
|
|
||||||
sub SeedArtifacts {
|
|
||||||
open (my $AFH, '<', "$dir/archeologic_artifacts.txt") || die "No $dir/archeologic_artifacts.txt\n";
|
|
||||||
my @arch_artifacts;
|
|
||||||
|
|
||||||
while (my $artifact = <$AFH>) {
|
|
||||||
next if ($artifact =~ /^\s*$/);
|
|
||||||
$artifact = trim ($artifact);
|
|
||||||
push @arch_artifacts, $artifact;
|
|
||||||
}
|
|
||||||
|
|
||||||
close $AFH; ## no critic (InputOutput::RequireCheckedSyscalls)
|
|
||||||
|
|
||||||
open ($AFH, '<', "$dir/fisher_artifacts.txt") || die "No $dir/fisher_artifacts.txt\n";
|
|
||||||
my @fisher_artifacts;
|
|
||||||
|
|
||||||
while (my $artifact = <$AFH>) {
|
|
||||||
next if ($artifact =~ /^\s*$/);
|
|
||||||
$artifact = trim ($artifact);
|
|
||||||
push @fisher_artifacts, $artifact;
|
|
||||||
}
|
|
||||||
|
|
||||||
close $AFH; ## no critic (InputOutput::RequireCheckedSyscalls)
|
|
||||||
undef $AFH;
|
|
||||||
|
|
||||||
my $tablename = random_string ('..........');
|
|
||||||
$tablename = utf2sha1 ($tablename);
|
|
||||||
|
|
||||||
while ($tablename =~ /^\d/) {
|
|
||||||
$tablename = utf2sha1 ($tablename);
|
|
||||||
}
|
|
||||||
|
|
||||||
$tablename =~ s/[\/_\+]/a/g;
|
|
||||||
$tablename = lc ($tablename);
|
|
||||||
|
|
||||||
unless (-d $gamestatdir) {
|
|
||||||
make_path ($gamestatdir) || die "Unable to create $gamestatdir: $OS_ERROR\n";
|
|
||||||
}
|
|
||||||
|
|
||||||
my $dbh = DBI->connect ("dbi:SQLite:$dbfile", '', '');
|
|
||||||
$dbh->{sqlite_unicode} = 1;
|
|
||||||
my $rows_affected = $dbh->do ('PRAGMA foreign_keys=ON') or die $dbh->errstr . "\n";
|
|
||||||
$rows_affected = $dbh->do ('PRAGMA journal_mode=WAL') or die $dbh->errstr . "\n";
|
|
||||||
|
|
||||||
# Open transaction
|
|
||||||
$dbh->begin_work or die $dbh->errstr . "\n";
|
|
||||||
|
|
||||||
my $query = <<"QUERY";
|
|
||||||
CREATE TABLE IF NOT EXISTS $tablename (
|
|
||||||
id INT UNIQUE NOT NULL, -- artifact id
|
|
||||||
name TEXT PRIMARY KEY -- artifact name
|
|
||||||
);
|
|
||||||
QUERY
|
|
||||||
|
|
||||||
$rows_affected = $dbh->do ($query) or die $dbh->errstr . "\n";
|
|
||||||
my $sth = $dbh->prepare ("REPLACE INTO $tablename(id,name) VALUES (?,?)") or die $dbh->errstr . "\n";
|
|
||||||
|
|
||||||
# Insert our archeological artifacts
|
|
||||||
my $counter = 0;
|
|
||||||
|
|
||||||
foreach my $artifact (@arch_artifacts) {
|
|
||||||
last if ($counter == 10000);
|
|
||||||
$sth->execute ($c, $artifact);
|
|
||||||
$counter++;
|
|
||||||
}
|
|
||||||
|
|
||||||
# Insert our fishing artifacts
|
|
||||||
$counter = 10000;
|
|
||||||
|
|
||||||
foreach my $artifact (@fisher_artifacts) {
|
|
||||||
last if ($counter == 20000);
|
|
||||||
$sth->execute ($c, $artifact);
|
|
||||||
$counter++;
|
|
||||||
}
|
|
||||||
|
|
||||||
# Add indexes
|
|
||||||
$rows_affected = $dbh->do ("CREATE INDEX IF NOT EXISTS myartifactid ON $tablename(id)") or die $dbh->errstr . "\n";
|
|
||||||
|
|
||||||
# Drop target table and replace it with our
|
|
||||||
$rows_affected = $dbh->do ('DROP TABLE IF EXISTS artifacts') or die $dbh->errstr . "\n";
|
|
||||||
$rows_affected = $dbh->do ("ALTER TABLE $tablename RENAME TO artifacts") or die $dbh->errstr . "\n";
|
|
||||||
|
|
||||||
# Close transaction
|
|
||||||
$dbh->commit or die $dbh->errstr . "\n";
|
|
||||||
$dbh->disconnect or warn (sprintf '[WARN] Unable to close gamestat db, sqlite error: %s', $dbh->errstr) . "\n";
|
|
||||||
return;
|
|
||||||
}
|
|
||||||
|
|
||||||
1;
|
|
||||||
@@ -1,241 +0,0 @@
|
|||||||
package BotLib::Image;
|
|
||||||
|
|
||||||
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 Log::Any qw ($log);
|
|
||||||
use Math::Random::Secure qw (irand);
|
|
||||||
use Mojo::UserAgent;
|
|
||||||
use BotLib::Image::Flickr qw (FlickrByTags);
|
|
||||||
use BotLib::Image::Imgur qw (Imgur);
|
|
||||||
use BotLib::Util qw (urlencode);
|
|
||||||
|
|
||||||
use version; our $VERSION = qw (1.0);
|
|
||||||
use Exporter qw (import);
|
|
||||||
our @EXPORT_OK = qw (Kitty Fox Oboobs Obutts Rabbit Owl Frog Horse Snail);
|
|
||||||
|
|
||||||
sub Kitty {
|
|
||||||
my $r;
|
|
||||||
my $ret = 'Нету кошечек, все разбежались.';
|
|
||||||
|
|
||||||
for (1..3) {
|
|
||||||
my $ua = Mojo::UserAgent->new->connect_timeout (3);
|
|
||||||
$r = $ua->get ('https://api.thecatapi.com/v1/images/search')->result;
|
|
||||||
|
|
||||||
if ($r->is_success) {
|
|
||||||
last;
|
|
||||||
}
|
|
||||||
|
|
||||||
sleep 2;
|
|
||||||
}
|
|
||||||
|
|
||||||
if ($r->is_success) {
|
|
||||||
my $jcat = eval {
|
|
||||||
return $r->json;
|
|
||||||
};
|
|
||||||
|
|
||||||
unless (defined $jcat) {
|
|
||||||
$log->warn ("[WARN] Unable to decode JSON from thecatapi: $EVAL_ERROR");
|
|
||||||
} else {
|
|
||||||
if ($jcat->[0]->{url}) {
|
|
||||||
my @cats = ('龴ↀ◡ↀ龴', '=^..^=', '≧◔◡◔≦ ','^ↀᴥↀ^');
|
|
||||||
$ret = sprintf '[%s](%s)', $cats[irand ($#cats + 1)], $jcat->[0]->{url};
|
|
||||||
}
|
|
||||||
}
|
|
||||||
} else {
|
|
||||||
$log->warn (sprintf '[WARN] Thecatapi server return status %s with message: %s', $r->code, $r->message);
|
|
||||||
}
|
|
||||||
|
|
||||||
return $ret;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub Fox {
|
|
||||||
my $r;
|
|
||||||
my $ret = 'Нету лисичек, все разбежались.';
|
|
||||||
|
|
||||||
for (1..3) {
|
|
||||||
my $ua = Mojo::UserAgent->new->connect_timeout (3);
|
|
||||||
$r = $ua->get ('https://randomfox.ca/floof/')->result;
|
|
||||||
|
|
||||||
if ($r->is_success) {
|
|
||||||
last;
|
|
||||||
}
|
|
||||||
|
|
||||||
sleep 2;
|
|
||||||
}
|
|
||||||
|
|
||||||
if ($r->is_success) {
|
|
||||||
my $jfox = eval {
|
|
||||||
return $r->json;
|
|
||||||
};
|
|
||||||
|
|
||||||
unless (defined $jfox) {
|
|
||||||
$log->warn ("[WARN] Unable to decode JSON from randomfox: $EVAL_ERROR");
|
|
||||||
} else {
|
|
||||||
if ($jfox->{image}) {
|
|
||||||
$jfox->{image} =~ s/\\//xmsg;
|
|
||||||
$ret = sprintf '[-^^,--,~](%s)', $jfox->{image};
|
|
||||||
}
|
|
||||||
}
|
|
||||||
} else {
|
|
||||||
$log->warn (sprintf '[WARN] Randomfox server return status %s with message: %s', $r->code, $r->message);
|
|
||||||
}
|
|
||||||
|
|
||||||
return $ret;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub Oboobs {
|
|
||||||
my $r;
|
|
||||||
my $ret = 'Нету cисичек, все разбежались.';
|
|
||||||
|
|
||||||
for (1..3) {
|
|
||||||
my $ua = Mojo::UserAgent->new->connect_timeout (3);
|
|
||||||
$r = $ua->get ('http://api.oboobs.ru/boobs/0/1/random')->result;
|
|
||||||
|
|
||||||
if ($r->is_success) {
|
|
||||||
last;
|
|
||||||
}
|
|
||||||
|
|
||||||
sleep 2;
|
|
||||||
}
|
|
||||||
|
|
||||||
if ($r->is_success) {
|
|
||||||
my $joboobs = eval {
|
|
||||||
return $r->json;
|
|
||||||
};
|
|
||||||
|
|
||||||
unless (defined $joboobs) {
|
|
||||||
$log->warn ("[WARN] Unable to decode JSON from oboobs: $EVAL_ERROR");
|
|
||||||
} else {
|
|
||||||
if ($joboobs->[0]->{preview}) {
|
|
||||||
my @boobs = ('(. )( .)', '( . Y . )', '(o)(o)', '( @ )( @ )', '(.)(.)');
|
|
||||||
$ret = sprintf '[%s](https://media.oboobs.ru/%s)', $boobs[irand ($#boobs + 1)], $joboobs->[0]->{preview};
|
|
||||||
}
|
|
||||||
}
|
|
||||||
} else {
|
|
||||||
$log->warn (sprintf '[WARN] Oboobs server return status %s with message: %s', $r->code, $r->message);
|
|
||||||
}
|
|
||||||
|
|
||||||
return $ret;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub Obutts {
|
|
||||||
my $r;
|
|
||||||
my $ret = 'Нету попок, все разбежались.';
|
|
||||||
|
|
||||||
for (1..3) {
|
|
||||||
my $ua = Mojo::UserAgent->new->connect_timeout (3);
|
|
||||||
$r = $ua->get ('http://api.obutts.ru/butts/0/1/random')->result;
|
|
||||||
|
|
||||||
if ($r->is_success) {
|
|
||||||
last;
|
|
||||||
}
|
|
||||||
|
|
||||||
sleep 2;
|
|
||||||
}
|
|
||||||
|
|
||||||
if ($r->is_success) {
|
|
||||||
my $jobutts = eval {
|
|
||||||
return $r->json;
|
|
||||||
};
|
|
||||||
|
|
||||||
unless (defined $jobutts) {
|
|
||||||
$log->warn ("[ERROR] Unable to decode JSON from obutts: $EVAL_ERROR");
|
|
||||||
} else {
|
|
||||||
if ($jobutts->[0]->{preview}) {
|
|
||||||
my @butts = ('(__(__)', '(_!_)', '(__.__)');
|
|
||||||
$ret = sprintf '[%s](http://media.obutts.ru/%s)', $butts[irand ($#butts + 1)], $jobutts->[0]->{preview};
|
|
||||||
}
|
|
||||||
}
|
|
||||||
} else {
|
|
||||||
$log->warn (sprintf '[WARN] Obutts server return status %s with message: %s', $r->code, $r->message);
|
|
||||||
}
|
|
||||||
|
|
||||||
return $ret;
|
|
||||||
}
|
|
||||||
|
|
||||||
# It works but results are not particulary relevant, partially. about 20-30% miss
|
|
||||||
# So i prefer to use flickr rabbits selection :)
|
|
||||||
sub rabbit_imgur {
|
|
||||||
my @terms = (
|
|
||||||
urlencode '?q=animals AND (rabbits OR bunnies)',
|
|
||||||
urlencode 'year?q=animals AND (rabbits OR bunnies)',
|
|
||||||
urlencode 'relevance?q=animals AND (rabbits OR bunnies)',
|
|
||||||
urlencode 'relevance/year?q=animals AND (rabbits OR bunnies)',
|
|
||||||
urlencode 'score?q_not=cat OR kitten OR kittens OR dog OR cats OR dogs OR puppy OR puppies&q_tags=bunnies,bunny,rabbits,rabbit',
|
|
||||||
);
|
|
||||||
|
|
||||||
my $rabbit = Imgur ($terms[irand ($#terms + 1)]);
|
|
||||||
# return just large thumbnail instead of real photo (that can be really huge)
|
|
||||||
$rabbit = sprintf '%sl%s', substr ($rabbit, 0, -4), substr ($rabbit, -4);
|
|
||||||
|
|
||||||
if (defined $rabbit) {
|
|
||||||
return sprintf '[(\_/)](%s)', $rabbit;
|
|
||||||
} else {
|
|
||||||
return 'Нету кроликов, все разбежались.'
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub Rabbit {
|
|
||||||
# rabbit, but bunny
|
|
||||||
my $url = FlickrByTags ('animal,bunny');
|
|
||||||
|
|
||||||
if (defined $url) {
|
|
||||||
return sprintf '[(\_/)](%s)', $url;
|
|
||||||
} else {
|
|
||||||
return 'Нету кроликов, все разбежались.';
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub Owl {
|
|
||||||
my $url = FlickrByTags ('bird,owl');
|
|
||||||
|
|
||||||
if (defined $url) {
|
|
||||||
return sprintf '[{ O v O }](%s)', $url;
|
|
||||||
} else {
|
|
||||||
return 'Нету сов, все разлетелись.';
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub Frog {
|
|
||||||
# unable to find any one-line ascii art for frog :(
|
|
||||||
my @art = qw (frog toad лягушка);
|
|
||||||
my $url = FlickrByTags ('frog,toad,amphibian');
|
|
||||||
|
|
||||||
if (defined $url) {
|
|
||||||
return sprintf '[%s](%s)', $art [irand ($#art + 1)], $url;
|
|
||||||
} else {
|
|
||||||
return 'Нету лягушек, все свалили.';
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub Horse {
|
|
||||||
# unable to find any one-line ascii art for frog :(
|
|
||||||
my @art = qw (horse лошадь лошадка);
|
|
||||||
my $url = FlickrByTags ('horse,equine,mammal');
|
|
||||||
|
|
||||||
if (defined $url) {
|
|
||||||
return sprintf '[%s](%s)', $art [irand ($#art + 1)], $url;
|
|
||||||
} else {
|
|
||||||
return 'Нету коняшек, все разбежались.';
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub Snail {
|
|
||||||
# unable to find any one-line ascii art for frog :(
|
|
||||||
my @art = qw ('-'_@_ @╜ @_'-');
|
|
||||||
my $url = FlickrByTags ('snail,slug');
|
|
||||||
|
|
||||||
if (defined $url) {
|
|
||||||
return sprintf '[%s](%s)', $art [irand ($#art + 1)], $url;
|
|
||||||
} else {
|
|
||||||
return 'Нету улиток, все расползлись.';
|
|
||||||
}
|
|
||||||
}
|
|
||||||
1;
|
|
||||||
|
|
||||||
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
|
||||||
@@ -1,599 +0,0 @@
|
|||||||
package BotLib::Image::Flickr;
|
|
||||||
|
|
||||||
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 CHI;
|
|
||||||
use CHI::Driver::BerkeleyDB;
|
|
||||||
use Digest::HMAC_SHA1 qw (hmac_sha1);
|
|
||||||
use Log::Any qw ($log);
|
|
||||||
use Math::Random::Secure qw (irand);
|
|
||||||
use MIME::Base64;
|
|
||||||
use Mojo::UserAgent;
|
|
||||||
use URI::Encode::XS qw (uri_encode);
|
|
||||||
|
|
||||||
use BotLib::Conf qw (LoadConf);
|
|
||||||
use BotLib::Util qw (urlencode);
|
|
||||||
|
|
||||||
use Data::Dumper;
|
|
||||||
|
|
||||||
use version; our $VERSION = qw (1.0);
|
|
||||||
use Exporter qw (import);
|
|
||||||
our @EXPORT_OK = qw (FlickrInit FlickrByTags FlickrByText FlickrTestLogin);
|
|
||||||
|
|
||||||
my $c = LoadConf ();
|
|
||||||
my $cachedir = $c->{cachedir};
|
|
||||||
|
|
||||||
my $flickr_consumer_key = $c->{image}->{flickr}->{consumer_key};
|
|
||||||
my $flickr_consumer_secret = $c->{image}->{flickr}->{consumer_secret};
|
|
||||||
my $flickr_verifier = $c->{image}->{flickr}->{verifier};
|
|
||||||
my $flickr_request_token_url = 'https://www.flickr.com/services/oauth/request_token';
|
|
||||||
my $flickr_authorization_url = 'https://www.flickr.com/services/oauth/authorize';
|
|
||||||
my $flickr_access_token_url = 'https://www.flickr.com/services/oauth/access_token';
|
|
||||||
my $flickr_callback_url = 'http://www.example.com';
|
|
||||||
my $flickr_api_url = 'https://www.flickr.com/services/rest/';
|
|
||||||
|
|
||||||
sub mknonce {
|
|
||||||
# make random number, 8 symbols in length
|
|
||||||
my $nonce = sprintf '%08d', irand (99999999);
|
|
||||||
return $nonce;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub flickerSignReq {
|
|
||||||
my %p = @_;
|
|
||||||
my $string;
|
|
||||||
my $hmac;
|
|
||||||
|
|
||||||
if ($p{type} eq 'request_token') {
|
|
||||||
my @parameters;
|
|
||||||
delete $p{type};
|
|
||||||
push @parameters, 'oauth_signature_method=HMAC-SHA1';
|
|
||||||
push @parameters, 'oauth_version=1.0';
|
|
||||||
push @parameters, sprintf 'oauth_callback=%s', uri_encode ($flickr_callback_url);
|
|
||||||
push @parameters, sprintf 'oauth_consumer_key=%s', $flickr_consumer_key;
|
|
||||||
|
|
||||||
foreach my $param (keys %p) {
|
|
||||||
push @parameters, sprintf ('%s=%s', $param, $p{$param});
|
|
||||||
}
|
|
||||||
|
|
||||||
$string = sprintf 'GET&%s&', uri_encode ($flickr_request_token_url);
|
|
||||||
$string .= uri_encode (join '&', sort (@parameters));
|
|
||||||
# Thanks to twitter api dev portal, they explain this particular case: while we requesting this token
|
|
||||||
# we do not yet know access_token secret, so we just omit it in this signature
|
|
||||||
# https://developer.twitter.com/en/docs/authentication/oauth-1-0a/creating-a-signature
|
|
||||||
$hmac = Digest::HMAC_SHA1->new (sprintf '%s&', uri_encode ($flickr_consumer_secret));
|
|
||||||
} elsif ($p{type} eq 'access_token') {
|
|
||||||
my @parameters;
|
|
||||||
my $flickr_request_token_secret = $p{oauth_token_secret};
|
|
||||||
delete $p{oauth_token_secret};
|
|
||||||
delete $p{type};
|
|
||||||
push @parameters, 'oauth_signature_method=HMAC-SHA1';
|
|
||||||
push @parameters, 'oauth_version=1.0';
|
|
||||||
push @parameters, sprintf 'oauth_consumer_key=%s', $flickr_consumer_key;
|
|
||||||
|
|
||||||
foreach my $param (keys %p) {
|
|
||||||
push @parameters, sprintf ('%s=%s', $param, $p{$param});
|
|
||||||
}
|
|
||||||
|
|
||||||
$string = sprintf 'GET&%s&', uri_encode ($flickr_access_token_url);
|
|
||||||
$string .= uri_encode (join '&', sort (@parameters));
|
|
||||||
$hmac = Digest::HMAC_SHA1->new (sprintf '%s&%s', uri_encode ($flickr_consumer_secret), uri_encode ($flickr_request_token_secret));
|
|
||||||
} elsif ($p{type} eq 'test_login' || $p{type} eq 'search_text' || $p{type} eq 'search_tags') {
|
|
||||||
my @parameters;
|
|
||||||
my $flickr_request_token_secret = $p{oauth_token_secret};
|
|
||||||
delete $p{oauth_token_secret};
|
|
||||||
delete $p{type};
|
|
||||||
|
|
||||||
foreach my $param (keys %p) {
|
|
||||||
push @parameters, sprintf ('%s=%s', $param, $p{$param});
|
|
||||||
}
|
|
||||||
|
|
||||||
$string = sprintf 'GET&%s&', uri_encode ($flickr_api_url);
|
|
||||||
$string .= uri_encode (join '&', sort (@parameters));
|
|
||||||
$hmac = Digest::HMAC_SHA1->new (sprintf '%s&%s', uri_encode ($flickr_consumer_secret), uri_encode ($flickr_request_token_secret));
|
|
||||||
}
|
|
||||||
|
|
||||||
$hmac->add ($string);
|
|
||||||
return encode_base64 ($hmac->digest, '');
|
|
||||||
}
|
|
||||||
|
|
||||||
sub flickrRequestToken {
|
|
||||||
my $oauth_timestamp = time ();
|
|
||||||
my $oauth_nonce = mknonce ();
|
|
||||||
|
|
||||||
my $oauth_signature = flickerSignReq (
|
|
||||||
type => 'request_token',
|
|
||||||
oauth_timestamp => $oauth_timestamp,
|
|
||||||
oauth_nonce => $oauth_nonce
|
|
||||||
);
|
|
||||||
|
|
||||||
my $url = $flickr_request_token_url . sprintf (
|
|
||||||
'?oauth_nonce=%s&oauth_timestamp=%s&oauth_consumer_key=%s&oauth_signature_method=HMAC-SHA1&oauth_version=1.0&&oauth_signature=%s&oauth_callback=%s',
|
|
||||||
$oauth_nonce,
|
|
||||||
$oauth_timestamp,
|
|
||||||
$flickr_consumer_key,
|
|
||||||
uri_encode ($oauth_signature),
|
|
||||||
uri_encode ($flickr_callback_url)
|
|
||||||
);
|
|
||||||
|
|
||||||
my $ua = Mojo::UserAgent->new->connect_timeout (5);
|
|
||||||
my $r = $ua->get ($url)->result;
|
|
||||||
my %params;
|
|
||||||
|
|
||||||
if ($r->is_success) {
|
|
||||||
# they ignore format=json, so...
|
|
||||||
%params = map {split /=/} split /&/, $r->body;
|
|
||||||
} else {
|
|
||||||
say "Something bad returns from flickr api: $r->code $r->message"; ## no critic (InputOutput::RequireCheckedSyscalls)
|
|
||||||
}
|
|
||||||
|
|
||||||
return %params;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub flickrAccessToken {
|
|
||||||
my $flickr_request_token = shift;
|
|
||||||
my $flickr_request_token_secret = shift;
|
|
||||||
my $flickr_verifier = shift; ## no critic (Variables::ProhibitReusedNames)
|
|
||||||
|
|
||||||
my $oauth_timestamp = time ();
|
|
||||||
my $oauth_nonce = mknonce ();
|
|
||||||
|
|
||||||
my $oauth_signature = flickerSignReq (
|
|
||||||
type => 'access_token',
|
|
||||||
oauth_timestamp => $oauth_timestamp,
|
|
||||||
oauth_nonce => $oauth_nonce,
|
|
||||||
oauth_token => $flickr_request_token,
|
|
||||||
oauth_token_secret => $flickr_request_token_secret,
|
|
||||||
oauth_verifier => $flickr_verifier
|
|
||||||
);
|
|
||||||
|
|
||||||
my $url = $flickr_access_token_url . sprintf (
|
|
||||||
'?oauth_nonce=%s&oauth_timestamp=%s&oauth_verifier=%s&oauth_consumer_key=%s&oauth_signature_method=HMAC-SHA1&oauth_version=1.0&oauth_token=%s&oauth_signature=%s',
|
|
||||||
$oauth_nonce,
|
|
||||||
$oauth_timestamp,
|
|
||||||
$flickr_verifier,
|
|
||||||
$flickr_consumer_key,
|
|
||||||
$flickr_request_token,
|
|
||||||
uri_encode ($oauth_signature)
|
|
||||||
);
|
|
||||||
|
|
||||||
my $ua = Mojo::UserAgent->new->connect_timeout (5);
|
|
||||||
my $r = $ua->get ($url)->result;
|
|
||||||
my %params;
|
|
||||||
|
|
||||||
if ($r->is_success) {
|
|
||||||
# they ignore format=json
|
|
||||||
%params = map {split /=/} split /&/, $r->body;
|
|
||||||
} else {
|
|
||||||
say "Something bad returns from flickr api: $r->code $r->message"; ## no critic (InputOutput::RequireCheckedSyscalls)
|
|
||||||
}
|
|
||||||
|
|
||||||
return %params;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub flickrAuthorization {
|
|
||||||
my $flickr_request_token = shift;
|
|
||||||
|
|
||||||
my $url = $flickr_authorization_url . sprintf (
|
|
||||||
'?oauth_token=%s&perms=read',
|
|
||||||
$flickr_request_token,
|
|
||||||
);
|
|
||||||
|
|
||||||
my $ua = Mojo::UserAgent->new->connect_timeout (5);
|
|
||||||
my $r = $ua->get ($url)->result;
|
|
||||||
|
|
||||||
if ($r->code == 302) {
|
|
||||||
return $r->content->headers->location;
|
|
||||||
} else {
|
|
||||||
printf "Something went wrong: %s %s\n", $r->code, $r->message;
|
|
||||||
return;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub flickrTestLogin {
|
|
||||||
my $flickr_access_token = shift;
|
|
||||||
my $flickr_access_token_secret = shift;
|
|
||||||
|
|
||||||
my $oauth_timestamp = time ();
|
|
||||||
my $oauth_nonce = mknonce ();
|
|
||||||
|
|
||||||
my $oauth_signature = flickerSignReq (
|
|
||||||
nojsoncallback => 1,
|
|
||||||
oauth_nonce => $oauth_nonce,
|
|
||||||
format => 'json',
|
|
||||||
oauth_consumer_key => $flickr_consumer_key,
|
|
||||||
oauth_timestamp => $oauth_timestamp,
|
|
||||||
type => 'test_login',
|
|
||||||
method => 'flickr.test.login',
|
|
||||||
oauth_token => $flickr_access_token,
|
|
||||||
oauth_token_secret => $flickr_access_token_secret,
|
|
||||||
oauth_signature_method => 'HMAC-SHA1',
|
|
||||||
oauth_version => '1.0'
|
|
||||||
);
|
|
||||||
|
|
||||||
my $url = $flickr_api_url . sprintf (
|
|
||||||
'?nojsoncallback=1&oauth_nonce=%s&format=json&oauth_consumer_key=%s&oauth_timestamp=%s&oauth_signature_method=HMAC-SHA1&oauth_version=1.0&oauth_token=%s&oauth_signature=%s&method=flickr.test.login',
|
|
||||||
$oauth_nonce,
|
|
||||||
$flickr_consumer_key,
|
|
||||||
$oauth_timestamp,
|
|
||||||
$flickr_access_token,
|
|
||||||
uri_encode ($oauth_signature)
|
|
||||||
);
|
|
||||||
|
|
||||||
my $ua = Mojo::UserAgent->new->connect_timeout (5);
|
|
||||||
my $r = $ua->get ($url)->result;
|
|
||||||
|
|
||||||
if ($r->is_success) {
|
|
||||||
my $response = eval {
|
|
||||||
return $r->json;
|
|
||||||
};
|
|
||||||
|
|
||||||
if (defined $response) {
|
|
||||||
say Dumper $response; ## no critic (InputOutput::RequireCheckedSyscalls)
|
|
||||||
return 1;
|
|
||||||
} else {
|
|
||||||
say "Flickr api returns incorrect json: $r->message"; ## no critic (InputOutput::RequireCheckedSyscalls)
|
|
||||||
return 0;
|
|
||||||
}
|
|
||||||
} else {
|
|
||||||
say "HTTP status code not 200: $r->code, $r->message"; ## no critic (InputOutput::RequireCheckedSyscalls)
|
|
||||||
return 0;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub flickrSearchByText {
|
|
||||||
my $flickr_access_token = shift;
|
|
||||||
my $flickr_access_token_secret = shift;
|
|
||||||
my $text = shift;
|
|
||||||
|
|
||||||
my $oauth_timestamp = time ();
|
|
||||||
my $oauth_nonce = mknonce ();
|
|
||||||
|
|
||||||
my $oauth_signature = flickerSignReq (
|
|
||||||
nojsoncallback => 1,
|
|
||||||
oauth_nonce => $oauth_nonce,
|
|
||||||
format => 'json',
|
|
||||||
oauth_consumer_key => $flickr_consumer_key,
|
|
||||||
oauth_timestamp => $oauth_timestamp,
|
|
||||||
type => 'search_text',
|
|
||||||
content_type => 1,
|
|
||||||
media => 'photos',
|
|
||||||
method => 'flickr.photos.search',
|
|
||||||
text => $text,
|
|
||||||
per_page => 1,
|
|
||||||
oauth_token => $flickr_access_token,
|
|
||||||
oauth_token_secret => $flickr_access_token_secret,
|
|
||||||
oauth_signature_method => 'HMAC-SHA1',
|
|
||||||
oauth_version => '1.0'
|
|
||||||
);
|
|
||||||
|
|
||||||
my $url = $flickr_api_url . sprintf (
|
|
||||||
'?nojsoncallback=1&oauth_nonce=%s&format=json&oauth_consumer_key=%s&oauth_timestamp=%s&oauth_signature_method=HMAC-SHA1&oauth_version=1.0&oauth_token=%s&oauth_signature=%s&method=flickr.photos.search&content_type=1&media=photos&per_page=1&text=%s',
|
|
||||||
$oauth_nonce,
|
|
||||||
$flickr_consumer_key,
|
|
||||||
$oauth_timestamp,
|
|
||||||
$flickr_access_token,
|
|
||||||
uri_encode ($oauth_signature),
|
|
||||||
uri_encode ($text)
|
|
||||||
);
|
|
||||||
|
|
||||||
my $ua = Mojo::UserAgent->new->connect_timeout (5);
|
|
||||||
my $r = $ua->get ($url)->result;
|
|
||||||
|
|
||||||
if ($r->is_success) {
|
|
||||||
my $response = eval {
|
|
||||||
return $r->json;
|
|
||||||
};
|
|
||||||
|
|
||||||
if (defined $response) {
|
|
||||||
# lets make another query, this time with random picture
|
|
||||||
my $page = irand int ($response->{photos}->{total} / 500);
|
|
||||||
$oauth_timestamp = time ();
|
|
||||||
$oauth_nonce = mknonce ();
|
|
||||||
$oauth_signature = flickerSignReq (
|
|
||||||
nojsoncallback => 1,
|
|
||||||
oauth_nonce => $oauth_nonce,
|
|
||||||
format => 'json',
|
|
||||||
oauth_consumer_key => $flickr_consumer_key,
|
|
||||||
oauth_timestamp => $oauth_timestamp,
|
|
||||||
type => 'search_text',
|
|
||||||
content_type => 1,
|
|
||||||
media => 'photos',
|
|
||||||
method => 'flickr.photos.search',
|
|
||||||
text => $text,
|
|
||||||
page => $page,
|
|
||||||
per_page => 500,
|
|
||||||
oauth_token => $flickr_access_token,
|
|
||||||
oauth_token_secret => $flickr_access_token_secret,
|
|
||||||
oauth_signature_method => 'HMAC-SHA1',
|
|
||||||
oauth_version => '1.0'
|
|
||||||
);
|
|
||||||
|
|
||||||
$url = $flickr_api_url . sprintf (
|
|
||||||
'?nojsoncallback=1&oauth_nonce=%s&format=json&oauth_consumer_key=%s&oauth_timestamp=%s&oauth_signature_method=HMAC-SHA1&oauth_version=1.0&oauth_token=%s&oauth_signature=%s&method=flickr.photos.search&content_type=1&media=photos&per_page=500&page=%d&text=%s',
|
|
||||||
$oauth_nonce,
|
|
||||||
$flickr_consumer_key,
|
|
||||||
$oauth_timestamp,
|
|
||||||
$flickr_access_token,
|
|
||||||
uri_encode ($oauth_signature),
|
|
||||||
$page,
|
|
||||||
uri_encode ($text)
|
|
||||||
);
|
|
||||||
|
|
||||||
$ua = Mojo::UserAgent->new->connect_timeout (5);
|
|
||||||
$r = $ua->get ($url)->result;
|
|
||||||
|
|
||||||
|
|
||||||
if ($r->is_success) {
|
|
||||||
$response = eval {
|
|
||||||
return $r->json;
|
|
||||||
};
|
|
||||||
|
|
||||||
if (defined $response) {
|
|
||||||
return $response;
|
|
||||||
} else {
|
|
||||||
$log->warn ("[WARN] Flickr api returns incorrect json: $r->message");
|
|
||||||
return undef;
|
|
||||||
}
|
|
||||||
} else {
|
|
||||||
$log->warn ("[WARN] Flickr api returns incorrect json: $r->message");
|
|
||||||
return undef;
|
|
||||||
}
|
|
||||||
} else {
|
|
||||||
$log->warn ("[WARN] Flickr api returns incorrect json: $r->message");
|
|
||||||
return undef;
|
|
||||||
}
|
|
||||||
} else {
|
|
||||||
$log->warn ("[WARN] Flickr api HTTP status code not 200: $r->code, $r->message");
|
|
||||||
return undef;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub flickrSearchByTags {
|
|
||||||
my $flickr_access_token = shift;
|
|
||||||
my $flickr_access_token_secret = shift;
|
|
||||||
my $tags = shift;
|
|
||||||
|
|
||||||
my $oauth_timestamp = time ();
|
|
||||||
my $oauth_nonce = mknonce ();
|
|
||||||
|
|
||||||
my $oauth_signature = flickerSignReq (
|
|
||||||
nojsoncallback => 1,
|
|
||||||
oauth_nonce => $oauth_nonce,
|
|
||||||
format => 'json',
|
|
||||||
oauth_consumer_key => $flickr_consumer_key,
|
|
||||||
oauth_timestamp => $oauth_timestamp,
|
|
||||||
type => 'search_tags',
|
|
||||||
content_type => 1,
|
|
||||||
media => 'photos',
|
|
||||||
method => 'flickr.photos.search',
|
|
||||||
tags => $tags,
|
|
||||||
per_page => 1,
|
|
||||||
oauth_token => $flickr_access_token,
|
|
||||||
oauth_token_secret => $flickr_access_token_secret,
|
|
||||||
oauth_signature_method => 'HMAC-SHA1',
|
|
||||||
oauth_version => '1.0'
|
|
||||||
);
|
|
||||||
|
|
||||||
my $url = $flickr_api_url . sprintf (
|
|
||||||
'?nojsoncallback=1&oauth_nonce=%s&format=json&oauth_consumer_key=%s&oauth_timestamp=%s&oauth_signature_method=HMAC-SHA1&oauth_version=1.0&oauth_token=%s&oauth_signature=%s&method=flickr.photos.search&content_type=1&media=photos&per_page=1&tags=%s&tag_mode=all',
|
|
||||||
$oauth_nonce,
|
|
||||||
$flickr_consumer_key,
|
|
||||||
$oauth_timestamp,
|
|
||||||
$flickr_access_token,
|
|
||||||
uri_encode ($oauth_signature),
|
|
||||||
uri_encode ($tags)
|
|
||||||
);
|
|
||||||
|
|
||||||
my $ua = Mojo::UserAgent->new->connect_timeout (5);
|
|
||||||
my $r = $ua->get ($url)->result;
|
|
||||||
|
|
||||||
if ($r->is_success) {
|
|
||||||
my $response = eval {
|
|
||||||
return $r->json;
|
|
||||||
};
|
|
||||||
|
|
||||||
if (defined $response) {
|
|
||||||
# lets make another query, this time with random picture
|
|
||||||
my $page = irand int ($response->{photos}->{total} / 500);
|
|
||||||
$oauth_timestamp = time ();
|
|
||||||
$oauth_nonce = mknonce ();
|
|
||||||
$oauth_signature = flickerSignReq (
|
|
||||||
nojsoncallback => 1,
|
|
||||||
oauth_nonce => $oauth_nonce,
|
|
||||||
format => 'json',
|
|
||||||
oauth_consumer_key => $flickr_consumer_key,
|
|
||||||
oauth_timestamp => $oauth_timestamp,
|
|
||||||
type => 'search_text',
|
|
||||||
content_type => 1,
|
|
||||||
media => 'photos',
|
|
||||||
method => 'flickr.photos.search',
|
|
||||||
tags => $tags,
|
|
||||||
page => $page,
|
|
||||||
per_page => 500,
|
|
||||||
oauth_token => $flickr_access_token,
|
|
||||||
oauth_token_secret => $flickr_access_token_secret,
|
|
||||||
oauth_signature_method => 'HMAC-SHA1',
|
|
||||||
oauth_version => '1.0'
|
|
||||||
);
|
|
||||||
|
|
||||||
$url = $flickr_api_url . sprintf (
|
|
||||||
'?nojsoncallback=1&oauth_nonce=%s&format=json&oauth_consumer_key=%s&oauth_timestamp=%s&oauth_signature_method=HMAC-SHA1&oauth_version=1.0&oauth_token=%s&oauth_signature=%s&method=flickr.photos.search&content_type=1&media=photos&per_page=500&page=%d&tags=%s&tag_mode=all',
|
|
||||||
$oauth_nonce,
|
|
||||||
$flickr_consumer_key,
|
|
||||||
$oauth_timestamp,
|
|
||||||
$flickr_access_token,
|
|
||||||
uri_encode ($oauth_signature),
|
|
||||||
$page,
|
|
||||||
uri_encode ($tags)
|
|
||||||
);
|
|
||||||
|
|
||||||
$ua = Mojo::UserAgent->new->connect_timeout (5);
|
|
||||||
$r = $ua->get ($url)->result;
|
|
||||||
|
|
||||||
if ($r->is_success) {
|
|
||||||
$response = eval {
|
|
||||||
return $r->json;
|
|
||||||
};
|
|
||||||
|
|
||||||
if (defined $response) {
|
|
||||||
return $response;
|
|
||||||
} else {
|
|
||||||
$log->warn ("[WARN] Flickr api returns incorrect json: $r->message");
|
|
||||||
return undef;
|
|
||||||
}
|
|
||||||
} else {
|
|
||||||
$log->warn ("[WARN] Flickr api returns incorrect json: $r->message");
|
|
||||||
return undef;
|
|
||||||
}
|
|
||||||
} else {
|
|
||||||
$log->warn ("[WARN] Flickr api returns incorrect json: $r->message");
|
|
||||||
return undef;
|
|
||||||
}
|
|
||||||
} else {
|
|
||||||
$log->warn ("[WARN] Flickr api HTTP status code not 200: $r->code, $r->message");
|
|
||||||
return undef;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub FlickrInit {
|
|
||||||
my $cache = CHI->new (
|
|
||||||
driver => 'BerkeleyDB',
|
|
||||||
root_dir => $cachedir,
|
|
||||||
namespace => __PACKAGE__
|
|
||||||
);
|
|
||||||
|
|
||||||
if (defined $flickr_verifier && $flickr_verifier) {
|
|
||||||
my $flickr_request_token = $cache->get ('flickr_request_token');
|
|
||||||
my $flickr_request_token_secret = $cache->get ('flickr_request_token_secret');
|
|
||||||
|
|
||||||
unless (defined $flickr_request_token || defined $flickr_request_token_secret) {
|
|
||||||
say 'Looks like there is no request token or request token secret in config db.'; ## no critic (InputOutput::RequireCheckedSyscalls)
|
|
||||||
say 'Please remove verifier settings from config.json and run this script again.'; ## no critic (InputOutput::RequireCheckedSyscalls)
|
|
||||||
return 0;
|
|
||||||
}
|
|
||||||
|
|
||||||
my %accessToken = flickrAccessToken ($flickr_request_token, $flickr_request_token_secret, $flickr_verifier);
|
|
||||||
|
|
||||||
if (defined ($accessToken{oauth_token}) && defined ($accessToken{oauth_token_secret})) {
|
|
||||||
# TODO: check set
|
|
||||||
$cache->set ('flickr_access_token', $accessToken{oauth_token}, 'never');
|
|
||||||
$cache->set ('flickr_access_token_secret', $accessToken{oauth_token_secret}, 'never');
|
|
||||||
|
|
||||||
say sprintf ( ## no critic (InputOutput::RequireCheckedSyscalls)
|
|
||||||
'Access token (%s) and access token secret (%s) are config db',
|
|
||||||
$accessToken{oauth_token},
|
|
||||||
$accessToken{oauth_token_secret},
|
|
||||||
);
|
|
||||||
|
|
||||||
return 1;
|
|
||||||
}
|
|
||||||
} else {
|
|
||||||
my %req = flickrRequestToken ();
|
|
||||||
if (defined ($req{oauth_token}) && defined ($req{oauth_token_secret}) && defined ($req{oauth_token})) {
|
|
||||||
# TODO: check set
|
|
||||||
$cache->set ('flickr_request_token', $req{oauth_token}, 'never');
|
|
||||||
$cache->set ('flickr_request_token_secret', $req{oauth_token_secret}, 'never');
|
|
||||||
my $confirm_url = flickrAuthorization ($req{oauth_token});
|
|
||||||
|
|
||||||
if (defined $confirm_url) {
|
|
||||||
say "Please open this url in your browser and grant access for this app:\n$confirm_url"; ## no critic (InputOutput::RequireCheckedSyscalls)
|
|
||||||
say 'Do not forget to put oauth_verifier to config.json file and re-run this script to get access token'; ## no critic (InputOutput::RequireCheckedSyscalls)
|
|
||||||
say 'Note that you should be logged off from flickr account.'; ## no critic (InputOutput::RequireCheckedSyscalls)
|
|
||||||
return 1;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
return 0;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub FlickrTestLogin {
|
|
||||||
my $text = shift;
|
|
||||||
my $cache = CHI->new (
|
|
||||||
driver => 'BerkeleyDB',
|
|
||||||
root_dir => $cachedir,
|
|
||||||
namespace => __PACKAGE__
|
|
||||||
);
|
|
||||||
|
|
||||||
my $flickr_access_token = $cache->get ('flickr_access_token');
|
|
||||||
my $flickr_access_token_secret = $cache->get ('flickr_access_token_secret');
|
|
||||||
|
|
||||||
if (flickrTestLogin ($flickr_access_token, $flickr_access_token_secret)) {
|
|
||||||
return 1;
|
|
||||||
} else {
|
|
||||||
return 0;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub FlickrByTags {
|
|
||||||
my $text = shift;
|
|
||||||
|
|
||||||
my $cache = CHI->new (
|
|
||||||
driver => 'BerkeleyDB',
|
|
||||||
root_dir => $cachedir,
|
|
||||||
namespace => __PACKAGE__
|
|
||||||
);
|
|
||||||
|
|
||||||
my $flickr_access_token = $cache->get ('flickr_access_token');
|
|
||||||
my $flickr_access_token_secret = $cache->get ('flickr_access_token_secret');
|
|
||||||
|
|
||||||
# NB: I honestly query random page (among number of pages) of results from api, but always got first page,
|
|
||||||
# no matter what is shown in response' "page" parameter. Looks like bug in API. Try to little bit mitigate
|
|
||||||
# this bug via query 500 results per page, then we can select random result in this heap. But anyway, let's
|
|
||||||
# make this thing future proof and leave randomizer in page select.
|
|
||||||
my $result = flickrSearchByTags ($flickr_access_token, $flickr_access_token_secret, $text);
|
|
||||||
|
|
||||||
if ($result) {
|
|
||||||
if (defined ($result->{photos}) && defined ($result->{photos}->{photo})) {
|
|
||||||
my $item = irand int(@{$result->{photos}->{photo}});
|
|
||||||
$item = ${$result->{photos}->{photo}}[$item];
|
|
||||||
$item = sprintf 'https://live.staticflickr.com/%s/%s_%s_z.jpg', $item->{server}, $item->{id}, $item->{secret};
|
|
||||||
return $item;
|
|
||||||
} else {
|
|
||||||
$log->notice ('[NOTICE] Flickr api returns empty search result list');
|
|
||||||
return;
|
|
||||||
}
|
|
||||||
} else {
|
|
||||||
return;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub FlickrByText {
|
|
||||||
my $text = shift;
|
|
||||||
|
|
||||||
my $cache = CHI->new (
|
|
||||||
driver => 'BerkeleyDB',
|
|
||||||
root_dir => $cachedir,
|
|
||||||
namespace => __PACKAGE__
|
|
||||||
);
|
|
||||||
|
|
||||||
my $flickr_access_token = $cache->get ('flickr_access_token');
|
|
||||||
my $flickr_access_token_secret = $cache->get ('flickr_access_token_secret');
|
|
||||||
|
|
||||||
# NB: I honestly query random page (among number of pages) of results from api, but always got first page,
|
|
||||||
# no matter what is shown in response' "page" parameter. Looks like bug in API. Try to little bit mitigate
|
|
||||||
# this bug via query 500 results per page, then we can select random result in this heap. But anyway, let's
|
|
||||||
# make this thing future proof and leave randomizer in page select.
|
|
||||||
my $result = flickrSearchByText ($flickr_access_token, $flickr_access_token_secret, $text);
|
|
||||||
|
|
||||||
if ($result) {
|
|
||||||
if (defined ($result->{photos}) && defined ($result->{photos}->{photo})) {
|
|
||||||
my $item = irand int(@{$result->{photos}->{photo}});
|
|
||||||
$item = ${$result->{photos}->{photo}}[$item];
|
|
||||||
$item = sprintf 'https://live.staticflickr.com/%s/%s_%s_z.jpg', $item->{server}, $item->{id}, $item->{secret};
|
|
||||||
return $item;
|
|
||||||
} else {
|
|
||||||
$log->notice ('[NOTICE] Flickr api returns empty search result list');
|
|
||||||
return;
|
|
||||||
}
|
|
||||||
} else {
|
|
||||||
return;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
1;
|
|
||||||
@@ -1,151 +0,0 @@
|
|||||||
package Botlib::Image::Imgur;
|
|
||||||
|
|
||||||
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 CHI;
|
|
||||||
use CHI::Driver::BerkeleyDB;
|
|
||||||
use Log::Any qw ($log);
|
|
||||||
use Math::Random::Secure qw (irand);
|
|
||||||
use Mojo::UserAgent;
|
|
||||||
|
|
||||||
use BotLib::Conf qw (LoadConf);
|
|
||||||
|
|
||||||
use version; our $VERSION = qw (1.0);
|
|
||||||
use Exporter qw (import);
|
|
||||||
our @EXPORT_OK = qw (Imgur);
|
|
||||||
|
|
||||||
my $c = LoadConf ();
|
|
||||||
my $cachedir = $c->{cachedir};
|
|
||||||
|
|
||||||
sub Imgur {
|
|
||||||
my $tag = shift;
|
|
||||||
|
|
||||||
my $refresh_url = 'https://api.imgur.com/oauth2/token';
|
|
||||||
my $search_url = 'https://api.imgur.com/3/gallery/search/';
|
|
||||||
|
|
||||||
my $imgur_client_id = $c->{image}->{imgur}->{client_id} // do {
|
|
||||||
$log->error ('[ERROR] No client_id specified in config for imgur module');
|
|
||||||
return undef;
|
|
||||||
};
|
|
||||||
my $imgur_client_secret = $c->{image}->{imgur}->{client_secret} // do {
|
|
||||||
$log->error ('[ERROR] No client_secret specified in config for imgur module');
|
|
||||||
return undef;
|
|
||||||
};
|
|
||||||
my $imgur_access_token = $c->{image}->{imgur}->{access_token} // do {
|
|
||||||
$log->error ('[ERROR] No access_token specified in config for imgur module');
|
|
||||||
return undef;
|
|
||||||
};
|
|
||||||
my $imgur_refresh_token = $c->{image}->{imgur}->{refresh_token} // do {
|
|
||||||
$log->warn ('[WARN] No refresh_token specified in config for imgur module');
|
|
||||||
};
|
|
||||||
|
|
||||||
# N.B. Both imgur_access_token and imgur_refresh_token time to time can change, so we need
|
|
||||||
# some place where we can store new values
|
|
||||||
my $cache = CHI->new (
|
|
||||||
driver => 'BerkeleyDB',
|
|
||||||
root_dir => $cachedir,
|
|
||||||
namespace => __PACKAGE__
|
|
||||||
);
|
|
||||||
|
|
||||||
$imgur_access_token = $cache->get ('imgur_access_token');
|
|
||||||
|
|
||||||
# if there is no access_token in db - put there one from config
|
|
||||||
unless (defined $imgur_access_token) {
|
|
||||||
$cache->set ('imgur_access_token', $c->{image}->{imgur}->{access_token}, 'never');
|
|
||||||
}
|
|
||||||
|
|
||||||
$imgur_refresh_token = $cache->get ('imgur_refresh_token');
|
|
||||||
|
|
||||||
# if there is no refresh_token in db - put there one from config
|
|
||||||
unless (defined $imgur_refresh_token) {
|
|
||||||
$cache->set ('imgur_refresh_token', $c->{image}->{imgur}->{refresh_token}, 'never');
|
|
||||||
}
|
|
||||||
|
|
||||||
# query api
|
|
||||||
my $ua = Mojo::UserAgent->new->connect_timeout (3);
|
|
||||||
my $r = $ua->get ($search_url . $tag => {Authorization => "Bearer $imgur_access_token"})->result;
|
|
||||||
|
|
||||||
# looks like we need to refresh token
|
|
||||||
if (($r->code == 401) || ($r->code == 403)) {
|
|
||||||
$ua->post (
|
|
||||||
$refresh_url => form {
|
|
||||||
refresh_token => $imgur_refresh_token,
|
|
||||||
client_id => $imgur_client_id,
|
|
||||||
clinent_secret => $imgur_client_secret,
|
|
||||||
grant_type => 'refresh_token',
|
|
||||||
}
|
|
||||||
);
|
|
||||||
|
|
||||||
unless ($r->is_success) {
|
|
||||||
$log->error ("[ERROR] Unable to refresh imgur token, please re-authorise app! or imgur experiencing api outage: $r->code $r->message");
|
|
||||||
return undef;
|
|
||||||
}
|
|
||||||
|
|
||||||
my $refresh = eval { return $r->json; };
|
|
||||||
|
|
||||||
if (defined $refresh) {
|
|
||||||
$imgur_refresh_token = $refresh->{refresh_token};
|
|
||||||
$cache->set ('refresh_token', $refresh->{refresh_token}, 'never');
|
|
||||||
$imgur_access_token = $refresh->{access_token};
|
|
||||||
$cache->set ('imgur_access_token', $refresh->{access_token}, 'never');
|
|
||||||
} else {
|
|
||||||
$log->warn ("[ERROR] Unable to refresh imgur access_token, unable to decode json: $EVAL_ERROR");
|
|
||||||
return undef;
|
|
||||||
}
|
|
||||||
|
|
||||||
# query api again
|
|
||||||
$r = $ua->get ($search_url . $tag => {Authorization => "Bearer $imgur_access_token"})->result;
|
|
||||||
}
|
|
||||||
|
|
||||||
if ($r->is_success) {
|
|
||||||
my $searchResult = eval { return $r->json; };
|
|
||||||
my @urls;
|
|
||||||
|
|
||||||
if (defined $searchResult) {
|
|
||||||
if ($searchResult->{success}) {
|
|
||||||
foreach my $item (@{$searchResult->{data}}) {
|
|
||||||
foreach my $image (@{$item->{images}}) {
|
|
||||||
if (defined ($image->{animated}) && (0 + $image->{animated}) != 0) {
|
|
||||||
next;
|
|
||||||
}
|
|
||||||
|
|
||||||
if (($image->{type} eq 'image/jpeg') || ($image->{type} eq 'image/png')) {
|
|
||||||
if (defined ($image->{is_ad}) && (0 + $image->{is_ad}) !=0) {
|
|
||||||
next;
|
|
||||||
}
|
|
||||||
|
|
||||||
if (defined ($image->{nsfw}) && (0 + $image->{nsfw}) != 0) {
|
|
||||||
next;
|
|
||||||
}
|
|
||||||
|
|
||||||
push @urls, $image->{link};
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
if ($#urls > 0) {
|
|
||||||
return $urls[irand ($#urls + 1)];
|
|
||||||
} else {
|
|
||||||
$log->notice ('[NOTICE] Imgur api returned empty result.');
|
|
||||||
return undef;
|
|
||||||
}
|
|
||||||
} else {
|
|
||||||
$log->warn ("[WARN] Unable to get results from imgur api: $r->message");
|
|
||||||
return undef;
|
|
||||||
}
|
|
||||||
} else {
|
|
||||||
$log->warn ("[WARN] Unable to decode imgur api json: $EVAL_ERROR");
|
|
||||||
return undef;
|
|
||||||
}
|
|
||||||
} else {
|
|
||||||
$log->warn ("[WARN] Unable to get results from imgur api: $r->code, $r->message");
|
|
||||||
return undef;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
1;
|
|
||||||
@@ -1,104 +0,0 @@
|
|||||||
package BotLib::Karma;
|
|
||||||
|
|
||||||
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 CHI;
|
|
||||||
use CHI::Driver::BerkeleyDB;
|
|
||||||
use Log::Any qw ($log);
|
|
||||||
use BotLib::Conf qw (LoadConf);
|
|
||||||
|
|
||||||
use version; our $VERSION = qw (1.0);
|
|
||||||
use Exporter qw (import);
|
|
||||||
our @EXPORT_OK = qw (KarmaSet KarmaGet);
|
|
||||||
|
|
||||||
my $c = LoadConf ();
|
|
||||||
my $cachedir = $c->{cachedir};
|
|
||||||
my $max = 5;
|
|
||||||
|
|
||||||
# swallow phrase and return answer
|
|
||||||
sub KarmaSet (@) {
|
|
||||||
my $chatid = shift;
|
|
||||||
my $phrase = shift;
|
|
||||||
my $action = shift;
|
|
||||||
|
|
||||||
if (($phrase eq '') || ($phrase =~ /^ +$/)) {
|
|
||||||
$phrase = ' ';
|
|
||||||
}
|
|
||||||
|
|
||||||
my $cache = CHI->new (
|
|
||||||
driver => 'BerkeleyDB',
|
|
||||||
root_dir => $cachedir,
|
|
||||||
namespace => __PACKAGE__ . '_' . $chatid
|
|
||||||
);
|
|
||||||
|
|
||||||
my $score = $cache->get ($phrase);
|
|
||||||
|
|
||||||
if (defined $score) {
|
|
||||||
if ($action eq '++') {
|
|
||||||
$score++;
|
|
||||||
} else {
|
|
||||||
$score--;
|
|
||||||
}
|
|
||||||
} else {
|
|
||||||
if ($action eq '++') {
|
|
||||||
$score = 1;
|
|
||||||
} else {
|
|
||||||
$score = -1;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
if ($cache->set ($phrase, $score, 'never') != $score) {
|
|
||||||
$log->error ('[ERROR] Cache error: unable to set karma.');
|
|
||||||
}
|
|
||||||
|
|
||||||
if ($score < -1 && (($score % (0 - $max)) + 1) == 0) {
|
|
||||||
if ($phrase eq ' ') {
|
|
||||||
return sprintf 'Зарегистрировано пробитие дна, карма пустоты составляет %d', $score;
|
|
||||||
} else {
|
|
||||||
return sprintf 'Зарегистрировано пробитие дна, карма %s составляет %d', $phrase, $score;
|
|
||||||
}
|
|
||||||
} else {
|
|
||||||
if ($phrase eq ' ') {
|
|
||||||
return sprintf 'Карма пустоты составляет %d', $score;
|
|
||||||
} else {
|
|
||||||
return sprintf 'Карма %s составляет %d', $phrase, $score;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
# just return answer
|
|
||||||
sub KarmaGet (@) {
|
|
||||||
my $chatid = shift;
|
|
||||||
my $phrase = shift;
|
|
||||||
|
|
||||||
if (($phrase eq '') || ($phrase =~ /^ +$/)) {
|
|
||||||
$phrase = ' ';
|
|
||||||
}
|
|
||||||
|
|
||||||
my $cache = CHI->new (
|
|
||||||
driver => 'BerkeleyDB',
|
|
||||||
root_dir => $cachedir,
|
|
||||||
namespace => __PACKAGE__ . '_' . $chatid
|
|
||||||
);
|
|
||||||
|
|
||||||
my $score = $cache->get ($phrase);
|
|
||||||
|
|
||||||
unless (defined $score) {
|
|
||||||
$score = 0;
|
|
||||||
}
|
|
||||||
|
|
||||||
if ($phrase eq ' ') {
|
|
||||||
return sprintf 'Карма пустоты составляет %d', $score;
|
|
||||||
} else {
|
|
||||||
return sprintf 'Карма %s составляет %d', $phrase, $score;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
1;
|
|
||||||
|
|
||||||
# vim: ft=perl noet ai ts=4 sw=4 sts=4:
|
|
||||||
@@ -1,74 +0,0 @@
|
|||||||
package BotLib::Lat;
|
|
||||||
# famous latin phases taken from https://ru.wikipedia.org/wiki/Список_крылатых_латинских_выражений
|
|
||||||
|
|
||||||
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 File::Basename qw (dirname);
|
|
||||||
use File::Path qw (make_path);
|
|
||||||
use Hailo;
|
|
||||||
use Log::Any qw ($log);
|
|
||||||
use BotLib::Conf qw (LoadConf);
|
|
||||||
|
|
||||||
use version; our $VERSION = qw (1.0);
|
|
||||||
use Exporter qw (import);
|
|
||||||
our @EXPORT_OK = qw (Train Lat);
|
|
||||||
|
|
||||||
my $c = LoadConf ();
|
|
||||||
my $brain = $c->{lat}->{brain};
|
|
||||||
my $srcfile = $c->{lat}->{src};
|
|
||||||
|
|
||||||
sub Train () {
|
|
||||||
my $braindir = dirname $brain;
|
|
||||||
|
|
||||||
unless (-d $braindir) {
|
|
||||||
make_path ($braindir) or do {
|
|
||||||
cluck "Unable to create $braindir: $OS_ERROR";
|
|
||||||
exit 1;
|
|
||||||
};
|
|
||||||
}
|
|
||||||
|
|
||||||
my $lat = Hailo->new (
|
|
||||||
brain => $brain,
|
|
||||||
# in our case mean amount of words in phase is 3
|
|
||||||
order => 2
|
|
||||||
);
|
|
||||||
|
|
||||||
$lat->train ($srcfile);
|
|
||||||
my ($tokens, $expressions) = ($lat->stats ())[0,1];
|
|
||||||
printf "Total tokens: %s\nTotal expressions: %s\n", $tokens, $expressions;
|
|
||||||
$lat->save ();
|
|
||||||
return;
|
|
||||||
}
|
|
||||||
|
|
||||||
# just return answer
|
|
||||||
sub Lat () {
|
|
||||||
my $braindir = dirname $brain;
|
|
||||||
|
|
||||||
unless (-d $braindir) {
|
|
||||||
$log->error ("[ERROR] No lat module data: $braindir is absent! Train lat first.");
|
|
||||||
return '';
|
|
||||||
}
|
|
||||||
|
|
||||||
unless (-f $brain) {
|
|
||||||
$log->error ("[ERROR] No lat module data: $brain is absent! Train lat first.");
|
|
||||||
return '';
|
|
||||||
}
|
|
||||||
|
|
||||||
my $lat = Hailo->new (
|
|
||||||
brain => $brain,
|
|
||||||
# in our case mean amount of words in phase is 3
|
|
||||||
order => 2,
|
|
||||||
save_on_exit => 0
|
|
||||||
);
|
|
||||||
|
|
||||||
return $lat->reply ();
|
|
||||||
}
|
|
||||||
|
|
||||||
1;
|
|
||||||
|
|
||||||
# vim: ft=perl noet ai ts=4 sw=4 sts=4:
|
|
||||||
@@ -1,63 +0,0 @@
|
|||||||
package BotLib::Monkeyuser;
|
|
||||||
|
|
||||||
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 HTML::TokeParser;
|
|
||||||
use Log::Any qw ($log);
|
|
||||||
use Math::Random::Secure qw (irand);
|
|
||||||
use Mojo::UserAgent;
|
|
||||||
|
|
||||||
use version; our $VERSION = qw (1.0);
|
|
||||||
use Exporter qw (import);
|
|
||||||
our @EXPORT_OK = qw (Monkeyuser);
|
|
||||||
|
|
||||||
sub Monkeyuser {
|
|
||||||
my $r;
|
|
||||||
my $ret = 'Нету Monkey User-ов, они все спрятались.';
|
|
||||||
my @link;
|
|
||||||
|
|
||||||
for (1..3) {
|
|
||||||
my $ua = Mojo::UserAgent->new->connect_timeout (3);
|
|
||||||
$r = $ua->get ('https://www.monkeyuser.com/toc/')->result;
|
|
||||||
|
|
||||||
if ($r->is_success) {
|
|
||||||
last;
|
|
||||||
}
|
|
||||||
|
|
||||||
sleep 2;
|
|
||||||
}
|
|
||||||
|
|
||||||
if ($r->is_success) {
|
|
||||||
my $p = HTML::TokeParser->new(\$r->body);
|
|
||||||
my @a;
|
|
||||||
|
|
||||||
do {
|
|
||||||
$#a = -1;
|
|
||||||
@a = $p->get_tag('a'); ## no critic (Variables::RequireLocalizedPunctuationVars)
|
|
||||||
|
|
||||||
if (defined $a[0][1]->{class} && $a[0][1]->{class} eq 'lazyload small-image') {
|
|
||||||
if (defined $a[0][1]->{'data-src'} && ($a[0][1]->{'data-src'} !~ /adlitteram/)) {
|
|
||||||
push @link, $a[0][1]->{'data-src'};
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
} while ($#{$a[0]} > 1);
|
|
||||||
|
|
||||||
if ($#link > 0) {
|
|
||||||
$ret = sprintf '[MonkeyUser](https://www.monkeyuser.com%s)', $link [irand (1 + $#link)];
|
|
||||||
}
|
|
||||||
} else {
|
|
||||||
$log->warn (sprintf '[WARN] MonkeyUser 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:
|
|
||||||
@@ -1,192 +0,0 @@
|
|||||||
package BotLib::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 CHI;
|
|
||||||
use CHI::Driver::BerkeleyDB;
|
|
||||||
use Log::Any qw ($log);
|
|
||||||
use Mojo::Log;
|
|
||||||
use Mojo::UserAgent::Cached;
|
|
||||||
use BotLib::Conf qw (LoadConf);
|
|
||||||
use BotLib::Util qw (trim urlencode);
|
|
||||||
|
|
||||||
use version; our $VERSION = qw (1.0);
|
|
||||||
use Exporter qw (import);
|
|
||||||
our @EXPORT_OK = qw (Weather);
|
|
||||||
|
|
||||||
my $c = LoadConf ();
|
|
||||||
my $cachedir = $c->{cachedir};
|
|
||||||
|
|
||||||
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}
|
|
||||||
);
|
|
||||||
} elsif ($w->{temperature_min} < 0 && $w->{temperature_max} <= 0) {
|
|
||||||
$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_max},
|
|
||||||
$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 $appid = $c->{openweathermap}->{appid};
|
|
||||||
my $now = time ();
|
|
||||||
my $fc;
|
|
||||||
my $w;
|
|
||||||
|
|
||||||
my $r;
|
|
||||||
|
|
||||||
# try 3 times and giveup
|
|
||||||
for (1..3) {
|
|
||||||
my $ua = Mojo::UserAgent::Cached->new;
|
|
||||||
$ua->local_dir ($cachedir);
|
|
||||||
$ua->cache_agent(
|
|
||||||
CHI->new (
|
|
||||||
driver => 'BerkeleyDB',
|
|
||||||
root_dir => $cachedir,
|
|
||||||
namespace => __PACKAGE__,
|
|
||||||
expires_in => '3 hours',
|
|
||||||
expires_on_backend => 1,
|
|
||||||
)
|
|
||||||
);
|
|
||||||
# just to make Mojo::UserAgent::Cached happy
|
|
||||||
$ua->logger (Mojo::Log->new (path => '/dev/null', level => 'error'));
|
|
||||||
$r = $ua->get (sprintf ('http://api.openweathermap.org/data/2.5/weather?q=%s&lang=ru&APPID=%s', $city, $appid))->result;
|
|
||||||
|
|
||||||
if ($r->is_success) {
|
|
||||||
last;
|
|
||||||
}
|
|
||||||
|
|
||||||
sleep 2;
|
|
||||||
}
|
|
||||||
|
|
||||||
# all 3 times can give error, so check it here
|
|
||||||
if ($r->is_success) {
|
|
||||||
$fc = eval {
|
|
||||||
return $r->json;
|
|
||||||
};
|
|
||||||
|
|
||||||
unless ($fc) {
|
|
||||||
$log->warn ("[WARN] openweathermap returns corrupted json: $EVAL_ERROR");
|
|
||||||
return undef;
|
|
||||||
};
|
|
||||||
} else {
|
|
||||||
$log->warn (sprintf '[WARN] Server return status %s with message: %s', $r->code, $r->message);
|
|
||||||
return undef;
|
|
||||||
}
|
|
||||||
|
|
||||||
# TODO: check all of this for existence
|
|
||||||
$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:
|
|
||||||
@@ -1,47 +0,0 @@
|
|||||||
package BotLib::Xkcd;
|
|
||||||
|
|
||||||
use 5.018;
|
|
||||||
use strict;
|
|
||||||
use warnings;
|
|
||||||
use utf8;
|
|
||||||
use open qw (:std :utf8);
|
|
||||||
use Mojo::UserAgent;
|
|
||||||
|
|
||||||
use version; our $VERSION = qw (1.0);
|
|
||||||
use Exporter qw (import);
|
|
||||||
our @EXPORT_OK = qw (Xkcd);
|
|
||||||
|
|
||||||
sub Xkcd {
|
|
||||||
my $ua = Mojo::UserAgent->new->connect_timeout (5)->max_redirects (0);
|
|
||||||
my $location;
|
|
||||||
my $status = 400;
|
|
||||||
my $c = 0;
|
|
||||||
|
|
||||||
do {
|
|
||||||
my $r = $ua->get ('https://xkcd.ru/random/')->result;
|
|
||||||
|
|
||||||
if (
|
|
||||||
defined $r->content &&
|
|
||||||
defined $r->content->headers &&
|
|
||||||
defined $r->content->headers->location &&
|
|
||||||
$r->content->headers->location ne ''
|
|
||||||
) {
|
|
||||||
$location = substr $r->content->headers->location, 1, -1;
|
|
||||||
$location = sprintf 'https://xkcd.ru/i/%s_v1.png', $location;
|
|
||||||
$r = $ua->head ($location)->result;
|
|
||||||
}
|
|
||||||
|
|
||||||
$c++;
|
|
||||||
$status = $r->code;
|
|
||||||
} while ($c < 3 || $status >= 404);
|
|
||||||
|
|
||||||
if ($status == 200) {
|
|
||||||
return sprintf '[xkcd.ru](%s)', $location;
|
|
||||||
}
|
|
||||||
|
|
||||||
return 'Комикс-стрип нарисовать не так-то просто :(';
|
|
||||||
}
|
|
||||||
|
|
||||||
1;
|
|
||||||
|
|
||||||
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
|
||||||
111
lib/RedisLib.pm
Normal file
111
lib/RedisLib.pm
Normal file
@@ -0,0 +1,111 @@
|
|||||||
|
package RedisLib;
|
||||||
|
|
||||||
|
use 5.018;
|
||||||
|
use strict;
|
||||||
|
use warnings;
|
||||||
|
use utf8;
|
||||||
|
use open qw (:std :utf8);
|
||||||
|
|
||||||
|
use Log::Any qw ($log);
|
||||||
|
# Чтобы "уж точно" использовать hiredis-биндинги, загрузим этот модуль перед Mojo::Redis
|
||||||
|
use Protocol::Redis::XS;
|
||||||
|
use Mojo::Redis;
|
||||||
|
use Mojo::Redis::Connection;
|
||||||
|
|
||||||
|
use BotLib::Conf qw (LoadConf);
|
||||||
|
|
||||||
|
use version; our $VERSION = qw (1.0);
|
||||||
|
use Exporter qw (import);
|
||||||
|
our @EXPORT_OK = qw (redis_parse_message redis_events_listener);
|
||||||
|
|
||||||
|
my $c = LoadConf ();
|
||||||
|
|
||||||
|
sub redis_parse_message {
|
||||||
|
my $self = shift;
|
||||||
|
my $m = shift;
|
||||||
|
my $message;
|
||||||
|
|
||||||
|
# Мы "не можем" отправлять сообщения в телеграм, если мы к нему не подключены
|
||||||
|
# (конечно, можем, но Teapot-lib предполагает, что объектик с чатом - это его собственность, а городить свой что-то
|
||||||
|
# не очень хочется)
|
||||||
|
until (defined $main::TGM) {
|
||||||
|
sleep 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
if ($m->{misc}->{msg_format}) {
|
||||||
|
$message->{parse_mode} = 'Markdown';
|
||||||
|
}
|
||||||
|
|
||||||
|
$message->{chat_id} = $m->{chatid};
|
||||||
|
$message->{text} = $m->{message};
|
||||||
|
|
||||||
|
if (Teapot::Bot::Object::ChatPermissions::canTalk ($main::TGM, $m->{chatid})) {
|
||||||
|
# Результат этого действия нас не сильно волнует, т.к. если будет ошибка, то в лог попадёт трейс
|
||||||
|
$main::TGM->sendMessage ($message);
|
||||||
|
}
|
||||||
|
|
||||||
|
return;
|
||||||
|
};
|
||||||
|
|
||||||
|
sub redis_events_listener {
|
||||||
|
$log->notice ('[NOTICE]Run redis events listener');
|
||||||
|
# If we already connected there is no point to disconnect
|
||||||
|
if (defined $main::REDIS) {
|
||||||
|
my $connected = eval { Mojo::Redis::Connection->is_connected ($main::REDIS); };
|
||||||
|
|
||||||
|
if ($connected) {
|
||||||
|
$log->notice ('[NOTICE] Redis client already running and connected');
|
||||||
|
return;
|
||||||
|
} else {
|
||||||
|
$log->notice ('[NOTICE] Redis client registered, but looks like it is not connected, try to re-connect');
|
||||||
|
$main::REDIS = undef;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
my $r = Mojo::Redis->new (
|
||||||
|
sprintf 'redis://%s:%s/1', $c->{redis_server}, $c->{redis_port}
|
||||||
|
);
|
||||||
|
|
||||||
|
$log->notice ('[NOTICE] New redis client registered, registering callbacks');
|
||||||
|
# Don't forget to update global ref to our redis context
|
||||||
|
$main::REDIS = $r;
|
||||||
|
|
||||||
|
$r->on (
|
||||||
|
connection => sub {
|
||||||
|
my ($redis, $connection) = @_;
|
||||||
|
$main::RCONN = $connection;
|
||||||
|
|
||||||
|
# Log error
|
||||||
|
$connection->on (
|
||||||
|
error => sub {
|
||||||
|
my ($conn, $error) = @_;
|
||||||
|
$log->error ("[ERROR] Redis connection error: $error");
|
||||||
|
$main::RCONN = undef;
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
);
|
||||||
|
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
);
|
||||||
|
|
||||||
|
# Subscribe to channels
|
||||||
|
my $pubsub = $r->pubsub;
|
||||||
|
my $sub;
|
||||||
|
my $rpm = \&redis_parse_message;
|
||||||
|
$log->notice ('[NOTICE] Subscribing to redis channels');
|
||||||
|
|
||||||
|
foreach my $channel (@{$c->{redis_channels}}) {
|
||||||
|
$log->info ("[INFO] Subscribing to $channel");
|
||||||
|
|
||||||
|
$sub->{$channel} = $pubsub->json ($channel)->listen (
|
||||||
|
$channel => sub { $rpm->(@_); }
|
||||||
|
);
|
||||||
|
}
|
||||||
|
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
|
|
||||||
|
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
||||||
@@ -458,6 +458,9 @@ sub sendChatAction {
|
|||||||
elsif ($args->{action} eq 'upload_video_note') {
|
elsif ($args->{action} eq 'upload_video_note') {
|
||||||
$send_args->{action} = 'upload_video_note';
|
$send_args->{action} = 'upload_video_note';
|
||||||
}
|
}
|
||||||
|
elsif ($args->{action} eq 'choose_sticker') {
|
||||||
|
$send_args->{action} = 'choose_sticker';
|
||||||
|
}
|
||||||
else {
|
else {
|
||||||
$send_args->{action} = 'typing';
|
$send_args->{action} = 'typing';
|
||||||
}
|
}
|
||||||
|
|||||||
@@ -17,6 +17,9 @@ has 'first_name'; # Optional.
|
|||||||
has 'last_name'; # Optional.
|
has 'last_name'; # Optional.
|
||||||
has 'photo'; # Teapot::Bot::Object::ChatPhoto. Optional. Returned only in getChat.
|
has 'photo'; # Teapot::Bot::Object::ChatPhoto. Optional. Returned only in getChat.
|
||||||
has 'bio'; # Optional. Bio of the other party in a private chat. Returned only in getChat.
|
has 'bio'; # Optional. Bio of the other party in a private chat. Returned only in getChat.
|
||||||
|
has 'has_private_forwards'; # Optional. True, if privacy settings of the other party in the private chat allows to
|
||||||
|
# use tg://user?id=<user_id> links only in chats with the user.
|
||||||
|
# Returned only in getChat.
|
||||||
has 'description'; # Optional. Returned only in getChat.
|
has 'description'; # Optional. Returned only in getChat.
|
||||||
has 'invite_link'; # Optional. Returned only in getChat.
|
has 'invite_link'; # Optional. Returned only in getChat.
|
||||||
has 'pinned_message'; # Teapot::Bot::Object::Message
|
has 'pinned_message'; # Teapot::Bot::Object::Message
|
||||||
@@ -25,6 +28,8 @@ has 'permissions'; # Teapot::Bot::Object::ChatPermissions. Optional
|
|||||||
has 'slow_mode_delay'; # Optional. Returned only in getChat.
|
has 'slow_mode_delay'; # Optional. Returned only in getChat.
|
||||||
has 'message_auto_delete_time'; # Optional. The time after which all messages sent to the chat will be automatically
|
has 'message_auto_delete_time'; # Optional. The time after which all messages sent to the chat will be automatically
|
||||||
# deleted; in seconds. Returned only in getChat.
|
# deleted; in seconds. Returned only in getChat.
|
||||||
|
has 'has_protected_content'; # Optional. True, if messages from the chat can't be forwarded to other chats.
|
||||||
|
# Returned only in getChat.
|
||||||
has 'sticker_set_name'; # Optional. Returned only in getChat.
|
has 'sticker_set_name'; # Optional. Returned only in getChat.
|
||||||
has 'can_set_sticker_set'; # Optional. Returned only in getChat.
|
has 'can_set_sticker_set'; # Optional. Returned only in getChat.
|
||||||
has 'linked_chat_id'; # Optional. greater than 32 bits, smaller than 52 bits
|
has 'linked_chat_id'; # Optional. greater than 32 bits, smaller than 52 bits
|
||||||
@@ -32,8 +37,9 @@ has 'location'; # Optional. Returned only in getChat.
|
|||||||
|
|
||||||
sub fields {
|
sub fields {
|
||||||
return {
|
return {
|
||||||
'scalar' => [qw/id type title username first_name last_name bio description
|
'scalar' => [qw/id type title username first_name last_name bio
|
||||||
invite_link slow_mode_delay message_auto_delete_time
|
has_private_forwards description invite_link slow_mode_delay
|
||||||
|
message_auto_delete_time has_protected_content
|
||||||
sticker_set_name can_set_sticker_set linked_chat_id/],
|
sticker_set_name can_set_sticker_set linked_chat_id/],
|
||||||
'Teapot::Bot::Object::ChatPhoto' => [qw/photo/],
|
'Teapot::Bot::Object::ChatPhoto' => [qw/photo/],
|
||||||
'Teapot::Bot::Object::Message' => [qw/pinned_message/],
|
'Teapot::Bot::Object::Message' => [qw/pinned_message/],
|
||||||
|
|||||||
@@ -8,15 +8,19 @@ $Teapot::Bot::Object::ChatInviteLink::VERSION = '0.022';
|
|||||||
|
|
||||||
has 'invite_link';
|
has 'invite_link';
|
||||||
has 'creator';
|
has 'creator';
|
||||||
|
has 'creates_join_request';
|
||||||
has 'is_primary';
|
has 'is_primary';
|
||||||
has 'is_revoked';
|
has 'is_revoked';
|
||||||
|
has 'name';
|
||||||
has 'expire_date'; # Optional. Point in time (Unix timestamp) when the link will expire or has been expired
|
has 'expire_date'; # Optional. Point in time (Unix timestamp) when the link will expire or has been expired
|
||||||
has 'member_limit'; # Optional. Maximum number of users that can be members of the chat simultaneously after joining
|
has 'member_limit'; # Optional. Maximum number of users that can be members of the chat simultaneously after joining
|
||||||
# the chat via this invite link; 1-99999
|
# the chat via this invite link; 1-99999
|
||||||
|
has 'pending_join_request_count';
|
||||||
|
|
||||||
sub fields {
|
sub fields {
|
||||||
return {
|
return {
|
||||||
'scalar' => [qw/invite_link is_primary is_revoked expire_date expire_date member_limit/],
|
'scalar' => [qw/invite_link creates_join_request is_primary is_revoked name expire_date
|
||||||
|
member_limit pending_join_request_count/],
|
||||||
'Teapot::Bot::Object::User' => [qw/creator/],
|
'Teapot::Bot::Object::User' => [qw/creator/],
|
||||||
};
|
};
|
||||||
}
|
}
|
||||||
|
|||||||
@@ -52,9 +52,11 @@ has 'forward_from_message_id';
|
|||||||
has 'forward_signature';
|
has 'forward_signature';
|
||||||
has 'forward_sender_name';
|
has 'forward_sender_name';
|
||||||
has 'forward_date';
|
has 'forward_date';
|
||||||
|
has 'is_automatic_forward';
|
||||||
has 'reply_to_message'; # Message
|
has 'reply_to_message'; # Message
|
||||||
has 'via_bot'; # User
|
has 'via_bot'; # User
|
||||||
has 'edit_date';
|
has 'edit_date';
|
||||||
|
has 'has_protected_content';
|
||||||
has 'media_group_id';
|
has 'media_group_id';
|
||||||
has 'author_signature';
|
has 'author_signature';
|
||||||
has 'text';
|
has 'text';
|
||||||
@@ -102,8 +104,8 @@ sub fields {
|
|||||||
return {
|
return {
|
||||||
'scalar' => [qw/message_id date forward_from_message_id
|
'scalar' => [qw/message_id date forward_from_message_id
|
||||||
forward_signature forward_sender_name
|
forward_signature forward_sender_name
|
||||||
forward_date edit_date media_group_id
|
forward_date is_automatic_forward edit_date has_protected_content
|
||||||
author_signature text caption
|
media_group_id author_signature text caption
|
||||||
new_chat_title delete_chat_photo
|
new_chat_title delete_chat_photo
|
||||||
group_chat_created supergroup_chat_created
|
group_chat_created supergroup_chat_created
|
||||||
channel_chat_created migrate_to_chat_id
|
channel_chat_created migrate_to_chat_id
|
||||||
|
|||||||
@@ -5,28 +5,26 @@ use 5.018;
|
|||||||
use strict;
|
use strict;
|
||||||
use warnings;
|
use warnings;
|
||||||
use utf8;
|
use utf8;
|
||||||
use Data::Dumper;
|
|
||||||
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 carp);
|
use Carp qw (cluck carp);
|
||||||
|
use Clone qw (clone);
|
||||||
use File::Path qw (make_path);
|
use File::Path qw (make_path);
|
||||||
use Hailo;
|
use Log::Any qw ($log);
|
||||||
use Log::Any qw($log);
|
|
||||||
use Math::Random::Secure qw (irand);
|
use Math::Random::Secure qw (irand);
|
||||||
use Mojo::Base 'Teapot::Bot::Brain';
|
use Mojo::Base 'Teapot::Bot::Brain';
|
||||||
use BotLib::Admin qw (FortuneToggleList);
|
|
||||||
use BotLib qw (RandomCommonPhrase Command Highlight BotSleep IsCensored);
|
use BotLib::Admin qw (FortuneToggleList ChanMsgEnabled);
|
||||||
|
use BotLib qw (Command Highlight BotSleep IsCensored);
|
||||||
use BotLib::Conf qw (LoadConf);
|
use BotLib::Conf qw (LoadConf);
|
||||||
use BotLib::Fortune qw (Fortune);
|
|
||||||
use BotLib::Karma qw (KarmaSet);
|
|
||||||
use BotLib::Util qw (trim fmatch);
|
use BotLib::Util qw (trim fmatch);
|
||||||
|
use RedisLib qw (redis_parse_message redis_events_listener);
|
||||||
|
|
||||||
use version; our $VERSION = qw (1.0);
|
use version; our $VERSION = qw (1.0);
|
||||||
use Exporter qw (import);
|
use Exporter qw (import);
|
||||||
our @EXPORT_OK = qw (RunTelegramBot);
|
our @EXPORT_OK = qw (RunTelegramBot);
|
||||||
|
|
||||||
my $c = LoadConf ();
|
my $c = LoadConf ();
|
||||||
my $hailo;
|
|
||||||
my $myid;
|
my $myid;
|
||||||
my $myusername;
|
my $myusername;
|
||||||
my $myfirst_name;
|
my $myfirst_name;
|
||||||
@@ -35,25 +33,42 @@ my $myfullname;
|
|||||||
|
|
||||||
has token => $c->{telegrambot}->{token};
|
has token => $c->{telegrambot}->{token};
|
||||||
|
|
||||||
|
my $redismsg->{from} = 'telegram';
|
||||||
|
$redismsg->{plugin} = 'telegram';
|
||||||
|
$redismsg->{misc}->{answer} = 1;
|
||||||
|
$redismsg->{misc}->{csign} = $c->{telegrambot}->{csign};
|
||||||
|
$redismsg->{misc}->{msg_format} = 0;
|
||||||
|
$redismsg->{misc}->{fwd_cnt} = 1;
|
||||||
|
|
||||||
sub __cron {
|
sub __cron {
|
||||||
my $self = shift;
|
my $self = shift;
|
||||||
|
|
||||||
# fortune mod
|
my $rmsg = clone ($redismsg);
|
||||||
my @intro = (
|
$rmsg->{mode} = 'public';
|
||||||
'Сегодняшний день пройдёт под эгидой фразы:',
|
# Press 'F' to pay respect
|
||||||
'Крылатая фраза на сегодня:',
|
$rmsg->{message} = sprintf '%sf', $c->{telegrambot}->{csign};
|
||||||
'Сегодняшняя фраза дня:',
|
$rmsg->{misc}->{good_morning} = 1;
|
||||||
);
|
$rmsg->{misc}->{msg_format} = 1;
|
||||||
|
|
||||||
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime (time);
|
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime (time);
|
||||||
|
|
||||||
|
{
|
||||||
|
do {
|
||||||
|
my $ready = eval { $main::RCONN->is_connected; };
|
||||||
|
last if ($ready);
|
||||||
|
} while (sleep 1);
|
||||||
|
}
|
||||||
|
|
||||||
|
my $pubsub = $main::REDIS->pubsub;
|
||||||
|
|
||||||
if ($hour == 8 && ($min >= 0 && $min <= 14)) {
|
if ($hour == 8 && ($min >= 0 && $min <= 14)) {
|
||||||
foreach my $enabledfortunechat (FortuneToggleList ()) {
|
foreach my $enabledfortunechat (FortuneToggleList ()) {
|
||||||
my $send_args;
|
$rmsg->{userid} = $enabledfortunechat;
|
||||||
$send_args->{text} = sprintf "%s\n```\n%s\n```\n", $intro[irand ($#intro + 1)], trim (Fortune ());
|
$rmsg->{chatid} = $enabledfortunechat;
|
||||||
$send_args->{chat_id} = $enabledfortunechat;
|
|
||||||
$send_args->{parse_mode} = 'Markdown';
|
$pubsub->json ($c->{'redis_router_channel'})->notify (
|
||||||
$self->sendMessage ($send_args);
|
$c->{'redis_router_channel'} => $rmsg
|
||||||
|
);
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -115,21 +130,33 @@ sub __on_msg {
|
|||||||
# Newcommer event, greet our new member and suggest to introduce themself.
|
# Newcommer event, greet our new member and suggest to introduce themself.
|
||||||
if ($msg->can ('new_chat_members') && defined ($msg->new_chat_members)) {
|
if ($msg->can ('new_chat_members') && defined ($msg->new_chat_members)) {
|
||||||
my @members;
|
my @members;
|
||||||
|
my @introduce = (
|
||||||
|
'Дратути',
|
||||||
|
'Дарована',
|
||||||
|
'Доброе утро, день или вечер',
|
||||||
|
'Добро пожаловать в наше скромное коммунити',
|
||||||
|
'Наше вам с кисточкой тут, на канальчике',
|
||||||
|
);
|
||||||
|
|
||||||
foreach my $member (@{$msg->new_chat_members}) {
|
foreach my $member (@{$msg->new_chat_members}) {
|
||||||
my $member_str = '';
|
my $member_str = '';
|
||||||
|
|
||||||
if ($member->can ('first_name') && defined ($member->first_name)) {
|
# avoid naming people by spacing symbols, or empty names
|
||||||
|
if ($member->can ('first_name') && defined ($member->first_name) && $member->first_name !~ /^\s+$/ui) {
|
||||||
$member_str .= $member->first_name;
|
$member_str .= $member->first_name;
|
||||||
|
|
||||||
if ($member->can ('last_name') && defined ($member->last_name)) {
|
if ($member->can ('last_name') && defined ($member->last_name) && $member->last_name !~ /^\s+$/ui) {
|
||||||
$member_str .= ' ' . $member->last_name;
|
$member_str .= ' ' . $member->last_name;
|
||||||
}
|
}
|
||||||
} else {
|
} else {
|
||||||
if ($member->can ('last_name') && defined ($member->last_name)) {
|
if ($member->can ('last_name') && defined ($member->last_name) && $member->last_name !~ /^\s+$/ui) {
|
||||||
$member_str .= ' ' . $member->last_name;
|
$member_str .= ' ' . $member->last_name;
|
||||||
} else {
|
# username must be uniq and should contain only english letters and numbers, so...
|
||||||
|
} elsif ($member->can ('username') && defined ($member->username)) {
|
||||||
$member_str .= '@' . $member->username;
|
$member_str .= '@' . $member->username;
|
||||||
|
# fallback to id if uose trying to be smartass and use only spacing chars in it's firstname and/or lastname
|
||||||
|
} else {
|
||||||
|
$member_str .= $member->id;
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -138,9 +165,9 @@ sub __on_msg {
|
|||||||
|
|
||||||
if ($#members > 1) {
|
if ($#members > 1) {
|
||||||
my $lastone = pop @members;
|
my $lastone = pop @members;
|
||||||
$phrase = sprintf 'Дратути, %s и %s. Представьтес, пожалуйста, и расскажите, что вас сюда привело.', join (', ', @members), $lastone;
|
$phrase = sprintf '%s, %s и %s. Представьтес, пожалуйста, и расскажите, что вас сюда привело.', $introduce[irand ($#introduce + 1)], join (', ', @members), $lastone;
|
||||||
} else {
|
} else {
|
||||||
$phrase = sprintf 'Дратути, %s. Представьтес, пожалуйста, и расскажите, что вас сюда привело.', $members[0];
|
$phrase = sprintf '%s, %s. Представьтес, пожалуйста, и расскажите, что вас сюда привело.', $introduce[irand ($#introduce + 1)], $members[0];
|
||||||
}
|
}
|
||||||
|
|
||||||
BotSleep $msg;
|
BotSleep $msg;
|
||||||
@@ -148,23 +175,6 @@ sub __on_msg {
|
|||||||
return;
|
return;
|
||||||
}
|
}
|
||||||
|
|
||||||
# lazy init chat-bot brains
|
|
||||||
unless (defined $hailo->{$chatid}) {
|
|
||||||
my $brainname = sprintf '%s/%s.brain.sqlite', $c->{telegrambot}->{braindir}, $chatid;
|
|
||||||
|
|
||||||
$hailo->{$chatid} = Hailo->new (
|
|
||||||
# we'll got file like this: data/telegrambot-brains/-1001332512695.brain.sqlite
|
|
||||||
brain => $brainname,
|
|
||||||
order => 3
|
|
||||||
);
|
|
||||||
|
|
||||||
if ($chatid < 0) {
|
|
||||||
$log->info ("[INFO] Initialized brain for public chat $chatname ($chatid): $brainname");
|
|
||||||
} else {
|
|
||||||
$log->info ("[INFO] Initialized brain for private chat $chatname ($chatid): $brainname");
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
# is this a 1-on-1 ?
|
# is this a 1-on-1 ?
|
||||||
if ($msg->chat->type eq 'private') {
|
if ($msg->chat->type eq 'private') {
|
||||||
unless (defined $msg->text) {
|
unless (defined $msg->text) {
|
||||||
@@ -173,44 +183,27 @@ sub __on_msg {
|
|||||||
|
|
||||||
my $text = $msg->text;
|
my $text = $msg->text;
|
||||||
$log->debug (sprintf ('[DEBUG] Private chat %s say to bot: %s', $vis_a_vi, $text));
|
$log->debug (sprintf ('[DEBUG] Private chat %s say to bot: %s', $vis_a_vi, $text));
|
||||||
|
# Ответ по-умолчанию
|
||||||
my $reply = 'Давайте ещё пообщаемся, а то я ещё не научилась от вас плохому.';
|
my $reply = 'Давайте ещё пообщаемся, а то я ещё не научилась от вас плохому.';
|
||||||
|
|
||||||
if (substr ($text, 0, 1) eq $csign) {
|
if (substr ($text, 0, 1) eq $csign) {
|
||||||
|
# Если текст похож на команду, усылаем его в BotLib.pm
|
||||||
$reply = Command ($self, $msg, $text, $userid);
|
$reply = Command ($self, $msg, $text, $userid);
|
||||||
} else {
|
} else {
|
||||||
my $just_message_in_chat = 0;
|
my $rmsg = clone ($redismsg);
|
||||||
|
$rmsg->{mode} = 'private';
|
||||||
|
$rmsg->{message} = $text;
|
||||||
|
$rmsg->{userid} = $userid;
|
||||||
|
$rmsg->{chatid} = $userid;
|
||||||
|
my $pubsub = $main::REDIS->pubsub;
|
||||||
|
$pubsub->json ($c->{'redis_router_channel'})->notify (
|
||||||
|
$c->{'redis_router_channel'} => $rmsg
|
||||||
|
);
|
||||||
|
|
||||||
# is it karma adjustment?
|
return;
|
||||||
if (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 = 1;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
if ($just_message_in_chat) {
|
|
||||||
my $str = $hailo->{$msg->chat->id}->learn_reply ($text);
|
|
||||||
|
|
||||||
if (defined ($str) && $str ne '') {
|
|
||||||
$reply = $str;
|
|
||||||
$phrase = trim $text;
|
|
||||||
|
|
||||||
while ($phrase =~ /[\.|\,|\?|\!]$/) {
|
|
||||||
chop $phrase;
|
|
||||||
}
|
|
||||||
|
|
||||||
$phrase = lc $phrase;
|
|
||||||
|
|
||||||
if (fmatch (lc ($reply), $phrase)) {
|
|
||||||
$reply = RandomCommonPhrase ();
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
}
|
||||||
|
|
||||||
|
# Команды раздела Admin ответ таки возвращают
|
||||||
if (defined $reply) {
|
if (defined $reply) {
|
||||||
$msg->typing ();
|
$msg->typing ();
|
||||||
sleep 1;
|
sleep 1;
|
||||||
@@ -221,46 +214,89 @@ sub __on_msg {
|
|||||||
} elsif (($msg->chat->type eq 'supergroup') or ($msg->chat->type eq 'group')) {
|
} elsif (($msg->chat->type eq 'supergroup') or ($msg->chat->type eq 'group')) {
|
||||||
my $reply;
|
my $reply;
|
||||||
|
|
||||||
|
# Некоторые виды сообщений можно "зацензурить" ботом, например, голосовые сообщения, картинки итд.
|
||||||
|
# И вот тут как раз такая проверка и происходит
|
||||||
if (IsCensored $msg) {
|
if (IsCensored $msg) {
|
||||||
$log->info (sprintf '[INFO] In public chat %s (%s) message from %s was censored', $chatname, $chatid, $vis_a_vi);
|
$log->info (sprintf '[INFO] In public chat %s (%s) message from %s was censored', $chatname, $chatid, $vis_a_vi);
|
||||||
$self->deleteMessage ({chat_id => $chatid, message_id => $msg->{message_id}});
|
$self->deleteMessage ({chat_id => $chatid, message_id => $msg->{message_id}});
|
||||||
}
|
}
|
||||||
|
|
||||||
# detect and log messages without text, noop here
|
# Некоторые рекламные товарищи пытаются срать своими каналами в чятик это тоже можно зацензурить ботом и это
|
||||||
|
# пидорство он будет удалять asap
|
||||||
|
# 136817688 - это специальный id пользователя, который принимает облик канала, на него можно нажать и попасть
|
||||||
|
# на рекламируемый канал
|
||||||
|
if ($msg->from->id == 136817688) {
|
||||||
|
my $sender_chat = eval { $msg->sender_chat->id };
|
||||||
|
|
||||||
|
if (defined $sender_chat) {
|
||||||
|
unless (ChanMsgEnabled ($chatid)) {
|
||||||
|
$self->deleteMessage ({chat_id => $chatid, message_id => $msg->{message_id}});
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
# Если обнаруживаем здесь сообщение без текста, просто ничего не делаем и выходим из процедуры обработки
|
||||||
|
# сообщения
|
||||||
unless (defined $msg->text) {
|
unless (defined $msg->text) {
|
||||||
$log->debug (sprintf ('[DEBUG] No text in message from %s', $vis_a_vi));
|
$log->debug (sprintf ('[DEBUG] No text in message from %s', $vis_a_vi));
|
||||||
return;
|
return;
|
||||||
}
|
}
|
||||||
|
|
||||||
# we have text here! so potentially we can chit-chat
|
# Текст есть, потенциально можно будет поболтать!
|
||||||
my $text = $msg->text;
|
my $text = $msg->text;
|
||||||
$log->debug (sprintf ('[DEBUG] In public chat %s (%s) %s say: %s', $chatname, $chatid, $vis_a_vi, $text));
|
$log->debug (sprintf ('[DEBUG] In public chat %s (%s) %s say: %s', $chatname, $chatid, $vis_a_vi, $text));
|
||||||
|
|
||||||
# are they quote something, maybe, us?
|
# Если это ответ на сообщение, то вдруг, на наше?
|
||||||
if (defined ($msg->reply_to_message) &&
|
if (defined ($msg->reply_to_message) &&
|
||||||
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)) {
|
||||||
$log->debug (sprintf ('[DEBUG] In public chat %s (%s) %s quote us!', $chatname, $chatid, $vis_a_vi));
|
$log->debug (sprintf ('[DEBUG] In public chat %s (%s) %s quote us!', $chatname, $chatid, $vis_a_vi));
|
||||||
|
|
||||||
# do not answer back if someone quote our new member greet
|
# Если новый участник чата ответил на наше приветствие, проигнорируем его ответ (и попробуем сойти за
|
||||||
if ((substr ($msg->reply_to_message->text, 0, 9) eq 'Дратути, ') &&
|
# человека :)
|
||||||
(substr ($msg->reply_to_message->text, -61) eq 'Представьтес, пожалуйста, и расскажите, что вас сюда привело.')) {
|
if (substr ($msg->reply_to_message->text, -61) eq 'Представьтес, пожалуйста, и расскажите, что вас сюда привело.') {
|
||||||
return;
|
my $match = 0;
|
||||||
} else {
|
my @hello = (
|
||||||
# remove our name from users reply, just in case
|
'Дратути, ',
|
||||||
my $pat1 = quotemeta ('@' . $myusername);
|
'Дарована, ',
|
||||||
my $pat2 = quotemeta $myfullname;
|
'Доброе утро, день или вечер, ',
|
||||||
$phrase = $text;
|
'Добро пожаловать в наше скромное коммунити, ',
|
||||||
$phrase =~ s/$pat1//g;
|
'Наше вам с кисточкой тут, на канальчике, '
|
||||||
$phrase =~ s/$pat2//g;
|
);
|
||||||
|
|
||||||
# figure out reply :)
|
foreach my $hi (@hello) {
|
||||||
$reply = $hailo->{$msg->chat->id}->learn_reply ($phrase) if (length ($phrase) > 3);
|
if (substr ($msg->reply_to_message->text, 0, length $hi) eq $hi) {
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
}
|
||||||
}
|
}
|
||||||
# simple commands
|
|
||||||
|
# На всякий случай, попробуем убрать наше имя из фразы.
|
||||||
|
my $pat1 = quotemeta ('@' . $myusername);
|
||||||
|
my $pat2 = quotemeta $myfullname;
|
||||||
|
$phrase = $text;
|
||||||
|
$phrase =~ s/$pat1//g;
|
||||||
|
$phrase =~ s/$pat2//g;
|
||||||
|
|
||||||
|
# Попробуем сгенерить ответ
|
||||||
|
my $rmsg = clone ($redismsg);
|
||||||
|
$rmsg->{mode} = 'public';
|
||||||
|
$rmsg->{message} = $phrase;
|
||||||
|
$rmsg->{userid} = $userid;
|
||||||
|
$rmsg->{chatid} = $chatid;
|
||||||
|
|
||||||
|
my $pubsub = $main::REDIS->pubsub;
|
||||||
|
|
||||||
|
$pubsub->json ($c->{'redis_router_channel'})->notify (
|
||||||
|
$c->{'redis_router_channel'} => $rmsg
|
||||||
|
);
|
||||||
|
|
||||||
|
return;
|
||||||
|
# Если текст похож на команду, усылаем его в BotLib.pm
|
||||||
} elsif (substr ($text, 0, 1) eq $csign) {
|
} elsif (substr ($text, 0, 1) eq $csign) {
|
||||||
$reply = Command ($self, $msg, $text, $chatid);
|
$reply = Command ($self, $msg, $text, $chatid);
|
||||||
|
# Похоже кто-то написал наше имя в чятике, но ничего не захотел дописывать к нему
|
||||||
} elsif (
|
} elsif (
|
||||||
($text eq $myusername) or
|
($text eq $myusername) or
|
||||||
($text eq '@' . $myusername) or
|
($text eq '@' . $myusername) or
|
||||||
@@ -269,55 +305,42 @@ sub __on_msg {
|
|||||||
($text eq $myfullname . ' ')
|
($text eq $myfullname . ' ')
|
||||||
) {
|
) {
|
||||||
$reply = 'Чего?';
|
$reply = 'Чего?';
|
||||||
|
# А тут кто-то к нам обратился с чем-то по имени
|
||||||
} else {
|
} else {
|
||||||
my $qname = quotemeta ('@' . $myusername);
|
my $qname = quotemeta ('@' . $myusername);
|
||||||
my $qtname = quotemeta $myfullname;
|
my $qtname = quotemeta $myfullname;
|
||||||
|
|
||||||
# phrase directed to bot
|
my $rmsg = clone ($redismsg);
|
||||||
|
$rmsg->{mode} = 'public';
|
||||||
|
$rmsg->{userid} = $userid;
|
||||||
|
$rmsg->{chatid} = $chatid;
|
||||||
|
|
||||||
|
# Сообщение обращено к боту
|
||||||
if ((lc ($text) =~ /^${qname}[\,|\:]? (.+)/) or (lc ($text) =~ /^${qtname}[\,|\:]? (.+)/)){
|
if ((lc ($text) =~ /^${qname}[\,|\:]? (.+)/) or (lc ($text) =~ /^${qtname}[\,|\:]? (.+)/)){
|
||||||
$phrase = $1;
|
$phrase = $1;
|
||||||
|
$rmsg->{message} = $phrase;
|
||||||
if ($phrase =~ /^кто +все +эти +люди *\?$/i) {
|
# Бота упомянули по имени
|
||||||
$reply = 'Кто здесь?';
|
|
||||||
} else {
|
|
||||||
$reply = $hailo->{$msg->chat->id}->learn_reply ($phrase);
|
|
||||||
}
|
|
||||||
# bot mention by name
|
|
||||||
} elsif ((lc ($text) =~ /.+ ${qname}[\,|\!|\?|\.| ]/) or (lc ($text) =~ / $qname$/)) {
|
} elsif ((lc ($text) =~ /.+ ${qname}[\,|\!|\?|\.| ]/) or (lc ($text) =~ / $qname$/)) {
|
||||||
$phrase = $text;
|
$phrase = $text;
|
||||||
|
$rmsg->{message} = $phrase;
|
||||||
if ($phrase =~ /^кто +все +эти +люди *\?$/i) {
|
# Бота упомянули по телеграммному имени
|
||||||
$reply = 'Кто здесь?';
|
|
||||||
} else {
|
|
||||||
$reply = $hailo->{$msg->chat->id}->learn_reply ($phrase);
|
|
||||||
}
|
|
||||||
# bot mention by telegram name
|
|
||||||
} elsif ((lc ($text) =~ /.+ ${qtname}[\,|\!|\?|\.| ]/) or (lc ($text) =~ / $qtname$/)) {
|
} elsif ((lc ($text) =~ /.+ ${qtname}[\,|\!|\?|\.| ]/) or (lc ($text) =~ / $qtname$/)) {
|
||||||
$phrase = $text;
|
$phrase = $text;
|
||||||
|
|
||||||
if ($phrase =~ /^кто +все +эти +люди *\?$/i) {
|
$rmsg->{message} = $phrase;
|
||||||
$reply = 'Кто здесь?';
|
|
||||||
} else {
|
|
||||||
$reply = $hailo->{$msg->chat->id}->learn_reply ($phrase);
|
|
||||||
}
|
|
||||||
# karma adjustment
|
|
||||||
} 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
|
|
||||||
$hailo->{$msg->chat->id}->learn ($text);
|
|
||||||
}
|
|
||||||
# just message in chat
|
|
||||||
} else {
|
} else {
|
||||||
if ($text =~ /^кто +все +эти +люди *\?$/i) {
|
$rmsg->{message} = $text;
|
||||||
$reply = 'Кто здесь?';
|
$rmsg->{misc}->{answer} = 0;
|
||||||
} else {
|
|
||||||
$hailo->{$msg->chat->id}->learn ($text);
|
|
||||||
}
|
|
||||||
}
|
}
|
||||||
|
|
||||||
|
my $pubsub = $main::REDIS->pubsub;
|
||||||
|
|
||||||
|
$pubsub->json ($c->{'redis_router_channel'})->notify (
|
||||||
|
$c->{'redis_router_channel'} => $rmsg
|
||||||
|
);
|
||||||
|
|
||||||
|
return;
|
||||||
}
|
}
|
||||||
|
|
||||||
if (defined ($reply) && $reply ne '') {
|
if (defined ($reply) && $reply ne '') {
|
||||||
@@ -350,20 +373,34 @@ sub __on_msg {
|
|||||||
return;
|
return;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
sub RandomCommonPhrase {
|
||||||
|
my @myphrase = (
|
||||||
|
'Так, блядь...',
|
||||||
|
'*Закатывает рукава* И ради этого ты меня позвал?',
|
||||||
|
'Ну чего ты начинаешь, нормально же общались',
|
||||||
|
'Повтори свой вопрос, не поняла',
|
||||||
|
'Выйди и зайди нормально',
|
||||||
|
'Я подумаю',
|
||||||
|
'Даже не знаю, что на это ответить',
|
||||||
|
'Ты упал такие вопросы девочке задавать?',
|
||||||
|
'Можно и так, но не уверена',
|
||||||
|
'А как ты думаешь?',
|
||||||
|
'А ви, таки, почему интересуетесь?',
|
||||||
|
);
|
||||||
|
|
||||||
|
return $myphrase[irand ($#myphrase + 1)];
|
||||||
|
}
|
||||||
|
|
||||||
# setup our bot
|
# setup our bot
|
||||||
sub init {
|
sub init {
|
||||||
my $self = shift;
|
my $self = shift;
|
||||||
my $braindir = $c->{telegrambot}->{braindir};
|
|
||||||
|
|
||||||
unless (-d $braindir) {
|
# Don't forget to update global ref to our telegram context
|
||||||
make_path ($braindir, 0, 0755) or do { ## no critic (ValuesAndExpressions::ProhibitLeadingZeros)
|
$main::TGM = $self;
|
||||||
$log->fatal ("[FATAL] Unable to create $braindir: $OS_ERROR");
|
|
||||||
exit 1;
|
|
||||||
};
|
|
||||||
}
|
|
||||||
|
|
||||||
$self->add_listener (\&__on_msg);
|
$self->add_listener (\&__on_msg);
|
||||||
$self->add_repeating_task (900, \&__cron);
|
$self->add_repeating_task (900, \&__cron);
|
||||||
|
redis_events_listener ();
|
||||||
return;
|
return;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|||||||
Reference in New Issue
Block a user