aboutsummaryrefslogtreecommitdiff
path: root/plugins/zyklonb/factoids
diff options
context:
space:
mode:
authorPřemysl Eric Janouch <p@janouch.name>2021-08-06 16:12:15 +0200
committerPřemysl Eric Janouch <p@janouch.name>2021-08-06 16:43:59 +0200
commit50057d5149dda340b3b47aca4096f4a6ec66b9ee (patch)
tree79323d20b17c2c8e32942a1ac9b84d9da3041c6d /plugins/zyklonb/factoids
parent1f64710e795b0c5434d15813d4f1f568467ca087 (diff)
downloadxK-50057d5149dda340b3b47aca4096f4a6ec66b9ee.tar.gz
xK-50057d5149dda340b3b47aca4096f4a6ec66b9ee.tar.xz
xK-50057d5149dda340b3b47aca4096f4a6ec66b9ee.zip
Come up with sillier names for the binaries
I'm not entirely sure, but it looks like some people might not like jokes about the Holocaust. On a more serious note, the project has become more serious over the 7 or so years of its existence.
Diffstat (limited to 'plugins/zyklonb/factoids')
-rwxr-xr-xplugins/zyklonb/factoids177
1 files changed, 0 insertions, 177 deletions
diff --git a/plugins/zyklonb/factoids b/plugins/zyklonb/factoids
deleted file mode 100755
index 431600c..0000000
--- a/plugins/zyklonb/factoids
+++ /dev/null
@@ -1,177 +0,0 @@
-#!/usr/bin/env perl
-#
-# ZyklonB factoids plugin
-#
-# Copyright 2016 Přemysl Eric Janouch <p@janouch.name>
-# See the file LICENSE for licensing information.
-#
-
-use strict;
-use warnings;
-use Text::Wrap;
-
-# --- IRC protocol -------------------------------------------------------------
-
-binmode STDIN; select STDIN; $| = 1; $/ = "\r\n";
-binmode STDOUT; select STDOUT; $| = 1; $\ = "\r\n";
-
-sub parse ($) {
- chomp (my $line = shift);
- return undef unless my ($nick, $user, $host, $command, $args) = ($line =~
- qr/^(?::([^! ]*)(?:!([^@]*)@([^ ]*))? +)?([^ ]+)(?: +(.*))?$/o);
- return {nick => $nick, user => $user, host => $host, command => $command,
- args => defined $args ? [$args =~ /:?((?<=:).*|[^ ]+) */og] : []};
-}
-
-sub bot_print {
- print "ZYKLONB print :${\shift}";
-}
-
-# --- Initialization -----------------------------------------------------------
-
-my %config;
-for my $name (qw(prefix)) {
- print "ZYKLONB get_config :$name";
- $config{$name} = (parse <STDIN>)->{args}->[0];
-}
-
-print "ZYKLONB register";
-
-# --- Database -----------------------------------------------------------------
-# Simple map of (factoid_name => [definitions]); all factoids are separated
-# by newlines and definitions by carriage returns. Both disallowed in IRC.
-
-sub db_load {
- local $/ = "\n";
- my ($path) = @_;
- open my $db, "<", $path or return {};
-
- my %entries;
- while (<$db>) {
- chomp;
- my @defs = split "\r";
- $entries{shift @defs} = \@defs;
- }
- \%entries
-}
-
-sub db_save {
- local $\ = "\n";
- my ($path, $ref) = @_;
- my $path_new = "$path.new";
- open my $db, ">", $path_new or die "db save failed: $!";
-
- my %entries = %$ref;
- print $db join "\r", ($_, @{$entries{$_}}) for keys %entries;
- close $db;
- rename $path_new, $path or die "db save failed: $!";
-}
-
-# --- Factoids -----------------------------------------------------------------
-
-my $db_path = 'factoids.db';
-my %db = %{db_load $db_path};
-
-sub learn {
- my ($respond, $input) = @_;
- return &$respond("usage: <name> = <definition>")
- unless $input =~ /^([^=]+?)(?:\s+(\d+))?\s*=\s*(.+?)\s*$/;
-
- my ($name, $number, $definition) = ($1, $2, $3);
- return &$respond("trailing numbers in names are disallowed")
- if defined $2;
- $db{$name} = [] unless exists $db{$name};
-
- my $entries = $db{$name};
- return &$respond("duplicate definition")
- if grep { lc $_ eq lc $definition } @$entries;
-
- push @$entries, $definition;
- &$respond("saved as #${\scalar @$entries}");
- db_save $db_path, \%db;
-}
-
-sub check_number {
- my ($respond, $name, $number) = @_;
- my $entries = $db{$name};
- if ($number > @$entries) {
- &$respond(qq/"$name" has only ${\scalar @$entries} definitions/);
- } elsif (not $number) {
- &$respond("number must not be zero");
- } else {
- return 1;
- }
- return 0;
-}
-
-sub forget {
- my ($respond, $input) = @_;
- return &$respond("usage: <name> <number>")
- unless $input =~ /^([^=]+?)\s+(\d+)\s*$/;
-
- my ($name, $number) = ($1, int($2));
- return &$respond(qq/"$name" is undefined/)
- unless exists $db{$name};
-
- my $entries = $db{$name};
- return unless check_number $respond, $name, $number;
-
- splice @$entries, --$number, 1;
- &$respond("forgotten");
- db_save $db_path, \%db;
-}
-
-sub whatis {
- my ($respond, $input) = @_;
- return &$respond("usage: <name> [<number>]")
- unless $input =~ /^([^=]+?)(?:\s+(\d+))?\s*$/;
-
- my ($name, $number) = ($1, $2);
- return &$respond(qq/"$name" is undefined/)
- unless exists $db{$name};
-
- my $entries = $db{$name};
- if (defined $number) {
- return unless check_number $respond, $name, $number;
- &$respond(qq/"$name" is #$number $entries->[$number - 1]/);
- } else {
- my $i = 1;
- my $definition = join ", ", map { "#${\$i++} $_" } @{$entries};
- &$respond(qq/"$name" is $definition/);
- }
-}
-
-sub wildcard {
- my ($respond, $input) = @_;
- $input =~ /=/ ? learn(@_) : whatis(@_);
-}
-
-my %commands = (
- 'learn' => \&learn,
- 'forget' => \&forget,
- 'whatis' => \&whatis,
- '??' => \&wildcard,
-);
-
-# --- Input loop ---------------------------------------------------------------
-
-while (my $line = <STDIN>) {
- my %msg = %{parse $line};
- my @args = @{$msg{args}};
-
- # This plugin only bothers to respond to PRIVMSG messages
- next unless $msg{command} eq 'PRIVMSG' and @args >= 2
- and my ($cmd, $input) = $args[1] =~ /^$config{prefix}(\S+)\s*(.*)/;
-
- # So far the only reaction is a PRIVMSG back to the sender, so all the
- # handlers need is a response callback and all arguments to the command
- my ($target => $quote) = ($args[0] =~ /^[#+&!]/)
- ? ($args[0] => "$msg{nick}: ") : ($msg{nick} => '');
- # Wrap all responses so that there's space for our prefix in the message
- my $respond = sub {
- local ($Text::Wrap::columns, $Text::Wrap::unexpand) = 400, 0;
- my $start = "PRIVMSG $target :$quote";
- print for split "\n", wrap $start, $start, shift;
- };
- &{$commands{$cmd}}($respond, $input) if exists($commands{$cmd});
-}