91 Commits
Author SHA1 Message Date
Elijah Perrault af92eed006 Updated. 2011-02-27 21:40:59 -07:00
Elijah Perrault f904d3e991 Updated for alpha6 release. 2011-02-27 21:38:00 -07:00
Elijah Perrault f51e695a2a My last commit also included a bugfix regarding SASL timeout. 2011-02-27 21:36:06 -07:00
Elijah Perrault e65f5d6f0a Cleanup, CAP is now core and added hook on_capack. 2011-02-27 21:33:47 -07:00
Elijah Perrault b48e77a4b3 Trigger on_shutdown in the event of a fatal error. 2011-02-27 20:26:37 -07:00
Elijah Perrault bfa0baf51e Cleaned up socket creation heavily. 2011-02-27 20:23:56 -07:00
Elijah Perrault c5f8a31bd0 Fixed a bug with multi-prefix support. 2011-02-27 16:55:06 -07:00
Elijah Perrault 66cc08fd87 Use fpfmt here. 2011-02-27 16:18:38 -07:00
Elijah Perrault b0fc9065f5 Added fpfmt() to API::Std, and removed the %20's from Bin. 2011-02-27 16:17:40 -07:00
Elijah Perrault ec363be888 Replace spaces in the file path with %20. 2011-02-27 12:52:06 -07:00
Elijah Perrault eda22e02db Use quotes to satisfy Windows. 2011-02-27 12:50:27 -07:00
Elijah Perrault 8d5664c7ef Added an extra note. 2011-02-27 12:49:47 -07:00
Elijah Perrault 7e8ba692f7 Add a check for Solaris. 2011-02-26 23:49:57 -07:00
Elijah Perrault 3e418271c7 Some notes for when running on Windows. 2011-02-26 23:32:45 -07:00
Elijah Perrault c3b3c56322 Windows is now supported. 2011-02-26 23:16:32 -07:00
Elijah Perrault f7b5428c60 Auto::GR renamed to $Auto::VERGITREV. 2011-02-26 23:11:37 -07:00
Elijah Perrault ef75910c0e Invoke perl from command line instead. 2011-02-26 21:11:33 -07:00
Elijah Perrault 6d0efb08f7 Cleanup. 2011-02-26 21:07:43 -07:00
Elijah Perrault 3ca1685044 Needs more exit. 2011-02-26 20:09:40 -07:00
Elijah Perrault aa1302c1bb Cleaning up. 2011-02-26 20:08:15 -07:00
Elijah Perrault 14334122bc Cleaning up. 2011-02-26 19:54:50 -07:00
Elijah Perrault c88c8f66f3 Whoops. 2011-02-26 17:21:09 -07:00
Elijah Perrault 0ba0d8e030 A list of abbreviated with full name licenses, for future reference. 2011-02-26 17:02:09 -07:00
Elijah Perrault db3f388006 Fixed a few warnings. 2011-02-26 14:49:53 -07:00
Elijah Perrault 5b8568f811 Bumped minimum version for API to 3.0.0a6. 2011-02-26 14:36:43 -07:00
Elijah Perrault d33d47afd2 Cleaned up TOPIC parsing. 2011-02-26 14:27:57 -07:00
Elijah Perrault 5c517b8093 This has been removed. 2011-02-26 14:09:40 -07:00
Elijah Perrault 58063f147d New hook on_isupport, code cleanup, and now parsing numeric 004 (RPL_MYINFO). 2011-02-26 14:08:39 -07:00
Elijah Perrault 8f5da92a45 Updated list. 2011-02-25 23:16:30 -07:00
Elijah Perrault 88e8930aff Fixed a bug in TOP10. 2011-02-25 22:21:51 -07:00
Elijah Perrault 2e7ab78f7e Removed a comma. 2011-02-25 21:29:20 -07:00
Elijah Perrault a8b8256385 Added a BotStats module for returning statistics about the bot. 2011-02-25 21:26:40 -07:00
Elijah Perrault 501dd30a0b Now parsing numeric 396. 2011-02-25 20:48:45 -07:00
Elijah Perrault 8512ea129a * Added who() to API::IRC.
* Added hook on_whoreply.
* PRIVMSGs and NOTICEs that would cause a >512 bytes resulting message are now divided into multiple messages.
* Renamed botnick to botinfo.
2011-02-25 20:14:19 -07:00
Elijah Perrault 9c8200fb78 Updated. 2011-02-25 18:23:51 -07:00
Elijah Perrault d5378cca9f Continue renaming. 2011-02-25 18:22:13 -07:00
Elijah Perrault 06aaf41ef0 Continue renaming process. 2011-02-25 18:19:58 -07:00
Elijah Perrault 402dfade65 Merge branch 'indev' of github.com:Xelhua/Auto into indev 2011-02-25 18:16:22 -07:00
Elijah Perrault 217fdbd1e7 We're renaming Parser::IRC to Proto::IRC. 2011-02-25 18:15:57 -07:00
Elijah Perrault a895a77418 Sigh. Now, fix it. 2011-02-25 13:06:26 -07:00
Elijah Perrault 91185e5ec3 Now, fix it. 2011-02-25 13:06:16 -07:00
Elijah Perrault 989d52b7f7 Set et to true in modelines. 2011-02-25 13:02:59 -07:00
Elijah Perrault b25ec915b9 Can now be used in a channel and, now returns any errors that occur. 2011-02-23 15:02:17 -07:00
Elijah Perrault 064f1099e3 Added an Eval module for evaluating Perl code. 2011-02-23 14:43:19 -07:00
Elijah Perrault b7d6da07b0 Accept alpha6 modules. 2011-02-23 14:27:29 -07:00
Elijah Perrault f481f9d4e7 Whoops, this was for 3.0.0a6, not 3.0.0a5. 2011-02-23 14:25:24 -07:00
Elijah Perrault fdb4093ad6 Added 'any' option for uno:edition (see POD:INSTALL) and made edition update on rehash. 2011-02-23 11:55:11 -07:00
Elijah Perrault 0bbcdd7f4b Fix formatting. 2011-02-23 11:34:21 -07:00
Elijah Perrault 71056bc2ed Fixed a bug with wildcards and made red|green|blue|yellow valid colors. 2011-02-22 22:30:01 -07:00
Elijah Perrault 88cdde59ce Updated. 2011-02-22 22:16:46 -07:00
Elijah Perrault 910c1afb86 Added an UNO module for endless fun playing the UNO card game. Warning: Can be addicting. MAKE SURE TO READ THE DOCS. 2011-02-22 22:14:59 -07:00
Elijah Perrault 39ce9b2da4 Updated. 2011-02-22 21:19:15 -07:00
Elijah Perrault cae3f191a8 Initialize the on_part event. 2011-02-22 21:18:27 -07:00
Elijah Perrault 47605fd33e Remove any leading colons. 2011-02-22 11:10:11 -07:00
Elijah Perrault 4de600d91a Updated for 3.0.0a5. 2011-02-21 23:31:55 -07:00
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
40 changed files with 4150 additions and 2010 deletions

No files matched your search

+2 -1
View File
@@ -1,3 +1,4 @@
*.conf
auto.conf
build/*
*.swp
autodoc/*
+13 -19
View File
@@ -11,32 +11,26 @@
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 alpha4 release, we have added:
In this alpha6 release, we have added:
* MySQL support.
* PostgreSQL support.
* A Greet module for greeting users on join.
* IRC logchan functionality.
* Improved multilingual support.
* A ChanTopics module for advanced management of channel topics.
* buildmod now generates HTML and man(1) pages from a module's POD.
* server:ajoin now supports channel keys by spacing the name and key.
* A Dictionary module for looking up definitions of words.
* Heavily improved module API.
* Support for Microsoft Windows. See doc/WINDOWS if running on Windows.
* Added an UNO module for playing the classic game of UNO.
* Added an Eval module for evaluating Perl code.
* Added a BotStats module for returning statistics about the bot.
* PRIVMSG's and NOTICE's that would create a resulting message of >512 bytes are
now divided into multiple messages.
Bug fixes:
* Commands getting Permission denied even with incorrect prefix.
* Program not properly shutting down if all IRC connections close.
* Fixed a bug that occurs when our configured nickname is in use.
* Fixed a bug with multi-prefix support.
* Fixed a bug with SASL timeouts.
Incompatibilities:
* Database: Changed structure of the `qdb` table. Modify the configuration
values in upgrade.pl then run it to upgrade the database.
* database:format is now required in the config.
* bantype is now required in the config.
* Module API changes. Minimum version is now 3.0.0a6 from 3.0.0a4.
We thank you for choosing Auto. Please remember that he is still in early
We thank you for choosing Auto. Please remember that he is still in mid-
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.
@@ -44,4 +38,4 @@ 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 4!
Enjoy Auto 3.0.0 Alpha 6!
+29 -33
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:
# vim: set ai et sw=4 ts=4:
+152 -207
View File
@@ -21,23 +21,26 @@ our $Bin = $Bin; ## no critic qw(NamingConventions::Capitalization Variables::Pr
BEGIN {
unshift @INC, "$Bin/../lib";
open my $gitfh, '<', "$Bin/../.git/refs/heads/indev";
our $VERGITREV = substr readline $gitfh, 0, 7;
close $gitfh;
# Set version information.
use constant { ## no critic qw(ValuesAndExpressions::ProhibitConstantPragma)
NAME => 'Auto IRC Bot',
VER => 3,
SVER => 0,
REV => 0,
RSTAGE => 'd',
GR => substr `cat $Bin/../.git/refs/heads/indev`, 0, 7
NAME => 'Auto IRC Bot',
VER => 3,
SVER => 0,
REV => 0,
RSTAGE => 'd',
};
}
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;
use Parser::IRC;
use Proto::IRC;
use Core::IRC;
use Core::Cmd;
@@ -46,7 +49,7 @@ 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") {
say '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.
@@ -54,7 +57,7 @@ open my $BFOS, '<', "$Bin/../build/os" or say 'Cannot start: Broken build.' and
my @BFOS = <$BFOS>;
close $BFOS or say 'Cannot start: Broken build.' and exit;
if ($BFOS[0] ne $OSNAME."\n") {
say 'Cannot start: Broken build.' and exit;
say 'Cannot start: Broken build.' and exit;
}
undef @BFOS;
@@ -71,7 +74,7 @@ open my $BFPERL, '<', "$Bin/../build/perl" or say 'Cannot start: Broken build.'
my @BFPERL = <$BFPERL>;
close $BFPERL or say 'Cannot start: Broken build.' and exit;
if ($BFPERL[0] ne $]."\n") {
say 'Cannot start: Broken build.' and exit;
say 'Cannot start: Broken build.' and exit;
}
undef @BFPERL;
@@ -80,7 +83,7 @@ open my $BFVER, '<', "$Bin/../build/ver" or say 'Cannot start: Broken build.' an
my @BFVER = <$BFVER>;
close $BFVER or say 'Cannot start: Broken build.' and exit;
if ($BFVER[0] ne VER.q{.}.SVER.q{.}.REV.RSTAGE."\n") {
say 'Cannot start: Broken build.' and exit;
say 'Cannot start: Broken build.' and exit;
}
undef @BFVER;
@@ -112,8 +115,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; }
}
@@ -135,23 +138,23 @@ our %SETTINGS = $CONF->parse or err(1, 'Failed to parse configuration file!', 1)
say ' Success';
if (conf_get('die')) {
if ((conf_get('die'))[0][0] == 1) {
say '!!! You didn\'t read the whole config.';
say '!!! 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 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;
@@ -179,8 +182,9 @@ given (lc((conf_get('database:format'))[0][0])) {
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];
open my $dbfh, '>', "$Bin/../etc/".(conf_get('database:filename'))[0][0];
close $dbfh;
chmod 0755, "$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);
@@ -253,49 +257,49 @@ 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.
@@ -303,6 +307,14 @@ our $STARTTIME = time;
say '* Auto successfully started at '.POSIX::strftime('%Y-%m-%d %I:%M:%S %p', localtime).q{.};
alog 'Auto successfully started.';
# If we're on Windows, disable forking.
if ($OSNAME =~ /win/i) {
if (!$DEBUG) {
say '!!! Forking unavailable (OS is Microsoft Windows), continuing in debug mode.';
$DEBUG = 1;
}
}
# Fork into the background if not in debug mode.
if (!$DEBUG) {
say '*** Becoming a daemon...';
@@ -312,12 +324,9 @@ if (!$DEBUG) {
$APID = fork;
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;
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);
@@ -328,14 +337,20 @@ else {
# Events.
API::Std::event_add('on_preconnect');
# CAP.
my %tcsvrs = conf_get('server');
foreach my $svr (keys %tcsvrs) {
$Proto::IRC::cap{$svr} = 'multi-prefix';
}
undef %tcsvrs;
# 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.
@@ -346,94 +361,25 @@ my %cservers = conf_get('server');
# Set the socket hash and select instance.
our (%SOCKET, $SELECT);
$SELECT = IO::Select->new();
my $it = 0;
# Iterate through each configured server.
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],
Timeout => 20,
);
# Set IPv6/SSL data.
my $use6 = 0;
my $usessl = 0;
if (defined $cservers{$cskey}{'ipv6'}[0]) { $use6 = $cservers{$cskey}{'ipv6'}[0]; }
if (defined $cservers{$cskey}{'ssl'}[0]) { $usessl = $cservers{$cskey}{'ssl'}[0]; }
# CertFP.
if ($usessl) {
if (defined $cservers{$cskey}{'certfp'}[0]) {
if ($cservers{$cskey}{'certfp'}[0] eq 1) {
$conndata{'SSL_use_cert'} = 1;
if (defined $cservers{$cskey}{'certfp_cert'}[0]) {
$conndata{'SSL_cert_file'} = "$Bin/../etc/certs/".$cservers{$cskey}{'certfp_cert'}[0];
}
if (defined $cservers{$cskey}{'certfp_key'}[0]) {
$conndata{'SSL_key_file'} = "$Bin/../etc/certs/".$cservers{$cskey}{'certfp_key'}[0];
}
if (defined $cservers{$cskey}{'certfp_pass'}[0]) {
$conndata{'SSL_passwd_cb'} = sub { return $cservers{$cskey}{'certfp_pass'}[0]; };
}
}
}
}
# Create the socket.
if ($use6) {
$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.
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.
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;
Lib::Auto::ircsock(\%{$cservers{$cskey}}, $cskey);
}
# Success!
if ($it) {
alog '** Success: Connected to server(s).';
dbug '** Success: Connected to server(s).';
if (keys %SOCKET) {
alog '** Success: Connected to server(s).';
dbug '** Success: Connected to server(s).';
}
else {
err(2, 'No server connections.', 1);
err(2, 'No IRC connections -- Exiting program.', 1);
}
undef $it;
# Create core commands.
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);
@@ -441,40 +387,40 @@ 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.
@@ -485,22 +431,22 @@ while (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);
}
}
Proto::IRC::ircparse($sockid, $line);
}
}
}
###############
@@ -508,18 +454,17 @@ while (1) {
###############
# Send data to socket.
sub socksnd
{
my ($svr, $data) = @_;
sub socksnd {
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."\r\n", POSIX::BUFSIZ, 0;
dbug "$svr << $data";
return 1;
}
else {
return 0;
}
}
# Load a module.
@@ -546,4 +491,4 @@ sub mod_load {
return;
}
# vim: set ai sw=4 ts=4:
# vim: set ai et sw=4 ts=4:
+1 -1
View File
@@ -150,4 +150,4 @@ $manifier->parse_from_file("$Bin/../autodoc/$module.pod", "$Bin/../autodoc/$modu
print $RS;
say 'Done.';
# vim: set ai sw=4 ts=4:
# vim: set ai et sw=4 ts=4:
+1 -1
View File
@@ -58,4 +58,4 @@ foreach (@violations) {
}
say "$count violations in $ARGV[0].";
# vim: set ai sw=4 ts=4:
# vim: set ai et sw=4 ts=4:
+1 -1
View File
@@ -44,4 +44,4 @@ while ($fpr =~ s/(.*\n)//) {
# Print the fingerprint.
say 'Done. Fingerprint: '.$fp;
# vim: set ai sw=4 ts=4:
# vim: set ai et sw=4 ts=4:
+43
View File
@@ -2,6 +2,49 @@ Auto IRC Bot 3.0: Change Log
-------------------------------------------------------------------------------
3.0 Indev
===============================================================================
3.0 Alpha 6
===============================================================================
* Bug fix: Fixed an issue with SASL timeout.
* Added hook on_capack.
* CAP is now core.
* Fixed a bug with multi-prefix support.
* Added fpfmt() to API::Std.
* Auto::GR renamed to $Auto::VERGITREV.
* Bumped minimum version for API to 3.0.0a6.
* Changed on_topic args to: full source hashref, new topic array
* on_topic is now triggered for any topic change, regardless of source.
* Now parsing numeric 004.
* Added hook on_isupport.
* Added a BotStats module for returning statistics about the bot.
* Now parsing numeric 396.
* Added who() to API::IRC.
* Added hook on_whoreply.
* PRIVMSGs and NOTICEs that would cause a >512 bytes resulting message are
now divided into multiple messages.
* Renamed botnick to botinfo.
* Renamed Parser::IRC to Proto::IRC.
* Added an Eval module.
* Added an UNO module.
* Added on_part hook.
3.0 Alpha 5
===============================================================================
* 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.
+2 -2
View File
@@ -42,7 +42,7 @@ Legend:
[!] Features
[X] Weather module
[!] Urban Dictionary module
[ ] UNO module
[X] UNO module
[ ] Google Search module
[ ] IRC Relay module
[ ] (Google?) News module
@@ -51,7 +51,7 @@ Legend:
[X] Google Calculator module
[ ] YouTube Search module
[ ] Twitter module
[!] Advanced Topics module
[X] Advanced Topics module
[ ] Custom Triggers module
[X] Shorten URL (bit.ly?) module
[?] Bot Talk module
+18
View File
@@ -0,0 +1,18 @@
Auto IRC Bot 3.0: Microsoft Windows Notes
===============================================================================
When running Auto on Microsoft Windows, you should be aware of the following:
* Windows support has not been thoroughly tested, some scripts/features may not
function correctly.
* Forking into the background is disabled.
* Some file system operations may fail if Auto is installed to a path with
spaces. Please report these.
For the full power of Auto; run him in a UNIX environment.
Since Windows support can be considered experimental, testers are welcome and
you should report anything you find to malfunction.
At some point in the future, we hope to achieve Windows support with no core
caveats. Again, reporting issues in Auto on Windows is highly appreciated.
+33 -38
View File
@@ -19,18 +19,18 @@ our $ERROR = 0;
# Iterate through the arguments passed to us.
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.';
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';
}
println '*** End of Help ***';
exit 1;
}
elsif ($_ eq '--enable-sasl') {
$features .= ' sasl';
}
elsif ($_ eq '--disable-ssl') {
$features =~ s/ ssl//g;
}
@@ -40,13 +40,13 @@ if (defined $ARGV[0]) {
elsif ($_ eq '--with-mysql') {
$features =~ s/(sqlite|pgsql)/mysql/g;
}
elsif ($_ eq '--with-pgsql') {
elsif ($_ eq '--with-pgsql') {
$features =~ s/(sqlite|mysql)/pgsql/g;
}
else {
println "Warning: Unknown option '$_'";
}
}
println "Warning: Unknown option '$_'";
}
}
}
# Check Perl version.
@@ -58,32 +58,39 @@ 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";
exit;
}
elsif ($OSNAME eq "MSWin32") {
print "Microsoft Windows is not supported. Support is planned for the future.\r\n";
print "OK\r\n";
}
elsif ($OSNAME eq "NetWare") {
print "NetWare is not supported.\r\n";
print "NetWare is not supported.\r\n";
exit;
}
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";
exit;
}
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";
}
elsif ($OSNAME eq "solaris") {
print "OK\n";
}
else {
print "Unknown operating system. Contact support.\r\n";
}
print "Unknown operating system. Contact support.\r\n";
exit;
}
# Check for Perl core modules.
println "Checking for core Perl modules.....";
@@ -124,19 +131,7 @@ else {
println "\0";
println "Building.....";
if (!-d "$Bin/build") {
system "mkdir $Bin/build";
}
if (!-e "$Bin/build/time") {
system "touch $Bin/build/time";
}
if (!-e "$Bin/build/os") {
system "touch $Bin/build/os";
}
if (!-e "$Bin/build/perl") {
system "touch $Bin/build/perl";
}
if (!-e "$Bin/build/ver") {
system "touch $Bin/build/ver";
mkdir "$Bin/build";
}
build($features);
@@ -149,4 +144,4 @@ println q{};
# Success!
println "Done. Auto successfully installed.";
# vim: set ai sw=4 ts=4:
# vim: set ai et sw=4 ts=4:
+116 -93
View File
@@ -9,7 +9,7 @@ use Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(ban cjoin cpart cmode umode kick privmsg notice quit nick names
topic usrc match_mask);
topic who usrc match_mask);
# Set a ban, based on config bantype value.
@@ -48,68 +48,84 @@ sub ban
# Join a channel.
sub cjoin
{
my ($svr, $chan, $key) = @_;
Auto::socksnd($svr, "JOIN ".((defined $key) ? "$chan $key" : "$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;
if (defined $Proto::IRC::botchans{$svr}{$chan}) { delete $Proto::IRC::botchans{$svr}{$chan}; }
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 ".$Proto::IRC::botinfo{$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) = @_;
# Get maximum length.
my $maxlen = 510 - length q{:}.$Proto::IRC::botinfo{$svr}{nick}.q{!}.$Proto::IRC::botinfo{$svr}{user}.q{@}.$Proto::IRC::botinfo{$svr}{mask}." PRIVMSG $target :";
# Divide message if it surpasses the maximum length.
while (length $message >= $maxlen) {
my $submsg = substr $message, 0, $maxlen, q{};
Auto::socksnd($svr, "PRIVMSG $target :$submsg");
}
if (length $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) = @_;
# Get maximum length.
my $maxlen = 510 - length q{:}.$Proto::IRC::botinfo{$svr}{nick}.q{!}.$Proto::IRC::botinfo{$svr}{user}.q{@}.$Proto::IRC::botinfo{$svr}{mask}." NOTICE $target :";
# Divide message if it surpasses the maximum length.
while (length $message >= $maxlen) {
my $submsg = substr $message, 0, $maxlen, q{};
Auto::socksnd($svr, "NOTICE $target :$submsg");
}
if (length $message) { Auto::socksnd($svr, "NOTICE $target :$message") }
return 1;
}
# Send an ACTION PRIVMSG.
@@ -125,33 +141,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");
$Proto::IRC::botinfo{$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.
@@ -165,58 +181,65 @@ 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;
sub quit {
my ($svr, $reason) = @_;
if (defined $reason) {
Auto::socksnd($svr, "QUIT :$reason");
}
else {
Auto::socksnd($svr, "QUIT :Leaving");
}
delete $Proto::IRC::got_001{$svr} if (defined $Proto::IRC::got_001{$svr});
delete $Proto::IRC::botinfo{$svr} if (defined $Proto::IRC::botinfo{$svr});
return 1;
}
# Send a WHO.
sub who {
my ($svr, $nick) = @_;
Auto::socksnd($svr, "WHO $nick");
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;
}
1;
# vim: set ai sw=4 ts=4:
# vim: set ai et sw=4 ts=4:
+54 -58
View File
@@ -10,7 +10,7 @@ use POSIX;
use Time::Local;
use Exporter;
use base qw(Exporter);
use API::Std qw(conf_get);
use API::Std qw(conf_get fpfmt);
our @EXPORT_OK = qw(println dbug alog slog);
@@ -18,11 +18,11 @@ 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;
}
@@ -33,79 +33,75 @@ 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.
say $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)
}
# 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 fpfmt("$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.
@@ -129,7 +125,7 @@ sub slog
}
# Check if we're in the channel.
if (!defined $Parser::IRC::botchans{$net}{$chan}) {
if (!defined $Proto::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;
@@ -143,4 +139,4 @@ sub slog
}
1;
# vim: set ai sw=4 ts=4:
# vim: set ai et sw=4 ts=4:
+280 -269
View File
@@ -11,237 +11,237 @@ 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 fpfmt);
# 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.0a4') {
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 ($autover !~ m/^3\.0\.0a(6)$/xsm) {
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;
}
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?');
# 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;
}
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{.});
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{.});
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;
}
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} }) {
my $ri = &{ $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;
}
@@ -249,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 $Proto::IRC::RAWC{$cmd}) { return; }
$Parser::IRC::RAWC{$cmd} = $sub;
$Proto::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 $Proto::IRC::RAWC{$cmd}) { return; }
delete $Parser::IRC::RAWC{$cmd};
delete $Proto::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 = shift;
$id =~ s/ /_/gsm;
$id =~ s/ /_/gsm;
if (defined $API::Std::LANGE{$id}) {
return sprintf $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.
@@ -374,55 +374,55 @@ 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];
if (defined $Auto::SOCKET{$svr}) {
if ($ccnm eq 'CURRENT' and defined $user{chan}) {
if (defined $Parser::IRC::chanusers{$svr}{$user{chan}}{$user{nick}}) {
if ($Parser::IRC::chanusers{$svr}{$user{chan}}{$user{nick}} =~ m/($ccst)/sm) { return $userkey; } ## no critic qw(RegularExpressions::RequireExtendedFormatting)
if (defined $Proto::IRC::chanusers{$svr}{$user{chan}}{$user{nick}}) {
if ($Proto::IRC::chanusers{$svr}{$user{chan}}{$user{nick}} =~ m/($ccst)/sm) { return $userkey; } ## no critic qw(RegularExpressions::RequireExtendedFormatting)
}
}
else {
foreach my $bcj (keys %{ $Parser::IRC::botchans{$svr} }) {
foreach my $bcj (keys %{ $Proto::IRC::botchans{$svr} }) {
if (API::IRC::match_mask($bcj, $ccnm)) {
if (defined $Parser::IRC::chanusers{$svr}{$bcj}{$user{nick}}) {
if ($Parser::IRC::chanusers{$svr}{$bcj}{$user{nick}} =~ m/($ccst)/sm) { return $userkey; } ## no critic qw(RegularExpressions::RequireExtendedFormatting)
if (defined $Proto::IRC::chanusers{$svr}{$bcj}{$user{nick}}) {
if ($Proto::IRC::chanusers{$svr}{$bcj}{$user{nick}} =~ m/($ccst)/sm) { return $userkey; } ## no critic qw(RegularExpressions::RequireExtendedFormatting)
}
}
}
}
}
}
}
}
}
}
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.
@@ -461,61 +461,72 @@ 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) {
say "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) {
API::Std::event_run('on_shutdown');
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) {
say "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;
}
# Formatting a file path.
sub fpfmt {
my ($path) = @_;
if ($path =~ m/\s/xsm) { return "\"$path\""; }
else { return $path; }
}
1;
# vim: set ai sw=4 ts=4:
# vim: set ai et sw=4 ts=4:
+26 -4
View File
@@ -125,9 +125,31 @@ sub cmd_modreload
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
@@ -164,10 +186,10 @@ sub cmd_restart
# Time to come back from the dead!
if ($Auto::DEBUG) {
system("$Auto::Bin/auto -d -nuc");
exec "perl $Auto::Bin/auto -d -nuc";
}
else {
system("$Auto::Bin/auto -nuc");
exec "perl $Auto::Bin/auto -nuc";
}
exit;
@@ -292,4 +314,4 @@ sub cmd_help
1;
# vim: set ai sw=4 ts=4:
# vim: set ai et sw=4 ts=4:
+82 -25
View File
@@ -19,7 +19,7 @@ hook_add("on_uprivmsg", "ctcp_version_reply", sub {
notice($src->{svr}, $src->{nick}, "\001VERSION ".Auto::NAME." ".Auto::VER.".".Auto::SVER.".".Auto::REV.Auto::RSTAGE." ".$OSNAME."\001");
}
else {
notice($src->{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::VERGITREV ".$OSNAME."\001");
}
}
@@ -32,8 +32,8 @@ hook_add("on_quit", "quit_update_chanusers", sub {
my %src = %{ $src };
# Delete the user from all channels.
foreach my $ccu (keys %{ $Parser::IRC::chanusers{$svr} }) {
if (defined $Parser::IRC::chanusers{$svr}{$ccu}{$src{nick}}) { delete $Parser::IRC::chanusers{$svr}{$ccu}{$src{nick}}; }
foreach my $ccu (keys %{ $Proto::IRC::chanusers{$svr} }) {
if (defined $Proto::IRC::chanusers{$svr}{$ccu}{$src{nick}}) { delete $Proto::IRC::chanusers{$svr}{$ccu}{$src{nick}}; }
}
return 1;
@@ -43,22 +43,31 @@ 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;
});
# Self-WHO on connect.
hook_add('on_connect', 'on_connect_selfwho', sub {
my ($svr) = @_;
API::IRC::who($svr, $Proto::IRC::botinfo{$svr}{nick});
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;
});
@@ -67,14 +76,14 @@ 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]);
# 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) {
@@ -84,13 +93,13 @@ hook_add("on_connect", "autojoin", sub {
}
else {
# Else join without one.
API::IRC::cjoin($svr, $_);
API::IRC::cjoin($svr, $_);
}
}
}
else {
# For multi-line ajoins.
foreach (@cajoin) {
}
else {
# For multi-line ajoins.
foreach (@cajoin) {
# Check if a key was specified.
if ($_ =~ m/\s/xsm) {
# There was, join with it.
@@ -114,6 +123,54 @@ hook_add("on_connect", "autojoin", sub {
return 1;
});
# WHO reply.
hook_add('on_whoreply', 'selfwho.getdata', sub {
my (($svr, $nick, undef, $user, $mask, undef, undef, undef, undef, undef)) = @_;
# Check if it's for us.
if ($nick eq $Proto::IRC::botinfo{$svr}{nick}) {
# It is. Set data.
$Proto::IRC::botinfo{$svr}{user} = $user;
$Proto::IRC::botinfo{$svr}{mask} = $mask;
}
return 1;
});
# ISUPPORT - Set prefixes and channel modes.
hook_add('on_isupport', 'core.prefixchanmode.getdata', sub {
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.
$Proto::IRC::csprefix{$svr}{$ppm} = shift(@app);
}
}
elsif ($ex =~ m/^CHANMODES/xsm) {
# Found CHANMODES.
my ($mtl, $mtp, $mtpp, $mts) = split m/[,]/xsm, substr($ex, 10);
# List modes.
foreach (split(//, $mtl)) { $Proto::IRC::chanmodes{$svr}{$_} = 1; }
# Modes with parameter.
foreach (split(//, $mtp)) { $Proto::IRC::chanmodes{$svr}{$_} = 2; }
# Modes with parameter when +.
foreach (split(//, $mtpp)) { $Proto::IRC::chanmodes{$svr}{$_} = 3; }
# Modes without parameter.
foreach (split(//, $mts)) { $Proto::IRC::chanmodes{$svr}{$_} = 4; }
}
}
return 1;
});
sub clear_usercmd_timer
{
# If ratelimit is set to 1 in config, add this timer.
@@ -133,4 +190,4 @@ sub clear_usercmd_timer
1;
# vim: set ai sw=4 ts=4:
# vim: set ai et sw=4 ts=4:
+101 -77
View File
@@ -4,11 +4,12 @@
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(hook_add conf_get err);
use API::Log qw(println dbug alog);
use API::Log qw(dbug alog);
our $VERSION = 3.000000;
# Core events.
@@ -19,7 +20,7 @@ API::Std::event_add('on_rehash');
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',
@@ -37,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.');
}
}
}
@@ -54,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 ratelimit database:format bantype);
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;
@@ -133,83 +134,106 @@ sub rehash
# Iterate through each configured server.
foreach my $cskey (keys %cservers) {
if (!defined $Auto::SOCKET{$cskey}) {
# Prepare socket data.
my %conndata = (
Proto => 'tcp',
LocalAddr => $cservers{$cskey}{'bind'}[0],
PeerAddr => $cservers{$cskey}{'host'}[0],
PeerPort => $cservers{$cskey}{'port'}[0],
Timeout => 20,
);
# Set IPv6/SSL data.
my $use6 = 0;
my $usessl = 0;
if (defined $cservers{$cskey}{'ipv6'}[0]) { $use6 = $cservers{$cskey}{'ipv6'}[0]; }
if (defined $cservers{$cskey}{'ssl'}[0]) { $usessl = $cservers{$cskey}{'ssl'}[0]; }
# CertFP.
if ($usessl) {
if (defined $cservers{$cskey}{'certfp'}[0]) {
if ($cservers{$cskey}{'certfp'}[0] eq 1) {
$conndata{'SSL_use_cert'} = 1;
if (defined $cservers{$cskey}{'certfp_cert'}[0]) {
$conndata{'SSL_cert_file'} = "$Auto::Bin/../etc/certs/".$cservers{$cskey}{'certfp_cert'}[0];
}
if (defined $cservers{$cskey}{'certfp_key'}[0]) {
$conndata{'SSL_key_file'} = "$Auto::Bin/../etc/certs/".$cservers{$cskey}{'certfp_key'}[0];
}
if (defined $cservers{$cskey}{'certfp_pass'}[0]) {
$conndata{'SSL_passwd_cb'} = sub { return $cservers{$cskey}{'certfp_pass'}[0]; };
}
}
}
}
# Create the socket.
if ($use6) {
$Auto::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 $Auto::SOCKET{$cskey} and next;
}
else {
if ($usessl) {
$Auto::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 $Auto::SOCKET{$cskey} and next;
}
else {
$Auto::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 $Auto::SOCKET{$cskey} and next;
}
}
# Send PASS if we have one.
if (defined $cservers{$cskey}{'pass'}[0]) {
Auto::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]);
Auto::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.
$Auto::SELECT->add($Auto::SOCKET{$cskey});
# Success!
alog '** Successfully connected to server: '.$cskey;
dbug '** Successfully connected to server: '.$cskey;
ircsock(\%{$cservers{$cskey}}, $cskey);
}
}
# Check for server connections.
if (!keys %Auto::SOCKET) {
err(2, 'No IRC connections -- Exiting program.', 0);
API::Std::event_run('on_shutdown');
exit 1;
}
# Now trigger on_rehash.
API::Std::event_run('on_rehash');
return 1;
}
# Socket creation.
sub ircsock {
my ($cdata, $svrname) = @_;
# Prepare socket data.
my %conndata = (
Proto => 'tcp',
LocalAddr => $cdata->{'bind'}[0],
PeerAddr => $cdata->{'host'}[0],
PeerPort => $cdata->{'port'}[0],
Timeout => 20,
);
# Set IPv6/SSL data.
my $use6 = 0;
my $usessl = 0;
if (defined $cdata->{'ipv6'}[0]) { $use6 = $cdata->{'ipv6'}[0]; }
if (defined $cdata->{'ssl'}[0]) { $usessl = $cdata->{'ssl'}[0]; }
# Check for appropriate build data.
if ($usessl) {
if ($Auto::ENFEAT !~ m/ssl/ixsm) { err(2, '** Auto not built with SSL support: Aborting connection to '.$svrname, 0); return; }
}
if ($use6) {
if ($Auto::ENFEAT !~ m/ipv6/ixsm) { err(2, '** Auto not built with IPv6 support: Aborting connection to '.$svrname, 0); return; }
}
# CertFP.
if ($usessl) {
if (defined $cdata->{'certfp'}[0]) {
if ($cdata->{'certfp'}[0] eq 1) {
$conndata{'SSL_use_cert'} = 1;
if (defined $cdata->{'certfp_cert'}[0]) {
$conndata{'SSL_cert_file'} = "$Auto::Bin/../etc/certs/".$cdata->{'certfp_cert'}[0];
}
if (defined $cdata->{'certfp_key'}[0]) {
$conndata{'SSL_key_file'} = "$Auto::Bin/../etc/certs/".$cdata->{'certfp_key'}[0];
}
if (defined $cdata->{'certfp_pass'}[0]) {
$conndata{'SSL_passwd_cb'} = sub { return $cdata->{'certfp_pass'}[0]; };
}
}
}
}
# Create the socket.
if ($use6) {
$Auto::SOCKET{$svrname} = IO::Socket::INET6->new(%conndata) or # Or error.
err(2, 'Failed to connect to server ('.$ERRNO.'): '.$svrname.' ['.$cdata->{'host'}[0].q{:}.$cdata->{'port'}[0].']', 0)
and delete $Auto::SOCKET{$svrname} and return;
}
else {
if ($usessl) {
$Auto::SOCKET{$svrname} = IO::Socket::SSL->new(%conndata) or # Or error.
err(2, 'Failed to connect to server ('.$ERRNO.'): '.$svrname.' ['.$cdata->{'host'}[0].q{:}.$cdata->{'port'}[0].']', 0)
and delete $Auto::SOCKET{$svrname} and next;
}
else {
$Auto::SOCKET{$svrname} = IO::Socket::INET->new(%conndata) or # Or error.
err(2, 'Failed to connect to server ('.$ERRNO.'): '.$svrname.' ['.$cdata->{'host'}[0].q{:}.$cdata->{'port'}[0].']', 0)
and delete $Auto::SOCKET{$svrname} and next;
}
}
# Send PASS if we have one.
if (defined $cdata->{'pass'}[0]) {
Auto::socksnd($svrname, 'PASS :'.$cdata->{'pass'}[0]) or return;
}
# Send CAP LS.
Auto::socksnd($svrname, 'CAP LS');
# Trigger on_preconnect.
API::Std::event_run('on_preconnect', $svrname);
# Send NICK/USER.
API::IRC::nick($svrname, $cdata->{'nick'}[0]);
Auto::socksnd($svrname, 'USER '.$cdata->{'ident'}[0].q{ }.hostname.q{ }.$cdata->{'host'}[0].' :'.$cdata->{'realname'}[0]) or return;
# Add to select.
$Auto::SELECT->add($Auto::SOCKET{$svrname});
# Success!
alog '** Successfully connected to server: '.$svrname;
dbug '** Successfully connected to server: '.$svrname;
return 1;
}
# Shutdown.
hook_add('on_shutdown', 'shutdown.core_cleanup', sub {
if (defined $Auto::DB) { $Auto::DB->disconnect; }
@@ -261,7 +285,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;
}
@@ -276,10 +300,10 @@ sub signal_perldie
foreach (keys %Auto::SOCKET) { API::IRC::quit($_, 'A fatal error occurred!'); }
API::Std::event_run('on_shutdown');
sleep 1;
println 'FATAL: '.$diemsg;
say 'FATAL: '.$diemsg;
exit;
}
1;
# vim: set ai sw=4 ts=4:
# vim: set ai et sw=4 ts=4:
+3 -3
View File
@@ -119,16 +119,16 @@ 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, Greet, HelloChan, IsItUp, QDB, SASLAuth, Weather';
println 'Available modules: Badwords, Bitly, BotStats, Calc, ChanTopics, Dictionary, EightBall, Eval, FML, Greet, HelloChan, IsItUp, LinkTitle, QDB, SASLAuth, Weather';
print '> ';
my $modules = <STDIN>; chomp $modules;
$modules =~ s/ //g;
my @modst = split ',', $modules;
foreach (@modst) {
system "$Bin/bin/buildmod $_";
system "perl \"$Bin/bin/buildmod\" $_";
}
}
}
1;
# vim: set ai sw=4 ts=4:
# vim: set ai et sw=4 ts=4:
+153 -153
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,150 +31,150 @@ 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;
}
1;
# vim: set ai sw=4 ts=4:
# vim: set ai et sw=4 ts=4:
-679
View File
@@ -1,679 +0,0 @@
# lib/Parser/IRC.pm - Subroutines for parsing incoming data from IRC.
# Copyright (C) 2010-2011 Xelhua Development Group, et al.
# This program is free software; rights to this code are stated in doc/LICENSE.
package Parser::IRC;
use strict;
use warnings;
use API::Std qw(conf_get err awarn trans);
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,
'KICK' => \&kick,
'MODE' => \&mode,
'NICK' => \&nick,
'NOTICE' => \&notice,
'PART' => \&part,
'PRIVMSG' => \&privmsg,
'QUIT' => \&quit,
'TOPIC' => \&topic,
);
# Variables for various functions.
our (%got_001, %botnick, %botchans, %csprefix, %chanusers, %chanmodes);
# Events.
API::Std::event_add("on_connect");
API::Std::event_add("on_rcjoin");
API::Std::event_add("on_ucjoin");
API::Std::event_add("on_kick");
API::Std::event_add("on_nick");
API::Std::event_add("on_notice");
API::Std::event_add("on_cprivmsg");
API::Std::event_add("on_uprivmsg");
API::Std::event_add("on_quit");
API::Std::event_add("on_topic");
# Parse raw data.
sub ircparse
{
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;
}
###########################
# Raw parsing subroutines #
###########################
# Parse: Numeric:001
# 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};
}
# Trigger on_connect.
API::Std::event_run("on_connect", $svr);
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);
}
}
elsif ($ex =~ m/^CHANMODES/xsm) {
# Found CHANMODES.
my ($mtl, $mtp, $mtpp, $mts) = split m/[,]/xsm, substr($ex, 10);
# List modes.
foreach (split(//, $mtl)) { $chanmodes{$svr}{$_} = 1; }
# Modes with parameter.
foreach (split(//, $mtp)) { $chanmodes{$svr}{$_} = 2; }
# Modes with parameter when +.
foreach (split(//, $mtpp)) { $chanmodes{$svr}{$_} = 3; }
# Modes without parameter.
foreach (split(//, $mts)) { $chanmodes{$svr}{$_} = 4; }
}
}
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;
}
# 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;
}
# 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;
}
# 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;
}
# Parse: Numeric:465
# You're banned creep!
sub num465
{
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;
}
# 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;
}
# 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;
}
# 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;
}
# 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;
}
# Parse: JOIN
sub cjoin
{
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(substr $ex[2], 1)} = 1;
API::Std::event_run("on_ucjoin", ($svr, $chan));
}
else {
# It isn't. Update chanusers and trigger on_rcjoin.
$chanusers{$svr}{lc(substr $ex[2], 1)}{$src{nick}} = 1;
$src{svr} = $svr;
API::Std::event_run("on_rcjoin", (\%src, $chan));
}
return 1;
}
# Parse: KICK
sub kick
{
my ($svr, @ex) = @_;
my %src = API::IRC::usrc(substr($ex[0], 1));
# Update chanusers.
delete $chanusers{$svr}{$ex[2]}{$ex[3]} if defined $chanusers{$svr}{$ex[2]}{$ex[3]};
# Set $msg to the kick message.
my $msg = 0;
if (defined $ex[4]) {
$msg = substr($ex[4], 1);
if (defined $ex[5]) {
for (my $i = 5; $i < scalar(@ex); $i++) {
$msg .= " ".$ex[$i];
}
}
}
# Check if we were the ones kicked.
if (lc($ex[3]) eq lc($botnick{$svr}{nick})) {
# We were kicked!
# Delete channel from botchans.
delete $botchans{$svr}{$ex[2]};
# Log this horrible act.
API::Log::alog("I was kicked from ".$svr."/".$ex[2]." by ".$src{nick}."! Reason: ".$msg);
# Rejoin if we're told to in config.
if (conf_get("server:$svr:autorejoin")) {
if ((conf_get("server:$svr:autorejoin"))[0][0] eq 1) {
API::IRC::cjoin($svr, $ex[2]);
}
}
}
else {
# We weren't. Update chanusers and trigger on_kick.
if (defined $chanusers{$svr}{$ex[2]}{$ex[3]}) { delete $chanusers{$svr}{$ex[2]}{$ex[3]}; }
API::Std::event_run("on_kick", ($svr, \%src, $ex[2], $ex[3], $msg));
}
return 1;
}
# Parse: MODE
sub mode
{
my ($svr, @ex) = @_;
if ($ex[2] ne $botnick{$svr}{nick}) {
# Set data we'll need later.
my $chan = $ex[2];
my $modes = $ex[3];
# Get rid of the useless data, so the mode parser will work smoothly.
shift @ex; shift @ex; shift @ex; shift @ex;
# Check if the modes contain any status modes.
my $nt = 0;
foreach (keys %{ $csprefix{$svr} }) {
if ($modes =~ /($_)/) {
$nt = 1;
last;
}
}
if ($nt) {
# It did. Lets parse the changes.
my @ma = split(//, $modes);
my $op = 1;
foreach my $maf (@ma) {
if ($maf eq '+') {
# If it's a +, change the operator to 1.
$op = 1;
}
elsif ($maf eq '-') {
# If it's a -, change the operator to 2.
$op = 2;
}
else {
# It's a mode, lets check if it's a status mode.
my $nnt = 0;
foreach (keys %{ $csprefix{$svr} }) {
if ($maf eq $_) {
$nnt = 1;
last;
}
}
if ($nnt) {
# It is a status mode, lets parse changes.
my $user = shift(@ex);
if (defined $chanusers{$svr}{$chan}{$user}) {
if ($op == 1) {
if ($chanusers{$svr}{$chan}{$user} eq 1) {
$chanusers{$svr}{$chan}{$user} = $maf;
}
else {
$chanusers{$svr}{$chan}{$user} .= $maf;
}
}
elsif ($op == 2) {
if (length($chanusers{$svr}{$chan}{$user}) == 1) {
$chanusers{$svr}{$chan}{$user} = 1;
}
else {
$chanusers{$svr}{$chan}{$user} =~ s/($maf)//gxsm;
}
}
}
else {
$chanusers{$svr}{$chan}{$user} = $maf;
}
}
else {
# It is not. Lets adjust arguments accordingly.
if (defined $chanmodes{$svr}{$maf}) {
if ($chanmodes{$svr}{$maf} == 1 || $chanmodes{$svr}{$maf} == 2) { shift @ex; }
if ($chanmodes{$svr}{$maf} == 3) {
if ($op == 1) { shift @ex; }
}
}
}
}
}
}
}
return 1;
}
# Parse: NICK
sub nick
{
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.
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;
}
# Parse: NOTICE
sub notice
{
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
sub part
{
my ($svr, @ex) = @_;
my %src = API::IRC::usrc(substr($ex[0], 1));
# Delete them from chanusers.
delete $chanusers{$svr}{$ex[2]}{$src{nick}} if defined $chanusers{$svr}{$ex[2]}{$src{nick}};
# Set $msg to the part message.
my $msg = 0;
if (defined $ex[3]) {
$msg = substr($ex[3], 1);
if (defined $ex[4]) {
for (my $i = 4; $i < scalar(@ex); $i++) {
$msg .= " ".$ex[$i];
}
}
}
# Trigger on_part.
API::Std::event_run("on_part", ($svr, \%src, $ex[2], $msg));
return 1;
}
# Parse: PRIVMSG
sub privmsg
{
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;
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 execute the command without any extra checks.
&{ $API::Std::CMDS{$cmd}{'sub'} }(\%data, @argv);
}
}
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.
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").".");
}
}
else {
# Else continue executing without any extra checks.
&{ $API::Std::CMDS{$cmd}{'sub'} }(\%data, @argv) if $rprefix eq $cprefix;
}
}
else {
# Send them a notice about their bad deed.
API::IRC::notice($data{svr}, $data{nick}, trans('Rate limit exceeded').q{.});
}
}
}
}
# 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));
# Set $msg to the quit message.
my $msg = 0;
if (defined $ex[2]) {
$msg = substr($ex[2], 1);
if (defined $ex[3]) {
for (my $i = 3; $i < scalar(@ex); $i++) {
$msg .= " ".$ex[$i];
}
}
}
# Trigger on_quit.
API::Std::event_run("on_quit", ($svr, \%src, $msg));
return 1;
}
# 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;
}
1;
# vim: set ai sw=4 ts=4:
+51 -51
View File
@@ -10,58 +10,58 @@ 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;
}
1;
# vim: set ai sw=4 ts=4:
# vim: set ai et sw=4 ts=4:
+756
View File
@@ -0,0 +1,756 @@
# lib/Proto/IRC.pm - Subroutines for parsing incoming data from IRC.
# Copyright (C) 2010-2011 Xelhua Development Group, et al.
# This program is free software; rights to this code are stated in doc/LICENSE.
package Proto::IRC;
use strict;
use warnings;
use feature qw(switch);
use API::Std qw(conf_get err awarn trans);
use API::IRC;
# Raw parsing hash.
our %RAWC = (
'001' => \&num001,
'004' => \&num004,
'005' => \&num005,
'352' => \&num352,
'353' => \&num353,
'396' => \&num396,
'432' => \&num432,
'433' => \&num433,
'438' => \&num438,
'465' => \&num465,
'471' => \&num471,
'473' => \&num473,
'474' => \&num474,
'475' => \&num475,
'477' => \&num477,
'CAP' => \&cap,
'JOIN' => \&cjoin,
'KICK' => \&kick,
'MODE' => \&mode,
'NICK' => \&nick,
'NOTICE' => \&notice,
'PART' => \&part,
'PRIVMSG' => \&privmsg,
'QUIT' => \&quit,
'TOPIC' => \&topic,
);
# Variables for various functions.
our (%got_001, %botinfo, %botchans, %csprefix, %chanusers, %chanmodes, %cap);
# Events.
API::Std::event_add('on_capack');
API::Std::event_add('on_connect');
API::Std::event_add('on_rcjoin');
API::Std::event_add('on_ucjoin');
API::Std::event_add('on_isupport');
API::Std::event_add('on_kick');
API::Std::event_add('on_nick');
API::Std::event_add('on_notice');
API::Std::event_add('on_part');
API::Std::event_add('on_cprivmsg');
API::Std::event_add('on_uprivmsg');
API::Std::event_add('on_quit');
API::Std::event_add('on_topic');
API::Std::event_add('on_whoreply');
# Parse raw data.
sub ircparse
{
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;
}
###########################
# Raw parsing subroutines #
###########################
# Parse: Numeric:001
# Successful connection.
sub num001 {
my ($svr, @ex) = @_;
$got_001{$svr} = 1;
# In case we don't get NICK from the server.
if (!defined $botinfo{$svr}{nick}) {
$botinfo{$svr}{nick} = $botinfo{$svr}{newnick};
delete $botinfo{$svr}{newnick};
}
# Log.
API::Log::alog "! Successfully connected to $svr as $botinfo{$svr}{nick}";
API::Log::dbug "! Successfully connected to $svr as $botinfo{$svr}{nick}";
# Trigger on_connect.
API::Std::event_run('on_connect', $svr);
return 1;
}
# Parse: Numeric:004
# Server information.
sub num004 {
my ($svr, @ex) = @_;
# Log server name and version.
API::Log::alog "! $svr: $ex[3] running version $ex[4]";
API::Log::dbug "! $svr: $ex[3] running version $ex[4]";
return 1;
}
# Parse: Numeric:005
# Server ISUPPORT.
sub num005 {
my ($svr, @ex) = @_;
# Trigger on_isupport.
API::Std::event_run('on_isupport', ($svr, @ex[3..$#ex]));
return 1;
}
# Parse: Numeric:352
# WHO reply.
sub num352 {
my ($svr, @ex) = @_;
# Trigger on_whoreply.
API::Std::event_run('on_whoreply', ($svr, $ex[2], $ex[3], $ex[4], $ex[5], $ex[6], @ex[7..$#ex]));
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;
PFITER: 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 $ex[$i]}) {
# If the user has multiple statuses.
$chanusers{$svr}{$ex[4]}{lc(substr($ex[$i], 1))} = $chanusers{$svr}{$ex[4]}{lc $ex[$i]}.$_;
delete $chanusers{$svr}{$ex[4]}{lc $ex[$i]};
}
else {
# Or not.
$chanusers{$svr}{$ex[4]}{lc(substr($ex[$i], 1))} = $_;
}
$fi = 1;
$ex[$i] = substr $ex[$i], 1;
}
}
# Check if there's still a prefix.
foreach (keys %{$csprefix{$svr}}) {
if (substr($ex[$i], 0, 1) eq $csprefix{$svr}{$_}) { goto 'PFITER' }
}
# 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:396
# Hidden host changed.
sub num396 {
my ($svr, @ex) = @_;
# Update our mask.
$botinfo{$svr}{mask} = $ex[3];
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 $botinfo{$svr}{newnick} if (defined $botinfo{$svr}{newnick});
return 1;
}
# Parse: Numeric:433
# Nickname is already in use.
sub num433 {
my ($svr, undef) = @_;
if (defined $botinfo{$svr}{newnick}) {
API::IRC::nick($svr, $botinfo{$svr}{newnick}."_");
}
return 1;
}
# Parse: Numeric:438
# Nick change too fast.
sub num438 {
my ($svr, @ex) = @_;
if (defined $botinfo{$svr}{newnick}) {
API::Std::timer_add("num438_".$botinfo{$svr}{newnick}, 1, $ex[11], sub {
API::IRC::nick($Proto::IRC::botinfo{$svr}{newnick});
delete $botinfo{$svr}{newnick} if (defined $botinfo{$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;
}
# 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;
}
# 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;
}
# 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;
}
# 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;
}
# 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;
}
# Parse: CAP
sub cap {
my ($svr, @ex) = @_;
my $capout;
# Iterate ex[3].
given ($ex[3]) {
when ('LS') {
# Get our CAP REQ list.
my @capreq = ();
if ($cap{$svr} =~ m/\s/xsm) { @capreq = split ' ', $cap{$svr} }
else { push @capreq, $cap{$svr} }
# Iterate through what we received from the server.
$ex[4] =~ s/^://xsm;
foreach my $scap (@ex[4..$#ex]) {
# Check if we support this.
foreach my $icap (@capreq) {
if ($icap eq $scap) {
$capout .= " $scap";
}
}
}
# Send CAP REQ/CAP END based on what both we and the server support.
if (!$capout) { Auto::socksnd($svr, 'CAP END'); }
else {
$capout = substr $capout, 1;
Auto::socksnd($svr, "CAP REQ :$capout");
}
}
when ('ACK') {
# Iterate through the ACK arguments.
$ex[4] =~ s/^://xsm;
my $sasl = 0;
foreach (@ex[4..$#ex]) {
if ($_ eq 'sasl') { $sasl++ }
API::Std::event_run('on_capack', ($svr, $_));
}
Auto::socksnd($svr, 'CAP END') unless $sasl;
}
when ('NAK') {
# This should never happen, but just in case...
API::Log::awarn(2, "$svr: CAP failed: Server refused '$capout'");
Auto::socksnd($svr, 'CAP END');
}
}
return 1;
}
# Parse: JOIN
sub cjoin {
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 $botinfo{$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
sub kick {
my ($svr, @ex) = @_;
my %src = API::IRC::usrc(substr($ex[0], 1));
# Update chanusers.
delete $chanusers{$svr}{$ex[2]}{$ex[3]} if defined $chanusers{$svr}{$ex[2]}{$ex[3]};
# Set $msg to the kick message.
my $msg = 0;
if (defined $ex[4]) {
$msg = substr($ex[4], 1);
if (defined $ex[5]) {
for (my $i = 5; $i < scalar(@ex); $i++) {
$msg .= " ".$ex[$i];
}
}
}
# Check if we were the ones kicked.
if (lc($ex[3]) eq lc($botinfo{$svr}{nick})) {
# We were kicked!
# Delete channel from botchans.
delete $botchans{$svr}{$ex[2]};
# Log this horrible act.
API::Log::alog("I was kicked from ".$svr."/".$ex[2]." by ".$src{nick}."! Reason: ".$msg);
# Rejoin if we're told to in config.
if (conf_get("server:$svr:autorejoin")) {
if ((conf_get("server:$svr:autorejoin"))[0][0] eq 1) {
API::IRC::cjoin($svr, $ex[2]);
}
}
}
else {
# We weren't. Update chanusers and trigger on_kick.
if (defined $chanusers{$svr}{$ex[2]}{$ex[3]}) { delete $chanusers{$svr}{$ex[2]}{$ex[3]}; }
API::Std::event_run("on_kick", ($svr, \%src, $ex[2], $ex[3], $msg));
}
return 1;
}
# Parse: MODE
sub mode {
my ($svr, @ex) = @_;
if ($ex[2] ne $botinfo{$svr}{nick}) {
# Set data we'll need later.
my $chan = $ex[2];
my $modes = $ex[3];
$modes =~ s/^://xsm;
# Get rid of the useless data, so the mode parser will work smoothly.
shift @ex; shift @ex; shift @ex; shift @ex;
# Check if the modes contain any status modes.
my $nt = 0;
foreach (keys %{ $csprefix{$svr} }) {
if ($modes =~ /($_)/) {
$nt = 1;
last;
}
}
if ($nt) {
# It did. Lets parse the changes.
my @ma = split(//, $modes);
my $op = 1;
foreach my $maf (@ma) {
if ($maf eq '+') {
# If it's a +, change the operator to 1.
$op = 1;
}
elsif ($maf eq '-') {
# If it's a -, change the operator to 2.
$op = 2;
}
else {
# It's a mode, lets check if it's a status mode.
my $nnt = 0;
foreach (keys %{ $csprefix{$svr} }) {
if ($maf eq $_) {
$nnt = 1;
last;
}
}
if ($nnt) {
# It is a status mode, lets parse changes.
my $user = shift(@ex);
if (defined $chanusers{$svr}{$chan}{$user}) {
if ($op == 1) {
if ($chanusers{$svr}{$chan}{$user} eq 1) {
$chanusers{$svr}{$chan}{$user} = $maf;
}
else {
$chanusers{$svr}{$chan}{$user} .= $maf;
}
}
elsif ($op == 2) {
if (length($chanusers{$svr}{$chan}{$user}) == 1) {
$chanusers{$svr}{$chan}{$user} = 1;
}
else {
$chanusers{$svr}{$chan}{$user} =~ s/($maf)//gxsm;
}
}
}
else {
$chanusers{$svr}{$chan}{$user} = $maf;
}
}
else {
# It is not. Lets adjust arguments accordingly.
if (defined $chanmodes{$svr}{$maf}) {
if ($chanmodes{$svr}{$maf} == 1 || $chanmodes{$svr}{$maf} == 2) { shift @ex; }
if ($chanmodes{$svr}{$maf} == 3) {
if ($op == 1) { shift @ex; }
}
}
}
}
}
}
}
return 1;
}
# Parse: NICK
sub nick {
my ($svr, ($uex, undef, $nex)) = @_;
$nex =~ s/^://gxsm;
my %src = API::IRC::usrc(substr($uex, 1));
# Check if this is coming from ourselves.
if ($src{nick} eq $botinfo{$svr}{nick}) {
# It is. Update bot nick hash.
$botinfo{$svr}{nick} = $nex;
delete $botinfo{$svr}{newnick} if (defined $botinfo{$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;
}
# Parse: NOTICE
sub notice {
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
sub part {
my ($svr, @ex) = @_;
my %src = API::IRC::usrc(substr($ex[0], 1));
# Delete them from chanusers.
delete $chanusers{$svr}{$ex[2]}{$src{nick}} if defined $chanusers{$svr}{$ex[2]}{$src{nick}};
# Set $msg to the part message.
my $msg = 0;
if (defined $ex[3]) {
$msg = substr($ex[3], 1);
if (defined $ex[4]) {
for (my $i = 4; $i < scalar(@ex); $i++) {
$msg .= " ".$ex[$i];
}
}
}
# Trigger on_part.
API::Std::event_run("on_part", ($svr, \%src, $ex[2], $msg));
return 1;
}
# Parse: PRIVMSG
sub privmsg {
my ($svr, @ex) = @_;
my %data = API::IRC::usrc(substr($ex[0], 1));
# 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($botinfo{$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 execute the command without any extra checks.
&{ $API::Std::CMDS{$cmd}{'sub'} }(\%data, @argv);
}
}
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.
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 continue executing without any extra checks.
&{ $API::Std::CMDS{$cmd}{'sub'} }(\%data, @argv);
}
}
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.
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));
# Set $msg to the quit message.
my $msg = 0;
if (defined $ex[2]) {
$msg = substr($ex[2], 1);
if (defined $ex[3]) {
for (my $i = 3; $i < scalar(@ex); $i++) {
$msg .= " ".$ex[$i];
}
}
}
# Trigger on_quit.
API::Std::event_run("on_quit", ($svr, \%src, $msg));
return 1;
}
# Parse: TOPIC
sub topic {
my ($svr, @ex) = @_;
my %src = API::IRC::usrc(substr($ex[0], 1));
$src{svr} = $svr;
$src{chan} = $ex[2];
$ex[3] = substr $ex[3], 1;
# Trigger on_topic.
API::Std::event_run('on_topic', (\%src, @ex[3..$#ex]));
return 1;
}
1;
# vim: set ai et sw=4 ts=4:
+11 -11
View File
@@ -12,12 +12,12 @@ use API::IRC qw(privmsg notice kick ban);
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,16 +27,16 @@ 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 (($src, $chan, @msg)) = @_;
my (($src, $chan, @msg)) = @_;
my $msg = join ' ', @msg;
@@ -70,8 +70,8 @@ sub actonbadword
}
API::Std::mod_init('Badwords', 'Xelhua', '1.00', '3.0.0a4', __PACKAGE__);
# vim: set ai sw=4 ts=4:
API::Std::mod_init('Badwords', 'Xelhua', '1.00', '3.0.0a6', __PACKAGE__);
# vim: set ai et sw=4 ts=4:
# build: perl=5.010000
__END__
@@ -122,6 +122,6 @@ Changing the obvious to your wish.
=over
This module is compatible with Auto version 3.0.0a4+.
This module is compatible with Auto version 3.0.0a6+.
=back
+30 -30
View File
@@ -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,37 +47,37 @@ our %HELP_REVERSE = (
# Callback for SHORTEN command.
sub shorten
{
my ($src, @args) = @_;
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.
if (!defined $args[0]) {
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($src->{svr}, $src->{chan}, "URL: ".$d);
}
privmsg($src->{svr}, $src->{chan}, "URL: ".$d);
}
else {
# Otherwise, send an error message.
privmsg($src->{svr}, $src->{chan}, "An error occurred while shortening your URL.");
}
return 1;
return 1;
}
# Callback for REVERSE command.
@@ -104,22 +104,22 @@ 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($src->{svr}, $src->{chan}, "URL: ".$d);
}
else {
privmsg($src->{svr}, $src->{chan}, "URL: ".$d);
}
else {
# Otherwise, send an error message.
privmsg($src->{svr}, $src->{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.0a4', __PACKAGE__);
# vim: set ai sw=4 ts=4:
API::Std::mod_init('Bitly', 'Xelhua', '1.00', '3.0.0a6', __PACKAGE__);
# vim: set ai et sw=4 ts=4:
# build: cpan=LWP::UserAgent,URI::Escape perl=5.010000
__END__
@@ -179,6 +179,6 @@ Add Bitly to module auto-load and the following to your configuration file:
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.0a4+.
This module is compatible with Auto version 3.0.0a6+.
=back
+115
View File
@@ -0,0 +1,115 @@
# Module: BotStats. 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::BotStats;
use strict;
use warnings;
use English qw(-no_match_vars);
use API::Std qw(cmd_add cmd_del);
use API::IRC qw(privmsg);
# Initialization subroutine.
sub _init {
# Create the STATS command.
cmd_add('STATS', 2, 0, \%M::BotStats::HELP_STATS, \&M::BotStats::stats) or return;
# Success.
return 1;
}
# Void subroutine.
sub _void {
# Delete the STATS command.
cmd_del('STATS') or return;
# Success.
return 1;
}
# Help hash for STATS. Spanish, German and French translations needed.
our %HELP_STATS = (
'en' => "This command will return information about the bot (uptime, version, etc.). \2Syntax:\2 STATS",
);
# Callback for STATS command.
sub stats {
my ($src, undef) = @_;
# Check if this was private or public.
my $target;
if ($src->{chan}) {
$target = $src->{chan};
}
else {
$target = $src->{nick};
}
# Get uptime data.
my $uptime = time - $Auto::STARTTIME;
my $days = my $hours = my $mins = my $secs = 0;
while ($uptime >= 86_400) { $days++; $uptime -= 86_400; }
while ($uptime >= 3_600) { $hours++; $uptime -= 3_600; }
while ($uptime >= 60) { $mins++; $uptime -= 60; }
while ($uptime >= 1) { $secs++; $uptime--; }
# Return it.
privmsg($src->{svr}, $target, "I have been running for \2$days\2 days, \2$hours\2 hours, \2$mins\2 minutes, and \2$secs\2 seconds.");
# Return version data.
privmsg($src->{svr}, $target, 'I am running '.Auto::NAME.' (version '.Auto::VER.q{.}.Auto::SVER.q{.}.Auto::REV.Auto::RSTAGE.") for Perl $PERL_VERSION on $OSNAME.");
# Get network and channel data.
my $nets = keys %Auto::SOCKET;
my $chans;
foreach my $net (keys %Auto::SOCKET) {
foreach (keys %{$Proto::IRC::botchans{$net}}) { $chans++; }
}
# Return network/channel data.
privmsg($src->{svr}, $target, "I am on \2$chans\2 channels across \2$nets\2 networks.");
return 1;
}
API::Std::mod_init('BotStats', 'Xelhua', '1.00', '3.0.0a6', __PACKAGE__);
# vim: set ai et sw=4 ts=4:
# build: perl=5.010000
__END__
=head1 NAME
BotStats - General information about the bot
=head1 VERSION
1.00
=head1 SYNOPSIS
<starcoder> !stats
<blue> I have been running for 0 days, 0 hours, 1 minutes, and 5 seconds.
<blue> I am running Auto IRC Bot (version 3.0.0a6) for Perl v5.12.3 on linux.
<blue> I am on 2 channels, across 1 networks.
=head1 DESCRIPTION
This module creates the STATS command, for returning general information about
the bot such as uptime, version, etc.
This module is compatible with Auto v3.0.0a6+.
=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.
This module is released under the same licensing terms as Auto itself.
=cut
+39 -39
View File
@@ -13,73 +13,73 @@ use JSON -support_by_pp;
# Initialization subroutine.
sub _init
{
# 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 ($src, @args) = @_;
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.
# 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($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
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.");
}
}
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.0a4', __PACKAGE__);
# vim: set ai sw=4 ts=4:
API::Std::mod_init('Calc', 'Xelhua', '1.00', '3.0.0a6', __PACKAGE__);
# vim: set ai et sw=4 ts=4:
# build: cpan=LWP::UserAgent,URI::Escape,JSON,JSON::PP perl=5.010000
__END__
@@ -119,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.0a4+.
This module is compatible with Auto version 3.0.0a6+.
=back
+3 -3
View File
@@ -282,8 +282,8 @@ sub _getdata
}
API::Std::mod_init('ChanTopics', 'Xelhua', '1.00', '3.0.0a4', __PACKAGE__);
# vim: set ai sw=4 ts=4:
API::Std::mod_init('ChanTopics', 'Xelhua', '1.00', '3.0.0a6', __PACKAGE__);
# vim: set ai et sw=4 ts=4:
# build: perl=5.010000
__END__
@@ -338,7 +338,7 @@ This module adds no extra dependencies.
This module is not compatible with PostgreSQL, yet.
This module is compatible with Auto v3.0.0a4+.
This module is compatible with Auto v3.0.0a6+.
Ported from v1.0.
+3 -3
View File
@@ -75,8 +75,8 @@ sub cmd_dict
# Start initialization.
API::Std::mod_init('Dictionary', 'Xelhua', '1.00', '3.0.0a4', __PACKAGE__);
# vim: set ai sw=4 ts=4:
API::Std::mod_init('Dictionary', 'Xelhua', '1.00', '3.0.0a6', __PACKAGE__);
# vim: set ai et sw=4 ts=4:
# build: cpan=Net::Dict perl=5.010000
__END__
@@ -99,6 +99,6 @@ DICT command.
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+.
This module is compatible with Auto v3.0.0a6+.
=back
+11 -11
View File
@@ -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,7 +42,7 @@ our %HELP_RIGBALL = (
# Callback for 8BALL command.
sub c_8ball
{
my ($src, @argv) = @_;
my ($src, @argv) = @_;
if (!defined $argv[0]) {
notice($src->{svr}, $src->{nick}, trans("Not enough parameters").".");
@@ -77,7 +77,7 @@ sub c_8ball
privmsg($src->{svr}, $src->{chan}, "\002Answer:\002 ".$a);
return 1;
return 1;
}
# Callback for RIGBALL command.
@@ -94,13 +94,13 @@ sub rigball
$ANSWER = join(" ", @argv);
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.0a4', __PACKAGE__);
# vim: set ai sw=4 ts=4:
API::Std::mod_init('EightBall', 'Xelhua', '1.00', '3.0.0a6', __PACKAGE__);
# vim: set ai et sw=4 ts=4:
# build: perl=5.010000
__END__
@@ -143,7 +143,7 @@ command for setting ("rigging") the 8-Ball's next answer.
=over
This module is compatible with Auto version 3.0.0a4+.
This module is compatible with Auto version 3.0.0a6+.
Ported from Auto 1.0.
+106
View File
@@ -0,0 +1,106 @@
# Module: Eval. 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::Eval;
use strict;
use warnings;
use English qw(-no_match_vars);
use API::Std qw(cmd_add cmd_del trans);
use API::IRC qw(privmsg notice);
# Initialization subroutine.
sub _init {
# Create the EVAL command.
cmd_add('EVAL', 2, 'cmd.eval', \%M::Eval::HELP_EVAL, \&M::Eval::cmd_eval) or return;
# Success.
return 1;
}
# Void subroutine.
sub _void {
# Delete the EVAL command.
cmd_del('EVAL') or return;
# Success.
return 1;
}
# Help hash for EVAL command. Spanish, German and French translations are needed.
our %HELP_EVAL = (
'en' => "This command allows you to eval Perl code. USE WITH CAUTION. \2Syntax:\2 EVAL <expression>",
);
# Callback for EVAL command.
sub cmd_eval {
my ($src, @argv) = @_;
# Check for needed parameter.
if (!defined $argv[0]) {
notice($src->{svr}, $src->{nick}, trans('Not enough parameters').q{.});
return;
}
# Evaluate the expression and return the result.
my $expr = join ' ', @argv;
my $result = eval($expr);
if (!defined $result) { $result = 'None'; }
if ($EVAL_ERROR) {
$result = $EVAL_ERROR;
$result =~ s/(\r|\n)//gxsm;
}
# Return the result.
if (!defined $src->{chan}) {
notice($src->{svr}, $src->{nick}, "Output: $result");
}
else {
privmsg($src->{svr}, $src->{chan}, "$src->{nick}: $result");
}
return 1;
}
# Start initialization.
API::Std::mod_init('Eval', 'Xelhua', '1.01', '3.0.0a6', __PACKAGE__);
# vim: set ai et sw=4 ts=4:
# build: perl=5.010000
__END__
=head1 NAME
Eval - Allows you to evaluate Perl code from IRC
=head1 VERSION
1.01
=head1 SYNOPSIS
>blue< eval 1;
-blue- Output: 1
=head1 DESCRIPTION
This module adds the EVAL command which allows you to evaluate Perl code from
IRC, returning the output via notice.
This command requires the cmd.eval privilege.
This module is compatible with Auto v3.0.0a6+.
=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.
This module is released under the same licensing terms as Auto itself.
=cut
+15 -15
View File
@@ -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,39 +36,39 @@ our %HELP_FML = (
# Callback for FML command.
sub fml
{
my ($src, undef) = @_;
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');
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($src->{svr}, $src->{chan}, "\002Random FML:\002 ".$fml);
}
privmsg($src->{svr}, $src->{chan}, "\002Random FML:\002 ".$fml);
}
else {
# Otherwise, send an error message.
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.0a4', __PACKAGE__);
# vim: set ai sw=4 ts=4:
API::Std::mod_init('FML', 'Xelhua', '1.00', '3.0.0a6', __PACKAGE__);
# vim: set ai et sw=4 ts=4:
# build: cpan=LWP::UserAgent perl=5.010000
__END__
@@ -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.0a4+.
This module is compatible with Auto version 3.0.0a6+.
Ported from Auto 2.0.
+3 -3
View File
@@ -125,8 +125,8 @@ sub hook_rcjoin
}
# Start initialization.
API::Std::mod_init('Greet', 'Xelhua', '1.00', '3.0.0a4', __PACKAGE__);
# vim: set ai sw=4 ts=4:
API::Std::mod_init('Greet', 'Xelhua', '1.00', '3.0.0a6', __PACKAGE__);
# vim: set ai et sw=4 ts=4:
# build: perl=5.010000
__END__
@@ -154,6 +154,6 @@ user that has a greet in the database joins a channel the bot is in.
=over
This module is compatible with Auto version 3.0.0a4+.
This module is compatible with Auto version 3.0.0a6+.
=back
+14 -14
View File
@@ -10,34 +10,34 @@ 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.0a4', __PACKAGE__);
# vim: set ai sw=4 ts=4:
API::Std::mod_init('HelloChan', 'Xelhua', '1.00', '3.0.0a6', __PACKAGE__);
# vim: set ai et sw=4 ts=4:
# build: perl=5.010000
__END__
+38 -38
View File
@@ -11,66 +11,66 @@ 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 ($src, @argv) = @_;
my ($src, @argv) = @_;
# 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;
}
# 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($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.');
}
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.0a4', __PACKAGE__);
# vim: set ai sw=4 ts=4:
API::Std::mod_init('IsItUp', 'Xelhua', '1.00', '3.0.0a6', __PACKAGE__);
# vim: set ai et sw=4 ts=4:
# build: cpan=LWP::UserAgent perl=5.010000
__END__
@@ -110,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.0a4+.
This module is compatible with Auto version 3.0.0a6+.
=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.0a6', __PACKAGE__);
# vim: set ai et 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.
+114 -26
View File
@@ -5,14 +5,15 @@ 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;
# 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; }
@@ -34,7 +35,7 @@ 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
{
@@ -46,7 +47,7 @@ sub cmd_qdb
return;
}
# ADD|VIEW|COUNT|RAND|DEL.
# ADD|VIEW|COUNT|RAND|SEARCH|MORE|DEL.
given (uc $argv[0]) {
when ('ADD') {
# QDB ADD.
@@ -55,13 +56,10 @@ sub cmd_qdb
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($src->{svr}, $src->{nick}, trans('An error occurred').q{.}) and return;
$dbq->execute($src->{nick}, time, join(q{ }, @argv)) or
$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.
@@ -83,6 +81,9 @@ sub cmd_qdb
$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($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]);
@@ -114,6 +115,78 @@ sub cmd_qdb
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(%$src), 'cmd.qdbdel')) {
@@ -138,37 +211,52 @@ sub cmd_qdb
}
API::Std::mod_init('QDB', 'Xelhua', '1.00', '3.0.0a4', __PACKAGE__);
# vim: set ai sw=4 ts=4:
API::Std::mod_init('QDB', 'Xelhua', '1.02', '3.0.0a6', __PACKAGE__);
# vim: set ai et 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.0a4+.
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
+36 -55
View File
@@ -13,62 +13,43 @@ 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.
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;
# Check if this Auto was built with SASL support.
if ($Auto::ENFEAT !~ m/sasl/xsm) { err(2, 'Auto was not built with SASL support. Aborting SASLAuth.', 0) and return; }
# Add sasl to supported CAP for servers configured with SASL.
my %servers = conf_get('server');
foreach my $svr (keys %servers) {
if (conf_get("server:$svr:sasl_username")) { $Proto::IRC::cap{$svr} .= ' sasl'; }
}
# Hook for when CAP ACK sasl is received.
hook_add('on_capack', 'sasl.cap', \&M::SASLAuth::handle_capack) or return;
# Hook for parsing 903.
rchook_add('903', \&M::SASLAuth::handle_903) or return 0;
rchook_add('903', \&M::SASLAuth::handle_903) or return;
# Hook for parsing 904.
rchook_add('904', \&M::SASLAuth::handle_904) or return 0;
rchook_add('904', \&M::SASLAuth::handle_904) or return;
# 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;
return 1;
}
# Void subroutine.
sub _void
{
# 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;
# Delete the hooks.
hook_del('on_capack') or return;
rchook_del('903') or return;
rchook_del('904') or return;
rchook_del('906') or return;
return 1;
}
sub handle_cap {
my ($srv, @parv) = @_;
my $line = join(' ',@parv);
my ($tosend);
given ($line) {
when (/ LS /) {
$tosend .= 'multi-prefix ' if $line =~ /multi-prefix/i;
$tosend .= 'sasl ' if $line =~ /sasl/ and conf_get("server:$srv:sasl_username");
awarn(2, "SASL is unavailable on this server.") if $tosend !~ /sasl/;
if ($tosend eq '') { Auto::socksnd($srv, 'CAP END') }
else { Auto::socksnd($srv, "CAP REQ :$tosend"); }
}
when (/ ACK /) {
if ( $line =~ /sasl/) {
Auto::socksnd($srv, 'AUTHENTICATE PLAIN');
timer_add('auth_timeout', 1, (conf_get("server:$srv:sasl_timeout"))[0][0], sub { Auto::socksnd($srv, 'CAP END'); });
}
else {
Auto::socksnd($srv, 'CAP END');
awarn(2, "SASL authentication failed at ACK");
}
}
when (/ NAK /) {
Auto::socksnd($srv, 'CAP END');
awarn(2, "SASL authentication failed. Server refused ".$tosend);
}
sub handle_capack {
my (($svr, $sacap)) = @_;
if ($sacap eq 'sasl') {
Auto::socksnd($svr, 'AUTHENTICATE PLAIN');
timer_add('auth_timeout_'.$svr, 1, (conf_get("server:$svr:sasl_timeout"))[0][0], sub { Auto::socksnd($svr, 'CAP END'); });
}
return 1;
}
@@ -105,8 +86,8 @@ sub handle_authenticate
sub handle_903
{
my ($srv, undef) = @_;
Auto::socksnd($srv, 'CAP END');
timer_del('auth_timeout');
timer_add('cap_end_'.$srv, 1, 2, sub { Auto::socksnd($srv, 'CAP END') });
timer_del('auth_timeout_'.$srv);
}
# Parse: Numeric:904
@@ -114,8 +95,8 @@ sub handle_903
sub handle_904
{
my ($srv, undef) = @_;
Auto::socksnd($srv, 'CAP END');
timer_del('auth_timeout');
timer_add('cap_end_'.$srv, 1, 2, sub { Auto::socksnd($srv, 'CAP END') });
timer_del('auth_timeout_'.$srv);
awarn(2, "SASL authentication failed!");
}
@@ -123,15 +104,15 @@ sub handle_904
# SASL authentication aborted.
sub handle_906
{
my ($svr, undef) = @_;
Auto::socksnd($svr, 'CAP END');
timer_del('auth_timeout');
my ($svr, undef) = @_;
timer_add('cap_end_'.$svr, 1, 2, sub { Auto::socksnd($svr, 'CAP END') });
timer_del('auth_timeout_'.$svr);
awarn(2, "SASL authentication aborted!");
}
# Start initialization.
API::Std::mod_init('SASLAuth', 'Xelhua', '1.00', '3.0.0a4', __PACKAGE__);
# vim: set ai sw=4 ts=4:
API::Std::mod_init('SASLAuth', 'Xelhua', '1.00', '3.0.0a6', __PACKAGE__);
# vim: set ai et sw=4 ts=4:
# build: perl=5.010000
__END__
@@ -188,6 +169,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.0a4+.
This module is compatible with Auto v3.0.0a6+.
=back
+1456
View File
File diff suppressed because it is too large. Load diff
+47 -47
View File
@@ -12,74 +12,74 @@ 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 ($src, @args) = @_;
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.
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);
# 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($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.");
}
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.0a4', __PACKAGE__);
# vim: set ai sw=4 ts=4:
API::Std::mod_init('Weather', 'Xelhua', '1.00', '3.0.0a6', __PACKAGE__);
# vim: set ai et sw=4 ts=4:
# build: cpan=LWP::UserAgent,XML::Simple perl=5.010000
__END__
@@ -121,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.0a4+.
This module is compatible with Auto version 3.0.0a6+.
=back
+70
View File
@@ -0,0 +1,70 @@
# OSI-approved software licenses as of February 26, 2011.
my %licenses = (
auto => 'Same license as Auto itself',
afl => 'Academic Free License',
agpl => 'Affero GNU Public License',
apl => 'Adaptive Public License',
apache => 'Apache License',
apsl => 'Apple Public Source License',
art => 'Artistic License',
aal => 'Attribution Assurance License',
nbsd => 'New BSD License',
sbsd => 'Simplified BSD License',
bsl => 'Boost Software License',
catosl => 'Computer Associates Trusted Open Source License',
cddl => 'Common Development and Distribution License',
cpal => 'Common Public Attribution License',
cua => 'CUA Office Public License',
eudgsl => 'EU DataGrid Software License',
epl => 'Eclipse Public License',
ecl => 'Educational Community License',
efl => 'Eiffel Forum License',
enpl => 'Entessa Public License',
eupl => 'European Union Public License',
fair => 'Fair License',
fwl => 'Frameworx License',
gpl2 => 'GNU General Public License v2',
gpl3 => 'GNU General Public License v3',
lgpl => 'GNU Lesser General Public License',
ibm => 'IBM Public License',
ipa => 'IPA Font License',
isc => 'ISC License',
lppl => 'LaTeX Project Public License',
lpl => 'Lucent Public License',
miros => 'MirOS Licence',
mspl => 'Microsoft Public License',
msrl => 'Microsoft Reciprocal License',
mit => 'MIT License',
msl => 'Motosoto License',
mpl => 'Mozilla Public License',
mtl => 'Multics License',
nasa => 'NASA Open Source Agreement',
ntpl => 'NTP License',
naumen => 'Naumen Public License',
nhgpl => 'Nethack General Public License',
nosl => 'Nokia Open Source License',
nposl => 'Non-Profit Open Software License',
oclc => 'OCLC Research Public License',
ofl => 'Open Font License',
ogtsl => 'Open Group Test Suite License',
osl => 'Open Software License',
php => 'PHP License',
pgsql => 'The PostgreSQL License',
python => 'Python License',
pysfl => 'Python Software Foundation License',
qpl => 'Qt Public License',
real => 'RealNetworks Public Source License',
rpl => 'Reciprocal Public License',
rscpl => 'Ricoh Source Code Public License',
simple => 'Simple Public License',
scl => 'Sleepycat License',
spl => 'Sun Public License',
sowpl => 'Sybase Open Watcom Public License',
ncsa => 'University of Illinois/NCSA Open Source License',
vsl => 'Vovida Software License',
w3c => 'W3C License',
wxwll => 'wxWindows Library License',
xnet => 'X.Net License',
zpl => 'Zope Public License',
zlib => 'zlib/libpng license'
);