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

Another bits of refactoring, code-style fixes, etc

Browse Source
This commit is contained in:
Sergei Fedosov
2021-02-08 18:01:03 +03:00
parent 96b861b507
commit c619e47560
20 changed files with 82 additions and 93 deletions
Download Patch File Download Diff File Expand all files Collapse all files

3
.gitignore vendored
View File

@@ -10,3 +10,6 @@ data/lat/**
TODO TODO
*.pid *.pid
*.log *.log
_Deparsed_XSubs.pm
.idea/**
.vstags

10
.perlcriticrc
View File

@@ -35,7 +35,7 @@ verbose = 8
[-ControlStructures::ProhibitPostfixControls] [-ControlStructures::ProhibitPostfixControls]
# In short lines we can afford ourselves to use postfix controls # In short lines we can afford ourselves to use postfix controls
# but ofcorse we should avoid such constructions in long lines. # but of course we should avoid such constructions in long lines.
[-Subroutines::ProhibitSubroutinePrototypes] [-Subroutines::ProhibitSubroutinePrototypes]
# Contrary to Perl::Critic we consider prototypes as useful, even if # Contrary to Perl::Critic we consider prototypes as useful, even if
@@ -52,7 +52,7 @@ verbose = 8
[-ValuesAndExpressions::ProhibitEmptyQuotes] [-ValuesAndExpressions::ProhibitEmptyQuotes]
# cause we consider following correct and useful: my $var = ''; # cause we consider following correct and useful: my $var = '';
# the recomended use of q{} looks too complex: my $var = q{}; # the recommended use of q{} looks too complex: my $var = q{};
[-ValuesAndExpressions::ProhibitNoisyQuotes] [-ValuesAndExpressions::ProhibitNoisyQuotes]
# Other people, other opinions: "," is better readable than qw(,) # Other people, other opinions: "," is better readable than qw(,)
@@ -64,14 +64,14 @@ verbose = 8
[-NamingConventions::Capitalization] [-NamingConventions::Capitalization]
# duh... # duh...
# Noone care, really # Noone cares, really
[-ControlStructures::ProhibitUnlessBlocks] [-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 # that's all
[-Miscellanea::ProhibitTies] [-Miscellanea::ProhibitTies]
# Just allow it. It's very handy stuff and extremely simple and safe enugh to use. # Just allow it. It's very handy stuff and extremely simple and safe enough to use.
[-ValuesAndExpressions::RequireNumberSeparators] [-ValuesAndExpressions::RequireNumberSeparators]
# Not really # Not really
@@ -97,4 +97,4 @@ lib_sections = NAME | VERSION | DESCRIPTION | AUTHOR | LICENSE AND COPYRIGHT
# used only in botlib.pm, in this particular case it makes more clean code # used only in botlib.pm, in this particular case it makes more clean code
[-ControlStructures::ProhibitDeepNests] [-ControlStructures::ProhibitDeepNests]
# jabber bot lib habe very nested structures that a bit fiddle to navigate :( # jabber bot lib have very nested structures that a bit fiddle to navigate :(

2
README.md
View File

@@ -19,7 +19,7 @@ You'll need "Development Tools" or similar group of packages, perl, perl-devel,
perl-local-lib, perl-app-cpanm, sqlite-devel, zlib-devel, openssl-devel, perl-local-lib, perl-app-cpanm, sqlite-devel, zlib-devel, openssl-devel,
libdb4-devel (Berkeley DB devel), make. libdb4-devel (Berkeley DB devel), make.
After installng required dependencies it is possible to run: After installing required dependencies it is possible to run:
```bash ```bash
bash bootstrap.sh bash bootstrap.sh

12
bin/fortune_seed.pl
View File

@@ -4,16 +4,16 @@ use 5.018;
use strict; use strict;
use warnings; use warnings;
use utf8; use utf8;
use open qw(:std :utf8); use open qw (:std :utf8);
use English qw( -no_match_vars ); use English qw ( -no_match_vars );
use vars qw/$VERSION/;
$VERSION = '1.0'; use version; our $VERSION = qw (1.0);
my $workdir; my $workdir;
# before we run, change working dir # before we run, change working dir
BEGIN { BEGIN {
use Cwd qw(chdir abs_path); use Cwd qw (chdir abs_path);
my @CWD = split /\//xms, abs_path ($PROGRAM_NAME); my @CWD = split /\//xms, abs_path ($PROGRAM_NAME);
if ($#CWD > 1) { $#CWD = $#CWD - 2; } if ($#CWD > 1) { $#CWD = $#CWD - 2; }
$workdir = join '/', @CWD; $workdir = join '/', @CWD;
@@ -21,7 +21,7 @@ BEGIN {
} }
use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5"); use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
use fortune qw(seed fortune); use fortune qw (seed);
seed (); seed ();

9
bin/friday_seed.pl
View File

@@ -4,10 +4,9 @@ use 5.018;
use strict; use strict;
use warnings; use warnings;
use utf8; use utf8;
use open qw(:std :utf8); use open qw (:std :utf8);
use English qw( -no_match_vars ); use English qw ( -no_match_vars );
use vars qw/$VERSION/; use version; our $VERSION = qw (1.0);
$VERSION = '1.0';
my $workdir; my $workdir;
@@ -21,7 +20,7 @@ BEGIN {
} }
use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5"); use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
use friday qw(seed); use friday qw (seed);
seed (); seed ();

9
bin/train_lat.pl
View File

@@ -4,10 +4,9 @@ use 5.018;
use strict; use strict;
use warnings; use warnings;
use utf8; use utf8;
use open qw(:std :utf8); use open qw (:std :utf8);
use English qw( -no_match_vars ); use English qw ( -no_match_vars );
use vars qw/$VERSION/; use version; our $VERSION = qw (1.0);
$VERSION = '1.0';
my $workdir; my $workdir;
@@ -21,7 +20,7 @@ BEGIN {
} }
use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5"); use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
use lat qw(train); use lat qw (train);
train (); train ();
exit 0; exit 0;

12
confcheck.pl
View File

@@ -4,16 +4,16 @@ use 5.018;
use strict; use strict;
use warnings; use warnings;
use utf8; use utf8;
use open qw(:std :utf8); use open qw (:std :utf8);
use English qw( -no_match_vars ); use English qw ( -no_match_vars );
use lib qw(./lib ./vendor_perl ./vendor_perl/lib/perl5); use lib qw (./lib ./vendor_perl ./vendor_perl/lib/perl5);
use JSON::PP; use JSON::PP;
use version; our $VERSION = qv(1.0); use version; our $VERSION = qw (1.0);
my $c = 'data/config.json'; my $c = 'data/config.json';
open (my $C, '<', $c) or die "No conf at $c: $OS_ERROR\n"; ## no critic (InputOutput::RequireBriefOpen) open (my $C, '<', $c) || die "No conf at $c: $OS_ERROR\n"; ## no critic (InputOutput::RequireBriefOpen)
my $len = (stat ($c)) [7]; my $len = (stat $c) [7];
my $json; my $json;
my $readlen = read ($C, $json, $len); my $readlen = read ($C, $json, $len);

1
cpanfile
View File

@@ -18,6 +18,7 @@ requires 'local::lib';
requires 'Log::Any'; requires 'Log::Any';
requires 'Log::Any::Adapter'; requires 'Log::Any::Adapter';
requires 'Log::Any::For::Std'; requires 'Log::Any::For::Std';
requires 'Math::Random::Secure';
# Bundled Net::Jabber::Bot deps # Bundled Net::Jabber::Bot deps
# requires 'Net::Jabber::Bot'; # requires 'Net::Jabber::Bot';

18
lib/archeologist.pm
View File

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

10
lib/botlib.pm
View File

@@ -7,6 +7,7 @@ use utf8;
use open qw (:std :utf8); use open qw (:std :utf8);
use English qw ( -no_match_vars ); use English qw ( -no_match_vars );
use Carp qw (carp); use Carp qw (carp);
use Math::Random::Secure qw (irand);
use archeologist qw (dig); use archeologist qw (dig);
use conf qw (loadConf); use conf qw (loadConf);
use fisher qw (fish); use fisher qw (fish);
@@ -18,10 +19,9 @@ use lat qw (latAnswer);
use util qw (trim utf2sha1); use util qw (trim utf2sha1);
use weather qw (weather); use weather qw (weather);
use vars qw/$VERSION/; use version; our $VERSION = qw (1.0);
use Exporter qw(import); use Exporter qw(import);
our @EXPORT_OK = qw(command randomCommonPhrase realjid); our @EXPORT_OK = qw(command randomCommonPhrase realjid);
$VERSION = '1.0';
my $c = loadConf (); my $c = loadConf ();
@@ -39,7 +39,7 @@ sub randomCommonPhrase () {
'А как ты думаешь?', 'А как ты думаешь?',
); );
return $myphrase[int (rand ($#myphrase + 1))]; return $myphrase[irand ($#myphrase + 1)];
} }
sub command { sub command {
@@ -233,7 +233,7 @@ EOL
return $reply; return $reply;
} }
# in this particular case real jid is really hidden :) and i hope that i found where it is seaking. # in this particular case real jid is really hidden :) and i hope that i found where it is hiding.
sub realjid { sub realjid {
my %hash = @_; my %hash = @_;
my $bot = $hash{'bot_object'}; my $bot = $hash{'bot_object'};
@@ -299,7 +299,7 @@ sub realjid {
'name' => (split (/\//, $myjid))[1], 'name' => (split (/\//, $myjid))[1],
); );
} else { } else {
# looks like it is correct real jid, assume that conference server and main server are woking on different domains # looks like it is correct real jid, assume that conference server and main server reside on different domains
# at least i hope that this assumption correct # at least i hope that this assumption correct
%result = ( %result = (
'fulljid' => $myjid, 'fulljid' => $myjid,

3
lib/conf.pm
View File

@@ -9,10 +9,9 @@ use open qw(:std :utf8);
use English qw( -no_match_vars ); use English qw( -no_match_vars );
use JSON::XS; use JSON::XS;
use vars qw/$VERSION/; use version; our $VERSION = qw (1.0);
use Exporter qw(import); use Exporter qw(import);
our @EXPORT_OK = qw(loadConf); our @EXPORT_OK = qw(loadConf);
$VERSION = '1.0';
sub loadConf { sub loadConf {
my $c = 'data/config.json'; my $c = 'data/config.json';

2
lib/fisher.pm
View File

@@ -32,7 +32,7 @@ sub fish {
'плотву', 'плотву',
'зубатку', 'зубатку',
'солнечную рыбу', 'солнечную рыбу',
'cтарую шину', 'старую шину',
'скользкую корягу', 'скользкую корягу',
'лампу джина', 'лампу джина',
'любовное послание в бутылке', 'любовное послание в бутылке',

14
lib/fortune.pm
View File

@@ -1,5 +1,5 @@
package fortune; package fortune;
# Any fortune_mod sources are suitable. Text file with "\n%\n" sentence delimeter. # Any fortune_mod sources are suitable. Text file with "\n%\n" sentence delimiters.
use 5.018; use 5.018;
use strict; use strict;
@@ -9,14 +9,14 @@ use open qw (:std :utf8);
use English qw ( -no_match_vars ); use English qw ( -no_match_vars );
use Carp qw (croak carp); use Carp qw (croak carp);
use SQLite_File; use SQLite_File;
use Math::Random::Secure qw (irand);
use MIME::Base64; use MIME::Base64;
use File::Path qw (make_path); use File::Path qw (make_path);
use conf qw (loadConf); use conf qw (loadConf);
use vars qw/$VERSION/; use version; our $VERSION = qw (1.0);
use Exporter qw(import); use Exporter qw (import);
our @EXPORT_OK = qw(seed fortune); our @EXPORT_OK = qw (seed fortune);
$VERSION = '1.0';
my $c = loadConf (); my $c = loadConf ();
my $dir = $c->{fortune}->{dir}; my $dir = $c->{fortune}->{dir};
@@ -36,7 +36,7 @@ sub seed () {
tie my @fortune, 'SQLite_File', $backingfile || croak "Unable to tie to $backingfile: $OS_ERROR\n"; tie my @fortune, 'SQLite_File', $backingfile || croak "Unable to tie to $backingfile: $OS_ERROR\n";
opendir (my $srcdirhandle, $srcdir) || croak "Unable to open $srcdir: $OS_ERROR"; opendir (my $srcdirhandle, $srcdir) || croak "Unable to open $srcdir: $OS_ERROR";
while (my $fortunefile = readdir ($srcdirhandle)) { while (my $fortunefile = readdir $srcdirhandle) {
my $srcfile = sprintf '%s/%s', $srcdir, $fortunefile; my $srcfile = sprintf '%s/%s', $srcdir, $fortunefile;
unless (-f $srcfile) { unless (-f $srcfile) {
@@ -73,7 +73,7 @@ sub fortune () {
return ''; return '';
}; };
my $phrase = $array[int (rand ($#array - 1))]; my $phrase = $array[irand ($#array - 1)];
# decode? # decode?
utf8::decode $phrase; utf8::decode $phrase;
untie @array; untie @array;

14
lib/friday.pm
View File

@@ -9,13 +9,13 @@ use open qw (:std :utf8);
use English qw ( -no_match_vars ); use English qw ( -no_match_vars );
use Carp qw (carp croak); use Carp qw (carp croak);
use File::Path qw (make_path); use File::Path qw (make_path);
use Math::Random::Secure qw (irand);
use SQLite_File; use SQLite_File;
use conf qw (loadConf); use conf qw (loadConf);
use vars qw/$VERSION/; use version; our $VERSION = qw (1.0);
use Exporter qw (import); use Exporter qw (import);
our @EXPORT_OK = qw (seed friday); our @EXPORT_OK = qw (seed friday);
$VERSION = '1.0';
my $c = loadConf (); my $c = loadConf ();
my $dir = $c->{friday}->{dir}; my $dir = $c->{friday}->{dir};
@@ -46,9 +46,9 @@ sub seed () {
next; next;
} }
chomp(); chomp ();
my ($phrase, $days) = split(/ \|\| /); my ($phrase, $days) = split (/ \|\| /);
my @daylist = split(//, $days); my @daylist = split (//, $days);
foreach my $day (@daylist) { foreach my $day (@daylist) {
unless (defined $day) { unless (defined $day) {
@@ -59,7 +59,7 @@ sub seed () {
next ; next ;
} }
if (defined $phrase && ($phrase ne '') && ($phrase !~ m/^\s+$/xmsg)) { if (defined ($phrase) && ($phrase ne '') && ($phrase !~ m/^\s+$/xmsg)) {
push @{$friday->[$day - 1]}, $phrase; push @{$friday->[$day - 1]}, $phrase;
} }
} }
@@ -84,7 +84,7 @@ sub friday () {
return ''; return '';
}; };
my $phrase = $array[int (rand ($#array - 1))]; my $phrase = $array[irand ($#array - 1)];
# decode? # decode?
utf8::decode $phrase; utf8::decode $phrase;
untie @array; untie @array;

21
lib/jabberbot.pm
View File

@@ -1,5 +1,5 @@
# note http://www.gentoo.ru/node/21449 # note http://www.gentoo.ru/node/21449
# необходимо закомменировать строку $response{authzid} = $authzid; # необходимо закомментировать строку $response{authzid} = $authzid;
# в vendor_perl/5.24.3/Authen/SASL/Perl/DIGEST_MD5.pm # в vendor_perl/5.24.3/Authen/SASL/Perl/DIGEST_MD5.pm
package jabberbot; package jabberbot;
@@ -18,9 +18,8 @@ use conf qw (loadConf);
use karma qw (karmaSet); use karma qw (karmaSet);
use util qw (trim utf2sha1); use util qw (trim utf2sha1);
use version; our $VERSION = qw (1.0);
use Exporter qw (import); use Exporter qw (import);
use vars qw/$VERSION/;
$VERSION = '1.0';
our @EXPORT_OK = qw (run_jabberbot); our @EXPORT_OK = qw (run_jabberbot);
my $c = loadConf (); my $c = loadConf ();
@@ -49,7 +48,7 @@ sub __new_bot_message {
my $text = $hash{body}; my $text = $hash{body};
my %jid = realjid (%hash); my %jid = realjid %hash;
my $chattername = $jid{'name'}; my $chattername = $jid{'name'};
my $chatid; my $chatid;
@@ -64,7 +63,7 @@ sub __new_bot_message {
my $reply; my $reply;
# lazy init chat-bot brains # lazy init chat-bot brains
unless (defined ($hailo->{$chatid})) { unless (defined $hailo->{$chatid}) {
my $braindir = $c->{jabberbot}->{braindir}; my $braindir = $c->{jabberbot}->{braindir};
my $brainname = sprintf '%s/%s.sqlite', $braindir, $chatid; my $brainname = sprintf '%s/%s.sqlite', $braindir, $chatid;
@@ -88,17 +87,17 @@ sub __new_bot_message {
} }
# parse messages # parse messages
my $qname = quotemeta ($bot->{'alias'}); my $qname = quotemeta $bot->{'alias'};
if ($text =~ /^$qname\,?\s*$/) { if ($text =~ /^$qname\,?\s*$/) {
$reply = 'Чего тебе?'; $reply = 'Чего тебе?';
} elsif (($text =~ /^$qname[\,|\:]? (.+)/) && ($hash{'type'} eq 'groupchat')) { } elsif (($text =~ /^$qname[\,|\:]? (.+)/) && ($hash{'type'} eq 'groupchat')) {
$reply = $hailo->{$chatid}->learn_reply ($1); $reply = $hailo->{$chatid}->learn_reply ($1);
} elsif (substr ($text, 0, 1) eq $c->{jabberbot}->{aleesa}->{csign}) { } elsif (substr ($text, 0, 1) eq $c->{jabberbot}->{aleesa}->{csign}) {
$reply = command (%hash); $reply = command %hash;
# karma agjustment # karma adjustment
} elsif (substr ($text, -2) eq '++' || substr ($text, -2) eq '--') { } elsif (substr ($text, -2) eq '++' || substr ($text, -2) eq '--') {
my @arr = split(/\n/, $text); my @arr = split /\n/, $text;
if ($#arr < 1) { if ($#arr < 1) {
$reply = karmaSet ($chatid, trim (substr ($text, 0, -2)), substr ($text, -2)); $reply = karmaSet ($chatid, trim (substr ($text, 0, -2)), substr ($text, -2));
@@ -138,7 +137,7 @@ sub __new_bot_message {
sub run_jabberbot { sub run_jabberbot {
my %conflist = (); my %conflist = ();
$conflist{$c->{jabberbot}->{aleesa}->{room}} = []; $conflist{$c->{jabberbot}->{aleesa}->{room}} = [];
my $qname = quotemeta ($c->{jabberbot}->{aleesa}->{mucname}); my $qname = quotemeta $c->{jabberbot}->{aleesa}->{mucname};
my $bot = Net::Jabber::Bot->new ( my $bot = Net::Jabber::Bot->new (
server => $c->{jabberbot}->{aleesa}->{host}, server => $c->{jabberbot}->{aleesa}->{host},
@@ -149,7 +148,7 @@ sub run_jabberbot {
username => $c->{jabberbot}->{aleesa}->{authname}, username => $c->{jabberbot}->{aleesa}->{authname},
# threre is some nasty bug in module, so we have to set from_full explicitly # threre is some nasty bug in module, so we have to set from_full explicitly
from_full => sprintf ( from_full => sprintf (
"%s@%s/%s", '%s@%s/%s',
$c->{jabberbot}->{aleesa}->{room}, $c->{jabberbot}->{aleesa}->{room},
$c->{jabberbot}->{aleesa}->{confsrv}, $c->{jabberbot}->{aleesa}->{confsrv},
$c->{jabberbot}->{aleesa}->{authname} $c->{jabberbot}->{aleesa}->{authname}

17
lib/karma.pm
View File

@@ -10,12 +10,11 @@ use Carp qw (carp);
use DB_File; use DB_File;
use File::Path qw (make_path); use File::Path qw (make_path);
use conf qw (loadConf); use conf qw (loadConf);
use util qw (utf2sha1); use util qw (utf2sha1 trim);
use vars qw/$VERSION/; use version; our $VERSION = qw (1.0);
use Exporter qw (import); use Exporter qw (import);
our @EXPORT_OK = qw (karmaSet karmaGet); our @EXPORT_OK = qw (karmaSet karmaGet);
$VERSION = '1.0';
my $c = loadConf (); my $c = loadConf ();
my $karmadir = $c->{karma}->{dir}; my $karmadir = $c->{karma}->{dir};
@@ -26,16 +25,13 @@ sub karmaSet (@) {
my $chatid = shift; my $chatid = shift;
my $phrase = shift; my $phrase = shift;
my $action = shift; my $action = shift;
$phrase = trim $phrase;
my $score = 0; my $score = 0;
# sha1* does not understand utf8, so explicitly construct string cost of decimal numbers only # sha1* does not understand utf8, so explicitly construct string cost of decimal numbers only
my $karmafile = utf2sha1 $chatid; my $karmafile = utf2sha1 $chatid;
$karmafile =~ s/\//-/xmsg; $karmafile =~ s/\//-/xmsg;
$karmafile = sprintf '%s/%s.db', $karmadir, $karmafile; $karmafile = sprintf '%s/%s.db', $karmadir, $karmafile;
if (($phrase eq '') || ($phrase =~ /^ +$/)) {
$phrase = '';
}
unless (-d $karmadir) { unless (-d $karmadir) {
make_path ($karmadir) or do { make_path ($karmadir) or do {
carp "Unable to create $karmadir: $OS_ERROR"; carp "Unable to create $karmadir: $OS_ERROR";
@@ -45,7 +41,7 @@ sub karmaSet (@) {
# init hash, store phrase and score # init hash, store phrase and score
tie my %karma, 'DB_File', $karmafile || do { tie my %karma, 'DB_File', $karmafile || do {
carp "[ERROR] Something nasty happen when cachedata ties to its data: $OS_ERROR"; carp "[ERROR] Something nasty happen when karma ties to its data: $OS_ERROR";
return sprintf 'Карма %s составляет 0', $phrase; return sprintf 'Карма %s составляет 0', $phrase;
}; };
@@ -91,14 +87,11 @@ sub karmaSet (@) {
sub karmaGet (@) { sub karmaGet (@) {
my $chatid = shift; my $chatid = shift;
my $phrase = shift; my $phrase = shift;
$phrase = trim $phrase;
my $karmafile = utf2sha1 $chatid; my $karmafile = utf2sha1 $chatid;
$karmafile =~ s/\//-/xmsg; $karmafile =~ s/\//-/xmsg;
$karmafile = sprintf '%s/%s.db', $karmadir, $karmafile; $karmafile = sprintf '%s/%s.db', $karmadir, $karmafile;
if (($phrase eq '') || ($phrase =~ /^ +$/)) {
$phrase = '';
}
unless (-d $karmadir) { unless (-d $karmadir) {
make_path ($karmadir) or do { make_path ($karmadir) or do {
carp "Unable to create $karmadir: $OS_ERROR"; carp "Unable to create $karmadir: $OS_ERROR";

3
lib/kitty.pm
View File

@@ -10,10 +10,9 @@ use Carp qw (carp);
use JSON::XS; use JSON::XS;
use HTTP::Tiny; use HTTP::Tiny;
use vars qw/$VERSION/; use version; our $VERSION = qw (1.0);
use Exporter qw (import); use Exporter qw (import);
our @EXPORT_OK = qw (kitty); our @EXPORT_OK = qw (kitty);
$VERSION = '1.0';
sub kitty { sub kitty {
my $r; my $r;

5
lib/lat.pm
View File

@@ -13,10 +13,9 @@ use File::Path qw (make_path);
use Hailo; use Hailo;
use conf qw (loadConf); use conf qw (loadConf);
use vars qw/$VERSION/; use version; our $VERSION = qw (1.0);
use Exporter qw (import); use Exporter qw (import);
our @EXPORT_OK = qw (train latAnswer); our @EXPORT_OK = qw (train latAnswer);
$VERSION = '1.0';
my $c = loadConf (); my $c = loadConf ();
my $brain = $c->{lat}->{brain}; my $brain = $c->{lat}->{brain};
@@ -40,7 +39,7 @@ sub train () {
$lat->train ($srcfile); $lat->train ($srcfile);
my ($tokens, $expressions) = ($lat->stats ())[0,1]; my ($tokens, $expressions) = ($lat->stats ())[0,1];
printf "Total tokens: %s\nTotal expressins: %s\n", $tokens, $expressions; printf "Total tokens: %s\nTotal expressions: %s\n", $tokens, $expressions;
$lat->save (); $lat->save ();
return; return;
} }

3
lib/util.pm
View File

@@ -13,10 +13,9 @@ use MIME::Base64;
use Text::Fuzzy qw (distance_edits); use Text::Fuzzy qw (distance_edits);
use URI::URL; use URI::URL;
use vars qw /$VERSION/; use version; our $VERSION = qw (1.0);
use Exporter qw (import); use Exporter qw (import);
our @EXPORT_OK = qw (trim urlencode fmatch utf2b64 utf2sha1); our @EXPORT_OK = qw (trim urlencode fmatch utf2b64 utf2sha1);
$VERSION = '1.0';
sub trim { sub trim {
my $str = shift; my $str = shift;

7
lib/weather.pm
View File

@@ -15,10 +15,9 @@ use JSON::XS;
use conf qw (loadConf); use conf qw (loadConf);
use util qw (trim urlencode); use util qw (trim urlencode);
use vars qw/$VERSION/; use version; our $VERSION = qw (1.0);
use Exporter qw (import); use Exporter qw (import);
our @EXPORT_OK = qw (weather); our @EXPORT_OK = qw (weather);
$VERSION = '1.0';
my $c = loadConf (); my $c = loadConf ();
@@ -98,7 +97,7 @@ sub __weather {
}; };
# lookup cache # lookup cache
if (defined ($cachetime{$id}) && ($now - $cachetime{$id}) < 10800) { if (defined ($cachetime{$id}) && (($now - $cachetime{$id}) < 10800)) {
$fc = decode_json ($cachedata{$id}); $fc = decode_json ($cachedata{$id});
} else { } else {
my $r; my $r;
@@ -141,7 +140,7 @@ sub __weather {
untie %cachetime; untie %cachetime;
untie %cachedata; untie %cachedata;
# TODO: check all of this for existance # TODO: check all of this for existence
$w->{'name'} = $fc->{name}; $w->{'name'} = $fc->{name};
$w->{'state'} = $fc->{state}; $w->{'state'} = $fc->{state};
$w->{'country'} = $fc->{sys}->{country}; $w->{'country'} = $fc->{sys}->{country};