daf319a402
git-svn-id: https://svn.code.sf.net/p/xcat/code/xcat-core/trunk@15203 8638fb3e-16cb-4fca-ae20-7b5d299a9bcd
2294 lines
79 KiB
Perl
Executable File
2294 lines
79 KiB
Perl
Executable File
#!/usr/bin/env perl
|
|
# IBM(c) 2007 EPL license http://www.eclipse.org/legal/epl-v10.html
|
|
use strict;
|
|
use warnings;
|
|
use Carp qw(cluck confess);
|
|
BEGIN
|
|
{
|
|
$::XCATROOT = $ENV{'XCATROOT'} ? $ENV{'XCATROOT'} : '/opt/xcat';
|
|
# Required when using DB2 as the xCAT database:
|
|
$ENV{'DB2INSTANCE'} = 'xcatdb';
|
|
$ENV{'EXTSHM'} = 'ON';
|
|
|
|
if (defined $ENV{ENABLE_TRACE_CODE}) {
|
|
use lib "$ENV{'XCATROOT'}/lib/perl";
|
|
use lib "/opt/xcat/lib/perl";
|
|
use xCAT::Enabletrace qw(loadtrace filter);
|
|
loadtrace();
|
|
}
|
|
}
|
|
|
|
# if AIX - make sure we include perl 5.8.2 in INC path.
|
|
# Needed to find perl dependencies shipped in deps tarball.
|
|
if ($^O =~ /^aix/i) {
|
|
unshift(@INC, qw(/usr/opt/perl5/lib/5.8.2/aix-thread-multi /usr/opt/perl5/lib/5.8.2 /usr/opt/perl5/lib/site_perl/5.8.2/aix-thread-multi /usr/opt/perl5/lib/site_perl/5.8.2));
|
|
}
|
|
|
|
use lib "$::XCATROOT/lib/perl";
|
|
use Storable qw(freeze thaw);
|
|
use xCAT::Utils;
|
|
use xCAT::TableUtils;
|
|
use xCAT::NetworkUtils;
|
|
use xCAT::MsgUtils;
|
|
use xCAT::xcatd;
|
|
use IO::Uncompress::Gunzip qw/gunzip/;
|
|
use File::Path;
|
|
use Time::HiRes qw(sleep);
|
|
use Thread qw(yield);
|
|
use Fcntl qw/:DEFAULT :flock/;
|
|
use xCAT::Client qw(submit_request);
|
|
my $clientselect = new IO::Select;
|
|
my $sslclients = 0; #THROTTLE
|
|
my $maxsslclients = 64; #default
|
|
my @deferredmsgargs; # hold argumentlist for MsgUtils call until after fork
|
|
#parallelizing logging overhead with real work
|
|
|
|
sub xexit {
|
|
while (wait() > 0) {
|
|
yield;
|
|
}
|
|
exit @_;
|
|
}
|
|
my $dispatch_children=0;
|
|
my %dispatched_children=();
|
|
my $plugin_numchildren=0;
|
|
my %plugin_children;
|
|
my $inet6support;
|
|
if ($^O =~ /^aix/i) { # disable AIX IPV6 TODO
|
|
$inet6support = 0;
|
|
} else {
|
|
$inet6support=eval { require Socket6 };
|
|
}
|
|
if ($inet6support) {
|
|
$inet6support = eval { require IO::Socket::INET6 };
|
|
}
|
|
if ($inet6support) {
|
|
$inet6support = eval { require IO::Socket::SSL; IO::Socket::SSL->import('inet6'); 1; };
|
|
}
|
|
|
|
if ($^O =~ /^linux/i) {
|
|
# Is IPv6 enabled on the MN or SN at all?
|
|
my $ipv6enabled = `ip addr | grep inet6`;
|
|
if (!$ipv6enabled) {
|
|
$inet6support = 0;
|
|
}
|
|
}
|
|
|
|
unless ($inet6support) {
|
|
eval { require Socket };
|
|
eval { require IO::Socket::INET };
|
|
eval { require IO::Socket::SSL; IO::Socket::SSL->import('inet4'); };
|
|
}
|
|
|
|
my $dispatch_requests = 1; # govern whether commands are dispatchable
|
|
use IO::Socket;
|
|
#use IO::Handle;
|
|
use IO::Select;
|
|
use XML::Simple;
|
|
$XML::Simple::PREFERRED_PARSER='XML::Parser';
|
|
use xCAT::Table;
|
|
my $dbmaster;
|
|
use xCAT::ExtTab;
|
|
use Data::Dumper;
|
|
use Getopt::Long;
|
|
use Sys::Syslog qw(:DEFAULT setlogsock);
|
|
openlog("xcatd",,"local4");
|
|
setlogsock(["tcp","unix","stream"]);
|
|
use xCAT::NotifHandler;
|
|
use xCAT_monitoring::monitorctrl;
|
|
|
|
|
|
Getopt::Long::Configure("bundling");
|
|
Getopt::Long::Configure("pass_through");
|
|
|
|
use Storable qw(dclone);
|
|
use POSIX qw(WNOHANG setsid :errno_h);
|
|
my $pidfile;
|
|
my $foreground;
|
|
GetOptions(
|
|
'pidfile|p=s' => \$pidfile,
|
|
'foreground|f' => \$foreground
|
|
);
|
|
|
|
unless ($pidfile) {
|
|
$pidfile = "/var/run/xcatd.pid";
|
|
}
|
|
|
|
#start syslog if it is not up
|
|
if (xCAT::Utils->isLinux()) {
|
|
my $init_file="/etc/init.d/syslog";
|
|
if (-f "/etc/fedora-release") {
|
|
$init_file="/etc/init.d/rsyslog";
|
|
}
|
|
if ( -x $init_file ) {
|
|
my $result=`$init_file status 2>&1`;
|
|
if ($result !~ /running/i) {
|
|
`$init_file start`;
|
|
}
|
|
}
|
|
} else {
|
|
my $result=`lssrc -s syslogd 2>&1`;
|
|
if ($result !~ /active/i) {
|
|
`startsrc -s syslogd`;
|
|
}
|
|
}
|
|
|
|
|
|
my $quit = 0;
|
|
my $port;
|
|
my $sport;
|
|
my $domain;
|
|
my $xcatdir;
|
|
my $sitetab;
|
|
my $retries = 0;
|
|
# The database initialization may take some time in the system boot scenario
|
|
# wait for a while for the database initialization
|
|
while (!($sitetab=xCAT::Table->new('site')) && $retries < 200)
|
|
{
|
|
print ("Can not open basic site table for configuration, waiting the database to be initialized.\n");
|
|
sleep 1;
|
|
$retries++;
|
|
}
|
|
unless ($sitetab) {
|
|
xCAT::MsgUtils->message("S","ERROR: Unable to open basic site table for configuration");
|
|
die;
|
|
}
|
|
|
|
my ($tmp) = $sitetab->getAttribs({'key'=>'xcatdport'},'value');
|
|
unless ($tmp) {
|
|
xCAT::MsgUtils->message("S","ERROR:Need xcatdport defined in site table, try chtab key=xcatdport site.value=3001");
|
|
die;
|
|
}
|
|
$port = $tmp->{value};
|
|
($tmp) = $sitetab->getAttribs({'key'=>'xcatiport'},'value');
|
|
if ($tmp) {
|
|
$sport = $tmp->{value};
|
|
}
|
|
($tmp) = $sitetab->getAttribs({'key'=>'xcatmaxconnections'},'value');
|
|
if ($tmp and $tmp->{value}) { $maxsslclients = $tmp->{value}; }
|
|
|
|
|
|
my $plugins_dir=$::XCATROOT.'/lib/perl/xCAT_plugin';
|
|
($tmp) = $sitetab->getAttribs({'key'=>'xcatconfdir'},'value');
|
|
$xcatdir = (($tmp and $tmp->{value}) ? $tmp->{value} : "/etc/xcat");
|
|
|
|
$sitetab->close;
|
|
my $progname;
|
|
my $pipeexpected;
|
|
$SIG{PIPE} = sub {
|
|
if ($pipeexpected) { return; }
|
|
confess "SIGPIPE $$progname encountered a broken pipe (probably Ctrl-C by client)";
|
|
};
|
|
$progname = \$0;
|
|
|
|
#create and update any xCAt tables
|
|
#create the user defined external database tables if they do not exist.
|
|
#update the tables if there are schema changes.
|
|
# runsqlcmd runs sql scripts provided by the user in
|
|
# /opt/xcat/lib/perl/xCAT_schema
|
|
|
|
if (xCAT::Utils->isMN()) {
|
|
# update schema for xCAT tables
|
|
my @table;
|
|
push @table,xCAT::Table->getTableList();
|
|
foreach my $tablename (@table) {
|
|
my $tablelisttab=xCAT::Table->new($tablename,-create=>1);
|
|
my $rc= $tablelisttab->updateschema();
|
|
$tablelisttab->close;
|
|
}
|
|
# update schema for user tables
|
|
xCAT::ExtTab->updateTables();
|
|
# run any sql commands
|
|
`$::XCATROOT/sbin/runsqlcmd`;
|
|
}
|
|
|
|
my $startupchild;
|
|
my $startupparent;
|
|
sub daemonize {
|
|
chdir('/');
|
|
umask 0022;
|
|
my $pid;
|
|
socketpair($startupparent,$startupchild,AF_UNIX,SOCK_STREAM,PF_UNSPEC);
|
|
if (! defined($pid = xCAT::Utils->xfork)) {
|
|
xCAT::MsgUtils->message("S","Can't fork: $!");
|
|
die;
|
|
}
|
|
if ($pid) {
|
|
close($startupparent); # the launcher only wants to examing startupchild
|
|
if ($pidfile) {
|
|
open(PFILE, '>', $pidfile);
|
|
print PFILE $pid;
|
|
close (PFILE);
|
|
} else {
|
|
xCAT::MsgUtils->message("S","xCATd starting as PID $pid");
|
|
}
|
|
my $result=<$startupchild>;
|
|
chomp($result);
|
|
unless ($result) { exit (1); }
|
|
if ($result ne "SUCCESS") {
|
|
xCAT::MsgUtils->message("S","xCATd failed to start: $result");
|
|
exit(1);
|
|
}
|
|
exit;
|
|
}
|
|
close($startupchild); # only want child to report up to parent...
|
|
if (! open STDIN, '/dev/null') {
|
|
print $startupparent "Can't read /dev/null: $!\n";
|
|
die;
|
|
}
|
|
open STDOUT, '>/dev/null';
|
|
open STDERR, '>/dev/null';
|
|
$0='xcatd';
|
|
$progname = \$0;
|
|
if (! setsid) {
|
|
xCAT::MsgUtils->message("S","Can't start new session");
|
|
print $startupparent "Can't start new session\n";
|
|
die;
|
|
}
|
|
}
|
|
|
|
my %cmd_handlers;
|
|
sub do_installm_service {
|
|
unless ($sport) { return; }
|
|
#This function servers as a handler for messages from installing nodes
|
|
my $socket;
|
|
my $installpidfile;
|
|
my $retry=1;
|
|
$SIG{USR2} = sub {
|
|
if ($socket) { #do not mess with pid file except when we still have the socket.
|
|
unlink("/var/run/xcat/installservice.pid"); close($socket); $quit=1;
|
|
xCAT::MsgUtils->message("S","xcatd install monitor $$ quiescing");
|
|
}
|
|
};
|
|
if ($inet6support) {
|
|
$socket = IO::Socket::INET6->new(LocalPort=>$sport,
|
|
Proto => 'tcp',
|
|
ReuseAddr => 1,
|
|
Listen => 8192);
|
|
} else {
|
|
$socket = IO::Socket::INET->new(LocalPort=>$sport,
|
|
Proto => 'tcp',
|
|
ReuseAddr => 1,
|
|
Listen => 8192);
|
|
}
|
|
if (not $socket and open($installpidfile,"<","/var/run/xcat/installservice.pid")) { #if we couldn't get the socket, go to pid to figure out current owner
|
|
#TODO: lsof or similar may be a more accurate measure
|
|
my $pid = <$installpidfile>;
|
|
if ($pid) {
|
|
$retry=100; #grace period for old instance to get out of the way, 5 seconds
|
|
kill 12,$pid;
|
|
yield(); # let peer have a shot at closure
|
|
}
|
|
close($installpidfile);
|
|
}
|
|
while (not $socket and $retry) {
|
|
$retry--;
|
|
if ($inet6support) {
|
|
$socket = IO::Socket::INET6->new(LocalPort=>$sport,
|
|
Proto => 'tcp',
|
|
ReuseAddr => 1,
|
|
Listen => 8192);
|
|
} else {
|
|
$socket = IO::Socket::INET->new(LocalPort=>$sport,
|
|
Proto => 'tcp',
|
|
ReuseAddr => 1,
|
|
Listen => 8192);
|
|
}
|
|
sleep 0.05; #up to 50 ms outage possible
|
|
}
|
|
|
|
unless ($socket) {
|
|
xCAT::MsgUtils->message("S","xcatd unable to open install monitor services on $sport");
|
|
die;
|
|
}
|
|
#we have the socket, now we claim the pid file as our own
|
|
open($installpidfile,">","/var/run/xcat/installservice.pid"); #if here, everyone else has unlinked installservicepid or doesn't care
|
|
print $installpidfile $$;
|
|
close($installpidfile);
|
|
until ($quit) {
|
|
$SIG{ALRM} = sub { xCAT::MsgUtils->message("S","XCATTIMEOUT"); die; };
|
|
my $conn;
|
|
next unless $conn = $socket->accept;
|
|
|
|
my @clients;
|
|
if ($inet6support) {
|
|
@clients = gethostbyaddr($conn->peeraddr,AF_INET6);
|
|
unless (@clients) { @clients = gethostbyaddr($conn->peeraddr,AF_INET); }
|
|
} else {
|
|
@clients = gethostbyaddr($conn->peeraddr,AF_INET);
|
|
}
|
|
|
|
my $validclient=0;
|
|
my $node;
|
|
my $domain;
|
|
|
|
my $nd = xCAT::NetworkUtils->getNodeDomains(\@clients);
|
|
my %nodedomains = %{$nd};
|
|
|
|
foreach my $client (@clients) {
|
|
$domain = $nodedomains{$client};
|
|
$client =~ s/\..*//;
|
|
if ($domain) {
|
|
$client =~ s/\.$domain//;
|
|
} else {
|
|
$client =~ s/\..*//;
|
|
}
|
|
#ensure this is coming from a node IP at least
|
|
($node) = noderange($client);
|
|
if ($node) { #Means the source isn't valid
|
|
$validclient=1;
|
|
last;
|
|
}
|
|
}
|
|
|
|
unless ($validclient) {
|
|
close($conn);
|
|
next;
|
|
}
|
|
my $tftpdir = xCAT::TableUtils->getTftpDir();
|
|
eval {
|
|
alarm(2);
|
|
print $conn "ready\n";
|
|
while (my $text = <$conn>) {
|
|
alarm(0);
|
|
print $conn "done\n";
|
|
$text =~ s/\r//g;
|
|
if ($text =~ /next/) {
|
|
my %request = (
|
|
command => [ 'nodeset' ],
|
|
node => [ $node ],
|
|
arg => [ 'next' ],
|
|
);
|
|
#node should be blocked, race condition may occur otherwise
|
|
#my $pid=xCAT::Utils->xfork();
|
|
#unless ($pid) { #fork off the nodeset and potential slowness
|
|
plugin_command(\%request,undef,\&build_response);
|
|
# exit(0);
|
|
#}
|
|
close($conn);
|
|
} elsif ($text =~ /installstatus/) {
|
|
my @tmpa=split(' ', $text);
|
|
for (my $i = 1; $i <= @tmpa-1; $i++) {
|
|
my $newstat=$tmpa[$i];
|
|
my %request = (
|
|
command => [ 'updatenodestat' ],
|
|
node => [ $node ],
|
|
arg => [ "$newstat" ],
|
|
);
|
|
#node should be blocked, race condition may occur otherwise
|
|
#my $pid=xCAT::Utils->xfork();
|
|
#unless ($pid) { #fork off the nodeset and potential slowness
|
|
plugin_command(\%request,undef,\&build_response);
|
|
# exit(0);
|
|
#}
|
|
}
|
|
close($conn);
|
|
} elsif ($text =~ /^unlocktftpdir/) { #TODO: only nodes in install state should be allowed
|
|
mkpath("$tftpdir/xcat/$node");
|
|
chmod 01777,"$tftpdir/xcat/$node";
|
|
chmod 0666,glob("$tftpdir/xcat/$node/*");
|
|
close($conn);
|
|
} elsif ($text =~ /locktftpdir/) {
|
|
chmod 0755,"$tftpdir/xcat/$node";
|
|
chmod 0644,glob("$tftpdir/xcat/$node/*");
|
|
} elsif ($text =~ /^getpostscript/) {
|
|
my $reply =plugin_command({command=>['getpostscript'],_xcat_clienthost=>[$node]},undef,\&build_response);
|
|
foreach (@{$reply->{data}}) {
|
|
print $conn $_;
|
|
}
|
|
print $conn "#END OF SCRIPT\n";
|
|
close($conn);
|
|
} elsif ($text =~ /^syncfiles/) {
|
|
plugin_command({command=>['syncfiles'],_xcat_clienthost=>[$node]},undef,\&build_response);
|
|
print $conn "syncfiles done\n";
|
|
close($conn);
|
|
} elsif ($text =~ /^setiscsiparms/) {
|
|
$text =~ s/^setiscsiparms\s+//;
|
|
my $kname;
|
|
my $iname;
|
|
my $kcmdline;
|
|
($kname,$iname,$kcmdline) = split(/\s+/,$text,3);
|
|
chomp($kcmdline);
|
|
my $bptab = xCAT::Table->new('bootparams',-create=>1);
|
|
$bptab->setNodeAttribs($node,{kernel=>"xcat/$node/$kname",initrd=>"xcat/$node/$iname",kcmdline=>$kcmdline});
|
|
my $iscsitab = xCAT::Table->new('iscsi',-create=>1);
|
|
$iscsitab->setNodeAttribs($node,{kernel=>"xcat/$node/$kname",initrd=>"xcat/$node/$iname",kcmdline=>$kcmdline});
|
|
my $chaintab = xCAT::Table->new('chain',-create=>1);
|
|
$chaintab->setNodeAttribs($node,{currstate=>'iscsiboot',currchain=>'netboot'});
|
|
$bptab->close;
|
|
$chaintab->close;
|
|
undef $bptab;
|
|
undef $chaintab;
|
|
my %request = (
|
|
command => [ 'nodeset' ],
|
|
node => [ $node ],
|
|
arg => [ 'enact' ],
|
|
);
|
|
my $pid=xCAT::Utils->xfork();
|
|
unless ($pid) { #fork off the nodeset and potential slowness
|
|
plugin_command(\%request,undef,\&build_response);
|
|
xexit(0);
|
|
}
|
|
} elsif ($text =~ /hpcbootstatus/) {
|
|
$text =~ s/hpcbootstatus //;
|
|
chomp $text;
|
|
my %request = (
|
|
command => [ 'updatenodeappstat' ],
|
|
node => [ $node ],
|
|
arg => [ "$text" ],
|
|
);
|
|
|
|
plugin_command(\%request,undef,\&build_response);
|
|
close($conn);
|
|
} elsif ($text =~ /basecustremv/) {
|
|
|
|
$text =~ s/basecustremv //;
|
|
chomp $text;
|
|
# remove the BASECUST_REMOVAL line from /tftpboot/hostname.info file
|
|
my $myfile = "/tftpboot/$text" . ".info";
|
|
`/usr/bin/cat $myfile | /usr/bin/sed "/BASECUST_REMOVAL/d">/tmp/$text.nimtmp`;
|
|
`/usr/bin/mv /tmp/$text.nimtmp $myfile`;
|
|
close($conn);
|
|
}
|
|
alarm(2);
|
|
}
|
|
alarm(0);
|
|
};
|
|
if ($@) {
|
|
if ($@ =~ /XCATTIMEOUT/) {
|
|
xCAT::MsgUtils->message("S","xcatd installmonitor timed out talking to $node");
|
|
} else {
|
|
xCAT::MsgUtils->message("S","xcatd: possible BUG encountered by xCAT install monitor service: ".$@);
|
|
}
|
|
}
|
|
}
|
|
if (open($installpidfile,"<","/var/run/xcat/installservice.pid")) {
|
|
my $pid = <$installpidfile>;
|
|
if ($pid == $$) { #if our pid, unlink the file, otherwise, we managed to see the pid after someone else created it
|
|
unlink("/var/run/xcat/installservice.pid");
|
|
}
|
|
close($installpidfile);
|
|
}
|
|
}
|
|
|
|
|
|
sub do_udp_service { #This function opens up a UDP port
|
|
#It will do similar to the standard service, except:
|
|
#-Obviously, unencrypted and messages are not guaranteed
|
|
#-For that reason, more often than not plugins designed with
|
|
#-this method will not expect to have a callback
|
|
#Also, this throttles to handle one message at a time, so no forking either
|
|
#Explicitly, to handle whatever operations nodes periodically send during discover state
|
|
#Could be used for heartbeating and such as desired
|
|
$dispatch_requests=0;
|
|
my $udppidfile;
|
|
my $retry=1;
|
|
my $socket;
|
|
$SIG{USR2} = sub {
|
|
if ($socket) {
|
|
#only clear out pid file when we still have socket.
|
|
unlink("/var/run/xcat/udpservice.pid"); close($socket); $quit=1; $socket=0;
|
|
xCAT::MsgUtils->message("S","xcatd udp service $$ quiescing");
|
|
}
|
|
};
|
|
if ($inet6support) {
|
|
$socket = IO::Socket::INET6->new(LocalPort => $port,
|
|
Proto => 'udp',
|
|
Domain => AF_INET);
|
|
} else {
|
|
$socket = IO::Socket::INET->new(LocalPort => $port,
|
|
Proto => 'udp',
|
|
Domain => AF_INET);
|
|
}
|
|
if (not $socket and open($udppidfile,"<","/var/run/xcat/udpservice.pid")) {
|
|
my $pid = <$udppidfile>;
|
|
if ($pid) {
|
|
$retry=100; #grace period for old instance to get out of the way, 5 seconds
|
|
kill 12,$pid;
|
|
yield(); # let peer have a shot at closure
|
|
}
|
|
close($udppidfile);
|
|
}
|
|
my $select = new IO::Select;
|
|
while (not $socket and $retry) {
|
|
if ($inet6support) {
|
|
$socket = IO::Socket::INET6->new(LocalPort => $port,
|
|
Proto => 'udp',
|
|
Domain => AF_INET);
|
|
} else {
|
|
$socket = IO::Socket::INET->new(LocalPort => $port,
|
|
Proto => 'udp',
|
|
Domain => AF_INET);
|
|
}
|
|
sleep 0.05;
|
|
}
|
|
|
|
openlog("xCAT UDP",'','local4');
|
|
unless ($socket) {
|
|
xCAT::MsgUtils->message("S","xCAT UDP service unable to open port $port: $!");
|
|
closelog();
|
|
die "Unable to start UDP on $port";
|
|
}
|
|
#only take udp pid if we get the socket
|
|
open($udppidfile,">","/var/run/xcat/udpservice.pid"); #if here, everyone else has unlinked udpservicepid or doesn't care
|
|
print $udppidfile $$;
|
|
close($udppidfile);
|
|
$select->add($socket);
|
|
my $data;
|
|
my $part;
|
|
my $sport;
|
|
my $client;
|
|
my $peerhost;
|
|
my %packets;
|
|
my $actualpid=$$;
|
|
until ($quit) {
|
|
eval {
|
|
while (1) {
|
|
unless ($actualpid == $$) { #This really should be impossible now...
|
|
xCAT::MsgUtils->message("S","xcatd: Something absolutely ludicrous happpened, xCAT developers think this message is impossible to see, post if you see it, fork bomb averted");
|
|
exit(1);
|
|
}
|
|
until ($select->can_read(5)) { #Wait for data
|
|
if ($quit) { last; };
|
|
populate_site_hash();
|
|
yield;
|
|
}
|
|
while ($select->can_read(0)) { #Pull all buffer data that can be pulled
|
|
$part = $socket->recv($data,1500);
|
|
($sport,$client) = sockaddr_in($part);
|
|
if ($sport < 1000) { #Only remember udp packets from privileged ports
|
|
$packets{inet_ntoa($client)} = [$part,$data];
|
|
}
|
|
}
|
|
foreach my $pkey (keys %packets) {
|
|
($sport,$client) = sockaddr_in($packets{$pkey}->[0]);
|
|
$data=$packets{$pkey}->[1];
|
|
$peerhost=gethostbyaddr($client,AF_INET);
|
|
$peerhost .="\n";
|
|
if ($data =~ /^\037\213/) { #per rfc 1952, these two bytes are gzip, and they are invalid for
|
|
#xcatrequest xml, so go ahead and decompress it
|
|
my $bigdata;
|
|
gunzip \$data => \$bigdata;
|
|
$data = $bigdata
|
|
}
|
|
my $req = eval { XMLin($data, SuppressEmpty=>undef,ForceArray=>1) };
|
|
if ($req and $req->{command} and ($req->{command}->[0] eq "findme")) {
|
|
$req->{'_xcat_clienthost'}=gethostbyaddr($client,AF_INET);
|
|
$req->{'_xcat_clientip'}=inet_ntoa($client);
|
|
$req->{'_xcat_clientport'}=$sport;
|
|
if (defined($cmd_handlers{"findme"}) and xCAT::NetworkUtils->nodeonmynet(inet_ntoa($client))) { #only discover from ips that appear to be on a managed network
|
|
xCAT::MsgUtils->message("S","xcatd: Processing discovery request from ".$req->{'_xcat_clientip'});
|
|
$req->{cacheonly}->[0] = 1;
|
|
plugin_command($req,undef,\&build_response);
|
|
if ($req->{cacheonly}->[0]) {
|
|
delete $req->{cacheonly};
|
|
plugin_command($req,undef,\&build_response);
|
|
#if ($req) {
|
|
# $req->{cacheonly}->[0] = 1;
|
|
# $req->{checkallmacs}->[0] = 1;
|
|
# plugin_command($req,undef,\&convey_response);
|
|
# }
|
|
|
|
}
|
|
} else {
|
|
xCAT::MsgUtils->message("S","xcatd: Skipping discovery from ".inet_ntoa($client)." because we either have no discovery plugins or the client address does not match an IP network that xCAT is managing");
|
|
}
|
|
}
|
|
if ($quit) { last; }
|
|
while ($select->can_read(0)) { #grab any incoming requests during run
|
|
$part = $socket->recv($data,1500);
|
|
($sport,$client) = sockaddr_in($part);
|
|
$packets{inet_ntoa($client)} = [$part,$data];
|
|
}
|
|
#Some of those 'future' packets might be stale dupes of this packet, so...
|
|
delete $packets{$pkey}; #Delete any duplicates of current packet
|
|
}
|
|
if ($quit) { last; }
|
|
}
|
|
};
|
|
if ($@) {
|
|
xCAT::MsgUtils->message("S","xcatd: possible BUG encountered by xCAT UDP service: ".$@);
|
|
}
|
|
unless ($actualpid == $$) { #We should absolutely never be here, exponential growth from a plugin crash.
|
|
xCAT::MsgUtils->message("S","xcatd: Something ludicrous happpened, bailing to avoid fork bomb, double check perl XS modules like 'net-snmp-perl'");
|
|
exit 1;
|
|
}
|
|
}
|
|
if (open($udppidfile,"<","/var/run/xcat/udpservice.pid")) {
|
|
my $pid = <$udppidfile>;
|
|
if ($pid == $$) { #if our pid, unlink the file, otherwise, we managed to see the pid after someone else created it
|
|
unlink("/var/run/xcat/udpservice.pid");
|
|
}
|
|
close($udppidfile);
|
|
}
|
|
}
|
|
|
|
|
|
|
|
sub scan_plugins {
|
|
my $serialdest = shift;
|
|
my @plugins=glob($plugins_dir."/*.pm");
|
|
foreach (@plugins) {
|
|
/.*\/([^\/]*).pm$/;
|
|
my $modname = $1;
|
|
unless ( eval { require "$_" }) {
|
|
xCAT::MsgUtils->message("S","Error loading module ".$_." ...skipping");
|
|
|
|
next;
|
|
}
|
|
no strict 'refs';
|
|
my $cmd_adds;
|
|
eval {
|
|
$cmd_adds=${"xCAT_plugin::".$modname."::"}{handled_commands}->();
|
|
};
|
|
if ($@) {
|
|
xCAT::MsgUtils->message("S","Error registering module ".$_." ...skipping");
|
|
next;
|
|
}
|
|
foreach (keys %$cmd_adds) {
|
|
my $value = $_;
|
|
my @modulehandlerinfos;
|
|
if (ref $cmd_adds->{$_}) {
|
|
@modulehandlerinfos=@{$cmd_adds->{$value}};
|
|
} else {
|
|
@modulehandlerinfos=($cmd_adds->{$value});
|
|
}
|
|
unless (defined($cmd_handlers{$value})) {
|
|
$cmd_handlers{$value} = [ ];
|
|
}
|
|
# Add every plugin registration to cmd_handlers
|
|
foreach (@modulehandlerinfos) {
|
|
push @{$cmd_handlers{$value}},[$modname,$_];
|
|
}
|
|
}
|
|
}
|
|
foreach (@plugins) {
|
|
no strict 'refs';
|
|
/.*\/([^\/]*).pm$/;
|
|
my $modname = $1;
|
|
unless (defined(${"xCAT_plugin::".$modname."::"}{init_plugin})) {
|
|
next;
|
|
}
|
|
${"xCAT_plugin::".$modname."::"}{init_plugin}->(\&do_request);
|
|
}
|
|
if ($serialdest) { print $serialdest freeze(\%cmd_handlers); };
|
|
}
|
|
|
|
my $pid_init;
|
|
my $readpipe;
|
|
my $writepipe;
|
|
if (socketpair($readpipe, $writepipe,AF_UNIX,SOCK_STREAM,PF_UNSPEC)) {
|
|
$pid_init = xCAT::Utils->xfork;
|
|
} else {
|
|
xCAT::MsgUtils->message("S", "socketpair failed: $!");
|
|
}
|
|
if (defined $pid_init) {
|
|
if ($pid_init) { #parent, just sit and wait..
|
|
close($writepipe);
|
|
my $serialized_handlers="";
|
|
while ($serialized_handlers !~ /xCATINITDoneWithHandlersNow/) {
|
|
$serialized_handlers.=<$readpipe>;
|
|
}
|
|
%cmd_handlers=%{thaw($serialized_handlers)};
|
|
} else {
|
|
scan_plugins($writepipe);
|
|
print $writepipe "\nxCATINITDoneWithHandlersNow\n";
|
|
exit(0);
|
|
}
|
|
} else {
|
|
print "Unable to branch the initialization portion, will use more memory\n";
|
|
scan_plugins();
|
|
}
|
|
|
|
|
|
unless (xCAT::Utils->isLinux()) { # messes up the output of the service cmd on linux
|
|
eval {
|
|
xCAT::MsgUtils->message("S","xCATd: service starting");
|
|
};
|
|
}
|
|
if ($@) {
|
|
print "ERROR: $@";
|
|
xexit;
|
|
}
|
|
unless ($foreground) {
|
|
daemonize;
|
|
}
|
|
|
|
$dbmaster=xCAT::Table::init_dbworker;
|
|
my $CHILDPID=0; #Global for reapers
|
|
my %immediatechildren;
|
|
sub generic_reaper {
|
|
while (($CHILDPID=waitpid(-1,WNOHANG)) > 0) {
|
|
yield;
|
|
}
|
|
$SIG{CHLD} = \&generic_reaper;
|
|
}
|
|
|
|
sub ssl_reaper {
|
|
while (($CHILDPID=waitpid(-1,WNOHANG)) > 0) {
|
|
if ($immediatechildren{$CHILDPID}) {
|
|
delete $immediatechildren{$CHILDPID};
|
|
}
|
|
$sslclients--;
|
|
}
|
|
$SIG{CHLD} = \&ssl_reaper;
|
|
}
|
|
|
|
sub dispatch_reaper {
|
|
while (($CHILDPID =waitpid(-1, WNOHANG)) > 0) {
|
|
if ($dispatched_children{$CHILDPID}) {
|
|
delete $dispatched_children{$CHILDPID};
|
|
$dispatch_children--;
|
|
}
|
|
}
|
|
$SIG{CHLD} = \&dispatch_reaper;
|
|
}
|
|
|
|
sub plugin_reaper {
|
|
while (($CHILDPID = waitpid(-1, WNOHANG)) > 0) {
|
|
if ($plugin_children{$CHILDPID}) {
|
|
delete $plugin_children{$CHILDPID};
|
|
$plugin_numchildren--;
|
|
}
|
|
}
|
|
$SIG{CHLD} = \&plugin_reaper;
|
|
}
|
|
|
|
$SIG{CHLD} = \&generic_reaper;
|
|
|
|
my $pid_UDP;
|
|
my $pid_MON;
|
|
$SIG{TERM} = $SIG{INT} = sub {
|
|
#printf("Asked to quit...\n");
|
|
$quit++;
|
|
foreach (keys %dispatched_children) {
|
|
kill 2, $_;
|
|
}
|
|
foreach (keys %plugin_children) {
|
|
kill 2, $_;
|
|
}
|
|
if ($pid_UDP) {
|
|
kill 2, $pid_UDP;
|
|
}
|
|
if ($pid_MON) {
|
|
kill 2, $pid_MON;
|
|
kill 12, $pid_MON;
|
|
}
|
|
xCAT::Table::shut_dbworker;
|
|
if ($dbmaster) {
|
|
kill 2, $dbmaster;
|
|
}
|
|
$SIG{ALRM} = sub { xexit 0; }; #die "Did not close out in time for 5 second grace period"; };
|
|
alarm(2);
|
|
};
|
|
|
|
$pid_UDP = xCAT::Utils->xfork;
|
|
if (! defined $pid_UDP) {
|
|
xCAT::MsgUtils->message("S", "Unable to fork for UDP/TCP");
|
|
die;
|
|
}
|
|
unless ($pid_UDP) {
|
|
$$progname="xcatd: UDP listener";
|
|
do_udp_service;
|
|
xexit(0);
|
|
}
|
|
$pid_MON = xCAT::Utils->xfork;
|
|
if (! defined $pid_MON) {
|
|
xCAT::MsgUtils->message("S", "Unable to fork installmonitor");
|
|
die;
|
|
}
|
|
unless ($pid_MON) {
|
|
$$progname="xcatd: install monitor";
|
|
do_installm_service;
|
|
xexit(0);
|
|
}
|
|
$$progname="xcatd: SSL listener";
|
|
|
|
# Enable the signals for the subroutine calling trace
|
|
$SIG{TRAP} = sub {
|
|
if (-f "/tmp/xcatcallingtrace.flag") {
|
|
if (open (TRACEFLAG, "</tmp/xcatcallingtrace.flag")) {
|
|
my $traceflag = <TRACEFLAG>;
|
|
if($traceflag == 1) {
|
|
&enable_callingtrace;
|
|
print "enabled calling trace\n";
|
|
} else {
|
|
&disable_callingtrace;
|
|
print "dislabled calling trace\n";
|
|
}
|
|
close (TRACEFLAG);
|
|
}
|
|
}
|
|
};
|
|
|
|
#setup signal in NotifHandler so that the cache can be updated
|
|
xCAT::NotifHandler::setup($$, $dbmaster);
|
|
|
|
#start the monitoring process
|
|
xCAT_monitoring::monitorctrl::start($$);
|
|
|
|
my $peername;
|
|
my $ssltimeout;
|
|
my $retry=1;
|
|
openlog("xCAT SSL","","local4");
|
|
my $listener;
|
|
my $mainpidfile;
|
|
$SIG{USR2} = sub {
|
|
if ($listener) {
|
|
unlink("/var/run/xcat/mainservice.pid"); close($listener); $quit=1; $listener=0;
|
|
xCAT::MsgUtils->message("S","xcatd main service $$ quiescing");
|
|
}
|
|
};
|
|
if ($inet6support) {
|
|
$listener = IO::Socket::INET6->new(
|
|
LocalPort => $port,
|
|
Listen => 8192,
|
|
Reuse => 1,
|
|
);
|
|
} else {
|
|
$listener = IO::Socket::INET->new(
|
|
LocalPort => $port,
|
|
Listen => 8192,
|
|
Reuse => 1,
|
|
);
|
|
}
|
|
if (not $listener and open($mainpidfile,"<","/var/run/xcat/mainservice.pid")) {
|
|
my $pid = <$mainpidfile>;
|
|
if ($pid) {
|
|
$retry=100; #grace period for old instance to get out of the way, 5 seconds
|
|
kill 12,$pid;
|
|
yield(); # let peer have a shot at closure
|
|
}
|
|
close($mainpidfile);
|
|
}
|
|
while (not $listener and $retry) {
|
|
$retry--;
|
|
if ($inet6support) {
|
|
$listener = IO::Socket::INET6->new(
|
|
LocalPort => $port,
|
|
Listen => 8192,
|
|
Reuse => 1,
|
|
);
|
|
} else {
|
|
$listener = IO::Socket::INET->new(
|
|
LocalPort => $port,
|
|
Listen => 8192,
|
|
Reuse => 1,
|
|
);
|
|
}
|
|
sleep(0.05);
|
|
}
|
|
my $listenwatcher = IO::Select->new($listener);
|
|
|
|
unless ($listener) {
|
|
kill 2, $pid_UDP;
|
|
kill 2, $pid_MON;
|
|
xCAT::Table::shut_dbworker;
|
|
if ($dbmaster) {
|
|
kill 2, $dbmaster;
|
|
}
|
|
xCAT::MsgUtils->message("S","xCAT service unable to open SSL services on $port: $!");
|
|
closelog();
|
|
if ($startupparent) {
|
|
print $startupparent "Unable to perform socket takeover from existing xCAT instance\n";
|
|
}
|
|
die "ERROR:Unable to start xCAT service on port $port.";
|
|
}
|
|
if ($startupparent) {
|
|
print $startupparent "SUCCESS\n";
|
|
close($startupparent);
|
|
}
|
|
|
|
|
|
#only write to pid file if we have listener, listener ownership serves as lock to protect integrity
|
|
open($mainpidfile,">","/var/run/xcat/mainservice.pid"); #if here, everyone else has unlinked mainservicepid or doesn't care
|
|
print $mainpidfile $$;
|
|
close($mainpidfile);
|
|
closelog();
|
|
my @pendingconnections;
|
|
my $tconn;
|
|
until ($quit) {
|
|
$SIG{CHLD} = \&ssl_reaper; #set here to ensure that signal handler is not corrupted during loop
|
|
if (@pendingconnections) {
|
|
while ($listenwatcher->can_read(0)) { #grab everything we can, but don't spend any time waiting for more
|
|
$tconn = $listener->accept;
|
|
unless ($tconn) { next; }
|
|
push @pendingconnections,$tconn;
|
|
}
|
|
} else {
|
|
$tconn = $listener->accept; #we have no connections pending, no rush, just wait until the next connection attempt comes in
|
|
unless ($tconn) { next; } #sometimes we get 'undef', in which case carry on with our lives...
|
|
push @pendingconnections,$tconn;
|
|
}
|
|
unless (scalar @pendingconnections) { next; } #if for some reason we landed here without any accepted connections, carry on..
|
|
if ($sslclients > $maxsslclients) { #we have enough children, wait for some to exit before spawning more
|
|
$listenwatcher->can_read(0.1); #when next connection tries to come in or a tenth of a second, whichever comes first
|
|
next; #just keep pulling things off listen queue onto our own
|
|
}
|
|
#we have a pending connection and we are under the threshold, grab one from the list and process it...
|
|
my $cnnection=shift @pendingconnections;
|
|
my $connection;
|
|
my $child = xCAT::Utils->xfork(); #Yes we fork, IO::Socket::SSL is not threadsafe..
|
|
if ($child) {
|
|
$immediatechildren{$child}=1;
|
|
}
|
|
|
|
unless (defined $child) {
|
|
xCAT::MsgUtils->message("S","xCATd cannot fork");
|
|
die;
|
|
}
|
|
|
|
if ($child == 0) {
|
|
$SIG{TERM} = $SIG{INT} = {};
|
|
$SIG{CHLD} = \&generic_reaper; #THROTTLE
|
|
$listener->close;
|
|
|
|
$SIG{ALRM} = sub { $ssltimeout = 1; die; };
|
|
eval {
|
|
alarm(10);
|
|
$connection = IO::Socket::SSL->start_SSL($cnnection,
|
|
SSL_key_file=>$xcatdir."/cert/server-cred.pem",
|
|
SSL_cert_file=>$xcatdir."/cert/server-cred.pem",
|
|
SSL_ca_file=>$xcatdir."/cert/ca.pem",
|
|
SSL_server=>1,
|
|
SSL_verify_mode=> 1
|
|
);
|
|
alarm(0);
|
|
};
|
|
$SIG{ALRM}='DEFAULT';
|
|
if ($@) { #SSL failure
|
|
close($cnnection);
|
|
xexit 0;
|
|
}
|
|
unless ($connection) {
|
|
xexit 0;
|
|
}
|
|
$clientselect->add($connection);
|
|
my $peerhost=undef;
|
|
my $peerfqdn=undef;
|
|
my $peer=$connection->peer_certificate("owner");
|
|
if ($peer) {
|
|
$peer =~ m/CN=([^\/]*)/;
|
|
$peername = $1;
|
|
} else {
|
|
$peername=undef;
|
|
}
|
|
populate_site_hash();
|
|
|
|
if ($inet6support) {
|
|
$peerhost = gethostbyaddr($connection->peeraddr,AF_INET6);
|
|
} else {
|
|
$peerhost = gethostbyaddr($connection->peeraddr,AF_INET);
|
|
}
|
|
|
|
unless ($peerhost) { $peerhost = gethostbyaddr($connection->peeraddr,AF_INET); }
|
|
$peerfqdn=$peerhost;
|
|
my $peerhostorg=$peerhost; # save original with domain for validation
|
|
|
|
if ($peerhost) {
|
|
my @hosts;
|
|
push (@hosts, $peerhost);
|
|
my $nd = xCAT::NetworkUtils->getNodeDomains(\@hosts);
|
|
my %nodedomains = %$nd;
|
|
$domain = $nodedomains{$peerhost};
|
|
}
|
|
|
|
if ($domain) {
|
|
# strip off domain if set
|
|
$peerhost && $peerhost =~ s/\.$domain\.*$//;
|
|
} else {
|
|
# otherwise just strip off whatever comes after the first dot
|
|
$peerhost && $peerhost =~ s/\..*//;
|
|
}
|
|
|
|
$peerhost && $peerhost =~ s/-eth\d*$//;
|
|
$peerhost && $peerhost =~ s/-myri\d*$//;
|
|
$peerhost && $peerhost =~ s/-ib\d*$//;
|
|
#printf('info'.": xcatd: connection from ".($peername ? $peername . "@" . $peerhost : $peerhost)."\n");
|
|
$$progname="xCATd SSL: Instance for ".($peername ? $peername ."@".$peerhost : $peerhost) if $peerhost;
|
|
service_connection($connection,$peername,$peerhost,$peerfqdn,$peerhostorg);
|
|
xexit(0);
|
|
}
|
|
$sslclients++; #THROTTLE
|
|
$cnnection->close();
|
|
}
|
|
if (open($mainpidfile,"<","/var/run/xcat/mainservice.pid")) {
|
|
my $pid = <$mainpidfile>;
|
|
if ($pid == $$) { #if our pid, unlink the file, otherwise, we managed to see the pid after someone else created it
|
|
unlink("/var/run/xcat/mainservice.pid");
|
|
}
|
|
close($mainpidfile);
|
|
}
|
|
if ($listener) { $listener->close; }
|
|
my $lastpid;
|
|
while (keys %immediatechildren) {
|
|
$lastpid=wait();
|
|
if ($immediatechildren{$lastpid}) {
|
|
delete $immediatechildren{$lastpid};
|
|
}
|
|
}
|
|
xCAT::Table::shut_dbworker;
|
|
if ($dbmaster) {
|
|
kill 2, $dbmaster;
|
|
}
|
|
|
|
#stop the monitoring process
|
|
xCAT_monitoring::monitorctrl::stop($$);
|
|
|
|
my $parent_fd;
|
|
my %resps;
|
|
|
|
|
|
|
|
|
|
|
|
sub plugin_command {
|
|
my $req = shift;
|
|
my $sock = shift;
|
|
my $callback = shift;
|
|
my %handler_hash;
|
|
my $usesiteglobal = 0;
|
|
use xCAT::NodeRange qw/extnoderange nodesmissed noderange/;
|
|
$Main::resps={};
|
|
my @nodes;
|
|
@ARGV = ();
|
|
if ($req->{node}) {
|
|
@nodes = @{$req->{node}};
|
|
} elsif ($req->{noderange} and $req->{noderange}->[0]) {
|
|
xCAT::NodeRange::retain_cache(0); #if the request has a 'noderange' element, take the performance hit for the sake of freshness
|
|
@nodes = noderange($req->{noderange}->[0]);
|
|
if (nodesmissed) {
|
|
my $rsp = {errorcode=>1,error=>"Invalid nodes and/or groups in noderange: ".join(',',nodesmissed)};
|
|
$rsp->{serverdone} = {};
|
|
if ($sock) {
|
|
print $sock XMLout($rsp,RootName=>'xcatresponse' ,NoAttr=>1);
|
|
}
|
|
return ($rsp);
|
|
}
|
|
unless (@nodes) {
|
|
$req->{emptynoderange} = [1];
|
|
}
|
|
|
|
}
|
|
if (@nodes) { $req->{node} = \@nodes; }
|
|
my %unhandled_nodes;
|
|
foreach (@nodes) {
|
|
$unhandled_nodes{$_}=1;
|
|
}
|
|
my $useunhandled=0;
|
|
if (defined($cmd_handlers{$req->{command}->[0]})) {
|
|
my $hdlspec;
|
|
my @globalhandlers=();
|
|
my $useglobals=1; #If it stays 1, then use globals normally, if 0, use only for 'unhandled_nodes, if -1, don't do at all
|
|
my %hdlrcaches;
|
|
foreach (@{$cmd_handlers{$req->{command}->[0]}}) {
|
|
$hdlspec =$_->[1];
|
|
my $ownmod = $_->[0];
|
|
if ($hdlspec =~ /^site:/) { #A site entry specifies a plugin
|
|
my $sitekey = $hdlspec;
|
|
$sitekey =~ s/^site://;
|
|
if ($::XCATSITEVALS{$sitekey}) {#A site style plugin specification is just like
|
|
#a static global, it grabs all nodes rather than some
|
|
$useglobals = -1; #If they tried to specify anything, don't use the default global handlers at all
|
|
unless (@nodes) {
|
|
$handler_hash{$::XCATSITEVALS{$sitekey}} = 1;
|
|
$usesiteglobal = 1;
|
|
}
|
|
foreach (@nodes) { #Specified a specific plugin, not a table lookup
|
|
$handler_hash{$::XCATSITEVALS{$sitekey}}->{$_} = 1;
|
|
}
|
|
}
|
|
} elsif ($hdlspec =~ /:/) { #Specificed a table lookup path for plugin name
|
|
if (@nodes) { # only use table lookup plugin if nodelist exists
|
|
# Usage will be handled in common AAAhelp plugin
|
|
$useglobals = 0; #Only contemplate nodes that aren't caught through searching below in the global handler
|
|
$useunhandled=1;
|
|
my $table;
|
|
my $cols;
|
|
($table,$cols) = split(/:/,$hdlspec);
|
|
my @colmns=split(/,/,$cols);
|
|
my @columns;
|
|
my $hdlrtable=0;
|
|
unless ($hdlrcaches{$hdlspec}) {
|
|
$hdlrtable=xCAT::Table->new($table,-create=>0);
|
|
unless ($hdlrtable) {
|
|
next;
|
|
}
|
|
}
|
|
my $node;
|
|
my $colvals = {};
|
|
foreach my $colu (@colmns) {
|
|
if ($colu =~ /=/) { #a value redirect to a pattern/specific name
|
|
my $coln; my $colv;
|
|
($coln,$colv) = split(/=/,$colu,2);
|
|
$colvals->{$coln} = $colv;
|
|
push (@columns,$coln);
|
|
} else {
|
|
push (@columns,$colu);
|
|
}
|
|
}
|
|
|
|
|
|
unless (@nodes) { #register the plugin in the event of usage
|
|
$handler_hash{$ownmod} = 1;
|
|
$useglobals = 1;
|
|
}
|
|
if ($hdlrtable) {
|
|
$hdlrcaches{$hdlspec} = $hdlrtable->getNodesAttribs(\@nodes,\@columns);
|
|
}
|
|
foreach $node (@nodes) {
|
|
unless ($hdlrcaches{$hdlspec}) { next; }
|
|
my $attribs = $hdlrcaches{$hdlspec}->{$node}->[0]; #$hdlrtable->getNodeAttribs($node,\@columns);
|
|
unless (defined($attribs)) { next; }
|
|
foreach (@columns) {
|
|
my $col=$_;
|
|
if (defined($attribs->{$col})) {
|
|
if ($colvals->{$col}) { #A pattern match style request.
|
|
if ($attribs->{$col} =~ /$colvals->{$col}/) {
|
|
$handler_hash{$ownmod}->{$node} = 1;
|
|
delete $unhandled_nodes{$node};
|
|
last;
|
|
}
|
|
} else {
|
|
# call the plugin that matches the table value for that node
|
|
if ($attribs->{$col} =~ /$ownmod/) {
|
|
$handler_hash{$attribs->{$col}}->{$node} = 1;
|
|
delete $unhandled_nodes{$node};
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
$hdlrtable->close if $hdlrtable;
|
|
} # end if (@nodes)
|
|
|
|
} else {
|
|
push @globalhandlers,$hdlspec;
|
|
}
|
|
}
|
|
if ($useglobals == 1) { #Behavior when globals have not been overriden
|
|
my $hdlspec;
|
|
foreach $hdlspec (@globalhandlers) {
|
|
unless (@nodes) {
|
|
$handler_hash{$hdlspec} = 1;
|
|
}
|
|
foreach (@nodes) { #Specified a specific plugin, not a table lookup
|
|
$handler_hash{$hdlspec}->{$_} = 1;
|
|
}
|
|
}
|
|
} elsif ($useglobals == 0) {
|
|
unless (@nodes or $usesiteglobal) { #if something like 'makedhcp -n',
|
|
foreach (keys %handler_hash) {
|
|
if ($handler_hash{$_} == 1) {
|
|
delete ($handler_hash{$_})
|
|
}
|
|
}
|
|
}
|
|
foreach $hdlspec (@globalhandlers) {
|
|
unless (@nodes or $usesiteglobal) {
|
|
$handler_hash{$hdlspec} = 1;
|
|
}
|
|
foreach (keys %unhandled_nodes) { #Specified a specific plugin, not a table lookup
|
|
$handler_hash{$hdlspec}->{$_} = 1;
|
|
}
|
|
}
|
|
} #Otherwise, global handler is implicitly disabled
|
|
} else {
|
|
return 1; #TODO: error back that request has no known plugin for it
|
|
}
|
|
if ($useunhandled) {
|
|
my $queuelist='';
|
|
foreach (@{$cmd_handlers{$req->{command}->[0]}}) {
|
|
my $queueitem = $_->[1];
|
|
if (($queueitem =~ /:/) and !($queuelist =~ /($queueitem)/)) {
|
|
$queuelist .= "$_->[1];";
|
|
}
|
|
}
|
|
$queuelist =~ s/;$//;
|
|
$queuelist =~ s/:/./g;
|
|
if ($sock) {
|
|
my $xcatresponse = { xcatresponse => [] };
|
|
foreach (keys %unhandled_nodes) {
|
|
push @{$xcatresponse->{xcatresponse}},{node=>[{name=>[$_],error=>["Unable to identify plugin for this command, check relevant tables: $queuelist"],errorcode=>[1]}]};
|
|
}
|
|
print $sock XMLout($xcatresponse,KeepRoot=>1,NoAttr=>1);
|
|
} else {
|
|
foreach (keys %unhandled_nodes) {
|
|
my $tabdesc = $queuelist;
|
|
$tabdesc =~ s/=.*$//;
|
|
$callback->({node=>[{name=>[$_],error=>['Unable to identify plugin for this command, check relevant tables: '.$tabdesc],errorcode=>[1]}]});
|
|
}
|
|
}
|
|
}
|
|
my %xcatresponses = ( xcatresponse => [] );
|
|
$plugin_numchildren=0;
|
|
%plugin_children=();
|
|
# save the old signal
|
|
my $old_sig_chld = $SIG{CHLD};
|
|
$SIG{CHLD} = \&plugin_reaper; #sub {my $plugpid; while (($plugpid = waitpid(-1, WNOHANG)) > 0) { if ($plugin_children{$plugpid}) { delete $plugin_children{$plugpid}; $plugin_numchildren--; } } };
|
|
my $check_fds;
|
|
if ($sock) {
|
|
$check_fds = new IO::Select;
|
|
}
|
|
# Multiple plugins for one command
|
|
# $req->{sequential} is 0 by default
|
|
if (defined($req->{sequential}) && $req->{sequential}->[0]) {
|
|
# PCM case, executing plugins sequentially in alphabetic order
|
|
my $old_parent_fd = $parent_fd;
|
|
$parent_fd = 0;
|
|
foreach (sort(keys %handler_hash)) {
|
|
my $modname = $_;
|
|
$Main::resps={};
|
|
if (-r $plugins_dir."/".$modname.".pm") {
|
|
require $plugins_dir."/".$modname.".pm";
|
|
$plugin_numchildren++;
|
|
my $oldprogname=$$progname;
|
|
$$progname=$oldprogname.": $modname instance";
|
|
unless ($handler_hash{$_} == 1) {
|
|
#ok, if nodes have numbers, this sorts them numerically... roughly..
|
|
#if node doesn't, then it sorts out alphabetically.
|
|
my @nodes = sort {($a =~ /(\d+)/ ? $1 : -1)[0] <=> ($b =~ /(\d+)/ ? $1 : -1)[0] || $a cmp $b } (keys %{$handler_hash{$_}});
|
|
$req->{node}=\@nodes;
|
|
}
|
|
no strict "refs";
|
|
eval { #REMOVEEVALFORDEBUG
|
|
if ($dispatch_requests) {
|
|
dispatch_request($req,$callback,$modname);
|
|
} else {
|
|
$SIG{CHLD}='DEFAULT';
|
|
${"xCAT_plugin::".$modname."::"}{process_request}->($req,$callback,\&do_request);
|
|
}
|
|
$$progname=$oldprogname;
|
|
}; #REMOVEEVALFORDEBUG
|
|
if ($@) { #We are still alive, should be alive, but yet we have an error. This means we are in the case of 'do_request' or something similar. Forward up the death since our communication channel is intact..
|
|
xCAT::MsgUtils->message("S", "$@");
|
|
die $@;
|
|
}
|
|
} else {
|
|
my $pm_name = $plugins_dir."/".$modname.".pm";
|
|
if (ref $handler_hash{$_}) {
|
|
foreach my $node (keys %{$handler_hash{$_}}) {
|
|
if ($sock) {
|
|
print $sock XMLout({node=>[{name=>[$node],data=>["Cannot find the perl module to complete the operation: $pm_name"],errorcode=>[1]}]},NoAttr=>1,RootName=>'xcatresponse');
|
|
} else {
|
|
$callback->({node=>[{name=>[$node],data=>["Cannot find the perl module to complete the operation: $pm_name"],errorcode=>[1]}]});
|
|
}
|
|
}
|
|
} else {
|
|
if ($sock) {
|
|
print $sock XMLout({data=>["Cannot find the perl module to complete the operation: $pm_name"],errorcode=>[1]},NoAttr=>1,RootName=>'xcatresponse');
|
|
} else {
|
|
$callback->({data=>["Cannot find the perl module to complete the operation: $pm_name"],errorcode=>[1]});
|
|
}
|
|
}
|
|
}
|
|
push @{$xcatresponses{xcatresponse}}, $Main::resps;
|
|
}
|
|
$parent_fd = $old_parent_fd;
|
|
} else {
|
|
# executing plugins parallel
|
|
foreach (keys %handler_hash) {
|
|
my $modname = $_;
|
|
my $shouldbealivepid=$$;
|
|
if (-r $plugins_dir."/".$modname.".pm") {
|
|
require $plugins_dir."/".$modname.".pm";
|
|
$plugin_numchildren++;
|
|
my $pfd; #will be referenced for inter-process messaging.
|
|
my $parfd; #not causing a problem that I discern yet, but theoretically
|
|
my $child;
|
|
if ($sock) { #If $sock not passed in, don't fork..
|
|
if (! socketpair($pfd, $parfd,AF_UNIX,SOCK_STREAM,PF_UNSPEC)) {
|
|
xCAT::MsgUtils->message("S", "socketpair failed: $!");
|
|
die;
|
|
}
|
|
#pipe($pfd,$cfd);
|
|
my $oldfh = select $parfd;
|
|
$|=1;
|
|
select $pfd;
|
|
$|=1;
|
|
select $oldfh;
|
|
binmode($parfd,':utf8');
|
|
binmode($pfd,':utf8');
|
|
$child = xCAT::Utils->xfork;
|
|
} else {
|
|
$child = 0;
|
|
}
|
|
unless (defined $child) {
|
|
xCAT::MsgUtils->message("S", "Fork failed");
|
|
die;
|
|
}
|
|
if ($child == 0) {
|
|
setpgrp(0,0);
|
|
if ($parfd) { #If xCAT is doing multiple requests in same communication PID, things would get unfortunate otherwise
|
|
$parent_fd = $parfd;
|
|
}
|
|
my $org_parent_fd = $parent_fd;
|
|
my $oldprogname=$$progname;
|
|
$$progname=$oldprogname.": $modname instance";
|
|
if ($sock) { close $pfd; }
|
|
unless ($handler_hash{$_} == 1) {
|
|
#ok, if nodes have numbers, this sorts them numerically... roughly..
|
|
#if node doesn't, then it sorts out alphabetically.
|
|
my @nodes = sort {($a =~ /(\d+)/ ? $1 : -1)[0] <=> ($b =~ /(\d+)/ ? $1 : -1)[0] || $a cmp $b } (keys %{$handler_hash{$_}});
|
|
$req->{node}=\@nodes;
|
|
}
|
|
no strict "refs";
|
|
eval { #REMOVEEVALFORDEBUG
|
|
if ($dispatch_requests) {
|
|
dispatch_request($req,$callback,$modname);
|
|
} else {
|
|
$SIG{CHLD}='DEFAULT';
|
|
${"xCAT_plugin::".$modname."::"}{process_request}->($req,$callback,\&do_request);
|
|
}
|
|
$$progname=$oldprogname;
|
|
$parent_fd = $org_parent_fd;
|
|
if ($sock) {
|
|
close($parent_fd);
|
|
xexit(0);
|
|
}
|
|
$@=""; #sometimes a child 'eval' doesn't clean up $@, if we make it this far, no non-eval bug bombed out
|
|
}; #REMOVEEVALFORDEBUG
|
|
if ($sock or $shouldbealivepid != $$) { #We shouldn't still be alive, try to send as much detail to parent as possible as to why
|
|
my $error= "$modname plugin bug, pid $$, process description: '$$progname'";
|
|
if ($@) {
|
|
$error .= " with error '$@'";
|
|
} else { #Sys::Virt and perhaps Net::SNMP sometimes crashes in a way $@ won't catch..
|
|
$error .= " with missing eval error, probably due to special manipulation of $@ or strange circumstances in an XS library, remove evals in xcatd marked 'REMOVEEVALFORDEBUG and run xcatd -f for more info";
|
|
}
|
|
if (scalar (@nodes)) { #Don't know which of the nodes, so one error message warning about the possibliity..
|
|
$error .= " while trying to fulfill request for the following nodes: ".join(",",@nodes);
|
|
}
|
|
xCAT::MsgUtils->message("S","xcatd: $error");
|
|
$callback->({error=>[$error],errorcode=>[1]});
|
|
xexit(0); #Die like we should have done
|
|
} elsif ($@) { #We are still alive, should be alive, but yet we have an error. This means we are in the case of 'do_request' or something similar. Forward up the death since our communication channel is intact..
|
|
xCAT::MsgUtils->message("S", "$@");
|
|
die $@;
|
|
}
|
|
} else {
|
|
$plugin_children{$child}=1;
|
|
close $parfd;
|
|
$check_fds->add($pfd);
|
|
}
|
|
} else {
|
|
my $pm_name = $plugins_dir."/".$modname.".pm";
|
|
if (ref $handler_hash{$_}) {
|
|
foreach my $node (keys %{$handler_hash{$_}}) {
|
|
if ($sock) {
|
|
print $sock XMLout({node=>[{name=>[$node],data=>["Cannot find the perl module to complete the operation: $pm_name"],errorcode=>[1]}]},NoAttr=>1,RootName=>'xcatresponse');
|
|
} else {
|
|
$callback->({node=>[{name=>[$node],data=>["Cannot find the perl module to complete the operation: $pm_name"],errorcode=>[1]}]});
|
|
}
|
|
}
|
|
} else {
|
|
if ($sock) {
|
|
print $sock XMLout({data=>["Cannot find the perl module to complete the operation: $pm_name"],errorcode=>[1]},NoAttr=>1,RootName=>'xcatresponse');
|
|
} else {
|
|
$callback->({data=>["Cannot find the perl module to complete the operation: $pm_name"],errorcode=>[1]});
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
unless ($sock) {
|
|
# restore the old signal
|
|
$SIG{CHLD} = $old_sig_chld;
|
|
return $Main::resps
|
|
}
|
|
|
|
if (@deferredmsgargs) { xCAT::MsgUtils->message(@deferredmsgargs) };
|
|
@deferredmsgargs=();
|
|
my $nextxmittime = time()+1;
|
|
while (($plugin_numchildren > 0) and ($check_fds->count > 0)) { #this tracks end of useful data from children much more closely
|
|
relay_fds($check_fds,$xcatresponses{xcatresponse});
|
|
if (time() > $nextxmittime) {
|
|
$nextxmittime = time()+1;
|
|
send_pending_responses(\%xcatresponses,$sock);
|
|
$xcatresponses{xcatresponse}=[];
|
|
}
|
|
}
|
|
if (scalar(@{$xcatresponses{xcatresponse}})) {
|
|
send_pending_responses(\%xcatresponses,$sock);
|
|
$xcatresponses{xcatresponse}=[];
|
|
}
|
|
#while (relay_fds($check_fds,$sock)) {}
|
|
|
|
# restore the old signal
|
|
$SIG{CHLD} = $old_sig_chld;
|
|
|
|
my %done;
|
|
$done{serverdone} = {};
|
|
if ($req->{transid}) {
|
|
$done{transid}=$req->{transid}->[0];
|
|
}
|
|
if ($sock) {
|
|
my $clientpresence = new IO::Select; #The client may have gone away without confirmation, don't PIPE over this trivial thing
|
|
$clientpresence->add($sock);
|
|
my $deadline = time()+5;
|
|
while ($deadline > time()) { #sometimes can_write exits prematurely without waiting the whole time.....
|
|
if ($clientpresence->can_write(5)) {
|
|
print $sock XMLout(\%done,RootName => 'xcatresponse',NoAttr=>1);
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
my $dispatch_parentfd;
|
|
sub dispatch_callback {
|
|
my $rspo = shift;
|
|
unless ($rspo) {
|
|
return;
|
|
}
|
|
my $rsp = {%$rspo}; # deep copy
|
|
delete $rsp->{serverdone};
|
|
unless (%$rsp) { return; }
|
|
print $dispatch_parentfd freeze($rsp);
|
|
print $dispatch_parentfd "\nENDOFFREEZE6sK6xa\n";
|
|
yield; #This has to happen before next line could possibly work anyway
|
|
my $parselect = new IO::Select;
|
|
$parselect->add($dispatch_parentfd);
|
|
my $selbits = $parselect->bits;
|
|
while (defined($selbits) && ($rsp = select($selbits,undef,undef,5))) { #block for up to 5 seconds before continuing
|
|
if ($quit) { # termination requested by a clean shutdown facility
|
|
xexit 0;
|
|
}
|
|
if ($rsp == 0) { #The select call failed to find any ready items
|
|
last;
|
|
}
|
|
if ($rsp < 0) { #A child exited or other signal event that made select skip out before suggesting succes
|
|
next;
|
|
}
|
|
if ($rsp = <$dispatch_parentfd>) {
|
|
if ($rsp =~ /die/ or $quit) {
|
|
xexit 0;
|
|
}
|
|
last;
|
|
} else {
|
|
$parselect->remove($dispatch_parentfd); #Block until parent acks data
|
|
last;
|
|
}
|
|
$selbits = $parselect->bits;
|
|
yield;
|
|
}
|
|
}
|
|
|
|
sub relay_dispatch {
|
|
my $fds = shift;
|
|
my $dispatch_cb = shift;
|
|
my @ready_ins;
|
|
eval {
|
|
@ready_ins = $fds->can_read(1);
|
|
};
|
|
if ($@) { undef $@; return 0; }
|
|
foreach my $rin (@ready_ins) {
|
|
my $data;
|
|
if ($data = <$rin>) {
|
|
while ($data !~ /ENDOFFREEZE6sK6xa/) {
|
|
$data .= <$rin>;
|
|
}
|
|
my $response = thaw($data);
|
|
print $rin "dfin\n";
|
|
$dispatch_cb->($response);
|
|
} else {
|
|
$fds->remove($rin);
|
|
close($rin);
|
|
}
|
|
}
|
|
yield; #At this point, explicitly yield to other processes. If children will have more data, this process would otherwise uselessly loop on data that never will be. If children are all done, still no harm in waiting a short bit for a timeslice to come back
|
|
return scalar(@ready_ins);
|
|
}
|
|
|
|
sub dispatch_request {
|
|
%dispatched_children=();
|
|
my $req = shift;
|
|
my $dispatch_cb = shift;
|
|
|
|
my $modname = shift;
|
|
my $reqs = [];
|
|
my $child_fdset = new IO::Select;
|
|
no strict "refs";
|
|
|
|
# save the old signal
|
|
my $old_sig_chld = $SIG{CHLD};
|
|
|
|
#Hierarchy support. Originally, the default scope for noderange commands was
|
|
#going to be the servicenode associated unless overriden.
|
|
#However, assume for example that you have blades and a blade is the service node
|
|
#rpower being executed by the servicenode for one of its subnodes would have to
|
|
#reach it's own management module. This has the potential to be non-trivial for some quite possible network configurations.
|
|
#Since plugins may commonly experience this, a preprocess_request implementation
|
|
#will for now be required for a command to be scaled through service nodes
|
|
#If the plugin offers a preprocess method, use it to set the request array
|
|
if ((not (defined $req->{_xcatpreprocessed}->[0] and $req->{_xcatpreprocessed}->[0] == 1)) and (defined(${"xCAT_plugin::".$modname."::"}{preprocess_request}))) {
|
|
$SIG{CHLD}='DEFAULT';
|
|
$reqs = ${"xCAT_plugin::".$modname."::"}{preprocess_request}->($req,$dispatch_cb,\&do_request);
|
|
} else { #otherwise, pass it in without hierarchy support
|
|
$reqs = [$req];
|
|
}
|
|
|
|
$dispatch_children=0;
|
|
$SIG{CHLD} = \&dispatch_reaper; #sub {my $cpid; while (($cpid =waitpid(-1, WNOHANG)) > 0) { if ($dispatched_children{$cpid}) { delete $dispatched_children{$cpid}; $dispatch_children--; } } };
|
|
$SIG{TERM} = $SIG{INT} = sub {
|
|
foreach (keys %dispatched_children) {
|
|
kill 2, $_;
|
|
}
|
|
};
|
|
# this is used to filter out the incorrect module that xcat command came into
|
|
# Mainly useful for hierarchical environment on SN
|
|
if (defined $req->{'_modname'} ) {
|
|
my $in_modname = undef;
|
|
if (ref $req->{'_modname'} eq 'ARRAY') {
|
|
$in_modname = $req->{'_modname'}->[0];
|
|
} else {
|
|
$in_modname = $req->{'_modname'};
|
|
}
|
|
if ($in_modname ne $modname) {
|
|
$reqs = [];
|
|
}
|
|
}
|
|
|
|
my $onlyone=0;
|
|
if (defined $reqs and (scalar(@{$reqs}) == 1)) {
|
|
$onlyone=1;
|
|
}
|
|
|
|
foreach (@{$reqs}) {
|
|
my $pfd;
|
|
my $parfd; #use a private variable so it won't trounce itself recursively
|
|
my $child;
|
|
delete $_->{noderange};
|
|
if (ref $_->{'_xcatdest'} and (ref $_->{'_xcatdest'}) eq 'ARRAY') {
|
|
_->{'_xcatdest'} = $_->{'_xcatdest'}->[0];
|
|
}
|
|
if ($onlyone and not ($_->{'_xcatdest'} and xCAT::NetworkUtils->thishostisnot($_->{'_xcatdest'}))) {
|
|
$SIG{CHLD}='DEFAULT';
|
|
if ($_->{'_xcatdelay'} and not ref $_->{'_xcatdelay'}) { sleep $_->{'_xcatdelay'}; }
|
|
${"xCAT_plugin::".$modname."::"}{process_request}->($_,$dispatch_cb,\&do_request);
|
|
return;
|
|
}
|
|
|
|
if (! socketpair($pfd, $parfd,AF_UNIX,SOCK_STREAM,PF_UNSPEC)) {
|
|
xCAT::MsgUtils->message("S", "ERROR: socketpair: $!");
|
|
die;
|
|
}
|
|
my $oldfh = select $parfd;
|
|
$|=1;
|
|
select $pfd;
|
|
$|=1;
|
|
select $oldfh;
|
|
binmode($parfd,':utf8');
|
|
binmode($pfd,':utf8');
|
|
$child = xCAT::Utils->xfork;
|
|
if ($child) {
|
|
$dispatch_children++;
|
|
$dispatched_children{$child}=1;
|
|
$child_fdset->add($pfd);
|
|
close($parfd);
|
|
next;
|
|
}
|
|
unless (defined $child) {
|
|
$dispatch_cb->({error=>['Fork failure dispatching request'],errorcode=>[1]});
|
|
}
|
|
close($pfd);
|
|
$SIG{CHLD}='DEFAULT';
|
|
$dispatch_parentfd = $parfd;
|
|
my @prexcatdests=();
|
|
my @xcatdests=();
|
|
if ($_->{'_xcatdelay'} and not ref $_->{'_xcatdelay'}) { sleep $_->{'_xcatdelay'}; }
|
|
if (ref($_->{'_xcatdest'}) eq 'ARRAY') { #If array, consider it an 'anycast' operation, broadcast done through dupe
|
|
#requests, or an alternative join '&' maybe?
|
|
@prexcatdests=@{$_->{'_xcatdest'}};
|
|
} else {
|
|
@prexcatdests=($_->{'_xcatdest'});
|
|
}
|
|
foreach (@prexcatdests) {
|
|
if ($_ and /,/) {
|
|
push @xcatdests,split /,/,$_;
|
|
} else {
|
|
push @xcatdests,$_;
|
|
}
|
|
}
|
|
my $xcatdest;
|
|
my $numdests=scalar(@xcatdests);
|
|
my $request_satisfied=0;
|
|
foreach $xcatdest (@xcatdests) {
|
|
my $dlock;
|
|
if ($xcatdest and xCAT::NetworkUtils->thishostisnot($xcatdest)) {
|
|
#mkpath("/var/lock/xcat/"); #For now, limit intra-xCAT requests to one at a time, to mitigate DB handle usage
|
|
#open($dlock,">","/var/lock/xcat/dispatchto_$xcatdest");
|
|
#flock($dlock,LOCK_EX);
|
|
$ENV{XCATHOST} = ($xcatdest =~ /:/ ? $xcatdest : $xcatdest.":3001" );
|
|
$$progname.=": connection to ".$ENV{XCATHOST};
|
|
my $errstr;
|
|
eval {
|
|
undef $_->{'_xcatdest'};
|
|
#mainly used by SN to filter out the incorrect module that xcat command came into
|
|
$_->{'_modname'} = $modname;
|
|
xCAT::Client::submit_request($_,\&dispatch_callback,$xcatdir."/cert/server-cred.pem",$xcatdir."/cert/server-cred.pem",$xcatdir."/cert/ca.pem");
|
|
};
|
|
if ($@) {
|
|
$errstr=$@;
|
|
}
|
|
#unlink("/var/lock/xcat/dispatchto_$xcatdest");
|
|
#flock($dlock,LOCK_UN);
|
|
if ($errstr) {
|
|
if ($numdests == 1) {
|
|
dispatch_callback({error=>["Unable to dispatch hierarchical sub-command to ".$ENV{XCATHOST}.". This service node may be down or its xcatd daemon may not be responding."],errorcode=>[1]});
|
|
xCAT::MsgUtils->message("S","Error dispatching request to ".$ENV{XCATHOST}.": ".$errstr);
|
|
} else {
|
|
xCAT::MsgUtils->message("S","Error dispatching request to ".$ENV{XCATHOST}.", trying other service nodes: ".$errstr);
|
|
}
|
|
next;
|
|
} else {
|
|
$request_satisfied=1;
|
|
last;
|
|
}
|
|
} else {
|
|
$$progname.=": locally executing";
|
|
$SIG{CHLD}='DEFAULT';
|
|
${"xCAT_plugin::".$modname."::"}{process_request}->($_,\&dispatch_callback,\&do_request);
|
|
last;
|
|
}
|
|
}
|
|
if (!(xCAT::Utils->isServiceNode())) { # not on a service node
|
|
if ($numdests > 1 and not $request_satisfied) {
|
|
xCAT::MsgUtils->message("S","Error dispatching a request to all possible service nodes for request");
|
|
dispatch_callback({error=>["Failed to dispatch command to any of the following service nodes: ".join(",",@xcatdests)],errorcode=>[1]});
|
|
}
|
|
}
|
|
|
|
xexit;
|
|
}
|
|
while (($dispatch_children > 0) and ($child_fdset->count > 0)) { relay_dispatch($child_fdset,$dispatch_cb) }
|
|
while (relay_dispatch($child_fdset,$dispatch_cb)) { } #Potentially useless drain.
|
|
|
|
# restore the old signal
|
|
$SIG{CHLD} = $old_sig_chld;
|
|
}
|
|
|
|
|
|
sub do_request {
|
|
my $req = shift;
|
|
my $second = shift;
|
|
my $rsphandler = \&build_response;
|
|
my $sock = undef;
|
|
if ($second) {
|
|
if (ref($second) eq "CODE") {
|
|
$rsphandler = $second;
|
|
} elsif (ref($second) eq "GLOB") {
|
|
$sock = $second;
|
|
}
|
|
}
|
|
|
|
#my $sock = shift; #If no sock, will return a response hash
|
|
if ($cmd_handlers{$req->{command}->[0]}) {
|
|
return plugin_command($req,$sock,$rsphandler);
|
|
} elsif ($req->{command}->[0] eq "noderange" and $req->{noderange}) {
|
|
my @nodes = noderange($req->{noderange}->[0]);
|
|
my %resp;
|
|
if (nodesmissed) {
|
|
$resp{warning}="Invalid nodes in noderange:".join ',',nodesmissed;
|
|
}
|
|
$resp{serverdone} = {};
|
|
@{$resp{node}}=@nodes;
|
|
if ($req->{transid}) {
|
|
$resp{transid}=$req->{transid}->[0];
|
|
}
|
|
if ($sock) {
|
|
print $sock XMLout(\%resp,RootName => 'xcatresponse',NoAttr=>1);
|
|
} else {
|
|
return (\%resp);
|
|
}
|
|
} else {
|
|
my %resp=(error=>"Unsupported request");
|
|
$resp{serverdone} = {};
|
|
if ($req->{transid}) {
|
|
$resp{transid}=$req->{transid}->[0];
|
|
}
|
|
if ($sock) {
|
|
print $sock XMLout(\%resp,RootName => 'xcatresponse',NoAttr=>1);
|
|
} else {
|
|
return (\%resp);
|
|
}
|
|
}
|
|
}
|
|
|
|
sub convey_response {
|
|
my $resp=shift;
|
|
#TODO: This is where the following will/may happen:
|
|
#-Track transaction id
|
|
#-Save output for deferred commands
|
|
unless ($parent_fd) {
|
|
build_response($resp);
|
|
return;
|
|
}
|
|
unless ($resp) { return; }
|
|
$resp = freeze($resp);
|
|
$pipeexpected=1;
|
|
#$resp = XMLout($resp,KeyAttr=>[], NoAttr=>1,RootName=>'xcatresponse');
|
|
#sanitize the response, to avoid being killed by non-printable bytes
|
|
#$resp =~ tr/\011-\177/?/c;
|
|
#seeing if using utf-8 offloads potential issues to client terminal, it didn't
|
|
print $parent_fd $resp;
|
|
print $parent_fd "\nENDOFFREEZE6sK6xa\n";
|
|
yield; #parent must get timeslice anyway before an ack could possibly return
|
|
my $parsel = new IO::Select;
|
|
$parsel->add($parent_fd);
|
|
my $selbits = $parsel->bits;
|
|
my $rsp;
|
|
while ($selbits && ($rsp = select($selbits, undef, undef, 5))) { #block up to five seconds
|
|
if ($quit) { # Obey quit flag
|
|
xexit 0;
|
|
}
|
|
if ($rsp == 0) { #This means the filedescriptor was removed
|
|
last;
|
|
}
|
|
if ($rsp < 0) { # A signal caused select to skip out, do-over
|
|
next;
|
|
}
|
|
#At this point, the only possibility is a positive return, meaning parent_fd requires attention of some sort
|
|
$rsp = <$parent_fd>;
|
|
if ($rsp) { #If data actually came in, last, otherwise, remove it from the IO::Select, but both should amount to the same thing
|
|
last;
|
|
} else {
|
|
$parsel->remove($parent_fd);
|
|
last;
|
|
}
|
|
}
|
|
yield; #If still around, it means a peer process still hasn't gotten to us, so might as well yield
|
|
$selbits = $parsel->bits;
|
|
}
|
|
|
|
sub build_response {
|
|
# Handle responses from do_request calls made directly from a plugin
|
|
# Merge this response into the full response hash. We'll collect all
|
|
# the responses and ship it back on the return to the plugin.
|
|
# Note: Need to create a new "deep clone" copy of each response structure
|
|
# otherwise the next call will overwrite the reference we pushed on
|
|
# the response array
|
|
my $resp = shift;
|
|
foreach (keys %$resp) {
|
|
my $subresp = dclone($resp->{$_});
|
|
if (ref $subresp eq 'ARRAY') {
|
|
push (@{$Main::resps->{$_}}, @{$subresp});
|
|
} else {
|
|
push (@{$Main::resps->{$_}}, $subresp);
|
|
}
|
|
}
|
|
}
|
|
|
|
sub becomeuser {
|
|
#if username and password match, return the new username
|
|
#otherwise, return undef
|
|
#TODO PAM?
|
|
my $passtab = xCAT::Table->new('passwd');
|
|
my $id=shift;
|
|
my $pass=shift;
|
|
unless (defined $id and defined $pass) {
|
|
return undef;
|
|
}
|
|
my $passent=$passtab->getAttribs({key=>'xcat',username=>$id},['password']);
|
|
unless ($passent) {
|
|
return undef;
|
|
}
|
|
$passent=$passent->{password};
|
|
my $encryptedpass = crypt($pass,$passent);
|
|
if ($encryptedpass eq $passent) {
|
|
return $id;
|
|
}elsif ($pass eq $passent) {
|
|
return $id;
|
|
}
|
|
# if ($passent =~ /^\$(2a|1)\$.*\$/) { #MD5 or Blowfish hash, calculate before comparison
|
|
# $pass = crypt($pass,$passent);
|
|
# } #Not bothering with old DES method, for now assume plaintext if not set
|
|
# if ($pass eq $passent) {
|
|
# return $id;
|
|
# }
|
|
#If here, unable to validate given credential
|
|
return undef;
|
|
}
|
|
sub populate_site_hash {
|
|
%::XCATSITEVALS=();
|
|
my $sitetab = xCAT::Table->new('site',-create=>0);
|
|
unless ($sitetab) { return; }
|
|
my @records = $sitetab->getAllAttribs(qw/key value/);
|
|
foreach (@records) {
|
|
$::XCATSITEVALS{$_->{key}}=$_->{value};
|
|
}
|
|
}
|
|
|
|
|
|
sub service_connection {
|
|
my $sock = shift;
|
|
my $peername = shift;
|
|
my $peerhost = shift;
|
|
my $peerfqdn = shift;
|
|
my $peerhostorg = shift;
|
|
my $peerport = $sock->peerport;
|
|
my %tables=();
|
|
#some paranoid measures could reduce a third party abusing stage3 image to attempting to get USER/PASS for BMCs:
|
|
# -Well, minimally, ignore requests if requesting node is not in spconfig mode (stage3)
|
|
# -Option to generate a random password per 'getipmi' request. This reduces the exposure to a D.O.S. hopefully
|
|
#Give only 15 seconds of silence allowed or terminate connection. Using alarm since we are in thread-unsafe world anyway
|
|
my $timedout = 0;
|
|
|
|
$SIG{ALRM} = sub { $timedout = 1; die; };
|
|
my $evalpid = $$;
|
|
eval { #REMOVEEVALFORDEBUG
|
|
my $request;
|
|
my $req=undef;
|
|
my $line;
|
|
my $clientsel = new IO::Select;
|
|
$clientsel->add($sock);
|
|
while (1) {
|
|
$line="";
|
|
unless ($clientsel->can_read(15)) { last; } #don't let an unresponsive client hold us up
|
|
my $flags=fcntl($sock,F_GETFL,0);
|
|
$flags |= O_NONBLOCK; #we want sysread to bail on us, select seems to be evil to us still..
|
|
fcntl($sock,F_SETFL,$flags);
|
|
my $bytesread;
|
|
do { $bytesread=sysread($sock,$line,65536,length($line)) } while ($bytesread);
|
|
if (length($line)==0) {
|
|
if (not defined $bytesread and $! == EAGAIN) { next; } #
|
|
last;
|
|
}
|
|
$flags=fcntl($sock,F_GETFL,0);
|
|
$flags &= ~O_NONBLOCK; #now we want *print* to be blocking IO
|
|
fcntl($sock,F_SETFL,$flags);
|
|
$request .= $line;
|
|
#$req = eval { XMLin($request, ForceArray => [ 'attribute' , 'attributepair' ]) };
|
|
if ($line =~ m/<\/xcatrequest>/) {
|
|
$req = eval { XMLin($request, SuppressEmpty=>undef,ForceArray=>1) };
|
|
#first change peername on 'becomeuser' tag if present and valid
|
|
if (defined $req->{becomeuser}) {
|
|
$peername=becomeuser($req->{becomeuser}->[0]->{username}->[0],
|
|
$req->{becomeuser}->[0]->{password}->[0]);
|
|
unless (defined $peername) {
|
|
my $resp={error=>["Authentication failure"],errorcode=>[1]};
|
|
$resp->{serverdone}={};
|
|
print $sock XMLout($resp,RootName => 'xcatresponse',NoAttr=>1);
|
|
return;
|
|
}
|
|
delete($req->{becomeuser}); #Remove it to keep it from view
|
|
}
|
|
|
|
#we have a full request..
|
|
#printf $request."\n";
|
|
$request="";
|
|
if (xCAT::xcatd->validate($peername,$peerhost,$req,$peerhostorg,\@deferredmsgargs)) {
|
|
$req->{'_xcat_authname'} = [$peername];
|
|
$req->{'_xcat_clienthost'} = [$peerhost];
|
|
$req->{'_xcat_clientfqdn'} = [$peerfqdn];
|
|
$req->{'_xcat_clientport'}= [$peerport];
|
|
$$progname="xCATd SSL: ".$req->{command}->[0];
|
|
if ($req->{noderange} && defined($req->{noderange}->[0])) {
|
|
$$progname .= " to ".$req->{noderange}->[0];
|
|
}
|
|
|
|
if($peerhost){
|
|
$$progname .= " for ".($peername ? $peername ."@".$peerhost : $peerhost);
|
|
}
|
|
if ($req->{command}->[0] eq "authcheck") { #provide a method for UI to verify a user without actually requesting action
|
|
my $resp;
|
|
if ($peername or $peername eq "0") {
|
|
$resp->{username}=[$peername];
|
|
$resp->{data}=["Authenticated"];
|
|
} else {
|
|
$resp->{data}=["Unauthenticated"];
|
|
}
|
|
$resp->{serverdone}={};
|
|
print $sock XMLout($resp,RootName => 'xcatresponse',NoAttr=>1);
|
|
} elsif ($cmd_handlers{$req->{command}->[0]}) {
|
|
plugin_command($req,$sock,\&convey_response);
|
|
} elsif ($req->{command}->[0] eq "noderange" and $req->{noderange}) {
|
|
xCAT::NodeRange::retain_cache(0); #if the request has a 'noderange' element, take the performance hit for the sake of freshness
|
|
my @nodes = noderange($req->{noderange}->[0]);
|
|
my %resp;
|
|
if (nodesmissed) {
|
|
$resp{warning}="Invalid nodes in noderange:".join ',',nodesmissed;
|
|
}
|
|
$resp{serverdone} = {};
|
|
@{$resp{node}}=@nodes;
|
|
if ($req->{transid}) {
|
|
$resp{transid}=$req->{transid}->[0];
|
|
}
|
|
print $sock XMLout(\%resp,RootName => 'xcatresponse',NoAttr=>1);
|
|
next;
|
|
} elsif ($req->{command}->[0] eq "extnoderange" and $req->{noderange}) { #This is intended for the UIs to build trees
|
|
#as this would be part of a highly dynamic construct, it has a shortcut here to minimize server load
|
|
my $subgroups=0;
|
|
if ($req->{arg} and grep /subgroups/,@{$req->{arg}}) {
|
|
$subgroups=1;
|
|
}
|
|
my %resp=%{extnoderange($req->{noderange}->[0],{intersectinggroups=>$subgroups})};
|
|
$resp{serverdone}={};
|
|
print $sock XMLout(\%resp,RootName => 'xcatresponse',NoAttr=>1);
|
|
next;
|
|
} else {
|
|
my %resp=(error=>"Unsupported request");
|
|
$resp{serverdone} = {};
|
|
if ($req->{transid}) {
|
|
$resp{transid}=$req->{transid}->[0];
|
|
}
|
|
xCAT::MsgUtils->message("S","Unsupported request: peername=$peername, peerhost=$peerhost,peerfqdn=$peerfqdn,peerport=$peerport, command=".$req->{command}->[0]);
|
|
print $sock XMLout(\%resp,RootName => 'xcatresponse',NoAttr=>1);
|
|
next;
|
|
}
|
|
} else {
|
|
my %resp=(error=>"Permission denied for request");
|
|
$resp{serverdone} = {};
|
|
if ($req->{transid}) {
|
|
$resp{transid}=$req->{transid}->[0];
|
|
}
|
|
xCAT::MsgUtils->message("S","Permission denied for request: peername=$peername, peerhost=$peerhost,peerfqdn=$peerfqdn,peerport=$peerport command= ".$req->{command}->[0]);
|
|
my $response=XMLout(\%resp,RootName =>'xcatresponse',NoAttr => 1);
|
|
print $sock $response;
|
|
next;
|
|
}
|
|
}
|
|
}
|
|
}; #REMOVEEVALFORDEBUG
|
|
if ($@) { # The eval statement caught a program bug..
|
|
if ($@ =~ /^SIGPIPE/) {
|
|
xCAT::MsgUtils->message("S","xcatd: Unexpected client disconnect");
|
|
if ($sock) {
|
|
eval {
|
|
print $sock XMLout({error=>"Generic PIPE error occurred. $@"},RootName=>'xcatresponse',NoAttr=>1);
|
|
};
|
|
}
|
|
} elsif ($@ =~ /Client abort requested/) {
|
|
} else {
|
|
my $errstr="A fatal error was encountered, the following information may help identify a bug: $@";
|
|
chomp($errstr);
|
|
xCAT::MsgUtils->message("S","xcatd: possible BUG encountered by xCAT TCP service: ".$@);
|
|
if ($sock) {
|
|
eval {
|
|
print $sock XMLout({error=>$errstr},RootName=>'xcatresponse',NoAttr=>1);
|
|
};
|
|
}
|
|
}
|
|
} elsif ($evalpid ne $$) {
|
|
xCAT::MsgUtils->message("S","A child jumped to where it should never ever be, this shouldn't be possible, please report this bug");
|
|
#The folowing corrupts the SSL state preventing any further output by the parent.
|
|
#A bug triggering this absolutely
|
|
#needs to fixed. With the current code layout it is either trash valid data that could have been or
|
|
#risk user missing data
|
|
#without knowing it. It's likely possible to rearchitect to change that, but as it stands it really
|
|
#should be no longer possible to hit this condition.
|
|
print $sock,XMLout({error=>"A child jumped to where it should never ever be, this shouldn't be possible, please report this bug"});
|
|
}
|
|
$SIG{ALRM}= sub { xCAT::MsgUtils->message("S","$$ failed shutting down"); die;};
|
|
alarm(10);
|
|
foreach (keys %tables) {
|
|
$tables{$_}->commit;
|
|
}
|
|
$sock->close(SSL_fast_shutdown=>1);
|
|
if ($timedout == 1) {
|
|
printf ("Client timeout");
|
|
}
|
|
}
|
|
|
|
sub send_pending_responses {
|
|
my $xcatresponse = shift;
|
|
my $sock = shift;
|
|
my $resp = XMLout($xcatresponse,KeyAttr=>[], NoAttr=>1,KeepRoot=>1);
|
|
#sanitize the response, to avoid being killed by non-printable bytes
|
|
$resp =~ tr/\011-\177/?/c;
|
|
#seeing if using utf-8 offloads potential issues to client terminal, it didn't
|
|
eval {
|
|
my $rsplen = length($resp);
|
|
my $blocks = int($rsplen/4096)-1;
|
|
if ($rsplen%4096) {
|
|
$blocks += 1;
|
|
}
|
|
foreach (0..$blocks) {
|
|
syswrite($sock,$resp,4096,$_*4096);
|
|
}
|
|
};
|
|
}
|
|
sub relay_fds { #Relays file descriptors from pipes to children to the SSL socket
|
|
my $fds = shift;
|
|
my $replyqueue=shift;
|
|
my $goneclient=0;
|
|
my $collate = ( scalar @_ > 0 ? shift : 0);
|
|
my @readyset = $fds->can_read(1);
|
|
my $rfh;
|
|
my $rc = @readyset;
|
|
my $text;
|
|
foreach $rfh (@readyset) { #go through each child, extract a complete, atomic message
|
|
my $line;
|
|
my $resp;
|
|
while ($line = <$rfh>) { #Will break on complete </xcatresponse> messages, avoid interleave
|
|
$resp .= $line;
|
|
if ($line =~ /ENDOFFREEZE6sK6xa\n/) {
|
|
print $rfh "nfin\n"; #ok, ack the data (superfluous, but svn revision history shows an oddity with killed processes and assuming that was legit... for now)
|
|
#ack before doing the real work to allow child to get back to work
|
|
$resp = thaw($resp);
|
|
push @$replyqueue,$resp;
|
|
last;
|
|
}
|
|
if ($@ and $@ =~ /PIPE/) {
|
|
$goneclient=1;
|
|
print "Piped while writing to client\n";
|
|
last;
|
|
}
|
|
}
|
|
unless ($line) {
|
|
# print $rfh "nfin\n"; #Notify convey_response message done
|
|
# } else {
|
|
$fds->remove($rfh);
|
|
close($rfh);
|
|
}
|
|
}
|
|
foreach my $rin ($clientselect->can_read(0)) {
|
|
my $subselect = new IO::Select;
|
|
$subselect->add($rin);
|
|
my $clientintr="";
|
|
my $subdata;
|
|
while ($subselect->can_read(1)) {
|
|
if ($subdata=<$rin>) {
|
|
$clientintr.=$subdata;
|
|
} else {
|
|
$subselect->remove($rin);
|
|
close($rin);
|
|
}
|
|
}
|
|
chomp($clientintr);
|
|
unless ($clientintr) {
|
|
next;
|
|
}
|
|
$clientintr=XMLin($clientintr, SuppressEmpty=>undef,ForceArray=>1 );
|
|
if ($clientintr->{abortcommand}->[0]) {
|
|
$pipeexpected=1;
|
|
print "Aborting...";
|
|
foreach (keys %plugin_children) {
|
|
print "Sending INT to $_\n";
|
|
kill -15, $_;
|
|
}
|
|
foreach my $cin ($fds->handles) {
|
|
print $cin "die\n";
|
|
$fds->remove($cin);
|
|
close($cin);
|
|
}
|
|
xCAT::MsgUtils->message("S", "Client abort requested");
|
|
exit(0);
|
|
}
|
|
}
|
|
yield; #Give other processes, including children, explicit control, to avoid uselessly aggressive looping
|
|
if ($goneclient) {
|
|
xCAT::MsgUtils->message("S", "SIGPIPE $$progname encountered a broken pipe (Sudden client disconnect)");
|
|
die;
|
|
}
|
|
return $rc;
|
|
}
|
|
|
|
# Enable the trace of subroutine calling.
|
|
# Replace the original subroutine with a trace added subroutine to output more debug trace
|
|
sub enable_callingtrace{
|
|
my $enableall = 0; # if $enableall=1, enable trace for all the functions of xcat
|
|
my @pluginfuncs = (); # function list that will be enabled for plugins
|
|
my @xcatdfuncs = (); # function list that will be enabled for xcatd
|
|
|
|
# call the subroutine scan_plugins to fill the symbol table
|
|
scan_plugins();
|
|
|
|
# Backup the trace log
|
|
my ($sec,$min,$hour,$mday,$mon,$year) = localtime();
|
|
$year -= 100;
|
|
$mon += 1;
|
|
my $time = sprintf "%02s%02s%02s%02s%02s%02s", $year, $mon, $mday, $hour, $min, $sec;
|
|
if (-e "/var/log/xcat/subcallingtrace") {
|
|
system("mv /var/log/xcat/subcallingtrace /var/log/xcat/subcallingtrace$time");
|
|
}
|
|
|
|
# Start the trace log
|
|
xCAT::MsgUtils->start_logging("subcallingtrace");
|
|
|
|
# Read the subroutine list from the configuration file
|
|
if (-f "/tmp/xcatcallingtrace.cfg") {
|
|
if (! open (FUNLIST, "</tmp/xcatcallingtrace.cfg")) {
|
|
xCAT::MsgUtils->message("SL", "Enable subroutine calling trace failed: cannot open /tmp/xcatcallingtrace.cfg");
|
|
xCAT::MsgUtils->stop_logging();
|
|
return 1;
|
|
}
|
|
my $cfg = <FUNLIST>;
|
|
chomp($cfg);
|
|
my @funlist;
|
|
if (-f $cfg) { # Specified a configuration file
|
|
if (! open (CFG, "<$cfg")) {
|
|
xCAT::MsgUtils->message("SL", "Enable subroutine calling trace failed: cannot open $cfg");
|
|
xCAT::MsgUtils->stop_logging();
|
|
return 1;
|
|
} else { # read the configuration file
|
|
while (<CFG>) {
|
|
push @funlist, $_;
|
|
}
|
|
close (CFG);
|
|
}
|
|
} else {
|
|
# Specified the function list
|
|
# The format of the function list should be package(func1,func2,...),package(func1,func2,...)
|
|
push @funlist, split /\|/, $cfg;
|
|
}
|
|
|
|
# Parse the function list
|
|
foreach (@funlist) {
|
|
if (/(.*::.*)\((.*)\)/) { # if the format is xCAT::plugin(f1,f2)
|
|
my $pkg = $1;
|
|
my @funcs = split /,/, $2;
|
|
foreach (@funcs) {
|
|
chomp;
|
|
s/^\s*//;
|
|
push @pluginfuncs, "\*".$pkg."::".$_;
|
|
}
|
|
} else { # if the format is f1,f2, only for the functions in the xcatd
|
|
s/^\s*\(//;
|
|
s/\)\s*$//;
|
|
my @funcs = split /,/;
|
|
foreach (@funcs) {
|
|
chomp;
|
|
s/^\s*//;
|
|
push @xcatdfuncs, "\*main::".$_;
|
|
}
|
|
}
|
|
}
|
|
close (FUNLIST);
|
|
} else {
|
|
$enableall = 1;
|
|
}
|
|
|
|
no strict 'refs';
|
|
|
|
my @debugfuns = ();
|
|
# Get the functions of xcatd
|
|
my $xcatdpath = $::XCATROOT."/sbin/xcatd";
|
|
if (! open (XCATDLINES, "<$xcatdpath")) {
|
|
xCAT::MsgUtils->message("SL", "Enable subroutine calling trace failed: cannot open $xcatdpath");
|
|
} else {
|
|
my @sub_in_xcatd;
|
|
# Get all the name of subroutines except the xxx_callingtrace
|
|
while (<XCATDLINES>) {
|
|
if (/^\s*sub\s+([^\s]*)/) {
|
|
if (! /enable_callingtrace|disable_callingtrace|add_callingtrace/) {
|
|
push @sub_in_xcatd, $1;
|
|
}
|
|
}
|
|
}
|
|
close(XCATDLINES);
|
|
# Get all the symbols from the %main:: space
|
|
foreach my $fun (keys %main::) {
|
|
my $symfun = $main::{$fun};
|
|
if (($symfun =~ /^\*/) # must be a symbol
|
|
&& *{$symfun}{CODE} # must be a subroutine
|
|
&& grep (/\Q$fun\E/, @sub_in_xcatd) # must be defined in the xcatd
|
|
&& ($enableall || grep (/\Q$symfun\E/, @xcatdfuncs))) { # all or configured in the configuration file
|
|
push @debugfuns, $symfun;
|
|
}
|
|
}
|
|
}
|
|
|
|
# Get the functions of xCAT plugins
|
|
foreach my $plugin (\%xCAT::, \%xCAT_plugin::) {
|
|
# Get the path of the plugins
|
|
my $path = "";
|
|
foreach (keys %$plugin) {
|
|
my $glob = $plugin->{$_};
|
|
if ($glob =~ /\*([^:]*)::/) {
|
|
$path = $::XCATROOT."/lib/perl/$1/";
|
|
last;
|
|
}
|
|
}
|
|
# For each plugin moduel, search the matched functions
|
|
foreach my $xcatplugin (keys %$plugin) {
|
|
if ($xcatplugin =~ /[^\*].*::$/) {
|
|
# get the subroutines in the plugin file
|
|
my $pluginfile = $xcatplugin;
|
|
$pluginfile =~ s/:://;
|
|
# Ignore to enable the trace for the subroutines in the MsgUtils
|
|
if ($pluginfile eq "MsgUtils") {
|
|
next;
|
|
}
|
|
my $module_file = $path.$pluginfile.".pm";
|
|
my @sub_in_pm = ();
|
|
if (-r $module_file) {
|
|
open (LINES, "<$module_file") or last;
|
|
while (<LINES>) {
|
|
if (/^\s*sub\s+([^\s]*)/) {
|
|
push @sub_in_pm, $1;
|
|
}
|
|
}
|
|
close (LINES);
|
|
}
|
|
# Search the symbol from the space of plugin
|
|
foreach my $fun (keys %{$plugin->{$xcatplugin}}) {
|
|
my $symfun = $plugin->{$xcatplugin}{$fun};
|
|
if ($symfun =~ /^\*/ # must be a symbol
|
|
&& *{$symfun}{CODE} # must be a subroutine
|
|
&& grep (/\Q$fun\E/, @sub_in_pm) # must be defined in the plugin modules
|
|
&& ($enableall || grep (/\Q$symfun\E/, @pluginfuncs))) { # all or configured in the configuration file
|
|
push @debugfuns, $symfun;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
# return a new subroutine with some debug code to output the trace log
|
|
# and calling the original subroutine at the last
|
|
sub add_callingtrace {
|
|
my ($funname, $orig) = @_;
|
|
sub {
|
|
my $args = Dumper(@_);
|
|
#$args =~ s{\A\$VAR\d+\s*=\s*}{};
|
|
my $callstack = Carp::longmess;
|
|
|
|
# write the trace log to the trace file
|
|
print $::LOG_FILE_HANDLE "\n***************Calling of subroutine $funname***************\n";
|
|
print $::LOG_FILE_HANDLE localtime()."\n";
|
|
print $::LOG_FILE_HANDLE "Arguments: \n$args\n";
|
|
print $::LOG_FILE_HANDLE "Calling stack: \n $callstack\n";
|
|
&$orig;
|
|
};
|
|
}
|
|
|
|
# Replace the original subroutine with a trace log added one
|
|
print $::LOG_FILE_HANDLE "##########Enabled the calling trace for: ###########\n";
|
|
foreach my $debugfun (@debugfuns) {
|
|
print $::LOG_FILE_HANDLE " $debugfun\n";
|
|
if (defined ($::DEBUG_FUN{"$debugfun"}{'debug'})) {
|
|
# if the trace added subroutine has been defined
|
|
*{"$debugfun"} = $::DEBUG_FUN{"$debugfun"}{'debug'};
|
|
#print " => $::DEBUG_FUN{$debugfun}{debug}\n";
|
|
} else {
|
|
my $oldfun = *{$debugfun}{CODE};
|
|
# Bakcup the original subroutine
|
|
$::DEBUG_FUN{"$debugfun"}{'orig'} = $oldfun;
|
|
#print "$debugfun".": $::DEBUG_FUN{$debugfun}{orig}";
|
|
# otherise creating a trace added subroutine from scratch
|
|
*{"$debugfun"} = add_callingtrace($debugfun, $oldfun);
|
|
$::DEBUG_FUN{"$debugfun"}{'debug'} = *{"$debugfun"}{CODE};
|
|
#print " => $::DEBUG_FUN{$debugfun}{debug}\n";
|
|
}
|
|
}
|
|
print $::LOG_FILE_HANDLE "####################################################\n";
|
|
}
|
|
|
|
# Go through all the trace log added subroutines, replace it with the original one
|
|
sub disable_callingtrace {
|
|
no strict 'refs';
|
|
print $::LOG_FILE_HANDLE "##########Disabled the calling trace for: ##########\n" if ($::LOG_FILE_HANDLE);
|
|
foreach my $glob (keys %::DEBUG_FUN) {
|
|
if (defined $::DEBUG_FUN{$glob}{'orig'}) {
|
|
*{"$glob"} = $::DEBUG_FUN{$glob}{'orig'};
|
|
print $::LOG_FILE_HANDLE "$glob\n" if ($::LOG_FILE_HANDLE);
|
|
}
|
|
}
|
|
print $::LOG_FILE_HANDLE "####################################################\n" if ($::LOG_FILE_HANDLE);
|
|
xCAT::MsgUtils->stop_logging();
|
|
}
|
|
|
|
|
|
|