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