76 Commits
Author SHA1 Message Date
Elijah Perrault e833309c4e Fixed a typo. 2011-03-24 14:19:53 -06:00
Elijah Perrault 3c81f0587a Updated for alpha9 release. 2011-03-24 14:18:18 -06:00
Elijah Perrault 5366855f96 Fixed an exploit in QDB RAND. 2011-03-24 14:15:28 -06:00
Elijah Perrault caf9b36b8c Updated for new installation guide. 2011-03-21 23:33:32 -06:00
Elijah Perrault 789cec8f80 UNO: Fixed a formatting issue in duration. 2011-03-21 21:21:20 -06:00
Elijah Perrault ed72b5e444 alpha9. 2011-03-21 21:20:40 -06:00
Elijah Perrault 3cfe22e5c1 More tabs = gone. 2011-03-21 14:20:19 -06:00
Elijah Perrault ea775d4c98 More tab removal. 2011-03-21 14:18:57 -06:00
Elijah Perrault 153084f808 Removing tabs. 2011-03-21 14:17:21 -06:00
Elijah Perrault 637db6bae4 var/* too. 2011-03-21 14:16:14 -06:00
Elijah Perrault 7f4ea8d196 Added a (not so thoroughly tested) Batch file for management of Auto. 2011-03-21 10:03:48 -06:00
Elijah Perrault 8ee16eb39b Add *.db to ignore. 2011-03-21 09:57:59 -06:00
Elijah Perrault 6813a009df Updated for alpha8 release. 2011-03-20 21:38:09 -06:00
Elijah Perrault 1d6436b59b With buildmod fixed, support for custom PREFIX installs (including global installs) is complete. 2011-03-20 21:36:49 -06:00
Elijah Perrault 0e781dde9d Fixed buildmod. 2011-03-20 21:35:11 -06:00
Elijah Perrault 4021eabcf5 Added fastest/slowest game, most cards and most players records to UNO. 2011-03-20 21:34:51 -06:00
Elijah Perrault 79db0a2687 Fixed a bug in UNO that allowed users to join more than once. 2011-03-20 17:15:27 -06:00
Elijah Perrault 05e49c0ba1 Added optional uno:english option. See documentation for UNO. 2011-03-20 17:07:52 -06:00
Elijah Perrault 0cb486191f Added uno:msg to synopsis. 2011-03-20 16:50:41 -06:00
Elijah Perrault 5bbbe224d3 Lets actually commit the changes. 2011-03-20 16:39:01 -06:00
Elijah Perrault d0eeb58c72 UNO has a new config option, uno:msg, for setting what method the bot uses for private messages. 2011-03-20 16:37:40 -06:00
Elijah Perrault 168266696a Added command aliasing. 2011-03-20 15:23:28 -06:00
Elijah Perrault 703f2c2ec8 Moved botinfo to State::IRC. 2011-03-20 13:40:41 -06:00
Elijah Perrault c999bd1372 Bumping version to 2.00d. 2011-03-20 13:16:52 -06:00
Elijah Perrault be9932498b Cloned UNO, to add an AI to it over time. 2011-03-20 13:15:49 -06:00
Elijah Perrault e033b76a6c Since Perl isn't so nice as to do this for us all the time, we'll throw it in. 2011-03-20 09:16:51 -06:00
Elijah Perrault 0315a1f121 Added hook on_selfkick for when we are kicked from a channel. 2011-03-19 23:12:54 -06:00
Elijah Perrault 669561c8a4 Removed some hard tabs. 2011-03-19 23:03:15 -06:00
Elijah Perrault 3e1e2e98be Large amounts of code cleanup. 2011-03-19 22:46:45 -06:00
Elijah Perrault f2deae219d Started State::IRC, and moved chanusers to it. 2011-03-18 14:34:02 -06:00
Elijah Perrault ab2d404f20 Removing more return 0's. 2011-03-18 14:06:22 -06:00
Elijah Perrault 8a8166bdb8 Removing return 0's as it's improper. 2011-03-18 14:05:10 -06:00
Elijah Perrault 374b04fddc Removing hard tabs. 2011-03-18 13:55:50 -06:00
Elijah Perrault 502cda97ed Cleanup. 2011-03-18 13:52:50 -06:00
Elijah Perrault 908dc13159 Start these out as 0, stopping a warning. 2011-03-18 01:31:20 -06:00
Elijah Perrault 1eff0e95e9 Bumping version. 2011-03-18 01:11:48 -06:00
Elijah Perrault b52b488165 UNO now keeps game duration and cards played count. 2011-03-18 01:09:53 -06:00
Elijah Perrault 1bbcc6feec Somewhat early spring cleaning! 2011-03-17 23:28:57 -06:00
Elijah Perrault a153045bc3 Cleaning up. 2011-03-17 22:50:14 -06:00
Elijah Perrault 9a61c75772 Updated. 2011-03-17 21:26:45 -06:00
Elijah Perrault 43928f70dc Updated list. 2011-03-17 21:24:54 -06:00
Elijah Perrault 9c8687da1c Added a LOLCAT module for translating English to LOLCAT. 2011-03-17 21:23:45 -06:00
Elijah Perrault 61fe399ac6 Rewrote EightBall to be nicer. 2011-03-17 21:00:50 -06:00
Elijah Perrault e2afe403c0 Fixing POD. 2011-03-17 13:33:33 -06:00
Elijah Perrault 0dc4f7a2b7 Bumping versions. 2011-03-17 13:32:02 -06:00
Elijah Perrault dbdb9e0d67 alpha8 support. 2011-03-17 13:31:12 -06:00
Elijah Perrault 6b09c4d818 Fixed a bug in LinkTitle that caused multi-line <title>'s to display wrong. 2011-03-17 13:28:12 -06:00
Elijah Perrault f75618e5ec This was in the wrong spot... 2011-03-16 23:02:53 -06:00
Elijah Perrault f19838091c Added wizard, for creating local Auto config directories. 2011-03-16 23:01:42 -06:00
Elijah Perrault 25a0ec8081 Made Auto respond properly to PRIVMSGs received before connection. 2011-03-16 18:38:49 -06:00
Elijah Perrault 9b9997a24d Added backgrounds to cards for those that have odd clients. 2011-03-14 23:32:02 -06:00
Elijah Perrault 618cc6cccb Fixed an exploit in QDB that allowed users to use services fantasy commands with the bot's account. 2011-03-14 21:56:29 -06:00
Elijah Perrault ddf2e8bdea Cleanup. 2011-03-14 18:58:35 -06:00
Elijah Perrault 992bc5affb Fixing documentation, syntax, etc. 2011-03-14 18:55:08 -06:00
Matthew Barksdale ca0545b000 Kill $man with fire 2011-03-14 20:52:37 -04:00
Matthew Barksdale ebf0a78cce Updated. 2011-03-14 20:40:05 -04:00
Matthew Barksdale 344ce60f00 Added a module to get information on packages in AUR. 2011-03-14 20:38:22 -04:00
Elijah Perrault e2d26e3982 Now works with custom PREFIX installs. 2011-03-12 22:21:44 -07:00
Elijah Perrault 98736ebac6 We're alpha8. 2011-03-11 22:22:53 -07:00
Elijah Perrault 59d5c36cba Added bin:mod, and module loading now works as desired. 2011-03-11 22:00:51 -07:00
Elijah Perrault a02a3a8728 Install modules too. 2011-03-11 22:00:32 -07:00
Elijah Perrault 8e1ce1476e auto.pid saves to the correct location and CertFP works. 2011-03-11 21:53:04 -07:00
Elijah Perrault 881fc0d93d Logging now works with custom PREFIX installs. \o/ 2011-03-11 21:41:53 -07:00
Elijah Perrault 580770c5b8 Now installing lang/ properly, and config+language files are pulled from the current working directory. 2011-03-11 21:39:50 -07:00
Elijah Perrault 6033904d0d bin:lng, and moved some stuff to the correct locations. 2011-03-11 21:32:24 -07:00
Elijah Perrault c1960f5837 New bin path system, partially finished. 2011-03-11 21:26:55 -07:00
Elijah Perrault 9bd3e5227b Copy example.conf to DISTDIR/ for later wizard installs. 2011-03-11 19:55:17 -07:00
Elijah Perrault 3efed8bad4 Move this to scripts/ until we decide to trash it. 2011-03-08 17:30:26 -07:00
Elijah Perrault 7342c70639 This is more desirable. 2011-03-07 21:01:31 -07:00
Elijah Perrault d0652138a1 Include this with Auto, for the sake of simplicity. 2011-03-07 20:57:30 -07:00
Elijah Perrault 0480810e59 Improved Lib::Install as well. 2011-03-07 20:46:43 -07:00
Elijah Perrault 9f223b5b92 Merge branch 'indev' of github.com:Xelhua/Auto into indev 2011-03-07 20:44:56 -07:00
Elijah Perrault 2836ebc6a3 Heavily improved ./install. 2011-03-07 20:44:30 -07:00
Matthew Barksdale 30c9178c4e Replaced some useless double quotes with single 2011-03-07 17:18:54 -05:00
Elijah Perrault 68c4ca7b4a Fixed an issue in Git snapshots. 2011-03-06 20:46:43 -07:00
Elijah Perrault 9f3a8624c9 /me slaps matthew 2011-03-06 19:48:24 -07:00
47 changed files with 4154 additions and 1223 deletions

No files matched your search

+2
View File
@@ -2,3 +2,5 @@ auto.conf
build/*
*.swp
autodoc/*
*.db
var/*
+10 -15
View File
@@ -11,30 +11,25 @@
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 alpha7 release, we have added:
In this alpha9 release, we have added:
* Support for multiple configuration files using bin/auto -c=FILENAME. See
bin/auto -h for details.
* Added network-wide user tracking through Core::IRC::Users.
None
Bug fixes:
* Fixed a bug where a CAP entry for a network was not recreated on a reconnect.
* Fixed a bug where incoming PART's from ourselves were not parsed.
* Fixed a bug in UNO where rehashing during a game caused a crash.
* Fixed a bug where appropriate data was not cleared after a disconnect.
* Fixed a bug where Vim modelines were in an incorrect spot in modules.
* UNO: Fixed a formatting issue in duration.
* QDB: Fixed an exploit in QDB RAND.
Incompatibilities:
* Many API changes - Minimum version bumped to 3.0.0a7.
None
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.
We thank you for choosing Auto. Please remember that he is coming to late
development stages soon, and testers are needed! But we hope we've piqued
your interest, as Auto's upcoming module repository will allow modules to be
created by anyone and uploaded there for everyone to use.
Auto's goal is to create an efficient, stable and highly customizable IRC bot
in Perl. To offer an alternative to other platforms.
Enjoy Auto 3.0.0 Alpha 7!
Enjoy Auto 3.0.0 Alpha 9!
+2 -1
View File
@@ -38,7 +38,8 @@ Contributors - Non-developers who contribute to the project greatly.
3. HOW TO INSTALL
Installation documentation is at: http://wiki.xelhua.org/index.php/Auto:Install
Installation documentation is at:
http://wiki.xelhua.org/index.php/Auto:Installation_guide
4. HOW TO UPGRADE
+1 -1
View File
@@ -42,7 +42,7 @@ greatly.
## 3. HOW TO INSTALL
Installation documentation can be found [here](http://wiki.xelhua.org/index.php/Auto:Install).
Installation documentation can be found [here](http://wiki.xelhua.org/index.php/Auto:Installation_guide).
## 4. HOW TO UPGRADE
+45
View File
@@ -0,0 +1,45 @@
:: auto.bat - Launcher for Microsoft Windows.
:: Copyright (C) 2010-2011 Xelhua Development Group, et al.
:: Released under the terms stated in doc/LICENSE.
:: Clone of `auto`, since Windows likes Batch, not sh.
@echo off
set pidfile=bin/auto.pid
if "%1" == "" goto errparams
if "%1" == "start" goto start
if "%1" == "status" goto status
else goto errparams
:errparams
echo.
echo Usage: auto.bat (start|status) [force]
:end
:start
echo.
if exist "%pidfile" (
if "%2" == "force" (
echo Starting Auto. . .
perl bin/auto
)
else (
echo Auto appears to be running already. Run `auto.bat start force` to start anyway.
)
)
else (
echo Starting Auto. . .
perl bin/auto
)
:end
:status
echo.
if exist "%pidfile" (
echo Status: Auto appears to be running.
)
else (
echo Status: Auto appears to not be running.
)
:end
+177 -119
View File
@@ -19,12 +19,47 @@ use DBI;
use Class::Unload;
use FindBin qw($Bin);
our $Bin = $Bin; ## no critic qw(NamingConventions::Capitalization Variables::ProhibitPackageVars)
our (%bin, $UPREFIX);
BEGIN {
unshift @INC, "$Bin/../lib";
$bin{cwd} = getcwd;
if (!-e "$Bin/../build/syswide") {
# Must be a custom PREFIX install.
$bin{etc} = "$bin{cwd}/etc";
$bin{var} = "$bin{cwd}/var";
if (!-e "$Bin/lib/Lib/Auto.pm") {
# Must be a system wide install.
$bin{lib} = "$Bin/../lib/autobot/3.0.0";
$bin{bld} = "$bin{lib}/build";
$bin{lng} = "$bin{lib}/lang";
$bin{mod} = "$bin{lib}/modules";
}
else {
# Or not.
$bin{lib} = "$Bin/../lib";
$bin{bld} = "$Bin/../build";
$bin{lng} = "$Bin/../lang";
$bin{mod} = "$Bin/../modules";
}
$UPREFIX = 1;
}
else {
# Must be a standard install.
$bin{etc} = "$Bin/../etc";
$bin{var} = "$Bin/../var";
$bin{lib} = "$Bin/../lib";
$bin{bld} = "$Bin/../build";
$bin{lng} = "$Bin/../lang";
$bin{mod} = "$Bin/../modules";
$UPREFIX = 0;
}
open my $gitfh, '<', "$Bin/../.git/refs/heads/indev";
our $VERGITREV = substr readline $gitfh, 0, 7;
close $gitfh;
unshift @INC, $bin{lib};
if (-d "$Bin/../.git") {
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)
@@ -42,6 +77,7 @@ use API::Log qw(alog dbug);
use Parser::Config;
use Parser::Lang;
use Proto::IRC;
use State::IRC;
use Core::IRC;
use Core::IRC::Users;
use Core::Cmd;
@@ -50,12 +86,12 @@ our $VERSION = 3.000000;
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") {
if (!-e "$bin{bld}/os" or !-e "$bin{bld}/perl" or !-e "$bin{bld}/time" or !-e "$bin{bld}/ver") {
say 'Missing build file(s). Please build Auto before running it.' and exit;
}
# Check build OS.
open my $BFOS, '<', "$Bin/../build/os" or say 'Cannot start: Broken build.' and exit;
open my $BFOS, '<', "$bin{bld}/os" or say 'Cannot start: Broken build.' and exit;
my @BFOS = <$BFOS>;
close $BFOS or say 'Cannot start: Broken build.' and exit;
if ($BFOS[0] ne $OSNAME."\n") {
@@ -65,14 +101,14 @@ undef @BFOS;
# Check build features.
our $ENFEAT;
open my $BFFEAT, '<', "$Bin/../build/feat" or say 'Cannot start: Broken build.' and exit;
open my $BFFEAT, '<', "$bin{bld}/feat" or say 'Cannot start: Broken build.' and exit;
my @BFFEAT = <$BFFEAT>;
close $BFFEAT or say 'Cannot start: Broken build.' and exit;
$ENFEAT = substr $BFFEAT[0], 0, length($BFFEAT[0]) - 1;
undef @BFFEAT;
# Check build Perl version.
open my $BFPERL, '<', "$Bin/../build/perl" or say 'Cannot start: Broken build.' and exit;
open my $BFPERL, '<', "$bin{bld}/perl" or say 'Cannot start: Broken build.' and exit;
my @BFPERL = <$BFPERL>;
close $BFPERL or say 'Cannot start: Broken build.' and exit;
if ($BFPERL[0] ne $]."\n") {
@@ -81,7 +117,7 @@ if ($BFPERL[0] ne $]."\n") {
undef @BFPERL;
# Check build Auto version.
open my $BFVER, '<', "$Bin/../build/ver" or say 'Cannot start: Broken build.' and exit;
open my $BFVER, '<', "$bin{bld}/ver" or say 'Cannot start: Broken build.' and exit;
my @BFVER = <$BFVER>;
close $BFVER or say 'Cannot start: Broken build.' and exit;
if ($BFVER[0] ne VER.q{.}.SVER.q{.}.REV.RSTAGE."\n") {
@@ -89,6 +125,14 @@ if ($BFVER[0] ne VER.q{.}.SVER.q{.}.REV.RSTAGE."\n") {
}
undef @BFVER;
# Check build path setup.
our $SYSWIDE;
open my $BFPATH, '<', "$bin{bld}/syswide" or say 'Cannot start: Broken build.' and exit;
my @BFPATH = <$BFPATH>;
close $BFPATH or say 'Cannot start: Broken build.' and exit;
if ($BFPATH[0] eq "1\n") { $SYSWIDE = 1 }
else { $SYSWIDE = 0 }
# Set signal handlers.
local $SIG{TERM} = \&Lib::Auto::signal_term;
local $SIG{INT} = \&Lib::Auto::signal_int;
@@ -116,7 +160,7 @@ GetOptions(
# If we were passed -h, print help.
if ($opt_help) {
print <<'HELP';
print <<"HELP";
Usage: $PROGRAM_NAME [options]
--help, -h Prints this help.
@@ -174,13 +218,13 @@ our ($APID, %TIMERS);
Lib::Auto::checkver();
# Include IPv6 if Auto was built for it.
if ($ENFEAT =~ /ipv6/) { require IO::Socket::INET6; }
if ($ENFEAT =~ /ipv6/) { require IO::Socket::INET6 }
# Include SSL if Auto was built for it.
if ($ENFEAT =~ /ssl/) { require IO::Socket::SSL; }
if ($ENFEAT =~ /ssl/) { require IO::Socket::SSL }
# Parse configuration file.
my $configfile = 'auto.conf';
if ($USECONFIG) { $configfile = $USECONFIG; }
if ($USECONFIG) { $configfile = $USECONFIG }
say "* Parsing configuration file $configfile...";
our $CONF = Parser::Config->new($configfile) or err(1, 'Failed to parse configuration file!', 1);
our %SETTINGS = $CONF->parse or err(1, 'Failed to parse configuration file!', 1);
@@ -191,8 +235,8 @@ undef $USECONFIG;
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;
say '!!! Insert new user then try again.';
exit;
}
}
@@ -200,11 +244,11 @@ if (conf_get('die')) {
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);
my $err = 2;
if ($REQCVAL eq 'expire_logs') {
$err = 1;
}
err($err, "Missing required configuration value: $REQCVAL", 1);
}
}
undef @REQCVALS;
@@ -225,26 +269,26 @@ our $DB;
given (lc((conf_get('database:format'))[0][0])) {
when ('sqlite') {
# SQLite.
if ($ENFEAT !~ /sqlite/) { err(2, 'Auto not built with SQLite support. Aborting.', 1); }
if (!conf_get('database:filename')) { err(2, 'Missing required configuration value database:filename. Aborting.', 1); }
if ($ENFEAT !~ /sqlite/) { err(2, 'Auto not built with SQLite support. Aborting.', 1) }
if (!conf_get('database:filename')) { err(2, 'Missing required configuration value database:filename. Aborting.', 1) }
# Import DBD::SQLite.
require DBD::SQLite;
if (!-e "$Bin/../etc/".(conf_get('database:filename'))[0][0]) {
if (!-e "$bin{etc}/".(conf_get('database:filename'))[0][0]) {
# Create <database:filename> if it's missing.
open my $dbfh, '>', "$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];
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);
$DB = DBI->connect("dbi:SQLite:dbname=$bin{etc}/".(conf_get('database:filename'))[0][0]) or err(2, 'Failed to connect to database!', 1);
}
when ('mysql') {
# MySQL.
if ($ENFEAT !~ /mysql/) { err(2, 'Auto not built with MySQL support. Aborting.', 1); }
if ($ENFEAT !~ /mysql/) { err(2, 'Auto not built with MySQL support. Aborting.', 1) }
my @reqcval = qw(database:host database:name database:username database:password);
foreach (@reqcval) { if (!conf_get($_)) { err(2, "Missing required configuration value $_. Aborting.", 1); } }
foreach (@reqcval) { if (!conf_get($_)) { err(2, "Missing required configuration value $_. Aborting.", 1) } }
undef @reqcval;
# Import DBD::mysql.
@@ -265,20 +309,20 @@ given (lc((conf_get('database:format'))[0][0])) {
# CSV no work. :(
#when ('csv') {
# # CSV.
# if ($ENFEAT !~ /csv/) { err(2, 'Auto not built with CSV support.', 1); }
# if (!conf_get('database:dir')) { err(2, 'Missing required configuration value database:dir. Aborting.', 1); }
# if ($ENFEAT !~ /csv/) { err(2, 'Auto not built with CSV support.', 1) }
# if (!conf_get('database:dir')) { err(2, 'Missing required configuration value database:dir. Aborting.', 1) }
#
# # Import DBD::CSV.
# require DBD::CSV;
#
# # Connect to database.
# $DB = DBI->connect("dbi:CSV:f_dir=$Bin/../etc/".(conf_get('database:dir'))[0][0]) or err(2, 'Failed to connect to database!', 1);
# $DB = DBI->connect("dbi:CSV:f_dir=$bin{etc}/".(conf_get('database:dir'))[0][0]) or err(2, 'Failed to connect to database!', 1);
#}
when ('pgsql') {
# PostgreSQL.
if ($ENFEAT !~ /pgsql/) { err(2, 'Auto not built with PostgreSQL support. Aborting.', 1); }
if ($ENFEAT !~ /pgsql/) { err(2, 'Auto not built with PostgreSQL support. Aborting.', 1) }
my @reqcval = qw(database:name database:host database:username database:password);
foreach (@reqcval) { if (!conf_get($_)) { err(2, "Missing required configuration value $_. Aborting.", 1); } }
foreach (@reqcval) { if (!conf_get($_)) { err(2, "Missing required configuration value $_. Aborting.", 1) } }
undef @reqcval;
# Import DBD::Pg.
@@ -297,7 +341,7 @@ given (lc((conf_get('database:format'))[0][0])) {
}
}
# Unknown database format.
default { err(2, 'Unknown database format \''.lc((conf_get('database:format'))[0][0]).'\'. Aborting.', 1); }
default { err(2, 'Unknown database format \''.lc((conf_get('database:format'))[0][0]).'\'. Aborting.', 1) }
}
@@ -312,44 +356,44 @@ if (conf_get('privset')) {
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} } = ($_);
}
}
}
}
}
}
}
}
@@ -375,9 +419,13 @@ if (!$DEBUG) {
$APID = fork;
if ($APID != 0) {
alog '* Successfully forked into the background. Process ID: '.$APID;
open my $FPID, '>', "$Bin/auto.pid" or exit;
print {$FPID} "$APID\n" or exit;
close $FPID or exit;
# Figure out where to throw auto.pid.
my $pidfile;
if ($UPREFIX) { $pidfile = "$bin{cwd}/auto.pid" }
else { $pidfile = "$Bin/auto.pid" }
open my $FPID, '>', $pidfile 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);
@@ -400,7 +448,7 @@ if (conf_get('module')) {
alog '* Loading modules...';
dbug '* Loading modules...';
foreach (@{ (conf_get('module'))[0] }) {
mod_load($_);
mod_load($_);
}
}
@@ -435,43 +483,53 @@ API::Std::cmd_add('SHUTDOWN', 2, 'cmd.shutdown', \%Core::Cmd::HELP_SHUTDOWN, \&C
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);
API::Std::cmd_add('HELP', 2, 0, \%Core::Cmd::HELP_HELP, \&Core::Cmd::cmd_help);
# Aliases, if any.
if (conf_get('aliases:alias')) {
my $aliases = (conf_get('aliases:alias'))[0];
foreach (@{$aliases}) {
if ($_ =~ m/\s/xsm) {
my @data = split /\s/xsm, $_;
API::Std::cmd_alias($data[0], join ' ', @data[1..$#data]);
}
}
}
# 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};
}
}
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;
# 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};
API::Std::event_run('on_disconnect', $sockid);
if (!keys %SOCKET) {
@@ -483,21 +541,21 @@ 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.
Proto::IRC::ircparse($sockid, $line);
}
Proto::IRC::ircparse($sockid, $line);
}
}
}
@@ -510,12 +568,12 @@ sub socksnd {
my ($svr, $data) = @_;
if (defined $SOCKET{$svr}) {
syswrite $SOCKET{$svr}, $data."\r\n", POSIX::BUFSIZ, 0;
dbug "$svr << $data";
return 1;
syswrite $SOCKET{$svr}, $data."\r\n", POSIX::BUFSIZ, 0;
dbug "$svr << $data";
return 1;
}
else {
return 0;
return;
}
}
@@ -523,12 +581,12 @@ sub socksnd {
sub mod_load {
my ($module) = @_;
if (-e "$Bin/../modules/$module.pm") {
do "$Bin/../modules/$module.pm" and return 1;
if (-e "$bin{mod}/$module.pm") {
do "$bin{mod}/$module.pm" and return 1;
}
else {
if (-e "$Bin/../modules/$module/main.pm") {
do "$Bin/../modules/$module/main.pm" and return 1;
if (-e "$bin{mod}/$module/main.pm") {
do "$bin{mod}/$module/main.pm" and return 1;
}
}
+54 -15
View File
@@ -8,12 +8,45 @@ use strict;
use warnings;
use English qw(-no_match_vars);
use FindBin qw($Bin);
use Cwd;
use Pod::Html;
use Pod::Man;
our $Bin = $Bin;
our $VERSION = 1.00;
my ($UPREFIX, %bin);
$bin{cwd} = getcwd;
if (!-e "$Bin/../build/syswide") {
# Must be a custom PREFIX install.
$bin{etc} = "$bin{cwd}/etc";
$bin{var} = "$bin{cwd}/var";
if (!-e "$Bin/lib/Lib/Auto.pm") {
# Must be a system wide install.
$bin{lib} = "$Bin/../lib/autobot/3.0.0";
$bin{bld} = "$bin{lib}/build";
$bin{lng} = "$bin{lib}/lang";
$bin{mod} = "$bin{lib}/modules";
}
else {
# Or not.
$bin{lib} = "$Bin/../lib";
$bin{bld} = "$Bin/../build";
$bin{lng} = "$Bin/../lang";
$bin{mod} = "$Bin/../modules";
}
$UPREFIX = 1;
}
else {
# Must be a standard install.
$bin{etc} = "$Bin/../etc";
$bin{var} = "$Bin/../var";
$bin{lib} = "$Bin/../lib";
$bin{bld} = "$Bin/../build";
$bin{lng} = "$Bin/../lang";
$bin{mod} = "$Bin/../modules";
$UPREFIX = 0;
}
# Get module parameter.
if (!defined $ARGV[0]) {
say 'Not enough parameters. Usage: buildmod <module>';
@@ -24,13 +57,13 @@ my $module = $ARGV[0];
# Set full path.
my $type = 0;
my $modulep;
if (-e "$Bin/../modules/$module.pm") {
$modulep = "$Bin/../modules/$module.pm";
if (-e "$bin{mod}/$module.pm") {
$modulep = "$bin{mod}/$module.pm";
$type = 1;
}
else {
if (-e "$Bin/../modules/$module/Buildfile") {
$modulep = "$Bin/../modules/$module/Buildfile";
if (-e "$bin{mod}/$module/Buildfile") {
$modulep = "$bin{mod}/$module/Buildfile";
$type = 2;
}
else {
@@ -95,17 +128,17 @@ foreach (@pars) {
foreach my $cpanmod (@vals) {
$res = eval('require '.$cpanmod.'; 1;');
say ' '.$cpanmod.': '.(($res) ? 'Found' : 'Not Found');
if (!$res) { $die = 1; }
if (!$res) { $die = 1 }
}
print $RS;
if ($die) { say 'Failed to build '.$module.'.'; exit; }
if ($die) { say 'Failed to build '.$module.'.'; exit }
}
when ('perl') {
print 'Checking Perl version..... '.$PERL_VERSION.' - ';
if ($] < $val) { $die = 1; }
if ($] < $val) { $die = 1 }
say (($die) ? 'Not OK' : 'OK');
if ($die) { say 'Failed to build '.$module.'.'; exit; }
if ($die) { say 'Failed to build '.$module.'.'; exit }
}
}
}
@@ -119,7 +152,7 @@ close $FMPH;
say 'Generating documentation.....';
my $podbuf;
foreach my $line (@MPBUF) {
if (!defined $line) { $line = ' '; }
if (!defined $line) { $line = ' ' }
$line =~ s/(\r|\n)//g;
if ($line eq '__END__') {
@@ -132,20 +165,26 @@ foreach my $line (@MPBUF) {
}
# Create the autodoc/ dir if it doesn't exist.
if (!-d "$Bin/../autodoc") {
mkdir "$Bin/../autodoc";
my $docdir;
if ($UPREFIX) {
$docdir = "$ENV{HOME}/autodoc";
if (!-d "$ENV{HOME}/autodoc") { mkdir "$ENV{HOME}/autodoc" }
}
else {
$docdir = "$Bin/../autodoc";
if (!-d "$Bin/../autodoc") { mkdir "$Bin/../autodoc" }
}
# Save to POD file in autodoc/
open my $FMPNH, '>', "$Bin/../autodoc/$module.pod";
open my $FMPNH, '>', "$docdir/$module.pod";
print {$FMPNH} $podbuf;
close $FMPNH;
# Create HTML.
pod2html("--infile=$Bin/../autodoc/$module.pod", "--outfile=$Bin/../autodoc/$module.html");
pod2html("--infile=$docdir/$module.pod", "--outfile=$docdir/$module.html");
# Create *roff.
my $manifier = Pod::Man->new();
$manifier->parse_from_file("$Bin/../autodoc/$module.pod", "$Bin/../autodoc/$module.1");
$manifier->parse_from_file("$docdir/$module.pod", "$docdir/$module.1");
print $RS;
say 'Done.';
+40 -6
View File
@@ -9,8 +9,42 @@ use 5.010_000;
use strict;
use warnings;
use FindBin qw($Bin);
use Cwd;
our $VERSION = 1.00;
my $bin = $Bin;
my $Bin = $Bin;
my ($UPREFIX, %bin);
$bin{cwd} = getcwd;
if (!-e "$Bin/../build/syswide") {
# Must be a custom PREFIX install.
$bin{etc} = "$bin{cwd}/etc";
$bin{var} = "$bin{cwd}/var";
if (!-e "$Bin/lib/Lib/Auto.pm") {
# Must be a system wide install.
$bin{lib} = "$Bin/../lib/autobot/3.0.0";
$bin{bld} = "$bin{lib}/build";
$bin{lng} = "$bin{lib}/lang";
$bin{mod} = "$bin{lib}/modules";
}
else {
# Or not.
$bin{lib} = "$Bin/../lib";
$bin{bld} = "$Bin/../build";
$bin{lng} = "$Bin/../lang";
$bin{mod} = "$Bin/../modules";
}
$UPREFIX = 1;
}
else {
# Must be a standard install.
$bin{etc} = "$Bin/../etc";
$bin{var} = "$Bin/../var";
$bin{lib} = "$Bin/../lib";
$bin{bld} = "$Bin/../build";
$bin{lng} = "$Bin/../lang";
$bin{mod} = "$Bin/../modules";
$UPREFIX = 0;
}
# Get the name of the network this cert is for.
print 'Network Name: ';
@@ -19,15 +53,15 @@ $net =~ s/(\r|\n)//gxsm;
say q{};
# Make sure etc/certs/ exists.
if (!-d "$bin/../etc") { mkdir "$bin/../etc", 0755; }
if (!-d "$bin/../etc/certs") { mkdir "$bin/../etc/certs", 0755; }
if (!-d "$bin{etc}") { mkdir "$bin{etc}", 0755 }
if (!-d "$bin{etc}/certs") { mkdir "$bin{etc}/certs", 0755 }
# Generate key and cert.
system 'openssl req -nodes -newkey rsa:2048 -keyout '.$bin.'/../etc/certs/'.$net.'.key -x509 -days 3650 -out '.$bin.'/../etc/certs/'.$net.'.cert';
chmod 0400, "$bin/../etc/certs/$net.key";
system "openssl req -nodes -newkey rsa:2048 -keyout $bin{etc}/certs/$net.key -x509 -days 3650 -out $bin{etc}/certs/$net.cert";
chmod 0400, "$bin{etc}/certs/$net.key";
# Get the fingerprint.
my $fpr = `openssl x509 -noout -fingerprint < $bin/../etc/certs/$net.cert`;
my $fpr = `openssl x509 -noout -fingerprint < $bin{etc}/certs/$net.cert`;
my $fp;
while ($fpr =~ s/(.*\n)//) {
my $line = $1;
Executable
+53
View File
@@ -0,0 +1,53 @@
#!/usr/bin/env perl
# bin/wizard - Wizard for creating local Auto configuration directories.
# Copyright (C) 2010-2011 Xelhua Development Group, et al.
# This program is free software; rights to this code are stated in doc/LICENSE.
use 5.010_000;
use strict;
use warnings;
use Cwd;
use FindBin qw($Bin);
use File::Copy;
our $VERSION = 1.00;
my $Bin = $Bin;
# Get current working directory.
my $cwd = getcwd();
# One argument required.
if (!defined $ARGV[0]) {
say 'ERROR: Missing arguments.';
say 'Usage: auto-wizard <directory>';
exit;
}
# Strip trailing slash.
my $installdir = $ARGV[0];
$installdir =~ s/\/$//xsm;
# Create missing directories.
if (!-d "$cwd/$installdir") { mkdir "$cwd/$installdir" }
if (!-d "$cwd/$installdir/etc") { mkdir "$cwd/$installdir/etc" }
if (!-d "$cwd/$installdir/var") { mkdir "$cwd/$installdir/var" }
# Copy over example.conf.
copy("$Bin/../lib/autobot/3.0.0/dist/example.conf", "$cwd/$installdir/etc/example.conf");
chmod 0644, "$cwd/$installdir/etc/example.conf";
# Our work is done.
print <<"MSG";
Successfully installed to "$cwd/$installdir"!
I've also created an example.conf for you and left it in etc/, configure it and
rename it to auto.conf or any name of your choice.
See the Xelhua Wiki at http://wiki.xelhua.org for complete documentation.
After that, change directory to "$cwd/$installdir" and run `$Bin/auto` (or if
"$Bin" is in your PATH; just `auto`).
If you gave your config file a name other than auto.conf, pass -c=FILENAME to
`auto`, like so, if your config is etc/foo.conf: $Bin/auto -c=foo.conf
Enjoy.
MSG
+32
View File
@@ -5,12 +5,44 @@ Auto IRC Bot 3.0: Change Log
===============================================================================
3.0 Alpha 9
===============================================================================
* Bug fix: Fixed an exploit in QDB RAND.
* UNO: Fixed a formatting issue in duration.
3.0 Alpha 8
===============================================================================
* Full support for custom PREFIX installs (including global installs) has
been completed.
* Added fastest/slowest game, most cards and most players records to UNO.
* Fixed a bug in UNO that allowed users to join more than once.
* Added optional uno:english option. See documentation for UNO.
* UNO has a new config option, uno:msg, for setting what method the bot
uses for private messages.
* Added command aliasing.
* Moved botinfo to State::IRC.
* Added hook on_selfkick for when we are kicked from a channel.
* Moved chanusers to State::IRC.
* Created State::IRC.
* UNO now keeps game duration and cards played count.
* Added a LOLCAT module for translating English to LOLCAT.
* EightBall module rewritten.
* Fixed a bug in LinkTitle that caused multi-line <title>'s to display
wrong.
* Added `wizard`, for creating local Auto config directories.
* Made Auto respond properly to PRIVMSGs received before connection.
* Added an AUR module.
* Fixed an exploit in QDB that allowed users to use services fantasy
commands with the bot's account.
* Heavily improved ./install.
3.0 Alpha 7
===============================================================================
* Fixed a bug in UNO where rehashing during a game caused a crash.
* Proto::IRC::umodes renamed to Proto::IRC::botinfo{svr}{modes}.
* Fixed a bug where incoming PART's from ourselves were not parsed.
* Our usermodes are now tracked in Proto::IRC::umodes.
* Added an Oper module.
* Added events on_cmode and on_umode.
* Added event on_myinfo for RPL_MYINFO (numeric 004).
* Raw hooks now take hook names and support multiple hooks. This changes
+1
View File
@@ -18,6 +18,7 @@ Legend:
[X] Add English strings
[X] Add Spanish strings
[X] Add French strings
[ ] Add Spanish, French and German translations to all official command help hashes.
[!] API
[X] Create basic modular functions
+7
View File
@@ -86,6 +86,13 @@ user "#bot-ops" {
privs "op";
}
# Command aliases.
# These can be used to alias a shortcut to a longer command.
# Like so: alias "PL UNO PLAY";
aliases {
alias "RELOAD REHASH";
}
# Database.
database {
# Format. This can be one of the following:
+113 -36
View File
@@ -6,49 +6,78 @@
package Install;
use strict;
use warnings;
use Getopt::Long;
use English qw(-no_match_vars);
use FindBin qw($Bin);
use File::Copy;
use File::Path qw(make_path remove_tree);
our $Bin = $Bin;
BEGIN { unshift(@INC, "$Bin/lib"); }
BEGIN { unshift(@INC, "$Bin/lib") }
use Lib::Install;
# Installation script.
our $VERSION = 1.00;
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.';
println ' --enable-ipv6 - Enable support for IPv6.';
println ' --disable-ssl - Disable support for SSL.';
println '*** End of Help ***';
exit 1;
}
elsif ($_ eq '--enable-sasl') {
$features .= ' sasl';
}
elsif ($_ eq '--disable-ssl') {
$features =~ s/ ssl//g;
}
elsif ($_ eq '--enable-ipv6') {
$features .= ' ipv6';
}
elsif ($_ eq '--with-mysql') {
$features =~ s/(sqlite|pgsql)/mysql/g;
}
elsif ($_ eq '--with-pgsql') {
$features =~ s/(sqlite|mysql)/pgsql/g;
}
else {
println "Warning: Unknown option '$_'";
}
}
# Store the arguments passed to us.
my ($opt_help, $opt_syswide, $PREFIX, $feature_nossl, $feature_sasl, $feature_ipv6, $feature_mysql, $feature_pgsql);
GetOptions(
'--disable-ssl' => \$feature_nossl,
'--enable-sasl' => \$feature_sasl,
'--enable-ipv6' => \$feature_ipv6,
'--with-mysql' => \$feature_mysql,
'--with-pgsql' => \$feature_pgsql,
'--prefix=s' => \$PREFIX,
'--syswide' => \$opt_syswide,
'--help' => \$opt_help,
);
# If --help was passed.
if ($opt_help) {
print <<"HELP";
Auto IRC Bot Installation Wizard (v1.00).
Usage: perl install [options]
Options:
--disable-ssl Disables SSL support.
--enable-sasl Enables SASL support.
--enable-ipv6 Enables IPv6 support.
--with-mysql Uses MySQL instead of SQLite.
--with-pgsql Uses PostgreSQL instead of SQLite.
--syswide Prefixes bin/ files with auto- (excluding `auto` itself), as
well as installs build/ to lib/ instead. Always use this
when installing to /usr.
--prefix=PREFIX Installs files to PREFIX
[$Bin]
HELP
exit 1;
}
# Set features.
my $features = 'base';
$features .= ' ssl' unless $feature_nossl;
$features .= ' sasl' if $feature_sasl;
$features .= ' ipv6' if $feature_ipv6;
if ($feature_mysql) { $features .= ' mysql' }
elsif ($feature_pgsql) { $features .= ' pgsql' }
else { $features .= ' sqlite' }
# Where to install.
my $upref;
if (!$PREFIX) {
$PREFIX = $Bin;
$upref = 0;
}
else { $upref = 1 }
# Adjust installation to be more appropriate for system-wide installs.
my $libbuild = 0;
if ($opt_syswide) { $libbuild = 1 }
# Check Perl version.
println "Checking Perl version..... $^V";
eval {
@@ -130,15 +159,63 @@ else {
# Create build.
println "\0";
println "Building.....";
if (!-d "$Bin/build") {
mkdir "$Bin/build";
if (!-d $PREFIX) { make_path($PREFIX) }
my $libdir;
if ($libbuild) { $libdir = "$PREFIX/lib/autobot/3.0.0" }
else { $libdir = "$PREFIX/lib" }
my $builddir;
if ($libbuild) { $builddir = "$libdir/build" }
else { $builddir = "$PREFIX/build" }
if (!-d $builddir) { make_path($builddir) }
build($features, $builddir, $opt_syswide);
# Install.
if ($upref) {
require File::Copy::Recursive;
File::Copy::Recursive->import('rcopy');
my $langdir;
if ($libbuild) { $langdir = "$libdir/lang" }
else { $langdir = "$PREFIX/lang" }
my $moddir;
if ($libbuild) { $moddir = "$libdir/modules" }
else { $moddir = "$PREFIX/modules" }
my $distdir;
if ($libbuild) { $distdir = "$libdir/dist" }
else { $distdir = "$PREFIX/dist" }
println "Installing.....";
if (!-d "$PREFIX/bin") { make_path("$PREFIX/bin") }
if (!-d $libdir) { make_path($libdir) }
if (!-d $langdir) { make_path($langdir) }
if (!-d $moddir) { make_path($moddir) }
if (!-d $distdir) { make_path($distdir) }
my $bgenssl = 'genssl';
my $bbuildmod = 'buildmod';
my $bwizard = 'wizard';
if ($libbuild) {
$bgenssl = "auto-$bgenssl";
$bbuildmod = "auto-$bbuildmod";
$bwizard = "auto-$bwizard";
}
copy("$Bin/bin/auto", "$PREFIX/bin/auto");
copy("$Bin/bin/buildmod", "$PREFIX/bin/$bbuildmod");
copy("$Bin/bin/genssl", "$PREFIX/bin/$bgenssl");
copy("$Bin/bin/wizard", "$PREFIX/bin/$bwizard");
chmod 0755, "$PREFIX/bin/auto", "$PREFIX/bin/$bgenssl", "$PREFIX/bin/$bbuildmod", "$PREFIX/bin/$bwizard";
rcopy("$Bin/lib/*", "$libdir/");
rcopy("$Bin/lang/*", "$langdir/");
rcopy("$Bin/modules/*", "$moddir/");
copy("$Bin/etc/example.conf", "$distdir/");
remove_tree("$libdir/File");
}
build($features);
println 'Done.';
println q{};
installmods();
if ($libbuild) {
println 'To install modules, run the auto-buildmod utility on a module.';
}
else { installmods($PREFIX) }
println q{};
# Success!
+64 -78
View File
@@ -6,8 +6,8 @@ use strict;
use warnings;
use feature qw(switch);
use Exporter;
use base qw(Exporter);
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(ban cjoin cpart cmode umode kick privmsg notice quit nick names
topic who usrc match_mask);
@@ -15,22 +15,21 @@ our @EXPORT_OK = qw(ban cjoin cpart cmode umode kick privmsg notice quit nick na
API::Std::event_add('on_disconnect');
# Set a ban, based on config bantype value.
sub ban
{
sub ban {
my ($svr, $chan, $type, $user) = @_;
my $cbt = (API::Std::conf_get('bantype'))[0][0];
# Prepare the mask we're going to ban.
my $mask;
given ($cbt) {
when (1) { $mask = '*!*@'.$user->{host}; }
when (2) { $mask = $user->{nick}.'!*@*'; }
when (3) { $mask = '*!'.$user->{user}.'@'.$user->{host}; }
when (4) { $mask = $user->{nick}.'!*'.$user->{user}.'@'.$user->{host}; }
when (1) { $mask = '*!*@'.$user->{host} }
when (2) { $mask = $user->{nick}.'!*@*' }
when (3) { $mask = q{*!}.$user->{user}.q{@}.$user->{host} }
when (4) { $mask = $user->{nick}.q{!*}.$user->{user}.q{@}.$user->{host} }
when (5) {
my @hd = split m/[\.]/, $user->{host};
shift @hd;
$mask = '*!*@*.'.join ' ', @hd;
$mask = '*!*@*.'.join q{ }, @hd;
}
}
@@ -48,57 +47,52 @@ sub ban
}
# Join a channel.
sub cjoin
{
sub cjoin {
my ($svr, $chan, $key) = @_;
Auto::socksnd($svr, "JOIN ".((defined $key) ? "$chan $key" : "$chan"));
Auto::socksnd($svr, 'JOIN '.((defined $key) ? "$chan $key" : $chan));
return 1;
}
# Part a channel.
sub cpart
{
sub cpart {
my ($svr, $chan, $reason) = @_;
if (defined $reason) {
Auto::socksnd($svr, "PART $chan :$reason");
Auto::socksnd($svr, "PART $chan :$reason");
}
else {
Auto::socksnd($svr, "PART $chan :Leaving");
Auto::socksnd($svr, "PART $chan :Leaving");
}
return 1;
}
# Set mode(s) on a channel.
sub cmode
{
sub cmode {
my ($svr, $chan, $modes) = @_;
Auto::socksnd($svr, "MODE $chan $modes");
return 1;
}
# Set mode(s) on us.
sub umode
{
sub umode {
my ($svr, $modes) = @_;
Auto::socksnd($svr, "MODE ".$Proto::IRC::botinfo{$svr}{nick}." $modes");
Auto::socksnd($svr, 'MODE '.$State::IRC::botinfo{$svr}{nick}." $modes");
return 1;
}
}
# Send a PRIVMSG.
sub privmsg
{
sub privmsg {
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 :";
my $maxlen = 510 - length q{:}.$State::IRC::botinfo{$svr}{nick}.q{!}.$State::IRC::botinfo{$svr}{user}.q{@}.$State::IRC::botinfo{$svr}{mask}." PRIVMSG $target :";
# Divide message if it surpasses the maximum length.
while (length $message >= $maxlen) {
@@ -106,17 +100,16 @@ sub privmsg
Auto::socksnd($svr, "PRIVMSG $target :$submsg");
}
if (length $message) { Auto::socksnd($svr, "PRIVMSG $target :$message") }
return 1;
}
# Send a NOTICE.
sub notice
{
sub notice {
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 :";
my $maxlen = 510 - length q{:}.$State::IRC::botinfo{$svr}{nick}.q{!}.$State::IRC::botinfo{$svr}{user}.q{@}.$State::IRC::botinfo{$svr}{mask}." NOTICE $target :";
# Divide message if it surpasses the maximum length.
while (length $message >= $maxlen) {
@@ -124,13 +117,12 @@ sub notice
Auto::socksnd($svr, "NOTICE $target :$submsg");
}
if (length $message) { Auto::socksnd($svr, "NOTICE $target :$message") }
return 1;
}
# Send an ACTION PRIVMSG.
sub act
{
sub act {
my ($svr, $target, $message) = @_;
Auto::socksnd($svr, "PRIVMSG $target :\001ACTION $message\001");
@@ -139,40 +131,36 @@ sub act
}
# Change bot nickname.
sub nick
{
sub nick {
my ($svr, $newnick) = @_;
Auto::socksnd($svr, "NICK $newnick");
$Proto::IRC::botinfo{$svr}{newnick} = $newnick;
$State::IRC::botinfo{$svr}{newnick} = $newnick;
return 1;
}
# Request the users of a channel.
sub names
{
sub names {
my ($svr, $chan) = @_;
Auto::socksnd($svr, "NAMES $chan");
return 1;
}
# Send a topic to the channel.
sub topic
{
sub topic {
my ($svr, $chan, $topic) = @_;
Auto::socksnd($svr, "TOPIC $chan :$topic");
return 1;
}
# Kick a user.
sub kick
{
sub kick {
my ($svr, $chan, $nick, $msg) = @_;
Auto::socksnd($svr, "KICK $chan $nick :".((defined $msg) ? $msg : 'No reason'));
@@ -183,12 +171,12 @@ sub kick
# Quit IRC.
sub quit {
my ($svr, $reason) = @_;
if (defined $reason) {
Auto::socksnd($svr, "QUIT :$reason");
Auto::socksnd($svr, "QUIT :$reason");
}
else {
Auto::socksnd($svr, 'QUIT :Leaving');
Auto::socksnd($svr, 'QUIT :Leaving');
}
# Trigger on_disconnect.
@@ -207,37 +195,35 @@ sub who {
}
# Get nick, ident and host from a <nick>!<ident>@<host>
sub usrc
{
sub usrc {
my ($ex) = @_;
my @si = split('!', $ex);
my @sii = split('@', $si[1]);
my @si = split m/[!]/xsm, $ex;
my @sii = split m/[@]/xsm, $si[1];
return (
nick => $si[0],
user => $sii[0],
host => $sii[1]
nick => $si[0],
user => $sii[0],
host => $sii[1]
);
}
# Match two IRC masks.
sub match_mask
{
sub match_mask {
my ($mu, $mh) = @_;
# Prepare the regex.
$mh =~ s/\./\\\./g;
$mh =~ s/\?/\./g;
$mh =~ s/\*/\.\*/g;
$mh = '^'.$mh.'$';
$mh =~ s/\./\\\./gxsm;
$mh =~ s/\?/\./gxsm;
$mh =~ s/\*/\.\*/gxsm;
$mh = q{^}.$mh.q{$};
# Let's grep the user's mask.
if (grep(/$mh/, $mu)) {
return 1;
if ($mu =~ m/$mh/xsm) {
return 1;
}
return 0;
return;
}
+22 -22
View File
@@ -21,7 +21,7 @@ sub println
my ($out) = @_;
if (!defined $out) {
print $RS;
print $RS;
}
else {
print $out.$RS;
@@ -36,8 +36,8 @@ sub dbug
my ($out) = @_;
if ($Auto::DEBUG) {
# We're in debug mode; print it out.
say $out;
# We're in debug mode; print it out.
say $out;
}
return 1;
@@ -56,12 +56,12 @@ sub alog
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)
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;
open my $FLOG, '>>', "$Auto::bin{var}/$date.log" or return;
print {$FLOG} "[$time] $lmsg\n" or return;
close $FLOG or return;
@@ -76,29 +76,29 @@ sub expire_logs
# Check for invalid values.
if ($celog =~ m/[^0-9]/sm) { ## no critic qw(RegularExpressions::RequireExtendedFormatting)
# Must be numbers only.
return;
# Must be numbers only.
return;
}
elsif (!$celog) {
# No expire.
return;
# No expire.
return;
}
# Iterate through each logfile.
foreach my $file (glob fpfmt("$Auto::Bin/../var/*")) {
my (undef, $file) = split 'bin/../var/', $file; ## no critic qw(BuiltinFunctions::ProhibitStringySplit)
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;
+171 -177
View File
@@ -9,113 +9,111 @@ use Exporter;
use base qw(Exporter);
our (%LANGE, %MODULE, %EVENTS, %HOOKS, %CMDS, %RAWHOOKS);
our (%LANGE, %MODULE, %EVENTS, %HOOKS, %CMDS, %ALIASES, %RAWHOOKS);
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 fpfmt);
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
{
sub mod_init {
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.'...');
if (keys %Auto::SOCKET) { API::Log::slog('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 !~ m/^3\.0\.0a(7)$/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;
if ($autover !~ m/^3\.0\.0a(7|8|9)$/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;
}
# 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 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.');
if (keys %Auto::SOCKET) { API::Log::slog('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;
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{.}); }
# 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{.}) }
# Just in case.
Class::Unload->unload($pkg);
return;
return;
}
}
# Check if a module exists.
sub mod_exists
{
sub mod_exists {
my ($name) = @_;
if (defined $API::Std::MODULE{$name}) { return 1; }
if (defined $API::Std::MODULE{$name}) { return 1 }
return;
}
# Void a module.
sub mod_void
{
sub mod_void {
my ($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.'...'); }
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?');
if (keys %Auto::SOCKET) { API::Log::slog('MODULES: Failed to unload '.$module.'. No such module?'); }
return;
API::Log::dbug('MODULES: Failed to unload '.$module.'. No such module?');
API::Log::alog('MODULES: Failed to unload '.$module.'. No such module?');
if (keys %Auto::SOCKET) { API::Log::slog('MODULES: Failed to unload '.$module.'. No such module?') }
return;
}
# Run the module's _void sub.
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 (keys %Auto::SOCKET) { API::Log::slog('MODULES: Successfully unloaded '.$module.q{.}); }
return 1;
# If successful, delete class from program and delete module from hash.
Class::Unload->unload($MODULE{$module}{pkg});
delete $MODULE{$module};
API::Log::dbug('MODULES: Successfully unloaded '.$module.q{.});
API::Log::alog('MODULES: Successfully unloaded '.$module.q{.});
if (keys %Auto::SOCKET) { API::Log::slog('MODULES: Successfully unloaded '.$module.q{.}) }
return 1;
}
else {
# Otherwise, return a failed to unload message.
API::Log::dbug('MODULES: Failed to unload '.$module.q{.});
API::Log::alog('MODULES: Failed to unload '.$module.q{.});
if (keys %Auto::SOCKET) { API::Log::slog('MODULES: Failed to unload '.$module.q{.}); }
return;
# Otherwise, return a failed to unload message.
API::Log::dbug('MODULES: Failed to unload '.$module.q{.});
API::Log::alog('MODULES: Failed to unload '.$module.q{.});
if (keys %Auto::SOCKET) { API::Log::slog('MODULES: Failed to unload '.$module.q{.}) }
return;
}
}
# Add a command to Auto.
sub cmd_add
{
sub cmd_add {
my ($cmd, $lvl, $priv, $help, $sub) = @_;
$cmd = uc $cmd;
if (defined $API::Std::CMDS{$cmd}) { return; }
if ($lvl =~ m/[^0-3]/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;
@@ -125,144 +123,148 @@ sub cmd_add
return 1;
}
# Alias a command to another.
sub cmd_alias {
my ($alias, $cmd) = @_;
# Prepare data.
$alias = uc $alias;
$cmd = uc $cmd;
# Create alias.
$ALIASES{$alias} = $cmd;
return 1;
}
# Delete a command from Auto.
sub cmd_del
{
sub cmd_del {
my ($cmd) = @_;
$cmd = uc $cmd;
if (defined $API::Std::CMDS{$cmd}) {
delete $API::Std::CMDS{$cmd};
delete $API::Std::CMDS{$cmd};
}
else {
return;
return;
}
return 1;
}
# Add an event to Auto.
sub event_add
{
sub event_add {
my ($name) = @_;
if (!defined $EVENTS{lc $name}) {
$EVENTS{lc $name} = 1;
return 1;
$EVENTS{lc $name} = 1;
return 1;
}
else {
API::Log::dbug('DEBUG: Attempt to add a pre-existing event ('.lc $name.')! Ignoring...');
return;
API::Log::dbug('DEBUG: Attempt to add a pre-existing event ('.lc $name.')! Ignoring...');
return;
}
}
# Delete an event from Auto.
sub event_del
{
sub event_del {
my ($name) = @_;
if (defined $EVENTS{lc $name}) {
delete $EVENTS{lc $name};
delete $HOOKS{lc $name};
return 1;
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;
API::Log::dbug('DEBUG: Attempt to delete a non-existing event ('.lc $name.')! Ignoring...');
return;
}
}
# Trigger an event.
sub event_run
{
sub event_run {
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 ($ri == -1) { last; }
}
foreach my $hk (keys %{ $HOOKS{lc $event} }) {
my $ri = &{ $HOOKS{lc $event}{$hk} }(@args);
if ($ri == -1) { last }
}
}
return 1;
}
# Add a hook to Auto.
sub hook_add
{
sub hook_add {
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;
}
if (defined $API::Std::EVENTS{lc $event}) {
$API::Std::HOOKS{lc $event}{lc $name} = $sub;
return 1;
}
else {
return;
}
}
else {
return;
return;
}
}
# Delete a hook from Auto.
sub hook_del
{
sub hook_del {
my ($event, $name) = @_;
if (defined $API::Std::HOOKS{lc $event}{lc $name}) {
delete $API::Std::HOOKS{lc $event}{lc $name};
return 1;
delete $API::Std::HOOKS{lc $event}{lc $name};
return 1;
}
else {
return;
return;
}
}
# Add a timer to Auto.
sub timer_add
{
sub timer_add {
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;
return;
}
if ($time =~ m/[^0-9]/sm) { ## no critic qw(RegularExpressions::RequireExtendedFormatting)
return;
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;
$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;
}
# Delete a timer from Auto.
sub timer_del
{
sub timer_del {
my ($name) = @_;
$name = lc $name;
if (defined $Auto::TIMERS{$name}) {
delete $Auto::TIMERS{$name};
return 1;
delete $Auto::TIMERS{$name};
return 1;
}
return;
}
# Hook onto a raw command.
sub rchook_add
{
sub rchook_add {
my ($cmd, $name, $sub) = @_;
$cmd = uc $cmd;
@@ -278,8 +280,7 @@ sub rchook_add
}
# Delete a raw command hook.
sub rchook_del
{
sub rchook_del {
my ($cmd, $name) = @_;
$cmd = uc $cmd;
@@ -293,17 +294,16 @@ sub rchook_del
}
# Configuration value getter.
sub conf_get
{
sub conf_get {
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)
@val = split m/[:]/sm, $value; ## no critic qw(RegularExpressions::RequireExtendedFormatting)
}
else {
@val = ($value);
@val = ($value);
}
# Undefine this as it's unnecessary now.
undef $value;
@@ -313,65 +313,63 @@ sub conf_get
# 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]};
}
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]};
}
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]};
}
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;
}
}
# Translation subroutine.
sub trans
{
sub trans {
my $id = shift;
$id =~ s/ /_/gsm;
if (defined $API::Std::LANGE{$id}) {
return sprintf $API::Std::LANGE{$id}, @_;
return sprintf $API::Std::LANGE{$id}, @_;
}
else {
$id =~ s/_/ /gsm;
return $id;
$id =~ s/_/ /gsm;
return $id;
}
}
# Match user subroutine.
sub match_user
{
sub match_user {
my (%user) = @_;
# Get data from config.
if (!conf_get('user')) { return; }
if (!conf_get('user')) { return }
my %uhp = conf_get('user');
foreach my $userkey (keys %uhp) {
# For each user block.
my %ulhp = %{ $uhp{$userkey} };
foreach my $uhk (keys %ulhp) {
# 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.
@@ -380,60 +378,58 @@ 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 $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)
if (defined $State::IRC::chanusers{$svr}{$user{chan}}{$user{nick}}) {
if ($State::IRC::chanusers{$svr}{$user{chan}}{$user{nick}} =~ m/($ccst)/sm) { return $userkey } ## no critic qw(RegularExpressions::RequireExtendedFormatting)
}
}
else {
foreach my $bcj (keys %{ $Proto::IRC::botchans{$svr} }) {
if (API::IRC::match_mask($bcj, $ccnm)) {
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)
if (defined $State::IRC::chanusers{$svr}{$bcj}{$user{nick}}) {
if ($State::IRC::chanusers{$svr}{$bcj}{$user{nick}} =~ m/($ccst)/sm) { return $userkey } ## no critic qw(RegularExpressions::RequireExtendedFormatting)
}
}
}
}
}
}
}
}
}
return;
}
# Privilege subroutine.
sub has_priv
{
sub has_priv {
my ($cuser, $cpriv) = @_;
if (conf_get("user:$cuser:privs")) {
my $cups = (conf_get("user:$cuser:privs"))[0][0];
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;
}
# Ratelimit check subroutine.
sub ratelimit_check
{
sub ratelimit_check {
my (%src) = @_;
# Check if ratelimit is set to on.
@@ -451,9 +447,9 @@ sub ratelimit_check
return 1;
}
else {
# Increment their uses and return 0.
# Increment their uses and return false.
$Core::IRC::usercmd{$src{nick}.'@'.$src{host}.'/'.$src{svr}}++;
return 0;
return;
}
}
else {
@@ -465,25 +461,24 @@ sub ratelimit_check
}
# Error subroutine.
sub err ## no critic qw(Subroutines::ProhibitBuiltinHomonyms)
{
sub err { ## no critic qw(Subroutines::ProhibitBuiltinHomonyms)
my ($lvl, $msg, $fatal) = @_;
# Check for an invalid level.
if ($lvl =~ m/[^0-9]/sm) { ## no critic qw(RegularExpressions::RequireExtendedFormatting)
return;
return;
}
if ($fatal =~ m/[^0-1]/sm) { ## no critic qw(RegularExpressions::RequireExtendedFormatting)
return;
return;
}
# Level 1: Print to screen.
if ($lvl >= 1) {
say "ERROR: $msg";
say "ERROR: $msg";
}
# Level 2: Log to file.
if ($lvl >= 2) {
API::Log::alog("ERROR: $msg");
API::Log::alog("ERROR: $msg");
}
# Level 3: Log to IRC.
if ($lvl >= 3) {
@@ -500,13 +495,12 @@ sub err ## no critic qw(Subroutines::ProhibitBuiltinHomonyms)
}
# Warn subroutine.
sub awarn
{
sub awarn {
my ($lvl, $msg) = @_;
# Check for an invalid level.
if ($lvl =~ m/[^0-9]/sm) { ## no critic qw(RegularExpressions::RequireExtendedFormatting)
return;
return;
}
# Level 1: Print to screen.
@@ -515,7 +509,7 @@ sub awarn
}
# Level 2: Log to file.
if ($lvl >= 2) {
API::Log::alog("WARNING: $msg");
API::Log::alog("WARNING: $msg");
}
# Level 3: Log to IRC.
if ($lvl >= 3) {
@@ -529,8 +523,8 @@ sub awarn
sub fpfmt {
my ($path) = @_;
if ($path =~ m/\s/xsm) { return "\"$path\""; }
else { return $path; }
if ($path =~ m/\s/xsm) { return "\"$path\"" }
else { return $path }
}
+9 -9
View File
@@ -21,13 +21,13 @@ sub cmd_modload
# Check for the needed parameters.
if (!defined $argv[0]) {
notice($src->{svr}, $src->{nick}, trans("Not enough parameters").".");
return 0;
return;
}
# Check if the module is already loaded.
if (API::Std::mod_exists($argv[0])) {
notice($src->{svr}, $src->{nick}, "Module \002".$argv[0]."\002 is already loaded.");
return 0;
return;
}
# Go for it!
@@ -41,7 +41,7 @@ sub cmd_modload
else {
# We weren't.
notice($src->{svr}, $src->{nick}, "Module \002".$argv[0]."\002 failed to load.");
return 0;
return;
}
return 1;
@@ -59,13 +59,13 @@ sub cmd_modunload
# Check for the needed parameters.
if (!defined $argv[0]) {
notice($src->{svr}, $src->{nick}, trans("Not enough parameters").".");
return 0;
return;
}
# Check if the module exists.
if (!API::Std::mod_exists($argv[0])) {
notice($src->{svr}, $src->{nick}, "Module \002".$argv[0]."\002 is not loaded.");
return 0;
return;
}
# Go for it!
@@ -79,7 +79,7 @@ sub cmd_modunload
else {
# We weren't.
notice($src->{svr}, $src->{nick}, "Module \002".$argv[0]."\002 failed to unload.");
return 0;
return;
}
return 1;
@@ -97,13 +97,13 @@ sub cmd_modreload
# Check for the needed parameters.
if (!defined $argv[0]) {
notice($src->{svr}, $src->{nick}, trans("Not enough parameters").".");
return 0;
return;
}
# Check if the module exists.
if (!API::Std::mod_exists($argv[0])) {
notice($src->{svr}, $src->{nick}, "Module \002".$argv[0]."\002 is not loaded.");
return 0;
return;
}
# Go for it!
@@ -119,7 +119,7 @@ sub cmd_modreload
else {
# We weren't.
notice($src->{svr}, $src->{nick}, "Module \002".$argv[0]."\002 failed to reload.");
return 0;
return;
}
return 1;
+70 -35
View File
@@ -26,14 +26,49 @@ hook_add("on_uprivmsg", "ctcp_version_reply", sub {
return 1;
});
# Command alias parsing.
hook_add('on_cprivmsg', 'irc.commands.aliases', sub {
my (($src, $chan, ($cmd, @args))) = @_;
# Check for valid length.
if (length $cmd >= 2) {
my $ipref = substr $cmd, 0, 1, q{};
my $upref = (conf_get('fantasy_pf'))[0][0];
# Check if the prefix is valid.
if ($upref eq $ipref) {
# It is, check for an alias.
if (defined $API::Std::ALIASES{uc $cmd}) {
# Get aliased command.
my @actual;
if ($API::Std::ALIASES{uc $cmd} =~ m/ /xsm) { @actual = split /\s/xsm, $API::Std::ALIASES{uc $cmd} }
else { @actual = ($API::Std::ALIASES{uc $cmd}) }
# Prepare data.
my @msg = (
q{:}.$src->{nick}.q{!}.$src->{user}.q{@}.$src->{host},
'PRIVMSG',
$chan,
q{:}.$upref.$actual[0],
);
# Rest of the data.
if (scalar @actual > 1) { for (1..$#actual) { push @msg, $actual[$_] } }
if (defined $args[0]) { foreach (@args) { push @msg, $_ } }
# Simulate a PRIVMSG.
Proto::IRC::privmsg($src->{svr}, @msg);
}
}
}
return 1;
});
# QUIT hook; delete user from chanusers.
hook_add("on_quit", "quit_update_chanusers", sub {
my (($src, undef)) = @_;
my %src = %{ $src };
# Delete the user from all channels.
foreach my $ccu (keys %{ $Proto::IRC::chanusers{$src{svr}}}) {
if (defined $Proto::IRC::chanusers{$src{svr}}{$ccu}{$src{nick}}) { delete $Proto::IRC::chanusers{$src{svr}}{$ccu}{$src{nick}}; }
foreach my $ccu (keys %{ $State::IRC::chanusers{$src{svr}}}) {
if (defined $State::IRC::chanusers{$src{svr}}{$ccu}{$src{nick}}) { delete $State::IRC::chanusers{$src{svr}}{$ccu}{$src{nick}} }
}
return 1;
@@ -44,8 +79,8 @@ 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);
my $connmodes = (conf_get("server:$svr:modes"))[0][0];
API::IRC::umode($svr, $connmodes);
}
return 1;
@@ -55,7 +90,7 @@ hook_add("on_connect", "on_connect_modes", sub {
hook_add('on_connect', 'on_connect_selfwho', sub {
my ($svr) = @_;
API::IRC::who($svr, $Proto::IRC::botinfo{$svr}{nick});
API::IRC::who($svr, $State::IRC::botinfo{$svr}{nick});
return 1;
});
@@ -65,8 +100,8 @@ hook_add("on_connect", "plaintext_auth", sub {
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;
@@ -81,9 +116,9 @@ hook_add("on_connect", "autojoin", sub {
# Join the channels.
if (!defined $cajoin[1]) {
# For single-line ajoins.
my @sajoin = split(',', $cajoin[0]);
# For single-line ajoins.
my @sajoin = split(',', $cajoin[0]);
foreach (@sajoin) {
# Check if a key was specified.
if ($_ =~ m/\s/xsm) {
@@ -93,13 +128,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) {
# For multi-line ajoins.
foreach (@cajoin) {
# Check if a key was specified.
if ($_ =~ m/\s/xsm) {
# There was, join with it.
@@ -128,10 +163,10 @@ hook_add('on_whoreply', 'selfwho.getdata', sub {
my (($svr, $nick, undef, $user, $mask, undef, undef, undef, undef)) = @_;
# Check if it's for us.
if ($nick eq $Proto::IRC::botinfo{$svr}{nick}) {
if ($nick eq $State::IRC::botinfo{$svr}{nick}) {
# It is. Set data.
$Proto::IRC::botinfo{$svr}{user} = $user;
$Proto::IRC::botinfo{$svr}{mask} = $mask;
$State::IRC::botinfo{$svr}{user} = $user;
$State::IRC::botinfo{$svr}{mask} = $mask;
}
return 1;
@@ -143,28 +178,28 @@ hook_add('on_isupport', 'core.prefixchanmode.getdata', sub {
# 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);
}
}
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; }
foreach (split(//, $mtl)) { $Proto::IRC::chanmodes{$svr}{$_} = 1 }
# Modes with parameter.
foreach (split(//, $mtp)) { $Proto::IRC::chanmodes{$svr}{$_} = 2; }
foreach (split(//, $mtp)) { $Proto::IRC::chanmodes{$svr}{$_} = 2 }
# Modes with parameter when +.
foreach (split(//, $mtpp)) { $Proto::IRC::chanmodes{$svr}{$_} = 3; }
foreach (split(//, $mtpp)) { $Proto::IRC::chanmodes{$svr}{$_} = 3 }
# Modes without parameter.
foreach (split(//, $mts)) { $Proto::IRC::chanmodes{$svr}{$_} = 4; }
foreach (split(//, $mts)) { $Proto::IRC::chanmodes{$svr}{$_} = 4 }
}
}
@@ -194,9 +229,9 @@ hook_add('on_disconnect', 'core.irc.deldata', sub {
# Delete all data related to the server.
if (defined $Proto::IRC::got_001{$svr}) { delete $Proto::IRC::got_001{$svr} }
if (defined $Proto::IRC::botinfo{$svr}) { delete $Proto::IRC::botinfo{$svr} }
if (defined $State::IRC::botinfo{$svr}) { delete $State::IRC::botinfo{$svr} }
if (defined $Proto::IRC::botchans{$svr}) { delete $Proto::IRC::botchans{$svr} }
if (defined $Proto::IRC::chanusers{$svr}) { delete $Proto::IRC::chanusers{$svr} }
if (defined $State::IRC::chanusers{$svr}) { delete $State::IRC::chanusers{$svr} }
if (defined $Proto::IRC::csprefix{$svr}) { delete $Proto::IRC::csprefix{$svr} }
if (defined $Proto::IRC::chanmodes{$svr}) { delete $Proto::IRC::chanmodes{$svr} }
if (defined $Proto::IRC::cap{$svr}) { delete $Proto::IRC::cap{$svr} }
@@ -223,10 +258,10 @@ hook_add('on_umode', 'core.irc.state.umode', sub {
else {
# Adjust our modes.
if ($op) {
$Proto::IRC::botinfo{$svr}{modes} .= $_;
$State::IRC::botinfo{$svr}{modes} .= $_;
}
else {
$Proto::IRC::botinfo{$svr}{modes} =~ s/($_)//xsm;
$State::IRC::botinfo{$svr}{modes} =~ s/($_)//xsm;
}
}
}
+6 -6
View File
@@ -29,7 +29,7 @@ hook_add('on_namesreply', 'ircusers.names', sub {
my ($svr, $chan, undef) = @_;
# Iterate through the users for this channel.
foreach (keys %{$Proto::IRC::chanusers{$svr}{$chan}}) {
foreach (keys %{$State::IRC::chanusers{$svr}{$chan}}) {
# Check if the user already exists.
if (!$users{$svr}{$_}) {
# They do not; WHO them.
@@ -45,7 +45,7 @@ hook_add('on_whoreply', 'ircusers.who', sub {
my ($svr, $nick, undef) = @_;
# Ensure it is not us.
if (lc $nick ne lc $Proto::IRC::botinfo{$svr}{nick}) {
if (lc $nick ne lc $State::IRC::botinfo{$svr}{nick}) {
# It is not. Check if they're already in the users hash.
if (!$users{$svr}{lc $nick}) {
# They are not; add them.
@@ -77,9 +77,9 @@ hook_add('on_kick', 'ircusers.onkick', sub {
if ($users{$src->{svr}}{lc $user}) {
# Figure out if the user is in any other channel we're in.
my $ri = 0;
foreach my $chan (keys %{$Proto::IRC::chanusers{$src->{svr}}}) {
foreach my $chan (keys %{$State::IRC::chanusers{$src->{svr}}}) {
if ($chan ne $kchan) {
if (defined $Proto::IRC::chanusers{$src->{svr}}{$chan}{lc $user}) { $ri++; last; }
if (defined $State::IRC::chanusers{$src->{svr}}{$chan}{lc $user}) { $ri++; last }
}
}
if (!$ri) {
@@ -100,9 +100,9 @@ hook_add('on_part', 'ircusers.onpart', sub {
if ($users{$src->{svr}}{lc $src->{nick}}) {
# Figure out if the user is in any other channel we're in.
my $ri = 0;
foreach my $chan (keys %{$Proto::IRC::chanusers{$src->{svr}}}) {
foreach my $chan (keys %{$State::IRC::chanusers{$src->{svr}}}) {
if ($chan ne $pchan) {
if (defined $Proto::IRC::chanusers{$src->{svr}}{$chan}{lc $src->{nick}}) { $ri++; last; }
if (defined $State::IRC::chanusers{$src->{svr}}{$chan}{lc $src->{nick}}) { $ri++; last }
}
}
if (!$ri) {
+708
View File
@@ -0,0 +1,708 @@
package File::Copy::Recursive;
use strict;
BEGIN {
# Keep older versions of Perl from trying to use lexical warnings
$INC{'warnings.pm'} = "fake warnings entry for < 5.6 perl ($])" if $] < 5.006;
}
use warnings;
use Carp;
use File::Copy;
use File::Spec; #not really needed because File::Copy already gets it, but for good measure :)
use vars qw(
@ISA @EXPORT_OK $VERSION $MaxDepth $KeepMode $CPRFComp $CopyLink
$PFSCheck $RemvBase $NoFtlPth $ForcePth $CopyLoop $RMTrgFil $RMTrgDir
$CondCopy $BdTrgWrn $SkipFlop $DirPerms
);
require Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = qw(fcopy rcopy dircopy fmove rmove dirmove pathmk pathrm pathempty pathrmdir);
$VERSION = '0.38';
$MaxDepth = 0;
$KeepMode = 1;
$CPRFComp = 0;
$CopyLink = eval { local $SIG{'__DIE__'};symlink '',''; 1 } || 0;
$PFSCheck = 1;
$RemvBase = 0;
$NoFtlPth = 0;
$ForcePth = 0;
$CopyLoop = 0;
$RMTrgFil = 0;
$RMTrgDir = 0;
$CondCopy = {};
$BdTrgWrn = 0;
$SkipFlop = 0;
$DirPerms = 0777;
my $samecheck = sub {
return 1 if $^O eq 'MSWin32'; # need better way to check for this on winders...
return if @_ != 2 || !defined $_[0] || !defined $_[1];
return if $_[0] eq $_[1];
my $one = '';
if($PFSCheck) {
$one = join( '-', ( stat $_[0] )[0,1] ) || '';
my $two = join( '-', ( stat $_[1] )[0,1] ) || '';
if ( $one eq $two && $one ) {
carp "$_[0] and $_[1] are identical";
return;
}
}
if(-d $_[0] && !$CopyLoop) {
$one = join( '-', ( stat $_[0] )[0,1] ) if !$one;
my $abs = File::Spec->rel2abs($_[1]);
my @pth = File::Spec->splitdir( $abs );
while(@pth) {
my $cur = File::Spec->catdir(@pth);
last if !$cur; # probably not necessary, but nice to have just in case :)
my $two = join( '-', ( stat $cur )[0,1] ) || '';
if ( $one eq $two && $one ) {
# $! = 62; # Too many levels of symbolic links
carp "Caught Deep Recursion Condition: $_[0] contains $_[1]";
return;
}
pop @pth;
}
}
return 1;
};
my $glob = sub {
my ($do, $src_glob, @args) = @_;
local $CPRFComp = 1;
my @rt;
for my $path ( glob($src_glob) ) {
my @call = [$do->($path, @args)] or return;
push @rt, \@call;
}
return @rt;
};
my $move = sub {
my $fl = shift;
my @x;
if($fl) {
@x = fcopy(@_) or return;
} else {
@x = dircopy(@_) or return;
}
if(@x) {
if($fl) {
unlink $_[0] or return;
} else {
pathrmdir($_[0]) or return;
}
if($RemvBase) {
my ($volm, $path) = File::Spec->splitpath($_[0]);
pathrm(File::Spec->catpath($volm,$path,''), $ForcePth, $NoFtlPth) or return;
}
}
return wantarray ? @x : $x[0];
};
my $ok_todo_asper_condcopy = sub {
my $org = shift;
my $copy = 1;
if(exists $CondCopy->{$org}) {
if($CondCopy->{$org}{'md5'}) {
}
if($copy) {
}
}
return $copy;
};
sub fcopy {
$samecheck->(@_) or return;
if($RMTrgFil && (-d $_[1] || -e $_[1]) ) {
my $trg = $_[1];
if( -d $trg ) {
my @trgx = File::Spec->splitpath( $_[0] );
$trg = File::Spec->catfile( $_[1], $trgx[ $#trgx ] );
}
$samecheck->($_[0], $trg) or return;
if(-e $trg) {
if($RMTrgFil == 1) {
unlink $trg or carp "\$RMTrgFil failed: $!";
} else {
unlink $trg or return;
}
}
}
my ($volm, $path) = File::Spec->splitpath($_[1]);
if($path && !-d $path) {
pathmk(File::Spec->catpath($volm,$path,''), $NoFtlPth);
}
if( -l $_[0] && $CopyLink ) {
carp "Copying a symlink ($_[0]) whose target does not exist"
if !-e readlink($_[0]) && $BdTrgWrn;
symlink readlink(shift()), shift() or return;
} else {
copy(@_) or return;
my @base_file = File::Spec->splitpath($_[0]);
my $mode_trg = -d $_[1] ? File::Spec->catfile($_[1], $base_file[ $#base_file ]) : $_[1];
chmod scalar((stat($_[0]))[2]), $mode_trg if $KeepMode;
}
return wantarray ? (1,0,0) : 1; # use 0's incase they do math on them and in case rcopy() is called in list context = no uninit val warnings
}
sub rcopy {
if (-l $_[0] && $CopyLink) {
goto &fcopy;
}
goto &dircopy if -d $_[0] || substr( $_[0], ( 1 * -1), 1) eq '*';
goto &fcopy;
}
sub rcopy_glob {
$glob->(\&rcopy, @_);
}
sub dircopy {
if($RMTrgDir && -d $_[1]) {
if($RMTrgDir == 1) {
pathrmdir($_[1]) or carp "\$RMTrgDir failed: $!";
} else {
pathrmdir($_[1]) or return;
}
}
my $globstar = 0;
my $_zero = $_[0];
my $_one = $_[1];
if ( substr( $_zero, ( 1 * -1 ), 1 ) eq '*') {
$globstar = 1;
$_zero = substr( $_zero, 0, ( length( $_zero ) - 1 ) );
}
$samecheck->( $_zero, $_[1] ) or return;
if ( !-d $_zero || ( -e $_[1] && !-d $_[1] ) ) {
$! = 20;
return;
}
if(!-d $_[1]) {
pathmk($_[1], $NoFtlPth) or return;
} else {
if($CPRFComp && !$globstar) {
my @parts = File::Spec->splitdir($_zero);
while($parts[ $#parts ] eq '') { pop @parts; }
$_one = File::Spec->catdir($_[1], $parts[$#parts]);
}
}
my $baseend = $_one;
my $level = 0;
my $filen = 0;
my $dirn = 0;
my $recurs; #must be my()ed before sub {} since it calls itself
$recurs = sub {
my ($str,$end,$buf) = @_;
$filen++ if $end eq $baseend;
$dirn++ if $end eq $baseend;
$DirPerms = oct($DirPerms) if substr($DirPerms,0,1) eq '0';
mkdir($end,$DirPerms) or return if !-d $end;
chmod scalar((stat($str))[2]), $end if $KeepMode;
if($MaxDepth && $MaxDepth =~ m/^\d+$/ && $level >= $MaxDepth) {
return ($filen,$dirn,$level) if wantarray;
return $filen;
}
$level++;
my @files;
if ( $] < 5.006 ) {
opendir(STR_DH, $str) or return;
@files = grep( $_ ne '.' && $_ ne '..', readdir(STR_DH));
closedir STR_DH;
}
else {
opendir(my $str_dh, $str) or return;
@files = grep( $_ ne '.' && $_ ne '..', readdir($str_dh));
closedir $str_dh;
}
for my $file (@files) {
my ($file_ut) = $file =~ m{ (.*) }xms;
my $org = File::Spec->catfile($str, $file_ut);
my $new = File::Spec->catfile($end, $file_ut);
if( -l $org && $CopyLink ) {
carp "Copying a symlink ($org) whose target does not exist"
if !-e readlink($org) && $BdTrgWrn;
symlink readlink($org), $new or return;
}
elsif(-d $org) {
$recurs->($org,$new,$buf) if defined $buf;
$recurs->($org,$new) if !defined $buf;
$filen++;
$dirn++;
}
else {
if($ok_todo_asper_condcopy->($org)) {
if($SkipFlop) {
fcopy($org,$new,$buf) or next if defined $buf;
fcopy($org,$new) or next if !defined $buf;
}
else {
fcopy($org,$new,$buf) or return if defined $buf;
fcopy($org,$new) or return if !defined $buf;
}
chmod scalar((stat($org))[2]), $new if $KeepMode;
$filen++;
}
}
}
1;
};
$recurs->($_zero, $_one, $_[2]) or return;
return wantarray ? ($filen,$dirn,$level) : $filen;
}
sub fmove { $move->(1, @_) }
sub rmove {
if (-l $_[0] && $CopyLink) {
goto &fmove;
}
goto &dirmove if -d $_[0] || substr( $_[0], ( 1 * -1), 1) eq '*';
goto &fmove;
}
sub rmove_glob {
$glob->(\&rmove, @_);
}
sub dirmove { $move->(0, @_) }
sub pathmk {
my @parts = File::Spec->splitdir( shift() );
my $nofatal = shift;
my $pth = $parts[0];
my $zer = 0;
if(!$pth) {
$pth = File::Spec->catdir($parts[0],$parts[1]);
$zer = 1;
}
for($zer..$#parts) {
$DirPerms = oct($DirPerms) if substr($DirPerms,0,1) eq '0';
mkdir($pth,$DirPerms) or return if !-d $pth && !$nofatal;
mkdir($pth,$DirPerms) if !-d $pth && $nofatal;
$pth = File::Spec->catdir($pth, $parts[$_ + 1]) unless $_ == $#parts;
}
1;
}
sub pathempty {
my $pth = shift;
return 2 if !-d $pth;
my @names;
my $pth_dh;
if ( $] < 5.006 ) {
opendir(PTH_DH, $pth) or return;
@names = grep !/^\.+$/, readdir(PTH_DH);
}
else {
opendir($pth_dh, $pth) or return;
@names = grep !/^\.+$/, readdir($pth_dh);
}
for my $name (@names) {
my ($name_ut) = $name =~ m{ (.*) }xms;
my $flpth = File::Spec->catdir($pth, $name_ut);
if( -l $flpth ) {
unlink $flpth or return;
}
elsif(-d $flpth) {
pathrmdir($flpth) or return;
}
else {
unlink $flpth or return;
}
}
if ( $] < 5.006 ) {
closedir PTH_DH;
}
else {
closedir $pth_dh;
}
1;
}
sub pathrm {
my $path = shift;
return 2 if !-d $path;
my @pth = File::Spec->splitdir( $path );
my $force = shift;
while(@pth) {
my $cur = File::Spec->catdir(@pth);
last if !$cur; # necessary ???
if(!shift()) {
pathempty($cur) or return if $force;
rmdir $cur or return;
}
else {
pathempty($cur) if $force;
rmdir $cur;
}
pop @pth;
}
1;
}
sub pathrmdir {
my $dir = shift;
if( -e $dir ) {
return if !-d $dir;
}
else {
return 2;
}
pathempty($dir) or return;
rmdir $dir or return;
}
1;
__END__
=head1 NAME
File::Copy::Recursive - Perl extension for recursively copying files and directories
=head1 SYNOPSIS
use File::Copy::Recursive qw(fcopy rcopy dircopy fmove rmove dirmove);
fcopy($orig,$new[,$buf]) or die $!;
rcopy($orig,$new[,$buf]) or die $!;
dircopy($orig,$new[,$buf]) or die $!;
fmove($orig,$new[,$buf]) or die $!;
rmove($orig,$new[,$buf]) or die $!;
dirmove($orig,$new[,$buf]) or die $!;
rcopy_glob("orig/stuff-*", $trg [, $buf]) or die $!;
rmove_glob("orig/stuff-*", $trg [,$buf]) or die $!;
=head1 DESCRIPTION
This module copies and moves directories recursively (or single files, well... singley) to an optional depth and attempts to preserve each file or directory's
mode.
=head1 EXPORT
None by default. But you can export all the functions as in the example above and the path* functions if you wish.
=head2 fcopy()
This function uses File::Copy's copy() function to copy a file but not a directory. Any directories are recursively created if need be.
One difference to File::Copy::copy() is that fcopy attempts to preserve the mode (see Preserving Mode below)
The optional $buf in the synopsis if the same as File::Copy::copy()'s 3rd argument
returns the same as File::Copy::copy() in scalar context and 1,0,0 in list context to accomidate rcopy()'s list context on regular files. (See below for more
info)
=head2 dircopy()
This function recursively traverses the $orig directory's structure and recursively copies it to the $new directory.
$new is created if necessary (multiple non existant directories is ok (IE foo/bar/baz). The script logically and portably creates all of them if necessary).
It attempts to preserve the mode (see Preserving Mode below) and
by default it copies all the way down into the directory, (see Managing Depth) below.
If a directory is not specified it croaks just like fcopy croaks if its not a file that is specified.
returns true or false, for true in scalar context it returns the number of files and directories copied,
In list context it returns the number of files and directories, number of directories only, depth level traversed.
my $num_of_files_and_dirs = dircopy($orig,$new);
my($num_of_files_and_dirs,$num_of_dirs,$depth_traversed) = dircopy($orig,$new);
Normally it stops and return's if a copy fails, to continue on regardless set $File::Copy::Recursive::SkipFlop to true.
local $File::Copy::Recursive::SkipFlop = 1;
That way it will copy everythgingit can ina directory and won't stop because of permissions, etc...
=head2 rcopy()
This function will allow you to specify a file *or* directory. It calls fcopy() if its a file and dircopy() if its a directory.
If you call rcopy() (or fcopy() for that matter) on a file in list context, the values will be 1,0,0 since no directories and no depth are used.
This is important becasue if its a directory in list context and there is only the initial directory the return value is 1,1,1.
=head2 rcopy_glob()
This function lets you specify a pattern suitable for perl's glob() as the first argument. Subsequently each path returned by perl's glob() gets rcopy()ied.
It returns and array whose items are array refs that contain the return value of each rcopy() call.
It forces behavior as if $File::Copy::Recursive::CPRFComp is true.
=head2 fmove()
Copies the file then removes the original. You can manage the path the original file is in according to $RemvBase.
=head2 dirmove()
Uses dircopy() to copy the directory then removes the original. You can manage the path the original directory is in according to $RemvBase.
=head2 rmove()
Like rcopy() but calls fmove() or dirmove() instead.
=head2 rmove_glob()
Like rcopy_glob() but calls rmove() instead of rcopy()
=head3 $RemvBase
Default is false. When set to true the *move() functions will not only attempt to remove the original file or directory but will remove the given path it is in.
So if you:
rmove('foo/bar/baz', '/etc/');
# "baz" is removed from foo/bar after it is successfully copied to /etc/
local $File::Copy::Recursive::Remvbase = 1;
rmove('foo/bar/baz','/etc/');
# if baz is successfully copied to /etc/ :
# first "baz" is removed from foo/bar
# then "foo/bar is removed via pathrm()
=head4 $ForcePth
Default is false. When set to true it calls pathempty() before any directories are removed to empty the directory so it can be rmdir()'ed when $RemvBase is in
effect.
=head2 Creating and Removing Paths
=head3 $NoFtlPth
Default is false. If set to true rmdir(), mkdir(), and pathempty() calls in pathrm() and pathmk() do not return() on failure.
If its set to true they just silently go about their business regardless. This isn't a good idea but its there if you want it.
=head3 $DirPerms
Mode to pass to any mkdir() calls. Defaults to 0777 as per umask()'s POD. Explicitly having this allows older perls to be able to use FCR and might add a bit of
flexibility for you.
Any value you set it to should be suitable for oct()
=head3 Path functions
These functions exist soley because they were necessary for the move and copy functions to have the features they do and not because they are of themselves the
purpose of this module. That being said, here is how they work so you can understand how the copy and move funtions work and use them by themselves if you wish.
=head4 pathrm()
Removes a given path recursively. It removes the *entire* path so be carefull!!!
Returns 2 if the given path is not a directory.
File::Copy::Recursive::pathrm('foo/bar/baz') or die $!;
# foo no longer exists
Same as:
rmdir 'foo/bar/baz' or die $!;
rmdir 'foo/bar' or die $!;
rmdir 'foo' or die $!;
An optional second argument makes it call pathempty() before any rmdir()'s when set to true.
File::Copy::Recursive::pathrm('foo/bar/baz', 1) or die $!;
# foo no longer exists
Same as:PFSCheck
File::Copy::Recursive::pathempty('foo/bar/baz') or die $!;
rmdir 'foo/bar/baz' or die $!;
File::Copy::Recursive::pathempty('foo/bar/') or die $!;
rmdir 'foo/bar' or die $!;
File::Copy::Recursive::pathempty('foo/') or die $!;
rmdir 'foo' or die $!;
An optional third argument acts like $File::Copy::Recursive::NoFtlPth, again probably not a good idea.
=head4 pathempty()
Recursively removes the given directory's contents so it is empty. returns 2 if argument is not a directory, 1 on successfully emptying the directory.
File::Copy::Recursive::pathempty($pth) or die $!;
# $pth is now an empty directory
=head4 pathmk()
Creates a given path recursively. Creates foo/bar/baz even if foo does not exist.
File::Copy::Recursive::pathmk('foo/bar/baz') or die $!;
An optional second argument if true acts just like $File::Copy::Recursive::NoFtlPth, which means you'd never get your die() if something went wrong. Again,
probably a *bad* idea.
=head4 pathrmdir()
Same as rmdir() but it calls pathempty() first to recursively empty it first since rmdir can not remove a directory with contents.
Just removes the top directory the path given instead of the entire path like pathrm(). Return 2 if given argument does not exist (IE its already gone). Return
false if it exists but is not a directory.
=head2 Preserving Mode
By default a quiet attempt is made to change the new file or directory to the mode of the old one.
To turn this behavior off set
$File::Copy::Recursive::KeepMode
to false;
=head2 Managing Depth
You can set the maximum depth a directory structure is recursed by setting:
$File::Copy::Recursive::MaxDepth
to a whole number greater than 0.
=head2 SymLinks
If your system supports symlinks then symlinks will be copied as symlinks instead of as the target file.
Perl's symlink() is used instead of File::Copy's copy()
You can customize this behavior by setting $File::Copy::Recursive::CopyLink to a true or false value.
It is already set to true or false dending on your system's support of symlinks so you can check it with an if statement to see how it will behave:
if($File::Copy::Recursive::CopyLink) {
print "Symlinks will be preserved\n";
} else {
print "Symlinks will not be preserved because your system does not support it\n";
}
If symlinks are being copied you can set $File::Copy::Recursive::BdTrgWrn to true to make it carp when it copies a link whose target does not exist. Its false
by default.
local $File::Copy::Recursive::BdTrgWrn = 1;
=head2 Removing existing target file or directory before copying.
This can be done by setting $File::Copy::Recursive::RMTrgFil or $File::Copy::Recursive::RMTrgDir for file or directory behavior respectively.
0 = off (This is the default)
1 = carp() $! if removal fails
2 = return if removal fails
local $File::Copy::Recursive::RMTrgFil = 1;
fcopy($orig, $target) or die $!;
# if it fails it does warn() and keeps going
local $File::Copy::Recursive::RMTrgDir = 2;
dircopy($orig, $target) or die $!;
# if it fails it does your "or die"
This should be unnecessary most of the time but its there if you need it :)
=head2 Turning off stat() check
By default the files or directories are checked to see if they are the same (IE linked, or two paths (absolute/relative or different relative paths) to the same
file) by comparing the file's stat() info.
It's a very efficient check that croaks if they are and shouldn't be turned off but if you must for some weird reason just set $File::Copy::Recursive::PFSCheck
to a false value. ("PFS" stands for "Physical File System")
=head2 Emulating cp -rf dir1/ dir2/
By default dircopy($dir1,$dir2) will put $dir1's contents right into $dir2 whether $dir2 exists or not.
You can make dircopy() emulate cp -rf by setting $File::Copy::Recursive::CPRFComp to true.
NOTE: This only emulates -f in the sense that it does not prompt. It does not remove the target file or directory if it exists.
If you need to do that then use the variables $RMTrgFil and $RMTrgDir described in "Removing existing target file or directory before copying" above.
That means that if $dir2 exists it puts the contents into $dir2/$dir1 instead of $dir2 just like cp -rf.
If $dir2 does not exist then the contents go into $dir2 like normal (also like cp -rf)
So assuming 'foo/file':
dircopy('foo', 'bar') or die $!;
# if bar does not exist the result is bar/file
# if bar does exist the result is bar/file
$File::Copy::Recursive::CPRFComp = 1;
dircopy('foo', 'bar') or die $!;
# if bar does not exist the result is bar/file
# if bar does exist the result is bar/foo/file
You can also specify a star for cp -rf glob type behavior:
dircopy('foo/*', 'bar') or die $!;
# if bar does not exist the result is bar/file
# if bar does exist the result is bar/file
$File::Copy::Recursive::CPRFComp = 1;
dircopy('foo/*', 'bar') or die $!;
# if bar does not exist the result is bar/file
# if bar does exist the result is bar/file
NOTE: The '*' is only like cp -rf foo/* and *DOES NOT EXPAND PARTIAL DIRECTORY NAMES LIKE YOUR SHELL DOES* (IE not like cp -rf fo* to copy foo/*)
=head2 Allowing Copy Loops
If you want to allow:
cp -rf . foo/
type behavior set $File::Copy::Recursive::CopyLoop to true.
This is false by default so that a check is done to see if the source directory will contain the target directory and croaks to avoid this problem.
If you ever find a situation where $CopyLoop = 1 is desirable let me know (IE its a bad bad idea but is there if you want it)
(Note: On Windows this was necessary since it uses stat() to detemine samedness and stat() is essencially useless for this on Windows.
The test is now simply skipped on Windows but I'd rather have an actual reliable check if anyone in Microsoft land would care to share)
=head1 SEE ALSO
L<File::Copy> L<File::Spec>
=head1 TO DO
I am currently working on and reviewing some other modules to use in the new interface so we can lose the horrid globals as well as some other undesirable
traits and also more easily make available some long standing requests.
Tests will be easier to do with the new interface and hence the testing focus will shift to the new interface and aim to be comprehensive.
The old interface will work, it just won't be brought in until it is used, so it will add no overhead for users of the new interface.
I'll add this after the latest verision has been out for a while with no new features or issues found :)
=head1 AUTHOR
Daniel Muey, L<http://drmuey.com/cpan_contact.pl>
=head1 COPYRIGHT AND LICENSE
Copyright 2004 by Daniel Muey
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
+18 -17
View File
@@ -123,7 +123,7 @@ sub rehash
if (conf_get('module')) {
alog '* Loading modules...';
foreach (@{ (conf_get('module'))[0] }) {
if (!API::Std::mod_exists($_)) { Auto::mod_load($_); }
if (!API::Std::mod_exists($_)) { Auto::mod_load($_) }
}
}
@@ -157,24 +157,24 @@ sub ircsock {
# Prepare socket data.
my %conndata = (
Proto => 'tcp',
Proto => 'tcp',
LocalAddr => $cdata->{'bind'}[0],
PeerAddr => $cdata->{'host'}[0],
PeerPort => $cdata->{'port'}[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]; }
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 ($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; }
if ($Auto::ENFEAT !~ m/ipv6/ixsm) { err(2, '** Auto not built with IPv6 support: Aborting connection to '.$svrname, 0); return }
}
# CertFP.
@@ -183,13 +183,13 @@ sub ircsock {
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];
$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];
$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]; };
$conndata{'SSL_passwd_cb'} = sub { return $cdata->{'certfp_pass'}[0] };
}
}
}
@@ -238,8 +238,9 @@ sub ircsock {
# Shutdown.
hook_add('on_shutdown', 'shutdown.core_cleanup', sub {
if (defined $Auto::DB) { $Auto::DB->disconnect; }
if (-e "$Auto::Bin/auto.pid") { unlink "$Auto::Bin/auto.pid"; }
if (defined $Auto::DB) { $Auto::DB->disconnect }
if ($Auto::UPREFIX) { if (-e "$Auto::bin{cwd}/auto.pid") { unlink "$Auto::bin{cwd}/auto.pid" } }
else { if (-e "$Auto::Bin/auto.pid") { unlink "$Auto::Bin/auto.pid" } }
return 1;
});
@@ -252,7 +253,7 @@ sub signal_term
{
API::Std::event_run('on_sigterm');
API::Std::event_run('on_shutdown');
foreach (keys %Auto::SOCKET) { API::IRC::quit($_, 'Caught SIGTERM'); }
foreach (keys %Auto::SOCKET) { API::IRC::quit($_, 'Caught SIGTERM') }
dbug '!!! Caught SIGTERM; terminating...';
alog '!!! Caught SIGTERM; terminating...';
sleep 1;
@@ -264,7 +265,7 @@ sub signal_int
{
API::Std::event_run('on_sigint');
API::Std::event_run('on_shutdown');
foreach (keys %Auto::SOCKET) { API::IRC::quit($_, 'Caught SIGINT'); }
foreach (keys %Auto::SOCKET) { API::IRC::quit($_, 'Caught SIGINT') }
dbug '!!! Caught SIGINT; terminating...';
alog '!!! Caught SIGINT; terminating...';
sleep 1;
@@ -287,7 +288,7 @@ sub signal_perlwarn
my ($warnmsg) = @_;
$warnmsg =~ s/(\n|\r)//xsmg;
alog 'Perl Warning: '.$warnmsg;
if ($Auto::DEBUG) { say 'Perl Warning: '.$warnmsg; }
if ($Auto::DEBUG) { say 'Perl Warning: '.$warnmsg }
return 1;
}
@@ -299,7 +300,7 @@ sub signal_perldie
return if $EXCEPTIONS_BEING_CAUGHT;
alog 'Perl Fatal: '.$diemsg.' -- Terminating program!';
foreach (keys %Auto::SOCKET) { API::IRC::quit($_, 'A fatal error occurred!'); }
foreach (keys %Auto::SOCKET) { API::IRC::quit($_, 'A fatal error occurred!') }
API::Std::event_run('on_shutdown');
sleep 1;
say 'FATAL: '.$diemsg;
+14 -10
View File
@@ -6,8 +6,6 @@ use strict;
use warnings;
use Exporter;
use English qw(-no_match_vars);
use FindBin qw($Bin);
our $Bin = $Bin;
our $VERSION = 1.00;
our @ISA = qw(Exporter);
@@ -39,28 +37,33 @@ sub modfind
sub build
{
my ($features) = @_;
my ($features, $Bin, $syswide) = @_;
if (!defined $syswide) { $syswide = 0 }
open(my $FTIME, q{>}, "$Bin/build/time") or println "Failed to install." and exit;
open(my $FTIME, q{>}, "$Bin/time") or println "Failed to install." and exit;
print $FTIME time."\n" or println "Failed to install." and exit;
close $FTIME or println "Failed to install." and exit;
open(my $FOS, q{>}, "$Bin/build/os") or println "Failed to install." and exit;
open(my $FOS, q{>}, "$Bin/os") or println "Failed to install." and exit;
print $FOS $OSNAME."\n" or println "Failed to install." and exit;
close $FOS or println "Failed to install." and exit;
open(my $FFEAT, q{>}, "$Bin/build/feat") or println "Failed to install." and exit;
open(my $FFEAT, q{>}, "$Bin/feat") or println "Failed to install." and exit;
print $FFEAT $features."\n" or println "Failed to install." and exit;
close $FFEAT or println "Failed to install." and exit;
open(my $FPERL, q{>}, "$Bin/build/perl") or println "Failed to install." and exit;
open(my $FPERL, q{>}, "$Bin/perl") or println "Failed to install." and exit;
print $FPERL "$]\n" or println "Failed to install." and exit;
close $FPERL or println "Failed to install." and exit;
open(my $FVER, q{>}, "$Bin/build/ver") or println "Failed to install." and exit;
open(my $FVER, q{>}, "$Bin/ver") or println "Failed to install." and exit;
print $FVER "3.0.0d\n" or println "Failed to install." and exit;
close $FVER or println "Failed to install." and exit;
open my $FSYS, '>', "$Bin/syswide" or println "Failed to install." and exit;
print {$FSYS} "$syswide\n" or println "Failed to install." and exit;
close $FSYS or println "Failed to install." and exit;
return 1;
}
@@ -114,18 +117,19 @@ sub checkcore
sub installmods
{
my ($prefix) = @_;
print 'Would you like to install any official modules? [y/n] ';
my $response = <STDIN>;
chomp $response;
if (lc $response eq 'y') {
println 'What modules would you like to install? (separate by commas)';
println 'Available modules: Badwords, Bitly, BotStats, Calc, ChanTopics, Dictionary, EightBall, Eval, FML, Greet, HelloChan, IsItUp, LinkTitle, QDB, SASLAuth, UNO, Weather';
println 'Available modules: AUR, Badwords, Bitly, BotStats, Calc, ChanTopics, Dictionary, EightBall, Eval, FML, Greet, HelloChan, IsItUp, LinkTitle, LOLCAT, Oper, QDB, SASLAuth, UNO, Weather';
print '> ';
my $modules = <STDIN>; chomp $modules;
$modules =~ s/ //g;
my @modst = split ',', $modules;
foreach (@modst) {
system "perl \"$Bin/bin/buildmod\" $_";
system "perl \"$prefix/bin/buildmod\" $_";
}
}
}
+134 -134
View File
@@ -13,17 +13,17 @@ sub new
my $self = bless {}, $class;
# Check to see if the configuration file exists.
if (!-e "$Auto::Bin/../etc/$file") {
return 0;
if (!-e "$Auto::bin{etc}/$file") {
return;
}
# 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;
open(my $FCONF, q{<}, "$Auto::bin{etc}/$file") or return;
my @cosfl = <$FCONF> or return;
close $FCONF or return;
# Save it to self variable.
$self->{'config'}->{'path'} = "$Auto::Bin/../etc/$file";
$self->{'config'}->{'path'} = "$Auto::bin{etc}/$file";
return $self;
}
@@ -38,141 +38,141 @@ sub parse
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;
open(my $FCONF, q{<}, "$file") or return;
my @fbuf = <$FCONF> or return;
close $FCONF or return;
# 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.
# 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;
}
}
}
}
}
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;
return %rs;
}
+37 -37
View File
@@ -13,51 +13,51 @@ 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";
if (!-e "$Auto::bin{lng}/$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;
open(my $FALF, '<', "$Auto::bin{lng}/$lang.alf") or return;
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;
}
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;
}
+105 -128
View File
@@ -38,7 +38,7 @@ our %RAWC = (
);
# Variables for various functions.
our (%got_001, %botinfo, %botchans, %csprefix, %chanusers, %chanmodes, %cap);
our (%got_001, %botchans, %csprefix, %chanmodes, %cap);
# Events.
API::Std::event_add('on_capack');
@@ -49,6 +49,7 @@ 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_selfkick');
API::Std::event_add('on_myinfo');
API::Std::event_add('on_namesreply');
API::Std::event_add('on_nick');
@@ -71,29 +72,29 @@ sub ircparse
# 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')) {
# 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);
}
}
}
}
# Check if it's handled by core.
elsif (defined $RAWC{$ex[1]}) {
&{ $RAWC{$ex[1]} }($svr, @ex);
}
else {
# otherwise, check for a raw hook.
if (defined $API::Std::RAWHOOKS{$ex[1]}) {
foreach (keys %{$API::Std::RAWHOOKS{$ex[1]}}) {
else {
# otherwise, check for a raw hook.
if (defined $API::Std::RAWHOOKS{$ex[1]}) {
foreach (keys %{$API::Std::RAWHOOKS{$ex[1]}}) {
&{ $API::Std::RAWHOOKS{$ex[1]}{$_} }($svr, @ex);
}
}
}
}
}
}
return 1;
@@ -111,14 +112,14 @@ sub num001 {
$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};
if (!defined $State::IRC::botinfo{$svr}{nick}) {
$State::IRC::botinfo{$svr}{nick} = $State::IRC::botinfo{$svr}{newnick};
delete $State::IRC::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}";
API::Log::alog "! Successfully connected to $svr as $State::IRC::botinfo{$svr}{nick}";
API::Log::dbug "! Successfully connected to $svr as $State::IRC::botinfo{$svr}{nick}";
# Trigger on_connect.
API::Std::event_run('on_connect', $svr);
@@ -171,43 +172,9 @@ sub num353 {
# Get rid of the colon.
$ex[5] =~ s/^://xsm;
# Delete the old chanusers hash if it exists.
if (defined $chanusers{$svr}{$ex[4]}) { delete $chanusers{$svr}{$ex[4]} }
# Iterate through each user.
for (5..$#ex) {
my $fi = 0;
PFITER: foreach my $spfx (keys %{ $csprefix{$svr} }) {
# Check if the user has status in the channel.
if (substr($ex[$_], 0, 1) eq $csprefix{$svr}{$spfx}) {
# He/she does. Lets set that.
if (defined $chanusers{$svr}{$ex[4]}{lc $ex[$_]}) {
# If the user has multiple statuses.
$chanusers{$svr}{$ex[4]}{lc substr $ex[$_], 1} = $chanusers{$svr}{$ex[4]}{lc $ex[$_]}.$spfx;
delete $chanusers{$svr}{$ex[4]}{lc $ex[$_]};
}
else {
# Or not.
$chanusers{$svr}{$ex[4]}{lc substr $ex[$_], 1} = $spfx;
}
$fi = 1;
$ex[$_] = substr $ex[$_], 1;
}
}
# Check if there's still a prefix.
foreach my $spfx (keys %{$csprefix{$svr}}) {
if (substr($ex[$_], 0, 1) eq $csprefix{$svr}{$spfx}) { 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[$_]}) {
$chanusers{$svr}{$ex[4]}{lc $ex[$_]} = 1;
}
}
# Trigger on_namesreply.
API::Std::event_run('on_namesreply', ($svr, $ex[4], @ex[5..$#ex]));
return 1;
}
@@ -217,7 +184,7 @@ sub num396 {
my ($svr, @ex) = @_;
# Update our mask.
$botinfo{$svr}{mask} = $ex[3];
$State::IRC::botinfo{$svr}{mask} = $ex[3];
return 1;
}
@@ -228,14 +195,14 @@ sub num432 {
my ($svr, undef) = @_;
if ($got_001{$svr}) {
err(3, "Got error from server[$svr]: Erroneous nickname.", 0);
err(3, "Got error from server[$svr]: Erroneous nickname.", 0);
}
else {
err(2, "Got error from server[$svr] before connection complete: Erroneous nickname. Closing connection.", 0);
API::IRC::quit($svr, 'An error occurred.');
err(2, "Got error from server[$svr] before connection complete: Erroneous nickname. Closing connection.", 0);
API::IRC::quit($svr, 'An error occurred.');
}
if (defined $botinfo{$svr}{newnick}) { delete $botinfo{$svr}{newnick} }
if (defined $State::IRC::botinfo{$svr}{newnick}) { delete $State::IRC::botinfo{$svr}{newnick} }
return 1;
}
@@ -245,8 +212,8 @@ sub num432 {
sub num433 {
my ($svr, undef) = @_;
if (defined $botinfo{$svr}{newnick}) {
API::IRC::nick($svr, $botinfo{$svr}{newnick}.'_');
if (defined $State::IRC::botinfo{$svr}{newnick}) {
API::IRC::nick($svr, $State::IRC::botinfo{$svr}{newnick}.'_');
}
return 1;
@@ -257,11 +224,11 @@ sub num433 {
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});
if (defined $botinfo{$svr}{newnick}) { delete $botinfo{$svr}{newnick} }
});
if (defined $State::IRC::botinfo{$svr}{newnick}) {
API::Std::timer_add('num438_'.$State::IRC::botinfo{$svr}{newnick}, 1, $ex[11], sub {
API::IRC::nick($State::IRC::botinfo{$svr}{newnick});
if (defined $State::IRC::botinfo{$svr}{newnick}) { delete $State::IRC::botinfo{$svr}{newnick} }
});
}
return 1;
@@ -352,7 +319,7 @@ sub cap {
}
# Send CAP REQ/CAP END based on what both we and the server support.
if (!$capout) { Auto::socksnd($svr, 'CAP END'); }
if (!$capout) { Auto::socksnd($svr, 'CAP END') }
else {
$capout = substr $capout, 1;
Auto::socksnd($svr, "CAP REQ :$capout");
@@ -386,15 +353,15 @@ sub cjoin {
$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));
if ($src{nick} eq $State::IRC::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;
# It isn't. Update chanusers and trigger on_rcjoin.
$State::IRC::chanusers{$svr}{lc $chan}{$src{nick}} = 1;
$src{svr} = $svr;
API::Std::event_run("on_rcjoin", (\%src, $chan));
API::Std::event_run("on_rcjoin", (\%src, $chan));
}
return 1;
@@ -408,7 +375,7 @@ sub kick {
$src{svr} = $svr;
# Update chanusers.
delete $chanusers{$svr}{$ex[2]}{$ex[3]} if defined $chanusers{$svr}{$ex[2]}{$ex[3]};
delete $State::IRC::chanusers{$svr}{$ex[2]}{$ex[3]} if defined $State::IRC::chanusers{$svr}{$ex[2]}{$ex[3]};
# Set $msg to the kick message.
my $msg = 0;
@@ -422,7 +389,7 @@ sub kick {
}
# Check if we were the ones kicked.
if (lc($ex[3]) eq lc($botinfo{$svr}{nick})) {
if (lc($ex[3]) eq lc($State::IRC::botinfo{$svr}{nick})) {
# We were kicked!
# Delete channel from botchans.
@@ -437,10 +404,13 @@ sub kick {
API::IRC::cjoin($svr, $ex[2]);
}
}
# Trigger on_selfkick.
API::Std::event_run('on_selfkick', (\%src, $ex[2], $msg));
}
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]}; }
if (defined $State::IRC::chanusers{$svr}{$ex[2]}{$ex[3]}) { delete $State::IRC::chanusers{$svr}{$ex[2]}{$ex[3]} }
API::Std::event_run("on_kick", (\%src, $ex[2], $ex[3], $msg));
}
@@ -451,7 +421,7 @@ sub kick {
sub mode {
my ($svr, @ex) = @_;
if ($ex[2] ne $botinfo{$svr}{nick}) {
if ($ex[2] ne $State::IRC::botinfo{$svr}{nick}) {
# Set data we'll need later.
my $chan = $ex[2];
$ex[3] =~ s/^://xsm;
@@ -499,34 +469,34 @@ sub mode {
# It is a status mode, lets parse changes.
my $user = shift(@ex);
if (defined $chanusers{$svr}{$chan}{$user}) {
if (defined $State::IRC::chanusers{$svr}{$chan}{$user}) {
if ($op == 1) {
if ($chanusers{$svr}{$chan}{$user} eq 1) {
$chanusers{$svr}{$chan}{$user} = $maf;
if ($State::IRC::chanusers{$svr}{$chan}{$user} eq 1) {
$State::IRC::chanusers{$svr}{$chan}{$user} = $maf;
}
else {
$chanusers{$svr}{$chan}{$user} .= $maf;
$State::IRC::chanusers{$svr}{$chan}{$user} .= $maf;
}
}
elsif ($op == 2) {
if (length($chanusers{$svr}{$chan}{$user}) == 1) {
$chanusers{$svr}{$chan}{$user} = 1;
if (length($State::IRC::chanusers{$svr}{$chan}{$user}) == 1) {
$State::IRC::chanusers{$svr}{$chan}{$user} = 1;
}
else {
$chanusers{$svr}{$chan}{$user} =~ s/($maf)//gxsm;
$State::IRC::chanusers{$svr}{$chan}{$user} =~ s/($maf)//gxsm;
}
}
}
else {
$chanusers{$svr}{$chan}{$user} = $maf;
$State::IRC::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} == 1 || $chanmodes{$svr}{$maf} == 2) { shift @ex }
if ($chanmodes{$svr}{$maf} == 3) {
if ($op == 1) { shift @ex; }
if ($op == 1) { shift @ex }
}
}
}
@@ -553,23 +523,23 @@ sub nick {
$src{svr} = $svr;
# 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});
if ($src{nick} eq $State::IRC::botinfo{$svr}{nick}) {
# It is. Update bot nick hash.
$State::IRC::botinfo{$svr}{nick} = $nex;
delete $State::IRC::botinfo{$svr}{newnick} if (defined $State::IRC::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}};
# It isn't. Update chanusers and trigger on_nick.
foreach my $chk (keys %{ $State::IRC::chanusers{$svr} }) {
if (defined $State::IRC::chanusers{$svr}{$chk}{$src{nick}}) {
$State::IRC::chanusers{$svr}{$chk}{$nex} = $State::IRC::chanusers{$svr}{$chk}{$src{nick}};
delete $State::IRC::chanusers{$svr}{$chk}{$src{nick}};
}
}
API::Std::event_run("on_nick", (\%src, $nex));
API::Std::event_run("on_nick", (\%src, $nex));
}
return 1;
return 1;
}
# Parse: NOTICE
@@ -577,7 +547,7 @@ sub notice {
my ($svr, @ex) = @_;
# Ensure this is coming from a user rather than a server.
if ($ex[0] !~ m/!/xsm) { return; }
if ($ex[0] !~ m/!/xsm) { return }
# Prepare all the data.
my %src = API::IRC::usrc(substr $ex[0], 1);
@@ -600,15 +570,15 @@ sub part {
$src{svr} = $svr;
# Check if it's from us or someone else.
if ($src{nick} eq $botinfo{$svr}{nick}) {
if ($src{nick} eq $State::IRC::botinfo{$svr}{nick}) {
# Delete this channel from botchans.
if ($botchans{$svr}{$ex[2]}) { delete $botchans{$svr}{$ex[2]}; }
if ($botchans{$svr}{$ex[2]}) { delete $botchans{$svr}{$ex[2]} }
# Trigger on_upart.
API::Std::event_run('on_upart', ($svr, $ex[2]));
}
else {
# Delete them from chanusers.
delete $chanusers{$svr}{$ex[2]}{$src{nick}} if defined $chanusers{$svr}{$ex[2]}{$src{nick}};
delete $State::IRC::chanusers{$svr}{$ex[2]}{$src{nick}} if defined $State::IRC::chanusers{$svr}{$ex[2]}{$src{nick}};
# Set $msg to the part message.
my $msg = 0;
@@ -631,32 +601,39 @@ sub part {
# Parse: PRIVMSG
sub privmsg {
my ($svr, @ex) = @_;
my %data = API::IRC::usrc(substr($ex[0], 1));
my %data;
# Ensure this is coming from a user rather than a server.
if ($ex[0] !~ m/!/xsm) { return; }
if ($ex[0] !~ m/!/xsm) {
%data = (
'nick' => substr($ex[0], 1),
'user' => '*',
'host' => '*'
);
}
else { %data = API::IRC::usrc(substr($ex[0], 1)) }
my @argv;
for (my $i = 4; $i < scalar(@ex); $i++) {
push(@argv, $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.
if (lc($ex[2]) eq lc($State::IRC::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}) {
$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) {
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 ($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.
@@ -676,26 +653,26 @@ sub privmsg {
# Send them a notice about their bad deed.
API::IRC::notice($data{svr}, $data{nick}, trans('Rate limit exceeded').q{.});
}
}
}
}
}
}
# Trigger event on_uprivmsg.
# Trigger event on_uprivmsg.
shift @ex; shift @ex; shift @ex;
$ex[0] = substr $ex[0], 1;
API::Std::event_run("on_uprivmsg", (\%data, @ex));
API::Std::event_run("on_uprivmsg", (\%data, @ex));
}
else {
# It is coming to us in a channel message.
$data{chan} = $ex[2];
# 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) {
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) {
$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) {
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.
@@ -742,14 +719,14 @@ sub privmsg {
}
}
}
}
}
}
# Trigger event on_cprivmsg.
# 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));
API::Std::event_run("on_cprivmsg", (\%data, $target, @ex));
}
return 1;
+49
View File
@@ -0,0 +1,49 @@
# lib/State/IRC.pm - IRC state data.
# Copyright (C) 2010-2011 Xelhua Development Group, et al.
# This program is free software; rights to this code are stated in doc/LICENSE.
package State::IRC;
use strict;
use warnings;
use API::Std qw(hook_add);
our (%chanusers, %botinfo);
# Create on_namesreply hook.
hook_add('on_namesreply', 'state.irc.names', sub {
my ($svr, $chan, @data) = @_;
# Delete the old chanusers hash if it exists.
if (defined $chanusers{$svr}{$chan}) { delete $chanusers{$svr}{$chan} }
# Iterate through each user.
for (1..$#data) {
my $fi = 0;
PFITER: foreach my $spfx (keys %{ $Proto::IRC::csprefix{$svr} }) {
# Check if the user has status in the channel.
if (substr($data[$_], 0, 1) eq $Proto::IRC::csprefix{$svr}{$spfx}) {
# He/she does. Lets set that.
if (defined $chanusers{$svr}{$chan}{lc $data[$_]}) {
# If the user has multiple statuses.
$chanusers{$svr}{$chan}{lc substr $data[$_], 1} = $chanusers{$svr}{$chan}{lc $data[$_]}.$spfx;
delete $chanusers{$svr}{$chan}{lc $data[$_]};
}
else {
# Or not.
$chanusers{$svr}{$chan}{lc substr $data[$_], 1} = $spfx;
}
$fi = 1;
$data[$_] = substr $data[$_], 1;
}
}
# Check if there's still a prefix.
foreach my $spfx (keys %{$Proto::IRC::csprefix{$svr}}) {
if (substr($data[$_], 0, 1) eq $Proto::IRC::csprefix{$svr}{$spfx}) { 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}{$chan}{lc $data[$_]}) {
$chanusers{$svr}{$chan}{lc $data[$_]} = 1;
}
}
return 1;
});
+118
View File
@@ -0,0 +1,118 @@
# Module: AUR. 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::AUR;
use strict;
use warnings;
use WWW::AUR;
use API::Std qw(cmd_add cmd_del trans);
use API::IRC qw(notice privmsg);
# Initialization subroutine.
sub _init {
# Create the AUR command.
cmd_add('AUR', 0, 0, \%M::AUR::HELP_AUR, \&M::AUR::cmd_aur) or return;
# Success.
return 1;
}
# Void subroutine.
sub _void {
# Delete the AUR command.
cmd_del('AUR') or return;
# Success.
return 1;
}
# Help hash for AUR. Spanish, French and German translations needed.
our %HELP_AUR = (
'en' => "This command allows you to lookup a module in the Arch Linux AUR. \002Syntax:\002 AUR <module>",
);
# Callback for AUR command.
sub cmd_aur {
my ($src, ($mod)) = @_;
# Check for needed parameters.
if (!defined $mod) {
notice($src->{svr}, $src->{nick}, trans('Not enough parameters').q{.});
return;
}
# Create an instance of WWW::AUR.
my $aur = WWW::AUR->new;
# Create an instance of WWW::AUR::Package.
my $pkg = $aur->find($mod);
# Check if there was a result.
if (defined $pkg) {
# Return the results.
privmsg($src->{svr}, $src->{chan}, "Results for \2$mod\2:");
privmsg($src->{svr}, $src->{chan}, 'ID: '.$pkg->id.' | Name: '.$pkg->name.' | Version: '.$pkg->version);
privmsg($src->{svr}, $src->{chan}, 'Maintainer: '.$pkg->maintainer->name);
privmsg($src->{svr}, $src->{chan}, 'URL: https://aur.archlinux.org/packages.php?ID='.$pkg->id);
}
else {
# Else return no results.
privmsg($src->{svr}, $src->{chan}, "No results for \2$mod\2.");
}
return 1;
}
# Start initialization.
API::Std::mod_init('AUR', 'Xelhua', '1.00', '3.0.0a8', __PACKAGE__);
# build: cpan=WWW::AUR perl=5.010000
__END__
=head1 NAME
AUR - AUR package information module.
=head1 VERSION
1.00
=head1 SYNOPSIS
<JohnSmith> !aur autobot-git
<Auto> Results for autobot-git:
<Auto> ID: 47329 Name: autobot-git Version: 20110311-1
<Auto> Maintainer: iElijah101
<Auto> URL: https://aur.archlinux.org/packages.php?ID=47329
=head1 DESCRIPTION
This module adds a command to allow getting information on a package in the
Arch User Repository at https://aur.archlinux.org.
=head1 DEPENDENCIES
This module is dependent on the following modules from CPAN:
=over
=item L<WWW::AUR>
Interface to the Arch User Repository.
=back
=head1 AUTHOR
This module was written by Matthew Barksdale.
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
# vim: set ai et sw=4 ts=4:
+3 -3
View File
@@ -13,8 +13,8 @@ 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;
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;
@@ -27,7 +27,7 @@ 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;
# Success.
return 1;
+15 -15
View File
@@ -14,12 +14,12 @@ 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;
err(2, 'Please verify that you have bitly_user and bitly_key defined in your configuration file.', 0);
return;
}
# 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;
cmd_add('REVERSE', 0, 0, \%M::Bitly::HELP_REVERSE, \&M::Bitly::reverse) or return;
# Success.
return 1;
@@ -29,8 +29,8 @@ 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;
cmd_del('REVERSE') or return;
# Success.
return 1;
@@ -56,8 +56,8 @@ sub shorten
# Put together the call to the Bit.ly API.
if (!defined $args[0]) {
notice($src->{svr}, $src->{nick}, trans("Not enough parameters").".");
return 0;
notice($src->{svr}, $src->{nick}, trans('Not enough parameters').".");
return;
}
my ($surl, $user, $key) = ($args[0], (conf_get('bitly:user'))[0][0], (conf_get('bitly:key'))[0][0]);
$surl = uri_escape($surl);
@@ -68,13 +68,13 @@ sub shorten
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.");
privmsg($src->{svr}, $src->{chan}, 'An error occurred while shortening your URL.');
}
return 1;
@@ -92,8 +92,8 @@ sub reverse
# Put together the call to the Bit.ly API.
if (!defined $args[0]) {
notice($src->{svr}, $src->{nick}, trans("Not enough parameters").".");
return 0;
notice($src->{svr}, $src->{nick}, trans('Not enough parameters').".");
return;
}
my ($surl, $user, $key) = ($args[0], (conf_get('bitly:user'))[0][0], (conf_get('bitly:key'))[0][0]);
$surl = uri_escape($surl);
@@ -104,13 +104,13 @@ 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 {
# 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;
+5 -5
View File
@@ -47,10 +47,10 @@ sub stats {
# 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--; }
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.");
@@ -62,7 +62,7 @@ sub stats {
my $nets = keys %Auto::SOCKET;
my $chans;
foreach my $net (keys %Auto::SOCKET) {
foreach (keys %{$Proto::IRC::botchans{$net}}) { $chans++; }
foreach (keys %{$Proto::IRC::botchans{$net}}) { $chans++ }
}
# Return network/channel data.
+10 -10
View File
@@ -14,7 +14,7 @@ use JSON -support_by_pp;
sub _init
{
# Create the CALC command.
cmd_add("CALC", 0, 0, \%M::Calc::HELP_CALC, \&M::Calc::calc) or return 0;
cmd_add("CALC", 0, 0, \%M::Calc::HELP_CALC, \&M::Calc::calc) or return;
# Success.
return 1;
@@ -24,7 +24,7 @@ sub _init
sub _void
{
# Delete the CALC command.
cmd_del("CALC") or return 0;
cmd_del("CALC") or return;
# Success.
return 1;
@@ -49,7 +49,7 @@ sub calc
# Put together the call to the Google Calculator API.
if (!defined $args[0]) {
notice($src->{svr}, $src->{nick}, trans("Not enough parameters").".");
return 0;
return;
}
my $expr = join(' ', @args);
my $url = "http://www.google.com/ig/calculator?q=".uri_escape($expr);
@@ -58,20 +58,20 @@ sub calc
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);
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) {
if ($d->{error} eq "" or $d->{error} == 0) {
# And send to channel
privmsg($src->{svr}, $src->{chan}, "Result: ".$d->{lhs}." = ".$d->{rhs});
}
else {
}
else {
# Otherwise, send an error message.
privmsg($src->{svr}, $src->{chan}, "Google Calculator sent an error.");
}
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.");
privmsg($src->{svr}, $src->{chan}, "An error occurred while sending your expression to Google Calculator.");
}
return 1;
+1 -1
View File
@@ -11,7 +11,7 @@ use API::IRC qw(notice topic);
sub _init
{
# PostgreSQL is not supported.
if ($Auto::ENFEAT =~ /pgsql/) { err(3, 'Unable to load ChanTopics: PostgreSQL is not supported.', 0); return; }
if ($Auto::ENFEAT =~ /pgsql/) { err(3, 'Unable to load ChanTopics: PostgreSQL is not supported.', 0); return }
# Create database table if it's missing.
$Auto::DB->do('CREATE TABLE IF NOT EXISTS topics (net TEXT, chan TEXT, topic TEXT, divider TEXT, owner TEXT, verb TEXT, status TEXT, other TEXT, static TEXT)') or print "$!\n" and return;
+44 -49
View File
@@ -4,28 +4,40 @@
package M::EightBall;
use strict;
use warnings;
use feature qw(switch);
use API::Std qw(cmd_add cmd_del trans);
use API::IRC qw(privmsg notice);
our $ANSWER = 0;
my @responses = (
'Yes!',
'No!',
'Yes... No... Yes... No... Hmm... No.',
'Hmm... it seems likely.',
'Very unlikely.',
'Heck no!',
'Definite yes!',
'Magic unavailable. Try again later.',
'Possibly, I wouldn\'t count on it though.',
'Outcome looks bad.',
'Outcome looks good.',
'Can\'t tell now. Maybe another time.',
'Sorry, but no.',
);
# Initialization subroutine.
sub _init
{
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;
cmd_add('RIGBALL', 1, 'cmd.rigball', \%M::EightBall::HELP_RIGBALL, \&M::EightBall::rigball) or return;
# Success.
return 1;
}
# Void subroutine.
sub _void
{
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;
cmd_del('RIGBALL') or return;
# Success.
return 1;
@@ -40,77 +52,64 @@ our %HELP_RIGBALL = (
);
# Callback for 8BALL command.
sub c_8ball
{
sub c_8ball {
my ($src, @argv) = @_;
if (!defined $argv[0]) {
notice($src->{svr}, $src->{nick}, trans("Not enough parameters").".");
notice($src->{svr}, $src->{nick}, trans('Not enough parameters').q{.});
return;
}
privmsg($src->{svr}, $src->{chan}, "\002Question:\002 ".join(" ", @argv));
my $a = '';
# Return the question.
privmsg($src->{svr}, $src->{chan}, "\2Question:\2 ".join q{ }, @argv);
# Set answer.
my $answer;
if (!$ANSWER) {
my $rn = int(rand(12));
given ($rn) {
when (1) { $a = "Yes!"; }
when (2) { $a = "No!"; }
when (3) { $a = "Yes... No... Yes... No... No."; }
when (4) { $a = "Hmm... it seems likely."; }
when (5) { $a = "Very unlikely."; }
when (6) { $a = "Heck no!"; }
when (7) { $a = "Definite yes!"; }
when (8) { $a = "Magic unavailable. Try again later."; }
when (9) { $a = "Possibly, I wouldn't count on it though."; }
when (10) { $a = "Outcome looks bad."; }
when (11) { $a = "Outcome looks good."; }
when (12) { $a = "Can't tell now. Maybe another time."; }
default { $a = "Sorry, but no."; }
}
$answer = $responses[int rand scalar @responses];
}
else {
$a = $ANSWER;
$answer = $ANSWER;
$ANSWER = 0;
}
privmsg($src->{svr}, $src->{chan}, "\002Answer:\002 ".$a);
# Return it.
privmsg($src->{svr}, $src->{chan}, "\2Answer:\2 $answer");
return 1;
}
# Callback for RIGBALL command.
sub rigball
{
sub rigball {
my ($src, @argv) = @_;
# Check for necessary parameters.
if (!defined $argv[0]) {
privmsg($src->{svr}, $src->{nick}, trans("Not enough parameters").".");
privmsg($src->{svr}, $src->{nick}, trans('Not enough parameters').q{.});
return;
}
$ANSWER = join(" ", @argv);
privmsg($src->{svr}, $src->{nick}, "Answer set to: ".$ANSWER);
# Return result.
$ANSWER = join q{ }, @argv;
privmsg($src->{svr}, $src->{nick}, "Answer set to: $ANSWER");
return 1;
}
# Start initialization.
API::Std::mod_init('EightBall', 'Xelhua', '1.00', '3.0.0a7', __PACKAGE__);
API::Std::mod_init('EightBall', 'Xelhua', '2.00', '3.0.0a8', __PACKAGE__);
# build: perl=5.010000
__END__
=head1 NAME
Eightball - A magic eightball module.
EightBall - A magic eightball module.
=head1 VERSION
1.00
2.00
=head1 SYNOPSIS
@@ -124,13 +123,9 @@ Eightball - A magic eightball module.
=head1 DESCRIPTION
This module adds the 8BALL and RIGBALL commands, 8BALL is a channel
command for asking the magic 8-Ball a question, RIGBALL is a private
command for setting ("rigging") the 8-Ball's next answer.
=head1 INSTALL
No additonal steps need to be taking to use this module.
This module adds the 8BALL and RIGBALL commands, 8BALL is a channel command for
asking the magic 8-Ball a question, RIGBALL is a private command for setting
("rigging") the 8-Ball's next answer.
=head1 AUTHOR
+1 -1
View File
@@ -44,7 +44,7 @@ sub cmd_eval {
# Evaluate the expression and return the result.
my $expr = join ' ', @argv;
my $result = eval($expr);
if (!defined $result) { $result = 'None'; }
if (!defined $result) { $result = 'None' }
if ($EVAL_ERROR) {
$result = $EVAL_ERROR;
$result =~ s/(\r|\n)//gxsm;
+4 -4
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;
# Success.
return 1;
@@ -22,7 +22,7 @@ sub _init
sub _void
{
# Delete the FML command.
cmd_del('FML') or return 0;
cmd_del('FML') or return;
# Success.
return 1;
@@ -49,14 +49,14 @@ sub fml
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.
+2 -2
View File
@@ -12,7 +12,7 @@ use API::IRC qw(privmsg notice);
sub _init
{
# Not compatible with PostgreSQL.
if ($Auto::ENFEAT =~ /pgsql/) { err(2, 'Unable to load Greet: PostgreSQL is not supported.', 0); return; }
if ($Auto::ENFEAT =~ /pgsql/) { err(2, 'Unable to load Greet: PostgreSQL is not supported.', 0); return }
# Create the `greets` table.
$Auto::DB->do('CREATE TABLE IF NOT EXISTS greets (nick TEXT, greet TEXT)') or return;
@@ -100,7 +100,7 @@ sub cmd_greet
$Auto::DB->do('DELETE FROM greets WHERE nick = "'.$nick.'"') or notice($src->{svr}, $src->{nick}, trans('An error occurred').q{.}) and return;
notice($src->{svr}, $src->{nick}, "Greet for \002$nick\002 successfully deleted.");
}
default { notice($src->{svr}, $src->{nick}, "Unknown action \002$argv[0]\002. \002Syntax:\002 GREET (ADD|DEL)"); return; }
default { notice($src->{svr}, $src->{nick}, "Unknown action \002$argv[0]\002. \002Syntax:\002 GREET (ADD|DEL)"); return }
}
return 1;
+3 -3
View File
@@ -11,7 +11,7 @@ use API::IRC qw(privmsg);
sub _init
{
# Add a hook for when we join a channel.
hook_add("on_ucjoin", "HelloChan", \&M::HelloChan::hello) or return 0;
hook_add('on_ucjoin', 'HelloChan', \&M::HelloChan::hello) or return;
return 1;
}
@@ -19,7 +19,7 @@ sub _init
sub _void
{
# Delete the hook.
hook_del("on_ucjoin", "HelloChan") or return 0;
hook_del('on_ucjoin', 'HelloChan') or return;
return 1;
}
@@ -29,7 +29,7 @@ sub hello
my (($svr, $chan)) = @_;
# Send a PRIVMSG.
privmsg($svr, $chan, "Hello channel! I am a bot!");
privmsg($svr, $chan, 'Hello channel! I am a bot!');
return 1;
}
+9 -9
View File
@@ -12,7 +12,7 @@ use LWP::UserAgent;
sub _init
{
# Create the ISITUP command.
cmd_add('ISITUP', 0, 0, \%M::IsItUp::HELP_ISITUP, \&M::IsItUp::check) or return 0;
cmd_add('ISITUP', 0, 0, \%M::IsItUp::HELP_ISITUP, \&M::IsItUp::check) or return;
# Success.
return 1;
@@ -22,7 +22,7 @@ sub _init
sub _void
{
# Delete the ISITUP command.
cmd_del('ISITUP') or return 0;
cmd_del('ISITUP') or return;
# Success.
return 1;
@@ -44,25 +44,25 @@ sub check
$ua->timeout(2);
# Do we have enough parameters?
if (!defined $argv[0]) {
notice($src->{svr}, $src->{nick}, trans('Not enough parameters').q{.});
return 0;
notice($src->{svr}, $src->{nick}, trans('Not enough parameters').q{.});
return;
}
my $curl = $argv[0];
# Does the URL start with http(s)?
if ($curl !~ m/^http/) {
$curl = 'http://'.$curl;
$curl = 'http://'.$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.');
# 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.');
# Otherwise, it's down.
privmsg($src->{svr}, $src->{chan}, $curl.' appears to be down from here.');
}
return 1;
+100
View File
@@ -0,0 +1,100 @@
# Module: LOLCAT. 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::LOLCAT;
use strict;
use warnings;
use API::Std qw(cmd_add cmd_del trans);
use API::IRC qw(privmsg notice);
use Acme::LOLCAT;
# Initialization subroutine.
sub _init {
# Create LOLCAT command.
cmd_add('LOLCAT', 0, 0, \%M::LOLCAT::HELP_LOLCAT, \&M::LOLCAT::cmd_lolcat) or return;
# Success.
return 1;
}
# Void subroutine.
sub _void {
# Delete LOLCAT command.
cmd_del('LOLCAT') or return;
# Success.
return 1;
}
# Help for LOLCAT.
our %HELP_LOLCAT = (
en => "This command will translate English to LOLCAT speak. \2Syntax:\2 LOLCAT <text>",
);
# Callback for LOLCAT command.
sub cmd_lolcat {
my ($src, @argv) = @_;
# At least one parameter is required.
if (!defined $argv[0]) {
notice($src->{svr}, $src->{nick}, trans('Not enough parameters').q{.});
return;
}
# Return LOLCAT translation.
privmsg($src->{svr}, $src->{chan}, 'Result: '.translate(join q{ }, @argv));
return 1;
}
# Start initialization.
API::Std::mod_init('LOLCAT', 'Xelhua', '1.00', '3.0.0a8', __PACKAGE__);
# build: perl=5.010000 cpan=Acme::LOLCAT
__END__
=head1 NAME
LOLCAT - Translates English into LOLCAT.
=head1 VERSION
1.00
=head1 SYNOPSIS
<starcoder> !lolcat You too can speak like a lolcat!
<Auto> Result: YU T CAN SPEKK LIEK LOLCAT! KTHXBYE!
=head1 DESCRIPTION
This will create the LOLCAT command which allows you to translate English text
into LOLCAT speak.
See also: http://en.wikipedia.org/wiki/Lolcat
=head1 DEPENDENCIES
This module is dependent on the following modules from CPAN:
=over
=item L<Acme::LOLCAT>
This is what the module uses to translate English into LOLCAT.
=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.
Released under the same licensing terms as Auto itself.
=cut
# vim: set ai et ts=4 sw=4:
+5 -2
View File
@@ -50,6 +50,9 @@ sub gettitle
if ($res->is_success) {
# We were, decode the data.
my $data = $res->decoded_content;
# Strip newlines.
$data =~ s/(\n|\r)//gxsm;
# Check for <title>
if ($data =~ m{<title>(.*)</title>}ixsm) {
@@ -66,7 +69,7 @@ sub gettitle
}
# Start initialization.
API::Std::mod_init('LinkTitle', 'Xelhua', '1.00', '3.0.0a7', __PACKAGE__);
API::Std::mod_init('LinkTitle', 'Xelhua', '1.01', '3.0.0a8', __PACKAGE__);
# build: cpan=LWP::UserAgent,HTML::Entities perl=5.010000
__END__
@@ -77,7 +80,7 @@ LinkTitle - A module for returning the page title of links.
=head1 VERSION
1.00
1.01
=head1 SYNOPSIS
+8 -8
View File
@@ -11,9 +11,9 @@ use API::Log qw(alog);
sub _init
{
# Add a hook for when we join a channel.
hook_add("on_connect", "Oper.onconnect", \&M::Oper::on_connect) or return 0;
hook_add('on_connect', 'Oper.onconnect', \&M::Oper::on_connect) or return;
# Add a hook for when we get numeric 491 (ERR_NOOPERHOST)
rchook_add("491", "Oper.on381", \&M::Oper::on_num491) or return 0;
rchook_add('491', 'Oper.on381', \&M::Oper::on_num491) or return;
return 1;
}
@@ -21,10 +21,10 @@ sub _init
sub _void
{
# Delete the hooks.
hook_del("on_connect", "Oper.onconnect") or return 0;
rchook_del("381", "Oper.on381") or return 0;
rchook_del("313", "Oper.on313") or return 0;
rchook_del("491", "Oper.on491") or return 0;
hook_del('on_connect', 'Oper.onconnect') or return;
rchook_del('381', 'Oper.on381') or return;
rchook_del('313', 'Oper.on313') or return;
rchook_del('491', 'Oper.on491') or return;
return 1;
}
@@ -55,9 +55,9 @@ sub on_num491 {
sub is_opered {
my ($svr) = @_;
# Auto is not opered.
return 0 if $Proto::IRC::botinfo{$svr}{modes} !~ m/o/xsm;
return if $State::IRC::botinfo{$svr}{modes} !~ m/o/xsm;
# Auto is opered.
return 1 if $Proto::IRC::botinfo{$svr}{modes} =~ m/o/xsm;
return 1 if $State::IRC::botinfo{$svr}{modes} =~ m/o/xsm;
return;
}
+10 -10
View File
@@ -15,7 +15,7 @@ sub _init
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; }
if ($Auto::ENFEAT =~ /pgsql/) { err(2, 'Unable to load QDB: PostgreSQL is not supported.', 0); return }
# Check for database table.
$Auto::DB->do('CREATE TABLE IF NOT EXISTS qdb (quoteid INTEGER PRIMARY KEY, creator TEXT, time INTEGER, quote TEXT)') or return;
@@ -82,11 +82,11 @@ sub cmd_qdb
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; }
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]);
privmsg($src->{svr}, $src->{chan}, '> '.$data[3]);
}
when ('COUNT') {
# Get count.
@@ -103,7 +103,7 @@ sub cmd_qdb
# Random number.
my $rand = int(rand($count));
if ($rand == 0) { $rand = $count; }
if ($rand == 0) { $rand = $count }
# Get quote.
my $dbq = $Auto::DB->prepare('SELECT * FROM qdb WHERE quoteid = ?') or
@@ -113,7 +113,7 @@ sub cmd_qdb
# Send it back.
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]);
privmsg($src->{svr}, $src->{chan}, '> '.$data[3]);
}
when ('SEARCH') {
# QDB SEARCH.
@@ -157,7 +157,7 @@ sub cmd_qdb
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; }
if (conf_get('qdb_search_resnum')) { $si = (conf_get('qdb_search_resnum'))[0][0] - 1 }
while ($i <= $si) {
if (!defined $BUFFER[0]) {
last;
@@ -177,7 +177,7 @@ sub cmd_qdb
# Return four quotes.
my $i = 0;
my $si = 3;
if (conf_get('qdb_search_resnum')) { $si = (conf_get('qdb_search_resnum'))[0][0] - 1; }
if (conf_get('qdb_search_resnum')) { $si = (conf_get('qdb_search_resnum'))[0][0] - 1 }
while ($i <= $si) {
if (!defined $BUFFER[0]) {
last;
@@ -204,14 +204,14 @@ sub cmd_qdb
notice($src->{svr}, $src->{nick}, (($dbq) ? 'Done.' : trans('An error occurred').q{.}));
}
default { notice($src->{svr}, $src->{nick}, "Unknown action \002".uc($argv[0])."\002. \002Syntax:\002 QDB (ADD|VIEW|COUNT|RAND|DEL) [quote]"); return; }
default { notice($src->{svr}, $src->{nick}, "Unknown action \002".uc($argv[0])."\002. \002Syntax:\002 QDB (ADD|VIEW|COUNT|RAND|DEL) [quote]"); return }
}
return 1;
}
API::Std::mod_init('QDB', 'Xelhua', '1.02', '3.0.0a7', __PACKAGE__);
API::Std::mod_init('QDB', 'Xelhua', '1.04', '3.0.0a9', __PACKAGE__);
# build: perl=5.010000
__END__
@@ -222,7 +222,7 @@ QDB - Quote database module.
=head1 VERSION
1.02
1.04
=head1 SYNOPSIS
+3 -3
View File
@@ -14,11 +14,11 @@ use API::IRC qw(privmsg);
sub _init
{
# 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; }
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") and conf_get("server:$svr:sasl_password") and conf_get("server:$svr:sasl_timeout")) { $Proto::IRC::cap{$svr} .= ' sasl'; }
if (conf_get("server:$svr:sasl_username") and conf_get("server:$svr:sasl_password") and conf_get("server:$svr:sasl_timeout")) { $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;
@@ -47,7 +47,7 @@ sub handle_capack {
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'); });
timer_add('auth_timeout_'.$svr, 1, (conf_get("server:$svr:sasl_timeout"))[0][0], sub { Auto::socksnd($svr, 'CAP END') });
}
return 1;
+381 -236
View File
File diff suppressed because it is too large. Load diff
+16 -16
View File
@@ -13,7 +13,7 @@ use XML::Simple;
sub _init
{
# Create the Weather command.
cmd_add("WEATHER", 0, 0, \%M::Weather::HELP_WEATHER, \&M::Weather::weather) or return 0;
cmd_add('WEATHER', 0, 0, \%M::Weather::HELP_WEATHER, \&M::Weather::weather) or return;
# Success.
return 1;
@@ -23,7 +23,7 @@ sub _init
sub _void
{
# Delete the Weather command.
cmd_del("WEATHER") or return 0;
cmd_del('WEATHER') or return;
# Success.
return 1;
@@ -45,8 +45,8 @@ sub weather
$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;
notice($src->{svr}, $src->{nick}, trans('Not enough parameters').".");
return;
}
my $loc = join(' ', @args);
$loc =~ s/ /%20/g;
@@ -56,22 +56,22 @@ sub weather
if ($response->is_success) {
# If successful, decode the content.
my $d = XMLin($response->decoded_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.");
}
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.");
privmsg($src->{svr}, $src->{chan}, 'An error occurred while retrieving your weather.');
}
return 1;
File diff suppressed because it is too large. Load diff
View File
File renamed without changes.