File Coverage

blib/lib/POE/Component/IRC/Plugin/Infobot.pm
Criterion Covered Total %
statement 12 14 85.7
branch n/a
condition n/a
subroutine 5 5 100.0
pod n/a
total 17 19 89.4


line stmt bran cond sub pod time code
1             package POE::Component::IRC::Plugin::Infobot;
2              
3 1     1   25175 use 5.014000;
  1         4  
4 1     1   6 use strict;
  1         2  
  1         21  
5 1     1   5 use warnings;
  1         2  
  1         29  
6 1     1   5 use re '/s';
  1         1  
  1         81  
7              
8             our $VERSION = '0.001003';
9              
10 1     1   511 use DB_File;
  0            
  0            
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 (/^ (.+)$/i) {
59             $irc->yield(ctcp => $to => "ACTION $1")
60             } elsif (/^ (.*)$/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__