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.001002';
   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 ($addressed && /^!?forget\s+(.*)$/ || /^!forget\s+(.*)$/) {
  90                 infobot_forget $self, $irc, $1, $to, $nick
  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 =encoding utf-8
 135
 136 =head1 NAME
 137
 138 POE::Component::IRC::Plugin::Infobot - Add infobot features to an PoCo-IRC
 139
 140 =head1 SYNOPSIS
 141
 142   use POE::Component::IRC::Plugin::Infobot;
 143   $irc->plugin_add(Infobot => POE::Component::Plugin::Infobot->new(filename => '/tmp/stuff.db'))
 144
 145 =head1 DESCRIPTION
 146
 147 POE::Component::IRC::Plugin::Infobot is a PoCo-IRC plugin that makes a PoCo-IRC behave like a simple infobot.
 148
 149 It stores factoids in a DB_File database and lets IRC users add, remove and retreive factoids.
 150
 151 The constructor takes one optional argument, I<filename>, the path to the factoids database. It is 'factoids.db' by default.
 152
 153 =head1 IRC COMMANDS
 154
 155 =over
 156
 157 =item B<add>
 158
 159 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.
 160
 161 Example session:
 162
 163   < mgv> bot: IRC is Internet Relay Chat
 164   <+bot> OK, mgv
 165   < mgv> bot: IRC is Internet Relay Chat
 166   <+bot> I already had it that way, mgv
 167   < mgv> bot: IRC is Internally-Routed Communication
 168   <+bot> ... but IRC is Internet Relay Chat!
 169   < mgv> bot: x is <reply> y!
 170   <+bot> sure, mgv
 171   < mgv> bot: whistle is <action> whistles
 172   <+bot>
 173
 174 =item B<forget>
 175
 176 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.
 177
 178 Example session:
 179
 180   < mgv> bot: forget IRC
 181   <+bot> mgv: I forgot IRC
 182   < mgv> bot: forget IRC
 183   <+bot> I didn't have anything matching IRC, mgv
 184
 185 =item B<query>
 186
 187 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.
 188
 189 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.
 190
 191 Example session:
 192
 193   < mgv> IRC?
 194   <+bot> methinks IRC is Internet Relay Chat
 195   < mgv> ASD?
 196   < mgv> bot: ASD?
 197   <+bot> Dunno, mgv
 198   < mgv> x?
 199   <+bot> y!
 200   < mgv> whistle?
 201   * bot whistles
 202
 203 =back
 204
 205 =head1 SEE ALSO
 206
 207 L<POE::Component::IRC::Plugin>, L<http://infobot.sourceforge.net/>
 208
 209 =head1 AUTHOR
 210
 211 Marius Gavrilescu, E<lt>marius@ieval.roE<gt>
 212
 213 =head1 COPYRIGHT AND LICENSE
 214
 215 Copyright (C) 2013 by Marius Gavrilescu
 216
 217 This library is free software; you can redistribute it and/or modify
 218 it under the same terms as Perl itself, either Perl version 5.14.2 or,
 219 at your option, any later version of Perl 5 you may have available.
 220
 221
 222 =cut