src/modules.pl

   1 #
   2 #  modules.pl: pseudo-Module handler
   3 #      Author: dms
   4 #     Version: v0.2 (20000629)
   5 #     Created: 20000624
   6 #
   7
   8 #use strict;
   9 use vars qw($AUTOLOAD);
  10
  11 ###
  12 ### REQUIRED MODULES.
  13 ###
  14
  15 eval "use IO::Socket";
  16 if ($@) {
  17     &ERROR("no IO::Socket?");
  18     exit 1;
  19 }
  20 &showProc(" (IO::Socket)");
  21
  22 ### MODULES.
  23 %myModules = (
  24         "bzflag"        => "BZFlag.pl",
  25         "countdown"     => "Countdown.pl",
  26         "debian"        => "Debian.pl",
  27         "debianExtra"   => "DebianExtra.pl",
  28         "dict"          => "Dict.pl",
  29         "dumpvars"      => "DumpVars.pl",
  30         "symdump"       => "DumpVars2.pl",
  31         "factoids"      => "Factoids.pl",
  32         "freshmeat"     => "Freshmeat.pl",
  33         "kernel"        => "Kernel.pl",
  34         "perlMath"      => "Math.pl",
  35         "news"          => "News.pl",
  36         "plug"          => "Plug.pl",
  37         "quote"         => "Quote.pl",
  38         "rootwarn"      => "RootWarn.pl",
  39         "search"        => "Search.pl",
  40         "slashdot"      => "Slashdot3.pl",
  41         "topic"         => "Topic.pl",
  42         "units"         => "Units.pl",
  43         "uptime"        => "Uptime.pl",
  44         "ircdcc"        => "UserDCC.pl",
  45         "userinfo"      => "UserInfo.pl",
  46         "weather"       => "Weather.pl",
  47         "wwwsearch"     => "W3Search.pl",
  48         "whatis"        => "WhatIs.pl",
  49         "wingate"       => "Wingate.pl",
  50         "babelfish"     => "babel.pl",
  51         "insult"        => "insult.pl",
  52         "nickometer"    => "nickometer.pl",
  53         "zfi"           => "zfi.pl",
  54         "zsi"           => "zsi.pl",
  55 );
  56 ### THIS IS NOT LOADED ON RELOAD :(
  57 my @myModulesLoadNow;
  58 my @myModulesReloadNot;
  59 BEGIN {
  60     @myModulesLoadNow   = ('topic', 'uptime', 'news', 'rootWarn', 'symdump');
  61     @myModulesReloadNot = ('IRC/Irc.pl','IRC/Schedulers.pl');
  62 }
  63
  64 sub loadCoreModules {
  65     my @mods = &getPerlFiles($bot_src_dir);
  66
  67     &status("Loading ".scalar(@mods)." CORE modules...");
  68
  69     foreach (sort @mods) {
  70         my $mod = "$bot_src_dir/$_";
  71
  72         eval "require \"$mod\"";
  73         if ($@) {
  74             &ERROR("lCM => $@");
  75             &shutdown();
  76             exit 1;
  77         }
  78
  79         $moduleAge{$mod} = (stat $mod)[9];
  80         &showProc(" ($_)") if (&IsParam("DEBUG"));
  81     }
  82 }
  83
  84 sub loadDBModules {
  85     my $f = "$bot_src_dir/modules.pl";
  86     $moduleAge{$f} = (stat $f)[9];
  87
  88     if ($param{'DBType'} =~ /^mysql$/i) {
  89         eval "use DBI";
  90         if ($@) {
  91             &ERROR("libdbd-mysql-perl is not installed!");
  92             exit 1;
  93         }
  94         &status("Loading MySQL support.");
  95         $f = "$bot_src_dir/db_mysql.pl";
  96         require $f;
  97         $moduleAge{$f} = (stat $f)[9];
  98         &showProc(" (DBI // mysql)");
  99     } elsif ($param{'DBType'} =~ /^pgsql$/i) {
 100 #       eval "use Pg";
 101         eval "use DBI";
 102         if ($@) {
 103             &ERROR("libpgperl is not installed!");
 104             exit 1;
 105         }
 106         &status("Loading pgsql support.");
 107         require "$bot_src_dir/db_pgsql.pl";
 108         &showProc(" (pgsql)");
 109     } elsif ($param{'DBType'} =~ /^sqlite$|^dbm$/i) {
 110         &status("Loading " . $param{'DBType'} . " support.");
 111         $f="$bot_src_dir/db_" . $param{'DBType'} . ".pl";
 112         $moduleAge{$f} = (stat $f)[9];
 113         require $f;
 114         &showProc(" $bot_src_dir/db_" . $param{'DBType'} . ".pl");
 115     } else {
 116         &status("DB support DISABLED.");
 117         return;
 118     }
 119 }
 120
 121 sub loadFactoidsModules {
 122     if (!&IsParam("factoids")) {
 123         &status("Factoid support DISABLED.");
 124         return;
 125     }
 126
 127     &status("Loading Factoids modules...");
 128
 129     foreach ( &getPerlFiles("$bot_src_dir/Factoids") ) {
 130         my $mod = "$bot_src_dir/Factoids/$_";
 131
 132         eval "require \"$mod\"";
 133         if ($@) {
 134             &ERROR("lFM: $@");
 135             exit 1;
 136         }
 137
 138         $moduleAge{$mod} = (stat $mod)[9];
 139         &showProc(" ($_)") if (&IsParam("DEBUG"));
 140     }
 141 }
 142
 143 sub loadIRCModules {
 144     my ($interface) = &whatInterface();
 145     if ($interface =~ /IRC/) {
 146         &status("Loading IRC modules...");
 147
 148         eval "use Net::IRC";
 149         if ($@) {
 150             &ERROR("libnet-irc-perl is not installed!");
 151             exit 1;
 152         }
 153         &showProc(" (Net::IRC)");
 154     } else {
 155         &status("IRC support DISABLED.");
 156         # disabling forking.
 157         $param{forking} = 0;
 158         $param{noSHM}   = 1;
 159     }
 160
 161     foreach ( &getPerlFiles("$bot_src_dir/$interface") ) {
 162         my $mod = "$bot_src_dir/$interface/$_";
 163
 164         # hrm... use another config option besides DEBUG to display
 165         # change in memory usage.
 166         &status("Loading Modules \"$mod\"") if (!&IsParam("DEBUG"));
 167         eval "require \"$mod\"";
 168         if ($@) {
 169             &ERROR("require \"$mod\" => $@");
 170             &shutdown();
 171             exit 1;
 172         }
 173
 174         $moduleAge{$mod} = (stat $mod)[9];
 175         &showProc(" ($_)") if (&IsParam("DEBUG"));
 176     }
 177 }
 178
 179 sub loadMyModulesNow {
 180     my $loaded = 0;
 181     my $total  = 0;
 182
 183     &status("Loading MyModules...");
 184     foreach (@myModulesLoadNow) {
 185         $total++;
 186         if (!defined $_) {
 187             &WARN("mMLN: null element.");
 188             next;
 189         }
 190
 191         if (!&IsParam($_) and !&IsChanConf($_) and !&getChanConfList($_)) {
 192             if (exists $myModules{$_}) {
 193                 &status("myModule: $myModules{$_} or $_ (1) not loaded.");
 194             } else {
 195                 &DEBUG("myModule: $_ (2) not loaded.");
 196             }
 197
 198             next;
 199         }
 200
 201         # weird hack to get rootwarn to work.
 202         # it may break on other cases though, any ideas?
 203         &loadMyModule( $myModules{$_} || $myModules{lc $_} );
 204         $loaded++;
 205     }
 206
 207     &status("Module: Runtime: Loaded/Total [$loaded/$total]");
 208 }
 209
 210 ### rename to moduleReloadAll?
 211 sub reloadAllModules {
 212     &VERB("Module: reloading all.",2);
 213
 214     # obscure usage of map and regex :)
 215     foreach (map { s/.*?\/?src/src/; $_ } keys %moduleAge) {
 216         &reloadModule($_);
 217     }
 218
 219     &VERB("Module: reloading done.",2);
 220 }
 221
 222 ### rename to modulesReload?
 223 sub reloadModule {
 224     my ($mod)   = @_;
 225     my $file    = (grep /\/$mod/, keys %INC)[0];
 226
 227     # don't reload if it's not our module.
 228     if ($mod =~ /::/ or $mod !~ /pl$/) {
 229         &VERB("Not reloading $mod.",3);
 230         return;
 231     }
 232
 233     if (!defined $file) {
 234         &WARN("rM: Cannot reload $mod since it was not loaded anyway.");
 235         return;
 236     }
 237
 238     if (! -f $file) {
 239         &ERROR("rM: file '$file' does not exist?");
 240         return;
 241     }
 242
 243     if (grep /$mod/, @myModulesReloadNot) {
 244         &DEBUG("rM: should not reload $mod");
 245         return;
 246     }
 247
 248     my $age = (stat $file)[9];
 249
 250     if (!exists $moduleAge{$file}) {
 251         &DEBUG("Looks like $file was not loaded; fixing.");
 252     } else {
 253         return if ($age == $moduleAge{$file});
 254
 255         if ($age < $moduleAge{$file}) {
 256             &WARN("rM: we're not gonna downgrade '$file'; use touch.");
 257             &DEBUG("age => $age");
 258             &DEBUG("mA{$file} => $moduleAge{$file}");
 259             return;
 260         }
 261
 262         my $dc  = &Time2String($age   - $moduleAge{$file});
 263         my $ago = &Time2String(time() - $moduleAge{$file});
 264
 265         &VERB("Module:  delta change: $dc",2);
 266         &VERB("Module:           ago: $ago",2);
 267     }
 268
 269     &status("Module: Loading $mod...");
 270
 271     delete $INC{$file};
 272     eval "require \"$file\"";   # require or use?
 273     if (@$) {
 274         &DEBUG("rM: failure: @$");
 275     } else {
 276         my $basename = $file;
 277         $basename =~ s/^.*\///;
 278         &status("Module: reloaded $basename");
 279         $moduleAge{$file} = $age;
 280     }
 281 }
 282
 283 ###
 284 ### OPTIONAL MODULES.
 285 ###
 286
 287 my %perlModulesLoaded  = ();
 288 my %perlModulesMissing = ();
 289
 290 sub loadPerlModule {
 291     return 0 if (exists $perlModulesMissing{$_[0]});
 292     &reloadModule($_[0]);
 293     return 1 if (exists $perlModulesLoaded{$_[0]});
 294
 295     eval "use $_[0]";
 296     if ($@) {
 297         &WARN("Module: $_[0] is not installed!");
 298         $perlModulesMissing{$_[0]} = 1;
 299         return 0;
 300     } else {
 301         $perlModulesLoaded{$_[0]} = 1;
 302         &status("Module: Loaded $_[0] ...");
 303         &showProc(" ($_[0])");
 304         return 1;
 305     }
 306 }
 307
 308 sub loadMyModule {
 309     my ($tmp) = @_;
 310     if (!defined $tmp) {
 311         &WARN("loadMyModule: module is NULL.");
 312         return 0;
 313     }
 314
 315     my ($modulename, $modulebase);
 316     if (exists $myModules{$tmp}) {
 317         ($modulename, $modulebase) = ($tmp, $myModules{$tmp});
 318     } else {
 319         $modulebase = $tmp;
 320         if ($tmp = grep /^$modulebase$/, keys %myModules) {
 321             &DEBUG("lMM: lame hack, file => name => $tmp.");
 322             $modulename = $tmp;
 323         }
 324     }
 325     my $modulefile = "$bot_src_dir/Modules/$modulebase";
 326
 327     # call reloadModule() which checks age of file and reload.
 328     if (grep /\/$modulebase$/, keys %INC) {
 329         &reloadModule($modulebase);
 330         return 1;       # depend on reloadModule?
 331     }
 332
 333     if (! -f $modulefile) {
 334         &ERROR("lMM: module ($modulebase) does not exist.");
 335         if ($$ == $bot_pid) {   # parent.
 336             &shutdown() if (defined $shm and defined $dbh);
 337         } else {                        # child.
 338             &DEBUG("b4 delfork 1");
 339             &delForked($modulebase);
 340         }
 341
 342         exit 1;
 343     }
 344
 345     eval "require \"$modulefile\"";
 346     if ($@) {
 347         &ERROR("cannot load my module: $modulebase");
 348         if ($bot_pid != $$) {   # child.
 349             &DEBUG("b4 delfork 2");
 350             &delForked($modulebase);
 351             exit 1;
 352         }
 353
 354         return 0;
 355     } else {
 356         $moduleAge{$modulefile} = (stat $modulefile)[9];
 357
 358         &status("myModule: Loaded $modulebase ...");
 359         &showProc(" ($modulebase)");
 360         return 1;
 361     }
 362 }
 363
 364 $no_timehires = 0;
 365 eval "use Time::HiRes qw(gettimeofday tv_interval)";
 366 if ($@) {
 367     &WARN("No Time::HiRes?");
 368     $no_timehires = 1;
 369 }
 370 &showProc(" (Time::HiRes)");
 371
 372 sub AUTOLOAD {
 373     if (!defined $AUTOLOAD and defined $::AUTOLOAD) {
 374         &DEBUG("AUTOLOAD: hrm.. ::AUTOLOAD defined!");
 375     }
 376     return unless (defined $AUTOLOAD);
 377     return if ($AUTOLOAD =~ /__/);      # internal.
 378
 379     my $str = join(', ', @_);
 380     my ($package, $filename, $line) = caller;
 381     &ERROR("UNKNOWN FUNCTION CALLED: $AUTOLOAD ($str) $filename line $line");
 382
 383     $AUTOLOAD =~ s/^(\S+):://g;
 384
 385     if (exists $myModules{lc $AUTOLOAD}) {
 386         # hopefully this will work.
 387         &DEBUG("Trying to load module $AUTOLOAD...");
 388         &loadMyModule(lc $AUTOLOAD);
 389     }
 390 }
 391
 392 sub getPerlFiles {
 393     my($dir) = @_;
 394
 395     if (!opendir(DIR, $dir)) {
 396         &ERROR("Cannot open source directory ($dir): $!");
 397         exit 1;
 398     }
 399
 400     my @mods;
 401     while (defined(my $file = readdir DIR)) {
 402         next unless $file =~ /\.pl$/;
 403         next unless $file =~ /^[A-Z]/;
 404         push(@mods, $file);
 405     }
 406     closedir DIR;
 407
 408     return reverse sort @mods;
 409 }
 410
 411 1;