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