1 files changed, 177 insertions, 0 deletions
diff --git a/plugins/xB/factoids b/plugins/xB/factoids
new file mode 100755
index 0000000..84f6559
--- /dev/null
+++ b/plugins/xB/factoids
@@ -0,0 +1,177 @@
+#!/usr/bin/env perl
+#
+# xB 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 "XB print :${\shift}";
+}
+
+# --- Initialization -----------------------------------------------------------
+
+my %config;
+for my $name (qw(prefix)) {
+	print "XB get_config :$name";
+	$config{$name} = (parse <STDIN>)->{args}->[0];
+}
+
+print "XB 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});
+}