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