Move Archeologist and Fisher to separate module

2022-01-07 16:53:32 +03:00
parent ca946c7e7b
commit 3a061078d4
7 changed files with 12 additions and 487 deletions
--- a/bin/gamedata_seed.pl
+++ b/bin/gamedata_seed.pl
@@ -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;
--- a/data/archeologic_artifacts.txt
+++ b/data/archeologic_artifacts.txt
@@ -1,54 +0,0 @@
-амулет Мерлина
-библиотеку Ивана Грозного
-деревянную плошку
-диплока
-доски Ноева Ковчега
-древний презерватив из бараньей кишки
-икону
-инсталятор Windows 3.11
-истлевший гроб
-каменный топор
-клад со златом-серебром
-кривой нож
-ледяную глыбу
-лунный грунт
-мамонта
-мамонтёнка
-метеорит
-мумию фараона Тутанхамона
-носки прапорщика (поставит в угол)
-обломки грузинской керамики
-птеродактиля
-рубль с Лениным
-рыцарские доспехи
-синий мох
-скелет
-скелет собаки по кличке Беня
-тиранозавтра
-тотем индейцев
-трубу с туркменским газом
-скорбь еврейского народа
-залежи активированного угля
-не очень новый завет
-мать леннарта поттеринга
-руководство "начинающему археологу"
-слово о полку игореве и дело о полку игореве, вместе с игорем
-телепрограмму канала A-one
-могилу искателя могил
-заплесневевший кусок хлеба
-преемник радиоприемника
-глушитель от ВАЗ-2106
-чувство удовлетворения
-крота
-воспоминания о былой любви
-грязистор
-египетское мумиё
-окаменелый камень
-кладку яиц рептилоида
-яму
-чеснок и стрелы
-доллар по 30
-несмазанные скрижали
-четырелобита
-чучело тролля
-целое ничего
--- a/data/fisher_artifacts.txt
+++ b/data/fisher_artifacts.txt
@@ -1,47 +0,0 @@
-семикрылого чешуйчатого пятихуя
-разумного конденсатора
-сальмонеллу
-селёдку
-желтоперого тунца
-розовую сальмонеллу
-голавля
-барбуса
-окуня
-верхоплавку
-коричневую форель
-полярника
-плотву
-зубатку
-солнечную рыбу
-старую шину
-скользкую корягу
-лампу джина
-любовное послание в бутылке
-старое бревно
-резиновый сапог
-труп
-Лох-Несское чудовище
-старую рыбацкую приманку
-кусок Титаника
-обломок Атлантиды
-кита
-кальмара
-дельфина
-ската
-подводную лодку
-медузу
-морскую звезду
-электрического угря
-большую белую акулу
-аквалангиста
-монстра
-вируса
-сырую пачку сигарет
-водоросли
-якорь от лодки
-водяного
-русалку
-палтуса
-труп собаки по кличке Беня
-олигофрена Проню
-огеймера Фишкина
--- 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";
 ```
--- a/lib/BotLib/Archeologist.pm
+++ b/lib/BotLib/Archeologist.pm
@@ -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:
--- a/lib/BotLib/Fisher.pm
+++ b/lib/BotLib/Fisher.pm
@@ -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:
--- a/lib/BotLib/Gamestat.pm
+++ b/lib/BotLib/Gamestat.pm
@@ -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;