File Coverage

blib/lib/Bot/Cobalt/IRC.pm
Criterion Covered Total %
statement 51 369 13.8
branch 0 86 0.0
condition 0 83 0.0
subroutine 17 50 34.0
pod 0 28 0.0
total 68 616 11.0


line stmt bran cond sub pod time code
1             package Bot::Cobalt::IRC;
2             $Bot::Cobalt::IRC::VERSION = '0.021002';
3 5     5   13502 use strictures 2;
  5         1125  
  5         173  
4 5     5   691 use Scalar::Util 'reftype';
  5         5  
  5         228  
5              
6 5     5   1266 use Bot::Cobalt;
  5         8  
  5         23  
7 5     5   3268 use Bot::Cobalt::Common;
  5         6  
  5         23  
8              
9 5     5   1765 use Bot::Cobalt::IRC::FloodChk;
  5         10  
  5         127  
10              
11 5     5   1840 use Bot::Cobalt::IRC::Server;
  5         9  
  5         138  
12              
13 5     5   1524 use Bot::Cobalt::IRC::Message;
  5         7  
  5         146  
14 5     5   1552 use Bot::Cobalt::IRC::Message::Public;
  5         6  
  5         115  
15              
16 5     5   1875 use Bot::Cobalt::IRC::Event::Channel;
  5         9  
  5         125  
17 5     5   1747 use Bot::Cobalt::IRC::Event::Kick;
  5         10  
  5         127  
18 5     5   1741 use Bot::Cobalt::IRC::Event::Mode;
  5         10  
  5         131  
19 5     5   1528 use Bot::Cobalt::IRC::Event::Nick;
  5         8  
  5         132  
20 5     5   2073 use Bot::Cobalt::IRC::Event::Quit;
  5         11  
  5         132  
21 5     5   1898 use Bot::Cobalt::IRC::Event::Topic;
  5         9  
  5         176  
22              
23 5         36 use POE qw/
24             Component::IRC::State
25             Component::IRC::Plugin::CTCP
26             Component::IRC::Plugin::AutoJoin
27             Component::IRC::Plugin::Connector
28             Component::IRC::Plugin::NickServID
29             Component::IRC::Plugin::NickReclaim
30 5     5   25 /;
  5         5  
31              
32             ## Bot::Cobalt::Common pulls the rest of these:
33 5     5   528949 use IRC::Utils 'parse_mode_line';
  5         6  
  5         172  
34              
35              
36 5     5   19 use Moo;
  5         5  
  5         38  
37              
38             has NON_RELOADABLE => (
39             ## Well, really, it's sort-of unloadable.
40             ## ... but life usually sucks when you do.
41             ## Call _set_NON_RELOADABLE if you really need to
42             isa => Bool,
43             is => 'rwp',
44             default => sub { 1 },
45             );
46              
47             ## We keep references to our ircobjs; core tracks these also,
48             ## but there is no guarantee that we're the only IRC plugin loaded.
49             has ircobjs => (
50             lazy => 1,
51             is => 'rw',
52             isa => HashObj,
53             coerce => 1,
54             default => sub { {} },
55             );
56              
57             has flood => (
58             is => 'ro',
59             isa => Object,
60             lazy => 1,
61             predicate => 'has_flood',
62             default => sub {
63             my $ccfg = core->get_core_cfg;
64             my $count = $ccfg->opts->{FloodCount} || 5;
65             my $secs = $ccfg->opts->{FloodTime} || 6;
66             Bot::Cobalt::IRC::FloodChk->new(
67             count => $count,
68             in => $secs,
69             )
70             },
71             );
72              
73             ## Outgoing IRC traffic is handled by UserEvents role:
74             with 'Bot::Cobalt::IRC::Role::UserEvents';
75              
76             ## Administrative commands:
77             with 'Bot::Cobalt::IRC::Role::AdminCmds';
78              
79             sub Cobalt_register {
80 0     0 0   my ($self, $core) = splice @_, 0, 2;
81              
82 0           register($self, SERVER => 'all' );
83 0           broadcast( 'initialize_irc' );
84              
85             ## Start a lazy cleanup timer for flood->expire
86 0           $core->timer_set( 180,
87             +{ Event => 'ircplug_chk_floodkey_expire' },
88             'IRCPLUG_CHK_FLOODKEY_EXPIRE'
89             );
90              
91 0           logger->info("Loaded");
92              
93 0           PLUGIN_EAT_NONE
94             }
95              
96             sub Cobalt_unregister {
97 0     0 0   my ($self, $core) = splice @_, 0, 2;
98 0           logger->info("Unregistering and dropping servers.");
99 0           $self->_clear_context($_) for keys %{ $self->ircobjs };
  0            
100 0           logger->debug("Clean unload");
101 0           PLUGIN_EAT_NONE
102             }
103              
104             sub Bot_initialize_irc {
105 0     0 0   my ($self, $core) = splice @_, 0, 2;
106              
107             ## The IRC: directive in cobalt.conf provides context 'Main'
108             ## (This will override any 'Main' specified in multiserv.conf)
109             ## Munge core->irc() hash into our plugin's opts()
110 0           my $p_cfg = $core->cfg->plugins->plugin( plugin_alias($self) );
111 0           $p_cfg->opts->{Networks}->{Main} = $core->cfg->core->irc;
112              
113 0 0         if (exists $p_cfg->opts->{Networks}->{'-ALL'}) {
114             ## Reserved by core Auth plugin
115 0           logger->error("-ALL is not a valid context name, disregarding.");
116 0           delete $p_cfg->opts->{Networks}->{'-ALL'}
117             }
118              
119 0           my $active_contexts = 0;
120 0           for my $context (keys %{ $p_cfg->opts->{Networks} } ) {
  0            
121 0           ++$active_contexts;
122             next if defined $p_cfg->opts->{Networks}->{$context}->{Enabled}
123 0 0 0       and $p_cfg->opts->{Networks}->{$context}->{Enabled} == 0;
124 0           logger->debug("Found configured context $context");
125 0           broadcast( 'ircplug_connect', $context );
126             }
127              
128 0 0         unless ($active_contexts) {
129 0           logger->error("No contexts configured/enabled!");
130             }
131 0           logger->info("Connecting to $active_contexts contexts");
132            
133 0           PLUGIN_EAT_ALL
134             }
135              
136             sub Bot_ircplug_connect {
137 0     0 0   my ($self, $core) = splice @_, 0, 2;
138 0           my $context = ${ $_[0] };
  0            
139              
140             ## Spawn an IRC Component and a Session to manage it.
141             ##
142             ## Called for each configured context.
143             ##
144             ## The sessions call the same object with different contexts in HEAP;
145             ## the handlers do some processing and relay the event from the
146             ## PoCo::IRC syndicator to the Bot::Cobalt::Core pipeline.
147              
148 0 0         if ($core->Servers->{$context}) {
149 0 0         if ( $core->Servers->{$context}->has_irc ) {
150 0           $core->Servers->{$context}->irc->call('shutdown',
151             'Reconnecting'
152             );
153              
154 0           $core->Servers->{$context}->clear_irc;
155             }
156              
157             ## Just in case ...
158 0           $core->auth->clear($context);
159 0           $core->ignore->clear($context);
160             }
161              
162 0           logger->debug("ircplug_connect issued for $context");
163              
164 0           my $pcfg = core->cfg->plugins->plugin( plugin_alias($self) );
165 0           my $thiscfg = $pcfg->opts->{Networks}->{$context};
166              
167 0 0 0       unless (ref $thiscfg && reftype $thiscfg eq 'HASH' && keys %$thiscfg) {
      0        
168 0           logger->error("Connect issued for context without valid cfg ($context)");
169 0           return PLUGIN_EAT_ALL
170             }
171              
172 0           my $server = $thiscfg->{ServerAddr};
173              
174 0 0         unless (defined $server) {
175 0           logger->error("Context $context has no defined ServerAddr");
176 0           return PLUGIN_EAT_ALL
177             }
178              
179 0   0       my $port = $thiscfg->{ServerPort} || 6667;
180 0   0       my $nick = $thiscfg->{Nickname} || 'cobalt2' ;
181              
182 0 0         my $usessl = $thiscfg->{UseSSL} ? 1 : 0;
183 0 0         my $use_v6 = $thiscfg->{IPv6} ? 1 : 0;
184              
185 0           logger->info(
186             "Spawning IRC for $context ($nick on $server : $port)"
187             );
188 0           logger->debug(
189             "Context $context; SSL $usessl ; V6 $use_v6"
190             );
191              
192             # FIXME at least optionally disable outgoing flood queue,
193             # probably better to reimplement on top of IRC::FloodChk
194             my %spawn_opts = (
195             resolver => core->resolver,
196              
197             alias => $context,
198             nick => $nick,
199             username => $thiscfg->{Username} // 'cobalt',
200 0   0       ircname => $thiscfg->{Realname} // 'http://cobaltirc.org',
      0        
201             server => $server,
202             port => $port,
203             useipv6 => $use_v6,
204             usessl => $usessl,
205             raw => 0,
206             );
207              
208             $spawn_opts{localaddr} = $thiscfg->{BindAddr}
209 0 0         if defined $thiscfg->{BindAddr};
210              
211             $spawn_opts{password} = $thiscfg->{ServerPass}
212 0 0         if defined $thiscfg->{ServerPass};
213              
214 0 0 0       my $irc = POE::Component::IRC::State->spawn(%spawn_opts)
215             or logger->error("IRC component spawn() for $context failed")
216             and return PLUGIN_EAT_ALL;
217              
218 0           my $server_obj = Bot::Cobalt::IRC::Server->new(
219             name => $server,
220             irc => $irc,
221             prefer_nick => $nick,
222             );
223              
224 0           $core->Servers->{$context} = $server_obj;
225 0           $self->ircobjs->{$context} = $irc;
226              
227             ## Attempt to spin up a session.
228 0 0         if ( $self->_spawn_for_context($context) ) {
229 0           logger->debug("Successful session creation for context $context");
230             }
231              
232 0           return PLUGIN_EAT_ALL
233             }
234              
235             sub _spawn_for_context {
236 0     0     my ($self, $context) = @_;
237              
238 0 0 0       POE::Session->create(
239             ## track this session's context name in HEAP
240             heap => { Context => $context },
241             object_states => [
242             $self => [ qw/
243             _start
244              
245             irc_001
246             irc_connected
247             irc_disconnected
248             irc_error
249             irc_socketerr
250              
251             irc_chan_sync
252              
253             irc_public
254             irc_msg
255             irc_notice
256             irc_ctcp_action
257              
258             irc_kick
259             irc_mode
260             irc_topic
261             irc_invite
262              
263             irc_nick
264             irc_join
265             irc_part
266             irc_quit
267             / ],
268             ],
269             ) or
270             logger->error("Session creation failed for context $context")
271             and return;
272             }
273              
274             sub Bot_ircplug_disconnect {
275 0     0 0   my ($self, $core) = splice @_, 0, 2;
276 0           my $context = ${ $_[0] };
  0            
277              
278 0           logger->debug("ircplug_disconnect event caught for $context");
279              
280 0           $self->_clear_context($context);
281              
282 0           return PLUGIN_EAT_ALL
283             }
284              
285             sub _clear_context {
286 0     0     my ($self, $context) = @_;
287              
288 0           logger->debug("_clear_context called for $context");
289              
290 0           core->auth->clear($context);
291 0           core->ignore->clear($context);
292              
293 0           core->Servers->{$context}->clear_irc;
294              
295 0 0 0       my $irc = delete $self->ircobjs->{$context}
296             or logger->error(
297             "ircplug_disconnect called for nonexistant context $context"
298             ) and return PLUGIN_EAT_ALL;
299              
300 0           $irc->call('shutdown', "IRC component shut down");
301              
302 0           logger->info("Called shutdown for context $context");
303              
304 0           return $context
305             }
306              
307             sub _start {
308 0     0     my ($self, $kernel, $heap) = @_[OBJECT, KERNEL, HEAP];
309              
310 0           my $context = $heap->{Context};
311 0           my $irc = $self->ircobjs->{$context};
312              
313 0           my $ccfg = core->get_core_cfg;
314 0           my $pcfg = core->cfg->plugins->plugin( plugin_alias($self) );
315              
316 0           logger->debug("pocoirc plugin load");
317              
318             ## autoreconn plugin:
319 0           my %connector;
320              
321 0   0       $connector{delay} = $ccfg->opts->{StonedCheck} || 300;
322 0   0       $connector{reconnect} = $ccfg->opts->{ReconnectDelay} || 60;
323              
324 0           $irc->plugin_add('Connector' =>
325             POE::Component::IRC::Plugin::Connector->new(
326             %connector
327             ),
328             );
329              
330             ## attempt to regain primary nickname:
331             $irc->plugin_add('NickReclaim' =>
332             POE::Component::IRC::Plugin::NickReclaim->new(
333 0   0       poll => $ccfg->opts->{NickRegainDelay} // 30,
334             ),
335             );
336              
337 0 0         if (defined $pcfg->opts->{Networks}->{$context}->{NickServPass}) {
338 0           logger->debug("Adding NickServ ID for $context");
339             $irc->plugin_add('NickServID' =>
340             POE::Component::IRC::Plugin::NickServID->new(
341             Password => $pcfg->opts->{Networks}->{$context}->{NickServPass},
342 0           ),
343             );
344             }
345              
346 0   0       my $chanhash = core->cfg->channels->context($context) // {};
347             ## AutoJoin plugin takes a hash in form of { $channel => $passwd }:
348 0           my %ajoin;
349 0           for my $chan (%$chanhash) {
350 0   0       my $key = $chanhash->{$chan}->{password} // '';
351 0           $ajoin{$chan} = $key;
352             }
353              
354             $irc->plugin_add('AutoJoin' =>
355             POE::Component::IRC::Plugin::AutoJoin->new(
356             Channels => \%ajoin,
357             RejoinOnKick => $ccfg->opts->{Chan_RetryAfterKick} // 1,
358             Rejoin_delay => $ccfg->opts->{Chan_RejoinDelay} // 5,
359             NickServ_delay => $ccfg->opts->{Chan_NickServDelay} // 1,
360 0   0       Retry_when_banned => $ccfg->opts->{Chan_RetryAfterBan} // 60,
      0        
      0        
      0        
361             ),
362             );
363              
364             ## define ctcp responses
365 0   0       $irc->plugin_add('CTCP' =>
366             POE::Component::IRC::Plugin::CTCP->new(
367             version => "Bot::Cobalt ".core->version." (perl $^V) ".core->url,
368             userinfo => "I'm a teapot",
369             clientinfo => __PACKAGE__.'-'.(__PACKAGE__->VERSION // 'vcs'),
370             source => core->url,
371             ),
372             );
373              
374             ## register for all events from the component
375 0           $irc->yield(register => 'all');
376             ## initiate ze connection:
377 0           $irc->yield(connect => {});
378              
379 0           logger->debug("irc component connect issued");
380             }
381              
382              
383             ### IRC event 'relay' to our pipeline.
384              
385             sub irc_connected {
386 0     0 0   my ($self, $kernel, $server) = @_[OBJECT, KERNEL, ARG0];
387              
388             ## irc_connected indicates we're connected to the server
389             ## however, irc_001 is the server welcome message
390             ## irc_connected happens before auth, no guarantee we can send yet.
391             ## (we don't broadcast Bot_connected until irc_001)
392 0           logger->debug("Received irc_connected for $server");
393             }
394              
395             sub irc_001 {
396 0     0 0   my ($self, $heap, $kernel) = @_[OBJECT, HEAP, KERNEL];
397              
398 0           my $context = $heap->{Context};
399 0           my $irc = $self->ircobjs->{$context};
400              
401             ## set up some stuff relevant to our server context:
402 0           irc_context($context)->connected(1);
403 0           irc_context($context)->connectedat( time );
404 0   0       irc_context($context)->maxmodes( $irc->isupport('MODES') // 4 );
405 0   0       irc_context($context)->maxtargets( $irc->isupport('MAXTARGETS') // 4 );
406              
407             ## irc comes with odd case-mapping rules.
408             ## []\~ are considered uppercase equivalents of {}|^
409             ##
410             ## this may vary by server
411             ## (most servers are rfc1459, some are -strict, some are ascii)
412             ##
413             ## we can tell eq_irc/uc_irc/lc_irc to do the right thing by
414             ## checking ISUPPORT and setting the casemapping if available
415 0   0       my $casemap = lc( $irc->isupport('CASEMAPPING') || 'rfc1459' );
416 0           irc_context($context)->casemap( $casemap );
417              
418             ## if the server returns a fubar value IRC::Utils automagically
419             ## defaults to rfc1459 casemapping rules
420             ##
421             ## this is unavoidable in some situations, however:
422             ## misconfigured inspircd on paradoxirc gave a codepage for CASEMAPPING
423             ## and a casemapping for CHARSET (which is supposed to be deprecated)
424             ##
425             ## I strongly suspect there are other similarly broken servers around.
426             ## para has since fixed this after extensive whining on my part \o/
427             ##
428             ## we can try to check for this, but it's still a crapshoot.
429             ##
430             ## this 'fix' will still break when CASEMAPPING is nonsense and CHARSET
431             ## is set to 'ascii' but other casemapping rules are being followed.
432             ##
433             ## the better fix is to smack your admins with a hammer.
434 0           my @valid_casemaps = qw/ rfc1459 ascii strict-rfc1459 /;
435 0 0         unless (grep { $_ eq $casemap } @valid_casemaps) {
  0            
436 0   0       my $charset = lc( $irc->isupport('CHARSET') || '' );
437 0 0 0       if ($charset && grep { $_ eq $charset } @valid_casemaps) {
  0            
438 0           irc_context($context)->casemap( $charset );
439             }
440             ## we don't save CHARSET, it's deprecated per the spec
441             ## also mostly unreliable and meaningless
442             ## you're on your own for handling fubar encodings.
443             ## http://www.irc.org/tech_docs/draft-brocklesby-irc-isupport-03.txt
444             }
445              
446             ## May have configured umodes to set:
447 0           my $pcfg = core->cfg->plugins->plugin( plugin_alias($self) );
448 0           my $thiscfg = $pcfg->opts->{Networks}->{$context};
449              
450 0 0         if (my $umode = $thiscfg->{Umodes}) {
451 0           logger->debug("Setting umode $umode on $context");
452 0           $irc->yield('mode', $irc->nick_name => $umode)
453             }
454              
455 0           my $server = $irc->server_name;
456 0           logger->info("Connected: $context: $server");
457              
458             ## send a Bot_connected event with context and visible server name:
459 0           broadcast( 'connected', $context, $server );
460             }
461              
462             sub irc_disconnected {
463 0     0 0   my ($self, $kernel, $server) = @_[OBJECT, KERNEL, ARG0];
464 0           my $context = $_[HEAP]->{Context};
465              
466 0           logger->warn("Disconnected: $context ($server)");
467              
468 0 0         if ( irc_context($context) ) {
469 0           irc_context($context)->connected(0);
470 0           broadcast( 'disconnected', $context, $server );
471             }
472             }
473              
474             sub irc_socketerr {
475 0     0 0   my ($self, $kernel, $err) = @_[OBJECT, KERNEL, ARG0];
476 0           my $context = $_[HEAP]->{Context};
477              
478 0           logger->warn("Socket error: $context: $err");
479              
480 0 0         if ( irc_context($context) ) {
481 0           irc_context($context)->connected(0);
482 0           broadcast( 'server_error', $context, $err );
483             }
484             }
485              
486             sub irc_error {
487 0     0 0   my ($self, $kernel, $reason) = @_[OBJECT, KERNEL, ARG0];
488 0           my $context = $_[HEAP]->{Context};
489              
490 0           logger->warn("IRC error: $context: $reason");
491              
492 0 0         if ( irc_context($context) ) {
493 0           irc_context($context)->connected(0);
494 0           broadcast( 'server_error', $context, $reason );
495             }
496             }
497              
498             sub irc_chan_sync {
499 0     0 0   my ($self, $heap, $chan) = @_[OBJECT, HEAP, ARG0];
500              
501 0           my $context = $heap->{Context};
502 0           my $irc = $self->ircobjs->{$context};
503              
504 0           my $resp = core->rpl( q{RPL_CHAN_SYNC},
505             { 'chan' => $chan }
506             );
507              
508 0           broadcast( 'chan_sync', $context, $chan );
509              
510 0           my $cf_core = core->get_core_cfg();
511 0 0 0       my $notify = ($cf_core->opts->{NotifyOnSync} //= 1) ? 1 : 0 ;
512 0   0       my $chan_h = core->cfg->channels->context( $context ) || {};
513             ## check if we have a specific setting for this channel (override):
514             $notify = $chan_h->{$chan}->{notify_on_sync}
515             if exists $chan_h->{$chan}
516             and reftype $chan_h->{$chan} eq 'HASH'
517 0 0 0       and exists $chan_h->{$chan}->{notify_on_sync};
      0        
518              
519 0 0         $irc->yield(privmsg => $chan => $resp) if $notify;
520             }
521              
522             sub irc_ctcp_action {
523 0     0 0   my ($self, $heap, $kernel) = @_[OBJECT, HEAP, KERNEL];
524 0           my ($src, $target, $txt) = @_[ARG0 .. ARG2];
525              
526 0           my $context = $heap->{Context};
527 0           my $irc = $self->ircobjs->{$context};
528              
529 0           my $casemap = core->get_irc_casemap($context);
530 0           for my $mask ( core->ignore->list($context) ) {
531 0 0         return if matches_mask( $mask, $src, $casemap );
532             }
533              
534 0           my $msg_obj = Bot::Cobalt::IRC::Message->new(
535             context => $context,
536             src => $src,
537             targets => $target,
538             message => $txt,
539             );
540              
541 0           broadcast( 'ctcp_action', $msg_obj );
542             }
543              
544             sub irc_invite {
545 0     0 0   my ($self, $kernel, $heap) = @_[OBJECT, KERNEL, HEAP];
546 0           my ($src, $channel) = @_[ARG0, ARG1];
547              
548 0           my $context = $heap->{Context};
549 0           my $irc = $self->ircobjs->{$context};
550              
551 0           my $invite = Bot::Cobalt::IRC::Event::Channel->new(
552             context => $context,
553             src => $src,
554             channel => $channel,
555             );
556              
557             ## Bot_invited
558 0           broadcast( 'invited', $invite );
559             }
560              
561             sub irc_join {
562 0     0 0   my ($self, $kernel, $heap) = @_[OBJECT, KERNEL, HEAP];
563 0           my ($src, $channel) = @_[ARG0, ARG1];
564              
565 0           my $context = $heap->{Context};
566 0           my $irc = $self->ircobjs->{$context};
567              
568 0           my $join = Bot::Cobalt::IRC::Event::Channel->new(
569             context => $context,
570             src => $src,
571             channel => $channel,
572             );
573              
574 0           my $me = $irc->nick_name();
575 0           my $casemap = core->get_irc_casemap($context);
576 0 0         if ( eq_irc($me, $join->src_nick, $casemap) ) {
577 0           broadcast( 'self_joined', $context, $channel );
578             }
579              
580             ## Bot_user_joined
581 0           broadcast( 'user_joined', $join );
582             }
583              
584             sub irc_kick {
585 0     0 0   my ($self, $kernel, $heap) = @_[OBJECT, KERNEL, HEAP];
586 0           my ($src, $channel, $target, $reason) = @_[ARG0 .. ARG3];
587              
588 0           my $context = $heap->{Context};
589 0           my $irc = $self->ircobjs->{$context};
590              
591 0           my $kick = Bot::Cobalt::IRC::Event::Kick->new(
592             context => $context,
593             channel => $channel,
594             src => $src,
595             kicked => $target,
596             reason => $reason,
597             );
598              
599 0           my $me = $irc->nick_name();
600 0           my $casemap = core->get_irc_casemap($context);
601 0 0         if ( eq_irc($me, $kick->src_nick, $casemap) ) {
602             ## Bot_self_kicked:
603 0           broadcast( 'self_kicked', $context, $src, $channel, $reason );
604             }
605              
606             ## Bot_user_kicked:
607 0           broadcast( 'user_kicked', $kick );
608             }
609              
610             sub irc_mode {
611 0     0 0   my ($self, $kernel, $heap) = @_[OBJECT, KERNEL, HEAP];
612 0           my ($src, $changed_on, $modestr, @modeargs) = @_[ ARG0 .. $#_ ];
613              
614 0           my $context = $heap->{Context};
615 0           my $irc = $self->ircobjs->{$context};
616              
617 0           my $mode_obj = Bot::Cobalt::IRC::Event::Mode->new(
618             context => $context,
619             src => $src,
620             target => $changed_on,
621             mode => $modestr,
622             args => [ @modeargs ],
623             );
624              
625 0 0         if ( $mode_obj->is_umode ) {
626 0           broadcast( 'umode_changed', $mode_obj );
627             return
628 0           }
629             ## otherwise it's mostly safe to assume mode changed on a channel
630             ## could check by grabbing isupport('CHANTYPES') and checking against
631             ## is_valid_chan_name from IRC::Utils, f.ex:
632             ## my $chantypes = $self->irc->isupport('CHANTYPES') || '#&';
633             ## is_valid_chan_name($changed_on, [ split '', $chantypes ]) ? 1 : 0;
634             ## ...but afaik this Should Be Fine:
635 0           broadcast( 'mode_changed', $mode_obj);
636             }
637              
638             sub irc_msg {
639 0     0 0   my ($self, $heap, $kernel) = @_[OBJECT, HEAP, KERNEL];
640 0           my ($src, $target, $txt) = @_[ARG0 .. ARG2];
641              
642 0           my $context = $heap->{Context};
643 0           my $irc = $self->ircobjs->{$context};
644              
645 0           my $casemap = core->get_irc_casemap( $context );
646 0           for my $mask ( core->ignore->list($context) ) {
647 0 0         return if matches_mask( $mask, $src, $casemap );
648             }
649              
650 0 0         if ( $self->flood->check($context, $src) ) {
651 0           my $nick = parse_user($src);
652 0 0         $self->flood_ignore($context, $src)
653             unless core->auth->level($context, $nick);
654             return
655 0           }
656              
657 0           my $msg_obj = Bot::Cobalt::IRC::Message->new(
658             context => $context,
659             src => $src,
660             targets => $target,
661             message => $txt,
662             );
663              
664 0           broadcast( 'private_msg', $msg_obj );
665             }
666              
667             sub irc_nick {
668 0     0 0   my ($self, $kernel, $heap) = @_[OBJECT, KERNEL, HEAP];
669 0           my ($src, $new, $common) = @_[ARG0 .. ARG2];
670              
671 0           my $context = $heap->{Context};
672 0           my $irc = $self->ircobjs->{$context};
673              
674             ## see if it's our nick that changed, send event:
675 0 0         if ($new eq $irc->nick_name) {
676 0           broadcast( 'self_nick_changed', $context, $new );
677             return
678 0           }
679              
680 0           my $nchg = Bot::Cobalt::IRC::Event::Nick->new(
681             context => $context,
682             src => $src,
683             new_nick => $new,
684             channels => $common,
685             );
686              
687             ## Bot_nick_changed
688 0           broadcast( 'nick_changed', $nchg );
689             }
690              
691             sub irc_notice {
692 0     0 0   my ($self, $heap, $kernel) = @_[OBJECT, HEAP, KERNEL];
693 0           my ($src, $target, $txt) = @_[ARG0 .. ARG2];
694              
695 0           my $context = $heap->{Context};
696 0           my $irc = $self->ircobjs->{$context};
697              
698 0           my $casemap = core->get_irc_casemap($context);
699 0           for my $mask ( core->ignore->list($context) ) {
700 0 0         return if matches_mask( $mask, $src, $casemap );
701             }
702              
703 0           my $msg_obj = Bot::Cobalt::IRC::Message->new(
704             context => $context,
705             src => $src,
706             targets => $target,
707             message => $txt,
708             );
709              
710 0           broadcast( 'got_notice', $msg_obj );
711             }
712              
713             sub irc_part {
714 0     0 0   my ($self, $kernel, $heap) = @_[OBJECT, KERNEL, HEAP];
715 0           my ($src, $channel, $msg) = @_[ARG0 .. ARG2];
716              
717 0           my $context = $heap->{Context};
718 0           my $irc = $self->ircobjs->{$context};
719              
720 0           my $part = Bot::Cobalt::IRC::Event::Channel->new(
721             context => $context,
722             src => $src,
723             channel => $channel,
724             );
725              
726 0           my $me = $irc->nick_name();
727 0           my $casemap = core->get_irc_casemap($context);
728             ## shouldfix? we could try an 'eq' here ... but is a part issued by
729             ## force methods going to be guaranteed the same case ... ?
730 0 0         if ( eq_irc($me, $part->src_nick, $casemap) ) {
731             ## we were the issuer of the part -- possibly via /remove, perhaps?
732             ## (autojoin might bring back us back, though)
733 0           broadcast( 'self_left', $context, $channel );
734             }
735              
736             ## Bot_user_left
737 0           broadcast( 'user_left', $part );
738             }
739              
740             sub irc_public {
741 0     0 0   my ($self, $heap, $kernel) = @_[OBJECT, HEAP, KERNEL];
742 0           my ($src, $where, $txt) = @_[ ARG0 .. ARG2 ];
743              
744 0           my $context = $heap->{Context};
745 0           my $irc = $self->ircobjs->{$context};
746              
747 0           my $casemap = core->get_irc_casemap( $context );
748 0           for my $mask ( core->ignore->list($context) ) {
749             ## Check against ignore list
750             ## (Ignore list should be keyed by hostmask)
751 0 0         return if matches_mask( $mask, $src, $casemap );
752             }
753              
754 0           my $msg_obj = Bot::Cobalt::IRC::Message::Public->new(
755             context => $context,
756             src => $src,
757             targets => $where,
758             message => $txt,
759             );
760              
761             my $floodchk = sub {
762 0 0   0     if ( $self->flood->check(@_) ) {
763 0           $self->flood_ignore($context, $src);
764 0           return 1
765             }
766 0           };
767              
768             ## Bot_public_msg / Bot_public_cmd_$cmd
769             ## FloodChk cmds and highlights
770 0 0         if (my $cmd = $msg_obj->cmd) {
    0          
771              
772 0 0         $floodchk->($context, $src) ?
773             return
774             : broadcast( 'public_cmd_'.$cmd, $msg_obj);
775              
776             } elsif ($msg_obj->highlight) {
777              
778 0 0         $floodchk->($context, $src) ?
779             return
780             : broadcast( 'public_msg', $msg_obj);
781              
782             } else {
783             ## In the interests of keeping memory usage low on a
784             ## large channel, we don't flood-check every incoming public
785             ## message; plugins that respond to these may want to create
786             ## their own Bot::Cobalt::IRC::FloodChk
787 0           broadcast( 'public_msg', $msg_obj );
788             }
789             }
790              
791             sub irc_quit {
792 0     0 0   my ($self, $kernel, $heap) = @_[OBJECT, KERNEL, HEAP];
793 0           my ($src, $msg, $common) = @_[ARG0 .. ARG2];
794              
795 0           my $context = $heap->{Context};
796 0           my $irc = $self->ircobjs->{$context};
797              
798 0           my $quit = Bot::Cobalt::IRC::Event::Quit->new(
799             context => $context,
800             src => $src,
801             reason => $msg,
802             common => $common,
803             );
804              
805             ## Bot_user_quit
806 0           broadcast( 'user_quit', $quit );
807             }
808              
809             sub irc_snotice {
810 0     0 0   my ($self, $heap, $kernel) = @_[OBJECT, HEAP, KERNEL];
811              
812 0           my $context = $heap->{Context};
813              
814             ## These are weird.
815             ## There should be at least a string.
816 0           my ($string, $target, $sender) = @_[ARG0 .. ARG2];
817              
818             ## FIXME test / POD
819 0           broadcast( 'server_notice', $context, $string, $target, $sender );
820             }
821              
822             sub irc_topic {
823 0     0 0   my ($self, $kernel, $heap) = @_[OBJECT, KERNEL, HEAP];
824 0           my ($src, $channel, $topic) = @_[ARG0 .. ARG2];
825              
826 0           my $context = $heap->{Context};
827 0           my $irc = $self->ircobjs->{$context};
828              
829 0           my $topic_obj = Bot::Cobalt::IRC::Event::Topic->new(
830             context => $context,
831             src => $src,
832             channel => $channel,
833             topic => $topic,
834             );
835              
836             ## Bot_topic_changed
837 0           broadcast( 'topic_changed', $topic_obj );
838             }
839              
840              
841             ### Internals.
842              
843             sub Bot_rehashed {
844 0     0 0   my ($self, $core) = splice @_, 0, 2;
845 0           my $type = ${ $_[0] };
  0            
846              
847 0 0 0       if ($type eq 'core' || $type eq 'channels') {
848 0           logger->info("Rehash received ($type), resetting ajoins");
849 0           $self->_reset_ajoins;
850             }
851              
852             ## FIXME nickservid rehash if needed
853              
854 0           return PLUGIN_EAT_NONE
855             }
856              
857             sub Bot_ircplug_chk_floodkey_expire {
858 0     0 0   my ($self, $core) = splice @_, 0, 2;
859              
860             ## Lazy flood tracker cleanup.
861             ## These are just arrays of timestamps, but they gotta be cleaned up
862             ## when they're stale.
863              
864 0 0         $self->flood->expire if $self->has_flood;
865              
866 0           $core->timer_set( 60,
867             { Event => 'ircplug_chk_floodkey_expire' },
868             'IRCPLUG_CHK_FLOODKEY_EXPIRE'
869             );
870              
871 0           return PLUGIN_EAT_ALL
872             }
873              
874             sub Bot_ircplug_flood_rem_ignore {
875 0     0 0   my ($self, $core) = splice @_, 0, 2;
876 0           my $context = ${ $_[0] };
  0            
877 0           my $mask = ${ $_[1] };
  0            
878             ## Internal timer-fired event to remove temp ignores.
879              
880 0           logger->info("Clearing temp ignore: $mask ($context)");
881              
882 0           $core->ignore->del( $context, $mask );
883              
884 0           broadcast( 'flood_ignore_deleted', $context, $mask );
885              
886 0           return PLUGIN_EAT_ALL
887             }
888              
889             sub flood_ignore {
890             ## Pass me a context and a mask
891             ## Set a temporary ignore and a timer to remove it
892 0     0 0   my ($self, $context, $mask) = @_;
893              
894 0           my $corecf = core->get_core_cfg;
895 0   0       my $ignore_time = $corecf->opts->{FloodIgnore} || 20;
896              
897 0           $self->flood->clear($context, $mask);
898              
899 0           logger->info(
900             "Issuing temporary ignore due to flood: $mask ($context)"
901             );
902              
903 0           my $added = core->ignore->add(
904             $context, $mask, "flood_ignore", __PACKAGE__
905             );
906              
907 0           broadcast( 'flood_ignore_added', $context, $mask );
908              
909 0           core->timer_set( $ignore_time,
910             {
911             Event => 'ircplug_flood_rem_ignore',
912             Args => [ $context, $mask ],
913             },
914             );
915             }
916              
917             sub _reset_ajoins {
918 0     0     my ($self) = @_;
919              
920 0           my $corecf = core->get_core_cfg;
921 0           my $servers = core->Servers;
922              
923 0           CONTEXT: for my $context (keys %$servers) {
924 0   0       my $chanscf = core->get_channels_cfg($context) // {};
925              
926 0   0       my $irc = core->get_irc_obj($context) || next CONTEXT;
927              
928 0           my %ajoin;
929              
930 0           CHAN: for my $channel (keys %$chanscf) {
931 0   0       my $key = $chanscf->{$channel}->{password} // '';
932 0           $ajoin{$channel} = $key;
933             }
934              
935 0           logger->debug("Removing AutoJoin plugin for $context");
936 0           $irc->plugin_del('AutoJoin');
937              
938 0           logger->debug("Loading new AutoJoin plugin for $context");
939             $irc->plugin_add('AutoJoin' =>
940             POE::Component::IRC::Plugin::AutoJoin->new(
941             Channels => \%ajoin,
942             RejoinOnKick => $corecf->opts->{Chan_RetryAfterKick} // 1,
943             Rejoin_delay => $corecf->opts->{Chan_RejoinDelay} // 5,
944             NickServ_delay => $corecf->opts->{Chan_NickServDelay} // 1,
945 0   0       Retry_when_banned => $corecf->opts->{Chan_RetryAfterBan} // 60,
      0        
      0        
      0        
946             ),
947             );
948              
949             }
950              
951             }
952              
953             1;
954             __END__