Compare commits
1 Commits
master
...
update_tea
| Author | SHA1 | Date | |
|---|---|---|---|
|
|
0aae36d534 |
7
.gitignore
vendored
7
.gitignore
vendored
@@ -1,16 +1,13 @@
|
||||
_Deparsed_XSubs.pm
|
||||
.idea/**
|
||||
.vscode/**
|
||||
.vstags
|
||||
aleesa-telegram-bot.pid
|
||||
data/cache/**
|
||||
data/config.json
|
||||
data/fortune/**
|
||||
data/friday/**
|
||||
data/gamestat/**
|
||||
data/image/**
|
||||
data/karma/**
|
||||
data/lat/**
|
||||
data/proverb/**
|
||||
data/telegrambot-brains/**
|
||||
data/lat/**
|
||||
data/image/**
|
||||
vendor_perl/**
|
||||
|
||||
@@ -52,7 +52,7 @@ verbose = 8
|
||||
|
||||
[-ValuesAndExpressions::ProhibitEmptyQuotes]
|
||||
# cause we consider following correct and useful: my $var = '';
|
||||
# the recommended use of q{} looks too complex: my $var = q{};
|
||||
# the recomended use of q{} looks too complex: my $var = q{};
|
||||
|
||||
[-ValuesAndExpressions::ProhibitNoisyQuotes]
|
||||
# Other people, other opinions: "," is better readable than qw(,)
|
||||
@@ -92,3 +92,4 @@ lib_sections = NAME | VERSION | DESCRIPTION | AUTHOR | LICENSE AND COPYRIGHT
|
||||
|
||||
[-ControlStructures::ProhibitDeepNests]
|
||||
# Have to use it, so fuckoff
|
||||
|
||||
|
||||
@@ -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 appropriate module.
|
||||
|
||||
How can i guess that i miss to perform this procedure?
|
||||
Most notable symptom 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 successfully build and
|
||||
install 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.
|
||||
74
README.md
74
README.md
@@ -1,32 +1,29 @@
|
||||
# Aleesa-Telegram-bot - Telegram chatty bot
|
||||
|
||||
## Disclaimer
|
||||
|
||||
This version - 3 (something) - considered stable. It means that further development of new features kind of frosen.
|
||||
Most effort will be targeted to future 4-th version development. If you have some ideas or fixes to this version
|
||||
feel free PR them, they will be merged as soon as being reviewed.
|
||||
|
||||
## About
|
||||
|
||||
It is based on Perl modules [Telegram::Bot][1] and [Hailo][2] as conversation generator.
|
||||
It is based on Perl modules [Telegram::Bot][1] and [Hailo][2] as conversation
|
||||
generator.
|
||||
|
||||
I have to fork [Telegram::Bot][1] and update it according to features appeared in [Telegram Bot API v5][3]. Also,
|
||||
I decide to rename it to avoid collision in the future, now it is Teapot::Bot and is bundled with bot. When lib becomes
|
||||
I have to fork [Telegram::Bot][1] and update it according to features appeared
|
||||
in [Telegram Bot API v5][3]. Also, I decide to rename it to avoid collision in
|
||||
the future, now it is Teapot::Bot and is bundled with bot. When lib becomes
|
||||
mature enough, maybe I release it separately.
|
||||
|
||||
Bot config located in **data/config.json**, sample config provided as **data/sample_config.json**.
|
||||
Bot config located in **data/config.json**, sample config provided as
|
||||
**data/sample_config.json**.
|
||||
|
||||
Bot can be run via **bin/aleesa-telegram-bot** and acts as daemon (double fork() and detaches stdio).
|
||||
Bot can be run via **bin/aleesa-telegram-bot** and acts as daemon (double fork()
|
||||
and detaches stdio).
|
||||
|
||||
## Installation
|
||||
|
||||
Application have been tested on alpine linux x86_64 3.12, with perl-5.32.1 builtin.
|
||||
In order to run this application, you need to "bootstrap" it - download and build
|
||||
all required dependencies and libraries.
|
||||
|
||||
In order to run this application, you need to "bootstrap" it - download and build all required dependencies and
|
||||
libraries.
|
||||
|
||||
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, zlib-devel, openssl-devel, libdb4-devel (Berkeley DB devel), make.
|
||||
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,
|
||||
zlib-devel, openssl-devel, libdb4-devel (Berkeley DB devel), make.
|
||||
|
||||
After installing required dependencies it is possible to run:
|
||||
|
||||
@@ -40,49 +37,56 @@ and all libraries should be downloaded, built, tested and installed.
|
||||
|
||||
## Running
|
||||
|
||||
This bot does not [ultilize][4] webhooks, so in order to run it only well internet connection is required, no
|
||||
public-available ip address is needed.
|
||||
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.
|
||||
|
||||
### Additional Settings to be performed in order to run bot as it designed
|
||||
|
||||
There are some "plugins" that requires registration on third party services and API keys and secrets in order to work.
|
||||
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".
|
||||
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.
|
||||
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
|
||||
appropriate handler in code, you should sign in imgur and get access token.
|
||||
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
|
||||
authorize your app according to [this][10] manual. Or [this][11] one.
|
||||
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.
|
||||
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 "verifier" parameter later).
|
||||
[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.
|
||||
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 instructions - copy and paste given link to browser login to
|
||||
flickr account and you'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.
|
||||
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
|
||||
[2]: https://metacpan.org/pod/Hailo
|
||||
|
||||
93
README_RU.md
93
README_RU.md
@@ -1,38 +1,32 @@
|
||||
# Aleesa-Telegram-bot - Болтливый бот для Telegram
|
||||
|
||||
## Дисклеймер
|
||||
|
||||
Эта версия бота за номером 3 (с мелочью) стабильная. Сие означает, что дальнейшего развития функций в этой версии не
|
||||
предполагается. Конечно, возможны исключения, но основной план - переключиться на 4-ю версию, куда планируется
|
||||
перенести большинство функций 3-й версии.
|
||||
|
||||
Если у кого-то возникнут идеи относительно этой версии бота - ставьте PR, я только рад. Т.к. несмотря на то, что
|
||||
развитие этой версии "слегка" заморожено, поддерживать её планируется как минимум до выхода в свет 4-й версии бота.
|
||||
|
||||
## Что это такое
|
||||
|
||||
Это бот, основанный на перловых модулях [Telegram::Bot][1] для работы в мессенджере Telegram и [Hailo][2] для генерации
|
||||
"умной" беседы.
|
||||
Это бот основанный на перловых модулях [Telegram::Bot][1] для работы в
|
||||
мессенджере Telegram и [Hailo][2] для генерации "умной" беседы.
|
||||
|
||||
Для корректной работы, пришлось форкнуть [Telegram::Bot][1], чтобы обновить интерфейс API до [Telegram Bot API v5][3].
|
||||
Для избежания неоднозначностей, модуль пришлось переименовать и теперь он идёт в составе бота. Возможно, когда модуль
|
||||
отлежится и будет похож на стабильный, он стнет самостоятельным и поселится на metacpan.org
|
||||
Для корректной работы пришлось форкнуть [Telegram::Bot][1] чтобы обновить
|
||||
интерфейс API до [Telegram Bot API v5][3]. Для избежания неоднозначностей модуль
|
||||
пришлось переименовать и теперь он идёт в составе бота. Возможно, когда модуль
|
||||
отлежится и будет похож на стабильный, он стнет самостоятельным и поселится на
|
||||
metacpan.org
|
||||
|
||||
Конфиг бота должен лежать в **data/config.json**. Пример конфига расположен в **data/sample_config.json**.
|
||||
Конфиг бота должен лежать в **data/config.json**, пример конфига расположен в
|
||||
**data/sample_config.json**.
|
||||
|
||||
Бота можно запустить через **bin/aleesa-telegram-bot** и он взлетит, как юниксовый демон (сделает двойной fork() и
|
||||
отцепится от stdio).
|
||||
Бота можно запустить через **bin/aleesa-telegram-bot** и он взлетит как юниксовый
|
||||
демон (сделает двойной fork() и отцепится от stdio).
|
||||
|
||||
## Установка
|
||||
|
||||
Приложение тестировалось на alpine linux x86_64 3.12, со встроенным perl-5.32.1.
|
||||
Чтобы запустить приложение, его надо "забурстрапить" - загрузить и собрать все
|
||||
необходимые зависимости.
|
||||
|
||||
Чтобы запустить приложение, его надо "забурстрапить" - загрузить и собрать все необходимые зависимости.
|
||||
Понадобится perl-5.18 а желательно новее, "Development Tools" или подобная
|
||||
группа пакетов , perl, perl-devel, perl-local-lib, perl-app-cpanm, sqlite-devel,
|
||||
zlib-devel, openssl-devel, libdb4-devel (Berkeley DB devel), make.
|
||||
|
||||
Понадобится perl-5.18, а желательно новее, "Development Tools" или подобная группа пакетов , perl, perl-devel,
|
||||
perl-local-lib, perl-app-cpanm, sqlite-devel, zlib-devel, openssl-devel, libdb4-devel (Berkeley DB devel), make.
|
||||
|
||||
После установки этих пакетов, можно будет запустить:
|
||||
После установки этих пакетов можно будет запустить:
|
||||
|
||||
```bash
|
||||
|
||||
@@ -40,54 +34,59 @@ bash bootstrap.sh
|
||||
|
||||
```
|
||||
|
||||
и, по идее, всё что нужно будет выкачено, собрано и разложено куда надо.
|
||||
и по идее всё что нужно будет выкачено, собрано и разложено куда надо.
|
||||
|
||||
## Запуск и работа
|
||||
|
||||
Бот не использует [вебхуки][4], поэтому ничего дополнительного, кроме хорошего подключения к интернету ему не нужно.
|
||||
Бот не использует [вебхуки][4], поэтому ничего дополнительного, кроме хорошего
|
||||
подключения к интернету ему не нужно.
|
||||
|
||||
### Дополнительные настройки
|
||||
|
||||
Некоторые "плагины" требуют регистрации в сторонних сервисах (API keys, secrets итд), чтобы бот не сыпал ошибками в
|
||||
логи (возможно, в дальнейшем возможно будет отключить эти плагины).
|
||||
Некоторые "плагины" требуют регистрации в сторонних сервисах (API keys, secrets
|
||||
итд), чтобы бот не сыпал ошибками в логи (возможно, в дальнейшем возможно будет
|
||||
отключить эти плагины).
|
||||
|
||||
#### OpenWeatherMap
|
||||
|
||||
Для работы погодного плагина, надо [заргистрироваться][5], [залогиниться][6] и [создать][7] api key. Free plan
|
||||
предлагает всё необхдимое для работы "плагина".
|
||||
Для работы погодного плагина надо [заргистрироваться][5], [залогиниться][6] и
|
||||
[создать][7] api key. Free plan предлагает всё необхдимое для работы "плагина".
|
||||
|
||||
Когда api key будет создан, его нужно вписать в **config.json** "секцию" openweathermap в качестве appid. На этом всё.
|
||||
Когда api key будет создан, его нужно вписать в **config.json** "секцию"
|
||||
openweathermap в качестве appid. На этом всё.
|
||||
|
||||
#### Imgur
|
||||
|
||||
Этот плагин "просто есть" и его на самом деле ничто и никто не использует. И в этой связи все настройки плагина можно
|
||||
оставить "как есть" в примере конфига.
|
||||
Этот плагин "просто есть" и его на самом деле ничто и никто не использует. И в
|
||||
этой связи все настройки плагина можно оставить "как есть" в примере конфига.
|
||||
|
||||
Тем не менее, если есть большое желание, то можно [залогиниться][8] и [зарегистрировать][9] бота как приложение, а
|
||||
потом разрешить приложению пользоваться API-шкой, как описано в [этом][10] или [этом][11] мануале.
|
||||
Тем не менее, если есть большое желание, то можно [залогиниться][8] и
|
||||
[зарегистрировать][9] бота как приложение, а потом разрешить приложению
|
||||
пользоваться API-шкой, как описано в [этом][10] или [этом][11] мануале.
|
||||
|
||||
#### Flickr
|
||||
|
||||
Этот "плагин" действительно используется для добычи ссылок на картинки в разных "картиночных" командах бота.
|
||||
Этот "плагин" действительно используется для добычи ссылок на картинки в разных
|
||||
"картиночных" командах бота.
|
||||
|
||||
Есть скрипт, который поможет с регистрацией приложения в api Flickr - **bin/flickr_init.pl**, он достанет все нужные
|
||||
ключи и секреты к ним.
|
||||
Есть скрипт, который поможет с регистрацией приложения в api Flickr -
|
||||
**bin/flickr_init.pl** он достанет все нужные ключи и секреты к ним.
|
||||
|
||||
До запуска этого скрипта, бот должен быть забутстраплен через **`bootstrap.sh`**.
|
||||
|
||||
[Залогиньтесь][11] и создайте [app][12] in своём Flicker-овском аккаунте. Далее, *разлогиньтесь*, это нужно, чтобы
|
||||
потом проще было достать параметр verifier.
|
||||
[Залогиньтесь][11] и создайте [app][12] in своём Flicker-овском аккаунте. Далее,
|
||||
*разлогиньтесь*, это нужно, чтобы потом проще было достать параметр verifier.
|
||||
|
||||
Запишите [app key и secret][13] в **config.json**. Удостоверьтесь, что параметр "verifier" в конфиге либо закоменчен,
|
||||
либо отсутствует.
|
||||
Запишите [app key и secret][13] в **config.json**. Удостоверьтесь, что параметр
|
||||
"verifier" в конфиге либо закоменчен либо отсутствует.
|
||||
|
||||
Запустите **bin/flickr_init.pl** и следуте предлагаемым инструкциям - в итоге будет дана ссылка, которую надо
|
||||
скопипастить в браузер. По ссылке предложат залогиниться, далее надо будет разрешить приложению просматривать профиль
|
||||
и, через один-два редиректа, вы попадёте на example.com. Из адресной строки браузера надо скопировать параметр
|
||||
"verifier" и вписать его в **config.json**.
|
||||
Запустите **bin/flickr_init.pl** и следуте предлагаемым инструкциям - в итоге
|
||||
будет дана ссылка, которую надо скопипастить в браузер и через один-два
|
||||
редиректа вы попадёте на example.com. Из адресной строки браузера надо
|
||||
скопировать параметр "verifier" и вписать его в **config.json**.
|
||||
|
||||
Чтобы сохранить в бд плагина API access token для нормальной работы "плагина", второй раз запустите
|
||||
**bin/flickr_init.pl**. На этом всё.
|
||||
Чтобы сохранить в бд плагина API access token для нормальной работы "плагина",
|
||||
второй раз запустите **bin/flickr_init.pl**. На этом всё.
|
||||
|
||||
[1]: https://metacpan.org/pod/Telegram::Bot
|
||||
[2]: https://metacpan.org/pod/Hailo
|
||||
|
||||
@@ -29,12 +29,11 @@ no Cwd;
|
||||
use Cwd::utf8 qw (chdir abs_path);
|
||||
use File::Basename qw (basename dirname);
|
||||
use File::Path qw (make_path);
|
||||
use Log::Any qw ($log);
|
||||
use Log::Any::Adapter;
|
||||
use Log::Any::For::Std;
|
||||
use POSIX qw (setgid setuid setsid);
|
||||
use BotLib::Conf qw (LoadConf);
|
||||
use TelegramBot qw (RunTelegramBot);
|
||||
use conf qw (loadConf);
|
||||
use telegrambot qw (run_telegrambot);
|
||||
|
||||
sub daemonize;
|
||||
sub __fork;
|
||||
@@ -44,8 +43,7 @@ local $OUTPUT_AUTOFLUSH = 1;
|
||||
my $runAsUid = $UID;
|
||||
|
||||
my $piddir = '/var/run/' . basename (abs_path ($PROGRAM_NAME));
|
||||
my $C = LoadConf ();
|
||||
my $loglevel = $C->{'loglevel'} // 'notice';
|
||||
my $C = loadConf ();
|
||||
my $logfile;
|
||||
|
||||
if (defined $C->{'log'}) {
|
||||
@@ -94,19 +92,7 @@ if ($UID == 0) {
|
||||
}
|
||||
|
||||
if (defined $logfile) {
|
||||
Log::Any::Adapter->set ('File', $logfile, log_level => $loglevel);
|
||||
|
||||
# Some annoying CHI logging events come with category set to CHI::Driver and log_level set to debug.
|
||||
# Until we use start using Log::Any native features and set whole loglevel accordingly, lets lower
|
||||
# verbosity paticulary for CHI.
|
||||
Log::Any::Adapter->set (
|
||||
{
|
||||
category => 'CHI::Driver'
|
||||
},
|
||||
'File',
|
||||
$logfile,
|
||||
log_level => 'warn'
|
||||
);
|
||||
Log::Any::Adapter->set ('File', $logfile);
|
||||
} else {
|
||||
Log::Any::Adapter->set ('File', '/dev/null');
|
||||
}
|
||||
@@ -118,24 +104,14 @@ daemonize ();
|
||||
my $apath = abs_path $PROGRAM_NAME;
|
||||
|
||||
unless (defined $apath) {
|
||||
$log->fatal ("[FATAL] Unable to get abs_path: $OS_ERROR\n");
|
||||
exit 1;
|
||||
die "[FATAL] Unable to get abs_path: $OS_ERROR\n";
|
||||
};
|
||||
|
||||
# write pidfile
|
||||
my $pidfile = sprintf '%s/%s.pid', $piddir, basename $apath;
|
||||
$log->info ("[INFO] Creating pidfile at $pidfile");
|
||||
|
||||
open my $MYPID, '>', $pidfile or do {
|
||||
$log->fatal ("[FATAL] Error opening $pidfile: $OS_ERROR");
|
||||
exit 1;
|
||||
};
|
||||
|
||||
print {$MYPID} $PID or do {
|
||||
$log->fatal ("[FATAL] Error writing to $pidfile: $OS_ERROR");
|
||||
exit 1;
|
||||
};
|
||||
|
||||
warn "[INFO] Creating pidfile at $pidfile\n";
|
||||
open my $MYPID, '>', $pidfile or die "[FATAL] Error opening $pidfile: $OS_ERROR\n";
|
||||
print {$MYPID} $PID or die "[FATAL] Error writing to $pidfile: $OS_ERROR\n";
|
||||
close $MYPID; ## no critic (InputOutput::RequireCheckedSyscalls
|
||||
|
||||
local $SIG{INT} = \&__signal_handler;
|
||||
@@ -145,7 +121,7 @@ local $SIG{TERM} = \&__signal_handler;
|
||||
$PROGRAM_NAME = abs_path $PROGRAM_NAME; ## no critic (Variables::RequireLocalizedPunctuationVars)
|
||||
|
||||
# run bot, at last
|
||||
RunTelegramBot ();
|
||||
run_telegrambot ();
|
||||
|
||||
if (-f $pidfile) {
|
||||
unlink $pidfile;
|
||||
@@ -169,8 +145,7 @@ sub __fork {
|
||||
my $pid = fork;
|
||||
|
||||
unless (defined $pid) {
|
||||
$log->fatal ("[FATAL] Can't fork: $OS_ERROR");
|
||||
exit 1;
|
||||
die "[FATAL] Can't fork: $OS_ERROR\n";
|
||||
}
|
||||
|
||||
if ($pid != 0) {
|
||||
@@ -181,7 +156,7 @@ sub __fork {
|
||||
}
|
||||
|
||||
sub __signal_handler {
|
||||
$log->info ("[INFO] Caught a signal $OS_ERROR");
|
||||
warn "[INFO] Caught a signal $OS_ERROR\n";
|
||||
|
||||
if (-f $pidfile) {
|
||||
unlink $pidfile;
|
||||
|
||||
@@ -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;
|
||||
@@ -20,9 +20,9 @@ BEGIN {
|
||||
}
|
||||
|
||||
use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
|
||||
use BotLib::Image::Flickr qw (FlickrByTags);
|
||||
use flickr qw (flickr_by_tags);
|
||||
|
||||
my $url = FlickrByTags ('bird,owl');
|
||||
my $url = flickr_by_tags ('bird,owl');
|
||||
|
||||
if ($url) {
|
||||
say $url; ## no critic (InputOutput::RequireCheckedSyscalls)
|
||||
|
||||
@@ -20,9 +20,9 @@ BEGIN {
|
||||
}
|
||||
|
||||
use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
|
||||
use BotLib::Image::Flickr qw (FlickrInit);
|
||||
use flickr qw (flickr_init);
|
||||
|
||||
if (FlickrInit ()) {
|
||||
if (flickr_init ()) {
|
||||
exit 0;
|
||||
} else {
|
||||
exit 1;
|
||||
|
||||
@@ -20,9 +20,9 @@ BEGIN {
|
||||
}
|
||||
|
||||
use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
|
||||
use BotLib::Image::Flickr qw (FlickrTestLogin);
|
||||
use flickr qw (flickr_test_login);
|
||||
|
||||
if (FlickrTestLogin ()) {
|
||||
if (flickr_test_login ()) {
|
||||
exit 0;
|
||||
} else {
|
||||
exit 1;
|
||||
|
||||
@@ -20,7 +20,9 @@ BEGIN {
|
||||
}
|
||||
|
||||
use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
|
||||
use BotLib::Fortune qw (Seed);
|
||||
use fortune qw (seed);
|
||||
use Carp;
|
||||
local $SIG{__DIE__} = sub { Carp::confess @_ };
|
||||
|
||||
Seed ();
|
||||
seed ();
|
||||
exit 0;
|
||||
|
||||
@@ -20,7 +20,7 @@ BEGIN {
|
||||
}
|
||||
|
||||
use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
|
||||
use BotLib::Friday qw (Seed);
|
||||
use friday qw (seed);
|
||||
|
||||
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::Proverb qw (Seed);
|
||||
|
||||
Seed ();
|
||||
exit 0;
|
||||
@@ -20,7 +20,7 @@ BEGIN {
|
||||
}
|
||||
|
||||
use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
|
||||
use BotLib::Lat qw (Train);
|
||||
use lat qw (train);
|
||||
|
||||
Train ();
|
||||
train ();
|
||||
exit 0;
|
||||
|
||||
70
cpanfile
70
cpanfile
@@ -1,39 +1,31 @@
|
||||
## no critic (TestingAndDebugging::RequireUseStrict,Modules::RequireVersionVar)
|
||||
## no critic (TestingAndDebugging::RequireUseWarnings,Modules::RequireExplicitPackage)
|
||||
## no critic (Modules::RequireEndWithOne)
|
||||
requires 'Carp', '==1.50';
|
||||
requires 'CHI', '==0.61';
|
||||
requires 'CHI::Driver::BerkeleyDB', '==0.05';
|
||||
requires 'Cwd::utf8', '==0.011';
|
||||
requires 'DateTime', '==1.55';
|
||||
requires 'DB_File', '==1.856';
|
||||
requires 'SQLite_File', '==0.1006';
|
||||
requires 'DBI', '==1.643';
|
||||
requires 'DBD::SQLite', '==1.70';
|
||||
requires 'Digest::HMAC_SHA1', '==1.04';
|
||||
requires 'Digest::MD5', '==2.58';
|
||||
requires 'Data::Dumper', '==2.183';
|
||||
requires 'Digest::SHA', '==6.02';
|
||||
requires 'File::Basename', '==2.85';
|
||||
requires 'File::Path', '==2.18';
|
||||
requires 'Hailo', '==0.75';
|
||||
requires 'HTML::TokeParser', '==3.76';
|
||||
requires 'IO::Socket::SSL', '==2.074';
|
||||
requires 'JSON', '==4.05';
|
||||
requires 'JSON::PP', '==4.07';
|
||||
requires 'JSON::XS', '==4.03';
|
||||
requires 'List::Util', '==1.60';
|
||||
requires 'local::lib', '==2.000028';
|
||||
requires 'Log::Any', '==1.710';
|
||||
requires 'Log::Any::Adapter', '==1.710';
|
||||
requires 'Log::Any::For::Std', '==0.05';
|
||||
requires 'Math::Random::Secure', '==0.080001';
|
||||
requires 'Mojolicious', '==9.22';
|
||||
requires 'Mojo::Base', '0';
|
||||
requires 'Mojo::IOLoop', '0';
|
||||
requires 'Mojo::UserAgent', '0';
|
||||
requires 'Mojo::UserAgent::Cached', '==1.18';
|
||||
requires 'String::Random', '==0.32';
|
||||
requires 'Text::Fuzzy', '==0.29';
|
||||
requires 'URI::Encode::XS', '==0.11';
|
||||
requires 'URI::URL', '==5.10';
|
||||
requires 'Carp';
|
||||
requires 'CHI';
|
||||
requires 'CHI::Driver::BerkeleyDB';
|
||||
requires 'Cwd::utf8';
|
||||
requires 'DateTime';
|
||||
requires 'DB_File';
|
||||
requires 'SQLite_File';
|
||||
requires 'Digest::HMAC_SHA1';
|
||||
requires 'Digest::MD5';
|
||||
requires 'Data::Dumper';
|
||||
requires 'Digest::SHA';
|
||||
requires 'File::Basename';
|
||||
requires 'File::Path';
|
||||
requires 'Hailo';
|
||||
requires 'HTML::TokeParser';
|
||||
requires 'IO::Socket::SSL';
|
||||
requires 'JSON';
|
||||
requires 'JSON::XS';
|
||||
requires 'List::Util';
|
||||
requires 'local::lib';
|
||||
requires 'Log::Any';
|
||||
requires 'Log::Any::Adapter';
|
||||
requires 'Log::Any::For::Std';
|
||||
requires 'Math::Random::Secure';
|
||||
requires 'Mojo::Base';
|
||||
requires 'Mojo::IOLoop';
|
||||
requires 'Mojo::UserAgent';
|
||||
requires 'Mojo::UserAgent::Cached';
|
||||
requires 'Text::Fuzzy';
|
||||
requires 'URI::Encode::XS';
|
||||
requires 'URI::URL';
|
||||
|
||||
@@ -1,54 +0,0 @@
|
||||
амулет Мерлина
|
||||
библиотеку Ивана Грозного
|
||||
деревянную плошку
|
||||
диплока
|
||||
доски Ноева Ковчега
|
||||
древний презерватив из бараньей кишки
|
||||
икону
|
||||
инсталятор Windows 3.11
|
||||
истлевший гроб
|
||||
каменный топор
|
||||
клад со златом-серебром
|
||||
кривой нож
|
||||
ледяную глыбу
|
||||
лунный грунт
|
||||
мамонта
|
||||
мамонтёнка
|
||||
метеорит
|
||||
мумию фараона Тутанхамона
|
||||
носки прапорщика (поставит в угол)
|
||||
обломки грузинской керамики
|
||||
птеродактиля
|
||||
рубль с Лениным
|
||||
рыцарские доспехи
|
||||
синий мох
|
||||
скелет
|
||||
скелет собаки по кличке Беня
|
||||
тиранозавтра
|
||||
тотем индейцев
|
||||
трубу с туркменским газом
|
||||
скорбь еврейского народа
|
||||
залежи активированного угля
|
||||
не очень новый завет
|
||||
мать леннарта поттеринга
|
||||
руководство "начинающему археологу"
|
||||
слово о полку игореве и дело о полку игореве, вместе с игорем
|
||||
телепрограмму канала A-one
|
||||
могилу искателя могил
|
||||
заплесневевший кусок хлеба
|
||||
преемник радиоприемника
|
||||
глушитель от ВАЗ-2106
|
||||
чувство удовлетворения
|
||||
крота
|
||||
воспоминания о былой любви
|
||||
грязистор
|
||||
египетское мумиё
|
||||
окаменелый камень
|
||||
кладку яиц рептилоида
|
||||
яму
|
||||
чеснок и стрелы
|
||||
доллар по 30
|
||||
несмазанные скрижали
|
||||
четырелобита
|
||||
чучело тролля
|
||||
целое ничего
|
||||
@@ -1,47 +0,0 @@
|
||||
семикрылого чешуйчатого пятихуя
|
||||
разумного конденсатора
|
||||
сальмонеллу
|
||||
селёдку
|
||||
желтоперого тунца
|
||||
розовую сальмонеллу
|
||||
голавля
|
||||
барбуса
|
||||
окуня
|
||||
верхоплавку
|
||||
коричневую форель
|
||||
полярника
|
||||
плотву
|
||||
зубатку
|
||||
солнечную рыбу
|
||||
старую шину
|
||||
скользкую корягу
|
||||
лампу джина
|
||||
любовное послание в бутылке
|
||||
старое бревно
|
||||
резиновый сапог
|
||||
труп
|
||||
Лох-Несское чудовище
|
||||
старую рыбацкую приманку
|
||||
кусок Титаника
|
||||
обломок Атлантиды
|
||||
кита
|
||||
кальмара
|
||||
дельфина
|
||||
ската
|
||||
подводную лодку
|
||||
медузу
|
||||
морскую звезду
|
||||
электрического угря
|
||||
большую белую акулу
|
||||
аквалангиста
|
||||
монстра
|
||||
вируса
|
||||
сырую пачку сигарет
|
||||
водоросли
|
||||
якорь от лодки
|
||||
водяного
|
||||
русалку
|
||||
палтуса
|
||||
труп собаки по кличке Беня
|
||||
олигофрена Проню
|
||||
огеймера Фишкина
|
||||
File diff suppressed because it is too large
Load Diff
@@ -1,10 +1,7 @@
|
||||
{
|
||||
# Cachedir used not only for caches but for some settings and stats too.
|
||||
"cachedir" : "data/cache",
|
||||
|
||||
"gamestat" : {
|
||||
"dir" : "data",
|
||||
"gamestatdir" : "data/gamestat"
|
||||
"admin" : {
|
||||
# store per-channel (per-conversation) settings
|
||||
"dir" : "data/admin"
|
||||
},
|
||||
|
||||
"fortune" : {
|
||||
@@ -12,62 +9,57 @@
|
||||
"srcdir" : "data/fortune_src"
|
||||
},
|
||||
|
||||
"proverb" : {
|
||||
"dir" : "data/proverb",
|
||||
"srcdir" : "data/proverb_src"
|
||||
},
|
||||
|
||||
"friday" : {
|
||||
"dir" : "data/friday",
|
||||
"src" : "data/friday.txt"
|
||||
},
|
||||
|
||||
"image": {
|
||||
"dir" : "data/image",
|
||||
"imgur" : {
|
||||
# See README.md about these settings - auth'ed search settings.
|
||||
# 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.
|
||||
# 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"
|
||||
}
|
||||
},
|
||||
|
||||
"karma": {
|
||||
"dir": "data/karma"
|
||||
},
|
||||
|
||||
"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.
|
||||
"log" : "/var/log/aleesa-telegram-bot/aleesa.log",
|
||||
# required for debugging reasons, if commented out or not exist, no debug logging appears at all
|
||||
"log" : "/var/log/aleesa-telegram-bot/debug.log",
|
||||
|
||||
# Verbosity can be trace, debug, info (inform), notice, warning (warn), error (err), critical (crit, fatal), alert, emergency.
|
||||
# Currently implemented debug, info, notice, warn, error, fatal. Notice is default logging level.
|
||||
"loglevel": "notice",
|
||||
|
||||
# Openwatermap plugin.
|
||||
# openwatermap plugin
|
||||
"openweathermap" : {
|
||||
"appid" : "md5sum-like_string",
|
||||
# result cache, stores data for 4 hours
|
||||
"cachedir" : "data/cache",
|
||||
},
|
||||
|
||||
# Stuff for telegram itself.
|
||||
# stuff for telegram itself
|
||||
"telegrambot" : {
|
||||
|
||||
# Directory with per-conversation "brains".
|
||||
# directory with per-conversation "brains"
|
||||
"braindir" : "data/telegrambot-brains",
|
||||
|
||||
# Prefix-sign for all commands. In many irc-bots (eggdrop/windrop) it is "." (dot), in sulci it was "!".
|
||||
# In telegram commands begin with "/" on the start of first (and only) line. In case of this bot you can define what to use.
|
||||
# prefix-sign for all commands. in many irc-bots (eggdrop/windrop) it is "." (dot), in sulci it was "!"
|
||||
# in telegram commands begin with "/" on the start of first (and only) line.
|
||||
"csign" : "!",
|
||||
|
||||
"token" : "Long_string_given_by_@BotFather"
|
||||
},
|
||||
|
||||
# Unprivileged user to run this bot from.
|
||||
# unprivileged user to run this bot from
|
||||
"user" : "unit",
|
||||
}
|
||||
|
||||
@@ -1,266 +0,0 @@
|
||||
package BotLib::Admin;
|
||||
|
||||
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 CHI;
|
||||
use CHI::Driver::BerkeleyDB;
|
||||
use BotLib::Conf qw (LoadConf);
|
||||
use BotLib::Util qw (utf2sha1);
|
||||
|
||||
use version; our $VERSION = qw (1.0);
|
||||
use Exporter qw (import);
|
||||
# to export array we need @ISA here
|
||||
our @ISA = qw / Exporter /; ## no critic (ClassHierarchies::ProhibitExplicitISA)
|
||||
our @EXPORT_OK = qw (@ForbiddenMessageTypes @PluginList GetForbiddenTypes AddForbiddenType DelForbiddenType
|
||||
ListForbidden FortuneToggle FortuneToggleList FortuneStatus PluginToggle PluginStatus
|
||||
PluginEnabled);
|
||||
|
||||
my $c = LoadConf ();
|
||||
my $cachedir = $c->{cachedir};
|
||||
# this list is not yet used
|
||||
our @PluginList = qw (oboobs obutts); ## no critic (Variables::ProhibitPackageVars)
|
||||
our @ForbiddenMessageTypes = qw (audio voice photo video video_note animation sticker dice game poll document); ## no critic (Variables::ProhibitPackageVars)
|
||||
|
||||
sub GetForbiddenTypes {
|
||||
my $chatid = shift;
|
||||
my $messageTypes;
|
||||
|
||||
my $cache = CHI->new (
|
||||
driver => 'BerkeleyDB',
|
||||
root_dir => $cachedir,
|
||||
namespace => __PACKAGE__ . '_' . 'censor' . '_' . utf2sha1 ($chatid)
|
||||
);
|
||||
|
||||
foreach (@ForbiddenMessageTypes) {
|
||||
my $type = $cache->get ($_);
|
||||
|
||||
if ($type) {
|
||||
$messageTypes->{$_} = 1;
|
||||
} else {
|
||||
unless (defined $type) {
|
||||
$cache->set ($_, 0, 'never');
|
||||
}
|
||||
|
||||
$messageTypes->{$_} = 0;
|
||||
}
|
||||
}
|
||||
|
||||
return $messageTypes;
|
||||
}
|
||||
|
||||
sub AddForbiddenType {
|
||||
my $chatid = shift;
|
||||
my $type = shift;
|
||||
|
||||
my $cache = CHI->new (
|
||||
driver => 'BerkeleyDB',
|
||||
root_dir => $cachedir,
|
||||
namespace => __PACKAGE__ . '_' . 'censor' . '_' . utf2sha1 ($chatid)
|
||||
);
|
||||
|
||||
$cache->set ($type, 1, 'never');
|
||||
return;
|
||||
}
|
||||
|
||||
sub DelForbiddenType {
|
||||
my $chatid = shift;
|
||||
my $type = shift;
|
||||
|
||||
my $cache = CHI->new (
|
||||
driver => 'BerkeleyDB',
|
||||
root_dir => $cachedir,
|
||||
namespace => __PACKAGE__ . '_' . 'censor' . '_' . utf2sha1 ($chatid)
|
||||
);
|
||||
|
||||
$cache->remove ($type);
|
||||
return;
|
||||
}
|
||||
|
||||
sub ListForbidden {
|
||||
my $chatid = shift;
|
||||
my @list;
|
||||
|
||||
my $cache = CHI->new (
|
||||
driver => 'BerkeleyDB',
|
||||
root_dir => $cachedir,
|
||||
namespace => __PACKAGE__ . '_' . 'censor' . '_' . utf2sha1 ($chatid)
|
||||
);
|
||||
|
||||
foreach (@ForbiddenMessageTypes) {
|
||||
my $type = $cache->get ($_);
|
||||
|
||||
if ($type) {
|
||||
push @list, sprintf 'Тип сообщения %s удаляется', $_;
|
||||
} else {
|
||||
unless (defined $type) {
|
||||
$cache->set ($_, 0, 'never');
|
||||
}
|
||||
|
||||
push @list, sprintf 'Тип сообщения %s не удаляется', $_;
|
||||
}
|
||||
}
|
||||
|
||||
return join "\n", @list;
|
||||
}
|
||||
|
||||
sub FortuneToggle (@) {
|
||||
my $chatid = shift;
|
||||
my $action = shift // undef;
|
||||
my $phrase = 'Фортунка с утра ';
|
||||
|
||||
my $cache = CHI->new (
|
||||
driver => 'BerkeleyDB',
|
||||
root_dir => $cachedir,
|
||||
namespace => __PACKAGE__ . '_' . 'fortune'
|
||||
);
|
||||
|
||||
my $state = $cache->get ($chatid);
|
||||
|
||||
if (defined $action) {
|
||||
if ($action) {
|
||||
$cache->set ($chatid, 1, 'never');
|
||||
$phrase .= 'будет показываться.';
|
||||
} else {
|
||||
if (defined $state) {
|
||||
$cache->remove ($chatid);
|
||||
}
|
||||
|
||||
$phrase .= 'не будет показываться.';
|
||||
}
|
||||
} else {
|
||||
if (defined $state && $state) {
|
||||
$cache->remove ($chatid);
|
||||
$phrase .= 'не будет показываться.';
|
||||
} else {
|
||||
$cache->set ($chatid, 1, 'never');
|
||||
$phrase .= 'будет показываться.';
|
||||
}
|
||||
}
|
||||
|
||||
return $phrase;
|
||||
}
|
||||
|
||||
sub FortuneStatus ($) {
|
||||
my $chatid = shift;
|
||||
my $phrase = 'Фортунка с утра ';
|
||||
|
||||
my $cache = CHI->new (
|
||||
driver => 'BerkeleyDB',
|
||||
root_dir => $cachedir,
|
||||
namespace => __PACKAGE__ . '_' . 'fortune'
|
||||
);
|
||||
|
||||
my $state = $cache->get ($chatid);
|
||||
|
||||
if (defined $state && $state) {
|
||||
$phrase .= 'показывается.';
|
||||
} else {
|
||||
$phrase .= 'не показывается.';
|
||||
}
|
||||
|
||||
return $phrase;
|
||||
}
|
||||
|
||||
sub FortuneToggleList () {
|
||||
my $cache = CHI->new (
|
||||
driver => 'BerkeleyDB',
|
||||
root_dir => $cachedir,
|
||||
namespace => __PACKAGE__ . '_' . 'fortune'
|
||||
);
|
||||
|
||||
return $cache->get_keys ();
|
||||
}
|
||||
|
||||
sub PluginStatus (@) {
|
||||
my $chatid = shift;
|
||||
my $plugin = shift;
|
||||
my $phrase = "Плагин $plugin ";
|
||||
|
||||
my $cache = CHI->new (
|
||||
driver => 'BerkeleyDB',
|
||||
root_dir => $cachedir,
|
||||
namespace => __PACKAGE__ . '_' . 'plugin' . '_' . utf2sha1 ($chatid)
|
||||
);
|
||||
|
||||
my $state = $cache->get ($plugin);
|
||||
|
||||
if ($state) {
|
||||
$phrase .= 'включён.';
|
||||
} else {
|
||||
unless (defined $state) {
|
||||
$cache->set ($plugin, 0, 'never');
|
||||
}
|
||||
|
||||
$phrase .= 'выключен.';
|
||||
}
|
||||
|
||||
return $phrase;
|
||||
}
|
||||
|
||||
sub PluginEnabled (@) {
|
||||
my $chatid = 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 (
|
||||
driver => 'BerkeleyDB',
|
||||
root_dir => $cachedir,
|
||||
namespace => __PACKAGE__ . '_' . 'plugin' . '_' . utf2sha1 ($chatid)
|
||||
);
|
||||
|
||||
my $state = $cache->get ($plugin);
|
||||
|
||||
if (defined $state && $state) {
|
||||
return 1;
|
||||
} else {
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
||||
sub PluginToggle (@) {
|
||||
my $chatid = shift;
|
||||
my $plugin = shift;
|
||||
my $action = shift // undef;
|
||||
my $phrase = "Плагин $plugin ";
|
||||
|
||||
my $cache = CHI->new (
|
||||
driver => 'BerkeleyDB',
|
||||
root_dir => $cachedir,
|
||||
namespace => __PACKAGE__ . '_' . 'plugin' . '_' . utf2sha1 ($chatid)
|
||||
);
|
||||
|
||||
my $state = $cache->get ($plugin);
|
||||
|
||||
if (defined $action) {
|
||||
if ($action) {
|
||||
$cache->set ($plugin, 1, 'never');
|
||||
$phrase .= 'включён';
|
||||
} else {
|
||||
$cache->set ($plugin, 0, 'never');
|
||||
$phrase .= 'выключен';
|
||||
}
|
||||
} else {
|
||||
if (defined ($state) && $state) {
|
||||
$cache->set ($plugin, 0, 'never');
|
||||
$phrase .= 'включён';
|
||||
} else {
|
||||
$cache->set ($plugin, 1, 'never');
|
||||
$phrase .= 'выключен';
|
||||
}
|
||||
}
|
||||
|
||||
return $phrase;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
||||
@@ -1,88 +0,0 @@
|
||||
package BotLib::Anek;
|
||||
|
||||
use 5.018;
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
use open qw (:std :utf8);
|
||||
use English qw ( -no_match_vars );
|
||||
use Encode;
|
||||
use HTML::TokeParser;
|
||||
use JSON::XS;
|
||||
use Log::Any qw ($log);
|
||||
use Mojo::UserAgent;
|
||||
|
||||
use version; our $VERSION = qw (1.0);
|
||||
use Exporter qw (import);
|
||||
our @EXPORT_OK = qw (Anek);
|
||||
|
||||
sub Anek {
|
||||
my $r;
|
||||
my $ret = 'Все рассказчики анекдотов отдыхают';
|
||||
my $got_anek = 0;
|
||||
|
||||
for (1..3) {
|
||||
for (1..3) {
|
||||
my $ua = Mojo::UserAgent->new->connect_timeout (3);
|
||||
$ua->max_redirects(3);
|
||||
$r = $ua->get ('https://www.anekdot.ru/rss/randomu.html')->result;
|
||||
|
||||
if ($r->is_success) {
|
||||
last;
|
||||
}
|
||||
|
||||
sleep 2;
|
||||
}
|
||||
|
||||
if ($r->is_success) {
|
||||
my $json;
|
||||
my $response_text = decode ('UTF-8', $r->body);
|
||||
my @text = split /\n/, $response_text;
|
||||
|
||||
while (my $str = pop @text) {
|
||||
if ($str =~ /^var anekdot_texts \= JSON/) {
|
||||
$str = (split /JSON\.parse\(\'/, $str, 2)[1];
|
||||
|
||||
if (defined $str && length ($str) > 10) {
|
||||
$json = (split /\';\)/, $str, 2)[0];
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if (defined $json && length ($json) > 10) {
|
||||
$json =~ s/\\"/"/g;
|
||||
$json =~ s/\\\\"/\\"/g;
|
||||
$json = substr $json, 0, -3;
|
||||
|
||||
my $anek = eval { ${JSON::XS->new->relaxed->decode ($json)}[0] };
|
||||
|
||||
if (defined $anek) {
|
||||
my @anek = split /<br>/, $anek;
|
||||
$ret = join "\n", @anek;
|
||||
|
||||
if (length ($ret) > 1) {
|
||||
$got_anek = 1;
|
||||
}
|
||||
} else {
|
||||
$log->warn (sprintf '[WARN] anekdot.ru server returns incorrect json, full response text message: %s', $response_text);
|
||||
}
|
||||
} else {
|
||||
$log->warn (sprintf '[WARN] anekdot.ru server returns unexpected response text: %s', $r->body);
|
||||
}
|
||||
|
||||
} else {
|
||||
$log->warn (sprintf '[WARN] anekdot.ru server return status %s with message: %s', $r->code, $r->message);
|
||||
}
|
||||
|
||||
if ($got_anek) {
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
||||
@@ -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,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,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,88 +0,0 @@
|
||||
package BotLib::Proverb;
|
||||
# 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 BotLib::Util qw (trim);
|
||||
|
||||
use version; our $VERSION = qw (1.0);
|
||||
use Exporter qw (import);
|
||||
our @EXPORT_OK = qw (Seed Proverb);
|
||||
|
||||
my $c = LoadConf ();
|
||||
my $dir = $c->{proverb}->{dir};
|
||||
my $srcdir = $c->{proverb}->{srcdir};
|
||||
|
||||
sub Seed () {
|
||||
unless (-d $dir) {
|
||||
make_path ($dir) || croak "Unable to create $dir: $OS_ERROR";
|
||||
}
|
||||
|
||||
my $backingfile = sprintf '%s/proverb.sqlite', $dir;
|
||||
|
||||
if (-f $backingfile) {
|
||||
unlink $backingfile || croak "Unable to remove $backingfile: $OS_ERROR";
|
||||
}
|
||||
|
||||
tie my @proverb, 'SQLite_File', $backingfile || croak "Unable to tie to $backingfile: $OS_ERROR";
|
||||
opendir (my $srcdirhandle, $srcdir) || croak "Unable to open $srcdir: $OS_ERROR";
|
||||
|
||||
while (my $proverbfile = readdir ($srcdirhandle)) {
|
||||
my $srcfile = sprintf '%s/%s', $srcdir, $proverbfile;
|
||||
|
||||
unless (-f $srcfile) {
|
||||
next;
|
||||
}
|
||||
|
||||
if ($proverbfile =~ m/^\.+$/) {
|
||||
next;
|
||||
}
|
||||
|
||||
open (my $fh, '<', $srcfile) || croak "Unable to open $srcfile, $OS_ERROR";
|
||||
|
||||
while (readline $fh) {
|
||||
chomp;
|
||||
my $str = trim ($_);
|
||||
|
||||
if ($str ne '') {
|
||||
push @proverb, $str;
|
||||
}
|
||||
}
|
||||
|
||||
close $fh; ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
|
||||
}
|
||||
|
||||
closedir $srcdirhandle;
|
||||
untie @proverb;
|
||||
return;
|
||||
}
|
||||
|
||||
# just return answer
|
||||
sub Proverb () {
|
||||
my $backingfile = sprintf '%s/proverb.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,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:
|
||||
@@ -18,13 +18,6 @@ use Log::Any;
|
||||
use Data::Dumper;
|
||||
|
||||
use Teapot::Bot::Object::Message;
|
||||
use Teapot::Bot::Object::Poll;
|
||||
use Teapot::Bot::Object::PollAnswer;
|
||||
use Teapot::Bot::Object::ChatMemberUpdated;
|
||||
use Teapot::Bot::Object::User;
|
||||
use Teapot::Bot::Object::Chat;
|
||||
use Teapot::Bot::Object::ChatMember;
|
||||
use Teapot::Bot::Object::ChatInviteLink;
|
||||
|
||||
$Teapot::Bot::Brain::VERSION = '0.022';
|
||||
|
||||
@@ -139,20 +132,20 @@ sub getChatMember {
|
||||
}
|
||||
}
|
||||
|
||||
sub banChatMember {
|
||||
sub kickChatMember {
|
||||
my $self = shift;
|
||||
my $args = shift || {};
|
||||
|
||||
my $token = $self->token || croak 'No token supplied to banChatMember?';
|
||||
my $token = $self->token || croak 'No token supplied to kickChatMember?';
|
||||
my $send_args = {};
|
||||
|
||||
unless ($args->{chat_id}) {
|
||||
cluck 'No chat_id supplied to banChatMember()';
|
||||
cluck 'No chat_id supplied to kickChatMember()';
|
||||
return {'error' => 1};
|
||||
}
|
||||
|
||||
unless ($args->{user_id}) {
|
||||
cluck 'No user_id supplied to banChatMember()';
|
||||
cluck 'No user_id supplied to kickChatMember()';
|
||||
return {'error' => 1};
|
||||
}
|
||||
|
||||
@@ -161,7 +154,7 @@ sub banChatMember {
|
||||
$send_args->{until_date} = $args->{until_date} if exists $args->{until_date};
|
||||
$send_args->{revoke_messages} = $args->{revoke_messages} if exists $args->{revoke_messages};
|
||||
|
||||
my $url = "https://api.telegram.org/bot${token}/banChatMember";
|
||||
my $url = "https://api.telegram.org/bot${token}/kickChatMember";
|
||||
my $api_response = $self->_post_request($url, $send_args);
|
||||
|
||||
return;
|
||||
@@ -361,7 +354,7 @@ sub deleteMessage {
|
||||
|
||||
my $token = $self->token || croak 'No token supplied to deleteMessage()?';
|
||||
|
||||
if (Teapot::Bot::Object::ChatMember->canDeleteMessage($self, $args->{chat_id})) {
|
||||
if (Teapot::Bot::Object::ChatMember::canDeleteMessage($self, $args->{chat_id})) {
|
||||
my $url = "https://api.telegram.org/bot${token}/deleteMessage";
|
||||
$self->_post_request($url, $send_args);
|
||||
}
|
||||
@@ -440,11 +433,11 @@ sub sendChatAction {
|
||||
elsif ($args->{action} eq 'upload_video') {
|
||||
$send_args->{action} = 'upload_video';
|
||||
}
|
||||
elsif ($args->{action} eq 'record_voice') {
|
||||
$send_args->{action} = 'record_voice';
|
||||
elsif ($args->{action} eq 'record_audio') {
|
||||
$send_args->{action} = 'record_audio';
|
||||
}
|
||||
elsif ($args->{action} eq 'upload_voice') {
|
||||
$send_args->{action} = 'upload_voice';
|
||||
elsif ($args->{action} eq 'upload_audio') {
|
||||
$send_args->{action} = 'upload_audio';
|
||||
}
|
||||
elsif ($args->{action} eq 'upload_document') {
|
||||
$send_args->{action} = 'upload_document';
|
||||
@@ -458,9 +451,6 @@ sub sendChatAction {
|
||||
elsif ($args->{action} eq 'upload_video_note') {
|
||||
$send_args->{action} = 'upload_video_note';
|
||||
}
|
||||
elsif ($args->{action} eq 'choose_sticker') {
|
||||
$send_args->{action} = 'choose_sticker';
|
||||
}
|
||||
else {
|
||||
$send_args->{action} = 'typing';
|
||||
}
|
||||
@@ -808,10 +798,10 @@ of Chat User.
|
||||
|
||||
On error returns hash reference with error set to 1
|
||||
|
||||
=head2 banChatMember
|
||||
=head2 kickChatMember
|
||||
|
||||
This is the wrapper around the C<banChatMember> API method. See
|
||||
L<https://core.telegram.org/bots/api#banchatmember>.
|
||||
This is the wrapper around the C<kickChatMember> API method. See
|
||||
L<https://core.telegram.org/bots/api#kickchatmember>.
|
||||
|
||||
Takes chat_id, and user_id as arguments. And optionally until_date and
|
||||
revoke_messages.
|
||||
|
||||
@@ -8,7 +8,6 @@ use Carp qw/croak/;
|
||||
$Teapot::Bot::Object::Animation::VERSION = '0.022';
|
||||
|
||||
has 'file_id';
|
||||
has 'file_unique_id';
|
||||
has 'width';
|
||||
has 'height';
|
||||
has 'duration';
|
||||
@@ -18,8 +17,7 @@ has 'mime_type';
|
||||
has 'file_size';
|
||||
|
||||
sub fields {
|
||||
return { scalar => [qw/file_id file_unique_id width height duration file_name mime_type
|
||||
file_size/],
|
||||
return { scalar => [qw/file_id width height duration file_name mime_type file_size/],
|
||||
'Teapot::Bot::Object::PhotoSize' => [qw/thumb/],
|
||||
};
|
||||
}
|
||||
|
||||
@@ -5,7 +5,6 @@ use Mojo::Base -base;
|
||||
use List::Util qw/any/;
|
||||
use Carp qw/croak cluck/;
|
||||
use Data::Dumper;
|
||||
use JSON::PP ();
|
||||
|
||||
$Teapot::Bot::Object::Base::VERSION = '0.022';
|
||||
|
||||
@@ -55,14 +54,115 @@ sub create_from_array {
|
||||
}
|
||||
|
||||
unless (ref ($array) eq 'ARRAY') {
|
||||
cluck 'Not array ' . Dumper ($array);
|
||||
cluck 'Not array ' . Dumper ($hash);
|
||||
return $obj;
|
||||
}
|
||||
|
||||
cluck "Dumping class: " . Dumper ($class);
|
||||
cluck "Dumping array: " . Dumper ($array);
|
||||
Dumping array: $VAR1 = [
|
||||
[
|
||||
{
|
||||
'text' => 'Spotify',
|
||||
'url' => 'https://open.spotify.com/track/44MxUoeZg6FXDlHMrSbVjX'
|
||||
},
|
||||
{
|
||||
'text' => 'Tidal',
|
||||
'url' => 'https://listen.tidal.com/track/159119367'
|
||||
},
|
||||
{
|
||||
'url' => 'https://music.apple.com/us/album/_/1534782030?i=1534782031',
|
||||
'text' => 'Apple'
|
||||
}
|
||||
],
|
||||
[
|
||||
{
|
||||
'text' => 'Deezer',
|
||||
'url' => 'https://www.deezer.com/track/1112603372'
|
||||
},
|
||||
{
|
||||
'text' => 'YouTube',
|
||||
'url' => 'https://music.youtube.com/watch?v=KT1jJDh7ir0'
|
||||
},
|
||||
{
|
||||
'url' => 'https://song.link/s/44MxUoeZg6FXDlHMrSbVjX',
|
||||
'text' => 'eXtra'
|
||||
}
|
||||
]
|
||||
];
|
||||
|
||||
Dumping array: $VAR1 = [
|
||||
[
|
||||
{
|
||||
'callback_data' => 'l85882326|open.spotify.com/track/44MxUoeZg6FXDlHMrSbVjX',
|
||||
'text' => 'Get links'
|
||||
}
|
||||
]
|
||||
];
|
||||
|
||||
# https://core.telegram.org/bots/api#inlinekeyboardmarkup
|
||||
# который содержит в себе тупо массив
|
||||
# Array of Array of Teapot::Bot::Object::InlineKeyboardButton
|
||||
|
||||
# https://core.telegram.org/bots/api#userprofilephotos
|
||||
# аналогично предыдущему содержит
|
||||
# Array of Array of Teapot::Bot::Object::PhotoSize
|
||||
|
||||
# deal with each type of field
|
||||
foreach my $type (keys %{ $class->fields }) {
|
||||
my @fields_of_this_type = @{ $class->fields->{$type} };
|
||||
|
||||
foreach my $field (@fields_of_this_type) {
|
||||
# ignore undefined fields (sic!)
|
||||
next if (! defined $field);
|
||||
|
||||
# ignore fields for which we have no value in the hash
|
||||
next if (! defined $hash->{$field} );
|
||||
|
||||
# warn "type: $type field $field\n";
|
||||
if ($type eq 'scalar') {
|
||||
if ($obj->_field_is_array($field)) {
|
||||
# simple scalar array ref, so just copy it
|
||||
my $val = $hash->{$field};
|
||||
# deal with boolean stuff so we don't pollute our object
|
||||
# with JSON
|
||||
if (ref($val) eq 'JSON::PP::Boolean') {
|
||||
$val = !!$val;
|
||||
}
|
||||
$obj->$field($val);
|
||||
}
|
||||
elsif ($obj->_field_is_array_of_arrays) {
|
||||
croak 'Not yet implemented for scalars';
|
||||
}
|
||||
else {
|
||||
my $val = $hash->{$field};
|
||||
if (ref($val) eq 'JSON::PP::Boolean') {
|
||||
$val = 0+$val;
|
||||
|
||||
}
|
||||
$obj->$field($val);
|
||||
}
|
||||
}
|
||||
|
||||
else {
|
||||
if ($obj->_field_is_array($field)) {
|
||||
my @sub_array;
|
||||
foreach my $data ( @{ $hash->{$field} } ) {
|
||||
push @sub_array, $type->create_from_hash($data, $brain);
|
||||
}
|
||||
$obj->$field(\@sub_array);
|
||||
}
|
||||
elsif ($obj->_field_is_array_of_arrays) {
|
||||
croak 'Not yet implemented for scalars';
|
||||
}
|
||||
else {
|
||||
$obj->$field($type->create_from_hash($hash->{$field}, $brain));
|
||||
}
|
||||
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# it's stub, return $obj
|
||||
return $obj;
|
||||
}
|
||||
|
||||
@@ -80,7 +180,7 @@ sub create_from_hash {
|
||||
}
|
||||
|
||||
unless (ref ($hash) eq 'HASH') {
|
||||
if (ref ($hash) eq 'ARRAY') {
|
||||
if (ref ($array) eq 'ARRAY') {
|
||||
return create_from_array($class, $hash, $brain);
|
||||
}
|
||||
|
||||
|
||||
@@ -11,36 +11,27 @@ $Teapot::Bot::Object::Chat::VERSION = '0.022';
|
||||
|
||||
has 'id';
|
||||
has 'type';
|
||||
has 'title'; # Optional.
|
||||
has 'username'; # Optional.
|
||||
has 'first_name'; # Optional.
|
||||
has 'last_name'; # Optional.
|
||||
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 '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 'invite_link'; # Optional. Returned only in getChat.
|
||||
has 'pinned_message'; # Teapot::Bot::Object::Message
|
||||
has 'permissions'; # Teapot::Bot::Object::ChatPermissions. Optional. Default chat member permissions, for
|
||||
# groups and supergroups. 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
|
||||
# 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 'can_set_sticker_set'; # Optional. Returned only in getChat.
|
||||
has 'linked_chat_id'; # Optional. greater than 32 bits, smaller than 52 bits
|
||||
has 'location'; # Optional. Returned only in getChat.
|
||||
has 'title'; # Optional.
|
||||
has 'username'; # Optional.
|
||||
has 'first_name'; # Optional.
|
||||
has 'last_name'; # Optional.
|
||||
has 'photo'; # Teapot::Bot::Object::ChatPhoto. Optional. Returned only in getChat.
|
||||
has 'description'; # Optional. Returned only in getChat.
|
||||
has 'invite_link'; # Optional. Returned only in getChat.
|
||||
has 'pinned_message'; # Teapot::Bot::Object::Message
|
||||
has 'permissions'; # Teapot::Bot::Object::ChatPermissions. Optional. Default chat member permissions, for
|
||||
# groups and supergroups. Returned only in getChat.
|
||||
has 'slow_mode_delay'; # 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 'linked_chat_id'; # Optional. greater than 32 bits, smaller than 52 bits
|
||||
has 'location'; # Optional. Returned only in getChat.
|
||||
|
||||
sub fields {
|
||||
return {
|
||||
'scalar' => [qw/id type title username first_name last_name bio
|
||||
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/],
|
||||
'scalar' => [qw/id type title username first_name last_name description
|
||||
invite_link slow_mode_delay sticker_set_name
|
||||
can_set_sticker_set linked_chat_id/],
|
||||
'Teapot::Bot::Object::ChatPhoto' => [qw/photo/],
|
||||
'Teapot::Bot::Object::Message' => [qw/pinned_message/],
|
||||
'Teapot::Bot::Object::ChatPermissions' => [qw/permissions/],
|
||||
|
||||
@@ -8,19 +8,15 @@ $Teapot::Bot::Object::ChatInviteLink::VERSION = '0.022';
|
||||
|
||||
has 'invite_link';
|
||||
has 'creator';
|
||||
has 'creates_join_request';
|
||||
has 'is_primary';
|
||||
has 'is_revoked';
|
||||
has 'name';
|
||||
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
|
||||
# the chat via this invite link; 1-99999
|
||||
has 'pending_join_request_count';
|
||||
|
||||
sub fields {
|
||||
return {
|
||||
'scalar' => [qw/invite_link creates_join_request is_primary is_revoked name expire_date
|
||||
member_limit pending_join_request_count/],
|
||||
'scalar' => [qw/invite_link is_primary is_revoked expire_date expire_date member_limit/],
|
||||
'Teapot::Bot::Object::User' => [qw/creator/],
|
||||
};
|
||||
}
|
||||
|
||||
@@ -7,58 +7,32 @@ use Carp qw(cluck);
|
||||
|
||||
$Teapot::Bot::Object::ChatMember::VERSION = '0.022';
|
||||
|
||||
# ChatMemberOwner
|
||||
has 'user';
|
||||
has 'status';
|
||||
has 'custom_title'; # optional. Owner and administrators only.
|
||||
has 'is_anonymous'; # Optional. Owner and administrators only.
|
||||
has 'user';
|
||||
has 'status';
|
||||
has 'custom_title'; # optional. Owner and administrators only.
|
||||
has 'is_anonymous'; # Optional. Owner and administrators only.
|
||||
|
||||
# ChatMemberAdministrator
|
||||
# has 'user';
|
||||
# has 'status';
|
||||
has 'can_be_edited'; # optional. Administrators only.
|
||||
# has 'custom_title'; # optional. Owner and administrators only.
|
||||
# has 'is_anonymous'; # Optional. Owner and administrators only.
|
||||
has 'can_manage_chat'; # Optional. Administrators only. True, if the administrator can access the chat event
|
||||
has 'can_be_edited'; # optional. Administrators only.
|
||||
has 'can_manage_chat' # Optional. Administrators only. True, if the administrator can access the chat event
|
||||
# log, chat statistics, message statistics in channels, see channel members, see
|
||||
# anonymous administrators in supergroups and ignore slow mode. Implied by any other
|
||||
# administrator privilege
|
||||
has 'can_post_messages'; # optional. Administrators only.
|
||||
has 'can_edit_messages'; # optional. Administrators only.
|
||||
has 'can_delete_messages'; # optional. Administrators only.
|
||||
has 'can_manage_voice_chats'; # Optional. Administrators only. True, if the administrator can manage voice chats
|
||||
has 'can_restrict_members'; # optional. Administrators only.
|
||||
has 'can_promote_members'; # optional. Administrators only.
|
||||
has 'can_change_info'; # optional. Administrators and restricted only.
|
||||
has 'can_invite_users'; # optional. Administrators and restricted only.
|
||||
has 'can_pin_messages'; # optional. Administrators and restricted only.
|
||||
|
||||
# ChatMemberMember
|
||||
# has 'status';
|
||||
# has 'user';
|
||||
|
||||
# ChatMemberRestricted
|
||||
# has 'status';
|
||||
# has 'user';
|
||||
has 'is_member'; # optional. Restricted only.
|
||||
# has 'can_change_info'; # optional. Administrators and restricted only.
|
||||
# has 'can_invite_users'; # optional. Administrators and restricted only.
|
||||
# has 'can_pin_messages'; # optional. Administrators and restricted only.
|
||||
has 'can_send_messages'; # optional. Restricted only.
|
||||
has 'can_send_media_messages'; # optional. Restricted only.
|
||||
has 'can_send_polls'; # optional. Restricted only.
|
||||
has 'can_send_other_messages'; # optional. Restricted only.
|
||||
has 'can_add_web_page_previews'; # optional. Restricted only.
|
||||
has 'until_date'; # optional. Restricted and kicked only.
|
||||
|
||||
# ChatMemberLeft
|
||||
# has 'status';
|
||||
# has 'user';
|
||||
|
||||
# ChatMemberBanned
|
||||
# has 'status';
|
||||
# has 'user';
|
||||
# has 'until_date'; # optional. Restricted and kicked only.
|
||||
has 'can_post_messages'; # optional. Administrators only.
|
||||
has 'can_edit_messages'; # optional. Administrators only.
|
||||
has 'can_delete_messages'; # optional. Administrators only.
|
||||
has 'can_manage_voice_chats' # Optional. Administrators only. True, if the administrator can manage voice chats
|
||||
has 'can_restrict_members'; # optional. Administrators only.
|
||||
has 'can_promote_members'; # optional. Administrators only.
|
||||
has 'can_change_info'; # optional. Administrators and restricted only.
|
||||
has 'can_invite_users'; # optional. Administrators and restricted only.
|
||||
has 'can_pin_messages'; # optional. Administrators and restricted only.
|
||||
has 'is_member'; # optional. Restricted only.
|
||||
has 'can_send_messages'; # optional. Restricted only.
|
||||
has 'can_send_media_messages'; # optional. Restricted only.
|
||||
has 'can_send_polls'; # optional. Restricted only.
|
||||
has 'can_send_other_messages'; # optional. Restricted only.
|
||||
has 'can_add_web_page_previews'; # optional. Restricted only.
|
||||
has 'until_date'; # optional. Restricted and kicked only.
|
||||
|
||||
sub fields {
|
||||
return {
|
||||
@@ -83,7 +57,7 @@ sub canDeleteMessage {
|
||||
my $chatobj = $self->getChat ({ 'chat_id' => $chatid });
|
||||
|
||||
# on api error, keep silence
|
||||
if ($chatobj == 0 || $chatobj->{error}) {
|
||||
unless ($chatobj) {
|
||||
cluck "Unable to get chat info for $chatid from telegram API";
|
||||
return 0;
|
||||
}
|
||||
@@ -91,7 +65,7 @@ sub canDeleteMessage {
|
||||
my $myObj = $self->getMe ();
|
||||
|
||||
# on api error, keep silence
|
||||
if ($myObj == 0 || $myObj->{error}) {
|
||||
unless ($chatobj) {
|
||||
cluck "Unable to get chat info for $chatid from telegram API";
|
||||
return 0;
|
||||
}
|
||||
@@ -100,7 +74,7 @@ sub canDeleteMessage {
|
||||
my $me = $self->getChatMember ({ 'chat_id' => $chatid, 'user_id' => $myid });
|
||||
|
||||
# on api error, keep silence
|
||||
if ($me == 0 || $me->{error}) {
|
||||
unless ($me) {
|
||||
cluck 'Unable to get chat info for bot itself from telegram API';
|
||||
return 0;
|
||||
}
|
||||
|
||||
@@ -6,7 +6,6 @@ use Teapot::Bot::Object::Chat;
|
||||
use Teapot::Bot::Object::User;
|
||||
use Teapot::Bot::Object::ChatMember;
|
||||
use Teapot::Bot::Object::ChatInviteLink;
|
||||
use Teapot::Bot::Object::Voice;
|
||||
|
||||
$Teapot::Bot::Object::ChatMemberUpdated::VERSION = '0.022';
|
||||
|
||||
@@ -15,8 +14,6 @@ has 'from';
|
||||
has 'date';
|
||||
has 'old_chat_member';
|
||||
has 'new_chat_member';
|
||||
has 'text'; # Undocumented as of Bot API 5.2
|
||||
has 'voice'; # Undocumented as of Bot API 5.2
|
||||
has 'invite_link'; # Optional. Chat invite link, which was used by the user to join the chat; for joining by
|
||||
# invite link events only.
|
||||
|
||||
@@ -24,9 +21,8 @@ sub fields {
|
||||
return {
|
||||
'Teapot::Bot::Object::Chat' => [qw/chat/],
|
||||
'Teapot::Bot::Object::User' => [qw/from/],
|
||||
'scalar' => [qw/date text/],
|
||||
'scalar' => [qw/date/],
|
||||
'Teapot::Bot::Object::ChatMember' => [qw/old_chat_member new_chat_member/],
|
||||
'Teapot::Bot::Object::Voice' => [qw/voice/],
|
||||
'Teapot::Bot::Object::ChatInviteLink' => [qw/invite_link/]
|
||||
};
|
||||
}
|
||||
|
||||
@@ -39,26 +39,26 @@ sub canTalk {
|
||||
my $chatobj = $self->_brain->getChat ({ 'chat_id' => $chatid });
|
||||
|
||||
# on api error, keep silence
|
||||
if ($chatobj == 0 || $chatobj->{error}) {
|
||||
unless ($chatobj) {
|
||||
carp "Unable to get chat info for $chatid from telegram API";
|
||||
return $can_talk;
|
||||
return 0;
|
||||
}
|
||||
|
||||
my $myObj = $self->_brain->getMe ();
|
||||
|
||||
# on api error, keep silence
|
||||
if ($myObj == 0 || $myObj->{error}) {
|
||||
unless ($chatobj) {
|
||||
carp "Unable to get chat info for $chatid from telegram API";
|
||||
return $can_talk;
|
||||
return 0;
|
||||
}
|
||||
|
||||
my $myid = $myObj->id;
|
||||
my $me = $self->_brain->getChatMember ({ 'chat_id' => $chatid, 'user_id' => $myid });
|
||||
|
||||
# on api error, keep silence
|
||||
if ($me == 0 || $me->{error}) {
|
||||
unless ($me) {
|
||||
carp 'Unable to get chat info for bot itself from telegram API';
|
||||
return $can_talk;
|
||||
return 0;
|
||||
}
|
||||
|
||||
if ($me->{'status'} eq 'administrator') {
|
||||
|
||||
@@ -9,11 +9,10 @@ has 'phone_number';
|
||||
has 'first_name';
|
||||
has 'last_name';
|
||||
has 'user_id';
|
||||
has 'vcard';
|
||||
|
||||
sub fields {
|
||||
return {
|
||||
scalar => [qw/phone_number first_name last_name user_id vcard/],
|
||||
scalar => [qw/phone_number first_name last_name user_id/],
|
||||
};
|
||||
}
|
||||
|
||||
|
||||
@@ -8,7 +8,6 @@ use Teapot::Bot::Object::PhotoSize;
|
||||
$Teapot::Bot::Object::Document::VERSION = '0.022';
|
||||
|
||||
has 'file_id';
|
||||
has 'file_unique_id';
|
||||
has 'thumb'; #PhotoSize
|
||||
has 'file_name';
|
||||
has 'mime_type';
|
||||
@@ -16,7 +15,7 @@ has 'file_size';
|
||||
|
||||
sub fields {
|
||||
return {
|
||||
scalar => [qw/file_id file_unique_id file_name mime_type file_size/],
|
||||
scalar => [qw/file_id file_name mime_type file_size/],
|
||||
'Teapot::Bot::Object::PhotoSize' => [qw/thumb/]
|
||||
};
|
||||
}
|
||||
|
||||
@@ -30,7 +30,6 @@ use Teapot::Bot::Object::InlineKeyboardMarkup;
|
||||
use Teapot::Bot::Object::ProximityAlertTriggered;
|
||||
use Teapot::Bot::Object::Dice;
|
||||
use Teapot::Bot::Object::MessageAutoDeleteTimerChanged;
|
||||
use Teapot::Bot::Object::VoiceChatScheduled;
|
||||
use Teapot::Bot::Object::VoiceChatStarted;
|
||||
use Teapot::Bot::Object::VoiceChatEnded;
|
||||
use Teapot::Bot::Object::VoiceChatParticipantsInvited;
|
||||
@@ -52,11 +51,9 @@ has 'forward_from_message_id';
|
||||
has 'forward_signature';
|
||||
has 'forward_sender_name';
|
||||
has 'forward_date';
|
||||
has 'is_automatic_forward';
|
||||
has 'reply_to_message'; # Message
|
||||
has 'via_bot'; # User
|
||||
has 'edit_date';
|
||||
has 'has_protected_content';
|
||||
has 'media_group_id';
|
||||
has 'author_signature';
|
||||
has 'text';
|
||||
@@ -94,7 +91,6 @@ has 'successful_payment'; # SuccessfulPayment
|
||||
has 'connected_website';
|
||||
has 'passport_data'; # PassportData
|
||||
has 'proximity_alert_triggered';
|
||||
has 'voice_chat_scheduled'; # Optional. Service message: voice chat scheduled
|
||||
has 'voice_chat_started'; # Optional. Service message: voice chat started
|
||||
has 'voice_chat_ended'; # Optional. Service message: voice chat ended
|
||||
has 'voice_chat_participants_invited'; # Optional. Service message: new participants invited to a voice chat
|
||||
@@ -104,8 +100,8 @@ sub fields {
|
||||
return {
|
||||
'scalar' => [qw/message_id date forward_from_message_id
|
||||
forward_signature forward_sender_name
|
||||
forward_date is_automatic_forward edit_date has_protected_content
|
||||
media_group_id author_signature text caption
|
||||
forward_date edit_date media_group_id
|
||||
author_signature text caption
|
||||
new_chat_title delete_chat_photo
|
||||
group_chat_created supergroup_chat_created
|
||||
channel_chat_created migrate_to_chat_id
|
||||
@@ -139,7 +135,6 @@ sub fields {
|
||||
'Teapot::Bot::Object::ProximityAlertTriggered' => [qw/proximity_alert_triggered/],
|
||||
'Teapot::Bot::Object::Dice' => [qw/dice/],
|
||||
'Teapot::Bot::Object::MessageAutoDeleteTimerChanged' => [qw/message_auto_delete_timer_changed/],
|
||||
'Teapot::Bot::Object::VoiceChatScheduled' => [qw/voice_chat_scheduled/],
|
||||
'Teapot::Bot::Object::VoiceChatStarted' => [qw/voice_chat_started/],
|
||||
'Teapot::Bot::Object::VoiceChatEnded' => [qw/voice_chat_ended/],
|
||||
'Teapot::Bot::Object::VoiceChatParticipantsInvited' => [qw/voice_chat_participants_invited/],
|
||||
@@ -157,7 +152,7 @@ sub reply {
|
||||
|
||||
my $chatid = $self->chat->id;
|
||||
|
||||
if (Teapot::Bot::Object::ChatPermissions->canTalk($self, $chatid)) {
|
||||
if (Teapot::Bot::Object::ChatPermissions::canTalk($self, $chatid)) {
|
||||
return $self->_brain->sendMessage({chat_id => $chatid, text => $text});
|
||||
}
|
||||
|
||||
@@ -170,7 +165,7 @@ sub replyMd {
|
||||
|
||||
my $chatid = $self->chat->id;
|
||||
|
||||
if (Teapot::Bot::Object::ChatPermissions->canTalk ($self, $chatid)) {
|
||||
if (Teapot::Bot::Object::ChatPermissions::canTalk ($self, $chatid)) {
|
||||
my $send_args;
|
||||
$send_args->{text} = $text;
|
||||
$send_args->{parse_mode} = 'Markdown';
|
||||
@@ -187,7 +182,7 @@ sub typing {
|
||||
|
||||
my $chatid = $self->chat->id;
|
||||
|
||||
if (Teapot::Bot::Object::ChatPermissions->canTalk ($self, $chatid)) {
|
||||
if (Teapot::Bot::Object::ChatPermissions::canTalk ($self, $chatid)) {
|
||||
return $self->_brain->sendChatAction({chat_id => $chatid});
|
||||
}
|
||||
|
||||
|
||||
@@ -7,13 +7,12 @@ use Carp qw/croak/;
|
||||
$Teapot::Bot::Object::PhotoSize::VERSION = '0.022';
|
||||
|
||||
has 'file_id';
|
||||
has 'file_unique_id';
|
||||
has 'width';
|
||||
has 'height';
|
||||
has 'file_size';
|
||||
|
||||
sub fields {
|
||||
return { scalar => [qw/file_id file_unique_id width height file_size/] };
|
||||
return { scalar => [qw/file_id width height file_size/] };
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
@@ -1,9 +1,9 @@
|
||||
package Teapot::Bot::Object::PollAnswer;
|
||||
package Teapot::Bot::Object::PollOption;
|
||||
# ABSTRACT: The base class for Telegram 'PollOption' type objects
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
|
||||
$Teapot::Bot::Object::PollAnswer::VERSION = '0.022';
|
||||
$Teapot::Bot::Object::PollOption::VERSION = '0.022';
|
||||
|
||||
has 'poll_id';
|
||||
has 'user';
|
||||
@@ -30,17 +30,17 @@ __END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::PollAnswer - The base class for Telegram 'PollAnswer' type objects
|
||||
Teapot::Bot::Object::PollOption - The base class for Telegram 'PollOption' type objects
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram 'PollAnswer' type objects.
|
||||
The base class for Telegram 'PollOption' type objects.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#pollanswer> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::PollAnswer> objects.
|
||||
See L<https://core.telegram.org/bots/api#polloption> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::PollOption> objects.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
@@ -48,7 +48,7 @@ Sergei Fedosov <eleksir@gmail.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This software is copyright (c) 2021 Sergei Fedosov <eleksir@gmail.com>.
|
||||
This software is copyright (c) 2020 Sergei Fedosov <eleksir@gmail.com>.
|
||||
|
||||
This is free software; you can redistribute it and/or modify it under
|
||||
the same terms as the Perl 5 programming language system itself.
|
||||
|
||||
@@ -8,7 +8,6 @@ use Teapot::Bot::Object::PhotoSize;
|
||||
$Teapot::Bot::Object::VideoNote::VERSION = '0.022';
|
||||
|
||||
has 'file_id';
|
||||
has 'file_unique_id';
|
||||
has 'length';
|
||||
has 'duration';
|
||||
has 'mime_type';
|
||||
@@ -17,7 +16,7 @@ has 'file_size';
|
||||
|
||||
sub fields {
|
||||
return {
|
||||
scalar => [qw/file_id file_unique_id length duration mime_type file_size/],
|
||||
scalar => [qw/file_id length duration mime_type file_size/],
|
||||
'Teapot::Bot::Object::PhotoSize' => [qw/thumb /],
|
||||
};
|
||||
}
|
||||
|
||||
@@ -6,13 +6,12 @@ use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
$Teapot::Bot::Object::Voice::VERSION = '0.022';
|
||||
|
||||
has 'file_id';
|
||||
has 'file_unique_id';
|
||||
has 'duration';
|
||||
has 'mime_type';
|
||||
has 'file_size';
|
||||
|
||||
sub fields {
|
||||
return { scalar => [qw/file_id file_unique_id duration mime_type file_size/] };
|
||||
return { scalar => [qw/file_id duration mime_type file_size/] };
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
@@ -6,7 +6,7 @@ use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
$Teapot::Bot::Object::VoiceChatEnded::VERSION = '0.022';
|
||||
|
||||
# This object represents a service message about a voice chat started in the chat. Currently holds no information.
|
||||
has 'duration';
|
||||
has 'duartion';
|
||||
|
||||
sub fields {
|
||||
return { scalar => [qw/duration/] };
|
||||
|
||||
@@ -1,48 +0,0 @@
|
||||
package Teapot::Bot::Object::VoiceChatScheduled;
|
||||
# ABSTRACT: The base class for Telegram message 'VoiceChatEnded' type.
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
|
||||
$Teapot::Bot::Object::VoiceChatScheduled::VERSION = '0.022';
|
||||
|
||||
# This object represents a service message about a voice chat started in the chat. Currently holds no information.
|
||||
has 'start_date';
|
||||
|
||||
sub fields {
|
||||
return { scalar => [qw/start_date/] };
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::VoiceChatScheduled - The base class for Telegram message 'VoiceChatScheduled' type
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram message 'VoiceChatScheduled' type.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#voicechatscheduled> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::VoiceChatScheduled> objects.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Sergei Fedosov <eleksir@gmail.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This software is copyright (c) 2021 by Sergei Fedosov <eleksir@gmail.com>.
|
||||
|
||||
This is free software; you can redistribute it and/or modify it under
|
||||
the same terms as the Perl 5 programming language system itself.
|
||||
|
||||
=cut
|
||||
392
lib/admin.pm
Normal file
392
lib/admin.pm
Normal file
@@ -0,0 +1,392 @@
|
||||
package admin;
|
||||
|
||||
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 SQLite_File;
|
||||
use conf qw (loadConf);
|
||||
use util qw (utf2sha1);
|
||||
|
||||
use version; our $VERSION = qw (1.0);
|
||||
use Exporter qw (import);
|
||||
# to export array we need @ISA here
|
||||
our @ISA = qw / Exporter /; ## no critic (ClassHierarchies::ProhibitExplicitISA)
|
||||
our @EXPORT_OK = qw (@forbiddenMessageTypes @pluginList getForbiddenTypes addForbiddenType delForbiddenType listForbidden fortune_toggle fortune_toggle_list fortune_status plugin_toggle plugin_status pluginEnabled);
|
||||
|
||||
my $c = loadConf ();
|
||||
my $dir = $c->{admin}->{dir};
|
||||
# this list is not yet used
|
||||
our @pluginList = qw (oboobs obutts); ## no critic (Variables::ProhibitPackageVars)
|
||||
our @forbiddenMessageTypes = qw (audio voice photo video video_note animation sticker dice game poll document); ## no critic (Variables::ProhibitPackageVars)
|
||||
|
||||
sub initCensorDB {
|
||||
my $backingfile = shift;
|
||||
|
||||
tie my %censor, 'SQLite_File', $backingfile || cluck "Unable to tie to $backingfile: $OS_ERROR";
|
||||
|
||||
foreach (@forbiddenMessageTypes) {
|
||||
$censor{$_} = 0;
|
||||
}
|
||||
|
||||
untie %censor;
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub getForbiddenTypes {
|
||||
my $chatid = shift;
|
||||
|
||||
unless (-d $dir) {
|
||||
unless (make_path $dir) {
|
||||
cluck "Unable to create $dir: $OS_ERROR";
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
my $messageTypes;
|
||||
my $backingfile = utf2sha1 $chatid;
|
||||
$backingfile =~ s/\//-/xmsg;
|
||||
$backingfile = sprintf '%s/censor_%s.db', $dir, $backingfile;
|
||||
my %censor;
|
||||
|
||||
unless (-f $backingfile) {
|
||||
initCensorDB ($backingfile);
|
||||
}
|
||||
|
||||
unless (tie %censor, 'SQLite_File', $backingfile) {
|
||||
cluck "Unable to tie to $backingfile: $OS_ERROR";
|
||||
return $messageTypes;
|
||||
}
|
||||
|
||||
foreach (keys %censor) {
|
||||
if ($censor{$_}) {
|
||||
$messageTypes->{$_} = 1;
|
||||
} else {
|
||||
$messageTypes->{$_} = 0;
|
||||
}
|
||||
}
|
||||
|
||||
untie %censor;
|
||||
return $messageTypes;
|
||||
}
|
||||
|
||||
sub addForbiddenType {
|
||||
my $chatid = shift;
|
||||
my $type = shift;
|
||||
|
||||
unless (-d $dir) {
|
||||
unless (make_path $dir) {
|
||||
cluck "Unable to create $dir: $OS_ERROR";
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
my $backingfile = utf2sha1 $chatid;
|
||||
$backingfile =~ s/\//-/xmsg;
|
||||
$backingfile = sprintf '%s/censor_%s.db', $dir, $backingfile;
|
||||
|
||||
unless (-f $backingfile) {
|
||||
initCensorDB ($backingfile);
|
||||
}
|
||||
|
||||
my %censor;
|
||||
|
||||
unless (tie %censor, 'SQLite_File', $backingfile) {
|
||||
cluck "Unable to tie to $backingfile: $OS_ERROR";
|
||||
return;
|
||||
}
|
||||
|
||||
$censor{$type} = 1;
|
||||
untie %censor;
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub delForbiddenType {
|
||||
my $chatid = shift;
|
||||
my $type = shift;
|
||||
|
||||
unless (-d $dir) {
|
||||
unless (make_path $dir) {
|
||||
cluck "Unable to create $dir: $OS_ERROR";
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
my $backingfile = utf2sha1 $chatid;
|
||||
$backingfile =~ s/\//-/xmsg;
|
||||
$backingfile = sprintf '%s/censor_%s.db', $dir, $backingfile;
|
||||
|
||||
unless (-f $backingfile) {
|
||||
initCensorDB ($backingfile);
|
||||
return;
|
||||
}
|
||||
|
||||
my %censor;
|
||||
|
||||
unless (tie %censor, 'SQLite_File', $backingfile) {
|
||||
cluck "Unable to tie to $backingfile: $OS_ERROR";
|
||||
return;
|
||||
}
|
||||
|
||||
$censor{$type} = 0;
|
||||
untie %censor;
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub listForbidden {
|
||||
my $chatid = shift;
|
||||
|
||||
unless (-d $dir) {
|
||||
unless (make_path $dir) {
|
||||
cluck "Unable to create $dir: $OS_ERROR";
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
my @list;
|
||||
my $backingfile = utf2sha1 $chatid;
|
||||
$backingfile =~ s/\//-/xmsg;
|
||||
$backingfile = sprintf '%s/censor_%s.db', $dir, $backingfile;
|
||||
|
||||
unless (-f $backingfile) {
|
||||
initCensorDB ($backingfile);
|
||||
}
|
||||
|
||||
my %censor;
|
||||
|
||||
# FIXME: return list with all types alowed
|
||||
unless (tie %censor, 'SQLite_File', $backingfile) {
|
||||
cluck "Unable to tie to $backingfile: $OS_ERROR";
|
||||
return '';
|
||||
}
|
||||
|
||||
foreach (keys %censor) {
|
||||
if ($censor{$_}) {
|
||||
push @list, sprintf 'Тип сообщения %s удаляется', $_;
|
||||
} else {
|
||||
push @list, sprintf 'Тип сообщения %s не удаляется', $_;
|
||||
}
|
||||
}
|
||||
|
||||
untie %censor;
|
||||
|
||||
return join "\n", @list;
|
||||
}
|
||||
|
||||
sub fortune_toggle (@) {
|
||||
my $chatid = shift;
|
||||
my $action = shift // undef;
|
||||
my $phrase = 'Фортунка с утра ';
|
||||
|
||||
unless (-d $dir) {
|
||||
make_path ($dir) || do {
|
||||
cluck "[ERROR] Unable to create $dir: $OS_ERROR";
|
||||
return;
|
||||
};
|
||||
}
|
||||
|
||||
my $backingfile = sprintf '%s/fortune_morning.sqlite', $dir;
|
||||
|
||||
tie my %toggle, 'SQLite_File', $backingfile || do {
|
||||
cluck "[ERROR] Unable to tie to $backingfile: $OS_ERROR";
|
||||
return;
|
||||
};
|
||||
|
||||
my $state = $toggle{$chatid};
|
||||
|
||||
if (defined $action) {
|
||||
if ($action) {
|
||||
$toggle{$chatid} = 1;
|
||||
$phrase .= 'будет показываться.';
|
||||
} else {
|
||||
if (defined $state) {
|
||||
delete $toggle{$chatid};
|
||||
}
|
||||
|
||||
$phrase .= 'не будет показываться.';
|
||||
}
|
||||
} else {
|
||||
if (defined $state && $state) {
|
||||
delete $toggle{$chatid};
|
||||
$phrase .= 'не будет показываться.';
|
||||
} else {
|
||||
$toggle{$chatid} = 1;
|
||||
$phrase .= 'будет показываться.';
|
||||
}
|
||||
}
|
||||
|
||||
untie %toggle;
|
||||
return $phrase;
|
||||
}
|
||||
|
||||
sub fortune_status ($) {
|
||||
my $chatid = shift;
|
||||
my $phrase = 'Фортунка с утра ';
|
||||
|
||||
unless (-d $dir) {
|
||||
make_path ($dir) || do {
|
||||
cluck "[ERROR] Unable to create $dir: $OS_ERROR";
|
||||
return;
|
||||
};
|
||||
}
|
||||
|
||||
my $backingfile = sprintf '%s/fortune_morning.sqlite', $dir;
|
||||
|
||||
tie my %toggle, 'SQLite_File', $backingfile || do {
|
||||
cluck "[ERROR] Unable to tie to $backingfile: $OS_ERROR\n";
|
||||
return;
|
||||
};
|
||||
|
||||
my $state = $toggle{$chatid};
|
||||
|
||||
if (defined $state && $state) {
|
||||
$phrase .= 'показывается.';
|
||||
} else {
|
||||
$phrase .= 'не показывается.';
|
||||
}
|
||||
|
||||
untie %toggle;
|
||||
return $phrase;
|
||||
}
|
||||
|
||||
sub fortune_toggle_list () {
|
||||
unless (-d $dir) {
|
||||
make_path ($dir) || do {
|
||||
cluck "[ERROR] Unable to create $dir: $OS_ERROR";
|
||||
my @empty = ();
|
||||
return @empty;
|
||||
}
|
||||
}
|
||||
|
||||
my $backingfile = sprintf '%s/fortune_morning.sqlite', $dir;
|
||||
|
||||
tie my %toggle, 'SQLite_File', $backingfile || do {
|
||||
cluck "[ERROR] Unable to tie to $backingfile: $OS_ERROR";
|
||||
my @empty = ();
|
||||
return @empty;
|
||||
};
|
||||
|
||||
my @list = keys %toggle;
|
||||
untie %toggle;
|
||||
return @list;
|
||||
}
|
||||
|
||||
sub plugin_status (@) {
|
||||
my $chatid = shift;
|
||||
my $plugin = shift;
|
||||
my $phrase = "Плагин $plugin ";
|
||||
|
||||
unless (-d $dir) {
|
||||
make_path ($dir) || do {
|
||||
cluck "[ERROR] Unable to create $dir: $OS_ERROR";
|
||||
return;
|
||||
};
|
||||
}
|
||||
|
||||
my $backingfile = utf2sha1 $chatid;
|
||||
$backingfile =~ s/\//-/xmsg;
|
||||
$backingfile = sprintf '%s/%s.sqlite', $dir, $backingfile;
|
||||
|
||||
tie my %toggle, 'SQLite_File', $backingfile || do {
|
||||
cluck "[ERROR] Unable to tie to $backingfile: $OS_ERROR\n";
|
||||
return;
|
||||
};
|
||||
|
||||
my $state = $toggle{$plugin};
|
||||
untie %toggle;
|
||||
|
||||
if (defined $state && $state) {
|
||||
$phrase .= 'включён.';
|
||||
} else {
|
||||
$phrase .= 'выключен.';
|
||||
}
|
||||
|
||||
return $phrase;
|
||||
}
|
||||
|
||||
sub pluginEnabled (@) {
|
||||
my $chatid = shift;
|
||||
my $plugin = shift;
|
||||
|
||||
unless (-d $dir) {
|
||||
make_path ($dir) || do {
|
||||
cluck "[ERROR] Unable to create $dir: $OS_ERROR";
|
||||
return;
|
||||
};
|
||||
}
|
||||
|
||||
my $backingfile = utf2sha1 $chatid;
|
||||
$backingfile =~ s/\//-/xmsg;
|
||||
$backingfile = sprintf '%s/%s.sqlite', $dir, $backingfile;
|
||||
|
||||
tie my %toggle, 'SQLite_File', $backingfile || do {
|
||||
cluck "[ERROR] Unable to tie to $backingfile: $OS_ERROR\n";
|
||||
return;
|
||||
};
|
||||
|
||||
my $state = $toggle{$plugin};
|
||||
untie %toggle;
|
||||
|
||||
if (defined $state && $state) {
|
||||
return 1;
|
||||
} else {
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
||||
sub plugin_toggle (@) {
|
||||
my $chatid = shift;
|
||||
my $plugin = shift;
|
||||
my $action = shift // undef;
|
||||
my $phrase = "Плагин $plugin ";
|
||||
|
||||
unless (-d $dir) {
|
||||
make_path ($dir) || do {
|
||||
cluck "[ERROR] Unable to create $dir: $OS_ERROR";
|
||||
my @empty = ();
|
||||
return @empty;
|
||||
}
|
||||
}
|
||||
|
||||
my $backingfile = utf2sha1 $chatid;
|
||||
$backingfile =~ s/\//-/xmsg;
|
||||
$backingfile = sprintf '%s/%s.sqlite', $dir, $backingfile;
|
||||
|
||||
tie my %toggle, 'SQLite_File', $backingfile || do {
|
||||
cluck "[ERROR] Unable to tie to $backingfile: $OS_ERROR";
|
||||
my @empty = ();
|
||||
return @empty;
|
||||
};
|
||||
|
||||
if (defined $action) {
|
||||
if ($action) {
|
||||
$toggle{$plugin} = 1;
|
||||
$phrase .= 'включён';
|
||||
} else {
|
||||
$toggle{$plugin} = 0;
|
||||
$phrase .= 'выключен';
|
||||
}
|
||||
} else {
|
||||
if (defined ($toggle{$plugin}) && $toggle{$plugin}) {
|
||||
$toggle{$plugin} = 0;
|
||||
$phrase .= 'включён';
|
||||
} else {
|
||||
$toggle{$plugin} = 1;
|
||||
$phrase .= 'выключен';
|
||||
}
|
||||
}
|
||||
|
||||
untie %toggle;
|
||||
return $phrase;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
||||
126
lib/archeologist.pm
Normal file
126
lib/archeologist.pm
Normal file
@@ -0,0 +1,126 @@
|
||||
package archeologist;
|
||||
|
||||
use 5.018;
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
use open qw (:std :utf8);
|
||||
use English qw ( -no_match_vars );
|
||||
use Math::Random::Secure qw (irand);
|
||||
|
||||
use version; our $VERSION = qw (1.0);
|
||||
use Exporter qw (import);
|
||||
our @EXPORT_OK = qw (dig);
|
||||
|
||||
sub dig {
|
||||
my $name = shift;
|
||||
|
||||
my @artifact = (
|
||||
'амулет Мерлина',
|
||||
'библиотеку Ивана Грозного',
|
||||
'деревянную плошку',
|
||||
'диплока',
|
||||
'доски Ноева Ковчега',
|
||||
'древний презерватив из бараньей кишки',
|
||||
'икону',
|
||||
'инсталятор Windows 3.11',
|
||||
'истлевший гроб',
|
||||
'каменный топор',
|
||||
'клад со златом-серебром',
|
||||
'кривой нож',
|
||||
'ледяную глыбу',
|
||||
'лунный грунт',
|
||||
'мамонта',
|
||||
'мамонтёнка',
|
||||
'метеорит',
|
||||
'мумию фараона Тутанхамона',
|
||||
'носки прапорщика (поставит в угол)',
|
||||
'обломки грузинской керамики',
|
||||
'птеродактиля',
|
||||
'рубль с Лениным',
|
||||
'рыцарские доспехи',
|
||||
'синий мох',
|
||||
'скелет',
|
||||
'скелет собаки по кличке Беня',
|
||||
'тиранозавтра',
|
||||
'тотем индейцев',
|
||||
'трубу с туркменским газом',
|
||||
'скорбь еврейского народа',
|
||||
'залежи активированного угля',
|
||||
'не очень новый завет',
|
||||
'мать леннарта поттеринга',
|
||||
'руководство "начинающему археологу"',
|
||||
'слово о полку игореве и дело о полку игореве, вместе с игорем',
|
||||
'телепрограмму канала A-one',
|
||||
'могилу искателя могил',
|
||||
'заплесневевший кусок хлеба',
|
||||
'преемник радиоприемника',
|
||||
'глушитель от ВАЗ-2106',
|
||||
'чувство удовлетворения',
|
||||
'крота',
|
||||
'воспоминания о былой любви',
|
||||
'грязистор',
|
||||
'египетское мумиё',
|
||||
'окаменелый камень',
|
||||
'кладку яиц рептилоида',
|
||||
'яму',
|
||||
'чеснок и стрелы',
|
||||
'доллар по 30',
|
||||
'несмазанные скрижали',
|
||||
'четырелобита',
|
||||
'чучело тролля',
|
||||
'целое ничего',
|
||||
);
|
||||
|
||||
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";
|
||||
|
||||
if ($success_probability <= 25) {
|
||||
$phrase .= sprintf '%s стал лучшим археологом, выкопав %s! возраст артефакта - %s лет!', $name, $artifact[irand ($#artifact + 1)], $artifact_age;
|
||||
} else {
|
||||
$phrase .= sprintf "Поздравляю, %s! Вы только что выкопали %s, возраст - %s лет!\n", $name, $artifact[irand ($#artifact + 1)], $artifact_age;
|
||||
$phrase .= sprintf 'Извини, %s, но на артефакт это не тянет! Однако, попытка хорошая!', $name;
|
||||
}
|
||||
|
||||
return $phrase;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
||||
@@ -1,4 +1,4 @@
|
||||
package BotLib;
|
||||
package botlib;
|
||||
# store here utility functions that are not protocol-specified
|
||||
|
||||
use 5.018;
|
||||
@@ -10,34 +10,30 @@ use English qw ( -no_match_vars );
|
||||
use Carp qw (carp);
|
||||
use Math::Random::Secure qw (irand);
|
||||
|
||||
use BotLib::Conf qw (LoadConf);
|
||||
use BotLib::Admin qw (@ForbiddenMessageTypes GetForbiddenTypes AddForbiddenType
|
||||
DelForbiddenType ListForbidden FortuneToggle FortuneStatus
|
||||
PluginToggle PluginStatus PluginEnabled);
|
||||
use BotLib::Anek qw (Anek);
|
||||
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::Proverb qw (Proverb);
|
||||
use BotLib::Util qw (trim);
|
||||
use BotLib::Weather qw (Weather);
|
||||
use BotLib::Xkcd qw (Xkcd);
|
||||
use conf qw (loadConf);
|
||||
use admin qw (@forbiddenMessageTypes getForbiddenTypes addForbiddenType delForbiddenType listForbidden fortune_toggle fortune_status plugin_toggle plugin_status pluginEnabled);
|
||||
use archeologist qw (dig);
|
||||
use buni qw (buni);
|
||||
use drink qw (drink);
|
||||
use fisher qw (fish);
|
||||
use fortune qw (fortune);
|
||||
use friday qw (friday);
|
||||
use image qw (kitty fox oboobs obutts rabbit owl);
|
||||
use karma qw (karmaSet karmaGet);
|
||||
use lat qw (latAnswer);
|
||||
use monkeyuser qw (monkeyuse);
|
||||
use util qw (trim);
|
||||
use weather qw (weather);
|
||||
use xkcd qw (xkcd);
|
||||
|
||||
use version; our $VERSION = qw (1.0);
|
||||
use Exporter qw (import);
|
||||
our @EXPORT_OK = qw (RandomCommonPhrase Command Highlight BotSleep IsCensored);
|
||||
our @EXPORT_OK = qw (randomCommonPhrase command highlight botsleep isCensored);
|
||||
|
||||
my $c = LoadConf ();
|
||||
my $c = loadConf ();
|
||||
my $csign = $c->{telegrambot}->{csign};
|
||||
|
||||
sub RandomCommonPhrase {
|
||||
sub randomCommonPhrase {
|
||||
my @myphrase = (
|
||||
'Так, блядь...',
|
||||
'*Закатывает рукава* И ради этого ты меня позвал?',
|
||||
@@ -45,7 +41,7 @@ sub RandomCommonPhrase {
|
||||
'Повтори свой вопрос, не поняла',
|
||||
'Выйди и зайди нормально',
|
||||
'Я подумаю',
|
||||
'Даже не знаю, что на это ответить',
|
||||
'Даже не знаю что на это ответить',
|
||||
'Ты упал такие вопросы девочке задавать?',
|
||||
'Можно и так, но не уверена',
|
||||
'А как ты думаешь?',
|
||||
@@ -55,13 +51,13 @@ sub RandomCommonPhrase {
|
||||
return $myphrase[irand ($#myphrase + 1)];
|
||||
}
|
||||
|
||||
sub Command {
|
||||
sub command {
|
||||
my $self = shift;
|
||||
my $msg = shift;
|
||||
my $text = shift;
|
||||
my $chatid = shift;
|
||||
my $reply;
|
||||
my ($userid, $username, $fullname, $highlight, $visavi) = Highlight ($msg);
|
||||
my ($userid, $username, $fullname, $highlight, $visavi) = highlight ($msg);
|
||||
|
||||
if (substr ($text, 1) eq 'ping') {
|
||||
$reply = 'Pong.';
|
||||
@@ -71,81 +67,31 @@ sub Command {
|
||||
$reply = 'Wat?';
|
||||
} elsif (substr ($text, 1) eq 'понг') {
|
||||
$reply = 'Шта?';
|
||||
} elsif (substr ($text, 1) eq 'coin' || substr ($text, 1) eq 'монетка') {
|
||||
if (rand (101) < 0.016) {
|
||||
$reply = 'ребро';
|
||||
} else {
|
||||
if (irand (2) == 0) {
|
||||
if (irand (2) == 0) {
|
||||
$reply = 'орёл';
|
||||
} else {
|
||||
$reply = 'аверс';
|
||||
}
|
||||
} else {
|
||||
if (irand (2) == 0) {
|
||||
$reply = 'решка';
|
||||
} else {
|
||||
$reply = 'реверс';
|
||||
}
|
||||
}
|
||||
}
|
||||
} elsif (substr ($text, 1) eq 'roll' || substr ($text, 1) eq 'dice' || substr ($text, 1) eq 'кости') {
|
||||
$reply = sprintf 'На первой кости выпало %d, а на второй — %d.', irand (6) + 1, irand (6) + 1;
|
||||
} elsif (substr ($text, 1) eq 'ver' || substr ($text, 1) eq 'version' || substr ($text, 1) eq 'версия') {
|
||||
$reply = 'Версия: Три.Чего-то_там.С_мелочью';
|
||||
} elsif (substr ($text, 1) eq 'anek' || substr ($text, 1) eq 'анек' || substr ($text, 1) eq 'анекдот') {
|
||||
$msg->typing ();
|
||||
$reply = "```\n" . Anek () . "\n```";
|
||||
sleep (irand (2) + 1);
|
||||
$msg->replyMd ($reply);
|
||||
return;
|
||||
$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, 7) eq 'погода ') {
|
||||
my $city = substr $text, 7;
|
||||
$reply = Weather $city;
|
||||
} elsif ((substr ($text, 1, 8) eq 'погодка ') || (substr ($text, 1, 8) eq 'погадка ') || (substr ($text, 1, 8) eq 'weather ')){
|
||||
my $city = substr $text, 8;
|
||||
$reply = Weather $city;
|
||||
$reply = weather $city;
|
||||
} elsif (substr ($text, 1) eq 'buni') {
|
||||
$msg->typing ();
|
||||
$reply = Buni ();
|
||||
$reply = buni ();
|
||||
sleep (irand (2) + 1);
|
||||
$msg->replyMd ($reply);
|
||||
return;
|
||||
} elsif (substr ($text, 1) eq 'monkeyuser') {
|
||||
$msg->typing ();
|
||||
$reply = Monkeyuser ();
|
||||
$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 ();
|
||||
$reply = kitty ();
|
||||
sleep (irand (2) + 1);
|
||||
$msg->replyMd ($reply);
|
||||
return;
|
||||
} elsif (substr ($text, 1) eq 'lat' || substr ($text, 1) eq 'лат') {
|
||||
$reply = Lat ();
|
||||
$reply = latAnswer ();
|
||||
} elsif (
|
||||
(length ($text) >= 6 && (substr ($text, 1, 6) eq 'karma ' || substr ($text, 1, 6) eq 'карма ')) ||
|
||||
substr ($text, 1) eq 'karma' || substr ($text, 1) eq 'карма'
|
||||
@@ -160,40 +106,40 @@ sub Command {
|
||||
$mytext = '';
|
||||
}
|
||||
|
||||
$reply = KarmaGet ($chatid, $mytext);
|
||||
$reply = karmaGet ($chatid, $mytext);
|
||||
} elsif (substr ($text, 1) eq 'xkcd') {
|
||||
$msg->typing ();
|
||||
$reply = Xkcd ();
|
||||
$reply = xkcd ();
|
||||
sleep (irand (2) + 1);
|
||||
$msg->replyMd ($reply);
|
||||
return;
|
||||
} elsif (substr ($text, 1) eq 'fox' || substr ($text, 1) eq 'лис') {
|
||||
$msg->typing ();
|
||||
$reply = Fox ();
|
||||
$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 ();
|
||||
$reply = rabbit ();
|
||||
$msg->replyMd ($reply);
|
||||
return;
|
||||
} elsif (substr ($text, 1) eq 'owl' || substr ($text, 1) eq 'сова') {
|
||||
$msg->typing ();
|
||||
$reply = Owl ();
|
||||
$reply = owl ();
|
||||
$msg->replyMd ($reply);
|
||||
return;
|
||||
} elsif (
|
||||
substr ($text, 1) eq 'tits' ||
|
||||
substr ($text, 1) eq 'boobs' ||
|
||||
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 'boobies' ||
|
||||
substr ($text, 1) eq 'сиси' ||
|
||||
substr ($text, 1) eq 'сисечки'
|
||||
) {
|
||||
if (PluginEnabled $chatid, 'oboobs') {
|
||||
if (pluginEnabled $chatid, 'oboobs') {
|
||||
$msg->typing ();
|
||||
$reply = Oboobs ();
|
||||
$reply = oboobs ();
|
||||
sleep (irand (2) + 1);
|
||||
$msg->replyMd ($reply);
|
||||
}
|
||||
@@ -201,63 +147,48 @@ sub Command {
|
||||
return;
|
||||
} elsif (
|
||||
substr ($text, 1) eq 'butt' ||
|
||||
substr ($text, 1) eq 'booty' ||
|
||||
substr ($text, 1) eq 'ass' ||
|
||||
substr ($text, 1) eq 'booty' ||
|
||||
substr ($text, 1) eq 'ass' ||
|
||||
substr ($text, 1) eq 'попа' ||
|
||||
substr ($text, 1) eq 'попка'
|
||||
) {
|
||||
if (PluginEnabled $chatid, 'obutts') {
|
||||
if (pluginEnabled $chatid, 'obutts') {
|
||||
$msg->typing ();
|
||||
$reply = Obutts ();
|
||||
$reply = obutts ();
|
||||
sleep (irand (2) + 1);
|
||||
$msg->replyMd ($reply);
|
||||
}
|
||||
|
||||
return;
|
||||
} elsif (substr ($text, 1) eq 'friday' || substr ($text, 1) eq 'пятница') {
|
||||
$reply = Friday ();
|
||||
} elsif (substr ($text, 1) eq 'proverb' || substr ($text, 1) eq 'пословица') {
|
||||
$reply = Proverb ();
|
||||
$reply = friday ();
|
||||
} elsif (substr ($text, 1) eq 'fortune' || substr ($text, 1) eq 'фортунка' || substr ($text, 1) eq 'f' || substr ($text, 1) eq 'ф') {
|
||||
$reply = sprintf "```\n%s\n```\n", trim (Fortune ());
|
||||
$reply = sprintf "```\n%s\n```\n", trim (fortune ());
|
||||
$msg->replyMd ($reply);
|
||||
return;
|
||||
} elsif (substr ($text, 1) eq 'drink' || substr ($text, 1) eq 'праздник') {
|
||||
$msg->typing ();
|
||||
$reply = Drink ();
|
||||
$reply = drink ();
|
||||
sleep (irand (2) + 1);
|
||||
} elsif (substr ($text, 1) eq 'dig' || substr ($text, 1) eq 'копать') {
|
||||
$msg->typing ();
|
||||
$reply = Dig $highlight;
|
||||
$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;
|
||||
$reply = fish $highlight;
|
||||
sleep (irand (2) + 1);
|
||||
$msg->replyMd ($reply);
|
||||
return;
|
||||
} elsif (substr ($text, 1) eq 'хэлп' || substr ($text, 1) eq 'halp') {
|
||||
$reply = 'HALP!!!11';
|
||||
} elsif (substr ($text, 1) eq 'kde' || substr ($text, 1) eq 'кде') {
|
||||
my @phrases = (
|
||||
'Нет, я не буду поднимать вам плазму.',
|
||||
'Повторяйте эту мантру по утрам не менее 5 раз: "Плазма не падает." И, возможно, она перестанет у вас падать.',
|
||||
'Плазма не падает, она просто выходит отдохнуть.',
|
||||
'Плазма это не агрегатное состояние, это суперпозиция. Во время работы она находится сразу в жидком, мягком и тёплом состояниях.',
|
||||
);
|
||||
|
||||
$reply = $phrases[irand ($#phrases + 1)];
|
||||
} elsif (substr ($text, 1) eq 'help' || substr ($text, 1) eq 'помощь') {
|
||||
$reply = << "MYHELP";
|
||||
```
|
||||
${csign}help | ${csign}помощь - список команд
|
||||
${csign}anek | ${csign}анек | ${csign}анекдот - рандомный анекдот с anekdot.ru
|
||||
${csign}buni - рандомный стрип hapi buni
|
||||
${csign}bunny | ${csign}rabbit | ${csign}кролик - кролик
|
||||
${csign}cat | ${csign}кис - кошечка
|
||||
${csign}coin | ${csign}монетка - подбросить монетку - орёл или решка?
|
||||
${csign}dig | ${csign}копать - заняться археологией
|
||||
${csign}drink | ${csign}праздник - какой сегодня праздник?
|
||||
${csign}fish | ${csign}рыба | ${csign}рыбка - порыбачить
|
||||
@@ -266,21 +197,12 @@ ${csign}f | ${csign}ф - рандомная фраза из
|
||||
${csign}fortune | ${csign}фортунка - рандомная фраза из сборника цитат fortune_mod
|
||||
${csign}fox | ${csign}лис - лисичка
|
||||
${csign}friday | ${csign}пятница - а не пятница ли сегодня?
|
||||
${csign}frog | ${csign}лягушка - лягушка
|
||||
${csign}horse | ${csign}лошадка - лошадка
|
||||
${csign}lat | ${csign}лат - сгенерить фразу из крылатых латинских выражений
|
||||
${csign}monkeyuser - рандомный стрип MonkeyUser
|
||||
${csign}owl | ${csign}сова - сова
|
||||
${csign}proverb | ${csign}пословица - рандомная русская пословица
|
||||
${csign}ping | ${csign}пинг - попинговать бота
|
||||
${csign}roll | ${csign}dice | ${csign}кости - бросить кости
|
||||
${csign}snail | ${csign}улитка - улитка
|
||||
${csign}ver | ${csign}version | ${csign}версия - что-то про версию ПО
|
||||
${csign}w город | ${csign}п город - погода в указанном городе
|
||||
${csign}weather город - погода в указанном городе
|
||||
${csign}погода город - погода в указанном городе
|
||||
${csign}погодка город - погода в указанном городе
|
||||
${csign}погадка город - погода в указанном городе
|
||||
${csign}xkcd - рандомный стрип с сайта xkcd.ru
|
||||
${csign}karma фраза | ${csign}карма фраза - посмотреть карму фразы
|
||||
фраза-- | фраза++ - убавить или добавить карму фразе
|
||||
@@ -333,50 +255,50 @@ MYADMIN
|
||||
my ($msgType, $toggle) = split /\s/, $args, 2;
|
||||
|
||||
if (defined $toggle) {
|
||||
foreach (@ForbiddenMessageTypes) {
|
||||
foreach (@forbiddenMessageTypes) {
|
||||
if ($msgType eq $_) {
|
||||
if ($toggle == 1) {
|
||||
AddForbiddenType ($chatid, $msgType);
|
||||
addForbiddenType ($chatid, $msgType);
|
||||
$reply = "Теперь сообщения с $msgType будут автоматически удаляться";
|
||||
} elsif ($toggle == 0) {
|
||||
DelForbiddenType ($chatid, $msgType);
|
||||
delForbiddenType ($chatid, $msgType);
|
||||
$reply = "Теперь сообщения с $msgType будут оставаться";
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
} else {
|
||||
$reply = ListForbidden ($chatid);
|
||||
$reply = listForbidden ($chatid);
|
||||
}
|
||||
} elsif ($cmd eq 'fortune' || $cmd eq 'фортунка') {
|
||||
if (defined $args) {
|
||||
if ($args == 1) {
|
||||
$reply = FortuneToggle ($chatid, 1);
|
||||
$reply = fortune_toggle ($chatid, 1);
|
||||
} elsif ($args == 0) {
|
||||
$reply = FortuneToggle ($chatid, 0);
|
||||
$reply = fortune_toggle ($chatid, 0);
|
||||
}
|
||||
} else {
|
||||
$reply = FortuneStatus ($chatid);
|
||||
$reply = fortune_status ($chatid);
|
||||
}
|
||||
} elsif ($cmd eq 'oboobs') {
|
||||
if (defined $args) {
|
||||
if ($args == 1) {
|
||||
$reply = PluginToggle ($chatid, 'oboobs', 1);
|
||||
$reply = plugin_toggle ($chatid, 'oboobs', 1);
|
||||
} elsif ($args == 0) {
|
||||
$reply = PluginToggle ($chatid, 'oboobs', 0);
|
||||
$reply = plugin_toggle ($chatid, 'oboobs', 0);
|
||||
}
|
||||
} else {
|
||||
$reply = PluginStatus ($chatid, 'oboobs');
|
||||
$reply = plugin_status ($chatid, 'oboobs');
|
||||
}
|
||||
} elsif ($cmd eq 'obutts') {
|
||||
if (defined $args) {
|
||||
if ($args == 1) {
|
||||
$reply = PluginToggle ($chatid, 'obutts', 1);
|
||||
$reply = plugin_toggle ($chatid, 'obutts', 1);
|
||||
} elsif ($args == 0) {
|
||||
$reply = PluginToggle ($chatid, 'obutts', 0);
|
||||
$reply = plugin_toggle ($chatid, 'obutts', 0);
|
||||
}
|
||||
} else {
|
||||
$reply = PluginStatus ($chatid, 'obutts');
|
||||
$reply = plugin_status ($chatid, 'obutts');
|
||||
}
|
||||
}
|
||||
}
|
||||
@@ -385,7 +307,7 @@ MYADMIN
|
||||
return $reply;
|
||||
}
|
||||
|
||||
sub Highlight {
|
||||
sub highlight {
|
||||
my $msg = shift;
|
||||
|
||||
my $fullname;
|
||||
@@ -427,7 +349,7 @@ sub Highlight {
|
||||
return ($userid, $username, $fullname, $highlight, $visavi);
|
||||
}
|
||||
|
||||
sub BotSleep {
|
||||
sub botsleep {
|
||||
# TODO: Parametrise this with fuzzy sleep time in seconds
|
||||
my $msg = shift;
|
||||
# let's emulate real human and delay answer
|
||||
@@ -443,10 +365,10 @@ sub BotSleep {
|
||||
return;
|
||||
}
|
||||
|
||||
sub IsCensored {
|
||||
sub isCensored {
|
||||
my $msg = shift;
|
||||
|
||||
my $forbidden = GetForbiddenTypes ($msg->chat->id);
|
||||
my $forbidden = getForbiddenTypes ($msg->chat->id);
|
||||
|
||||
# voice messages are special
|
||||
if (defined ($msg->voice) && defined ($msg->voice->duration) && ($msg->voice->duration > 0)) {
|
||||
@@ -1,4 +1,4 @@
|
||||
package BotLib::Buni;
|
||||
package buni;
|
||||
|
||||
use 5.018;
|
||||
use strict;
|
||||
@@ -8,20 +8,18 @@ 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);
|
||||
our @EXPORT_OK = qw (buni);
|
||||
|
||||
sub 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) {
|
||||
@@ -49,7 +47,7 @@ sub Buni {
|
||||
} while ($#{$a[0]} > 1);
|
||||
}
|
||||
} else {
|
||||
$log->warn (sprintf '[WARN] Bunicomic server return status %s with message: %s', $r->code, $r->message);
|
||||
cluck sprintf 'Server return status %s with message: %s', $r->code, $r->message;
|
||||
}
|
||||
|
||||
return $ret;
|
||||
@@ -1,4 +1,4 @@
|
||||
package BotLib::Conf;
|
||||
package conf;
|
||||
# loads config
|
||||
|
||||
use 5.018;
|
||||
@@ -11,9 +11,9 @@ use JSON::XS;
|
||||
|
||||
use version; our $VERSION = qw (1.0);
|
||||
use Exporter qw (import);
|
||||
our @EXPORT_OK = qw (LoadConf);
|
||||
our @EXPORT_OK = qw (loadConf);
|
||||
|
||||
sub LoadConf {
|
||||
sub loadConf {
|
||||
my $c = 'data/config.json';
|
||||
open my $CH, '<', $c or die "[FATAL] No conf at $c: $OS_ERROR\n";
|
||||
my $len = (stat $c) [7];
|
||||
@@ -1,4 +1,4 @@
|
||||
package BotLib::Drink;
|
||||
package drink;
|
||||
|
||||
use 5.018;
|
||||
use strict;
|
||||
@@ -12,21 +12,17 @@ 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);
|
||||
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 {
|
||||
sub drink {
|
||||
my $r;
|
||||
my $ret = 'Не знаю праздников - вджобываю весь день на шахтах, как проклятая.';
|
||||
my ($dayNum, $monthNum) = (localtime ())[3, 4];
|
||||
@@ -63,7 +59,7 @@ sub Drink {
|
||||
$ua->cache_agent(
|
||||
CHI->new (
|
||||
driver => 'BerkeleyDB',
|
||||
root_dir => $cachedir,
|
||||
root_dir => 'data/cache',
|
||||
namespace => __PACKAGE__,
|
||||
expires_at => $expirationDate,
|
||||
expires_on_backend => 1,
|
||||
@@ -104,7 +100,7 @@ sub Drink {
|
||||
$ret = join "\n", @holyday;
|
||||
}
|
||||
} else {
|
||||
$log->warn (sprintf '[WARN] Kakoysegodnyaprazdnik server return status %s with message: %s', $r->code, $r->message);
|
||||
cluck sprintf 'Server return status %s with message: %s', $r->code, $r->message;
|
||||
}
|
||||
|
||||
return $ret;
|
||||
@@ -1,4 +1,4 @@
|
||||
package BotLib::Fisher;
|
||||
package fisher;
|
||||
|
||||
use 5.018;
|
||||
use strict;
|
||||
@@ -6,54 +6,66 @@ 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;
|
||||
our @EXPORT_OK = qw (fish);
|
||||
|
||||
|
||||
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 {
|
||||
sub fish {
|
||||
my $name = shift;
|
||||
|
||||
my @artifact = (
|
||||
'семикрылого чешуйчатого пятихуя',
|
||||
'разумного конденсатора',
|
||||
'сальмонеллу',
|
||||
'селёдку',
|
||||
'желтоперого тунца',
|
||||
'розовую сальмонеллу',
|
||||
'голавля',
|
||||
'барбуса',
|
||||
'окуня',
|
||||
'верхоплавку',
|
||||
'коричневую форель',
|
||||
'полярника',
|
||||
'плотву',
|
||||
'зубатку',
|
||||
'солнечную рыбу',
|
||||
'старую шину',
|
||||
'скользкую корягу',
|
||||
'лампу джина',
|
||||
'любовное послание в бутылке',
|
||||
'старое бревно',
|
||||
'резиновый сапог',
|
||||
'труп',
|
||||
'Лох-Несское чудовище',
|
||||
'старую рыбацкую приманку',
|
||||
'кусок Титаника',
|
||||
'обломок Атлантиды',
|
||||
'кита',
|
||||
'кальмара',
|
||||
'дельфина',
|
||||
'ската',
|
||||
'подводную лодку',
|
||||
'медузу',
|
||||
'морскую звезду',
|
||||
'электрического угря',
|
||||
'большую белую акулу',
|
||||
'аквалангиста',
|
||||
'монстра',
|
||||
'вируса',
|
||||
'сырую пачку сигарет',
|
||||
'водоросли',
|
||||
'якорь от лодки',
|
||||
'водяного',
|
||||
'русалку',
|
||||
'палтуса',
|
||||
'труп собаки по кличке Беня',
|
||||
'олигофрена Проню',
|
||||
'огеймера Фишкина',
|
||||
);
|
||||
|
||||
my @location = (
|
||||
'в поток',
|
||||
'в озеро',
|
||||
@@ -105,8 +117,7 @@ sub Fish {
|
||||
return $phrase;
|
||||
}
|
||||
|
||||
my $artifact = getRandomArtifact ();
|
||||
$phrase .= sprintf "Поздравляю, %s! Вы только что поймали %s! аж на %d кило!\n\n", $name, $artifact, $weight;
|
||||
$phrase .= sprintf "Поздравляю, %s! Вы только что поймали %s! аж на %d кило!\n\n", $name, $artifact[irand ($#artifact + 1)], $weight;
|
||||
|
||||
if ($success_probability <= 25) {
|
||||
$phrase .= sprintf 'Ё-мое!!! А это ведь новый рекорд! Продолжай в том же духе, %s!', $name;
|
||||
@@ -1,4 +1,4 @@
|
||||
package BotLib::Image::Flickr;
|
||||
package flickr;
|
||||
|
||||
use 5.018;
|
||||
use strict;
|
||||
@@ -7,26 +7,25 @@ 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 File::Path qw (make_path);
|
||||
use Math::Random::Secure qw (irand);
|
||||
use MIME::Base64;
|
||||
use Mojo::UserAgent;
|
||||
use SQLite_File;
|
||||
use URI::Encode::XS qw (uri_encode);
|
||||
|
||||
use BotLib::Conf qw (LoadConf);
|
||||
use BotLib::Util qw (urlencode);
|
||||
use conf qw (loadConf);
|
||||
use 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);
|
||||
our @EXPORT_OK = qw (flickr_init flickr_by_tags flickr_by_text flickr_test_login);
|
||||
|
||||
my $c = LoadConf ();
|
||||
my $cachedir = $c->{cachedir};
|
||||
my $c = loadConf ();
|
||||
my $dir = $c->{image}->{dir};
|
||||
|
||||
my $flickr_consumer_key = $c->{image}->{flickr}->{consumer_key};
|
||||
my $flickr_consumer_secret = $c->{image}->{flickr}->{consumer_secret};
|
||||
@@ -186,10 +185,10 @@ sub flickrAuthorization {
|
||||
my $ua = Mojo::UserAgent->new->connect_timeout (5);
|
||||
my $r = $ua->get ($url)->result;
|
||||
|
||||
if ($r->code == 302) {
|
||||
return $r->content->headers->location;
|
||||
if ($r->is_success) {
|
||||
return $r->url;
|
||||
} else {
|
||||
printf "Something went wrong: %s %s\n", $r->code, $r->message;
|
||||
say "Something went wrong: $r->code $r->message"; ## no critic (InputOutput::RequireCheckedSyscalls)
|
||||
return;
|
||||
}
|
||||
}
|
||||
@@ -336,19 +335,19 @@ sub flickrSearchByText {
|
||||
if (defined $response) {
|
||||
return $response;
|
||||
} else {
|
||||
$log->warn ("[WARN] Flickr api returns incorrect json: $r->message");
|
||||
cluck "Flickr api returns incorrect json: $r->message";
|
||||
return undef;
|
||||
}
|
||||
} else {
|
||||
$log->warn ("[WARN] Flickr api returns incorrect json: $r->message");
|
||||
cluck "Flickr api returns incorrect json: $r->message";
|
||||
return undef;
|
||||
}
|
||||
} else {
|
||||
$log->warn ("[WARN] Flickr api returns incorrect json: $r->message");
|
||||
cluck "Flickr api returns incorrect json: $r->message";
|
||||
return undef;
|
||||
}
|
||||
} else {
|
||||
$log->warn ("[WARN] Flickr api HTTP status code not 200: $r->code, $r->message");
|
||||
cluck "HTTP status code not 200: $r->code, $r->message";
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
@@ -443,85 +442,105 @@ sub flickrSearchByTags {
|
||||
if (defined $response) {
|
||||
return $response;
|
||||
} else {
|
||||
$log->warn ("[WARN] Flickr api returns incorrect json: $r->message");
|
||||
cluck "Flickr api returns incorrect json: $r->message";
|
||||
return undef;
|
||||
}
|
||||
} else {
|
||||
$log->warn ("[WARN] Flickr api returns incorrect json: $r->message");
|
||||
cluck "Flickr api returns incorrect json: $r->message";
|
||||
return undef;
|
||||
}
|
||||
} else {
|
||||
$log->warn ("[WARN] Flickr api returns incorrect json: $r->message");
|
||||
cluck "Flickr api returns incorrect json: $r->message";
|
||||
return undef;
|
||||
}
|
||||
} else {
|
||||
$log->warn ("[WARN] Flickr api HTTP status code not 200: $r->code, $r->message");
|
||||
cluck "HTTP status code not 200: $r->code, $r->message";
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
sub FlickrInit {
|
||||
my $cache = CHI->new (
|
||||
driver => 'BerkeleyDB',
|
||||
root_dir => $cachedir,
|
||||
namespace => __PACKAGE__
|
||||
);
|
||||
sub flickr_init {
|
||||
my $backingfile = sprintf '%s/secrets.sqlite', $dir;
|
||||
|
||||
unless (-d $dir) {
|
||||
make_path ($dir) or do {
|
||||
say "Unable to create $dir: $OS_ERROR"; ## no critic (InputOutput::RequireCheckedSyscalls)
|
||||
return 0;
|
||||
};
|
||||
}
|
||||
|
||||
tie my %secret, 'SQLite_File', $backingfile || do {
|
||||
say "[ERROR] Unable to tie to $backingfile: $OS_ERROR"; ## no critic (InputOutput::RequireCheckedSyscalls)
|
||||
return 0;
|
||||
};
|
||||
|
||||
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');
|
||||
my $flickr_request_token = $secret{flickr_request_token};
|
||||
my $flickr_request_token_secret = $secret{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)
|
||||
say "Looks like there is no request token or request token secret in $backingfile"; ## no critic (InputOutput::RequireCheckedSyscalls)
|
||||
say 'Please remove verifier settings from config.json and run this script again'; ## no critic (InputOutput::RequireCheckedSyscalls)
|
||||
untie %secret;
|
||||
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');
|
||||
$secret{flickr_access_token} = $accessToken{oauth_token};
|
||||
$secret{flickr_access_token_secret} = $accessToken{oauth_token_secret};
|
||||
|
||||
say sprintf ( ## no critic (InputOutput::RequireCheckedSyscalls)
|
||||
'Access token (%s) and access token secret (%s) are config db',
|
||||
'Access token (%s) and access token secret (%s) are in %s',
|
||||
$accessToken{oauth_token},
|
||||
$accessToken{oauth_token_secret},
|
||||
$backingfile
|
||||
);
|
||||
|
||||
untie %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');
|
||||
$secret{flickr_request_token} = $req{oauth_token};
|
||||
$secret{flickr_request_token_secret} = $req{oauth_token_secret};
|
||||
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)
|
||||
untie %secret;
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
untie %secret;
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub FlickrTestLogin {
|
||||
sub flickr_test_login {
|
||||
my $text = shift;
|
||||
my $cache = CHI->new (
|
||||
driver => 'BerkeleyDB',
|
||||
root_dir => $cachedir,
|
||||
namespace => __PACKAGE__
|
||||
);
|
||||
my $backingfile = sprintf '%s/secrets.sqlite', $dir;
|
||||
|
||||
my $flickr_access_token = $cache->get ('flickr_access_token');
|
||||
my $flickr_access_token_secret = $cache->get ('flickr_access_token_secret');
|
||||
unless (-d $dir) {
|
||||
make_path ($dir) or do {
|
||||
say "Unable to create $dir: $OS_ERROR"; ## no critic (InputOutput::RequireCheckedSyscalls)
|
||||
return 0;
|
||||
};
|
||||
}
|
||||
|
||||
tie my %secret, 'SQLite_File', $backingfile || do {
|
||||
say "[ERROR] Unable to tie to $backingfile: $OS_ERROR"; ## no critic (InputOutput::RequireCheckedSyscalls)
|
||||
return 0;
|
||||
};
|
||||
|
||||
my $flickr_access_token = $secret{flickr_access_token};
|
||||
my $flickr_access_token_secret = $secret{flickr_access_token_secret};
|
||||
untie %secret;
|
||||
|
||||
if (flickrTestLogin ($flickr_access_token, $flickr_access_token_secret)) {
|
||||
return 1;
|
||||
@@ -530,17 +549,25 @@ sub FlickrTestLogin {
|
||||
}
|
||||
}
|
||||
|
||||
sub FlickrByTags {
|
||||
sub flickr_by_tags {
|
||||
my $text = shift;
|
||||
my $backingfile = sprintf '%s/secrets.sqlite', $dir;
|
||||
|
||||
my $cache = CHI->new (
|
||||
driver => 'BerkeleyDB',
|
||||
root_dir => $cachedir,
|
||||
namespace => __PACKAGE__
|
||||
);
|
||||
unless (-d $dir) {
|
||||
make_path ($dir) or do {
|
||||
say "Unable to create $dir: $OS_ERROR"; ## no critic (InputOutput::RequireCheckedSyscalls)
|
||||
return 0;
|
||||
};
|
||||
}
|
||||
|
||||
my $flickr_access_token = $cache->get ('flickr_access_token');
|
||||
my $flickr_access_token_secret = $cache->get ('flickr_access_token_secret');
|
||||
tie my %secret, 'SQLite_File', $backingfile || do {
|
||||
say "[ERROR] Unable to tie to $backingfile: $OS_ERROR"; ## no critic (InputOutput::RequireCheckedSyscalls)
|
||||
return 0;
|
||||
};
|
||||
|
||||
my $flickr_access_token = $secret{flickr_access_token};
|
||||
my $flickr_access_token_secret = $secret{flickr_access_token_secret};
|
||||
untie %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
|
||||
@@ -555,7 +582,7 @@ sub FlickrByTags {
|
||||
$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');
|
||||
cluck 'Flickr api returns empty search result list';
|
||||
return;
|
||||
}
|
||||
} else {
|
||||
@@ -563,17 +590,25 @@ sub FlickrByTags {
|
||||
}
|
||||
}
|
||||
|
||||
sub FlickrByText {
|
||||
sub flickr_by_text {
|
||||
my $text = shift;
|
||||
my $backingfile = sprintf '%s/secrets.sqlite', $dir;
|
||||
|
||||
my $cache = CHI->new (
|
||||
driver => 'BerkeleyDB',
|
||||
root_dir => $cachedir,
|
||||
namespace => __PACKAGE__
|
||||
);
|
||||
unless (-d $dir) {
|
||||
make_path ($dir) or do {
|
||||
say "Unable to create $dir: $OS_ERROR"; ## no critic (InputOutput::RequireCheckedSyscalls)
|
||||
return 0;
|
||||
};
|
||||
}
|
||||
|
||||
my $flickr_access_token = $cache->get ('flickr_access_token');
|
||||
my $flickr_access_token_secret = $cache->get ('flickr_access_token_secret');
|
||||
tie my %secret, 'SQLite_File', $backingfile || do {
|
||||
say "[ERROR] Unable to tie to $backingfile: $OS_ERROR"; ## no critic (InputOutput::RequireCheckedSyscalls)
|
||||
return 0;
|
||||
};
|
||||
|
||||
my $flickr_access_token = $secret{flickr_access_token};
|
||||
my $flickr_access_token_secret = $secret{flickr_access_token_secret};
|
||||
untie %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
|
||||
@@ -588,7 +623,7 @@ sub FlickrByText {
|
||||
$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');
|
||||
cluck 'Flickr api returns empty search result list';
|
||||
return;
|
||||
}
|
||||
} else {
|
||||
@@ -1,4 +1,4 @@
|
||||
package BotLib::Fortune;
|
||||
package fortune;
|
||||
# Any fortune_mod sources are suitable. Text file with "\n%\n" sentence delimeter.
|
||||
|
||||
use 5.018;
|
||||
@@ -9,20 +9,19 @@ 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 conf qw (loadConf);
|
||||
|
||||
use version; our $VERSION = qw (1.0);
|
||||
use Exporter qw (import);
|
||||
our @EXPORT_OK = qw (Seed Fortune);
|
||||
our @EXPORT_OK = qw (seed fortune);
|
||||
|
||||
my $c = LoadConf ();
|
||||
my $c = loadConf ();
|
||||
my $dir = $c->{fortune}->{dir};
|
||||
my $srcdir = $c->{fortune}->{srcdir};
|
||||
|
||||
sub Seed () {
|
||||
sub seed () {
|
||||
unless (-d $dir) {
|
||||
make_path ($dir) || croak "Unable to create $dir: $OS_ERROR";
|
||||
}
|
||||
@@ -66,11 +65,11 @@ sub Seed () {
|
||||
}
|
||||
|
||||
# just return answer
|
||||
sub Fortune () {
|
||||
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");
|
||||
cluck "[ERROR] Unable to tie to $backingfile: $OS_ERROR";
|
||||
return '';
|
||||
};
|
||||
|
||||
@@ -1,4 +1,4 @@
|
||||
package BotLib::Friday;
|
||||
package friday;
|
||||
# for friday data stolen from https://raw.githubusercontent.com/isida/vi/master/data/friday.txt
|
||||
|
||||
use 5.018;
|
||||
@@ -9,21 +9,20 @@ 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 conf qw (loadConf);
|
||||
|
||||
use version; our $VERSION = qw (1.0);
|
||||
use Exporter qw (import);
|
||||
our @EXPORT_OK = qw (Seed Friday);
|
||||
our @EXPORT_OK = qw (seed friday);
|
||||
|
||||
my $c = LoadConf ();
|
||||
my $c = loadConf ();
|
||||
my $dir = $c->{friday}->{dir};
|
||||
my $srcfile = $c->{friday}->{src};
|
||||
my @dow = qw (monday tuesday wednesday thursday friday saturday sunday);
|
||||
|
||||
sub Seed () {
|
||||
sub seed () {
|
||||
unless (-d $dir) {
|
||||
make_path ($dir) || croak "Unable to create $dir: $OS_ERROR";
|
||||
}
|
||||
@@ -76,12 +75,12 @@ sub Seed () {
|
||||
}
|
||||
|
||||
# just return answer
|
||||
sub Friday () {
|
||||
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");
|
||||
cluck "[ERROR] Unable to tie to $backingfile: $OS_ERROR\n";
|
||||
return '';
|
||||
};
|
||||
|
||||
@@ -1,4 +1,4 @@
|
||||
package BotLib::Image;
|
||||
package image;
|
||||
|
||||
use 5.018;
|
||||
use strict;
|
||||
@@ -7,18 +7,23 @@ use utf8;
|
||||
use open qw (:std :utf8);
|
||||
use English qw ( -no_match_vars );
|
||||
use Carp qw (cluck);
|
||||
use Log::Any qw ($log);
|
||||
use File::Path qw (make_path);
|
||||
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 SQLite_File;
|
||||
use conf qw (loadConf);
|
||||
use flickr qw (flickr_by_tags);
|
||||
use imgur qw (imgur);
|
||||
use 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);
|
||||
our @EXPORT_OK = qw (kitty fox oboobs obutts rabbit owl);
|
||||
|
||||
sub Kitty {
|
||||
my $c = loadConf ();
|
||||
my $dir = $c->{image}->{dir};
|
||||
|
||||
sub kitty {
|
||||
my $r;
|
||||
my $ret = 'Нету кошечек, все разбежались.';
|
||||
|
||||
@@ -39,21 +44,21 @@ sub Kitty {
|
||||
};
|
||||
|
||||
unless (defined $jcat) {
|
||||
$log->warn ("[WARN] Unable to decode JSON from thecatapi: $EVAL_ERROR");
|
||||
cluck "[ERROR] Unable to decode JSON: $EVAL_ERROR";
|
||||
} else {
|
||||
if ($jcat->[0]->{url}) {
|
||||
my @cats = ('龴ↀ◡ↀ龴', '=^..^=', '≧◔◡◔≦ ','^ↀᴥↀ^');
|
||||
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);
|
||||
cluck sprintf 'Server return status %s with message: %s', $r->code, $r->message;
|
||||
}
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub Fox {
|
||||
sub fox {
|
||||
my $r;
|
||||
my $ret = 'Нету лисичек, все разбежались.';
|
||||
|
||||
@@ -74,7 +79,7 @@ sub Fox {
|
||||
};
|
||||
|
||||
unless (defined $jfox) {
|
||||
$log->warn ("[WARN] Unable to decode JSON from randomfox: $EVAL_ERROR");
|
||||
cluck "[ERROR] Unable to decode JSON: $EVAL_ERROR";
|
||||
} else {
|
||||
if ($jfox->{image}) {
|
||||
$jfox->{image} =~ s/\\//xmsg;
|
||||
@@ -82,13 +87,13 @@ sub Fox {
|
||||
}
|
||||
}
|
||||
} else {
|
||||
$log->warn (sprintf '[WARN] Randomfox server return status %s with message: %s', $r->code, $r->message);
|
||||
cluck sprintf 'Server return status %s with message: %s', $r->code, $r->message;
|
||||
}
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub Oboobs {
|
||||
sub oboobs {
|
||||
my $r;
|
||||
my $ret = 'Нету cисичек, все разбежались.';
|
||||
|
||||
@@ -109,7 +114,7 @@ sub Oboobs {
|
||||
};
|
||||
|
||||
unless (defined $joboobs) {
|
||||
$log->warn ("[WARN] Unable to decode JSON from oboobs: $EVAL_ERROR");
|
||||
cluck "[ERROR] Unable to decode JSON: $EVAL_ERROR";
|
||||
} else {
|
||||
if ($joboobs->[0]->{preview}) {
|
||||
my @boobs = ('(. )( .)', '( . Y . )', '(o)(o)', '( @ )( @ )', '(.)(.)');
|
||||
@@ -117,13 +122,13 @@ sub Oboobs {
|
||||
}
|
||||
}
|
||||
} else {
|
||||
$log->warn (sprintf '[WARN] Oboobs server return status %s with message: %s', $r->code, $r->message);
|
||||
cluck sprintf 'Server return status %s with message: %s', $r->code, $r->message;
|
||||
}
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub Obutts {
|
||||
sub obutts {
|
||||
my $r;
|
||||
my $ret = 'Нету попок, все разбежались.';
|
||||
|
||||
@@ -144,7 +149,7 @@ sub Obutts {
|
||||
};
|
||||
|
||||
unless (defined $jobutts) {
|
||||
$log->warn ("[ERROR] Unable to decode JSON from obutts: $EVAL_ERROR");
|
||||
cluck "[ERROR] Unable to decode JSON: $EVAL_ERROR";
|
||||
} else {
|
||||
if ($jobutts->[0]->{preview}) {
|
||||
my @butts = ('(__(__)', '(_!_)', '(__.__)');
|
||||
@@ -152,13 +157,13 @@ sub Obutts {
|
||||
}
|
||||
}
|
||||
} else {
|
||||
$log->warn (sprintf '[WARN] Obutts server return status %s with message: %s', $r->code, $r->message);
|
||||
cluck sprintf 'Server return status %s with message: %s', $r->code, $r->message;
|
||||
}
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
# It works but results are not particularly relevant, partially. about 20-30% miss
|
||||
# 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 = (
|
||||
@@ -169,7 +174,7 @@ sub rabbit_imgur {
|
||||
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)]);
|
||||
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);
|
||||
|
||||
@@ -180,9 +185,9 @@ sub rabbit_imgur {
|
||||
}
|
||||
}
|
||||
|
||||
sub Rabbit {
|
||||
sub rabbit {
|
||||
# rabbit, but bunny
|
||||
my $url = FlickrByTags ('animal,bunny');
|
||||
my $url = flickr_by_tags ('animal,bunny');
|
||||
|
||||
if (defined $url) {
|
||||
return sprintf '[(\_/)](%s)', $url;
|
||||
@@ -191,8 +196,8 @@ sub Rabbit {
|
||||
}
|
||||
}
|
||||
|
||||
sub Owl {
|
||||
my $url = FlickrByTags ('bird,owl');
|
||||
sub owl {
|
||||
my $url = flickr_by_tags ('bird,owl');
|
||||
|
||||
if (defined $url) {
|
||||
return sprintf '[{ O v O }](%s)', $url;
|
||||
@@ -201,41 +206,6 @@ sub Owl {
|
||||
}
|
||||
}
|
||||
|
||||
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,4 +1,4 @@
|
||||
package Botlib::Image::Imgur;
|
||||
package imgur;
|
||||
|
||||
use 5.018;
|
||||
use strict;
|
||||
@@ -7,63 +7,56 @@ 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 File::Path qw (make_path);
|
||||
use Math::Random::Secure qw (irand);
|
||||
use Mojo::UserAgent;
|
||||
|
||||
use BotLib::Conf qw (LoadConf);
|
||||
use SQLite_File;
|
||||
use conf qw (loadConf);
|
||||
|
||||
use version; our $VERSION = qw (1.0);
|
||||
use Exporter qw (import);
|
||||
our @EXPORT_OK = qw (Imgur);
|
||||
our @EXPORT_OK = qw (imgur);
|
||||
|
||||
my $c = LoadConf ();
|
||||
my $cachedir = $c->{cachedir};
|
||||
my $c = loadConf ();
|
||||
my $dir = $c->{image}->{dir};
|
||||
my $imgur_client_id = $c->{image}->{imgur}->{client_id};
|
||||
my $imgur_client_secret = $c->{image}->{imgur}->{client_secret};
|
||||
my $imgur_access_token = $c->{image}->{imgur}->{access_token};;
|
||||
my $imgur_refresh_token = $c->{image}->{imgur}->{refresh_token};
|
||||
|
||||
sub Imgur {
|
||||
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');
|
||||
};
|
||||
# load all tokens from api secrets db
|
||||
my $backingfile = sprintf '%s/secrets.sqlite', $dir;
|
||||
|
||||
# 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');
|
||||
unless (-d $dir) {
|
||||
make_path ($dir) or do {
|
||||
cluck "Unable to create $dir: $OS_ERROR";
|
||||
return undef;
|
||||
};
|
||||
}
|
||||
|
||||
$imgur_refresh_token = $cache->get ('imgur_refresh_token');
|
||||
tie my %secret, 'SQLite_File', $backingfile || do {
|
||||
cluck "[ERROR] Unable to tie to $backingfile: $OS_ERROR";
|
||||
return undef;
|
||||
};
|
||||
|
||||
# if there is no access_token in db - put there one from config
|
||||
if (defined $secret{imgur_access_token}) {
|
||||
$imgur_access_token = $secret{imgur_access_token};
|
||||
} else {
|
||||
$secret{imgur_access_token} = $imgur_access_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');
|
||||
if (defined $secret{imgur_refresh_token}) {
|
||||
$imgur_refresh_token = $secret{imgur_refresh_token};
|
||||
} else {
|
||||
$secret{imgur_refresh_token} = $imgur_refresh_token;
|
||||
}
|
||||
|
||||
# query api
|
||||
@@ -76,13 +69,14 @@ sub Imgur {
|
||||
$refresh_url => form {
|
||||
refresh_token => $imgur_refresh_token,
|
||||
client_id => $imgur_client_id,
|
||||
client_secret => $imgur_client_secret,
|
||||
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");
|
||||
cluck "Unable to refresh imgur token, please re-authorise app! or imgur experiencing api outage: $r->code $r->message";
|
||||
untie %secret;
|
||||
return undef;
|
||||
}
|
||||
|
||||
@@ -90,11 +84,12 @@ sub Imgur {
|
||||
|
||||
if (defined $refresh) {
|
||||
$imgur_refresh_token = $refresh->{refresh_token};
|
||||
$cache->set ('refresh_token', $refresh->{refresh_token}, 'never');
|
||||
$secret{imgur_refresh_token} = $refresh->{refresh_token};
|
||||
$imgur_access_token = $refresh->{access_token};
|
||||
$cache->set ('imgur_access_token', $refresh->{access_token}, 'never');
|
||||
$secret{imgur_access_token} = $refresh->{access_token};
|
||||
} else {
|
||||
$log->warn ("[ERROR] Unable to refresh imgur access_token, unable to decode json: $EVAL_ERROR");
|
||||
cluck "Unable to refresh imgur access_token, unable to decode json: $EVAL_ERROR";
|
||||
untie %secret;
|
||||
return undef;
|
||||
}
|
||||
|
||||
@@ -102,6 +97,8 @@ sub Imgur {
|
||||
$r = $ua->get ($search_url . $tag => {Authorization => "Bearer $imgur_access_token"})->result;
|
||||
}
|
||||
|
||||
untie %secret;
|
||||
|
||||
if ($r->is_success) {
|
||||
my $searchResult = eval { return $r->json; };
|
||||
my @urls;
|
||||
@@ -131,21 +128,21 @@ sub Imgur {
|
||||
if ($#urls > 0) {
|
||||
return $urls[irand ($#urls + 1)];
|
||||
} else {
|
||||
$log->notice ('[NOTICE] Imgur api returned empty result.');
|
||||
cluck 'Imgur api returned empty result.';
|
||||
return undef;
|
||||
}
|
||||
} else {
|
||||
$log->warn ("[WARN] Unable to get results from imgur api: $r->message");
|
||||
cluck "Unable to get results from imgur api: $r->message";
|
||||
return undef;
|
||||
}
|
||||
} else {
|
||||
$log->warn ("[WARN] Unable to decode imgur api json: $EVAL_ERROR");
|
||||
cluck "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");
|
||||
cluck "Unable to get results from imgur api: $r->code, $r->message";
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
1;
|
||||
137
lib/karma.pm
Normal file
137
lib/karma.pm
Normal file
@@ -0,0 +1,137 @@
|
||||
package 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 Digest::SHA qw (sha1_base64);
|
||||
use DB_File;
|
||||
use File::Path qw (make_path);
|
||||
use conf qw (loadConf);
|
||||
|
||||
use version; our $VERSION = qw (1.0);
|
||||
use Exporter qw (import);
|
||||
our @EXPORT_OK = qw (karmaSet karmaGet);
|
||||
|
||||
my $c = loadConf ();
|
||||
my $karmadir = $c->{karma}->{dir};
|
||||
my $max = 5;
|
||||
|
||||
# swallow phrase and return answer
|
||||
sub karmaSet (@) {
|
||||
my $chatid = shift;
|
||||
my $phrase = shift;
|
||||
my $action = shift;
|
||||
my $score = 0;
|
||||
# sha1* does not understand utf8, so explicitly construct string cost of decimal numbers only
|
||||
my $karmafile = join ('', unpack ('C*', $chatid));
|
||||
$karmafile = sha1_base64 $karmafile;
|
||||
# sha1 string can contain slashes, so make a bit longer string consist of only decimal numbers
|
||||
$karmafile = join ('', unpack ('C*', $karmafile));
|
||||
$karmafile = sprintf '%s/%s.db', $karmadir, $karmafile;
|
||||
|
||||
if (($phrase eq '') || ($phrase =~ /^ +$/)) {
|
||||
$phrase = '';
|
||||
}
|
||||
|
||||
unless (-d $karmadir) {
|
||||
make_path ($karmadir) or do {
|
||||
cluck "Unable to create $karmadir: $OS_ERROR";
|
||||
return sprintf 'Карма %s составляет 0', $phrase;
|
||||
};
|
||||
}
|
||||
|
||||
# init hash, store phrase and score
|
||||
tie my %karma, 'DB_File', $karmafile || do {
|
||||
cluck "[ERROR] Something nasty happen when cachedata ties to its data: $OS_ERROR";
|
||||
return sprintf 'Карма %s составляет 0', $phrase;
|
||||
};
|
||||
|
||||
# bdb does not understand utf8, so tied hash too, we do not want store original phrase anyway
|
||||
my $sha1_phrase = sha1_base64 (join ('', unpack ('C*', $phrase)));
|
||||
|
||||
if (defined $karma{$sha1_phrase}) {
|
||||
if ($action eq '++') {
|
||||
$score = $karma{$sha1_phrase} + 1;
|
||||
$karma{$sha1_phrase} = $score;
|
||||
} else {
|
||||
$score = $karma{$sha1_phrase} - 1;
|
||||
$karma{$sha1_phrase} = $score;
|
||||
}
|
||||
} else {
|
||||
if ($action eq '++') {
|
||||
$karma{$sha1_phrase} = 1;
|
||||
$score = 1;
|
||||
} else {
|
||||
$karma{$sha1_phrase} = -1;
|
||||
$score = -1;
|
||||
}
|
||||
}
|
||||
|
||||
untie %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;
|
||||
# sha1* does not understand utf8, so explicitly construct string cost of decimal numbers only
|
||||
my $karmafile = join ('', unpack ('C*', $chatid));
|
||||
$karmafile = sha1_base64 $karmafile;
|
||||
# sha1 string can contain slashes, so make a bit longer string consist of only decimal numbers
|
||||
$karmafile = join ('', unpack ('C*', $karmafile));
|
||||
$karmafile = sprintf '%s/%s.db', $karmadir, $karmafile;
|
||||
|
||||
if (($phrase eq '') || ($phrase =~ /^ +$/)) {
|
||||
$phrase = '';
|
||||
}
|
||||
|
||||
unless (-d $karmadir) {
|
||||
make_path ($karmadir) or do {
|
||||
cluck "Unable to create $karmadir: $OS_ERROR";
|
||||
return sprintf 'Карма %s составляет 0', $phrase;
|
||||
};
|
||||
}
|
||||
|
||||
# init hash, store phrase and score
|
||||
tie my %karma, 'DB_File', $karmafile || do {
|
||||
cluck "[ERROR] Something nasty happen when karma ties to its data: $OS_ERROR";
|
||||
return sprintf 'Карма %s составляет 0', $phrase;
|
||||
};
|
||||
|
||||
# bdb does not understand utf8, so tied hash too, we do not want store original phrase anyway
|
||||
my $sha1_phrase = sha1_base64 (join ('', unpack ('C*', $phrase)));
|
||||
my $score = $karma{$sha1_phrase};
|
||||
untie %karma;
|
||||
|
||||
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,4 +1,4 @@
|
||||
package BotLib::Lat;
|
||||
package lat;
|
||||
# famous latin phases taken from https://ru.wikipedia.org/wiki/Список_крылатых_латинских_выражений
|
||||
|
||||
use 5.018;
|
||||
@@ -11,18 +11,17 @@ 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 conf qw (loadConf);
|
||||
|
||||
use version; our $VERSION = qw (1.0);
|
||||
use Exporter qw (import);
|
||||
our @EXPORT_OK = qw (Train Lat);
|
||||
our @EXPORT_OK = qw (train latAnswer);
|
||||
|
||||
my $c = LoadConf ();
|
||||
my $c = loadConf ();
|
||||
my $brain = $c->{lat}->{brain};
|
||||
my $srcfile = $c->{lat}->{src};
|
||||
|
||||
sub Train () {
|
||||
sub train () {
|
||||
my $braindir = dirname $brain;
|
||||
|
||||
unless (-d $braindir) {
|
||||
@@ -46,16 +45,16 @@ sub Train () {
|
||||
}
|
||||
|
||||
# just return answer
|
||||
sub Lat () {
|
||||
sub latAnswer () {
|
||||
my $braindir = dirname $brain;
|
||||
|
||||
unless (-d $braindir) {
|
||||
$log->error ("[ERROR] No lat module data: $braindir is absent! Train lat first.");
|
||||
cluck "[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.");
|
||||
cluck "[ERROR] No lat module data: $brain is absent! Train lat first.";
|
||||
return '';
|
||||
}
|
||||
|
||||
@@ -1,4 +1,4 @@
|
||||
package BotLib::Monkeyuser;
|
||||
package monkeyuser;
|
||||
|
||||
use 5.018;
|
||||
use strict;
|
||||
@@ -8,15 +8,14 @@ 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);
|
||||
our @EXPORT_OK = qw (monkeyuser);
|
||||
|
||||
sub Monkeyuser {
|
||||
sub monkeyuser {
|
||||
my $r;
|
||||
my $ret = 'Нету Monkey User-ов, они все спрятались.';
|
||||
my @link;
|
||||
@@ -52,7 +51,7 @@ sub Monkeyuser {
|
||||
$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});
|
||||
cluck sprintf 'Server return status %s with message: %s', $r->{status}, $r->{reason};
|
||||
}
|
||||
|
||||
return $ret;
|
||||
@@ -1,31 +1,30 @@
|
||||
package TelegramBot;
|
||||
package telegrambot;
|
||||
# main bot gears are here
|
||||
|
||||
use 5.018;
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
use Data::Dumper;
|
||||
use open qw (:std :utf8);
|
||||
use English qw ( -no_match_vars );
|
||||
use Carp qw (cluck carp);
|
||||
use File::Path qw (make_path);
|
||||
use Hailo;
|
||||
use Log::Any qw ($log);
|
||||
use Math::Random::Secure qw (irand);
|
||||
use Mojo::Base 'Teapot::Bot::Brain';
|
||||
use BotLib::Admin qw (FortuneToggleList);
|
||||
use BotLib qw (RandomCommonPhrase Command Highlight BotSleep IsCensored);
|
||||
use BotLib::Conf qw (LoadConf);
|
||||
use BotLib::Fortune qw (Fortune);
|
||||
use BotLib::Image qw (Oboobs Obutts);
|
||||
use BotLib::Karma qw (KarmaSet);
|
||||
use BotLib::Util qw (trim fmatch);
|
||||
use admin qw (fortune_toggle_list);
|
||||
use botlib qw (randomCommonPhrase command highlight botsleep isCensored);
|
||||
use conf qw (loadConf);
|
||||
use fortune qw (fortune);
|
||||
use karma qw (karmaSet);
|
||||
use util qw (trim fmatch);
|
||||
|
||||
use version; our $VERSION = qw (1.0);
|
||||
use Exporter qw (import);
|
||||
our @EXPORT_OK = qw (RunTelegramBot);
|
||||
our @EXPORT_OK = qw (run_telegrambot);
|
||||
|
||||
my $c = LoadConf ();
|
||||
my $c = loadConf ();
|
||||
my $hailo;
|
||||
my $myid;
|
||||
my $myusername;
|
||||
@@ -48,9 +47,9 @@ sub __cron {
|
||||
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime (time);
|
||||
|
||||
if ($hour == 8 && ($min >= 0 && $min <= 14)) {
|
||||
foreach my $enabledfortunechat (FortuneToggleList ()) {
|
||||
foreach my $enabledfortunechat (fortune_toggle_list ()) {
|
||||
my $send_args;
|
||||
$send_args->{text} = sprintf "%s\n```\n%s\n```\n", $intro[irand ($#intro + 1)], trim (Fortune ());
|
||||
$send_args->{text} = sprintf "%s\n```\n%s\n```\n", $intro[irand ($#intro + 1)], trim (fortune ());
|
||||
$send_args->{chat_id} = $enabledfortunechat;
|
||||
$send_args->{parse_mode} = 'Markdown';
|
||||
$self->sendMessage ($send_args);
|
||||
@@ -66,14 +65,14 @@ sub __on_msg {
|
||||
my $chatid;
|
||||
my $chatname = 'Noname chat';
|
||||
# user sending message info
|
||||
my ($userid, $username, $fullname, $highlight, $vis_a_vi) = BotLib::Highlight ($msg);
|
||||
my ($userid, $username, $fullname, $highlight, $vis_a_vi) = highlight $msg;
|
||||
my $csign = $c->{telegrambot}->{csign};
|
||||
|
||||
unless ($myid) {
|
||||
my $myObj = $self->getMe ();
|
||||
|
||||
unless ($myObj) {
|
||||
$log->error ('[ERROR] Unable to get chatid, API Error?');
|
||||
carp '[ERROR] Unable to get chatid, API Error?';
|
||||
return;
|
||||
}
|
||||
|
||||
@@ -106,7 +105,7 @@ sub __on_msg {
|
||||
}
|
||||
}
|
||||
} else {
|
||||
$log->warn ('[INFO] Unable to get chatid');
|
||||
carp '[INFO] Unable to get chatid';
|
||||
return;
|
||||
}
|
||||
|
||||
@@ -115,33 +114,21 @@ sub __on_msg {
|
||||
# Newcommer event, greet our new member and suggest to introduce themself.
|
||||
if ($msg->can ('new_chat_members') && defined ($msg->new_chat_members)) {
|
||||
my @members;
|
||||
my @introduce = (
|
||||
'Дратути',
|
||||
'Дарована',
|
||||
'Доброе утро, день или вечер',
|
||||
'Добро пожаловать в наше скромное коммунити',
|
||||
'Наше вам с кисточкой тут, на канальчике',
|
||||
);
|
||||
|
||||
foreach my $member (@{$msg->new_chat_members}) {
|
||||
my $member_str = '';
|
||||
|
||||
# avoid naming people by spacing symbols, or empty names
|
||||
if ($member->can ('first_name') && defined ($member->first_name) && $member->first_name !~ /^\s+$/ui) {
|
||||
if ($member->can ('first_name') && defined ($member->first_name)) {
|
||||
$member_str .= $member->first_name;
|
||||
|
||||
if ($member->can ('last_name') && defined ($member->last_name) && $member->last_name !~ /^\s+$/ui) {
|
||||
if ($member->can ('last_name') && defined ($member->last_name)) {
|
||||
$member_str .= ' ' . $member->last_name;
|
||||
}
|
||||
} else {
|
||||
if ($member->can ('last_name') && defined ($member->last_name) && $member->last_name !~ /^\s+$/ui) {
|
||||
if ($member->can ('last_name') && defined ($member->last_name)) {
|
||||
$member_str .= ' ' . $member->last_name;
|
||||
# username must be uniq and should contain only english letters and numbers, so...
|
||||
} elsif ($member->can ('username') && defined ($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;
|
||||
$member_str .= '@' . $member->username;
|
||||
}
|
||||
}
|
||||
|
||||
@@ -150,12 +137,12 @@ sub __on_msg {
|
||||
|
||||
if ($#members > 1) {
|
||||
my $lastone = pop @members;
|
||||
$phrase = sprintf '%s, %s и %s. Представьтес, пожалуйста, и расскажите, что вас сюда привело.', $introduce[irand ($#introduce + 1)], join (', ', @members), $lastone;
|
||||
$phrase = sprintf 'Дратути, %s и %s. Представьтес, пожалуйста, и расскажите, что вас сюда привело.', join (', ', @members), $lastone;
|
||||
} else {
|
||||
$phrase = sprintf '%s, %s. Представьтес, пожалуйста, и расскажите, что вас сюда привело.', $introduce[irand ($#introduce + 1)], $members[0];
|
||||
$phrase = sprintf 'Дратути, %s. Представьтес, пожалуйста, и расскажите, что вас сюда привело.', $members[0];
|
||||
}
|
||||
|
||||
BotSleep $msg;
|
||||
botsleep $msg;
|
||||
$msg->replyMd ($phrase);
|
||||
return;
|
||||
}
|
||||
@@ -171,9 +158,9 @@ sub __on_msg {
|
||||
);
|
||||
|
||||
if ($chatid < 0) {
|
||||
$log->info ("[INFO] Initialized brain for public chat $chatname ($chatid): $brainname");
|
||||
carp "[INFO] Initialized brain for public chat $chatname ($chatid): $brainname";
|
||||
} else {
|
||||
$log->info ("[INFO] Initialized brain for private chat $chatname ($chatid): $brainname");
|
||||
carp "[INFO] Initialized brain for private chat $chatname ($chatid): $brainname";
|
||||
}
|
||||
}
|
||||
|
||||
@@ -184,11 +171,11 @@ sub __on_msg {
|
||||
}
|
||||
|
||||
my $text = $msg->text;
|
||||
$log->debug (sprintf ('[DEBUG] Private chat %s say to bot: %s', $vis_a_vi, $text));
|
||||
carp sprintf ('[DEBUG] Private chat %s say to bot: %s', $vis_a_vi, $text) if $c->{debug};
|
||||
my $reply = 'Давайте ещё пообщаемся, а то я ещё не научилась от вас плохому.';
|
||||
|
||||
if (substr ($text, 0, 1) eq $csign) {
|
||||
$reply = Command ($self, $msg, $text, $userid);
|
||||
$reply = command ($self, $msg, $text, $userid);
|
||||
} else {
|
||||
my $just_message_in_chat = 0;
|
||||
|
||||
@@ -197,45 +184,27 @@ sub __on_msg {
|
||||
my @arr = split /\n/, $text;
|
||||
|
||||
if ($#arr < 1) {
|
||||
$reply = KarmaSet ($chatid, trim (substr ($text, 0, -2)), substr ($text, -2));
|
||||
$reply = karmaSet ($chatid, trim (substr ($text, 0, -2)), substr ($text, -2));
|
||||
} else {
|
||||
$just_message_in_chat = 1;
|
||||
}
|
||||
} else {
|
||||
$just_message_in_chat = 1;
|
||||
}
|
||||
|
||||
if ($just_message_in_chat) {
|
||||
if ($text =~ /^ *кто +все +эти +люди *\?$/ui) {
|
||||
$reply = 'Какие "люди"? Мы здесь вдвоём, только ты и я.';
|
||||
} elsif ($text =~ /^ *кто +я *\?$/ui) {
|
||||
$reply = 'Где?';
|
||||
} elsif ($text =~ /^ *кто +(здесь|тут) *\?$/ui) {
|
||||
$reply = 'Ты да я, да мы с тобой.';
|
||||
} elsif ($text =~ /покажи +(сиськи|сиси|титьки) *$/ui) {
|
||||
$reply = Oboobs ();
|
||||
} elsif ($text =~ /show +(titts|tities|boobs) *$/i) {
|
||||
$reply = Oboobs ();
|
||||
} elsif ($text =~ /покажи +(попку|попу) *$/ui) {
|
||||
$reply = Obutts ();
|
||||
} elsif ($text =~ /show +(ass|butt|butty) *$/i) {
|
||||
$reply = Obutts ();
|
||||
} else {
|
||||
my $str = $hailo->{$msg->chat->id}->learn_reply ($text);
|
||||
my $str = $hailo->{$msg->chat->id}->learn_reply ($text);
|
||||
|
||||
if (defined ($str) && $str ne '') {
|
||||
$reply = $str;
|
||||
$phrase = trim $text;
|
||||
if (defined ($str) && $str ne '') {
|
||||
$reply = $str;
|
||||
$phrase = trim $text;
|
||||
|
||||
while ($phrase =~ /[\.|\,|\?|\!]$/) {
|
||||
chop $phrase;
|
||||
}
|
||||
while ($phrase =~ /[\.|\,|\?|\!]$/) {
|
||||
chop $phrase;
|
||||
}
|
||||
|
||||
$phrase = lc $phrase;
|
||||
$phrase = lc $phrase;
|
||||
|
||||
if (fmatch (lc ($reply), $phrase)) {
|
||||
$reply = RandomCommonPhrase ();
|
||||
}
|
||||
if (fmatch (lc ($reply), $phrase)) {
|
||||
$reply = randomCommonPhrase ();
|
||||
}
|
||||
}
|
||||
}
|
||||
@@ -244,64 +213,53 @@ sub __on_msg {
|
||||
if (defined $reply) {
|
||||
$msg->typing ();
|
||||
sleep 1;
|
||||
$log->debug (sprintf ('[DEBUG] Private chat bot reply to %s: %s', $vis_a_vi, $reply));
|
||||
carp sprintf ('[DEBUG] Private chat bot reply to %s: %s', $vis_a_vi, $reply) if $c->{debug};
|
||||
$msg->reply ($reply);
|
||||
}
|
||||
# group chat
|
||||
} elsif (($msg->chat->type eq 'supergroup') or ($msg->chat->type eq 'group')) {
|
||||
my $reply;
|
||||
|
||||
if (IsCensored $msg) {
|
||||
$log->info (sprintf '[INFO] In public chat %s (%s) message from %s was censored', $chatname, $chatid, $vis_a_vi);
|
||||
if (isCensored $msg) {
|
||||
carp 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}});
|
||||
}
|
||||
|
||||
# detect and log messages without text, noop here
|
||||
unless (defined $msg->text) {
|
||||
$log->debug (sprintf ('[DEBUG] No text in message from %s', $vis_a_vi));
|
||||
carp sprintf ('[INFO] No text in message from %s', $vis_a_vi);
|
||||
return;
|
||||
}
|
||||
|
||||
# we have text here! so potentially we can chit-chat
|
||||
my $text = $msg->text;
|
||||
$log->debug (sprintf ('[DEBUG] In public chat %s (%s) %s say: %s', $chatname, $chatid, $vis_a_vi, $text));
|
||||
carp sprintf ('[DEBUG] In public chat %s (%s) %s say: %s', $chatname, $chatid, $vis_a_vi, $text) if $c->{debug};
|
||||
|
||||
# are they quote something, maybe, us?
|
||||
if (defined ($msg->reply_to_message) &&
|
||||
defined ($msg->reply_to_message->from) &&
|
||||
defined ($msg->reply_to_message->from->username) &&
|
||||
($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));
|
||||
carp sprintf ('[DEBUG] In public chat %s (%s) %s quote us!', $chatname, $chatid, $vis_a_vi) if $c->{debug};
|
||||
|
||||
# do not answer back if someone quote our new member greet
|
||||
if (substr ($msg->reply_to_message->text, -61) eq 'Представьтес, пожалуйста, и расскажите, что вас сюда привело.') {
|
||||
my @hello = (
|
||||
'Дратути, ',
|
||||
'Дарована, ',
|
||||
'Доброе утро, день или вечер, ',
|
||||
'Добро пожаловать в наше скромное коммунити, ',
|
||||
'Наше вам с кисточкой тут, на канальчике, ',
|
||||
);
|
||||
|
||||
foreach my $hi (@hello) {
|
||||
if (substr ($msg->reply_to_message->text, 0, length $hi) eq $hi) {
|
||||
return;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# 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;
|
||||
if ((substr ($msg->reply_to_message->text, 0, 9) eq 'Дратути, ') &&
|
||||
(substr ($msg->reply_to_message->text, -61) eq 'Представьтес, пожалуйста, и расскажите, что вас сюда привело.')) {
|
||||
return;
|
||||
} else {
|
||||
# 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 :)
|
||||
$reply = $hailo->{$msg->chat->id}->learn_reply ($phrase) if (length ($phrase) > 3);
|
||||
$reply = $hailo->{$msg->chat->id}->learn_reply ($phrase) if (length ($phrase) > 3);
|
||||
}
|
||||
# simple commands
|
||||
} elsif (substr ($text, 0, 1) eq $csign) {
|
||||
$reply = Command ($self, $msg, $text, $chatid);
|
||||
$reply = command ($self, $msg, $text, $chatid);
|
||||
} elsif (
|
||||
($text eq $myusername) or
|
||||
($text eq '@' . $myusername) or
|
||||
@@ -317,63 +275,28 @@ sub __on_msg {
|
||||
# phrase directed to bot
|
||||
if ((lc ($text) =~ /^${qname}[\,|\:]? (.+)/) or (lc ($text) =~ /^${qtname}[\,|\:]? (.+)/)){
|
||||
$phrase = $1;
|
||||
|
||||
if ($phrase =~ /^ *кто +все +эти +люди *\?$/ui) {
|
||||
$reply = 'Кто здесь?';
|
||||
} elsif ($phrase =~ /^ *кто +я *?$/ui){
|
||||
$reply = 'Где?';
|
||||
} elsif ($phrase =~ /^ *кто +(здесь|тут) *\?$/ui) {
|
||||
$reply = 'Здесь все: Никита, Стас, Гена, Турбо и Дюша Метёлкин.';
|
||||
} else {
|
||||
$reply = $hailo->{$msg->chat->id}->learn_reply ($phrase);
|
||||
}
|
||||
$reply = $hailo->{$msg->chat->id}->learn_reply ($phrase);
|
||||
# bot mention by name
|
||||
} elsif ((lc ($text) =~ /.+ ${qname}[\,|\!|\?|\.| ]/) or (lc ($text) =~ / $qname$/)) {
|
||||
$phrase = $text;
|
||||
|
||||
if ($phrase =~ /^ *кто +все +эти +люди *\?$/ui) {
|
||||
$reply = 'Кто здесь?';
|
||||
} elsif ($phrase =~ /^ *кто +я *?$/ui){
|
||||
$reply = 'Где?';
|
||||
} elsif ($phrase =~ /^ *кто +(здесь|тут) *\?$/ui) {
|
||||
$reply = 'Здесь все: Никита, Стас, Гена, Турбо и Дюша Метёлкин.';
|
||||
} else {
|
||||
$reply = $hailo->{$msg->chat->id}->learn_reply ($phrase);
|
||||
}
|
||||
$reply = $hailo->{$msg->chat->id}->reply($phrase);
|
||||
# bot mention by telegram name
|
||||
} elsif ((lc ($text) =~ /.+ ${qtname}[\,|\!|\?|\.| ]/) or (lc ($text) =~ / $qtname$/)) {
|
||||
$phrase = $text;
|
||||
|
||||
if ($phrase =~ /^ *кто +все +эти +люди *\?$/ui) {
|
||||
$reply = 'Кто здесь?';
|
||||
} elsif ($phrase =~ /^ *кто +я *?$/ui){
|
||||
$reply = 'Где?';
|
||||
} elsif ($phrase =~ /^ *кто +(здесь|тут) *\?$/ui) {
|
||||
$reply = 'Здесь все: Никита, Стас, Гена, Турбо и Дюша Метёлкин.';
|
||||
} else {
|
||||
$reply = $hailo->{$msg->chat->id}->learn_reply ($phrase);
|
||||
}
|
||||
$reply = $hailo->{$msg->chat->id}->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));
|
||||
$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 {
|
||||
if ($text =~ /^ *кто +все +эти +люди *\?$/ui) {
|
||||
$reply = 'Кто здесь?';
|
||||
} elsif ($phrase =~ /^ *кто +я *?$/ui){
|
||||
$reply = 'Где?';
|
||||
} elsif ($phrase =~ /^ *кто +(здесь|тут) *\?$/ui) {
|
||||
$reply = 'Здесь все: Никита, Стас, Гена, Турбо и Дюша Метёлкин.';
|
||||
} else {
|
||||
$hailo->{$msg->chat->id}->learn ($text);
|
||||
}
|
||||
$hailo->{$msg->chat->id}->learn ($text);
|
||||
}
|
||||
}
|
||||
|
||||
@@ -388,15 +311,15 @@ sub __on_msg {
|
||||
$phrase = lc $phrase;
|
||||
|
||||
if (fmatch (lc ($reply), $phrase)) {
|
||||
$reply = RandomCommonPhrase ();
|
||||
$reply = randomCommonPhrase ();
|
||||
}
|
||||
|
||||
$msg->typing ();
|
||||
sleep (irand 2);
|
||||
$log->debug (sprintf ('[DEBUG] In public chat %s (%s) bot reply to %s: %s', $chatname, $chatid, $vis_a_vi, $reply));
|
||||
carp sprintf ('[DEBUG] In public chat %s (%s) bot reply to %s: %s', $chatname, $chatid, $vis_a_vi, $reply) if $c->{debug};
|
||||
$msg->reply ($reply);
|
||||
} else {
|
||||
$log->debug (sprintf ('[DEBUG] In public chat %s (%s) bot is not required to reply to %s', $chatname, $chatid, $vis_a_vi));
|
||||
carp sprintf ('[DEBUG] In public chat %s (%s) bot is not required to reply to %s', $chatname, $chatid, $vis_a_vi) if $c->{debug};
|
||||
}
|
||||
|
||||
# should be channel, so we can't talk
|
||||
@@ -414,7 +337,7 @@ sub init {
|
||||
|
||||
unless (-d $braindir) {
|
||||
make_path ($braindir, 0, 0755) or do { ## no critic (ValuesAndExpressions::ProhibitLeadingZeros)
|
||||
$log->fatal ("[FATAL] Unable to create $braindir: $OS_ERROR");
|
||||
cluck "Unable to create $braindir: $OS_ERROR";
|
||||
exit 1;
|
||||
};
|
||||
}
|
||||
@@ -424,10 +347,10 @@ sub init {
|
||||
return;
|
||||
}
|
||||
|
||||
sub RunTelegramBot {
|
||||
sub run_telegrambot {
|
||||
while (sleep 3) {
|
||||
eval { ## no critic (ErrorHandling::RequireCheckingReturnValueOfEval)
|
||||
TelegramBot->new->think;
|
||||
telegrambot->new->think;
|
||||
}
|
||||
}
|
||||
|
||||
@@ -1,4 +1,4 @@
|
||||
package BotLib::Util;
|
||||
package util;
|
||||
|
||||
use 5.018;
|
||||
use strict;
|
||||
@@ -77,6 +77,7 @@ sub utf2sha1 {
|
||||
return sha1_base64 $bytes;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
||||
@@ -1,4 +1,4 @@
|
||||
package BotLib::Weather;
|
||||
package weather;
|
||||
|
||||
use 5.018;
|
||||
use strict;
|
||||
@@ -9,20 +9,21 @@ use English qw ( -no_match_vars );
|
||||
use Carp qw (carp cluck);
|
||||
use CHI;
|
||||
use CHI::Driver::BerkeleyDB;
|
||||
use Log::Any qw ($log);
|
||||
use DB_File;
|
||||
use Digest::MD5 qw (md5_base64);
|
||||
use File::Path qw (make_path);
|
||||
use Mojo::Log;
|
||||
use Mojo::UserAgent::Cached;
|
||||
use BotLib::Conf qw (LoadConf);
|
||||
use BotLib::Util qw (trim urlencode);
|
||||
use conf qw (loadConf);
|
||||
use util qw (trim urlencode);
|
||||
|
||||
use version; our $VERSION = qw (1.0);
|
||||
use Exporter qw (import);
|
||||
our @EXPORT_OK = qw (Weather);
|
||||
our @EXPORT_OK = qw (weather);
|
||||
|
||||
my $c = LoadConf ();
|
||||
my $cachedir = $c->{cachedir};
|
||||
my $c = loadConf ();
|
||||
|
||||
sub Weather {
|
||||
sub weather {
|
||||
my $city = shift;
|
||||
$city = trim $city;
|
||||
|
||||
@@ -30,22 +31,13 @@ sub Weather {
|
||||
return 'Длинновато для названия города.' if (length ($city) > 80);
|
||||
|
||||
$city = ucfirst $city;
|
||||
|
||||
if ($city eq 'Мск' || $city eq 'Default' || $city eq 'Dc' || $city eq 'Msk' || $city eq 'Dc-universe') {
|
||||
$city = 'Москва';
|
||||
} elsif ($city eq 'Спб' || $city eq 'Spb') {
|
||||
$city = 'Санкт-Петербург';
|
||||
} elsif ($city eq 'Ект' || $city eq 'Ебург' || $city eq 'Ёбург' || $city eq 'Екат' || $city eq 'Ekt' || $city eq 'Eburg' || $city eq 'Ekat') {
|
||||
$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 мм.рт.ст",
|
||||
"Погода в городе %s, %s:\n%s, ветер %s %s м/c, температура %s°C, ощущается как %s°C, относительная влажность %s%%, давление %s мм.рт.с",
|
||||
$w->{name},
|
||||
$w->{country},
|
||||
ucfirst $w->{description},
|
||||
@@ -56,23 +48,9 @@ sub Weather {
|
||||
$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 мм.рт.ст",
|
||||
"Погода в городе %s, %s:\n%s, ветер %s %s м/c, температура %s-%s°C, ощущается как %s°C, относительная влажность %s%%, давление %s мм.рт.ст",
|
||||
$w->{name},
|
||||
$w->{country},
|
||||
ucfirst $w->{description},
|
||||
@@ -96,6 +74,7 @@ sub __weather {
|
||||
my $city = shift;
|
||||
$city = urlencode $city;
|
||||
my $appid = $c->{openweathermap}->{appid};
|
||||
my $cachedir = $c->{openweathermap}->{cachedir};
|
||||
my $now = time ();
|
||||
my $fc;
|
||||
my $w;
|
||||
@@ -133,11 +112,11 @@ sub __weather {
|
||||
};
|
||||
|
||||
unless ($fc) {
|
||||
$log->warn ("[WARN] openweathermap returns corrupted json: $EVAL_ERROR");
|
||||
cluck "[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);
|
||||
cluck sprintf 'Server return status %s with message: %s', $r->code, $r->message;
|
||||
return undef;
|
||||
}
|
||||
|
||||
32
lib/xkcd.pm
Normal file
32
lib/xkcd.pm
Normal file
@@ -0,0 +1,32 @@
|
||||
package 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 $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 ''
|
||||
) {
|
||||
return sprintf '[xkcd.ru](https://xkcd.ru/i/%s_v1.png)', substr ($r->content->headers->location, 1, -1);
|
||||
}
|
||||
|
||||
return 'Комикс-стрип нарисовать не так-то просто :(';
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
||||
Reference in New Issue
Block a user