зеркало из https://github.com/mozilla/gecko-dev.git
2777 строки
98 KiB
Prolog
Executable File
2777 строки
98 KiB
Prolog
Executable File
#!/usr/bin/perl -wT
|
|
# -*- Mode: perl; indent-tabs-mode: nil -*-
|
|
# DO NOT REMOVE THE -T ON THE FIRST LINE!!!
|
|
#
|
|
# _ _
|
|
# m o z i l l a |.| o r g | |
|
|
# _ __ ___ ___ ___| |__ ___ | |_
|
|
# | '_ ` _ \ / _ \_ / '_ \ / _ \| __|
|
|
# | | | | | | (_) / /| |_) | (_) | |_
|
|
# |_| |_| |_|\___/___|_.__/ \___/ \__|
|
|
# =======================- 2 . 0 -==
|
|
#
|
|
# The contents of this file are subject to the Mozilla Public
|
|
# License Version 1.1 (the "License"); you may not use this file
|
|
# except in compliance with the License. You may obtain a copy of
|
|
# the License at http://www.mozilla.org/MPL/
|
|
#
|
|
# Software distributed under the License is distributed on an "AS
|
|
# IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
|
|
# implied. See the License for the specific language governing
|
|
# rights and limitations under the License.
|
|
#
|
|
# The Original Code is the Bugzilla Bug Tracking System.
|
|
#
|
|
# The Initial Developer of the Original Code is Netscape Communications
|
|
# Corporation. Portions created by Netscape are
|
|
# Copyright (C) 1998 Netscape Communications Corporation. All
|
|
# Rights Reserved.
|
|
#
|
|
# Contributor(s): Harrison Page <harrison@netscape.com>
|
|
# Terry Weissman <terry@mozilla.org>
|
|
# Risto Kotalampi <risto@kotalampi.com>
|
|
# Josh Soref <timeless@bemail.org>
|
|
# Ian Hickson <mozbot@hixie.ch>
|
|
#
|
|
# mozbot.pl harrison@netscape.com 1998-10-14
|
|
# "irc bot for the gang on #mozilla"
|
|
#
|
|
# mozbot.pl mozbot@hixie.ch 2000-07-04
|
|
# "irc bot engine for anyone" :-)
|
|
#
|
|
# hack on me! required reading:
|
|
#
|
|
# Net::IRC web page:
|
|
# http://netirc.betterbox.net/
|
|
# (free software)
|
|
# or get it from CPAN @ http://www.perl.com/CPAN
|
|
#
|
|
# RFC 1459 (Internet Relay Chat Protocol):
|
|
# http://sunsite.cnlab-switch.ch/ftp/doc/standard/rfc/14xx/1459
|
|
#
|
|
# Please file bugs in Bugzilla, under the 'Webtools' product,
|
|
# component 'Mozbot'. http://bugzilla.mozilla.org/
|
|
|
|
# TO DO LIST
|
|
# XXX Something that checks modules that failed to compile and then
|
|
# reloads them when possible
|
|
# XXX an HTML entity convertor for things that speak web page contents
|
|
# XXX UModeChange
|
|
# XXX minor checks
|
|
# XXX throttle nick changing and away setting (from module API)
|
|
# XXX compile self before run
|
|
# XXX parse mode (+o, etc)
|
|
# XXX customise gender
|
|
# XXX optimisations
|
|
# XXX maybe should catch hangup signal and go to background?
|
|
# XXX protect the bot from DOS attacks causing server overload
|
|
# XXX protect the server from an overflowing log (add log size limitter
|
|
# or rotation)
|
|
|
|
|
|
################################
|
|
# Initialisation #
|
|
################################
|
|
|
|
# -- #mozwebtools was here --
|
|
# <Hixie> syntax error at oopsbot.pl line 48, near "; }"
|
|
# <Hixie> Execution of oopsbot.pl aborted due to compilation errors.
|
|
# <Hixie> DOH!
|
|
# <endico> hee hee. nice smily in the error message
|
|
|
|
# catch nasty occurances
|
|
$SIG{'INT'} = sub { &killed('INT'); };
|
|
$SIG{'KILL'} = sub { &killed('KILL'); };
|
|
$SIG{'TERM'} = sub { &killed('TERM'); };
|
|
$SIG{'CHLD'} = sub { wait(); };
|
|
|
|
# this allows us to exit() without shutting down (by exec($0)ing)
|
|
BEGIN { exit() if ((defined($ARGV[0])) and ($ARGV[0] eq '--abort')); }
|
|
|
|
# pragmas
|
|
use strict;
|
|
use diagnostics;
|
|
|
|
# chroot if requested
|
|
my $CHROOT = 0;
|
|
if ((defined($ARGV[0])) and ($ARGV[0] eq '--chroot')) {
|
|
# chroot
|
|
chroot('.') or die "chroot failed: $!\nAborted";
|
|
# setuid
|
|
# This is hardcoded to use user ids and group ids 60001.
|
|
# You'll want to change this on your system.
|
|
$> = 60001; # setuid nobody
|
|
$) = 60001; # setgid nobody
|
|
shift(@ARGV);
|
|
use lib '/lib';
|
|
$CHROOT = 1;
|
|
} elsif ((defined($ARGV[0])) and ($ARGV[0] eq '--assume-chrooted')) {
|
|
shift(@ARGV);
|
|
use lib '/lib';
|
|
$CHROOT = 1;
|
|
} else {
|
|
use lib 'lib';
|
|
}
|
|
|
|
# important modules
|
|
use Net::IRC 0.7; # 0.7 is not backwards compatible with 0.63 for CTCP responses
|
|
use IO::SecurePipe; # internal based on IO::Pipe
|
|
use IO::Select;
|
|
use Carp qw(cluck confess);
|
|
use Configuration; # internal
|
|
use Mails; # internal
|
|
|
|
# Note: Net::SMTP is also used, see the sendmail function in Mails.
|
|
|
|
# force flushing
|
|
$|++;
|
|
|
|
# internal 'constants'
|
|
my $NAME = 'mozbot';
|
|
my $VERSION = q$Revision: 2.8 $;
|
|
my $USERNAME = "pid-$$";
|
|
my $LOGFILEPREFIX;
|
|
|
|
# adjust the version constant
|
|
$VERSION =~ /([0-9.]+)/;
|
|
$VERSION = $1;
|
|
|
|
# variables that should only be changed if you know what you are doing
|
|
my $LOGGING = 1; # set to '0' to disable logging
|
|
my $LOGFILEDIR; # set this to override the logging output directory
|
|
|
|
if ($LOGGING) {
|
|
# set up the log directory
|
|
unless (defined($LOGFILEDIR)) {
|
|
if ($CHROOT) {
|
|
$LOGFILEDIR = '/log';
|
|
} else {
|
|
# setpwent doesn't work on Windows, we should wrap this in some OS test
|
|
setpwent; # reset the search settings for the getpwuid call below
|
|
$LOGFILEDIR = (getpwuid($<))[7].'/log';
|
|
}
|
|
}
|
|
"$LOGFILEDIR/$0" =~ /^(.*)$/os; # untaints the evil $0.
|
|
$LOGFILEPREFIX = $1; # for some reason, $0 is considered tainted here, but not in other cases...
|
|
mkdir($LOGFILEDIR, 0700); # if this fails for a bad reason, we'll find out during the next line
|
|
}
|
|
|
|
# begin session log...
|
|
&debug('-'x80);
|
|
&debug("$NAME $VERSION starting up");
|
|
&debug('compilation took '.&days($^T).'.');
|
|
if ($CHROOT) {
|
|
&debug('mozbot chroot()ed successfully');
|
|
}
|
|
|
|
# secure the environment
|
|
#
|
|
# XXX could automatically remove the current directory here but I am
|
|
# more comfortable with people knowing it is not allowed -- see the
|
|
# README file.
|
|
if ($ENV{'PATH'} =~ /^(?:.*:)?\.?(?::.*)?$/os) {
|
|
die 'SECURITY RISK. You cannot have \'.\' in the path. See the README. Aborted';
|
|
}
|
|
$ENV{'PATH'} =~ /^(.*)$/os;
|
|
$ENV{'PATH'} = $1; # we have to assume their path is otherwise safe, they called us!
|
|
delete (@ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'});
|
|
|
|
|
|
# read the configuration file
|
|
my $cfgfile = shift || "$0.cfg";
|
|
$cfgfile =~ /^(.*)$/os;
|
|
$cfgfile = $1; # untaint it -- we trust this, it comes from the admin.
|
|
&debug("reading configuration from '$cfgfile'...");
|
|
|
|
# - setup variables
|
|
# note: owner is only used by the Mails module
|
|
my ($server, $port, $localAddr, @nicks, @channels, %channelKeys, $owner, @modulenames, @ignoredUsers);
|
|
my $nick = 0;
|
|
my $sleepdelay = 60;
|
|
my $connectTimeout = 120;
|
|
my $delaytime = 1.3;
|
|
my $variablepattern = '[-_:a-zA-Z0-9]+';
|
|
my %users = ('admin' => &newPassword('password')); # default password for admin
|
|
my %userFlags = ('admin' => 3); # bitmask; 0x1 = admin, 0x2 = delete user a soon as other admin authenticates
|
|
my $helpline = 'see http://www.mozilla.org/projects/mozbot/'; # used in IRC name and in help
|
|
|
|
# - which variables can be saved.
|
|
®isterConfigVariables(
|
|
[\$server, 'server'],
|
|
[\$port, 'port'],
|
|
[\$localAddr, 'localAddr'],
|
|
[\@nicks, 'nicks'],
|
|
[\$nick, 'currentnick'], # pointer into @nicks
|
|
[\@channels, 'channels'],
|
|
[\%channelKeys, 'channelKeys'],
|
|
[\@ignoredUsers, 'ignoredUsers'],
|
|
[\@modulenames, 'modules'],
|
|
[\$owner, 'owner'],
|
|
[\$sleepdelay, 'sleep'],
|
|
[\$connectTimeout, 'connectTimeout'],
|
|
[\$delaytime, 'throttleTime'],
|
|
[\%users, 'users'], # usernames => &newPassword(passwords)
|
|
[\%userFlags, 'userFlags'], # usernames => bits
|
|
[\$variablepattern, 'variablepattern'],
|
|
[\$helpline, 'helpline'],
|
|
[\$Mails::smtphost, 'smtphost'],
|
|
);
|
|
|
|
# - read file
|
|
&Configuration::Get($cfgfile, &configStructure()); # empty gets entire structure
|
|
|
|
# - check variables are ok
|
|
# note. Ensure only works on an interactive terminal (-t).
|
|
# It will abort otherwise.
|
|
{ my $changed; # scope this variable
|
|
$changed = &Configuration::Ensure([
|
|
['Connect to which server?', \$server],
|
|
['To which port should I connect?', \$port],
|
|
['What channels should I join?', \@channels],
|
|
['What is the e-mail address of my owner?', \$owner],
|
|
['What is your SMTP host?', \$Mails::smtphost],
|
|
]);
|
|
|
|
# - check we have some nicks
|
|
until (@nicks) {
|
|
$changed = &Configuration::Ensure([['What nicks should I use? (I need at least one.)', \@nicks]]) || $changed;
|
|
# the original 'mozbot 2.0' development codename (and thus nick) was oopsbot.
|
|
}
|
|
|
|
# - check current nick pointer is valid
|
|
# (we assume that no sillyness has happened with $[ as,
|
|
# according to man perlvar, "Its use is highly discouraged".)
|
|
$nick = 0 if (($nick > $#nicks) or ($nick < 0));
|
|
|
|
# - check channel names are all lowercase
|
|
|
|
foreach (@channels) { $_ = lc; }
|
|
|
|
# save configuration straight away, to make sure it is possible and to save
|
|
# any initial settings on the first run, if anything changed.
|
|
if ($changed) {
|
|
&debug("saving configuration to '$cfgfile'...");
|
|
&Configuration::Save($cfgfile, &configStructure());
|
|
}
|
|
|
|
} # close the scope for the $changed variable
|
|
|
|
# ensure Mails is ready
|
|
&debug("setting up Mails module...");
|
|
$Mails::debug = \&debug;
|
|
$Mails::owner = \$owner;
|
|
|
|
# setup the IRC variables
|
|
&debug("setting up IRC variables...");
|
|
my $uptime;
|
|
my $irc = new Net::IRC or confess("Could not create a new Net::IRC object. Aborting");
|
|
|
|
# connect
|
|
&debug("attempting initial connection...");
|
|
&connect(); # hmm.
|
|
|
|
# setup the modules array
|
|
my @modules; # we initialize it lower down (at the bottom in fact)
|
|
my $lastadmin; # nick of last admin to be seen
|
|
my %authenticatedUsers; # hash of user@hostname=>users who have authenticated
|
|
|
|
|
|
################################
|
|
# Net::IRC handler subroutines #
|
|
################################
|
|
|
|
# setup connection
|
|
sub connect {
|
|
$uptime = time();
|
|
|
|
&debug("connecting to $server:$port...");
|
|
|
|
my ($bot, $mailed);
|
|
|
|
until ($bot = $irc->newconn(
|
|
Server => $server,
|
|
Port => $port,
|
|
Nick => $nicks[$nick],
|
|
Ircname => "$NAME $VERSION; $helpline",
|
|
Username => $USERNAME,
|
|
LocalAddr => $localAddr,
|
|
)) {
|
|
&debug("Could not connect. Are you sure '$server:$port' is a valid host?");
|
|
if (defined($localAddr)) {
|
|
&debug("Is '$localAddr' the correct address of the interface to use?");
|
|
} else {
|
|
&debug("Try editing '$cfgfile' to set 'localAddr' to the address of the interface to use.");
|
|
}
|
|
$mailed = &Mails::ServerDown($server, $port, $localAddr, $nicks[$nick], "$NAME $VERSION; $helpline", $nicks[0]) unless $mailed;
|
|
sleep($sleepdelay);
|
|
&Configuration::Get($cfgfile, &configStructure(\$server, \$port, \@nicks, \$nick, \$owner, \$sleepdelay));
|
|
&debug("connecting to $server:$port...");
|
|
}
|
|
|
|
&debug("connected! woohoo!");
|
|
|
|
# add the handlers
|
|
&debug("adding IRC handlers");
|
|
|
|
# $bot->debug(1); # this can help when debugging API stuff
|
|
|
|
&debug(" + informational ");
|
|
$bot->add_global_handler([ # Informational messages -- print these to the console
|
|
251, # RPL_LUSERCLIENT
|
|
252, # RPL_LUSEROP
|
|
253, # RPL_LUSERUNKNOWN
|
|
254, # RPL_LUSERCHANNELS
|
|
255, # RPL_LUSERME
|
|
302, # RPL_USERHOST
|
|
375, # RPL_MOTDSTART
|
|
372, # RPL_MOTD
|
|
], \&on_startup);
|
|
|
|
$bot->add_global_handler([ # Informational messages -- print these to the console
|
|
'snotice', # server notices
|
|
409, # noorigin
|
|
405, # toomanychannels XXX should do something about this!
|
|
404, # cannot sent to channel
|
|
403, # no such channel
|
|
401, # no such server
|
|
402, # no such nick
|
|
407, # too many targets
|
|
], \&on_notice);
|
|
|
|
&debug(" + end of startup ");
|
|
$bot->add_global_handler([ # should only be one command here - when to join channels
|
|
376, # RPL_ENDOFMOTD
|
|
422, # nomotd
|
|
], \&on_connect);
|
|
|
|
&debug(" + nick management ");
|
|
$bot->add_global_handler([ # when to change nick name
|
|
433, # ERR_NICKNAMEINUSE
|
|
436, # nick collision
|
|
], \&on_nick_taken);
|
|
|
|
&debug(" + connection management ");
|
|
$bot->add_global_handler([ # when to give up and go home
|
|
'disconnect', 'kill', # bad connection, booted offline
|
|
465, # ERR_YOUREBANNEDCREEP
|
|
], \&on_disconnected);
|
|
$bot->add_handler('destroy', \&on_destroy); # when object is GCed.
|
|
|
|
&debug(" + channel handlers");
|
|
$bot->add_handler('msg', \&on_private); # /msg bot hello
|
|
$bot->add_handler('public', \&on_public); # hello
|
|
$bot->add_handler('join', \&on_join); # when someone else joins
|
|
$bot->add_handler('part', \&on_part); # when someone else leaves
|
|
$bot->add_handler('topic', \&on_topic); # when topic changes in a channel
|
|
$bot->add_handler('notopic', \&on_topic); # when topic in a channel is cleared
|
|
$bot->add_handler('invite', \&on_invite); # when someone invites us
|
|
$bot->add_handler('quit', \&on_quit); # when someone quits IRC
|
|
$bot->add_handler('nick', \&on_nick); # when someone changes nick
|
|
$bot->add_handler('kick', \&on_kick); # when someone (or us) is kicked
|
|
$bot->add_handler('mode', \&on_mode); # when modes change
|
|
$bot->add_handler('umode', \&on_umode); # when modes of user change (by IRCop or ourselves)
|
|
# XXX could add handler for 474, # ERR_BANNEDFROMCHAN
|
|
|
|
&debug(" + whois messages");
|
|
$bot->add_handler([ # ones we handle to get our hostmask
|
|
311, # whoisuser
|
|
], \&on_whois);
|
|
$bot->add_handler([ # ones we handle just by outputting to the console
|
|
312, # whoisserver
|
|
313, # whoisoperator
|
|
314, # whowasuser
|
|
315, # endofwho
|
|
316, # whoischanop
|
|
317, # whoisidle
|
|
318, # endofwhois
|
|
319, # whoischannels
|
|
], \&on_notice);
|
|
|
|
&debug(" + CTCP handlers");
|
|
$bot->add_handler('cping', \&on_cping); # client to client ping
|
|
$bot->add_handler('crping', \&on_cpong); # client to client ping (response)
|
|
$bot->add_handler('cversion', \&on_version); # version info of mozbot.pl
|
|
$bot->add_handler('csource', \&on_source); # where is mozbot.pl's source
|
|
$bot->add_handler('caction', \&on_me); # when someone says /me
|
|
$bot->add_handler('cgender', \&on_gender); # guess
|
|
|
|
&debug("handlers added");
|
|
|
|
$bot->schedule($connectTimeout, \&on_check_connect);
|
|
|
|
# and done.
|
|
&Mails::ServerUp($server) if $mailed;
|
|
|
|
}
|
|
|
|
# called when the client receives a startup-related message
|
|
sub on_startup {
|
|
my ($self, $event) = @_;
|
|
my (@args) = $event->args;
|
|
shift(@args);
|
|
&debug(join(' ', @args));
|
|
}
|
|
|
|
# called when the client receives a server notice
|
|
sub on_notice {
|
|
my ($self, $event) = @_;
|
|
&debug($event->type.': '.join(' ', $event->args));
|
|
}
|
|
|
|
# called when the client receives whois data
|
|
sub on_whois {
|
|
my ($self, $event) = @_;
|
|
&debug('collecting whois information: '.join('|', $event->args));
|
|
# XXX could cache this information and then autoop people from
|
|
# the bot's host, or whatever
|
|
}
|
|
|
|
my ($nickHadProblem, $nickProblemEscalated, $nickOriginal) = (0, 0, 0);
|
|
|
|
sub on_nick_taken {
|
|
my ($self, $event, $nickSlept) = @_, 0;
|
|
return unless $self->connected();
|
|
if ($nickSlept) {
|
|
&debug("waited for a bit -- reading $cfgfile then searching for a nick...");
|
|
&Configuration::Get($cfgfile, &configStructure(\@nicks, \$nick));
|
|
$nick = 0 if ($nick > $#nicks) or ($nick < 0); # sanitise
|
|
$nickOriginal = $nick;
|
|
} else {
|
|
if (!$nickHadProblem) {
|
|
&debug("preferred nick ($nicks[$nick]) in use, searching for another...");
|
|
$nickOriginal = $nick;
|
|
$nickHadProblem++;
|
|
} # else we are currently looping
|
|
$nick++;
|
|
$nick = 0 if $nick > $#nicks;
|
|
if ($nick == $nickOriginal) {
|
|
# looped!
|
|
local $" = ", ";
|
|
&debug("could not find an unused nick");
|
|
&debug("nicks tried: @nicks");
|
|
if (-t) {
|
|
print "Please suggest a nick (blank to abort): ";
|
|
my $new = <>;
|
|
chomp($new);
|
|
if ($new) {
|
|
@nicks = (@nicks[0..$nickOriginal], $new, @nicks[$nickOriginal+1..$#nicks]);
|
|
&debug("saving nicks: @nicks");
|
|
&Configuration::Save($cfgfile, &configStructure(\@nicks));
|
|
} else {
|
|
&debug("Could not find an unused nick");
|
|
exit(1);
|
|
}
|
|
} else {
|
|
&debug("edit $cfgfile to add more nicks *hint* *hint*");
|
|
$nickProblemEscalated = Mails::NickShortage($cfgfile, $self->server, $self->port,
|
|
$self->username, $self->ircname, @nicks) unless $nickProblemEscalated;
|
|
$nickProblemEscalated++;
|
|
&debug("going to wait $sleepdelay seconds so as not to overload ourselves.");
|
|
$self->schedule($sleepdelay, \&on_nick_taken, $event, 1); # try again, this time don't mail if it goes wrong
|
|
return; # otherwise we no longer respond to pings.
|
|
}
|
|
}
|
|
}
|
|
&debug("now going to try nick $nicks[$nick]");
|
|
$self->nick($nicks[$nick]);
|
|
}
|
|
|
|
# called when we connect.
|
|
sub on_connect {
|
|
my $self = shift;
|
|
|
|
if (defined($self->{'__mozbot__shutdown'})) { # HACK HACK HACK
|
|
&debug('Uh oh. I connected anyway, even though I thought I had timed out.');
|
|
&debug('I\'m going to increase the timeout time by 20%.');
|
|
$connectTimeout = $connectTimeout * 1.2;
|
|
&Configuration::Save($cfgfile, &configStructure(\$connectTimeout));
|
|
$self->quit('having trouble connecting, brb...');
|
|
return;
|
|
}
|
|
|
|
&debug("using nick '$nicks[$nick]'");
|
|
if ($nickHadProblem) {
|
|
# Remember which nick we are using
|
|
&Configuration::Save($cfgfile, &configStructure(\$nick));
|
|
Mails::NickOk($nicks[$nick]) if $nickProblemEscalated;
|
|
}
|
|
|
|
# -- #mozwebtools was here --
|
|
# *** oopsbot (oopsbot@129.59.231.42) has joined channel #mozwebtools
|
|
# *** Mode change [+o oopsbot] on channel #mozwebtools by timeless
|
|
# <timeless> wow an oopsbot!
|
|
# *** Signoff: oopsbot (oopsbot@129.59.231.42) has left IRC [Leaving]
|
|
# <timeless> um
|
|
# <timeless> not very stable.
|
|
|
|
# now load all modules
|
|
@modules = ( # the 'internal' modules
|
|
BotModules::Admin->create('Admin', ''), # admin commands
|
|
BotModules::General->create('General', ''), # help-related commands
|
|
);
|
|
foreach (@modulenames) {
|
|
my $result = LoadModule($_);
|
|
if (ref($result)) {
|
|
&debug("loaded $_");
|
|
} else {
|
|
&debug("failed to load $_", $result);
|
|
}
|
|
}
|
|
|
|
# mass-configure the modules
|
|
&debug("loading module configurations...");
|
|
{ my %struct; # scope this variable
|
|
foreach my $module (@modules) { %struct = (%struct, %{$module->configStructure()}); }
|
|
&Configuration::Get($cfgfile, \%struct);
|
|
} # close the scope for the %struct variable
|
|
|
|
# tell the modules they have joined IRC
|
|
foreach my $module (@modules) { $module->JoinedIRC({'bot'=>$self}); }
|
|
|
|
# join the channels
|
|
&debug('going to join: '.join(',', @channels));
|
|
foreach my $channel (@channels) {
|
|
if (defined($channelKeys{$channel})) {
|
|
$self->join($channel, $channelKeys{$channel});
|
|
} else {
|
|
$self->join($channel);
|
|
}
|
|
}
|
|
|
|
# try to get our hostname
|
|
$self->whois($self->nick);
|
|
|
|
# tell the modules to set up the scheduled commands
|
|
&debug('setting up scheduler...');
|
|
foreach my $module (@modules) { $module->Schedule({'bot'=>$self}); }
|
|
|
|
# enable the drainmsgqueue
|
|
&drainmsgqueue($self);
|
|
|
|
# signal that we are connected (see next two functions)
|
|
$self->{'__mozbot__active'} = 1; # HACK HACK HACK
|
|
|
|
# all done!
|
|
&debug('initialisation took '.&days($uptime).'.');
|
|
$uptime = time();
|
|
|
|
}
|
|
|
|
sub on_check_connect {
|
|
my $self = shift;
|
|
return if (defined($self->{'__mozbot__shutdown'}) or defined($self->{'__mozbot__active'})); # HACK HACK HACK
|
|
$self->{'__mozbot__shutdown'} = 1; # HACK HACK HACK
|
|
&debug("connection timed out -- trying again");
|
|
foreach (@modules) { $_->unload(); }
|
|
@modules = ();
|
|
$self->quit('connection timed out -- trying to reconnect');
|
|
&connect();
|
|
}
|
|
|
|
# if something nasty happens
|
|
sub on_disconnected {
|
|
my $self = shift;
|
|
return if defined($self->{'__mozbot__shutdown'}); # HACK HACK HACK
|
|
$self->{'__mozbot__shutdown'} = 1; # HACK HACK HACK
|
|
&debug("eek! disconnected from network");
|
|
foreach (@modules) { $_->unload(); }
|
|
@modules = ();
|
|
&connect();
|
|
}
|
|
|
|
# if something nasty happens
|
|
sub on_destroy {
|
|
&debug("Connection: garbage collected");
|
|
}
|
|
|
|
# on_public: messages received on channels
|
|
sub on_public {
|
|
my ($self, $event) = @_;
|
|
if ($event->nick ne $self->nick) {
|
|
my $data = join(' ', $event->args);
|
|
my $nick = quotemeta($self->nick);
|
|
if ($data =~ /^(\s*$nick(?:[-\s,:;.!?]+|\s*-+>?\s+))(.+)$/is) {
|
|
if ($2) {
|
|
$event->args($2);
|
|
&do($self, $event, 'Told', 'Baffled');
|
|
} else {
|
|
&do($self, $event, 'Heard');
|
|
}
|
|
} else {
|
|
&do($self, $event, 'Heard');
|
|
}
|
|
}
|
|
}
|
|
|
|
sub on_private {
|
|
my ($self, $event) = @_;
|
|
my $data = join(' ', $event->args);
|
|
my $nick = quotemeta($self->nick);
|
|
if (($data =~ /^($nick(?:[-\s,:;.!?]|\s*-+>?\s+))(.+)$/is) and ($2)) {
|
|
# we do this so that you can say 'mozbot do this' in both channels
|
|
# and /query screens alike (otherwise, in /query screens you would
|
|
# have to remember to omit the bot name).
|
|
$event->args($2);
|
|
}
|
|
&do($self, $event, 'Told', 'Baffled');
|
|
}
|
|
|
|
# on_me: /me actions (CTCP actually)
|
|
sub on_me {
|
|
my ($self, $event) = @_;
|
|
if ($event->nick ne $self->nick) {
|
|
my @data = $event->args;
|
|
my $data = join(' ', @data);
|
|
$event->args($data);
|
|
my $nick = quotemeta($self->nick);
|
|
if ($data =~ /(?:^|[\s":<([])$nick(?:[])>.,?!\s'&":]|$)/is) {
|
|
&do($self, $event, 'Felt');
|
|
} else {
|
|
&do($self, $event, 'Saw');
|
|
}
|
|
}
|
|
}
|
|
|
|
# on_topic: for when someone changes the topic
|
|
# also for when the server notifies us of the topic
|
|
# ...so we have to parse it carefully.
|
|
sub on_topic {
|
|
my ($self, $event) = @_;
|
|
if ($event->userhost eq '@') {
|
|
# server notification
|
|
# need to parse data
|
|
my (undef, $channel, $topic) = $event->args;
|
|
$event->args($topic);
|
|
$event->to($channel);
|
|
}
|
|
&do(@_, 'SpottedTopicChange');
|
|
}
|
|
|
|
# on_kick: parse the kick event
|
|
sub on_kick {
|
|
my ($self, $event) = @_;
|
|
my ($channel, $from) = $event->args; # from is already set anyway
|
|
my $who = $event->to;
|
|
$event->to($channel);
|
|
foreach (@$who) {
|
|
$event->args($_);
|
|
if ($_ eq $self->nick) {
|
|
&do(@_, 'Kicked');
|
|
} else {
|
|
&do(@_, 'SpottedKick');
|
|
}
|
|
}
|
|
}
|
|
|
|
# Gives lag results for outgoing PINGs.
|
|
sub on_cpong {
|
|
my ($self, $event) = @_;
|
|
&debug('completed CTCP PING with '.$event->nick.': '.days($event->args->[0]));
|
|
# XXX should be able to use this then... see also Greeting module
|
|
# in standard distribution
|
|
}
|
|
|
|
# -- #mozbot was here --
|
|
# <timeless> $conn->add_handler('gender',\&on_ctcp_gender);
|
|
# <timeless> sub on_ctcp_gender{
|
|
# <timeless> my (undef, $event)=@_;
|
|
# <timeless> my $nick=$event->nick;
|
|
# <Hixie> # timeless this suspense is killing me!
|
|
# <timeless> $bot->ctcp_reply($nick, 'neuter');
|
|
# <timeless> }
|
|
|
|
# on_gender: What gender are we?
|
|
sub on_gender {
|
|
my ($self, $event) = @_;
|
|
my $nick = $event->nick;
|
|
$self->ctcp_reply($nick, 'neuter');
|
|
} # well, close enough...
|
|
|
|
# simple handler for when users do various things and stuff
|
|
sub on_join { &do(@_, 'SpottedJoin'); }
|
|
sub on_part { &do(@_, 'SpottedPart'); }
|
|
sub on_quit { &do(@_, 'SpottedQuit'); }
|
|
sub on_invite { &do(@_, 'Invited'); }
|
|
sub on_nick { &do(@_, 'SpottedNickChange'); }
|
|
sub on_mode { &do(@_, 'ModeChange'); } # XXX need to parse modes # XXX on key change, change %channelKeys hash
|
|
sub on_umode { &do(@_, 'UModeChange'); }
|
|
sub on_version { &do(@_, 'CTCPVersion'); }
|
|
sub on_source { &do(@_, 'CTCPSource'); }
|
|
sub on_cping { &do(@_, 'CTCPPing'); }
|
|
|
|
|
|
sub do {
|
|
my $self = shift @_;
|
|
my $event = shift @_;
|
|
my $channel = ''; # if message was sent to one channel only, this is it.
|
|
my $to = $event->to;
|
|
foreach (@$to) {
|
|
if (/^[#&+\$]/os) {
|
|
if ($channel) {
|
|
$channel = '';
|
|
last;
|
|
} else {
|
|
$channel = $_;
|
|
}
|
|
} elsif ($_ eq $self->nick) {
|
|
$channel = '';
|
|
last;
|
|
}
|
|
}
|
|
$channel = lc($channel);
|
|
my $e = {
|
|
'bot' => $self,
|
|
'_event' => $event, # internal internal internal do not use... ;-)
|
|
'channel' => $channel,
|
|
'from' => $event->nick,
|
|
'target' => $channel || $event->nick,
|
|
'user' => $event->userhost,
|
|
'data' => join(' ', $event->args),
|
|
'to' => $to,
|
|
'subtype' => $event->type,
|
|
'firsttype' => $_[0],
|
|
'nick' => $self->nick(),
|
|
# level (set below)
|
|
# type (set below)
|
|
};
|
|
# updated admin field if person is an admin
|
|
if ($authenticatedUsers{$event->userhost}) {
|
|
if (($userFlags{$authenticatedUsers{$event->userhost}} & 1) == 1) {
|
|
$lastadmin = $event->nick;
|
|
}
|
|
$e->{'userName'} = $authenticatedUsers{$event->userhost};
|
|
$e->{'userFlags'} = $userFlags{$authenticatedUsers{$event->userhost}};
|
|
} else {
|
|
$e->{'userName'} = 0;
|
|
}
|
|
unless (scalar(grep $e->{'user'} =~ /^\Q$_\E$/g, @ignoredUsers)) {
|
|
my $continue;
|
|
do {
|
|
my $type = shift @_;
|
|
my $level = 0;
|
|
my @modulesInNextLoop = @modules;
|
|
$continue = 1;
|
|
$e->{'type'} = $type;
|
|
&debug("$type: $channel <".$event->nick.'> '.join(' ', $event->args));
|
|
do {
|
|
$level++;
|
|
$e->{'level'} = $level;
|
|
my @modulesInThisLoop = @modulesInNextLoop;
|
|
@modulesInNextLoop = ();
|
|
foreach my $module (@modulesInThisLoop) {
|
|
my $currentResponse;
|
|
eval {
|
|
$currentResponse = $module->do($self, $event, $type, $e);
|
|
};
|
|
if ($@) {
|
|
# $@ contains the error
|
|
&debug("ERROR IN MODULE $module->{'_name'}!!!", $@);
|
|
} elsif (!defined($currentResponse)) {
|
|
&debug("ERROR IN MODULE $module->{'_name'}: invalid response code to event '$type'.");
|
|
} else {
|
|
if ($currentResponse > $level) {
|
|
push(@modulesInNextLoop, $module);
|
|
}
|
|
$continue = ($continue and $currentResponse);
|
|
}
|
|
}
|
|
} while (@modulesInNextLoop);
|
|
} while ($continue and scalar(@_));
|
|
} else {
|
|
&debug("Ignored: $channel <".$event->nick.'> '.join(' ', $event->args));
|
|
}
|
|
foreach my $module (@modules) {
|
|
eval {
|
|
$module->Log($e);
|
|
};
|
|
if ($@) {
|
|
# $@ contains the error
|
|
&debug("ERROR!!!", $@);
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
################################
|
|
# internal utilities #
|
|
################################
|
|
|
|
my @msgqueue;
|
|
my $timeLastSetAway = 0; # the time since the away flag was last set, so that we don't set it repeatedly.
|
|
|
|
# Use this routine, always, instead of the standard "privmsg" routine. This
|
|
# one makes sure we don't send more than one message every two seconds or so,
|
|
# which will make servers not whine about us flooding the channel.
|
|
# messages aren't the only type of flood :-( away is included
|
|
sub sendmsg {
|
|
my ($self, $who, $msg, $do) = (@_, 'msg');
|
|
unless ((defined($do) and defined($msg) and defined($who) and ($who ne '')) and
|
|
((($do eq 'msg') and (not ref($msg))) or
|
|
(($do eq 'me') and (not ref($msg))) or
|
|
(($do eq 'ctcpSend') and (ref($msg) eq 'ARRAY') and (@$msg >= 2)) or
|
|
(($do eq 'ctcpReply') and (not ref($msg))))) {
|
|
cluck('Wrong arguments passed to sendmsg() - ignored');
|
|
} else {
|
|
$self->schedule($delaytime / 2, \&drainmsgqueue) unless @msgqueue;
|
|
if ($do eq 'msg' or $do eq 'me') {
|
|
foreach (splitMessageAcrossLines($msg)) {
|
|
push(@msgqueue, [$who, $_, $do]);
|
|
}
|
|
} else {
|
|
push(@msgqueue, [$who, $msg, $do]);
|
|
}
|
|
}
|
|
}
|
|
|
|
# send any pending messages
|
|
sub drainmsgqueue {
|
|
my $self = shift;
|
|
return unless $self->connected;
|
|
my $qln = @msgqueue;
|
|
if (@msgqueue > 0) {
|
|
my ($who, $msg, $do) = getnextmsg();
|
|
if ($do eq 'msg') {
|
|
&debug("->$who: $msg"); # XXX this makes logfiles large quickly...
|
|
$self->privmsg($who, $msg); # it seems 'who' can be an arrayref and it works
|
|
} elsif ($do eq 'me') {
|
|
&debug("->$who * $msg"); # XXX
|
|
$self->me($who, $msg);
|
|
} elsif ($do eq 'ctcpSend') {
|
|
{ local $" = ' '; &debug("->$who CTCP PRIVMSG @$msg"); }
|
|
my $type = shift @$msg; # @$msg contains (type, args)
|
|
$self->ctcp($type, $who, @$msg);
|
|
} elsif ($do eq 'ctcpReply') {
|
|
{ local $" = ' '; &debug("->$who CTCP NOTICE $msg"); }
|
|
$self->ctcp_reply($who, $msg);
|
|
} else {
|
|
&debug("Unknown action '$do' intended for '$who' (content: '$msg') ignored.");
|
|
}
|
|
if (@msgqueue > 0) {
|
|
if ((@msgqueue % 10 == 0) and (time() - $timeLastSetAway > 5 * $delaytime)) {
|
|
&bot_longprocess($self, "Long send queue. There were $qln, and I just sent one to $who.");
|
|
$timeLastSetAway = time();
|
|
$self->schedule($delaytime * 4, # because previous one counts as message, plus you want to delay an extra bit regularly
|
|
\&drainmsgqueue);
|
|
} else {
|
|
$self->schedule($delaytime, \&drainmsgqueue);
|
|
}
|
|
} else {
|
|
&bot_back($self); # clear away state
|
|
}
|
|
}
|
|
}
|
|
|
|
# wrap long lines at spaces and hard returns (\n)
|
|
# this is for IRC, not for the console -- long can be up to 255
|
|
sub splitMessageAcrossLines {
|
|
my ($str) = @_;
|
|
my $MAXPROTOCOLLENGTH = 255;
|
|
my @output;
|
|
# $str could be several lines split with \n, so split it first:
|
|
foreach my $line (split(/\n/, $str)) {
|
|
while (length($line) > $MAXPROTOCOLLENGTH) {
|
|
# position is zero-based index
|
|
my $pos = rindex($line, ' ', $MAXPROTOCOLLENGTH - 1);
|
|
if ($pos < 0) {
|
|
$pos = $MAXPROTOCOLLENGTH - 1;
|
|
}
|
|
push(@output, substr($line, 0, $pos));
|
|
$line = substr($line, $pos);
|
|
$line =~ s/^\s+//gos;
|
|
}
|
|
push(@output, $line) if length($line);
|
|
}
|
|
return @output;
|
|
}
|
|
|
|
# equivalent of shift or pop, but for the middle of the array.
|
|
# used by getnextmsg() below to pull the messages out of the
|
|
# msgqueue stack and shove them at the end.
|
|
sub yank {
|
|
my ($index, $list) = @_;
|
|
my $result = @{$list}[$index];
|
|
@{$list} = (@{$list}[0..$index-1], @{$list}[$index+1..$#{$list}]);
|
|
return $result;
|
|
}
|
|
|
|
# looks at the msgqueue stack and decides which message to send next.
|
|
sub getnextmsg {
|
|
my ($who, $msg, $do) = @{shift(@msgqueue)};
|
|
my @newmsgqueue;
|
|
my $index = 0;
|
|
while ($index < @msgqueue) {
|
|
if ($msgqueue[$index]->[0] eq $who) {
|
|
push(@newmsgqueue, &yank($index, \@msgqueue));
|
|
} else {
|
|
$index++;
|
|
}
|
|
}
|
|
push(@msgqueue, @newmsgqueue);
|
|
return ($who, $msg, $do);
|
|
}
|
|
|
|
my $markedaway = 0;
|
|
|
|
# mark bot as being away
|
|
sub bot_longprocess {
|
|
my $self = shift;
|
|
&debug('[away: '.join(' ',@_).']');
|
|
$self->away(join(' ',@_));
|
|
$markedaway = @_;
|
|
}
|
|
|
|
# mark bot as not being away anymore
|
|
sub bot_back {
|
|
my $self = shift;
|
|
$self->away('') if $markedaway;
|
|
$markedaway = 0;
|
|
}
|
|
|
|
|
|
# internal routines for IO::Select handling
|
|
|
|
sub bot_select {
|
|
my ($pipe) = @_;
|
|
$irc->removefh($pipe);
|
|
# enable slurp mode for this function (see man perlvar for $/ documentation)
|
|
local $/;
|
|
undef $/;
|
|
my $data = <$pipe>;
|
|
&debug("child ${$pipe}->{'BotModules_PID'} completed ${$pipe}->{'BotModules_ChildType'}".
|
|
(${$pipe}->{'BotModules_Module'}->{'_shutdown'} ?
|
|
' (nevermind, module has shutdown)': ''));
|
|
waitpid(${$pipe}->{'BotModules_PID'}, 0);
|
|
&debug("child ${$pipe}->{'BotModules_PID'} exited.");
|
|
return if ${$pipe}->{'BotModules_Module'}->{'_shutdown'}; # see unload()
|
|
eval {
|
|
${$pipe}->{'BotModules_Module'}->ChildCompleted(
|
|
${$pipe}->{'BotModules_Event'},
|
|
${$pipe}->{'BotModules_ChildType'},
|
|
$data,
|
|
@{${$pipe}->{'BotModules_Data'}}
|
|
);
|
|
};
|
|
if ($@) {
|
|
# $@ contains the error
|
|
&debug("ERROR!!!", $@);
|
|
}
|
|
}
|
|
|
|
|
|
# internal routines for console output, stuff
|
|
|
|
# print debugging info
|
|
sub debug {
|
|
my $line;
|
|
foreach (@_) {
|
|
$line = $_; # can't chomp $_ since it is a hardref to the arguments...
|
|
chomp $line; # ...and they are probably a constant string!
|
|
if (-t) {
|
|
print &logdate() . " ($$) $line";
|
|
}
|
|
if ($LOGGING) {
|
|
# XXX this file grows without bounds!!!
|
|
if (open(LOG, ">>$LOGFILEPREFIX.$$.log")) {
|
|
print LOG &logdate() . " $line\n";
|
|
close(LOG);
|
|
print "\n";
|
|
} else {
|
|
print " [not logged, $!]\n";
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
# logdate: return nice looking date and time stamp
|
|
sub logdate {
|
|
my ($sec, $min, $hour, $mday, $mon, $year) = gmtime(shift or time);
|
|
return sprintf("%d-%02d-%02d %02d:%02d:%02d UTC",
|
|
$year + 1900, $mon + 1, $mday, $hour, $min, $sec);
|
|
}
|
|
|
|
# days: how long ago was that?
|
|
sub days {
|
|
my $then = shift;
|
|
# maths
|
|
my $seconds = time - $then;
|
|
my $minutes = int ($seconds / 60);
|
|
my $hours = int ($minutes / 60);
|
|
my $days = int ($hours / 24);
|
|
# english
|
|
if ($seconds < 60) {
|
|
return sprintf("%d second%s", $seconds, $seconds == 1 ? "" : "s");
|
|
} elsif ($minutes < 60) {
|
|
return sprintf("%d minute%s", $minutes, $minutes == 1 ? "" : "s");
|
|
} elsif ($hours < 24) {
|
|
return sprintf("%d hour%s", $hours, $hours == 1 ? "" : "s");
|
|
} else {
|
|
return sprintf("%d day%s", $days, $days == 1 ? "" : "s");
|
|
}
|
|
}
|
|
|
|
# signal handler
|
|
sub killed {
|
|
my($sig) = @_;
|
|
&debug("received signal $sig. shutting down...");
|
|
&debug('This is evil. You should /msg me a shutdown command instead.');
|
|
&debug('WARNING: SHUTTING ME DOWN LIKE THIS CAN CAUSE FORKED PROCESSES TO START UP AS BOTS!!!'); # XXX which we should fix, of course.
|
|
exit(1); # sane exit, including shutting down any modules
|
|
}
|
|
|
|
|
|
# internal routines for configuration
|
|
|
|
my %configStructure; # hash of cfg file keys and associated variable refs
|
|
|
|
# ok. In strict 'refs' mode, you cannot use strings as refs. Fair enough.
|
|
# However, hash keys are _always_ strings. Using a ref as a hash key turns
|
|
# it into a string. So we have to keep a virgin copy of the ref around.
|
|
#
|
|
# So the structure of the %configStructure hash is:
|
|
# "ref" => [ cfgName, ref ]
|
|
# Ok?
|
|
|
|
sub registerConfigVariables {
|
|
my (@variables) = @_;
|
|
foreach (@variables) {
|
|
$configStructure{$$_[0]} = [$$_[1], $$_[0]];
|
|
}
|
|
} # are you confused yet?
|
|
|
|
sub configStructure {
|
|
my (@variables) = @_;
|
|
my %struct;
|
|
@variables = keys %configStructure unless @variables;
|
|
foreach (@variables) {
|
|
confess("Function configStructure was passed something that is either not a ref or has not yet neem registered, so aborted") unless defined($configStructure{$_});
|
|
$struct{$configStructure{$_}[0]} = $configStructure{$_}[1];
|
|
}
|
|
return \%struct;
|
|
}
|
|
|
|
|
|
# internal routines for handling the modules
|
|
|
|
sub getModule {
|
|
my ($name) = @_;
|
|
foreach my $module (@modules) { # XXX this is not cached as a hash as performance is not a priority here
|
|
return $module if $name eq $module->{'_name'};
|
|
}
|
|
return undef;
|
|
}
|
|
|
|
sub LoadModule {
|
|
my ($name) = @_;
|
|
# sanitize the name
|
|
$name =~ s/[^-a-zA-Z0-9]/-/gos;
|
|
# check the module is not already loaded
|
|
foreach (@modules) {
|
|
if ($_->{'_name'} eq $name) {
|
|
return "Failed [0]: Module already loaded. Don't forget to enable it in the various channels (vars $name channels '+#channelname').";
|
|
}
|
|
}
|
|
# read the module in from a file
|
|
my $filename = "./BotModules/$name.bm"; # bm = bot module
|
|
my $result = open(my $file, "< $filename");
|
|
if ($result) {
|
|
local $/;
|
|
undef $/; # enable "slurp" mode
|
|
my $code = <$file>; # whole file now here
|
|
if ($code) {
|
|
# if ($code =~ /package\s+\QBotModules::$name\E\s*;/gos) { XXX doesn't work reliably?? XXX
|
|
# eval the file
|
|
$code =~ /^(.*)$/os;
|
|
$code = $1; # completely defeat the tainting mechanism.
|
|
# $code = "# FILE: $filename\n".$code; # "# file 1 '$filename' \n" would be good without Carp.pm
|
|
{ no warnings; # as per the warning, but doesn't work??? XXX
|
|
eval($code); }
|
|
if ($@) {
|
|
# $@ contains the error
|
|
return "Failed [4]: $@";
|
|
} else {
|
|
# if ok, then create a module
|
|
my $newmodule;
|
|
eval("
|
|
\$newmodule = BotModules::$name->create('$name', '$filename');
|
|
");
|
|
if ($@) {
|
|
# $@ contains the error
|
|
return "Failed [5]: $@";
|
|
} else {
|
|
# if ok, then add it to the @modules list
|
|
push(@modules, $newmodule);
|
|
# Done!!!
|
|
return $newmodule;
|
|
}
|
|
}
|
|
# } else {
|
|
# return "Failed [3]: Could not find valid module definition line.";
|
|
# }
|
|
} else {
|
|
# $! contains the error
|
|
if ($!) {
|
|
return "Failed [2]: $!";
|
|
} else {
|
|
return "Failed [2]: Module file is empty.";
|
|
}
|
|
}
|
|
} else {
|
|
# $! contains the error
|
|
return "Failed [1]: $!";
|
|
}
|
|
}
|
|
|
|
sub UnloadModule {
|
|
my ($name) = @_;
|
|
# remove the reference from @modules
|
|
my @newmodules;
|
|
foreach (@modules) {
|
|
if ($name eq $_->{'_name'}) {
|
|
if ($_->{'_static'}) {
|
|
return 'Cannot unload this module, it is built in.';
|
|
}
|
|
$_->unload();
|
|
} else {
|
|
push(@newmodules, $_);
|
|
}
|
|
}
|
|
if (@modules == @newmodules) {
|
|
return 'Module not loaded. Are you sure you have the right name?';
|
|
} else {
|
|
@modules = @newmodules;
|
|
return;
|
|
}
|
|
}
|
|
|
|
# password management functions
|
|
|
|
sub getSalt {
|
|
# straight from man perlfunc
|
|
return join('', ('.', '/', 0..9, 'A'..'Z', 'a'..'z')[rand 64, rand 64]);
|
|
}
|
|
|
|
sub newPassword {
|
|
my($text) = @_;
|
|
return crypt($text, &getSalt());
|
|
}
|
|
|
|
sub checkPassword {
|
|
my($text, $password) = @_;
|
|
return (crypt($text, $password) eq $password);
|
|
}
|
|
|
|
################################
|
|
# Base Module #
|
|
################################
|
|
|
|
# And now, for my next trick, the base module (duh).
|
|
|
|
package BotModules;
|
|
|
|
1; # nothing to see here...
|
|
|
|
# ENGINE INTERFACE
|
|
|
|
# create - create a new BotModules object.
|
|
# Do not call this yourself. We call it. Ok?
|
|
# Do not override this either, unless you know what
|
|
# you are doing (I don't, and I wrote it...). If you
|
|
# want to add variables to $self, use Initialise.
|
|
# The paramter is the name of the module.
|
|
sub create {
|
|
my $class = shift;
|
|
my ($name, $filename) = @_;
|
|
my $self = {
|
|
'_name' => $name,
|
|
'_shutdown' => 0, # see unload()
|
|
'_static' => 0, # set to 1 to prevent module being unloaded
|
|
'_variables' => {},
|
|
'_config' => {},
|
|
'_filename' => $filename,
|
|
'_filemodificationtime' => undef,
|
|
};
|
|
bless($self, $class);
|
|
$self->Initialise();
|
|
$self->RegisterConfig();
|
|
return $self;
|
|
}
|
|
|
|
sub DESTROY {
|
|
my $self = shift;
|
|
$self->debug('garbage collected');
|
|
}
|
|
|
|
# called by &::UnloadModule().
|
|
# this removes any pointers to the module.
|
|
# for example, it stops the scheduler from installing new timers,
|
|
# so that the bot [eventually] severs its connection with the module.
|
|
sub unload {
|
|
my $self = shift;
|
|
$self->{'_shutdown'} = 1; # see doScheduled and bot_select
|
|
}
|
|
|
|
# configStructure - return the hash needed for Configuration module
|
|
sub configStructure {
|
|
my $self = shift;
|
|
return $self->{'_config'};
|
|
}
|
|
|
|
# do - called to do anything (duh) (no, do, not duh) (oh, ok, sorry)
|
|
sub do {
|
|
my $self = shift;
|
|
my ($bot, $event, $type, $e) = @_;
|
|
# first, we check that the user is not banned from using this module. If he
|
|
# is, then re give up straight away.
|
|
return 1 if ($self->IsBanned($e));
|
|
# next we check that the module is actually enabled in this channel, and
|
|
# if it is not we quit straight away as well.
|
|
return 1 unless ($e->{'channel'} eq '') or ($self->InChannel($e));
|
|
# Ok, dispatch the event.
|
|
if ($type eq 'Told') {
|
|
return $self->Told($e, $e->{'data'});
|
|
} elsif ($type eq 'Heard') {
|
|
return $self->Heard($e, $e->{'data'});
|
|
} elsif ($type eq 'Baffled') {
|
|
return $self->Baffled($e, $e->{'data'});
|
|
} elsif ($type eq 'Felt') {
|
|
return $self->Felt($e, $e->{'data'});
|
|
} elsif ($type eq 'Saw') {
|
|
return $self->Saw($e, $e->{'data'});
|
|
} elsif ($type eq 'Invited') {
|
|
return $self->Invited($e, $e->{'data'});
|
|
} elsif ($type eq 'Kicked') {
|
|
return $self->Kicked($e, $e->{'channel'});
|
|
} elsif ($type eq 'ModeChange') {
|
|
return $self->ModeChange($e, $e->{'channel'}, $e->{'data'}, $e->{'from'});
|
|
} elsif ($type eq 'Authed') {
|
|
return $self->Authed($e, $e->{'from'});
|
|
} elsif ($type eq 'SpottedNickChange') {
|
|
return $self->SpottedNickChange($e, $e->{'from'}, $e->{'data'});
|
|
} elsif ($type eq 'SpottedTopicChange') {
|
|
return $self->SpottedTopicChange($e, $e->{'channel'}, $e->{'data'});
|
|
} elsif ($type eq 'SpottedJoin') {
|
|
return $self->SpottedJoin($e, $e->{'channel'}, $e->{'from'});
|
|
} elsif ($type eq 'SpottedPart') {
|
|
return $self->SpottedPart($e, $e->{'channel'}, $e->{'from'});
|
|
} elsif ($type eq 'SpottedKick') {
|
|
return $self->SpottedKick($e, $e->{'channel'}, $e->{'data'});
|
|
} elsif ($type eq 'SpottedQuit') {
|
|
return $self->SpottedQuit($e, $e->{'from'}, $e->{'data'});
|
|
} elsif ($type eq 'CTCPPing') {
|
|
return $self->CTCPPing($e, $e->{'from'}, $e->{'data'});
|
|
} elsif ($type eq 'CTCPVersion') {
|
|
return $self->CTCPVersion($e, $e->{'from'}, $e->{'data'});
|
|
} elsif ($type eq 'CTCPSource') {
|
|
return $self->CTCPSource($e, $e->{'from'}, $e->{'data'});
|
|
|
|
# XXX have not implemented mode parsing yet
|
|
} elsif ($type eq 'GotOpped') {
|
|
return $self->GotOpped($e, $e->{'channel'}, $e->{'from'});
|
|
} elsif ($type eq 'GotDeopped') {
|
|
return $self->GotDeopped($e, $e->{'channel'}, $e->{'from'});
|
|
} elsif ($type eq 'SpottedOpping') {
|
|
return $self->SpottedOpping($e, $e->{'channel'}, $e->{'from'});
|
|
} elsif ($type eq 'SpottedDeopping') {
|
|
return $self->SpottedDeopping($e, $e->{'channel'}, $e->{'from'});
|
|
} else {
|
|
$self->debug("Unknown action type '$type'. Ignored.");
|
|
# XXX UModeChange (not implemented yet)
|
|
return 1; # could not do it
|
|
}
|
|
}
|
|
|
|
|
|
# MODULE API - use these from the your routines.
|
|
|
|
# prints output to the console
|
|
sub debug {
|
|
my $self = shift;
|
|
foreach my $line (@_) {
|
|
&::debug('Module '.$self->{'_name'}.': '.$line);
|
|
}
|
|
}
|
|
|
|
# saveConfig - call this when you change a configuration option. It resaves the config file.
|
|
sub saveConfig {
|
|
my $self = shift;
|
|
&Configuration::Save($cfgfile, $self->configStructure());
|
|
}
|
|
|
|
# registerVariables - Registers a variable with the config system and the var setting system
|
|
# parameters: (
|
|
# [ 'name', persistent ? 1:0, editable ? 1:0, $value ],
|
|
# use undef instead of 0 or 1 to leave as is
|
|
# use undef (or don't mention) the $value to not set the value
|
|
# )
|
|
sub registerVariables {
|
|
my $self = shift;
|
|
my (@variables) = @_;
|
|
foreach (@variables) {
|
|
$self->{$$_[0]} = $$_[3] if defined($$_[3]);
|
|
if (defined($$_[1])) {
|
|
if ($$_[1]) {
|
|
$self->{'_config'}->{$self->{'_name'}.'::'.$$_[0]} = \$self->{$$_[0]};
|
|
} else {
|
|
delete($self->{'_config'}->{$self->{'_name'}.'::'.$$_[0]});
|
|
}
|
|
}
|
|
$self->{'_variables'}->{$$_[0]} = $$_[2] if defined($$_[2]);
|
|
}
|
|
}
|
|
|
|
# internal implementation of the scheduler
|
|
sub doScheduled {
|
|
my $bot = shift;
|
|
my ($self, $event, $time, $times, @data) = @_;
|
|
return if ($self->{'_shutdown'}); # see unload()
|
|
# $self->debug("scheduled event occured; $times left @ $time second interval");
|
|
eval {
|
|
$self->Scheduled($event, @data);
|
|
$self->schedule($event, $time, --$times, @data);
|
|
};
|
|
if ($@) {
|
|
# $@ contains the error
|
|
&::debug("ERROR!!!", $@);
|
|
}
|
|
}
|
|
|
|
# schedule - Sets a timer to call Scheduled later
|
|
# for events that should be setup at startup, call this from Schedule().
|
|
sub schedule {
|
|
my $self = shift;
|
|
my ($event, $time, $times, @data) = @_;
|
|
return if ($times == 0 or $self->{'_shutdown'}); # see unload()
|
|
$times = -1 if ($times < 0); # pass a negative number to have a recurring timer
|
|
my $delay = $time;
|
|
if (ref($time)) {
|
|
if (ref($time) eq 'SCALAR') {
|
|
$delay = $$time;
|
|
} else {
|
|
return; # XXX maybe be useful?
|
|
}
|
|
}
|
|
# if ($delay < 1) {
|
|
# $self->debug("Vetoed aggressive scheduling; forcing to 1 second minimum");
|
|
# $delay = 1;
|
|
# }
|
|
$event->{'bot'}->schedule($delay, \&doScheduled, $self, $event, $time, $times, @data);
|
|
}
|
|
|
|
# spawnChild - spawns a child process and adds it to the list of file handles to monitor
|
|
# eventually the bot calls ChildCompleted() with the output of the chlid process.
|
|
sub spawnChild {
|
|
my $self = shift;
|
|
my ($event, $command, $arguments, $type, $data) = @_;
|
|
# uses IO::SecurePipe and fork and exec
|
|
# secure, predictable, no dependencies on external code
|
|
# uses fork explicitly (and once implicitly)
|
|
my $pipe = IO::SecurePipe->new();
|
|
if (defined($pipe)) {
|
|
my $child = fork();
|
|
if (defined($child)) {
|
|
if ($child) {
|
|
# we are the parent process
|
|
$pipe->reader();
|
|
${$pipe}->{'BotModules_Module'} = $self;
|
|
${$pipe}->{'BotModules_Event'} = $event;
|
|
${$pipe}->{'BotModules_ChildType'} = $type;
|
|
${$pipe}->{'BotModules_Data'} = $data;
|
|
${$pipe}->{'BotModules_Command'} = $command;
|
|
${$pipe}->{'BotModules_Arguments'} = $arguments;
|
|
${$pipe}->{'BotModules_PID'} = $child;
|
|
$irc->addfh($pipe, \&::bot_select);
|
|
local $" = ' ';
|
|
$self->debug("spawned $child ($command @$arguments)");
|
|
return 0;
|
|
} else {
|
|
eval {
|
|
# we are the child process
|
|
# call $command and buffer the output
|
|
$pipe->writer(); # get writing end of pipe, ready to output the result
|
|
my $output;
|
|
if (ref($command) eq 'CODE') {
|
|
$output = &$command(@$arguments);
|
|
} else {
|
|
# it would be nice if some of this was on a timeout...
|
|
my $result = IO::SecurePipe->new(); # create a new pipe for $command
|
|
# call $command (implicit fork(), which may of course fail)
|
|
$result->reader($command, @$arguments);
|
|
local $/; # to not affect the rest of the program (what little there is)
|
|
$/ = \(2*1024*1024); # slurp up to two megabytes
|
|
$output = <$result>; # blocks until child process has finished
|
|
close($result); # reap child
|
|
}
|
|
print $pipe $output if ($output); # output the lot in one go back to parent
|
|
$pipe->close();
|
|
};
|
|
if ($@) {
|
|
# $@ contains the error
|
|
$self->debug('failed to spawn child', $@);
|
|
}
|
|
|
|
# -- #mozwebtools was here --
|
|
# <dawn> when is that stupid bot going to get checked in?
|
|
# <timeless> after it stops fork bombing
|
|
# <dawn> which one? yours or hixies?
|
|
# <timeless> his, mine doesn't fork
|
|
# <timeless> see topic
|
|
# <dawn> are there plans to fix it?
|
|
# <timeless> yes. but he isn't sure exactly what went wrong
|
|
# <timeless> i think it's basically they fork for wget
|
|
# <dawn> why don't you help him?
|
|
# <timeless> i don't understand forking
|
|
# <dawn> that didn't stop hixie
|
|
# <timeless> not to mention the fact that his forking doesn't
|
|
# work on windows
|
|
# <dawn> you have other machines. techbot1 runs on windows?
|
|
# <timeless> yeah it runs on windows
|
|
# <dawn> oh
|
|
# <dawn> get a real os, man
|
|
|
|
# The bug causing the 'fork bombing' was that I only
|
|
# did the following if $@ was true or if the call to
|
|
# 'reader' succeeded -- so if some other error occured
|
|
# that didn't trip the $@ test but still crashed out
|
|
# of the eval, then the script would quite happily
|
|
# continue, and when it eventually died (e.g. because
|
|
# of a bad connection), it would respawn multiple
|
|
# times (as many times as it had failed to fork) and
|
|
# it would succeed in reconnecting as many times as
|
|
# had been configured nicks...
|
|
|
|
eval {
|
|
exec { $0 } ($0, '--abort'); # do not call shutdown handlers
|
|
# the previous line works because exec() bypasses
|
|
# the perl object garbarge collection and simply
|
|
# deallocates all the memory in one go. This means
|
|
# the shutdown handlers (DESTROY and so on) are
|
|
# never called for this fork. This is good,
|
|
# because otherwise we would disconnect from IRC
|
|
# at this point!
|
|
};
|
|
|
|
$self->debug("failed to shutdown cleanly!!! $@");
|
|
exit(1); # exit in case exec($0) failed
|
|
|
|
}
|
|
} else {
|
|
$self->debug("failed to fork: $!");
|
|
}
|
|
} else {
|
|
$self->debug("failed to open pipe: $!");
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
# getURI - Downloads a file and then calls GotURI
|
|
sub getURI {
|
|
my $self = shift;
|
|
my ($event, $uri, @data) = @_;
|
|
$self->spawnChild($event, 'wget', ['--quiet', '--passive', '--user-agent="Mozilla/5.0 (compatible; mozbot)"', '--output-document=-', $uri], 'URI', [$uri, @data]);
|
|
}
|
|
|
|
# returns a reference to a module -- DO NOT STORE THIS REFERENCE!!!
|
|
sub getModule {
|
|
my $self = shift;
|
|
return &::getModule(@_);
|
|
}
|
|
|
|
# tellAdmin - may try to talk to an admin.
|
|
# NO GUARANTEES! This will PROBABLY NOT reach anyone!
|
|
sub tellAdmin {
|
|
my $self = shift;
|
|
my ($event, $data) = @_;
|
|
if ($lastadmin) {
|
|
$self->debug("Trying to tell admin '$lastadmin' this: $data");
|
|
&::sendmsg($event->{'bot'}, $lastadmin, $data);
|
|
} else {
|
|
$self->debug("Wanted to tell an admin '$data', but I've never seen one.");
|
|
}
|
|
}
|
|
|
|
# ctcpSend - Sends a CTCP message to someone
|
|
sub ctcpSend {
|
|
my $self = shift;
|
|
my ($event, $type, $data) = @_;
|
|
&::sendmsg($event->{'bot'}, $event->{'from'}, [$type, $data], 'ctcpSend');
|
|
}
|
|
|
|
# ctcpReply - Sends a CTCP reply to someone
|
|
sub ctcpReply {
|
|
my $self = shift;
|
|
my ($event, $type, $data) = @_;
|
|
unless (defined($type)) {
|
|
cluck('No type passed to ctcpReply - ignored');
|
|
}
|
|
if (defined($data)) {
|
|
&::sendmsg($event->{'bot'}, $event->{'from'}, "$type $data", 'ctcpReply');
|
|
} else {
|
|
&::sendmsg($event->{'bot'}, $event->{'from'}, $type, 'ctcpReply');
|
|
}
|
|
}
|
|
|
|
# say - Sends a message to the channel
|
|
sub say {
|
|
my $self = shift;
|
|
my ($event, $data) = @_;
|
|
$data =~ s/^\Q$event->{'target'}\E: //gs;
|
|
&::sendmsg($event->{'bot'}, $event->{'target'}, $data);
|
|
}
|
|
|
|
# announce - Sends a message to every channel
|
|
sub announce {
|
|
my $self = shift;
|
|
my ($event, $data) = @_;
|
|
foreach (@{$self->{'channels'}}) {
|
|
&::sendmsg($event->{'bot'}, $_, $data);
|
|
}
|
|
}
|
|
|
|
# directSay - Sends a message to the person who spoke
|
|
sub directSay {
|
|
my $self = shift;
|
|
my ($event, $data) = @_;
|
|
&::sendmsg($event->{'bot'}, $event->{'from'}, $data);
|
|
}
|
|
|
|
# channelSay - Sends a message to the channel the message came from, IFF it came from a channel.
|
|
sub channelSay {
|
|
my $self = shift;
|
|
my ($event, $data) = @_;
|
|
&::sendmsg($event->{'bot'}, $event->{'channel'}, $data) if $event->{'channel'};
|
|
}
|
|
|
|
# -- #mozilla was here --
|
|
# <richb> timeless: it's focal review time, and they are working out
|
|
# where to allocate the money.
|
|
# <richb> timeless: needless to say i have a vested interest in this.
|
|
# <leaf> there's money in this?
|
|
# <timeless> richb yes; leaf always
|
|
# <leaf> how come nobody told me?
|
|
# <timeless> because leaf doesn't need money
|
|
# <timeless> for leaf it grows on trees
|
|
# <leaf> *wince*
|
|
|
|
# emote - Sends an emote to the channel
|
|
sub emote {
|
|
my $self = shift;
|
|
my ($event, $data) = @_;
|
|
&::sendmsg($event->{'bot'}, $event->{'target'}, $data, 'me');
|
|
}
|
|
|
|
# directEmote - Sends an emote to the person who spoke
|
|
sub directEmote {
|
|
my $self = shift;
|
|
my ($event, $data) = @_;
|
|
&::sendmsg($event->{'bot'}, $event->{'from'}, $data, 'me');
|
|
}
|
|
|
|
# sayOrEmote - calls say() or emote() depending on whether the string starts with /me or not.
|
|
sub sayOrEmote {
|
|
my $self = shift;
|
|
my ($event, $data) = @_;
|
|
if ($data =~ /^\/me\s+/osi) {
|
|
$data =~ s/^\/me\s+//gosi;
|
|
$self->emote($event, $data);
|
|
} else {
|
|
$self->say($event, $data);
|
|
}
|
|
}
|
|
|
|
# directSayOrEmote - as sayOrEmote() but calls the direct versions instead
|
|
sub directSayOrEmote {
|
|
my $self = shift;
|
|
my ($event, $data) = @_;
|
|
if ($data =~ /^\/me\s+/osi) {
|
|
$data =~ s/^\/me\s+//gosi;
|
|
$self->directEmote($event, $data);
|
|
} else {
|
|
$self->directSay($event, $data);
|
|
}
|
|
}
|
|
|
|
# isAdmin - Returns true if the person is an admin
|
|
sub isAdmin {
|
|
my $self = shift;
|
|
my ($event) = @_;
|
|
return (($event->{'userName'}) and (($event->{'userFlags'} & 1) == 1));
|
|
}
|
|
|
|
# setAway - Set the bot's 'away' flag. A blank message will mark the bot as back.
|
|
# Note: If you need this you are doing something wrong!!!
|
|
sub setAway {
|
|
my $self = shift;
|
|
my ($event, $message) = @_;
|
|
$event->{'bot'}->away($message);
|
|
}
|
|
|
|
# setNick - Set the bot's nick.
|
|
# Note: Best not to use this too much, especially not based on user input,
|
|
# as it is not throttled. XXX
|
|
sub setNick {
|
|
my $self = shift;
|
|
my ($event, $value) = @_;
|
|
# Find nick's index.
|
|
my $newnick = 0;
|
|
$newnick++ while (($newnick < @nicks) and ($value ne $nicks[$newnick]));
|
|
# If nick isn't there, add it.
|
|
if ($newnick >= @nicks) {
|
|
push(@nicks, $value);
|
|
}
|
|
# set variable
|
|
$nick = $newnick;
|
|
$event->{'bot'}->nick($nicks[$nick]);
|
|
# save
|
|
&Configuration::Save($cfgfile, &::configStructure(\$nick, \@nicks));
|
|
}
|
|
|
|
sub mode {
|
|
my $self = shift;
|
|
my ($event, $channel, $mode, $arg) = @_;
|
|
$event->{'bot'}->mode($channel, $mode, $arg);
|
|
}
|
|
|
|
sub invite {
|
|
my $self = shift;
|
|
my ($event, $who, $channel) = @_;
|
|
$event->{'bot'}->invite($who, $channel);
|
|
}
|
|
|
|
# pretty printer for turning lists of varying length strings into
|
|
# lists of roughly equal length strings without losing any data
|
|
sub prettyPrint {
|
|
my $self = shift;
|
|
my ($preferredLineLength, $prefix, $indent, $divider, @input) = @_;
|
|
# sort numerically descending by length
|
|
@input = sort {length($b) <=> length($a)} @input;
|
|
# if we have a prefix defined, it goes first (duh)
|
|
unshift(@input, $prefix) if defined($prefix);
|
|
my @output;
|
|
my $index;
|
|
while (@input) {
|
|
push(@output, $indent . shift(@input));
|
|
$index = 0;
|
|
while (($index <= $#input) and
|
|
((length($output[$#output]) + length($input[$#input])) < $preferredLineLength)) {
|
|
# does this one fit?
|
|
if ((length($output[$#output]) + length($input[$index])) < $preferredLineLength) {
|
|
if (defined($prefix)) {
|
|
# don't stick the divider between the prefix and the first item
|
|
undef($prefix);
|
|
} else {
|
|
$output[$#output] .= $divider;
|
|
}
|
|
$output[$#output] .= splice(@input, $index, 1);
|
|
} else {
|
|
$index++;
|
|
}
|
|
}
|
|
}
|
|
return @output;
|
|
}
|
|
|
|
# wordWrap routines which takes a list and wraps it. A less pretty version
|
|
# of prettyPrinter, but it keeps the order.
|
|
sub wordWrap {
|
|
my $self = shift;
|
|
my ($preferredLineLength, $prefix, $indent, $divider, @input) = @_;
|
|
unshift(@input, $prefix) if defined($prefix);
|
|
my @output;
|
|
while (@input) {
|
|
push(@output, $indent . shift(@input));
|
|
while (($#input >= 0) and
|
|
((length($output[$#output]) + length($input[0])) < $preferredLineLength)) {
|
|
$output[$#output] .= $divider . shift(@input);
|
|
}
|
|
}
|
|
return @output;
|
|
}
|
|
|
|
sub unescapeXML {
|
|
my $self = shift;
|
|
my ($string) = @_;
|
|
$string =~ s/'/'/gos;
|
|
$string =~ s/"/"/gos;
|
|
$string =~ s/</</gos;
|
|
$string =~ s/>/>/gos;
|
|
$string =~ s/&/&/gos;
|
|
return $string;
|
|
}
|
|
|
|
sub days {
|
|
my $self = shift;
|
|
my ($then) = @_;
|
|
return &::days($then);
|
|
}
|
|
|
|
# return the argument if it is a valid regular expression,
|
|
# otherwise quotes the argument and returns that.
|
|
sub sanitizeRegexp {
|
|
my $self = shift;
|
|
my ($regexp) = @_;
|
|
if (defined($regexp)) {
|
|
eval {
|
|
'' =~ /$regexp/;
|
|
};
|
|
$self->debug("regexp |$regexp| returned error |$@|, quoting...") if $@;
|
|
return $@ ? quotemeta($regexp) : $regexp;
|
|
} else {
|
|
$self->debug("blank regexp, returning wildcard regexp //...");
|
|
return '';
|
|
}
|
|
}
|
|
|
|
|
|
# MODULE INTERFACE (override these)
|
|
|
|
# Initialise - Called when the module is loaded
|
|
sub Initialise {
|
|
my $self = shift;
|
|
}
|
|
|
|
# Schedule - Called after bot is set up, to set up any scheduled tasks
|
|
# use $self->schedule($event, $delay, $times, $data)
|
|
# where $times is 1 for a single event, -1 for recurring events,
|
|
# and a +ve number for an event that occurs that many times.
|
|
sub Schedule {
|
|
my $self = shift;
|
|
my ($event) = @_;
|
|
}
|
|
|
|
# JoinedIRC - Called before joining any channels (but after module is setup)
|
|
# this does not get called for dynamically loaded modules
|
|
sub JoinedIRC {
|
|
my $self = shift;
|
|
my ($event) = @_;
|
|
}
|
|
|
|
sub JoinedChannel {
|
|
my $self = shift;
|
|
my ($event, $channel) = @_;
|
|
if ($self->{'autojoin'}) {
|
|
push(@{$self->{'channels'}}, $channel) unless ((scalar(grep $_ eq $channel, @{$self->{'channels'}})) or
|
|
(scalar(grep $_ eq $channel, @{$self->{'channelsBlocked'}})));
|
|
$self->saveConfig();
|
|
}
|
|
}
|
|
|
|
sub PartedChannel {
|
|
my $self = shift;
|
|
my ($event, $channel) = @_;
|
|
if ($self->{'autojoin'}) {
|
|
my %channels = map { $_ => 1 } @{$self->{'channels'}};
|
|
if ($channels{$channel}) {
|
|
delete($channels{$channel});
|
|
@{$self->{'channels'}} = keys %channels;
|
|
$self->saveConfig();
|
|
}
|
|
}
|
|
}
|
|
|
|
sub InChannel {
|
|
my $self = shift;
|
|
my ($event) = @_;
|
|
return scalar(grep $_ eq $event->{'channel'}, @{$self->{'channels'}});
|
|
# XXX could be optimised - cache the list into a hash.
|
|
}
|
|
|
|
sub IsBanned {
|
|
my $self = shift;
|
|
my ($event) = @_;
|
|
return 0 if scalar(grep { $_ = $self->sanitizeRegexp($_); $event->{'user'} =~ /^$_$/ } @{$self->{'allowusers'}});
|
|
return scalar(grep { $_ = $self->sanitizeRegexp($_); $event->{'user'} =~ /^$_$/ } @{$self->{'denyusers'}});
|
|
}
|
|
|
|
# Baffled - Called for messages prefixed by the bot's nick which we don't understand
|
|
sub Baffled {
|
|
my $self = shift;
|
|
my ($event, $message) = @_;
|
|
return 1;
|
|
}
|
|
|
|
# Told - Called for messages prefixed by the bot's nick
|
|
sub Told {
|
|
my $self = shift;
|
|
my ($event, $message) = @_;
|
|
return 1;
|
|
}
|
|
|
|
# Heard - Called for all messages
|
|
sub Heard {
|
|
my $self = shift;
|
|
my ($event, $message) = @_;
|
|
return 1;
|
|
}
|
|
|
|
# Felt - Called for all emotes containing bot's nick
|
|
sub Felt {
|
|
my $self = shift;
|
|
my ($event, $message) = @_;
|
|
return 1;
|
|
}
|
|
|
|
# -- #mozilla was here --
|
|
# * bryner tries to imagine the need for NS_TWIPS_TO_MILES
|
|
#<Ben_Goodger> bryner: yeah, that isn't even a metric unit. should
|
|
# be NS_TWIPS_TO_KILOMETERS
|
|
# <bryner> there's that too
|
|
#<Ben_Goodger> oh
|
|
#<Ben_Goodger> really?
|
|
# <bryner> yep
|
|
#<Ben_Goodger> o_O
|
|
# <bryner> for when we use mozilla for surveying and such
|
|
# <pinkerton> lol
|
|
|
|
# BTW. They aren't kidding. See:
|
|
# http://lxr.mozilla.org/seamonkey/search?string=NS_TWIPS_TO_KILOMETERS
|
|
|
|
# Saw - Called for all emotes
|
|
sub Saw {
|
|
my $self = shift;
|
|
my ($event, $message) = @_;
|
|
return 1;
|
|
}
|
|
|
|
# Invited - Called when bot is invited into another channel
|
|
sub Invited {
|
|
my $self = shift;
|
|
my ($event, $channel) = @_;
|
|
return 1;
|
|
}
|
|
|
|
# Kicked - Called when bot is kicked out of a channel
|
|
sub Kicked {
|
|
my $self = shift;
|
|
my ($event, $channel) = @_;
|
|
return 1;
|
|
}
|
|
|
|
# ModeChange - Called when channel or bot has a mode flag changed
|
|
sub ModeChange {
|
|
my $self = shift;
|
|
my ($event, $what, $change, $who) = @_;
|
|
return 1;
|
|
}
|
|
|
|
# GotOpped - Called when bot is opped
|
|
sub GotOpped {
|
|
my $self = shift;
|
|
my ($event, $channel, $who) = @_;
|
|
return 1;
|
|
}
|
|
|
|
# GotDeopped - Called when bot is deopped
|
|
sub GotDeopped {
|
|
my $self = shift;
|
|
my ($event, $channel, $who) = @_;
|
|
return 1;
|
|
}
|
|
|
|
# SpottedNickChange - Called when someone changes their nick
|
|
# Remember that you cannot use directSay here, since $event
|
|
# has the details of the old nick. And 'say' is useless
|
|
# since the channel is the old userhost string... XXX
|
|
sub SpottedNickChange {
|
|
my $self = shift;
|
|
my ($event, $from, $to) = @_;
|
|
return 1;
|
|
}
|
|
|
|
# Authed - Called when someone authenticates with us.
|
|
# Remember that you cannot use say here, since this
|
|
# cannot actually be done in a channel...
|
|
sub Authed {
|
|
my $self = shift;
|
|
my ($event, $who) = @_;
|
|
return 1;
|
|
}
|
|
|
|
# SpottedTopicChange - Called when someone thinks someone else said something funny
|
|
sub SpottedTopicChange {
|
|
my $self = shift;
|
|
my ($event, $channel, $new) = @_;
|
|
return 1;
|
|
}
|
|
|
|
# SpottedJoin - Called when someone joins a channel
|
|
sub SpottedJoin {
|
|
my $self = shift;
|
|
my ($event, $channel, $who) = @_;
|
|
return 1;
|
|
}
|
|
|
|
# SpottedPart - Called when someone leaves a channel
|
|
sub SpottedPart {
|
|
my $self = shift;
|
|
my ($event, $channel, $who) = @_;
|
|
return 1;
|
|
}
|
|
|
|
# SpottedKick - Called when someone leaves a channel forcibly
|
|
sub SpottedKick {
|
|
my $self = shift;
|
|
my ($event, $channel, $who) = @_;
|
|
return 1;
|
|
}
|
|
|
|
# SpottedQuit - Called when someone leaves a server
|
|
# can't use say or directSay: no channel involved, and
|
|
# user has quit (obviously). XXX
|
|
sub SpottedQuit {
|
|
my $self = shift;
|
|
my ($event, $who, $why) = @_;
|
|
return 1;
|
|
}
|
|
|
|
# CTCPPing - Called when we receive a CTCP Ping.
|
|
sub CTCPPing {
|
|
my $self = shift;
|
|
my ($event, $who, $what) = @_;
|
|
return 1;
|
|
}
|
|
|
|
# CTCPVersion - Called when we receive a CTCP Version.
|
|
sub CTCPVersion {
|
|
my $self = shift;
|
|
my ($event, $who, $what) = @_;
|
|
return 1;
|
|
}
|
|
|
|
# CTCPSource - Called when we receive a CTCP Source.
|
|
sub CTCPSource {
|
|
my $self = shift;
|
|
my ($event, $who, $what) = @_;
|
|
return 1;
|
|
}
|
|
|
|
# SpottedOpping - Called when someone is opped
|
|
sub SpottedOpping {
|
|
my $self = shift;
|
|
my ($event, $channel, $who) = @_;
|
|
return 1;
|
|
}
|
|
|
|
# SpottedDeopping - Called when someone is... deopped, maybe?
|
|
sub SpottedDeopping {
|
|
my $self = shift;
|
|
my ($event, $channel, $who) = @_;
|
|
return 1;
|
|
}
|
|
|
|
# Scheduled - Called when a scheduled timer triggers
|
|
sub Scheduled {
|
|
my $self = shift;
|
|
my ($event, @data) = @_;
|
|
if (ref($data[0]) eq 'CODE') {
|
|
&{$data[0]}($event, @data);
|
|
} else {
|
|
$self->debug('Unhandled scheduled event... :-/');
|
|
}
|
|
}
|
|
|
|
# ChildCompleted - Called when a child process has quit
|
|
sub ChildCompleted {
|
|
my $self = shift;
|
|
my ($event, $type, $output, @data) = @_;
|
|
if ($type eq 'URI') {
|
|
my $uri = shift(@data);
|
|
$self->GotURI($event, $uri, $output, @data);
|
|
}
|
|
}
|
|
|
|
# GotURI - Called when a requested URI has been downloaded
|
|
sub GotURI {
|
|
my $self = shift;
|
|
my ($event, $uri, $contents, @data) = @_;
|
|
}
|
|
|
|
# Help - Called to fully explain the module (return hash of command/description pairs)
|
|
# the string given for the '' key should be a module description
|
|
sub Help {
|
|
my $self = shift;
|
|
my ($event) = @_;
|
|
return {};
|
|
}
|
|
|
|
# RegisterConfig - Called when initialised, should call registerVariables
|
|
sub RegisterConfig {
|
|
my $self = shift;
|
|
$self->registerVariables(
|
|
# [ name, save?, settable?, value ]
|
|
['channels', 1, 1, []],
|
|
['channelsBlocked', 1, 1, []], # the channels in which this module will not autojoin regardless
|
|
['autojoin', 1, 1, 1],
|
|
['allowusers', 1, 1, []],
|
|
['denyusers', 1, 1, []],
|
|
);
|
|
}
|
|
|
|
# Set - called to set a variable to a particular value.
|
|
sub Set {
|
|
my $self = shift;
|
|
my ($event, $variable, $value) = @_;
|
|
if ($self->{'_variables'}->{$variable}) {
|
|
if ((not defined($self->{$variable})) or (not ref($self->{$variable}))) {
|
|
$self->{$variable} = $value;
|
|
} elsif (ref($self->{$variable}) eq 'SCALAR') {
|
|
${$self->{$variable}} = $value;
|
|
} elsif (ref($self->{$variable}) eq 'ARRAY') {
|
|
if ($value =~ /^([-+])(.*)$/so) {
|
|
if ($1 eq '+') {
|
|
push(@{$self->{$variable}}, $2);
|
|
} else {
|
|
# We don't want to change the reference!!!
|
|
# Other variables might be pointing to there,
|
|
# it is *those* vars that affect the app.
|
|
my @oldvalue = @{$self->{$variable}};
|
|
@{$self->{$variable}} = ();
|
|
foreach (@oldvalue) {
|
|
push(@{$self->{$variable}}, $_) unless ($2 eq $_);
|
|
}
|
|
# XXX no feedback if nothing is done
|
|
}
|
|
} else {
|
|
return 3; # not the right format dude!
|
|
}
|
|
} elsif (ref($self->{$variable}) eq 'HASH') {
|
|
if ($value =~ /^\+(.)(.*)\1(.*)$/so) {
|
|
$self->{$variable}->{$2} = $3;
|
|
return -2 if $1 =~ /[a-zA-Z]/so;
|
|
} elsif ($value =~ /^\-(.*)$/so) {
|
|
# XXX no feedback if nothing is done
|
|
delete($self->{$variable}->{$1});
|
|
} else {
|
|
return 4; # not the right format dude!
|
|
}
|
|
} else {
|
|
return 1; # please to not be trying to set coderefs or arrayrefs or hashrefs or ...
|
|
}
|
|
} else {
|
|
return 2; # please to not be trying to set variables I not understand!
|
|
}
|
|
$self->saveConfig();
|
|
return 0;
|
|
}
|
|
|
|
# Get - called to get a particular variable
|
|
sub Get {
|
|
my $self = shift;
|
|
my ($event, $variable) = @_;
|
|
return $self->{$variable};
|
|
}
|
|
|
|
# Log - Called for every event
|
|
sub Log {
|
|
my $self = shift;
|
|
my ($event) = @_;
|
|
}
|
|
|
|
|
|
################################
|
|
# Admin Module #
|
|
################################
|
|
|
|
package BotModules::Admin;
|
|
use vars qw(@ISA);
|
|
@ISA = qw(BotModules);
|
|
1;
|
|
|
|
# Initialise - Called when the module is loaded
|
|
sub Initialise {
|
|
my $self = shift;
|
|
$self->{'_fileModifiedTimes'} = {};
|
|
$self->{'_static'} = 1;
|
|
}
|
|
|
|
# RegisterConfig - Called when initialised, should call registerVariables
|
|
sub RegisterConfig {
|
|
my $self = shift;
|
|
$self->SUPER::RegisterConfig(@_);
|
|
$self->registerVariables(
|
|
# [ name, save?, settable?, value ]
|
|
['allowInviting', 1, 1, 1], # by default, anyone can invite a bot into their channel
|
|
['allowChannelAdmin', 1, 1, 0], # by default, one cannot admin from a channel
|
|
['sourceCodeCheckDelay', 1, 1, 20], # by default, wait 20 seconds between source code checks
|
|
['files', 1, 1, [$0, 'lib/Mails.pm', 'lib/Configuration.pm', 'lib/IO/SecurePipe.pm']], # files to check for source code changes
|
|
['channels', 0, 0, undef], # remove the 'channels' internal variable...
|
|
['autojoin', 0, 0, 0], # remove the 'autojoin' internal variable...
|
|
['errorMessagesMaxLines', 1, 1, 5], # by default, only have 5 lines in error messages, trim middle if more
|
|
);
|
|
# now add in all the global variables...
|
|
foreach (keys %configStructure) {
|
|
$self->registerVariables([$configStructure{$_}[0], 0, 1, $configStructure{$_}[1]]) if (ref($configStructure{$_}[1]) =~ /^(?:SCALAR|ARRAY|HASH)$/go);
|
|
}
|
|
}
|
|
|
|
# saveConfig - make sure we also save the main config variables...
|
|
sub saveConfig {
|
|
my $self = shift;
|
|
$self->SUPER::saveConfig(@_);
|
|
&Configuration::Save($cfgfile, &::configStructure());
|
|
}
|
|
|
|
# Set - called to set a variable to a particular value.
|
|
sub Set {
|
|
my $self = shift;
|
|
my ($event, $variable, $value) = @_;
|
|
# First let's special case some magic variables...
|
|
if ($variable eq 'currentnick') {
|
|
$self->setNick($event, $value);
|
|
return -1;
|
|
} else {
|
|
return $self->SUPER::Set($event, $variable, $value);
|
|
}
|
|
}
|
|
|
|
# Get - called to get a particular variable.
|
|
sub Get {
|
|
my $self = shift;
|
|
my ($event, $variable) = @_;
|
|
# First let's special case some magic variables...
|
|
if ($variable eq 'currentnick') {
|
|
return $event->{'bot'}->nick(); # at this point, $event->{'nick'} would work too
|
|
} elsif ($variable eq 'users') {
|
|
my @users = sort keys %users;
|
|
return \@users;
|
|
} else {
|
|
# else, check for known global variables...
|
|
my $configStructure = &::configStructure();
|
|
if (defined($configStructure->{$variable})) {
|
|
return $configStructure->{$variable};
|
|
} else {
|
|
return $self->SUPER::Get($event, $variable);
|
|
}
|
|
}
|
|
}
|
|
|
|
# Schedule - called when bot connects to a server, to install any schedulers
|
|
# use $self->schedule($event, $delay, $times, $data)
|
|
# where $times is 1 for a single event, -1 for recurring events,
|
|
# and a +ve number for an event that occurs that many times.
|
|
sub Schedule {
|
|
my $self = shift;
|
|
my ($event) = @_;
|
|
$self->schedule($event, \$self->{'sourceCodeCheckDelay'}, -1, {'action'=>'source'});
|
|
$self->SUPER::Schedule($event);
|
|
}
|
|
|
|
sub InChannel {
|
|
my $self = shift;
|
|
my ($event) = @_;
|
|
return $self->{'allowChannelAdmin'};
|
|
}
|
|
|
|
sub Help {
|
|
my $self = shift;
|
|
my ($event) = @_;
|
|
if ($self->isAdmin($event)) {
|
|
return {
|
|
'' => 'The administration module is used to perform tasks that fundamentally affect the bot.',
|
|
'shutdown' => 'Shuts the bot down completely.',
|
|
'shutup' => 'Clears the output queue (you actually have to say \'shutup please\' or nothing will happen).',
|
|
'restart' => 'Shuts the bot down completely then restarts it, so that any source changes take effect.',
|
|
'cycle' => 'Makes the bot disconnect from the server then try to reconnect.',
|
|
'vars' => 'Manage variables: vars [<module> [<variable> [\'<value>\']]], say \'vars\' for more details.',
|
|
'join' => 'Makes the bot attempt to join a channel. The same effect can be achieved using /invite. Syntax: join <channel>',
|
|
'part' => 'Makes the bot leave a channel. The same effect can be achieved using /kick. Syntax: part <channel>',
|
|
'load' => 'Loads a module from disk, if it is not already loaded: load <module>',
|
|
'unload' => 'Unloads a module from memory: load <module>',
|
|
'reload' => 'Unloads and then loads a module: reload <module>',
|
|
'bless' => 'Sets the \'admin\' flag on a registered user. Syntax: bless <user>',
|
|
'unbless' => 'Resets the \'admin\' flag on a registered user. Syntax: unbless <user>',
|
|
};
|
|
} else {
|
|
return {};
|
|
}
|
|
}
|
|
|
|
# Told - Called for messages prefixed by the bot's nick
|
|
sub Told {
|
|
my $self = shift;
|
|
my ($event, $message) = @_;
|
|
if ($self->isAdmin($event)) {
|
|
if ($message =~ /^\s*(?:shutdown,?\s+please)\s*[?!.]*\s*$/osi) {
|
|
$self->say($event, 'But of course. Have a nice day!');
|
|
$event->{'bot'}->quit('I was told to shutdown by '.$event->{'from'}.'. :-(');
|
|
exit(0); # prevents any other events happening...
|
|
} elsif ($message =~ /^\s*shutdown/osi) {
|
|
$self->say($event, 'If you really want me to shutdown, use the magic word.');
|
|
$self->schedule($event, 7, 1, 'i.e., please.');
|
|
} elsif ($message =~ /^\s*(?:restart,?\s+please)\s*[?!.]*\s*$/osi) {
|
|
$self->Restart($event, "I was told to restart by $event->{'from'} -- brb");
|
|
} elsif ($message =~ /^\s*restart/osi) {
|
|
$self->say($event, 'If you really want me to restart, use the magic word.');
|
|
$self->schedule($event, 7, 1, 'i.e., please.');
|
|
} elsif ($message =~ /^\s*(?:shutup,?\s+please)\s*[?!.]*\s*$/osi) {
|
|
my $lost = @msgqueue;
|
|
@msgqueue = ();
|
|
if ($lost) {
|
|
$self->say($event, "Ok, threw away $lost messages.");
|
|
} else {
|
|
$self->say($event, 'But I wasn\'t saying anything!');
|
|
}
|
|
} elsif ($message =~ /^\s*cycle(?:\s+please)?\s*[?!.]*\s*$/osi) {
|
|
$event->{'bot'}->quit('I was told to cycle by '.$event->{'from'}.'. BRB!');
|
|
&Configuration::Get($cfgfile, &::configStructure());
|
|
} elsif ($message =~ /^\s*join\s+([&#+][^\s]+)(?:\s+please)?\s*[?!.]*\s*$/osi) {
|
|
$self->Invited($event, $1);
|
|
} elsif ($message =~ /^\s*part\s+([&#+][^\s]+)(?:\s+please)?\s*[?!.]*\s*$/osi) {
|
|
$self->Kicked($event, $1);
|
|
} elsif ($message =~ /^\s*bless\s+('?)($variablepattern)\1\s*$/osi) {
|
|
if (defined($users{$2})) {
|
|
$userFlags{$2} = $userFlags{$2} || 1;
|
|
$self->saveConfig();
|
|
$self->say($event, "Ok, $2 is now an admin.");
|
|
} else {
|
|
$self->say($event, 'I don\'t know that user. Try the \'newuser\' command (see \'help newuser\' for details).');
|
|
}
|
|
} elsif ($message =~ /^\s*unbless\s+('?)($variablepattern)\1\s*$/osi) {
|
|
if (defined($users{$2})) {
|
|
$userFlags{$2} = $userFlags{$2} &~ 1;
|
|
$self->saveConfig();
|
|
$self->say($event, "Ok, $2 is now a mundane luser.");
|
|
} else {
|
|
$self->say($event, 'I don\'t know that user. Check your spelling!');
|
|
}
|
|
} elsif ($message =~ /^\s*load\s+('?)($variablepattern)\1\s*$/osi) {
|
|
$self->LoadModule($event, $2, 1);
|
|
} elsif ($message =~ /^\s*reload\s+('?)($variablepattern)\1\s*$/osi) {
|
|
$self->ReloadModule($event, $2, 1);
|
|
} elsif ($message =~ /^\s*unload\s+('?)($variablepattern)\1\s*$/osi) {
|
|
$self->UnloadModule($event, $2, 1);
|
|
} elsif ($message =~ /^\s*vars(?:\s+($variablepattern)(?:\s+($variablepattern)(?:\s+'(.*)')?)?|(.*))?\s*$/osi) {
|
|
$self->Vars($event, $1, $2, $3, $4);
|
|
} else {
|
|
return $self->SUPER::Told(@_);
|
|
}
|
|
} else {
|
|
return $self->SUPER::Told(@_);
|
|
}
|
|
return 0; # if made it here then we did it!
|
|
}
|
|
|
|
sub Scheduled {
|
|
my $self = shift;
|
|
my ($event, $type) = @_;
|
|
if ((ref($type) eq 'HASH') and ($type->{'action'} eq 'source')) {
|
|
$self->CheckSource($event);
|
|
} elsif (ref($type)) {
|
|
$self->SUPER::Scheduled(@_);
|
|
} else {
|
|
$self->directSay($event, $type);
|
|
}
|
|
}
|
|
|
|
sub CheckSource {
|
|
my $self = shift;
|
|
my ($event) = @_;
|
|
foreach my $file (@{$self->{'files'}}) {
|
|
my $lastModifiedTime = $self->{'_fileModifiedTimes'}->{$file};
|
|
my ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime, $blksize, $blocks)
|
|
= stat($file);
|
|
$self->{'_fileModifiedTimes'}->{$file} = $mtime;
|
|
if (defined($lastModifiedTime) and ($mtime > $lastModifiedTime)) {
|
|
$self->debug("Noticed that source code of $file had changed");
|
|
# compile new bot using perl -cwT XXX
|
|
if (1) { # XXX replace 1 with "did compile succeed" test
|
|
$self->Restart($event, 'someone seems to have changed my source code. brb, unless I get a compile error!');
|
|
} else {
|
|
# tellAdmin that it did not compile XXX
|
|
# debug that it did not compile
|
|
}
|
|
}
|
|
}
|
|
my @updatedModules;
|
|
foreach my $module (@modules) {
|
|
if ($module->{'_filename'}) {
|
|
my $lastModifiedTime = $module->{'_fileModificationTime'};
|
|
my ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime, $blksize, $blocks)
|
|
= stat($module->{'_filename'});
|
|
$module->{'_fileModificationTime'} = $mtime;
|
|
if (defined($lastModifiedTime) and ($mtime > $lastModifiedTime)) {
|
|
push(@updatedModules, $module->{'_name'});
|
|
}
|
|
}
|
|
}
|
|
foreach my $module (@updatedModules) {
|
|
$self->ReloadModule($event, $module, 0);
|
|
}
|
|
}
|
|
|
|
sub Restart {
|
|
my $self = shift;
|
|
my ($event, $reason) = @_;
|
|
$event->{'bot'}->quit($reason);
|
|
# Note that `exec' will not call our `END' blocks, nor will it
|
|
# call any `DESTROY' methods in our objects. So we fork a child to
|
|
# do that first.
|
|
my $parent = $$;
|
|
my $child = fork();
|
|
if (defined($child)) {
|
|
if ($child) {
|
|
# we are the parent process who is
|
|
# about to exec($0), so wait for
|
|
# child to shutdown.
|
|
$self->debug("spawned $child to handle shutdown...");
|
|
waitpid($child, 0);
|
|
} else {
|
|
# we are the child process who is
|
|
# in charge of shutting down cleanly.
|
|
$self->debug("initiating shutdown for parent process $parent...");
|
|
exit(0);
|
|
}
|
|
} else {
|
|
$self->debug("failed to fork: $!");
|
|
}
|
|
$self->debug("About to defer to a new $0 process...");
|
|
# we have done our best to shutdown, so go for it!
|
|
eval {
|
|
if ($CHROOT) {
|
|
exec { $0 } ($0, '--assume-chrooted', $cfgfile);
|
|
} else {
|
|
exec { $0 } ($0, $cfgfile);
|
|
}
|
|
# I am told (by some nice people in #perl on Efnet) that our
|
|
# memory is all cleared up for us. So don't worry that even
|
|
# though we don't call DESTROY in _this_ instance, we leave
|
|
# memory behind.
|
|
};
|
|
$self->debug("That failed!!! Bailing out to prevent all hell from breaking loose! $@ :-|");
|
|
exit(1); # we never get here unless exec fails
|
|
}
|
|
|
|
# handles the 'vars' command
|
|
sub Vars {
|
|
my $self = shift;
|
|
my ($event, $modulename, $variable, $value, $nonsense) = @_;
|
|
if (defined($modulename)) {
|
|
my $module = $self->getModule($modulename);
|
|
if (defined($module)) {
|
|
if (defined($variable)) {
|
|
if (defined($value)) {
|
|
my $result = $module->Set($event, $variable, $value);
|
|
if ((not defined($result)) or ($result == 0)) {
|
|
$self->say($event, "Variable '$variable' in module '$modulename' has changed.");
|
|
} elsif ($result == 1) {
|
|
$self->say($event, "Variable '$variable' is of type ".ref($module->{$variable}).' and I do not know how to set that kind of variable!');
|
|
} elsif ($result == 2) { # we don't know that variable!
|
|
if ($module->{$variable}) { # well we do, but only to read
|
|
$self->say($event, "Variable '$variable' in module '$modulename' is read-only, sorry.");
|
|
} else { # not known
|
|
$self->say($event, "Module '$modulename' does not have a variable '$variable' as far as I can tell.");
|
|
}
|
|
} elsif ($result == 3) {
|
|
$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>').");
|
|
} elsif ($result == 4) {
|
|
$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>').");
|
|
} elsif ($result == -1) {
|
|
# already reported success
|
|
} elsif ($result == -2) {
|
|
$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...");
|
|
} elsif ($result > 0) { # negative = success
|
|
$self->say($event, "Variable '$variable' in module '$modulename' could not be set for some reason unknown to me.");
|
|
}
|
|
} else { # else give variable's current value
|
|
$value = $module->Get($event, $variable);
|
|
if (defined($value)) {
|
|
my $type = ref($value);
|
|
if ($type eq 'SCALAR') {
|
|
$self->say($event, "Variable '$variable' in module '$modulename' is set to: '$$value'");
|
|
} elsif ($type eq 'ARRAY') {
|
|
# XXX need a 'maximum number of items' feature to prevent flooding ourselves to pieces (or is shutup please enough?)
|
|
if (@$value) {
|
|
local $" = '\', \'';
|
|
$self->say($event, "Variable '$variable' in module '$modulename' is a list with the following values: '@$value'");
|
|
} else {
|
|
$self->say($event, "Variable '$variable' in module '$modulename' is an empty list.");
|
|
}
|
|
} elsif ($type eq 'HASH') {
|
|
# XXX need a 'maximum number of items' feature to prevent flooding ourselves to pieces (or is shutup please enough?)
|
|
$self->say($event, "Variable '$variable' in module '$modulename' is a hash with the following values:");
|
|
foreach (sort keys %$value) {
|
|
$self->say($event, " '$_' => '".($value->{$_}).'\' ');
|
|
}
|
|
$self->say($event, "End of dump of variable '$variable'.");
|
|
} else {
|
|
$self->say($event, "Variable '$variable' in module '$modulename' is set to: '$value'");
|
|
}
|
|
} else { # we don't know that variable
|
|
if ($module->{'_variables'}->{$variable}) { # well we do, but only to write
|
|
$self->say($event, "Variable '$variable' in module '$modulename' is write-only, sorry.");
|
|
} else { # not known
|
|
$self->say($event, "Module '$modulename' does not have a variable '$variable' as far as I can tell.");
|
|
}
|
|
}
|
|
}
|
|
} else { # else list variables
|
|
my @variables;
|
|
# then enumerate its variables
|
|
foreach my $variable (sort keys %{$module->{'_variables'}}) {
|
|
push(@variables, $variable) if $module->{'_variables'}->{$variable};
|
|
}
|
|
# then list 'em
|
|
if (@variables) {
|
|
local $" = '\', \'';
|
|
$self->say($event, "Module '$modulename' has the following published variables: '@variables'");
|
|
} else {
|
|
$self->say($event, "Module '$modulename' has no settable variables.");
|
|
}
|
|
}
|
|
} else { # complain no module
|
|
$self->say($event, "I didn't recognise that module name ('$modulename'). Try just 'vars' on its own for help.");
|
|
}
|
|
} elsif ($nonsense) {
|
|
$self->say($event, 'I didn\'t quite understand that. Try just \'vars\' on its own for help.');
|
|
$self->say($event, 'If you are trying to set a variable, don\'t forget the quotes around the value!');
|
|
} else { # else give help
|
|
$self->say($event, 'The \'vars\' command gives you an interface to the module variables in the bot.');
|
|
$self->say($event, 'To list the variables in a module: vars <module>');
|
|
$self->say($event, 'To get the value of a variable: vars <module> <variable>');
|
|
$self->say($event, 'To set the value of a variable: vars <module> <variable> \'<value>\'');
|
|
$self->say($event, 'Note the quotes around the value. They are required. If the value contains quotes itself, that is fine.');
|
|
}
|
|
}
|
|
|
|
# This is also called when we are messaged a 'join' command
|
|
sub Invited {
|
|
my $self = shift;
|
|
my ($event, $channelName) = @_;
|
|
# $channelName is the name as requested and as should be /joined.
|
|
# This is important so that case is kept in the list of channels
|
|
# on the server should the bot join first.
|
|
my $channel = lc($channelName);
|
|
if (grep $_ eq $channel, @channels) {
|
|
$self->directSay($event, "I think I'm already *in* channel $channel! If this is not the case please make me part and then rejoin.");
|
|
} else {
|
|
if ($self->isAdmin($event) || $self->{'allowInviting'}) {
|
|
$self->debug("Joining $channel, since I was invited.");
|
|
if (defined($channelKeys{$channel})) {
|
|
$event->{'bot'}->join($channel, $channelKeys{$channel});
|
|
} else {
|
|
$event->{'bot'}->join($channel);
|
|
}
|
|
push(@channels, $channel);
|
|
&Configuration::Save($cfgfile, &::configStructure(\@channels));
|
|
$self->debug('about to autojoin modules...');
|
|
foreach (@modules) {
|
|
$_->JoinedChannel($event, $channel);
|
|
}
|
|
} else {
|
|
$self->debug($event->{'from'}." asked me to join $channel, but I refused.");
|
|
$self->directSay($event, "Please contact one of my administrators if you want me to join $channel.");
|
|
$self->tellAdmin($event, "Excuse me, but ".$event->{'from'}." asked me to join $channel. I thought you should know.");
|
|
}
|
|
}
|
|
return $self->SUPER::Invited($event, $channel);
|
|
}
|
|
|
|
# This is also called when we are /msg'ed a 'part' command
|
|
sub Kicked {
|
|
my $self = shift;
|
|
my ($event, $channel) = @_;
|
|
$channel = lc($channel);
|
|
my %channels = map { $_ => 1 } @channels;
|
|
if ($channels{$channel}) {
|
|
$self->debug("kicked from $channel by ".$event->{'from'});
|
|
$event->{'bot'}->part($channel, 'I was told to leave by '.$event->{'from'}.'. :-(');
|
|
delete($channels{$channel});
|
|
@channels = keys %channels;
|
|
&Configuration::Save($cfgfile, &::configStructure(\@channels));
|
|
$self->debug('about to autopart modules...');
|
|
foreach (@modules) {
|
|
$_->PartedChannel($event, $channel);
|
|
}
|
|
} else {
|
|
$self->directSay($event, "I'm not *in* channel $channel!");
|
|
}
|
|
return $self->SUPER::Kicked($event, $channel);
|
|
}
|
|
|
|
sub LoadModule {
|
|
my $self = shift;
|
|
my ($event, $name, $requested) = @_;
|
|
my $newmodule = &::LoadModule($name);
|
|
if (ref($newmodule)) {
|
|
# configure module
|
|
$newmodule->{'channels'} = [@channels];
|
|
&Configuration::Get($cfgfile, $newmodule->configStructure());
|
|
$newmodule->Schedule($event);
|
|
# ensure we don't add it if it is there already
|
|
push(@modulenames, $newmodule->{'_name'}) unless grep $_ eq $newmodule->{'_name'}, @modulenames;
|
|
$newmodule->saveConfig();
|
|
&Configuration::Save($cfgfile, &::configStructure(\@modulenames));
|
|
$self->debug("Successfully loaded module '$name'.");
|
|
if ($requested) {
|
|
$self->say($event, "Loaded module '$name'.");
|
|
}
|
|
} else {
|
|
if ($requested) { # it failed, $newmodule contains error message
|
|
my @errors = split(/[\n\r]/gos, $newmodule);
|
|
if (scalar(@errors) > $self->{'errorMessagesMaxLines'}) {
|
|
# remove lines from the middle if the log is too long
|
|
@errors = (@errors[0..int($self->{'errorMessagesMaxLines'} / 2)-1], '...', @errors[-(int($self->{'errorMessagesMaxLines'} / 2))..-1]);
|
|
}
|
|
local $" = "\n";
|
|
$self->say($event, "@errors");
|
|
}
|
|
$self->debug($newmodule);
|
|
}
|
|
}
|
|
|
|
sub UnloadModule {
|
|
my $self = shift;
|
|
my ($event, $name, $requested) = @_;
|
|
my $result = &::UnloadModule($name);
|
|
if ($result) { # failed
|
|
if ($requested) {
|
|
$self->say($event, $result);
|
|
} else {
|
|
$self->debug($result);
|
|
}
|
|
} else {
|
|
my @newmodulenames;
|
|
foreach (@modulenames) {
|
|
push(@newmodulenames, $_) unless ($name eq $_);
|
|
}
|
|
@modulenames = @newmodulenames;
|
|
if ($requested) {
|
|
$self->say($event, "Unloaded module '$name'.");
|
|
} else {
|
|
$self->debug("Successfully unloaded module '$name'.");
|
|
}
|
|
&Configuration::Save($cfgfile, &::configStructure(\@modulenames));
|
|
}
|
|
}
|
|
|
|
sub ReloadModule {
|
|
my $self = shift;
|
|
# XXX there used to be a memory leak around this code. It seems to be fixed
|
|
# now. However if your bot process suddenly balloons to 90M+, here would be a good
|
|
# place to start looking. Of course if that happens and you never reloaded modules
|
|
# then it is also a good time to remove this comment... ;-)
|
|
$self->UnloadModule(@_);
|
|
$self->LoadModule(@_);
|
|
}
|
|
|
|
|
|
################################
|
|
# General Module #
|
|
################################
|
|
|
|
package BotModules::General;
|
|
use vars qw(@ISA);
|
|
@ISA = qw(BotModules);
|
|
1;
|
|
|
|
# Initialise - Called when the module is loaded
|
|
sub Initialise {
|
|
my $self = shift;
|
|
$self->{'_static'} = 1;
|
|
}
|
|
|
|
# RegisterConfig - Called when initialised, should call registerVariables
|
|
sub RegisterConfig {
|
|
my $self = shift;
|
|
$self->SUPER::RegisterConfig(@_);
|
|
$self->registerVariables(
|
|
# [ name, save?, settable?, value ]
|
|
['channels', 0, 0, undef], # remove the 'channels' internal variable...
|
|
['autojoin', 0, 0, 0], # remove the 'autojoin' internal variable...
|
|
['preferredHelpLineLength', 1, 1, 70],
|
|
);
|
|
}
|
|
|
|
sub InChannel {
|
|
# my $self = shift;
|
|
# my ($event) = @_;
|
|
return 1; # always
|
|
}
|
|
|
|
# saveConfig - make sure we also save the main config variables...
|
|
sub saveConfig {
|
|
my $self = shift;
|
|
$self->SUPER::saveConfig(@_);
|
|
&Configuration::Save($cfgfile, &::configStructure(\%users, \%userFlags));
|
|
}
|
|
|
|
sub Help {
|
|
my $self = shift;
|
|
my ($event) = @_;
|
|
return {
|
|
'' => 'The module that provides the bot-wide services.',
|
|
'help' => 'Gives information about modules and commands. Syntax: help [<topic>]',
|
|
'auth' => 'Authenticate yourself: auth <username> <password>',
|
|
'password' => 'Change your password: password <oldpassword> <newpassword> <newpassword>',
|
|
'newuser' => 'Registers a new username and password (with no privileges). Syntax: newuser <username> <newpassword> <newpassword>',
|
|
};
|
|
}
|
|
|
|
# Told - Called for messages prefixed by the bot's nick
|
|
sub Told {
|
|
my $self = shift;
|
|
my ($event, $message) = @_;
|
|
if ($message =~ /^\s*help(?:\s+($variablepattern))?[ ?!.]*\s*$/osi) {
|
|
if ($1) {
|
|
# display help for that command
|
|
# first, build the help file...
|
|
my %topicList;
|
|
foreach my $module (@modules) {
|
|
my $commands = $module->Help($event);
|
|
if ($commands->{''}) {
|
|
$topicList{lc($module->{'_name'})} = [] unless defined($topicList{lc($module->{'_name'})});
|
|
push(@{$topicList{lc($module->{'_name'})}}, $commands->{''});
|
|
}
|
|
foreach (keys %$commands) {
|
|
$topicList{lc($_)} = [] unless defined($topicList{lc($_)});
|
|
push(@{$topicList{lc($_)}}, $commands->{lc($_)});
|
|
}
|
|
}
|
|
if (defined($topicList{lc($1)})) {
|
|
foreach (@{$topicList{lc($1)}}) {
|
|
$self->say($event, "$1: $_");
|
|
}
|
|
} else {
|
|
$self->say($event, "No help for topic '$1'.");
|
|
}
|
|
} else {
|
|
$self->directSay($event, "Help topics for $NAME $VERSION ($helpline):");
|
|
$self->say($event, "$event->{'from'}: help info /msg'ed") if ($event->{'channel'});
|
|
local @" = ', '; # to reset font-lock: "
|
|
my @helplist;
|
|
foreach my $module (@modules) {
|
|
my %commands = %{$module->Help($event)};
|
|
my $moduleHelp = delete($commands{''});
|
|
my @commands = sort keys %commands;
|
|
if (@commands) {
|
|
push(@helplist, "$module->{'_name'}: @commands");
|
|
} elsif ($moduleHelp) {
|
|
push(@helplist, "$module->{'_name'}");
|
|
}
|
|
}
|
|
foreach ($self->prettyPrint($self->{'preferredHelpLineLength'}, undef, ' ', '; ', @helplist)) {
|
|
$self->directSay($event, $_);
|
|
}
|
|
$self->directSay($event, 'For help on a particular topic, type \'help <topic>\'. Note that some commands may be disabled in certain channels.');
|
|
}
|
|
} elsif ($message =~ /^\s*auth\s+($variablepattern)\s+($variablepattern)\s*$/osi) {
|
|
if (not $event->{'channel'}) {
|
|
if (defined($users{$1})) {
|
|
if (&::checkPassword($2, $users{$1})) {
|
|
$authenticatedUsers{$event->{'user'}} = $1;
|
|
$self->directSay($event, "Hi $1!");
|
|
&::do($event->{'bot'}, $event->{'_event'}, 'Authed'); # hack hack hack
|
|
} else {
|
|
$self->directSay($event, "No...");
|
|
}
|
|
} else {
|
|
$self->directSay($event, "You have not been added as a user yet. Try the \'newuser\' command (see \'help newuser\' for details).");
|
|
}
|
|
}
|
|
} elsif ($message =~ /^\s*password\s+($variablepattern)\s+($variablepattern)\s+\2\s*$/osi) {
|
|
if (not $event->{'channel'}) {
|
|
if ($authenticatedUsers{$event->{'user'}}) {
|
|
if (&::checkPassword($1, $users{$authenticatedUsers{$event->{'user'}}})) {
|
|
$users{$authenticatedUsers{$event->{'user'}}} = &::newPassword($2);
|
|
$self->say($event, 'Password changed. Please reauthenticate.');
|
|
$self->saveConfig();
|
|
} else {
|
|
$self->say($event, 'That is not your current password. Please reauthenticate.');
|
|
}
|
|
delete($authenticatedUsers{$event->{'user'}});
|
|
}
|
|
}
|
|
} elsif ($message =~ /^\s*new\s*user\s+($variablepattern)\s+($variablepattern)\s+\2\s*$/osi) {
|
|
if (not $event->{'channel'}) {
|
|
if (defined($users{$1})) {
|
|
$self->say($event, 'That user already exists in my list, you can\'t add them again!');
|
|
} elsif ($1) {
|
|
$users{$1} = &::newPassword($2);
|
|
$userFlags{$1} = 0;
|
|
$self->directSay($event, "New user '$1' added with password '$2' and no rights.");
|
|
$self->saveConfig();
|
|
} else {
|
|
$self->say($event, 'That is not a valid user name.');
|
|
}
|
|
}
|
|
} else {
|
|
return $self->SUPER::Told(@_);
|
|
}
|
|
return 0; # dealt with it, do nothing else
|
|
}
|
|
|
|
|
|
# remove any (other) temporary administrators when an admin authenticates
|
|
sub Authed {
|
|
my $self = shift;
|
|
my ($event, $who) = @_;
|
|
if ($self->isAdmin($event)) {
|
|
foreach (keys %userFlags) {
|
|
if ((($userFlags{$_} & 2) == 2) and ($authenticatedUsers{$event->{'user'}} ne $_)) {
|
|
delete($userFlags{$_});
|
|
delete($users{$_});
|
|
# if they authenticated, remove the entry to prevent dangling links
|
|
foreach my $user (keys %authenticatedUsers) {
|
|
if ($authenticatedUsers{$user} eq $_) {
|
|
delete($authenticatedUsers{$user});
|
|
}
|
|
}
|
|
$self->directSay($event, "Temporary administrator '$_' removed from user list.");
|
|
$self->saveConfig();
|
|
}
|
|
}
|
|
}
|
|
return $self->SUPER::Authed(@_); # this should not stop anything else happening
|
|
}
|
|
|
|
# SpottedQuit - Called when someone leaves a server
|
|
sub SpottedQuit {
|
|
my $self = shift;
|
|
my ($event, $who, $why) = @_;
|
|
delete($authenticatedUsers{$event->{'user'}});
|
|
# XXX this doesn't deal with a user who has authenticated twice.
|
|
return $self->SUPER::SpottedQuit(@_);
|
|
}
|
|
|
|
sub CTCPVersion {
|
|
my $self = shift;
|
|
my ($event, $who, $what) = @_;
|
|
local $" = ', ';
|
|
$self->ctcpReply($event, 'VERSION', "$NAME $VERSION (@modulenames)");
|
|
}
|
|
|
|
|
|
################################
|
|
# Startup (aka main) #
|
|
################################
|
|
|
|
package main;
|
|
|
|
# -- #mozilla was here --
|
|
# <zero> is the bug with zilla hanging on startup on every
|
|
# platform fixed in today's nightlies?
|
|
# <leaf> no
|
|
# <alecf> heh
|
|
# <leaf> NEVER
|
|
# <leaf> we're shipping with it.
|
|
# <andreww> helps hide our other bugs
|
|
|
|
# Do this at the very end, so we can intersperse "my" initializations outside
|
|
# of routines above and be assured that they will run.
|
|
|
|
&debug('starting up command loop...');
|
|
|
|
END { &debug('perl is shutting down...'); }
|
|
|
|
$irc->start();
|
|
|
|
# -- #mozilla was here --
|
|
# <alecf> Maybe I'll file a bug about netcenter and that will
|
|
# get some attention
|
|
# <alecf> "Browser won't render home.netscape.com.. because it
|
|
# won't start up"
|
|
# <andreww> alecf how about "cant view banner ads - wont start up"
|
|
# <alecf> even better
|
|
# <pinkerton> all bugs are dependent on this one!
|
|
|
|
# *** Disconnected from irc.mozilla.org
|