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