411 lines
10 KiB
Perl
Executable File
411 lines
10 KiB
Perl
Executable File
#!/usr/bin/env perl
|
|
|
|
# Auto IRC Bot. An advanced, lightweight and powerful IRC bot.
|
|
# Copyright (C) 2010-2011 Xelhua Development Team (doc/CREDITS)
|
|
# This program is free software; rights to this code are stated in doc/LICENSE.
|
|
package Auto;
|
|
require 5.10.0;
|
|
use strict;
|
|
use warnings;
|
|
use POSIX;
|
|
use locale;
|
|
use feature qw(switch);
|
|
use Mouse;
|
|
use IO::Socket;
|
|
use IO::Select;
|
|
use Class::Unload;
|
|
use FindBin qw($Bin);
|
|
our $Bin = $Bin;
|
|
BEGIN {
|
|
unshift(@INC, "$Bin/../src");
|
|
|
|
# Set version information.
|
|
use constant {
|
|
NAME => 'Auto IRC Bot',
|
|
VER => 3,
|
|
SVER => 0,
|
|
REV => 0,
|
|
RSTAGE => 'd'
|
|
};
|
|
}
|
|
use API::Std qw(conf_get err cmd_add cmd_del);
|
|
use API::Log qw(println alog dbug);
|
|
use DB::Flatfile;
|
|
use Parser::Config;
|
|
use Parser::Lang;
|
|
use Parser::IRC;
|
|
use Core::IRC;
|
|
|
|
|
|
our $VERSION = 3.0.0;
|
|
$0 = NAME;
|
|
|
|
# Check for build files.
|
|
unless (-e "$Bin/../build/os" and -e "$Bin/../build/perl" and -e "$Bin/../build/time" and -e "$Bin/../build/ver") {
|
|
println "Missing build file(s). Please build Auto before running it." and exit;
|
|
}
|
|
|
|
# Check build OS.
|
|
open(my $BFOS, q{<}, "$Bin/../build/os") or println "Cannot start: Broken build." and exit;
|
|
my @BFOS = <$BFOS>;
|
|
close $BFOS;
|
|
if ($BFOS[0] ne $^O."\n") {
|
|
println "Cannot start: Broken build." and exit;
|
|
}
|
|
undef @BFOS;
|
|
|
|
# Check build features.
|
|
our $ENFEAT;
|
|
open(my $BFFEAT, q{<}, "$Bin/../build/feat") or println "Cannot start: Broken build." and exit;
|
|
my @BFFEAT = <$BFFEAT>;
|
|
close $BFFEAT;
|
|
$ENFEAT = substr($BFFEAT[0], 0, length($BFFEAT[0]) - 1);
|
|
undef @BFFEAT;
|
|
|
|
# Check build Perl version.
|
|
open(my $BFPERL, q{<}, "$Bin/../build/perl") or println "Cannot start: Broken build." and exit;
|
|
my @BFPERL = <$BFPERL>;
|
|
close $BFPERL;
|
|
if ($BFPERL[0] ne $]."\n") {
|
|
println "Cannot start: Broken build." and exit;
|
|
}
|
|
undef @BFPERL;
|
|
|
|
# Check build Auto version.
|
|
open(my $BFVER, q{<}, "$Bin/../build/ver") or println "Cannot start: Broken build." and exit;
|
|
my @BFVER = <$BFVER>;
|
|
close $BFVER;
|
|
if ($BFVER[0] ne VER.".".SVER.".".REV.RSTAGE."\n") {
|
|
println "Cannot start: Broken build." and exit;
|
|
}
|
|
undef @BFVER;
|
|
|
|
# Set signal handlers.
|
|
$SIG{TERM} = \&signal_TERM;
|
|
$SIG{INT} = \&signal_INT;
|
|
$SIG{HUP} = \&signal_HUP;
|
|
API::Std::event_add("on_sigterm");
|
|
API::Std::event_add("on_sigint");
|
|
API::Std::event_add("on_sighup");
|
|
|
|
|
|
# Print startup message.
|
|
println <<'EOF';
|
|
8""""8
|
|
8 8 e e eeeee eeeee
|
|
8eeee8 8 8 8 8 88
|
|
88 8 8e 8 8e 8 8
|
|
88 8 88 8 88 8 8
|
|
88 8 88ee8 88 8eee8
|
|
EOF
|
|
println "* ".NAME." (version ".VER.".".SVER.".".REV.RSTAGE.") is starting up...";
|
|
|
|
our ($APID, %TIMERS);
|
|
|
|
# Check for debug mode.
|
|
our $DEBUG = 0;
|
|
if (defined $ARGV[0]) {
|
|
if ($ARGV[0] eq '-d') {
|
|
$DEBUG = 1;
|
|
}
|
|
}
|
|
|
|
# Parse configuration file.
|
|
println "* Parsing configuration file auto.conf...";
|
|
our $CONF = Parser::Config->new("auto.conf") or err(1, "Failed to parse configuration file!", 1);
|
|
our %SETTINGS = $CONF->parse or err(1, "Failed to parse configuration file!", 1);
|
|
println " Success";
|
|
|
|
if (conf_get("die")) {
|
|
if ((conf_get("die"))[0][0] == 1) {
|
|
println "!!! You didn't read the whole config.";
|
|
println "!!! Insert new user then try again.";
|
|
exit;
|
|
}
|
|
}
|
|
|
|
# Check for required configuration values.
|
|
my @REQCVALS = qw(locale expire_logs server fantasy_pf);
|
|
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);
|
|
}
|
|
}
|
|
undef @REQCVALS;
|
|
|
|
# Parse translations.
|
|
println "* Parsing translation files...";
|
|
our $LOCALE = (conf_get("locale"))[0][0];
|
|
my @lang = split('_', $LOCALE);
|
|
Parser::Lang::parse($lang[0]) or err(2, "Failed to parse translation files!", 1);
|
|
undef @lang;
|
|
println " Success";
|
|
|
|
# Expire old logs.
|
|
API::Log::expire_logs();
|
|
|
|
# Load database.
|
|
DB::load();
|
|
|
|
# Parse privileges.
|
|
our (%PRIVILEGES);
|
|
# If there are any privsets.
|
|
if (conf_get("privset")) {
|
|
# Get them.
|
|
my %tcprivs = conf_get("privset");
|
|
|
|
foreach my $tckpriv (keys %tcprivs) {
|
|
# For each privset, get the inner values.
|
|
my %mcprivs = conf_get("privset:$tckpriv");
|
|
|
|
# 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} } = ($_);
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
# Successful startup.
|
|
our $STARTTIME = time;
|
|
println "* Auto successfully started at ".POSIX::strftime("%Y-%m-%d %I:%M:%S %p", localtime).".";
|
|
alog "Auto successfully started.";
|
|
|
|
# Fork into the background if not in debug mode.
|
|
unless ($DEBUG) {
|
|
println "*** Becoming a daemon...";
|
|
open(STDIN, q{<}, '/dev/null') or err(2, "Can't read /dev/null: $!", 1);
|
|
open(STDOUT, q{>>}, '/dev/null') or err(2, "Can't write to /dev/null: $!", 1);
|
|
open(STDERR, q{>>}, '/dev/null') or err(2, "Can't write to /dev/null: $!", 1);
|
|
$APID = fork();
|
|
unless ($APID == 0) {
|
|
alog "* Successfully forked into the background. Process ID: ".$APID;
|
|
unless (-e "$Bin/auto.pid") {
|
|
system("touch $Bin/auto.pid");
|
|
}
|
|
open(my $FPID, q{>}, "$Bin/auto.pid") or exit;
|
|
print $FPID "$APID\n" or exit;
|
|
close $FPID or exit;
|
|
exit;
|
|
}
|
|
POSIX::setsid() or err(2, "Can't start a new session: $!", 1);
|
|
}
|
|
else {
|
|
$APID = $$;
|
|
}
|
|
|
|
# Events.
|
|
API::Std::event_add("on_preconnect");
|
|
|
|
# Load modules.
|
|
if (conf_get("module")) {
|
|
alog "* Loading modules...";
|
|
dbug "* Loading modules...";
|
|
foreach (@{ (conf_get("module"))[0] }) {
|
|
mod_load($_);
|
|
}
|
|
}
|
|
|
|
## Create sockets.
|
|
alog "* Connecting to servers...";
|
|
dbug "* Connecting to servers...";
|
|
# Get servers from config.
|
|
my %cservers = conf_get("server");
|
|
# Set the hashes and processes hashes.
|
|
my (%SOCKET, %SOCKETH, $SELECT);
|
|
$SELECT = IO::Select->new();
|
|
my $it = 0;
|
|
# Iterate through each configured server.
|
|
foreach my $cskey (keys %cservers) {
|
|
# Create the socket.
|
|
$SOCKET{$cskey} = IO::Socket::INET->new(
|
|
Proto => "tcp",
|
|
LocalAddr => $cservers{$cskey}{'bind'}[0],
|
|
PeerAddr => $cservers{$cskey}{'host'}[0],
|
|
PeerPort => $cservers{$cskey}{'port'}[0]
|
|
) or err(2, "Failed to connect to server: ".$cskey." [".$cservers{$cskey}{'host'}[0].":".$cservers{$cskey}{'port'}[0]."]", 0) and next; # Or error.
|
|
# Send PASS if we have one.
|
|
if (defined $cservers{$cskey}{'pass'}[0]) {
|
|
socksnd($cskey, "PASS :".$cservers{$cskey}{'pass'}[0]) or
|
|
err(2, "Failed to connect to server: ".$cskey." [".$cservers{$cskey}{'host'}[0].":".$cservers{$cskey}{'port'}[0]."]", 0)
|
|
and next;
|
|
}
|
|
API::Std::event_run("on_preconnect", $cskey);
|
|
# Send USER and NICK.
|
|
socksnd($cskey, "USER ".$cservers{$cskey}{'ident'}[0]." * * :".$cservers{$cskey}{'realname'}[0]) or
|
|
err(2, "Failed to connect to server: ".$cskey." [".$cservers{$cskey}{'host'}[0].":".$cservers{$cskey}{'port'}[0]."]", 0)
|
|
and next;
|
|
API::IRC::nick($cskey, $cservers{$cskey}{'nick'}[0]);
|
|
# Add to select.
|
|
$SELECT->add($SOCKET{$cskey});
|
|
# Success!
|
|
alog "** Successfully connected to server: ".$cskey;
|
|
dbug "** Successfully connected to server: ".$cskey;
|
|
$it = 1;
|
|
}
|
|
|
|
# Success!
|
|
if ($it) {
|
|
alog "** Success: Connected to server(s).";
|
|
dbug "** Success: Connected to server(s).";
|
|
}
|
|
else {
|
|
err(2, "No server connections.", 1);
|
|
}
|
|
undef $it;
|
|
|
|
# Create core hooks.
|
|
API::Std::hook_add("on_uprivmsg", "ctcp_version_reply", \&Core::IRC::version_reply);
|
|
|
|
# Infinite while loop.
|
|
while (1) {
|
|
# Timer check.
|
|
foreach my $tk (keys %TIMERS) {
|
|
if ($TIMERS{$tk}{time} <= time) {
|
|
&{ $TIMERS{$tk}{sub} }();
|
|
if ($TIMERS{$tk}{type} == 1) {
|
|
# If it's type 1, delete from memory.
|
|
delete $TIMERS{$tk};
|
|
}
|
|
elsif ($TIMERS{$tk}{type} == 2) {
|
|
# If it's type 2, reset timer.
|
|
$TIMERS{$tk}{time} = time + $TIMERS{$tk}{secs};
|
|
}
|
|
else {
|
|
# This should never happen.
|
|
delete $TIMERS{$tk};
|
|
}
|
|
}
|
|
}
|
|
# Socket check.
|
|
foreach my $sock ($SELECT->can_read(1)) {
|
|
# Figure out what network is sending us data.
|
|
my $sockid;
|
|
foreach (keys %SOCKET) {
|
|
$sockid = $_ if ($SOCKET{$_} eq $sock);
|
|
}
|
|
# Read the data.
|
|
my $data = readline($sock);
|
|
if (!defined $data) {
|
|
# Got EOF, close socket
|
|
err(2, "Lost connection to $sockid!", 0);
|
|
$SELECT->remove($sock);
|
|
next;
|
|
}
|
|
# Remove the newlines.
|
|
chomp $data;
|
|
# Debug.
|
|
dbug $sockid." >> ".$data;
|
|
|
|
# Parse data.
|
|
Parser::IRC::ircparse($sockid, $data);
|
|
}
|
|
}
|
|
|
|
###############
|
|
# Subroutines #
|
|
###############
|
|
|
|
# Send data to socket.
|
|
sub socksnd
|
|
{
|
|
my ($svr, $data) = @_;
|
|
|
|
if (defined $SOCKET{$svr}) {
|
|
send($SOCKET{$svr}, $data."\n", 0);
|
|
dbug "$svr << $data";
|
|
return 1;
|
|
}
|
|
else {
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
# Load a module.
|
|
sub mod_load {
|
|
my ($module) = @_;
|
|
|
|
if (-e "$Bin/../modules/".$module.".pm") {
|
|
do "$Bin/../modules/".$module.".pm" and return 1 or print $@ and return 0;
|
|
}
|
|
else {
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
|
|
## Signal handlers
|
|
|
|
# SIGTERM
|
|
sub signal_TERM
|
|
{
|
|
API::Std::event_run("on_sigterm");
|
|
API::IRC::quit($_, "Caught SIGTERM") foreach (keys %SOCKET);
|
|
DB::flush();
|
|
dbug "!!! Caught SIGTERM; terminating...";
|
|
alog "!!! Caught SIGTERM; terminating...";
|
|
if (-e "$Bin/auto.pid") {
|
|
system("rm $Bin/auto.pid");
|
|
}
|
|
sleep 1;
|
|
exit;
|
|
}
|
|
|
|
# SIGINT
|
|
sub signal_INT
|
|
{
|
|
API::Std::event_run("on_sigint");
|
|
API::IRC::quit($_, "Caught SIGINT") foreach (keys %SOCKET);
|
|
DB::flush();
|
|
dbug "!!! Caught SIGINT; terminating...";
|
|
alog "!!! Caught SIGINT; terminating...";
|
|
if (-e "$Bin/auto.pid") {
|
|
system("rm $Bin/auto.pid");
|
|
}
|
|
sleep 1;
|
|
exit;
|
|
}
|
|
|
|
# SIGHUP
|
|
sub signal_HUP
|
|
{
|
|
API::Std::event_run("on_sighup");
|
|
dbug "!!! Caught SIGHUP but rehash is unavailable; ignoring";
|
|
alog "!!! Caught SIGHUP but rehash is unavailable; ignoring";
|
|
return 1;
|
|
}
|