From 50057d5149dda340b3b47aca4096f4a6ec66b9ee Mon Sep 17 00:00:00 2001 From: Přemysl Eric Janouch Date: Fri, 6 Aug 2021 16:12:15 +0200 Subject: Come up with sillier names for the binaries I'm not entirely sure, but it looks like some people might not like jokes about the Holocaust. On a more serious note, the project has become more serious over the 7 or so years of its existence. --- plugins/xB/factoids | 177 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 177 insertions(+) create mode 100755 plugins/xB/factoids (limited to 'plugins/xB/factoids') diff --git a/plugins/xB/factoids b/plugins/xB/factoids new file mode 100755 index 0000000..9e9a7b4 --- /dev/null +++ b/plugins/xB/factoids @@ -0,0 +1,177 @@ +#!/usr/bin/env perl +# +# xB factoids plugin +# +# Copyright 2016 Přemysl Eric Janouch +# 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 )->{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: = ") + 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: ") + 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: []") + 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 = ) { + 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}); +} -- cgit v1.2.3-70-g09d2