112 Commits
Author SHA1 Message Date
Elijah Perrault 7902aba4c5 Bug fix: Fixed broken rehash. 2011-02-21 23:30:55 -07:00
Elijah Perrault f3f58c8f94 Updated. 2011-02-21 23:29:56 -07:00
Elijah Perrault c616931339 Try again. 2011-02-20 20:48:46 -07:00
Elijah Perrault 92c9a64793 Revert "Getting rid of tabs."
This reverts commit cc1c8fd5bc.
Failed.
2011-02-20 20:47:09 -07:00
Elijah Perrault cc1c8fd5bc Getting rid of tabs. 2011-02-20 20:46:10 -07:00
Elijah Perrault ad799a32a2 Ignore PRIVMSG's if they're from an invalid source. 2011-02-20 19:51:09 -07:00
Elijah Perrault 35f58bf5b7 Fixed an odd bug when viewing non-existent quotes. 2011-02-20 19:44:18 -07:00
Elijah Perrault 9ad245fc79 My bad. 2011-02-19 21:08:32 -07:00
Elijah Perrault f9cafa11e7 Fixed a small issue. 2011-02-19 21:06:18 -07:00
Elijah Perrault 6a7cf754cc Stupid Git. 2011-02-19 21:04:18 -07:00
Elijah Perrault 24ab4aaf9a Improved QDB. Also, You can now define how many results are returned by QDB SEARCH/MORE at a time with qdb_search_resnum in the config. 2011-02-19 21:02:31 -07:00
Elijah Perrault 9ff384866e Improved MORE. 2011-02-19 17:17:19 -07:00
Elijah Perrault 4eb157ad8e Filter regex characters. 2011-02-19 17:05:03 -07:00
Elijah Perrault bec120c70f Try this instead. 2011-02-19 16:59:28 -07:00
Elijah Perrault 8898e74341 Use case insensitivity. 2011-02-19 16:56:41 -07:00
Elijah Perrault 18a8752e28 Added SEARCH and MORE to QDB. 2011-02-19 16:54:21 -07:00
Elijah Perrault 27521072c5 Whoops. 2011-02-19 16:29:26 -07:00
Elijah Perrault 01cc71d564 Documentation updated. 2011-02-19 16:26:03 -07:00
Matthew Barksdale 634a68b5f2 Don't export println 2011-02-19 04:06:44 -05:00
Matthew Barksdale c330a59474 Replaced println with say 2011-02-19 04:04:04 -05:00
Matthew Barksdale be43449e74 Fixed a typo. 2011-02-19 04:02:57 -05:00
Matthew Barksdale 445b7e0db3 Revert "Replaced println with say."
This reverts commit 30d9e11f1f.
2011-02-19 04:02:16 -05:00
Matthew Barksdale 30d9e11f1f Replaced println with say. 2011-02-19 04:00:42 -05:00
Matthew Barksdale 66c4b3441a Updated. 2011-02-19 03:55:53 -05:00
Matthew Barksdale ba6f7dba40 Updated MODS - Mouse has been gone for a while, and DBI was introduced for the DB backend 2011-02-19 03:52:47 -05:00
Matthew Barksdale 5f74bb3171 Kill EMODS with fire 2011-02-19 03:49:11 -05:00
Matthew Barksdale 15f188edfb This is why you shouldn't code half asleep 2011-02-19 03:43:41 -05:00
Matthew Barksdale 6e0263bcd8 Fixed an issue with cjoin 2011-02-19 03:39:53 -05:00
Elijah Perrault 411e08fd1c Added core command MODLIST. 2011-02-18 23:49:27 -07:00
Elijah Perrault e93939d4cf Added command level 3 for logchan-only command. 2011-02-18 23:26:41 -07:00
Elijah Perrault 88d7799569 Updated for alpha5. 2011-02-18 15:13:33 -07:00
Elijah Perrault 234c8d1657 Use HTML::Entities to decode the entities in the response. 2011-02-18 15:07:46 -07:00
Elijah Perrault 11dae6b927 Added a LinkTitle module for getting the title of a web page posted in a channel. This is of little use, but meh. 2011-02-18 14:54:49 -07:00
Elijah Perrault 897ad85615 Allow alpha5 modules. 2011-02-18 14:36:19 -07:00
Elijah Perrault 96384f853a Updated. 2011-02-18 14:25:07 -07:00
Elijah Perrault c5e0853cb1 Updated for alpha4. 2011-02-17 22:40:43 -07:00
Elijah Perrault 1b853d9269 Updated. 2011-02-17 22:39:51 -07:00
Elijah Perrault ec627df22e Fix all the modules. 2011-02-17 22:33:14 -07:00
Elijah Perrault 43e6ce1aaa For the sake of my sanity during packaging, lets just do this. 2011-02-17 22:23:03 -07:00
Elijah Perrault a4ae87a86c Changed module naming scheme to appease Perl::Critic. 2011-02-17 17:41:33 -07:00
Elijah Perrault 7a9230c75a Added a Dictionary module for looking up definitions of words. 2011-02-17 15:05:54 -07:00
Elijah Perrault 9288301259 Oops, here's the changes. 2011-02-17 14:02:31 -07:00
Elijah Perrault 85ea081435 server:ajoin now supports channel keys by spacing the name and key. 2011-02-17 14:01:47 -07:00
Elijah Perrault eb3332241f Updated. 2011-02-17 13:47:57 -07:00
Elijah Perrault deb95a7ee7 Allow a hook to block an event. 2011-02-17 13:47:18 -07:00
Elijah Perrault 067da4d7ad Oops, I forgot TSYNC. *slaps self* 2011-02-16 20:44:25 -07:00
Elijah Perrault 49332e5d93 Updated. 2011-02-16 20:35:00 -07:00
Elijah Perrault 7108f3fdfa buildmod generates documentation now. 2011-02-16 20:33:07 -07:00
Elijah Perrault 8077acd9ae Oops, had this backwards. 2011-02-16 19:10:06 -07:00
Elijah Perrault 7928f77083 Updated. 2011-02-16 18:57:09 -07:00
Elijah Perrault f1b6e2f91b Support for channels with a key. 2011-02-16 18:55:47 -07:00
Elijah Perrault 3f17cb99b2 Forgot a small detail in the POD. 2011-02-16 17:46:40 -07:00
Elijah Perrault 6828aafc44 Added a ChanTopics module for advanced management of channel topics. (this thing took bloody ages to make) 2011-02-16 17:45:17 -07:00
Elijah Perrault dbe32535d4 Updated. 2011-02-16 11:38:28 -07:00
Elijah Perrault 42cb5201f6 Updated. 2011-02-15 22:59:18 -07:00
Elijah Perrault 04949f38bf Updated to use ban() 2011-02-15 22:58:36 -07:00
Elijah Perrault 7dbebdeca9 Add ban() to API::IRC. Also, bantype is now a required config value. 2011-02-15 22:58:15 -07:00
Elijah Perrault f97b55a56c Updated to obey updated API. 2011-02-15 22:29:03 -07:00
Elijah Perrault 60cdd488ba Changed arguments for on_uprivmsg and on_cprivmsg. 2011-02-15 22:22:45 -07:00
Elijah Perrault c0aa9d981c Bug fix: Commands getting Permission denied even with incorrect prefix. 2011-02-15 22:09:11 -07:00
Elijah Perrault 187de7cdef Updated the rest of the modules. 2011-02-15 22:04:09 -07:00
Elijah Perrault 42b58c73e9 Updated Calc to obey new command API. 2011-02-15 21:50:53 -07:00
Elijah Perrault 795c1da38d Ignore a NOTICE if it's from the server. 2011-02-15 21:48:51 -07:00
Elijah Perrault 5c9376524c Fixing commands... 2011-02-15 21:43:11 -07:00
Elijah Perrault c65f3afda4 Updated to obey new API. 2011-02-15 21:36:25 -07:00
Elijah Perrault c2b436f420 We now pass nicer arguments to command callbacks. 2011-02-15 21:35:32 -07:00
Elijah Perrault 853c7e087e Oops, forgot the trigger. 2011-02-15 19:24:06 -07:00
Elijah Perrault 0abc3a8236 Added event on_rehash. 2011-02-15 19:23:27 -07:00
Elijah Perrault ac389ef399 Obey updated API. 2011-02-15 19:13:46 -07:00
Elijah Perrault a831e0c4ab Bundle server with src in the on_rcjoin event. 2011-02-15 19:12:22 -07:00
Elijah Perrault e154175571 Actually, this is nicer. 2011-02-15 19:06:11 -07:00
Elijah Perrault 3c7e975c98 logchan is now joined automatically. 2011-02-15 19:03:32 -07:00
Elijah Perrault 945edfaf54 Accept JOIN with or without colon. 2011-02-15 19:00:18 -07:00
Elijah Perrault bad3169336 on_notice now sends the proper arguments. 2011-02-15 18:33:09 -07:00
Elijah Perrault 6e61841e20 Ensure that ex[3] is a valid length before continuing, creating a warning if invalid. 2011-02-15 18:23:24 -07:00
Elijah Perrault b133ef7a6f Oops. 2011-02-15 18:13:55 -07:00
Elijah Perrault 29f00aba27 Use decent regex. 2011-02-15 18:13:00 -07:00
Elijah Perrault df401193dc Clean up shutdown. 2011-02-15 14:18:48 -07:00
Elijah Perrault 55071e09d0 Created event on_shutdown. 2011-02-15 14:01:32 -07:00
Elijah Perrault 7f6cd84af8 Shutdown if there are no more IRC connections. 2011-02-15 13:58:21 -07:00
Elijah Perrault e543af08ad Put NEWS in git, for simplicity's sake. 2011-02-14 21:03:02 -07:00
Elijah Perrault 31e2c8b4f9 Added the ability to use printf(3) % variables in trans() 2011-02-14 20:55:49 -07:00
Elijah Perrault 934a10d880 Use say, not println. 2011-02-14 20:45:09 -07:00
Elijah Perrault cf45c4468a mod_init and mod_void now call slog() 2011-02-14 20:43:05 -07:00
Elijah Perrault c2e58299d7 Yes, you can slap me for this. 2011-02-14 20:41:34 -07:00
Elijah Perrault 9de515a172 Replacing println with say. 2011-02-14 19:58:56 -07:00
Elijah Perrault f274f04c3b Replacing println with say. 2011-02-14 19:56:37 -07:00
Elijah Perrault 42cd6da78c We need to replace println with say from Perl 5.10. 2011-02-14 19:29:41 -07:00
Elijah Perrault c9181cf4ce Made level 3 work. 2011-02-14 15:08:32 -07:00
Elijah Perrault a75e3ee771 Added slog() to API::Log. 2011-02-14 14:59:07 -07:00
Elijah Perrault 50a3f73a82 Store channels with case insensitivity. 2011-02-14 14:48:26 -07:00
Elijah Perrault 80004fe047 Updated. 2011-02-14 13:34:19 -07:00
Elijah Perrault 6706445dff Added a Greet module. 2011-02-14 13:33:02 -07:00
Elijah Perrault 02ce09749c Undef this when we're done. 2011-02-14 12:00:01 -07:00
Elijah Perrault 6bff5da689 Fail to load if the database format is PostgreSQL. 2011-02-14 11:55:51 -07:00
Elijah Perrault 536fc0bc48 Updated. 2011-02-14 11:52:08 -07:00
Elijah Perrault 69c9ccb917 On second thought, added PostgreSQL support. But official modules do not work with it yet. 2011-02-14 11:50:49 -07:00
Elijah Perrault 0bbf9ae5f1 Cancelling support for PostgreSQL: We need to find a decent way of doing it. Cancelling support for Oracle DB: Support for Oracle DB is unnecessary. 2011-02-14 11:47:06 -07:00
Elijah Perrault e73fe3138a Updated. 2011-02-13 21:51:36 -07:00
Elijah Perrault 20a8e8c2e4 Fixed a typo and added a commented out block for CSV, but CSV doesn't work ATM. 2011-02-13 21:45:29 -07:00
Elijah Perrault 7f4655121e These aren't needed. 2011-02-13 21:32:58 -07:00
Elijah Perrault 650ffdd39f Updated to include database block. 2011-02-13 21:30:51 -07:00
Elijah Perrault fe57f6df3e Added support for MySQL. This has the side effect of making database:format a required config value. 2011-02-13 21:25:29 -07:00
Elijah Perrault 27e242bbef Updated QDB module. 2011-02-13 21:23:12 -07:00
Elijah Perrault b43daecd97 Database upgrade script for the 'qdb' table. 2011-02-13 21:22:26 -07:00
Elijah Perrault e9cf2bda42 Fixed quotes. 2011-02-12 21:27:07 -07:00
Elijah Perrault 74b20cb9e7 For kicks with no reason. 2011-02-12 20:09:21 -07:00
Elijah Perrault 87692dd0ea Updated. 2011-02-12 18:21:15 -07:00
Elijah Perrault bd7f52d574 Moving incompatibilities to NEWS. 2011-02-12 18:07:27 -07:00
Elijah Perrault c21ed7bacb Forgot this. 2011-02-12 18:03:28 -07:00
Elijah Perrault f9d624abd0 Add release notes. 2011-02-12 16:44:59 -07:00
Elijah Perrault 3c1cb00628 Updated for 3.0.0a3 release. 2011-02-12 16:40:00 -07:00
34 changed files with 2879 additions and 1573 deletions

No files matched your search

+2 -1
View File
@@ -1,3 +1,4 @@
*.conf
auto.conf
build/*
*.swp
autodoc/*
+38
View File
@@ -0,0 +1,38 @@
8""""8
8 8 e e eeeee eeeee
8eeee8 8 8 8 8 88
88 8 8e 8 8e 8 8
88 8 88 8 88 8 8
88 8 88ee8 88 8eee8
3.0
The future of IRC bots is here! Xelhua gives to you, Auto 3.0, a new version of
the popular Auto IRC bot.
In this alpha5 release, we have added:
* LinkTitle module for returning the page title of links sent to a channel.
* Added core command MODLIST.
* Added SEARCH and MORE to QDB. Amount of results returned at a time with
qdb_search_resnum in the config.
Bug fixes:
* Fixed a bug when viewing non-existent quotes.
* SEVERE: Fixed a bug that caused rehash to fail.
Incompatibilities:
None
We thank you for choosing Auto. Please remember that he is still in early
development stages. But we hope we've piqued your interest, as Auto's upcoming
module repository will allow modules to be created by anyone and uploaded
there for everyone to use.
Auto's goal is to create an efficient, stable and highly customizable IRC bot
in Perl. To offer an alternative to other platforms.
Enjoy Auto 3.0.0 Alpha 5!
+28 -32
View File
@@ -5,53 +5,49 @@
# Written in sh because the user may not have Perl...to run Auto....
PID=bin/auto.pid
MODS="Mouse Class::Unload"
EMODS="MIME::Base64 XML::Simple"
MODS="Class::Unload DBI"
if [ "$1" = "start" ] ; then
if [ -e $PID ]; then
if [ "$2" = "force" ]; then
echo "Starting Auto. . ."
bin/auto
sleep 2
if [ ! -r $PID ]; then
echo "Possible failed startup... check Auto logs for more information."
fi
if [ -e $PID ]; then
if [ "$2" = "force" ]; then
echo "Starting Auto. . ."
bin/auto
sleep 2
if [ ! -r $PID ]; then
echo "Possible failed startup... check Auto logs for more information."
fi
else
echo "Auto appears to be running already. Run ./auto start force to start anyway."
fi
else
echo "Starting Auto. . ."
bin/auto
sleep 2
if [ ! -r $PID ]; then
echo "Possible failed startup... check Auto logs for more information"
fi
fi
else
echo "Starting Auto. . ."
bin/auto
sleep 2
if [ ! -r $PID ]; then
echo "Possible failed startup... check Auto logs for more information"
fi
fi
elif [ "$1" = "stop" ]; then
echo "Stopping Auto. . ."
kill -TERM `cat $PID`
echo "Stopping Auto. . ."
kill -TERM `cat $PID`
elif [ "$1" = "rehash" ]; then
echo "Rehashing Auto. . ."
kill -HUP `cat $PID`
echo "Rehashing Auto. . ."
kill -HUP `cat $PID`
elif [ "$1" = "status" ]; then
if [ -e $PID ]; then
echo "Status: Auto appears to be running."
else
echo "Status: Auto appears to not be running."
fi
if [ -e $PID ]; then
echo "Status: Auto appears to be running."
else
echo "Status: Auto appears to not be running."
fi
elif [ "$1" = "getmodules" ]; then
cpan -i $MODS
elif [ "$1" = "getextras" ]; then
cpan -i $EMODS
cpan -i $MODS
else
echo "Usage: auto (start|stop|rehash|status|getmodules|getextras)"
echo "Usage: auto (start|stop|rehash|status|getmodules)"
fi
# vim: set ai sw=4 ts=4:
+256 -175
View File
@@ -7,7 +7,7 @@ package Auto;
use 5.010_000;
use strict;
use warnings;
no feature qw(say state);
no feature qw(state);
use POSIX;
use locale;
use English qw(-no_match_vars);
@@ -15,7 +15,6 @@ use Sys::Hostname;
use IO::Socket;
use IO::Select;
use DBI;
use DBD::SQLite;
use Class::Unload;
use FindBin qw($Bin);
our $Bin = $Bin; ## no critic qw(NamingConventions::Capitalization Variables::ProhibitPackageVars)
@@ -24,17 +23,17 @@ BEGIN {
# Set version information.
use constant { ## no critic qw(ValuesAndExpressions::ProhibitConstantPragma)
NAME => 'Auto IRC Bot',
VER => 3,
SVER => 0,
REV => 0,
RSTAGE => 'd',
NAME => 'Auto IRC Bot',
VER => 3,
SVER => 0,
REV => 0,
RSTAGE => 'd',
GR => substr `cat $Bin/../.git/refs/heads/indev`, 0, 7
};
}
use Lib::Auto;
use API::Std qw(conf_get err);
use API::Log qw(println alog dbug);
use API::Log qw(alog dbug);
#use DB::Flatfile;
use Parser::Config;
use Parser::Lang;
@@ -47,41 +46,41 @@ local $PROGRAM_NAME = 'auto';
# Check for build files.
if (!-e "$Bin/../build/os" or !-e "$Bin/../build/perl" or !-e "$Bin/../build/time" or !-e "$Bin/../build/ver") {
println 'Missing build file(s). Please build Auto before running it.' and exit;
say 'Missing build file(s). Please build Auto before running it.' and exit;
}
# Check build OS.
open my $BFOS, '<', "$Bin/../build/os" or println 'Cannot start: Broken build.' and exit;
open my $BFOS, '<', "$Bin/../build/os" or say 'Cannot start: Broken build.' and exit;
my @BFOS = <$BFOS>;
close $BFOS or println 'Cannot start: Broken build.' and exit;
close $BFOS or say 'Cannot start: Broken build.' and exit;
if ($BFOS[0] ne $OSNAME."\n") {
println 'Cannot start: Broken build.' and exit;
say 'Cannot start: Broken build.' and exit;
}
undef @BFOS;
# Check build features.
our $ENFEAT;
open my $BFFEAT, '<', "$Bin/../build/feat" or println 'Cannot start: Broken build.' and exit;
open my $BFFEAT, '<', "$Bin/../build/feat" or say 'Cannot start: Broken build.' and exit;
my @BFFEAT = <$BFFEAT>;
close $BFFEAT or println 'Cannot start: Broken build.' and exit;
close $BFFEAT or say 'Cannot start: Broken build.' and exit;
$ENFEAT = substr $BFFEAT[0], 0, length($BFFEAT[0]) - 1;
undef @BFFEAT;
# Check build Perl version.
open my $BFPERL, '<', "$Bin/../build/perl" or println 'Cannot start: Broken build.' and exit;
open my $BFPERL, '<', "$Bin/../build/perl" or say 'Cannot start: Broken build.' and exit;
my @BFPERL = <$BFPERL>;
close $BFPERL or println 'Cannot start: Broken build.' and exit;
close $BFPERL or say 'Cannot start: Broken build.' and exit;
if ($BFPERL[0] ne $]."\n") {
println 'Cannot start: Broken build.' and exit;
say 'Cannot start: Broken build.' and exit;
}
undef @BFPERL;
# Check build Auto version.
open my $BFVER, '<', "$Bin/../build/ver" or println 'Cannot start: Broken build.' and exit;
open my $BFVER, '<', "$Bin/../build/ver" or say 'Cannot start: Broken build.' and exit;
my @BFVER = <$BFVER>;
close $BFVER or println 'Cannot start: Broken build.' and exit;
close $BFVER or say 'Cannot start: Broken build.' and exit;
if ($BFVER[0] ne VER.q{.}.SVER.q{.}.REV.RSTAGE."\n") {
println 'Cannot start: Broken build.' and exit;
say 'Cannot start: Broken build.' and exit;
}
undef @BFVER;
@@ -97,7 +96,7 @@ API::Std::event_add('on_sighup');
# Print startup message.
println <<'EOF';
say <<'EOF';
8""""8
8 8 e e eeeee eeeee
8eeee8 8 8 8 8 88
@@ -105,7 +104,7 @@ println <<'EOF';
88 8 88 8 88 8 8
88 8 88ee8 88 8eee8
EOF
println '* '.NAME.' (version '.VER.q{.}.SVER.q{.}.REV.RSTAGE.') is starting up...';
say '* '.NAME.' (version '.VER.q{.}.SVER.q{.}.REV.RSTAGE.') is starting up...';
our ($APID, %TIMERS);
@@ -113,8 +112,8 @@ our ($APID, %TIMERS);
our $DEBUG = 0;
our $NUC = 0;
if (defined $ARGV[0]) {
foreach (@ARGV) {
given ($_) {
foreach (@ARGV) {
given ($_) {
when ('-d') { $DEBUG = 1; }
when ('-nuc') { $NUC = 1; }
}
@@ -130,49 +129,122 @@ if ($ENFEAT =~ /ipv6/) { require IO::Socket::INET6; }
if ($ENFEAT =~ /ssl/) { require IO::Socket::SSL; }
# Parse configuration file.
println '* Parsing configuration file auto.conf...';
say '* Parsing configuration file auto.conf...';
our $CONF = Parser::Config->new('auto.conf') or err(1, 'Failed to parse configuration file!', 1);
our %SETTINGS = $CONF->parse or err(1, 'Failed to parse configuration file!', 1);
println ' Success';
say ' Success';
if (conf_get('die')) {
if ((conf_get('die'))[0][0] == 1) {
println '!!! You didn\'t read the whole config.';
println '!!! Insert new user then try again.';
exit;
}
if ((conf_get('die'))[0][0] == 1) {
say '!!! You didn\'t read the whole config.';
say '!!! Insert new user then try again.';
exit;
}
}
# Check for required configuration values.
my @REQCVALS = qw(locale expire_logs server fantasy_pf ratelimit);
my @REQCVALS = qw(locale expire_logs server fantasy_pf ratelimit database:format bantype);
foreach my $REQCVAL (@REQCVALS) {
if (!conf_get($REQCVAL)) {
my $err = 2;
if ($REQCVAL eq 'expire_logs') {
$err = 1;
}
err($err, "Missing required configuration value: $REQCVAL", 1);
}
if (!conf_get($REQCVAL)) {
my $err = 2;
if ($REQCVAL eq 'expire_logs') {
$err = 1;
}
err($err, "Missing required configuration value: $REQCVAL", 1);
}
}
undef @REQCVALS;
# Parse translations.
println '* Parsing translation files...';
say '* Parsing translation files...';
our $LOCALE = (conf_get('locale'))[0][0];
my @lang = split m/[_]/, $LOCALE;
Parser::Lang::parse($lang[0]) or err(2, 'Failed to parse translation files!', 1);
undef @lang;
println ' Success';
say ' Success';
# Expire old logs.
API::Log::expire_logs();
# Connect to database.
if (!-e "$Bin/../etc/auto.db") {
system "touch $Bin/../etc/auto.db";
system "chmod a+x $Bin/../etc/auto.db";
our $DB;
given (lc((conf_get('database:format'))[0][0])) {
when ('sqlite') {
# SQLite.
if ($ENFEAT !~ /sqlite/) { err(2, 'Auto not built with SQLite support. Aborting.', 1); }
if (!conf_get('database:filename')) { err(2, 'Missing required configuration value database:filename. Aborting.', 1); }
# Import DBD::SQLite.
require DBD::SQLite;
if (!-e "$Bin/../etc/".(conf_get('database:filename'))[0][0]) {
# Create <database:filename> if it's missing.
system "touch $Bin/../etc/".(conf_get('database:filename'))[0][0];
system "chmod a+x $Bin/../etc/".(conf_get('database:filename'))[0][0];
}
# Connect to database.
$DB = DBI->connect("dbi:SQLite:dbname=$Bin/../etc/".(conf_get('database:filename'))[0][0]) or err(2, 'Failed to connect to database!', 1);
}
when ('mysql') {
# MySQL.
if ($ENFEAT !~ /mysql/) { err(2, 'Auto not built with MySQL support. Aborting.', 1); }
my @reqcval = qw(database:host database:name database:username database:password);
foreach (@reqcval) { if (!conf_get($_)) { err(2, "Missing required configuration value $_. Aborting.", 1); } }
undef @reqcval;
# Import DBD::mysql.
require DBD::mysql;
# Connect to database.
if (conf_get('database:port')) {
# If we were given a port, connect with it.
$DB = DBI->connect('DBI:mysql:database='.(conf_get('database:name'))[0][0].';host='.(conf_get('database:host'))[0][0].';port='.(conf_get('database:port'))[0][0],
(conf_get('database:username'))[0][0], (conf_get('database:password'))[0][0]) or err(2, 'Failed to connect to database!', 1);;
}
else {
# If not, connect without specifying a port.
$DB = DBI->connect('DBI:mysql:database='.(conf_get('database:name'))[0][0].';host='.(conf_get('database:host'))[0][0],
(conf_get('database:username'))[0][0], (conf_get('database:password'))[0][0]) or err(2, 'Failed to connect to database!', 1);;
}
}
# CSV no work. :(
#when ('csv') {
# # CSV.
# if ($ENFEAT !~ /csv/) { err(2, 'Auto not built with CSV support.', 1); }
# if (!conf_get('database:dir')) { err(2, 'Missing required configuration value database:dir. Aborting.', 1); }
#
# # Import DBD::CSV.
# require DBD::CSV;
#
# # Connect to database.
# $DB = DBI->connect("dbi:CSV:f_dir=$Bin/../etc/".(conf_get('database:dir'))[0][0]) or err(2, 'Failed to connect to database!', 1);
#}
when ('pgsql') {
# PostgreSQL.
if ($ENFEAT !~ /pgsql/) { err(2, 'Auto not built with PostgreSQL support. Aborting.', 1); }
my @reqcval = qw(database:name database:host database:username database:password);
foreach (@reqcval) { if (!conf_get($_)) { err(2, "Missing required configuration value $_. Aborting.", 1); } }
undef @reqcval;
# Import DBD::Pg.
require DBD::Pg;
# Connect to database.
if (conf_get('database:port')) {
# If a specific port was given, use it.
$DB = DBI->connect('dbi:Pg:db='.(conf_get('database:name'))[0][0].';host='.(conf_get('database:host'))[0][0].';port='.(conf_get('database:port'))[0][0],
(conf_get('database:username'))[0][0], (conf_get('database:password'))[0][0]) or err(2, 'Failed to connect to database!', 1);
}
else {
# We were not given a port, connect using PGPORT (usually 5432)
$DB = DBI->connect('dbi:Pg:db='.(conf_get('database:name'))[0][0].';host='.(conf_get('database:host'))[0][0],
(conf_get('database:username'))[0][0], (conf_get('database:password'))[0][0]) or err(2, 'Failed to connect to database!', 1);
}
}
# Unknown database format.
default { err(2, 'Unknown database format \''.lc((conf_get('database:format'))[0][0]).'\'. Aborting.', 1); }
}
our $DB = DBI->connect("dbi:SQLite:dbname=$Bin/../etc/auto.db", q{}, q{});
# Ratelimit timer.
Core::IRC::clear_usercmd_timer();
@@ -181,59 +253,59 @@ Core::IRC::clear_usercmd_timer();
our (%PRIVILEGES);
# If there are any privsets.
if (conf_get('privset')) {
# Get them.
my %tcprivs = conf_get('privset');
# Get them.
my %tcprivs = conf_get('privset');
foreach my $tckpriv (keys %tcprivs) {
# For each privset, get the inner values.
my %mcprivs = conf_get("privset:$tckpriv");
# For each privset, get the inner values.
my %mcprivs = conf_get("privset:$tckpriv");
# Iterate through them.
foreach my $mckpriv (keys %mcprivs) {
# Switch statement for the values.
given ($mckpriv) {
# If it's 'priv', save it as a privilege.
when ('priv') {
if (defined $PRIVILEGES{$tckpriv}) {
# If this privset exists, push to it.
push @{ $PRIVILEGES{$tckpriv} }, ($mcprivs{$mckpriv})[0][0];
}
else {
# Otherwise, create it.
@{ $PRIVILEGES{$tckpriv} } = (($mcprivs{$mckpriv})[0][0]);
}
}
# If it's 'inherit', inherit the privileges of another privset.
when ('inherit') {
# If the privset we're inheriting exists, continue.
if (defined $PRIVILEGES{($mcprivs{$mckpriv})[0][0]}) {
# Iterate through each privilege.
foreach (@{ $PRIVILEGES{($mcprivs{$mckpriv})[0][0]} }) {
# And save them to the privset inheriting them
if (defined $PRIVILEGES{$tckpriv}) {
# If this privset exists, push to it.
push @{ $PRIVILEGES{$tckpriv} }, $_;
}
else {
# Otherwise, create it.
@{ $PRIVILEGES{$tckpriv} } = ($_);
}
}
}
}
}
}
}
foreach my $mckpriv (keys %mcprivs) {
# Switch statement for the values.
given ($mckpriv) {
# If it's 'priv', save it as a privilege.
when ('priv') {
if (defined $PRIVILEGES{$tckpriv}) {
# If this privset exists, push to it.
push @{ $PRIVILEGES{$tckpriv} }, ($mcprivs{$mckpriv})[0][0];
}
else {
# Otherwise, create it.
@{ $PRIVILEGES{$tckpriv} } = (($mcprivs{$mckpriv})[0][0]);
}
}
# If it's 'inherit', inherit the privileges of another privset.
when ('inherit') {
# If the privset we're inheriting exists, continue.
if (defined $PRIVILEGES{($mcprivs{$mckpriv})[0][0]}) {
# Iterate through each privilege.
foreach (@{ $PRIVILEGES{($mcprivs{$mckpriv})[0][0]} }) {
# And save them to the privset inheriting them
if (defined $PRIVILEGES{$tckpriv}) {
# If this privset exists, push to it.
push @{ $PRIVILEGES{$tckpriv} }, $_;
}
else {
# Otherwise, create it.
@{ $PRIVILEGES{$tckpriv} } = ($_);
}
}
}
}
}
}
}
}
# Successful startup.
our $STARTTIME = time;
println '* Auto successfully started at '.POSIX::strftime('%Y-%m-%d %I:%M:%S %p', localtime).q{.};
say '* Auto successfully started at '.POSIX::strftime('%Y-%m-%d %I:%M:%S %p', localtime).q{.};
alog 'Auto successfully started.';
# Fork into the background if not in debug mode.
if (!$DEBUG) {
println '*** Becoming a daemon...';
say '*** Becoming a daemon...';
open STDIN, '<', '/dev/null' or err(2, "Can't read /dev/null: $ERRNO", 1);
open STDOUT, '>>', '/dev/null' or err(2, "Can't write to /dev/null: $ERRNO", 1);
open STDERR, '>>', '/dev/null' or err(2, "Can't write to /dev/null: $ERRNO", 1);
@@ -241,11 +313,11 @@ if (!$DEBUG) {
if ($APID != 0) {
alog '* Successfully forked into the background. Process ID: '.$APID;
if (!-e "$Bin/auto.pid") {
system "touch $Bin/auto.pid";
}
open my $FPID, '>', "$Bin/auto.pid" or exit;
print {$FPID} "$APID\n" or exit;
close $FPID or exit;
system "touch $Bin/auto.pid";
}
open my $FPID, '>', "$Bin/auto.pid" or exit;
print {$FPID} "$APID\n" or exit;
close $FPID or exit;
exit;
}
POSIX::setsid() or err(2, "Can't start a new session: $ERRNO", 1);
@@ -259,11 +331,11 @@ API::Std::event_add('on_preconnect');
# Load modules.
if (conf_get('module')) {
alog '* Loading modules...';
dbug '* Loading modules...';
foreach (@{ (conf_get('module'))[0] }) {
mod_load($_);
}
alog '* Loading modules...';
dbug '* Loading modules...';
foreach (@{ (conf_get('module'))[0] }) {
mod_load($_);
}
}
## Create sockets.
@@ -279,13 +351,13 @@ my $it = 0;
foreach my $cskey (keys %cservers) {
# Prepare socket data.
my %conndata = (
Proto => 'tcp',
LocalAddr => $cservers{$cskey}{'bind'}[0],
PeerAddr => $cservers{$cskey}{'host'}[0],
PeerPort => $cservers{$cskey}{'port'}[0],
Proto => 'tcp',
LocalAddr => $cservers{$cskey}{'bind'}[0],
PeerAddr => $cservers{$cskey}{'host'}[0],
PeerPort => $cservers{$cskey}{'port'}[0],
Timeout => 20,
);
# Set IPv6/SSL data.
# Set IPv6/SSL data.
my $use6 = 0;
my $usessl = 0;
if (defined $cservers{$cskey}{'ipv6'}[0]) { $use6 = $cservers{$cskey}{'ipv6'}[0]; }
@@ -311,50 +383,50 @@ foreach my $cskey (keys %cservers) {
# Create the socket.
if ($use6) {
$SOCKET{$cskey} = IO::Socket::INET6->new(%conndata) or # Or error.
$SOCKET{$cskey} = IO::Socket::INET6->new(%conndata) or # Or error.
err(2, 'Failed to connect to server ('.$ERRNO.'): '.$cskey.' ['.$cservers{$cskey}{'host'}[0].q{:}.$cservers{$cskey}{'port'}[0].']', 0)
and delete $SOCKET{$cskey} and next;
}
else {
if ($usessl) {
$SOCKET{$cskey} = IO::Socket::SSL->new(%conndata) or # Or error.
$SOCKET{$cskey} = IO::Socket::SSL->new(%conndata) or # Or error.
err(2, 'Failed to connect to server ('.$ERRNO.'): '.$cskey.' ['.$cservers{$cskey}{'host'}[0].q{:}.$cservers{$cskey}{'port'}[0].']', 0)
and delete $SOCKET{$cskey} and next;
}
else {
$SOCKET{$cskey} = IO::Socket::INET->new(%conndata) or # Or error.
$SOCKET{$cskey} = IO::Socket::INET->new(%conndata) or # Or error.
err(2, 'Failed to connect to server ('.$ERRNO.'): '.$cskey.' ['.$cservers{$cskey}{'host'}[0].q{:}.$cservers{$cskey}{'port'}[0].']', 0)
and delete $SOCKET{$cskey} and next;
}
}
# Send PASS if we have one.
if (defined $cservers{$cskey}{'pass'}[0]) {
socksnd($cskey, 'PASS :'.$cservers{$cskey}{'pass'}[0]) or
err(2, 'Failed to connect to server: '.$cskey.' ['.$cservers{$cskey}{'host'}[0].q{:}.$cservers{$cskey}{'port'}[0].']', 0)
and next;
}
API::Std::event_run('on_preconnect', $cskey);
# Send NICK/USER.
API::IRC::nick($cskey, $cservers{$cskey}{'nick'}[0]);
socksnd($cskey, 'USER '.$cservers{$cskey}{'ident'}[0].q{ }.hostname.q{ }.$cservers{$cskey}{'host'}[0].' :'.$cservers{$cskey}{'realname'}[0]) or
err(2, 'Failed to connect to server: '.$cskey.' ['.$cservers{$cskey}{'host'}[0].q{:}.$cservers{$cskey}{'port'}[0].']', 0)
and next;
# Add to select.
$SELECT->add($SOCKET{$cskey});
# Success!
alog '** Successfully connected to server: '.$cskey;
dbug '** Successfully connected to server: '.$cskey;
$it = 1;
if (defined $cservers{$cskey}{'pass'}[0]) {
socksnd($cskey, 'PASS :'.$cservers{$cskey}{'pass'}[0]) or
err(2, 'Failed to connect to server: '.$cskey.' ['.$cservers{$cskey}{'host'}[0].q{:}.$cservers{$cskey}{'port'}[0].']', 0)
and next;
}
API::Std::event_run('on_preconnect', $cskey);
# Send NICK/USER.
API::IRC::nick($cskey, $cservers{$cskey}{'nick'}[0]);
socksnd($cskey, 'USER '.$cservers{$cskey}{'ident'}[0].q{ }.hostname.q{ }.$cservers{$cskey}{'host'}[0].' :'.$cservers{$cskey}{'realname'}[0]) or
err(2, 'Failed to connect to server: '.$cskey.' ['.$cservers{$cskey}{'host'}[0].q{:}.$cservers{$cskey}{'port'}[0].']', 0)
and next;
# Add to select.
$SELECT->add($SOCKET{$cskey});
# Success!
alog '** Successfully connected to server: '.$cskey;
dbug '** Successfully connected to server: '.$cskey;
$it = 1;
}
# Success!
if ($it) {
alog '** Success: Connected to server(s).';
dbug '** Success: Connected to server(s).';
alog '** Success: Connected to server(s).';
dbug '** Success: Connected to server(s).';
}
else {
err(2, 'No server connections.', 1);
err(2, 'No server connections.', 1);
}
undef $it;
@@ -362,6 +434,7 @@ undef $it;
API::Std::cmd_add('MODLOAD', 1, 'cfunc.modules', \%Core::Cmd::HELP_MODLOAD, \&Core::Cmd::cmd_modload);
API::Std::cmd_add('MODUNLOAD', 1, 'cfunc.modules', \%Core::Cmd::HELP_MODUNLOAD, \&Core::Cmd::cmd_modunload);
API::Std::cmd_add('MODRELOAD', 1, 'cfunc.modules', \%Core::Cmd::HELP_MODRELOAD, \&Core::Cmd::cmd_modreload);
API::Std::cmd_add('MODLIST', 1, 'cfunc.modules', \%Core::Cmd::HELP_MODLIST, \&Core::Cmd::cmd_modlist);
API::Std::cmd_add('SHUTDOWN', 2, 'cmd.shutdown', \%Core::Cmd::HELP_SHUTDOWN, \&Core::Cmd::cmd_shutdown);
API::Std::cmd_add('RESTART', 2, 'cmd.restart', \%Core::Cmd::HELP_RESTART, \&Core::Cmd::cmd_restart);
API::Std::cmd_add('REHASH', 2, 'cmd.rehash', \%Core::Cmd::HELP_REHASH, \&Core::Cmd::cmd_rehash);
@@ -369,58 +442,66 @@ API::Std::cmd_add('HELP', 2, 0, \%Core::Cmd::HELP_HELP, \&Core::Cmd::cmd_help);
# Infinite while loop.
while (1) {
# Timer check.
foreach my $tk (keys %TIMERS) {
if ($TIMERS{$tk}{time} <= time) {
&{ $TIMERS{$tk}{sub} }();
if ($TIMERS{$tk}{type} == 1) {
# If it's type 1, delete from memory.
delete $TIMERS{$tk};
}
elsif ($TIMERS{$tk}{type} == 2) {
# If it's type 2, reset timer.
$TIMERS{$tk}{time} = time + $TIMERS{$tk}{secs};
}
else {
# This should never happen.
delete $TIMERS{$tk};
}
}
}
# Socket check.
foreach my $sock ($SELECT->can_read(1)) {
# Figure out what network is sending us data.
my $sockid;
foreach (keys %SOCKET) {
if ($SOCKET{$_} eq $sock) { $sockid = $_; }
}
# Read the data.
my $idata;
sysread $sock, $idata, POSIX::BUFSIZ, 0;
# Timer check.
foreach my $tk (keys %TIMERS) {
if ($TIMERS{$tk}{time} <= time) {
&{ $TIMERS{$tk}{sub} }();
if ($TIMERS{$tk}{type} == 1) {
# If it's type 1, delete from memory.
delete $TIMERS{$tk};
}
elsif ($TIMERS{$tk}{type} == 2) {
# If it's type 2, reset timer.
$TIMERS{$tk}{time} = time + $TIMERS{$tk}{secs};
}
else {
# This should never happen.
delete $TIMERS{$tk};
}
}
}
# Socket check.
foreach my $sock ($SELECT->can_read(1)) {
# Figure out what network is sending us data.
my $sockid;
foreach (keys %SOCKET) {
if ($SOCKET{$_} eq $sock) { $sockid = $_; }
}
# Read the data.
my $idata;
sysread $sock, $idata, POSIX::BUFSIZ, 0;
# Check for the data.
if (!defined $idata || length($idata) == 0) {
# Got EOF, close socket
err(2, "Lost connection to $sockid!", 0);
$SELECT->remove($sock);
# Check for the data.
if (!defined $idata || length($idata) == 0) {
# Got EOF, close socket
err(2, "Lost connection to $sockid!", 0);
$SELECT->remove($sock);
delete $SOCKET{$sockid};
if (!keys %SOCKET) {
# No more connections, stop the program.
API::Std::event_run('on_shutdown');
dbug '* No more IRC connections, shutting down.';
alog '* No more IRC connections, shutting down.';
sleep 1;
exit;
}
next;
}
}
# Read the buffer.
my $data .= $idata;
while ($data =~ s/(.*\n)//) {
my $line = $1;
my $data .= $idata;
while ($data =~ s/(.*\n)//) {
my $line = $1;
# Remove the newlines.
chomp $line;
# Debug.
dbug $sockid.' >> '.$line;
chomp $line;
# Debug.
dbug $sockid.' >> '.$line;
# Parse data.
Parser::IRC::ircparse($sockid, $line);
}
}
Parser::IRC::ircparse($sockid, $line);
}
}
}
###############
@@ -430,16 +511,16 @@ while (1) {
# Send data to socket.
sub socksnd
{
my ($svr, $data) = @_;
my ($svr, $data) = @_;
if (defined $SOCKET{$svr}) {
syswrite $SOCKET{$svr}, $data."\n", POSIX::BUFSIZ, 0;
dbug "$svr << $data";
return 1;
}
else {
return 0;
}
syswrite $SOCKET{$svr}, $data."\n", POSIX::BUFSIZ, 0;
dbug "$svr << $data";
return 1;
}
else {
return 0;
}
}
# Load a module.
+40 -1
View File
@@ -8,6 +8,8 @@ use strict;
use warnings;
use English qw(-no_match_vars);
use FindBin qw($Bin);
use Pod::Html;
use Pod::Man;
our $Bin = $Bin;
our $VERSION = 1.00;
@@ -103,12 +105,49 @@ foreach (@pars) {
print 'Checking Perl version..... '.$PERL_VERSION.' - ';
if ($] < $val) { $die = 1; }
say (($die) ? 'Not OK' : 'OK');
print $RS;
if ($die) { say 'Failed to build '.$module.'.'; exit; }
}
}
}
# Generate documentation.
my $got_end = 0;
open my $FMPH, '<', $modulep;
my @MPBUF = <$FMPH>;
close $FMPH;
say 'Generating documentation.....';
my $podbuf;
foreach my $line (@MPBUF) {
if (!defined $line) { $line = ' '; }
$line =~ s/(\r|\n)//g;
if ($line eq '__END__') {
$got_end = 1;
}
if ($got_end and $line ne '__END__') {
$podbuf .= $line."\n";
}
}
# Create the autodoc/ dir if it doesn't exist.
if (!-d "$Bin/../autodoc") {
mkdir "$Bin/../autodoc";
}
# Save to POD file in autodoc/
open my $FMPNH, '>', "$Bin/../autodoc/$module.pod";
print {$FMPNH} $podbuf;
close $FMPNH;
# Create HTML.
pod2html("--infile=$Bin/../autodoc/$module.pod", "--outfile=$Bin/../autodoc/$module.html");
# Create *roff.
my $manifier = Pod::Man->new();
$manifier->parse_from_file("$Bin/../autodoc/$module.pod", "$Bin/../autodoc/$module.1");
print $RS;
say 'Done.';
# vim: set ai sw=4 ts=4:
+44
View File
@@ -2,6 +2,50 @@ Auto IRC Bot 3.0: Change Log
-------------------------------------------------------------------------------
3.0 Indev
===============================================================================
* Bug fix: Fixed broken rehash.
* Ignore PRIVMSG's if they're from an invalid source.
* Fixed an odd bug when viewing non-existent quotes.
* You can now define how many results are returned by QDB SEARCH/MORE at a
time with qdb_search_resnum in the config.
* Added SEARCH and MORE to QDB.
* Killed EMODS in the starter script and updated MODS
* Added core command MODLIST.
* Added command level 3 for logchan-only command.
* Added a LinkTitle module for getting the title of a web page posted in a
channel.
3.0 Alpha 4
===============================================================================
* Added a Dictionary module for looking up definitions of words.
* server:ajoin now supports channel keys by spacing the name and key.
* Hooks can now block events by returning -1.
* bin/buildmod now retrieves the POD from modules and creates man(1) page
plus HTML file.
* cjoin() now supports a channel key as the last argument.
* Added a ChanTopics module for advanced management of channel topics.
* bantype is now a required configuration value.
* Added ban() to API::IRC.
* Changed on_cprivmsg arguments to: \%src, $channel, @msg
* Changed on_uprivmsg arguments to: \%src, @msg
* Bug fix: Commands getting Permission denied even with incorrect prefix.
* Changed command callback arguments to: \%src, @args
* Bundle server with \%src in the on_rcjoin event.
* logchan is now joined automatically.
* Changed on_notice arguments to: \%src, $target, @msg
* Clean up shutdown.
* Created event on_shutdown.
* Shutdown if there are no more IRC connections.
* Added the ability to use printf(3) % variables in trans().
* Added slog() to API::Log for logging to IRC.
* Added a Greet module for greeting users on join.
* Added PostgreSQL support. Official modules do not support this yet.
* database:format now a required configuration value.
* Added support for MySQL. ./install --with-mysql
* Added a database upgrade script for upgrading the `qdb` table in 3.0.0a3
to the new format used by 3.0.0a4.
3.0 Alpha 3
===============================================================================
* Added command rate limiting.
* Added module installer to ./install.
+9 -5
View File
@@ -8,6 +8,8 @@ Legend:
? = Being questioned.
+ = Planned for Auto v3.1.
[ ] Cleanup
[ ] Replace println with Perl 5.10's say.
[X] Language
[X] Create method of translation.
@@ -21,15 +23,17 @@ Legend:
[X] Create basic modular functions
[X] Create logging functions
[X] Create command creation functions
[!] Create user permissions (levels)
[!] IRC
[X] Create IRC parser
[!] DB
[X] Create Auto-Flatfile database format
[X] Implement Auto-Flatfile as the main format
[ ] Add MySQL support
[O] Create Auto-Flatfile database format
[O] Implement Auto-Flatfile as the main format
[X] Add SQLite support as default
[x] Add MySQL support
[X] Add PostgreSQL support
[O] Add Oracle DB support
[O] Sys
[ ] Create system file for UNIX (or: Linux, BSD, etc.)
@@ -42,7 +46,7 @@ Legend:
[ ] Google Search module
[ ] IRC Relay module
[ ] (Google?) News module
[ ] QDB module
[X] QDB module
[ ] Tumblr module
[X] Google Calculator module
[ ] YouTube Search module
+28
View File
@@ -86,10 +86,30 @@ user "#bot-ops" {
privs "op";
}
# Database.
database {
# Format. This can be one of the following:
# sqlite Requires database:filename. Recommended.
# mysql Requires database:name,host,username,password and that Auto be built with --with-mysql. Optional: database:port
# pgsql Requires database:name,host,username,password and that Auto be built with --with-pgsql. Optional: database:port
format "sqlite";
# If you chose SQLite, uncomment this and choose a filename.
# filename "somebot.db";
# If you chose MySQL or PostgreSQL, uncomment these and set them.
# name "auto";
# host "localhost";
# username "root";
# password "moocows";
}
# Locale.
locale "en_US";
# Logging to IRC. Uncomment this and set it to setup an IRC logchan.
# logchan "Freenode/#logchan";
# Expire logs in days. 0 disables.
expire_logs 15;
@@ -103,6 +123,14 @@ ratelimit_time 6;
# How many commands can be used by a user in each period.
ratelimit_amount 3;
# Type of ban.
# 1 - *!*@h
# 2 - n!*@*
# 3 - *!u@h
# 4 - n!*u@h
# 5 - *!*@*.h+
bantype 1;
# Module autoload.
module "HelloChan";
+44 -36
View File
@@ -17,30 +17,36 @@ our $VERSION = 1.00;
our $ERROR = 0;
# Iterate through the arguments passed to us.
my $features = "base ssl";
my $features = 'base ssl sqlite';
if (defined $ARGV[0]) {
foreach (@ARGV) {
if ($_ eq "-h" or $_ eq "--help") {
println "*** ./install help ***";
println " --enable-sasl - Enable support for SASL.";
println " --enable-ipv6 - Enable support for IPv6.";
println " --disable-ssl - Disable support for SSL.";
println "*** End of Help ***";
exit;
}
elsif ($_ eq "--enable-sasl") {
$features .= " sasl";
}
elsif ($_ eq "--disable-ssl") {
foreach (@ARGV) {
if ($_ eq '-h' or $_ eq '--help') {
println '*** ./install help ***';
println ' --enable-sasl - Enable support for SASL.';
println ' --enable-ipv6 - Enable support for IPv6.';
println ' --disable-ssl - Disable support for SSL.';
println '*** End of Help ***';
exit 1;
}
elsif ($_ eq '--enable-sasl') {
$features .= ' sasl';
}
elsif ($_ eq '--disable-ssl') {
$features =~ s/ ssl//g;
}
elsif ($_ eq "--enable-ipv6") {
$features .= " ipv6";
elsif ($_ eq '--enable-ipv6') {
$features .= ' ipv6';
}
else {
println "Warning: Unknown option '".$_."'";
}
}
elsif ($_ eq '--with-mysql') {
$features =~ s/(sqlite|pgsql)/mysql/g;
}
elsif ($_ eq '--with-pgsql') {
$features =~ s/(sqlite|mysql)/pgsql/g;
}
else {
println "Warning: Unknown option '$_'";
}
}
}
# Check Perl version.
@@ -52,32 +58,32 @@ eval {
# Check operating system.
print "Checking operating system..... $OSNAME - ";
if ($OSNAME =~ /dos/i) {
print "DOS is not supported.\r\n";
print "DOS is not supported.\r\n";
}
elsif ($OSNAME eq "MSWin32") {
print "Microsoft Windows is not supported. Support is planned for the future.\r\n";
print "Microsoft Windows is not supported. Support is planned for the future.\r\n";
}
elsif ($OSNAME eq "NetWare") {
print "NetWare is not supported.\r\n";
print "NetWare is not supported.\r\n";
}
elsif ($OSNAME eq "linux") {
print "OK\n";
print "OK\n";
}
elsif ($OSNAME eq "os2") {
print "IBM OS/2 is not supported.\r\n";
print "IBM OS/2 is not supported.\r\n";
}
elsif ($OSNAME =~ /mac/i or $OSNAME =~ /darwin/i) {
print "OK\r";
print "OK\r";
}
elsif ($OSNAME eq "freebsd") {
print "OK\n";
print "OK\n";
}
elsif ($OSNAME eq "openbsd") {
print "OK\n";
print "OK\n";
}
else {
print "Unknown operating system. Contact support.\r\n";
}
print "Unknown operating system. Contact support.\r\n";
}
# Check for Perl core modules.
println "Checking for core Perl modules.....";
@@ -97,7 +103,9 @@ println 'Checking for required CPAN modules......';
println "\0";
#modfind("Mouse");
modfind('DBI');
modfind('DBD::SQLite');
modfind('DBD::SQLite') if $features =~ /sqlite/;
modfind('DBD::mysql') if $features =~ /mysql/;
modfind('DBD::Pg') if $features =~ /pgsql/;
modfind('Class::Unload');
modfind('IO::Socket::INET6') if $features =~ /ipv6/;
modfind('IO::Socket::SSL') if $features =~ /ssl/;
@@ -116,19 +124,19 @@ else {
println "\0";
println "Building.....";
if (!-d "$Bin/build") {
system "mkdir $Bin/build";
system "mkdir $Bin/build";
}
if (!-e "$Bin/build/time") {
system "touch $Bin/build/time";
system "touch $Bin/build/time";
}
if (!-e "$Bin/build/os") {
system "touch $Bin/build/os";
system "touch $Bin/build/os";
}
if (!-e "$Bin/build/perl") {
system "touch $Bin/build/perl";
system "touch $Bin/build/perl";
}
if (!-e "$Bin/build/ver") {
system "touch $Bin/build/ver";
system "touch $Bin/build/ver";
}
build($features);
+125 -91
View File
@@ -4,78 +4,112 @@
package API::IRC;
use strict;
use warnings;
use feature qw(switch);
use Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(cjoin cpart cmode umode kick privmsg notice quit nick names topic
usrc match_mask);
our @EXPORT_OK = qw(ban cjoin cpart cmode umode kick privmsg notice quit nick names
topic usrc match_mask);
# Set a ban, based on config bantype value.
sub ban
{
my ($svr, $chan, $type, $user) = @_;
my $cbt = (API::Std::conf_get('bantype'))[0][0];
# Prepare the mask we're going to ban.
my $mask;
given ($cbt) {
when (1) { $mask = '*!*@'.$user->{host}; }
when (2) { $mask = $user->{nick}.'!*@*'; }
when (3) { $mask = '*!'.$user->{user}.'@'.$user->{host}; }
when (4) { $mask = $user->{nick}.'!*'.$user->{user}.'@'.$user->{host}; }
when (5) {
my @hd = split m/[\.]/, $user->{host};
shift @hd;
$mask = '*!*@*.'.join ' ', @hd;
}
}
# Now set the ban.
if (lc $type eq 'b') {
# We were requested to set a regular ban.
cmode($svr, $chan, "+b $mask");
}
elsif (lc $type eq 'q') {
# We were requested to set a ratbox-style quiet.
cmode($svr, $chan, "+q $mask");
}
return 1;
}
# Join a channel.
sub cjoin
{
my ($svr, $chan) = @_;
Auto::socksnd($svr, "JOIN $chan");
return 1;
my ($svr, $chan, $key) = @_;
Auto::socksnd($svr, "JOIN ".((defined $key) ? "$chan $key" : "$chan"));
return 1;
}
# Part a channel.
sub cpart
{
my ($svr, $chan, $reason) = @_;
if (defined $reason) {
Auto::socksnd($svr, "PART $chan :$reason");
}
else {
Auto::socksnd($svr, "PART $chan :Leaving");
}
my ($svr, $chan, $reason) = @_;
if (defined $reason) {
Auto::socksnd($svr, "PART $chan :$reason");
}
else {
Auto::socksnd($svr, "PART $chan :Leaving");
}
if (defined $Parser::IRC::botchans{$svr}{$chan}) { delete $Parser::IRC::botchans{$svr}{$chan}; }
return 1;
return 1;
}
# Set mode(s) on a channel.
sub cmode
{
my ($svr, $chan, $modes) = @_;
my ($svr, $chan, $modes) = @_;
Auto::socksnd($svr, "MODE $chan $modes");
return 1;
Auto::socksnd($svr, "MODE $chan $modes");
return 1;
}
# Set mode(s) on us.
sub umode
{
my ($svr, $modes) = @_;
Auto::socksnd($svr, "MODE ".$Parser::IRC::botnick{$svr}{nick}." $modes");
return 1;
my ($svr, $modes) = @_;
Auto::socksnd($svr, "MODE ".$Parser::IRC::botnick{$svr}{nick}." $modes");
return 1;
}
# Send a PRIVMSG.
sub privmsg
{
my ($svr, $target, $message) = @_;
Auto::socksnd($svr, "PRIVMSG $target :$message");
return 1;
my ($svr, $target, $message) = @_;
Auto::socksnd($svr, "PRIVMSG $target :$message");
return 1;
}
# Send a NOTICE.
sub notice
{
my ($svr, $target, $message) = @_;
Auto::socksnd($svr, "NOTICE $target :$message");
return 1;
my ($svr, $target, $message) = @_;
Auto::socksnd($svr, "NOTICE $target :$message");
return 1;
}
# Send an ACTION PRIVMSG.
@@ -91,33 +125,33 @@ sub act
# Change bot nickname.
sub nick
{
my ($svr, $newnick) = @_;
Auto::socksnd($svr, "NICK $newnick");
$Parser::IRC::botnick{$svr}{newnick} = $newnick;
return 1;
my ($svr, $newnick) = @_;
Auto::socksnd($svr, "NICK $newnick");
$Parser::IRC::botnick{$svr}{newnick} = $newnick;
return 1;
}
# Request the users of a channel.
sub names
{
my ($svr, $chan) = @_;
Auto::socksnd($svr, "NAMES $chan");
return 1;
my ($svr, $chan) = @_;
Auto::socksnd($svr, "NAMES $chan");
return 1;
}
# Send a topic to the channel.
sub topic
{
my ($svr, $chan, $topic) = @_;
Auto::socksnd($svr, "TOPIC $chan :$topic");
return 1;
my ($svr, $chan, $topic) = @_;
Auto::socksnd($svr, "TOPIC $chan :$topic");
return 1;
}
# Kick a user.
@@ -125,7 +159,7 @@ sub kick
{
my ($svr, $chan, $nick, $msg) = @_;
Auto::socksnd($svr, "KICK $chan $nick :$msg");
Auto::socksnd($svr, "KICK $chan $nick :".((defined $msg) ? $msg : 'No reason'));
return 1;
}
@@ -133,54 +167,54 @@ sub kick
# Quit IRC.
sub quit
{
my ($svr, $reason) = @_;
if (defined $reason) {
Auto::socksnd($svr, "QUIT :$reason");
}
else {
Auto::socksnd($svr, "QUIT :Leaving");
}
delete $Parser::IRC::got_001{$svr} if (defined $Parser::IRC::got_001{$svr});
delete $Parser::IRC::botnick{$svr} if (defined $Parser::IRC::botnick{$svr});
return 1;
my ($svr, $reason) = @_;
if (defined $reason) {
Auto::socksnd($svr, "QUIT :$reason");
}
else {
Auto::socksnd($svr, "QUIT :Leaving");
}
delete $Parser::IRC::got_001{$svr} if (defined $Parser::IRC::got_001{$svr});
delete $Parser::IRC::botnick{$svr} if (defined $Parser::IRC::botnick{$svr});
return 1;
}
# Get nick, ident and host from a <nick>!<ident>@<host>
sub usrc
{
my ($ex) = @_;
my @si = split('!', $ex);
my @sii = split('@', $si[1]);
return (
nick => $si[0],
user => $sii[0],
host => $sii[1]
);
my ($ex) = @_;
my @si = split('!', $ex);
my @sii = split('@', $si[1]);
return (
nick => $si[0],
user => $sii[0],
host => $sii[1]
);
}
# Match two IRC masks.
sub match_mask
{
my ($mu, $mh) = @_;
# Prepare the regex.
$mh =~ s/\./\\\./g;
$mh =~ s/\?/\./g;
$mh =~ s/\*/\.\*/g;
$mh = '^'.$mh.'$';
# Let's grep the user's mask.
if (grep(/$mh/, $mu)) {
return 1;
}
return 0;
my ($mu, $mh) = @_;
# Prepare the regex.
$mh =~ s/\./\\\./g;
$mh =~ s/\?/\./g;
$mh =~ s/\*/\.\*/g;
$mh = '^'.$mh.'$';
# Let's grep the user's mask.
if (grep(/$mh/, $mu)) {
return 1;
}
return 0;
}
+90 -56
View File
@@ -4,6 +4,7 @@
package API::Log;
use strict;
use warnings;
use feature qw(say);
use English qw(-no_match_vars);
use POSIX;
use Time::Local;
@@ -11,17 +12,17 @@ use Exporter;
use base qw(Exporter);
use API::Std qw(conf_get);
our @EXPORT_OK = qw(println dbug alog);
our @EXPORT_OK = qw(println dbug alog slog);
# Print with the system newline appended.
sub println
{
my ($out) = @_;
my ($out) = @_;
if (!defined $out) {
print $RS;
}
if (!defined $out) {
print $RS;
}
else {
print $out.$RS;
}
@@ -32,81 +33,114 @@ sub println
# Print only if in debug mode.
sub dbug
{
my ($out) = @_;
my ($out) = @_;
if ($Auto::DEBUG) {
# We're in debug mode; print it out.
println $out;
}
if ($Auto::DEBUG) {
# We're in debug mode; print it out.
say $out;
}
return 1;
return 1;
}
# Log to file.
sub alog
{
my ($lmsg) = @_;
my ($lmsg) = @_;
# Expire old logs first.
expire_logs();
# Expire old logs first.
expire_logs();
# Get date and time in the desired format.
my $date = POSIX::strftime('%Y%m%d', localtime);
my $time = POSIX::strftime('%Y-%m-%d %I:%M:%S %p', localtime);
# Get date and time in the desired format.
my $date = POSIX::strftime('%Y%m%d', localtime);
my $time = POSIX::strftime('%Y-%m-%d %I:%M:%S %p', localtime);
# Create var/ if it doesn't exist.
if (!-d "$Auto::Bin/../var") {
mkdir "$Auto::Bin/../var", 0600; ## no critic qw(ValuesAndExpressions::ProhibitMagicNumbers)
}
# Create var/DATE.log if it doesn't exist.
if (!-e "$Auto::Bin/../var/$date.log") {
system "touch $Auto::Bin/../var/$date.log";
}
# Create var/ if it doesn't exist.
if (!-d "$Auto::Bin/../var") {
mkdir "$Auto::Bin/../var", 0600; ## no critic qw(ValuesAndExpressions::ProhibitMagicNumbers)
}
# Create var/DATE.log if it doesn't exist.
if (!-e "$Auto::Bin/../var/$date.log") {
system "touch $Auto::Bin/../var/$date.log";
}
# Open the logfile, print the log message to it and close it.
open my $FLOG, '>>', "$Auto::Bin/../var/$date.log" or return;
print {$FLOG} "[$time] $lmsg\n" or return;
close $FLOG or return;
# Open the logfile, print the log message to it and close it.
open my $FLOG, '>>', "$Auto::Bin/../var/$date.log" or return;
print {$FLOG} "[$time] $lmsg\n" or return;
close $FLOG or return;
return 1;
return 1;
}
# Expire old logs.
sub expire_logs
{
# Get configuration value.
my $celog = (conf_get('expire_logs'))[0][0] or return;
# Get configuration value.
my $celog = (conf_get('expire_logs'))[0][0] or return;
# Check for invalid values.
if ($celog =~ m/[^0-9]/sm) { ## no critic qw(RegularExpressions::RequireExtendedFormatting)
# Must be numbers only.
return;
}
elsif (!$celog) {
# No expire.
return;
}
# Check for invalid values.
if ($celog =~ m/[^0-9]/sm) { ## no critic qw(RegularExpressions::RequireExtendedFormatting)
# Must be numbers only.
return;
}
elsif (!$celog) {
# No expire.
return;
}
# Iterate through each logfile.
foreach my $file (glob "$Auto::Bin/../var/*") {
my (undef, $file) = split 'bin/../var/', $file; ## no critic qw(BuiltinFunctions::ProhibitStringySplit)
# Iterate through each logfile.
foreach my $file (glob "$Auto::Bin/../var/*") {
my (undef, $file) = split 'bin/../var/', $file; ## no critic qw(BuiltinFunctions::ProhibitStringySplit)
# Convert filename to UNIX time.
my $yyyy = substr $file, 0, 4; ## no critic qw(ValuesAndExpressions::ProhibitMagicNumbers)
my $mm = substr $file, 4, 2; ## no critic qw(ValuesAndExpressions::ProhibitMagicNumbers)
$mm = $mm - 1;
my $dd = substr $file, 6, 2; ## no critic qw(ValuesAndExpressions::ProhibitMagicNumbers)
my $epoch = timelocal(0, 0, 0, $dd, $mm, $yyyy);
# Convert filename to UNIX time.
my $yyyy = substr $file, 0, 4; ## no critic qw(ValuesAndExpressions::ProhibitMagicNumbers)
my $mm = substr $file, 4, 2; ## no critic qw(ValuesAndExpressions::ProhibitMagicNumbers)
$mm = $mm - 1;
my $dd = substr $file, 6, 2; ## no critic qw(ValuesAndExpressions::ProhibitMagicNumbers)
my $epoch = timelocal(0, 0, 0, $dd, $mm, $yyyy);
# If it's older than <config_value> days, delete it.
if (time - $epoch > 86_400 * $celog) { ## no critic qw(ValuesAndExpressions::ProhibitMagicNumbers)
unlink "$Auto::Bin/../var/$file";
}
}
# If it's older than <config_value> days, delete it.
if (time - $epoch > 86_400 * $celog) { ## no critic qw(ValuesAndExpressions::ProhibitMagicNumbers)
unlink "$Auto::Bin/../var/$file";
}
}
return 1;
return 1;
}
# Subroutine for logging to an IRC logchan.
sub slog
{
my ($msg) = @_;
# Check if logging to channel is enabled.
if (conf_get('logchan')) {
# It is, continue.
# Split the network and channel.
my ($net, $chan) = split '/', (conf_get('logchan'))[0][0];
$chan = lc $chan;
# Check if we're connected to the network.
if (!defined $Auto::SOCKET{$net}) {
dbug 'WARNING: slog(): Unable to log to IRC: Not connected to network.';
alog 'WARNING: slog(): Unable to log to IRC: Not connected to network.';
return;
}
# Check if we're in the channel.
if (!defined $Parser::IRC::botchans{$net}{$chan}) {
dbug 'WARNING: slog(): Unable to log to IRC: Not in channel.';
alog 'WARNING: slog(): Unable to log to IRC: Not in channel.';
return;
}
# Log to IRC.
API::IRC::privmsg($net, $chan, "\002LOG:\002 $msg");
}
return 1;
}
1;
# vim: set ai sw=4 ts=4:
+283 -264
View File
@@ -4,234 +4,244 @@
package API::Std;
use strict;
use warnings;
use feature qw(say);
use Exporter;
use base qw(Exporter);
our (%LANGE, %MODULE, %EVENTS, %HOOKS, %CMDS);
our @EXPORT_OK = qw(conf_get trans err awarn timer_add timer_del cmd_add
cmd_del hook_add hook_del rchook_add rchook_del match_user
has_priv mod_exists ratelimit_check);
cmd_del hook_add hook_del rchook_add rchook_del match_user
has_priv mod_exists ratelimit_check);
# Initialize a module.
sub mod_init
{
my ($name, $author, $version, $autover, $pkg) = @_;
my ($name, $author, $version, $autover, $pkg) = @_;
# Log/debug.
API::Log::dbug('MODULES: Attempting to load '.$name.' (version '.$version.') by '.$author.'...');
API::Log::alog('MODULES: Attempting to load '.$name.' (version '.$version.') by '.$author.'...');
API::Log::dbug('MODULES: Attempting to load '.$name.' (version '.$version.') by '.$author.'...');
API::Log::alog('MODULES: Attempting to load '.$name.' (version '.$version.') by '.$author.'...');
if (keys %Auto::SOCKET) { API::Log::slog('MODULES: Attempting to load '.$name.' (version '.$version.') by '.$author.'...'); }
# Check if this module is compatible with this version of Auto.
if ($autover ne '3.0.0d') {
API::Log::dbug('MODULES: Failed to load '.$name.': Incompatible with your version of Auto.');
API::Log::alog('MODULES: Failed to load '.$name.': Incompatible with your version of Auto.');
return;
}
if ($autover ne '3.0.0a4' and $autover ne '3.0.0a5') {
API::Log::dbug('MODULES: Failed to load '.$name.': Incompatible with your version of Auto.');
API::Log::alog('MODULES: Failed to load '.$name.': Incompatible with your version of Auto.');
if (keys %Auto::SOCKET) { API::Log::slog('MODULES: Failed to load '.$name.': Incompatible with your version of Auto.'); }
return;
}
# Run the module's _init sub.
# Run the module's _init sub.
my $mi = eval($pkg.'::_init();'); ## no critic qw(BuiltinFunctions::ProhibitStringyEval)
if ($mi) {
# If successful, add to hash.
$MODULE{$name}{name} = $name;
$MODULE{$name}{version} = $version;
$MODULE{$name}{author} = $author;
$MODULE{$name}{pkg} = $pkg;
if ($mi) {
# If successful, add to hash.
$MODULE{$name}{name} = $name;
$MODULE{$name}{version} = $version;
$MODULE{$name}{author} = $author;
$MODULE{$name}{pkg} = $pkg;
API::Log::dbug('MODULES: '.$name.' successfully loaded.');
API::Log::alog('MODULES: '.$name.' successfully loaded.');
API::Log::dbug('MODULES: '.$name.' successfully loaded.');
API::Log::alog('MODULES: '.$name.' successfully loaded.');
if (keys %Auto::SOCKET) { API::Log::slog('MODULES: '.$name.' successfully loaded.'); }
return 1;
}
else {
# Otherwise, return a failed to load message.
API::Log::dbug('MODULES: Failed to load '.$name.q{.});
API::Log::alog('MODULES: Failed to load '.$name.q{.});
return 1;
}
else {
# Otherwise, return a failed to load message.
API::Log::dbug('MODULES: Failed to load '.$name.q{.});
API::Log::alog('MODULES: Failed to load '.$name.q{.});
if (keys %Auto::SOCKET) { API::Log::slog('MODULES: Failed to load '.$name.q{.}); }
return;
}
return;
}
}
# Check if a module exists.
sub mod_exists
{
my ($name) = @_;
my ($name) = @_;
if (defined $API::Std::MODULE{$name}) { return 1; }
if (defined $API::Std::MODULE{$name}) { return 1; }
return;
return;
}
# Void a module.
sub mod_void
{
my ($module) = @_;
my ($module) = @_;
# Log/debug.
API::Log::dbug('MODULES: Attempting to unload module: '.$module.'...');
API::Log::alog('MODULES: Attempting to unload module: '.$module.'...');
# Log/debug.
API::Log::dbug('MODULES: Attempting to unload module: '.$module.'...');
API::Log::alog('MODULES: Attempting to unload module: '.$module.'...');
if (keys %Auto::SOCKET) { API::Log::slog('MODULES: Attempting to unload module: '.$module.'...'); }
# Check if this module exists.
if (!defined $MODULE{$module}) {
API::Log::dbug('MODULES: Failed to unload '.$module.'. No such module?');
API::Log::alog('MODULES: Failed to unload '.$module.'. No such module?');
return;
}
# Check if this module exists.
if (!defined $MODULE{$module}) {
API::Log::dbug('MODULES: Failed to unload '.$module.'. No such module?');
API::Log::alog('MODULES: Failed to unload '.$module.'. No such module?');
if (keys %Auto::SOCKET) { API::Log::slog('MODULES: Failed to unload '.$module.'. No such module?'); }
return;
}
# Run the module's _void sub.
# Run the module's _void sub.
my $mi = eval($MODULE{$module}{pkg}.'::_void();'); ## no critic qw(BuiltinFunctions::ProhibitStringyEval)
if ($mi) {
# If successful, delete class from program and delete module from hash.
Class::Unload->unload($MODULE{$module}{pkg});
delete $MODULE{$module};
API::Log::dbug('MODULES: Successfully unloaded '.$module.q{.});
API::Log::alog('MODULES: Successfully unloaded '.$module.q{.});
return 1;
}
else {
# Otherwise, return a failed to unload message.
API::Log::dbug('MODULES: Failed to unload '.$module.q{.});
API::Log::alog('MODULES: Failed to unload '.$module.q{.});
return;
}
if ($mi) {
# If successful, delete class from program and delete module from hash.
Class::Unload->unload($MODULE{$module}{pkg});
delete $MODULE{$module};
API::Log::dbug('MODULES: Successfully unloaded '.$module.q{.});
API::Log::alog('MODULES: Successfully unloaded '.$module.q{.});
if (keys %Auto::SOCKET) { API::Log::slog('MODULES: Successfully unloaded '.$module.q{.}); }
return 1;
}
else {
# Otherwise, return a failed to unload message.
API::Log::dbug('MODULES: Failed to unload '.$module.q{.});
API::Log::alog('MODULES: Failed to unload '.$module.q{.});
if (keys %Auto::SOCKET) { API::Log::slog('MODULES: Failed to unload '.$module.q{.}); }
return;
}
}
# Add a command to Auto.
sub cmd_add
{
my ($cmd, $lvl, $priv, $help, $sub) = @_;
$cmd = uc $cmd;
my ($cmd, $lvl, $priv, $help, $sub) = @_;
$cmd = uc $cmd;
if (defined $API::Std::CMDS{$cmd}) { return; }
if ($lvl =~ m/[^0-2]/sm) { return; } ## no critic qw(RegularExpressions::RequireExtendedFormatting)
if (defined $API::Std::CMDS{$cmd}) { return; }
if ($lvl =~ m/[^0-3]/sm) { return; } ## no critic qw(RegularExpressions::RequireExtendedFormatting)
$API::Std::CMDS{$cmd}{lvl} = $lvl;
$API::Std::CMDS{$cmd}{help} = $help;
$API::Std::CMDS{$cmd}{priv} = $priv;
$API::Std::CMDS{$cmd}{sub} = $sub;
$API::Std::CMDS{$cmd}{lvl} = $lvl;
$API::Std::CMDS{$cmd}{help} = $help;
$API::Std::CMDS{$cmd}{priv} = $priv;
$API::Std::CMDS{$cmd}{'sub'} = $sub;
return 1;
return 1;
}
# Delete a command from Auto.
sub cmd_del
{
my ($cmd) = @_;
$cmd = uc $cmd;
my ($cmd) = @_;
$cmd = uc $cmd;
if (defined $API::Std::CMDS{$cmd}) {
delete $API::Std::CMDS{$cmd};
}
else {
return;
}
if (defined $API::Std::CMDS{$cmd}) {
delete $API::Std::CMDS{$cmd};
}
else {
return;
}
return 1;
return 1;
}
# Add an event to Auto.
sub event_add
{
my ($name) = @_;
my ($name) = @_;
if (!defined $EVENTS{lc $name}) {
$EVENTS{lc $name} = 1;
return 1;
}
else {
API::Log::dbug('DEBUG: Attempt to add a pre-existing event ('.lc $name.')! Ignoring...');
return;
}
if (!defined $EVENTS{lc $name}) {
$EVENTS{lc $name} = 1;
return 1;
}
else {
API::Log::dbug('DEBUG: Attempt to add a pre-existing event ('.lc $name.')! Ignoring...');
return;
}
}
# Delete an event from Auto.
sub event_del
{
my ($name) = @_;
my ($name) = @_;
if (defined $EVENTS{lc $name}) {
delete $EVENTS{lc $name};
delete $HOOKS{lc $name};
return 1;
}
else {
API::Log::dbug('DEBUG: Attempt to delete a non-existing event ('.lc $name.')! Ignoring...');
return;
}
if (defined $EVENTS{lc $name}) {
delete $EVENTS{lc $name};
delete $HOOKS{lc $name};
return 1;
}
else {
API::Log::dbug('DEBUG: Attempt to delete a non-existing event ('.lc $name.')! Ignoring...');
return;
}
}
# Trigger an event.
sub event_run
{
my ($event, @args) = @_;
my ($event, @args) = @_;
if (defined $EVENTS{lc $event} and defined $HOOKS{lc $event}) {
foreach my $hk (keys %{ $HOOKS{lc $event} }) {
&{ $HOOKS{lc $event}{$hk} }(@args);
}
}
if (defined $EVENTS{lc $event} and defined $HOOKS{lc $event}) {
foreach my $hk (keys %{ $HOOKS{lc $event} }) {
my $ri = &{ $HOOKS{lc $event}{$hk} }(@args);
if ($ri == -1) { last; }
}
}
return 1;
return 1;
}
# Add a hook to Auto.
sub hook_add
{
my ($event, $name, $sub) = @_;
my ($event, $name, $sub) = @_;
if (!defined $API::Std::HOOKS{lc $name}) {
if (defined $API::Std::EVENTS{lc $event}) {
$API::Std::HOOKS{lc $event}{lc $name} = $sub;
return 1;
}
else {
return;
}
}
else {
return;
}
if (!defined $API::Std::HOOKS{lc $name}) {
if (defined $API::Std::EVENTS{lc $event}) {
$API::Std::HOOKS{lc $event}{lc $name} = $sub;
return 1;
}
else {
return;
}
}
else {
return;
}
}
# Delete a hook from Auto.
sub hook_del
{
my ($event, $name) = @_;
my ($event, $name) = @_;
if (defined $API::Std::HOOKS{lc $event}{lc $name}) {
delete $API::Std::HOOKS{lc $event}{lc $name};
return 1;
}
else {
return;
}
if (defined $API::Std::HOOKS{lc $event}{lc $name}) {
delete $API::Std::HOOKS{lc $event}{lc $name};
return 1;
}
else {
return;
}
}
# Add a timer to Auto.
sub timer_add
{
my ($name, $type, $time, $sub) = @_;
$name = lc $name;
my ($name, $type, $time, $sub) = @_;
$name = lc $name;
# Check for invalid type/time.
if ($type =~ m/[^1-2]/sm) { ## no critic qw(RegularExpressions::RequireExtendedFormatting)
return;
}
if ($time =~ m/[^0-9]/sm) { ## no critic qw(RegularExpressions::RequireExtendedFormatting)
return;
}
# Check for invalid type/time.
if ($type =~ m/[^1-2]/sm) { ## no critic qw(RegularExpressions::RequireExtendedFormatting)
return;
}
if ($time =~ m/[^0-9]/sm) { ## no critic qw(RegularExpressions::RequireExtendedFormatting)
return;
}
if (!defined $Auto::TIMERS{$name}) {
$Auto::TIMERS{$name}{type} = $type;
$Auto::TIMERS{$name}{time} = time + $time;
if ($type == 2) { $Auto::TIMERS{$name}{secs} = $time; }
$Auto::TIMERS{$name}{sub} = $sub;
return 1;
}
if (!defined $Auto::TIMERS{$name}) {
$Auto::TIMERS{$name}{type} = $type;
$Auto::TIMERS{$name}{time} = time + $time;
if ($type == 2) { $Auto::TIMERS{$name}{secs} = $time; }
$Auto::TIMERS{$name}{sub} = $sub;
return 1;
}
return 1;
}
@@ -239,123 +249,123 @@ sub timer_add
# Delete a timer from Auto.
sub timer_del
{
my ($name) = @_;
$name = lc $name;
my ($name) = @_;
$name = lc $name;
if (defined $Auto::TIMERS{$name}) {
delete $Auto::TIMERS{$name};
return 1;
}
if (defined $Auto::TIMERS{$name}) {
delete $Auto::TIMERS{$name};
return 1;
}
return;
return;
}
# Hook onto a raw command.
sub rchook_add
{
my ($cmd, $sub) = @_;
$cmd = uc $cmd;
my ($cmd, $sub) = @_;
$cmd = uc $cmd;
if (defined $Parser::IRC::RAWC{$cmd}) { return; }
if (defined $Parser::IRC::RAWC{$cmd}) { return; }
$Parser::IRC::RAWC{$cmd} = $sub;
$Parser::IRC::RAWC{$cmd} = $sub;
return 1;
return 1;
}
# Delete a raw command hook.
sub rchook_del
{
my ($cmd) = @_;
$cmd = uc $cmd;
my ($cmd) = @_;
$cmd = uc $cmd;
if (!defined $Parser::IRC::RAWC{$cmd}) { return; }
if (!defined $Parser::IRC::RAWC{$cmd}) { return; }
delete $Parser::IRC::RAWC{$cmd};
delete $Parser::IRC::RAWC{$cmd};
return 1;
return 1;
}
# Configuration value getter.
sub conf_get
{
my ($value) = @_;
my ($value) = @_;
# Create an array out of the value.
my @val;
if ($value =~ m/:/sm) { ## no critic qw(RegularExpressions::RequireExtendedFormatting)
@val = split m/[:]/sm, $value; ## no critic qw(RegularExpressions::RequireExtendedFormatting)
}
else {
@val = ($value);
}
# Undefine this as it's unnecessary now.
undef $value;
# Create an array out of the value.
my @val;
if ($value =~ m/:/sm) { ## no critic qw(RegularExpressions::RequireExtendedFormatting)
@val = split m/[:]/sm, $value; ## no critic qw(RegularExpressions::RequireExtendedFormatting)
}
else {
@val = ($value);
}
# Undefine this as it's unnecessary now.
undef $value;
# Get the count of elements in the array.
my $count = scalar @val;
# Get the count of elements in the array.
my $count = scalar @val;
# Return the requested configuration value(s).
if ($count == 1) {
if (ref $Auto::SETTINGS{$val[0]} eq 'HASH') {
return %{ $Auto::SETTINGS{$val[0]} };
}
else {
return $Auto::SETTINGS{$val[0]};
}
}
elsif ($count == 2) {
if (ref $Auto::SETTINGS{$val[0]}{$val[1]} eq 'HASH') {
return %{ $Auto::SETTINGS{$val[0]}{$val[1]} };
}
else {
return $Auto::SETTINGS{$val[0]}{$val[1]};
}
}
elsif ($count == 3) {
if (ref $Auto::SETTINGS{$val[0]}{$val[1]}{$val[2]} eq 'HASH') {
return %{ $Auto::SETTINGS{$val[0]}{$val[1]}{$val[2]} };
}
else {
return $Auto::SETTINGS{$val[0]}{$val[1]}{$val[2]};
}
}
else {
return;
}
# Return the requested configuration value(s).
if ($count == 1) {
if (ref $Auto::SETTINGS{$val[0]} eq 'HASH') {
return %{ $Auto::SETTINGS{$val[0]} };
}
else {
return $Auto::SETTINGS{$val[0]};
}
}
elsif ($count == 2) {
if (ref $Auto::SETTINGS{$val[0]}{$val[1]} eq 'HASH') {
return %{ $Auto::SETTINGS{$val[0]}{$val[1]} };
}
else {
return $Auto::SETTINGS{$val[0]}{$val[1]};
}
}
elsif ($count == 3) {
if (ref $Auto::SETTINGS{$val[0]}{$val[1]}{$val[2]} eq 'HASH') {
return %{ $Auto::SETTINGS{$val[0]}{$val[1]}{$val[2]} };
}
else {
return $Auto::SETTINGS{$val[0]}{$val[1]}{$val[2]};
}
}
else {
return;
}
}
# Translation subroutine.
sub trans
{
my ($id) = @_;
$id =~ s/ /_/gsm;
my $id = shift;
$id =~ s/ /_/gsm;
if (defined $API::Std::LANGE{$id}) {
return $API::Std::LANGE{$id};
}
else {
$id =~ s/_/ /gsm;
return $id;
}
if (defined $API::Std::LANGE{$id}) {
return sprintf $API::Std::LANGE{$id}, @_;
}
else {
$id =~ s/_/ /gsm;
return $id;
}
}
# Match user subroutine.
sub match_user
{
my (%user) = @_;
my (%user) = @_;
# Get data from config.
# Get data from config.
if (!conf_get('user')) { return; }
my %uhp = conf_get('user');
my %uhp = conf_get('user');
foreach my $userkey (keys %uhp) {
# For each user block.
my %ulhp = %{ $uhp{$userkey} };
foreach my $uhk (keys %ulhp) {
foreach my $userkey (keys %uhp) {
# For each user block.
my %ulhp = %{ $uhp{$userkey} };
foreach my $uhk (keys %ulhp) {
# For each user.
if ($uhk eq 'net') {
if ($uhk eq 'net') {
if (defined $user{svr}) {
if (lc $user{svr} ne lc(($ulhp{$uhk})[0][0])) {
# config.user:net conflicts with irc.user:svr.
@@ -364,13 +374,13 @@ sub match_user
}
}
elsif ($uhk eq 'mask') {
# Put together the user information.
my $mask = $user{nick}.q{!}.$user{user}.q{@}.$user{host};
if (API::IRC::match_mask($mask, ($ulhp{$uhk})[0][0])) {
# We've got a host match.
return $userkey;
}
}
# Put together the user information.
my $mask = $user{nick}.q{!}.$user{user}.q{@}.$user{host};
if (API::IRC::match_mask($mask, ($ulhp{$uhk})[0][0])) {
# We've got a host match.
return $userkey;
}
}
elsif ($uhk eq 'chanstatus' and defined $ulhp{'net'}) {
my ($ccst, $ccnm) = split m/[:]/sm, ($ulhp{$uhk})[0][0]; ## no critic qw(RegularExpressions::RequireExtendedFormatting)
my $svr = $ulhp{net}[0];
@@ -391,28 +401,28 @@ sub match_user
}
}
}
}
}
}
}
return;
return;
}
# Privilege subroutine.
sub has_priv
{
my ($cuser, $cpriv) = @_;
my ($cuser, $cpriv) = @_;
if (conf_get("user:$cuser:privs")) {
my $cups = (conf_get("user:$cuser:privs"))[0][0];
if (conf_get("user:$cuser:privs")) {
my $cups = (conf_get("user:$cuser:privs"))[0][0];
if (defined $Auto::PRIVILEGES{$cups}) {
foreach (@{ $Auto::PRIVILEGES{$cups} }) {
if ($_ eq $cpriv or $_ eq 'ALL') { return 1; }
}
}
}
if (defined $Auto::PRIVILEGES{$cups}) {
foreach (@{ $Auto::PRIVILEGES{$cups} }) {
if ($_ eq $cpriv or $_ eq 'ALL') { return 1; }
}
}
}
return;
return;
}
# Ratelimit check subroutine.
@@ -430,6 +440,7 @@ sub ratelimit_check
# If the user has not passed the rate limit.
if ($Core::IRC::usercmd{$src{nick}.'@'.$src{host}.'/'.$src{svr}} <= (conf_get('ratelimit_amount'))[0][0]) {
# Increment their uses and return 1.
$Core::IRC::usercmd{$src{nick}.'@'.$src{host}.'/'.$src{svr}}++;
return 1;
}
@@ -450,51 +461,59 @@ sub ratelimit_check
# Error subroutine.
sub err ## no critic qw(Subroutines::ProhibitBuiltinHomonyms)
{
my ($lvl, $msg, $fatal) = @_;
my ($lvl, $msg, $fatal) = @_;
# Check for an invalid level.
if ($lvl =~ m/[^0-9]/sm) { ## no critic qw(RegularExpressions::RequireExtendedFormatting)
return;
}
if ($fatal =~ m/[^0-1]/sm) { ## no critic qw(RegularExpressions::RequireExtendedFormatting)
return;
}
# Check for an invalid level.
if ($lvl =~ m/[^0-9]/sm) { ## no critic qw(RegularExpressions::RequireExtendedFormatting)
return;
}
if ($fatal =~ m/[^0-1]/sm) { ## no critic qw(RegularExpressions::RequireExtendedFormatting)
return;
}
# Level 1: Print to screen.
if ($lvl >= 1) {
API::Log::println("ERROR: $msg");
}
# Level 2: Log to file.
if ($lvl >= 2) {
API::Log::alog("ERROR: $msg");
}
# Level 1: Print to screen.
if ($lvl >= 1) {
say "ERROR: $msg";
}
# Level 2: Log to file.
if ($lvl >= 2) {
API::Log::alog("ERROR: $msg");
}
# Level 3: Log to IRC.
if ($lvl >= 3) {
API::Log::slog("ERROR: $msg");
}
# If it's a fatal error, exit the program.
if ($fatal) { exit; }
# If it's a fatal error, exit the program.
if ($fatal) { exit; }
return 1;
return 1;
}
# Warn subroutine.
sub awarn
{
my ($lvl, $msg) = @_;
my ($lvl, $msg) = @_;
# Check for an invalid level.
if ($lvl =~ m/[^0-9]/sm) { ## no critic qw(RegularExpressions::RequireExtendedFormatting)
return;
}
# Check for an invalid level.
if ($lvl =~ m/[^0-9]/sm) { ## no critic qw(RegularExpressions::RequireExtendedFormatting)
return;
}
# Level 1: Print to screen.
if ($lvl >= 1) {
API::Log::println("WARNING: $msg");
}
# Level 2: Log to file.
if ($lvl >= 2) {
API::Log::alog("WARNING: $msg");
}
# Level 1: Print to screen.
if ($lvl >= 1) {
say "WARNING: $msg";
}
# Level 2: Log to file.
if ($lvl >= 2) {
API::Log::alog("WARNING: $msg");
}
# Level 3: Log to IRC.
if ($lvl >= 3) {
API::Log::slog("WARNING: $msg");
}
return 1;
return 1;
}
+67 -51
View File
@@ -16,18 +16,17 @@ our %HELP_MODLOAD = (
# MODLOAD callback.
sub cmd_modload
{
my (%data) = @_;
my @argv = @{ $data{args} };
my ($src, @argv) = @_;
# Check for the needed parameters.
if (!defined $argv[0]) {
notice($data{svr}, $data{nick}, trans("Not enough parameters").".");
notice($src->{svr}, $src->{nick}, trans("Not enough parameters").".");
return 0;
}
# Check if the module is already loaded.
if (API::Std::mod_exists($argv[0])) {
notice($data{svr}, $data{nick}, "Module \002".$argv[0]."\002 is already loaded.");
notice($src->{svr}, $src->{nick}, "Module \002".$argv[0]."\002 is already loaded.");
return 0;
}
@@ -37,11 +36,11 @@ sub cmd_modload
# Check if we were successful or not.
if ($tn) {
# We were!
notice($data{svr}, $data{nick}, "Module \002".$argv[0]."\002 successfully loaded.");
notice($src->{svr}, $src->{nick}, "Module \002".$argv[0]."\002 successfully loaded.");
}
else {
# We weren't.
notice($data{svr}, $data{nick}, "Module \002".$argv[0]."\002 failed to load.");
notice($src->{svr}, $src->{nick}, "Module \002".$argv[0]."\002 failed to load.");
return 0;
}
@@ -55,18 +54,17 @@ our %HELP_MODUNLOAD = (
# MODUNLOAD callback.
sub cmd_modunload
{
my (%data) = @_;
my @argv = @{ $data{args} };
my ($src, @argv) = @_;
# Check for the needed parameters.
if (!defined $argv[0]) {
notice($data{svr}, $data{nick}, trans("Not enough parameters").".");
notice($src->{svr}, $src->{nick}, trans("Not enough parameters").".");
return 0;
}
# Check if the module exists.
if (!API::Std::mod_exists($argv[0])) {
notice($data{svr}, $data{nick}, "Module \002".$argv[0]."\002 is not loaded.");
notice($src->{svr}, $src->{nick}, "Module \002".$argv[0]."\002 is not loaded.");
return 0;
}
@@ -76,11 +74,11 @@ sub cmd_modunload
# Check if we were successful or not.
if ($tn) {
# We were!
notice($data{svr}, $data{nick}, "Module \002".$argv[0]."\002 successfully unloaded.");
notice($src->{svr}, $src->{nick}, "Module \002".$argv[0]."\002 successfully unloaded.");
}
else {
# We weren't.
notice($data{svr}, $data{nick}, "Module \002".$argv[0]."\002 failed to unload.");
notice($src->{svr}, $src->{nick}, "Module \002".$argv[0]."\002 failed to unload.");
return 0;
}
@@ -94,18 +92,17 @@ our %HELP_MODRELOAD = (
# MODRELOAD callback.
sub cmd_modreload
{
my (%data) = @_;
my @argv = @{ $data{args} };
my ($src, @argv) = @_;
# Check for the needed parameters.
if (!defined $argv[0]) {
notice($data{svr}, $data{nick}, trans("Not enough parameters").".");
notice($src->{svr}, $src->{nick}, trans("Not enough parameters").".");
return 0;
}
# Check if the module exists.
if (!API::Std::mod_exists($argv[0])) {
notice($data{svr}, $data{nick}, "Module \002".$argv[0]."\002 is not loaded.");
notice($src->{svr}, $src->{nick}, "Module \002".$argv[0]."\002 is not loaded.");
return 0;
}
@@ -117,33 +114,54 @@ sub cmd_modreload
# Check if we were successful or not.
if ($tvn and $tln) {
# We were!
notice($data{svr}, $data{nick}, "Module \002".$argv[0]."\002 successfully reloaded.");
notice($src->{svr}, $src->{nick}, "Module \002".$argv[0]."\002 successfully reloaded.");
}
else {
# We weren't.
notice($data{svr}, $data{nick}, "Module \002".$argv[0]."\002 failed to reload.");
notice($src->{svr}, $src->{nick}, "Module \002".$argv[0]."\002 failed to reload.");
return 0;
}
return 1;
}
# Help hash for MODLIST. Spanish, French and German needed.
our %HELP_MODLIST = (
'en' => "This will return a list of all currently loaded modules. \2Syntax:\2 MODLIST",
);
# MODLIST callback.
sub cmd_modlist
{
my ($src, undef) = @_;
# Iterate through all loaded modules.
my $str;
foreach (keys %API::Std::MODULE) {
$str .= ", \2$_\2 (v".$API::Std::MODULE{$_}{version}.')';
}
# Return it.
$str = substr $str, 2;
notice($src->{svr}, $src->{nick}, "\2Module List:\2 $str");
return 1;
}
# Help hash for SHUTDOWN. Spanish, French and German needed.
our %HELP_SHUTDOWN = (
'en' => 'This will send out shutdown notifications, quit all networks, flush the database then exit the program.',
'en' => "This will send out shutdown notifications, quit all networks, flush the database then exit the program. \2Syntax:\2 SHUTDOWN",
);
# SHUTDOWN callback.
sub cmd_shutdown
{
my (%data) = @_;
my ($src, undef) = @_;
# Goodbye world!
notice($data{svr}, $data{nick}, "Shutting down.");
dbug "Got SHUTDOWN from ".$data{nick}."!".$data{user}."@".$data{host}."/".$data{svr}."! Shutting down. . .";
alog "Got SHUTDOWN from ".$data{nick}."!".$data{user}."@".$data{host}."/".$data{svr}."! Shutting down. . .";
quit($_, "SHUTDOWN from ".$data{nick}."/".$data{svr}) foreach (keys %Auto::SOCKET);
$Auto::DB->disconnect;
system("rm $Auto::Bin/auto.pid");
notice($src->{svr}, $src->{nick}, "Shutting down.");
dbug "Got SHUTDOWN from ".$src->{nick}."!".$src->{user}."@".$src->{host}."/".$src->{svr}."! Shutting down. . .";
alog "Got SHUTDOWN from ".$src->{nick}."!".$src->{user}."@".$src->{host}."/".$src->{svr}."! Shutting down. . .";
quit($_, "SHUTDOWN from ".$src->{nick}."/".$src->{svr}) foreach (keys %Auto::SOCKET);
API::Std::event_run('on_shutdown');
exit;
# To appease PerlCritic.
@@ -157,15 +175,14 @@ our %HELP_RESTART = (
# RESTART callback.
sub cmd_restart
{
my (%data) = @_;
my ($src, undef) = @_;
# Goodbye world!
notice($data{svr}, $data{nick}, "Restarting.");
dbug "Got RESTART from ".$data{nick}."!".$data{user}."@".$data{host}."/".$data{svr}."! Restarting. . .";
alog "Got RESTART from ".$data{nick}."!".$data{user}."@".$data{host}."/".$data{svr}."! Restarting. . .";
quit($_, "RESTART from ".$data{nick}."/".$data{svr}) foreach (keys %Auto::SOCKET);
$Auto::DB->disconnect;
system("rm $Auto::Bin/auto.pid") if -e "$Auto::Bin/auto.pid";
notice($src->{svr}, $src->{nick}, "Restarting.");
dbug "Got RESTART from ".$src->{nick}."!".$src->{user}."@".$src->{host}."/".$src->{svr}."! Restarting. . .";
alog "Got RESTART from ".$src->{nick}."!".$src->{user}."@".$src->{host}."/".$src->{svr}."! Restarting. . .";
quit($_, "RESTART from ".$src->{nick}."/".$src->{svr}) foreach (keys %Auto::SOCKET);
API::Std::event_run('on_shutdown');
# Time to come back from the dead!
if ($Auto::DEBUG) {
@@ -187,16 +204,16 @@ our %HELP_REHASH = (
# REHASH callback.
sub cmd_rehash
{
my (%data) = @_;
my ($src, undef) = @_;
# Send out notifications.
notice($data{svr}, $data{nick}, "Rehashing.");
dbug "Got REHASH from ".$data{nick}."!".$data{user}."@".$data{host}."/".$data{svr}."! Rehashing. . .";
alog "Got REHASH from ".$data{nick}."!".$data{user}."@".$data{host}."/".$data{svr}."! Rehashing. . .";
notice($src->{svr}, $src->{nick}, "Rehashing.");
dbug "Got REHASH from ".$src->{nick}."!".$src->{user}."@".$src->{host}."/".$src->{svr}."! Rehashing. . .";
alog "Got REHASH from ".$src->{nick}."!".$src->{user}."@".$src->{host}."/".$src->{svr}."! Rehashing. . .";
# Rehash.
Lib::Auto::rehash();
notice($data{svr}, $data{nick}, "Done.");
notice($src->{svr}, $src->{nick}, "Done.");
return 1;
}
@@ -208,18 +225,17 @@ our %HELP_HELP = (
# HELP callback.
sub cmd_help
{
my (%data) = @_;
my @argv = @{ $data{args} }; delete $data{args};
my ($src, @argv) = @_;
# Check for arguments and reply accordingly.
if (!defined $argv[0]) {
# No command specified. List commands.
my $cmdlist = '';
foreach (sort keys %API::Std::CMDS) {
if (defined $data{chan}) {
if (defined $src->{chan}) {
if ($API::Std::CMDS{$_}{lvl} == 0 or $API::Std::CMDS{$_}{lvl} == 2) {
if ($API::Std::CMDS{$_}{priv}) {
if (has_priv(match_user(%data), $API::Std::CMDS{$_}{priv})) {
if (has_priv(match_user(%$src), $API::Std::CMDS{$_}{priv})) {
$cmdlist .= ", \002".uc($_)."\002";
}
}
@@ -231,7 +247,7 @@ sub cmd_help
else {
if ($API::Std::CMDS{$_}{lvl} == 1 or $API::Std::CMDS{$_}{lvl} == 2) {
if ($API::Std::CMDS{$_}{priv}) {
if (has_priv(match_user(%data), $API::Std::CMDS{$_}{priv})) {
if (has_priv(match_user(%$src), $API::Std::CMDS{$_}{priv})) {
$cmdlist .= ", \002".uc($_)."\002";
}
}
@@ -243,7 +259,7 @@ sub cmd_help
}
$cmdlist = substr($cmdlist, 2);
notice($data{svr}, $data{nick}, "Command List: ".$cmdlist);
notice($src->{svr}, $src->{nick}, "Command List: ".$cmdlist);
}
else {
# Help for a specific command was requested. Lets get it.
@@ -254,8 +270,8 @@ sub cmd_help
# Check for necessary privileges.
if ($API::Std::CMDS{$rcm}{priv}) {
if (!has_priv(match_user(%data), $API::Std::CMDS{$rcm}{priv})) {
notice($data{svr}, $data{nick}, trans("Access denied").".");
if (!has_priv(match_user(%$src), $API::Std::CMDS{$rcm}{priv})) {
notice($src->{svr}, $src->{nick}, trans("Access denied").".");
return;
}
}
@@ -268,28 +284,28 @@ sub cmd_help
if (defined ${ $API::Std::CMDS{$rcm}{help} }{$lang}) {
# If help for this command is available in the configured language.
notice($data{svr}, $data{nick}, "Help for \002".$rcm."\002: ".${ $API::Std::CMDS{$rcm}{help} }{$lang});
notice($src->{svr}, $src->{nick}, "Help for \002".$rcm."\002: ".${ $API::Std::CMDS{$rcm}{help} }{$lang});
}
else {
# If it isn't, default to English.
if (defined ${ $API::Std::CMDS{$rcm}{help} }{en}) {
# If help for this command is available in English.
notice($data{svr}, $data{nick}, "Help for \002".$rcm."\002: ".${ $API::Std::CMDS{$rcm}{help} }{en});
notice($src->{svr}, $src->{nick}, "Help for \002".$rcm."\002: ".${ $API::Std::CMDS{$rcm}{help} }{en});
}
else {
# If it isn't, no help.
notice($data{svr}, $data{nick}, "No help for \002".$rcm."\002 available.");
notice($src->{svr}, $src->{nick}, "No help for \002".$rcm."\002 available.");
}
}
}
else {
# If it isn't valid, no help.
notice($data{svr}, $data{nick}, "No help for \002".$rcm."\002 available.");
notice($src->{svr}, $src->{nick}, "No help for \002".$rcm."\002 available.");
}
}
else {
# If there is no help, don't give any.
notice($data{svr}, $data{nick}, "No help for \002".$rcm."\002 available.");
notice($src->{svr}, $src->{nick}, "No help for \002".$rcm."\002 available.");
}
}
+54 -26
View File
@@ -12,15 +12,14 @@ our (%usercmd);
# CTCP VERSION reply.
hook_add("on_uprivmsg", "ctcp_version_reply", sub {
my (($svr, @ex)) = @_;
my %src = usrc(substr($ex[0], 1));
my (($src, @msg)) = @_;
if ($ex[3] eq ":\001VERSION\001") {
if ($msg[0] eq "\001VERSION\001") {
if (Auto::RSTAGE ne 'd') {
notice($svr, $src{nick}, "\001VERSION ".Auto::NAME." ".Auto::VER.".".Auto::SVER.".".Auto::REV.Auto::RSTAGE." ".$OSNAME."\001");
notice($src->{svr}, $src->{nick}, "\001VERSION ".Auto::NAME." ".Auto::VER.".".Auto::SVER.".".Auto::REV.Auto::RSTAGE." ".$OSNAME."\001");
}
else {
notice($svr, $src{nick}, "\001VERSION ".Auto::NAME." ".Auto::VER.".".Auto::SVER.".".Auto::REV.Auto::RSTAGE."-".Auto::GR." ".$OSNAME."\001");
notice($src->{svr}, $src->{nick}, "\001VERSION ".Auto::NAME." ".Auto::VER.".".Auto::SVER.".".Auto::REV.Auto::RSTAGE."-".Auto::GR." ".$OSNAME."\001");
}
}
@@ -44,22 +43,22 @@ hook_add("on_quit", "quit_update_chanusers", sub {
hook_add("on_connect", "on_connect_modes", sub {
my ($svr) = @_;
if (conf_get("server:$svr:modes")) {
my $connmodes = (conf_get("server:$svr:modes"))[0][0];
API::IRC::umode($svr, $connmodes);
}
if (conf_get("server:$svr:modes")) {
my $connmodes = (conf_get("server:$svr:modes"))[0][0];
API::IRC::umode($svr, $connmodes);
}
return 1;
});
# Plaintext auth.
hook_add("on_connect", "plaintext_auth", sub {
my ($svr) = @_;
my ($svr) = @_;
if (conf_get("server:$svr:idstr")) {
my $idstr = (conf_get("server:$svr:idstr"))[0][0];
Auto::socksnd($svr, $idstr);
}
my $idstr = (conf_get("server:$svr:idstr"))[0][0];
Auto::socksnd($svr, $idstr);
}
return 1;
});
@@ -68,19 +67,48 @@ hook_add("on_connect", "plaintext_auth", sub {
hook_add("on_connect", "autojoin", sub {
my ($svr) = @_;
# Get the auto-join from the config.
my @cajoin = @{ (conf_get("server:$svr:ajoin"))[0] };
# Join the channels.
if (!defined $cajoin[1]) {
# For single-line ajoins.
my @sajoin = split(',', $cajoin[0]);
API::IRC::cjoin($svr, $_) foreach (@sajoin);
}
else {
# For multi-line ajoins.
API::IRC::cjoin($svr, $_) foreach (@cajoin);
# Get the auto-join from the config.
my @cajoin = @{ (conf_get("server:$svr:ajoin"))[0] };
# Join the channels.
if (!defined $cajoin[1]) {
# For single-line ajoins.
my @sajoin = split(',', $cajoin[0]);
foreach (@sajoin) {
# Check if a key was specified.
if ($_ =~ m/\s/xsm) {
# There was, join with it.
my ($chan, $key) = split / /;
API::IRC::cjoin($svr, $chan, $key);
}
else {
# Else join without one.
API::IRC::cjoin($svr, $_);
}
}
}
else {
# For multi-line ajoins.
foreach (@cajoin) {
# Check if a key was specified.
if ($_ =~ m/\s/xsm) {
# There was, join with it.
my ($chan, $key) = split / /;
API::IRC::cjoin($svr, $chan, $key);
}
else {
# Else join without one.
API::IRC::cjoin($svr, $_);
}
}
}
# And logchan, if applicable.
if (conf_get('logchan')) {
my ($lcn, $lcc) = split '/', (conf_get('logchan'))[0][0];
if ($lcn eq $svr) {
API::IRC::cjoin($svr, $lcc);
}
}
return 1;
+27 -21
View File
@@ -4,18 +4,23 @@
package Lib::Auto;
use strict;
use warnings;
use feature qw(say);
use English qw(-no_match_vars);
use Sys::Hostname;
use feature qw(switch);
use API::Std qw(conf_get err);
use API::Log qw(println dbug alog);
use API::Std qw(hook_add conf_get err);
use API::Log qw(dbug alog);
our $VERSION = 3.000000;
# Core events.
API::Std::event_add('on_shutdown');
API::Std::event_add('on_rehash');
# Update checker.
sub checkver
{
if (!$Auto::NUC and Auto::RSTAGE ne 'd') {
println '* Connecting to update server...';
say '* Connecting to update server...';
my $uss = IO::Socket::INET->new(
'Proto' => 'tcp',
'PeerAddr' => 'dist.xelhua.org',
@@ -33,11 +38,11 @@ sub checkver
}
elsif ($v eq 'version') {
if (Auto::VER.q{.}.Auto::SVER.q{.}.Auto::REV.Auto::RSTAGE ne $c) {
println('!!! NOTICE !!! Your copy of Auto is outdated. Current version: '.Auto::VER.q{.}.Auto::SVER.q{.}.Auto::REV.Auto::RSTAGE.' - Latest version: '.$c);
println('!!! NOTICE !!! You can get the latest Auto by downloading '.$dll);
say('!!! NOTICE !!! Your copy of Auto is outdated. Current version: '.Auto::VER.q{.}.Auto::SVER.q{.}.Auto::REV.Auto::RSTAGE.' - Latest version: '.$c);
say('!!! NOTICE !!! You can get the latest Auto by downloading '.$dll);
}
else {
println('* Auto is up-to-date.');
say('* Auto is up-to-date.');
}
}
}
@@ -50,7 +55,7 @@ sub rehash
my %newsettings = $Auto::CONF->parse or err(2, 'Failed to parse configuration file!', 0) and return;
# Check for required configuration values.
my @REQCVALS = qw(locale expire_logs server fantasy_pf);
my @REQCVALS = qw(locale expire_logs server fantasy_pf ratelimit bantype);
foreach my $REQCVAL (@REQCVALS) {
if (!defined $newsettings{$REQCVAL}) {
err(2, "Missing required configuration value: $REQCVAL", 0) and return;
@@ -200,9 +205,19 @@ sub rehash
}
}
# Now trigger on_rehash.
API::Std::event_run('on_rehash');
return 1;
}
# Shutdown.
hook_add('on_shutdown', 'shutdown.core_cleanup', sub {
if (defined $Auto::DB) { $Auto::DB->disconnect; }
if (-e "$Auto::Bin/auto.pid") { unlink "$Auto::Bin/auto.pid"; }
return 1;
});
###################
# Signal handlers #
###################
@@ -211,13 +226,10 @@ sub rehash
sub signal_term
{
API::Std::event_run('on_sigterm');
API::Std::event_run('on_shutdown');
foreach (keys %Auto::SOCKET) { API::IRC::quit($_, 'Caught SIGTERM'); }
$Auto::DB->disconnect;
dbug '!!! Caught SIGTERM; terminating...';
alog '!!! Caught SIGTERM; terminating...';
if (-e "$Auto::Bin/auto.pid") {
unlink "$Auto::Bin/auto.pid";
}
sleep 1;
exit;
}
@@ -226,13 +238,10 @@ sub signal_term
sub signal_int
{
API::Std::event_run('on_sigint');
API::Std::event_run('on_shutdown');
foreach (keys %Auto::SOCKET) { API::IRC::quit($_, 'Caught SIGINT'); }
$Auto::DB->disconnect;
dbug '!!! Caught SIGINT; terminating...';
alog '!!! Caught SIGINT; terminating...';
if (-e "$Auto::Bin/auto.pid") {
unlink "$Auto::Bin/auto.pid";
}
sleep 1;
exit;
}
@@ -253,7 +262,7 @@ sub signal_perlwarn
my ($warnmsg) = @_;
$warnmsg =~ s/(\n|\r)//xsmg;
alog 'Perl Warning: '.$warnmsg;
if ($Auto::DEBUG) { println 'Perl Warning: '.$warnmsg; }
if ($Auto::DEBUG) { say 'Perl Warning: '.$warnmsg; }
return 1;
}
@@ -266,12 +275,9 @@ sub signal_perldie
return if $EXCEPTIONS_BEING_CAUGHT;
alog 'Perl Fatal: '.$diemsg.' -- Terminating program!';
foreach (keys %Auto::SOCKET) { API::IRC::quit($_, 'A fatal error occurred!'); }
$Auto::DB->disconnect;
if (-e "$Auto::Bin/auto.pid") {
unlink "$Auto::Bin/auto.pid";
}
API::Std::event_run('on_shutdown');
sleep 1;
println 'FATAL: '.$diemsg;
say 'FATAL: '.$diemsg;
exit;
}
+1 -1
View File
@@ -119,7 +119,7 @@ sub installmods
chomp $response;
if (lc $response eq 'y') {
println 'What modules would you like to install? (separate by commas)';
println 'Available modules: Badwords, Bitly, Calc, EightBall, FML, HelloChan, IsItUp, QDB, SASLAuth, Weather';
println 'Available modules: Badwords, Bitly, Calc, EightBall, FML, Greet, HelloChan, IsItUp, QDB, SASLAuth, Weather';
print '> ';
my $modules = <STDIN>; chomp $modules;
$modules =~ s/ //g;
+152 -152
View File
@@ -12,18 +12,18 @@ sub new
my ($file) = @_;
my $self = bless {}, $class;
# Check to see if the configuration file exists.
if (!-e "$Auto::Bin/../etc/$file") {
return 0;
}
# Open, read and close the config.
open(my $FCONF, q{<}, "$Auto::Bin/../etc/$file") or return 0;
my @cosfl = <$FCONF> or return 0;
close $FCONF or return 0;
# Save it to self variable.
$self->{'config'}->{'path'} = "$Auto::Bin/../etc/$file";
# Check to see if the configuration file exists.
if (!-e "$Auto::Bin/../etc/$file") {
return 0;
}
# Open, read and close the config.
open(my $FCONF, q{<}, "$Auto::Bin/../etc/$file") or return 0;
my @cosfl = <$FCONF> or return 0;
close $FCONF or return 0;
# Save it to self variable.
$self->{'config'}->{'path'} = "$Auto::Bin/../etc/$file";
return $self;
}
@@ -31,148 +31,148 @@ sub new
# Parse the configuration file.
sub parse
{
# Get the path to the file.
my $self = shift;
my $file = $self->{'config'}->{'path'};
my $blk = 0;
my (%rs);
# Open, read and close it.
open(my $FCONF, q{<}, "$file") or return 0;
my @fbuf = <$FCONF> or return 0;
close $FCONF or return 0;
# Iterate the file.
foreach my $buff (@fbuf) {
# Main newline buffer.
if (defined $buff) {
# If the line begins with a #, it's a comment so ignore it.
if (substr($buff, 0, 1) eq '#') {
next;
}
if ($buff =~ m/;/) {
# Semicolon buffer.
my @asbuf = split(';', $buff);
foreach my $asbuff (@asbuf) {
if (defined $asbuff) {
# Space buffer.
my @ebuf = split(' ', $asbuff);
if (!defined $ebuf[0] or !defined $ebuf[1]) {
# Garbage. Ignoring.
next;
}
my $param = $ebuf[1];
if (substr($param, 0, 1) eq '"' and substr($param, length($param) - 1, 1) ne '"') {
# Multi-word string.
$param = substr($param, 1);
for (my $i = 2; $i < scalar(@ebuf); $i++) {
if (substr($ebuf[$i], length($ebuf[$i]) - 1, 1) eq '"') {
$param .= " ".substr($ebuf[$i], 0, length($ebuf[$i]) - 1);
last;
}
else {
$param .= " ".$ebuf[$i];
}
}
}
elsif (substr($param, 0, 1) eq '"' and substr($param, length($param) - 1, 1) eq '"') {
# Single-word string.
$param = substr($param, 1, length($ebuf[1]) - 2);
}
elsif ($param =~ m/[0-9]/) {
# Numeric.
$param =~ s/[^0-9.]//g;
}
else {
# Garbage.
next;
}
my @param = ($param);
unless (!$blk) {
# We're inside a block.
if ($blk =~ m/@@@/) {
# We're inside a block with a parameter.
my @sblk = split('@@@', $blk);
# Check to see if this config option already exists.
if (defined $rs{$sblk[0]}{$sblk[1]}{$ebuf[0]}) {
# It does, so merely push this second one to the existing array.
push(@{ $rs{$sblk[0]}{$sblk[1]}{$ebuf[0]} }, $param);
}
else {
# It doesn't, create it as an array.
@{ $rs{$sblk[0]}{$sblk[1]}{$ebuf[0]} } = @param;
}
}
else {
# We're inside a block with no parameter.
# Check to see if this config option already exists.
if (defined $rs{$blk}{$ebuf[0]}) {
# It does, so merely push this second one to the existing array.
# Get the path to the file.
my $self = shift;
my $file = $self->{'config'}->{'path'};
my $blk = 0;
my (%rs);
# Open, read and close it.
open(my $FCONF, q{<}, "$file") or return 0;
my @fbuf = <$FCONF> or return 0;
close $FCONF or return 0;
# Iterate the file.
foreach my $buff (@fbuf) {
# Main newline buffer.
if (defined $buff) {
# If the line begins with a #, it's a comment so ignore it.
if (substr($buff, 0, 1) eq '#') {
next;
}
if ($buff =~ m/;/) {
# Semicolon buffer.
my @asbuf = split(';', $buff);
foreach my $asbuff (@asbuf) {
if (defined $asbuff) {
# Space buffer.
my @ebuf = split(' ', $asbuff);
if (!defined $ebuf[0] or !defined $ebuf[1]) {
# Garbage. Ignoring.
next;
}
my $param = $ebuf[1];
if (substr($param, 0, 1) eq '"' and substr($param, length($param) - 1, 1) ne '"') {
# Multi-word string.
$param = substr($param, 1);
for (my $i = 2; $i < scalar(@ebuf); $i++) {
if (substr($ebuf[$i], length($ebuf[$i]) - 1, 1) eq '"') {
$param .= " ".substr($ebuf[$i], 0, length($ebuf[$i]) - 1);
last;
}
else {
$param .= " ".$ebuf[$i];
}
}
}
elsif (substr($param, 0, 1) eq '"' and substr($param, length($param) - 1, 1) eq '"') {
# Single-word string.
$param = substr($param, 1, length($ebuf[1]) - 2);
}
elsif ($param =~ m/[0-9]/) {
# Numeric.
$param =~ s/[^0-9.]//g;
}
else {
# Garbage.
next;
}
my @param = ($param);
unless (!$blk) {
# We're inside a block.
if ($blk =~ m/@@@/) {
# We're inside a block with a parameter.
my @sblk = split('@@@', $blk);
# Check to see if this config option already exists.
if (defined $rs{$sblk[0]}{$sblk[1]}{$ebuf[0]}) {
# It does, so merely push this second one to the existing array.
push(@{ $rs{$sblk[0]}{$sblk[1]}{$ebuf[0]} }, $param);
}
else {
# It doesn't, create it as an array.
@{ $rs{$sblk[0]}{$sblk[1]}{$ebuf[0]} } = @param;
}
}
else {
# We're inside a block with no parameter.
# Check to see if this config option already exists.
if (defined $rs{$blk}{$ebuf[0]}) {
# It does, so merely push this second one to the existing array.
push(@{ $rs{$blk}{$ebuf[0]} }, $param);
}
else {
# It doesn't, create it as an array.
@{ $rs{$blk}{$ebuf[0]} } = @param;
}
}
}
else {
# We're not inside a block.
# Check to see if this config option already exists.
if (defined $rs{$ebuf[0]}) {
# It does, so merely push this second one to the existing array.
push(@{ $rs{$ebuf[0]} }, $param);
}
else {
# It doesn't, create it as an array.
@{ $rs{$ebuf[0]} } = @param;
}
}
}
}
}
else {
# No semicolon space buffer.
my @ebuf = split(' ', $buff);
if (!defined $ebuf[0]) {
# Garbage. Ignoring.
next;
}
if (defined $ebuf[1]) {
if ($ebuf[1] eq '{') {
# This is the beginning of a block with no parameter.
}
else {
# It doesn't, create it as an array.
@{ $rs{$blk}{$ebuf[0]} } = @param;
}
}
}
else {
# We're not inside a block.
# Check to see if this config option already exists.
if (defined $rs{$ebuf[0]}) {
# It does, so merely push this second one to the existing array.
push(@{ $rs{$ebuf[0]} }, $param);
}
else {
# It doesn't, create it as an array.
@{ $rs{$ebuf[0]} } = @param;
}
}
}
}
}
else {
# No semicolon space buffer.
my @ebuf = split(' ', $buff);
if (!defined $ebuf[0]) {
# Garbage. Ignoring.
next;
}
if (defined $ebuf[1]) {
if ($ebuf[1] eq '{') {
# This is the beginning of a block with no parameter.
$blk = $ebuf[0];
}
elsif (defined $ebuf[2]) {
if ($ebuf[2] eq '{') {
# This is the beginning of a block with a parameter.
my $param = $ebuf[1];
$param =~ s/"//g;
$blk = $ebuf[0].'@@@'.$param;
}
}
}
if ($ebuf[0] eq '}') {
# This is the end of a block.
$blk = 0;
}
}
}
}
# Return the configuration data.
return %rs;
}
elsif (defined $ebuf[2]) {
if ($ebuf[2] eq '{') {
# This is the beginning of a block with a parameter.
my $param = $ebuf[1];
$param =~ s/"//g;
$blk = $ebuf[0].'@@@'.$param;
}
}
}
if ($ebuf[0] eq '}') {
# This is the end of a block.
$blk = 0;
}
}
}
}
# Return the configuration data.
return %rs;
}
+343 -295
View File
@@ -9,26 +9,26 @@ use API::IRC;
# Raw parsing hash.
our %RAWC = (
'001' => \&num001,
'005' => \&num005,
'353' => \&num353,
'432' => \&num432,
'433' => \&num433,
'438' => \&num438,
'465' => \&num465,
'471' => \&num471,
'473' => \&num473,
'474' => \&num474,
'475' => \&num475,
'477' => \&num477,
'JOIN' => \&cjoin,
'001' => \&num001,
'005' => \&num005,
'353' => \&num353,
'432' => \&num432,
'433' => \&num433,
'438' => \&num438,
'465' => \&num465,
'471' => \&num471,
'473' => \&num473,
'474' => \&num474,
'475' => \&num475,
'477' => \&num477,
'JOIN' => \&cjoin,
'KICK' => \&kick,
'MODE' => \&mode,
'NICK' => \&nick,
'NOTICE' => \&notice,
'NICK' => \&nick,
'NOTICE' => \&notice,
'PART' => \&part,
'PRIVMSG' => \&privmsg,
'QUIT' => \&quit,
'PRIVMSG' => \&privmsg,
'QUIT' => \&quit,
'TOPIC' => \&topic,
);
@@ -50,33 +50,33 @@ API::Std::event_add("on_topic");
# Parse raw data.
sub ircparse
{
my ($svr, $data) = @_;
# Split spaces into @ex.
my @ex = split(' ', $data);
# Make sure there is enough data.
if (defined $ex[0] and defined $ex[1]) {
# If it's a ping...
if ($ex[0] eq 'PING') {
# send a PONG.
Auto::socksnd($svr, "PONG ".$ex[1]);
}
# If it's AUTHENTICATE
elsif ($ex[0] eq 'AUTHENTICATE') {
if (API::Std::mod_exists("SASLAuth")) {
m_SASLAuth::handle_authenticate($svr, @ex);
}
}
else {
# otherwise, check %RAWC for ex[1].
if (defined $RAWC{$ex[1]}) {
&{ $RAWC{$ex[1]} }($svr, @ex);
}
}
}
return 1;
my ($svr, $data) = @_;
# Split spaces into @ex.
my @ex = split /\s+/, $data;
# Make sure there is enough data.
if (defined $ex[0] and defined $ex[1]) {
# If it's a ping...
if ($ex[0] eq 'PING') {
# send a PONG.
Auto::socksnd($svr, "PONG ".$ex[1]);
}
# If it's AUTHENTICATE
elsif ($ex[0] eq 'AUTHENTICATE') {
if (API::Std::mod_exists("SASLAuth")) {
M::SASLAuth::handle_authenticate($svr, @ex);
}
}
else {
# otherwise, check %RAWC for ex[1].
if (defined $RAWC{$ex[1]}) {
&{ $RAWC{$ex[1]} }($svr, @ex);
}
}
}
return 1;
}
###########################
@@ -87,41 +87,41 @@ sub ircparse
# Successful connection.
sub num001
{
my ($svr, @ex) = @_;
$got_001{$svr} = 1;
# In case we don't get NICK from the server.
if (defined $botnick{$svr}{newnick}) {
$botnick{$svr}{nick} = $botnick{$svr}{newnick};
delete $botnick{$svr}{newnick};
}
my ($svr, @ex) = @_;
$got_001{$svr} = 1;
# In case we don't get NICK from the server.
if (defined $botnick{$svr}{newnick}) {
$botnick{$svr}{nick} = $botnick{$svr}{newnick};
delete $botnick{$svr}{newnick};
}
# Trigger on_connect.
API::Std::event_run("on_connect", $svr);
return 1;
return 1;
}
# Parse: Numeric:005
# Prefixes and channel modes.
sub num005
{
my ($svr, @ex) = @_;
# Find PREFIX and CHANMODES.
foreach my $ex (@ex) {
if ($ex =~ m/^PREFIX/xsm) {
# Found PREFIX.
my $rpx = substr($ex, 8);
my ($pm, $pp) = split('\)', $rpx);
my @apm = split(//, $pm);
my @app = split(//, $pp);
foreach my $ppm (@apm) {
# Store data.
$csprefix{$svr}{$ppm} = shift(@app);
}
}
my ($svr, @ex) = @_;
# Find PREFIX and CHANMODES.
foreach my $ex (@ex) {
if ($ex =~ m/^PREFIX/xsm) {
# Found PREFIX.
my $rpx = substr($ex, 8);
my ($pm, $pp) = split('\)', $rpx);
my @apm = split(//, $pm);
my @app = split(//, $pp);
foreach my $ppm (@apm) {
# Store data.
$csprefix{$svr}{$ppm} = shift(@app);
}
}
elsif ($ex =~ m/^CHANMODES/xsm) {
# Found CHANMODES.
my ($mtl, $mtp, $mtpp, $mts) = split m/[,]/xsm, substr($ex, 10);
@@ -134,183 +134,186 @@ sub num005
# Modes without parameter.
foreach (split(//, $mts)) { $chanmodes{$svr}{$_} = 4; }
}
}
return 1;
}
return 1;
}
# Parse: Numeric:353
# NAMES reply.
sub num353
{
my ($svr, @ex) = @_;
# Get rid of the colon.
$ex[5] = substr($ex[5], 1);
# Delete the old chanusers hash if it exists.
delete $chanusers{$svr}{$ex[4]} if (defined $chanusers{$svr}{$ex[4]});
# Iterate through each user.
for (my $i = 5; $i < scalar(@ex); $i++) {
my $fi = 0;
foreach (keys %{ $csprefix{$svr} }) {
# Check if the user has status in the channel.
if (substr($ex[$i], 0, 1) eq $csprefix{$svr}{$_}) {
# He/she does. Lets set that.
if (defined $chanusers{$svr}{$ex[4]}{lc(substr($ex[$i], 1))}) {
# If the user has multiple statuses.
$chanusers{$svr}{$ex[4]}{lc(substr($ex[$i], 1))} .= $_;
}
else {
# Or not.
$chanusers{$svr}{$ex[4]}{lc(substr($ex[$i], 1))} = $_;
}
$fi = 1;
}
}
# They had status, so go to the next user.
next if $fi;
# They didn't, set them as a normal user.
if (!defined $chanusers{$svr}{$ex[4]}{lc($ex[$i])}) {
$chanusers{$svr}{$ex[4]}{lc($ex[$i])} = 1;
}
}
return 1;
my ($svr, @ex) = @_;
# Get rid of the colon.
$ex[5] = substr($ex[5], 1);
# Delete the old chanusers hash if it exists.
delete $chanusers{$svr}{$ex[4]} if (defined $chanusers{$svr}{$ex[4]});
# Iterate through each user.
for (my $i = 5; $i < scalar(@ex); $i++) {
my $fi = 0;
foreach (keys %{ $csprefix{$svr} }) {
# Check if the user has status in the channel.
if (substr($ex[$i], 0, 1) eq $csprefix{$svr}{$_}) {
# He/she does. Lets set that.
if (defined $chanusers{$svr}{$ex[4]}{lc(substr($ex[$i], 1))}) {
# If the user has multiple statuses.
$chanusers{$svr}{$ex[4]}{lc(substr($ex[$i], 1))} .= $_;
}
else {
# Or not.
$chanusers{$svr}{$ex[4]}{lc(substr($ex[$i], 1))} = $_;
}
$fi = 1;
}
}
# They had status, so go to the next user.
next if $fi;
# They didn't, set them as a normal user.
if (!defined $chanusers{$svr}{$ex[4]}{lc($ex[$i])}) {
$chanusers{$svr}{$ex[4]}{lc($ex[$i])} = 1;
}
}
return 1;
}
# Parse: Numeric:432
# Erroneous nickname.
sub num432
{
my ($svr, undef) = @_;
if ($got_001{$svr}) {
err(3, "Got error from server[".$svr."]: Erroneous nickname.", 0);
}
else {
err(2, "Got error from server[".$svr."] before 001: Erroneous nickname. Closing connection.", 0);
API::IRC::quit($svr, "An error occurred.");
}
delete $botnick{$svr}{newnick} if (defined $botnick{$svr}{newnick});
return 1;
my ($svr, undef) = @_;
if ($got_001{$svr}) {
err(3, "Got error from server[".$svr."]: Erroneous nickname.", 0);
}
else {
err(2, "Got error from server[".$svr."] before 001: Erroneous nickname. Closing connection.", 0);
API::IRC::quit($svr, "An error occurred.");
}
delete $botnick{$svr}{newnick} if (defined $botnick{$svr}{newnick});
return 1;
}
# Parse: Numeric:433
# Nickname is already in use.
sub num433
{
my ($svr, undef) = @_;
if (defined $botnick{$svr}{newnick}) {
API::IRC::nick($svr, $botnick{$svr}{newnick}."_");
delete $botnick{$svr}{newnick} if (defined $botnick{$svr}{newnick});
}
return 1;
my ($svr, undef) = @_;
if (defined $botnick{$svr}{newnick}) {
API::IRC::nick($svr, $botnick{$svr}{newnick}."_");
delete $botnick{$svr}{newnick} if (defined $botnick{$svr}{newnick});
}
return 1;
}
# Parse: Numeric:438
# Nick change too fast.
sub num438
{
my ($svr, @ex) = @_;
if (defined $botnick{$svr}{newnick}) {
API::Std::timer_add("num438_".$botnick{$svr}{newnick}, 1, $ex[11], sub {
API::IRC::nick($Parser::IRC::botnick{$svr}{newnick});
delete $botnick{$svr}{newnick} if (defined $botnick{$svr}{newnick});
});
}
return 1;
my ($svr, @ex) = @_;
if (defined $botnick{$svr}{newnick}) {
API::Std::timer_add("num438_".$botnick{$svr}{newnick}, 1, $ex[11], sub {
API::IRC::nick($Parser::IRC::botnick{$svr}{newnick});
delete $botnick{$svr}{newnick} if (defined $botnick{$svr}{newnick});
});
}
return 1;
}
# Parse: Numeric:465
# You're banned creep!
sub num465
{
my ($svr, undef) = @_;
err(3, "Banned from ".$svr."! Closing link...", 0);
return 1;
my ($svr, undef) = @_;
err(3, "Banned from ".$svr."! Closing link...", 0);
return 1;
}
# Parse: Numeric:471
# Cannot join channel: Channel is full.
sub num471
{
my ($svr, (undef, undef, undef, $chan)) = @_;
err(3, "Cannot join channel ".$chan." on ".$svr.": Channel is full.", 0);
return 1;
my ($svr, (undef, undef, undef, $chan)) = @_;
err(3, "Cannot join channel ".$chan." on ".$svr.": Channel is full.", 0);
return 1;
}
# Parse: Numeric:473
# Cannot join channel: Channel is invite-only.
sub num473
{
my ($svr, (undef, undef, undef, $chan)) = @_;
err(3, "Cannot join channel ".$chan." on ".$svr.": Channel is invite-only.", 0);
return 1;
my ($svr, (undef, undef, undef, $chan)) = @_;
err(3, "Cannot join channel ".$chan." on ".$svr.": Channel is invite-only.", 0);
return 1;
}
# Parse: Numeric:474
# Cannot join channel: Banned from channel.
sub num474
{
my ($svr, (undef, undef, undef, $chan)) = @_;
err(3, "Cannot join channel ".$chan." on ".$svr.": Banned from channel.", 0);
return 1;
my ($svr, (undef, undef, undef, $chan)) = @_;
err(3, "Cannot join channel ".$chan." on ".$svr.": Banned from channel.", 0);
return 1;
}
# Parse: Numeric:475
# Cannot join channel: Bad key.
sub num475
{
my ($svr, (undef, undef, undef, $chan)) = @_;
err(3, "Cannot join channel ".$chan." on ".$svr.": Bad key.", 0);
return 1;
my ($svr, (undef, undef, undef, $chan)) = @_;
err(3, "Cannot join channel ".$chan." on ".$svr.": Bad key.", 0);
return 1;
}
# Parse: Numeric:477
# Cannot join channel: Need registered nickname.
sub num477
{
my ($svr, (undef, undef, undef, $chan)) = @_;
err(3, "Cannot join channel ".$chan." on ".$svr.": Need registered nickname.", 0);
return 1;
my ($svr, (undef, undef, undef, $chan)) = @_;
err(3, "Cannot join channel ".$chan." on ".$svr.": Need registered nickname.", 0);
return 1;
}
# Parse: JOIN
sub cjoin
{
my ($svr, @ex) = @_;
my %src = API::IRC::usrc(substr($ex[0], 1));
# Check if this is coming from ourselves.
if ($src{nick} eq $botnick{$svr}{nick}) {
$botchans{$svr}{substr $ex[2], 1} = 1;
API::Std::event_run("on_ucjoin", ($svr, substr($ex[2], 1)));
}
else {
# It isn't. Update chanusers and trigger on_rcjoin.
$chanusers{$svr}{substr $ex[2], 1}{$src{nick}} = 1;
API::Std::event_run("on_rcjoin", ($svr, \%src, substr($ex[2], 1)));
}
return 1;
my ($svr, @ex) = @_;
my %src = API::IRC::usrc(substr($ex[0], 1));
my $chan = $ex[2];
$chan =~ s/^://gxsm;
# Check if this is coming from ourselves.
if ($src{nick} eq $botnick{$svr}{nick}) {
$botchans{$svr}{lc $chan} = 1;
API::Std::event_run("on_ucjoin", ($svr, $chan));
}
else {
# It isn't. Update chanusers and trigger on_rcjoin.
$chanusers{$svr}{lc $chan}{$src{nick}} = 1;
$src{svr} = $svr;
API::Std::event_run("on_rcjoin", (\%src, $chan));
}
return 1;
}
# Parse: KICK
@@ -451,39 +454,50 @@ sub mode
# Parse: NICK
sub nick
{
my ($svr, ($uex, undef, $nex)) = @_;
my ($svr, ($uex, undef, $nex)) = @_;
$nex = substr($nex, 1);
my %src = API::IRC::usrc(substr($uex, 1));
# Check if this is coming from ourselves.
if ($src{nick} eq $botnick{$svr}{nick}) {
# It is. Update bot nick hash.
$botnick{$svr}{nick} = $nex;
delete $botnick{$svr}{newnick} if (defined $botnick{$svr}{newnick});
}
else {
# It isn't. Update chanusers and trigger on_nick.
my %src = API::IRC::usrc(substr($uex, 1));
# Check if this is coming from ourselves.
if ($src{nick} eq $botnick{$svr}{nick}) {
# It is. Update bot nick hash.
$botnick{$svr}{nick} = $nex;
delete $botnick{$svr}{newnick} if (defined $botnick{$svr}{newnick});
}
else {
# It isn't. Update chanusers and trigger on_nick.
foreach my $chk (keys %{ $chanusers{$svr} }) {
if (defined $chanusers{$svr}{$chk}{$src{nick}}) {
$chanusers{$svr}{$chk}{$nex} = $chanusers{$svr}{$chk}{$src{nick}};
delete $chanusers{$svr}{$chk}{$src{nick}};
}
}
API::Std::event_run("on_nick", ($svr, \%src, $nex));
}
return 1;
API::Std::event_run("on_nick", ($svr, \%src, $nex));
}
return 1;
}
# Parse: NOTICE
sub notice
{
my ($svr, @ex) = @_;
API::Std::event_run("on_notice", ($svr, @ex));
return 1;
my ($svr, @ex) = @_;
# Ensure this is coming from a user rather than a server.
if ($ex[0] !~ m/!/xsm) { return; }
# Prepare all the data.
my %src = API::IRC::usrc(substr $ex[0], 1);
my $target = $ex[2];
shift @ex; shift @ex; shift @ex;
$ex[0] = substr $ex[0], 1;
$src{svr} = $svr;
# Send it off.
API::Std::event_run("on_notice", (\%src, $target, @ex));
return 1;
}
# Parse: PART
@@ -515,102 +529,136 @@ sub part
# Parse: PRIVMSG
sub privmsg
{
my ($svr, @ex) = @_;
my %data = API::IRC::usrc(substr($ex[0], 1));
my ($svr, @ex) = @_;
my %data = API::IRC::usrc(substr($ex[0], 1));
my @argv;
for (my $i = 4; $i < scalar(@ex); $i++) {
push(@argv, $ex[$i]);
}
$data{svr} = $svr;
@{ $data{args} } = @argv;
my ($cmd, $cprefix, $rprefix);
# Check if it's to a channel or to us.
if (lc($ex[2]) eq lc($botnick{$svr}{nick})) {
# It is coming to us in a private message.
$cmd = uc(substr($ex[3], 1));
if (defined $API::Std::CMDS{$cmd}) {
# If this is indeed a command, continue.
if ($API::Std::CMDS{$cmd}{lvl} == 1 or $API::Std::CMDS{$cmd}{lvl} == 2) {
# Ensure the level is private or all.
if (!defined $Core::IRC::usercmd{$data{nick}.'@'.$data{host}}) { $Core::IRC::usercmd{$data{nick}.'@'.$data{host}} = 0; }
if (API::Std::ratelimit_check(%data)) {
# Continue if the user has not passed the ratelimit amount.
if ($API::Std::CMDS{$cmd}{priv}) {
# If this command requires a privilege...
if (API::Std::has_priv(API::Std::match_user(%data), $API::Std::CMDS{$cmd}{priv})) {
# Make sure they have it.
&{ $API::Std::CMDS{$cmd}{'sub'} }(%data);
# Ensure this is coming from a user rather than a server.
if ($ex[0] !~ m/!/xsm) { return; }
my @argv;
for (my $i = 4; $i < scalar(@ex); $i++) {
push(@argv, $ex[$i]);
}
$data{svr} = $svr;
my ($cmd, $cprefix, $rprefix);
# Check if it's to a channel or to us.
if (lc($ex[2]) eq lc($botnick{$svr}{nick})) {
# It is coming to us in a private message.
# Ensure it's a valid length.
if (length($ex[3]) > 1) {
$cmd = uc(substr($ex[3], 1));
if (defined $API::Std::CMDS{$cmd}) {
# If this is indeed a command, continue.
if ($API::Std::CMDS{$cmd}{lvl} == 1 or $API::Std::CMDS{$cmd}{lvl} == 2) {
# Ensure the level is private or all.
if (API::Std::ratelimit_check(%data)) {
# Continue if the user has not passed the ratelimit amount.
if ($API::Std::CMDS{$cmd}{priv}) {
# If this command requires a privilege...
if (API::Std::has_priv(API::Std::match_user(%data), $API::Std::CMDS{$cmd}{priv})) {
# Make sure they have it.
&{ $API::Std::CMDS{$cmd}{'sub'} }(\%data, @argv);
}
else {
# Else give them the boot.
API::IRC::notice($data{svr}, $data{nick}, API::Std::trans("Permission denied").".");
}
}
else {
# Else give them the boot.
API::IRC::notice($data{svr}, $data{nick}, API::Std::trans("Permission denied").".");
# Else execute the command without any extra checks.
&{ $API::Std::CMDS{$cmd}{'sub'} }(\%data, @argv);
}
}
else {
# Else execute the command without any extra checks.
&{ $API::Std::CMDS{$cmd}{'sub'} }(%data);
# Send them a notice about their bad deed.
API::IRC::notice($data{svr}, $data{nick}, trans('Rate limit exceeded').q{.});
}
}
else {
# Send them a notice about their bad deed.
API::IRC::notice($data{svr}, $data{nick}, trans('Rate limit exceeded').q{.});
}
}
}
# Trigger event on_uprivmsg.
API::Std::event_run("on_uprivmsg", ($svr, @ex));
}
else {
# It is coming to us in a channel message.
$data{chan} = $ex[2];
$cprefix = (conf_get("fantasy_pf"))[0][0];
$rprefix = substr($ex[3], 1, 1);
$cmd = uc(substr($ex[3], 2));
if (defined $API::Std::CMDS{$cmd}) {
# If this is indeed a command, continue.
if ($API::Std::CMDS{$cmd}{lvl} == 0 or $API::Std::CMDS{$cmd}{lvl} == 2) {
# Ensure the level is public or all.
if (!defined $Core::IRC::usercmd{$data{nick}.'@'.$data{host}}) { $Core::IRC::usercmd{$data{nick}.'@'.$data{host}} = 0; }
if (API::Std::ratelimit_check(%data)) {
# Continue if the user has not passed the ratelimit amount.
if ($API::Std::CMDS{$cmd}{priv}) {
# If this command takes a privilege...
if (API::Std::has_priv(API::Std::match_user(%data), $API::Std::CMDS{$cmd}{priv})) {
# Make sure they have it.
&{ $API::Std::CMDS{$cmd}{'sub'} }(%data) if $rprefix eq $cprefix;
}
}
}
# Trigger event on_uprivmsg.
shift @ex; shift @ex; shift @ex;
$ex[0] = substr $ex[0], 1;
API::Std::event_run("on_uprivmsg", (\%data, @ex));
}
else {
# It is coming to us in a channel message.
$data{chan} = $ex[2];
# Ensure it's a valid length before continuing.
if (length($ex[3]) > 1) {
$cprefix = (conf_get("fantasy_pf"))[0][0];
$rprefix = substr($ex[3], 1, 1);
$cmd = uc(substr($ex[3], 2));
if (defined $API::Std::CMDS{$cmd} and $rprefix eq $cprefix) {
# If this is indeed a command, continue.
if ($API::Std::CMDS{$cmd}{lvl} == 0 or $API::Std::CMDS{$cmd}{lvl} == 2) {
# Ensure the level is public or all.
if (API::Std::ratelimit_check(%data)) {
# Continue if the user has not passed the ratelimit amount.
if ($API::Std::CMDS{$cmd}{priv}) {
# If this command takes a privilege...
if (API::Std::has_priv(API::Std::match_user(%data), $API::Std::CMDS{$cmd}{priv})) {
# Make sure they have it.
&{ $API::Std::CMDS{$cmd}{'sub'} }(\%data, @argv);
}
else {
# Else give them the boot.
API::IRC::notice($data{svr}, $data{nick}, API::Std::trans('Permission denied').q{.});
}
}
else {
# Else give them the boot.
API::IRC::notice($data{svr}, $data{nick}, API::Std::trans("Permission denied").".");
else {
# Else continue executing without any extra checks.
&{ $API::Std::CMDS{$cmd}{'sub'} }(\%data, @argv);
}
}
else {
# Else continue executing without any extra checks.
&{ $API::Std::CMDS{$cmd}{'sub'} }(%data) if $rprefix eq $cprefix;
# Send them a notice about their bad deed.
API::IRC::notice($data{svr}, $data{nick}, trans('Rate limit exceeded').q{.});
}
}
else {
# Send them a notice about their bad deed.
API::IRC::notice($data{svr}, $data{nick}, trans('Rate limit exceeded').q{.});
elsif ($API::Std::CMDS{$cmd}{lvl} == 3) {
# Or if it's a logchan command...
my ($lcn, $lcc) = split '/', (conf_get('logchan'))[0][0];
if ($lcn eq $data{svr} and lc $lcc eq lc $data{chan}) {
# Check if it's being sent from the logchan.
if ($API::Std::CMDS{$cmd}{priv}) {
# If this command takes a privilege...
if (API::Std::has_priv(API::Std::match_user(%data), $API::Std::CMDS{$cmd}{priv})) {
# Make sure they have it.
&{ $API::Std::CMDS{$cmd}{'sub'} }(\%data, @argv);
}
else {
# Else give them the boot.
API::IRC::notice($data{svr}, $data{nick}, API::Std::trans('Permission denied').q{.});
}
}
else {
# Else continue executing without any extra checks.
&{ $API::Std::CMDS{$cmd}{'sub'} }(\%data, @argv);
}
}
}
}
}
# Trigger event on_cprivmsg.
API::Std::event_run("on_cprivmsg", ($svr, @ex));
}
return 1;
}
}
# Trigger event on_cprivmsg.
my $target = $ex[2]; delete $data{chan};
shift @ex; shift @ex; shift @ex;
$ex[0] = substr $ex[0], 1;
API::Std::event_run("on_cprivmsg", (\%data, $target, @ex));
}
return 1;
}
# Parse: QUIT
sub quit
{
my ($svr, @ex) = @_;
my %src = API::IRC::usrc(substr($ex[0], 1));
my %src = API::IRC::usrc(substr($ex[0], 1));
# Set $msg to the quit message.
my $msg = 0;
@@ -632,23 +680,23 @@ sub quit
# Parse: TOPIC
sub topic
{
my ($svr, @ex) = @_;
my %src = API::IRC::usrc(substr($ex[0], 1));
# Ignore it if it's coming from us.
if (lc($src{nick}) ne lc($botnick{$svr}{nick})) {
$src{chan} = $ex[2];
my (@argv);
$argv[0] = substr($ex[3], 1);
if (defined $ex[4]) {
for (my $i = 4; $i < scalar(@ex); $i++) {
push(@argv, $ex[$i]);
}
}
API::Std::event_run("on_topic", ($svr, \%src, @argv));
}
return 1;
my ($svr, @ex) = @_;
my %src = API::IRC::usrc(substr($ex[0], 1));
# Ignore it if it's coming from us.
if (lc($src{nick}) ne lc($botnick{$svr}{nick})) {
$src{chan} = $ex[2];
my (@argv);
$argv[0] = substr($ex[3], 1);
if (defined $ex[4]) {
for (my $i = 4; $i < scalar(@ex); $i++) {
push(@argv, $ex[$i]);
}
}
API::Std::event_run("on_topic", ($svr, \%src, @argv));
}
return 1;
}
+50 -50
View File
@@ -10,56 +10,56 @@ use API::Log qw(dbug alog);
# Parser.
sub parse
{
my ($lang) = @_;
# Check that the language file exists.
unless (-e "$Auto::Bin/../lang/$lang.alf") {
# Otherwise, use English.
dbug "Language '$lang' not found. Using English.";
alog "Language '$lang' not found. Using English.";
$lang = "en";
}
# Open, read and close the file.
open(my $FALF, q{<}, "$Auto::Bin/../lang/$lang.alf") or return 0;
my @fbuf = <$FALF>;
close $FALF;
# Iterate the file buffer.
foreach my $buff (@fbuf) {
if (defined $buff) {
# Space buffer.
my @sbuf = split(' ', $buff);
# Check for all required values.
if (!defined $sbuf[0] or !defined $sbuf[1] or !defined $sbuf[2]) {
# Missing a value.
next;
}
# Make sure the first value is "msge".
if ($sbuf[0] ne "msge") {
# It isn't.
next;
}
my $id = $sbuf[1];
my $val = $sbuf[2];
# If the translation is multi-word, continue to parse.
if (defined $sbuf[3]) {
for (my $i = 3; $i < scalar(@sbuf); $i++) {
$val .= " ".$sbuf[$i];
}
}
# Save to memory.
$id =~ s/"//g;
$val =~ s/"//g;
$API::Std::LANGE{$id} = $val;
}
}
return 1;
my ($lang) = @_;
# Check that the language file exists.
unless (-e "$Auto::Bin/../lang/$lang.alf") {
# Otherwise, use English.
dbug "Language '$lang' not found. Using English.";
alog "Language '$lang' not found. Using English.";
$lang = "en";
}
# Open, read and close the file.
open(my $FALF, q{<}, "$Auto::Bin/../lang/$lang.alf") or return 0;
my @fbuf = <$FALF>;
close $FALF;
# Iterate the file buffer.
foreach my $buff (@fbuf) {
if (defined $buff) {
# Space buffer.
my @sbuf = split(' ', $buff);
# Check for all required values.
if (!defined $sbuf[0] or !defined $sbuf[1] or !defined $sbuf[2]) {
# Missing a value.
next;
}
# Make sure the first value is "msge".
if ($sbuf[0] ne "msge") {
# It isn't.
next;
}
my $id = $sbuf[1];
my $val = $sbuf[2];
# If the translation is multi-word, continue to parse.
if (defined $sbuf[3]) {
for (my $i = 3; $i < scalar(@sbuf); $i++) {
$val .= " ".$sbuf[$i];
}
}
# Save to memory.
$id =~ s/"//g;
$val =~ s/"//g;
$API::Std::LANGE{$id} = $val;
}
}
return 1;
}
+20 -22
View File
@@ -1,23 +1,23 @@
# Module: Badwords. See below for documentation.
# Copyright (C) 2010-2011 Xelhua Development Group, et al.
# This program is free software; rights to this code are stated in doc/LICENSE.
package m_Badwords;
package M::Badwords;
use strict;
use warnings;
use feature qw(switch);
use API::Std qw(hook_add hook_del conf_get err);
use API::IRC qw(privmsg notice kick cmode);
use API::IRC qw(privmsg notice kick ban);
# Initialization subroutine.
sub _init
{
# Check for required configuration values.
if (!conf_get('badwords')) {
err(2, 'Please verify that you have a badwords block with word entries defined in your configuration file.', 0);
return;
}
if (!conf_get('badwords')) {
err(2, 'Please verify that you have a badwords block with word entries defined in your configuration file.', 0);
return;
}
# Create the act_on_badword hook.
hook_add('on_cprivmsg', 'act_on_badword', \&m_Badwords::actonbadword) or return;
hook_add('on_cprivmsg', 'act_on_badword', \&M::Badwords::actonbadword) or return;
# Success.
return 1;
@@ -27,23 +27,21 @@ sub _init
sub _void
{
# Delete the act_on_badword hook.
hook_del('act_on_badword') or return 0;
hook_del('act_on_badword') or return 0;
# Success.
return 1;
return 1;
}
# Callback for act_on_badword hook.
sub actonbadword
{
my (($svr, @ex)) = @_;
my %src = API::IRC::usrc(substr $ex[0], 1);
my (($src, $chan, @msg)) = @_;
my $msg = substr $ex[3], 1;
for (my $i = 4; $i < scalar @ex; $i++) { $msg .= q{ }.$ex[$i]; }
my $msg = join ' ', @msg;
if (conf_get("badwords:$ex[2]:word")) {
my @words = @{ (conf_get("badwords:$ex[2]:word"))[0] };
if (conf_get("badwords:$chan:word")) {
my @words = @{ (conf_get("badwords:$chan:word"))[0] };
foreach (@words) {
my ($w, $a) = split m/[:]/, $_;
@@ -51,17 +49,17 @@ sub actonbadword
if ($msg =~ m/($w)/ixsm) {
given ($a) {
when ('kick') {
kick($svr, $ex[2], $src{nick}, 'Foul language is prohibited here.');
kick($src->{svr}, $chan, $src->{nick}, 'Foul language is prohibited here.');
}
when ('kickban') {
cmode($svr, $ex[2], '+b *!*@'.$src{host});
kick($svr, $ex[2], $src{nick}, 'Foul language is prohibited here.');
ban($src->{svr}, $chan, 'b', $src);
kick($src->{svr}, $chan, $src->{nick}, 'Foul language is prohibited here.');
}
when ('quiet') {
cmode($svr, $ex[2], '+q *!*@'.$src{host});
ban($src->{svr}, $chan, 'q', $src);
}
default {
kick($svr, $ex[2], $src{nick}, 'Foul language is prohibited here.');
kick($src->{svr}, $chan, $src->{nick}, 'Foul language is prohibited here.');
}
}
}
@@ -72,7 +70,7 @@ sub actonbadword
}
API::Std::mod_init("Badwords", "Xelhua", "1.00", "3.0.0d", __PACKAGE__);
API::Std::mod_init('Badwords', 'Xelhua', '1.00', '3.0.0a4', __PACKAGE__);
# vim: set ai sw=4 ts=4:
# build: perl=5.010000
@@ -124,6 +122,6 @@ Changing the obvious to your wish.
=over
This module is compatible with Auto version 3.0.0a3+.
This module is compatible with Auto version 3.0.0a4+.
=back
+36 -38
View File
@@ -1,7 +1,7 @@
# Module: Bitly. See below for documentation.
# Copyright (C) 2010-2011 Xelhua Development Group, et al.
# This program is free software; rights to this code are stated in doc/LICENSE.
package m_Bitly;
package M::Bitly;
use strict;
use warnings;
use API::Std qw(cmd_add cmd_del conf_get err trans);
@@ -13,13 +13,13 @@ use URI::Escape;
sub _init
{
# Check for required configuration values.
if (!(conf_get('bitly:user'))[0][0] or !(conf_get('bitly:key'))[0][0]) {
err(2, "Please verify that you have bitly_user and bitly_key defined in your configuration file.", 0);
return 0;
}
if (!(conf_get('bitly:user'))[0][0] or !(conf_get('bitly:key'))[0][0]) {
err(2, "Please verify that you have bitly_user and bitly_key defined in your configuration file.", 0);
return 0;
}
# Create the SHORTEN and REVERSE commands.
cmd_add("SHORTEN", 0, 0, \%m_Bitly::HELP_SHORTEN, \&m_Bitly::shorten) or return 0;
cmd_add("REVERSE", 0, 0, \%m_Bitly::HELP_REVERSE, \&m_Bitly::reverse) or return 0;
cmd_add("SHORTEN", 0, 0, \%M::Bitly::HELP_SHORTEN, \&M::Bitly::shorten) or return 0;
cmd_add("REVERSE", 0, 0, \%M::Bitly::HELP_REVERSE, \&M::Bitly::reverse) or return 0;
# Success.
return 1;
@@ -29,11 +29,11 @@ sub _init
sub _void
{
# Delete the SHORTEN and REVERSE commands.
cmd_del("SHORTEN") or return 0;
cmd_del("REVERSE") or return 0;
cmd_del("SHORTEN") or return 0;
cmd_del("REVERSE") or return 0;
# Success.
return 1;
return 1;
}
# Help hashes.
@@ -47,44 +47,43 @@ our %HELP_REVERSE = (
# Callback for SHORTEN command.
sub shorten
{
my (%data) = @_;
my ($src, @args) = @_;
# Create an instance of LWP::UserAgent.
my $ua = LWP::UserAgent->new();
$ua->agent('Auto IRC Bot');
$ua->timeout(2);
my $ua = LWP::UserAgent->new();
$ua->agent('Auto IRC Bot');
$ua->timeout(2);
# Put together the call to the Bit.ly API.
my @args = @{ $data{args} };
if (!defined $args[0]) {
notice($data{svr}, $data{nick}, trans("Not enough parameters").".");
notice($src->{svr}, $src->{nick}, trans("Not enough parameters").".");
return 0;
}
my ($surl, $user, $key) = ($args[0], (conf_get('bitly:user'))[0][0], (conf_get('bitly:key'))[0][0]);
my ($surl, $user, $key) = ($args[0], (conf_get('bitly:user'))[0][0], (conf_get('bitly:key'))[0][0]);
$surl = uri_escape($surl);
my $url = "http://api.bit.ly/v3/shorten?version=3.0.1&longUrl=".$surl."&apiKey=".$key."&login=".$user."&format=txt";
my $url = "http://api.bit.ly/v3/shorten?version=3.0.1&longUrl=".$surl."&apiKey=".$key."&login=".$user."&format=txt";
# Get the response via HTTP.
my $response = $ua->get($url);
if ($response->is_success) {
if ($response->is_success) {
# If successful, decode the content.
my $d = $response->decoded_content;
chomp $d;
chomp $d;
# And send to channel.
privmsg($data{svr}, $data{chan}, "URL: ".$d);
}
privmsg($src->{svr}, $src->{chan}, "URL: ".$d);
}
else {
# Otherwise, send an error message.
privmsg($data{svr}, $data{chan}, "An error occurred while shortening your URL.");
privmsg($src->{svr}, $src->{chan}, "An error occurred while shortening your URL.");
}
return 1;
return 1;
}
# Callback for REVERSE command.
sub reverse
{
my (%data) = @_;
my ($src, @args) = @_;
# Create an instance of LWP::UserAgent.
my $ua = LWP::UserAgent->new();
@@ -92,9 +91,8 @@ sub reverse
$ua->timeout(2);
# Put together the call to the Bit.ly API.
my @args = @{ $data{args} };
if (!defined $args[0]) {
notice($data{svr}, $data{nick}, trans("Not enough parameters").".");
notice($src->{svr}, $src->{nick}, trans("Not enough parameters").".");
return 0;
}
my ($surl, $user, $key) = ($args[0], (conf_get('bitly:user'))[0][0], (conf_get('bitly:key'))[0][0]);
@@ -106,21 +104,21 @@ sub reverse
if ($response->is_success) {
# If successful, decode the content.
my $d = $response->decoded_content;
chomp $d;
chomp $d;
# And send it to channel.
privmsg($data{svr}, $data{chan}, "URL: ".$d);
}
else {
privmsg($src->{svr}, $src->{chan}, "URL: ".$d);
}
else {
# Otherwise, send an error message.
privmsg($data{svr}, $data{chan}, "An error occurred while reversing your URL.");
}
privmsg($src->{svr}, $src->{chan}, "An error occurred while reversing your URL.");
}
return 1;
return 1;
}
# Start initialization.
API::Std::mod_init("Bitly", "Xelhua", "1.00", "3.0.0d", __PACKAGE__);
API::Std::mod_init('Bitly', 'Xelhua', '1.00', '3.0.0a4', __PACKAGE__);
# vim: set ai sw=4 ts=4:
# build: cpan=LWP::UserAgent,URI::Escape perl=5.010000
@@ -178,9 +176,9 @@ Add Bitly to module auto-load and the following to your configuration file:
=over
This module adds extra dependencies: LWP::UserAgent and URI::Escape.
You can get it from the CPAN <http://www.cpan.org>.
This module adds extra dependencies: LWP::UserAgent and URI::Escape. You can
get it from the CPAN <http://www.cpan.org>.
This module is compatible with Auto version 3.0.0a2+.
This module is compatible with Auto version 3.0.0a4+.
=back
+41 -47
View File
@@ -1,7 +1,7 @@
# Module: Calc. See below for documentation.
# Copyright (C) 2010-2011 Xelhua Development Group, et al.
# This program is free software; rights to this code are stated in doc/LICENSE.
package m_Calc;
package M::Calc;
use strict;
use warnings;
use API::Std qw(cmd_add cmd_del trans);
@@ -13,78 +13,72 @@ use JSON -support_by_pp;
# Initialization subroutine.
sub _init
{
# Check for JSON::PP.
eval {
require JSON::PP;
1;
} or return 0;
# Create the CALC command.
cmd_add("CALC", 0, 0, \%m_Calc::HELP_CALC, \&m_Calc::calc) or return 0;
# Create the CALC command.
cmd_add("CALC", 0, 0, \%M::Calc::HELP_CALC, \&M::Calc::calc) or return 0;
# Success.
return 1;
# Success.
return 1;
}
# Void subroutine.
sub _void
{
# Delete the CALC command.
cmd_del("CALC") or return 0;
# Delete the CALC command.
cmd_del("CALC") or return 0;
# Success.
return 1;
# Success.
return 1;
}
# Help hash.
our %FHELP_CALC = (
'en' => "This command will calculate an expression using Google Calculator. \002Syntax:\002 CALC <expression>",
'en' => "This command will calculate an expression using Google Calculator. \002Syntax:\002 CALC <expression>",
);
# Callback for CALC command.
sub calc
{
my (%data) = @_;
my ($src, @args) = @_;
# Create an instance of LWP::UserAgent.
my $ua = LWP::UserAgent->new();
$ua->agent('Auto IRC Bot');
$ua->timeout(2);
# Create an instance of JSON.
my $json = JSON->new();
# Put together the call to the Google Calculator API.
my @args = @{ $data{args} };
# Create an instance of LWP::UserAgent.
my $ua = LWP::UserAgent->new();
$ua->agent('Auto IRC Bot');
$ua->timeout(2);
# Create an instance of JSON.
my $json = JSON->new();
# Put together the call to the Google Calculator API.
if (!defined $args[0]) {
notice($data{svr}, $data{nick}, trans("Not enough parameters").".");
notice($src->{svr}, $src->{nick}, trans("Not enough parameters").".");
return 0;
}
my $expr = join(' ', @args);
my $url = "http://www.google.com/ig/calculator?q=".uri_escape($expr);
# Get the response via HTTP.
my $response = $ua->get($url);
my $url = "http://www.google.com/ig/calculator?q=".uri_escape($expr);
# Get the response via HTTP.
my $response = $ua->get($url);
if ($response->is_success) {
# If successful, decode the content.
my $d = $json->allow_nonref->relaxed->escape_slash->loose->allow_singlequote->allow_barekey->decode($response->decoded_content);
if ($response->is_success) {
# If successful, decode the content.
my $d = $json->allow_nonref->relaxed->escape_slash->loose->allow_singlequote->allow_barekey->decode($response->decoded_content);
if ($d->{error} eq "" or $d->{error} == 0) {
# And send to channel
privmsg($data{svr}, $data{chan}, "Result: ".$d->{lhs}." = ".$d->{rhs});
}
else {
# Otherwise, send an error message.
privmsg($data{svr}, $data{chan}, "Google Calculator sent an error.");
}
}
else {
# Otherwise, send an error message.
privmsg($data{svr}, $data{chan}, "An error occurred while sending your expression to Google Calculator.");
}
if ($d->{error} eq "" or $d->{error} == 0) {
# And send to channel
privmsg($src->{svr}, $src->{chan}, "Result: ".$d->{lhs}." = ".$d->{rhs});
}
else {
# Otherwise, send an error message.
privmsg($src->{svr}, $src->{chan}, "Google Calculator sent an error.");
}
}
else {
# Otherwise, send an error message.
privmsg($src->{svr}, $src->{chan}, "An error occurred while sending your expression to Google Calculator.");
}
return 1;
return 1;
}
# Start initialization.
API::Std::mod_init("Calc", "Xelhua", "1.00", "3.0.0d", __PACKAGE__);
API::Std::mod_init('Calc', 'Xelhua', '1.00', '3.0.0a4', __PACKAGE__);
# vim: set ai sw=4 ts=4:
# build: cpan=LWP::UserAgent,URI::Escape,JSON,JSON::PP perl=5.010000
@@ -125,6 +119,6 @@ Google Calculator.
This module requires LWP::UserAgent, URI::Escape and JSON/JSON::PP.
All are obtainable from the CPAN <http://www.cpan.org>.
This module is compatible with Auto version 3.0.0a2+.
This module is compatible with Auto version 3.0.0a4+.
=back
+345
View File
@@ -0,0 +1,345 @@
# Module: ChanTopics. See below for documentation.
# Copyright (C) 2010-2011 Xelhua Development Group, et al.
# This program is free software; rights to this code are stated in doc/LICENSE.
package M::ChanTopics;
use strict;
use warnings;
use API::Std qw(cmd_add cmd_del trans);
use API::IRC qw(notice topic);
# Initialization subroutine.
sub _init
{
# PostgreSQL is not supported.
if ($Auto::ENFEAT =~ /pgsql/) { err(3, 'Unable to load ChanTopics: PostgreSQL is not supported.', 0); return; }
# Create database table if it's missing.
$Auto::DB->do('CREATE TABLE IF NOT EXISTS topics (net TEXT, chan TEXT, topic TEXT, divider TEXT, owner TEXT, verb TEXT, status TEXT, other TEXT, static TEXT)') or print "$!\n" and return;
# Create the TOPIC command.
cmd_add('TOPIC', 0, 'topic.topic', \%M::ChanTopics::HELP_TOPIC, \&M::ChanTopics::cmd_topic) or return;
# Create the DIVIDER command.
cmd_add('DIVIDER', 0, 'topic.topic', \%M::ChanTopics::HELP_DIVIDER, \&M::ChanTopics::cmd_divider) or return;
# Create the OWNER command.
cmd_add('OWNER', 0, 'topic.owner', \%M::ChanTopics::HELP_OWNER, \&M::ChanTopics::cmd_owner) or return;
# Create the VERB command.
cmd_add('VERB', 0, 'topic.status', \%M::ChanTopics::HELP_VERB, \&M::ChanTopics::cmd_verb) or return;
# Create the STATUS command.
cmd_add('STATUS', 0, 'topic.status', \%M::ChanTopics::HELP_STATUS, \&M::ChanTopics::cmd_status) or return;
# Create the OTHER command.
cmd_add('OTHER', 0, 'topic.static', \%M::ChanTopics::HELP_OTHER, \&M::ChanTopics::cmd_other) or return;
# Create the STATIC command.
cmd_add('STATIC', 0, 'topic.static', \%M::ChanTopics::HELP_STATIC, \&M::ChanTopics::cmd_static) or return;
# Create the TSYNC command.
cmd_add('TSYNC', 0, 'topic.topic', \%M::ChanTopics::HELP_TSYNC, \&M::ChanTopics::cmd_tsync) or return;
return 1;
}
# Void subroutine.
sub _void
{
# Delete all the commands.
cmd_del('TOPIC') or return;
cmd_del('DIVIDER') or return;
cmd_del('OWNER') or return;
cmd_del('VERB') or return;
cmd_del('STATUS') or return;
cmd_del('OTHER') or return;
cmd_del('STATIC') or return;
cmd_del('TSYNC') or return;
return 1;
}
# Help hashes for the TOPIC, OWNER, VERB, STATUS, OTHER, STATIC, DIVIDER and TSYNC commands. Spanish, French and German translations needed.
our %HELP_TOPIC = (
'en' => "This command allows you to set the topic section of a channel topic. \002Syntax:\002 TOPIC <new topic>",
);
our %HELP_DIVIDER = (
'en' => "This command allows you to set the divider for topic sections in a channel topic. \002Syntax:\002 DIVIDER <new divider>",
);
our %HELP_OWNER = (
'en' => "This command allows you to set the channel owner section of a channel topic. \002Syntax:\002 OWNER <new owner>",
);
our %HELP_VERB = (
'en' => "This command allows you to set the status verb section of a channel topic. \002Syntax:\002 VERB <new verb>",
);
our %HELP_STATUS = (
'en' => "This command allows you to set the status section of a channel topic. \002Syntax:\002 STATUS <new status>",
);
our %HELP_OTHER = (
'en' => "This command allows you to set the other static section of a channel topic. \002Syntax:\002 OTHER <new other static>",
);
our %HELP_STATIC = (
'en' => "This command allows you to set the static section of a channel topic. \002Syntax:\002 STATIC <new static>",
);
our %HELP_TSYNC = (
'en' => "This command allows you to sync the channel topic with the topic in the database. \002Syntax:\002 TSYNC",
);
# Callback for TOPIC command.
sub cmd_topic
{
my ($src, @argv) = @_;
# Check for required parameters.
if (!defined $argv[0]) {
notice($src->{svr}, $src->{nick}, trans('Not enough parameters').q{.});
return;
}
# Get existing topic data.
my (undef, $div, $owner, $verb, $status, $other, $static) = _getdata(lc $src->{svr}, lc $src->{chan});
# Query the database with the new topic.
my $dbq = $Auto::DB->prepare('UPDATE topics SET topic = ? WHERE net = ? AND chan = ?') or return;
$dbq->execute(join(' ', @argv), lc $src->{svr}, lc $src->{chan}) or return;
# Set new topic.
topic($src->{svr}, $src->{chan}, "Topic: ".join(' ', @argv)." $div $owner $verb $status $div $other $div $static");
return 1;
}
# Callback for DIVIDER command.
sub cmd_divider
{
my ($src, @argv) = @_;
# Check for required parameters.
if (!defined $argv[0]) {
notice($src->{svr}, $src->{nick}, trans('Not enough parameters').q{.});
return;
}
# Get existing topic data.
my ($topic, undef, $owner, $verb, $status, $other, $static) = _getdata(lc $src->{svr}, lc $src->{chan});
# Query the database with the new divider.
my $dbq = $Auto::DB->prepare('UPDATE topics SET divider = ? WHERE net = ? AND chan = ?') or return;
$dbq->execute($argv[0], lc $src->{svr}, lc $src->{chan}) or return;
# Set new topic.
topic($src->{svr}, $src->{chan}, "Topic: $topic $argv[0] $owner $verb $status $argv[0] $other $argv[0] $static");
return 1;
}
# Callback for OWNER command.
sub cmd_owner
{
my ($src, @argv) = @_;
# Check for required parameters.
if (!defined $argv[0]) {
notice($src->{svr}, $src->{nick}, trans('Not enough parameters').q{.});
return;
}
# Get existing topic data.
my ($topic, $div, undef, $verb, $status, $other, $static) = _getdata(lc $src->{svr}, lc $src->{chan});
# Query the database with the new owner.
my $dbq = $Auto::DB->prepare('UPDATE topics SET owner = ? WHERE net = ? AND chan = ?') or return;
$dbq->execute($argv[0], lc $src->{svr}, lc $src->{chan}) or return;
# Set new topic.
topic($src->{svr}, $src->{chan}, "Topic: $topic $div $argv[0] $verb $status $div $other $div $static");
return 1;
}
# Callback for VERB command.
sub cmd_verb
{
my ($src, @argv) = @_;
# Check for required parameters.
if (!defined $argv[0]) {
notice($src->{svr}, $src->{nick}, trans('Not enough parameters').q{.});
return;
}
# Get existing topic data.
my ($topic, $div, $owner, undef, $status, $other, $static) = _getdata(lc $src->{svr}, lc $src->{chan});
# Query the database with the new verb.
my $dbq = $Auto::DB->prepare('UPDATE topics SET verb = ? WHERE net = ? AND chan = ?') or return;
$dbq->execute($argv[0], lc $src->{svr}, lc $src->{chan}) or return;
# Set new topic.
topic($src->{svr}, $src->{chan}, "Topic: $topic $div $owner $argv[0] $status $div $other $div $static");
return 1;
}
# Callback for STATUS command.
sub cmd_status
{
my ($src, @argv) = @_;
# Check for required parameters.
if (!defined $argv[0]) {
notice($src->{svr}, $src->{nick}, trans('Not enough parameters').q{.});
return;
}
# Get existing topic data.
my ($topic, $div, $owner, $verb, undef, $other, $static) = _getdata(lc $src->{svr}, lc $src->{chan});
# Query the database with the new status.
my $dbq = $Auto::DB->prepare('UPDATE topics SET status = ? WHERE net = ? AND chan = ?') or return;
$dbq->execute(join(' ', @argv), lc $src->{svr}, lc $src->{chan}) or return;
# Set new topic.
topic($src->{svr}, $src->{chan}, "Topic: $topic $div $owner $verb ".join(' ', @argv)." $div $other $div $static");
return 1;
}
# Callback for OTHER command.
sub cmd_other
{
my ($src, @argv) = @_;
# Check for required parameters.
if (!defined $argv[0]) {
notice($src->{svr}, $src->{nick}, trans('Not enough parameters').q{.});
return;
}
# Get existing topic data.
my ($topic, $div, $owner, $verb, $status, undef, $static) = _getdata(lc $src->{svr}, lc $src->{chan});
# Query the database with the new other.
my $dbq = $Auto::DB->prepare('UPDATE topics SET other = ? WHERE net = ? AND chan = ?') or return;
$dbq->execute(join(' ', @argv), lc $src->{svr}, lc $src->{chan}) or return;
# Set new topic.
topic($src->{svr}, $src->{chan}, "Topic: $topic $div $owner $verb $status $div ".join(' ', @argv)." $div $static");
return 1;
}
# Callback for STATIC command.
sub cmd_static
{
my ($src, @argv) = @_;
# Check for required parameters.
if (!defined $argv[0]) {
notice($src->{svr}, $src->{nick}, trans('Not enough parameters').q{.});
return;
}
# Get existing topic data.
my ($topic, $div, $owner, $verb, $status, $other, undef) = _getdata(lc $src->{svr}, lc $src->{chan});
# Query the database with the new static.
my $dbq = $Auto::DB->prepare('UPDATE topics SET static = ? WHERE net = ? AND chan = ?') or return;
$dbq->execute(join(' ', @argv), lc $src->{svr}, lc $src->{chan}) or return;
# Set new topic.
topic($src->{svr}, $src->{chan}, "Topic: $topic $div $owner $verb $status $div $other $div ".join(' ', @argv));
return 1;
}
# Callback for TSYNC command.
sub cmd_tsync
{
my ($src, @argv) = @_;
# Get the topic data.
my ($topic, $div, $owner, $verb, $status, $other, $static) = _getdata(lc $src->{svr}, lc $src->{chan});
# Set new topic.
topic($src->{svr}, $src->{chan}, "Topic: $topic $div $owner $verb $status $div $other $div $static");
return 1;
}
# Subroutine for getting topic data.
sub _getdata
{
my ($net, $chan) = @_;
# Check if there is a database entry for this channel.
if (!$Auto::DB->selectrow_array('SELECT * FROM topics WHERE net = "'.$net.'" AND chan = "'.$chan.'"')) {
# There is not; create it.
my $dbq = $Auto::DB->prepare('INSERT INTO topics (net, chan, topic, divider, owner, verb, status, other, static) VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?)') or return;
$dbq->execute($net, $chan, 'NULL', 'NULL', 'NULL', 'NULL', 'NULL', 'NULL', 'NULL') or return;
}
# Now retrieve all the desired data.
my $dbq = $Auto::DB->prepare('SELECT topic,divider,owner,verb,status,other,static FROM topics WHERE net = ? AND chan = ?') or return;
$dbq->execute($net, $chan) or return;
my $data = $dbq->fetchrow_hashref or return;
# And return it.
return ($data->{topic}, $data->{divider}, $data->{owner}, $data->{verb}, $data->{status}, $data->{other}, $data->{static});
}
API::Std::mod_init('ChanTopics', 'Xelhua', '1.00', '3.0.0a4', __PACKAGE__);
# vim: set ai sw=4 ts=4:
# build: perl=5.010000
__END__
=head1 ChanTopics
=head2 Description
=over
This module adds the TOPIC, DIVIDER, OWNER, VERB, STATUS, OTHER and STATIC
commands for advanced yet simple management of a channel's topic.
Topic Format: Topic: TOPIC DIVIDER OWNER VERB STATUS DIVIDER OTHER DIVIDER STATIC
=back
=head2 How To Use
=over
This module adds the topic.topic, topic.owner, topic.status and topic.static
privileges. topic.topic grants access to TOPIC, topic.owner to OWNER,
topic.status to VERB and STATUS, and topic.static to OTHER and STATIC.
=back
=head2 Examples
=over
<JohnSmith> !topic Random Nonsense
* Auto changes topic to: Topic: Random Nonsense | JohnSmith is here | Welcome to #johnsmith | Website at http://example.com
<JohnSmith> !status sleeping
* Auto changes topic to: Topic: Random Nonsense | JohnSmith is sleeping | Welcome to #johnsmith | Website at http://example.com
=back
=head2 To Do
=over
* Spanish, French and German translations for the help hashes.
=back
=head2 Technical
=over
This module adds no extra dependencies.
This module is not compatible with PostgreSQL, yet.
This module is compatible with Auto v3.0.0a4+.
Ported from v1.0.
=back
+104
View File
@@ -0,0 +1,104 @@
# Module: Dictionary. See below for documentation.
# Copyright (C) 2010-2011 Xelhua Development Group, et al.
# This program is free software; rights to this code are stated in doc/LICENSE.
package M::Dictionary;
use strict;
use warnings;
use Net::Dict;
use API::Std qw(cmd_add cmd_del trans);
use API::IRC qw(notice privmsg);
# Initialization subroutine.
sub _init
{
# Create the DICT command.
cmd_add('DICT', 0, 0, \%M::Dictionary::HELP_DICT, \&M::Dictionary::cmd_dict) or return;
# Success.
return 1;
}
# Void subroutine.
sub _void
{
# Delete the DICT command.
cmd_del('DICT') or return;
# Success.
return 1;
}
# Help hash for DICT. Spanish, French and German translations needed.
our %HELP_DICT = (
'en' => "This command allows you to lookup a word through Dict.org. \002Syntax:\002 DICT <word>",
);
# Callback for DICT command.
sub cmd_dict
{
my ($src, ($word)) = @_;
# Check for needed parameters.
if (!defined $word) {
notice($src->{svr}, $src->{nick}, trans('Not enough parameters').q{.});
return;
}
# Create an instance of Net::Dict.
my $dictv = Net::Dict->new('dict.org');
# Get the definition for this word.
my $res = $dictv->define($word);
# Check if there was a result.
if (defined $res) {
# Return the results.
privmsg($src->{svr}, $src->{chan}, "Results for \2$word\2:");
foreach (@{ $res }) {
# Split the newlines.
my @lines = split m/\n/, @$_[1];
foreach (@lines) {
if ($_ =~ m/[^\s]/) {
privmsg($src->{svr}, $src->{chan}, $_);
}
}
}
}
else {
# Else return no results.
privmsg($src->{svr}, $src->{chan}, "No results for \2$word\2.");
}
return 1;
}
# Start initialization.
API::Std::mod_init('Dictionary', 'Xelhua', '1.00', '3.0.0a4', __PACKAGE__);
# vim: set ai sw=4 ts=4:
# build: cpan=Net::Dict perl=5.010000
__END__
=head1 Dictionary
=head2 Description
=over
This module allows users to lookup definitions for words from dict.org via the
DICT command.
=back
=head2 Technical
=over
This module adds an extra dependency: Net::Dict. You can get it from the CPAN
<http://www.cpan.org>.
This module is compatible with Auto v3.0.0a4+.
=back
+17 -19
View File
@@ -1,7 +1,7 @@
# Module: EightBall. See below for documentation.
# Copyright (C) 2010-2011 Xelhua Development Group, et al.
# This program is free software; rights to this code are stated in doc/LICENSE.
package m_EightBall;
package M::EightBall;
use strict;
use warnings;
use feature qw(switch);
@@ -13,8 +13,8 @@ our $ANSWER = 0;
sub _init
{
# Create the 8BALL and RIGBALL commands.
cmd_add("8BALL", 0, 0, \%m_EightBall::HELP_8BALL, \&m_EightBall::c_8ball) or return 0;
cmd_add("RIGBALL", 1, "cmd.rigball", \%m_EightBall::HELP_RIGBALL, \&m_EightBall::rigball) or return 0;
cmd_add('8BALL', 0, 0, \%M::EightBall::HELP_8BALL, \&M::EightBall::c_8ball) or return 0;
cmd_add('RIGBALL', 1, 'cmd.rigball', \%M::EightBall::HELP_RIGBALL, \&M::EightBall::rigball) or return 0;
# Success.
return 1;
@@ -24,11 +24,11 @@ sub _init
sub _void
{
# Delete the 8BALL and RIGBALL commands.
cmd_del("8BALL") or return 0;
cmd_del("RIGBALL") or return 0;
cmd_del('8BALL') or return 0;
cmd_del('RIGBALL') or return 0;
# Success.
return 1;
return 1;
}
# Help hashes.
@@ -42,15 +42,14 @@ our %HELP_RIGBALL = (
# Callback for 8BALL command.
sub c_8ball
{
my (%data) = @_;
my @argv = @{ $data{args} }; delete $data{args};
my ($src, @argv) = @_;
if (!defined $argv[0]) {
notice($data{svr}, $data{nick}, trans("Not enough parameters").".");
notice($src->{svr}, $src->{nick}, trans("Not enough parameters").".");
return;
}
privmsg($data{svr}, $data{chan}, "\002Question:\002 ".join(" ", @argv));
privmsg($src->{svr}, $src->{chan}, "\002Question:\002 ".join(" ", @argv));
my $a = '';
if (!$ANSWER) {
@@ -76,32 +75,31 @@ sub c_8ball
$ANSWER = 0;
}
privmsg($data{svr}, $data{chan}, "\002Answer:\002 ".$a);
privmsg($src->{svr}, $src->{chan}, "\002Answer:\002 ".$a);
return 1;
return 1;
}
# Callback for RIGBALL command.
sub rigball
{
my (%data) = @_;
my @argv = @{ $data{args} }; delete $data{args};
my ($src, @argv) = @_;
# Check for necessary parameters.
if (!defined $argv[0]) {
privmsg($data{svr}, $data{nick}, trans("Not enough parameters").".");
privmsg($src->{svr}, $src->{nick}, trans("Not enough parameters").".");
return;
}
$ANSWER = join(" ", @argv);
privmsg($data{svr}, $data{nick}, "Answer set to: ".$ANSWER);
privmsg($src->{svr}, $src->{nick}, "Answer set to: ".$ANSWER);
return 1;
return 1;
}
# Start initialization.
API::Std::mod_init("EightBall", "Xelhua", "1.00", "3.0.0d", __PACKAGE__);
API::Std::mod_init('EightBall', 'Xelhua', '1.00', '3.0.0a4', __PACKAGE__);
# vim: set ai sw=4 ts=4:
# build: perl=5.010000
@@ -145,7 +143,7 @@ command for setting ("rigging") the 8-Ball's next answer.
=over
This module is compatible with Auto version 3.0.0a2+.
This module is compatible with Auto version 3.0.0a4+.
Ported from Auto 1.0.
+17 -17
View File
@@ -1,7 +1,7 @@
# Module: FML. See below for documentation.
# Copyright (C) 2010-2011 Xelhua Development Group, et al.
# This program is free software; rights to this code are stated in doc/LICENSE.
package m_FML;
package M::FML;
use strict;
use warnings;
use API::Std qw(cmd_add cmd_del trans);
@@ -12,7 +12,7 @@ use LWP::UserAgent;
sub _init
{
# Create the FML command.
cmd_add("FML", 0, 0, \%m_FML::HELP_FML, \&m_FML::fml) or return 0;
cmd_add('FML', 0, 0, \%M::FML::HELP_FML, \&M::FML::fml) or return 0;
# Success.
return 1;
@@ -22,10 +22,10 @@ sub _init
sub _void
{
# Delete the FML command.
cmd_del("FML") or return 0;
cmd_del('FML') or return 0;
# Success.
return 1;
return 1;
}
# Help hash.
@@ -36,38 +36,38 @@ our %HELP_FML = (
# Callback for FML command.
sub fml
{
my (%data) = @_;
my ($src, undef) = @_;
# Create an instance of LWP::UserAgent.
my $ua = LWP::UserAgent->new();
$ua->agent('Auto IRC Bot');
$ua->timeout(2);
my $ua = LWP::UserAgent->new();
$ua->agent('Auto IRC Bot');
$ua->timeout(2);
# Get the random FML via HTTP.
my $rp = $ua->get("http://rscript.org/lookup.php?type=fml");
my $rp = $ua->get('http://rscript.org/lookup.php?type=fml');
if ($rp->is_success) {
if ($rp->is_success) {
# If successful, decode the content.
my $d = $rp->decoded_content;
$d =~ s/(\n|\r)//g;
$d =~ s/(\n|\r)//g;
# Get the FML.
my (undef, $dfa) = split('Text: ', $d);
my ($fml, undef) = split('Agree:', $dfa);
# And send to channel.
privmsg($data{svr}, $data{chan}, "\002Random FML:\002 ".$fml);
}
privmsg($src->{svr}, $src->{chan}, "\002Random FML:\002 ".$fml);
}
else {
# Otherwise, send an error message.
privmsg($data{svr}, $data{chan}, "An error occurred while retrieving the FML.");
privmsg($src->{svr}, $src->{chan}, "An error occurred while retrieving the FML.");
}
return 1;
return 1;
}
# Start initialization.
API::Std::mod_init("FML", "Xelhua", "1.00", "3.0.0d", __PACKAGE__);
API::Std::mod_init('FML', 'Xelhua', '1.00', '3.0.0a4', __PACKAGE__);
# vim: set ai sw=4 ts=4:
# build: cpan=LWP::UserAgent perl=5.010000
@@ -110,7 +110,7 @@ have my hand back?" FML
This module adds an extra dependency: LWP::UserAgent. You can get it from
the CPAN <http://www.cpan.org>.
This module is compatible with Auto version 3.0.0a2+.
This module is compatible with Auto version 3.0.0a4+.
Ported from Auto 2.0.
+159
View File
@@ -0,0 +1,159 @@
# Module: Greet. See below for documentation.
# Copyright (C) 2010-2011 Xelhua Development Group, et al.
# This program is free software; rights to this code are stated in doc/LICENSE.
package M::Greet;
use strict;
use warnings;
use feature qw(switch);
use API::Std qw(cmd_add cmd_del hook_add hook_del trans);
use API::IRC qw(privmsg notice);
# Initialization subroutine.
sub _init
{
# Not compatible with PostgreSQL.
if ($Auto::ENFEAT =~ /pgsql/) { err(2, 'Unable to load Greet: PostgreSQL is not supported.', 0); return; }
# Create the `greets` table.
$Auto::DB->do('CREATE TABLE IF NOT EXISTS greets (nick TEXT, greet TEXT)') or return;
# Create the GREET command.
cmd_add('GREET', 2, 'cmd.greet', \%M::Greet::HELP_GREET, \&M::Greet::cmd_greet) or return;
# Create the greet_onjoin hook.
hook_add('on_rcjoin', 'greet_onjoin', \&M::Greet::hook_rcjoin) or return;
# Success.
return 1;
}
# Void subroutine.
sub _void
{
# Delete the GREET command.
cmd_del('GREET') or return;
# Delete the greet_onjoin hook.
hook_del('on_rcjoin') or return;
# Success.
return 1;
}
# Help hash for GREET. Spanish, French and German translation needed.
our %HELP_GREET = (
'en' => "This command allows management of greets. \002Syntax:\002 GREET (ADD|DEL) [nick] [greet]",
);
# Callback for GREET.
sub cmd_greet
{
my ($src, @argv) = @_;
# Check for required parameters.
if (!defined $argv[0]) {
notice($src->{svr}, $src->{nick}, trans('Not enough parameters').q{.});
return;
}
# Check what action we're being told to take.
given (uc $argv[0]) {
when ('ADD') {
# GREET ADD
# Check for needed parameters.
if (!defined $argv[1] or !defined $argv[2]) {
notice($src->{svr}, $src->{nick}, trans('Not enough parameters').q{.});
return;
}
my $nick = $argv[1]; shift @argv; shift @argv;
$nick = lc $nick;
my $greet = join(' ', @argv);
# Make sure it doesn't already exist.
if ($Auto::DB->selectrow_array('SELECT * FROM greets WHERE nick = "'.$nick.'"')) {
notice($src->{svr}, $src->{nick}, "A greet for \002$nick\002 already exists.");
return;
}
# Insert into database.
my $dbq = $Auto::DB->prepare('INSERT INTO greets (nick, greet) VALUES (?, ?)') or notice($src->{svr}, $src->{nick}, trans('An error occurred').q{.}) and return;
$dbq->execute($nick, $greet) or notice($src->{svr}, $src->{nick}, trans('An error occurred').q{.}) and return;
API::Log::slog('cmd_greet(): Creating new greet.');
# Done.
notice($src->{svr}, $src->{nick}, "Successfully added greet for \002$nick\002.");
}
when ('DEL') {
# GREET DEL
# Check for needed parameters.
if (!defined $argv[1]) {
notice($src->{svr}, $src->{nick}, trans('Not enough parameters').q{.});
return;
}
my $nick = lc $argv[1];
# Check if there is a greet for this user.
if (!$Auto::DB->selectrow_array('SELECT * FROM greets WHERE nick = "'.$nick.'"')) {
notice($src->{svr}, $src->{nick}, "There is no greet for \002$nick\002.");
return;
}
# Delete it.
$Auto::DB->do('DELETE FROM greets WHERE nick = "'.$nick.'"') or notice($src->{svr}, $src->{nick}, trans('An error occurred').q{.}) and return;
notice($src->{svr}, $src->{nick}, "Greet for \002$nick\002 successfully deleted.");
}
default { notice($src->{svr}, $src->{nick}, "Unknown action \002$argv[0]\002. \002Syntax:\002 GREET (ADD|DEL)"); return; }
}
return 1;
}
# Call back for on_rcjoin hook.
sub hook_rcjoin
{
my (($src, $chan)) = @_;
my $nick = lc $src->{nick};
# Check if there's a greet for this user.
if ($Auto::DB->selectrow_array('SELECT * FROM greets WHERE nick = "'.$nick.'"')) {
# Get data.
my @data = $Auto::DB->selectrow_array('SELECT * FROM greets WHERE nick = "'.$nick.'"');
# Send the greet.
privmsg($src->{svr}, $chan, "[\002".$src->{nick}."\002] ".$data[1]);
}
return 1;
}
# Start initialization.
API::Std::mod_init('Greet', 'Xelhua', '1.00', '3.0.0a4', __PACKAGE__);
# vim: set ai sw=4 ts=4:
# build: perl=5.010000
__END__
=head1 Greet
=head2 Description
=over
This module adds GREET ADD|DEL for greet management. Greets are sent when a
user that has a greet in the database joins a channel the bot is in.
=back
=head2 To Do
=over
* Add Spanish, French and German translations for the help hash.
=back
=head2 Technical
=over
This module is compatible with Auto version 3.0.0a4+.
=back
+24 -14
View File
@@ -1,7 +1,7 @@
# Module: HelloChan.
# Copyright (C) 2010-2011 Xelhua Development Group, et al.
# This program is free software; rights to this code are stated in doc/LICENSE.
package m_HelloChan;
package M::HelloChan;
use strict;
use warnings;
use API::Std qw(hook_add hook_del);
@@ -10,32 +10,42 @@ use API::IRC qw(privmsg);
# Initialization subroutine.
sub _init
{
# Add a hook for when we join a channel.
hook_add("on_ucjoin", "HelloChan", \&m_HelloChan::hello) or return 0;
return 1;
# Add a hook for when we join a channel.
hook_add("on_ucjoin", "HelloChan", \&M::HelloChan::hello) or return 0;
return 1;
}
# Void subroutine.
sub _void
{
# Delete the hook.
hook_del("on_ucjoin", "HelloChan") or return 0;
return 1;
# Delete the hook.
hook_del("on_ucjoin", "HelloChan") or return 0;
return 1;
}
# Main subroutine.
sub hello
{
my (($svr, $chan)) = @_;
# Send a PRIVMSG.
privmsg($svr, $chan, "Hello channel! I am a bot!");
return 1;
my (($svr, $chan)) = @_;
# Send a PRIVMSG.
privmsg($svr, $chan, "Hello channel! I am a bot!");
return 1;
}
# Start initialization.
API::Std::mod_init("HelloChan", "Xelhua", "1.00", "3.0.0d", __PACKAGE__);
API::Std::mod_init('HelloChan', 'Xelhua', '1.00', '3.0.0a4', __PACKAGE__);
# vim: set ai sw=4 ts=4:
# build: perl=5.010000
__END__
=head1 HelloChan
=over
This is an example module. Also, cows go moo.
=back
+38 -39
View File
@@ -1,7 +1,7 @@
# Module: IsItUp. See below for documentation.
# Copyright (C) 2010-2011 Xelhua Development Group, et al.
# This program is free software; rights to this code are stated in doc/LICENSE.
package m_IsItUp;
package M::IsItUp;
use strict;
use warnings;
use API::Std qw(cmd_add cmd_del trans);
@@ -11,66 +11,65 @@ use LWP::UserAgent;
# Initialization subroutine.
sub _init
{
# Create the ISITUP command.
cmd_add("ISITUP", 0, 0, \%m_IsItUp::HELP_ISITUP, \&m_IsItUp::check) or return 0;
# Create the ISITUP command.
cmd_add('ISITUP', 0, 0, \%M::IsItUp::HELP_ISITUP, \&M::IsItUp::check) or return 0;
# Success.
return 1;
# Success.
return 1;
}
# Void subroutine.
sub _void
{
# Delete the ISITUP command.
cmd_del("ISITUP") or return 0;
# Delete the ISITUP command.
cmd_del('ISITUP') or return 0;
# Success.
return 1;
# Success.
return 1;
}
# Help hashes.
our %HELP_ISITUP = (
'en' => "This command will check if a website appears up or down to the bot. \002Syntax:\002 ISITUP <url>",
'en' => "This command will check if a website appears up or down to the bot. \002Syntax:\002 ISITUP <url>",
);
# Callback for ISITUP command.
sub check
{
my (%data) = @_;
my ($src, @argv) = @_;
# Create an instance of LWP::UserAgent.
my $ua = LWP::UserAgent->new();
$ua->agent('Auto IRC Bot');
$ua->timeout(2);
my @args = @{ $data{args} };
my $curl = $args[0];
# Do we have enough parameters?
if (!defined $args[0]) {
notice($data{svr}, $data{nick}, trans("Not enough parameters").".");
return 0;
}
# Does the URL start with http(s)?
if ($curl !~ m/^http/) {
$curl = "http://".$curl;
}
# Create an instance of LWP::UserAgent.
my $ua = LWP::UserAgent->new();
$ua->agent('Auto IRC Bot');
$ua->timeout(2);
# Do we have enough parameters?
if (!defined $argv[0]) {
notice($src->{svr}, $src->{nick}, trans('Not enough parameters').q{.});
return 0;
}
my $curl = $argv[0];
# Does the URL start with http(s)?
if ($curl !~ m/^http/) {
$curl = 'http://'.$curl;
}
# Get the response via HTTP.
my $response = $ua->get($curl);
# Get the response via HTTP.
my $response = $ua->get($curl);
if ($response->is_success) {
# If successful, it's up.
privmsg($data{svr}, $data{chan}, $curl." appears to be up from here.");
}
else {
# Otherwise, it's down.
privmsg($data{svr}, $data{chan}, $curl." appears to be down from here.");
}
if ($response->is_success) {
# If successful, it's up.
privmsg($src->{svr}, $src->{chan}, $curl.' appears to be up from here.');
}
else {
# Otherwise, it's down.
privmsg($src->{svr}, $src->{chan}, $curl.' appears to be down from here.');
}
return 1;
return 1;
}
# Start initialization.
API::Std::mod_init("IsItUp", "Xelhua", "1.00", "3.0.0d", __PACKAGE__);
API::Std::mod_init('IsItUp', 'Xelhua', '1.00', '3.0.0a4', __PACKAGE__);
# vim: set ai sw=4 ts=4:
# build: cpan=LWP::UserAgent perl=5.010000
@@ -111,6 +110,6 @@ appears up or down to Auto.
This module requires LWP::UserAgent. You can get it from
the CPAN <http://www.cpan.org>.
This module is compatible with Auto version 3.0.0a2+.
This module is compatible with Auto version 3.0.0a4+.
=back
+122
View File
@@ -0,0 +1,122 @@
# Module: LinkTitle. See below for documentation.
# Copyright (C) 2010-2011 Xelhua Development Group, et al.
# This program is free software; rights to this code are stated in doc/LICENSE.
package M::LinkTitle;
use strict;
use warnings;
use LWP::UserAgent;
use HTML::Entities;
use API::Std qw(hook_add hook_del);
use API::IRC qw(privmsg);
# Initialization subroutine.
sub _init
{
# Create the on_cprivmsg hook.
hook_add('on_cprivmsg', 'privmsg.html.returntitle', \&M::LinkTitle::gettitle) or return;
# Success.
return 1;
}
# Void subroutine.
sub _void
{
# Delete the hook we created.
hook_del('on_cprivmsg', 'privmsg.html.returntitle') or return;
# Success.
return 1;
}
# Hook callback.
sub gettitle
{
my ($src, $chan, @msg) = @_;
# Check if the message contains a URL.
foreach my $smw (@msg) {
if ($smw =~ m{(http|https)://}xsm) {
# We've got a match, connect to the server.
my $srv = $1;
# Create an instance of LWP::UserAgent.
my $ua = LWP::UserAgent->new();
$ua->agent('Auto IRC Bot');
$ua->timeout(3);
# Get data.
my $res = $ua->get($smw);
# Check if we're successful.
if ($res->is_success) {
# We were, decode the data.
my $data = $res->decoded_content;
# Check for <title>
if ($data =~ m{<title>(.*)</title>}ixsm) {
# Found. Decode it.
my $title = decode_entities($1);
# Return to channel.
privmsg($src->{svr}, $chan, "\2Title:\2 $title");
}
}
}
}
return 1;
}
# Start initialization.
API::Std::mod_init('LinkTitle', 'Xelhua', '1.00', '3.0.0a5', __PACKAGE__);
# vim: set ai sw=4 ts=4:
# build: cpan=LWP::UserAgent,HTML::Entities perl=5.010000
__END__
=head1 NAME
LinkTitle - A module for returning the page title of links.
=head1 VERSION
1.00
=head1 SYNOPSIS
<starcoder> http://xelhua.org/auto.php
<blue> Title: Xelhua / Projects / Auto
=head1 DESCRIPTION
This module will make Auto parse all links sent to a channel. When a link is
detected, Auto will connect to it and get the page title by scanning for the
<title> tag and returning its contents to the channel.
=head1 DEPENDENCIES
This module is dependent on two modules from the CPAN.
=over
=item L<LWP::UserAgent|LWP::UserAgent>
This module is used for connecting to the target web server via HTTP(S).
=item L<HTML::Entities|HTML::Entities>
This module is used for decoding HTML entities in the response we receive from
the server.
=back
=head1 AUTHOR
This module was written by Elijah Perrault.
This module is maintained by Xelhua Development Group.
=head1 LICENSE AND COPYRIGHT
This module is Copyright 2010-2011 Xelhua Development Group. All rights
reserved.
This module is released under the same licensing terms as Auto itself.
+145 -55
View File
@@ -1,20 +1,24 @@
# Module: QDB. See below for documentation.
# Copyright (C) 2010-2011 Xelhua Development Group, et al.
# This program is free software; rights to this code are stated in doc/LICENSE.
package m_QDB;
package M::QDB;
use strict;
use warnings;
use feature qw(switch);
use API::Std qw(cmd_add cmd_del trans has_priv match_user);
use API::Std qw(cmd_add cmd_del trans has_priv conf_get match_user);
use API::IRC qw(privmsg notice);
our @BUFFER;
sub _init
{
# Create the QDB command.
cmd_add('QDB', 0, 0, \%m_QDB::HELP_QDB, \&m_QDB::cmd_qdb) or return;
cmd_add('QDB', 0, 0, \%M::QDB::HELP_QDB, \&M::QDB::cmd_qdb) or return;
# Check the database format. Fail to load if it's PostgreSQL.
if ($Auto::ENFEAT =~ /pgsql/) { err(2, 'Unable to load QDB: PostgreSQL is not supported.', 0); return; }
# Check for database table.
$Auto::DB->do('CREATE TABLE IF NOT EXISTS qdb (key INTEGER PRIMARY KEY, creator TEXT, time INTEGER, quote TEXT)') or return;
$Auto::DB->do('CREATE TABLE IF NOT EXISTS qdb (quoteid INTEGER PRIMARY KEY, creator TEXT, time INTEGER, quote TEXT)') or return;
# Success.
return 1;
@@ -31,142 +35,228 @@ sub _void
# Help hash for QDB. Spanish, French and German translations needed.
our %HELP_QDB = (
'en' => "This command allows you to add, read, and delete quotes. \002Syntax:\002 QDB (ADD|VIEW|COUNT|RAND|DEL) [quote]",
'en' => "This command allows you to add, read, and delete quotes. \002Syntax:\002 QDB (ADD|VIEW|COUNT|RAND|SEARCH|MORE|DEL) [quote|expression]",
);
sub cmd_qdb
{
my (%data) = @_;
my @argv = @{ $data{args} };
my ($src, @argv) = @_;
# Check for needed parameter.
if (!defined $argv[0]) {
notice($data{svr}, $data{nick}, trans('Not enough parameters').q{.});
notice($src->{svr}, $src->{nick}, trans('Not enough parameters').q{.});
return;
}
# ADD|VIEW|COUNT|RAND|DEL.
# ADD|VIEW|COUNT|RAND|SEARCH|MORE|DEL.
given (uc $argv[0]) {
when ('ADD') {
# QDB ADD.
if (!defined $argv[1]) {
notice($data{svr}, $data{nick}, trans('Not enough parameters').q{.});
notice($src->{svr}, $src->{nick}, trans('Not enough parameters').q{.});
return;
}
# Get rid of the ADD part.
shift @argv;
# Insert into database.
my $dbq = $Auto::DB->prepare('INSERT INTO qdb (creator, time, quote) VALUES (?, ?, ?)') or
notice($data{svr}, $data{nick}, trans('An error occurred').q{.}) and return;
$dbq->execute($data{nick}, time, join(q{ }, @argv)) or
notice($data{svr}, $data{nick}, trans('An error occurred').q{.}) and return;
notice($src->{svr}, $src->{nick}, trans('An error occurred').q{.}) and return;
$dbq->execute($src->{nick}, time, join(q{ }, @argv[1..$#argv])) or
notice($src->{svr}, $src->{nick}, trans('An error occurred').q{.}) and return;
# Get ID.
my $count = $Auto::DB->selectrow_array('SELECT COUNT(*) FROM qdb') or
notice($data{svr}, $data{nick}, trans('An error occurred').q{.}) and return;
notice($src->{svr}, $src->{nick}, trans('An error occurred').q{.}) and return;
privmsg($data{svr}, $data{chan}, 'Quote successfully submitted. ID: '.$count);
privmsg($src->{svr}, $src->{chan}, 'Quote successfully submitted. ID: '.$count);
}
when ('VIEW') {
# QDB VIEW.
if (!defined $argv[1]) {
notice($data{svr}, $data{nick}, trans('Not enough parameters').q{.});
notice($src->{svr}, $src->{nick}, trans('Not enough parameters').q{.});
return;
}
# Get quote.
my $dbq = $Auto::DB->prepare('SELECT * FROM qdb WHERE key = ?') or
notice($data{svr}, $data{nick}, trans('An error occurred').'. Quote might not exist.') and return;
$dbq->execute($argv[1]) or notice($data{svr}, $data{nick}, trans('An error occurred').'. Quote might not exist.') and return;
my $dbq = $Auto::DB->prepare('SELECT * FROM qdb WHERE quoteid = ?') or
notice($src->{svr}, $src->{nick}, trans('An error occurred').'. Quote might not exist.') and return;
$dbq->execute($argv[1]) or notice($src->{svr}, $src->{nick}, trans('An error occurred').'. Quote might not exist.') and return;
my @data = $dbq->fetchrow_array;
# Check for an unusual issue.
if (!defined $data[1]) { notice($src->{svr}, $src->{nick}, trans('An error occurred').'. Quote might not exist.'); return; }
# Send it back.
privmsg($data{svr}, $data{chan}, "\002Submitted by\002 $data[1] \002on\002 ".POSIX::strftime('%F', localtime($data[2]))." \002at\002 ".POSIX::strftime('%I:%M %p', localtime($data[2])));
privmsg($data{svr}, $data{chan}, $data[3]);
privmsg($src->{svr}, $src->{chan}, "\002Submitted by\002 $data[1] \002on\002 ".POSIX::strftime('%F', localtime($data[2]))." \002at\002 ".POSIX::strftime('%I:%M %p', localtime($data[2])));
privmsg($src->{svr}, $src->{chan}, $data[3]);
}
when ('COUNT') {
# Get count.
my $count = $Auto::DB->selectrow_array('SELECT COUNT(*) FROM qdb') or
notice($data{svr}, $data{nick}, trans('An error occurred').q{.}) and return;
notice($src->{svr}, $src->{nick}, trans('An error occurred').q{.}) and return;
# Send it back.
privmsg($data{svr}, $data{chan}, "There is currently \002$count\002 quotes in my database.");
privmsg($src->{svr}, $src->{chan}, "There is currently \002$count\002 quotes in my database.");
}
when ('RAND') {
# Get count.
my $count = $Auto::DB->selectrow_array('SELECT COUNT(*) FROM qdb') or
notice($data{svr}, $data{nick}, trans('An error occurred').q{.}) and return;
notice($src->{svr}, $src->{nick}, trans('An error occurred').q{.}) and return;
# Random number.
my $rand = int(rand($count));
if ($rand == 0) { $rand = $count; }
# Get quote.
my $dbq = $Auto::DB->prepare('SELECT * FROM qdb WHERE key = ?') or
notice($data{svr}, $data{nick}, trans('An error occurred').q{.}) and return;
$dbq->execute($rand) or notice($data{svr}, $data{nick}, trans('An error occurred').q{.}) and return;
my $dbq = $Auto::DB->prepare('SELECT * FROM qdb WHERE quoteid = ?') or
notice($src->{svr}, $src->{nick}, trans('An error occurred').q{.}) and return;
$dbq->execute($rand) or notice($src->{svr}, $src->{nick}, trans('An error occurred').q{.}) and return;
my @data = $dbq->fetchrow_array;
# Send it back.
privmsg($data{svr}, $data{chan}, "\002ID:\002 $data[0] - \002Submitted by\002 $data[1] \002on\002 ".POSIX::strftime('%F', localtime($data[2]))." \002at\002 ".POSIX::strftime('%I:%M %p', localtime($data[2])));
privmsg($data{svr}, $data{chan}, $data[3]);
privmsg($src->{svr}, $src->{chan}, "\002ID:\002 $data[0] - \002Submitted by\002 $data[1] \002on\002 ".POSIX::strftime('%F', localtime($data[2]))." \002at\002 ".POSIX::strftime('%I:%M %p', localtime($data[2])));
privmsg($src->{svr}, $src->{chan}, $data[3]);
}
when ('SEARCH') {
# QDB SEARCH.
# Get all quotes.
my $dbq = $Auto::DB->prepare('SELECT * FROM qdb') or return;
$dbq->execute or return;
my $quotes = $dbq->fetchall_hashref('quoteid') or return;
# Set expression.
my $expr = my $rexpr = join ' ', @argv[1 .. $#argv];
$rexpr =~ s{\(}{\\\(}g;
$rexpr =~ s{\)}{\\\)}g;
$rexpr =~ s{\?}{\\\?}g;
$rexpr =~ s{\*}{\\\*}g;
$rexpr =~ s{\[}{\\\[}g;
$rexpr =~ s{\]}{\\\]}g;
$rexpr =~ s{\.}{\\\.}g;
$rexpr =~ s{\$}{\\\$}g;
$rexpr =~ s{\^}{\\\^}g;
# Clear the buffer.
@BUFFER = ();
# Iterate through all quotes.
foreach my $qkt (keys %$quotes) {
# Check if we have a match.
if ($quotes->{$qkt}->{quote} =~ m/$rexpr/ixsm) {
# Match. Add to buffer.
push @BUFFER, "\2ID:\2 $qkt - ".$quotes->{$qkt}->{quote};
}
}
# Check if we had any matches.
if (!defined $BUFFER[0]) {
privmsg($src->{svr}, $src->{chan}, "No results for \2$expr\2.");
return;
}
# Return four quotes.
privmsg($src->{svr}, $src->{chan}, "\2".scalar @BUFFER."\2 results for \2$expr\2:");
my $i = 0;
my $si = 3;
if (conf_get('qdb_search_resnum')) { $si = (conf_get('qdb_search_resnum'))[0][0] - 1; }
while ($i <= $si) {
if (!defined $BUFFER[0]) {
last;
}
privmsg($src->{svr}, $src->{chan}, shift @BUFFER);
$i++;
}
}
when ('MORE') {
# Check if there's any quotes in the buffer.
if (!defined $BUFFER[0]) {
notice($src->{svr}, $src->{nick}, 'No quotes in buffer.');
return;
}
# Return four quotes.
my $i = 0;
my $si = 3;
if (conf_get('qdb_search_resnum')) { $si = (conf_get('qdb_search_resnum'))[0][0] - 1; }
while ($i <= $si) {
if (!defined $BUFFER[0]) {
last;
}
privmsg($src->{svr}, $src->{chan}, shift @BUFFER);
$i++;
}
}
when ('DEL') {
# Check for the cmd.qdbdel privilege.
if (!has_priv(match_user(%data), 'cmd.qdbdel')) {
notice($data{svr}, $data{chan}, trans('Permission denied').q{.});
if (!has_priv(match_user(%$src), 'cmd.qdbdel')) {
notice($src->{svr}, $src->{chan}, trans('Permission denied').q{.});
return;
}
# Check for the needed parameter.
if (!defined $argv[1]) {
notice($data{svr}, $data{nick}, trans('Not enough parameters').q{.});
notice($src->{svr}, $src->{nick}, trans('Not enough parameters').q{.});
return;
}
# Update database.
my $dbq = $Auto::DB->do("UPDATE qdb SET quote = \"NOTICE: Quote deleted.\" WHERE key = $argv[1]");
my $dbq = $Auto::DB->do("UPDATE qdb SET quote = \"NOTICE: Quote deleted.\" WHERE quoteid = $argv[1]");
notice($data{svr}, $data{nick}, (($dbq) ? 'Done.' : trans('An error occurred').q{.}));
notice($src->{svr}, $src->{nick}, (($dbq) ? 'Done.' : trans('An error occurred').q{.}));
}
default { notice($data{svr}, $data{nick}, "Unknown action \002".uc($argv[0])."\002. \002Syntax:\002 QDB (ADD|VIEW|COUNT|RAND|DEL) [quote]"); return; }
default { notice($src->{svr}, $src->{nick}, "Unknown action \002".uc($argv[0])."\002. \002Syntax:\002 QDB (ADD|VIEW|COUNT|RAND|DEL) [quote]"); return; }
}
return 1;
}
API::Std::mod_init('QDB', 'Xelhua', '1.00', '3.0.0d', __PACKAGE__);
API::Std::mod_init('QDB', 'Xelhua', '1.02', '3.0.0a4', __PACKAGE__);
# vim: set ai sw=4 ts=4:
# build: perl=5.010000
__END__
=head1 QDB
=head1 NAME
=head2 Description
QDB - Quote database module.
=over
=head1 VERSION
This module adds the QDB (ADD|VIEW|COUNT|RAND|DEL) command, for adding,
viewing, listing number of, viewing a random, deleting a quote from the Auto
database.
1.02
=back
=head1 SYNOPSIS
=head2 Examples
<JohnSmith> !qdb add <JohnDoe> moocows
<Auto> Quote successfully submitted. ID: 732
=over
=head1 DESCRIPTION
<JohnSmith> !qdb add <JohnDoe> moocows
<Auto> Quote successfully submitted. ID: 732
This module adds the QDB (ADD|VIEW|COUNT|RAND|SEARCH|MORE|DEL) command, for
adding, viewing, listing number of, viewing a random, deleting a quote from the
Auto database.
=back
=head1 INSTALL
=head2 Technical
Before using QDB, we'd recommend adding the following to your configuration
file:
=over
qdb_search_resnum <number>;
This module is compatible with Auto v3.0.0a3+.
Where <number> is the amount of results returned per SEARCH/MORE load.
=back
This is not required, 4 will be used if it is not specified.
=head1 AUTHOR
This module was written by Elijah Perrault.
This module is maintained by Xelhua Development Group.
=head1 LICENSE AND COPYRIGHT
This module is Copyright 2010-2011 Xelhua Development Group.
Released under the same licensing terms as Auto itself.
=cut
+17 -17
View File
@@ -1,7 +1,7 @@
# Module: SASLAuth. See below for documentation.
# Copyright (C) 2010-2011 Xelhua Development Group, et al.
# This program is free software; rights to this code are stated in doc/LICENSE.
package m_SASLAuth;
package M::SASLAuth;
use strict;
use warnings;
use feature qw(switch);
@@ -13,32 +13,32 @@ use API::IRC qw(privmsg);
# Initialization subroutine.
sub _init
{
# Check if this Auto was built with SASL support.
err(2, "Auto was not built with SASL support. Aborting SASLAuth.", 0) and return 0 if $Auto::ENFEAT !~ /sasl/;
# Add a hook for before we connect.
# Check if this Auto was built with SASL support.
err(2, "Auto was not built with SASL support. Aborting SASLAuth.", 0) and return 0 if $Auto::ENFEAT !~ /sasl/;
# Add a hook for before we connect.
hook_add('on_preconnect', 'CAP', sub { my ($srv) = @_; Auto::socksnd($srv, 'CAP LS'); }
) or return 0;
# Hook for parsing CAP.
rchook_add('CAP', \&m_SASLAuth::handle_cap) or return 0;
rchook_add('CAP', \&M::SASLAuth::handle_cap) or return 0;
# Hook for parsing 903.
rchook_add('903', \&m_SASLAuth::handle_903) or return 0;
rchook_add('903', \&M::SASLAuth::handle_903) or return 0;
# Hook for parsing 904.
rchook_add('904', \&m_SASLAuth::handle_904) or return 0;
rchook_add('904', \&M::SASLAuth::handle_904) or return 0;
# Hook for parsing 906.
rchook_add('906', \&m_SASLAuth::handle_906) or return 0;
return 1;
rchook_add('906', \&M::SASLAuth::handle_906) or return 0;
return 1;
}
# Void subroutine.
sub _void
{
# Delete the hooks.
hook_del("on_preconnect", "CAP") or return 0;
# Delete the hooks.
hook_del("on_preconnect", "CAP") or return 0;
rchook_del('CAP');
rchook_del('903');
rchook_del('904');
rchook_del('906');
return 1;
return 1;
}
sub handle_cap {
@@ -123,20 +123,20 @@ sub handle_904
# SASL authentication aborted.
sub handle_906
{
my ($svr, undef) = @_;
Auto::socksnd($svr, 'CAP END');
my ($svr, undef) = @_;
Auto::socksnd($svr, 'CAP END');
timer_del('auth_timeout');
awarn(2, "SASL authentication aborted!");
}
# Start initialization.
API::Std::mod_init("SASLAuth", "Xelhua", "1.00", "3.0.0d", __PACKAGE__);
API::Std::mod_init('SASLAuth', 'Xelhua', '1.00', '3.0.0a4', __PACKAGE__);
# vim: set ai sw=4 ts=4:
# build: perl=5.010000
__END__
=head1 SASL Auth
=head1 SASLAuth
=head2 Description
@@ -188,6 +188,6 @@ block(s) you wish to use SASL with:
This adds an extra dependency: You must build Auto with the
--enable-sasl option.
This module is compatible with Auto v3.0.0a1+.
This module is compatible with Auto v3.0.0a4+.
=back
+47 -48
View File
@@ -1,7 +1,7 @@
# Module: Weather. See below for documentation.
# Copyright (C) 2010-2011 Xelhua Development Group, et al.
# This program is free software; rights to this code are stated in doc/LICENSE.
package m_Weather;
package M::Weather;
use strict;
use warnings;
use API::Std qw(cmd_add cmd_del trans);
@@ -12,74 +12,73 @@ use XML::Simple;
# Initialization subroutine.
sub _init
{
# Create the Weather command.
cmd_add("WEATHER", 0, 0, \%m_Weather::HELP_WEATHER, \&m_Weather::weather) or return 0;
# Create the Weather command.
cmd_add("WEATHER", 0, 0, \%M::Weather::HELP_WEATHER, \&M::Weather::weather) or return 0;
# Success.
return 1;
# Success.
return 1;
}
# Void subroutine.
sub _void
{
# Delete the Weather command.
cmd_del("WEATHER") or return 0;
# Delete the Weather command.
cmd_del("WEATHER") or return 0;
# Success.
return 1;
# Success.
return 1;
}
# Help hashes.
our %HELP_WEATHER = (
'en' => "This command will retrieve the weather via Wunderground for the specified location. \002Syntax:\002 WEATHER <location>",
'en' => "This command will retrieve the weather via Wunderground for the specified location. \002Syntax:\002 WEATHER <location>",
);
# Callback for Weather command.
sub weather
{
my (%data) = @_;
my ($src, @args) = @_;
# Create an instance of LWP::UserAgent.
my $ua = LWP::UserAgent->new();
$ua->agent('Auto IRC Bot');
$ua->timeout(2);
# Put together the call to the Wunderground API.
my @args = @{ $data{args} };
if (!defined $args[0]) {
notice($data{svr}, $data{nick}, trans("Not enough parameters").".");
return 0;
}
my $loc = join(' ', @args);
$loc =~ s/ /%20/g;
my $url = "http://api.wunderground.com/auto/wui/geo/WXCurrentObXML/index.xml?query=".$loc;
# Get the response via HTTP.
my $response = $ua->get($url);
# Create an instance of LWP::UserAgent.
my $ua = LWP::UserAgent->new();
$ua->agent('Auto IRC Bot');
$ua->timeout(2);
# Put together the call to the Wunderground API.
if (!defined $args[0]) {
notice($src->{svr}, $src->{nick}, trans("Not enough parameters").".");
return 0;
}
my $loc = join(' ', @args);
$loc =~ s/ /%20/g;
my $url = "http://api.wunderground.com/auto/wui/geo/WXCurrentObXML/index.xml?query=".$loc;
# Get the response via HTTP.
my $response = $ua->get($url);
if ($response->is_success) {
# If successful, decode the content.
my $d = XMLin($response->decoded_content);
# And send to channel
if (!ref($d->{observation_location}->{country})) {
my $windc = $d->{wind_string};
if (substr($windc, length($windc) - 1, 1) eq " ") { $windc = substr($windc, 0, length($windc) - 1); }
privmsg($data{svr}, $data{chan}, "Results for \2".$d->{observation_location}->{full}."\2 - \2Temperature:\2 ".$d->{temperature_string}." \2Wind Conditions:\2 ".$windc." \2Conditions:\2 ".$d->{weather});
privmsg($data{svr}, $data{chan}, "\2Heat index:\2 ".$d->{heat_index_string}." \2Humidity:\2 ".$d->{relative_humidity}." \2Pressure:\2 ".$d->{pressure_string}." - ".$d->{observation_time});
}
else {
# Otherwise, send an error message.
privmsg($data{svr}, $data{chan}, "Location not found.");
}
}
else {
# Otherwise, send an error message.
privmsg($data{svr}, $data{chan}, "An error occurred while retrieving your weather.");
}
if ($response->is_success) {
# If successful, decode the content.
my $d = XMLin($response->decoded_content);
# And send to channel
if (!ref($d->{observation_location}->{country})) {
my $windc = $d->{wind_string};
if (substr($windc, length($windc) - 1, 1) eq " ") { $windc = substr($windc, 0, length($windc) - 1); }
privmsg($src->{svr}, $src->{chan}, "Results for \2".$d->{observation_location}->{full}."\2 - \2Temperature:\2 ".$d->{temperature_string}." \2Wind Conditions:\2 ".$windc." \2Conditions:\2 ".$d->{weather});
privmsg($src->{svr}, $src->{chan}, "\2Heat index:\2 ".$d->{heat_index_string}." \2Humidity:\2 ".$d->{relative_humidity}." \2Pressure:\2 ".$d->{pressure_string}." - ".$d->{observation_time});
}
else {
# Otherwise, send an error message.
privmsg($src->{svr}, $src->{chan}, "Location not found.");
}
}
else {
# Otherwise, send an error message.
privmsg($src->{svr}, $src->{chan}, "An error occurred while retrieving your weather.");
}
return 1;
return 1;
}
# Start initialization.
API::Std::mod_init("Weather", "Xelhua", "1.00", "3.0.0d", __PACKAGE__);
API::Std::mod_init('Weather', 'Xelhua', '1.00', '3.0.0a4', __PACKAGE__);
# vim: set ai sw=4 ts=4:
# build: cpan=LWP::UserAgent,XML::Simple perl=5.010000
@@ -122,6 +121,6 @@ From the NE at 9 MPH Gusting to 22 MPH Conditions: Overcast
This module requires LWP::UserAgent and XML::Simple. Both are
obtainable from CPAN <http://www.cpan.org>.
This module is compatible with Auto version 3.0.0a2+.
This module is compatible with Auto version 3.0.0a4+.
=back
Executable
+66
View File
@@ -0,0 +1,66 @@
# upgrade.pl - Upgrade SQLite database from 3.0.0a3 to 3.0.0a4.
# Copyright (C) 2010-2011 Xelhua Development Group, et al.
# This program is free software; rights to this code are stated in doc/LICENSE.
use 5.010_000;
use strict;
use warnings;
use DBI;
use DBD::SQLite;
use Carp;
use Cwd;
our $Bin = getcwd();
#################
# Configuration #
#################
# Old database filename. (relative to etc/)
my $olddbfile = 'auto.db';
# New database filename. (relative to etc/)
my $newdbfile = 'somebot.db';
##########################
# Program - Don't touch. #
##########################
# Print startup message.
say 'Converting database from Auto-3.0.0a3 format to Auto-3.0.0a4 format...';
# Connect to database.
my $DB = DBI->connect("dbi:SQLite:dbname=$Bin/etc/$olddbfile") or croak 'Failed to open old DB!';
# Query the database for the data from the `qdb` table.
my $dbq = $DB->prepare('SELECT * FROM qdb') or croak 'Failed to query for `qdb` data!';
$dbq->execute() or croak 'Failed to query for `qdb` data!';
my $data = $dbq->fetchall_hashref('key');
my %data = %$data;
# Disconnect from database.
$DB->disconnect;
# Now, connect to the new database so we can enter the data in the new format.
if (!-e "$Bin/etc/$newdbfile") {
system "touch $Bin/etc/$newdbfile";
chmod 0755, "$Bin/etc/$newdbfile";
}
$DB = DBI->connect("dbi:SQLite:dbname=$Bin/etc/$newdbfile") or croak 'Failed to open new DB!';
# Create the `qdb` table.
$DB->do('CREATE TABLE IF NOT EXISTS qdb (quoteid INTEGER PRIMARY KEY, creator TEXT, time INT, quote TEXT)') or croak 'Failed to create `qdb` table!';
# Iterate through the data.
foreach my $qid (sort keys %data) {
# Prepare query to insert data.
my $ndbq = $DB->prepare('INSERT INTO qdb (quoteid, creator, time, quote) VALUES (?, ?, ?, ?)') or croak 'Failed to query `qdb` table!';
# Insert data.
$ndbq->execute($qid, $data{$qid}{creator}, $data{$qid}{'time'}, $data{$qid}{quote}) or croak 'Failed to query `qdb` table!';
}
# Disconnect from database.
$DB->disconnect;
# Success.
say 'Done.';