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