ZyklonB: add a factoids plugin
This commit is contained in:
parent
ed20322e5e
commit
676e6c20fa
|
|
@ -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});
|
||||||
|
}
|
||||||
Loading…
Reference in New Issue