1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
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});
}
|
