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
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
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 "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) = @_;
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});
}
|
