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