lib/POE/Component/IRC/Plugin/Infobot.pm

   1 package POE::Component::IRC::Plugin::Infobot;
   2
   3 use 5.014000;
   4 use strict;
   5 use warnings;
   6 use re '/s';
   7
   8 our $VERSION = '0.001002';
   9
  10 use DB_File;
  11
  12 use IRC::Utils qw/parse_user/;
  13 use POE::Component::IRC::Plugin qw/PCI_EAT_NONE/;
  14
  15 use constant +{ ## no critic (Capitalization)
  16         OK => [ 'sure, %s', 'ok, %s', 'gotcha, %s'],
  17         A_IS_B => [ '%s is %s', 'I think %s is %s', 'hmmm... %s is %s', 'it has been said that %s is %s', '%s is probably %s', 'rumour has it %s is %s', 'i heard %s was %s', 'somebody said %s is %s', 'i guess %s is %s', 'well, %s is %s', '%s is, like, %s', 'methinks %s is %s'],
  18         I_DONT_KNOW => [ 'I don\'t know, %s', 'Dunno, %s', 'No idea, %s', '%s: huh?', 'nem tudom, %s', 'anlamıyorum, %s', 'bilmiyorum, %s', 'nu ştiu d\'astea, %s', 'Je ne sais pas, %s', 'Я не знаю, %s'],
  19 };
  20
  21 sub new { ## no critic (RequireArgUnpacking)
  22         my $class = shift;
  23         my $self = {
  24                 filename => 'factoids.db',
  25                 @_
  26         };
  27
  28         my %db;
  29         $self->{dbobj} = tie %db, DB_File => $self->{filename} if defined $self->{filename}; ## no critic (ProhibitTie)
  30         $self->{db} = \%db;
  31         bless $self, $class
  32 }
  33
  34 sub getstr {
  35         my $rstrings = shift;
  36         my @strings = @$rstrings;
  37         sprintf $strings[int rand $#strings], @_
  38 }
  39
  40 sub infobot_add { ## no critic (ProhibitManyArgs)
  41         my ($self, $irc, $key, $value, $to, $nick) = @_;
  42         if (exists $self->{db}->{$key}) {
  43                 $irc->yield(privmsg => $to => "I already had it that way, $nick") if $value eq $self->{db}->{$key};
  44                 $irc->yield(privmsg => $to => "... but $key is $self->{db}->{$key}!") unless $value eq $self->{db}->{$key};
  45         } else {
  46                 $self->{db}->{$key} = $value;
  47                 $self->{dbobj}->sync if exists $self->{dbobj};
  48                 $irc->yield(privmsg => $to => getstr OK, $nick);
  49         }
  50 }
  51
  52 sub infobot_query { ## no critic (ProhibitManyArgs)
  53         my ($self, $irc, $key, $to, $nick, $addressed) = @_;
  54         if (exists $self->{db}->{$key}) {
  55                 my @answers = split /\s+[|]\s+/, $self->{db}->{$key};
  56                 local $_ = $answers[int rand $#answers];
  57
  58                 if (/^<action> (.+)$/i) {
  59                         $irc->yield(ctcp => $to => "ACTION $1")
  60                 } elsif (/^<reply> (.*)$/i) {
  61                         $irc->yield(privmsg => $to => $1)
  62                 } else {
  63                         $irc->yield(privmsg => $to => getstr A_IS_B, $key, $_)
  64                 }
  65         } elsif ($addressed) {
  66                 $irc->yield(privmsg => $to => getstr I_DONT_KNOW, $nick)
  67         }
  68 }
  69
  70 sub infobot_forget {
  71         my ($self, $irc, $key, $to, $nick) = @_;
  72         if (exists $self->{db}->{$key}) {
  73                 delete $self->{db}->{$key};
  74                 $self->{dbobj}->sync if exists $self->{dbobj};
  75                 $irc->yield(privmsg => $to => "$nick: I forgot $key")
  76         } else {
  77                 $irc->yield(privmsg => $to => "I didn't have anything matching $key, $nick")
  78         }
  79 }
  80
  81 sub runcmd{  ## no critic (ProhibitManyArgs)
  82         my ($self, $irc, $to, $nick, $message, $addressed) = @_;
  83
  84         local $_= $message;
  85
  86         if (/^(.+)\s+is\s+(.*[^?])$/x) {
  87                 infobot_add $self, $irc, $1, $2, $to, $nick if $addressed
  88         } elsif (/^(.+)[?]$/) {
  89                 infobot_query $self, $irc, $1, $to, $nick, $addressed
  90         } elsif ($addressed && /^!?forget\s+(.*)$/ || /^!forget\s+(.*)$/) {
  91                 infobot_forget $self, $irc, $1, $to, $nick
  92         }
  93 }
  94
  95 sub PCI_register { ## no critic (Capitalization)
  96         my ($self, $irc) = @_;
  97         $irc->plugin_register($self, SERVER => qw/public msg/);
  98         1
  99 }
 100
 101 sub PCI_unregister{ 1 } ## no critic (Capitalization)
 102
 103 sub S_public { ## no critic (Capitalization)
 104         my ($self, $irc, $rfullname, $rchannels, $rmessage) = @_;
 105         my $nick = parse_user $$rfullname;
 106
 107         for my $channel (@$$rchannels) {
 108                 local $_ = $$rmessage;
 109
 110                 my $addressed=0;
 111                 my $mynick=$irc->nick_name;
 112                 if (/^$mynick [,:]\s+/x) {
 113                         $addressed=1;
 114                         s/^$mynick [,:]\s+//x;
 115                 }
 116
 117                 runcmd $self, $irc, $channel, $nick, $_, $addressed
 118         }
 119
 120         PCI_EAT_NONE
 121 }
 122
 123 sub S_msg{ ## no critic (Capitalization)
 124         my ($self, $irc, $rfullname, $rtargets, $rmessage) = @_;
 125         my $nick = parse_user $$rfullname;
 126
 127         runcmd $self, $irc, $nick, $nick, $$rmessage, 1;
 128
 129         PCI_EAT_NONE
 130 }
 131
 132 1;
 133 __END__
 134
 135 =encoding utf-8
 136
 137 =head1 NAME
 138
 139 POE::Component::IRC::Plugin::Infobot - Add infobot features to an PoCo-IRC
 140
 141 =head1 SYNOPSIS
 142
 143   use POE::Component::IRC::Plugin::Infobot;
 144   $irc->plugin_add(Infobot => POE::Component::Plugin::Infobot->new(filename => '/tmp/stuff.db'))
 145
 146 =head1 DESCRIPTION
 147
 148 POE::Component::IRC::Plugin::Infobot is a PoCo-IRC plugin that makes a PoCo-IRC behave like a simple infobot.
 149
 150 It stores factoids in a DB_File database and lets IRC users add, remove and retreive factoids.
 151
 152 The constructor takes one optional argument, I<filename>, the path to the factoids database. It is 'factoids.db' by default.
 153
 154 =head1 IRC COMMANDS
 155
 156 =over
 157
 158 =item B<add>
 159
 160 Any message of the form "X is Y" which is addressed to the bot or sent in private is an add command. This will not overwrite a previous factoid with the same key.
 161
 162 Example session:
 163
 164   < mgv> bot: IRC is Internet Relay Chat
 165   <+bot> OK, mgv
 166   < mgv> bot: IRC is Internet Relay Chat
 167   <+bot> I already had it that way, mgv
 168   < mgv> bot: IRC is Internally-Routed Communication
 169   <+bot> ... but IRC is Internet Relay Chat!
 170   < mgv> bot: x is <reply> y!
 171   <+bot> sure, mgv
 172   < mgv> bot: whistle is <action> whistles
 173   <+bot>
 174
 175 =item B<forget>
 176
 177 Any message of the form "forget X" which is addressed to the bot or sent in private is a forget command. This command will erase any previous factoid with this key.
 178
 179 Example session:
 180
 181   < mgv> bot: forget IRC
 182   <+bot> mgv: I forgot IRC
 183   < mgv> bot: forget IRC
 184   <+bot> I didn't have anything matching IRC, mgv
 185
 186 =item B<query>
 187
 188 Any message ending in a question mark is a query command. If a factoid with that key is found, the plugin will respond. If no such factoid is found AND the message is either addressed to the bot or sent in private, the bot will say that it doesn't know the answer to the question.
 189
 190 If the factoid starts with C<< <reply> >>, everything after the C<< <reply> >> is sent. If it starts with C<< <action> >>, it is sent as a CTCP ACTION. Otherwise, a message of the form C<factoid_key is factoid_value> is sent.
 191
 192 Example session:
 193
 194   < mgv> IRC?
 195   <+bot> methinks IRC is Internet Relay Chat
 196   < mgv> ASD?
 197   < mgv> bot: ASD?
 198   <+bot> Dunno, mgv
 199   < mgv> x?
 200   <+bot> y!
 201   < mgv> whistle?
 202   * bot whistles
 203
 204 =back
 205
 206 =head1 SEE ALSO
 207
 208 L<POE::Component::IRC::Plugin>, L<http://infobot.sourceforge.net/>
 209
 210 =head1 AUTHOR
 211
 212 Marius Gavrilescu, E<lt>marius@ieval.roE<gt>
 213
 214 =head1 COPYRIGHT AND LICENSE
 215
 216 Copyright (C) 2013 by Marius Gavrilescu
 217
 218 This library is free software; you can redistribute it and/or modify
 219 it under the same terms as Perl itself, either Perl version 5.14.2 or,
 220 at your option, any later version of Perl 5 you may have available.
 221
 222
 223 =cut