aboutsummaryrefslogtreecommitdiff
path: root/plugins
diff options
context:
space:
mode:
authorPřemysl Janouch <p.janouch@gmail.com>2016-02-27 22:29:19 +0100
committerPřemysl Janouch <p.janouch@gmail.com>2016-02-27 22:29:19 +0100
commit676e6c20fa0b7f4c2186880a8938fd8fae7b99bc (patch)
tree6038e817cad1ee6d4f7086aafea5c60b07d7e4dd /plugins
parented20322e5e19b9f36ab8a493d7716e4fddd63368 (diff)
downloadxK-676e6c20fa0b7f4c2186880a8938fd8fae7b99bc.tar.gz
xK-676e6c20fa0b7f4c2186880a8938fd8fae7b99bc.tar.xz
xK-676e6c20fa0b7f4c2186880a8938fd8fae7b99bc.zip
ZyklonB: add a factoids plugin
Diffstat (limited to 'plugins')
-rwxr-xr-xplugins/zyklonb/factoids156
1 files changed, 156 insertions, 0 deletions
diff --git a/plugins/zyklonb/factoids b/plugins/zyklonb/factoids
new file mode 100755
index 0000000..4fe7aee
--- /dev/null
+++ b/plugins/zyklonb/factoids
@@ -0,0 +1,156 @@
+#!/usr/bin/env perl
+#
+# ZyklonB factoids plugin
+#
+# Copyright 2016 Přemysl Janouch <p.janouch@gmail.com>
+# 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) = @_;
+ open my $db, ">", $path or die "db save failed: $!";
+
+ my %entries = %$ref;
+ print $db join "\r", ($_, @{$entries{$_}}) for keys %entries;
+}
+
+# --- 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*=\s*(.+?)\s*$/;
+
+ my ($name, $definition) = ($1, $2);
+ $db{$name} = [] unless exists $db{$name};
+
+ my $entries = $db{$name};
+ return &$respond("duplicate definition")
+ if grep { $_ eq $definition } @$entries;
+
+ push @$entries, $definition;
+ &$respond("saved as #${\scalar @$entries}");
+ db_save $db_path, \%db;
+}
+
+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 &$respond(qq/"$name" has only ${\scalar @$entries} definitions/)
+ if $number > @$entries;
+ return &$respond("number must not be zero")
+ unless $number;
+
+ splice @$entries, --$number, 1;
+ &$respond("forgotten");
+ db_save $db_path, \%db;
+}
+
+sub whatis {
+ my ($respond, $input) = @_;
+ return &$respond("usage: <name>")
+ unless $input =~ /^([^=]+?)\s*$/;
+
+ my ($name) = ($1);
+ return &$respond(qq/"$name" is undefined/)
+ unless exists $db{$name};
+
+ my $i = 1;
+ my $definition = join ", ", map { "#${\$i++} $_" } @{$db{$name}};
+ &$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});
+}