xK/plugins/xB/factoids

178 lines
4.7 KiB
Plaintext
Raw Normal View History

2016-02-27 22:29:19 +01:00
#!/usr/bin/env perl
#
# xB factoids plugin
2016-02-27 22:29:19 +01:00
#
2020-09-02 19:00:11 +02:00
# Copyright 2016 Přemysl Eric Janouch <p@janouch.name>
2016-02-27 22:29:19 +01:00
# 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) = @_;
2016-02-29 03:15:44 +01:00
my $path_new = "$path.new";
open my $db, ">", $path_new or die "db save failed: $!";
2016-02-27 22:29:19 +01:00
my %entries = %$ref;
print $db join "\r", ($_, @{$entries{$_}}) for keys %entries;
2016-02-29 03:15:44 +01:00
close $db;
rename $path_new, $path or die "db save failed: $!";
2016-02-27 22:29:19 +01:00
}
# --- 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*$/;
2016-02-27 22:29:19 +01:00
my ($name, $number, $definition) = ($1, $2, $3);
return &$respond("trailing numbers in names are disallowed")
if defined $2;
2016-02-27 22:29:19 +01:00
$db{$name} = [] unless exists $db{$name};
my $entries = $db{$name};
return &$respond("duplicate definition")
if grep { lc $_ eq lc $definition } @$entries;
2016-02-27 22:29:19 +01:00
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;
}
2016-02-27 22:29:19 +01:00
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;
2016-02-27 22:29:19 +01:00
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*$/;
2016-02-27 22:29:19 +01:00
my ($name, $number) = ($1, $2);
2016-02-27 22:29:19 +01:00
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/);
}
2016-02-27 22:29:19 +01:00
}
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});
}