From 3a061078d4445a96f9de213547f2ce5ecf6f2b07 Mon Sep 17 00:00:00 2001 From: eleksir Date: Fri, 7 Jan 2022 16:53:32 +0300 Subject: [PATCH] Move Archeologist and Fisher to separate module --- bin/gamedata_seed.pl | 26 ------- data/archeologic_artifacts.txt | 54 --------------- data/fisher_artifacts.txt | 47 ------------- lib/BotLib.pm | 27 ++++---- lib/BotLib/Archeologist.pm | 108 ----------------------------- lib/BotLib/Fisher.pm | 122 --------------------------------- lib/BotLib/Gamestat.pm | 115 ------------------------------- 7 files changed, 12 insertions(+), 487 deletions(-) delete mode 100644 bin/gamedata_seed.pl delete mode 100644 data/archeologic_artifacts.txt delete mode 100644 data/fisher_artifacts.txt delete mode 100644 lib/BotLib/Archeologist.pm delete mode 100644 lib/BotLib/Fisher.pm delete mode 100644 lib/BotLib/Gamestat.pm diff --git a/bin/gamedata_seed.pl b/bin/gamedata_seed.pl deleted file mode 100644 index 48cfbbe..0000000 --- a/bin/gamedata_seed.pl +++ /dev/null @@ -1,26 +0,0 @@ -#!/usr/bin/perl - -use 5.018; -use strict; -use warnings; -use utf8; -use open qw (:std :utf8); -use English qw ( -no_match_vars ); -use version; our $VERSION = qw (1.0); - -my $workdir; - -# before we run, change working dir -BEGIN { - use Cwd qw (chdir abs_path); - my @CWD = split /\//xms, abs_path ($PROGRAM_NAME); - if ($#CWD > 1) { $#CWD = $#CWD - 2; } - $workdir = join '/', @CWD; - chdir $workdir; -} - -use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5"); -use BotLib::Gamestat qw (SeedArtifacts); - -SeedArtifacts (); -exit 0; diff --git a/data/archeologic_artifacts.txt b/data/archeologic_artifacts.txt deleted file mode 100644 index b08628b..0000000 --- a/data/archeologic_artifacts.txt +++ /dev/null @@ -1,54 +0,0 @@ -амулет Мерлина -библиотеку Ивана Грозного -деревянную плошку -диплока -доски Ноева Ковчега -древний презерватив из бараньей кишки -икону -инсталятор Windows 3.11 -истлевший гроб -каменный топор -клад со златом-серебром -кривой нож -ледяную глыбу -лунный грунт -мамонта -мамонтёнка -метеорит -мумию фараона Тутанхамона -носки прапорщика (поставит в угол) -обломки грузинской керамики -птеродактиля -рубль с Лениным -рыцарские доспехи -синий мох -скелет -скелет собаки по кличке Беня -тиранозавтра -тотем индейцев -трубу с туркменским газом -скорбь еврейского народа -залежи активированного угля -не очень новый завет -мать леннарта поттеринга -руководство "начинающему археологу" -слово о полку игореве и дело о полку игореве, вместе с игорем -телепрограмму канала A-one -могилу искателя могил -заплесневевший кусок хлеба -преемник радиоприемника -глушитель от ВАЗ-2106 -чувство удовлетворения -крота -воспоминания о былой любви -грязистор -египетское мумиё -окаменелый камень -кладку яиц рептилоида -яму -чеснок и стрелы -доллар по 30 -несмазанные скрижали -четырелобита -чучело тролля -целое ничего diff --git a/data/fisher_artifacts.txt b/data/fisher_artifacts.txt deleted file mode 100644 index b2f730c..0000000 --- a/data/fisher_artifacts.txt +++ /dev/null @@ -1,47 +0,0 @@ -семикрылого чешуйчатого пятихуя -разумного конденсатора -сальмонеллу -селёдку -желтоперого тунца -розовую сальмонеллу -голавля -барбуса -окуня -верхоплавку -коричневую форель -полярника -плотву -зубатку -солнечную рыбу -старую шину -скользкую корягу -лампу джина -любовное послание в бутылке -старое бревно -резиновый сапог -труп -Лох-Несское чудовище -старую рыбацкую приманку -кусок Титаника -обломок Атлантиды -кита -кальмара -дельфина -ската -подводную лодку -медузу -морскую звезду -электрического угря -большую белую акулу -аквалангиста -монстра -вируса -сырую пачку сигарет -водоросли -якорь от лодки -водяного -русалку -палтуса -труп собаки по кличке Беня -олигофрена Проню -огеймера Фишкина diff --git a/lib/BotLib.pm b/lib/BotLib.pm index dcbed82..7a73d2a 100644 --- a/lib/BotLib.pm +++ b/lib/BotLib.pm @@ -16,8 +16,6 @@ use BotLib::Conf qw (LoadConf); use BotLib::Admin qw (@ForbiddenMessageTypes GetForbiddenTypes AddForbiddenType DelForbiddenType ListForbidden FortuneToggle FortuneStatus PluginToggle PluginStatus PluginEnabled ChanMsgToggle ChanMsgStatus); -use BotLib::Archeologist qw (Dig); -use BotLib::Fisher qw (Fish); use BotLib::Util qw (trim); use version; our $VERSION = qw (1.0); @@ -75,7 +73,7 @@ sub Command { @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); + boobies сиси сисечки butt booty ass попа попка xkcd dig копать fish fishing рыба рыбка рыбалка); my $bingo = 0; @@ -108,6 +106,17 @@ sub Command { } } + $#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; }; @@ -120,18 +129,6 @@ sub Command { $pubsub->json ($c->{'redis_router_channel'})->notify ( $c->{'redis_router_channel'} => $rmsg ); - } elsif (substr ($text, 1) eq 'dig' || substr ($text, 1) eq 'копать') { - $msg->typing (); - $reply = Dig $highlight; - sleep (irand (2) + 1); - $msg->replyMd ($reply); - return; - } elsif (substr ($text, 1) eq 'fish' || substr ($text, 1) eq 'fishing' || substr ($text, 1) eq 'рыба' || substr ($text, 1) eq 'рыбка' || substr ($text, 1) eq 'рыбалка' ) { - $msg->typing (); - $reply = Fish $highlight; - sleep (irand (2) + 1); - $msg->replyMd ($reply); - return; } elsif (substr ($text, 1) eq 'help' || substr ($text, 1) eq 'помощь') { $reply = << "MYHELP"; ``` diff --git a/lib/BotLib/Archeologist.pm b/lib/BotLib/Archeologist.pm deleted file mode 100644 index 7c96713..0000000 --- a/lib/BotLib/Archeologist.pm +++ /dev/null @@ -1,108 +0,0 @@ -package BotLib::Archeologist; - -use 5.018; -use strict; -use warnings; -use utf8; -use open qw (:std :utf8); -use English qw ( -no_match_vars ); -use DBI; -use Log::Any qw ($log); -use Math::Random::Secure qw (irand); - -use BotLib::Conf qw (LoadConf); - -use version; our $VERSION = qw (1.0); -use Exporter qw (import); -our @EXPORT_OK = qw (Dig); - -my $c = LoadConf (); -my $gamestatdir = $c->{gamestat}->{gamestatdir}; -my $dbfile = sprintf '%s/gamestat.sqlite', $gamestatdir; - - -sub getRandomArtifact { - my $dbh; - $dbh = DBI->connect ("dbi:SQLite:$dbfile", '', '') or do { - $log->error (sprintf '[ERROR] Unable to get random artifact, sqlite error: %s', $dbh->errstr); - return undef; - }; - - $dbh->{sqlite_unicode} = 1; - - my $rows_affected = $dbh->do ('PRAGMA foreign_keys=ON') or do { - $log->error (sprintf '[ERROR] Unable to get random artifact, sqlite error: %s', $dbh->errstr); - return undef; - }; - - $rows_affected = $dbh->do ('PRAGMA journal_mode=WAL') or do { - $log->error (sprintf '[ERROR] Unable to get random artifact, sqlite error: %s', $dbh->errstr); - return undef; - }; - - my $ary_ref = $dbh->selectall_arrayref ('SELECT name FROM artifacts WHERE id > 0 AND id < 10000') or do { - $log->error (sprintf '[ERROR] Unable to get random artifact, sqlite error: %s', $dbh->errstr); - return undef; - }; - - $dbh->disconnect or $log->warn (sprintf '[WARN] Unable to close gamestat db, sqlite error: %s', $dbh->errstr); - - return $ary_ref->[irand ($#{ $ary_ref } + 1)]->[0]; -} - -sub Dig { - my $name = shift; - - my @location = ( - 'в архивах', - 'в гималаях', - 'в интернете', - 'в кармане', - 'в клумбе', - 'в лунном кратере', - 'во льдах арктики', - 'в морге', - 'в окрестностях погоста', - 'в песочнице', - 'в пустыне Гоби', - 'в пустыне Сахаре', - 'в русле высохшей реки', - 'в собственной памяти', - 'в старом сортире', - 'в углу', - 'в цветочном горшке', - 'на бабушкином огороде', - 'на винчестере', - 'на горе Арарат', - 'на горном плато', - 'на дне моря', - 'на необитаемом острове', - 'на первом слое сумрака', - 'на просторах Украины', - ); - - my $find_probability = irand 100; - my $success_probability = irand 100; - my $artifact_age = irand 15000; - - if ($find_probability <= 20) { - return sprintf 'По уши закопавшись %s, %s, нифига вы не выкопали! Может повезет в другом месте?', $location[irand ($#location + 1)], $name; - } - - my $phrase = sprintf "Вы начали раскопки %s и усиленно роете лопатами, экскаватором...\n", $location[irand ($#location + 1)]; - $phrase .= "Вам кажется, что ваш совочек ударился обо что-то твердое. Может, это клад?!\n\n"; - my $artifact = getRandomArtifact(); - - if ($success_probability <= 25) { - $phrase .= sprintf '%s стал лучшим археологом, выкопав %s! возраст артефакта - %s лет!', $name, $artifact, $artifact_age; - } else { - $phrase .= sprintf "Поздравляю, %s! Вы только что выкопали %s, возраст - %s лет!\n", $name, $artifact, $artifact_age; - $phrase .= sprintf 'Извини, %s, но на артефакт это не тянет! Однако, попытка хорошая!', $name; - } - - return $phrase; -} - -1; - -# vim: set ft=perl noet ai ts=4 sw=4 sts=4: diff --git a/lib/BotLib/Fisher.pm b/lib/BotLib/Fisher.pm deleted file mode 100644 index 4379dbc..0000000 --- a/lib/BotLib/Fisher.pm +++ /dev/null @@ -1,122 +0,0 @@ -package BotLib::Fisher; - -use 5.018; -use strict; -use warnings; -use utf8; -use open qw (:std :utf8); -use English qw ( -no_match_vars ); -use DBI; -use Log::Any qw ($log); -use Math::Random::Secure qw (irand); - -use BotLib::Conf qw (LoadConf); - -use version; our $VERSION = qw (1.0); -use Exporter qw (import); -our @EXPORT_OK = qw (Fish); - -my $c = LoadConf (); -my $gamestatdir = $c->{gamestat}->{gamestatdir}; -my $dbfile = sprintf '%s/gamestat.sqlite', $gamestatdir; - - -sub getRandomArtifact { - my $dbh; - $dbh = DBI->connect ("dbi:SQLite:$dbfile", '', '') or do { - $log->error (sprintf '[ERROR] Unable to get random artifact, sqlite error: %s', $dbh->errstr); - return undef; - }; - - $dbh->{sqlite_unicode} = 1; - - my $rows_affected = $dbh->do ('PRAGMA foreign_keys=ON') or do { - $log->error (sprintf '[ERROR] Unable to get random artifact, sqlite error: %s', $dbh->errstr); - return undef; - }; - - $rows_affected = $dbh->do ('PRAGMA journal_mode=WAL') or do { - $log->error (sprintf '[ERROR] Unable to get random artifact, sqlite error: %s', $dbh->errstr); - return undef; - }; - - my $ary_ref = $dbh->selectall_arrayref ('SELECT name FROM artifacts WHERE id > 9999 AND id < 20000') or do { - $log->error (sprintf '[ERROR] Unable to get random artifact, sqlite error: %s', $dbh->errstr); - return undef; - }; - - $dbh->disconnect or $log->warn (sprintf '[WARN] Unable to close gamestat db, sqlite error: %s', $dbh->errstr); - - return $ary_ref->[irand ($#{ $ary_ref } + 1)]->[0]; -} - - -sub Fish { - my $name = shift; - - my @location = ( - 'в поток', - 'в озеро', - 'в реку', - 'в северный ледовитый океан', - 'в индийский океан', - 'в биде', - 'в детский плавательный бассейн', - 'в туалет', - 'в кучу рвоты', - 'в лужу мочи', - 'в раковину', - 'в слив ванной', - 'в лужу грязи', - 'в ведро воды', - 'в бутылку с водкой', - 'в ванную', - 'в бочку с дождевой водой', - 'в аквариум', - 'в сугроб', - 'в водопад', - 'в чашку кофе', - 'в стакан молока', - 'в черную дыру', - 'дно Удомельского реактора', - 'на Марс', - 'в соседнюю галактику', - 'к соседу на балкон', - 'далеко-далеко', - 'далеко и надолго', - 'на крышу дома', - ); - - my @material = ( - 'бамбуковую', - 'фибергласовую', - 'карбоновую', - 'композитную', - ); - - my $find_probability = irand 100; - my $success_probability = irand 100; - my $weight = irand 7000; - - my $phrase = sprintf "Вы забрасываете %s удочку %s.\nВы чувствуете поклёвку и начинаете быстро тащить что-то.\n", $material[irand ($#material + 1)], $location[irand ($#location + 1)]; - - if ($find_probability <= 20) { - $phrase .= sprintf 'Черт, твоя рыбка сорвалась, %s! Не беда, может потом повезет?', $name; - return $phrase; - } - - my $artifact = getRandomArtifact (); - $phrase .= sprintf "Поздравляю, %s! Вы только что поймали %s! аж на %d кило!\n\n", $name, $artifact, $weight; - - if ($success_probability <= 25) { - $phrase .= sprintf 'Ё-мое!!! А это ведь новый рекорд! Продолжай в том же духе, %s!', $name; - } else { - $phrase .= sprintf 'Извини, %s, но это не новый рекорд! Однако, хорошая попытка!', $name; - } - - return $phrase; -} - -1; - -# vim: set ft=perl noet ai ts=4 sw=4 sts=4: diff --git a/lib/BotLib/Gamestat.pm b/lib/BotLib/Gamestat.pm deleted file mode 100644 index db0497e..0000000 --- a/lib/BotLib/Gamestat.pm +++ /dev/null @@ -1,115 +0,0 @@ -package BotLib::Gamestat; -# Stores and calculates player stats for games - -use 5.018; -use strict; -use warnings; -use utf8; -use open qw (:std :utf8); -use DBI; -use English qw ( -no_match_vars ); -use File::Path qw (make_path); -use String::Random qw (random_string); - -use BotLib::Conf qw (LoadConf); -use BotLib::Util qw (trim utf2sha1); - -use version; our $VERSION = qw (1.0); -use Exporter qw (import); -our @EXPORT_OK = qw (SeedArtifacts); - - -my $c = LoadConf (); -my $dir = $c->{gamestat}->{dir}; -my $gamestatdir = $c->{gamestat}->{gamestatdir}; -my $dbfile = sprintf '%s/gamestat.sqlite', $gamestatdir; - -# assume that there is not too much artifacts. -sub SeedArtifacts { - open (my $AFH, '<', "$dir/archeologic_artifacts.txt") || die "No $dir/archeologic_artifacts.txt\n"; - my @arch_artifacts; - - while (my $artifact = <$AFH>) { - next if ($artifact =~ /^\s*$/); - $artifact = trim ($artifact); - push @arch_artifacts, $artifact; - } - - close $AFH; ## no critic (InputOutput::RequireCheckedSyscalls) - - open ($AFH, '<', "$dir/fisher_artifacts.txt") || die "No $dir/fisher_artifacts.txt\n"; - my @fisher_artifacts; - - while (my $artifact = <$AFH>) { - next if ($artifact =~ /^\s*$/); - $artifact = trim ($artifact); - push @fisher_artifacts, $artifact; - } - - close $AFH; ## no critic (InputOutput::RequireCheckedSyscalls) - undef $AFH; - - my $tablename = random_string ('..........'); - $tablename = utf2sha1 ($tablename); - - while ($tablename =~ /^\d/) { - $tablename = utf2sha1 ($tablename); - } - - $tablename =~ s/[\/_\+]/a/g; - $tablename = lc ($tablename); - - unless (-d $gamestatdir) { - make_path ($gamestatdir) || die "Unable to create $gamestatdir: $OS_ERROR\n"; - } - - my $dbh = DBI->connect ("dbi:SQLite:$dbfile", '', ''); - $dbh->{sqlite_unicode} = 1; - my $rows_affected = $dbh->do ('PRAGMA foreign_keys=ON') or die $dbh->errstr . "\n"; - $rows_affected = $dbh->do ('PRAGMA journal_mode=WAL') or die $dbh->errstr . "\n"; - - # Open transaction - $dbh->begin_work or die $dbh->errstr . "\n"; - - my $query = <<"QUERY"; -CREATE TABLE IF NOT EXISTS $tablename ( - id INT UNIQUE NOT NULL, -- artifact id - name TEXT PRIMARY KEY -- artifact name -); -QUERY - - $rows_affected = $dbh->do ($query) or die $dbh->errstr . "\n"; - my $sth = $dbh->prepare ("REPLACE INTO $tablename(id,name) VALUES (?,?)") or die $dbh->errstr . "\n"; - - # Insert our archeological artifacts - my $counter = 0; - - foreach my $artifact (@arch_artifacts) { - last if ($counter == 10000); - $sth->execute ($c, $artifact); - $counter++; - } - - # Insert our fishing artifacts - $counter = 10000; - - foreach my $artifact (@fisher_artifacts) { - last if ($counter == 20000); - $sth->execute ($c, $artifact); - $counter++; - } - - # Add indexes - $rows_affected = $dbh->do ("CREATE INDEX IF NOT EXISTS myartifactid ON $tablename(id)") or die $dbh->errstr . "\n"; - - # Drop target table and replace it with our - $rows_affected = $dbh->do ('DROP TABLE IF EXISTS artifacts') or die $dbh->errstr . "\n"; - $rows_affected = $dbh->do ("ALTER TABLE $tablename RENAME TO artifacts") or die $dbh->errstr . "\n"; - - # Close transaction - $dbh->commit or die $dbh->errstr . "\n"; - $dbh->disconnect or warn (sprintf '[WARN] Unable to close gamestat db, sqlite error: %s', $dbh->errstr) . "\n"; - return; -} - -1;