src/IRC/Schedulers.pl

   1 #
   2 # ProcessExtra.pl: Extensions to Process.pl
   3 #          Author: dms
   4 #         Version: v0.5 (20010124)
   5 #         Created: 20000117
   6 #
   7
   8 # use strict;   # TODO
   9
  10 use POSIX qw(strftime);
  11 use vars qw(%sched %schedule);
  12
  13 # format: function name = (
  14 #       str     chanconfdefault,
  15 #       int     internaldefault,
  16 #       bool    deferred,
  17 #       int     next run,               (optional)
  18 # )
  19
  20 #%schedule = {
  21 #       uptimeLoop => ('', 60, 1),
  22 #};
  23
  24 sub setupSchedulersII {
  25     foreach (keys %schedule) {
  26         &queueTask($_, @{ $schedule{$_} });
  27     }
  28 }
  29
  30 sub queueTask {
  31     my($codename, $chanconfdef, $intervaldef, $defer) = @_;
  32     my $t = &getChanConfDefault($chanconfdef, $intervaldef, $chan);
  33     my $waittime = &getRandomInt($t);
  34
  35     if (!defined $waittime) {
  36         &WARN("interval == waittime == UNDEF for $codename.");
  37         return;
  38     }
  39
  40     my $time = $schedule{$codename}[3];
  41     if (defined $time and $time > time()) {
  42         &WARN("Sched for $codename already exists in " . &Time2String(time() - $time) . ".");
  43         return;
  44     }
  45
  46     #&VERB("Scheduling \&$codename() for " . &Time2String($waittime),3);
  47
  48     my $retval = $conn->schedule($waittime, sub {
  49                 \&$codename;
  50     }, @args );
  51 }
  52
  53 sub setupSchedulers {
  54     &VERB( 'Starting schedulers...', 2 );
  55
  56     # ONCE OFF.
  57
  58     # REPETITIVE.
  59     # 2 for on next-run.
  60     &randomQuote(2);
  61     &randomFactoid(2);
  62     &seenFlush(2);
  63     &leakCheck(2);    # mandatory
  64     &seenFlushOld(2);
  65     &miscCheck2(2);    # mandatory
  66     &slashdotLoop(2);
  67     &plugLoop(2);
  68     &kernelLoop(2);
  69     &wingateWriteFile(2);
  70     &factoidCheck(2);    # takes a couple of seconds on a 486. defer it
  71
  72     # TODO: convert to new format... or nuke altogether.
  73     &newsFlush(2);
  74     &rssFeeds(2);
  75
  76     # 1 for run straight away
  77     &uptimeLoop(1);
  78     &logLoop(1);
  79     &chanlimitCheck(1);
  80     &netsplitCheck(1);    # mandatory
  81     &floodLoop(1);        # mandatory
  82     &ignoreCheck(1);      # mandatory
  83     &miscCheck(1);        # mandatory
  84     &shmFlush(1);         # mandatory
  85     sleep 1;
  86     &ircCheck(1);         # mandatory
  87
  88     # TODO: squeeze this into a one-liner.
  89     #    my $count = map { exists $sched{$_}{TIME} } keys %sched;
  90     my $count = 0;
  91     foreach ( keys %sched ) {
  92         my $time = $sched{$_}{TIME};
  93         next unless ( defined $time and $time > time() );
  94
  95         $count++;
  96     }
  97
  98     &status("Schedulers: $count will be running.");
  99     &scheduleList();
 100 }
 101
 102 sub ScheduleThis {
 103     my ( $interval, $codename, @args ) = @_;
 104
 105    # Set to supllied value plus a random 0-60 seconds to avoid simultaneous runs
 106     my $waittime =
 107       &getRandomInt( "$interval-" . ( $interval + &getRandomInt(60) ) );
 108
 109     if ( !defined $waittime ) {
 110         &WARN("interval == waittime == UNDEF for $codename.");
 111         return;
 112     }
 113
 114     my $time = $sched{$codename}{TIME};
 115     if ( defined $time and $time > time() ) {
 116         &WARN(  "Sched for $codename already exists in "
 117               . &Time2String( time() - $time )
 118               . '.' );
 119         return;
 120     }
 121
 122     &DEBUG(
 123         "Scheduling \&$codename() "
 124           . \&$codename . ' for '
 125           . &Time2String($waittime),
 126         3
 127     );
 128
 129     my $retval = $conn->schedule( $waittime, \&$codename, @args );
 130     $sched{$codename}{LABEL} = $retval;
 131     $sched{$codename}{TIME}  = time() + $waittime;
 132     $sched{$codename}{LOOP}  = 1;
 133 }
 134
 135 ####
 136 #### LET THE FUN BEGIN.
 137 ####
 138
 139 sub rssFeeds {
 140     my $interval = $param{'rssFeedTime'} || 30;
 141     if (@_) {
 142         &ScheduleThis( $interval * 60, 'rssFeeds' );    # minutes
 143         return if ( $_[0] eq '2' );                     # defer.
 144     }
 145     &Forker(
 146         'RSSFeeds',
 147         sub {
 148             my $line = &RSSFeeds::RSS();
 149             return unless ( defined $line );
 150
 151         }
 152     );
 153 }
 154
 155 sub randomQuote {
 156     my $interval = &getChanConfDefault( 'randomQuoteInterval', 60, $chan );
 157     if (@_) {
 158         &ScheduleThis( $interval * 60, 'randomQuote' );    # every hour
 159         return if ( $_[0] eq '2' );                        # defer.
 160     }
 161
 162     foreach ( &ChanConfList('randomQuote') ) {
 163         next unless ( &validChan($_) );
 164
 165         my $line =
 166           &getRandomLineFromFile( $bot_data_dir . '/infobot.randtext' );
 167         if ( !defined $line ) {
 168             &ERROR('random Quote: weird error?');
 169             return;
 170         }
 171
 172         &status("sending random Quote to $_.");
 173         &action( $_, 'Ponders: ' . $line );
 174     }
 175     ### TODO: if there were no channels, don't reschedule until channel
 176     ###         configuration is modified.
 177 }
 178
 179 sub randomFactoid {
 180     my ( $key, $val );
 181     my $error = 0;
 182
 183     my $interval = &getChanConfDefault( 'randomFactoidInterval', 60, $chan );
 184     if (@_) {
 185         &ScheduleThis( $interval * 60, 'randomFactoid' );    # minutes
 186         return if ( $_[0] eq '2' );                          # defer.
 187     }
 188
 189     foreach ( &ChanConfList('randomFactoid') ) {
 190         next unless ( &validChan($_) );
 191
 192         &status("sending random Factoid to $_.");
 193         while (1) {
 194             ( $key, $val ) =
 195               &randKey( 'factoids', 'factoid_key,factoid_value' );
 196             &DEBUG("rF: $key, $val");
 197 ###         $val =~ tr/^[A-Z]/[a-z]/;   # blah is Good => blah is good.
 198             last
 199               if (  ( defined $val )
 200                 and ( $val !~ /^</ )
 201                 and ( $key !~ /\#DEL\#/ )
 202                 and ( $key !~ /^cmd:/ ) );
 203
 204             $error++;
 205             if ( $error == 5 ) {
 206                 &ERROR('rF: tried 5 times but failed.');
 207                 return;
 208             }
 209         }
 210         &action( $_, "Thinks: \037$key\037 is $val" );
 211         ### FIXME: Use &getReply() on above to format factoid properly?
 212         $good++;
 213     }
 214 }
 215
 216 sub logLoop {
 217     if (@_) {
 218         &ScheduleThis( 3600, 'logLoop' );    # 1 hour
 219         return if ( $_[0] eq '2' );          # defer.
 220     }
 221
 222     return unless ( defined fileno LOG );
 223     return unless ( &IsParam('logfile') );
 224     return unless ( &IsParam('maxLogSize') );
 225
 226     ### check if current size is too large.
 227     if ( -s $file{log} > $param{'maxLogSize'} ) {
 228         my $date = sprintf( '%04d%02d%02d', (gmtime)[ 5, 4, 3 ] );
 229         $file{log} = $param{'logfile'} . '-' . $date;
 230         &status('cycling log file.');
 231
 232         if ( -e $file{log} ) {
 233             my $i = 1;
 234             my $newlog;
 235             while () {
 236                 $newlog = $file{log} . '-' . $i;
 237                 last if ( !-e $newlog );
 238                 $i++;
 239             }
 240             $file{log} = $newlog;
 241         }
 242
 243         &closeLog();
 244         CORE::system("/bin/mv '$param{'logfile'}' '$file{log}'");
 245         &compress( $file{log} );
 246         &openLog();
 247         &status('cycling log file.');
 248     }
 249
 250     ### check if all the logs exceed size.
 251     if ( !opendir( LOGS, $bot_log_dir ) ) {
 252         &WARN("logLoop: could not open dir '$bot_log_dir'");
 253         return;
 254     }
 255
 256     my $tsize = 0;
 257     my ( %age, %size );
 258     while ( defined( $_ = readdir LOGS ) ) {
 259         my $logfile = "$bot_log_dir/$_";
 260
 261         next unless ( -f $logfile );
 262
 263         my $size = -s $logfile;
 264         my $age  = ( stat $logfile )[9];
 265         $age{$age}      = $logfile;
 266         $size{$logfile} = $size;
 267         $tsize += $size;
 268     }
 269     closedir LOGS;
 270
 271     my $delete = 0;
 272     while ( $tsize > $param{'maxLogSize'} ) {
 273         &status("LOG: current size > max ($tsize > $param{'maxLogSize'})");
 274         my $oldest = ( sort { $a <=> $b } keys %age )[0];
 275         &status("LOG: unlinking $age{$oldest}.");
 276         unlink $age{$oldest};
 277         $tsize -= $oldest;
 278         $delete++;
 279     }
 280
 281     ### TODO: add how many b,kb,mb removed?
 282     &status("LOG: removed $delete logs.") if ($delete);
 283 }
 284
 285 sub seenFlushOld {
 286     if (@_) {
 287         &ScheduleThis( 86400, 'seenFlushOld' );    # 1 day
 288         return if ( $_[0] eq '2' );                # defer.
 289     }
 290
 291     # is this global-only?
 292     return unless ( &IsChanConf('seen') > 0 );
 293     return unless ( &IsChanConf('seenFlushInterval') > 0 );
 294
 295     # global setting. does not make sense for per-channel.
 296     my $max_time =
 297       &getChanConfDefault( 'seenMaxDays', 30, $chan ) * 60 * 60 * 24;
 298     my $delete = 0;
 299
 300     if ( $param{'DBType'} =~ /^(pgsql|mysql|sqlite(2)?)$/i ) {
 301         my $query;
 302
 303         if ( $param{'DBType'} =~ /^mysql$/i ) {
 304             $query =
 305                 'SELECT nick,time FROM seen GROUP BY nick HAVING '
 306               . "UNIX_TIMESTAMP() - time > $max_time";
 307         }
 308         elsif ( $param{'DBType'} =~ /^sqlite(2)?$/i ) {
 309             $query =
 310                 'SELECT nick,time FROM seen GROUP BY nick HAVING '
 311               . "strftime('%s','now','localtime') - time > $max_time";
 312         }
 313         else {    # pgsql.
 314             $query =
 315                 'SELECT nick,time FROM seen WHERE '
 316               . "extract(epoch from timestamp 'now') - time > $max_time";
 317         }
 318
 319         my $sth = $dbh->prepare($query);
 320         if ( $sth->execute ) {
 321             while ( my @row = $sth->fetchrow_array ) {
 322                 my ( $nick, $time ) = @row;
 323
 324                 &sqlDelete( 'seen', { nick => $nick } );
 325                 $delete++;
 326             }
 327             $sth->finish;
 328         }
 329     }
 330     else {
 331         &FIXME( 'seenFlushOld: for bad DBType:' . $param{'DBType'} . '.' );
 332     }
 333     &VERB( "SEEN deleted $delete seen entries.", 2 );
 334
 335 }
 336
 337 sub newsFlush {
 338     if (@_) {
 339         &ScheduleThis( 3600, 'newsFlush' );    # 1 hour
 340         return if ( $_[0] eq '2' );            # defer.
 341     }
 342
 343     if ( !&ChanConfList('News') ) {
 344         &DEBUG("newsFlush: news disabled? (chan => $chan)");
 345         return;
 346     }
 347
 348     my $delete = 0;
 349     my $oldest = time();
 350     my %none;
 351     foreach $chan ( keys %::news ) {
 352         my $i     = 0;
 353         my $total = scalar( keys %{ $::news{$chan} } );
 354
 355         if ( !$total ) {
 356             delete $::news{$chan};
 357             next;
 358         }
 359
 360         foreach $item ( keys %{ $::news{$chan} } ) {
 361             my $t = $::news{$chan}{$item}{Expire};
 362
 363             my $tadd = $::news{$chan}{$item}{Time};
 364             $oldest = $tadd if ( $oldest > $tadd );
 365
 366             next if ( $t == 0 or $t == -1 );
 367             if ( $t < 1000 ) {
 368                 &status(
 369 "newsFlush: Fixed Expire time for $chan/$item, should not happen anyway."
 370                 );
 371                 $::news{$chan}{$item}{Expire} = time() + $t * 60 * 60 * 24;
 372                 next;
 373             }
 374
 375             my $delta = $t - time();
 376
 377             next unless ( time() > $t );
 378
 379             # TODO: show how old it was.
 380             delete $::news{$chan}{$item};
 381             &status("NEWS: (newsflush) deleted '$item'");
 382             $delete++;
 383             $i++;
 384         }
 385
 386         &status("NEWS (newsflush) {$chan}: deleted [$i/$total] news entries.")
 387           if ($i);
 388         $none{$chan} = 1 if ( $total == $i );
 389     }
 390
 391     # TODO: flush users aswell.
 392     my $duser = 0;
 393     foreach $chan ( keys %::newsuser ) {
 394         next if ( exists $none{$chan} );
 395
 396         foreach ( keys %{ $::newsuser{$chan} } ) {
 397             my $t = $::newsuser{$chan}{$_};
 398             if ( !defined $t or ( $t > 2 and $t < 1000 ) ) {
 399                 &DEBUG("something wrong with newsuser{$chan}{$_} => $t");
 400                 next;
 401             }
 402
 403             next unless ( $oldest > $t );
 404
 405             delete $::newsuser{$chan}{$_};
 406             $duser++;
 407         }
 408
 409         my $i = scalar( keys %{ $::newsuser{$chan} } );
 410         delete $::newsuser{$chan} unless ($i);
 411     }
 412
 413     if ( $delete or $duser ) {
 414         &status("NewsFlush: deleted: $delete news entries; $duser user cache.");
 415     }
 416 }
 417
 418 sub chanlimitCheck {
 419     my $interval = &getChanConfDefault( 'chanlimitcheckInterval', 10, $chan );
 420     my $mynick = $conn->nick();
 421
 422     if (@_) {
 423         &ScheduleThis( $interval * 60, 'chanlimitCheck' );  # default 10 minutes
 424         return if ( $_[0] eq '2' );
 425     }
 426
 427     my $str = join( ' ', &ChanConfList('chanlimitcheck') );
 428
 429     foreach $chan ( &ChanConfList('chanlimitcheck') ) {
 430         next unless ( &validChan($chan) );
 431
 432         if ( $chan eq '_default' ) {
 433             &WARN("chanlimit: we're doing $chan!! HELP ME!");
 434             next;
 435         }
 436
 437         my $limitplus = &getChanConfDefault( 'chanlimitcheckPlus', 5, $chan );
 438         my $newlimit  = scalar( keys %{ $channels{$chan}{''} } ) + $limitplus;
 439         my $limit     = $channels{$chan}{'l'};
 440
 441         if ( scalar keys %netsplitservers ) {
 442             if ( defined $limit ) {
 443                 &status("chanlimit: netsplit; removing it for $chan.");
 444                 $conn->mode( $chan, '-l' );
 445                 $cache{chanlimitChange}{$chan} = time();
 446                 &status('chanlimit: netsplit; removed.');
 447             }
 448
 449             next;
 450         }
 451
 452         if ( defined $limit and scalar keys %{ $channels{$chan}{''} } > $limit )
 453         {
 454             &FIXME('LIMIT: set too low!!!');
 455             ### run NAMES again and flush it.
 456         }
 457
 458         if ( defined $limit and $limit == $newlimit ) {
 459             $cache{chanlimitChange}{$chan} = time();
 460             next;
 461         }
 462
 463         if ( !exists $channels{$chan}{'o'}{$mynick} ) {
 464             &status("chanlimit: dont have ops on $chan.")
 465               unless ( exists $cache{warn}{chanlimit}{$chan} );
 466             $cache{warn}{chanlimit}{$chan} = 1;
 467             &chanServCheck($chan);
 468             next;
 469         }
 470         delete $cache{warn}{chanlimit}{$chan};
 471
 472         if ( !defined $limit ) {
 473             &status(
 474                 "chanlimit: $chan: setting for first time or from netsplit.");
 475         }
 476
 477         if ( exists $cache{chanlimitChange}{$chan} ) {
 478             my $delta = time() - $cache{chanlimitChange}{$chan};
 479             if ( $delta < $interval * 60 ) {
 480                 &DEBUG(
 481 "chanlimit: not going to change chanlimit! ($delta<$interval*60)"
 482                 );
 483                 return;
 484             }
 485         }
 486
 487         $conn->mode( $chan, '+l', $newlimit );
 488         $cache{chanlimitChange}{$chan} = time();
 489     }
 490 }
 491
 492 sub netsplitCheck {
 493     my ( $s1, $s2 );
 494
 495     if (@_) {
 496         &ScheduleThis( 300, 'netsplitCheck' );    # every 5 minutes
 497         return if ( $_[0] eq '2' );
 498     }
 499
 500     $cache{'netsplitCache'}++;
 501
 502     #    &DEBUG("running netsplitCheck... $cache{netsplitCache}");
 503
 504     if ( !scalar %netsplit and scalar %netsplitservers ) {
 505         &DEBUG('nsC: !hash netsplit but hash netsplitservers <- removing!');
 506         undef %netsplitservers;
 507         return;
 508     }
 509
 510     # well... this shouldn't happen since %netsplit code does it anyway.
 511     foreach $s1 ( keys %netsplitservers ) {
 512
 513         foreach $s2 ( keys %{ $netsplitservers{$s1} } ) {
 514             my $delta = time() - $netsplitservers{$s1}{$s2};
 515
 516             if ( $delta > 60 * 30 ) {
 517                 &status("netsplit between $s1 and $s2 appears to be stale.");
 518                 delete $netsplitservers{$s1}{$s2};
 519                 &chanlimitCheck();
 520             }
 521         }
 522
 523         my $i = scalar( keys %{ $netsplitservers{$s1} } );
 524         delete $netsplitservers{$s1} unless ($i);
 525     }
 526
 527     # %netsplit hash checker.
 528     my $count  = scalar keys %netsplit;
 529     my $delete = 0;
 530     foreach ( keys %netsplit ) {
 531         if ( &IsNickInAnyChan($_) ) {    # why would this happen?
 532
 533           #         &DEBUG("nsC: $_ is in some chan; removing from netsplit list.");
 534             delete $netsplit{$_};
 535             $delete++;
 536             next;
 537         }
 538
 539         next unless ( time() - $netsplit{$_} > 60 * 15 );
 540
 541         $delete++;
 542         delete $netsplit{$_};
 543     }
 544
 545 # yet another hack.
 546 # FIXED: $ch should be used rather than $chan since it creates NULL channels in the hash
 547     foreach my $ch ( keys %channels ) {
 548         my $i = $cache{maxpeeps}{$ch} || 0;
 549         my $j = scalar( keys %{ $channels{$ch} } );
 550         next unless ( $i > 10 and 0.25 * $i > $j );
 551
 552         &DEBUG("netsplit: 0.25*max($i) > current($j); possible netsplit?");
 553     }
 554
 555     if ($delete) {
 556         my $j = scalar( keys %netsplit );
 557         &status("nsC: removed from netsplit list: (before: $count; after: $j)");
 558     }
 559
 560     if ( !scalar %netsplit and scalar %netsplitservers ) {
 561         &DEBUG('nsC: ok hash netsplit is NULL; purging hash netsplitservers');
 562         undef %netsplitservers;
 563     }
 564
 565     if ( $count and !scalar keys %netsplit ) {
 566         &DEBUG('nsC: netsplit is hopefully gone. reinstating chanlimit check.');
 567         &chanlimitCheck();
 568     }
 569 }
 570
 571 sub floodLoop {
 572     my $delete = 0;
 573     my $who;
 574
 575     if (@_) {
 576         &ScheduleThis( 60, 'floodLoop' );    # 1 minute
 577         return if ( $_[0] eq '2' );
 578     }
 579
 580     my $time = time();
 581     my $interval = &getChanConfDefault( 'floodCycle', 60, $chan );
 582
 583     foreach $who ( keys %flood ) {
 584         foreach ( keys %{ $flood{$who} } ) {
 585             if ( !exists $flood{$who}{$_} ) {
 586                 &WARN("flood{$who}{$_} undefined?");
 587                 next;
 588             }
 589
 590             if ( $time - $flood{$who}{$_} > $interval ) {
 591                 delete $flood{$who}{$_};
 592                 $delete++;
 593             }
 594         }
 595     }
 596     &VERB( "floodLoop: deleted $delete items.", 2 );
 597 }
 598
 599 sub seenFlush {
 600     if (@_) {
 601         my $interval = &getChanConfDefault( 'seenFlushInterval', 60, $chan );
 602         &ScheduleThis( $interval * 60, 'seenFlush' );    # minutes
 603         return if ( $_[0] eq '2' );
 604     }
 605
 606     my %stats;
 607     my $nick;
 608     my $flushed = 0;
 609     $stats{'count_old'} = &countKeys('seen') || 0;
 610     $stats{'new'}       = 0;
 611     $stats{'old'}       = 0;
 612
 613     if ( $param{'DBType'} =~ /^(mysql|pgsql|sqlite(2)?)$/i ) {
 614         foreach $nick ( keys %seencache ) {
 615             my $retval = &sqlSet(
 616                 'seen',
 617                 { 'nick' => lc $seencache{$nick}{'nick'} },
 618                 {
 619                     time    => $seencache{$nick}{'time'},
 620                     host    => $seencache{$nick}{'host'},
 621                     channel => $seencache{$nick}{'chan'},
 622                     message => $seencache{$nick}{'msg'},
 623                 }
 624             );
 625
 626             delete $seencache{$nick};
 627             $flushed++;
 628         }
 629     }
 630     else {
 631         &DEBUG('seenFlush: NO VALID FACTOID SUPPORT?');
 632     }
 633
 634     &status("Seen: Flushed $flushed entries.") if ($flushed);
 635     &VERB(
 636         sprintf(
 637             '  new seen: %03.01f%% (%d/%d)',
 638             $stats{'new'} * 100 / ( $stats{'count_old'} || 1 ),
 639             $stats{'new'},
 640             ( $stats{'count_old'} || 1 )
 641         ),
 642         2
 643     ) if ( $stats{'new'} );
 644     &VERB(
 645         sprintf(
 646             '  now seen: %3.1f%% (%d/%d)',
 647             $stats{'old'} * 100 / ( &countKeys('seen') || 1 ), $stats{'old'},
 648             &countKeys('seen')
 649         ),
 650         2
 651     ) if ( $stats{'old'} );
 652
 653     &WARN('scalar keys seenflush != 0!') if ( scalar keys %seenflush );
 654 }
 655
 656 sub leakCheck {
 657     my ( $blah1, $blah2 );
 658     my $count = 0;
 659
 660     if (@_) {
 661         &ScheduleThis( 14400, 'leakCheck' );    # every 4 hours
 662         return if ( $_[0] eq '2' );
 663     }
 664
 665     # flood. this is dealt with in floodLoop()
 666     foreach $blah1 ( keys %flood ) {
 667         foreach $blah2 ( keys %{ $flood{$blah1} } ) {
 668             $count += scalar( keys %{ $flood{$blah1}{$blah2} } );
 669         }
 670     }
 671     &VERB( "leak: hash flood has $count total keys.", 2 );
 672
 673     # floodjoin.
 674     $count = 0;
 675     foreach $blah1 ( keys %floodjoin ) {
 676         foreach $blah2 ( keys %{ $floodjoin{$blah1} } ) {
 677             $count += scalar( keys %{ $floodjoin{$blah1}{$blah2} } );
 678         }
 679     }
 680     &VERB( "leak: hash floodjoin has $count total keys.", 2 );
 681
 682     # floodwarn.
 683     $count = scalar( keys %floodwarn );
 684     &VERB( "leak: hash floodwarn has $count total keys.", 2 );
 685
 686     my $chan;
 687     foreach $chan ( grep /[A-Z]/, keys %channels ) {
 688         &DEBUG("leak: chan => '$chan'.");
 689         my ( $i, $j );
 690         foreach $i ( keys %{ $channels{$chan} } ) {
 691             foreach ( keys %{ $channels{$chan}{$i} } ) {
 692                 &DEBUG("leak:   \$channels{$chan}{$i}{$_} ...");
 693             }
 694         }
 695     }
 696
 697     # chanstats
 698     $count = scalar( keys %chanstats );
 699     &VERB( "leak: hash chanstats has $count total keys.", 2 );
 700
 701     # nuh.
 702     my $delete = 0;
 703     foreach ( keys %nuh ) {
 704         next if ( &IsNickInAnyChan($_) );
 705         next if ( exists $dcc{CHAT}{$_} );
 706
 707         delete $nuh{$_};
 708         $delete++;
 709     }
 710
 711     &status(
 712         "leak: $delete nuh{} items deleted; now have " . scalar( keys %nuh ) )
 713       if ($delete);
 714 }
 715
 716 sub ignoreCheck {
 717     if (@_) {
 718         &ScheduleThis( 60, 'ignoreCheck' );    # once every minute
 719         return if ( $_[0] eq '2' );            # defer.
 720     }
 721
 722     my $time  = time();
 723     my $count = 0;
 724
 725     foreach ( keys %ignore ) {
 726         my $chan = $_;
 727
 728         foreach ( keys %{ $ignore{$chan} } ) {
 729             my @array = @{ $ignore{$chan}{$_} };
 730
 731             next unless ( $array[0] and $time > $array[0] );
 732
 733             delete $ignore{$chan}{$_};
 734             &status("ignore: $_/$chan has expired.");
 735             $count++;
 736         }
 737     }
 738
 739     $cache{ignoreCheckTime} = time();
 740
 741     &VERB( "ignore: $count items deleted.", 2 );
 742 }
 743
 744 sub ircCheck {
 745     if (@_) {
 746         &ScheduleThis( 300, 'ircCheck' );    # every 5 minutes
 747         return if ( $_[0] eq '2' );          # defer.
 748     }
 749
 750     $cache{statusSafe} = 1;
 751     foreach ( sort keys %conns ) {
 752         $conn = $conns{$_};
 753         my $mynick = $conn->nick();
 754         &DEBUG("ircCheck for $_");
 755         # Display with min of 900sec delay between redisplay
 756         # FIXME: should only use 900sec when we are on the LAST %conns
 757         my @join = &getJoinChans(900);
 758         if ( scalar @join ) {
 759             &FIXME( 'ircCheck: found channels to join! ' . join( ',', @join ) );
 760             &joinNextChan();
 761         }
 762
 763         # TODO: fix on_disconnect()
 764
 765         if ( time() - $msgtime > 3600 ) {
 766
 767             # TODO: shouldn't we use cache{connect} somewhere?
 768             if ( exists $cache{connect} ) {
 769                 &WARN("ircCheck: no msg for 3600 and disco'd! reconnecting!");
 770                 $msgtime = time();    # just in case.
 771                 &ircloop();
 772                 delete $cache{connect};
 773             }
 774             else {
 775                 &status( 'ircCheck: possible lost in space; checking.'
 776                       . scalar(gmtime) );
 777                 &msg( $mynick, 'TEST' );
 778                 $cache{connect} = time();
 779             }
 780         }
 781     }
 782
 783     if ( grep /^\s*$/, keys %channels ) {
 784         &WARN('ircCheck: we have a NULL chan in hash channels? removing!');
 785         if ( !exists $channels{''} ) {
 786             &DEBUG('ircCheck: this should never happen!');
 787         }
 788     }
 789     if ( $ident !~ /^\Q$param{ircNick}\E$/ ) {
 790
 791         # this does not work unfortunately.
 792         &WARN("ircCheck: ident($ident) != param{ircNick}($param{ircNick}).");
 793
 794         # this check is misleading... perhaps we should do a notify.
 795         if ( !&IsNickInAnyChan( $param{ircNick} ) ) {
 796             &DEBUG("$param{ircNick} not in use... changing!");
 797             &nick( $param{ircNick} );
 798         }
 799         else {
 800             &WARN("$param{ircNick} is still in use...");
 801         }
 802     }
 803
 804     $cache{statusSafe} = 0;
 805
 806     ### USER FILE.
 807     if ( $utime_userfile > $wtime_userfile and time() - $wtime_userfile > 3600 )
 808     {
 809         &writeUserFile();
 810         $wtime_userfile = time();
 811     }
 812     ### CHAN FILE.
 813     if ( $utime_chanfile > $wtime_chanfile and time() - $wtime_chanfile > 3600 )
 814     {
 815         &writeChanFile();
 816         $wtime_chanfile = time();
 817     }
 818 }
 819
 820 sub miscCheck {
 821     if (@_) {
 822         &ScheduleThis( 7200, 'miscCheck' );    # every 2 hours
 823         return if ( $_[0] eq '2' );            # defer.
 824     }
 825
 826     # SHM check.
 827     my @ipcs;
 828     if ( -x '/usr/bin/ipcs' ) {
 829         @ipcs = `/usr/bin/ipcs`;
 830     }
 831     else {
 832         &WARN("ircCheck: no 'ipcs' binary.");
 833         return;
 834     }
 835
 836     # make backup of important files.
 837     &mkBackup( $bot_state_dir . '/infobot.chan',    60 * 60 * 24 * 3 );
 838     &mkBackup( $bot_state_dir . '/infobot.users',   60 * 60 * 24 * 3 );
 839     &mkBackup( $bot_base_dir . '/infobot-news.txt', 60 * 60 * 24 * 1 );
 840
 841     # flush cache{lobotomy}
 842     foreach ( keys %{ $cache{lobotomy} } ) {
 843         next unless ( time() - $cache{lobotomy}{$_} > 60 * 60 );
 844         delete $cache{lobotomy}{$_};
 845     }
 846
 847     ### check modules if they've been modified. might be evil.
 848     &reloadAllModules();
 849
 850     # shmid stale remove.
 851     foreach (@ipcs) {
 852         chop;
 853
 854         # key, shmid, owner, perms, bytes, nattch
 855         next unless (/^(0x\d+) (\d+)\s+(\S+)\s+(\d+)\s+(\d+)\s+/);
 856
 857         my ( $shmid, $size ) = ( $2, $5 );
 858         next unless ( $shmid != $shm and $size == 2000 );
 859         my $z = &shmRead($shmid);
 860         if ( $z =~ /^(\S+):(\d+):(\d+): / ) {
 861             my $n    = $1;
 862             my $pid  = $2;
 863             my $time = $3;
 864             next if ( time() - $time < 60 * 60 );
 865
 866             # FIXME remove not-pid shm if parent process dead
 867             next if ( $pid == $bot_pid );
 868
 869             # don't touch other bots, if they're running.
 870             next unless ( $param{ircUser} =~ /^\Q$n\E$/ );
 871         }
 872         else {
 873             &DEBUG("shm: $shmid is not ours or old infobot => ($z)");
 874             next;
 875         }
 876
 877         &status("SHM: nuking shmid $shmid");
 878         CORE::system("/usr/bin/ipcrm shm $shmid >/dev/null");
 879     }
 880 }
 881
 882 sub miscCheck2 {
 883     if (@_) {
 884         &ScheduleThis( 14400, 'miscCheck2' );    # every 4 hours
 885         return if ( $_[0] eq '2' );              # defer.
 886     }
 887
 888     # debian check.
 889     opendir( DEBIAN, "$bot_state_dir/debian" );
 890     foreach ( grep /gz$/, readdir(DEBIAN) ) {
 891         my $exit = CORE::system("gzip -t $bot_state_dir/debian/$_");
 892         next unless ($exit);
 893
 894         &status("debian: unlinking file => $_");
 895         unlink "$bot_state_dir/debian/$_";
 896     }
 897     closedir DEBIAN;
 898
 899     # compress logs that should have been compressed.
 900     # TODO: use strftime?
 901     my ( $day, $month, $year ) = ( gmtime( time() ) )[ 3, 4, 5 ];
 902     my $date = sprintf( '%04d%02d%02d', $year + 1900, $month + 1, $day );
 903
 904     if ( !opendir( DIR, "$bot_log_dir" ) ) {
 905         &ERROR("misccheck2: log dir $bot_log_dir does not exist.");
 906         closedir DIR;
 907         return -1;
 908     }
 909
 910     while ( my $f = readdir(DIR) ) {
 911         next unless ( -f "$bot_log_dir/$f" );
 912         next if ( $f =~ /gz|bz2/ );
 913         next unless ( $f =~ /(\d{8})/ );
 914         next if ( $date eq $1 );
 915
 916         &compress("$bot_log_dir/$f");
 917     }
 918     closedir DIR;
 919 }
 920
 921 ### this is semi-scheduled
 922 sub getNickInUse {
 923
 924     # FIXME: broken for multiple connects
 925     #    if ($ident eq $param{'ircNick'}) {
 926     #   &status('okay, got my nick back.');
 927     #   return;
 928     #    }
 929     #
 930     #    if (@_) {
 931     #   &ScheduleThis(30, 'getNickInUse');
 932     #   return if ($_[0] eq '2');       # defer.
 933     #    }
 934     #
 935     #    &nick( $param{'ircNick'} );
 936 }
 937
 938 sub uptimeLoop {
 939     return if ( !defined &uptimeWriteFile );
 940
 941     #    return unless &IsParam('Uptime');
 942
 943     if (@_) {
 944         &ScheduleThis( 3600, 'uptimeLoop' );    # once per hour
 945         return if ( $_[0] eq '2' );             # defer.
 946     }
 947
 948     &uptimeWriteFile();
 949 }
 950
 951 sub slashdotLoop {
 952
 953     if (@_) {
 954         &ScheduleThis( 3600, 'slashdotLoop' );    # once per hour
 955         return if ( $_[0] eq '2' );
 956     }
 957
 958     my @chans = &ChanConfList('slashdotAnnounce');
 959     return unless ( scalar @chans );
 960
 961     &Forker(
 962         'slashdot',
 963         sub {
 964             my $line = &Slashdot::slashdotAnnounce();
 965             return unless ( defined $line );
 966
 967             foreach (@chans) {
 968                 next unless ( &::validChan($_) );
 969
 970                 &::status("sending slashdot update to $_.");
 971                 &notice( $_, "Slashdot: $line" );
 972             }
 973         }
 974     );
 975 }
 976
 977 sub plugLoop {
 978
 979     if (@_) {
 980         &ScheduleThis( 3600, 'plugLoop' );    # once per hour
 981         return if ( $_[0] eq '2' );
 982     }
 983
 984     my @chans = &ChanConfList('plugAnnounce');
 985     return unless ( scalar @chans );
 986
 987     &Forker(
 988         'Plug',
 989         sub {
 990             my $line = &Plug::plugAnnounce();
 991             return unless ( defined $line );
 992
 993             foreach (@chans) {
 994                 next unless ( &::validChan($_) );
 995
 996                 &::status("sending plug update to $_.");
 997                 &notice( $_, "Plug: $line" );
 998             }
 999         }
1000     );
1001 }
1002
1003 sub kernelLoop {
1004     if (@_) {
1005         &ScheduleThis( 14400, 'kernelLoop' );    # once every 4 hours
1006         return if ( $_[0] eq '2' );
1007     }
1008
1009     my @chans = &ChanConfList('kernelAnnounce');
1010     return unless ( scalar @chans );
1011
1012     &Forker(
1013         'Kernel',
1014         sub {
1015             my @data = &Kernel::kernelAnnounce();
1016
1017             foreach (@chans) {
1018                 next unless ( &::validChan($_) );
1019
1020                 &::status("sending kernel update to $_.");
1021                 my $c = $_;
1022                 foreach (@data) {
1023                     &notice( $c, "Kernel: $_" );
1024                 }
1025             }
1026         }
1027     );
1028 }
1029
1030 sub wingateCheck {
1031     return unless &IsChanConf('Wingate') > 0;
1032
1033     ### FILE CACHE OF OFFENDING WINGATES.
1034     foreach ( grep /^$host$/, @wingateBad ) {
1035         &status("Wingate: RUNNING ON $host BY $who");
1036         &ban( "*!*\@$host", '' ) if &IsChanConf('wingateBan') > 0;
1037
1038         my $reason = &getChanConf('wingateKick');
1039
1040         next unless ($reason);
1041         &kick( $who, '', $reason );
1042     }
1043
1044     ### RUN CACHE OF TRIED WINGATES.
1045     if ( grep /^$host$/, @wingateCache ) {
1046         push( @wingateNow,   $host );    # per run.
1047         push( @wingateCache, $host );    # cache per run.
1048     }
1049     else {
1050         &DEBUG("Already scanned $host. good.");
1051     }
1052
1053     my $interval =
1054       &getChanConfDefault( 'wingateInterval', 60, $chan );    # seconds.
1055     return if ( defined $forked{'Wingate'} );
1056     return if ( time() - $wingaterun <= $interval );
1057     return unless ( scalar( keys %wingateToDo ) );
1058
1059     $wingaterun = time();
1060
1061     &Forker( 'Wingate', sub { &Wingate::Wingates( keys %wingateToDo ); } );
1062     undef @wingateNow;
1063 }
1064
1065 ### TODO: ??
1066 sub wingateWriteFile {
1067     if (@_) {
1068         &ScheduleThis( 3600, 'wingateWriteFile' );    # once per hour
1069         return if ( $_[0] eq '2' );                   # defer.
1070     }
1071
1072     return unless ( scalar @wingateCache );
1073
1074     my $file = "$bot_base_dir/$param{'ircUser'}.wingate";
1075     if ( $bot_pid != $$ ) {
1076         &DEBUG('wingateWriteFile: Reorganising!');
1077
1078         open( IN, $file );
1079         while (<IN>) {
1080             chop;
1081             push( @wingateNow, $_ );
1082         }
1083         close IN;
1084
1085         # very lame hack.
1086         my %hash = map { $_ => 1 } @wingateNow;
1087         @wingateNow = sort keys %hash;
1088     }
1089
1090     &DEBUG('wingateWF: writing...');
1091     open( OUT, ">$file" );
1092     foreach (@wingateNow) {
1093         print OUT "$_\n";
1094     }
1095     close OUT;
1096 }
1097
1098 sub factoidCheck {
1099     if (@_) {
1100         &ScheduleThis( 43200, 'factoidCheck' );    # ever 12 hours
1101         return if ( $_[0] eq '2' );                # defer.
1102     }
1103
1104     my @list =
1105       &searchTable( 'factoids', 'factoid_key', 'factoid_key', ' #DEL#' );
1106     my $stale =
1107       &getChanConfDefault( 'factoidDeleteDelay', 14, $chan ) * 60 * 60 * 24;
1108     if ( $stale < 1 ) {
1109
1110         # disable it since it's 'illegal'.
1111         return;
1112     }
1113
1114     my $time = time();
1115
1116     foreach (@list) {
1117         my $age = &getFactInfo( $_, 'modified_time' );
1118
1119         if ( !defined $age or $age !~ /^\d+$/ ) {
1120             if ( scalar @list > 50 ) {
1121                 if ( !$cache{warnDel} ) {
1122                     &WARN(  'list is over 50 ('
1123                           . scalar(@list)
1124                           . '... giving it a miss.' );
1125                     $cache{warnDel} = 1;
1126                     last;
1127                 }
1128             }
1129
1130             &WARN("del factoid: old cruft (no time): $_");
1131             &delFactoid($_);
1132             next;
1133         }
1134
1135         next unless ( $time - $age > $stale );
1136
1137         my $fix = $_;
1138         $fix =~ s/ #DEL#$//g;
1139         my $agestr = &Time2String( $time - $age );
1140         &status("safedel: Removing '$_' for good. [$agestr old]");
1141
1142         &delFactoid($_);
1143     }
1144 }
1145
1146 sub dccStatus {
1147     return unless ( scalar keys %{ $dcc{CHAT} } );
1148
1149     if (@_) {
1150         &ScheduleThis( 600, 'dccStatus' );    # every 10 minutes
1151         return if ( $_[0] eq '2' );           # defer.
1152     }
1153
1154     my $time = strftime( '%H:%M', gmtime( time() ) );
1155
1156     my $c;
1157     foreach ( keys %channels ) {
1158         my $c     = $_;
1159         my $users = keys %{ $channels{$c}{''} };
1160         my $chops = keys %{ $channels{$c}{o} };
1161         my $bans  = keys %{ $channels{$c}{b} };
1162
1163         my $txt = "[$time] $c: $users members ($chops chops), $bans bans";
1164         foreach ( keys %{ $dcc{'CHAT'} } ) {
1165             next unless ( exists $channels{$c}{''}{ lc $_ } );
1166             $conn->privmsg( $dcc{'CHAT'}{$_}, $txt );
1167         }
1168     }
1169 }
1170
1171 sub scheduleList {
1172     ###
1173     # custom:
1174     #   a - time == now.
1175     #   b - weird time.
1176     ###
1177
1178     my $reply = 'sched:';
1179     foreach ( keys %{ $irc->{_queue} } ) {
1180         my $q       = $_;
1181         my $coderef = $irc->{_queue}->{$q}->[1];
1182         my $sched;
1183         foreach ( keys %sched ) {
1184             my $schedname = $_;
1185             next unless defined( \&$schedname );
1186             next unless ( $coderef eq \&$schedname );
1187             $sched = $schedname;
1188             last;
1189         }
1190
1191         my $time = $irc->{_queue}->{$q}->[0] - time();
1192
1193         if ( defined $sched ) {
1194             $reply = "$reply, $sched($q):" . &Time2String($time);
1195         }
1196         else {
1197             $reply = "$reply, NULL($q):" . &Time2String($time);
1198         }
1199     }
1200
1201     &DEBUG("$reply");
1202 }
1203
1204 sub mkBackup {
1205     my ( $file, $time ) = @_;
1206     my $backup = 0;
1207
1208     if ( !-f $file ) {
1209         &VERB( "mkB: file '$file' does not exist.", 2 );
1210         return;
1211     }
1212
1213     my $age = 'New';
1214     if ( -e "$file~" ) {
1215         $backup++ if ( ( stat $file )[9] - ( stat "$file~" )[9] > $time );
1216         my $delta = time() - ( stat "$file~" )[9];
1217         $age = &Time2String($delta);
1218     }
1219     else {
1220         $backup++;
1221     }
1222
1223     return unless ($backup);
1224
1225     ### TODO: do internal copying.
1226     &status("Backup: $file ($age)");
1227     CORE::system("/bin/cp $file $file~");
1228 }
1229
1230 1;
1231
1232 # vim:ts=4:sw=4:expandtab:tw=80