605 lines
20 KiB
Perl
Executable File
605 lines
20 KiB
Perl
Executable File
#!/usr/bin/env perl
|
|
|
|
# bin/auto - Main file.
|
|
# Copyright (C) 2010-2011 Xelhua Development Group, et al.
|
|
# This program is free software; rights to this code are stated in doc/LICENSE.
|
|
package Auto;
|
|
use 5.010_000;
|
|
use strict;
|
|
use warnings;
|
|
no feature qw(state);
|
|
use POSIX;
|
|
use locale;
|
|
use English qw(-no_match_vars);
|
|
use Sys::Hostname;
|
|
use IO::Socket;
|
|
use IO::Select;
|
|
use Getopt::Long;
|
|
use DBI;
|
|
use Class::Unload;
|
|
use FindBin qw($Bin);
|
|
our $Bin = $Bin; ## no critic qw(NamingConventions::Capitalization Variables::ProhibitPackageVars)
|
|
our (%bin, $UPREFIX);
|
|
BEGIN {
|
|
$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;
|
|
}
|
|
|
|
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)
|
|
NAME => 'Auto IRC Bot',
|
|
VER => 3,
|
|
SVER => 0,
|
|
REV => 0,
|
|
RSTAGE => 'd',
|
|
};
|
|
}
|
|
use Lib::Auto;
|
|
use API::Std qw(conf_get err);
|
|
use API::Log qw(alog dbug);
|
|
#use DB::Flatfile;
|
|
use Parser::Config;
|
|
use Parser::Lang;
|
|
use Proto::IRC;
|
|
use State::IRC;
|
|
use Core::IRC;
|
|
use Core::IRC::Users;
|
|
use Core::Cmd;
|
|
|
|
our $VERSION = 3.000000;
|
|
local $PROGRAM_NAME = 'auto';
|
|
|
|
# Check for build files.
|
|
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{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") {
|
|
say 'Cannot start: Broken build.' and exit;
|
|
}
|
|
undef @BFOS;
|
|
|
|
# Check build features.
|
|
our $ENFEAT;
|
|
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{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") {
|
|
say 'Cannot start: Broken build.' and exit;
|
|
}
|
|
undef @BFPERL;
|
|
|
|
# Check build Auto version.
|
|
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") {
|
|
say 'Cannot start: Broken build.' and exit;
|
|
}
|
|
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;
|
|
local $SIG{HUP} = \&Lib::Auto::signal_hup;
|
|
local $SIG{'__WARN__'} = \&Lib::Auto::signal_perlwarn;
|
|
local $SIG{'__DIE__'} = \&Lib::Auto::signal_perldie;
|
|
API::Std::event_add('on_sigterm');
|
|
API::Std::event_add('on_sigint');
|
|
API::Std::event_add('on_sighup');
|
|
|
|
# Get arguments.
|
|
our ($DEBUG, $NUC);
|
|
my ($opt_help, $opt_version, $USECONFIG);
|
|
GetOptions(
|
|
'nuc' => \$NUC,
|
|
'c=s' => \$USECONFIG,
|
|
'config=s' => \$USECONFIG,
|
|
'h' => \$opt_help,
|
|
'help' => \$opt_help,
|
|
'd' => \$DEBUG,
|
|
'debug' => \$DEBUG,
|
|
'v' => \$opt_version,
|
|
'version' => \$opt_version
|
|
);
|
|
|
|
# If we were passed -h, print help.
|
|
if ($opt_help) {
|
|
print <<"HELP";
|
|
|
|
Usage: $PROGRAM_NAME [options]
|
|
--help, -h Prints this help.
|
|
--version, -v Prints the version of this Auto.
|
|
--debug, -d Runs Auto in debug mode. Debug mode will print out debug
|
|
messages, including IRC raw data, to screen. This will also
|
|
stop Auto from forking into the background.
|
|
|
|
--config=FILENAME, -c Uses etc/FILENAME for the configuration file.
|
|
|
|
HELP
|
|
exit 1;
|
|
}
|
|
|
|
# If we were passed -v, print version.
|
|
if ($opt_version) {
|
|
say q{};
|
|
say NAME.' version '.VER.', subversion '.SVER.', revision '.REV.' ('.VER.q{.}.SVER.q{.}.REV.RSTAGE.').';
|
|
print <<'VERINFO';
|
|
|
|
Copyright (C) 2010-2011, Xelhua Development Group. All rights reserved.
|
|
|
|
Auto is released under the licensing terms of the New (3-Clause) BSD License,
|
|
which may be found in doc/LICENSE.
|
|
|
|
For documentation, you might refer to README, doc/*, and the Xelhua Wiki at
|
|
http://wiki.xelhua.org. Documentation for modules is stored in Man Page and
|
|
HTML form in autodoc/.
|
|
|
|
For support, visit the Xelhua Forums at http://forums.xelhua.org, or drop by
|
|
the official IRC chatroom at irc.xelhua.org #xelhua. Please report bugs and
|
|
request new features at http://rm.xelhua.org.
|
|
|
|
VERINFO
|
|
exit 1;
|
|
}
|
|
|
|
undef $opt_help;
|
|
undef $opt_version;
|
|
|
|
# Print startup message.
|
|
say <<'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
|
|
say '* '.NAME.' (version '.VER.q{.}.SVER.q{.}.REV.RSTAGE.') is starting up...';
|
|
|
|
our ($APID, %TIMERS);
|
|
|
|
# Check for updates.
|
|
Lib::Auto::checkver();
|
|
|
|
# Include IPv6 if Auto was built for it.
|
|
if ($ENFEAT =~ /ipv6/) { require IO::Socket::INET6 }
|
|
# Include SSL if Auto was built for it.
|
|
if ($ENFEAT =~ /ssl/) { require IO::Socket::SSL }
|
|
|
|
# Parse configuration file.
|
|
my $configfile = 'auto.conf';
|
|
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);
|
|
say ' Success';
|
|
undef $configfile;
|
|
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;
|
|
}
|
|
}
|
|
|
|
# Check for required configuration values.
|
|
my @REQCVALS = qw(locale expire_logs server fantasy_pf ratelimit database:format bantype);
|
|
foreach my $REQCVAL (@REQCVALS) {
|
|
if (!conf_get($REQCVAL)) {
|
|
my $err = 2;
|
|
if ($REQCVAL eq 'expire_logs') {
|
|
$err = 1;
|
|
}
|
|
err($err, "Missing required configuration value: $REQCVAL", 1);
|
|
}
|
|
}
|
|
undef @REQCVALS;
|
|
|
|
# Parse translations.
|
|
say '* Parsing translation files...';
|
|
our $LOCALE = (conf_get('locale'))[0][0];
|
|
my @lang = split m/[_]/, $LOCALE;
|
|
Parser::Lang::parse($lang[0]) or err(2, 'Failed to parse translation files!', 1);
|
|
undef @lang;
|
|
say ' Success';
|
|
|
|
# Expire old logs.
|
|
API::Log::expire_logs();
|
|
|
|
# Connect to database.
|
|
our $DB;
|
|
given (lc((conf_get('database:format'))[0][0])) {
|
|
when ('sqlite') {
|
|
# SQLite.
|
|
if ($ENFEAT !~ /sqlite/) { err(2, 'Auto not built with SQLite support. Aborting.', 1) }
|
|
if (!conf_get('database:filename')) { err(2, 'Missing required configuration value database:filename. Aborting.', 1) }
|
|
|
|
# Import DBD::SQLite.
|
|
require DBD::SQLite;
|
|
|
|
if (!-e "$bin{etc}/".(conf_get('database:filename'))[0][0]) {
|
|
# Create <database:filename> if it's missing.
|
|
open my $dbfh, '>', "$bin{etc}/".(conf_get('database:filename'))[0][0];
|
|
close $dbfh;
|
|
chmod 0755, "$bin{etc}/".(conf_get('database:filename'))[0][0];
|
|
}
|
|
# Connect to database.
|
|
$DB = DBI->connect("dbi:SQLite:dbname=$bin{etc}/".(conf_get('database:filename'))[0][0]) or err(2, 'Failed to connect to database!', 1);
|
|
}
|
|
when ('mysql') {
|
|
# MySQL.
|
|
if ($ENFEAT !~ /mysql/) { err(2, 'Auto not built with MySQL support. Aborting.', 1) }
|
|
my @reqcval = qw(database:host database:name database:username database:password);
|
|
foreach (@reqcval) { if (!conf_get($_)) { err(2, "Missing required configuration value $_. Aborting.", 1) } }
|
|
undef @reqcval;
|
|
|
|
# Import DBD::mysql.
|
|
require DBD::mysql;
|
|
|
|
# Connect to database.
|
|
if (conf_get('database:port')) {
|
|
# If we were given a port, connect with it.
|
|
$DB = DBI->connect('DBI:mysql:database='.(conf_get('database:name'))[0][0].';host='.(conf_get('database:host'))[0][0].';port='.(conf_get('database:port'))[0][0],
|
|
(conf_get('database:username'))[0][0], (conf_get('database:password'))[0][0]) or err(2, 'Failed to connect to database!', 1);;
|
|
}
|
|
else {
|
|
# If not, connect without specifying a port.
|
|
$DB = DBI->connect('DBI:mysql:database='.(conf_get('database:name'))[0][0].';host='.(conf_get('database:host'))[0][0],
|
|
(conf_get('database:username'))[0][0], (conf_get('database:password'))[0][0]) or err(2, 'Failed to connect to database!', 1);;
|
|
}
|
|
}
|
|
# CSV no work. :(
|
|
#when ('csv') {
|
|
# # CSV.
|
|
# if ($ENFEAT !~ /csv/) { err(2, 'Auto not built with CSV support.', 1) }
|
|
# if (!conf_get('database:dir')) { err(2, 'Missing required configuration value database:dir. Aborting.', 1) }
|
|
#
|
|
# # Import DBD::CSV.
|
|
# require DBD::CSV;
|
|
#
|
|
# # Connect to database.
|
|
# $DB = DBI->connect("dbi:CSV:f_dir=$bin{etc}/".(conf_get('database:dir'))[0][0]) or err(2, 'Failed to connect to database!', 1);
|
|
#}
|
|
when ('pgsql') {
|
|
# PostgreSQL.
|
|
if ($ENFEAT !~ /pgsql/) { err(2, 'Auto not built with PostgreSQL support. Aborting.', 1) }
|
|
my @reqcval = qw(database:name database:host database:username database:password);
|
|
foreach (@reqcval) { if (!conf_get($_)) { err(2, "Missing required configuration value $_. Aborting.", 1) } }
|
|
undef @reqcval;
|
|
|
|
# Import DBD::Pg.
|
|
require DBD::Pg;
|
|
|
|
# Connect to database.
|
|
if (conf_get('database:port')) {
|
|
# If a specific port was given, use it.
|
|
$DB = DBI->connect('dbi:Pg:db='.(conf_get('database:name'))[0][0].';host='.(conf_get('database:host'))[0][0].';port='.(conf_get('database:port'))[0][0],
|
|
(conf_get('database:username'))[0][0], (conf_get('database:password'))[0][0]) or err(2, 'Failed to connect to database!', 1);
|
|
}
|
|
else {
|
|
# We were not given a port, connect using PGPORT (usually 5432)
|
|
$DB = DBI->connect('dbi:Pg:db='.(conf_get('database:name'))[0][0].';host='.(conf_get('database:host'))[0][0],
|
|
(conf_get('database:username'))[0][0], (conf_get('database:password'))[0][0]) or err(2, 'Failed to connect to database!', 1);
|
|
}
|
|
}
|
|
# Unknown database format.
|
|
default { err(2, 'Unknown database format \''.lc((conf_get('database:format'))[0][0]).'\'. Aborting.', 1) }
|
|
}
|
|
|
|
|
|
# Ratelimit timer.
|
|
Core::IRC::clear_usercmd_timer();
|
|
|
|
# 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;
|
|
say '* Auto successfully started at '.POSIX::strftime('%Y-%m-%d %I:%M:%S %p', localtime).q{.};
|
|
alog 'Auto successfully started.';
|
|
|
|
# If we're on Windows, disable forking.
|
|
if ($OSNAME =~ /win/i) {
|
|
if (!$DEBUG) {
|
|
say '!!! Forking unavailable (OS is Microsoft Windows), continuing in debug mode.';
|
|
$DEBUG = 1;
|
|
}
|
|
}
|
|
|
|
# Fork into the background if not in debug mode.
|
|
if (!$DEBUG) {
|
|
say '*** Becoming a daemon...';
|
|
open STDIN, '<', '/dev/null' or err(2, "Can't read /dev/null: $ERRNO", 1);
|
|
open STDOUT, '>>', '/dev/null' or err(2, "Can't write to /dev/null: $ERRNO", 1);
|
|
open STDERR, '>>', '/dev/null' or err(2, "Can't write to /dev/null: $ERRNO", 1);
|
|
$APID = fork;
|
|
if ($APID != 0) {
|
|
alog '* Successfully forked into the background. Process ID: '.$APID;
|
|
# 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);
|
|
}
|
|
else {
|
|
$APID = $PID;
|
|
}
|
|
|
|
# Events.
|
|
API::Std::event_add('on_preconnect');
|
|
# CAP.
|
|
my %tcsvrs = conf_get('server');
|
|
foreach my $svr (keys %tcsvrs) {
|
|
$Proto::IRC::cap{$svr} = 'multi-prefix';
|
|
}
|
|
undef %tcsvrs;
|
|
|
|
# Load modules.
|
|
if (conf_get('module')) {
|
|
alog '* Loading modules...';
|
|
dbug '* Loading modules...';
|
|
foreach (@{ (conf_get('module'))[0] }) {
|
|
mod_load($_);
|
|
}
|
|
}
|
|
|
|
## Create sockets.
|
|
alog '* Connecting to servers...';
|
|
dbug '* Connecting to servers...';
|
|
# Get servers from config.
|
|
my %cservers = conf_get('server');
|
|
# Set the socket hash and select instance.
|
|
our (%SOCKET, $SELECT);
|
|
$SELECT = IO::Select->new();
|
|
# Iterate through each configured server.
|
|
foreach my $cskey (keys %cservers) {
|
|
Lib::Auto::ircsock(\%{$cservers{$cskey}}, $cskey);
|
|
}
|
|
|
|
# Success!
|
|
if (keys %SOCKET) {
|
|
alog '** Success: Connected to server(s).';
|
|
dbug '** Success: Connected to server(s).';
|
|
}
|
|
else {
|
|
err(2, 'No IRC connections -- Exiting program.', 1);
|
|
}
|
|
|
|
# Create core commands.
|
|
API::Std::cmd_add('MODLOAD', 1, 'cfunc.modules', \%Core::Cmd::HELP_MODLOAD, \&Core::Cmd::cmd_modload);
|
|
API::Std::cmd_add('MODUNLOAD', 1, 'cfunc.modules', \%Core::Cmd::HELP_MODUNLOAD, \&Core::Cmd::cmd_modunload);
|
|
API::Std::cmd_add('MODRELOAD', 1, 'cfunc.modules', \%Core::Cmd::HELP_MODRELOAD, \&Core::Cmd::cmd_modreload);
|
|
API::Std::cmd_add('MODLIST', 1, 'cfunc.modules', \%Core::Cmd::HELP_MODLIST, \&Core::Cmd::cmd_modlist);
|
|
API::Std::cmd_add('SHUTDOWN', 2, 'cmd.shutdown', \%Core::Cmd::HELP_SHUTDOWN, \&Core::Cmd::cmd_shutdown);
|
|
API::Std::cmd_add('RESTART', 2, 'cmd.restart', \%Core::Cmd::HELP_RESTART, \&Core::Cmd::cmd_restart);
|
|
API::Std::cmd_add('REHASH', 2, 'cmd.rehash', \%Core::Cmd::HELP_REHASH, \&Core::Cmd::cmd_rehash);
|
|
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};
|
|
}
|
|
}
|
|
}
|
|
# Socket check.
|
|
foreach my $sock ($SELECT->can_read(1)) {
|
|
# Figure out what network is sending us data.
|
|
my $sockid;
|
|
foreach (keys %SOCKET) {
|
|
if ($SOCKET{$_} eq $sock) { $sockid = $_ }
|
|
}
|
|
# Read the data.
|
|
my $idata;
|
|
sysread $sock, $idata, POSIX::BUFSIZ, 0;
|
|
|
|
# Check for the data.
|
|
if (!defined $idata || length($idata) == 0) {
|
|
# Got EOF, close socket
|
|
err(2, "Lost connection to $sockid!", 0);
|
|
$SELECT->remove($sock);
|
|
delete $SOCKET{$sockid};
|
|
API::Std::event_run('on_disconnect', $sockid);
|
|
if (!keys %SOCKET) {
|
|
# No more connections, stop the program.
|
|
API::Std::event_run('on_shutdown');
|
|
dbug '* No more IRC connections, shutting down.';
|
|
alog '* No more IRC connections, shutting down.';
|
|
sleep 1;
|
|
exit;
|
|
}
|
|
next;
|
|
}
|
|
|
|
# Read the buffer.
|
|
my $data .= $idata;
|
|
while ($data =~ s/(.*\n)//) {
|
|
my $line = $1;
|
|
|
|
# Remove the newlines.
|
|
chomp $line;
|
|
# Debug.
|
|
dbug $sockid.' >> '.$line;
|
|
|
|
# Parse data.
|
|
Proto::IRC::ircparse($sockid, $line);
|
|
}
|
|
}
|
|
}
|
|
|
|
###############
|
|
# Subroutines #
|
|
###############
|
|
|
|
# Send data to socket.
|
|
sub socksnd {
|
|
my ($svr, $data) = @_;
|
|
|
|
if (defined $SOCKET{$svr}) {
|
|
syswrite $SOCKET{$svr}, $data."\r\n", POSIX::BUFSIZ, 0;
|
|
dbug "$svr << $data";
|
|
return 1;
|
|
}
|
|
else {
|
|
return;
|
|
}
|
|
}
|
|
|
|
# Load a module.
|
|
sub mod_load {
|
|
my ($module) = @_;
|
|
|
|
if (-e "$bin{mod}/$module.pm") {
|
|
do "$bin{mod}/$module.pm" and return 1;
|
|
}
|
|
else {
|
|
if (-e "$bin{mod}/$module/main.pm") {
|
|
do "$bin{mod}/$module/main.pm" and return 1;
|
|
}
|
|
}
|
|
|
|
my $errs = $EVAL_ERROR;
|
|
while ($errs =~ s/(.*\n)//) {
|
|
my $line = $1;
|
|
$line =~ s/(\r|\n)//g;
|
|
alog 'Error in '.$module.': '.$line;
|
|
dbug 'Error in '.$module.': '.$line;
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
# vim: set ai et sw=4 ts=4:
|