Mini Shell
#!/usr/local/cpanel/3rdparty/bin/perl
package MSP;
use strict;
use warnings;
use Getopt::Long;
use Cpanel::AdvConfig::dovecot ();
use Cpanel::FileUtils::Dir ();
use Cpanel::IONice ();
use Cpanel::IO ();
use Term::ANSIColor qw{:constants};
# Variables
our $VERSION = '2.1';
$Term::ANSIColor::AUTORESET = 1;
our $LOGDIR = q{/var/log/};
our $CPANEL_CONFIG_FILE = q{/var/cpanel/cpanel.config};
our $EXIM_LOCALOPTS_FILE = q{/etc/exim.conf.localopts};
our $DOVECOT_CONF = q{/var/cpanel/conf/dovecot/main};
our $EXIM_MAINLOG = q{exim_mainlog};
our $MAILLOG = q{maillog};
our @RBLS = qw{ b.barracudacentral.org
bl.spamcop.net
dnsbl.sorbs.net
spam.dnsbl.sorbs.net
ips.backscatterer.org
zen.spamhaus.org
};
# Initialize
our $LIMIT = 10;
our $THRESHOLD = 1;
our $ROTATED_LIMIT = 5; # I've seen users with hundreds of rotated logs before, we should safeguard to prevent msp from working against unreasonably large data set
our $OPT_TIMEOUT;
# Options
my %opts;
my ( $all, $auth, $conf, $forwards, $help, $limit, $logdir, $queue, @rbl, $rbllist, $rotated, $rude, $threshold, $verbose );
GetOptions(
\%opts,
'all',
'auth',
'forwards',
'help',
'conf',
'limit=i{1}',
'logdir=s{1}',
'maillog',
'queue',
'rbl=s',
'rbllist',
'rotated',
'rude',
'threshold=i{1}',
'verbose'
) or die("Please see --help\n");
# Make this a modulino
__PACKAGE__->main(@ARGV) unless caller();
1;
sub print_help {
print BOLD BRIGHT_BLUE ON_BLACK "[MSP-$VERSION] ";
print BOLD WHITE ON_BLACK "Mail Status Probe: Mail authentication statistics and configuration checker\n";
print "Usage: ./msp.pl --auth --rotated --rude\n";
print " ./msp.pl --conf --rbl [all|bl.spamcop.net,zen.spamhaus.org]\n\n";
printf( "\t%-15s %s\n", "--help", "print this help message");
# printf( "\t%-15s %s\n", "--all", "run all checks");
printf( "\t%-15s %s\n", "--auth", "print mail authentication statistics");
printf( "\t%-15s %s\n", "--conf", "print mail configuration info (e.g. require_secure_auth, smtpmailgidonly, etc.)");
# printf( "\t%-15s %s\n", "--forwards", "print forward relay statistics");
# printf( "\t%-15s %s\n", "--ignore", "ignore common statistics (e.g. cwd=/var/spool/exim)");
printf( "\t%-15s %s\n", "--limit", "limit statistics checks to n results (defaults to 10, set to 0 for no limit)");
printf( "\t%-15s %s\n", "--logdir", "specify an alternative logging directory, (defaults to /var/log)");
printf( "\t%-15s %s\n", "--maillog", "check maillog for common errors");
printf( "\t%-15s %s\n", "--queue", "print exim queue length");
# printf( "\t%-15s %s\n", "--quiet", "only print alarming information or statistics (requires --threshold)");
printf( "\t%-15s %s\n", "--rbl", "check IP's against provided blacklists(comma delimited)");
printf( "\t%-15s %s\n", "--rbllist", "list available RBL's");
printf( "\t%-15s %s\n", "--rotated", "check rotated exim logs");
printf( "\t%-15s %s\n", "--rude", "forgo nice/ionice settings");
printf( "\t%-15s %s\n", "--threshold", "limit statistics output to n threshold(defaults to 1)");
printf( "\t%-15s %s\n", "--verbose", "display all information");
print "\n";
exit;
}
sub main {
die "MSP must be run as root\n" if ( $< != 0 );
print_help() if ( (!%opts) || ($opts{help}) );
conf_check() if ($opts{conf});
print_exim_queue() if ($opts{queue});
auth_check() if ($opts{auth});
maillog_check() if ($opts{maillog});
rbl_list() if ($opts{rbllist});
rbl_check($opts{rbl}) if ($opts{rbl});
return;
}
sub conf_check {
# Check Tweak Settings
print_bold_white("Checking Tweak Settings...\n");
print "--------------------------\n";
my %cpconf = get_conf( $CPANEL_CONFIG_FILE );
if ( $cpconf{'smtpmailgidonly'} ne 1 ) {
print_warn("Restrict outgoing SMTP to root, exim, and mailman (FKA SMTP Tweak) is disabled!\n");
} elsif ( $opts{verbose} ) {
print_info("Restrict outgoing SMTP to root, exim, and mailman (FKA SMTP Tweak) is enabled\n");
}
if ( $cpconf{'nobodyspam'} ne 1 ) {
print_warn("Prevent “nobody” from sending mail is disabled!\n");
} elsif ( $opts{verbose} ) {
print_info("Prevent “nobody” from sending mail is enabled\n");
}
if ( $cpconf{'popbeforesmtp'} ne 0 ) {
print_warn("Pop-before-SMTP is enabled!\n");
} elsif ( $opts{verbose} ) {
print_info("Pop-before-SMTP is disabled\n");
}
if ( $cpconf{'domainowner_mail_pass'} ne 0 ) {
print_warn("Mail authentication via domain owner password is enabled!\n");
} elsif ( $opts{verbose} ) {
print_info("Mail authentication via domain owner password is disabled\n");
}
print "\n";
# Check Exim Configuration
print_bold_white("Checking Exim Configuration...\n");
print "------------------------------\n";
my %exim_localopts_conf = get_conf( $EXIM_LOCALOPTS_FILE );
if ( $exim_localopts_conf{'allowweakciphers'} ne 0 ) {
print_warn("Allow weak SSL/TLS ciphers is enabled!\n");
} elsif ( $opts{verbose} ) {
print_info("Allow weak SSL/TLS ciphers is disabled\n");
}
if ( $exim_localopts_conf{'require_secure_auth'} ne 1 ) {
print_warn("Require clients to connect with SSL or issue the STARTTLS is disabled!\n");
} elsif ( $opts{verbose} ) {
print_info("Require clients to connect with SSL or issue the STARTTLS is enabled\n");
}
if ( $exim_localopts_conf{'systemfilter'} ne q{/etc/cpanel_exim_system_filter} ) {
print_warn("Custom System Filter File in use: $exim_localopts_conf{'systemfilter'}\n");
} elsif ( $opts{verbose} ) {
print_info("System Filter File is set to the default path: $exim_localopts_conf{'systemfilter'}\n");
}
print "\n";
# Check Dovecot Configuration
print_bold_white("Checking Dovecot Configuration...\n");
print "---------------------------------\n";
my $dovecot = Cpanel::AdvConfig::dovecot::get_config();
if ( $dovecot->{'protocols'} !~ m/imap/ ) {
print_warn("IMAP Protocol is disabled!\n");
}
if ( $dovecot->{'disable_plaintext_auth'} !~ m/no/ ) {
print_warn("Allow Plaintext Authentication is enabled!\n");
} elsif ( $opts{verbose} ) {
print_info("Allow Plaintext Authentication is disabled\n");
}
print "\n";
return;
}
sub auth_check {
my @logfiles;
my @auth_password_hits;
my @auth_sendmail_hits;
my @auth_local_user_hits;
my @subject_hits;
my $logcount = 0;
# Exim regex search strings
my $auth_password_regex = qr{\sA=dovecot_(login|plain):([^\s]+)\s};
my $auth_sendmail_regex = qr{\scwd=([^\s]+)\s};
my $auth_local_user_regex = qr{\sU=([^\s]+)\s.*B=authenticated_local_user};
my $subject_regex = qr{\s<=\s.*T="([^"]+)"\s};
print_bold_white("Checking Mail Authentication statistics...\n");
print "------------------------------------------\n";
# Set logdir, ensure trailing slash, and bail if the provided logdir doesn't exist:
my $logdir = ($opts{logdir}) ? ($opts{logdir}) : $LOGDIR;
$logdir =~ s@/*$@/@;
if (!-d $logdir) {
print_warn("$opts{logdir}: No such file or directory. Skipping spam check...\n\n");
return;
}
# Collect log files
for my $file ( grep { m/^exim_mainlog/ } @{ Cpanel::FileUtils::Dir::get_directory_nodes($logdir) } ) {
if ( $opts{rotated} ) {
if ( ( $file =~ m/mainlog-/ ) && ( $logcount ne $ROTATED_LIMIT ) ) {
push @logfiles, $file;
$logcount++;
}
}
push @logfiles, $file if ( $file =~ m/mainlog$/ );
}
print_warn("Safeguard triggered... --rotated is limited to $ROTATED_LIMIT logs\n") if ( $logcount eq $ROTATED_LIMIT );
# Bail if we can't find any logs
return print_warn("Bailing, no exim logs found...\n\n") if (!@logfiles);
# Set ionice
my %cpconf = get_conf( $CPANEL_CONFIG_FILE );
if ( ( !$opts{rude} ) && ( Cpanel::IONice::ionice( 'best-effort', exists $cpconf{'ionice_import_exim_data'} ? $cpconf{'ionice_import_exim_data'} : 6 ) ) ) {
print("Setting I/O priority to reduce system load: " . Cpanel::IONice::get_ionice() . "\n\n");
setpriority( 0, 0, 19 );
}
my $fh;
lOG: for my $log ( @logfiles ) {
if ( $log =~ /[.]gz$/ ) {
my @cmd = ( qw{ gunzip -c -f }, $logdir . $log );
if ( !open $fh, '-|', @cmd ) {
print_warn("Skipping $logdir/$log: Cannot open pipe to read stdout from command '@{ [ join ' ', @cmd ] }' : $!\n");
next LOG;
}
} else {
if ( !open $fh, '<', $logdir . $log ) {
print_warn("Skipping $logdir/$log: Cannot open for reading $!\n");
next LOG;
}
}
while ( my $block = Cpanel::IO::read_bytes_to_end_of_line( $fh, 65_535 ) ) {
foreach my $line ( split( m{\n}, $block ) ) {
push @auth_password_hits, $2 if ($line =~ $auth_password_regex);
push @auth_sendmail_hits, $1 if ($line =~ $auth_sendmail_regex);
push @auth_local_user_hits, $1 if ($line =~ $auth_local_user_regex);
push @subject_hits, $1 if ($line =~ $subject_regex);
}
}
close($fh);
}
# Print info
print_bold_white("Emails sent via Password Authentication:\n");
if (@auth_password_hits) {
sort_uniq(@auth_password_hits);
} else {
print "None\n";
}
print "\n";
print_bold_white("Directories where email was sent via sendmail/script:\n");
if (@auth_sendmail_hits) {
sort_uniq(@auth_sendmail_hits);
} else {
print "None\n";
}
print "\n";
print_bold_white("Users who sent mail via local SMTP:\n");
if (@auth_local_user_hits) {
sort_uniq(@auth_local_user_hits);
} else {
print "None\n";
}
print "\n";
print_bold_white("Subjects by commonality:\n");
sort_uniq(@subject_hits);
print "\n";
return;
}
sub print_exim_queue {
# Print exim queue length
print_bold_white("Exim Queue: ");
my $queue = get_exim_queue();
if ($queue >= 1000) {
print_bold_red("$queue\n");
} else {
print_bold_green("$queue\n");
}
return;
}
sub get_exim_queue {
my $queue = timed_run_trap_stderr( 10, 'exim', '-bpc');
return $queue;
}
sub rbl_check {
my $rbls = shift;
my @rbls = split( /,/, $rbls);
my @ips;
# Fetch IP's... should we only check mailips? this is more thorough...
# could ignore local through bogon regex?
return unless my $ips = get_ips();
# Uncomment the following for testing positive hits
# push @$ips, qw{ 127.0.0.2 };
# In cPanel 11.84, we switched to the libunbound resolver
my ($cp_numeric_version, $cp_original_version) = get_cpanel_version();
my $libunbound = (version_compare($cp_numeric_version, qw( < 11.84))) ? 0 : 1;
# If "all" is found in the --rbl arg, ignore rest, use default rbl list
# maybe we should append so that user can specify all and ones which are not included in the list?
@rbls = @RBLS if (grep { /\ball\b/i } @rbls);
print_bold_white("Checking IP's against RBL's...\n");
print "------------------------------\n";
foreach my $ip (@$ips) {
print "$ip:\n";
my $ip_rev = join('.', reverse split('\.', $ip));
foreach my $rbl (@rbls) {
printf("\t%-25s ", $rbl);
my $result;
if ($libunbound) {
$result = dns_query("$ip_rev.$rbl", 'A')->[0] || 0;
} else {
# This uses libunbound, which will return an aref, but we can always expect just one result here
$result = dns_query_pre_84("$ip_rev.$rbl", 'A') || 0;
}
if ( $result =~ /\A 127\.0\.0\./xms ) {
print_bold_red("LISTED\n");
} else {
print_bold_green("GOOD\n");
}
}
print "\n";
}
return;
}
sub rbl_list {
print_bold_white("Available RBL's:\n");
print "----------------\n";
foreach my $rbl (@RBLS) {
print "$rbl\n";
}
print "\n";
return;
}
sub maillog_check {
my @logfiles;
my $logcount = 0;
# General
my @out_of_memory;
my $out_of_memory_regex = qr{lmtp\(([\w\.@]+)\): Fatal: \S+: Out of memory};
my $time_backwards = 0;
my $time_backwards_regex = qr{Fatal: Time just moved backwards by \d+ \w+\. This might cause a lot of problems, so I'll just kill myself now};
# Quota errors
my @quota_failed;
my $quotactl_failed_regex = qr{quota-fs: (quotactl\(Q_X?GETQUOTA, [\w/]+\) failed: .+)};
my $ioctl_failed_regex = qr{quota-fs: (ioctl\([\w/]+, Q_QUOTACTL\) failed: .+)};
my $invalid_nfs_regex = qr{quota-fs: (.+ is not a valid NFS device path)};
my $unrespponsive_rpc_regex = qr{quota-fs: (could not contact RPC service on .+)};
my $rquota_remote_regex = qr{quota-fs: (remote( ext)? rquota call failed: .+)};
my $rquota_eacces_regex = qr{quota-fs: (permission denied to( ext)? rquota service)};
my $rquota_compile_regex = qr{quota-fs: (rquota not compiled with group support)};
my $dovecot_compile_regex = qr{quota-fs: (Dovecot was compiled with Linux quota .+)};
my $unrec_code_regex = qr{quota-fs: (unrecognized status code .+)};
# Spamd error
my $pyzor_timeout = 0;
my $pyzor_timeout_regex = qr{Timeout: Did not receive a response from the pyzor server public\.pyzor\.org};
my $pyzor_unreachable = 0;
my $pyzor_unreachable_regex = qr{pyzor: check failed: Cannot connect to public.pyzor.org:24441: IO::Socket::INET: connect: Network is unreachable};
print_bold_white("Checking Maillog for common errors...\n");
print "-----------------------------------------\n";
# Set logdir, ensure trailing slash, and bail if the provided logdir doesn't exist:
my $logdir = ($opts{logdir}) ? ($opts{logdir}) : $LOGDIR;
$logdir =~ s@/*$@/@;
if (!-d $logdir) {
print_warn("$opts{logdir}: No such file or directory. Skipping spam check...\n\n");
return;
}
# Collect log files
for my $file ( grep { m/^maillog/ } @{ Cpanel::FileUtils::Dir::get_directory_nodes($logdir) } ) {
if ( $opts{rotated} ) {
if ( ( $file =~ m/maillog-/ ) && ( $logcount ne $ROTATED_LIMIT ) ) {
push @logfiles, $file;
$logcount++;
}
}
push @logfiles, $file if ( $file =~ m/maillog$/ );
}
print_warn("Safeguard triggered... --rotated is limited to $ROTATED_LIMIT logs\n") if ( $logcount eq $ROTATED_LIMIT );
# Bail if we can't find any logs
return print_warn("Bailing, no maillog found...\n\n") if (!@logfiles);
# Set ionice
my %cpconf = get_conf( $CPANEL_CONFIG_FILE );
if ( ( !$opts{rude} ) && ( Cpanel::IONice::ionice( 'best-effort', exists $cpconf{'ionice_import_exim_data'} ? $cpconf{'ionice_import_exim_data'} : 6 ) ) ) {
print("Setting I/O priority to reduce system load: " . Cpanel::IONice::get_ionice() . "\n\n");
setpriority( 0, 0, 19 );
}
my $fh;
lOG: for my $log ( @logfiles ) {
if ( $log =~ /[.]gz$/ ) {
my @cmd = ( qw{ gunzip -c -f }, $logdir . $log );
if ( !open $fh, '-|', @cmd ) {
print_warn("Skipping $logdir/$log: Cannot open pipe to read stdout from command '@{ [ join ' ', @cmd ] }' : $!\n");
next LOG;
}
} else {
if ( !open $fh, '<', $logdir . $log ) {
print_warn("Skipping $logdir/$log: Cannot open for reading $!\n");
next LOG;
}
}
while ( my $block = Cpanel::IO::read_bytes_to_end_of_line( $fh, 65_535 ) ) {
foreach my $line ( split( m{\n}, $block ) ) {
push @out_of_memory, $1 if ($line =~ $out_of_memory_regex);
push @quota_failed, $1 if ($line =~ $quotactl_failed_regex);
++$pyzor_timeout if ($line =~ $pyzor_timeout_regex);
}
}
close($fh);
}
# Print info
print_bold_white("LMTP quota issues:\n");
if (@quota_failed) {
sort_uniq(@quota_failed);
} else {
print "None\n";
}
print "\n";
print_bold_white("Email accounts triggering LMTP Out of memory:\n");
if (@out_of_memory) {
sort_uniq(@out_of_memory);
} else {
print "None\n";
}
print "\n";
print_bold_white("Timeouts to public.pyzor.org:24441:\n");
if ($pyzor_timeout ne 0) {
print "Pyzor timed out $pyzor_timeout times\n";
} else {
print "None\n";
}
print "\n";
return;
}
sub version_compare {
# example: return if version_compare($ver_string, qw( >= 1.2.3.3 ));
# Must be no more than four version numbers separated by periods and/or underscores.
my ( $ver1, $mode, $ver2 ) = @_;
return if ( !defined($ver1) || ( $ver1 =~ /[^\._0-9]/ ) );
return if ( !defined($ver2) || ( $ver2 =~ /[^\._0-9]/ ) );
# Shamelessly copied the comparison logic out of Cpanel::Version::Compare
my %modes = (
'>' => sub {
return if $_[0] eq $_[1];
return _version_cmp(@_) > 0;
},
'<' => sub {
return if $_[0] eq $_[1];
return _version_cmp(@_) < 0;
},
'==' => sub { return $_[0] eq $_[1] || _version_cmp(@_) == 0; },
'!=' => sub { return $_[0] ne $_[1] && _version_cmp(@_) != 0; },
'>=' => sub {
return 1 if $_[0] eq $_[1];
return _version_cmp(@_) >= 0;
},
'<=' => sub {
return 1 if $_[0] eq $_[1];
return _version_cmp(@_) <= 0;
}
);
return if ( !exists $modes{$mode} );
return $modes{$mode}->( $ver1, $ver2 );
}
sub _version_cmp {
my ( $first, $second ) = @_;
my ( $a1, $b1, $c1, $d1 ) = split /[\._]/, $first;
my ( $a2, $b2, $c2, $d2 ) = split /[\._]/, $second;
for my $ref ( \$a1, \$b1, \$c1, \$d1, \$a2, \$b2, \$c2, \$d2, ) { # Fill empties with 0
$$ref = 0 unless defined $$ref;
}
return $a1 <=> $a2 || $b1 <=> $b2 || $c1 <=> $c2 || $d1 <=> $d2;
}
sub get_cpanel_version {
my $cpanel_version_file = '/usr/local/cpanel/version';
my $numeric_version;
my $original_version;
if ( open my $file_fh, '<', $cpanel_version_file ) {
$original_version = readline($file_fh);
close $file_fh;
}
return ( 'UNKNOWN', 'UNKNOWN' ) unless defined $original_version;
chomp $original_version;
# Parse either 1.2.3.4 or 1.2.3-THING_4 to 1.2.3.4
$numeric_version = join( '.', split( /\.|-[a-zA-Z]+_/, $original_version ) );
$numeric_version = 'UNKNOWN' unless $numeric_version =~ /^\d+\.\d+\.\d+\.\d+$/;
return ( $numeric_version, $original_version );
}
sub get_ips {
my @ips;
return if !load_module_with_fallbacks(
'needed_subs' => [qw{get_detailed_ip_cfg}],
'modules' => [qw{Whostmgr::Ips}],
'fail_warning' => 'can\'t load Whostmgr::Ips',
);
return if !load_module_with_fallbacks(
'needed_subs' => [qw{get_public_ip}],
'modules' => [qw{Cpanel::NAT}],
'fail_warning' => 'can\'t load Cpanel::NAT',
);
my $ipref = Whostmgr::Ips::get_detailed_ip_cfg();
foreach my $iphash ( @{$ipref} ) {
push @ips, Cpanel::NAT::get_public_ip( $iphash->{'ip'} );
}
return \@ips;
}
sub dns_query_pre_84 {
my ($name, $type) = @_;
return if !load_module_with_fallbacks(
'needed_subs' => [qw{new recursive_query}],
'modules' => [qw{Cpanel::DnsRoots::Resolver}],
'fail_warning' => 'can\'t load Cpanel::DnsRoots::Resolver',
);
my $dns = Cpanel::DnsRoots::Resolver->new();
my ($res) = $dns->recursive_query( $name, $type );
return $res;
}
sub dns_query {
my($name, $type) = @_;
return if !load_module_with_fallbacks(
'needed_subs' => [qw{new recursive_queries}],
'modules' => [qw{Cpanel::DNS::Unbound}],
'fail_warning' => 'can\'t load Cpanel::DNS::Unbound',
);
my $dns = Cpanel::DNS::Unbound->new();
my ($res) = $dns->recursive_queries( [ [ $name, $type ] ] )->[0];
return $res->{'decoded_data'} || $res->{result}{data};
}
sub sort_uniq {
my @input = @_;
my %count;
my $line = 1;
$opts{limit} //= $LIMIT;
$opts{threshold} //= $THRESHOLD;
foreach ( @input ) { $count{$_}++; }
for ( sort { $count{$b} <=> $count{$a} } keys %count ) {
if ( $line ne $opts{limit} ) {
printf ("%7d %s\n", "$count{$_}", "$_") if ( $count{$_} >= $opts{threshold} );
$line++;
} else {
printf( "%7d %s\n", "$count{$_}", "$_") if ( $count{$_} >= $opts{threshold} );
last;
}
}
return;
}
# cpanel.confg and exim.conf.localopts
sub get_conf {
my $conf = shift;
my %cpconf;
if ( open( my $cpconf_fh, '<', $conf ) ) {
local $/ = undef;
%cpconf = map { ( split( /=/, $_, 2 ) )[ 0, 1 ] } split( /\n/, readline($cpconf_fh) );
close $cpconf_fh;
return %cpconf;
} else {
print_warn("Could not open file: $conf\n");
}
return;
}
# exec utilities, taken from SSP
sub timed_run_trap_stderr {
my ( $timer, @PROGA ) = @_;
return _timedsaferun( $timer, 1, @PROGA );
}
sub _timedsaferun { # Borrowed from WHM 66 Cpanel::SafeRun::Timed and modified
# We need to be sure to never return undef, return an empty string instead.
my ( $timer, $stderr_to_stdout, @PROGA ) = @_;
return '' if ( substr( $PROGA[0], 0, 1 ) eq '/' && !-x $PROGA[0] );
$timer = $timer ? $timer : 25; # A timer value of 0 means use the default, currently 25.
$timer = $OPT_TIMEOUT ? $OPT_TIMEOUT : $timer;
my $output;
my $complete = 0;
my $pid;
my $fh; # FB-63723: must declare $fh before eval block in order to avoid unwanted implicit waitpid on die
eval {
local $SIG{'__DIE__'} = 'DEFAULT';
local $SIG{'ALRM'} = sub { $output = ''; print RED ON_BLACK 'Timeout while executing: ' . join( ' ', @PROGA ) . "\n"; die; };
alarm($timer);
if ( $pid = open( $fh, '-|' ) ) { ## no critic (BriefOpen)
local $/;
$output = readline($fh);
close($fh);
}
elsif ( defined $pid ) {
open( STDIN, '<', '/dev/null' ); ## no critic (BriefOpen)
if ($stderr_to_stdout) {
open( STDERR, '>&', 'STDOUT' ); ## no critic (BriefOpen)
}
else {
open( STDERR, '>', '/dev/null' ); ## no critic (BriefOpen)
}
exec(@PROGA) or exit 1;
}
else {
print RED ON_BLACK 'Error while executing: [ ' . join( ' ', @PROGA ) . ' ]: ' . $! . "\n";
alarm 0;
die;
}
$complete = 1;
alarm 0;
};
alarm 0;
if ( !$complete && $pid && $pid > 0 ) {
kill( 15, $pid ); #TERM
sleep(2); # Give the process a chance to die 'nicely'
kill( 9, $pid ); #KILL
}
return defined $output ? $output : '';
}
# SUB load_module_with_fallbacks(
# 'modules' => [ 'module1', 'module2', ... ],
# 'needed_subs' => [ 'do_needful', ... ],
# 'fallback' => sub { *do_needful = sub { ... }; return; },
# 'fail_warning' => "Oops, something went wrong, you may want to do something about this",
# 'fail_fatal' => 1,
# );
#
# Input is HASH of options:
# 'modules' => ARRAYREF of SCALAR strings corresponding to module names to attempt to import. These are attempted first.
# 'needed_subs' => ARRAYREF of SCALAR strings corresponding to subroutine names you need defined from the module(s).
# 'fallback' => CODEREF which defines the needed subs manually. Only used if all modules passed in above fail to load. Optional.
# 'fail_warning' => SCALAR string that will convey a message to the user if the module(s) fail to load. Optional.
# 'fail_fatal' => BOOL whether you want to die if you fail to load the needed subs/modules via all available methods. Optional.
#
# Returns the module/namespace that loaded correctly, throws if all available attempts at finding the desired needed_subs subs fail and fail_fatal is passed.
sub load_module_with_fallbacks {
my %opts = @_;
my $namespace_loaded;
foreach my $module2try ( @{ $opts{'modules'} } ) {
# Don't 'require' it if we already have it.
my $inc_entry = join( "/", split( "::", $module2try ) ) . ".pm";
if ( !$INC{$module2try} ) {
local $@;
next if !eval "require $module2try; 1"; ## no critic (StringyEval)
}
# Check if the imported modules 'can' do the job
next if ( scalar( grep { $module2try->can($_) } @{ $opts{'needed_subs'} } ) != scalar( @{ $opts{'needed_subs'} } ) );
# Ok, we're good to go!
$namespace_loaded = $module2try;
last;
}
# Fallback to coderef, but don't do sanity checking on this, as it is presumed the caller "knows what they are doing" if passing a coderef.
if ( !$namespace_loaded ) {
if ( !$opts{'fallback'} || ref $opts{'fallback'} != 'CODE' ) {
print_warn( 'Missing Perl Module(s): ' . join( ', ', @{ $opts{'modules'} } ) . ' -- ' . $opts{'fail_warning'} . " -- Try using /usr/local/cpanel/3rdparty/bin/perl?\n" ) if $opts{'fail_warning'};
die "Stopping here." if $opts{'fail_fatal'};
}
else {
$opts{'fallback'}->();
# call like main::subroutine instead of Name::Space::subroutine
$namespace_loaded = 'main';
}
}
return $namespace_loaded;
}
# pretty prints
sub print_warn {
my $text = shift // '';
return if $text eq '';
print BOLD RED ON_BLACK '[WARN] * ';
print WHITE ON_BLACK "$text";
return;
}
sub print_info {
my $text = shift // '';
return if $text eq '';
print BOLD GREEN ON_BLACK '[INFO] * ';
print WHITE ON_BLACK "$text";
return;
}
sub print_std {
my $text = shift // '';
return if $text eq '';
print BOLD BRIGHT_BLUE ON_BLACK '[MSP] * ';
print BOLD WHITE ON_BLACK "$text";
return;
}
sub print_bold_white {
my $text = shift // '';
return if $text eq '';
print BOLD WHITE ON_BLACK "$text";
return;
}
sub print_bold_red {
my $text = shift // '';
return if $text eq '';
print BOLD RED ON_BLACK "$text";
return;
}
sub print_bold_green {
my $text = shift // '';
return if $text eq '';
print BOLD GREEN ON_BLACK "$text";
return;
}
Zerion Mini Shell 1.0