diff options
author | Přemysl Eric Janouch <p@janouch.name> | 2021-08-06 16:12:15 +0200 |
---|---|---|
committer | Přemysl Eric Janouch <p@janouch.name> | 2021-08-06 16:43:59 +0200 |
commit | 50057d5149dda340b3b47aca4096f4a6ec66b9ee (patch) | |
tree | 79323d20b17c2c8e32942a1ac9b84d9da3041c6d /plugins/zyklonb/factoids | |
parent | 1f64710e795b0c5434d15813d4f1f568467ca087 (diff) | |
download | xK-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-x | plugins/zyklonb/factoids | 177 |
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}); -} |