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 # dynamic 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 # dynamic hash.
  30 use vars qw(@joinchan @ircServers @wingateBad @wingateNow @wingateCache
  31 );
  32
  33 ### dynamic 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
  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 $msgtime        = time();
  64 $msgsize        = 0;
  65 $msgcount       = 0;
  66 $pubtime        = 0;
  67 $pubsize        = 0;
  68 $pubcount       = 0;
  69 $nottime        = 0;
  70 $notsize        = 0;
  71 $notcount       = 0;
  72 ###
  73 if ( -d "CVS" ) {
  74     use POSIX qw(strftime);
  75     $bot_release        = strftime("cvs (%Y%m%d)", localtime( (stat("CVS"))[9] ) );
  76 } else {
  77     $bot_release        = "1.0.10 (2001xxxx)";
  78 }
  79 $bot_version    = "blootbot $bot_release -- $^O";
  80 $noreply        = "NOREPLY";
  81
  82 ##########
  83 ### misc commands.
  84 ###
  85
  86 sub doExit {
  87     my ($sig)   = @_;
  88
  89     if (defined $flag_quit) {
  90         &WARN("doExit: quit already called.");
  91         return;
  92     }
  93     $flag_quit  = 1;
  94
  95     if (!defined $bot_pid) {    # independent.
  96         exit 0;
  97     } elsif ($bot_pid == $$) {  # parent.
  98         &status("parent caught SIG$sig (pid $$).") if (defined $sig);
  99
 100         &status("--- Start of quit.");
 101         $ident ||= "blootbot";  # lame hack.
 102
 103         &closeDCC();
 104         &closePID();
 105         &closeStats();
 106         &seenFlush();
 107         &quit($param{'quitMsg'}) if (&whatInterface() =~ /IRC/);
 108         &writeUserFile();
 109         &writeChanFile();
 110         &uptimeWriteFile()      if (&ChanConfList("uptime"));
 111         &News::writeNews()      if (&ChanConfList("news"));
 112         &closeDB();
 113         &closeSHM($shm);
 114         &dumpallvars()          if (&IsParam("dumpvarsAtExit"));
 115         &closeLog();
 116         &closeSQLDebug()        if (&IsParam("SQLDebug"));
 117
 118         &status("--- QUIT.");
 119     } else {                                    # child.
 120         &status("child caught SIG$sig (pid $$).");
 121     }
 122
 123     exit 0;
 124 }
 125
 126 sub doWarn {
 127     $SIG{__WARN__} = sub { warn $_[0]; };
 128
 129     foreach (@_) {
 130         &WARN("PERL: $_");
 131     }
 132
 133     $SIG{__WARN__} = 'doWarn';  # ???
 134 }
 135
 136 # Usage: &IsParam($param);
 137 # blootbot.config specific.
 138 sub IsParam {
 139     my $param = $_[0];
 140
 141     return 0 unless (defined $param);
 142     return 0 unless (exists $param{$param});
 143     return 0 unless ($param{$param});
 144     return 0 if $param{$param} =~ /^false$/i;
 145     return 1;
 146 }
 147
 148 #####
 149 #  Usage: &ChanConfList($param)
 150 #  About: gets channels with 'param' enabled. (!!!)
 151 # Return: array of channels
 152 sub ChanConfList {
 153     my $param   = $_[0];
 154     return unless (defined $param);
 155     my %chan    = &getChanConfList($param);
 156
 157     if (exists $chan{_default}) {
 158         return keys %chanconf;
 159     } else {
 160         return keys %chan;
 161     }
 162 }
 163
 164 #####
 165 #  Usage: &getChanConfList($param)
 166 #  About: gets channels with 'param' enabled, internal use only.
 167 # Return: hash of channels
 168 sub getChanConfList {
 169     my $param   = $_[0];
 170     my %chan;
 171
 172     return unless (defined $param);
 173
 174     foreach (keys %chanconf) {
 175         my $chan        = $_;
 176 #       &DEBUG("chan => $chan");
 177         my @array       = grep /^$param$/, keys %{ $chanconf{$chan} };
 178
 179         next unless (scalar @array);
 180
 181         if (scalar @array > 1) {
 182             &WARN("multiple items found?");
 183         }
 184
 185         if ($array[0] eq "0") {
 186             $chan{$chan}        = -1;
 187         } else {
 188             $chan{$chan}        =  1;
 189         }
 190     }
 191
 192     return %chan;
 193 }
 194
 195 #####
 196 #  Usage: &IsChanConf($param);
 197 #  About: Check for 'param' on the basis of channel config.
 198 # Return: 1 for enabled, 0 for passive disable, -1 for active disable.
 199 sub IsChanConf {
 200     my($param)  = shift;
 201     my $debug   = 0;    # knocked tons of bugs with this! :)
 202
 203     if (!defined $param) {
 204         &WARN("IsChanConf: param == NULL.");
 205         return 0;
 206     }
 207
 208     $chan       ||= "_default";
 209
 210     my $old = $chan;
 211     if ($chan =~ tr/A-Z/a-z/) {
 212         &WARN("IsChanConf: lowercased chan. ($old)");
 213     }
 214
 215     ### TODO: VERBOSITY on how chanconf returned 1 or 0 or -1.
 216     my %chan    = &getChanConfList($param);
 217     my $nomatch = 0;
 218     if (!defined $msgType) {
 219         $nomatch++;
 220     } else {
 221         $nomatch++ if ($msgType eq "");
 222         $nomatch++ unless ($msgType =~ /^(public|private)$/i);
 223     }
 224
 225 ### debug purposes only.
 226 #    &DEBUG("param => $param, msgType => $msgType.");
 227 #    foreach (keys %chan) {
 228 #       &DEBUG("   $_ => $chan{$_}");
 229 #    }
 230
 231     if ($nomatch) {
 232         if ($chan{$chan}) {
 233             &DEBUG("ICC: other: $chan{$chan} (_default/$param)") if ($debug);
 234         } elsif ($chan{_default}) {
 235             &DEBUG("ICC: other: $chan{_default} (_default/$param)") if ($debug);
 236         } else {
 237             &DEBUG("ICC: other: 0 ($param)") if ($debug);
 238         }
 239
 240         return $chan{$chan} || $chan{_default} || 0;
 241     }
 242
 243     if ($msgType eq "public") {
 244         if ($chan{$chan}) {
 245             &DEBUG("ICC: public: $chan{$chan} ($chan/$param)") if ($debug);
 246         } elsif ($chan{_default}) {
 247             &DEBUG("ICC: public: $chan{_default} (_default/$param)") if ($debug);
 248         } else {
 249             &DEBUG("ICC: public: 0 ($param)") if ($debug);
 250         }
 251
 252         return $chan{$chan} || $chan{_default} || 0;
 253     }
 254
 255     if ($msgType eq "private") {
 256         if ($chan{_default}) {
 257             &DEBUG("ICC: private: $chan{_default} (_default/$param)") if ($debug);
 258         } elsif ($chan{$chan}) {
 259             &DEBUG("ICC: private: $chan{$chan} ($chan/$param) (hack)") if ($debug);
 260         } else {
 261             &DEBUG("ICC: private: 0 ($param)") if ($debug);
 262         }
 263
 264         return $chan{$chan} || $chan{_default} || 0;
 265     }
 266
 267     &DEBUG("ICC: no-match: 0/$param (msgType = $msgType)");
 268
 269     return 0;
 270 }
 271
 272 #####
 273 #  Usage: &getChanConf($param);
 274 #  About: Retrieve value for 'param' value in current/default chan.
 275 # Return: scalar for success, undef for failure.
 276 sub getChanConf {
 277     my($param,$c)       = @_;
 278
 279     if (!defined $param) {
 280         &WARN("param == NULL.");
 281         return 0;
 282     }
 283
 284     # this looks evil...
 285     if (0 and !defined $chan) {
 286         &DEBUG("gCC: ok !chan... doing _default instead.");
 287     }
 288
 289     $c          ||= $chan;
 290     $c          ||= "_default";
 291     $c          = "_default" if ($c eq "*");    # fix!
 292     my @c       = grep /^$c$/i, keys %chanconf;
 293
 294     if (@c) {
 295         if (0 and $c[0] ne $c) {
 296             &WARN("c ne chan ($c[0] ne $chan)");
 297         }
 298         return $chanconf{$c[0]}{$param};
 299     }
 300
 301 #    &DEBUG("gCC: returning _default... ");
 302     return $chanconf{"_default"}{$param};
 303 }
 304
 305 #####
 306 #  Usage: &findChanConf($param);
 307 #  About: Retrieve value for 'param' value from any chan.
 308 # Return: scalar for success, undef for failure.
 309 sub findChanConf {
 310     my($param)  = @_;
 311
 312     if (!defined $param) {
 313         &WARN("param == NULL.");
 314         return 0;
 315     }
 316
 317     my $c;
 318     foreach $c (keys %chanconf) {
 319         foreach (keys %{ $chanconf{$c} }) {
 320             next unless (/^$param$/);
 321
 322             &DEBUG("chanconf{$c}{$_} ...");
 323             return $chanconf{$c}{$_};
 324         }
 325     }
 326
 327     return;
 328 }
 329
 330 sub showProc {
 331     my ($prefix) = $_[0] || "";
 332
 333     if (!open(IN, "/proc/$$/status")) {
 334         &ERROR("cannot open '/proc/$$/status'.");
 335         return;
 336     }
 337
 338     if ($^O eq "linux") {
 339         while (<IN>) {
 340             $memusage = $1 if (/^VmSize:\s+(\d+) kB/);
 341         }
 342         close IN;
 343
 344     } elsif ($^O eq "netbsd") {
 345         $memusage = (stat "/proc/$$/mem")[7]/1024;
 346
 347     } elsif ($^O =~ /^(free|open)bsd$/) {
 348         my @info  = split /\s+/, `/bin/ps -l -p $$`;
 349         $memusage = $info[20];
 350
 351     } else {
 352         $memusage = "UNKNOWN";
 353         return;
 354     }
 355
 356     if (defined $memusageOld and &IsParam("DEBUG")) {
 357         # it's always going to be increase.
 358         my $delta = $memusage - $memusageOld;
 359         my $str;
 360         if ($delta == 0) {
 361             return;
 362         } elsif ($delta > 500) {
 363             $str = "MEM:$prefix increased by $delta kB. (total: $memusage kB)";
 364         } elsif ($delta > 0) {
 365             $str = "MEM:$prefix increased by $delta kB";
 366         } else {        # delta < 0.
 367             $delta = -$delta;
 368             # never knew RSS could decrease, probably Size can't?
 369             $str = "MEM:$prefix decreased by $delta kB. YES YES YES";
 370         }
 371
 372         &status($str);
 373     }
 374     $memusageOld = $memusage;
 375 }
 376
 377 ######
 378 ###### SETUP
 379 ######
 380
 381 sub setup {
 382     &showProc(" (\&openLog before)");
 383     &openLog();         # write, append.
 384     &status("--- Started logging.");
 385
 386     foreach ("debian") {
 387         my $dir = "$bot_base_dir/$_/";
 388         next if ( -d $dir);
 389         &status("Making dir $_");
 390         mkdir $dir, 0755;
 391     }
 392
 393     # read.
 394     &loadLang($bot_data_dir. "/blootbot.lang");
 395     &loadIRCServers();
 396     &readUserFile();
 397     &readChanFile();
 398     &loadMyModulesNow();        # must be after chan file.
 399
 400     $shm = &openSHM();
 401     &openSQLDebug()     if (&IsParam("SQLDebug"));
 402     &openDB($param{'DBName'}, $param{'SQLUser'}, $param{'SQLPass'});
 403     &checkTables();
 404
 405     &status("Setup: ". &countKeys("factoids") ." factoids.");
 406     &News::readNews() if (&ChanConfList("news"));
 407     &getChanConfDefault("sendPrivateLimitLines", 3);
 408     &getChanConfDefault("sendPrivateLimitBytes", 1000);
 409     &getChanConfDefault("sendPublicLimitLines", 3);
 410     &getChanConfDefault("sendPublicLimitBytes", 1000);
 411     &getChanConfDefault("sendNoticeLimitLines", 3);
 412     &getChanConfDefault("sendNoticeLimitBytes", 1000);
 413
 414     $param{tempDir} =~ s#\~/#$ENV{HOME}/#;
 415
 416     &status("Initial memory usage: $memusage kB");
 417     &status("-------------------------------------------------------");
 418 }
 419
 420 sub setupConfig {
 421     $param{'VERBOSITY'} = 1;
 422     &loadConfig($bot_config_dir."/blootbot.config");
 423
 424     foreach ("ircNick", "ircUser", "ircName", "DBType", "tempDir") {
 425         next if &IsParam($_);
 426         &ERROR("Parameter $_ has not been defined.");
 427         exit 1;
 428     }
 429
 430     if ($param{tempDir} =~ s#\~/#$ENV{HOME}/#) {
 431         &VERB("Fixing up tempDir.",2);
 432     }
 433
 434     if ($param{tempDir} =~ /~/) {
 435         &ERROR("parameter tempDir still contains tilde.");
 436         exit 1;
 437     }
 438
 439     if (! -d $param{tempDir}) {
 440         &status("making $param{tempDir}...");
 441         system("mkdir $param{tempDir}");
 442     }
 443
 444     # static scalar variables.
 445     $file{utm}  = "$bot_state_dir/$param{'ircUser'}.uptime";
 446     $file{PID}  = "$bot_run_dir/$param{'ircUser'}.pid";
 447 }
 448
 449 sub startup {
 450     if (&IsParam("DEBUG")) {
 451         &status("enabling debug diagnostics.");
 452         ### I thought disabling this reduced memory usage by 1000 kB.
 453         use diagnostics;
 454     }
 455
 456     $count{'Question'}  = 0;
 457     $count{'Update'}    = 0;
 458     $count{'Dunno'}     = 0;
 459     $count{'Moron'}     = 0;
 460 }
 461
 462 sub shutdown {
 463     # reverse order of &setup().
 464     &status("--- shutdown called.");
 465
 466     $ident ||=  "blootbot";     # hack.
 467
 468     # opened files must be written to on shutdown/hup/whatever
 469     # unless they're write-only, like uptime.
 470     &writeUserFile();
 471     &writeChanFile();
 472     &News::writeNews()  if (&ChanConfList("news"));
 473
 474     &closeDB();
 475     &closeSHM($shm);    # aswell. TODO: use this in &doExit?
 476     &closeLog();
 477 }
 478
 479 sub restart {
 480     my ($sig) = @_;
 481
 482     if ($$ == $bot_pid) {
 483         &status("--- $sig called.");
 484
 485         ### crappy bug in Net::IRC?
 486         if (!$conn->connected and time - $msgtime > 900) {
 487             &status("reconnecting because of uncaught disconnect \@ ".scalar(localtime) );
 488 ###         $irc->start;
 489             &clearIRCVars();
 490             $conn->connect();
 491 ###         return;
 492         }
 493
 494         &ircCheck();    # heh, evil!
 495
 496         &DCCBroadcast("-HUP called.","m");
 497         &shutdown();
 498         &loadConfig($bot_config_dir."/blootbot.config");
 499         &reloadAllModules() if (&IsParam("DEBUG"));
 500         &setup();
 501
 502         &status("--- End of $sig.");
 503     } else {
 504         &status("$sig called; ignoring restart.");
 505     }
 506 }
 507
 508 # File: Configuration.
 509 sub loadConfig {
 510     my ($file) = @_;
 511
 512     if (!open(FILE, $file)) {
 513         &ERROR("FAILED loadConfig ($file): $!");
 514         &status("Please read the INSTALL file on how to install and setup this file.");
 515         exit 0;
 516     }
 517
 518     my $count = 0;
 519     while (<FILE>) {
 520         chomp;
 521         next if /^\s*\#/;
 522         next unless /\S/;
 523         my ($set,$key,$val) = split(/\s+/, $_, 3);
 524
 525         if ($set ne "set") {
 526             &status("loadConfig: invalid line '$_'.");
 527             next;
 528         }
 529
 530         # perform variable interpolation
 531         $val =~ s/(\$(\w+))/$param{$2}/g;
 532
 533         $param{$key} = $val;
 534
 535         ++$count;
 536     }
 537     close FILE;
 538
 539     $file =~ s/^.*\///;
 540     &status("Loaded config $file ($count items)");
 541 }
 542
 543 1;