mozbot.pl

   1 #!/usr/bin/perl -wT
   2 # -*- Mode: perl; indent-tabs-mode: nil -*-
   3 # DO NOT REMOVE THE -T ON THE FIRST LINE!!!
   4 #
   5 #                       _           _
   6 #        m o z i l l a |.| o r g   | |
   7 #    _ __ ___   ___ ___| |__   ___ | |_
   8 #   | '_ ` _ \ / _ \_  / '_ \ / _ \| __|
   9 #   | | | | | | (_) / /| |_) | (_) | |_
  10 #   |_| |_| |_|\___/___|_.__/ \___/ \__|
  11 #   ====================================
  12 #
  13 # The contents of this file are subject to the Mozilla Public
  14 # License Version 1.1 (the "License"); you may not use this file
  15 # except in compliance with the License. You may obtain a copy of
  16 # the License at http://www.mozilla.org/MPL/
  17 #
  18 # Software distributed under the License is distributed on an "AS
  19 # IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
  20 # implied. See the License for the specific language governing
  21 # rights and limitations under the License.
  22 #
  23 # The Original Code is the Bugzilla Bug Tracking System.
  24 #
  25 # The Initial Developer of the Original Code is Netscape Communications
  26 # Corporation. Portions created by Netscape are
  27 # Copyright (C) 1998 Netscape Communications Corporation. All
  28 # Rights Reserved.
  29 #
  30 # Contributor(s): Harrison Page <harrison@netscape.com>
  31 #                 Terry Weissman <terry@mozilla.org>
  32 #                 Risto Kotalampi <risto@kotalampi.com>
  33 #                 Josh Soref <timeless@bemail.org>
  34 #                 Ian Hickson <mozbot@hixie.ch>
  35 #                 Ken Coar <ken.coar@golux.com>
  36 #                 Adam Di Carlo <adam@onshored.com>
  37 #
  38 # mozbot.pl harrison@netscape.com 1998-10-14
  39 # "irc bot for the gang on #mozilla"
  40 #
  41 # mozbot.pl mozbot@hixie.ch 2000-07-04
  42 # "irc bot engine for anyone" :-)
  43 #
  44 # hack on me! required reading:
  45 #
  46 # Net::IRC web page:
  47 #   http://sourceforge.net/projects/net-irc/
  48 #   (free software)
  49 #   or get it from CPAN @ http://www.perl.com/CPAN
  50 #
  51 # RFC 1459 (Internet Relay Chat Protocol):
  52 #   http://sunsite.cnlab-switch.ch/ftp/doc/standard/rfc/14xx/1459
  53 #
  54 # Please file bugs in Bugzilla, under the 'Webtools' product,
  55 # component 'Mozbot'.  https://bugzilla.mozilla.org/
  56
  57 # TO DO LIST
  58 # XXX Something that checks modules that failed to compile and then
  59 #     reloads them when possible
  60 # XXX an HTML entity convertor for things that speak web page contents
  61 # XXX UModeChange
  62 # XXX minor checks
  63 # XXX throttle nick changing and away setting (from module API)
  64 # XXX compile self before run
  65 # XXX parse mode (+o, etc)
  66 # XXX optimisations
  67 # XXX maybe should catch hangup signal and go to background?
  68 # XXX protect the bot from DOS attacks causing server overload
  69 # XXX protect the server from an overflowing log (add log size limitter
  70 #     or rotation)
  71 # XXX fix the "hack hack hack" bits to be better.
  72
  73
  74 ################################
  75 # Initialisation               #
  76 ################################
  77
  78 # -- #mozwebtools was here --
  79 #      <Hixie> syntax error at oopsbot.pl line 48, near "; }"
  80 #      <Hixie> Execution of oopsbot.pl aborted due to compilation errors.
  81 #      <Hixie> DOH!
  82 #     <endico> hee hee. nice smily in the error message
  83
  84 # catch nasty occurances
  85 $SIG{'INT'}  = sub { &killed('INT'); };
  86 $SIG{'KILL'} = sub { &killed('KILL'); };
  87 $SIG{'TERM'} = sub { &killed('TERM'); };
  88
  89 # this allows us to exit() without shutting down (by exec($0)ing)
  90 BEGIN { exit() if ((defined($ARGV[0])) and ($ARGV[0] eq '--abort')); }
  91
  92 # pragmas
  93 use strict;
  94 use diagnostics;
  95
  96 # chroot if requested
  97 my $CHROOT = 0;
  98 if ((defined($ARGV[0])) and ($ARGV[0] eq '--chroot')) {
  99     # chroot
 100     chroot('.') or die "chroot failed: $!\nAborted";
 101     # setuid
 102     # This is hardcoded to use user ids and group ids 60001.
 103     # You'll want to change this on your system.
 104     $> = 60001; # setuid nobody
 105     $) = 60001; # setgid nobody
 106     shift(@ARGV);
 107     use lib '/lib';
 108     $CHROOT = 1;
 109 } elsif ((defined($ARGV[0])) and ($ARGV[0] eq '--assume-chrooted')) {
 110     shift(@ARGV);
 111     use lib '/lib';
 112     $CHROOT = 1;
 113 } else {
 114     use lib 'lib';
 115 }
 116
 117 # important modules
 118 use Net::IRC 0.7; # 0.7 is not backwards compatible with 0.63 for CTCP responses
 119 use IO::SecurePipe; # internal based on IO::Pipe
 120 use Socket;
 121 use POSIX ":sys_wait_h";
 122 use Carp qw(cluck confess);
 123 use Configuration; # internal
 124 use Mails; # internal
 125
 126 # Net::IRC 0.74+ require Time::HiRes, if its missing, Net::IRC will fail with
 127 # a "No method called "time" for object." error during mozbot startup.
 128
 129 # Note: Net::SMTP is also used, see the sendmail function in Mails.
 130
 131 # force flushing
 132 $|++;
 133
 134 # internal 'constants'
 135 my $USERNAME = "pid-$$";
 136 my $LOGFILEPREFIX;
 137
 138 # variables that should only be changed if you know what you are doing
 139 my $LOGGING = 1; # set to '0' to disable logging
 140 my $LOGFILEDIR; # set this to override the logging output directory
 141
 142 if ($LOGGING) {
 143     # set up the log directory
 144     unless (defined($LOGFILEDIR)) {
 145         if ($CHROOT) {
 146             $LOGFILEDIR = '/log';
 147         } else {
 148             # setpwent doesn't work on Windows, we should wrap this in some OS test
 149             setpwent; # reset the search settings for the getpwuid call below
 150             $LOGFILEDIR = (getpwuid($<))[7].'/log';
 151         }
 152     }
 153     "$LOGFILEDIR/$0" =~ /^(.*)$/os; # untaints the evil $0.
 154     $LOGFILEPREFIX = $1; # for some reason, $0 is considered tainted here, but not in other cases...
 155     mkdir($LOGFILEDIR, 0700); # if this fails for a bad reason, we'll find out during the next line
 156 }
 157
 158 # begin session log...
 159 &debug('-'x80);
 160 &debug('mozbot starting up');
 161 &debug('compilation took '.&days($^T).'.');
 162 if ($CHROOT) {
 163     &debug('mozbot chroot()ed successfully');
 164 }
 165
 166 # secure the environment
 167 #
 168 # XXX could automatically remove the current directory here but I am
 169 # more comfortable with people knowing it is not allowed -- see the
 170 # README file.
 171 if ($ENV{'PATH'} =~ /^(?:.*:)?\.?(?::.*)?$/os) {
 172     die 'SECURITY RISK. You cannot have \'.\' in the path. See the README. Aborted';
 173 }
 174 $ENV{'PATH'} =~ /^(.*)$/os;
 175 $ENV{'PATH'} = $1; # we have to assume their path is otherwise safe, they called us!
 176 delete (@ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'});
 177
 178
 179 # read the configuration file
 180 my $cfgfile = shift || "$0.cfg";
 181 $cfgfile =~ /^(.*)$/os;
 182 $cfgfile = $1; # untaint it -- we trust this, it comes from the admin.
 183 &debug("reading configuration from '$cfgfile'...");
 184
 185 # - setup variables
 186 # note: owner is only used by the Mails module
 187 my ($server, $port, $password, $localAddr, @nicks, @channels, %channelKeys, $owner,
 188     @ignoredUsers, @ignoredTargets, $ssl);
 189 my $nick = 0;
 190 my $sleepdelay = 60;
 191 my $connectTimeout = 120;
 192 my $delaytime = 1.3; # amount of time to wait between outputs
 193 my $recentMessageCountThreshold = 3; # threshold before we stop outputting
 194 my $recentMessageCountPenalty = 10; # if we hit the threshold, bump it up by this much
 195 my $recentMessageCountLimit = 20; # limit above which the count won't go
 196 my $recentMessageCountDecrementRate = 0.1; # how much to take off per $delaytime
 197 my $variablepattern = '[-_:a-zA-Z0-9]+';
 198 my %users = ('admin' => &newPassword('password')); # default password for admin
 199 my %userFlags = ('admin' => 3); # bitmask; 0x1 = admin, 0x2 = delete user a soon as other admin authenticates
 200 my $helpline = 'http://www.mozilla.org/projects/mozbot/'; # used in IRC name and in help
 201 my $serverRestrictsIRCNames = '';
 202 my $serverExpectsValidUsername = '';
 203 my $username = 0; # makes the username default to the pid ($USERNAME)
 204 my @modulenames = ('General', 'Greeting', 'Infobot', 'Parrot');
 205 my $gender = 'female'; #changed to female by special request
 206 my $umode;
 207
 208 # - which variables can be saved.
 209 &registerConfigVariables(
 210     [\$server, 'server'],
 211     [\$port, 'port'],
 212     [\$password, 'password'],
 213     [\$localAddr, 'localAddr'],
 214     [\@nicks, 'nicks'],
 215     [\$nick, 'currentnick'], # pointer into @nicks
 216     [\@channels, 'channels'],
 217     [\%channelKeys, 'channelKeys'],
 218     [\@ignoredUsers, 'ignoredUsers'],
 219     [\@ignoredTargets, 'ignoredTargets'],
 220     [\@modulenames, 'modules'],
 221     [\$owner, 'owner'],
 222     [\$sleepdelay, 'sleep'],
 223     [\$connectTimeout, 'connectTimeout'],
 224     [\$delaytime, 'throttleTime'],
 225     [\%users, 'users'], # usernames => &newPassword(passwords)
 226     [\%userFlags, 'userFlags'], # usernames => bits
 227     [\$variablepattern, 'variablepattern'],
 228     [\$helpline, 'helpline'],
 229     [\$username, 'username'],
 230     [\$serverRestrictsIRCNames, 'simpleIRCNameServer'],
 231     [\$serverExpectsValidUsername, 'validUsernameServer'],
 232     [\$ssl, 'ssl'],
 233     [\$umode, 'umode'],
 234     [\$gender, 'gender'],
 235     [\$Mails::smtphost, 'smtphost'],
 236 );
 237
 238 # - read file
 239 &Configuration::Get($cfgfile, &configStructure()); # empty gets entire structure
 240
 241 # - check variables are ok
 242 # note. Ensure only works on an interactive terminal (-t).
 243 # It will abort otherwise.
 244 { my $changed; # scope this variable
 245 $changed = &Configuration::Ensure([
 246     ['Connect to which server?', \$server],
 247     ['To which port should I connect?', \$port],
 248     ['Connect to this port using SSL?', \$ssl],
 249     ['What is the server\'s password? (Leave blank if there isn\'t one.)', \$password],
 250     ['What channels should I join?', \@channels],
 251     ['What is the e-mail address of my owner?', \$owner],
 252     ['What is your SMTP host?', \$Mails::smtphost],
 253 ]);
 254
 255 # - check we have some nicks
 256 until (@nicks) {
 257     $changed = &Configuration::Ensure([['What nicks should I use? (I need at least one.)', \@nicks]]) || $changed;
 258     # the original 'mozbot 2.0' development codename (and thus nick) was oopsbot.
 259 }
 260
 261 # - check current nick pointer is valid
 262 # (we assume that no sillyness has happened with $[ as,
 263 # according to man perlvar, "Its use is highly discouraged".)
 264 $nick = 0 if (($nick > $#nicks) or ($nick < 0));
 265
 266 # - check channel names are all lowercase
 267 foreach (@channels) { $_ = lc; }
 268
 269 # save configuration straight away, to make sure it is possible and to save
 270 # any initial settings on the first run, if anything changed.
 271 if ($changed) {
 272     &debug("saving configuration to '$cfgfile'...");
 273     &Configuration::Save($cfgfile, &configStructure());
 274 }
 275
 276 } # close the scope for the $changed variable
 277
 278 # ensure Mails is ready
 279 &debug("setting up Mails module...");
 280 $Mails::debug = \&debug;
 281 $Mails::owner = \$owner;
 282
 283 # setup the IRC variables
 284 &debug("setting up IRC variables...");
 285 my $uptime;
 286 my $irc = new Net::IRC or confess("Could not create a new Net::IRC object. Aborting");
 287
 288 # connect
 289 &debug("attempting initial connection...");
 290 &connect(); # hmm.
 291
 292 # setup the modules array
 293 my @modules; # we initialize it lower down (at the bottom in fact)
 294 my $lastadmin; # nick of last admin to be seen
 295 my %authenticatedUsers; # hash of user@hostname=>users who have authenticated
 296
 297
 298 ################################
 299 # Net::IRC handler subroutines #
 300 ################################
 301
 302 sub setEventArgs {
 303     my $event = shift;
 304     if ($Net::IRC::VERSION == 0.75) {
 305         # curses. This version of Net::IRC is broken. Work around
 306         # it here.
 307         return $event->args(\@_);
 308     } else {
 309         return $event->args(@_);
 310     }
 311 }
 312
 313 my $lastNick;
 314
 315 # setup connection
 316 sub connect {
 317     $uptime = time();
 318
 319     &debug("connecting to $server:$port using nick '$nicks[$nick]'..."
 320                         . ($ssl && lc($ssl) eq 'yes')? "via SSL" : "");
 321     my ($bot, $mailed);
 322
 323     $lastNick = undef;
 324
 325     my $ircname = 'mozbot';
 326     if ($serverRestrictsIRCNames ne $server) {
 327         $ircname = "[$ircname] $helpline";
 328     }
 329
 330     my $identd = getpwuid($<);
 331     if ($serverExpectsValidUsername ne $server) {
 332         $identd = $username || $USERNAME;
 333     }
 334
 335     until (inet_aton($server) and # we check this first because Net::IRC::Connection doesn't
 336            $bot = $irc->newconn(
 337              Server => $server,
 338              Port => $port,
 339              Password => $password ne '' ? $password : undef, # '' will cause PASS to be sent
 340              Nick => $nicks[$nick],
 341              Ircname => $ircname,
 342              Username => $identd,
 343              LocalAddr => $localAddr,
 344                          SSL => ($ssl && lc($ssl) eq 'yes') ? 'true' : undef,
 345            )) {
 346         &debug("Could not connect. Are you sure '$server:$port' is a valid host?");
 347         unless (inet_aton($server)) {
 348             &debug('I couldn\'t resolve it.');
 349         }
 350         if (defined($localAddr)) {
 351             &debug("Is '$localAddr' the correct address of the interface to use?");
 352         } else {
 353             &debug("Try editing '$cfgfile' to set 'localAddr' to the address of the interface to use.");
 354         }
 355         if ($Net::IRC::VERSION < 0.73) {
 356             &debug("Note that to use 'localAddr' you need Net::IRC version 0.73 or higher (you have $Net::IRC::VERSION)");
 357         }
 358         $mailed = &Mails::ServerDown($server, $port, $localAddr, $nicks[$nick], $ircname, $identd) unless $mailed;
 359         sleep($sleepdelay);
 360         &Configuration::Get($cfgfile, &configStructure(\$server, \$port, \$password, \@nicks, \$nick, \$owner, \$sleepdelay));
 361         &debug("connecting to $server:$port again...");
 362     }
 363
 364     &debug("connected! woohoo!");
 365
 366     # add the handlers
 367     &debug("adding event handlers");
 368
 369     # $bot->debug(1); # this can help when debugging API stuff
 370
 371     $bot->add_global_handler([ # Informational messages -- print these to the console
 372         251, # RPL_LUSERCLIENT
 373         252, # RPL_LUSEROP
 374         253, # RPL_LUSERUNKNOWN
 375         254, # RPL_LUSERCHANNELS
 376         255, # RPL_LUSERME
 377         302, # RPL_USERHOST
 378         375, # RPL_MOTDSTART
 379         372, # RPL_MOTD
 380     ], \&on_startup);
 381
 382     $bot->add_global_handler([ # Informational messages -- print these to the console
 383         'snotice', # server notices
 384         461, # need more arguments for PASS command
 385         409, # noorigin
 386         405, # toomanychannels  XXX should do something about this!
 387         404, # cannot send to channel
 388         403, # no such channel
 389         401, # no such server
 390         402, # no such nick
 391         407, # too many targets
 392     ], \&on_notice);
 393
 394     $bot->add_global_handler([ # should only be one command here - when to join channels
 395         376, # RPL_ENDOFMOTD
 396         422, # nomotd
 397     ], \&on_connect);
 398
 399     $bot->add_handler('welcome', \&on_welcome); # when we connect, to get our nick/umode
 400     $bot->add_global_handler([ # when to change nick name
 401         'erroneusnickname',
 402         433, # ERR_NICKNAMEINUSE
 403         436, # nick collision
 404     ], \&on_nick_taken);
 405     $bot->add_handler('nick', \&on_nick); # when someone changes nick
 406
 407     $bot->add_global_handler([ # when to give up and go home
 408         'disconnect', 'kill', # bad connection, booted offline
 409         465, # ERR_YOUREBANNEDCREEP
 410     ], \&on_disconnected);
 411     $bot->add_handler('destroy', \&on_destroy); # when object is GCed.
 412
 413     $bot->add_handler('msg', \&on_private); # /msg bot hello
 414     $bot->add_handler('public', \&on_public);  # hello
 415     $bot->add_handler('notice', \&on_noticemsg); # notice messages
 416     $bot->add_handler('join', \&on_join); # when someone else joins
 417     $bot->add_handler('part', \&on_part); # when someone else leaves
 418     $bot->add_handler('topic', \&on_topic); # when topic changes in a channel
 419     $bot->add_handler('notopic', \&on_topic); # when topic in a channel is cleared
 420     $bot->add_handler('invite', \&on_invite); # when someone invites us
 421     $bot->add_handler('quit', \&on_quit); # when someone quits IRC
 422     $bot->add_handler('kick', \&on_kick); # when someone (or us) is kicked
 423     $bot->add_handler('mode', \&on_mode); # when modes change
 424     $bot->add_handler('umode', \&on_umode); # when modes of user change (by IRCop or ourselves)
 425     # XXX could add handler for 474, # ERR_BANNEDFROMCHAN
 426
 427     $bot->add_handler([ # ones we handle to get our hostmask
 428         311, # whoisuser
 429     ], \&on_whois);
 430     $bot->add_handler([ # ones we handle just by outputting to the console
 431         312, # whoisserver
 432         313, # whoisoperator
 433         314, # whowasuser
 434         315, # endofwho
 435         316, # whoischanop
 436         317, # whoisidle
 437         318, # endofwhois
 438         319, # whoischannels
 439     ], \&on_notice);
 440     $bot->add_handler([ # names (currently just ignored)
 441         353, # RPL_NAMREPLY "<channel> :[[@|+]<nick> [[@|+]<nick> [...]]]"
 442     ], \&on_notice);
 443     $bot->add_handler([ # end of names (we use this to establish that we have entered a channel)
 444         366, # RPL_ENDOFNAMES "<channel> :End of /NAMES list"
 445     ], \&on_join_channel);
 446
 447     $bot->add_handler('cping', \&on_cping); # client to client ping
 448     $bot->add_handler('crping', \&on_cpong); # client to client ping (response)
 449     $bot->add_handler('cversion', \&on_version); # version info of mozbot.pl
 450     $bot->add_handler('csource', \&on_source); # where is mozbot.pl's source
 451     $bot->add_handler('caction', \&on_me); # when someone says /me
 452     $bot->add_handler('cgender', \&on_gender); # guess
 453
 454     $bot->schedule($connectTimeout, \&on_check_connect);
 455
 456     # and done.
 457     &Mails::ServerUp($server) if $mailed;
 458
 459 }
 460
 461 # called when the client receives a startup-related message
 462 sub on_startup {
 463     my ($self, $event) = @_;
 464     my (@args) = $event->args;
 465     shift(@args);
 466     &debug(join(' ', @args));
 467 }
 468
 469 # called when the client receives a server notice
 470 sub on_notice {
 471     my ($self, $event) = @_;
 472     &debug($event->type.': '.join(' ', $event->args));
 473 }
 474
 475 # called when the client receives whois data
 476 sub on_whois {
 477     my ($self, $event) = @_;
 478     &debug('collecting whois information: '.join('|', $event->args));
 479     # XXX could cache this information and then autoop people from
 480     # the bot's host, or whatever
 481 }
 482
 483 my ($nickFirstTried, $nickHadProblem, $nickProblemEscalated) = (0, 0, 0);
 484
 485 # this is called for the welcome message (001) it calls on_set_nick to
 486 # get our nick and on_set_umode to set our umode once we have a nick
 487 sub on_welcome {
 488     my ($self, $event) = @_;
 489     on_set_nick($self, $event);
 490     on_set_umode($self, $event);
 491 }
 492
 493 # this is called both for the welcome message (001) and by the on_nick handler
 494 sub on_set_nick {
 495     my ($self, $event) = @_;
 496     ($lastNick) = $event->args; # (args can be either array or scalar, we want the first value)
 497     # Find nick's index.
 498     my $newnick = 0;
 499     $newnick++ while (($newnick < @nicks) and ($lastNick ne $nicks[$newnick]));
 500     # If nick isn't there, add it.
 501     if ($newnick >= @nicks) {
 502         push(@nicks, $lastNick);
 503     }
 504     # set variable
 505     $nick = $newnick;
 506     &debug("using nick '$nicks[$nick]'");
 507
 508     # try to get our hostname
 509     $self->whois($nicks[$nick]);
 510
 511     if ($nickHadProblem) {
 512         Mails::NickOk($nicks[$nick]) if $nickProblemEscalated;
 513         $nickHadProblem = 0;
 514     }
 515
 516     # save
 517     &Configuration::Save($cfgfile, &::configStructure(\$nick, \@nicks));
 518 }
 519
 520 sub on_nick_taken {
 521     my ($self, $event, $nickSlept) = @_, 0;
 522     return unless $self->connected();
 523
 524     if ($event->type eq 'erroneusnickname') {
 525         my ($currentNick, $triedNick, $err) = $event->args; # current, tried, errmsg
 526         &debug("requested nick ('$triedNick') refused by server ('$err')");
 527     } elsif ($event->type eq 'nicknameinuse') {
 528         my ($currentNick, $triedNick, $err) = $event->args; # current, tried, errmsg
 529         &debug("requested nick ('$triedNick') already in use ('$err')");
 530     } else {
 531         my $type = $event->type;
 532         my $args = join(' ', $event->args);
 533         &debug("message $type from server: $args");
 534     }
 535
 536     if (defined $lastNick) {
 537         &debug("silently abandoning nick change idea :-)");
 538         return;
 539     }
 540
 541     # at this point, we don't yet have a nick, but we need one
 542
 543     if ($nickSlept) {
 544         &debug("waited for a bit -- reading $cfgfile then searching for a nick...");
 545         &Configuration::Get($cfgfile, &configStructure(\@nicks, \$nick));
 546         $nick = 0 if ($nick > $#nicks) or ($nick < 0); # sanitise
 547         $nickFirstTried = $nick;
 548     } else {
 549         if (not $nickHadProblem) {
 550             $nickHadProblem = 1;
 551             $nickFirstTried = $nick;
 552         }
 553         ++$nick;
 554         $nick = 0 if $nick > $#nicks; # sanitise
 555
 556         if ($nick == $nickFirstTried) {
 557             # looped!
 558             local $" = ", ";
 559             &debug("could not find an acceptable nick");
 560             &debug("nicks tried: @nicks");
 561
 562             if (not -t) {
 563                 &debug("edit $cfgfile to add more nicks *hint* *hint*");
 564                 $nickProblemEscalated ||= # only e-mail once (returns 0 on failure)
 565                   Mails::NickShortage($cfgfile, $self->server, $self->port,
 566                                       $self->username, $self->ircname, @nicks)
 567                 &debug("going to wait $sleepdelay seconds so as not to overload ourselves.");
 568                 $self->schedule($sleepdelay, \&on_nick_taken, $event, 1); # try again
 569                 return; # otherwise we no longer respond to pings.
 570             }
 571
 572             # else, we're terminal bound, ask user for nick
 573             print "Please suggest a nick (blank to abort): ";
 574             my $new = <>;
 575             chomp($new);
 576             if (not $new) {
 577                 &debug("Could not find an acceptable nick");
 578                 exit(1);
 579             }
 580             # XXX this could introduce duplicates
 581             @nicks = (@nicks[0..$nickFirstTried], $new, @nicks[$nickFirstTried+1..$#nicks]);
 582             $nick += 1; # try the new nick now
 583             $nickFirstTried = $nick;
 584         }
 585     }
 586
 587     &debug("now going to try nick '$nicks[$nick]'");
 588     &Configuration::Save($cfgfile, &configStructure(\$nick, \@nicks));
 589     $self->nick($nicks[$nick]);
 590 }
 591
 592 #called by on_welcome after we get our nick
 593 sub on_set_umode {
 594     my ($self, $event) = @_;
 595     # set usermode for the bot
 596     if ($umode) {
 597         &debug("using umode: '$umode'");
 598         $self->mode($self->nick, $umode);
 599     }
 600 }
 601
 602 # called when we connect.
 603 sub on_connect {
 604     my $self = shift;
 605
 606     if (defined($self->{'__mozbot__shutdown'})) { # HACK HACK HACK
 607         &debug('Uh oh. I connected anyway, even though I thought I had timed out.');
 608         &debug('I\'m going to increase the timeout time by 20%.');
 609         $connectTimeout = $connectTimeout * 1.2;
 610         &Configuration::Save($cfgfile, &configStructure(\$connectTimeout));
 611         $self->quit('having trouble connecting, brb...');
 612         # XXX we don't call the SpottedQuit handlers here
 613         return;
 614     }
 615
 616     # -- #mozwebtools was here --
 617     # *** oopsbot (oopsbot@129.59.231.42) has joined channel #mozwebtools
 618     # *** Mode change [+o oopsbot] on channel #mozwebtools by timeless
 619     #   <timeless> wow an oopsbot!
 620     # *** Signoff: oopsbot (oopsbot@129.59.231.42) has left IRC [Leaving]
 621     #   <timeless> um
 622     #   <timeless> not very stable.
 623
 624     # now load all modules
 625     my @modulesToLoad = @modulenames;
 626     @modules = (BotModules::Admin->create('Admin', '')); # admin commands
 627     @modulenames = ('Admin');
 628     foreach (@modulesToLoad) {
 629         next if $_ eq 'Admin'; # Admin is static and is installed manually above
 630         my $result = LoadModule($_);
 631         if (ref($result)) {
 632             &debug("loaded $_");
 633         } else {
 634             &debug("failed to load $_", $result);
 635         }
 636     }
 637
 638     # mass-configure the modules
 639     &debug("loading module configurations...");
 640     { my %struct; # scope this variable
 641     foreach my $module (@modules) { %struct = (%struct, %{$module->configStructure()}); }
 642     &Configuration::Get($cfgfile, \%struct);
 643     } # close the scope for the %struct variable
 644
 645     # tell the modules they have joined IRC
 646     my $event = newEvent({
 647         'bot' => $self,
 648     });
 649     foreach my $module (@modules) {
 650         $module->JoinedIRC($event);
 651     }
 652
 653     # tell the modules to set up the scheduled commands
 654     &debug('setting up scheduler...');
 655     foreach my $module (@modules) {
 656         eval {
 657             $module->Schedule($event);
 658         };
 659         if ($@) {
 660             &debug("Warning: An error occured while loading the module:\n$@");
 661         }
 662     }
 663
 664     # join the channels
 665     &debug('going to join: '.join(',', @channels));
 666     foreach my $channel (@channels) {
 667         if (defined($channelKeys{$channel})) {
 668             $self->join($channel, $channelKeys{$channel});
 669         } else {
 670             $self->join($channel);
 671         }
 672     }
 673     @channels = ();
 674
 675     # enable the drainmsgqueue
 676     &drainmsgqueue($self);
 677     $self->schedule($delaytime, \&lowerRecentMessageCount);
 678
 679     # signal that we are connected (see next two functions)
 680     $self->{'__mozbot__active'} = 1; # HACK HACK HACK
 681
 682     # all done!
 683     &debug('initialisation took '.&days($uptime).'.');
 684     $uptime = time();
 685
 686 }
 687
 688 sub on_check_connect {
 689     my $self = shift;
 690     return if (defined($self->{'__mozbot__shutdown'}) or defined($self->{'__mozbot__active'})); # HACK HACK HACK
 691     $self->{'__mozbot__shutdown'} = 1; # HACK HACK HACK
 692     &debug("connection timed out -- trying again");
 693     # XXX we don't call the SpottedQuit handlers here
 694     foreach (@modules) { $_->unload(); }
 695     @modules = ();
 696     $self->quit('connection timed out -- trying to reconnect');
 697     &connect();
 698 }
 699
 700 # if something nasty happens
 701 sub on_disconnected {
 702     my ($self, $event) = @_;
 703     return if defined($self->{'__mozbot__shutdown'}); # HACK HACK HACK
 704     $self->{'__mozbot__shutdown'} = 1; # HACK HACK HACK
 705     # &do(@_, 'SpottedQuit'); # XXX do we want to do this?
 706     my($reason) = $event->args;
 707     if ($reason =~ /Connection timed out/osi
 708         and ($serverRestrictsIRCNames ne $server
 709              or $serverExpectsValidUsername ne $server)) {
 710         # try to set everything up as simple as possible
 711         $serverRestrictsIRCNames = $server;
 712         $serverExpectsValidUsername = $server;
 713         &Configuration::Save($cfgfile, &configStructure(\$serverRestrictsIRCNames));
 714         &debug("Hrm, $server is having issues.");
 715         &debug("We're gonna try again with different settings, hold on.");
 716         &debug("The full message from the server was: '$reason'");
 717     } elsif ($reason =~ /Bad user info/osi and $serverRestrictsIRCNames ne $server) {
 718         # change our IRC name to something simpler by setting the flag
 719         $serverRestrictsIRCNames = $server;
 720         &Configuration::Save($cfgfile, &configStructure(\$serverRestrictsIRCNames));
 721         &debug("Hrm, $server didn't like our IRC name.");
 722         &debug("Trying again with a simpler one, hold on.");
 723         &debug("The full message from the server was: '$reason'");
 724     } elsif ($reason =~ /identd/osi and $serverExpectsValidUsername ne $server) {
 725         # try setting our username to the actual username
 726         $serverExpectsValidUsername = $server;
 727         &Configuration::Save($cfgfile, &configStructure(\$delaytime));
 728         &debug("Hrm, $server said something about an identd problem.");
 729         &debug("Trying again with our real username, hold on.");
 730         &debug("The full message from the server was: '$reason'");
 731     } elsif ($reason =~ /Excess Flood/osi) {
 732         # increase the delay by 20%
 733         $delaytime = $delaytime * 1.2;
 734         &Configuration::Save($cfgfile, &configStructure(\$delaytime));
 735         &debug('Hrm, we it seems flooded the server. Trying again with a delay 20% longer.');
 736         &debug("The full message from the server was: '$reason'");
 737     } elsif ($reason =~ /Bad Password/osi) {
 738         &debug('Hrm, we don\'t seem to know the server password.');
 739         &debug("The full message from the server was: '$reason'");
 740         if (-t) {
 741             print "Please enter the server password: ";
 742             $password = <>;
 743             chomp($password);
 744             &Configuration::Save($cfgfile, &configStructure(\$password));
 745         } else {
 746             &debug("edit $cfgfile to set the password *hint* *hint*");
 747             &debug("going to wait $sleepdelay seconds so as not to overload ourselves.");
 748             sleep $sleepdelay;
 749         }
 750     } else {
 751         &debug("eek! disconnected from network: '$reason'");
 752     }
 753     foreach (@modules) { $_->unload(); }
 754     @modules = ();
 755     &connect();
 756 }
 757
 758 # on_join_channel: called when we join a channel
 759 sub on_join_channel {
 760     my ($self, $event) = @_;
 761     my ($nick, $channel) = $event->args;
 762     $channel = lc($channel);
 763     push(@channels, $channel);
 764     &Configuration::Save($cfgfile, &configStructure(\@channels));
 765     &debug("joined $channel, about to autojoin modules...");
 766     foreach (@modules) {
 767         $_->JoinedChannel(newEvent({
 768             'bot' => $self,
 769             'channel' => $channel,
 770             'target' => $channel,
 771             'nick' => $nick
 772         }), $channel);
 773     }
 774 }
 775
 776 # if something nasty happens
 777 sub on_destroy {
 778     &debug("Connection: garbage collected");
 779 }
 780
 781 sub targetted {
 782     my ($data, $nick) = @_;
 783     return $data =~ /^(\s*$nick(?:[\s,:;!?]+|\s*:-\s*|\s*--+\s*|\s*-+>?\s+))(.+)$/is ?
 784       (defined $2 ? $2 : '') : undef;
 785 }
 786
 787 # on_public: messages received on channels
 788 sub on_public {
 789     my ($self, $event) = @_;
 790     my $data = join(' ', $event->args);
 791     if (defined($_ = targetted($data, quotemeta($nicks[$nick])))) {
 792         if ($_ ne '') {
 793             setEventArgs($event, $_);
 794             $event->{'__mozbot__fulldata'} = $data;
 795             &do($self, $event, 'Told', 'Baffled');
 796         } else {
 797             &do($self, $event, 'Heard');
 798         }
 799     } else {
 800         foreach my $nick (@ignoredTargets) {
 801             if (defined targetted($data, $nick)) {
 802                 my $channel = &toToChannel($self, @{$event->to});
 803                 &debug("Ignored (target matched /$nick/): $channel <".$event->nick.'> '.join(' ', $event->args));
 804                 return;
 805             }
 806         }
 807         &do($self, $event, 'Heard');
 808     }
 809 }
 810
 811 # on_noticemsg: notice messages from the server, some service, or another
 812 # user.  beware!  it's generally Bad Juju to respond to these, but for
 813 # some things (like opn's NickServ) it's appropriate.
 814 sub on_noticemsg {
 815     my ($self, $event) = @_;
 816     &do($self, $event, 'Noticed');
 817 }
 818
 819 sub on_private {
 820     my ($self, $event) = @_;
 821     my $data = join(' ', $event->args);
 822     my $nick = quotemeta($nicks[$nick]);
 823     if (($data =~ /^($nick(?:[-\s,:;.!?]|\s*-+>?\s+))(.+)$/is) and ($2)) {
 824         # we do this so that you can say 'mozbot do this' in both channels
 825         # and /query screens alike (otherwise, in /query screens you would
 826         # have to remember to omit the bot name).
 827         setEventArgs($event, $2);
 828     }
 829     &do($self, $event, 'Told', 'Baffled');
 830 }
 831
 832 # on_me: /me actions (CTCP actually)
 833 sub on_me {
 834     my ($self, $event) = @_;
 835     my @data = $event->args;
 836     my $data = join(' ', @data);
 837     setEventArgs($event, $data);
 838     my $nick = quotemeta($nicks[$nick]);
 839     if ($data =~ /(?:^|[\s":<([])$nick(?:[])>.,?!\s'&":]|$)/is) {
 840         &do($self, $event, 'Felt');
 841     } else {
 842         &do($self, $event, 'Saw');
 843     }
 844 }
 845
 846 # on_topic: for when someone changes the topic
 847 # also for when the server notifies us of the topic
 848 # ...so we have to parse it carefully.
 849 sub on_topic {
 850     my ($self, $event) = @_;
 851     if ($event->userhost eq '@') {
 852         # server notification
 853         # need to parse data
 854         my (undef, $channel, $topic) = $event->args;
 855         setEventArgs($event, $topic);
 856         $event->to($channel);
 857     }
 858     &do(@_, 'SpottedTopicChange');
 859 }
 860
 861 # on_kick: parse the kick event
 862 sub on_kick {
 863     my ($self, $event) = @_;
 864     my ($channel, $from) = $event->args; # from is already set anyway
 865     my $who = $event->to;
 866     $event->to($channel);
 867     foreach (@$who) {
 868         setEventArgs($event, $_);
 869         if ($_ eq $nicks[$nick]) {
 870             &do(@_, 'Kicked');
 871         } else {
 872             &do(@_, 'SpottedKick');
 873         }
 874     }
 875 }
 876
 877 # Gives lag results for outgoing PINGs.
 878 sub on_cpong {
 879     my ($self, $event) = @_;
 880     &debug('completed CTCP PING with '.$event->nick.': '.days($event->args->[0]));
 881     # XXX should be able to use this then... see also Greeting module
 882     # in standard distribution
 883 }
 884
 885 # -- #mozbot was here --
 886 #   <timeless> $conn->add_handler('gender',\&on_ctcp_gender);
 887 #   <timeless> sub on_ctcp_gender{
 888 #   <timeless>     my (undef, $event)=@_;
 889 #   <timeless>     my $nick=$event->nick;
 890 #      <Hixie>     # timeless this suspense is killing me!
 891 #   <timeless>     $bot->ctcp_reply($nick, 'neuter');
 892 #   <timeless> }
 893
 894 # on_gender: What gender are we?
 895 sub on_gender {
 896     my ($self, $event) = @_;
 897     my $nick = $event->nick;
 898     $self->ctcp_reply($nick, $gender);
 899 }
 900
 901 # on_nick: A nick changed -- was it ours?
 902 sub on_nick {
 903     my ($self, $event) = @_;
 904     if ($event->nick eq $nicks[$nick]) {
 905         on_set_nick($self, $event);
 906     }
 907     &do(@_, 'SpottedNickChange');
 908 }
 909
 910 # simple handler for when users do various things and stuff
 911 sub on_join { &do(@_, 'SpottedJoin'); }
 912 sub on_part { &do(@_, 'SpottedPart'); }
 913 sub on_quit { &do(@_, 'SpottedQuit'); }
 914 sub on_invite { &do(@_, 'Invited'); }
 915 sub on_mode { &do(@_, 'ModeChange'); } # XXX need to parse modes # XXX on key change, change %channelKeys hash
 916 sub on_umode { &do(@_, 'UModeChange'); }
 917 sub on_version { &do(@_, 'CTCPVersion'); }
 918 sub on_source { &do(@_, 'CTCPSource'); }
 919 sub on_cping { &do(@_, 'CTCPPing'); }
 920
 921 sub newEvent($) {
 922     my $event = shift;
 923     $event->{'time'} = time();
 924     return $event;
 925 }
 926
 927 sub toToChannel {
 928     my $self = shift;
 929     my $channel;
 930     foreach (@_) {
 931         if (/^[#&+\$]/os) {
 932             if (defined($channel)) {
 933                 return '';
 934             } else {
 935                 $channel = $_;
 936             }
 937         } elsif ($_ eq $nicks[$nick]) {
 938             return '';
 939         }
 940     }
 941     return lc($channel); # if message was sent to one person only, this is it
 942 }
 943
 944 # XXX some code below calls this, on lines marked "hack hack hack". We
 945 # should fix this so that those are supported calls.
 946 sub do {
 947     my $self = shift @_;
 948     my $event = shift @_;
 949     my $to = $event->to;
 950     my $channel = &toToChannel($self, @$to);
 951     my $e = newEvent({
 952         'bot' => $self,
 953         '_event' => $event, # internal internal internal do not use... ;-)
 954         'channel' => $channel,
 955         'from' => $event->nick,
 956         'target' => $channel || $event->nick,
 957         'user' => $event->userhost,
 958         'data' => join(' ', $event->args),
 959         'fulldata' => defined($event->{'__mozbot__fulldata'}) ? $event->{'__mozbot__fulldata'} : join(' ', $event->args),
 960         'to' => $to,
 961         'subtype' => $event->type,
 962         'firsttype' => $_[0],
 963         'nick' => $nicks[$nick],
 964         # level   (set below)
 965         # type  (set below)
 966     });
 967     # updated admin field if person is an admin
 968     if ($authenticatedUsers{$event->userhost}) {
 969         if (($userFlags{$authenticatedUsers{$event->userhost}} & 1) == 1) {
 970             $lastadmin = $event->nick;
 971         }
 972         $e->{'userName'} = $authenticatedUsers{$event->userhost};
 973         $e->{'userFlags'} = $userFlags{$authenticatedUsers{$event->userhost}};
 974     } else {
 975         $e->{'userName'} = 0;
 976     }
 977     unless (scalar(grep $e->{'user'} =~ /^$_$/gi, @ignoredUsers)) {
 978         my $continue;
 979         do {
 980             my $type = shift @_;
 981             my $level = 0;
 982             my @modulesInNextLoop = @modules;
 983             $continue = 1;
 984             $e->{'type'} = $type;
 985             &debug("$type: $channel <".$event->nick.'> '.join(' ', $event->args));
 986             do {
 987                 $level++;
 988                 $e->{'level'} = $level;
 989                 my @modulesInThisLoop = @modulesInNextLoop;
 990                 @modulesInNextLoop = ();
 991                 foreach my $module (@modulesInThisLoop) {
 992                     my $currentResponse;
 993                     eval {
 994                         $currentResponse = $module->do($self, $event, $type, $e);
 995                     };
 996                     if ($@) {
 997                         # $@ contains the error
 998                         &debug("ERROR IN MODULE $module->{'_name'}!!!", $@);
 999                     } elsif (!defined($currentResponse)) {
1000                         &debug("ERROR IN MODULE $module->{'_name'}: invalid response code to event '$type'.");
1001                     } else {
1002                         if ($currentResponse > $level) {
1003                             push(@modulesInNextLoop, $module);
1004                         }
1005                         $continue = ($continue and $currentResponse);
1006                     }
1007                 }
1008             } while ($continue and @modulesInNextLoop);
1009         } while ($continue and scalar(@_));
1010     } else {
1011         &debug('Ignored (from \'' . $event->userhost . "'): $channel <".$event->nick.'> '.join(' ', $event->args));
1012     }
1013     &doLog($e);
1014 }
1015
1016 sub doLog {
1017     my $e = shift;
1018     foreach my $module (@modules) {
1019         eval {
1020             $module->Log($e);
1021         };
1022         if ($@) {
1023             # $@ contains the error
1024             &debug("ERROR!!!", $@);
1025         }
1026     }
1027 }
1028
1029
1030 ################################
1031 # internal utilities           #
1032 ################################
1033
1034 my @msgqueue;
1035 my %recentMessages;
1036 my $timeLastSetAway = 0; # the time since the away flag was last set, so that we don't set it repeatedly.
1037
1038 # Use this routine, always, instead of the standard "privmsg" routine.  This
1039 # one makes sure we don't send more than one message every two seconds or so,
1040 # which will make servers not whine about us flooding the channel.
1041 # messages aren't the only type of flood :-( away is included
1042 sub sendmsg {
1043     my ($self, $who, $msg, $do) = (@_, 'msg');
1044     unless ((defined($do) and defined($msg) and defined($who) and ($who ne '')) and
1045             ((($do eq 'msg') and (not ref($msg))) or
1046              (($do eq 'me') and (not ref($msg))) or
1047              (($do eq 'notice') and (not ref($msg))) or
1048              (($do eq 'ctcpSend') and (ref($msg) eq 'ARRAY') and (@$msg >= 2)) or
1049              (($do eq 'ctcpReply') and (not ref($msg))))) {
1050         cluck('Wrong arguments passed to sendmsg() - ignored');
1051     } else {
1052         $self->schedule($delaytime / 2, \&drainmsgqueue) unless @msgqueue;
1053         if ($do eq 'msg' or $do eq 'me' or $do eq 'notice') {
1054             foreach (splitMessageAcrossLines($msg)) {
1055                 push(@msgqueue, [$who, $_, $do]);
1056             }
1057         } else {
1058             push(@msgqueue, [$who, $msg, $do]);
1059         }
1060     }
1061 }
1062
1063 # send any pending messages
1064 sub drainmsgqueue {
1065     my $self = shift;
1066     return unless $self->connected;
1067     my $qln = @msgqueue;
1068     if (@msgqueue > 0) {
1069         my ($who, $msg, $do) = getnextmsg();
1070         unless (weHaveSaidThisTooManyTimesAlready($self, \$who, \$msg, \$do)) {
1071             my $type;
1072             if ($do eq 'msg') {
1073                 &debug("->$who: $msg"); # XXX this makes logfiles large quickly...
1074                 $self->privmsg($who, $msg); # it seems 'who' can be an arrayref and it works
1075                 $type = 'Heard';
1076             } elsif ($do eq 'me') {
1077                 &debug("->$who * $msg"); # XXX
1078                 $self->me($who, $msg);
1079                 $type = 'Saw';
1080             } elsif ($do eq 'notice') {
1081                 &debug("=notice=>$who: $msg");
1082                 $self->notice($who, $msg);
1083                 # $type = 'XXX';
1084             } elsif ($do eq 'ctcpSend') {
1085                 { local $" = ' '; &debug("->$who CTCP PRIVMSG @$msg"); }
1086                 my $type = shift @$msg; # @$msg contains (type, args)
1087                 $self->ctcp($type, $who, @$msg);
1088                 # $type = 'XXX';
1089             } elsif ($do eq 'ctcpReply') {
1090                 &debug("->$who CTCP NOTICE $msg");
1091                 $self->ctcp_reply($who, $msg);
1092                 # $type = 'XXX';
1093             } else {
1094                 &debug("Unknown action '$do' intended for '$who' (content: '$msg') ignored.");
1095             }
1096             if (defined($type)) {
1097                 &doLog(newEvent({
1098                     'bot' => $self,
1099                     '_event' => undef,
1100                     'channel' => &toToChannel($self, $who),
1101                     'from' => $nicks[$nick],
1102                     'target' => $who,
1103                     'user' => undef, # XXX
1104                     'data' => $msg,
1105                     'fulldata' => $msg,
1106                     'to' => $who,
1107                     'subtype' => undef,
1108                     'firsttype' => $type,
1109                     'nick' => $nicks[$nick],
1110                     'level' => 0,
1111                     'type' => $type,
1112                 }));
1113             }
1114         }
1115         if (@msgqueue > 0) {
1116             if ((@msgqueue % 10 == 0) and (time() - $timeLastSetAway > 5 * $delaytime)) {
1117                 &bot_longprocess($self, "Long send queue. There were $qln, and I just sent one to $who.");
1118                 $timeLastSetAway = time();
1119                 $self->schedule($delaytime * 4, # because previous one counts as message, plus you want to delay an extra bit regularly
1120                     \&drainmsgqueue);
1121             } else {
1122                 $self->schedule($delaytime, \&drainmsgqueue);
1123             }
1124         } else {
1125             &bot_back($self); # clear away state
1126         }
1127     }
1128 }
1129
1130 sub weHaveSaidThisTooManyTimesAlready {
1131     my($self, $who, $msg, $do) = @_;
1132     my $key;
1133     if ($$do eq 'ctcpSend') {
1134         local $" = ',';
1135         $key = "$$who,$$do,@{$$msg}";
1136     } else {
1137         $key = "$$who,$$do,$$msg";
1138     }
1139     my $count = ++$recentMessages{$key};
1140     if ($count >= $recentMessageCountThreshold and
1141         $count < $recentMessageCountThreshold + 1 and
1142         $$do ne 'ctcpSend') {
1143         $recentMessages{$key} += $recentMessageCountPenalty;
1144         my $text = $$msg;
1145         if (length($msg) > 23) { # arbitrary length (XXX)
1146             $text = substr($text, 0, 20) . '...';
1147         }
1148         $$do = 'me';
1149         $$msg = "was going to say '$text' but has said it too many times today already";
1150     } elsif ($count >= $recentMessageCountThreshold) {
1151         if ($count > $recentMessageCountLimit) {
1152             # if the message keeps getting output, we'll get to the
1153             # point where if it stops it doesn't matter because the
1154             # recent count will be _so_ high we'll never see zero
1155             # again. So here we put a cap on the recent message count.
1156             $recentMessages{$key} = $recentMessageCountLimit;
1157         }
1158         if ($$do eq 'msg') {
1159             &debug("MUTED: ->$$who: $$msg");
1160         } elsif ($$do eq 'me') {
1161             &debug("MUTED: ->$$who * $$msg"); # XXX
1162         } elsif ($$do eq 'notice') {
1163             &debug("MUTED: =notice=>$$who: $$msg");
1164         } elsif ($$do eq 'ctcpSend') {
1165             local $" = ' ';
1166             &debug("MUTED: ->$$who CTCP PRIVMSG @{$$msg}");
1167         } elsif ($$do eq 'ctcpReply') {
1168             &debug("MUTED: ->$$who CTCP NOTICE $$msg");
1169         } else {
1170             &debug("MUTED: Unknown action '$$do' intended for '$$who' (content: '$$msg') ignored.");
1171         }
1172         return 1;
1173     }
1174     return 0;
1175 }
1176
1177 sub lowerRecentMessageCount {
1178     my $self = shift;
1179     return unless $self->connected;
1180     foreach my $key (keys %recentMessages) {
1181         $recentMessages{$key} -= $recentMessageCountDecrementRate;
1182         if ($recentMessages{$key} <= 0) {
1183             delete $recentMessages{$key};
1184         }
1185     }
1186     $self->schedule($delaytime, \&lowerRecentMessageCount);
1187 }
1188
1189 # wrap long lines at spaces and hard returns (\n)
1190 # this is for IRC, not for the console -- long can be up to 255
1191 sub splitMessageAcrossLines {
1192     my ($str) = @_;
1193     my $MAXPROTOCOLLENGTH = 255;
1194     my @output;
1195     # $str could be several lines split with \n, so split it first:
1196     foreach my $line (split(/\n/, $str)) {
1197         while (length($line) > $MAXPROTOCOLLENGTH) {
1198             # position is zero-based index
1199             my $pos = rindex($line, ' ', $MAXPROTOCOLLENGTH - 1);
1200             if ($pos < 0) {
1201                 $pos = $MAXPROTOCOLLENGTH - 1;
1202             }
1203             push(@output, substr($line, 0, $pos));
1204             $line = substr($line, $pos);
1205             $line =~ s/^\s+//gos;
1206         }
1207         push(@output, $line) if length($line);
1208     }
1209     return @output;
1210 }
1211
1212 # equivalent of shift or pop, but for the middle of the array.
1213 # used by getnextmsg() below to pull the messages out of the
1214 # msgqueue stack and shove them at the end.
1215 sub yank {
1216     my ($index, $list) = @_;
1217     my $result = @{$list}[$index];
1218     @{$list} = (@{$list}[0..$index-1], @{$list}[$index+1..$#{$list}]);
1219     return $result;
1220 }
1221
1222 # looks at the msgqueue stack and decides which message to send next.
1223 sub getnextmsg {
1224     my ($who, $msg, $do) = @{shift(@msgqueue)};
1225     my @newmsgqueue;
1226     my $index = 0;
1227     while ($index < @msgqueue) {
1228         if ($msgqueue[$index]->[0] eq $who) {
1229             push(@newmsgqueue, &yank($index, \@msgqueue));
1230         } else {
1231             $index++;
1232         }
1233     }
1234     push(@msgqueue, @newmsgqueue);
1235     return ($who, $msg, $do);
1236 }
1237
1238 my $markedaway = 0;
1239
1240 # mark bot as being away
1241 sub bot_longprocess {
1242     my $self = shift;
1243     &debug('[away: '.join(' ',@_).']');
1244     $self->away(join(' ',@_));
1245     $markedaway = @_;
1246 }
1247
1248 # mark bot as not being away anymore
1249 sub bot_back {
1250     my $self = shift;
1251     $self->away('') if $markedaway;
1252     $markedaway = 0;
1253 }
1254
1255
1256 # internal routines for IO::Select handling
1257
1258 sub bot_select {
1259     my ($pipe) = @_;
1260     $irc->removefh($pipe);
1261     # enable slurp mode for this function (see man perlvar for $/ documentation)
1262     local $/;
1263     undef $/;
1264     my $data = <$pipe>;
1265     &debug("child ${$pipe}->{'BotModules_PID'} completed ${$pipe}->{'BotModules_ChildType'}".
1266            (${$pipe}->{'BotModules_Module'}->{'_shutdown'} ?
1267             ' (nevermind, module has shutdown)': ''));
1268     kill 9, ${$pipe}->{'BotModules_PID'}; # ensure child is dead
1269     # non-blocking reap of any pending zombies
1270     1 while waitpid(-1,WNOHANG) > 0;
1271     return if ${$pipe}->{'BotModules_Module'}->{'_shutdown'}; # see unload()
1272     eval {
1273         ${$pipe}->{'BotModules_Event'}->{'time'} = time(); # update the time field of the event
1274         ${$pipe}->{'BotModules_Module'}->ChildCompleted(
1275             ${$pipe}->{'BotModules_Event'},
1276             ${$pipe}->{'BotModules_ChildType'},
1277             $data,
1278             @{${$pipe}->{'BotModules_Data'}}
1279         );
1280     };
1281     if ($@) {
1282         # $@ contains the error
1283         &debug("ERROR!!!", $@);
1284     }
1285     # prevent any memory leaks by cleaning up all the variables we added
1286     foreach (keys %{${$pipe}}) {
1287         m/^BotModules_/ && delete(${$pipe}->{$_});
1288     }
1289 }
1290
1291 sub bot_select_data_available {
1292     my ($handle) = @_;
1293     &debug("Module ${$handle}->{'BotModules_Module'}->{'_name'} received some data");
1294     # read data while there is some
1295     my $fh = '';
1296     vec($fh, fileno($handle), 1) = 1;
1297     my $count = 0; # number of bytes read
1298     my $ready;
1299     my $data = '';
1300     my $close = 0;
1301     while (select($ready = $fh, undef, undef, 0.1) and
1302            vec($ready, fileno($handle), 1) and
1303            $count < 1024 and
1304            not $close) { # read up to 1kb
1305         sysread($handle, $data, 1, length($data)) or $close = 1;
1306     }
1307     if (not ${$handle}->{'BotModules_Module'}->{'_shutdown'}) {
1308         eval {
1309             ${$handle}->{'BotModules_Event'}->{'time'} = time();
1310             ${$handle}->{'BotModules_Module'}->DataAvailable(
1311                 ${$handle}->{'BotModules_Event'},
1312                 $handle,
1313                 $data,
1314                 $close,
1315             );
1316         };
1317         if ($@) {
1318             # $@ contains the error
1319             &debug("ERROR!!!", $@);
1320         }
1321     } else {
1322         # module doesn't care, it was shut down
1323         &debug("Dropping data - module is already shut down.");
1324         $close = 1;
1325     }
1326     if ($close) {
1327         # Note: It's the responsibility of the module to actually
1328         # close the handle.
1329         &debug("Dropping handle...");
1330         $irc->removefh($handle);
1331         # prevent any memory leaks by cleaning up all the variables we added
1332         foreach (keys %{${$handle}}) {
1333             m/^BotModules_/ && delete(${$handle}->{$_});
1334         }
1335     }
1336 }
1337
1338
1339 # internal routines for console output, stuff
1340
1341 # print debugging info
1342 sub debug {
1343     my $line;
1344     foreach (@_) {
1345         $line = $_; # can't chomp $_ since it is a hardref to the arguments...
1346         chomp $line; # ...and they are probably a constant string!
1347         if (-t) {
1348             print &logdate() . " ($$) $line";
1349         }
1350         if ($LOGGING) {
1351             # XXX this file grows without bounds!!!
1352             if (open(LOG, ">>$LOGFILEPREFIX.$$.log")) {
1353                 print LOG &logdate() . " $line\n";
1354                 close(LOG);
1355                 print "\n";
1356             } else {
1357                 print " [not logged, $!]\n";
1358             }
1359         }
1360     }
1361 }
1362
1363 # logdate: return nice looking date and time stamp
1364 sub logdate {
1365     my ($sec, $min, $hour, $mday, $mon, $year) = gmtime(shift or time());
1366     return sprintf("%d-%02d-%02d %02d:%02d:%02d UTC",
1367                    $year + 1900, $mon + 1, $mday, $hour, $min, $sec);
1368 }
1369
1370 # days: how long ago was that?
1371 sub days {
1372     my $then = shift;
1373     # maths
1374     my $seconds = time() - $then;
1375     my $minutes = int ($seconds / 60);
1376     my $hours = int ($minutes / 60);
1377     my $days = int ($hours / 24);
1378     # english
1379     if ($seconds < 60) {
1380         return sprintf("%d second%s", $seconds, $seconds == 1 ? "" : "s");
1381     } elsif ($minutes < 60) {
1382         return sprintf("%d minute%s", $minutes, $minutes == 1 ? "" : "s");
1383     } elsif ($hours < 24) {
1384         return sprintf("%d hour%s", $hours, $hours == 1 ? "" : "s");
1385     } else {
1386         return sprintf("%d day%s", $days, $days == 1 ? "" : "s");
1387     }
1388 }
1389
1390 # signal handler
1391 sub killed {
1392     my($sig) = @_;
1393     &debug("received signal $sig. shutting down...");
1394     &debug('This is evil. You should /msg me a shutdown command instead.');
1395     &debug('WARNING: SHUTTING ME DOWN LIKE THIS CAN CAUSE FORKED PROCESSES TO START UP AS BOTS!!!'); # XXX which we should fix, of course.
1396     exit(1); # sane exit, including shutting down any modules
1397 }
1398
1399
1400 # internal routines for configuration
1401
1402 my %configStructure; # hash of cfg file keys and associated variable refs
1403
1404 # ok. In strict 'refs' mode, you cannot use strings as refs. Fair enough.
1405 # However, hash keys are _always_ strings. Using a ref as a hash key turns
1406 # it into a string. So we have to keep a virgin copy of the ref around.
1407 #
1408 # So the structure of the %configStructure hash is:
1409 #   "ref" => [ cfgName, ref ]
1410 # Ok?
1411
1412 sub registerConfigVariables {
1413     my (@variables) = @_;
1414     foreach (@variables) {
1415         $configStructure{$$_[0]} = [$$_[1], $$_[0]];
1416     }
1417 } # are you confused yet?
1418
1419 sub configStructure {
1420     my (@variables) = @_;
1421     my %struct;
1422     @variables = keys %configStructure unless @variables;
1423     foreach (@variables) {
1424         confess("Function configStructure was passed something that is either not a ref or has not yet neem registered, so aborted") unless defined($configStructure{$_});
1425         $struct{$configStructure{$_}[0]} = $configStructure{$_}[1];
1426     }
1427     return \%struct;
1428 }
1429
1430
1431 # internal routines for handling the modules
1432
1433 sub getModule {
1434     my ($name) = @_;
1435     foreach my $module (@modules) { # XXX this is not cached as a hash as performance is not a priority here
1436         return $module if $name eq $module->{'_name'};
1437     }
1438     return undef;
1439 }
1440
1441 sub LoadModule {
1442     my ($name) = @_;
1443     # sanitize the name
1444     $name =~ s/[^-a-zA-Z0-9]/-/gos;
1445     # check the module is not already loaded
1446     foreach (@modules) {
1447         if ($_->{'_name'} eq $name) {
1448             return "Failed [0]: Module already loaded. Don't forget to enable it in the various channels (vars $name channels '+#channelname').";
1449         }
1450     }
1451     # read the module in from a file
1452     my $filename = "./BotModules/$name.bm"; # bm = bot module
1453     my $result = open(my $file, "< $filename");
1454     if ($result) {
1455         my $code = do {
1456             local $/ = undef; # enable "slurp" mode
1457             <$file>; # whole file now here
1458         };
1459         if ($code) {
1460 #           if ($code =~ /package\s+\QBotModules::$name\E\s*;/gos) { XXX doesn't work reliably?? XXX
1461                 # eval the file
1462                 $code =~ /^(.*)$/os;
1463                 $code = $1; # completely defeat the tainting mechanism.
1464                 # $code = "# FILE: $filename\n".$code; # "# file 1 '$filename' \n" would be good without Carp.pm
1465                 { no warnings; # as per the warning, but doesn't work??? XXX
1466                 eval($code); }
1467                 if ($@) {
1468                     # $@ contains the error
1469                     return "Failed [4]: $@";
1470                 } else {
1471                     # if ok, then create a module
1472                     my $newmodule;
1473                     eval("
1474                         \$newmodule = BotModules::$name->create('$name', '$filename');
1475                     ");
1476                     if ($@) {
1477                         # $@ contains the error
1478                         return "Failed [5]: $@";
1479                     } else {
1480                         # if ok, then add it to the @modules list
1481                         push(@modules, $newmodule);
1482                         push(@modulenames, $newmodule->{'_name'});
1483                         &Configuration::Save($cfgfile, &::configStructure(\@modulenames));
1484                         # Done!!!
1485                         return $newmodule;
1486                     }
1487                 }
1488 #           } else {
1489 #               return "Failed [3]: Could not find valid module definition line.";
1490 #           }
1491         } else {
1492             # $! contains the error
1493             if ($!) {
1494                 return "Failed [2]: $!";
1495             } else {
1496                 return "Failed [2]: Module file is empty.";
1497             }
1498         }
1499     } else {
1500         # $! contains the error
1501         return "Failed [1]: $!";
1502     }
1503 }
1504
1505 sub UnloadModule {
1506     my ($name) = @_;
1507     # remove the reference from @modules
1508     my @newmodules;
1509     my @newmodulenames;
1510     foreach (@modules) {
1511         if ($name eq $_->{'_name'}) {
1512             if ($_->{'_static'}) {
1513                 return 'Cannot unload this module, it is built in.';
1514             }
1515             $_->unload();
1516         } else {
1517             push(@newmodules, $_);
1518             push(@newmodulenames, $_->{'_name'});
1519         }
1520     }
1521     if (@modules == @newmodules) {
1522         return 'Module not loaded. Are you sure you have the right name?';
1523     } else {
1524         @modules = @newmodules;
1525         @modulenames = @newmodulenames;
1526         &Configuration::Save($cfgfile, &::configStructure(\@modulenames));
1527         return;
1528     }
1529 }
1530
1531 # password management functions
1532
1533 sub getSalt {
1534     # straight from man perlfunc
1535     return join('', ('.', '/', 0..9, 'A'..'Z', 'a'..'z')[rand 64, rand 64]);
1536 }
1537
1538 sub newPassword {
1539     my($text) = @_;
1540     return crypt($text, &getSalt());
1541 }
1542
1543 sub checkPassword {
1544     my($text, $password) = @_;
1545     return (crypt($text, $password) eq $password);
1546 }
1547
1548 ################################
1549 # Base Module                  #
1550 ################################
1551
1552 # And now, for my next trick, the base module (duh).
1553
1554 package BotModules;
1555
1556 1; # nothing to see here...
1557
1558 # ENGINE INTERFACE
1559
1560 # create - create a new BotModules object.
1561 # Do not call this yourself. We call it. Ok?
1562 # Do not override this either, unless you know what
1563 # you are doing (I don't, and I wrote it...). If you
1564 # want to add variables to $self, use Initialise.
1565 # The parameter is the name of the module.
1566 sub create {
1567     my $class = shift;
1568     my ($name, $filename) = @_;
1569     my $self = {
1570         '_name' => $name,
1571         '_shutdown' => 0, # see unload()
1572         '_static' => 0, # set to 1 to prevent module being unloaded
1573         '_variables' => {},
1574         '_config' => {},
1575         '_filename' => $filename,
1576         '_filemodificationtime' => undef,
1577     };
1578     bless($self, $class);
1579     $self->Initialise();
1580     $self->RegisterConfig();
1581     return $self;
1582 }
1583
1584 sub DESTROY {
1585     my $self = shift;
1586     $self->debug('garbage collected');
1587 }
1588
1589 # called by &::UnloadModule().
1590 # this removes any pointers to the module.
1591 # for example, it stops the scheduler from installing new timers,
1592 # so that the bot [eventually] severs its connection with the module.
1593 sub unload {
1594     my $self = shift;
1595     $self->Unload(); # hook for bot modules to use
1596     $self->{'_shutdown'} = 1; # see doScheduled and bot_select
1597 }
1598
1599 # configStructure - return the hash needed for Configuration module
1600 sub configStructure {
1601     my $self = shift;
1602     return $self->{'_config'};
1603 }
1604
1605 # do - called to do anything (duh) (no, do, not duh) (oh, ok, sorry)
1606 sub do {
1607     my $self = shift;
1608     my ($bot, $event, $type, $e) = @_;
1609     # first, we check that the user is not banned from using this module. If he
1610     # is, then re give up straight away.
1611     return 1 if ($self->IsBanned($e));
1612     # next we check that the module is actually enabled in this channel, and
1613     # if it is not we quit straight away as well.
1614     return 1 unless ($e->{'channel'} eq '') or ($self->InChannel($e));
1615     # Ok, dispatch the event.
1616     if ($type eq 'Told') {
1617         return $self->Told($e, $e->{'data'});
1618     } elsif ($type eq 'Heard') {
1619         return $self->Heard($e, $e->{'data'});
1620     } elsif ($type eq 'Baffled') {
1621         return $self->Baffled($e, $e->{'data'});
1622     } elsif ($type eq 'Noticed') {
1623         return $self->Noticed($e, $e->{'data'});
1624     } elsif ($type eq 'Felt') {
1625         return $self->Felt($e, $e->{'data'});
1626     } elsif ($type eq 'Saw') {
1627         return $self->Saw($e, $e->{'data'});
1628     } elsif ($type eq 'Invited') {
1629         return $self->Invited($e, $e->{'data'});
1630     } elsif ($type eq 'Kicked') {
1631         return $self->Kicked($e, $e->{'channel'});
1632     } elsif ($type eq 'ModeChange') {
1633         return $self->ModeChange($e, $e->{'channel'}, $e->{'data'}, $e->{'from'});
1634     } elsif ($type eq 'Authed') {
1635         return $self->Authed($e, $e->{'from'});
1636     } elsif ($type eq 'SpottedNickChange') {
1637         return $self->SpottedNickChange($e, $e->{'from'}, $e->{'data'});
1638     } elsif ($type eq 'SpottedTopicChange') {
1639         return $self->SpottedTopicChange($e, $e->{'channel'}, $e->{'data'});
1640     } elsif ($type eq 'SpottedJoin') {
1641         return $self->SpottedJoin($e, $e->{'channel'}, $e->{'from'});
1642     } elsif ($type eq 'SpottedPart') {
1643         return $self->SpottedPart($e, $e->{'channel'}, $e->{'from'});
1644     } elsif ($type eq 'SpottedKick') {
1645         return $self->SpottedKick($e, $e->{'channel'}, $e->{'data'});
1646     } elsif ($type eq 'SpottedQuit') {
1647         return $self->SpottedQuit($e, $e->{'from'}, $e->{'data'});
1648     } elsif ($type eq 'CTCPPing') {
1649         return $self->CTCPPing($e, $e->{'from'}, $e->{'data'});
1650     } elsif ($type eq 'CTCPVersion') {
1651         return $self->CTCPVersion($e, $e->{'from'}, $e->{'data'});
1652     } elsif ($type eq 'CTCPSource') {
1653         return $self->CTCPSource($e, $e->{'from'}, $e->{'data'});
1654
1655     # XXX have not implemented mode parsing yet
1656     } elsif ($type eq 'GotOpped') {
1657         return $self->GotOpped($e, $e->{'channel'}, $e->{'from'});
1658     } elsif ($type eq 'GotDeopped') {
1659         return $self->GotDeopped($e, $e->{'channel'}, $e->{'from'});
1660     } elsif ($type eq 'SpottedOpping') {
1661         return $self->SpottedOpping($e, $e->{'channel'}, $e->{'from'});
1662     } elsif ($type eq 'SpottedDeopping') {
1663         return $self->SpottedDeopping($e, $e->{'channel'}, $e->{'from'});
1664     } else {
1665         $self->debug("Unknown action type '$type'. Ignored.");
1666         # XXX UModeChange (not implemented yet)
1667         return 1; # could not do it
1668     }
1669 }
1670
1671
1672 # MODULE API - use these from the your routines.
1673
1674 # prints output to the console
1675 sub debug {
1676     my $self = shift;
1677     foreach my $line (@_) {
1678         &::debug('Module '.$self->{'_name'}.': '.$line);
1679     }
1680 }
1681
1682 # saveConfig - call this when you change a configuration option. It resaves the config file.
1683 sub saveConfig {
1684     my $self = shift;
1685     &Configuration::Save($cfgfile, $self->configStructure());
1686 }
1687
1688 # registerVariables - Registers a variable with the config system and the var setting system
1689 # parameters: (
1690 #     [ 'name', persistent ? 1:0, editable ? 1:0, $value ],
1691 #               use undef instead of 0 or 1 to leave as is
1692 #               use undef (or don't mention) the $value to not set the value
1693 # )
1694 sub registerVariables {
1695     my $self = shift;
1696     my (@variables) = @_;
1697     foreach (@variables) {
1698         $self->{$$_[0]} = $$_[3] if defined($$_[3]);
1699         if (defined($$_[1])) {
1700             if ($$_[1]) {
1701                 $self->{'_config'}->{$self->{'_name'}.'::'.$$_[0]} = \$self->{$$_[0]};
1702             } else {
1703                 delete($self->{'_config'}->{$self->{'_name'}.'::'.$$_[0]});
1704             }
1705         }
1706         $self->{'_variables'}->{$$_[0]} = $$_[2] if defined($$_[2]);
1707     }
1708 }
1709
1710 # internal implementation of the scheduler
1711 sub doScheduled {
1712     my $bot = shift;
1713     my ($self, $event, $time, $times, @data) = @_;
1714     return if ($self->{'_shutdown'}); # see unload()
1715     # $self->debug("scheduled event occured; $times left @ $$time second interval");
1716     eval {
1717         $event->{'time'} = time(); # update the time field of the event
1718         $self->Scheduled($event, @data);
1719         $self->schedule($event, $time, --$times, @data);
1720     };
1721     if ($@) {
1722         # $@ contains the error
1723         &::debug("ERROR!!!", $@);
1724     }
1725 }
1726
1727 # schedule - Sets a timer to call Scheduled later
1728 # for events that should be setup at startup, call this from Schedule().
1729 sub schedule {
1730     my $self = shift;
1731     my ($event, $time, $times, @data) = @_;
1732     return if ($times == 0 or $self->{'_shutdown'}); # see unload()
1733     $times = -1 if ($times < 0); # pass a negative number to have a recurring timer
1734     my $delay = $time;
1735     if (ref($time)) {
1736         if (ref($time) eq 'SCALAR') {
1737             $delay = $$time;
1738         } else {
1739             return; # XXX maybe be useful?
1740         }
1741     }
1742     # if ($delay < 1) {
1743     #     $self->debug("Vetoed aggressive scheduling; forcing to 1 second minimum");
1744     #     $delay = 1;
1745     # }
1746     $event->{'bot'}->schedule($delay, \&doScheduled, $self, $event, $time, $times, @data);
1747 }
1748
1749 # spawnChild - spawns a child process and adds it to the list of file handles to monitor
1750 # eventually the bot calls ChildCompleted() with the output of the child process.
1751 sub spawnChild {
1752     my $self = shift;
1753     my ($event, $command, $arguments, $type, $data) = @_;
1754     # uses IO::SecurePipe and fork and exec
1755     # secure, predictable, no dependencies on external code
1756     # uses fork explicitly (and once implicitly)
1757     my $pipe = IO::SecurePipe->new();
1758     if (defined($pipe)) {
1759         my $child = fork();
1760         if (defined($child)) {
1761             if ($child) {
1762                 # we are the parent process
1763                 $pipe->reader();
1764                 ${$pipe}->{'BotModules_Module'} = $self;
1765                 ${$pipe}->{'BotModules_Event'} = {%$event}; # Must be unchanged
1766                 ${$pipe}->{'BotModules_ChildType'} = $type;
1767                 ${$pipe}->{'BotModules_Data'} = $data;
1768                 ${$pipe}->{'BotModules_Command'} = $command;
1769                 ${$pipe}->{'BotModules_Arguments'} = $arguments;
1770                 ${$pipe}->{'BotModules_PID'} = $child;
1771                 $irc->addfh($pipe, \&::bot_select);
1772                 local $" = ' ';
1773                 $self->debug("spawned $child ($command @$arguments)");
1774                 return 0;
1775             } else {
1776                 eval {
1777                     # we are the child process
1778                     # call $command and buffer the output
1779                     $pipe->writer(); # get writing end of pipe, ready to output the result
1780                     my $output;
1781                     if (ref($command) eq 'CODE') {
1782                         $output = &$command(@$arguments);
1783                     } else {
1784                         # it would be nice if some of this was on a timeout...
1785                         my $result = IO::SecurePipe->new(); # create a new pipe for $command
1786                         # call $command (implicit fork(), which may of course fail)
1787                         $result->reader($command, @$arguments);
1788                         local $/; # to not affect the rest of the program (what little there is)
1789                         $/ = \(2*1024*1024); # slurp up to two megabytes
1790                         $output = <$result>; # blocks until child process has finished
1791                         close($result); # reap child
1792                     }
1793                     print $pipe $output if ($output); # output the lot in one go back to parent
1794                     $pipe->close();
1795                 };
1796                 if ($@) {
1797                     # $@ contains the error
1798                     $self->debug('failed to spawn child', $@);
1799                 }
1800
1801                 # -- #mozwebtools was here --
1802                 #       <dawn> when is that stupid bot going to get checked in?
1803                 #   <timeless> after it stops fork bombing
1804                 #       <dawn> which one? yours or hixies?
1805                 #   <timeless> his, mine doesn't fork
1806                 #   <timeless> see topic
1807                 #       <dawn> are there plans to fix it?
1808                 #   <timeless> yes. but he isn't sure exactly what went wrong
1809                 #   <timeless> i think it's basically they fork for wget
1810                 #       <dawn> why don't you help him?
1811                 #   <timeless> i don't understand forking
1812                 #       <dawn> that didn't stop hixie
1813                 #   <timeless> not to mention the fact that his forking doesn't
1814                 #              work on windows
1815                 #       <dawn> you have other machines. techbot1 runs on windows?
1816                 #   <timeless> yeah it runs on windows
1817                 #       <dawn> oh
1818                 #       <dawn> get a real os, man
1819
1820                 # The bug causing the 'fork bombing' was that I only
1821                 # did the following if $@ was true or if the call to
1822                 # 'reader' succeeded -- so if some other error occured
1823                 # that didn't trip the $@ test but still crashed out
1824                 # of the eval, then the script would quite happily
1825                 # continue, and when it eventually died (e.g. because
1826                 # of a bad connection), it would respawn multiple
1827                 # times (as many times as it had failed to fork) and
1828                 # it would succeed in reconnecting as many times as
1829                 # had been configured nicks...
1830
1831                 eval {
1832                     $0 =~ m/^(.*)$/os; # untaint $0 so that we can call it below:
1833                     exec { $1 } ($1, '--abort'); # do not call shutdown handlers
1834                     # the previous line works because exec() bypasses
1835                     # the perl object garbarge collection and simply
1836                     # deallocates all the memory in one go. This means
1837                     # the shutdown handlers (DESTROY and so on) are
1838                     # never called for this fork. This is good,
1839                     # because otherwise we would disconnect from IRC
1840                     # at this point!
1841                 };
1842
1843                 $self->debug("failed to shutdown cleanly!!! $@");
1844                 exit(1); # exit in case exec($0) failed
1845
1846             }
1847         } else {
1848             $self->debug("failed to fork: $!");
1849         }
1850     } else {
1851         $self->debug("failed to open pipe: $!");
1852     }
1853     return 1;
1854 }
1855
1856 # registerDataHandle - eventually calls DataAvailable
1857 sub registerDataHandle {
1858     my $self = shift;
1859     my ($event, $handle, $details) = @_;
1860     ${$handle}->{'BotModules_Module'} = $self;
1861     ${$handle}->{'BotModules_Event'} = $event;
1862     ${$handle}->{'BotModules_Details'} = $details;
1863     $irc->addfh($handle, \&::bot_select_data_available);
1864     my $fileno = fileno($handle);
1865     $self->debug("listening to filehandle or socket $fileno");
1866 }
1867
1868 # getURI - Downloads a file and then calls GotURI
1869 sub getURI {
1870     my $self = shift;
1871     my ($event, $uri, @data) = @_;
1872     $self->spawnChild($event, 'wget', ['--quiet', '--passive', '--user-agent="Mozilla/5.0 (compatible; mozbot)"',  '--output-document=-', $uri], 'URI', [$uri, @data]);
1873 }
1874
1875 # returns a reference to a module -- DO NOT STORE THIS REFERENCE!!!
1876 sub getModule {
1877     my $self = shift;
1878     return &::getModule(@_);
1879 }
1880
1881 # returns a reference to @msgqueue
1882 # manipulating this is probably not a good idea. In particular,
1883 # don't add anything to this array (use the appropriate methods
1884 # instead, those that use &::sendmsg, below).
1885 sub getMessageQueue {
1886     my $self = shift;
1887     return \@msgqueue;
1888 }
1889
1890 # returns the value of $helpline
1891 sub getHelpLine {
1892     return $helpline;
1893 }
1894
1895 # returns a sorted list of module names
1896 sub getModules {
1897     return sort(@modulenames);
1898 }
1899
1900 # returns a filename with path suitable to use for logging
1901 sub getLogFilename {
1902     my $self = shift;
1903     my($name) = @_;
1904     return "$LOGFILEDIR/$name";
1905 }
1906
1907 # tellAdmin - may try to talk to an admin.
1908 # NO GUARANTEES! This will PROBABLY NOT reach anyone!
1909 sub tellAdmin {
1910     my $self = shift;
1911     my ($event, $data) = @_;
1912     if ($lastadmin) {
1913         $self->debug("Trying to tell admin '$lastadmin' this: $data");
1914         &::sendmsg($event->{'bot'}, $lastadmin, $data);
1915     } else {
1916         $self->debug("Wanted to tell an admin '$data', but I've never seen one.");
1917     }
1918 }
1919
1920 # ctcpSend - Sends a CTCP message to someone
1921 sub ctcpSend {
1922     my $self = shift;
1923     my ($event, $type, $data) = @_;
1924     &::sendmsg($event->{'bot'}, $event->{'target'}, [$type, $data], 'ctcpSend');
1925 }
1926
1927 # ctcpReply - Sends a CTCP reply to someone
1928 sub ctcpReply {
1929     my $self = shift;
1930     my ($event, $type, $data) = @_;
1931     unless (defined($type)) {
1932         cluck('No type passed to ctcpReply - ignored');
1933     }
1934     if (defined($data)) {
1935         &::sendmsg($event->{'bot'}, $event->{'from'}, "$type $data", 'ctcpReply');
1936     } else {
1937         &::sendmsg($event->{'bot'}, $event->{'from'}, $type, 'ctcpReply');
1938     }
1939 }
1940
1941 # notice - Sends a notice to a channel or person
1942 sub notice {
1943     my $self = shift;
1944     my ($event, $data) = @_;
1945     &::sendmsg($event->{'bot'}, $event->{'target'}, $data, 'notice');
1946 }
1947
1948 # say - Sends a message to the channel
1949 sub say {
1950     my $self = shift;
1951     my ($event, $data) = @_;
1952     return unless defined $event->{'target'};
1953     $data =~ s/^\Q$event->{'target'}\E: //gs;
1954     &::sendmsg($event->{'bot'}, $event->{'target'}, $data);
1955 }
1956
1957 # privsay - Sends message to person or channel directly
1958 # only use this if its time-senstive, otherwise you should use say
1959 sub privsay {
1960         my $self = shift;
1961     my ($event, $data) = @_;
1962         return unless defined $event->{'target'};
1963         $data =~ s/^\Q$event->{'target'}\E: //gs;
1964         $event->{'bot'}->privmsg($event->{'target'}, $data);
1965 }
1966
1967 # announce - Sends a message to every channel
1968 sub announce {
1969     my $self = shift;
1970     my ($event, $data) = @_;
1971     foreach (@{$self->{'channels'}}) {
1972         &::sendmsg($event->{'bot'}, $_, $data);
1973     }
1974 }
1975
1976 # directSay - Sends a message to the person who spoke
1977 sub directSay {
1978     my $self = shift;
1979     my ($event, $data) = @_;
1980     &::sendmsg($event->{'bot'}, $event->{'from'}, $data);
1981 }
1982
1983 # channelSay - Sends a message to the channel the message came from, IFF it came from a channel.
1984 sub channelSay {
1985     my $self = shift;
1986     my ($event, $data) = @_;
1987     &::sendmsg($event->{'bot'}, $event->{'channel'}, $data) if $event->{'channel'};
1988 }
1989
1990 # -- #mozilla was here --
1991 #      <richb> timeless: it's focal review time, and they are working out
1992 #              where to allocate the money.
1993 #      <richb> timeless: needless to say i have a vested interest in this.
1994 #       <leaf> there's money in this?
1995 #   <timeless> richb yes; leaf always
1996 #       <leaf> how come nobody told me?
1997 #   <timeless> because leaf doesn't need money
1998 #   <timeless> for leaf it grows on trees
1999 #       <leaf> *wince*
2000
2001 # emote - Sends an emote to the channel
2002 sub emote {
2003     my $self = shift;
2004     my ($event, $data) = @_;
2005     &::sendmsg($event->{'bot'}, $event->{'target'}, $data, 'me');
2006 }
2007
2008 # directEmote - Sends an emote to the person who spoke
2009 sub directEmote {
2010     my $self = shift;
2011     my ($event, $data) = @_;
2012     &::sendmsg($event->{'bot'}, $event->{'from'}, $data, 'me');
2013 }
2014
2015 # sayOrEmote - calls say() or emote() depending on whether the string starts with /me or not.
2016 sub sayOrEmote {
2017     my $self = shift;
2018     my ($event, $data) = @_;
2019     if ($data =~ /^\/me\s+/osi) {
2020         $data =~ s/^\/me\s+//gosi;
2021         $self->emote($event, $data);
2022     } else {
2023         $self->say($event, $data);
2024     }
2025 }
2026
2027 # directSayOrEmote - as sayOrEmote() but calls the direct versions instead
2028 sub directSayOrEmote {
2029     my $self = shift;
2030     my ($event, $data) = @_;
2031     if ($data =~ /^\/me\s+/osi) {
2032         $data =~ s/^\/me\s+//gosi;
2033         $self->directEmote($event, $data);
2034     } else {
2035         $self->directSay($event, $data);
2036     }
2037 }
2038
2039 # isAdmin - Returns true if the person is an admin
2040 sub isAdmin {
2041     my $self = shift;
2042     my ($event) = @_;
2043     return (($event->{'userName'}) and (($event->{'userFlags'} & 1) == 1));
2044 }
2045
2046 # setAway - Set the bot's 'away' flag. A blank message will mark the bot as back.
2047 # Note: If you need this you are doing something wrong!!!
2048 sub setAway {
2049     my $self = shift;
2050     my ($event, $message) = @_;
2051     $event->{'bot'}->away($message);
2052 }
2053
2054 # setNick - Set the bot's nick.
2055 # Note: Best not to use this too much, especially not based on user input,
2056 # as it is not throttled. XXX
2057 sub setNick {
2058     my $self = shift;
2059     my ($event, $value) = @_;
2060     $event->{'bot'}->nick($value);
2061 }
2062
2063 sub mode {
2064     my $self = shift;
2065     my ($event, $channel, $mode, $arg) = @_;
2066     $event->{'bot'}->mode($channel, $mode, $arg);
2067 }
2068
2069 sub kick {
2070     my $self = shift;
2071     my ($event, $channel, $who, $reason) = @_;
2072     $event->{'bot'}->kick($channel, $who, $reason);
2073 }
2074
2075 sub invite {
2076     my $self = shift;
2077     my ($event, $who, $channel) = @_;
2078     $event->{'bot'}->invite($who, $channel);
2079 }
2080
2081 # pretty printer for turning lists of varying length strings into
2082 # lists of roughly equal length strings without losing any data
2083 sub prettyPrint {
2084     my $self = shift;
2085     my ($preferredLineLength, $prefix, $indent, $divider, @input) = @_;
2086     # sort numerically descending by length
2087     @input = sort {length($b) <=> length($a)} @input;
2088     # if we have a prefix defined, it goes first (duh)
2089     unshift(@input, $prefix) if defined($prefix);
2090     my @output;
2091     my $index;
2092     while (@input) {
2093         push(@output, $indent . shift(@input));
2094         $index = 0;
2095         while (($index <= $#input) and
2096                ((length($output[$#output]) + length($input[$#input])) < $preferredLineLength)) {
2097             # does this one fit?
2098             if ((length($output[$#output]) + length($input[$index])) < $preferredLineLength) {
2099                 if (defined($prefix)) {
2100                     # don't stick the divider between the prefix and the first item
2101                     undef($prefix);
2102                 } else {
2103                     $output[$#output] .= $divider;
2104                 }
2105                 $output[$#output] .= splice(@input, $index, 1);
2106             } else {
2107                 $index++;
2108             }
2109         }
2110     }
2111     return @output;
2112 }
2113
2114 # wordWrap routines which takes a list and wraps it. A less pretty version
2115 # of prettyPrinter, but it keeps the order.
2116 sub wordWrap {
2117     my $self = shift;
2118     my ($preferredLineLength, $prefix, $indent, $divider, @input) = @_;
2119     unshift(@input, $prefix) if defined($prefix);
2120     $indent = '' unless defined($indent);
2121     my @output;
2122     while (@input) {
2123         push(@output, $indent . shift(@input));
2124         while (($#input >= 0) and
2125                ((length($output[$#output]) + length($input[0])) < $preferredLineLength)) {
2126             $output[$#output] .= $divider . shift(@input);
2127         }
2128     }
2129     return @output;
2130 }
2131
2132 sub unescapeXML {
2133     my $self = shift;
2134     my ($string) = @_;
2135     $string =~ s/&apos;/'/gos;
2136     $string =~ s/&quot;/"/gos;
2137     $string =~ s/&lt;/</gos;
2138     $string =~ s/&gt;/>/gos;
2139     $string =~ s/&amp;/&/gos;
2140     $string =~ s/&\#(\d+);/convertASCIICode($1)/ges;
2141     return $string;
2142 }
2143
2144 sub convertASCIICode {
2145     my $code = shift;
2146     return chr($code) if ($code > 31 and $code < 127);
2147     return "&#$code;";
2148 }
2149
2150 sub days {
2151     my $self = shift;
2152     my ($then) = @_;
2153     return &::days($then);
2154 }
2155
2156 # return the argument if it is a valid regular expression,
2157 # otherwise quotes the argument and returns that.
2158 sub sanitizeRegexp {
2159     my $self = shift;
2160     my ($regexp) = @_;
2161     if (defined($regexp)) {
2162         eval {
2163             '' =~ /$regexp/;
2164         };
2165         $self->debug("regexp |$regexp| returned error |$@|, quoting...") if $@;
2166         return $@ ? quotemeta($regexp) : $regexp;
2167     } else {
2168         $self->debug("blank regexp, returning wildcard regexp //...");
2169         return '';
2170     }
2171 }
2172
2173
2174 # MODULE INTERFACE (override these)
2175
2176 # Initialise - Called when the module is loaded
2177 sub Initialise {
2178     my $self = shift;
2179 }
2180
2181 # Schedule - Called after bot is set up, to set up any scheduled tasks
2182 # use $self->schedule($event, $delay, $times, $data)
2183 # where $times is 1 for a single event, -1 for recurring events,
2184 # and a +ve number for an event that occurs that many times.
2185 sub Schedule {
2186     my $self = shift;
2187     my ($event) = @_;
2188 }
2189
2190 # JoinedIRC - Called before joining any channels (but after module is setup)
2191 # this does not get called for dynamically loaded modules
2192 sub JoinedIRC {
2193     my $self = shift;
2194     my ($event) = @_;
2195 }
2196
2197 sub JoinedChannel {
2198     my $self = shift;
2199     my ($event, $channel) = @_;
2200     if ($self->{'autojoin'}) {
2201         push(@{$self->{'channels'}}, $channel)
2202           unless ((scalar(grep $_ eq $channel, @{$self->{'channels'}})) or
2203                   (scalar(grep $_ eq $channel, @{$self->{'channelsBlocked'}})));
2204         $self->saveConfig();
2205     }
2206 }
2207
2208 # Called by the Admin module's Kicked and SpottedPart handlers
2209 sub PartedChannel {
2210     my $self = shift;
2211     my ($event, $channel) = @_;
2212     if ($self->{'autojoin'}) {
2213         my %channels = map { $_ => 1 } @{$self->{'channels'}};
2214         if ($channels{$channel}) {
2215             delete($channels{$channel});
2216             @{$self->{'channels'}} = keys %channels;
2217             $self->saveConfig();
2218         }
2219     }
2220 }
2221
2222 sub InChannel {
2223     my $self = shift;
2224     my ($event) = @_;
2225     return scalar(grep $_ eq $event->{'channel'}, @{$self->{'channels'}});
2226     # XXX could be optimised - cache the list into a hash.
2227 }
2228
2229 sub IsBanned {
2230     my $self = shift;
2231     my ($event) = @_;
2232     return 0 if scalar(grep { $_ = $self->sanitizeRegexp($_); $event->{'user'} =~ /^$_$/ } @{$self->{'allowusers'}});
2233     return      scalar(grep { $_ = $self->sanitizeRegexp($_); $event->{'user'} =~ /^$_$/ } @{$self->{'denyusers'}});
2234 }
2235
2236 # Baffled - Called for messages prefixed by the bot's nick which we don't understand
2237 sub Baffled {
2238     my $self = shift;
2239     my ($event, $message) = @_;
2240     return 1;
2241 }
2242
2243 # Told - Called for messages prefixed by the bot's nick
2244 sub Told {
2245     my $self = shift;
2246     my ($event, $message) = @_;
2247     return 1;
2248 }
2249
2250 # Noticed - Called for notice messages
2251 sub Noticed {
2252     my $self = shift;
2253     my ($event, $message) = @_;
2254     return 1;
2255 }
2256
2257 # Heard - Called for all messages
2258 sub Heard {
2259     my $self = shift;
2260     my ($event, $message) = @_;
2261     return 1;
2262 }
2263
2264 # Felt - Called for all emotes containing bot's nick
2265 sub Felt {
2266     my $self = shift;
2267     my ($event, $message) = @_;
2268     return 1;
2269 }
2270
2271 # -- #mozilla was here --
2272 # * bryner tries to imagine the need for NS_TWIPS_TO_MILES
2273 #<Ben_Goodger> bryner: yeah, that isn't even a metric unit. should
2274 #              be NS_TWIPS_TO_KILOMETERS
2275 #     <bryner> there's that too
2276 #<Ben_Goodger> oh
2277 #<Ben_Goodger> really?
2278 #     <bryner> yep
2279 #<Ben_Goodger> o_O
2280 #     <bryner> for when we use mozilla for surveying and such
2281 #  <pinkerton> lol
2282
2283 # BTW. They aren't kidding. See:
2284 # http://lxr.mozilla.org/seamonkey/search?string=NS_TWIPS_TO_KILOMETERS
2285
2286 # Saw - Called for all emotes
2287 sub Saw {
2288     my $self = shift;
2289     my ($event, $message) = @_;
2290     return 1;
2291 }
2292
2293 # Invited - Called when bot is invited into another channel
2294 sub Invited {
2295     my $self = shift;
2296     my ($event, $channel) = @_;
2297     return 1;
2298 }
2299
2300 # Kicked - Called when bot is kicked out of a channel
2301 sub Kicked {
2302     my $self = shift;
2303     my ($event, $channel) = @_;
2304     return 1;
2305 }
2306
2307 # ModeChange - Called when channel or bot has a mode flag changed
2308 sub ModeChange {
2309     my $self = shift;
2310     my ($event, $what, $change, $who) = @_;
2311     return 1;
2312 }
2313
2314 # GotOpped - Called when bot is opped
2315 sub GotOpped {
2316     my $self = shift;
2317     my ($event, $channel, $who) = @_;
2318     return 1;
2319 }
2320
2321 # GotDeopped - Called when bot is deopped
2322 sub GotDeopped {
2323     my $self = shift;
2324     my ($event, $channel, $who) = @_;
2325     return 1;
2326 }
2327
2328 # SpottedNickChange - Called when someone changes their nick
2329 # Remember that you cannot use directSay here, since $event
2330 # has the details of the old nick. And 'say' is useless
2331 # since the channel is the old userhost string... XXX
2332 sub SpottedNickChange {
2333     my $self = shift;
2334     my ($event, $from, $to) = @_;
2335     return 1;
2336 }
2337
2338 # Authed - Called when someone authenticates with us.
2339 # Remember that you cannot use say here, since this
2340 # cannot actually be done in a channel...
2341 sub Authed {
2342     my $self = shift;
2343     my ($event, $who) = @_;
2344     return 1;
2345 }
2346
2347 # SpottedTopicChange - Called when someone thinks someone else said something funny
2348 sub SpottedTopicChange {
2349     my $self = shift;
2350     my ($event, $channel, $new) = @_;
2351     return 1;
2352 }
2353
2354 # SpottedJoin - Called when someone joins a channel
2355 sub SpottedJoin {
2356     my $self = shift;
2357     my ($event, $channel, $who) = @_;
2358     return 1;
2359 }
2360
2361 # SpottedPart - Called when someone leaves a channel
2362 sub SpottedPart {
2363     my $self = shift;
2364     my ($event, $channel, $who) = @_;
2365     return 1;
2366 }
2367
2368 # SpottedKick - Called when someone leaves a channel forcibly
2369 sub SpottedKick {
2370     my $self = shift;
2371     my ($event, $channel, $who) = @_;
2372     return 1;
2373 }
2374
2375 # SpottedQuit - Called when someone leaves a server
2376 # can't use say or directSay: no channel involved, and
2377 # user has quit (obviously). XXX
2378 sub SpottedQuit {
2379     my $self = shift;
2380     my ($event, $who, $why) = @_;
2381     return 1;
2382 }
2383
2384 # CTCPPing - Called when we receive a CTCP Ping.
2385 sub CTCPPing {
2386     my $self = shift;
2387     my ($event, $who, $what) = @_;
2388     return 1;
2389 }
2390
2391 # CTCPVersion - Called when we receive a CTCP Version.
2392 sub CTCPVersion {
2393     my $self = shift;
2394     my ($event, $who, $what) = @_;
2395     return 1;
2396 }
2397
2398 # CTCPSource - Called when we receive a CTCP Source.
2399 sub CTCPSource {
2400     my $self = shift;
2401     my ($event, $who, $what) = @_;
2402     return 1;
2403 }
2404
2405 # SpottedOpping - Called when someone is opped
2406 sub SpottedOpping {
2407     my $self = shift;
2408     my ($event, $channel, $who) = @_;
2409     return 1;
2410 }
2411
2412 # SpottedDeopping - Called when someone is... deopped, maybe?
2413 sub SpottedDeopping {
2414     my $self = shift;
2415     my ($event, $channel, $who) = @_;
2416     return 1;
2417 }
2418
2419 # Scheduled - Called when a scheduled timer triggers
2420 sub Scheduled {
2421     my $self = shift;
2422     my ($event, @data) = @_;
2423     if (ref($data[0]) eq 'CODE') {
2424         &{$data[0]}($event, @data);
2425     } else {
2426         $self->debug('Unhandled scheduled event... :-/');
2427     }
2428 }
2429
2430 # ChildCompleted - Called when a child process has quit
2431 sub ChildCompleted {
2432     my $self = shift;
2433     my ($event, $type, $output, @data) = @_;
2434     if ($type eq 'URI') {
2435         my $uri = shift(@data);
2436         $self->GotURI($event, $uri, $output, @data);
2437     }
2438 }
2439
2440 # DataAvailable - Called when a handle registered with
2441 # registerDataHandle has made data available
2442 sub DataAvailable {
2443     my $self = shift;
2444     my ($event, $handle, $data, $close) = @_;
2445     # do nothing
2446 }
2447
2448 # GotURI - Called when a requested URI has been downloaded
2449 sub GotURI {
2450     my $self = shift;
2451     my ($event, $uri, $contents, @data) = @_;
2452 }
2453
2454 # Help - Called to fully explain the module (return hash of command/description pairs)
2455 # the string given for the '' key should be a module description
2456 sub Help {
2457     my $self = shift;
2458     my ($event) = @_;
2459     return {};
2460 }
2461
2462 # RegisterConfig - Called when initialised, should call registerVariables
2463 sub RegisterConfig {
2464     my $self = shift;
2465     $self->registerVariables(
2466       # [ name, save?, settable?, value ]
2467         ['channels',        1, 1, []],
2468         ['channelsBlocked', 1, 1, []], # the channels in which this module will not autojoin regardless
2469         ['autojoin',        1, 1, 1],
2470         ['allowusers',      1, 1, []],
2471         ['denyusers',       1, 1, []],
2472     );
2473 }
2474
2475 # Set - called to set a variable to a particular value.
2476 sub Set {
2477     my $self = shift;
2478     my ($event, $variable, $value) = @_;
2479     if ($self->{'_variables'}->{$variable}) {
2480         if ((not defined($self->{$variable})) or (not ref($self->{$variable}))) {
2481             $self->{$variable} = $value;
2482         } elsif (ref($self->{$variable}) eq 'SCALAR') {
2483             ${$self->{$variable}} = $value;
2484         } elsif (ref($self->{$variable}) eq 'ARRAY') {
2485             if ($value =~ /^([-+])(.*)$/so) {
2486                 if ($1 eq '+') {
2487                     push(@{$self->{$variable}}, $2);
2488                 } else {
2489                     # We don't want to change the reference!!!
2490                     # Other variables might be pointing to there,
2491                     # it is *those* vars that affect the app.
2492                     my @oldvalue = @{$self->{$variable}};
2493                     @{$self->{$variable}} = ();
2494                     foreach (@oldvalue) {
2495                         push(@{$self->{$variable}}, $_) unless ($2 eq $_);
2496                     }
2497                     # XXX no feedback if nothing is done
2498                 }
2499             } else {
2500                 return 3; # not the right format dude!
2501             }
2502         } elsif (ref($self->{$variable}) eq 'HASH') {
2503             if ($value =~ /^\+(.)(.*)\1(.*)$/so) {
2504                 $self->{$variable}->{$2} = $3;
2505                 return -2 if $1 =~ /[a-zA-Z]/so;
2506             } elsif ($value =~ /^\-(.*)$/so) {
2507                 # XXX no feedback if nothing is done
2508                 delete($self->{$variable}->{$1});
2509             } else {
2510                 return 4; # not the right format dude!
2511             }
2512         } else {
2513             return 1; # please to not be trying to set coderefs or arrayrefs or hashrefs or ...
2514         }
2515     } else {
2516         return 2; # please to not be trying to set variables I not understand!
2517     }
2518     $self->saveConfig();
2519     return 0;
2520 }
2521
2522 # Get - called to get a particular variable
2523 sub Get {
2524     my $self = shift;
2525     my ($event, $variable) = @_;
2526     return $self->{$variable};
2527 }
2528
2529 # Log - Called for every event
2530 sub Log {
2531     my $self = shift;
2532     my ($event) = @_;
2533 }
2534
2535 # Log - Called for every event
2536 sub Unload {
2537     my $self = shift;
2538 }
2539
2540
2541 ################################
2542 # Admin Module                 #
2543 ################################
2544
2545 package BotModules::Admin;
2546 use vars qw(@ISA);
2547 @ISA = qw(BotModules);
2548 1;
2549
2550 # Initialise - Called when the module is loaded
2551 sub Initialise {
2552     my $self = shift;
2553     $self->{'_fileModifiedTimes'} = {};
2554     $self->{'_static'} = 1;
2555 }
2556
2557 # RegisterConfig - Called when initialised, should call registerVariables
2558 sub RegisterConfig {
2559     my $self = shift;
2560     $self->SUPER::RegisterConfig(@_);
2561     $self->registerVariables(
2562       # [ name, save?, settable?, value ]
2563         ['allowInviting', 1, 1, 1], # by default, anyone can invite a bot into their channel
2564         ['allowChannelAdmin', 1, 1, 0], # by default, one cannot admin from a channel
2565         ['sourceCodeCheckDelay', 1, 1, 20], # by default, wait 20 seconds between source code checks
2566         ['files', 1, 1, [$0, 'lib/Mails.pm', 'lib/Configuration.pm', 'lib/IO/SecurePipe.pm']], # files to check for source code changes
2567         ['channels', 0, 0, undef], # remove the 'channels' internal variable...
2568         ['autojoin', 0, 0, 0], # remove the 'autojoin' internal variable...
2569         ['errorMessagesMaxLines', 1, 1, 5], # by default, only have 5 lines in error messages, trim middle if more
2570     );
2571     # now add in all the global variables...
2572     foreach (keys %configStructure) {
2573         $self->registerVariables([$configStructure{$_}[0], 0, 1, $configStructure{$_}[1]]) if (ref($configStructure{$_}[1]) =~ /^(?:SCALAR|ARRAY|HASH)$/go);
2574     }
2575 }
2576
2577 # saveConfig - make sure we also save the main config variables...
2578 sub saveConfig {
2579     my $self = shift;
2580     $self->SUPER::saveConfig(@_);
2581     &Configuration::Save($cfgfile, &::configStructure());
2582 }
2583
2584 # Set - called to set a variable to a particular value.
2585 sub Set {
2586     my $self = shift;
2587     my ($event, $variable, $value) = @_;
2588     # First let's special case some magic variables...
2589     if ($variable eq 'currentnick') {
2590         $self->setNick($event, $value);
2591         $self->say($event, "Attempted to change nick to '$value'.");
2592         return -1;
2593     } elsif ($variable eq 'nicks') {
2594         if ($value =~ /^([-+])(.*)$/so) {
2595             if ($1 eq '+') {
2596                 # check it isn't there already and is not ''
2597                 my $value = $2;
2598                 if ($value eq '') {
2599                     $self->say($event, "The empty string is not a valid nick.");
2600                     return -1;
2601                 }
2602                 my $thenick = 0;
2603                 $thenick++ while (($thenick < @nicks) and ($value ne $nicks[$thenick]));
2604                 if ($thenick < @nicks) {
2605                     $self->say($event, "That nick (value) is already on the list of possible nicks.");
2606                     return -1;
2607                 }
2608             } else {
2609                 if ($2 eq $nicks[$nick]) {
2610                     $self->say($event, "You cannot remove the current nick ('$nicks[$nick]') from the list of allowed nicks... Change the 'currentnick' variable first!");
2611                     return -1;
2612                 }
2613             }
2614         }
2615     } elsif ($variable eq 'umode') {
2616         $self->mode($event, $nicks[$nick], $value, '');
2617         $self->say($event, "Attempted to change current umode to '$value'.");
2618     }
2619     return $self->SUPER::Set($event, $variable, $value);
2620 }
2621
2622 # Get - called to get a particular variable.
2623 sub Get {
2624     my $self = shift;
2625     my ($event, $variable) = @_;
2626     # First let's special case some magic variables...
2627     if ($variable eq 'currentnick') {
2628         return $event->{'nick'};
2629     } elsif ($variable eq 'users') {
2630         my @users = sort keys %users;
2631         return \@users;
2632     } else {
2633         # else, check for known global variables...
2634         my $configStructure = &::configStructure();
2635         if (defined($configStructure->{$variable})) {
2636             return $configStructure->{$variable};
2637         } else {
2638             return $self->SUPER::Get($event, $variable);
2639         }
2640     }
2641 }
2642
2643 # Schedule - called when bot connects to a server, to install any schedulers
2644 # use $self->schedule($event, $delay, $times, $data)
2645 # where $times is 1 for a single event, -1 for recurring events,
2646 # and a +ve number for an event that occurs that many times.
2647 sub Schedule {
2648     my $self = shift;
2649     my ($event) = @_;
2650     $self->schedule($event, \$self->{'sourceCodeCheckDelay'}, -1, {'action'=>'source'});
2651     $self->SUPER::Schedule($event);
2652 }
2653
2654 sub Help {
2655     my $self = shift;
2656     my ($event) = @_;
2657     my $result = {
2658         'auth' => 'Authenticate yourself. Append the word \'quiet\' after your password if you don\'t want confirmation. Syntax: auth <username> <password> [quiet]',
2659         'password' => 'Change your password: password <oldpassword> <newpassword> <newpassword>',
2660         'newuser' => 'Registers a new username and password (with no privileges). Syntax: newuser <username> <newpassword> <newpassword>',
2661     };
2662     if ($self->isAdmin($event)) {
2663         $result->{''} = 'The administration module is used to perform tasks that fundamentally affect the bot.';
2664         $result->{'shutdown'} = 'Shuts the bot down completely.';
2665         $result->{'shutup'} = 'Clears the output queue (you actually have to say \'shutup please\' or nothing will happen).';
2666         $result->{'restart'} = 'Shuts the bot down completely then restarts it, so that any source changes take effect.';
2667         $result->{'cycle'} = 'Makes the bot disconnect from the server then try to reconnect.';
2668         $result->{'changepassword'} = 'Change a user\'s password: changepassword <user> <newpassword> <newpassword>',
2669         $result->{'vars'} = 'Manage variables: vars [<module> [<variable> [\'<value>\']]], say \'vars\' for more details.';
2670         $result->{'join'} = 'Makes the bot attempt to join a channel. The same effect can be achieved using /invite. Syntax: join <channel>';
2671         $result->{'part'} = 'Makes the bot leave a channel. The same effect can be achieved using /kick. Syntax: part <channel>';
2672         $result->{'load'} = 'Loads a module from disk, if it is not already loaded: load <module>';
2673         $result->{'unload'} = 'Unloads a module from memory: load <module>';
2674         $result->{'reload'} = 'Unloads and then loads a module: reload <module>';
2675         $result->{'bless'} = 'Sets the \'admin\' flag on a registered user. Syntax: bless <user>';
2676         $result->{'unbless'} = 'Resets the \'admin\' flag on a registered user. Syntax: unbless <user>';
2677         $result->{'deleteuser'} = 'Deletes a user from the bot. Syntax: deleteuser <username>',
2678     }
2679     return $result;
2680 }
2681
2682 # Told - Called for messages prefixed by the bot's nick
2683 sub Told {
2684     my $self = shift;
2685     my ($event, $message) = @_;
2686     return $self->SUPER::Told(@_) unless $self->{allowChannelAdmin} or $event->{channel} eq '';
2687     if ($message =~ /^\s*auth\s+($variablepattern)\s+($variablepattern)(\s+quiet)?\s*$/osi) {
2688         if (not $event->{'channel'}) {
2689             if (defined($users{$1})) {
2690                 if (&::checkPassword($2, $users{$1})) {
2691                     $authenticatedUsers{$event->{'user'}} = $1;
2692                     if (not defined($3)) {
2693                         $self->directSay($event, "Hi $1!");
2694                     }
2695                     &::do($event->{'bot'}, $event->{'_event'}, 'Authed'); # hack hack hack
2696                 } else {
2697                     $self->directSay($event, "No...");
2698                 }
2699             } else {
2700                 $self->directSay($event, "You have not been added as a user yet. Try the \'newuser\' command (see \'help newuser\' for details).");
2701             }
2702         }
2703     } elsif ($message =~ /^\s*password\s+($variablepattern)\s+($variablepattern)\s+($variablepattern)\s*$/osi) {
2704         if (not $event->{'channel'}) {
2705             if ($authenticatedUsers{$event->{'user'}}) {
2706                 if ($2 ne $3) {
2707                     $self->say($event, 'New passwords did not match. Try again.');
2708                 } elsif (&::checkPassword($1, $users{$authenticatedUsers{$event->{'user'}}})) {
2709                     $users{$authenticatedUsers{$event->{'user'}}} = &::newPassword($2);
2710                     delete($authenticatedUsers{$event->{'user'}});
2711                     $self->say($event, 'Password changed. Please reauthenticate.');
2712                     $self->saveConfig();
2713                 } else {
2714                     delete($authenticatedUsers{$event->{'user'}});
2715                     $self->say($event, 'That is not your current password. Please reauthenticate.');
2716                 }
2717             }
2718         }
2719     } elsif ($message =~ /^\s*new\s*user\s+($variablepattern)\s+($variablepattern)\s+($variablepattern)\s*$/osi) {
2720         if (not $event->{'channel'}) {
2721             if (defined($users{$1})) {
2722                 $self->say($event, 'That user already exists in my list, you can\'t add them again!');
2723             } elsif ( $2 ne $3 ) {
2724                 $self->say($event, 'New passwords did not match. Try again.');
2725             } elsif ($1) {
2726                 $users{$1} = &::newPassword($2);
2727                 $userFlags{$1} = 0;
2728                 $self->directSay($event, "New user '$1' added with password '$2' and no rights.");
2729                 $self->saveConfig();
2730             } else {
2731                 $self->say($event, 'That is not a valid user name.');
2732             }
2733         }
2734     } elsif ($self->isAdmin($event)) {
2735         if ($message =~ /^\s*(?:shutdown,?\s+please)\s*[?!.]*\s*$/osi) {
2736             $self->say($event, 'But of course. Have a nice day!');
2737             my $reason = 'I was told to shutdown by '.$event->{'from'}.'. :-( ';
2738             # XXX should do something like &::do($event->{'bot'}, $event->{'_event'}, 'SpottedQuit'); # hack hack hack
2739             #     ...but it should have the right channel/nick/reason info
2740             # XXX we don't unload the modules here?
2741             $event->{'bot'}->quit($reason);
2742             exit(0); # prevents any other events happening...
2743         } elsif ($message =~ /^\s*shutdown/osi) {
2744             $self->say($event, 'If you really want me to shutdown, use the magic word.');
2745             $self->schedule($event, 7, 1, 'i.e., please.');
2746         } elsif ($message =~ /^\s*(?:restart,?\s+please)\s*[?!.]*\s*$/osi) {
2747             $self->Restart($event, "I was told to restart by $event->{'from'} -- brb");
2748         } elsif ($message =~ /^\s*restart/osi) {
2749             $self->say($event, 'If you really want me to restart, use the magic word.');
2750             $self->schedule($event, 7, 1, 'i.e., please.');
2751         } elsif ($message =~ /^\s*delete\s*user\s+($variablepattern)\s*$/osi) {
2752             if (not defined($users{$1})) {
2753                 $self->say($event, "I don't know of a user called '$1', sorry.");
2754             } else {
2755                 # check user is not last admin
2756                 my $doomedUser = $1;
2757                 my $count;
2758                 if (($userFlags{$doomedUser} & 1) == 1) {
2759                     # deleting an admin. Count how many are left.
2760                     $count = 0;
2761                     foreach my $user (keys %users) {
2762                         ++$count if ($user ne $doomedUser and
2763                                      ($userFlags{$user} & 1) == 1);
2764                     }
2765                 } else {
2766                     # not deleting an admin. We know there is an admin in there, it's
2767                     # the user doing the deleting. So we're safe.
2768                     $count = 1;
2769                 }
2770                 if ($count) {
2771                     $self->deleteUser($doomedUser);
2772                     $self->say($event, "User '$doomedUser' deleted.");
2773                 } else {
2774                     $self->say($event, "Can't delete user '$doomedUser', that would leave you with no admins!");
2775                 }
2776             }
2777         } elsif ($message =~ /^\s*change\s*password\s+($variablepattern)\s+($variablepattern)\s+($variablepattern)\s*$/osi) {
2778             if (not defined($users{$1})) {
2779                 $self->say($event, "I don't know of a user called '$1', sorry.");
2780             } elsif ($2 ne $3) {
2781                 $self->say($event, 'New passwords did not match. Try again.');
2782             } else {
2783                 $users{$1} = &::newPassword($2);
2784                 my $count = 0;
2785                 foreach my $user (keys %authenticatedUsers) {
2786                     if ($authenticatedUsers{$user} eq $1) {
2787                         delete($authenticatedUsers{$user});
2788                         ++$count;
2789                     }
2790                 }
2791                 if ($count) {
2792                     $self->say($event, "Password changed for user '$1'. They must reauthenticate.");
2793                 } else {
2794                     $self->say($event, "Password changed for user '$1'.");
2795                 }
2796                 $self->saveConfig();
2797             }
2798         } elsif ($message =~ /^\s*(?:shut\s*up,?\s+please)\s*[?!.]*\s*$/osi) {
2799             my $lost = @msgqueue;
2800             @msgqueue = ();
2801             if ($lost) {
2802                 $self->say($event, "Ok, threw away $lost messages.");
2803             } else {
2804                 $self->say($event, 'But I wasn\'t saying anything!');
2805             }
2806         } elsif ($message =~ /^\s*cycle(?:\s+please)?\s*[?!.]*\s*$/osi) {
2807             my $reason = 'I was told to cycle by '.$event->{'from'}.'. BRB!';
2808             # XXX should do something like &::do($event->{'bot'}, $event->{'_event'}, 'SpottedQuit'); # hack hack hack
2809             #     ...but it should have the right channel/nick/reason info
2810             # XXX we don't unload the modules here?
2811             $event->{'bot'}->quit($reason);
2812             &Configuration::Get($cfgfile, &::configStructure());
2813         } elsif ($message =~ /^\s*join\s+([&#+][^\s]+)(?:\s+please)?\s*[?!.]*\s*$/osi) {
2814             $self->Invited($event, $1);
2815         } elsif ($message =~ /^\s*part\s+([&#+][^\s]+)(?:\s+please)?\s*[?!.]*\s*$/osi) {
2816             $event->{'bot'}->part("$1 :I was told to leave by $event->{'from'}. :-(");
2817         } elsif ($message =~ /^\s*bless\s+('?)($variablepattern)\1\s*$/osi) {
2818             if (defined($users{$2})) {
2819                 $userFlags{$2} = $userFlags{$2} || 1;
2820                 $self->saveConfig();
2821                 $self->say($event, "Ok, $2 is now an admin.");
2822             } else {
2823                 $self->say($event, 'I don\'t know that user. Try the \'newuser\' command (see \'help newuser\' for details).');
2824             }
2825         } elsif ($message =~ /^\s*unbless\s+('?)($variablepattern)\1\s*$/osi) {
2826             if (defined($users{$2})) {
2827                 $userFlags{$2} = $userFlags{$2} &~ 1;
2828                 $self->saveConfig();
2829                 $self->say($event, "Ok, $2 is now a mundane luser.");
2830             } else {
2831                 $self->say($event, 'I don\'t know that user. Check your spelling!');
2832             }
2833         } elsif ($message =~ /^\s*load\s+('?)($variablepattern)\1\s*$/osi) {
2834             $self->LoadModule($event, $2, 1);
2835         } elsif ($message =~ /^\s*reload\s+('?)($variablepattern)\1\s*$/osi) {
2836             $self->ReloadModule($event, $2, 1);
2837         } elsif ($message =~ /^\s*unload\s+('?)($variablepattern)\1\s*$/osi) {
2838             $self->UnloadModule($event, $2, 1);
2839         } elsif ($message =~ /^\s*vars(?:\s+($variablepattern)(?:\s+($variablepattern)(?:\s+'(.*)')?)?|(.*))?\s*$/osi) {
2840             $self->Vars($event, $1, $2, $3, $4);
2841         } else {
2842             return $self->SUPER::Told(@_);
2843         }
2844     } else {
2845         return $self->SUPER::Told(@_);
2846     }
2847     return 0; # if made it here then we did it!
2848 }
2849
2850 sub Scheduled {
2851     my $self = shift;
2852     my ($event, $type) = @_;
2853     if ((ref($type) eq 'HASH') and ($type->{'action'} eq 'source')) {
2854         $self->CheckSource($event);
2855     } elsif (ref($type)) {
2856         $self->SUPER::Scheduled(@_);
2857     } else {
2858         $self->directSay($event, $type);
2859     }
2860 }
2861
2862 # remove any (other) temporary administrators when an admin authenticates
2863 sub Authed {
2864     my $self = shift;
2865     my ($event, $who) = @_;
2866     if ($self->isAdmin($event)) {
2867         foreach (keys %userFlags) {
2868             if ((($userFlags{$_} & 2) == 2) and ($authenticatedUsers{$event->{'user'}} ne $_)) {
2869                 $self->deleteUser($_);
2870                 $self->directSay($event, "Temporary administrator '$_' removed from user list.");
2871             }
2872         }
2873     }
2874     return $self->SUPER::Authed(@_); # this should not stop anything else happening
2875 }
2876
2877 # SpottedQuit - Called when someone leaves a server
2878 sub SpottedQuit {
2879     my $self = shift;
2880     my ($event, $who, $why) = @_;
2881     delete($authenticatedUsers{$event->{'user'}});
2882     # XXX this doesn't deal with a user who has authenticated twice.
2883     return $self->SUPER::SpottedQuit(@_);
2884 }
2885
2886 sub CheckSource {
2887     my $self = shift;
2888     my ($event) = @_;
2889     foreach my $file (@{$self->{'files'}}) {
2890         my $lastModifiedTime = $self->{'_fileModifiedTimes'}->{$file};
2891         my ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime, $blksize, $blocks)
2892             = stat($file);
2893         $self->{'_fileModifiedTimes'}->{$file} = $mtime;
2894         if (defined($lastModifiedTime) and ($mtime > $lastModifiedTime)) {
2895             $self->debug("Noticed that source code of $file had changed");
2896             # compile new bot using perl -cwT XXX
2897             if (1) { # XXX replace 1 with "did compile succeed" test
2898                 $self->Restart($event, 'someone seems to have changed my source code. brb, unless I get a compile error!');
2899             } else {
2900                 # tellAdmin that it did not compile XXX
2901                 # debug that it did not compile
2902             }
2903         }
2904     }
2905     my @updatedModules;
2906     foreach my $module (@modules) {
2907         if ($module->{'_filename'}) {
2908             my $lastModifiedTime = $module->{'_fileModificationTime'};
2909             my ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime, $blksize, $blocks)
2910                 = stat($module->{'_filename'});
2911             $module->{'_fileModificationTime'} = $mtime;
2912             if (defined($lastModifiedTime) and ($mtime > $lastModifiedTime)) {
2913                 push(@updatedModules, $module->{'_name'});
2914             }
2915         }
2916     }
2917     foreach my $module (@updatedModules) {
2918         $self->ReloadModule($event, $module, 0);
2919     }
2920 }
2921
2922 sub Restart {
2923     my $self = shift;
2924     my ($event, $reason) = @_;
2925     # XXX should do something like &::do($event->{'bot'}, $event->{'_event'}, 'SpottedQuit'); # hack hack hack
2926     #     ...but it should have the right channel/nick/reason info
2927     #     ...and it is broken if called from CheckSource, which is a
2928     #     scheduled event handler, since $event is then a very basic
2929     #     incomplete hash.
2930     # XXX we don't unload modules here?
2931     $event->{'bot'}->quit($reason);
2932     # Note that `exec' will not call our `END' blocks, nor will it
2933     # call any `DESTROY' methods in our objects. So we fork a child to
2934     # do that first.
2935     my $parent = $$;
2936     my $child = fork();
2937     if (defined($child)) {
2938         if ($child) {
2939             # we are the parent process who is
2940             # about to exec($0), so wait for
2941             # child to shutdown.
2942             $self->debug("spawned $child to handle shutdown...");
2943             waitpid($child, 0);
2944         } else {
2945             # we are the child process who is
2946             # in charge of shutting down cleanly.
2947             $self->debug("initiating shutdown for parent process $parent...");
2948             exit(0);
2949         }
2950     } else {
2951         $self->debug("failed to fork: $!");
2952     }
2953     $self->debug("About to defer to a new $0 process...");
2954     # we have done our best to shutdown, so go for it!
2955     eval {
2956         $0 =~ m/^(.*)$/os; # untaint $0 so that we can call it below (as $1)
2957         if ($CHROOT) {
2958             exec { $1 } ($1, '--assume-chrooted', $cfgfile);
2959         } else {
2960             exec { $1 } ($1, $cfgfile);
2961         }
2962         # I am told (by some nice people in #perl on Efnet) that our
2963         # memory is all cleared up for us. So don't worry that even
2964         # though we don't call DESTROY in _this_ instance, we leave
2965         # memory behind.
2966     };
2967     $self->debug("That failed!!! Bailing out to prevent all hell from breaking loose! $@ :-|");
2968     exit(1); # we never get here unless exec fails
2969 }
2970
2971 # handles the 'vars' command
2972 sub Vars {
2973     my $self = shift;
2974     my ($event, $modulename, $variable, $value, $nonsense) = @_;
2975     if (defined($modulename)) {
2976         my $module = $self->getModule($modulename);
2977         if (defined($module)) {
2978             if (defined($variable)) {
2979                 if (defined($value)) {
2980                     my $result = $module->Set($event, $variable, $value);
2981                     if ((not defined($result)) or ($result == 0)) {
2982                         $self->say($event, "Variable '$variable' in module '$modulename' has changed.");
2983                     } elsif ($result == 1) {
2984                         $self->say($event, "Variable '$variable' is of type ".ref($module->{$variable}).' and I do not know how to set that kind of variable!');
2985                     } elsif ($result == 2) { # we don't know that variable!
2986                         if ($module->{$variable}) { # well we do, but only to read
2987                             $self->say($event, "Variable '$variable' in module '$modulename' is read-only, sorry.");
2988                         } else { # not known
2989                             $self->say($event, "Module '$modulename' does not have a variable '$variable' as far as I can tell.");
2990                         }
2991                     } elsif ($result == 3) {
2992                         $self->say($event, "Variable '$variable' is a list. To add to a list, please use the '+' symbol before the value (vars <module> <variable> '+<value>'). To remove from a list, use the '-' symbol (vars <module> <variable> '-<value>').");
2993                     } elsif ($result == 4) {
2994                         $self->say($event, "Variable '$variable' is a hash. To add to a hash, please use the '+' symbol before the '|key|value' pair (vars <module> <variable> '+|<key>|<value>').  The separator symbol ('|' in this example) could be anything. To remove from a list, use the '-' symbol (vars <module> <variable> '-<key>').");
2995                     } elsif ($result == -1) {
2996                         # already reported success
2997                     } elsif ($result == -2) {
2998                         $self->say($event, "Variable '$variable' in module '$modulename' has changed, but may not be what you expect since it appears to me that you used a letter to delimit the sections. I hope that is what you meant to do...");
2999                     } elsif ($result > 0) { # negative = success
3000                         $self->say($event, "Variable '$variable' in module '$modulename' could not be set for some reason unknown to me.");
3001                     }
3002                 } else { # else give variable's current value
3003                     $value = $module->Get($event, $variable);
3004                     if (defined($value)) {
3005                         my $type = ref($value);
3006                         if ($type eq 'SCALAR') {
3007                             $self->say($event, "Variable '$variable' in module '$modulename' is set to: '$$value'");
3008                         } elsif ($type eq 'ARRAY') {
3009                             # XXX need a 'maximum number of items' feature to prevent flooding ourselves to pieces (or is shutup please enough?)
3010                             if (@$value) {
3011                                 local $" = '\', \'';
3012                                 $self->say($event, "Variable '$variable' in module '$modulename' is a list with the following values: '@$value'");
3013                             } else {
3014                                 $self->say($event, "Variable '$variable' in module '$modulename' is an empty list.");
3015                             }
3016                         } elsif ($type eq 'HASH') {
3017                             # XXX need a 'maximum number of items' feature to prevent flooding ourselves to pieces (or is shutup please enough?)
3018                             $self->say($event, "Variable '$variable' in module '$modulename' is a hash with the following values:");
3019                             foreach (sort keys %$value) {
3020                                 $self->say($event, "  '$_' => '".($value->{$_}).'\' ');
3021                             }
3022                             $self->say($event, "End of dump of variable '$variable'.");
3023                         } else {
3024                             $self->say($event, "Variable '$variable' in module '$modulename' is set to: '$value'");
3025                         }
3026                     } else { # we don't know that variable
3027                         if ($module->{'_variables'}->{$variable}) { # well we do, but only to write
3028                             $self->say($event, "Variable '$variable' in module '$modulename' is write-only, sorry.");
3029                         } else { # not known
3030                             $self->say($event, "Module '$modulename' does not have a variable '$variable' as far as I can tell.");
3031                         }
3032                     }
3033                 }
3034             } else { # else list variables
3035                 my @variables;
3036                 # then enumerate its variables
3037                 foreach my $variable (sort keys %{$module->{'_variables'}}) {
3038                     push(@variables, $variable) if $module->{'_variables'}->{$variable};
3039                 }
3040                 # then list 'em
3041                 if (@variables) {
3042                     local $" = '\', \'';
3043                     $self->say($event, "Module '$modulename' has the following published variables: '@variables'");
3044                 } else {
3045                     $self->say($event, "Module '$modulename' has no settable variables.");
3046                 }
3047             }
3048         } else { # complain no module
3049             $self->say($event, "I didn't recognise that module name ('$modulename'). Try just 'vars' on its own for help.");
3050         }
3051     } elsif ($nonsense) {
3052         $self->say($event, 'I didn\'t quite understand that. Try just \'vars\' on its own for help.');
3053         $self->say($event, 'If you are trying to set a variable, don\'t forget the quotes around the value!');
3054     } else { # else give help
3055         $self->say($event, 'The \'vars\' command gives you an interface to the module variables in the bot.');
3056         $self->say($event, 'To list the variables in a module: vars <module>');
3057         $self->say($event, 'To get the value of a variable: vars <module> <variable>');
3058         $self->say($event, 'To set the value of a variable: vars <module> <variable> \'<value>\'');
3059         $self->say($event, 'Note the quotes around the value. They are required. If the value contains quotes itself, that is fine.');
3060     }
3061 }
3062
3063 # This is also called when we are messaged a 'join' command
3064 sub Invited {
3065     my $self = shift;
3066     my ($event, $channelName) = @_;
3067     # $channelName is the name as requested and as should be /joined.
3068     # This is important so that case is kept in the list of channels
3069     # on the server should the bot join first.
3070     my $channel = lc($channelName);
3071     if (grep $_ eq $channel, @channels) {
3072         $self->directSay($event, "I thought I was already *in* channel $channel! Oh well.");
3073     }
3074     if ($self->isAdmin($event) || $self->{'allowInviting'}) {
3075         $self->debug("Joining $channel, since I was invited.");
3076         if (defined($channelKeys{$channel})) {
3077             $event->{'bot'}->join($channel, $channelKeys{$channel});
3078         } else {
3079             $event->{'bot'}->join($channel);
3080         }
3081     } else {
3082         $self->debug($event->{'from'}." asked me to join $channel, but I refused.");
3083         $self->directSay($event, "Please contact one of my administrators if you want me to join $channel.");
3084         $self->tellAdmin($event, "Excuse me, but ".$event->{'from'}." asked me to join $channel. I thought you should know.");
3085     }
3086     return $self->SUPER::Invited($event, $channel);
3087 }
3088
3089 sub Kicked {
3090     my $self = shift;
3091     my ($event, $channel) = @_;
3092     $self->debug("kicked from $channel by ".$event->{'from'});
3093     $self->debug('about to autopart modules...');
3094     foreach (@modules) {
3095         $_->PartedChannel($event, $channel);
3096     }
3097     return $self->SUPER::Kicked($event, $channel);
3098 }
3099
3100 sub SpottedPart {
3101     my $self = shift;
3102     my ($event, $channel, $who) = @_;
3103     if (lc $who eq lc $event->{'nick'}) {
3104         $self->debug("parted $channel");
3105         $self->debug('about to autopart modules...');
3106         foreach (@modules) {
3107             $_->PartedChannel($event, $channel);
3108         }
3109     }
3110     return $self->SUPER::SpottedPart($event, $channel, $who);
3111 }
3112
3113 sub PartedChannel {
3114     my $self = shift;
3115     my ($event, $channel) = @_;
3116     $channel = lc($channel);
3117     my %channels = map { $_ => 1 } @channels;
3118     delete($channels{$channel});
3119     @channels = keys %channels;
3120     &Configuration::Save($cfgfile, &::configStructure(\@channels));
3121     return $self->SUPER::PartedChannel($event, $channel);
3122 }
3123
3124 sub LoadModule {
3125     my $self = shift;
3126     my ($event, $name, $requested) = @_;
3127     my $newmodule = &::LoadModule($name);
3128     if (ref($newmodule)) {
3129         # configure module
3130         $newmodule->{'channels'} = [@channels];
3131         &Configuration::Get($cfgfile, $newmodule->configStructure());
3132         eval {
3133             $newmodule->Schedule($event);
3134         };
3135         if ($@) {
3136             $self->debug("Warning: An error occured while loading the module:\n$@");
3137             if ($requested) {
3138                 $self->say($event, "Warning: an error occured while loading module '$name'. Ignored.");
3139             }
3140         }
3141         $newmodule->saveConfig();
3142         $self->debug("Successfully loaded module '$name'.");
3143         if ($requested) {
3144             $self->say($event, "Loaded module '$name'.");
3145         }
3146     } else {
3147         if ($requested) { # it failed, $newmodule contains error message
3148             my @errors = split(/[\n\r]/os, $newmodule);
3149             if (scalar(@errors) > $self->{'errorMessagesMaxLines'}) {
3150                 # remove lines from the middle if the log is too long
3151                 @errors = (@errors[0..int($self->{'errorMessagesMaxLines'} / 2)-1], '...', @errors[-(int($self->{'errorMessagesMaxLines'} / 2))..-1]);
3152             }
3153             local $" = "\n";
3154             $self->say($event, "@errors");
3155         }
3156         $self->debug($newmodule);
3157     }
3158 }
3159
3160 sub UnloadModule {
3161     my $self = shift;
3162     my ($event, $name, $requested) = @_;
3163     my $result = &::UnloadModule($name);
3164     if (defined($result)) { # failed
3165         if ($requested) {
3166             $self->say($event, $result);
3167         } else {
3168             $self->debug($result);
3169         }
3170     } else {
3171         if ($requested) {
3172             $self->say($event, "Unloaded module '$name'.");
3173         } else {
3174             $self->debug("Successfully unloaded module '$name'.");
3175         }
3176     }
3177 }
3178
3179 sub ReloadModule {
3180     my $self = shift;
3181     # XXX there used to be a memory leak around this code. It seems to be fixed
3182     # now. However if your bot process suddenly balloons to 90M+, here would be a good
3183     # place to start looking. Of course if that happens and you never reloaded modules
3184     # then it is also a good time to remove this comment... ;-)
3185     $self->UnloadModule(@_);
3186     $self->LoadModule(@_);
3187 }
3188
3189 sub deleteUser {
3190     my $self = shift;
3191     my ($who) = @_;
3192     delete($userFlags{$who});
3193     delete($users{$who});
3194     # if they authenticated, remove the entry to prevent dangling links
3195     foreach my $user (keys %authenticatedUsers) {
3196         if ($authenticatedUsers{$user} eq $who) {
3197             delete($authenticatedUsers{$user});
3198         }
3199     }
3200     $self->saveConfig();
3201 }
3202
3203
3204 ################################
3205 # Startup (aka main)           #
3206 ################################
3207
3208 package main;
3209
3210 # -- #mozilla was here --
3211 #       <zero> is the bug with zilla hanging on startup on every
3212 #              platform fixed in today's nightlies?
3213 #       <leaf> no
3214 #      <alecf> heh
3215 #       <leaf> NEVER
3216 #       <leaf> we're shipping with it.
3217 #    <andreww> helps hide our other bugs
3218
3219 # Do this at the very end, so we can intersperse "my" initializations outside
3220 # of routines above and be assured that they will run.
3221
3222 &debug('starting up command loop...');
3223
3224 END { &debug('perl is shutting down...'); }
3225
3226 $irc->start();
3227
3228 # -- #mozilla was here --
3229 #      <alecf> Maybe I'll file a bug about netcenter and that will
3230 #              get some attention
3231 #      <alecf> "Browser won't render home.netscape.com.. because it
3232 #              won't start up"
3233 #    <andreww> alecf how about "cant view banner ads - wont start up"
3234 #      <alecf> even better
3235 #  <pinkerton> all bugs are dependent on this one!
3236
3237 # *** Disconnected from irc.mozilla.org