Compare commits
159 Commits
c9b46cc6f0
...
redis
| Author | SHA1 | Date | |
|---|---|---|---|
|
|
e135ef7d7c | ||
|
|
731d707baa | ||
|
|
6840e6d5d0 | ||
|
|
ba14f6e619 | ||
|
|
00a82dd2cd | ||
|
|
6554879b19 | ||
|
|
9a5b899a42 | ||
|
|
3a061078d4 | ||
|
|
ca946c7e7b | ||
|
|
c68f716cbb | ||
|
|
31e077c219 | ||
|
|
ae553d8aa5 | ||
|
|
1d287f853f | ||
|
|
e74a3e46c1 | ||
|
|
186b112eba | ||
|
|
f223ba04ae | ||
|
|
17bd260a45 | ||
|
|
7cac72d5b9 | ||
|
|
f33e05a91c | ||
|
|
ab89105168 | ||
|
|
8d35bb2452 | ||
|
|
71a2471725 | ||
|
|
e93c9f9131 | ||
|
|
1abb95622a | ||
|
|
bb399a5051 | ||
|
|
c5014a8f77 | ||
|
|
f83a2d3436 | ||
|
|
2134edd841 | ||
|
|
3dd565c658 | ||
|
|
7147b785e7 | ||
|
|
f1ad32d5ae | ||
|
|
66f64da5c6 | ||
|
|
cf71cd7f6f | ||
|
|
eddbcc6277 | ||
|
|
30fb568de0 | ||
|
|
9c9e67e0a2 | ||
|
|
47e82449e7 | ||
|
|
b6ec09c5de | ||
|
|
dca58a3deb | ||
|
|
6d439a1b44 | ||
|
|
096877bee2 | ||
|
|
095cb57a18 | ||
|
|
36c79eb46c | ||
|
|
dd693bf5fb | ||
|
|
b8c3f4957c | ||
|
|
ec6c63a954 | ||
|
|
62650bd8ad | ||
|
|
8d5b5df194 | ||
|
|
0befdf6327 | ||
|
|
8e2414288b | ||
|
|
fbab0a4d88 | ||
|
|
a3f8b43f07 | ||
|
|
615213ee41 | ||
|
|
e7ef39366b | ||
|
|
3c721b905f | ||
|
|
8665a6ddda | ||
|
|
f7634a26d1 | ||
|
|
729489236f | ||
|
|
cec3ed66fb | ||
|
|
57dee8b168 | ||
|
|
5d17018490 | ||
|
|
b8fb89358e | ||
|
|
c6ce5b1421 | ||
|
|
36208a35d5 | ||
|
|
23471ee185 | ||
|
|
3a39cf8513 | ||
|
|
bca6ee8512 | ||
|
|
2af166e3e6 | ||
|
|
6735d6217a | ||
|
|
3eb3e2126d | ||
|
|
c58a571da5 | ||
|
|
efea02972c | ||
|
|
d55d35f877 | ||
|
|
c8a766881e | ||
|
|
f669186787 | ||
|
|
1991edc803 | ||
|
|
bdcd3b56e5 | ||
|
|
5d14f08084 | ||
|
|
dd67f33ec5 | ||
|
|
f4651ff915 | ||
|
|
9fc11c7cf4 | ||
|
|
04cb3d2357 | ||
|
|
e38726a1f2 | ||
|
|
79004942bd | ||
|
|
52724accee | ||
|
|
4bdaea0a42 | ||
|
|
041ab3efeb | ||
|
|
5d0fe793fd | ||
|
|
4616470584 | ||
|
|
9732e71775 | ||
|
|
626feed7db | ||
|
|
f043fe5d78 | ||
|
|
054809ad3e | ||
|
|
35148838f9 | ||
|
|
a1d238949f | ||
|
|
8a521d3f3b | ||
|
|
d32a25f93b | ||
|
|
94f37408d7 | ||
|
|
a108ebd701 | ||
|
|
f58046599c | ||
|
|
380bff679e | ||
|
|
7d3d17f807 | ||
|
|
a9c049da13 | ||
|
|
ade7cefe5a | ||
|
|
6d7830024c | ||
|
|
33616284ca | ||
|
|
d8728b383e | ||
|
|
59e8fa525a | ||
|
|
afe50154ab | ||
|
|
252bb86eb8 | ||
|
|
2b06abdbf4 | ||
|
|
083ae88386 | ||
|
|
3787bb3073 | ||
|
|
0cfecd72b3 | ||
|
|
07275c5b43 | ||
|
|
8bbe3b5d18 | ||
|
|
10fc353924 | ||
|
|
4a312e23d1 | ||
|
|
cc43141d20 | ||
|
|
642aadfd84 | ||
|
|
0327130a5d | ||
|
|
e861f5420b | ||
|
|
a9193faf12 | ||
|
|
0256f6b45b | ||
|
|
1031fe9242 | ||
|
|
63304d6bb9 | ||
|
|
ad37a349c1 | ||
|
|
25b25ade5c | ||
|
|
e448225a7b | ||
|
|
48c07b0073 | ||
|
|
ac8c0f17de | ||
|
|
4bf814c473 | ||
|
|
ba56ea72a2 | ||
|
|
c6c53d6ebf | ||
|
|
c71ba14bdc | ||
|
|
8cb69e554d | ||
|
|
97434d511b | ||
|
|
05f8990f5e | ||
|
|
621d19486d | ||
|
|
57120eb461 | ||
|
|
97eddd414d | ||
|
|
a480786afa | ||
|
|
43c0286414 | ||
|
|
f0b1ae9c43 | ||
|
|
29c1fa8d07 | ||
|
|
c1b6ca013d | ||
|
|
edcd382183 | ||
|
|
75ee83c94f | ||
|
|
f93f974cb4 | ||
|
|
a1da4b193d | ||
|
|
0576a1ea57 | ||
|
|
1a8fa3e089 | ||
|
|
74e58db1b8 | ||
|
|
5cba9755af | ||
|
|
113a918010 | ||
|
|
45318757df | ||
|
|
033441c513 | ||
|
|
f816840e14 | ||
|
|
c3818e5dee |
19
.gitignore
vendored
19
.gitignore
vendored
@@ -1,5 +1,16 @@
|
||||
vendor_perl
|
||||
_Deparsed_XSubs.pm
|
||||
.idea/**
|
||||
.vscode/**
|
||||
.vstags
|
||||
aleesa-telegram-bot.pid
|
||||
data/cache/**
|
||||
data/config.json
|
||||
data/cache
|
||||
data/telegrambot-brains
|
||||
TODO
|
||||
data/fortune/**
|
||||
data/friday/**
|
||||
data/gamestat/**
|
||||
data/image/**
|
||||
data/karma/**
|
||||
data/lat/**
|
||||
data/proverb/**
|
||||
data/telegrambot-brains/**
|
||||
vendor_perl/**
|
||||
|
||||
@@ -4,38 +4,38 @@ verbose = 8
|
||||
|
||||
# minorify some of warnings that are not really critical
|
||||
[-InputOutput::RequireCheckedClose]
|
||||
# what can we handle in case of error?
|
||||
# What can we handle in case of error?
|
||||
|
||||
[-Modules::ProhibitExcessMainComplexity]
|
||||
# noone cares
|
||||
# Noone cares
|
||||
|
||||
[-Subroutines::ProhibitExcessComplexity]
|
||||
# noone cares
|
||||
# Noone cares
|
||||
|
||||
[-Subroutines::ProhibitExplicitReturnUndef]
|
||||
# but it's very handy sometimes!
|
||||
# But it's very handy sometimes!
|
||||
|
||||
[-ValuesAndExpressions::ProhibitMagicNumbers]
|
||||
# this policy makes too much false positives
|
||||
|
||||
[-RegularExpressions::RequireLineBoundaryMatching]
|
||||
# we use /m as needed
|
||||
# We use /m as needed
|
||||
|
||||
[-RegularExpressions::RequireExtendedFormatting]
|
||||
# we do not use extended formatting of regex, they still not THAT complex
|
||||
# We do not use extended formatting of regex, they still not THAT complex
|
||||
|
||||
[-RegularExpressions::RequireDotMatchAnything]
|
||||
# huh?
|
||||
|
||||
[-RegularExpressions::ProhibitEscapedMetacharacters]
|
||||
# looks like it pointless
|
||||
# Looks like it pointless
|
||||
|
||||
[-ControlStructures::ProhibitCascadingIfElse]
|
||||
# I like long ifelse chains
|
||||
# I like long if..else chains
|
||||
|
||||
[-ControlStructures::ProhibitPostfixControls]
|
||||
# in short lines we can afford ourselves to use postfix controls
|
||||
# but ofcorse we shoul avoid such constructions in long lines
|
||||
# In short lines we can afford ourselves to use postfix controls
|
||||
# but ofcorse we should avoid such constructions in long lines.
|
||||
|
||||
[-Subroutines::ProhibitSubroutinePrototypes]
|
||||
# Contrary to Perl::Critic we consider prototypes as useful, even if
|
||||
@@ -43,19 +43,19 @@ verbose = 8
|
||||
# hints.
|
||||
|
||||
[-CodeLayout::RequireTidyCode]
|
||||
# impossible to complete, because of on higher linting levels ## no critic
|
||||
# Impossible to complete, because of on higher linting levels "## no critic..."
|
||||
# require be per-case on same line where critique is, but tidy align them
|
||||
# one line down
|
||||
# one line down.
|
||||
|
||||
[-CodeLayout::ProhibitParensWithBuiltins]
|
||||
# duh...
|
||||
|
||||
[-ValuesAndExpressions::ProhibitEmptyQuotes]
|
||||
# cause we consider following correct and useful: my $var = '';
|
||||
# the recomended use of q{} looks too complex: my $var = q{};
|
||||
# the recommended use of q{} looks too complex: my $var = q{};
|
||||
|
||||
[-ValuesAndExpressions::ProhibitNoisyQuotes]
|
||||
# other people, other opinions: "," is better readable than qw(,)
|
||||
# Other people, other opinions: "," is better readable than qw(,)
|
||||
|
||||
[-BuiltinFunctions::ProhibitSleepViaSelect]
|
||||
# We do not wish to use too much external modules.
|
||||
@@ -67,14 +67,32 @@ verbose = 8
|
||||
# Noone care, really
|
||||
|
||||
[-ControlStructures::ProhibitUnlessBlocks]
|
||||
# they should not be too complex - only one condition should be checked,
|
||||
# They should not be too complex - only one condition should be checked,
|
||||
# that's all
|
||||
|
||||
[-Miscellanea::ProhibitTies]
|
||||
# Just allow it. It's very handy stuff and extremely simple and safe enugh to use.
|
||||
|
||||
[-ValuesAndExpressions::RequireNumberSeparators]
|
||||
# not really
|
||||
# Not really
|
||||
|
||||
[-InputOutput::RequireBracedFileHandleWithPrint]
|
||||
# we prefer not to use braced file handles
|
||||
# We prefer not to use braced file handles
|
||||
|
||||
[-Documentation::PodSpelling]
|
||||
# It doesn't help, but emits annoying errors
|
||||
|
||||
[Documentation::RequirePodSections]
|
||||
# Considering this as "soft" requirement. For modules that is (or will be)
|
||||
# stand-alone libs well formed documentation is highly desired.
|
||||
lib_sections = NAME | VERSION | DESCRIPTION | AUTHOR | LICENSE AND COPYRIGHT
|
||||
|
||||
[-InputOutput::RequireBriefOpen]
|
||||
# Yes, i do!
|
||||
|
||||
[-ControlStructures::ProhibitDeepNests]
|
||||
# Have to use it, so fuckoff
|
||||
|
||||
[-ControlStructures::ProhibitUntilBlocks]
|
||||
# Until is really useful if condition is simple, so let's assume condition is
|
||||
# always simple to read
|
||||
49
README.md
49
README.md
@@ -1,51 +1,48 @@
|
||||
# Aleesa-Telegram-bot - Simple Telegram chatty bot
|
||||
# Aleesa-Telegram-bot - Telegram chatty bot
|
||||
|
||||
## About
|
||||
|
||||
It is based on Perl modules [Telegram::Bot][1] and [Hailo][2] as conversation
|
||||
generator.
|
||||
|
||||
Config located in **data/config.json**, sample config provided as
|
||||
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 can be run via **bin/aleesa-telegam-bot** and acts as daemon.
|
||||
Bot can be run via **bin/aleesa-telegram-bot** and acts as daemon (double
|
||||
fork() and detaches stdio).
|
||||
|
||||
## Installation
|
||||
|
||||
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 "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,
|
||||
hiredis-devel.
|
||||
|
||||
After installng required dependencies it is possible to run:
|
||||
After installing required dependencies it is possible to run:
|
||||
|
||||
```bash
|
||||
|
||||
bash bootstrap.sh
|
||||
|
||||
```
|
||||
|
||||
and all libraries should be downloaded, built, tested and installed.
|
||||
|
||||
## N.B.
|
||||
## Running
|
||||
|
||||
If bot is unable to post to channel due to limited permissions, it will die.
|
||||
It is possible to change this behavior by patching Telegram/Bot/Brain.pm:
|
||||
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.
|
||||
|
||||
```diff
|
||||
--- Brain.pm 2019-07-01 04:04:17.000000000 +0300
|
||||
+++ Brain.pm.new 2020-09-05 22:25:20.941373455 +0300
|
||||
@@ -237,8 +237,9 @@
|
||||
|
||||
my $res = $self->ua->post($url, form => $form_args)->result;
|
||||
if ($res->is_success) { return $res->json->{result}; }
|
||||
- elsif ($res->is_error) { die "Failed to post: " . $res->message; }
|
||||
- else { die "Not sure what went wrong"; }
|
||||
+ elsif ($res->is_error) { warn "Failed to post: " . $res->message; }
|
||||
+ else { warn "Not sure what went wrong"; }
|
||||
+ return "";
|
||||
}
|
||||
```
|
||||
|
||||
[1]: https://metacpan.org/pod/Telegram::Bot
|
||||
[2]: https://metacpan.org/pod/Hailo
|
||||
[3]: https://core.telegram.org/bots/api
|
||||
[4]: https://core.telegram.org/bots/api#getting-updates
|
||||
|
||||
48
README_RU.md
Normal file
48
README_RU.md
Normal file
@@ -0,0 +1,48 @@
|
||||
# Aleesa-Telegram-bot - Болтливый бот для Telegram
|
||||
|
||||
## Что это такое
|
||||
|
||||
Это бот, основанный на перловых модулях [Telegram::Bot][1] для работы в
|
||||
мессенджере Telegram и [Hailo][2] для генерации "умной" беседы.
|
||||
|
||||
Для корректной работы, пришлось форкнуть [Telegram::Bot][1], чтобы обновить
|
||||
интерфейс API до [Telegram Bot API v5][3]. Для избежания неоднозначностей, модуль
|
||||
пришлось переименовать и теперь он идёт в составе бота. Возможно, когда модуль
|
||||
отлежится и будет похож на стабильный, он стнет самостоятельным и поселится на
|
||||
metacpan.org
|
||||
|
||||
Конфиг бота должен лежать в **data/config.json**. Пример конфига расположен в
|
||||
**data/sample_config.json**.
|
||||
|
||||
Бота можно запустить через **bin/aleesa-telegram-bot** и он взлетит, как юниксовый
|
||||
демон (сделает двойной fork() и отцепится от stdio).
|
||||
|
||||
## Установка
|
||||
|
||||
Чтобы запустить приложение, его надо "забурстрапить" - загрузить и собрать все
|
||||
необходимые зависимости.
|
||||
|
||||
Понадобится 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, hiredis-devel.
|
||||
|
||||
После установки этих пакетов, можно будет запустить:
|
||||
|
||||
```bash
|
||||
|
||||
bash bootstrap.sh
|
||||
|
||||
```
|
||||
|
||||
и, по идее, всё что нужно будет выкачено, собрано и разложено куда надо.
|
||||
|
||||
## Запуск и работа
|
||||
|
||||
Бот не использует [вебхуки][4], поэтому ничего дополнительного, кроме хорошего
|
||||
подключения к интернету ему не нужно.
|
||||
|
||||
|
||||
[1]: https://metacpan.org/pod/Telegram::Bot
|
||||
[2]: https://metacpan.org/pod/Hailo
|
||||
[3]: https://core.telegram.org/bots/api
|
||||
[4]: https://core.telegram.org/bots/api#getting-updates
|
||||
@@ -4,40 +4,55 @@ use 5.018;
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
use open qw(:std :utf8);
|
||||
use English qw( -no_match_vars );
|
||||
use open qw (:std :utf8);
|
||||
use English qw ( -no_match_vars );
|
||||
|
||||
use version; our $VERSION = qw(1.0);
|
||||
use version; our $VERSION = qw (1.0);
|
||||
|
||||
my $workdir;
|
||||
|
||||
# before we run, change working dir
|
||||
BEGIN {
|
||||
use Cwd qw(chdir abs_path);
|
||||
use Cwd qw (chdir abs_path);
|
||||
my @CWD = split /\//xms, abs_path ($PROGRAM_NAME);
|
||||
if ($#CWD > 1) { $#CWD = $#CWD - 2; }
|
||||
|
||||
if ($#CWD > 1) {
|
||||
$#CWD = $#CWD - 2;
|
||||
}
|
||||
|
||||
$workdir = join '/', @CWD;
|
||||
chdir $workdir;
|
||||
}
|
||||
|
||||
use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
|
||||
no Cwd;
|
||||
use Cwd::utf8 qw(chdir abs_path);
|
||||
use POSIX qw(setgid setuid setsid);
|
||||
use File::Path qw(make_path);
|
||||
use File::Basename qw(basename dirname);
|
||||
use conf qw(loadConf);
|
||||
use botlib qw(logger);
|
||||
use telegrambot qw(run_telegrambot);
|
||||
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);
|
||||
|
||||
sub daemonize;
|
||||
sub __fork;
|
||||
sub __signal_handler;
|
||||
|
||||
local $OUTPUT_AUTOFLUSH = 1;
|
||||
my $runAsUid = $UID;
|
||||
|
||||
my $piddir = '/var/run/' . basename (abs_path ($PROGRAM_NAME));
|
||||
my $C = loadConf ();
|
||||
my $C = LoadConf ();
|
||||
my $loglevel = $C->{'loglevel'} // 'notice';
|
||||
my $logfile;
|
||||
|
||||
if (defined $C->{'log'}) {
|
||||
$logfile = $C->{'log'};
|
||||
} elsif (defined $C->{'debug_log'}) {
|
||||
$logfile = $C->{'debug_log'};
|
||||
}
|
||||
|
||||
# if we run under root, create pid dir and set correct owner for it, same for debug log if it is defined
|
||||
if ($UID == 0) {
|
||||
@@ -58,14 +73,16 @@ if ($UID == 0) {
|
||||
);
|
||||
}
|
||||
|
||||
if ($C->{'debug_log'}) {
|
||||
unless (-d dirname ($C->{'debug_log'})) {
|
||||
if (defined $logfile) {
|
||||
my $logdir = dirname $logfile;
|
||||
|
||||
unless (-d $logdir) {
|
||||
make_path (
|
||||
dirname ($C->{'debug_log'}), {
|
||||
uid => $uid,
|
||||
group => $gid
|
||||
}
|
||||
);
|
||||
$logdir, {
|
||||
uid => $uid,
|
||||
group => $gid
|
||||
}
|
||||
) or die "Unable to create $logdir: $OS_ERROR\n";
|
||||
}
|
||||
}
|
||||
|
||||
@@ -76,6 +93,24 @@ if ($UID == 0) {
|
||||
$piddir = $workdir;
|
||||
}
|
||||
|
||||
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'
|
||||
);
|
||||
} else {
|
||||
Log::Any::Adapter->set ('File', '/dev/null');
|
||||
}
|
||||
|
||||
# double fork attach to /dev/null all stdio and go background
|
||||
daemonize ();
|
||||
|
||||
@@ -83,22 +118,39 @@ daemonize ();
|
||||
my $apath = abs_path $PROGRAM_NAME;
|
||||
|
||||
unless (defined $apath) {
|
||||
logger "Unable to get abs_path: $OS_ERROR";
|
||||
die "Unable to get abs_path: $OS_ERROR\n";
|
||||
$log->fatal ("[FATAL] Unable to get abs_path: $OS_ERROR\n");
|
||||
exit 1;
|
||||
};
|
||||
|
||||
# write pidfile
|
||||
my $pidfile = sprintf '%s/%s.pid', $piddir, basename $apath;
|
||||
logger "Creating pidfile at $pidfile";
|
||||
open my $MYPID, '>', $pidfile or die "Error opening $pidfile: $OS_ERROR\n";
|
||||
print {$MYPID} $PID or die "Error writing to $pidfile: $OS_ERROR\n";
|
||||
$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;
|
||||
};
|
||||
|
||||
close $MYPID; ## no critic (InputOutput::RequireCheckedSyscalls
|
||||
|
||||
local $SIG{INT} = \&__signal_handler;
|
||||
local $SIG{TERM} = \&__signal_handler;
|
||||
|
||||
# set correct proctitle
|
||||
$PROGRAM_NAME = abs_path $PROGRAM_NAME; ## no critic (Variables::RequireLocalizedPunctuationVars)
|
||||
|
||||
# make some global vars for telegram and redis context
|
||||
our $TGM;
|
||||
our $REDIS;
|
||||
our $RCONN;
|
||||
|
||||
# run bot, at last
|
||||
run_telegrambot ();
|
||||
RunTelegramBot ();
|
||||
|
||||
if (-f $pidfile) {
|
||||
unlink $pidfile;
|
||||
@@ -110,8 +162,9 @@ sub daemonize {
|
||||
__fork ();
|
||||
POSIX::setsid ();
|
||||
open STDIN, '<', '/dev/null'; ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
|
||||
open STDOUT, '>', '/dev/null'; ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
|
||||
open STDERR, '>', '/dev/null'; ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
|
||||
# we handle STDOUT && STDERR via Log::Any::For::Std, so do not close them explicitly
|
||||
#open STDOUT, '>', '/dev/null'; ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
|
||||
#open STDERR, '>', '/dev/null'; ## no critic (InputOutput::RequireCheckedSyscalls, InputOutput::RequireCheckedOpen)
|
||||
__fork ();
|
||||
umask 0;
|
||||
return;
|
||||
@@ -119,10 +172,28 @@ sub daemonize {
|
||||
|
||||
sub __fork {
|
||||
my $pid = fork;
|
||||
unless (defined $pid) { die "Can't fork: $OS_ERROR\n"; }
|
||||
exit if ($pid != 0);
|
||||
|
||||
unless (defined $pid) {
|
||||
$log->fatal ("[FATAL] Can't fork: $OS_ERROR");
|
||||
exit 1;
|
||||
}
|
||||
|
||||
if ($pid != 0) {
|
||||
exit;
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub __signal_handler {
|
||||
$log->info ("[INFO] Caught a signal $OS_ERROR");
|
||||
|
||||
if (-f $pidfile) {
|
||||
unlink $pidfile;
|
||||
}
|
||||
|
||||
exit 0;
|
||||
}
|
||||
|
||||
__END__
|
||||
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
||||
|
||||
@@ -1,27 +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 vars qw/$VERSION/;
|
||||
$VERSION = '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 lat qw(train);
|
||||
|
||||
train ();
|
||||
exit 0;
|
||||
@@ -1,5 +1,5 @@
|
||||
#!/bin/bash
|
||||
|
||||
cpanm -l vendor_perl --self-contained --force --update --installdeps .
|
||||
cpanm -l vendor_perl --self-contained --force --installdeps .
|
||||
|
||||
# vim: set ft=sh noet ai ts=4 sw=4 sts=4:
|
||||
|
||||
21
confcheck.pl
21
confcheck.pl
@@ -4,16 +4,16 @@ use 5.018;
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
use open qw(:std :utf8);
|
||||
use English qw( -no_match_vars );
|
||||
use lib qw(./lib ./vendor_perl ./vendor_perl/lib/perl5);
|
||||
use JSON::PP;
|
||||
use open qw (:std :utf8);
|
||||
use English qw ( -no_match_vars );
|
||||
use lib qw (./lib ./vendor_perl ./vendor_perl/lib/perl5);
|
||||
use JSON::XS;
|
||||
|
||||
use version; our $VERSION = qv(1.0);
|
||||
use version; our $VERSION = qw (1.0);
|
||||
|
||||
my $c = 'data/config.json';
|
||||
open (my $C, '<', $c) or die "No conf at $c: $OS_ERROR\n"; ## no critic (InputOutput::RequireBriefOpen)
|
||||
my $len = (stat ($c)) [7];
|
||||
open (my $C, '<', $c) or die "No conf at $c: $OS_ERROR\n";
|
||||
my $len = (stat $c) [7];
|
||||
my $json;
|
||||
my $readlen = read ($C, $json, $len);
|
||||
|
||||
@@ -28,9 +28,10 @@ if ($readlen != $len) {
|
||||
}
|
||||
|
||||
close C; ## no critic (InputOutput::RequireCheckedSyscalls)
|
||||
$c = decode_json ($json);
|
||||
$c = JSON::XS->new->utf8->relaxed;
|
||||
my $data = $c->decode ($json);
|
||||
|
||||
my $j = JSON::PP->new->pretty->canonical->indent_length (4); ## no critic (ValuesAndExpressions::ProhibitLongChainsOfMethodCalls)
|
||||
print $j->encode ($c); ## no critic (InputOutput::RequireCheckedSyscalls)
|
||||
my $j = JSON::XS->new->pretty();
|
||||
print $j->encode ($data); ## no critic (InputOutput::RequireCheckedSyscalls)
|
||||
|
||||
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
||||
|
||||
34
cpanfile
34
cpanfile
@@ -1,15 +1,37 @@
|
||||
requires 'Carp';
|
||||
requires 'Clone';
|
||||
requires 'CHI';
|
||||
requires 'CHI::Driver::BerkeleyDB';
|
||||
requires 'Cwd::utf8';
|
||||
requires 'DateTime';
|
||||
requires 'DB_File';
|
||||
requires 'SQLite_File';
|
||||
requires 'DBI';
|
||||
requires 'DBD::SQLite';
|
||||
requires 'Digest::HMAC_SHA1';
|
||||
requires 'Digest::MD5';
|
||||
requires 'Encode';
|
||||
requires 'Data::Dumper';
|
||||
requires 'Digest::SHA';
|
||||
requires 'File::Basename';
|
||||
requires 'File::Path';
|
||||
requires 'HTTP::Tiny';
|
||||
requires 'Hailo';
|
||||
requires 'HTML::TokeParser';
|
||||
requires 'IO::Socket::SSL';
|
||||
requires 'JSON';
|
||||
requires 'JSON::XS';
|
||||
requires 'JSON::PP';
|
||||
requires 'Mojo::Base';
|
||||
requires 'Telegram::Bot';
|
||||
requires 'URI::URL';
|
||||
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::Redis';
|
||||
requires 'Mojo::UserAgent';
|
||||
requires 'Mojo::UserAgent::Cached';
|
||||
requires 'Protocol::Redis::XS';
|
||||
requires 'String::Random';
|
||||
requires 'Text::Fuzzy';
|
||||
requires 'URI::Encode::XS';
|
||||
requires 'URI::URL';
|
||||
|
||||
1336
data/phrases.txt
1336
data/phrases.txt
File diff suppressed because it is too large
Load Diff
@@ -1,19 +1,39 @@
|
||||
{
|
||||
"user" : "nobody",
|
||||
"debug_log" : "/var/log/aleesa-telegram-bot/debug.log",
|
||||
# Cachedir used not only for caches but for some settings and stats too.
|
||||
"cachedir" : "data/cache",
|
||||
|
||||
"gamestat" : {
|
||||
"dir" : "data",
|
||||
"gamestatdir" : "data/gamestat"
|
||||
},
|
||||
|
||||
# Required for debugging reasons, if commented out or not exist, no debug logging appears at all.
|
||||
"log" : "/var/log/aleesa-telegram-bot/aleesa.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",
|
||||
|
||||
# Stuff for telegram itself.
|
||||
"telegrambot" : {
|
||||
"name" : "mybot",
|
||||
"tname" : "@my_bot",
|
||||
|
||||
# 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.
|
||||
"csign" : "!",
|
||||
"token" : "get_it_from_botfather",
|
||||
"braindir": "data/telegrambot-brains"
|
||||
|
||||
"token" : "Long_string_given_by_@BotFather"
|
||||
},
|
||||
"openweathermap" : {
|
||||
"cachetime": "data/cache/openweathermap.Id-Timestamp.db",
|
||||
"cachedata": "data/cache/openweathermap.Id-Data.db",
|
||||
"appid": "get_it_on_openweathermap.org"
|
||||
},
|
||||
"lat" : {
|
||||
"brain": "data/lat/lat.sqlite"
|
||||
}
|
||||
|
||||
# Unprivileged user to run this bot from.
|
||||
"user" : "nobody",
|
||||
|
||||
"redis_server": "127.0.0.1",
|
||||
"redis_port" : "6379",
|
||||
"redis_channels" : [
|
||||
"telegram"
|
||||
],
|
||||
"redis_router_channel" : "misc"
|
||||
}
|
||||
|
||||
387
lib/BotLib.pm
Normal file
387
lib/BotLib.pm
Normal file
@@ -0,0 +1,387 @@
|
||||
package BotLib;
|
||||
# store here utility functions that are not protocol-specified
|
||||
|
||||
use 5.018;
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
use open qw (:std :utf8);
|
||||
use English qw ( -no_match_vars );
|
||||
|
||||
use Carp qw (carp);
|
||||
use Clone qw (clone);
|
||||
use Math::Random::Secure qw (irand);
|
||||
use Data::Dumper;
|
||||
use Log::Any qw ($log);
|
||||
|
||||
use BotLib::Conf qw (LoadConf);
|
||||
use BotLib::Admin qw (@ForbiddenMessageTypes GetForbiddenTypes AddForbiddenType
|
||||
DelForbiddenType ListForbidden FortuneToggle FortuneStatus
|
||||
PluginToggle PluginStatus PluginEnabled ChanMsgToggle ChanMsgStatus);
|
||||
use BotLib::Util qw (trim);
|
||||
|
||||
use version; our $VERSION = qw (1.0);
|
||||
use Exporter qw (import);
|
||||
our @EXPORT_OK = qw (Command Highlight BotSleep IsCensored);
|
||||
|
||||
my $c = LoadConf ();
|
||||
my $csign = $c->{telegrambot}->{csign};
|
||||
my $redismsg->{from} = 'telegram';
|
||||
$redismsg->{plugin} = 'telegram';
|
||||
$redismsg->{misc}->{answer} = 1;
|
||||
$redismsg->{misc}->{csign} = $c->{telegrambot}->{csign};
|
||||
$redismsg->{misc}->{msg_format} = 0;
|
||||
$redismsg->{misc}->{fwd_cnt} = 1;
|
||||
|
||||
sub Command {
|
||||
my $self = shift;
|
||||
my $msg = shift;
|
||||
my $text = shift;
|
||||
my $chatid = shift;
|
||||
|
||||
my $reply;
|
||||
my ($userid, $username, $fullname, $highlight, $visavi) = Highlight ($msg);
|
||||
my $rmsg = clone ($redismsg);
|
||||
$rmsg->{userid} = $userid;
|
||||
$rmsg->{chatid} = $chatid;
|
||||
|
||||
if ($chatid >= 0) {
|
||||
$rmsg->{mode} = 'private';
|
||||
} else {
|
||||
$rmsg->{mode} = 'public';
|
||||
}
|
||||
|
||||
my $cmd = substr $text, 1;
|
||||
|
||||
# Проверка #1 на админское разрешение некоторых команд
|
||||
my @cmds = qw (tits boobs tities boobies сиси сисечки);
|
||||
|
||||
while (my $check = pop @cmds) {
|
||||
if ($cmd eq $check) {
|
||||
unless (PluginEnabled $chatid, 'oboobs') {
|
||||
return;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Проверка #2 на админское разрешение некоторых команд
|
||||
$#cmds = -1;
|
||||
@cmds = qw (butt booty ass попа попка);
|
||||
|
||||
while (my $check = pop @cmds) {
|
||||
if ($cmd eq $check) {
|
||||
unless (PluginEnabled $chatid, 'obutts') {
|
||||
return;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Полноценный поиск простой команды во входящем сообщении
|
||||
$#cmds = -1;
|
||||
@cmds = qw (ping пинг пинх pong понг понх coin монетка roll dice кости ver version версия хэлп halp kde кде lat
|
||||
лат friday пятница proverb пословица fortune фортунка f ф anek анек анекдот buni cat кис drink праздник fox лис
|
||||
frog лягушка horse лошадь лошадка monkeyuser owl сова сыч rabbit bunny кролик snail улитка tits boobs tities
|
||||
boobies сиси сисечки butt booty ass попа попка xkcd dig копать fish fishing рыба рыбка рыбалка);
|
||||
|
||||
my $bingo = 0;
|
||||
|
||||
while (my $check = pop @cmds) {
|
||||
if ($cmd eq $check) {
|
||||
$bingo = 1;
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
# Поиск "сложных" команд во входящем сообщении
|
||||
if (($cmd =~ /^w\s/u) || ($cmd =~ /^п\s/u) || ($cmd =~ /^weather\s/u) || ($cmd =~ /^погода\s/u) ||
|
||||
($cmd =~ /^погодка\s/u) || ($cmd =~ /^погадка\s/u) || ($cmd =~ /^karma\s/u) || ($cmd =~ /карма\s/u)) {
|
||||
$bingo = 1;
|
||||
}
|
||||
|
||||
# Если команда найдена...
|
||||
if ($bingo) {
|
||||
$rmsg->{message} = $text;
|
||||
$self->log->debug ('[DEBUG] Sending message to redis ' . Dumper ($rmsg));
|
||||
|
||||
# Для некоторых команд мы хотим получать форматированный вывод
|
||||
$#cmds = -1;
|
||||
@cmds = qw (fortune фортунка f ф anek анек анекдот buni cat кис fox лис frog лягушка horse лошадь
|
||||
лошадка monkeyuser owl сова сыч rabbit bunny кролик snail улитка tits boobs tities boobies сиси сисечки
|
||||
butt booty ass попа попка xkcd);
|
||||
|
||||
while (my $check = pop @cmds) {
|
||||
if ($cmd eq $check) {
|
||||
$rmsg->{misc}->{msg_format} = 1;
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
# Для других команд, хотим, чтобы было упоминание пользователя в ответе, чтобы подсветить его
|
||||
$#cmds = -1;
|
||||
@cmds = qw (dig копать fish fishing рыба рыбка рыбалка);
|
||||
|
||||
while (my $check = pop @cmds) {
|
||||
if ($cmd eq $check) {
|
||||
$rmsg->{misc}->{msg_format} = 1;
|
||||
$rmsg->{misc}->{username} = $highlight;
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
# Если соединения с редиской нету, ждём, пока оно появится. Своего рода костыль на всякий случай.
|
||||
{
|
||||
do {
|
||||
my $ready = eval { $main::RCONN->is_connected; };
|
||||
last if ($ready);
|
||||
} while (sleep 1);
|
||||
}
|
||||
|
||||
my $pubsub = $main::REDIS->pubsub;
|
||||
|
||||
$pubsub->json ($c->{'redis_router_channel'})->notify (
|
||||
$c->{'redis_router_channel'} => $rmsg
|
||||
);
|
||||
# Если команда не найдена, но строка подозрительно напоминает команду help
|
||||
} 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}рыбка - порыбачить
|
||||
${csign}fishing | ${csign}рыбалка - порыбачить
|
||||
${csign}f | ${csign}ф - рандомная фраза из сборника цитат fortune_mod
|
||||
${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}сыч - сова
|
||||
${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}карма фраза - посмотреть карму фразы
|
||||
фраза-- | фраза++ - убавить или добавить карму фразе
|
||||
```
|
||||
Но на самом деле я бот больше для общения, чем для исполнения команд.
|
||||
Поговоришь со мной?
|
||||
MYHELP
|
||||
$msg->replyMd ($reply);
|
||||
return;
|
||||
# Если строка не найдена, но это команда admin
|
||||
} elsif (substr ($text, 1) eq 'admin' || substr ($text, 1) eq 'админ') {
|
||||
my $member = $self->getChatMember ({ 'chat_id' => $msg->chat->id, 'user_id' => $msg->from->id });
|
||||
|
||||
# Это должно показываться только админам чата
|
||||
if (($member->status eq 'administrator') || ($member->status eq 'creator')) {
|
||||
$reply = << "MYADMIN";
|
||||
```
|
||||
${csign}admin censor type # - где 1 - вкл, 0 - выкл цензуры для означенного типа сообщений
|
||||
${csign}админ ценз тип # - где 1 - вкл, 0 - выкл цензуры для означенного типа сообщений
|
||||
${csign}admin censor - показать список состояния типов сообщений
|
||||
${csign}админ ценз - показать список состояния типов сообщений
|
||||
${csign}admin fortune # - где 1 - вкл, 0 - выкл фортунку с утра
|
||||
${csign}admin фортунка # - где 1 - вкл, 0 - выкл фортунку с утра
|
||||
${csign}admin fortune - показываем ли с утра фортунку для чата
|
||||
${csign}admin фортунка - показываем ли с утра фортунку для чата
|
||||
${csign}admin oboobs # - где 1 - вкл, 0 - выкл плагина oboobs
|
||||
${csign}admin oboobs - показываем ли сисечки по просьбе участников чата (команды ${csign}tits, ${csign}tities, ${csign}boobs, ${csign}boobies, ${csign}сиси, ${csign}сисечки)
|
||||
${csign}admin obutts # - где 1 - вкл, 0 - выкл плагина obutts
|
||||
${csign}admin obutts - показываем ли попки по просьбе участников чата (команды ${csign}ass, ${csign}butt, ${csign}booty, ${csign}попа, ${csign}попка)
|
||||
${csign}admin chan_msg - оставляем ли сообщения присланные от имени (других) каналов
|
||||
${csign}admin chan_msg # - где 1 - оставляем, 0 - удаляем
|
||||
```
|
||||
Типы сообщений:
|
||||
audio voice photo video animation sticker dice game poll document
|
||||
MYADMIN
|
||||
|
||||
$msg->replyMd ($reply);
|
||||
}
|
||||
|
||||
return;
|
||||
# Если строка не найдена, но это команда admin с параметрами
|
||||
} elsif ((substr ($text, 1, 5) eq 'admin' || substr ($text, 1, 5) eq 'админ') && (length ($text) >= 8)) {
|
||||
my $member = $self->getChatMember ({ 'chat_id' => $msg->chat->id, 'user_id' => $msg->from->id });
|
||||
|
||||
# Это должно показываться только админам чата
|
||||
if (($member->status eq 'administrator') || ($member->status eq 'creator')) {
|
||||
# Вынем субкоманду, это первый аргумент команды admin
|
||||
my $command = trim (substr $text, 7);
|
||||
$cmd = undef;
|
||||
my $args;
|
||||
($cmd, $args) = split /\s+/, $command, 2;
|
||||
|
||||
# Субкоманды не нашлось, ну и какбэ досвидонья
|
||||
if ($cmd eq '') {
|
||||
return;
|
||||
# Субкоманда censor...
|
||||
} elsif ($cmd eq 'censor' || $cmd eq 'ценз') {
|
||||
# Censor с аргументами
|
||||
if (defined ($args) && ($args ne '')) {
|
||||
my ($msgType, $toggle) = split /\s/, $args, 2;
|
||||
|
||||
if (defined $toggle) {
|
||||
foreach (@ForbiddenMessageTypes) {
|
||||
if ($msgType eq $_) {
|
||||
if ($toggle == 1) {
|
||||
AddForbiddenType ($chatid, $msgType);
|
||||
$reply = "Теперь сообщения с $msgType будут автоматически удаляться";
|
||||
} elsif ($toggle == 0) {
|
||||
DelForbiddenType ($chatid, $msgType);
|
||||
$reply = "Теперь сообщения с $msgType будут оставаться";
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
# Censor без аргументов, выдаёт список типов сообщений и будут ли они автоматически удаляться
|
||||
} else {
|
||||
$reply = ListForbidden ($chatid);
|
||||
}
|
||||
# Хотим ли мы показывать фортунку с утра
|
||||
} elsif ($cmd eq 'fortune' || $cmd eq 'фортунка') {
|
||||
if (defined $args) {
|
||||
if ($args == 1) {
|
||||
$reply = FortuneToggle ($chatid, 1);
|
||||
} elsif ($args == 0) {
|
||||
$reply = FortuneToggle ($chatid, 0);
|
||||
}
|
||||
} else {
|
||||
$reply = FortuneStatus ($chatid);
|
||||
}
|
||||
# Хотим ли мы удалять "сообщения от каналов"
|
||||
} elsif ($cmd eq 'chan_msg') {
|
||||
if (defined $args) {
|
||||
if ($args == 1) {
|
||||
$reply = ChanMsgToggle ($chatid, 1);
|
||||
} elsif ($args == 0) {
|
||||
$reply = ChanMsgToggle ($chatid, 0);
|
||||
}
|
||||
} else {
|
||||
$reply = ChanMsgStatus ($chatid);
|
||||
}
|
||||
# Работает ли плагин oboobs в чатике
|
||||
} elsif ($cmd eq 'oboobs') {
|
||||
if (defined $args) {
|
||||
if ($args == 1) {
|
||||
$reply = PluginToggle ($chatid, 'oboobs', 1);
|
||||
} elsif ($args == 0) {
|
||||
$reply = PluginToggle ($chatid, 'oboobs', 0);
|
||||
}
|
||||
} else {
|
||||
$reply = PluginStatus ($chatid, 'oboobs');
|
||||
}
|
||||
# Работает ли плагин obutts в чатике
|
||||
} elsif ($cmd eq 'obutts') {
|
||||
if (defined $args) {
|
||||
if ($args == 1) {
|
||||
$reply = PluginToggle ($chatid, 'obutts', 1);
|
||||
} elsif ($args == 0) {
|
||||
$reply = PluginToggle ($chatid, 'obutts', 0);
|
||||
}
|
||||
} else {
|
||||
$reply = PluginStatus ($chatid, 'obutts');
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return $reply;
|
||||
}
|
||||
|
||||
sub Highlight {
|
||||
my $msg = shift;
|
||||
|
||||
my $fullname;
|
||||
my $highlight;
|
||||
my $username;
|
||||
my $visavi = '';
|
||||
my $userid = $msg->from->id;
|
||||
|
||||
if ($msg->from->can ('username') && defined $msg->from->username ) {
|
||||
$username = $msg->from->username;
|
||||
}
|
||||
|
||||
if ($msg->from->can ('first_name') && defined $msg->from->first_name) {
|
||||
$fullname = $msg->from->first_name;
|
||||
|
||||
if ($msg->from->can ('last_name') && defined $msg->from->last_name) {
|
||||
$fullname .= ' ' . $msg->from->last_name;
|
||||
}
|
||||
} elsif ($msg->from->can ('last_name') && defined $msg->from->last_name) {
|
||||
$fullname .= $msg->from->last_name;
|
||||
}
|
||||
|
||||
if (defined $username) {
|
||||
$visavi .= '@' . $username;
|
||||
|
||||
if (defined $fullname) {
|
||||
$highlight = "[$fullname](tg://user?id=$userid)";
|
||||
$visavi .= ', ' . $fullname;
|
||||
} else {
|
||||
$highlight = "[$username](tg://user?id=$userid)";
|
||||
}
|
||||
} else {
|
||||
$highlight = "[$fullname](tg://user?id=$userid)";
|
||||
$visavi .= $fullname;
|
||||
}
|
||||
|
||||
$visavi .= " ($userid)";
|
||||
|
||||
return ($userid, $username, $fullname, $highlight, $visavi);
|
||||
}
|
||||
|
||||
sub BotSleep {
|
||||
# TODO: Parametrise this with fuzzy sleep time in seconds
|
||||
my $msg = shift;
|
||||
# let's emulate real human and delay answer
|
||||
sleep (irand (2) + 1);
|
||||
|
||||
for (0..(4 + irand (3))) {
|
||||
$msg->typing ();
|
||||
sleep 3;
|
||||
sleep 3 unless ($_);
|
||||
}
|
||||
|
||||
sleep ( 3 + irand (2));
|
||||
return;
|
||||
}
|
||||
|
||||
sub IsCensored {
|
||||
my $msg = shift;
|
||||
|
||||
my $forbidden = GetForbiddenTypes ($msg->chat->id);
|
||||
|
||||
# voice messages are special
|
||||
if (defined ($msg->voice) && defined ($msg->voice->duration) && ($msg->voice->duration > 0)) {
|
||||
if ($forbidden->{'voice'}) {
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
|
||||
foreach (keys %{$forbidden}) {
|
||||
if ($forbidden->{$_} && (defined $msg->{$_})) {
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
||||
367
lib/BotLib/Admin.pm
Normal file
367
lib/BotLib/Admin.pm
Normal file
@@ -0,0 +1,367 @@
|
||||
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 ChanMsgToggle ChanMsgStatus ChanMsgEnabled);
|
||||
|
||||
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 ChanMsgToggle (@) {
|
||||
my $chatid = shift;
|
||||
my $action = shift // undef;
|
||||
my $phrase = 'Сообщения, пришедшие от имени каналов ';
|
||||
|
||||
my $cache = CHI->new (
|
||||
driver => 'BerkeleyDB',
|
||||
root_dir => $cachedir,
|
||||
namespace => __PACKAGE__ . '_' . 'chan_msg'
|
||||
);
|
||||
|
||||
my $state = $cache->get ($chatid);
|
||||
|
||||
if (defined $action) {
|
||||
if ($action) {
|
||||
$cache->set ($chatid, 1, 'never');
|
||||
$phrase .= 'не будут удаляться.';
|
||||
} else {
|
||||
if (defined $state && $state) {
|
||||
$cache->set ($chatid, 0, 'never');
|
||||
$phrase .= 'будут удаляться.';
|
||||
} else {
|
||||
$cache->set ($chatid, 1, 'never');
|
||||
$phrase .= 'не будут удаляться.';
|
||||
}
|
||||
}
|
||||
} else {
|
||||
if (defined $state){
|
||||
if ($state) {
|
||||
$cache->set ($chatid, 0, 'never');
|
||||
$phrase .= 'будут удаляться.';
|
||||
} else {
|
||||
$cache->set ($chatid, 1, 'never');
|
||||
$phrase .= 'не будут удаляться.';
|
||||
}
|
||||
} else {
|
||||
$cache->set ($chatid, 1, 'never');
|
||||
$phrase .= 'не будут удаляться.';
|
||||
}
|
||||
}
|
||||
|
||||
return $phrase;
|
||||
}
|
||||
|
||||
sub ChanMsgStatus ($) {
|
||||
my $chatid = shift;
|
||||
my $phrase = 'Сообщения, пришедшие от имени каналов ';
|
||||
|
||||
my $cache = CHI->new (
|
||||
driver => 'BerkeleyDB',
|
||||
root_dir => $cachedir,
|
||||
namespace => __PACKAGE__ . '_' . 'chan_msg'
|
||||
);
|
||||
|
||||
my $state = $cache->get ($chatid);
|
||||
|
||||
if (defined $state) {
|
||||
if ($state) {
|
||||
$phrase .= 'не удаляются.';
|
||||
} else {
|
||||
$phrase .= 'удаляются.';
|
||||
}
|
||||
} else {
|
||||
$phrase .= 'не удаляются.';
|
||||
}
|
||||
|
||||
return $phrase;
|
||||
}
|
||||
|
||||
sub ChanMsgEnabled ($) {
|
||||
my $chatid = shift;
|
||||
|
||||
my $cache = CHI->new (
|
||||
driver => 'BerkeleyDB',
|
||||
root_dir => $cachedir,
|
||||
namespace => __PACKAGE__ . '_' . 'chan_msg'
|
||||
);
|
||||
|
||||
my $state = $cache->get ($chatid);
|
||||
|
||||
if (defined $state) {
|
||||
if ($state) {
|
||||
return 1;
|
||||
} else {
|
||||
return 0;
|
||||
}
|
||||
} else {
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
|
||||
sub ChanMsgToggleList () {
|
||||
my $cache = CHI->new (
|
||||
driver => 'BerkeleyDB',
|
||||
root_dir => $cachedir,
|
||||
namespace => __PACKAGE__ . '_' . 'chan_msg'
|
||||
);
|
||||
|
||||
return $cache->get_keys ();
|
||||
}
|
||||
|
||||
sub PluginStatus (@) {
|
||||
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,36 +1,33 @@
|
||||
package conf;
|
||||
package BotLib::Conf;
|
||||
# loads config
|
||||
|
||||
use 5.018;
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
use open qw(:std :utf8);
|
||||
use English qw( -no_match_vars );
|
||||
|
||||
use vars qw/$VERSION/;
|
||||
use open qw (:std :utf8);
|
||||
use English qw ( -no_match_vars );
|
||||
use JSON::XS;
|
||||
|
||||
use Exporter qw(import);
|
||||
our @EXPORT_OK = qw(loadConf);
|
||||
use version; our $VERSION = qw (1.0);
|
||||
use Exporter qw (import);
|
||||
our @EXPORT_OK = qw (LoadConf);
|
||||
|
||||
$VERSION = '1.0';
|
||||
|
||||
sub loadConf {
|
||||
sub LoadConf {
|
||||
my $c = 'data/config.json';
|
||||
open my $CH, '<', $c or die "[FATA] No conf at $c: $OS_ERROR\n";
|
||||
my $len = (stat ($c)) [7];
|
||||
open my $CH, '<', $c or die "[FATAL] No conf at $c: $OS_ERROR\n";
|
||||
my $len = (stat $c) [7];
|
||||
my $json;
|
||||
my $readlen = read $CH, $json, $len;
|
||||
|
||||
unless ($readlen) {
|
||||
close $CH; ## no critic (InputOutput::RequireCheckedSyscalls
|
||||
die "[FATA] Unable to read $c: $OS_ERROR\n";
|
||||
die "[FATAL] Unable to read $c: $OS_ERROR\n";
|
||||
}
|
||||
|
||||
if ($readlen != $len) {
|
||||
close $CH; ## no critic (InputOutput::RequireCheckedSyscalls
|
||||
die "[FATA] File $c is $len bytes on disk, but we read only $readlen bytes\n";
|
||||
die "[FATAL] File $c is $len bytes on disk, but we read only $readlen bytes\n";
|
||||
}
|
||||
|
||||
close $CH; ## no critic (InputOutput::RequireCheckedSyscalls
|
||||
82
lib/BotLib/Util.pm
Normal file
82
lib/BotLib/Util.pm
Normal file
@@ -0,0 +1,82 @@
|
||||
package BotLib::Util;
|
||||
|
||||
use 5.018;
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
use open qw (:std :utf8);
|
||||
use English qw ( -no_match_vars );
|
||||
use Digest::SHA qw (sha1_base64);
|
||||
use Encode;
|
||||
use MIME::Base64;
|
||||
use Text::Fuzzy qw (distance_edits);
|
||||
use URI::URL;
|
||||
|
||||
use version; our $VERSION = qw (1.0);
|
||||
use Exporter qw (import);
|
||||
our @EXPORT_OK = qw (trim urlencode fmatch utf2b64 utf2sha1);
|
||||
|
||||
sub trim {
|
||||
my $str = shift;
|
||||
|
||||
if ($str eq '') {
|
||||
return $str;
|
||||
}
|
||||
|
||||
while (substr ($str, 0, 1) =~ /^\s$/xms) {
|
||||
$str = substr $str, 1;
|
||||
}
|
||||
|
||||
while (substr ($str, -1, 1) =~ /^\s$/xms) {
|
||||
chop $str;
|
||||
}
|
||||
|
||||
return $str;
|
||||
}
|
||||
|
||||
sub urlencode {
|
||||
my $str = shift;
|
||||
my $urlobj = url $str;
|
||||
return $urlobj->as_string;
|
||||
}
|
||||
|
||||
sub fmatch {
|
||||
my $srcphrase = shift;
|
||||
my $answer = shift;
|
||||
|
||||
my ($distance, undef) = distance_edits ($srcphrase, $answer);
|
||||
my $srcphraselen = length $srcphrase;
|
||||
my $distance_max = int ($srcphraselen - ($srcphraselen * (100 - (90 / ($srcphraselen ** 0.5))) * 0.01));
|
||||
|
||||
if ($distance >= $distance_max) {
|
||||
return 0;
|
||||
} else {
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
|
||||
sub utf2b64 {
|
||||
my $string = shift;
|
||||
|
||||
if ($string eq '') {
|
||||
return encode_base64 '';
|
||||
}
|
||||
|
||||
my $bytes = encode_utf8 $string;
|
||||
return encode_base64 $bytes;
|
||||
}
|
||||
|
||||
sub utf2sha1 {
|
||||
my $string = shift;
|
||||
|
||||
if ($string eq '') {
|
||||
return sha1_base64 '';
|
||||
}
|
||||
|
||||
my $bytes = encode_utf8 $string;
|
||||
return sha1_base64 $bytes;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
||||
111
lib/RedisLib.pm
Normal file
111
lib/RedisLib.pm
Normal file
@@ -0,0 +1,111 @@
|
||||
package RedisLib;
|
||||
|
||||
use 5.018;
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
use open qw (:std :utf8);
|
||||
|
||||
use Log::Any qw ($log);
|
||||
# Чтобы "уж точно" использовать hiredis-биндинги, загрузим этот модуль перед Mojo::Redis
|
||||
use Protocol::Redis::XS;
|
||||
use Mojo::Redis;
|
||||
use Mojo::Redis::Connection;
|
||||
|
||||
use BotLib::Conf qw (LoadConf);
|
||||
|
||||
use version; our $VERSION = qw (1.0);
|
||||
use Exporter qw (import);
|
||||
our @EXPORT_OK = qw (redis_parse_message redis_events_listener);
|
||||
|
||||
my $c = LoadConf ();
|
||||
|
||||
sub redis_parse_message {
|
||||
my $self = shift;
|
||||
my $m = shift;
|
||||
my $message;
|
||||
|
||||
# Мы "не можем" отправлять сообщения в телеграм, если мы к нему не подключены
|
||||
# (конечно, можем, но Teapot-lib предполагает, что объектик с чатом - это его собственность, а городить свой что-то
|
||||
# не очень хочется)
|
||||
until (defined $main::TGM) {
|
||||
sleep 1;
|
||||
}
|
||||
|
||||
if ($m->{misc}->{msg_format}) {
|
||||
$message->{parse_mode} = 'Markdown';
|
||||
}
|
||||
|
||||
$message->{chat_id} = $m->{chatid};
|
||||
$message->{text} = $m->{message};
|
||||
|
||||
if (Teapot::Bot::Object::ChatPermissions::canTalk ($main::TGM, $m->{chatid})) {
|
||||
# Результат этого действия нас не сильно волнует, т.к. если будет ошибка, то в лог попадёт трейс
|
||||
$main::TGM->sendMessage ($message);
|
||||
}
|
||||
|
||||
return;
|
||||
};
|
||||
|
||||
sub redis_events_listener {
|
||||
$log->notice ('[NOTICE]Run redis events listener');
|
||||
# If we already connected there is no point to disconnect
|
||||
if (defined $main::REDIS) {
|
||||
my $connected = eval { Mojo::Redis::Connection->is_connected ($main::REDIS); };
|
||||
|
||||
if ($connected) {
|
||||
$log->notice ('[NOTICE] Redis client already running and connected');
|
||||
return;
|
||||
} else {
|
||||
$log->notice ('[NOTICE] Redis client registered, but looks like it is not connected, try to re-connect');
|
||||
$main::REDIS = undef;
|
||||
}
|
||||
}
|
||||
|
||||
my $r = Mojo::Redis->new (
|
||||
sprintf 'redis://%s:%s/1', $c->{redis_server}, $c->{redis_port}
|
||||
);
|
||||
|
||||
$log->notice ('[NOTICE] New redis client registered, registering callbacks');
|
||||
# Don't forget to update global ref to our redis context
|
||||
$main::REDIS = $r;
|
||||
|
||||
$r->on (
|
||||
connection => sub {
|
||||
my ($redis, $connection) = @_;
|
||||
$main::RCONN = $connection;
|
||||
|
||||
# Log error
|
||||
$connection->on (
|
||||
error => sub {
|
||||
my ($conn, $error) = @_;
|
||||
$log->error ("[ERROR] Redis connection error: $error");
|
||||
$main::RCONN = undef;
|
||||
return;
|
||||
}
|
||||
);
|
||||
|
||||
return;
|
||||
}
|
||||
);
|
||||
|
||||
# Subscribe to channels
|
||||
my $pubsub = $r->pubsub;
|
||||
my $sub;
|
||||
my $rpm = \&redis_parse_message;
|
||||
$log->notice ('[NOTICE] Subscribing to redis channels');
|
||||
|
||||
foreach my $channel (@{$c->{redis_channels}}) {
|
||||
$log->info ("[INFO] Subscribing to $channel");
|
||||
|
||||
$sub->{$channel} = $pubsub->json ($channel)->listen (
|
||||
$channel => sub { $rpm->(@_); }
|
||||
);
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
||||
100
lib/Teapot/Bot.pm
Normal file
100
lib/Teapot/Bot.pm
Normal file
@@ -0,0 +1,100 @@
|
||||
package Teapot::Bot;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
$Teapot::Bot::VERSION = '0.022';
|
||||
# ABSTRACT: A base class to make your very own Telegram bot
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A base class to make your very own Telegram bot
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
NOTE: This API should not yet be considered stable.
|
||||
|
||||
Creating a bot is easy:
|
||||
|
||||
package MyBot;
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Brain';
|
||||
|
||||
has token => 'YOURTOKENHERE';
|
||||
|
||||
# send a polite reply, to either a group or a single user,
|
||||
# depending on where we were addressed from
|
||||
sub _be_polite {
|
||||
my ($self, $msg) = @_;
|
||||
|
||||
return unless $msg->text =~ /hello/;
|
||||
|
||||
# is this a 1-on-1 ?
|
||||
if ($msg->chat->is_user) {
|
||||
$msg->reply("hello there");
|
||||
|
||||
# send them a picture as well
|
||||
$self->sendPhoto({chat_id => $msg->chat->id, photo => $image_filename});
|
||||
}
|
||||
# group chat
|
||||
else {
|
||||
$msg->reply("hello to everyone!");
|
||||
}
|
||||
}
|
||||
|
||||
# setup our bot
|
||||
sub init {
|
||||
my $self = shift;
|
||||
$self->add_listener(\&_be_polite);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
Now just:
|
||||
|
||||
perl -MMyBot -E 'MyBot->new->think'
|
||||
|
||||
and you've got yourself a stew, baby! Or a bot, anyway.
|
||||
|
||||
Note that for the bot to see messages that do not start with a leading '/', you will need to use
|
||||
the C<'/setprivacy'> command on Telegram's C<@botfather> interface to change the privacy settings.
|
||||
|
||||
=head1 DEPENDENCIES
|
||||
|
||||
IO::Socket::SSL
|
||||
Log::Any
|
||||
Mojolicious
|
||||
Test::Exception
|
||||
|
||||
=head1 EXAMPLES
|
||||
|
||||
This distribution's C<ex/> directory contains some complete examples that may be
|
||||
instructive to look at.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Justin Hawkins <justin@eatmorecode.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This software is copyright (c) 2019 by Justin Hawkins.
|
||||
|
||||
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
|
||||
966
lib/Teapot/Bot/Brain.pm
Normal file
966
lib/Teapot/Bot/Brain.pm
Normal file
@@ -0,0 +1,966 @@
|
||||
package Teapot::Bot::Brain;
|
||||
|
||||
# ABSTRACT: A base class to make your very own Telegram bot
|
||||
|
||||
use Mojo::Base -base;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use English qw ( -no_match_vars );
|
||||
|
||||
use Mojo::IOLoop;
|
||||
use Mojo::UserAgent;
|
||||
use Carp qw/croak cluck confess/; # use croak where we return error up to app that supply something wrong
|
||||
# use cluck where we want to say that something bad but non-critical happen in
|
||||
# lower layer (Mojo loop)
|
||||
# use confess where we want to say that fatal error happen in lower layer (Mojo loop)
|
||||
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';
|
||||
|
||||
# base class for building telegram robots with Mojolicious
|
||||
has longpoll_time => 60;
|
||||
has ua => sub { Mojo::UserAgent->new->inactivity_timeout(shift->longpoll_time + 15) };
|
||||
has token => sub { croak 'You need to supply your own token'; };
|
||||
|
||||
has tasks => sub { [] };
|
||||
has listeners => sub { [] };
|
||||
|
||||
has log => sub { Log::Any->get_logger };
|
||||
|
||||
|
||||
sub add_repeating_task {
|
||||
my $self = shift;
|
||||
my $seconds = shift;
|
||||
my $task = shift;
|
||||
|
||||
my $repeater = sub {
|
||||
|
||||
# Perform operation every $seconds seconds
|
||||
my $last_check = time();
|
||||
Mojo::IOLoop->recurring(0.1 => sub {
|
||||
my $loop = shift;
|
||||
my $now = time();
|
||||
return if ($now - $last_check) < $seconds;
|
||||
$last_check = $now;
|
||||
$task->($self);
|
||||
});
|
||||
};
|
||||
|
||||
# keep a copy
|
||||
push @{ $self->tasks }, $repeater;
|
||||
|
||||
# kick it off
|
||||
$repeater->();
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
sub add_listener {
|
||||
my $self = shift;
|
||||
my $coderef = shift;
|
||||
|
||||
push @{ $self->listeners }, $coderef;
|
||||
return;
|
||||
}
|
||||
|
||||
sub init {
|
||||
croak 'init() was not overridden!';
|
||||
}
|
||||
|
||||
|
||||
sub think {
|
||||
my $self = shift;
|
||||
$self->init();
|
||||
|
||||
$self->_add_getUpdates_handler;
|
||||
do { Mojo::IOLoop->start } until Mojo::IOLoop->is_running;
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub getMe {
|
||||
my $self = shift;
|
||||
my $token = $self->token || croak 'No token supplied to getMe()?';
|
||||
|
||||
my $url = "https://api.telegram.org/bot${token}/getMe";
|
||||
my $api_response = $self->_post_request($url);
|
||||
|
||||
if ($api_response) {
|
||||
return Teapot::Bot::Object::User->create_from_hash($api_response, $self);
|
||||
}
|
||||
else {
|
||||
return {'error' => 1};
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub getChatMember {
|
||||
my $self = shift;
|
||||
my $args = shift || {};
|
||||
|
||||
my $send_args = {};
|
||||
|
||||
unless ($args->{chat_id}) {
|
||||
cluck 'No chat_id supplied to getChatMember()';
|
||||
return {'error' => 1};
|
||||
}
|
||||
|
||||
unless ($args->{user_id}) {
|
||||
cluck 'No user_id supplied to getChatMember()';
|
||||
return {'error' => 1};
|
||||
}
|
||||
|
||||
|
||||
$send_args->{chat_id} = $args->{chat_id};
|
||||
$send_args->{user_id} = $args->{user_id};
|
||||
|
||||
my $token = $self->token || croak 'No token supplied to getChatMember?';
|
||||
|
||||
my $url = "https://api.telegram.org/bot${token}/getChatMember";
|
||||
my $api_response = $self->_post_request($url, $send_args);
|
||||
|
||||
if ($api_response) {
|
||||
return Teapot::Bot::Object::ChatMember->create_from_hash($api_response, $self);
|
||||
}
|
||||
else {
|
||||
return {'error' => 1};
|
||||
}
|
||||
}
|
||||
|
||||
sub banChatMember {
|
||||
my $self = shift;
|
||||
my $args = shift || {};
|
||||
|
||||
my $token = $self->token || croak 'No token supplied to banChatMember?';
|
||||
my $send_args = {};
|
||||
|
||||
unless ($args->{chat_id}) {
|
||||
cluck 'No chat_id supplied to banChatMember()';
|
||||
return {'error' => 1};
|
||||
}
|
||||
|
||||
unless ($args->{user_id}) {
|
||||
cluck 'No user_id supplied to banChatMember()';
|
||||
return {'error' => 1};
|
||||
}
|
||||
|
||||
$send_args->{chat_id} = $args->{chat_id};
|
||||
$send_args->{user_id} = $args->{user_id};
|
||||
$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 $api_response = $self->_post_request($url, $send_args);
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub unbanChatMember {
|
||||
my $self = shift;
|
||||
my $args = shift || {};
|
||||
|
||||
my $token = $self->token || croak 'No token supplied to unbanChatMember?';
|
||||
my $send_args = {};
|
||||
|
||||
unless ($args->{chat_id}) {
|
||||
cluck 'No chat_id supplied to unbanChatMember()';
|
||||
return {'error' => 1};
|
||||
}
|
||||
|
||||
unless ($args->{user_id}) {
|
||||
cluck 'No user_id supplied to unbanChatMember()';
|
||||
return {'error' => 1};
|
||||
}
|
||||
|
||||
$send_args->{chat_id} = $args->{chat_id};
|
||||
$send_args->{user_id} = $args->{user_id};
|
||||
$send_args->{only_if_banned} = $args->{only_if_banned} if exists $args->{only_if_banned};
|
||||
|
||||
my $url = "https://api.telegram.org/bot${token}/unbanChatMember";
|
||||
my $api_response = $self->_post_request($url, $send_args);
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
sub getChat {
|
||||
my $self = shift;
|
||||
my $args = shift || {};
|
||||
|
||||
my $send_args = {};
|
||||
|
||||
unless ($args->{chat_id}) {
|
||||
cluck 'No chat_id supplied to getChat()';
|
||||
return {'error' => 1};
|
||||
}
|
||||
|
||||
$send_args->{chat_id} = $args->{chat_id};
|
||||
|
||||
my $token = $self->token || croak 'No token supplied to getChat()?';
|
||||
|
||||
my $url = "https://api.telegram.org/bot${token}/getChat";
|
||||
my $api_response = $self->_post_request($url, $send_args);
|
||||
|
||||
if ($api_response) {
|
||||
return Teapot::Bot::Object::Chat->create_from_hash($api_response, $self);
|
||||
}
|
||||
else {
|
||||
return {'error' => 1};
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub leaveChat {
|
||||
my $self = shift;
|
||||
my $args = shift || {};
|
||||
|
||||
my $send_args = {};
|
||||
|
||||
unless ($args->{chat_id}) {
|
||||
cluck 'No chat_id supplied to getChat()';
|
||||
return {'error' => 1};
|
||||
}
|
||||
|
||||
$send_args->{chat_id} = $args->{chat_id};
|
||||
|
||||
my $token = $self->token || croak 'No token supplied to getChat()?';
|
||||
|
||||
my $url = "https://api.telegram.org/bot${token}/leaveChat";
|
||||
my $api_response = $self->_post_request($url, $send_args);
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
sub sendMessage {
|
||||
my $self = shift;
|
||||
my $args = shift || {};
|
||||
|
||||
my $send_args = {};
|
||||
|
||||
unless ($args->{chat_id}) {
|
||||
cluck 'No chat_id supplied in sendMessage()';
|
||||
return {'error' => 1};
|
||||
}
|
||||
|
||||
$send_args->{chat_id} = $args->{chat_id};
|
||||
|
||||
unless ($args->{text}) {
|
||||
cluck 'No text supplied in sendMessage()';
|
||||
return {'error' => 1};
|
||||
}
|
||||
|
||||
$send_args->{text} = $args->{text};
|
||||
|
||||
# these are optional, send if they are supplied
|
||||
$send_args->{parse_mode} = $args->{parse_mode} if exists $args->{parse_mode};
|
||||
$send_args->{disable_web_page_preview} = $args->{disable_web_page_preview} if exists $args->{disable_web_page_preview};
|
||||
$send_args->{disable_notification} = $args->{disable_notification} if exists $args->{disable_notification};
|
||||
$send_args->{reply_to_message_id} = $args->{reply_to_message_id} if exists $args->{reply_to_message_id};
|
||||
|
||||
# check reply_markup is the right kind
|
||||
if (exists $args->{reply_markup}) {
|
||||
my $reply_markup = $args->{reply_markup};
|
||||
|
||||
if ( ref($reply_markup) ne 'Teapot::Bot::Object::InlineKeyboardMarkup' &&
|
||||
ref($reply_markup) ne 'Teapot::Bot::Object::ReplyKeyboardMarkup' &&
|
||||
ref($reply_markup) ne 'Teapot::Bot::Object::ReplyKeyboardRemove' &&
|
||||
ref($reply_markup) ne 'Teapot::Bot::Object::ForceReply' ) {
|
||||
cluck 'Incorrect reply_markup in sendMessage()';
|
||||
return {'error' => 1};
|
||||
}
|
||||
|
||||
$send_args->{reply_markup} = $reply_markup;
|
||||
}
|
||||
|
||||
my $token = $self->token || croak 'No token supplied to sendMessage()?';
|
||||
my $url = "https://api.telegram.org/bot${token}/sendMessage";
|
||||
my $api_response = $self->_post_request($url, $send_args);
|
||||
|
||||
if ($api_response) {
|
||||
return Teapot::Bot::Object::Message->create_from_hash($api_response, $self);
|
||||
}
|
||||
else {
|
||||
return {'error' => 1};
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub forwardMessage {
|
||||
my $self = shift;
|
||||
my $args = shift || {};
|
||||
my $send_args = {};
|
||||
|
||||
unless ($args->{chat_id}) {
|
||||
cluck 'No chat_id supplied in forwardMessage()';
|
||||
return {'error' => 1};
|
||||
}
|
||||
|
||||
$send_args->{chat_id} = $args->{chat_id};
|
||||
|
||||
unless ($args->{from_chat_id}) {
|
||||
cluck 'No from_chat_id supplied in forwardMessage()';
|
||||
return {'error' => 1};
|
||||
}
|
||||
|
||||
$send_args->{from_chat_id} = $args->{from_chat_id};
|
||||
|
||||
unless ($args->{message_id}) {
|
||||
cluck 'No message_id supplied in forwardMessage()';
|
||||
return {'error' => 1};
|
||||
}
|
||||
|
||||
$send_args->{message_id} = $args->{message_id};
|
||||
|
||||
# these are optional, send if they are supplied
|
||||
$send_args->{disable_notification} = $args->{disable_notification} if exists $args->{disable_notification};
|
||||
|
||||
my $token = $self->token || croak 'No token supplied to forwardMessage()?';
|
||||
my $url = "https://api.telegram.org/bot${token}/forwardMessage";
|
||||
my $api_response = $self->_post_request($url, $send_args);
|
||||
|
||||
if ($api_response) {
|
||||
return Teapot::Bot::Object::Message->create_from_hash($api_response, $self);
|
||||
}
|
||||
else {
|
||||
return {'error' => 1};
|
||||
}
|
||||
}
|
||||
|
||||
# TODO: Check that message is no older than 48 hrs
|
||||
sub deleteMessage {
|
||||
my $self = shift;
|
||||
my $args = shift || {};
|
||||
my $send_args = {};
|
||||
|
||||
unless ($args->{chat_id}) {
|
||||
cluck 'No chat_id supplied in deleteMessage()';
|
||||
return {'error' => 1};
|
||||
}
|
||||
|
||||
$send_args->{chat_id} = $args->{chat_id};
|
||||
|
||||
unless ($args->{message_id}) {
|
||||
cluck 'No message_id supplied in deleteMessage()';
|
||||
return {'error' => 1};
|
||||
}
|
||||
|
||||
$send_args->{message_id} = $args->{message_id};
|
||||
|
||||
my $token = $self->token || croak 'No token supplied to deleteMessage()?';
|
||||
|
||||
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);
|
||||
}
|
||||
else {
|
||||
return {'error' => 1};
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
sub sendPhoto {
|
||||
my $self = shift;
|
||||
my $args = shift || {};
|
||||
my $send_args = {};
|
||||
|
||||
unless ($args->{chat_id}) {
|
||||
cluck 'No chat_id supplied to sendPhoto()';
|
||||
return {'error' => 1};
|
||||
}
|
||||
|
||||
$send_args->{chat_id} = $args->{chat_id};
|
||||
|
||||
# photo can be a string (which might be either a URL for telegram servers
|
||||
# to fetch, or a file_id string) or a file on disk to upload - we need
|
||||
# to handle that last case here as it changes the way we create the HTTP
|
||||
# request
|
||||
unless ($args->{photo}) {
|
||||
cluck 'No photo supplied in sendPhoto()';
|
||||
return {'error' => 1};
|
||||
}
|
||||
|
||||
if (-e $args->{photo}) {
|
||||
$send_args->{photo} = { file => $args->{photo} };
|
||||
}
|
||||
else {
|
||||
$send_args->{photo} = $args->{photo};
|
||||
}
|
||||
|
||||
my $token = $self->token || croak 'No token in sendPhoto()?';
|
||||
my $url = "https://api.telegram.org/bot${token}/sendPhoto";
|
||||
my $api_response = $self->_post_request($url, $send_args);
|
||||
|
||||
if ($api_response) {
|
||||
return Teapot::Bot::Object::Message->create_from_hash($api_response, $self);
|
||||
}
|
||||
else {
|
||||
return {'error' => 1};
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub sendChatAction {
|
||||
my $self = shift;
|
||||
my $args = shift || {};
|
||||
my $send_args = {};
|
||||
|
||||
unless ($args->{chat_id}) {
|
||||
cluck 'No chat_id supplied in sendChatAction()';
|
||||
return {'error' => 1};
|
||||
}
|
||||
|
||||
$send_args->{chat_id} = $args->{chat_id};
|
||||
|
||||
unless (defined $args->{action}) {
|
||||
$args->{action} = 'typing';
|
||||
$send_args->{action} = 'typing';
|
||||
}
|
||||
|
||||
if ($args->{action} eq 'upload_photo') {
|
||||
$send_args->{action} = 'upload_photo';
|
||||
}
|
||||
elsif ($args->{action} eq 'record_video') {
|
||||
$send_args->{action} = 'record_video';
|
||||
}
|
||||
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 'upload_voice') {
|
||||
$send_args->{action} = 'upload_voice';
|
||||
}
|
||||
elsif ($args->{action} eq 'upload_document') {
|
||||
$send_args->{action} = 'upload_document';
|
||||
}
|
||||
elsif ($args->{action} eq 'find_location') {
|
||||
$send_args->{action} = 'find_location';
|
||||
}
|
||||
elsif ($args->{action} eq 'record_video_note') {
|
||||
$send_args->{action} = 'record_video_note';
|
||||
}
|
||||
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';
|
||||
}
|
||||
|
||||
my $token = $self->token || croak 'No token in sendChatAction()?';
|
||||
my $url = "https://api.telegram.org/bot${token}/sendChatAction";
|
||||
my $api_response = $self->_post_request ($url, $send_args);
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub exportChatInviteLink {
|
||||
my $self = shift;
|
||||
my $args = shift || {};
|
||||
my $send_args = {};
|
||||
|
||||
my $token = $self->token || croak 'No token supplied to createChatInviteLink()?';
|
||||
|
||||
unless ($args->{chat_id}) {
|
||||
cluck 'No chat_id supplied in createChatInviteLink()';
|
||||
return {'error' => 1};
|
||||
}
|
||||
|
||||
$send_args->{chat_id} = $args->{chat_id};
|
||||
|
||||
my $url = "https://api.telegram.org/bot${token}/exportChatInviteLink";
|
||||
my $api_response = $self->_post_request($url);
|
||||
|
||||
if ($api_response) {
|
||||
return $api_response;
|
||||
}
|
||||
else {
|
||||
return {'error' => 1};
|
||||
}
|
||||
}
|
||||
|
||||
sub createChatInviteLink {
|
||||
my $self = shift;
|
||||
my $args = shift || {};
|
||||
my $send_args = {};
|
||||
|
||||
my $token = $self->token || croak 'No token supplied to createChatInviteLink()?';
|
||||
|
||||
unless ($args->{chat_id}) {
|
||||
cluck 'No chat_id supplied in createChatInviteLink()';
|
||||
return {'error' => 1};
|
||||
}
|
||||
|
||||
$send_args->{chat_id} = $args->{chat_id};
|
||||
$send_args->{expire_date} = $args->{expire_date} if exists $args->{expire_date};
|
||||
$send_args->{member_limit} = $args->{member_limit} if exists $args->{member_limit};
|
||||
|
||||
my $url = "https://api.telegram.org/bot${token}/createChatInviteLink";
|
||||
my $api_response = $self->_post_request($url);
|
||||
|
||||
if ($api_response) {
|
||||
return Teapot::Bot::Object::ChatInviteLink->create_from_hash($api_response, $self);
|
||||
}
|
||||
else {
|
||||
return {'error' => 1};
|
||||
}
|
||||
}
|
||||
|
||||
sub editChatInviteLink {
|
||||
my $self = shift;
|
||||
my $args = shift || {};
|
||||
my $send_args = {};
|
||||
|
||||
my $token = $self->token || croak 'No token supplied to editChatInviteLink()?';
|
||||
|
||||
unless ($args->{chat_id}) {
|
||||
cluck 'No chat_id supplied in editChatInviteLink()';
|
||||
return {'error' => 1};
|
||||
}
|
||||
|
||||
unless ($args->{invite_link}) {
|
||||
cluck 'No invite_link supplied in editChatInviteLink()';
|
||||
return {'error' => 1};
|
||||
}
|
||||
|
||||
$send_args->{chat_id} = $args->{chat_id};
|
||||
$send_args->{invite_link} = $args->{invite_link};
|
||||
$send_args->{expire_date} = $args->{expire_date} if exists $args->{expire_date};
|
||||
$send_args->{member_limit} = $args->{member_limit} if exists $args->{member_limit};
|
||||
|
||||
my $url = "https://api.telegram.org/bot${token}/editChatInviteLink";
|
||||
my $api_response = $self->_post_request($url);
|
||||
|
||||
if ($api_response) {
|
||||
return Teapot::Bot::Object::ChatInviteLink->create_from_hash($api_response, $self);
|
||||
}
|
||||
else {
|
||||
return {'error' => 1};
|
||||
}
|
||||
}
|
||||
|
||||
sub revokeChatInviteLink {
|
||||
my $self = shift;
|
||||
my $args = shift || {};
|
||||
my $send_args = {};
|
||||
|
||||
my $token = $self->token || croak 'No token supplied to revokeChatInviteLink()?';
|
||||
|
||||
unless ($args->{chat_id}) {
|
||||
cluck 'No chat_id supplied in revokeChatInviteLink()';
|
||||
return {'error' => 1};
|
||||
}
|
||||
|
||||
unless ($args->{invite_link}) {
|
||||
cluck 'No invite_link supplied in revokeChatInviteLink()';
|
||||
return {'error' => 1};
|
||||
}
|
||||
|
||||
$send_args->{chat_id} = $args->{chat_id};
|
||||
$send_args->{invite_link} = $args->{invite_link};
|
||||
|
||||
my $url = "https://api.telegram.org/bot${token}/revokeChatInviteLink";
|
||||
my $api_response = $self->_post_request($url);
|
||||
|
||||
if ($api_response) {
|
||||
return Teapot::Bot::Object::ChatInviteLink->create_from_hash($api_response, $self);
|
||||
}
|
||||
else {
|
||||
return {'error' => 1};
|
||||
}
|
||||
}
|
||||
|
||||
sub _add_getUpdates_handler {
|
||||
my $self = shift;
|
||||
|
||||
my $http_active = 0;
|
||||
my $last_update_id = -1;
|
||||
my $token = $self->token;
|
||||
|
||||
Mojo::IOLoop->recurring(0.1 => sub {
|
||||
# do nothing if our previous longpoll is still going
|
||||
return if $http_active;
|
||||
|
||||
my $offset = $last_update_id + 1;
|
||||
my $updateURL = "https://api.telegram.org/bot${token}/getUpdates?offset=${offset}&timeout=60";
|
||||
$http_active = 1;
|
||||
|
||||
$self->ua->get($updateURL => sub {
|
||||
my ($ua, $tx) = @_;
|
||||
my $res = eval { $tx->res->json; };
|
||||
|
||||
# it looks like we can catch an error here if timeout or something bad occurs,
|
||||
# try not to die in this case or we risk to stuck with $http_active=1 forever
|
||||
if ((defined $res) && $res ne '') {
|
||||
my $items = $res->{result};
|
||||
foreach my $item (@{$items}) {
|
||||
$last_update_id = $item->{update_id};
|
||||
$self->_process_message($item);
|
||||
}
|
||||
} else {
|
||||
cluck "Unable to get update from API: $EVAL_ERROR";
|
||||
}
|
||||
|
||||
$http_active = 0;
|
||||
});
|
||||
});
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
# process a message which arrived via getUpdates
|
||||
sub _process_message {
|
||||
my $self = shift;
|
||||
my $item = shift;
|
||||
|
||||
my $update_id = $item->{update_id};
|
||||
# There can be several types of responses. But only one response.
|
||||
# https://core.telegram.org/bots/api#update
|
||||
my $update;
|
||||
$update = Teapot::Bot::Object::Message->create_from_hash($item->{message}, $self) if $item->{message};
|
||||
$update = Teapot::Bot::Object::Message->create_from_hash($item->{edited_message}, $self) if $item->{edited_message};
|
||||
$update = Teapot::Bot::Object::Message->create_from_hash($item->{channel_post}, $self) if $item->{channel_post};
|
||||
$update = Teapot::Bot::Object::Message->create_from_hash($item->{edited_channel_post}, $self) if $item->{edited_channel_post};
|
||||
# Not yet implemented, we have no InlineQuery object yet
|
||||
#$update = Teapot::Bot::Object::InlineQuery->create_from_hash($tem->{inline_query}, $self) if $item->{inline_query};
|
||||
# Not yet implemented, we have no ChosenInlineResult object yet
|
||||
#$update = Teapot::Bot::Object::ChosenInlineResult->create_from_hash($tem->{chosen_inline_result}, $self) if $item->{chosen_inline_result};
|
||||
# Not yet implemented, we have no callback_query object yet, because we do not use this mechanism, s API should not gi us that shit
|
||||
#$update = Teapot::Bot::Object::CallbackQuery->create_from_hash($tem->{callback_query}, $self) if $item->{callback_query};
|
||||
# Not yet implemented, we have no ShippingQuery object yet
|
||||
#$update = Teapot::Bot::Object::ShippingQuery->create_from_hash($tem->{shipping_query}, $self) if $item->{shipping_query};
|
||||
# Not yet implemented, we have no PreCheckoutQuery object yet
|
||||
#$update = Teapot::Bot::Object::PreCheckoutQuery->create_from_hash($tem->{pre_checkout_query}, $self) if $item->{pre_checkout_query};
|
||||
$update = Teapot::Bot::Object::Poll->create_from_hash($item->{poll}, $self) if $item->{poll};
|
||||
$update = Teapot::Bot::Object::PollAnswer->create_from_hash($item->{poll_answer}, $self) if $item->{poll_answer};
|
||||
$update = Teapot::Bot::Object::ChatMemberUpdated->create_from_hash($item->{my_chat_member}, $self) if $item->{my_chat_member};
|
||||
$update = Teapot::Bot::Object::ChatMemberUpdated->create_from_hash($item->{chat_member}, $self) if $item->{chat_member};
|
||||
|
||||
# if we got to this point without creating a response, it must be a type we
|
||||
# don't handle yet
|
||||
if (! $update) {
|
||||
cluck 'Do not know how to handle this update: ' . Dumper($item);
|
||||
return;
|
||||
}
|
||||
|
||||
foreach my $listener (@{ $self->listeners }) {
|
||||
# call the listener code, supplying ourself and the update
|
||||
my $evalRet = eval {
|
||||
$listener->($self, $update);
|
||||
return 1;
|
||||
};
|
||||
|
||||
unless ($evalRet) {
|
||||
cluck "An error occured during update processing: $EVAL_ERROR";
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
sub _post_request {
|
||||
my $self = shift;
|
||||
my $url = shift;
|
||||
my $form_args = shift || {};
|
||||
|
||||
my $res = $self->ua->post($url, form => $form_args)->result;
|
||||
|
||||
if ($res->is_success) {
|
||||
return $res->json->{result};
|
||||
}
|
||||
elsif ($res->is_error) {
|
||||
# This can be non-fatal error: api change.
|
||||
cluck 'Failed to post: ' . $res->message;
|
||||
return 0; # to handle this as false in upper layers
|
||||
}
|
||||
else {
|
||||
# This must be something fatal for sure, because either is_success or is_error must be set by Mojo
|
||||
confess 'Not sure what went wrong';
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Brain - A base class to make your very own Telegram bot
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package MyApp::Coolbot;
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Brain';
|
||||
|
||||
has token => 'token-you-got-from-@botfather';
|
||||
|
||||
sub init {
|
||||
my $self = shift;
|
||||
$self->add_repeating_task(600, \&timed_task);
|
||||
$self->add_listener(\&respond_to_messages);
|
||||
}
|
||||
|
||||
Elsewhere....
|
||||
|
||||
my $bot = MyApp::Coolbot->new();
|
||||
$bot->think; # this will block unless there is already an event
|
||||
# loop running
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This base class makes it easy to create your own Bot classes that
|
||||
interface with the Telegram Bot API.
|
||||
|
||||
Internally it uses the Mojo::IOLoop event loop to provide non-blocking
|
||||
access to the Bot API, allowing your bot to listen for events via the
|
||||
longpoll getUpdates API method and also trigger timed events that can
|
||||
run without blocking.
|
||||
|
||||
As with any bot framework, the principle is that the framework allows you
|
||||
to interact with other users on Telegram. The Telegram API provides a rich
|
||||
set of typed objects. This framework will allow you to create those objects
|
||||
to send into the API (for instance, sending text messages, sending photos,
|
||||
and more) as well as call your code (via L<add_listener> when your bot
|
||||
receives messages (which might be text, or images, and so on).
|
||||
|
||||
How bots work with Telegram is out of scope for this document, a good
|
||||
starting place is L<https://core.telegram.org/bots>.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 add_repeating_task
|
||||
|
||||
This method will add a sub to run every C<$seconds> seconds. Pass this method
|
||||
two parameters, the number of seconds between executions, and the coderef to
|
||||
execute.
|
||||
|
||||
Your coderef will be passed the L<Teapot::Bot::Brain> object when it is
|
||||
executed.
|
||||
|
||||
=head2 add_listener
|
||||
|
||||
Respond to messages we receive. It takes a single argument, a coderef to execute
|
||||
for each update that is sent to us. These are *typically* C<Teapot::Bot:Object::Message>
|
||||
objects, though that is not the only type of update that may be sent (see
|
||||
L<https://core.telegram.org/bots/api#update>).
|
||||
|
||||
Multiple listeners can be added, they will receive the incoming update in the order
|
||||
that they are registered.
|
||||
|
||||
Any or all listeners can choose to ignore or take action on any particular update.
|
||||
|
||||
=head2 think
|
||||
|
||||
Start this bot thinking.
|
||||
|
||||
Calls your init method and then enters a blocking loop (unless a Mojo::IOLoop
|
||||
is already running).
|
||||
|
||||
=head2 getMe
|
||||
|
||||
This is the wrapper around the C<getMe> API method. See
|
||||
L<https://core.telegram.org/bots/api#getme>.
|
||||
|
||||
Takes no arguments, and returns the L<Teapot::Bot::Object::User> that
|
||||
represents this bot.
|
||||
|
||||
On error returns hash reference with error set to 1
|
||||
|
||||
=head2 getChatMember
|
||||
|
||||
This is the wrapper around the C<getChatMember> API method. See
|
||||
L<https://core.telegram.org/bots/api#getchatmember>.
|
||||
|
||||
Takes chat_id, and user_id as arguments.
|
||||
|
||||
Returns the L<Teapot::Bot::Object::ChatMember> that represents properties
|
||||
of Chat User.
|
||||
|
||||
On error returns hash reference with error set to 1
|
||||
|
||||
=head2 banChatMember
|
||||
|
||||
This is the wrapper around the C<banChatMember> API method. See
|
||||
L<https://core.telegram.org/bots/api#banchatmember>.
|
||||
|
||||
Takes chat_id, and user_id as arguments. And optionally until_date and
|
||||
revoke_messages.
|
||||
|
||||
Returns nothing, it's send-only method (Telegram API returns true on success)
|
||||
|
||||
=head2 unbanChatMember
|
||||
|
||||
This is the wrapper around the C<unbanChatMember> API method. See
|
||||
L<https://core.telegram.org/bots/api#unbanchatmember>.
|
||||
|
||||
Takes chat_id, and user_id as arguments. And optionally only_if_banned.
|
||||
|
||||
Returns nothing, it's send-only method (Telegram API returns true on success)
|
||||
|
||||
=head2 getChat
|
||||
|
||||
This is the wrapper around the C<getChat> API method. See
|
||||
L<https://core.telegram.org/bots/api#getchat>.
|
||||
|
||||
Takes chat_id as argument.
|
||||
|
||||
Returns the L<Teapot::Bot::Object::Chat> that represents properties of Chat.
|
||||
|
||||
On error returns hash reference with error set to 1
|
||||
|
||||
=head2 leaveChat
|
||||
|
||||
This is the wrapper around the C<leaveChat> API method. See
|
||||
L<https://core.telegram.org/bots/api#leavechat>.
|
||||
|
||||
Takes chat_id as argument.
|
||||
|
||||
Returns nothing, it's send-only method (Telegram API returns true on success)
|
||||
|
||||
=head2 sendMessage
|
||||
|
||||
See L<https://core.telegram.org/bots/api#sendmessage>.
|
||||
|
||||
Returns a L<Teapot::Bot::Object::Message> object.
|
||||
|
||||
On error returns hash reference with error set to 1
|
||||
|
||||
=head2 forwardMessage
|
||||
|
||||
See L<https://core.telegram.org/bots/api#forwardmessage>.
|
||||
|
||||
Returns a L<Teapot::Bot::Object::Message> object.
|
||||
|
||||
On error returns hash reference with error set to 1
|
||||
|
||||
=head2 deleteMessage
|
||||
|
||||
See L<https://core.telegram.org/bots/api#deletemessage>.
|
||||
|
||||
Returns a L<Teapot::Bot::Object::Message> object.
|
||||
|
||||
On error returns hash reference with error set to 1
|
||||
|
||||
=head2 sendPhoto
|
||||
|
||||
See L<https://core.telegram.org/bots/api#sendphoto>.
|
||||
|
||||
Returns a L<Teapot::Bot::Object::Message> object.
|
||||
|
||||
On error returns hash reference with error set to 1
|
||||
|
||||
=head2 sendChatAction
|
||||
See L<https://core.telegram.org/bots/api#sendchataction>.
|
||||
|
||||
Returns nothing, it's send-only method (Telegram API returns true on success)
|
||||
|
||||
=head2 exportChatInviteLink
|
||||
|
||||
See L<https://core.telegram.org/bots/api#exportchatinvitelink>
|
||||
|
||||
Takes chat_id as argument.
|
||||
|
||||
Returns a raw api answer.
|
||||
|
||||
On error returns hash reference with error set to 1
|
||||
|
||||
=head2 createChatInviteLink
|
||||
|
||||
See L<https://core.telegram.org/bots/api#createchatinvitelink>
|
||||
|
||||
Takes chat_id as argument. And optionally expire_date and member_limit.
|
||||
|
||||
Returns a L<Teapot::Bot::Object::ChatInviteLink> object.
|
||||
|
||||
On error returns hash reference with error set to 1
|
||||
|
||||
=head2 editChatInviteLink
|
||||
|
||||
See L<https://core.telegram.org/bots/api#editchatinvitelink>
|
||||
|
||||
Takes chat_id and invite_link as arguments. And optionally expire_date
|
||||
and member_limit.
|
||||
|
||||
Returns a L<Teapot::Bot::Object::ChatInviteLink> object.
|
||||
|
||||
On error returns hash reference with error set to 1
|
||||
|
||||
=head2 revokeChatInviteLink
|
||||
|
||||
See L<https://core.telegram.org/bots/api#revokechatinvitelink>
|
||||
|
||||
Takes chat_id and invite_link as arguments.
|
||||
|
||||
Returns a L<Teapot::Bot::Object::ChatInviteLink> object.
|
||||
|
||||
On error returns hash reference with error set to 1
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
L<Mojolicious>
|
||||
|
||||
=item *
|
||||
|
||||
L<https://core.telegram.org/bots>
|
||||
|
||||
=back
|
||||
|
||||
=head1 Telegram Bot API methods
|
||||
|
||||
The following methods are relatively thin wrappers around the various
|
||||
methods available in the Telgram Bot API to send messages and perform other
|
||||
updates.
|
||||
|
||||
L<https://core.telegram.org/bots/api#available-methods>
|
||||
|
||||
They all return immediately with the corresponding Teapot::Bot::Object
|
||||
subclass - consult the documenation for each below to see what to expect.
|
||||
|
||||
Note that not all methods have yet been implemented.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Justin Hawkins <justin@eatmorecode.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This software is copyright (c) 2019 by Justin Hawkins.
|
||||
|
||||
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
|
||||
61
lib/Teapot/Bot/Object/Animation.pm
Normal file
61
lib/Teapot/Bot/Object/Animation.pm
Normal file
@@ -0,0 +1,61 @@
|
||||
package Teapot::Bot::Object::Animation;
|
||||
# ABSTRACT: The base class for Telegram message 'Animation' type.
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
use Teapot::Bot::Object::PhotoSize;
|
||||
use Carp qw/croak/;
|
||||
|
||||
$Teapot::Bot::Object::Animation::VERSION = '0.022';
|
||||
|
||||
has 'file_id';
|
||||
has 'file_unique_id';
|
||||
has 'width';
|
||||
has 'height';
|
||||
has 'duration';
|
||||
has 'thumb'; #PhotoSize
|
||||
has 'file_name';
|
||||
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/],
|
||||
'Teapot::Bot::Object::PhotoSize' => [qw/thumb/],
|
||||
};
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::Animation - The base class for Telegram message 'Animation' type
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram message 'Animation' type.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#animation> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::Animation> objects.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Justin Hawkins <justin@eatmorecode.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This software is copyright (c) 2019 by Justin Hawkins.
|
||||
|
||||
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
|
||||
58
lib/Teapot/Bot/Object/Audio.pm
Normal file
58
lib/Teapot/Bot/Object/Audio.pm
Normal file
@@ -0,0 +1,58 @@
|
||||
package Teapot::Bot::Object::Audio;
|
||||
# ABSTRACT: The base class for Telegram 'Audio' type objects
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
|
||||
$Teapot::Bot::Object::Audio::VERSION = '0.022';
|
||||
|
||||
has 'file_id';
|
||||
has 'file_unique_id';
|
||||
has 'duration';
|
||||
has 'performer'; # Optional. Performer of the audio as defined by sender or by audio tags
|
||||
has 'title'; # Optional. Title of the audio as defined by sender or by audio tags
|
||||
has 'file_name'; # Optional. Original filename as defined by sender
|
||||
has 'mime_type'; # Optional. MIME type of the file as defined by sender
|
||||
has 'file_size'; # Optional. File size
|
||||
has 'thumb'; # Optional. Thumbnail of the album cover to which the music file belongs
|
||||
|
||||
sub fields {
|
||||
return { scalar => [qw/file_id file_unique_id duration performer title file_name mime_type
|
||||
file_size/],
|
||||
'Teapot::Bot::Object::PhotoSize' => [qw/thumb/],
|
||||
};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::Audio - The base class for Telegram 'Audio' type objects
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram 'Audio' type objects.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#audio> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::Audio> objects.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Justin Hawkins <justin@eatmorecode.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This software is copyright (c) 2019 by Justin Hawkins.
|
||||
|
||||
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
|
||||
233
lib/Teapot/Bot/Object/Base.pm
Normal file
233
lib/Teapot/Bot/Object/Base.pm
Normal file
@@ -0,0 +1,233 @@
|
||||
package Teapot::Bot::Object::Base;
|
||||
# ABSTRACT: The base class for all Teapot::Bot::Object objects.
|
||||
|
||||
use Mojo::Base -base;
|
||||
use List::Util qw/any/;
|
||||
use Carp qw/croak cluck/;
|
||||
use Data::Dumper;
|
||||
|
||||
$Teapot::Bot::Object::Base::VERSION = '0.022';
|
||||
|
||||
has '_brain'; # a reference to our brain
|
||||
|
||||
|
||||
sub arrays { return qw// } # override if needed
|
||||
sub _field_is_array {
|
||||
my $self = shift;
|
||||
my $field = shift;
|
||||
|
||||
unless (defined $field) {
|
||||
return;
|
||||
}
|
||||
|
||||
if (any { /^$field$/ } $self->arrays) {
|
||||
return 1;
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
sub array_of_arrays { return qw// } #override if needed
|
||||
sub _field_is_array_of_arrays {
|
||||
my $self = shift;
|
||||
my $field = shift;
|
||||
|
||||
unless (defined $field) {
|
||||
return;
|
||||
}
|
||||
|
||||
if (any { /^$field$/ } $self->array_of_arrays) {
|
||||
return 1;
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
sub create_from_array {
|
||||
my $class = shift;
|
||||
my $array = shift;
|
||||
my $brain = shift || croak 'No brain supplied to create_from_array()';
|
||||
my $obj = shift || $class->new(_brain => $brain);
|
||||
|
||||
unless (defined $array) {
|
||||
cluck 'Array is undef';
|
||||
return $obj;
|
||||
}
|
||||
|
||||
unless (ref ($array) eq 'ARRAY') {
|
||||
cluck 'Not array ' . Dumper ($array);
|
||||
return $obj;
|
||||
}
|
||||
|
||||
cluck "Dumping class: " . Dumper ($class);
|
||||
cluck "Dumping array: " . Dumper ($array);
|
||||
|
||||
# it's stub, return $obj
|
||||
return $obj;
|
||||
}
|
||||
|
||||
# create an object from a hash. Needs to deal with the nested types, and
|
||||
# arrays
|
||||
sub create_from_hash {
|
||||
my $class = shift;
|
||||
my $hash = shift;
|
||||
my $brain = shift || croak 'No brain supplied to create_from_hash()';
|
||||
my $obj = $class->new(_brain => $brain);
|
||||
|
||||
unless (defined $hash) {
|
||||
cluck 'Hash is undef';
|
||||
return $obj;
|
||||
}
|
||||
|
||||
unless (ref ($hash) eq 'HASH') {
|
||||
if (ref ($hash) eq 'ARRAY') {
|
||||
return create_from_array($class, $hash, $brain);
|
||||
}
|
||||
|
||||
cluck 'Not a hash ' . Dumper ($hash);
|
||||
return $obj;
|
||||
}
|
||||
|
||||
# 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));
|
||||
}
|
||||
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return $obj;
|
||||
}
|
||||
|
||||
|
||||
sub as_hashref {
|
||||
my $self = shift;
|
||||
my $hash = {};
|
||||
# add the simple scalar values
|
||||
foreach my $type ( keys %{ $self->fields }) {
|
||||
my @fields = @{ $self->fields->{$type} };
|
||||
foreach my $field (@fields) {
|
||||
if ($type eq 'scalar') {
|
||||
$hash->{$field} = $self->$field;
|
||||
}
|
||||
else {
|
||||
# non array types
|
||||
$hash->{$field} = $self->$field->as_hashref
|
||||
if (ref($self->$field) ne 'ARRAY' && defined $self->$field);
|
||||
# array types
|
||||
$hash->{$field} = [
|
||||
map { $_->as_hashref } @{ $self->$field }
|
||||
] if (ref($self->$field) eq 'ARRAY');
|
||||
}
|
||||
}
|
||||
}
|
||||
return $hash;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::Base - The base class for all Telegram::Bot::Object objects
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The base class for all Telegram::Bot::Object objects.
|
||||
|
||||
This class should not be instantiated itself. Instead, instantiate a sub-class.
|
||||
|
||||
You should generally not need to instantiate objects of sub-classes of L<Teapot::Bot::Object::Base>,
|
||||
instead the appropriate objects will be created from an incoming request via
|
||||
L<Teapot::Bot::Brain>.
|
||||
|
||||
You can then use the methods referenced below on those objects.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 arrays
|
||||
|
||||
Should be overridden by subclasses, returning an array listing of which fields
|
||||
for the object are arrays.
|
||||
|
||||
=head2 array_of_arrays
|
||||
|
||||
Should be overridden by subclasses, returning an array listing od which fields
|
||||
for the object are arrays of arrays.
|
||||
|
||||
=head2 create_from_hash
|
||||
|
||||
Create an object of the appropriate class, including any sub-objects of
|
||||
other types, as needed.
|
||||
|
||||
=head2 as_hashref
|
||||
|
||||
Return this object as a hashref.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Justin Hawkins <justin@eatmorecode.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This software is copyright (c) 2019 by Justin Hawkins.
|
||||
|
||||
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
|
||||
47
lib/Teapot/Bot/Object/CallbackGame.pm
Normal file
47
lib/Teapot/Bot/Object/CallbackGame.pm
Normal file
@@ -0,0 +1,47 @@
|
||||
package Teapot::Bot::Object::CallbackGame;
|
||||
# ABSTRACT: The base class for Telegram message 'CallbackGame' type.
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
$Teapot::Bot::Object::CallbackGame::VERSION = '0.022';
|
||||
|
||||
# https://core.telegram.org/bots/api#callbackgame
|
||||
# "A placeholder, currently holds no information. Use BotFather to set up your game"
|
||||
|
||||
sub fields {
|
||||
return { },
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::CallbackGame - The base class for Telegram message 'CallbackGame' type
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram message 'CallbackGame' type.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#callbackgame> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::CallbackGame> objects.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Justin Hawkins <justin@eatmorecode.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This software is copyright (c) 2019 by Justin Hawkins.
|
||||
|
||||
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
|
||||
104
lib/Teapot/Bot/Object/Chat.pm
Normal file
104
lib/Teapot/Bot/Object/Chat.pm
Normal file
@@ -0,0 +1,104 @@
|
||||
package Teapot::Bot::Object::Chat;
|
||||
# ABSTRACT: The base class for Telegram 'Chat' type objects
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
use Teapot::Bot::Object::ChatPhoto;
|
||||
use Teapot::Bot::Object::Message;
|
||||
use Teapot::Bot::Object::ChatPermissions;
|
||||
use Teapot::Bot::Object::ChatLocation;
|
||||
|
||||
$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.
|
||||
|
||||
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/],
|
||||
'Teapot::Bot::Object::ChatPhoto' => [qw/photo/],
|
||||
'Teapot::Bot::Object::Message' => [qw/pinned_message/],
|
||||
'Teapot::Bot::Object::ChatPermissions' => [qw/permissions/],
|
||||
'Teapot::Bot::Object::ChatLocation' => [qw/location/],
|
||||
};
|
||||
}
|
||||
|
||||
|
||||
sub is_user {
|
||||
return shift->id > 0;
|
||||
}
|
||||
|
||||
|
||||
sub is_group {
|
||||
return shift->id < 0;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::Chat - The base class for Telegram 'Chat' type objects
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram 'Chat' type objects.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#chat> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::Chat> objects.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 is_user
|
||||
|
||||
Returns true is this is a chat is a single user.
|
||||
|
||||
=head2 is_group
|
||||
|
||||
Returns true if this is a chat is a group.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Justin Hawkins <justin@eatmorecode.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This software is copyright (c) 2019 by Justin Hawkins.
|
||||
|
||||
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
|
||||
61
lib/Teapot/Bot/Object/ChatInviteLink.pm
Normal file
61
lib/Teapot/Bot/Object/ChatInviteLink.pm
Normal file
@@ -0,0 +1,61 @@
|
||||
package Teapot::Bot::Object::ChatInviteLink;
|
||||
# ABSTRACT: The base class for Telegram message 'ChatInviteLink' type.
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
use Teapot::Bot::Object::User;
|
||||
|
||||
$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/],
|
||||
'Teapot::Bot::Object::User' => [qw/creator/],
|
||||
};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::ChatInviteLink - The base class for Telegram message 'ChatInviteLink' type
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram message 'ChatInviteLink' type.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#chatinvitelink> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::ChatInviteLink> 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
|
||||
51
lib/Teapot/Bot/Object/ChatLocation.pm
Normal file
51
lib/Teapot/Bot/Object/ChatLocation.pm
Normal file
@@ -0,0 +1,51 @@
|
||||
package Teapot::Bot::Object::ChatLocation;
|
||||
# ABSTRACT: The base class for Telegram message 'ChatLocation' type.
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
|
||||
$Teapot::Bot::Object::ChatLocation::VERSION = '0.022';
|
||||
|
||||
has 'location';
|
||||
has 'address';
|
||||
|
||||
sub fields {
|
||||
return {
|
||||
'Teapot::Bot::Object::Location' => [qw/location/],
|
||||
'scalar' => [qw/address/],
|
||||
};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::ChatLocation - The base class for Telegram message 'ChatLocation' type
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram message 'ChatLocation' type.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#chatlocation> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::ChatLocation> objects.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Sergei Fedosov <eleksir@gmail.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This software is copyright (c) 2019 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
|
||||
168
lib/Teapot/Bot/Object/ChatMember.pm
Normal file
168
lib/Teapot/Bot/Object/ChatMember.pm
Normal file
@@ -0,0 +1,168 @@
|
||||
package Teapot::Bot::Object::ChatMember;
|
||||
# ABSTRACT: The base class for Telegram 'ChatMember' type objects
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
use Teapot::Bot::Object::User;
|
||||
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.
|
||||
|
||||
# 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
|
||||
# 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.
|
||||
|
||||
sub fields {
|
||||
return {
|
||||
'scalar' => [qw/status custom_title is_anonymous can_be_edited can_manage_chat can_post_messages
|
||||
can_edit_messages can_delete_messages can_manage_voice_chats can_restrict_members
|
||||
can_promote_members can_change_info can_invite_users can_pin_messages is_member
|
||||
can_send_messages can_send_media_messages can_send_polls can_send_other_messages
|
||||
can_add_web_page_previews until_date/],
|
||||
'Teapot::Bot::Object::User' => [qw/user/],
|
||||
};
|
||||
}
|
||||
|
||||
|
||||
sub canDeleteMessage {
|
||||
my $self = shift;
|
||||
my $chatid = shift;
|
||||
|
||||
my $can_delete = 0;
|
||||
|
||||
if ($chatid < 0) {
|
||||
# group chat
|
||||
my $chatobj = $self->getChat ({ 'chat_id' => $chatid });
|
||||
|
||||
# on api error, keep silence
|
||||
unless ($chatobj) {
|
||||
cluck "Unable to get chat info for $chatid from telegram API";
|
||||
return 0;
|
||||
}
|
||||
|
||||
my $myObj = $self->getMe ();
|
||||
|
||||
# on api error, keep silence
|
||||
unless ($chatobj) {
|
||||
cluck "Unable to get chat info for $chatid from telegram API";
|
||||
return 0;
|
||||
}
|
||||
|
||||
my $myid = $myObj->id;
|
||||
my $me = $self->getChatMember ({ 'chat_id' => $chatid, 'user_id' => $myid });
|
||||
|
||||
# on api error, keep silence
|
||||
unless ($me) {
|
||||
cluck 'Unable to get chat info for bot itself from telegram API';
|
||||
return 0;
|
||||
}
|
||||
|
||||
# bot can delete msg if it is group and it is admin there.
|
||||
if ($chatobj->{'type'} eq 'group') {
|
||||
if ($me->{'status'} eq 'administrator') {
|
||||
$can_delete = 1;
|
||||
}
|
||||
# in supergroup bot must be granted with can_delete_messages
|
||||
} elsif (($chatobj->{'type'} eq 'supergroup') || ($chatobj->{'type'} eq 'channel')) {
|
||||
if ($me->{'can_delete_messages'}) {
|
||||
$can_delete = 1;
|
||||
}
|
||||
}
|
||||
} else {
|
||||
# 1 on 1 chat with user
|
||||
$can_delete = 1;
|
||||
}
|
||||
|
||||
return $can_delete;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::ChatMember - The base class for Telegram 'ChatMember' type objects
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram 'ChatMember' type objects.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#chatmember> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::ChatMember> objects.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 canDeleteMessage
|
||||
|
||||
A convenience method to check if bot can delete message in given conversation.
|
||||
|
||||
Returns true if the bot can delete the message in given conversation, otherwise false.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Sergei Fedosov <eleksir@gmail.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This software is copyright (c) 2020 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
|
||||
67
lib/Teapot/Bot/Object/ChatMemberUpdated.pm
Normal file
67
lib/Teapot/Bot/Object/ChatMemberUpdated.pm
Normal file
@@ -0,0 +1,67 @@
|
||||
package Teapot::Bot::Object::ChatMemberUpdated;
|
||||
# ABSTRACT: The base class for Telegram 'ChatMemberUpdated' type objects
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
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';
|
||||
|
||||
has 'chat';
|
||||
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.
|
||||
|
||||
sub fields {
|
||||
return {
|
||||
'Teapot::Bot::Object::Chat' => [qw/chat/],
|
||||
'Teapot::Bot::Object::User' => [qw/from/],
|
||||
'scalar' => [qw/date text/],
|
||||
'Teapot::Bot::Object::ChatMember' => [qw/old_chat_member new_chat_member/],
|
||||
'Teapot::Bot::Object::Voice' => [qw/voice/],
|
||||
'Teapot::Bot::Object::ChatInviteLink' => [qw/invite_link/]
|
||||
};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::ChatMemberUpdated - The base class for Telegram 'ChatMemberUpdated' type objects
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram 'ChatMemberUpdated' type objects.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#chatmemberupdated> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::ChatMemberUpdated> 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
|
||||
119
lib/Teapot/Bot/Object/ChatPermissions.pm
Normal file
119
lib/Teapot/Bot/Object/ChatPermissions.pm
Normal file
@@ -0,0 +1,119 @@
|
||||
package Teapot::Bot::Object::ChatPermissions;
|
||||
# ABSTRACT: The base class for Telegram 'ChatPermissions' type objects
|
||||
use Carp qw(carp);
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
|
||||
$Teapot::Bot::Object::ChatPermissions::VERSION = '0.022';
|
||||
|
||||
# all fields are optional
|
||||
# N.B. Some of the fields "overlaps" other, so in order to guess valid set of permissions you should check all of them
|
||||
has 'can_send_messages'; # True, if the user is allowed to send text messages, contacts, locations and venues
|
||||
has 'can_send_media_messages'; # True, if the user is allowed to send audios, documents, photos, videos, video notes
|
||||
# and voice notes, implies can_send_messages
|
||||
has 'can_send_polls'; # True, if the user is allowed to send polls, implies can_send_messages
|
||||
has 'can_send_other_messages'; # True, if the user is allowed to send animations, games, stickers and use inline bots,
|
||||
# implies can_send_media_messages
|
||||
has 'can_add_web_page_previews'; # True, if the user is allowed to add web page previews to their messages, implies
|
||||
# can_send_media_messages
|
||||
has 'can_change_info'; # True, if the user is allowed to change the chat title, photo and other settings.
|
||||
# Ignored in public supergroups
|
||||
has 'can_invite_users'; # True, if the user is allowed to invite new users to the chat
|
||||
has 'can_pin_messages'; # True, if the user is allowed to pin messages. Ignored in public supergroups
|
||||
|
||||
sub fields {
|
||||
return {
|
||||
'scalar' => [qw/can_send_messages can_send_media_messages can_send_polls
|
||||
can_send_other_messages can_add_web_page_previews can_change_info
|
||||
can_invite_users can_pin_messages/]
|
||||
};
|
||||
}
|
||||
|
||||
sub canTalk {
|
||||
my $self = shift;
|
||||
my $chatid = shift;
|
||||
|
||||
my $can_talk = 0;
|
||||
|
||||
if ($chatid < 0) {
|
||||
# group chat
|
||||
my $chatobj = $self->_brain->getChat ({ 'chat_id' => $chatid });
|
||||
|
||||
# on api error, keep silence
|
||||
unless ($chatobj) {
|
||||
carp "Unable to get chat info for $chatid from telegram API";
|
||||
return 0;
|
||||
}
|
||||
|
||||
my $myObj = $self->_brain->getMe ();
|
||||
|
||||
# on api error, keep silence
|
||||
unless ($chatobj) {
|
||||
carp "Unable to get chat info for $chatid from telegram API";
|
||||
return 0;
|
||||
}
|
||||
|
||||
my $myid = $myObj->id;
|
||||
my $me = $self->_brain->getChatMember ({ 'chat_id' => $chatid, 'user_id' => $myid });
|
||||
|
||||
# on api error, keep silence
|
||||
unless ($me) {
|
||||
carp 'Unable to get chat info for bot itself from telegram API';
|
||||
return 0;
|
||||
}
|
||||
|
||||
if ($me->{'status'} eq 'administrator') {
|
||||
$can_talk = 1;
|
||||
} else {
|
||||
my $group_talk = int ($chatobj->{permissions}->{can_send_messages});
|
||||
$can_talk = $group_talk;
|
||||
}
|
||||
} else {
|
||||
# 1 on 1 chat with user
|
||||
$can_talk = 1;
|
||||
}
|
||||
|
||||
return $can_talk;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::ChatPermissions - The base class for Telegram 'ChatPermissions' type objects
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram 'ChatPermissions' type objects.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#chatpermissions> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::ChatPermissions> objects.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 canTalk
|
||||
|
||||
A convenience method to check if bot can talk in given conversation.
|
||||
|
||||
Returns true if the bot can talk in given conversation, otherwise false.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Sergei Fedosov <eleksir@gmail.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
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.
|
||||
|
||||
=cut
|
||||
52
lib/Teapot/Bot/Object/ChatPhoto.pm
Normal file
52
lib/Teapot/Bot/Object/ChatPhoto.pm
Normal file
@@ -0,0 +1,52 @@
|
||||
package Teapot::Bot::Object::ChatPhoto;
|
||||
# ABSTRACT: The base class for Telegram 'ChatPhoto' type objects
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
|
||||
$Teapot::Bot::Object::ChatPhoto::VERSION = '0.022';
|
||||
|
||||
has 'small_file_id';
|
||||
has 'small_file_unique_id';
|
||||
has 'big_file_id';
|
||||
has 'big_file_unique_id';
|
||||
|
||||
sub fields {
|
||||
return {
|
||||
'scalar' => [qw/small_file_id small_file_unique_id big_file_id big_file_unique_id/],
|
||||
};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::ChatPhoto - The base class for Telegram 'ChatPhoto' type objects
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram 'ChatPhoto' type objects.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#chatphoto> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::ChatPhoto> objects.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Justin Hawkins <justin@eatmorecode.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This software is copyright (c) 2019 by Justin Hawkins.
|
||||
|
||||
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
|
||||
53
lib/Teapot/Bot/Object/Contact.pm
Normal file
53
lib/Teapot/Bot/Object/Contact.pm
Normal file
@@ -0,0 +1,53 @@
|
||||
package Teapot::Bot::Object::Contact;
|
||||
# ABSTRACT: The base class for Telegram 'Contact' objects.
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
|
||||
$Teapot::Bot::Object::Contact::VERSION = '0.022';
|
||||
|
||||
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/],
|
||||
};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::Contact - The base class for Telegram 'Contact' objects
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram 'Contact' objects.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#contact> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::Contact> objects.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Justin Hawkins <justin@eatmorecode.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This software is copyright (c) 2019 by Justin Hawkins.
|
||||
|
||||
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
|
||||
48
lib/Teapot/Bot/Object/Dice.pm
Normal file
48
lib/Teapot/Bot/Object/Dice.pm
Normal file
@@ -0,0 +1,48 @@
|
||||
package Teapot::Bot::Object::Dice;
|
||||
# ABSTRACT: The base class for Telegram message 'Dice' type.
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
|
||||
$Teapot::Bot::Object::Dice::VERSION = '0.022';
|
||||
|
||||
has 'emoji';
|
||||
has 'value';
|
||||
|
||||
sub fields {
|
||||
return { scalar => [qw/emoji value/] };
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::Dice - The base class for Telegram message 'Dice' type
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram message 'Dice' type.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#dice> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::dice> objects.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Sergei Fedosov <eleksir@gmail.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This software is copyright (c) 2019 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
|
||||
57
lib/Teapot/Bot/Object/Document.pm
Normal file
57
lib/Teapot/Bot/Object/Document.pm
Normal file
@@ -0,0 +1,57 @@
|
||||
package Teapot::Bot::Object::Document;
|
||||
# ABSTRACT: The base class for Telegram 'Document' objects
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
|
||||
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';
|
||||
has 'file_size';
|
||||
|
||||
sub fields {
|
||||
return {
|
||||
scalar => [qw/file_id file_unique_id file_name mime_type file_size/],
|
||||
'Teapot::Bot::Object::PhotoSize' => [qw/thumb/]
|
||||
};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::Document - The base class for Telegram 'Document' objects
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram 'Document' objects.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#document> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::Document> objects.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Justin Hawkins <justin@eatmorecode.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This software is copyright (c) 2019 by Justin Hawkins.
|
||||
|
||||
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
|
||||
49
lib/Teapot/Bot/Object/EncryptedCredentials.pm
Normal file
49
lib/Teapot/Bot/Object/EncryptedCredentials.pm
Normal file
@@ -0,0 +1,49 @@
|
||||
package Teapot::Bot::Object::EncryptedCredentials;
|
||||
# ABSTRACT: The base class for Telegram 'EncryptedCredentials' type objects
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
|
||||
$Teapot::Bot::Object::EncryptedCredentials::VERSION = '0.022';
|
||||
|
||||
has 'data';
|
||||
has 'hash';
|
||||
has 'secret';
|
||||
|
||||
sub fields {
|
||||
return { 'scalar' => [qw/ data hash secret/] };
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::EncryptedCredentials - The base class for Telegram 'EncryptedCredentials' type objects
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram 'EncryptedCredentials' type objects.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#encryptedcredentials> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::EncryptedCredentials> objects.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Justin Hawkins <justin@eatmorecode.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This software is copyright (c) 2019 by Justin Hawkins.
|
||||
|
||||
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
|
||||
57
lib/Teapot/Bot/Object/EncryptedPassportElement.pm
Normal file
57
lib/Teapot/Bot/Object/EncryptedPassportElement.pm
Normal file
@@ -0,0 +1,57 @@
|
||||
package Teapot::Bot::Object::EncryptedPassportElement;
|
||||
# ABSTRACT: The base class for Telegram 'EncryptedPassportElement' type objects
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
|
||||
$Teapot::Bot::Object::EncryptedPassportElement::VERSION = '0.022';
|
||||
|
||||
# XXX Implement rest of this
|
||||
# https://core.telegram.org/bots/api#encryptedpassportelement
|
||||
|
||||
has 'type';
|
||||
has 'data';
|
||||
has 'phone_number';
|
||||
has 'email';
|
||||
|
||||
# XXX more here
|
||||
|
||||
sub fields {
|
||||
return { 'scalar' => [qw/type data phone_number email/] };
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::EncryptedPassportElement - The base class for Telegram 'EncryptedPassportElement' type objects
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram 'EncryptedPassportElement' type objects.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#encryptedpassportelement> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::EncryptedPassportElement> objects.
|
||||
|
||||
Note that this type is not yet fully implemented.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Justin Hawkins <justin@eatmorecode.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This software is copyright (c) 2019 by Justin Hawkins.
|
||||
|
||||
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
|
||||
63
lib/Teapot/Bot/Object/Game.pm
Normal file
63
lib/Teapot/Bot/Object/Game.pm
Normal file
@@ -0,0 +1,63 @@
|
||||
package Teapot::Bot::Object::Game;
|
||||
# ABSTRACT: The base class for Telegram message 'Game' type.
|
||||
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
use Teapot::Bot::Object::PhotoSize;
|
||||
use Teapot::Bot::Object::Animation;
|
||||
use Teapot::Bot::Object::MessageEntity;
|
||||
|
||||
$Teapot::Bot::Object::Game::VERSION = '0.022';
|
||||
|
||||
has 'title';
|
||||
has 'description';
|
||||
has 'photo'; # Array of PhotoSize
|
||||
has 'text';
|
||||
has 'text_entities'; #Array of MessageEntity
|
||||
has 'animation'; #Animation
|
||||
|
||||
sub fields {
|
||||
return {
|
||||
scalar => [qw/title description text/],
|
||||
'Teapot::Bot::Object::PhotoSize' => [qw/photo/],
|
||||
'Teapot::Bot::Object::MessageEntity' => [qw/text_entities/],
|
||||
'Teapot::Bot::Object::Animation' => [qw/animation/],
|
||||
};
|
||||
}
|
||||
|
||||
sub arrays { return qw/photo text_entities/; }
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::Game - The base class for Telegram message 'Game' type
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram message 'Game' type.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#game> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::Game> objects.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Justin Hawkins <justin@eatmorecode.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This software is copyright (c) 2019 by Justin Hawkins.
|
||||
|
||||
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
|
||||
60
lib/Teapot/Bot/Object/InlineKeyboardButton.pm
Normal file
60
lib/Teapot/Bot/Object/InlineKeyboardButton.pm
Normal file
@@ -0,0 +1,60 @@
|
||||
package Teapot::Bot::Object::InlineKeyboardButton;
|
||||
# ABSTRACT: The base class for Telegram 'InlineKeyboardButton' type objects
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
use Teapot::Bot::Object::LoginUrl;
|
||||
use Teapot::Bot::Object::CallbackGame;
|
||||
|
||||
$Teapot::Bot::Object::InlineKeyboardButton::VERSION = '0.022';
|
||||
|
||||
has 'text';
|
||||
has 'url';
|
||||
has 'login_url'; #LoginUrl
|
||||
has 'callback_data';
|
||||
has 'switch_inline_query';
|
||||
has 'switch_inline_query_current_chat';
|
||||
has 'callback_game'; # CallbackGame
|
||||
has 'pay';
|
||||
|
||||
sub fields {
|
||||
return { 'scalar' => [qw/text url callback_data switch_inline_query
|
||||
switch_inline_query_current_chat pay/],
|
||||
'Teapot::Bot::Object::LoginUrl' => [qw/login_url/],
|
||||
'Teapot::Bot::Object::CallbackGame' => [qw/callback_game/],
|
||||
};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::InlineKeyboardButton - The base class for Telegram 'InlineKeyboardButton' type objects
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram 'InlineKeyboardButton' type objects.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#inlinekeyboardbutton> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::InlineKeyboardButton> objects.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Justin Hawkins <justin@eatmorecode.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This software is copyright (c) 2019 by Justin Hawkins.
|
||||
|
||||
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
|
||||
52
lib/Teapot/Bot/Object/InlineKeyboardMarkup.pm
Normal file
52
lib/Teapot/Bot/Object/InlineKeyboardMarkup.pm
Normal file
@@ -0,0 +1,52 @@
|
||||
package Teapot::Bot::Object::InlineKeyboardMarkup;
|
||||
# ABSTRACT: The base class for Telegram 'InlineKeyboardMarkup' type objects
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
use Teapot::Bot::Object::InlineKeyboardButton;
|
||||
|
||||
$Teapot::Bot::Object::InlineKeyboardMarkup::VERSION = '0.022';
|
||||
|
||||
has 'inline_keyboard';
|
||||
|
||||
sub fields {
|
||||
return { 'Teapot::Bot::Object::InlineKeyboardButton' => [qw/inline_keyboard/] };
|
||||
}
|
||||
|
||||
sub array_of_arrays {
|
||||
return qw/inline_keyboard/;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::InlineKeyboardMarkup - The base class for Telegram 'InlineKeyboardMarkup' type objects
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram 'InlineKeyboardMarkup' type objects.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#inlinekeyboardmarkup> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::InlineKeyboardMarkup> objects.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Justin Hawkins <justin@eatmorecode.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This software is copyright (c) 2019 by Justin Hawkins.
|
||||
|
||||
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
|
||||
51
lib/Teapot/Bot/Object/Invoice.pm
Normal file
51
lib/Teapot/Bot/Object/Invoice.pm
Normal file
@@ -0,0 +1,51 @@
|
||||
package Teapot::Bot::Object::Invoice;
|
||||
# ABSTRACT: The base class for Telegram 'Invoice' type objects
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
|
||||
$Teapot::Bot::Object::Invoice::VERSION = '0.022';
|
||||
|
||||
has 'title';
|
||||
has 'description';
|
||||
has 'start_parameter';
|
||||
has 'currency';
|
||||
has 'total_amount';
|
||||
|
||||
sub fields {
|
||||
return { scalar => [qw/title description start_parameter currency total_amount/] };
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::Invoice - The base class for Telegram 'Invoice' type objects
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram 'Invoice' type objects.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#invoice> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::Invoice> objects.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Justin Hawkins <justin@eatmorecode.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This software is copyright (c) 2019 by Justin Hawkins.
|
||||
|
||||
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
|
||||
52
lib/Teapot/Bot/Object/Location.pm
Normal file
52
lib/Teapot/Bot/Object/Location.pm
Normal file
@@ -0,0 +1,52 @@
|
||||
package Teapot::Bot::Object::Location;
|
||||
# ABSTRACT: The base class for Telegram message 'Location' type.
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
|
||||
$Teapot::Bot::Object::Location::VERSION = '0.022';
|
||||
|
||||
has 'longitude';
|
||||
has 'latitude';
|
||||
has 'horizontal_accuracy';
|
||||
has 'live_period';
|
||||
has 'heading';
|
||||
has 'proximity_alert_radius';
|
||||
|
||||
sub fields {
|
||||
return { scalar => [qw/longitude latitude horizontal_accuracy live_period heading proximity_alert_radius/] };
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::Location - The base class for Telegram message 'Location' type
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram message 'Location' type.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#location> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::Location> objects.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Justin Hawkins <justin@eatmorecode.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This software is copyright (c) 2019 by Justin Hawkins.
|
||||
|
||||
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
|
||||
50
lib/Teapot/Bot/Object/LoginUrl.pm
Normal file
50
lib/Teapot/Bot/Object/LoginUrl.pm
Normal file
@@ -0,0 +1,50 @@
|
||||
package Teapot::Bot::Object::LoginUrl;
|
||||
# ABSTRACT: The base class for Telegram 'LoginUrl' type objects
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
|
||||
$Teapot::Bot::Object::LoginUrl::VERSION = '0.022';
|
||||
|
||||
has 'url';
|
||||
has 'forward_text';
|
||||
has 'bot_username';
|
||||
has 'request_write_access';
|
||||
|
||||
sub fields {
|
||||
return { 'scalar' => [qw/url forward_text bot_username request_write_access/] };
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::LoginUrl - The base class for Telegram 'LoginUrl' type objects
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram 'LoginUrl' type objects.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#loginurl> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::LoginUrl> objects.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Justin Hawkins <justin@eatmorecode.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This software is copyright (c) 2019 by Justin Hawkins.
|
||||
|
||||
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
|
||||
245
lib/Teapot/Bot/Object/Message.pm
Normal file
245
lib/Teapot/Bot/Object/Message.pm
Normal file
@@ -0,0 +1,245 @@
|
||||
package Teapot::Bot::Object::Message;
|
||||
# ABSTRACT: The base class for the Telegram type "Message".
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
|
||||
use Teapot::Bot::Object::User;
|
||||
use Teapot::Bot::Object::Chat;
|
||||
use Teapot::Bot::Object::ChatMember;
|
||||
use Teapot::Bot::Object::ChatPermissions;
|
||||
use Teapot::Bot::Object::MessageEntity;
|
||||
use Teapot::Bot::Object::Audio;
|
||||
use Teapot::Bot::Object::Document;
|
||||
use Teapot::Bot::Object::Animation;
|
||||
use Teapot::Bot::Object::Game;
|
||||
use Teapot::Bot::Object::PhotoSize;
|
||||
use Teapot::Bot::Object::Sticker;
|
||||
use Teapot::Bot::Object::Video;
|
||||
use Teapot::Bot::Object::Voice;
|
||||
use Teapot::Bot::Object::VideoNote;
|
||||
use Teapot::Bot::Object::Contact;
|
||||
use Teapot::Bot::Object::Location;
|
||||
use Teapot::Bot::Object::Poll;
|
||||
use Teapot::Bot::Object::Location;
|
||||
use Teapot::Bot::Object::PhotoSize;
|
||||
use Teapot::Bot::Object::Invoice;
|
||||
use Teapot::Bot::Object::Venue;
|
||||
use Teapot::Bot::Object::SuccessfulPayment;
|
||||
use Teapot::Bot::Object::PassportData;
|
||||
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;
|
||||
|
||||
use Data::Dumper;
|
||||
use Carp qw(cluck);
|
||||
|
||||
$Teapot::Bot::Object::Message::VERSION = '0.022';
|
||||
|
||||
# basic message stuff
|
||||
has 'message_id';
|
||||
has 'from'; # User
|
||||
has 'sender_chat'; # Chat
|
||||
has 'date';
|
||||
has 'chat'; # Chat
|
||||
has 'forward_from'; # User
|
||||
has 'forward_from_chat'; # Chat
|
||||
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';
|
||||
has 'entities'; # Array of MessageEntity
|
||||
has 'animation'; # Animation
|
||||
has 'audio'; # Audio
|
||||
has 'document'; # Document
|
||||
has 'photo'; # Array of PhotoSize
|
||||
has 'sticker'; # Sticker
|
||||
has 'video'; # Video
|
||||
has 'video_note'; # VideoNote
|
||||
has 'voice'; # Voice
|
||||
has 'caption';
|
||||
has 'caption_entities'; # Array of MessageEntity
|
||||
has 'contact'; # Contact
|
||||
has 'dice';
|
||||
has 'game';
|
||||
has 'poll'; # Poll
|
||||
has 'venue'; # Venue
|
||||
has 'location'; # Location
|
||||
has 'new_chat_members'; # Array of User
|
||||
has 'left_chat_member'; # User
|
||||
has 'new_chat_title';
|
||||
has 'new_chat_photo'; # Array of PhotoSize
|
||||
has 'delete_chat_photo';
|
||||
has 'group_chat_created';
|
||||
has 'supergroup_chat_created';
|
||||
has 'channel_chat_created';
|
||||
has 'message_auto_delete_timer_changed'; # Optional. Service message: auto-delete timer settings changed in the chat
|
||||
has 'migrate_to_chat_id';
|
||||
has 'migrate_from_chat_id';
|
||||
has 'pinned_message'; # Message
|
||||
has 'invoice'; # Invoice
|
||||
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
|
||||
has 'reply_markup'; # Array of InlineKeyboardMarkup
|
||||
|
||||
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
|
||||
new_chat_title delete_chat_photo
|
||||
group_chat_created supergroup_chat_created
|
||||
channel_chat_created migrate_to_chat_id
|
||||
migrate_from_chat_id connected_website/],
|
||||
'Teapot::Bot::Object::User' => [qw/from forward_from via_bot new_chat_members left_chat_member /],
|
||||
|
||||
'Teapot::Bot::Object::Chat' => [qw/sender_chat chat forward_from_chat/],
|
||||
'Teapot::Bot::Object::Message' => [qw/reply_to_message pinned_message/],
|
||||
'Teapot::Bot::Object::MessageEntity' => [qw/entities caption_entities /],
|
||||
|
||||
'Teapot::Bot::Object::Audio' => [qw/audio/],
|
||||
'Teapot::Bot::Object::Document' => [qw/document/],
|
||||
'Teapot::Bot::Object::Animation' => [qw/animation/],
|
||||
'Teapot::Bot::Object::Game' => [qw/game/],
|
||||
'Teapot::Bot::Object::PhotoSize' => [qw/photo new_chat_photo/],
|
||||
'Teapot::Bot::Object::Sticker' => [qw/sticker/],
|
||||
'Teapot::Bot::Object::Video' => [qw/video/],
|
||||
'Teapot::Bot::Object::Voice' => [qw/voice/],
|
||||
'Teapot::Bot::Object::VideoNote' => [qw/video_note/],
|
||||
|
||||
'Teapot::Bot::Object::Contact' => [qw/contact/],
|
||||
'Teapot::Bot::Object::Location' => [qw/location/],
|
||||
'Teapot::Bot::Object::Venue' => [qw/venue/],
|
||||
|
||||
'Teapot::Bot::Object::Poll' => [qw/poll/],
|
||||
|
||||
'Teapot::Bot::Object::Invoice' => [qw/invoice/],
|
||||
'Teapot::Bot::Object::SuccessfulPayment' => [qw/successful_payment/],
|
||||
'Teapot::Bot::Object::PassportData' => [qw/passport_data/],
|
||||
'Teapot::Bot::Object::InlineKeyboardMarkup' => [qw/reply_markup/],
|
||||
'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/],
|
||||
};
|
||||
}
|
||||
|
||||
sub arrays {
|
||||
return qw/photo entities caption_entities new_chat_members new_chat_photo/;
|
||||
}
|
||||
|
||||
|
||||
sub reply {
|
||||
my $self = shift;
|
||||
my $text = shift;
|
||||
|
||||
my $chatid = $self->chat->id;
|
||||
|
||||
if (Teapot::Bot::Object::ChatPermissions::canTalk($self, $chatid)) {
|
||||
return $self->_brain->sendMessage({chat_id => $chatid, text => $text});
|
||||
}
|
||||
|
||||
return {'error' => 1};
|
||||
}
|
||||
|
||||
sub replyMd {
|
||||
my $self = shift;
|
||||
my $text = shift;
|
||||
|
||||
my $chatid = $self->chat->id;
|
||||
|
||||
if (Teapot::Bot::Object::ChatPermissions::canTalk ($self, $chatid)) {
|
||||
my $send_args;
|
||||
$send_args->{text} = $text;
|
||||
$send_args->{parse_mode} = 'Markdown';
|
||||
$send_args->{chat_id} = $chatid;
|
||||
|
||||
return $self->_brain->sendMessage($send_args);
|
||||
}
|
||||
|
||||
return {'error' => 1};
|
||||
}
|
||||
|
||||
sub typing {
|
||||
my $self = shift;
|
||||
|
||||
my $chatid = $self->chat->id;
|
||||
|
||||
if (Teapot::Bot::Object::ChatPermissions::canTalk ($self, $chatid)) {
|
||||
return $self->_brain->sendChatAction({chat_id => $chatid});
|
||||
}
|
||||
|
||||
return {'error' => 1};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::Message - The base class for the Telegram type "Message"
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for the Telegram type "Message".
|
||||
|
||||
See L<https://core.telegram.org/bots/api#message> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::Message> objects.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 reply
|
||||
|
||||
A convenience method to reply to a message with text.
|
||||
|
||||
Will return the L<Teapot::Bot::Object::Message> object representing the message
|
||||
sent.
|
||||
|
||||
=head2 typing
|
||||
|
||||
Sends notification to chat that bot is "typing" something.
|
||||
|
||||
Returns nothing that should be checked.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Justin Hawkins <justin@eatmorecode.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This software is copyright (c) 2019 by Justin Hawkins.
|
||||
|
||||
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
|
||||
49
lib/Teapot/Bot/Object/MessageAutoDeleteTimerChanged.pm
Normal file
49
lib/Teapot/Bot/Object/MessageAutoDeleteTimerChanged.pm
Normal file
@@ -0,0 +1,49 @@
|
||||
package Teapot::Bot::Object::MessageAutoDeleteTimerChanged;
|
||||
# ABSTRACT: The base class for Telegram 'MessageAutoDeleteTimerChanged' type objects
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
|
||||
$Teapot::Bot::Object::MessageAutoDeleteTimerChanged::VERSION = '0.022';
|
||||
|
||||
has 'message_auto_delete_time';
|
||||
|
||||
sub fields {
|
||||
return {
|
||||
'scalar' => [qw/message_auto_delete_time/],
|
||||
};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::MessageAutoDeleteTimerChanged - The base class for Telegram 'MessageAutoDeleteTimerChanged' type objects
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram 'MessageAutoDeleteTimerChanged' type objects.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#messageautodeletetimerchanged> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::MessageAutoDeleteTimerChanged> 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
|
||||
56
lib/Teapot/Bot/Object/MessageEntity.pm
Normal file
56
lib/Teapot/Bot/Object/MessageEntity.pm
Normal file
@@ -0,0 +1,56 @@
|
||||
package Teapot::Bot::Object::MessageEntity;
|
||||
# ABSTRACT: The base class for Telegram 'MessageEntity' type objects
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
use Teapot::Bot::Object::User;
|
||||
|
||||
$Teapot::Bot::Object::MessageEntity::VERSION = '0.022';
|
||||
|
||||
has 'type';
|
||||
has 'offset';
|
||||
has 'length';
|
||||
has 'url'; # Optional.
|
||||
has 'user'; # Optional. Teapot::Bot::Object::User
|
||||
has 'language'; # Optional. For “pre” only, the programming language of the entity text
|
||||
|
||||
sub fields {
|
||||
return {
|
||||
'scalar' => [qw/type offset length url language/],
|
||||
'Teapot::Bot::Object::User' => [qw/user/],
|
||||
};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::MessageEntity - The base class for Telegram 'MessageEntity' type objects
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram 'MessageEntity' type objects.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#messageentity> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::MessageEntity> objects.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Justin Hawkins <justin@eatmorecode.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This software is copyright (c) 2019 by Justin Hawkins.
|
||||
|
||||
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
|
||||
57
lib/Teapot/Bot/Object/PassportData.pm
Normal file
57
lib/Teapot/Bot/Object/PassportData.pm
Normal file
@@ -0,0 +1,57 @@
|
||||
package Teapot::Bot::Object::PassportData;
|
||||
# ABSTRACT: The base class for Telegram 'PassportData' type objects
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
use Teapot::Bot::Object::EncryptedPassportElement;
|
||||
use Teapot::Bot::Object::EncryptedCredentials;
|
||||
|
||||
$Teapot::Bot::Object::PassportData::VERSION = '0.022';
|
||||
|
||||
has 'data'; # Array of EncryptedPassportElement
|
||||
has 'credentials'; # EncryptedCredentials
|
||||
|
||||
sub fields {
|
||||
return {
|
||||
'Teapot::Bot::Object::EncryptedPassportElement' => [qw/data/],
|
||||
'Teapot::Bot::Object::EncryptedCredentials' => [qw/credentials/],
|
||||
};
|
||||
}
|
||||
|
||||
sub arrays {
|
||||
return qw/data/;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::PassportData - The base class for Telegram 'PassportData' type objects
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram 'PassportData' type objects.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#passportdata> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::PassportData> objects.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Justin Hawkins <justin@eatmorecode.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This software is copyright (c) 2019 by Justin Hawkins.
|
||||
|
||||
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
|
||||
52
lib/Teapot/Bot/Object/PhotoSize.pm
Normal file
52
lib/Teapot/Bot/Object/PhotoSize.pm
Normal file
@@ -0,0 +1,52 @@
|
||||
package Teapot::Bot::Object::PhotoSize;
|
||||
# ABSTRACT: The base class for Telegram message 'PhotoSize' type.
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
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/] };
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::PhotoSize - The base class for Telegram message 'PhotoSize' type
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram message 'PhotoSize' type.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#photosize> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::PhotoSize> objects.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Justin Hawkins <justin@eatmorecode.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This software is copyright (c) 2019 by Justin Hawkins.
|
||||
|
||||
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
|
||||
69
lib/Teapot/Bot/Object/Poll.pm
Normal file
69
lib/Teapot/Bot/Object/Poll.pm
Normal file
@@ -0,0 +1,69 @@
|
||||
package Teapot::Bot::Object::Poll;
|
||||
# ABSTRACT: The base class for Telegram 'Poll' type objects
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
use Teapot::Bot::Object::PollOption;
|
||||
|
||||
$Teapot::Bot::Object::Poll::VERSION = '0.022';
|
||||
|
||||
has 'id';
|
||||
has 'question';
|
||||
has 'options'; # Array of PollOption
|
||||
has 'total_voter_count';
|
||||
has 'is_closed';
|
||||
has 'is_anonymous';
|
||||
has 'type';
|
||||
has 'allows_multiple_answers';
|
||||
has 'correct_option_id';
|
||||
has 'explanation';
|
||||
has 'explanation_entities';
|
||||
has 'open_period';
|
||||
has 'close_date';
|
||||
|
||||
sub fields {
|
||||
return {
|
||||
scalar => [qw/id question total_voter_count is_closed is_anonymous type
|
||||
allows_multiple_answers correct_option_id explanation
|
||||
explanation_entities open_period close_date/],
|
||||
'Teapot::Bot::Object::PollOption' => [qw/options/],
|
||||
};
|
||||
}
|
||||
|
||||
sub arrays {
|
||||
return qw/options explanation_entities/;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::Poll - The base class for Telegram 'Poll' type objects
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram 'Poll' type objects
|
||||
|
||||
See L<https://core.telegram.org/bots/api#poll> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::Poll> objects.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Justin Hawkins <justin@eatmorecode.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This software is copyright (c) 2019 by Justin Hawkins.
|
||||
|
||||
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
|
||||
56
lib/Teapot/Bot/Object/PollAnswer.pm
Normal file
56
lib/Teapot/Bot/Object/PollAnswer.pm
Normal file
@@ -0,0 +1,56 @@
|
||||
package Teapot::Bot::Object::PollAnswer;
|
||||
# ABSTRACT: The base class for Telegram 'PollOption' type objects
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
|
||||
$Teapot::Bot::Object::PollAnswer::VERSION = '0.022';
|
||||
|
||||
has 'poll_id';
|
||||
has 'user';
|
||||
has 'option_ids';
|
||||
|
||||
sub fields {
|
||||
return {
|
||||
'scalar' => [qw/poll_id option_ids/],
|
||||
'Teapot::Bot::Object::User' => [qw/user/],
|
||||
};
|
||||
}
|
||||
|
||||
sub arrays {
|
||||
return qw/option_ids/;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::PollAnswer - The base class for Telegram 'PollAnswer' type objects
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram 'PollAnswer' type objects.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#pollanswer> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::PollAnswer> objects.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Sergei Fedosov <eleksir@gmail.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This software is copyright (c) 2021 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
|
||||
48
lib/Teapot/Bot/Object/PollOption.pm
Normal file
48
lib/Teapot/Bot/Object/PollOption.pm
Normal file
@@ -0,0 +1,48 @@
|
||||
package Teapot::Bot::Object::PollOption;
|
||||
# ABSTRACT: The base class for Telegram 'PollOption' type objects
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
|
||||
$Teapot::Bot::Object::PollOption::VERSION = '0.022';
|
||||
|
||||
has 'text';
|
||||
has 'voter_count';
|
||||
|
||||
sub fields {
|
||||
return { scalar => [qw/text voter_count/] };
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::PollOption - The base class for Telegram 'PollOption' type objects
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram 'PollOption' type 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
|
||||
|
||||
Justin Hawkins <justin@eatmorecode.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This software is copyright (c) 2019 by Justin Hawkins.
|
||||
|
||||
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
|
||||
52
lib/Teapot/Bot/Object/ProximityAlertTriggered.pm
Normal file
52
lib/Teapot/Bot/Object/ProximityAlertTriggered.pm
Normal file
@@ -0,0 +1,52 @@
|
||||
package Teapot::Bot::Object::ProximityAlertTriggered;
|
||||
# ABSTRACT: The base class for Telegram message 'ProximityAlertTriggered' type.
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
|
||||
$Teapot::Bot::Object::ProximityAlertTriggered::VERSION = '0.022';
|
||||
|
||||
has 'traveler'; # User
|
||||
has 'watcher'; # User
|
||||
has 'distance';
|
||||
|
||||
sub fields {
|
||||
return {
|
||||
'Teapot::Bot::Object::User' => [qw/traveler watcher/],
|
||||
'scalar' => [qw/distance/],
|
||||
};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::ProximityAlertTriggered - The base class for Telegram message 'ProximityAlertTriggered' type
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram message 'ProximityAlertTriggered' type.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#proximityalerttriggered> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::ProximityAlertTriggered> objects.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Sergei Fedosov <eleksir@gmail.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
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.
|
||||
|
||||
=cut
|
||||
58
lib/Teapot/Bot/Object/Sticker.pm
Normal file
58
lib/Teapot/Bot/Object/Sticker.pm
Normal file
@@ -0,0 +1,58 @@
|
||||
package Teapot::Bot::Object::Sticker;
|
||||
# ABSTRACT: The base class for Telegram message 'Sticker' type.
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
use Teapot::Bot::Object::PhotoSize;
|
||||
|
||||
$Teapot::Bot::Object::Sticker::VERSION = '0.022';
|
||||
|
||||
has 'file_id';
|
||||
has 'width';
|
||||
has 'height';
|
||||
has 'thumb'; # PhotoSize
|
||||
has 'emoji';
|
||||
has 'set_name';
|
||||
# has 'mask_position'; # XXX TODO
|
||||
has 'file_size';
|
||||
|
||||
sub fields {
|
||||
return {
|
||||
scalar => [ qw/file_id width height emoji set_name file_size/ ],
|
||||
'Teapot::Bot::Object::PhotoSize' => [ qw/thumb/ ],
|
||||
};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::Sticker - The base class for Telegram message 'Sticker' type
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram message 'Sticker' type.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#sticker> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::Sticker> objects.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Justin Hawkins <justin@eatmorecode.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This software is copyright (c) 2019 by Justin Hawkins.
|
||||
|
||||
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
|
||||
58
lib/Teapot/Bot/Object/SuccessfulPayment.pm
Normal file
58
lib/Teapot/Bot/Object/SuccessfulPayment.pm
Normal file
@@ -0,0 +1,58 @@
|
||||
package Teapot::Bot::Object::SuccessfulPayment;
|
||||
# ABSTRACT: The base class for Telegram 'SuccessfulPayment' type objects
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
# use Teapot::Bot::Object::OrderInfo;
|
||||
|
||||
$Teapot::Bot::Object::SuccessfulPayment::VERSION = '0.022';
|
||||
|
||||
has 'currency';
|
||||
has 'total_amount';
|
||||
has 'invoice_payload';
|
||||
has 'shipping_option_id';
|
||||
# has 'order_info'; #OrderInfo XXX
|
||||
has 'telegram_payment_charge_id';
|
||||
has 'provider_payment_charge_id';
|
||||
|
||||
sub fields {
|
||||
return {
|
||||
scalar => [qw/currency total_amount invoice_payload shipping_option_id
|
||||
telegram_payment_charge_id provider_payment_charge_id/],
|
||||
# 'Teapot::Bot::Object::OrderInfo' => [qw/order_info/],
|
||||
};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::SuccessfulPayment - The base class for Telegram 'SuccessfulPayment' type objects
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram 'SuccessfulPayment' type objects.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#successfulpayment> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::SuccessfulPayment> objects.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Justin Hawkins <justin@eatmorecode.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This software is copyright (c) 2019 by Justin Hawkins.
|
||||
|
||||
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
|
||||
59
lib/Teapot/Bot/Object/User.pm
Normal file
59
lib/Teapot/Bot/Object/User.pm
Normal file
@@ -0,0 +1,59 @@
|
||||
package Teapot::Bot::Object::User;
|
||||
# ABSTRACT: The base class for Telegram message 'User' type.
|
||||
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
|
||||
$Teapot::Bot::Object::User::VERSION = '0.022';
|
||||
|
||||
has 'id';
|
||||
has 'is_bot';
|
||||
has 'first_name';
|
||||
has 'last_name'; # optional
|
||||
has 'username'; # optional
|
||||
has 'language_code'; # optional
|
||||
has 'can_join_groups'; # optional, only for getMe() method
|
||||
has 'can_read_all_group_messages';# optional, only for getMe() method
|
||||
has 'supports_inline_queries'; # optional, only for getMe() method
|
||||
|
||||
sub fields {
|
||||
return {
|
||||
scalar => [qw/id is_bot first_name last_name username language_code can_join_groups
|
||||
can_read_all_group_messages supports_inline_queries/]
|
||||
};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::User - The base class for Telegram message 'User' type
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram message 'User' type.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#user> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::User> objects.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Justin Hawkins <justin@eatmorecode.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This software is copyright (c) 2019 by Justin Hawkins.
|
||||
|
||||
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
|
||||
58
lib/Teapot/Bot/Object/Venue.pm
Normal file
58
lib/Teapot/Bot/Object/Venue.pm
Normal file
@@ -0,0 +1,58 @@
|
||||
package Teapot::Bot::Object::Venue;
|
||||
# ABSTRACT: The base class for Telegram 'LoginUrl' type objects
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
use Teapot::Bot::Object::Location;
|
||||
|
||||
$Teapot::Bot::Object::Venue::VERSION = '0.022';
|
||||
|
||||
has 'location'; #Location
|
||||
has 'title';
|
||||
has 'address';
|
||||
has 'foursquare_id';
|
||||
has 'foursquare_type';
|
||||
has 'google_place_id';
|
||||
has 'google_place_type';
|
||||
|
||||
sub fields {
|
||||
return {
|
||||
'scalar' => [qw/title address foursquare_id foursquare_type google_place_id google_place_type/],
|
||||
'Teapot::Bot::Object::Location' => [qw/location/]
|
||||
};
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::Venue - The base class for Telegram 'LoginUrl' type objects
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram 'LoginUrl' type objects.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#venue> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::Venue> objects.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Justin Hawkins <justin@eatmorecode.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This software is copyright (c) 2019 by Justin Hawkins.
|
||||
|
||||
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
|
||||
60
lib/Teapot/Bot/Object/Video.pm
Normal file
60
lib/Teapot/Bot/Object/Video.pm
Normal file
@@ -0,0 +1,60 @@
|
||||
package Teapot::Bot::Object::Video;
|
||||
# ABSTRACT: The base class for Telegram 'Video' object.
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
use Teapot::Bot::Object::PhotoSize;
|
||||
|
||||
$Teapot::Bot::Object::Video::VERSION = '0.022';
|
||||
|
||||
has 'file_id';
|
||||
has 'file_unique_id';
|
||||
has 'width';
|
||||
has 'height';
|
||||
has 'duration';
|
||||
has 'thumb'; # Optional. Video thumbnail
|
||||
has 'file_name'; # Optional. Original filename as defined by sender
|
||||
has 'mime_type'; # Optional. Mime type of a file as defined by sender
|
||||
has 'file_size'; # Optional. File size
|
||||
|
||||
sub fields {
|
||||
return {
|
||||
scalar => [qw/file_id file_unique_id width height duration file_name mime_type
|
||||
file_size/],
|
||||
'Teapot::Bot::Object::PhotoSize' => [qw/thumb/]
|
||||
};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::Video - The base class for Telegram 'Video' object
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram 'Video' object.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#video> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::Video> objects.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Justin Hawkins <justin@eatmorecode.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This software is copyright (c) 2019 by Justin Hawkins.
|
||||
|
||||
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
|
||||
58
lib/Teapot/Bot/Object/VideoNote.pm
Normal file
58
lib/Teapot/Bot/Object/VideoNote.pm
Normal file
@@ -0,0 +1,58 @@
|
||||
package Teapot::Bot::Object::VideoNote;
|
||||
# ABSTRACT: The base class for Telegram 'VideoNote' type objects
|
||||
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
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';
|
||||
has 'thumb'; #PhotoSize
|
||||
has 'file_size';
|
||||
|
||||
sub fields {
|
||||
return {
|
||||
scalar => [qw/file_id file_unique_id length duration mime_type file_size/],
|
||||
'Teapot::Bot::Object::PhotoSize' => [qw/thumb /],
|
||||
};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::VideoNote - The base class for Telegram 'VideoNote' type objects
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram 'VideoNote' type object.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#videonote> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::VideoNote> objects.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Justin Hawkins <justin@eatmorecode.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This software is copyright (c) 2019 by Justin Hawkins.
|
||||
|
||||
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
|
||||
51
lib/Teapot/Bot/Object/Voice.pm
Normal file
51
lib/Teapot/Bot/Object/Voice.pm
Normal file
@@ -0,0 +1,51 @@
|
||||
package Teapot::Bot::Object::Voice;
|
||||
# ABSTRACT: The base class for Telegram 'Voice' type objects
|
||||
|
||||
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/] };
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::Voice - The base class for Telegram 'Voice' type objects
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram 'Voice' type objects.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#voice> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::Voice> objects.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Justin Hawkins <justin@eatmorecode.com>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This software is copyright (c) 2019 by Justin Hawkins.
|
||||
|
||||
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
|
||||
48
lib/Teapot/Bot/Object/VoiceChatEnded.pm
Normal file
48
lib/Teapot/Bot/Object/VoiceChatEnded.pm
Normal file
@@ -0,0 +1,48 @@
|
||||
package Teapot::Bot::Object::VoiceChatEnded;
|
||||
# ABSTRACT: The base class for Telegram message 'VoiceChatEnded' type.
|
||||
|
||||
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';
|
||||
|
||||
sub fields {
|
||||
return { scalar => [qw/duration/] };
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::VoiceChatEnded - The base class for Telegram message 'VoiceChatEnded' type
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram message 'VoiceChatEnded' type.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#voicechatended> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::VoiceChatEnded> 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
|
||||
53
lib/Teapot/Bot/Object/VoiceChatParticipantsInvited.pm
Normal file
53
lib/Teapot/Bot/Object/VoiceChatParticipantsInvited.pm
Normal file
@@ -0,0 +1,53 @@
|
||||
package Teapot::Bot::Object::VoiceChatParticipantsInvited;
|
||||
# ABSTRACT: The base class for Telegram message 'VoiceChatParticipantsInvited' type.
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
use Teapot::Bot::Object::User;
|
||||
|
||||
$Teapot::Bot::Object::VoiceChatParticipantsInvited::VERSION = '0.022';
|
||||
|
||||
# This object represents a service message about a voice chat started in the chat. Currently holds no information.
|
||||
has 'users';
|
||||
|
||||
sub fields {
|
||||
return { 'Teapot::Bot::Object::User' => [qw/users/] };
|
||||
}
|
||||
|
||||
sub arrays {
|
||||
return qw/users/;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::VoiceChatParticipantsInvited - The base class for Telegram message 'VoiceChatParticipantsInvited' type
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram message 'VoiceChatParticipantsInvited' type.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#voicechatparticipantsinvited> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::VoiceChatParticipantsInvited> 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
|
||||
48
lib/Teapot/Bot/Object/VoiceChatScheduled.pm
Normal file
48
lib/Teapot/Bot/Object/VoiceChatScheduled.pm
Normal file
@@ -0,0 +1,48 @@
|
||||
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
|
||||
48
lib/Teapot/Bot/Object/VoiceChatStarted.pm
Normal file
48
lib/Teapot/Bot/Object/VoiceChatStarted.pm
Normal file
@@ -0,0 +1,48 @@
|
||||
package Teapot::Bot::Object::VoiceChatStarted;
|
||||
# ABSTRACT: The base class for Telegram message 'VoiceChatStarted' type.
|
||||
|
||||
use Mojo::Base 'Teapot::Bot::Object::Base';
|
||||
|
||||
$Teapot::Bot::Object::VoiceChatStarted::VERSION = '0.022';
|
||||
|
||||
# This object represents a service message about a voice chat started in the chat. Currently holds no information.
|
||||
has 'stub';
|
||||
|
||||
sub fields {
|
||||
return { scalar => [qw/stub/] };
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Teapot::Bot::Object::VoiceChatStarted - The base class for Telegram message 'VoiceChatStarted' type
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.022
|
||||
|
||||
=head1 DESCRIPTION
|
||||
The base class for Telegram message 'VoiceChatStarted' type.
|
||||
|
||||
See L<https://core.telegram.org/bots/api#voicechatstarted> for details of the
|
||||
attributes available for L<Teapot::Bot::Object::VoiceChatStarted> 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
|
||||
419
lib/TelegramBot.pm
Normal file
419
lib/TelegramBot.pm
Normal file
@@ -0,0 +1,419 @@
|
||||
package TelegramBot;
|
||||
# main bot gears are here
|
||||
|
||||
use 5.018;
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
use open qw (:std :utf8);
|
||||
use English qw ( -no_match_vars );
|
||||
use Carp qw (cluck carp);
|
||||
use Clone qw (clone);
|
||||
use File::Path qw (make_path);
|
||||
use Log::Any qw ($log);
|
||||
use Math::Random::Secure qw (irand);
|
||||
use Mojo::Base 'Teapot::Bot::Brain';
|
||||
|
||||
use BotLib::Admin qw (FortuneToggleList ChanMsgEnabled);
|
||||
use BotLib qw (Command Highlight BotSleep IsCensored);
|
||||
use BotLib::Conf qw (LoadConf);
|
||||
use BotLib::Util qw (trim fmatch);
|
||||
use RedisLib qw (redis_parse_message redis_events_listener);
|
||||
|
||||
use version; our $VERSION = qw (1.0);
|
||||
use Exporter qw (import);
|
||||
our @EXPORT_OK = qw (RunTelegramBot);
|
||||
|
||||
my $c = LoadConf ();
|
||||
my $myid;
|
||||
my $myusername;
|
||||
my $myfirst_name;
|
||||
my $mylast_name;
|
||||
my $myfullname;
|
||||
|
||||
has token => $c->{telegrambot}->{token};
|
||||
|
||||
my $redismsg->{from} = 'telegram';
|
||||
$redismsg->{plugin} = 'telegram';
|
||||
$redismsg->{misc}->{answer} = 1;
|
||||
$redismsg->{misc}->{csign} = $c->{telegrambot}->{csign};
|
||||
$redismsg->{misc}->{msg_format} = 0;
|
||||
$redismsg->{misc}->{fwd_cnt} = 1;
|
||||
|
||||
sub __cron {
|
||||
my $self = shift;
|
||||
|
||||
my $rmsg = clone ($redismsg);
|
||||
$rmsg->{mode} = 'public';
|
||||
# Press 'F' to pay respect
|
||||
$rmsg->{message} = sprintf '%sf', $c->{telegrambot}->{csign};
|
||||
$rmsg->{misc}->{good_morning} = 1;
|
||||
$rmsg->{misc}->{msg_format} = 1;
|
||||
|
||||
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime (time);
|
||||
|
||||
{
|
||||
do {
|
||||
my $ready = eval { $main::RCONN->is_connected; };
|
||||
last if ($ready);
|
||||
} while (sleep 1);
|
||||
}
|
||||
|
||||
my $pubsub = $main::REDIS->pubsub;
|
||||
|
||||
if ($hour == 8 && ($min >= 0 && $min <= 14)) {
|
||||
foreach my $enabledfortunechat (FortuneToggleList ()) {
|
||||
$rmsg->{userid} = $enabledfortunechat;
|
||||
$rmsg->{chatid} = $enabledfortunechat;
|
||||
|
||||
$pubsub->json ($c->{'redis_router_channel'})->notify (
|
||||
$c->{'redis_router_channel'} => $rmsg
|
||||
);
|
||||
}
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub __on_msg {
|
||||
my ($self, $msg) = @_;
|
||||
# chat info
|
||||
my $chatid;
|
||||
my $chatname = 'Noname chat';
|
||||
# user sending message info
|
||||
my ($userid, $username, $fullname, $highlight, $vis_a_vi) = BotLib::Highlight ($msg);
|
||||
my $csign = $c->{telegrambot}->{csign};
|
||||
|
||||
unless ($myid) {
|
||||
my $myObj = $self->getMe ();
|
||||
|
||||
unless ($myObj) {
|
||||
$log->error ('[ERROR] Unable to get chatid, API Error?');
|
||||
return;
|
||||
}
|
||||
|
||||
$myid = $myObj->id;
|
||||
$myusername = $myObj->username;
|
||||
$myfirst_name = $myObj->first_name;
|
||||
$mylast_name = $myObj->last_name;
|
||||
|
||||
if (defined ($myfirst_name) && ($myfirst_name ne '') && defined ($mylast_name) && ($mylast_name ne '')) {
|
||||
$myfullname = $myfirst_name . ' ' . $mylast_name;
|
||||
} elsif (defined ($myfirst_name) && ($myfirst_name ne '')) {
|
||||
$myfullname = $myfirst_name;
|
||||
} elsif (defined ($mylast_name) && ($mylast_name ne '')) {
|
||||
$myfullname = $mylast_name;
|
||||
} else {
|
||||
$myfullname = $myusername;
|
||||
}
|
||||
}
|
||||
|
||||
if ($msg->chat->can ('id') && defined ($msg->chat->id)) {
|
||||
$chatid = $msg->chat->id;
|
||||
|
||||
if ($msg->chat->can ('username') && defined ($msg->chat->username)) {
|
||||
$chatname = $msg->chat->username ;
|
||||
} else {
|
||||
if ($msg->chat->can ('title') && defined ($msg->chat->title)) {
|
||||
$chatname = $msg->chat->title;
|
||||
} else {
|
||||
$chatname = 'Noname chat';
|
||||
}
|
||||
}
|
||||
} else {
|
||||
$log->warn ('[INFO] Unable to get chatid');
|
||||
return;
|
||||
}
|
||||
|
||||
my $phrase = '';
|
||||
|
||||
# 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) {
|
||||
$member_str .= $member->first_name;
|
||||
|
||||
if ($member->can ('last_name') && defined ($member->last_name) && $member->last_name !~ /^\s+$/ui) {
|
||||
$member_str .= ' ' . $member->last_name;
|
||||
}
|
||||
} else {
|
||||
if ($member->can ('last_name') && defined ($member->last_name) && $member->last_name !~ /^\s+$/ui) {
|
||||
$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;
|
||||
}
|
||||
}
|
||||
|
||||
push @members, sprintf '[%s](tg://user?id=%s)', $member_str, $member->id;
|
||||
};
|
||||
|
||||
if ($#members > 1) {
|
||||
my $lastone = pop @members;
|
||||
$phrase = sprintf '%s, %s и %s. Представьтес, пожалуйста, и расскажите, что вас сюда привело.', $introduce[irand ($#introduce + 1)], join (', ', @members), $lastone;
|
||||
} else {
|
||||
$phrase = sprintf '%s, %s. Представьтес, пожалуйста, и расскажите, что вас сюда привело.', $introduce[irand ($#introduce + 1)], $members[0];
|
||||
}
|
||||
|
||||
BotSleep $msg;
|
||||
$msg->replyMd ($phrase);
|
||||
return;
|
||||
}
|
||||
|
||||
# is this a 1-on-1 ?
|
||||
if ($msg->chat->type eq 'private') {
|
||||
unless (defined $msg->text) {
|
||||
return;
|
||||
}
|
||||
|
||||
my $text = $msg->text;
|
||||
$log->debug (sprintf ('[DEBUG] Private chat %s say to bot: %s', $vis_a_vi, $text));
|
||||
# Ответ по-умолчанию
|
||||
my $reply = 'Давайте ещё пообщаемся, а то я ещё не научилась от вас плохому.';
|
||||
|
||||
if (substr ($text, 0, 1) eq $csign) {
|
||||
# Если текст похож на команду, усылаем его в BotLib.pm
|
||||
$reply = Command ($self, $msg, $text, $userid);
|
||||
} else {
|
||||
my $rmsg = clone ($redismsg);
|
||||
$rmsg->{mode} = 'private';
|
||||
$rmsg->{message} = $text;
|
||||
$rmsg->{userid} = $userid;
|
||||
$rmsg->{chatid} = $userid;
|
||||
my $pubsub = $main::REDIS->pubsub;
|
||||
$pubsub->json ($c->{'redis_router_channel'})->notify (
|
||||
$c->{'redis_router_channel'} => $rmsg
|
||||
);
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
# Команды раздела Admin ответ таки возвращают
|
||||
if (defined $reply) {
|
||||
$msg->typing ();
|
||||
sleep 1;
|
||||
$log->debug (sprintf ('[DEBUG] Private chat bot reply to %s: %s', $vis_a_vi, $reply));
|
||||
$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);
|
||||
$self->deleteMessage ({chat_id => $chatid, message_id => $msg->{message_id}});
|
||||
}
|
||||
|
||||
# Некоторые рекламные товарищи пытаются срать своими каналами в чятик это тоже можно зацензурить ботом и это
|
||||
# пидорство он будет удалять asap
|
||||
# 136817688 - это специальный id пользователя, который принимает облик канала, на него можно нажать и попасть
|
||||
# на рекламируемый канал
|
||||
if ($msg->from->id == 136817688) {
|
||||
my $sender_chat = eval { $msg->sender_chat->id };
|
||||
|
||||
if (defined $sender_chat) {
|
||||
unless (ChanMsgEnabled ($chatid)) {
|
||||
$self->deleteMessage ({chat_id => $chatid, message_id => $msg->{message_id}});
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Если обнаруживаем здесь сообщение без текста, просто ничего не делаем и выходим из процедуры обработки
|
||||
# сообщения
|
||||
unless (defined $msg->text) {
|
||||
$log->debug (sprintf ('[DEBUG] No text in message from %s', $vis_a_vi));
|
||||
return;
|
||||
}
|
||||
|
||||
# Текст есть, потенциально можно будет поболтать!
|
||||
my $text = $msg->text;
|
||||
$log->debug (sprintf ('[DEBUG] In public chat %s (%s) %s say: %s', $chatname, $chatid, $vis_a_vi, $text));
|
||||
|
||||
# Если это ответ на сообщение, то вдруг, на наше?
|
||||
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));
|
||||
|
||||
# Если новый участник чата ответил на наше приветствие, проигнорируем его ответ (и попробуем сойти за
|
||||
# человека :)
|
||||
if (substr ($msg->reply_to_message->text, -61) eq 'Представьтес, пожалуйста, и расскажите, что вас сюда привело.') {
|
||||
my $match = 0;
|
||||
my @hello = (
|
||||
'Дратути, ',
|
||||
'Дарована, ',
|
||||
'Доброе утро, день или вечер, ',
|
||||
'Добро пожаловать в наше скромное коммунити, ',
|
||||
'Наше вам с кисточкой тут, на канальчике, '
|
||||
);
|
||||
|
||||
foreach my $hi (@hello) {
|
||||
if (substr ($msg->reply_to_message->text, 0, length $hi) eq $hi) {
|
||||
return;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# На всякий случай, попробуем убрать наше имя из фразы.
|
||||
my $pat1 = quotemeta ('@' . $myusername);
|
||||
my $pat2 = quotemeta $myfullname;
|
||||
$phrase = $text;
|
||||
$phrase =~ s/$pat1//g;
|
||||
$phrase =~ s/$pat2//g;
|
||||
|
||||
# Попробуем сгенерить ответ
|
||||
my $rmsg = clone ($redismsg);
|
||||
$rmsg->{mode} = 'public';
|
||||
$rmsg->{message} = $phrase;
|
||||
$rmsg->{userid} = $userid;
|
||||
$rmsg->{chatid} = $chatid;
|
||||
|
||||
my $pubsub = $main::REDIS->pubsub;
|
||||
|
||||
$pubsub->json ($c->{'redis_router_channel'})->notify (
|
||||
$c->{'redis_router_channel'} => $rmsg
|
||||
);
|
||||
|
||||
return;
|
||||
# Если текст похож на команду, усылаем его в BotLib.pm
|
||||
} elsif (substr ($text, 0, 1) eq $csign) {
|
||||
$reply = Command ($self, $msg, $text, $chatid);
|
||||
# Похоже кто-то написал наше имя в чятике, но ничего не захотел дописывать к нему
|
||||
} elsif (
|
||||
($text eq $myusername) or
|
||||
($text eq '@' . $myusername) or
|
||||
($text eq '@' . $myusername . ' ') or
|
||||
($text eq $myfullname) or
|
||||
($text eq $myfullname . ' ')
|
||||
) {
|
||||
$reply = 'Чего?';
|
||||
# А тут кто-то к нам обратился с чем-то по имени
|
||||
} else {
|
||||
my $qname = quotemeta ('@' . $myusername);
|
||||
my $qtname = quotemeta $myfullname;
|
||||
|
||||
my $rmsg = clone ($redismsg);
|
||||
$rmsg->{mode} = 'public';
|
||||
$rmsg->{userid} = $userid;
|
||||
$rmsg->{chatid} = $chatid;
|
||||
|
||||
# Сообщение обращено к боту
|
||||
if ((lc ($text) =~ /^${qname}[\,|\:]? (.+)/) or (lc ($text) =~ /^${qtname}[\,|\:]? (.+)/)){
|
||||
$phrase = $1;
|
||||
$rmsg->{message} = $phrase;
|
||||
# Бота упомянули по имени
|
||||
} elsif ((lc ($text) =~ /.+ ${qname}[\,|\!|\?|\.| ]/) or (lc ($text) =~ / $qname$/)) {
|
||||
$phrase = $text;
|
||||
$rmsg->{message} = $phrase;
|
||||
# Бота упомянули по телеграммному имени
|
||||
} elsif ((lc ($text) =~ /.+ ${qtname}[\,|\!|\?|\.| ]/) or (lc ($text) =~ / $qtname$/)) {
|
||||
$phrase = $text;
|
||||
|
||||
$rmsg->{message} = $phrase;
|
||||
|
||||
} else {
|
||||
$rmsg->{message} = $text;
|
||||
$rmsg->{misc}->{answer} = 0;
|
||||
}
|
||||
|
||||
my $pubsub = $main::REDIS->pubsub;
|
||||
|
||||
$pubsub->json ($c->{'redis_router_channel'})->notify (
|
||||
$c->{'redis_router_channel'} => $rmsg
|
||||
);
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
if (defined ($reply) && $reply ne '') {
|
||||
# work a bit more on input phrase
|
||||
$phrase = trim $phrase;
|
||||
|
||||
while ($phrase =~ /[\.|\,|\?|\!]$/) {
|
||||
chop $phrase;
|
||||
}
|
||||
|
||||
$phrase = lc $phrase;
|
||||
|
||||
if (fmatch (lc ($reply), $phrase)) {
|
||||
$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));
|
||||
$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));
|
||||
}
|
||||
|
||||
# should be channel, so we can't talk
|
||||
} else {
|
||||
return;
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub RandomCommonPhrase {
|
||||
my @myphrase = (
|
||||
'Так, блядь...',
|
||||
'*Закатывает рукава* И ради этого ты меня позвал?',
|
||||
'Ну чего ты начинаешь, нормально же общались',
|
||||
'Повтори свой вопрос, не поняла',
|
||||
'Выйди и зайди нормально',
|
||||
'Я подумаю',
|
||||
'Даже не знаю, что на это ответить',
|
||||
'Ты упал такие вопросы девочке задавать?',
|
||||
'Можно и так, но не уверена',
|
||||
'А как ты думаешь?',
|
||||
'А ви, таки, почему интересуетесь?',
|
||||
);
|
||||
|
||||
return $myphrase[irand ($#myphrase + 1)];
|
||||
}
|
||||
|
||||
# setup our bot
|
||||
sub init {
|
||||
my $self = shift;
|
||||
|
||||
# Don't forget to update global ref to our telegram context
|
||||
$main::TGM = $self;
|
||||
|
||||
$self->add_listener (\&__on_msg);
|
||||
$self->add_repeating_task (900, \&__cron);
|
||||
redis_events_listener ();
|
||||
return;
|
||||
}
|
||||
|
||||
sub RunTelegramBot {
|
||||
while (sleep 3) {
|
||||
eval { ## no critic (ErrorHandling::RequireCheckingReturnValueOfEval)
|
||||
TelegramBot->new->think;
|
||||
}
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# vim: ft=perl noet ai ts=4 sw=4 sts=4:
|
||||
248
lib/botlib.pm
248
lib/botlib.pm
@@ -1,248 +0,0 @@
|
||||
package botlib;
|
||||
# store here utility functions that are not protocol-specified
|
||||
|
||||
use 5.018;
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
use open qw(:std :utf8);
|
||||
use English qw( -no_match_vars );
|
||||
|
||||
use HTTP::Tiny;
|
||||
use URI::URL;
|
||||
use JSON::XS qw(decode_json encode_json);
|
||||
use Digest::MD5 qw(md5_base64);
|
||||
use DB_File;
|
||||
|
||||
use conf qw(loadConf);
|
||||
|
||||
use vars qw/$VERSION/;
|
||||
|
||||
use Exporter qw(import);
|
||||
our @EXPORT_OK = qw(weather logger trim randomCommonPhrase);
|
||||
|
||||
$VERSION = '1.0';
|
||||
|
||||
my $c = loadConf();
|
||||
|
||||
sub __urlencode {
|
||||
my $str = shift;
|
||||
my $urlobj = url $str;
|
||||
$str = $urlobj->as_string;
|
||||
$urlobj = undef; undef $urlobj;
|
||||
return $str;
|
||||
}
|
||||
|
||||
sub logger {
|
||||
my $msg = shift;
|
||||
|
||||
if ($c->{debug_log}) {
|
||||
my @date = localtime();
|
||||
my @month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
|
||||
my $t = sprintf ('%02s %02d %02d:%02d:%02d ', $month[$date[4]], $date[3], $date[2], $date[1], $date[0]);
|
||||
|
||||
my $mode = '>';
|
||||
$mode = '>>' if (-f $c->{debug_log});
|
||||
|
||||
if (open my $LOG, $mode, $c->{debug_log}) {
|
||||
print $LOG $t . $msg . "\n"; ## no critic (InputOutput::RequireCheckedSyscalls)
|
||||
close $LOG; ## no critic (InputOutput::RequireCheckedSyscalls)
|
||||
}
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub trim {
|
||||
my $str = shift;
|
||||
|
||||
while (substr ($str, 0, 1) =~ /^\s$/xms) {
|
||||
$str = substr ($str, 1);
|
||||
}
|
||||
|
||||
while (substr ($str, -1, 1) =~ /^\s$/xms) {
|
||||
chop ($str);
|
||||
}
|
||||
|
||||
return $str;
|
||||
}
|
||||
|
||||
|
||||
sub weather {
|
||||
my $city = shift;
|
||||
$city = trim ($city);
|
||||
|
||||
return 'Мне нужно ИМЯ города.' if ($city eq '');
|
||||
return 'Длинновато для названия города.' if (length($city) > 80);
|
||||
|
||||
$city = ucfirst ($city);
|
||||
my $w = __weather ($city);
|
||||
my $reply;
|
||||
|
||||
if ($w) {
|
||||
if ($w->{temperature_min} == $w->{temperature_max}) {
|
||||
$reply = sprintf ("Погода в городе %s, %s:\n%s, ветер %s %s м/c, температура %s°C, ощущается как %s°C, относительная влажность %s%%, давление %s мм.рт.с",
|
||||
$w->{name},
|
||||
$w->{country},
|
||||
ucfirst ($w->{description}),
|
||||
$w->{wind_direction},
|
||||
$w->{wind_speed},
|
||||
$w->{temperature_min},
|
||||
$w->{temperature_feelslike},
|
||||
$w->{humidity},
|
||||
$w->{pressure}
|
||||
);
|
||||
} else {
|
||||
$reply = sprintf ("Погода в городе %s, %s:\n%s, ветер %s %s м/c, температура %s-%s°C, ощущается как %s°C, относительная влажность %s%%, давление %s мм.рт.ст",
|
||||
$w->{name},
|
||||
$w->{country},
|
||||
ucfirst ($w->{description}),
|
||||
$w->{wind_direction},
|
||||
$w->{wind_speed},
|
||||
$w->{temperature_min},
|
||||
$w->{temperature_max},
|
||||
$w->{temperature_feelslike},
|
||||
$w->{humidity},
|
||||
$w->{pressure}
|
||||
);
|
||||
}
|
||||
} else {
|
||||
$reply = "Я не знаю, какая погода в $city";
|
||||
}
|
||||
|
||||
return $reply;
|
||||
}
|
||||
|
||||
sub __weather {
|
||||
my $city = shift;
|
||||
$city = __urlencode ($city);
|
||||
my $id = md5_base64 ($city);
|
||||
my $appid = $c->{openweathermap}->{appid};
|
||||
my $now = time ();
|
||||
my $fc;
|
||||
my $w;
|
||||
|
||||
# attach to cache data
|
||||
tie my %cachetime, 'DB_File', $c->{openweathermap}->{cachetime} or do {
|
||||
logger "Something nasty happen when cachetime ties to its data: $OS_ERROR";
|
||||
return undef;
|
||||
};
|
||||
|
||||
tie my %cachedata, 'DB_File', $c->{openweathermap}->{cachedata} or do {
|
||||
logger "Something nasty happen when cachedata ties to its data: $OS_ERROR";
|
||||
return undef;
|
||||
};
|
||||
|
||||
# lookup cache
|
||||
if (defined ($cachetime{$id}) && ($now - $cachetime{$id}) < 10800) {
|
||||
$fc = decode_json ($cachedata{$id});
|
||||
} else {
|
||||
my $r;
|
||||
|
||||
# try 3 times and giveup
|
||||
for (1..3) {
|
||||
next if ($r->{success});
|
||||
my $http = HTTP::Tiny->new (timeout => 3);
|
||||
$r = $http->get (sprintf ('http://api.openweathermap.org/data/2.5/weather?q=%s&lang=ru&APPID=%s', $city, $appid));
|
||||
sleep 2;
|
||||
}
|
||||
|
||||
# all 3 times can give error, so check it here
|
||||
if ($r->{success}) {
|
||||
$fc = eval { decode_json ($r->{content}) };
|
||||
|
||||
if ($EVAL_ERROR) {
|
||||
logger "[WARN] openweathermap returns corrupted json: $EVAL_ERROR";
|
||||
untie %cachetime;
|
||||
untie %cachedata;
|
||||
return undef;
|
||||
};
|
||||
|
||||
$cachetime{$id} = $now;
|
||||
$cachedata{$id} = encode_json ($fc);
|
||||
} else {
|
||||
untie %cachetime;
|
||||
untie %cachedata;
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
untie %cachetime;
|
||||
untie %cachedata;
|
||||
|
||||
# TODO: check all of this for existance
|
||||
$w->{'name'} = $fc->{name};
|
||||
$w->{'state'} = $fc->{state};
|
||||
$w->{'country'} = $fc->{sys}->{country};
|
||||
$w->{'longitude'} = $fc->{coord}->{lon};
|
||||
$w->{'latitude'} = $fc->{coord}->{lat};
|
||||
$w->{'temperature_min'} = int ($fc->{main}->{temp_min} - 273.15);
|
||||
$w->{'temperature_max'} = int ($fc->{main}->{temp_max} - 273.15);
|
||||
$w->{'temperature_feelslike'} = int ($fc->{main}->{feels_like} - 273.15);
|
||||
$w->{'humidity'} = $fc->{main}->{humidity};
|
||||
$w->{'pressure'} = int ($fc->{main}->{pressure} * 0.75006375541921);
|
||||
$w->{'description'} = $fc->{weather}->[0]->{description};
|
||||
$w->{'wind_speed'} = $fc->{wind}->{speed};
|
||||
$w->{'wind_direction'} = 'разный';
|
||||
my $dir = int ($fc->{wind}->{deg} + 0);
|
||||
|
||||
if ($dir == 0) {
|
||||
$w->{'wind_direction'} = 'северный';
|
||||
} elsif ($dir > 0 && $dir <= 30) {
|
||||
$w->{'wind_direction'} = 'северо-северо-восточный';
|
||||
} elsif ($dir > 30 && $dir <= 60) {
|
||||
$w->{'wind_direction'} = 'северо-восточный';
|
||||
} elsif ($dir > 60 && $dir < 90) {
|
||||
$w->{'wind_direction'} = 'восточно-северо-восточный';
|
||||
} elsif ($dir == 90) {
|
||||
$w->{'wind_direction'} = 'восточный';
|
||||
} elsif ($dir > 90 && $dir <= 120) {
|
||||
$w->{'wind_direction'} = 'восточно-юго-восточный';
|
||||
} elsif ($dir > 120 && $dir <= 150) {
|
||||
$w->{'wind_direction'} = 'юговосточный';
|
||||
} elsif ($dir > 150 && $dir < 180) {
|
||||
$w->{'wind_direction'} = 'юго-юго-восточный';
|
||||
} elsif ($dir == 180) {
|
||||
$w->{'wind_direction'} = 'южный';
|
||||
} elsif ($dir > 180 && $dir <= 210) {
|
||||
$w->{'wind_direction'} = 'юго-юго-западный';
|
||||
} elsif ($dir > 210 && $dir <= 240) {
|
||||
$w->{'wind_direction'} = 'юго-западный';
|
||||
} elsif ($dir > 240 && $dir < 270) {
|
||||
$w->{'wind_direction'} = 'западно-юго-западный';
|
||||
} elsif ($dir == 270) {
|
||||
$w->{'wind_direction'} = 'западный';
|
||||
} elsif ($dir > 270 && $dir <= 300) {
|
||||
$w->{'wind_direction'} = 'западно-северо-западный';
|
||||
} elsif ($dir > 300 && $dir <= 330) {
|
||||
$w->{'wind_direction'} = 'северо-западный';
|
||||
} elsif ($dir > 330 && $dir < 360) {
|
||||
$w->{'wind_direction'} = 'северо-северо-западный';
|
||||
} elsif ($dir == 360) {
|
||||
$w->{'wind_direction'} = 'северный';
|
||||
}
|
||||
|
||||
return $w;
|
||||
}
|
||||
|
||||
sub randomCommonPhrase {
|
||||
my @myphrase = (
|
||||
'Так, блядь...',
|
||||
'*Закатывает рукава* И ради этого ты меня позвал?',
|
||||
'Ну чего ты начинаешь, нормально же общались',
|
||||
'Повтори свой вопрос, не поняла',
|
||||
'Выйди и зайди нормально',
|
||||
'Я подумаю',
|
||||
'Даже не знаю что на это ответить',
|
||||
'Ты упал такие вопросы девочке задавать?',
|
||||
'Можно и так, но не уверена',
|
||||
'А как ты думаешь?',
|
||||
'А ви, таки, почему интересуетесь?',
|
||||
);
|
||||
|
||||
return $myphrase[rand ($#myphrase -1)];
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
||||
76
lib/lat.pm
76
lib/lat.pm
@@ -1,76 +0,0 @@
|
||||
package lat;
|
||||
# famous latin phases taken from https://ru.wikipedia.org/wiki/Список_крылатых_латинских_выражений
|
||||
|
||||
use 5.018;
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
use open qw(:std :utf8);
|
||||
use English qw( -no_match_vars );
|
||||
|
||||
use vars qw/$VERSION/;
|
||||
use Exporter qw(import);
|
||||
our @EXPORT_OK = qw(train latAnswer);
|
||||
|
||||
$VERSION = '1.0';
|
||||
|
||||
use Hailo;
|
||||
use File::Basename qw(dirname);
|
||||
use File::Path qw(mkpath);
|
||||
use conf qw(loadConf);
|
||||
use botlib qw(logger);
|
||||
|
||||
my $c = loadConf();
|
||||
my $brain = $c->{lat}->{brain};
|
||||
|
||||
# swallow phrase and return answer
|
||||
sub train () {
|
||||
my $braindir = dirname ($brain);
|
||||
|
||||
unless (-d $braindir) {
|
||||
mkpath ($braindir) or do {
|
||||
logger "Unable to create $braindir: $OS_ERROR";
|
||||
exit 1;
|
||||
};
|
||||
}
|
||||
|
||||
my $lat = Hailo->new (
|
||||
brain => $brain,
|
||||
# in our case mean amount of words in phase is 3
|
||||
order => 2
|
||||
);
|
||||
|
||||
$lat->train('data/phrases.txt');
|
||||
my ($tokens, $expressions) = ($lat->stats())[0,1];
|
||||
printf "Total tokens: %s\nTotal expressins: %s\n", $tokens, $expressions;
|
||||
$lat->save();
|
||||
return;
|
||||
}
|
||||
|
||||
# just return answer
|
||||
sub latAnswer () {
|
||||
my $braindir = dirname ($brain);
|
||||
|
||||
unless (-d $braindir) {
|
||||
logger ("No lat module data: $braindir is absent! Train lat first.");
|
||||
return '';
|
||||
}
|
||||
|
||||
unless (-f $brain) {
|
||||
logger ("No lat module data: $brain is absent! Train lat first.");
|
||||
return '';
|
||||
}
|
||||
|
||||
my $lat = Hailo->new (
|
||||
brain => $brain,
|
||||
# in our case mean amount of words in phase is 3
|
||||
order => 2,
|
||||
save_on_exit => 0
|
||||
);
|
||||
|
||||
return $lat->reply();
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# vim: ft=perl noet ai ts=4 sw=4 sts=4:
|
||||
@@ -1,432 +0,0 @@
|
||||
package telegrambot;
|
||||
# main bot gears are here
|
||||
|
||||
use 5.018;
|
||||
use strict;
|
||||
use warnings;
|
||||
use vars qw/$VERSION/;
|
||||
use utf8;
|
||||
use Data::Dumper;
|
||||
use open qw(:std :utf8);
|
||||
use File::Path qw( mkpath );
|
||||
use Hailo;
|
||||
use Encode;
|
||||
use Mojo::Base 'Telegram::Bot::Brain';
|
||||
|
||||
use conf qw(loadConf);
|
||||
use botlib qw(weather logger trim randomCommonPhrase);
|
||||
use telegramlib qw(getChat getChatMember sendChatAction visavi);
|
||||
use lat qw(latAnswer);
|
||||
|
||||
use Exporter qw(import);
|
||||
our @EXPORT_OK = qw(run_telegrambot);
|
||||
|
||||
$VERSION = '1.0';
|
||||
|
||||
my $c = loadConf();
|
||||
my $hailo;
|
||||
my $myid;
|
||||
my $myusername;
|
||||
my $myfirst_name;
|
||||
my $mylast_name;
|
||||
my $myfullname;
|
||||
# guess it later
|
||||
my $can_talk = 0;
|
||||
|
||||
has token => $c->{telegrambot}->{token};
|
||||
|
||||
# i promise, i'll make use of this sub
|
||||
sub __cron { ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
|
||||
my $self = shift;
|
||||
# noop
|
||||
return;
|
||||
}
|
||||
|
||||
sub __on_msg {
|
||||
my ($self, $msg) = @_;
|
||||
# chat info
|
||||
my $chatid;
|
||||
my $chatname = 'Noname chat';
|
||||
# user sending message info
|
||||
my $userid;
|
||||
my $username;
|
||||
my $fullname;
|
||||
my $vis_a_vi = 'unknown';
|
||||
|
||||
$can_talk = 0;
|
||||
|
||||
unless ($myid) {
|
||||
my $myObj = Telegram::Bot::Brain::getMe ($self);
|
||||
$myid = $myObj->id;
|
||||
# TODO: use these values instead of pre-defined in config!
|
||||
$myusername = $myObj->username;
|
||||
$myfirst_name = $myObj->first_name;
|
||||
$mylast_name = $myObj->last_name;
|
||||
|
||||
if (defined ($myfirst_name) && ($myfirst_name ne '') && defined ($mylast_name) && ($mylast_name ne '')) {
|
||||
$myfullname = $myfirst_name . ' ' . $mylast_name;
|
||||
} elsif (defined ($myfirst_name) && ($myfirst_name ne '')) {
|
||||
$myfullname = $myfirst_name;
|
||||
} elsif (defined ($mylast_name) && ($mylast_name ne '')) {
|
||||
$myfullname = $mylast_name;
|
||||
} else {
|
||||
$myfullname = $myusername;
|
||||
}
|
||||
}
|
||||
|
||||
if ($msg->chat->can ('id') && defined ($msg->chat->id)) {
|
||||
$chatid = $msg->chat->id;
|
||||
my $group_talk = 0;
|
||||
|
||||
if ($msg->chat->can ('username') && defined ($msg->chat->username)) {
|
||||
$chatname = $msg->chat->username ;
|
||||
} else {
|
||||
if ($msg->chat->can ('title') && defined ($msg->chat->title)) {
|
||||
$chatname = $msg->chat->title;
|
||||
} else {
|
||||
$chatname = 'Noname chat';
|
||||
}
|
||||
}
|
||||
|
||||
# because of bot api restriction there is no events about changing permissions
|
||||
# in chat sent to bot so before sending any answer, we should check if we can do so
|
||||
|
||||
# N.B. there is situation when we do not recieve any messages from chat: if we
|
||||
# are in exception list, even if it allows any kind of events for bot
|
||||
|
||||
# If we are just member of chat, it looks like we obey general chat restrictions,
|
||||
# so we need only to query getChat in this case
|
||||
# If we admin, we can get|send messages even if group by itself disallows it.
|
||||
|
||||
# works only for public chats, so id shoud be < 0.
|
||||
if ($chatid < 0) {
|
||||
my $chatobj = getChat ($self, $chatid);
|
||||
# actually evaluates to 1 for true and to 0 for false
|
||||
$group_talk = int ($chatobj->{permissions}->{can_send_messages});
|
||||
my $chatObj = getChatMember ($self, $chatid, $myid);
|
||||
|
||||
if ($chatObj->{'status'} eq 'administrator') {
|
||||
logger "I can talk in group chat $chatname ($chatid)";
|
||||
$can_talk = 1;
|
||||
} else {
|
||||
logger "I can talk in group chat $chatname ($chatid)" if ($group_talk);
|
||||
logger "I can not talk in group chat $chatname ($chatid)" unless ($group_talk);
|
||||
$can_talk = $group_talk;
|
||||
}
|
||||
} else {
|
||||
# private chat, so definely can talk
|
||||
logger "I can talk in private chat $chatname ($chatid)";
|
||||
$can_talk = 1;
|
||||
}
|
||||
} else {
|
||||
logger 'Unable to get chatid';
|
||||
}
|
||||
|
||||
# according api user must have username and/or first_name and/or last_name at least one of these fields
|
||||
if ($msg->can ('from') && defined ($msg->from)) {
|
||||
$userid = $msg->from->id; # it must be filled, so do not check it
|
||||
$username = $msg->from->username if ($msg->from->can ('username') && defined($msg->from->username));
|
||||
|
||||
if ($msg->from->can ('first_name') && defined ($msg->from->first_name)) {
|
||||
$fullname = $msg->from->first_name;
|
||||
|
||||
if ($msg->from->can('last_name') && defined ($msg->from->last_name)) {
|
||||
$fullname .= ' ' . $msg->from->last_name;
|
||||
}
|
||||
} elsif ($msg->from->can ('last_name') && defined ($msg->from->last_name)) {
|
||||
$fullname .= $msg->from->last_name;
|
||||
}
|
||||
|
||||
$vis_a_vi = visavi ($userid, $username, $fullname);
|
||||
}
|
||||
|
||||
my $phrase = '';
|
||||
|
||||
# Newcommer event, greet our new member and suggest to introduce themself.
|
||||
if ($msg->can ('new_chat_members') && defined ($msg->new_chat_members)) {
|
||||
my $send_args;
|
||||
$send_args->{parse_mode} = 'Markdown';
|
||||
$send_args->{chat_id} = $chatid;
|
||||
|
||||
if (defined ($username)) {
|
||||
if (defined ($fullname)) {
|
||||
logger "Newcommer in $chatname ($chatid): \@$username, $fullname ($userid)";
|
||||
$send_args->{text} = "Дратути, [$fullname](tg://user?id=$userid). Представьтес, пожалуйста, и расскажите, что вас сюда привело.";
|
||||
} else {
|
||||
logger "Newcommer in $chatname ($chatid): \@$username ($userid)";
|
||||
$send_args->{text} = "Дратути, [$username](tg://user?id=$userid). Представьтес, пожалуйста, и расскажите, что вас сюда привело.";
|
||||
}
|
||||
} else {
|
||||
logger "Newcommer in $chatname ($chatid): $fullname ($userid)";
|
||||
$send_args->{text} = "Дратути, [$fullname](tg://user?id=$userid). Представьтес, пожалуйста, и расскажите, что вас сюда привело.";
|
||||
}
|
||||
|
||||
# let's emulate real human and delay answer
|
||||
sleep (int ( rand (2) + 1));
|
||||
|
||||
for (0..(4 + int (rand (3)))) {
|
||||
sendChatAction ($self, $chatid);
|
||||
sleep(3);
|
||||
sleep 3 unless ($_);
|
||||
}
|
||||
|
||||
sleep ( 3 + int ( rand (2)));
|
||||
|
||||
Telegram::Bot::Brain::sendMessage ($self, $send_args);
|
||||
return;
|
||||
}
|
||||
|
||||
# lazy init chat-bot brains
|
||||
unless (defined ($hailo->{$chatid})) {
|
||||
my $brainname = sprintf ('%s/%s.brain.sqlite', $c->{telegrambot}->{braindir}, $chatid);
|
||||
|
||||
$hailo->{$chatid} = Hailo->new (
|
||||
# we'll got file like this: data/telegrambot-brains/-1001332512695.brain.sqlite
|
||||
brain => $brainname,
|
||||
order => 3
|
||||
);
|
||||
|
||||
if ($chatid < 0) {
|
||||
logger "Initialized brain for public chat $chatname ($chatid): $brainname";
|
||||
} else {
|
||||
logger "Initialized for private chat $chatname ($chatid): $brainname";
|
||||
}
|
||||
}
|
||||
|
||||
# is this a 1-on-1 ?
|
||||
if ($msg->chat->type eq 'private') {
|
||||
# TODO: what about stickers, photos, documents, audio, video, etc... We should log em at least.
|
||||
return unless ($msg->can ('text') && defined ($msg->text));
|
||||
|
||||
my $text = $msg->text;
|
||||
logger sprintf ('Private chat %s say to bot: %s', $vis_a_vi, $text);
|
||||
my $csign = quotemeta ($c->{telegrambot}->{csign});
|
||||
my $reply = 'Давайте ещё пообщаемся, а то я ещё не научилась от вас плохому.';
|
||||
|
||||
# TODO: Process commands in separate sub, they are same for public and private chats.
|
||||
if (substr ($text, 0, 1) eq $c->{telegrambot}->{csign}) {
|
||||
if (substr ($text, 1) eq 'ping') {
|
||||
$reply = 'Pong.';
|
||||
} elsif (substr ($text, 1) eq 'пинг') {
|
||||
$reply = 'Понг.';
|
||||
} elsif (substr ($text, 1, 2) eq 'w ' || substr ($text, 1, 2) eq 'п ') {
|
||||
my $city = substr ($text, 2);
|
||||
$reply = weather ($city);
|
||||
} elsif ((length ($text) == 4) && (substr ($text, 1, 3) eq 'lat' || substr ($text, 1, 2) eq 'лат')) {
|
||||
$reply = latAnswer();
|
||||
} else {
|
||||
$reply = 'Чего?';
|
||||
}
|
||||
} else {
|
||||
my $str = $hailo->{$msg->chat->id}->learn_reply ($text);
|
||||
|
||||
if (defined ($str) && $str ne '') {
|
||||
$reply = $str;
|
||||
# TODO: move it to telegramlib.pm/botlib.pm!
|
||||
$phrase = trim ($text);
|
||||
|
||||
while ($phrase =~ /[\.|\,|\?|\!]$/) {
|
||||
chop $phrase;
|
||||
}
|
||||
|
||||
$phrase = lc ($phrase);
|
||||
|
||||
if (lc ($reply) eq $phrase) {
|
||||
$reply = randomCommonPhrase();
|
||||
} elsif (lc ($reply) eq substr ($phrase, 0, -1)) {
|
||||
# in case of trailing dot
|
||||
$reply = randomCommonPhrase();
|
||||
} elsif (substr (lc ($reply), 0, -1) eq $phrase) {
|
||||
$reply = randomCommonPhrase();
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sendChatAction ($self, $chatid);
|
||||
sleep 1;
|
||||
logger sprintf ("Private chat bot reply to $vis_a_vi: %s", $reply);
|
||||
$msg->reply ($reply);
|
||||
# group chat
|
||||
} elsif (($msg->chat->type eq 'supergroup') or ($msg->chat->type eq 'group')) {
|
||||
my $reply;
|
||||
|
||||
# detect and log messages without text, noop here
|
||||
unless (defined ($msg->text)) {
|
||||
logger sprintf('No text in message from %s', $vis_a_vi);
|
||||
|
||||
if ($msg->can ('document') && defined ($msg->document)) {
|
||||
if (defined ($msg->document->{'file_name'})) {
|
||||
my $docsize = 'unknown';
|
||||
$docsize = $msg->document->{'file_size'} if (defined ($msg->document->{'file_size'}));
|
||||
my $type = 'unknown';
|
||||
$type = $msg->document->{'mime_type'} if (defined ($msg->document->{'mime_type'}));
|
||||
logger sprintf ('In public chat %s (%s) %s send document type %s named %s, size %s bytes', $chatname, $chatid, $vis_a_vi, $type, $msg->document->{'file_name'}, $docsize);
|
||||
} else {
|
||||
logger sprintf ('In public chat %s (%s) %s send unknown document', $chatname, $chatid, $vis_a_vi);
|
||||
}
|
||||
} elsif ($msg->can ('sticker') && defined ($msg->sticker)) {
|
||||
my $set_name = 'unknown';
|
||||
$set_name = $msg->sticker->set_name if ($msg->sticker->can ('set_name') && defined ($msg->sticker->set_name));
|
||||
my $emoji = 'unknown';
|
||||
$emoji = $msg->sticker->emoji if ($msg->sticker->can ('emoji') && defined ($msg->sticker->emoji));
|
||||
logger sprintf ('In public chat %s (%s) %s reacted with sticker %s from pack %s', $chatname, $chatid, $vis_a_vi, $emoji, $set_name);
|
||||
} elsif ($msg->can ('photo') && defined ($msg->photo)) {
|
||||
# actually it is an array! duh, hate arrays!
|
||||
logger sprintf ('In public chat %s (%s) %s send photo', $chatname, $chatid, $vis_a_vi);
|
||||
} else {
|
||||
logger Dumper ($msg);
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
# we have text here! so potentially we can chit-chat
|
||||
my $text = $msg->text;
|
||||
logger sprintf ('In public chat %s (%s) %s say: %s', $chatname, $chatid, $vis_a_vi, $text);
|
||||
my $qname = quotemeta ($c->{telegrambot}->{name});
|
||||
my $qtname = quotemeta ($c->{telegrambot}->{tname});
|
||||
my $csign = quotemeta ($c->{telegrambot}->{csign});
|
||||
|
||||
# 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)) {
|
||||
logger sprintf ('In public chat %s (%s) %s quote us!', $chatname, $chatid, $vis_a_vi);
|
||||
# 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);
|
||||
# simple commands
|
||||
# TODO: Process commands in separate sub, they are same for public and private chats.
|
||||
# TODO: Log commands and answers
|
||||
} elsif (substr ($text, 0, 1) eq $c->{telegrambot}->{csign}) {
|
||||
if (substr ($text, 1) eq 'help') {
|
||||
unless ($can_talk) {
|
||||
return ;
|
||||
}
|
||||
|
||||
my $send_args;
|
||||
$send_args->{text} = << 'MYHELP';
|
||||
```
|
||||
!help | !помощь - список команд
|
||||
!w город | !п город - погода в указанном городе
|
||||
!ping | !пинг - попинговать бота
|
||||
!lat | !лат - сгенерировать фразу из крылатых латинских выражений
|
||||
```
|
||||
Но на самом деле я бот больше для общения, чем для исполнения команд.
|
||||
Поговоришь со мной?
|
||||
MYHELP
|
||||
$send_args->{parse_mode} = 'Markdown';
|
||||
$send_args->{chat_id} = $chatid;
|
||||
Telegram::Bot::Brain::sendMessage ($self, $send_args);
|
||||
return;
|
||||
} elsif (substr ($text, 1) eq 'ping') {
|
||||
$reply = 'Pong.';
|
||||
} elsif (substr ($text, 1) eq 'пинг') {
|
||||
$reply = 'Понг.';
|
||||
} elsif (substr ($text, 1) eq 'pong') {
|
||||
$reply = 'Wat?';
|
||||
} elsif (substr ($text, 1) eq 'понг') {
|
||||
$reply = 'Шта?';
|
||||
} elsif (substr ($text, 1, 2) eq 'w ' || substr ($text, 1, 2) eq 'п ') {
|
||||
my $city = substr ($text, 3);
|
||||
$reply = weather ($city);
|
||||
} elsif (length ($text) == 4 && (substr ($text, 1, 3) eq 'lat' || substr ($text, 1, 3) eq 'лат')) {
|
||||
$reply = latAnswer();
|
||||
}
|
||||
} elsif (
|
||||
($text eq $qname) or
|
||||
($text eq sprintf ('%s', $qtname)) or
|
||||
($text eq sprintf ("@%s_bot", $qname)) or # :(
|
||||
($text eq sprintf ('%s ', $qtname))
|
||||
) {
|
||||
$reply = 'Чего?';
|
||||
} else {
|
||||
# phrase directed to bot
|
||||
if ((lc ($text) =~ /^${qname}[\,|\:]? (.+)/) or (lc ($text) =~ /^${qtname}[\,|\:]? (.+)/)){
|
||||
$phrase = $1;
|
||||
$reply = $hailo->{$msg->chat->id}->learn_reply ($phrase);
|
||||
# bot mention by name
|
||||
} elsif ((lc ($text) =~ /.+ ${qname}[\,|\!|\?|\.| ]/) or (lc ($text) =~ / $qname$/)) {
|
||||
$phrase = $text;
|
||||
$reply = $hailo->{$msg->chat->id}->reply($phrase);
|
||||
# bot mention by telegram name
|
||||
} elsif ((lc ($text) =~ /.+ ${qtname}[\,|\!|\?|\.| ]/) or (lc ($text) =~ / $qtname$/)) {
|
||||
$phrase = $text;
|
||||
$reply = $hailo->{$msg->chat->id}->reply ($phrase);
|
||||
# just message in chat
|
||||
} else {
|
||||
$hailo->{$msg->chat->id}->learn ($text);
|
||||
}
|
||||
}
|
||||
|
||||
if (defined ($reply) && $reply ne '' && $can_talk) {
|
||||
# work a bit more on input phrase
|
||||
$phrase = trim ($phrase);
|
||||
|
||||
while ($phrase =~ /[\.|\,|\?|\!]$/) {
|
||||
chop $phrase;
|
||||
}
|
||||
|
||||
$phrase = lc ($phrase);
|
||||
|
||||
if (lc ($reply) eq $phrase) {
|
||||
$reply = randomCommonPhrase();
|
||||
} elsif (lc ($reply) eq substr ($phrase, 0, -1)) {
|
||||
# in case of trailing dot
|
||||
$reply = randomCommonPhrase();
|
||||
} elsif (substr(lc ($reply), 0, -1) eq $phrase) {
|
||||
$reply = randomCommonPhrase();
|
||||
}
|
||||
|
||||
sendChatAction ($self, $chatid);
|
||||
sleep (int (rand (2)));
|
||||
logger sprintf ('In public chat %s (%s) bot reply to %s: %s', $chatname, $chatid, $vis_a_vi, $reply);
|
||||
$msg->reply ($reply);
|
||||
} else {
|
||||
if ($can_talk) {
|
||||
logger sprintf ('In public chat %s (%s) bot is not required to reply to %s', $chatname, $chatid, $vis_a_vi);
|
||||
} else {
|
||||
logger sprintf ('In public chat %s (%s) bot can\'t talk, but reply to %s is: %s', $chatname, $chatid, $vis_a_vi, $reply);
|
||||
}
|
||||
}
|
||||
|
||||
# should be channel, so we can't talk
|
||||
} else {
|
||||
return;
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
# setup our bot
|
||||
sub init {
|
||||
unless (-d $c->{telegrambot}->{braindir}) {
|
||||
mkpath ($c->{telegrambot}->{braindir}, 0, 0755); ## no critic (ValuesAndExpressions::ProhibitLeadingZeros)
|
||||
}
|
||||
|
||||
my $self = shift;
|
||||
$self->add_listener (\&__on_msg);
|
||||
# $self->add_repeating_task(900, \&__cron);
|
||||
return;
|
||||
}
|
||||
|
||||
sub run_telegrambot {
|
||||
while (sleep 3) {
|
||||
eval { ## no critic (ErrorHandling::RequireCheckingReturnValueOfEval)
|
||||
telegrambot->new->think;
|
||||
}
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# vim: ft=perl noet ai ts=4 sw=4 sts=4:
|
||||
@@ -1,89 +0,0 @@
|
||||
package telegramlib;
|
||||
# store here functions that are not implemented in Telegram::Bot
|
||||
|
||||
use 5.018;
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
use open qw(:std :utf8);
|
||||
|
||||
use botlib qw(trim);
|
||||
use Telegram::Bot::Brain;
|
||||
|
||||
# module shit
|
||||
use vars qw/$VERSION/;
|
||||
use Exporter qw(import);
|
||||
our @EXPORT_OK = qw(getChat getChatMember sendChatAction visavi);
|
||||
|
||||
$VERSION = '1.0';
|
||||
|
||||
# complete framework with our getChat()
|
||||
sub getChat {
|
||||
my $self = shift;
|
||||
my $id = shift;
|
||||
my $send_args = {};
|
||||
$send_args->{chat_id} = $id;
|
||||
|
||||
my $token = $self->token;
|
||||
my $url = "https://api.telegram.org/bot${token}/getChat";
|
||||
my $api_response = $self->_post_request ($url, $send_args);
|
||||
|
||||
# we seek for permissions, when making call to this subroutine, but
|
||||
# framework does just omits it, when creating object from hash, so
|
||||
# pick raw json object instead
|
||||
|
||||
#return Telegram::Bot::Object::User->create_from_hash($api_response, $self);
|
||||
return $api_response;
|
||||
}
|
||||
|
||||
# complete framework with our getChatMember()
|
||||
sub getChatMember {
|
||||
my $self = shift;
|
||||
my $chatid = shift;
|
||||
my $userid = shift;
|
||||
my $send_args = {};
|
||||
$send_args->{chat_id} = $chatid;
|
||||
$send_args->{user_id} = $userid;
|
||||
my $token = $self->token;
|
||||
my $url = "https://api.telegram.org/bot${token}/getChatMember";
|
||||
my $api_response = $self->_post_request ($url, $send_args);
|
||||
|
||||
# return Telegram::Bot::Object::User->create_from_hash($api_response, $self);
|
||||
return $api_response;
|
||||
}
|
||||
|
||||
# complete framework with our sendChatAction()
|
||||
# sets bot status to "typing" for 5 seconds
|
||||
# # TODO: more actions!
|
||||
sub sendChatAction {
|
||||
my $self = shift;
|
||||
my $chatid = shift;
|
||||
my $send_args = {};
|
||||
$send_args->{chat_id} = $chatid;
|
||||
$send_args->{action} = 'typing';
|
||||
my $token = $self->token;
|
||||
my $url = "https://api.telegram.org/bot${token}/sendChatAction";
|
||||
my $api_response = $self->_post_request ($url, $send_args);
|
||||
|
||||
# return Telegram::Bot::Object::User->create_from_hash($api_response, $self);
|
||||
return;
|
||||
}
|
||||
|
||||
sub visavi {
|
||||
my ($userid, $username, $fullname) = @_;
|
||||
my $name = '';
|
||||
|
||||
if (defined ($username)) {
|
||||
$name .= '@' . $username;
|
||||
$name .= ', ' . $fullname if (defined ($fullname));
|
||||
} else {
|
||||
$name .= $fullname;
|
||||
}
|
||||
|
||||
$name .= " ($userid)";
|
||||
return $name;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# vim: ft=perl noet ai ts=4 sw=4 sts=4:
|
||||
Reference in New Issue
Block a user