src/core.pl

   1 #
   2 #   core.pl: Important functions stuff...
   3 #    Author: dms
   4 #   Version: v0.4 (20000718)
   5 #   Created: 20000322
   6 #
   7
   8 use strict;
   9
  10 # scalar. MUST BE REDUCED IN SIZE!!!
  11 ### TODO: reorder.
  12 use vars qw(
  13         $bot_misc_dir $bot_pid $bot_base_dir $bot_src_dir
  14         $bot_data_dir $bot_config_dir $bot_state_dir $bot_run_dir
  15         $answer $correction_plausible $talkchannel $bot_release
  16         $statcount $memusage $user $memusageOld $bot_version $dbh
  17         $shm $host $msg $noreply $conn $irc $learnok $nick $ident
  18         $force_public_reply $addrchar $userHandle $addressedother
  19         $floodwho $chan $msgtime $server $firsttime $wingaterun
  20         $flag_quit $msgType $no_syscall
  21         $utime_userfile $wtime_userfile $ucount_userfile
  22         $utime_chanfile $wtime_chanfile $ucount_chanfile
  23         $pubsize $pubcount $pubtime
  24         $msgsize $msgcount $msgtime
  25         $notsize $notcount $nottime
  26         $running
  27 );
  28
  29 # array.
  30 use vars qw(@ircServers @wingateBad @wingateNow @wingateCache
  31 );
  32
  33 ### hash. MUST BE REDUCED IN SIZE!!!
  34 #
  35 use vars qw(%count %netsplit %netsplitservers %flood %dcc %orig
  36             %nuh %talkWho %seen %floodwarn %param %dbh %ircPort
  37             %topic %moduleAge %last %time %mask %file
  38             %forked %chanconf %channels %cache
  39 );
  40
  41 # Signals.
  42 $SIG{'HUP'}  = 'restart'; #  1.
  43 $SIG{'INT'}  = 'doExit';  #  2.
  44 $SIG{'KILL'} = 'doExit';  #  9. DOES NOT WORK. 'man perlipc' for details.
  45 $SIG{'TERM'} = 'doExit';  # 15.
  46 $SIG{'__WARN__'} = 'doWarn';
  47
  48 # initialize variables.
  49 $last{buflen}   = 0;
  50 $last{say}      = "";
  51 $last{msg}      = "";
  52 $userHandle     = "_default";
  53 $wingaterun     = time();
  54 $firsttime      = 1;
  55 $utime_userfile = 0;
  56 $wtime_userfile = 0;
  57 $ucount_userfile = 0;
  58 $utime_chanfile = 0;
  59 $wtime_chanfile = 0;
  60 $ucount_chanfile = 0;
  61 $running        = 0;
  62 ### more variables...
  63 # static scalar variables.
  64 $mask{ip}       = '(\d+)\.(\d+)\.(\d+)\.(\d+)';
  65 $mask{host}     = '[\d\w\_\-\/]+\.[\.\d\w\_\-\/]+';
  66 $mask{chan}     = '[\#\&]\S*|_default';
  67 my $isnick1     = 'a-zA-Z\[\]\{\}\_\`\^\|\\\\';
  68 my $isnick2     = '0-9\-';
  69 $mask{nick}     = "[$isnick1]{1}[$isnick1$isnick2]*";
  70 $mask{nuh}      = '\S*!\S*\@\S*';
  71 $msgtime        = time();
  72 $msgsize        = 0;
  73 $msgcount       = 0;
  74 $pubtime        = 0;
  75 $pubsize        = 0;
  76 $pubcount       = 0;
  77 $nottime        = 0;
  78 $notsize        = 0;
  79 $notcount       = 0;
  80 ###
  81 $bot_release    = "1.3.3";
  82 if ( -d "CVS" ) {
  83     use POSIX qw(strftime);
  84     $bot_release        .= strftime(" cvs (%Y%m%d)", gmtime( (stat("CVS"))[9] ) );
  85 }
  86 $bot_version    = "blootbot $bot_release -- $^O";
  87 $noreply        = "NOREPLY";
  88
  89 ##########
  90 ### misc commands.
  91 ###
  92
  93 sub whatInterface {
  94     if (!&IsParam("Interface") or $param{'Interface'} =~ /IRC/) {
  95         return "IRC";
  96     } else {
  97         return "CLI";
  98     }
  99 }
 100
 101 sub doExit {
 102     my ($sig)   = @_;
 103
 104     if (defined $flag_quit) {
 105         &WARN("doExit: quit already called.");
 106         return;
 107     }
 108     $flag_quit  = 1;
 109
 110     if (!defined $bot_pid) {    # independent.
 111         exit 0;
 112     } elsif ($bot_pid == $$) {  # parent.
 113         &status("parent caught SIG$sig (pid $$).") if (defined $sig);
 114
 115         &status("--- Start of quit.");
 116         $ident ||= "blootbot";  # lame hack.
 117
 118         &status("Memory Usage: $memusage KiB");
 119
 120         &closePID();
 121         &closeStats();
 122         # shutdown IRC and related components.
 123         if (&whatInterface() =~ /IRC/) {
 124             &closeDCC();
 125             &seenFlush();
 126             &quit($param{'quitMsg'});
 127         }
 128         &writeUserFile();
 129         &writeChanFile();
 130         &uptimeWriteFile()      if (&IsChanConf('Uptime'));
 131         &sqlCloseDB();
 132         &closeSHM($shm);
 133
 134         if (&IsParam("dumpvarsAtExit")) {
 135             &loadMyModule('DumpVars');
 136             &dumpallvars();
 137         }
 138         &symdumpAll()           if (&IsParam("symdumpAtExit"));
 139         &closeLog();
 140         &closeSQLDebug()        if (&IsParam("SQLDebug"));
 141
 142         &status("--- QUIT.");
 143     } else {                                    # child.
 144         &status("child caught SIG$sig (pid $$).");
 145     }
 146
 147     exit 0;
 148 }
 149
 150 sub doWarn {
 151     $SIG{__WARN__} = sub { warn $_[0]; };
 152
 153     foreach (@_) {
 154         &WARN("PERL: $_");
 155     }
 156
 157     $SIG{__WARN__} = 'doWarn';  # ???
 158 }
 159
 160 # Usage: &IsParam($param);
 161 # blootbot.config specific.
 162 sub IsParam {
 163     my $param = $_[0];
 164
 165     return 0 unless (defined $param);
 166     return 0 unless (exists $param{$param});
 167     return 0 unless ($param{$param});
 168     return 0 if $param{$param} =~ /^false$/i;
 169     return 1;
 170 }
 171
 172 #####
 173 #  Usage: &ChanConfList($param)
 174 #  About: gets channels with 'param' enabled. (!!!)
 175 # Return: array of channels
 176 sub ChanConfList {
 177     my $param   = $_[0];
 178     return unless (defined $param);
 179     my %chan    = &getChanConfList($param);
 180
 181     if (exists $chan{_default}) {
 182         return keys %chanconf;
 183     } else {
 184         return keys %chan;
 185     }
 186 }
 187
 188 #####
 189 #  Usage: &getChanConfList($param)
 190 #  About: gets channels with 'param' enabled, internal use only.
 191 # Return: hash of channels
 192 sub getChanConfList {
 193     my $param   = $_[0];
 194     my %chan;
 195
 196     return unless (defined $param);
 197
 198     foreach (keys %chanconf) {
 199         my $chan        = $_;
 200 #       &DEBUG("chan => $chan");
 201         my @array       = grep /^$param$/, keys %{ $chanconf{$chan} };
 202
 203         next unless (scalar @array);
 204
 205         if (scalar @array > 1) {
 206             &WARN("multiple items found?");
 207         }
 208
 209         if ($array[0] eq "0") {
 210             $chan{$chan}        = -1;
 211         } else {
 212             $chan{$chan}        =  1;
 213         }
 214     }
 215
 216     return %chan;
 217 }
 218
 219 #####
 220 #  Usage: &IsChanConf($param);
 221 #  About: Check for 'param' on the basis of channel config.
 222 # Return: 1 for enabled, 0 for passive disable, -1 for active disable.
 223 sub IsChanConf {
 224     my($param)  = shift;
 225     my $debug   = 0;    # knocked tons of bugs with this! :)
 226
 227     if (!defined $param) {
 228         &WARN("IsChanConf: param == NULL.");
 229         return 0;
 230     }
 231
 232     # should we use IsParam() externally where needed or hack it in
 233     # here just in case? fix it later.
 234     if (&IsParam($param)) {
 235         &DEBUG("ICC: found '$param' option in main config file.");
 236         return 1;
 237     }
 238
 239     $chan       ||= "_default";
 240
 241     my $old = $chan;
 242     if ($chan =~ tr/A-Z/a-z/) {
 243         &WARN("IsChanConf: lowercased chan. ($old)");
 244     }
 245
 246     ### TODO: VERBOSITY on how chanconf returned 1 or 0 or -1.
 247     my %chan    = &getChanConfList($param);
 248     my $nomatch = 0;
 249     if (!defined $msgType) {
 250         $nomatch++;
 251     } else {
 252         $nomatch++ if ($msgType eq "");
 253         $nomatch++ unless ($msgType =~ /^(public|private)$/i);
 254     }
 255
 256 ### debug purposes only.
 257 #    &DEBUG("param => $param, msgType => $msgType.");
 258 #    foreach (keys %chan) {
 259 #       &DEBUG("   $_ => $chan{$_}");
 260 #    }
 261
 262     if ($nomatch) {
 263         if ($chan{$chan}) {
 264             &DEBUG("ICC: other: $chan{$chan} (_default/$param)") if ($debug);
 265         } elsif ($chan{_default}) {
 266             &DEBUG("ICC: other: $chan{_default} (_default/$param)") if ($debug);
 267         } else {
 268             &DEBUG("ICC: other: 0 ($param)") if ($debug);
 269         }
 270
 271         return $chan{$chan} || $chan{_default} || 0;
 272     }
 273
 274     if ($msgType eq "public") {
 275         if ($chan{$chan}) {
 276             &DEBUG("ICC: public: $chan{$chan} ($chan/$param)") if ($debug);
 277         } elsif ($chan{_default}) {
 278             &DEBUG("ICC: public: $chan{_default} (_default/$param)") if ($debug);
 279         } else {
 280             &DEBUG("ICC: public: 0 ($param)") if ($debug);
 281         }
 282
 283         return $chan{$chan} || $chan{_default} || 0;
 284     }
 285
 286     if ($msgType eq "private") {
 287         if ($chan{_default}) {
 288             &DEBUG("ICC: private: $chan{_default} (_default/$param)") if ($debug);
 289         } elsif ($chan{$chan}) {
 290             &DEBUG("ICC: private: $chan{$chan} ($chan/$param) (hack)") if ($debug);
 291         } else {
 292             &DEBUG("ICC: private: 0 ($param)") if ($debug);
 293         }
 294
 295         return $chan{$chan} || $chan{_default} || 0;
 296     }
 297
 298     &DEBUG("ICC: no-match: 0/$param (msgType = $msgType)");
 299
 300     return 0;
 301 }
 302
 303 #####
 304 #  Usage: &getChanConf($param);
 305 #  About: Retrieve value for 'param' value in current/default chan.
 306 # Return: scalar for success, undef for failure.
 307 sub getChanConf {
 308     my($param,$c)       = @_;
 309
 310     if (!defined $param) {
 311         &WARN("gCC: param == NULL.");
 312         return 0;
 313     }
 314
 315     # this looks evil...
 316     if (0 and !defined $chan) {
 317         &DEBUG("gCC: ok !chan... doing _default instead.");
 318     }
 319
 320     $c          ||= $chan;
 321     $c          ||= "_default";
 322     $c          = "_default" if ($c eq "*");    # FIXME
 323     my @c       = grep /^\Q$c\E$/i, keys %chanconf;
 324
 325     if (@c) {
 326         if (0 and $c[0] ne $c) {
 327             &WARN("c ne chan ($c[0] ne $chan)");
 328         }
 329         if (!defined $chanconf{$c[0]}{$param} and ($c ne '_default')) {
 330             return &getChanConf($param, '_default');
 331         }
 332         #&DEBUG("gCC: $param,$c \"" . $chanconf{$c[0]}{$param} . '"');
 333         return $chanconf{$c[0]}{$param};
 334     }
 335
 336     #&DEBUG("gCC: returning _default... " . $chanconf{"_default"}{$param});
 337     return $chanconf{"_default"}{$param};
 338 }
 339
 340 sub getChanConfDefault {
 341     my($what, $default, $chan) = @_;
 342
 343     $chan       ||= "_default";
 344
 345     if (exists $param{$what}) {
 346         if (!exists $cache{config}{$what}) {
 347             &status("config ($chan): backward-compatible option: found param{$what} ($param{$what}) instead of chan option");
 348             $cache{config}{$what} = 1;
 349         }
 350
 351         return $param{$what};
 352     }
 353     my $val = &getChanConf($what, $chan);
 354     return $val if (defined $val);
 355
 356     $param{$what}       = $default;
 357     &status("config ($chan): auto-setting param{$what} = $default");
 358     $cache{config}{$what} = 1;
 359     return $default;
 360 }
 361
 362
 363 #####
 364 #  Usage: &findChanConf($param);
 365 #  About: Retrieve value for 'param' value from any chan.
 366 # Return: scalar for success, undef for failure.
 367 sub findChanConf {
 368     my($param)  = @_;
 369
 370     if (!defined $param) {
 371         &WARN("param == NULL.");
 372         return 0;
 373     }
 374
 375     my $c;
 376     foreach $c (keys %chanconf) {
 377         foreach (keys %{ $chanconf{$c} }) {
 378             next unless (/^$param$/);
 379
 380             return $chanconf{$c}{$_};
 381         }
 382     }
 383
 384     return;
 385 }
 386
 387 sub showProc {
 388     my ($prefix) = $_[0] || "";
 389
 390     if ($^O eq "linux") {
 391         if (!open(IN, "/proc/$$/status")) {
 392             &ERROR("cannot open '/proc/$$/status'.");
 393             return;
 394         }
 395
 396         while (<IN>) {
 397             $memusage = $1 if (/^VmSize:\s+(\d+) kB/);
 398         }
 399         close IN;
 400
 401     } elsif ($^O eq "netbsd") {
 402         $memusage = int( (stat "/proc/$$/mem")[7]/1024 );
 403
 404     } elsif ($^O =~ /^(free|open)bsd$/) {
 405         my @info  = split /\s+/, `/bin/ps -l -p $$`;
 406         $memusage = $info[20];
 407
 408     } else {
 409         $memusage = "UNKNOWN";
 410         return;
 411     }
 412
 413     if (defined $memusageOld and &IsParam("DEBUG")) {
 414         # it's always going to be increase.
 415         my $delta = $memusage - $memusageOld;
 416         my $str;
 417         if ($delta == 0) {
 418             return;
 419         } elsif ($delta > 500) {
 420             $str = "MEM:$prefix increased by $delta KiB. (total: $memusage KiB)";
 421         } elsif ($delta > 0) {
 422             $str = "MEM:$prefix increased by $delta KiB";
 423         } else {        # delta < 0.
 424             $delta = -$delta;
 425             # never knew RSS could decrease, probably Size can't?
 426             $str = "MEM:$prefix decreased by $delta KiB.";
 427         }
 428
 429         &status($str);
 430     }
 431     $memusageOld = $memusage;
 432 }
 433
 434 ######
 435 ###### SETUP
 436 ######
 437
 438 sub setup {
 439     &showProc(" (\&openLog before)");
 440     &openLog();         # write, append.
 441     &status("--- Started logging.");
 442
 443     # read.
 444     &loadLang($bot_data_dir. "/blootbot.lang");
 445     &loadIRCServers();
 446     &readUserFile();
 447     &readChanFile();
 448     &loadMyModulesNow();        # must be after chan file.
 449
 450     $shm = &openSHM();
 451     &openSQLDebug()     if (&IsParam("SQLDebug"));
 452     &sqlOpenDB($param{'DBName'}, $param{'DBType'}, $param{'SQLUser'},
 453         $param{'SQLPass'});
 454     &checkTables();
 455
 456     &status("Setup: ". &countKeys("factoids") ." factoids.");
 457     &getChanConfDefault("sendPrivateLimitLines", 3);
 458     &getChanConfDefault("sendPrivateLimitBytes", 1000);
 459     &getChanConfDefault("sendPublicLimitLines", 3);
 460     &getChanConfDefault("sendPublicLimitBytes", 1000);
 461     &getChanConfDefault("sendNoticeLimitLines", 3);
 462     &getChanConfDefault("sendNoticeLimitBytes", 1000);
 463
 464     $param{tempDir} =~ s#\~/#$ENV{HOME}/#;
 465
 466     &status("Initial memory usage: $memusage KiB");
 467     &status("-------------------------------------------------------");
 468 }
 469
 470 sub setupConfig {
 471     $param{'VERBOSITY'} = 1;
 472     &loadConfig($bot_config_dir."/blootbot.config");
 473
 474     foreach ( qw(ircNick ircUser ircName DBType tempDir) ) {
 475         next if &IsParam($_);
 476         &ERROR("Parameter $_ has not been defined.");
 477         exit 1;
 478     }
 479
 480     if ($param{tempDir} =~ s#\~/#$ENV{HOME}/#) {
 481         &VERB("Fixing up tempDir.",2);
 482     }
 483
 484     if ($param{tempDir} =~ /~/) {
 485         &ERROR("parameter tempDir still contains tilde.");
 486         exit 1;
 487     }
 488
 489     if (! -d $param{tempDir}) {
 490         &status("making $param{tempDir}...");
 491         mkdir $param{tempDir}, 0755;
 492     }
 493
 494     # static scalar variables.
 495     $file{utm}  = "$bot_state_dir/$param{'ircUser'}.uptime";
 496     $file{PID}  = "$bot_run_dir/$param{'ircUser'}.pid";
 497 }
 498
 499 sub startup {
 500     if (&IsParam("DEBUG")) {
 501         &status("enabling debug diagnostics.");
 502         # I thought disabling this reduced memory usage by 1000 KiB.
 503         use diagnostics;
 504     }
 505
 506     $count{'Question'}  = 0;
 507     $count{'Update'}    = 0;
 508     $count{'Dunno'}     = 0;
 509     $count{'Moron'}     = 0;
 510 }
 511
 512 sub shutdown {
 513     my ($sig) = @_;
 514     # reverse order of &setup().
 515     &status("--- shutdown called.");
 516
 517     # hack.
 518     $ident ||=  "blootbot";
 519
 520     if (!&isFileUpdated("$bot_state_dir/blootbot.users", $wtime_userfile)) {
 521         &writeUserFile()
 522     }
 523
 524     if (!&isFileUpdated("$bot_state_dir/blootbot.chan", $wtime_chanfile)) {
 525         &writeChanFile();
 526     }
 527
 528     &sqlCloseDB();
 529     # aswell. TODO: use this in &doExit?
 530     &closeSHM($shm);
 531     &closeLog();
 532 }
 533
 534 sub restart {
 535     my ($sig) = @_;
 536
 537     if ($$ == $bot_pid) {
 538         &status("--- $sig called.");
 539
 540         ### crappy bug in Net::IRC?
 541         my $delta = time() - $msgtime;
 542         &DEBUG("restart: dtime = $delta");
 543         if (!$conn->connected or time() - $msgtime > 900) {
 544             &status("reconnecting because of uncaught disconnect \@ ".scalar(gmtime) );
 545 ###         $irc->start;
 546             &clearIRCVars();
 547             $conn->connect();
 548 ###         return;
 549         }
 550
 551         &ircCheck();    # heh, evil!
 552
 553         &DCCBroadcast("-HUP called.","m");
 554         &shutdown($sig);
 555         &loadConfig($bot_config_dir."/blootbot.config");
 556         &reloadAllModules() if (&IsParam("DEBUG"));
 557         &setup();
 558
 559         &status("--- End of $sig.");
 560     } else {
 561         &status("$sig called; ignoring restart.");
 562     }
 563 }
 564
 565 # File: Configuration.
 566 sub loadConfig {
 567     my ($file) = @_;
 568
 569     if (!open(FILE, $file)) {
 570         &ERROR("Failed to read configuration file ($file): $!");
 571         &status("Please read the INSTALL file on how to install and setup this file.");
 572         exit 0;
 573     }
 574
 575     my $count = 0;
 576     while (<FILE>) {
 577         chomp;
 578         next if /^\s*\#/;
 579         next unless /\S/;
 580         my ($set,$key,$val) = split(/\s+/, $_, 3);
 581
 582         if ($set ne "set") {
 583             &status("loadConfig: invalid line '$_'.");
 584             next;
 585         }
 586
 587         # perform variable interpolation
 588         $val =~ s/(\$(\w+))/$param{$2}/g;
 589
 590         $param{$key} = $val;
 591
 592         ++$count;
 593     }
 594     close FILE;
 595
 596     $file =~ s/^.*\///;
 597     &status("Loaded config $file ($count items)");
 598 }
 599
 600 1;