File Coverage

File:lib/Bot/IRC.pm
Coverage:46.6%

linestmtbrancondsubpodtimecode
1package Bot::IRC;
2# ABSTRACT: Yet Another IRC Bot
3
4
5
5
5
63
30
440
use strict;
5
5
5
5
60
37
290
use warnings;
6
7
5
5
5
45
24
1421
use Carp 'croak';
8
5
5
5
30565
2525651
7662
use Daemon::Device;
9
5
5
5
18838
994486
868
use IO::Socket;
10
5
5
5
55005
5239400
540
use IO::Socket::SSL;
11
5
5
5
22732
550653
115941
use Time::Crontab;
12
13# VERSION
14
15sub new {
16
9
1
57
    my $class = shift;
17
9
106
    my $self  = bless( {@_}, $class );
18
19
9
252
    croak('Odd number of elements passed to new()') if ( @_ % 2 );
20    croak('connect/server not provided to new()')
21
9
247
        unless ( ref $self->{connect} eq 'HASH' and $self->{connect}{server} );
22
23
8
95
    $self->{spawn} ||= 2;
24
25
8
69
    $self->{connect}{nick} //= 'bot';
26
8
67
    $self->{connect}{name} //= 'Yet Another IRC Bot';
27
8
66
    $self->{connect}{port} ||= 6667;
28
29
8
80
    $self->{daemon}           //= {};
30
8
81
    $self->{daemon}{name}     //= $self->{connect}{nick};
31
8
92
    $self->{daemon}{pid_file} //= $self->{daemon}{name} . '.pid';
32
33
8
48
    $self->{nick} = $self->{connect}{nick};
34
35
8
44
    $self->{hooks}  = [];
36
8
47
    $self->{ticks}  = [];
37
8
49
    $self->{helps}  = {};
38
8
50
    $self->{loaded} = {};
39
40    $self->load(
41
2
13
        ( ref $self->{plugins} eq 'ARRAY' ) ? @{ $self->{plugins} } : $self->{plugins}
42
8
56
    ) if ( $self->{plugins} );
43
44
7
55
    return $self;
45}
46
47sub run {
48
1
1
7
    my ($self) = @_;
49
50    $self->{socket} = ( ( $self->{connect}{ssl} ) ? 'IO::Socket::SSL' : 'IO::Socket::INET' )->new(
51        PeerAddr        => $self->{connect}{server},
52        PeerPort        => $self->{connect}{port},
53
1
14
        Proto           => 'tcp',
54        Type            => SOCK_STREAM,
55        SSL_verify_mode => SSL_VERIFY_NONE,
56    ) or die $!;
57
58
1
5
    eval {
59        $self->{device} = Daemon::Device->new(
60            parent     => \&_parent,
61            on_message => \&_on_message,
62            spawn      => $self->{spawn},
63            daemon     => $self->{daemon},
64
1
12
            data       => { self => $self },
65        );
66    };
67
1
7
    croak($@) if ($@);
68
1
8
    $self->{device}->run;
69}
70
71sub _parent {
72
0
0
    my ($device) = @_;
73
0
0
    my $self     = $device->data('self');
74
0
0
    my $session  = { start => time };
75    my $delegate = sub {
76        my ($random_child) =
77
0
0
            map { $_->[0] }
78
0
0
            sort { $a->[1] <=> $b->[1] }
79
0
0
            map { [ $_, rand() ] }
80
0
0
0
0
            @{ $device->children };
81
82
0
0
        $device->message( $random_child, @_ );
83
0
0
    };
84
85    local $SIG{ALRM} = sub {
86
0
0
        alarm 1;
87
0
0
        my $time = time;
88
89
0
0
        $_->{code}->($self) for (
90            grep {
91                ref $_->{timing} and ( $time % 60 == 0 ) and $_->{timing}->match($time) or
92
0
0
                not ref $_->{timing} and ( ( $time - $session->{start} ) % $_->{timing} == 0 )
93
0
0
            } @{ $self->{ticks} }
94        );
95
0
0
    };
96
97
0
0
    while ( my $line = $self->{socket}->getline ) {
98
0
0
        print $line;
99
0
0
        chomp($line);
100
101
0
0
        if ( not $session->{established} ) {
102
0
0
            if ( not $session->{user} ) {
103
0
0
                $self->say("USER $self->{nick} 0 * :$self->{connect}{name}");
104
0
0
                $self->say("NICK $self->{nick}");
105
0
0
                $session->{user} = 1;
106            }
107            elsif ( $line =~ /^:\S+\s433\s/ ) {
108
0
0
                $self->nick( $self->{nick} . '_' );
109            }
110            elsif ( $line =~ /^:\S+\s001\s/ ) {
111
0
0
                $self->join;
112
0
0
                $session->{established} = 1;
113
0
0
0
0
                alarm 1 if ( @{ $self->{ticks} } );
114            }
115        }
116
117
0
0
        $delegate->($line);
118    }
119}
120
121sub _on_message {
122
0
0
    my $device = shift;
123
0
0
    my $self   = $device->data('self');
124
125
0
0
    for my $line (@_) {
126
0
0
        if ( $line =~ /^>>>\sNICK\s(.*)/ ) {
127
0
0
            $self->{nick} = $1;
128
0
0
            next;
129        }
130        elsif ( $line =~ /^:\S+\s433\s/ ) {
131
0
0
            $self->nick( $self->{nick} . '_' );
132
0
0
            next;
133        }
134
135
0
0
0
0
        $self->{in} = { map { $_ => '' } qw( line source nick user server command forum text ) };
136
0
0
        $self->{in}{$_} = 0 for ( qw( private to_me ) );
137
0
0
        $self->{in}{line} = $line;
138
139
0
0
        if ( $line =~ /^:(\S+?)!~?(\S+?)@(\S+?)\s(\S+)\s(\S+)\s:(.*)/ ) {
140
0
0
0
0
            @{ $self->{in} }{ qw( nick user server command forum text ) } = ( $1, $2, $3, $4, $5, $6 );
141        }
142        elsif ( $line =~ /^:(\S+?)!~?(\S+?)@(\S+?)\s(\S+)\s:(.*)/ ) {
143
0
0
0
0
            @{ $self->{in} }{ qw( nick user server command text ) } = ( $1, $2, $3, $4, $5 );
144        }
145        elsif ( $line =~ /^:(\S+?)!~?(\S+?)@(\S+?)\s(\S+)\s(\S+)\s(.*)/ ) {
146
0
0
0
0
            @{ $self->{in} }{ qw( nick user server command forum text ) } = ( $1, $2, $3, $4, $5, $6 );
147        }
148        elsif ( $line =~ /^:(\S+?)!~?(\S+?)@(\S+?)\s(\S+)\s(\S+)/ ) {
149
0
0
0
0
            @{ $self->{in} }{ qw( nick user server command forum ) } = ( $1, $2, $3, $4, $5, $6 );
150        }
151        elsif ( $line =~ /^(PING)\s(.+)/ ) {
152
0
0
0
0
            @{ $self->{in} }{ qw( command text ) } = ( $1, $2 );
153
0
0
            $self->say( 'PONG ' . $self->{in}{text} );
154
0
0
            next;
155        }
156        elsif ( $line =~ /^:(\S+)\s(NOTICE|\d+)\s(\S+)\s(.*)/ ) {
157
0
0
0
0
            @{ $self->{in} }{ qw( source command forum text ) } = ( $1, $2, $3, $4 );
158        }
159        elsif ( $line =~ /^(ERROR)\s/ ) {
160
0
0
            warn $line . "\n";
161        }
162        else {
163
0
0
            warn 'Unparsed line (probably a bug in Bot::IRC; please report it): ', $line . "\n";
164        }
165
166
0
0
        next unless ( $self->{in}{nick} ne $self->{nick} );
167
168
0
0
        if ( $self->{in}{command} eq 'PRIVMSG' ) {
169
0
0
            $self->{in}{private} = 1 if ( $self->{in}{forum} and $self->{in}{forum} eq $self->{nick} );
170            $self->{in}{to_me}   = 1 if (
171                $self->{in}{text} =~ s/^\s*$self->{nick}\b\W*//i or
172                $self->{in}{private}
173
0
0
            );
174        }
175
176
0
0
        if ( $self->{in}{to_me} ) {
177
0
0
            if ( $self->{in}{text} =~ /^\s*help\W*$/i ) {
178                $self->reply(
179                    ( ( $self->{in}{private} ) ? '' : $self->{in}{nick} . ': ' ) .
180                    'Ask me for help with "help topic" where the topic is one of the following: ' .
181
0
0
0
0
                    join( ', ', sort keys %{ $self->{helps} } ) . '.'
182                );
183
0
0
                next;
184            }
185            elsif ( $self->{in}{text} =~ /^\s*help\s+(.+?)\W*$/i ) {
186                $self->reply(
187                    ( ( $self->{in}{private} ) ? '' : $self->{in}{nick} . ': ' ) .
188
0
0
                    ( $self->{helps}{$1} || "Couldn't find the help topic: $1." )
189                );
190
0
0
                next;
191            }
192        }
193
194
0
0
0
0
        hook: for my $hook ( @{ $self->{hooks} } ) {
195
0
0
            my $captured_matches = {};
196
197
0
0
0
0
            for my $type ( keys %{ $hook->{when} } ) {
198                next hook unless (
199                    ref( $hook->{when}{$type} ) eq 'Regexp' and $self->{in}{$type} =~ $hook->{when}{$type} or
200                    ref( $hook->{when}{$type} ) eq 'CODE' and $hook->{when}{$type}->(
201                        $self,
202                        $self->{in}{$type},
203
0
0
                        { %{ $self->{in} } },
204                    ) or
205
0
0
                    $self->{in}{$type} eq $hook->{when}{$type}
206                );
207
208
5
5
5
0
19541
58559
95844
0
                $captured_matches = { %$captured_matches, %+ } if ( keys %+ );
209            }
210
211            last if ( $hook->{code}->(
212                $self,
213
0
0
0
0
                { %{ $self->{in} } },
214                $captured_matches,
215            ) );
216        }
217    }
218}
219
220sub load {
221
4
1
20
    my $self = shift;
222
223
4
22
    for my $plugin (@_) {
224
4
22
        unless ( ref $plugin ) {
225
4
19
            my $namespace;
226
4
30
            for (
227                $plugin,
228                __PACKAGE__ . "::Y::$plugin",
229                __PACKAGE__ . "::X::$plugin",
230                __PACKAGE__ . "::$plugin",
231            ) {
232
10
815
                eval "require $_";
233
10
101
                unless ($@) {
234
3
18
                    $namespace = $_;
235
3
18
                    last;
236                }
237                else {
238
7
72
                    croak($@) unless ( $@ =~ /^Can't locate/ );
239                }
240            }
241
4
48
            croak("Unable to find or properly load $plugin") unless ($namespace);
242
243
3
24
            next if ( $self->{loaded}{$namespace} );
244
245
3
46
            $namespace->import if ( $namespace->can('import') );
246
3
32
            croak("$namespace does not implement init()") unless ( $namespace->can('init') );
247
248
3
157
            eval "${namespace}::init(\$self)";
249
3
26
            die($@) if ($@);
250
251
3
34
            $self->{loaded}{$namespace} = time;
252        }
253        else {
254
0
0
0
0
            $self->$_( @{ $plugin->{$_} } ) for ( qw( hooks ticks ) );
255
0
0
            $self->$_( $plugin->{$_} ) for ( qw( helps subs ) );
256        }
257    }
258
259
3
33
    return $self;
260}
261
262sub reload {
263
1
1
6
    my $self = shift;
264
1
8
    delete $self->{loaded}{$_} for (@_);
265
1
7
    return $self->load(@_);
266}
267
268sub hook {
269
5
1
26
    my ( $self, $when, $code, $attr ) = @_;
270
271
5
109
    $attr //= {};
272
5
72
    $attr->{priority} //= 0;
273
274    $self->{hooks} = [
275        sort {
276            $b->{attr} <=> $a->{attr}
277
5
33
        }
278
5
5
23
50
        @{ $self->{hooks} },
279        {
280            when => $when,
281            code => $code,
282            attr => $attr,
283        },
284    ];
285
286
5
0
99
0
    $self->subs(  %{ $attr->{subs}  } ) if ( ref $attr->{subs}  eq 'HASH' );
287
5
0
31
0
    $self->helps( %{ $attr->{helps} } ) if ( ref $attr->{helps} eq 'HASH' );
288
289
5
47
    return $self;
290}
291
292sub hooks {
293
1
1
6
    my $self = shift;
294
1
6
    $self->hook(@$_) for (@_);
295
1
7
    return $self;
296}
297
298sub helps {
299
2
1
10
    my $self = shift;
300
2
2
10
17
    $self->{helps} = { %{ $self->{helps} }, @_ };
301
2
19
    return $self;
302}
303
304sub tick {
305
3
1
13
    my ( $self, $timing, $code ) = @_;
306
307
3
3
14
30
    push( @{ $self->{ticks} }, {
308        timing => ( $timing =~ /^\d+$/ ) ? $timing : Time::Crontab->new($timing),
309        code   => $code,
310    } );
311
3
21
    return $self;
312}
313
314sub ticks {
315
1
1
6
    my $self = shift;
316
1
7
    $self->tick(@$_) for (@_);
317
1
46
    return $self;
318}
319
320sub subs {
321
4
1
23
    my $self = shift;
322
4
29
    my $subs = {@_};
323
324
4
28
    for my $name ( keys %$subs ) {
325
5
5
5
6118
290
61731
        no strict 'refs';
326
5
5
28
53
        *{ __PACKAGE__ . '::' . $name } = $subs->{$name};
327    }
328
4
75
    return $self;
329}
330
331sub register {
332
2
1
10
    my $self = shift;
333
2
26
    $self->{loaded}{$_} = time for (@_);
334
2
14
    return $self;
335}
336
337sub reply {
338
1
1
6
    my ( $self, $message ) = @_;
339
340
1
7
    if ( $self->{in}{forum} ) {
341        $self->msg(
342
0
0
            ( ( $self->{in}{forum} eq $self->{nick} ) ? $self->{in}{nick} : $self->{in}{forum} ),
343            $message,
344        );
345    }
346    else {
347
1
40
        warn "Didn't have a target to send reply to.\n";
348    }
349
1
53
    return $self;
350}
351
352sub msg {
353
1
1
7
    my ( $self, $target, $message ) = @_;
354
1
9
    $self->say("PRIVMSG $target :$message");
355
1
8
    return $self;
356}
357
358sub say {
359
3
1
18
    my $self = shift;
360
361
3
20
    for (@_) {
362
4
561
        $self->{socket}->print( $_ . "\r\n" );
363
4
5217
        print '<<< ', $_, "\n";
364    }
365
3
71
    return $self;
366}
367
368sub nick {
369
1
1
22
    my ( $self, $nick ) = @_;
370
371
1
8
    if ($nick) {
372
1
6
        $self->{nick} = $nick;
373        $self->{device}->message( $_, ">>> NICK $self->{nick}" )
374
1
3
1
157
282
167
            for ( grep { $_ != $$ } $self->{device}->ppid, @{ $self->{device}->children } );
375
1
9
        $self->say("NICK $self->{nick}");
376    }
377
1
9
    return $self->{nick};
378}
379
380sub join {
381
0
1
    my $self = shift;
382
383
0
0
    my @join = @{ ( $self->can('store') ) ? $self->store->get('join') || [] : [] };
384
385
0
    unless (@_) {
386
0
        if (@join) {
387
0
            $self->say("JOIN $_") for (@join);
388        }
389        elsif ( $self->{connect}{join} ) {
390
0
            for (
391                ( ref $self->{connect}{join} eq 'ARRAY' )
392
0
                    ? @{ $self->{connect}{join} }
393                    : $self->{connect}{join}
394            ) {
395
0
                push( @join, $_ );
396
0
                $self->say("JOIN $_");
397            }
398        }
399    }
400    else {
401
0
        for (@_) {
402
0
            push( @join, $_ );
403
0
            $self->say("JOIN $_");
404        }
405    }
406
407
0
    $self->store->set( 'join' => \@join ) if ( $self->can('store') );
408
409
0
    return $self;
410}
411
412sub part {
413
0
1
    my $self = shift;
414
415
0
0
    my @join = @{ ( $self->can('store') ) ? $self->store->get('join') || [] : [] };
416
417
0
    for my $channel (@_) {
418
0
        $self->say("PART $channel");
419
0
0
        @join = grep { $_ ne $channel } @join;
420    }
421
422
0
    $self->store->set( 'join' => \@join ) if ( $self->can('store') );
423
424
0
    return $self;
425}
426
4271;