File Coverage

blib/lib/Slurm/Sacctmgr.pm

Criterion	Covered	Total	%
statement	160	221	72.4
branch	39	82	47.5
condition	6	15	40.0
subroutine	19	21	90.4
pod	4	8	50.0
total	228	347	65.7

#!/usr/local/bin/perl
#
#Perl wrappers for Slurm sacctmgr

package Slurm::Sacctmgr;
use strict;
use warnings;
use base qw(Class::Accessor);
use Carp qw(carp croak);

use version; our $VERSION = qw(1.1.0);


#-------------------------------------------------------------------
#	Globals
#-------------------------------------------------------------------

#By default, use the sacctmgr found in your path
my $DEFAULT_SACCTMGR_CMD='sacctmgr';
#If you wish to default to something else, you can either modify the
#class method default_sacctmgr_path_version, and/or uncomment
#and change the line below.
#$DEFAULT_SACCTMGR_CMD='/usr/local/slurm/bin/sacctmgr';
#It is also recommended that you set the $DEFAULT_SACCTMGR_VERSION to the
#Slurm version number associated with that specified sacctmgr command.
#Failure to do so might result in the package needing to issue extra
#sacctmgr commands to determine what version of sacctmgr being run, which is inefficient
my $DEFAULT_SACCTMGR_VERSION;
#Uncomment and modify this if the Slurm version for the sacctmgr command listed
#in $DEFAULT_SACCTMGR_CMD is known
#$DEFAULT_SACCTMGR_VERSION='15.08.2';
#The default version of default_sacctmgr_path_version just returns these
#two values; modified versions might or might not use these values.

#This is intended for regression tests only
my $_last_raw_output;
sub _sacctmgr_last_raw_output($)
{       return $_last_raw_output;
}

my @SACCTMGR_CMD_CAPABILITIES_LIST =
(	'trackable_resources', #Supports TRES, at least at basic level
);

my %SACCTMGR_CMD_CAPABILITIES_HASH = map { $_ => undef } @SACCTMGR_CMD_CAPABILITIES_LIST;


#-------------------------------------------------------------------
#	Accessors
#-------------------------------------------------------------------

my @rw_accessors = qw(
	dryrun
	verbose
);

my @ro_accessors = qw(
	sacctmgr
	slurm_version
);
#	_sacctmgr_cmd_capabilities
#	_cached_sacctmgr_cmd_capabilities

__PACKAGE__->mk_accessors(@rw_accessors);
__PACKAGE__->mk_ro_accessors(@ro_accessors);


my @required_parms = qw(
	sacctmgr
);

#-------	Special accessors/mutators

sub slurm_version($;$)
#Gets version of slurm/sacctmgr cmd
#Preferably our cached version, but (unless $cachedonly flag is set)
#will call sacctmgr to get it if needed
#If unknown and $cachedonly set, will return undef.
{	my $self = shift;
	my $cachedonly = shift;

	my $svers = $self->get('slurm_version');
	return $svers if $svers;

	return if $cachedonly;

	return $self->_determine_slurm_version; #This sets 'slurm_version' data member
}

#-------------------------------------------------------------------
#	Constructors, etc
#-------------------------------------------------------------------

sub new($;@)
{	my $class = shift;
	my @args = @_;

	my $obj = {};
	bless $obj, $class;

	$obj->_parse_args(@args);
	$obj->_set_defaults;
	$obj->_init;

	return $obj;
}

sub _parse_args($@)
{	my $obj = shift;
	my %args = @_;

	my ($arg, $meth, $val);
	RWARG: foreach $arg (@rw_accessors)
	{	next RWARG unless exists $args{$arg};
		$val = delete $args{$arg};
		next RWARG unless defined $val;
		$meth = $arg;
		$obj->$meth($val);
	}

	ROARG: foreach $arg (@ro_accessors)
	{	next ROARG unless exists $args{$arg};
		$val = delete $args{$arg};
		next ROARG unless defined $val;

		if ( $arg eq 'sacctmgr' || $arg eq 'slurm_version' )
		{	#This gets handled specially
			my ($tmppath, $tmpver);
			if ( $arg eq 'sacctmgr' )
			{	$tmppath = $val;
				$tmpver = delete $args{'slurm_version'};
			} elsif ( $arg eq 'slurm_version' )
			{	$tmpver = $val;
				$tmppath = delete $args{'sacctmgr'};
			} else
			{	die "Should not reach here at ";
			}
			$obj->_set_sacctmgr_path($tmppath, $tmpver);
			next ROARG;
		}

		$meth = $arg;
		$obj->set($meth,$val);
	}


	#Warn about unknown arguments
	if ( scalar(keys %args) )
	{	my $tmp = join ", ", (keys %args);
		croak "Unrecognized arguments [ $tmp ] to constructor at ";
	};
}

sub _set_defaults($)
{	my $obj = shift;

	my ($tmp);
	$tmp = $obj->sacctmgr;
	unless ( $tmp )
	{	my @tmp = $obj->default_sacctmgr_path_version;
		$obj->_set_sacctmgr_path(@tmp);
	}

	return;
}

sub _init($)
{	my $obj = shift;

	my ($fld, $meth, $val);
	foreach $fld (@required_parms)
	{	$meth = $fld;
		$val = $obj->$meth;
		unless ( defined $val )
		{	croak "Missing required argument $fld";
		}
	}

}

#-------------------------------------------------------------------
#	Sacctmgr/slurm versioning stuff
#-------------------------------------------------------------------

sub default_sacctmgr_path_version($)
#This returns the default path to sacctmgr, and the default Slurm
#version, for use when defaulting sacctmgr value during construction
#of an instance.  The path and version are returned as elements
#of a 2 value list.
#
#This version just returns the lexicals
#	$DEFAULT_SACCTMGR_CMD and
#	$DEFAULT_SACCTMGR_VERSION
#defined at the top of this file.  For most cases, it is easiest to
#just change those variables.  This routine is provided as a hook
#in case system admins need to do something more complicated when
#defaulting these.
{	my $class = shift;

	return ( $DEFAULT_SACCTMGR_CMD,
		$DEFAULT_SACCTMGR_VERSION );
}

sub sacctmgr_capabilities_by_version($$)
#Return the appropriate sacctmgr_cmd_capabilities hash for a given
#Slurm version number.  This is our "guess" of what various versions
#can/cannot do.
#Returns hash ref.
#This is a class method
{	my $class = shift;
	my $slurm_version = shift;
	my $me = __PACKAGE__ . '::sacctmgr_capabilities_by_version';

	return unless $slurm_version;
	#Strip leading/trailing whitespace from version
	$slurm_version=~ s/^\s*//; $slurm_version =~ s/\s*$//;

	my @vcomps = split /\./, $slurm_version;
	my $slurm_major = $vcomps[0];

	#REturn unknown caps if bad version given
	return unless $slurm_major =~ /^\d+$/;

	#Guess at capabilities
	if ( $slurm_major < 15 )
	{	#Looks like an older, pre-TRES version of slurm
		return
			{	trackable_resources => 0,
			};
	} else
	{	#Looks like a newer version of Slurm, with TRES support
		return
			{	trackable_resources => 1,
			};
	}
}

sub _set_sacctmgr_path($$;$)
#Sets sacctmgr path and version, and the capabilities hash
{	my $obj = shift;
	my $newpath = shift;
	my $newversion = shift;
	#This should only be called via new???
	my $me = __PACKAGE__ . '::new';

	unless ( $newpath )
	{	$newpath = $DEFAULT_SACCTMGR_CMD;
		unless ( $newversion )
		{	#Only default if defaulting path as well
			$newversion = $DEFAULT_SACCTMGR_VERSION;
		}
	}

	$obj->set('sacctmgr', $newpath); #newpath should always be set
	if ( $newversion )
	{	$obj->set('slurm_version', $newversion);
	} else
	{	#No version given, so set version to undef
		$obj->set('slurm_version', undef);
	}
	#Always clear capabilities_hash
	$obj->set('_capabilities_hash', undef);
}

sub _determine_slurm_version($)
#Calls 'sacctmgr --version' to get our slurm version
#Sets slurm_version data method and returns version
{	my $obj = shift;
	my $me = __PACKAGE__ . '::_determine_slurm_version';

	my @args = ( '--version' );

	my ( $err, @out) = $obj->_run_generic_sacctmgr_cmd_always(@args);

	my $errstr;
	if ( $err )
	{	$errstr = "Exit code: $err";
		my $output = join "\n", @out;
		$errstr .= "\n$output" if $output;
		croak "$me: Error running sacctmgr --version to get slurm version\n$errstr\nat ";
	}

	my @vlines = grep /^slurm/, @out;
	unless ( scalar(@vlines) )
	{	$errstr = join "\n", @out;
		croak "$me: Unable to get slurm version from 'sacctmgr --version'\n" .
			"Output was\n$errstr\nat ";
	}

	my $version = $vlines[0];
	$version =~ s/^slurm\s*//;
	$obj->set('slurm_version', $version);
	return $version;
}

sub sacctmgr_cmd_supports($$;$)
#This checks if the current sshare command supports the named capability.
#If $cachedonly is set, will only used cached information (i.e. will
#NOT invoke an sacctmgr call to find out the version)
#Returns 1 if supports, 0 if doesn't, and undef if unknown (should
#only occur if $cachedonly is set)
{	my $self = shift;
	my $capname = shift;
	my $cachedonly = shift;
	my $me = __PACKAGE__ . '::sacctmgr_cmd_supports';

	unless ( exists $SACCTMGR_CMD_CAPABILITIES_HASH{$capname} )
	{	warn "$me: Unrecognized capability named '$capname' at ";
		return 0; #Unrecognized => unsupported
	}

	my $capshash = $self->get('_capabilities_hash');
	unless ( $capshash && ref($capshash) eq 'HASH' )
	{	#No capabilities hash, do we have a slurm_version
		my $svers = $self->slurm_version($cachedonly);

		#svers should only be undef if cachedonly and need to look up
		return unless defined $svers;

		$capshash = $self->sacctmgr_capabilities_by_version($svers);
		unless ( $capshash && ref($capshash) )
		{	croak "$me: Unable to get capabilities hash for Slurm version $svers at ";
		}
		$self->set('_capabilities_hash', $capshash);
	}

	my $tmp = $capshash->{$capname};
	return $tmp if defined $tmp;
	warn "$me: Capability $capname not in capshash at ";
	return;
}

#
#-------------------------------------------------------------------
#	Basic sacctmgr commands
#-------------------------------------------------------------------

sub _noshell_backticks($$@)
#Calls an external command using pipes and forks so no shell gets invoked
#Returns ($err, @out) where $err is the error is the exit status of
#the command, and @out is the list of output returned, line by line.
#If $mode is 0, only STDOUT is returned in @out,
#If $mode is non-zero, STDERR is dupped onto STDOUT and also returned.
{	my $obj = shift;
	my $mode = shift;
	my @cmd = @_;

	#Exit code for errors in exec in child
	my $chd_excode=254;

	my ($err, @out, $PIPE, $res);

	if ( $res = open($PIPE, "-|" )  )
	{	#Parent
		if ( ! defined $res )
		{	my $tmp = join ' ', @cmd;
			die "Pipe to '$tmp' failed: $!";
		}
		@out = <$PIPE>;
		$res = close $PIPE;
		$err = $?;
		if ( $err && ( ($err >> 8)  == $chd_excode ) )
		{	#We (probably?) got an exception running exec in child process
			#Re raise the exception
			my $exc = join '', @out;
			die $exc;
		}
		return ($err, @out);
	} else
	{	#Child
		#Duplicate stderr onto stdout if so requested
		if ( $mode )
		{	unless ( open(STDERR, '>&STDOUT') )
			{	print "Cannot dup stderr to stdout in child";
				die "Cannot dup stderr to stdout in child";
			}
		}
		#Wrap exec in an eval, and exit on error, not die.
		#Otherwise, if _noshell_backticks is put in an eval block, an exception raised
		#by exec (e.g. taint issues) will result in both child and parent continuing from
		#the user's eval block.  See e.g. http://www.perlmonks.org/?node_id=166538
		eval { exec { $cmd[0] } @cmd; #Not subject to shell escapes
		};
		#We only reach here if exec raised an exception
		warn "$@" if $@;
		exit $chd_excode;
	}
}

sub _run_generic_sacctmgr_cmd_always($@)
#Run a generic sacctmgr cmd, returning results
#Does NOT honors dryrun.
#This should only be called directly for commands which do NOT
#modify the database
{	my $obj = shift;
	my @args = @_;

	my $cmd = $obj->sacctmgr;
	my $mode = 1;
	if ( $obj->verbose )
	{	#Verbose mode:
		#Output command before executing it
		my @tmp = ($obj->sacctmgr, @args);
		my $tmpsp = '';
		my $tmpcmd = '';
		#Quote any args with whitespace so verbose output looks better
		foreach (@tmp)
		{	my $tmp = $_;
			if ( $tmp =~ /\s/ )
			{	#Quote it if it has whitespace
				$tmp = "'$tmp'";
			}
			$tmpcmd .= $tmpsp . $tmp;
			$tmpsp = " ";
		}
		#my $tmpcmd = join ' ', @tmp;
		print STDERR "[VERBOSE] $tmpcmd\n";
	}
	my ($err, @out ) = $obj->_noshell_backticks($mode, $cmd, @args);
	$_last_raw_output = [ @out ];
	return ($err, @out);
}

sub run_generic_sacctmgr_cmd($@)
#Run a generic sacctmgr cmd, returning results
#Honors dryrun
#Returns list ref of output, line by line on success.
#Returns non-ref error message on error.
{	my $obj = shift;
	my @args = @_;

	if ( $obj->dryrun )
	{	unshift @args, $obj->sacctmgr;
		#my $cmd = join ' ', @args;
		#Quote any args with whitespace so debug output looks better
		my $cmd = '';
		my $tmpsp = '';
		foreach (@args)
		{	my $tmp = $_;
			if ( $tmp =~ /\s/ )
			{	#quote it if has whitespace
				$tmp = "'$tmp'";
			}
			$cmd .= $tmpsp . $tmp;
			$tmpsp = ' ';
		}
		print STDERR "[DRYRUN] $cmd\n";
		return [];
	}
	my ($err, @out) = $obj->_run_generic_sacctmgr_cmd_always(@args);
	if ( $err )
	{	my $errstr = "Exit code: $err";
		my $output = join "\n", @out;
		$errstr .= "\n$output" if $output;
		return $errstr;
	}
	#return $err if $err;
	return [ @out ];

}

sub run_generic_safe_sacctmgr_cmd($@)
#Run a "safe" generic sacctmgr cmd, returning results
#which should not modify accounting info.
#Does NOT honor dryrun, as command is "safe"
#We append a --readonly to command to make sure it IS safe
#
#Returns list ref of output, line by line on success.
#Returns non-ref error message on error.
{	my $obj = shift;
	my @args = @_;

	push @args, '--readonly';
	my ($err, @out) = $obj->_run_generic_sacctmgr_cmd_always(@args);
	if ( $err )
	{	my $errstr = "Exit code: $err";
		my $output = join "\n", @out;
		$errstr .= "\n$output" if $output;
		return $errstr;
	}
	#return $err if $err;
	return [ @out ];
}

sub run_generic_sacctmgr_list_command($@)
#Runs a sacctmgr list command, returns output as a list ref of list refs
#of the fields in order.
#(Tried using hash refs, but those get abbreviated.  Ugh!)
#'list' should be included in the command spec
#
#On error, returns non-ref error message/error code
#
#Appends --parsable2 and --noheader to the command
#Does NOT honor dryrun (as --readonly)
{	my $obj = shift;
	my @cmd = @_;

	push @cmd, '--parsable2', '--noheader';
	my $lines = $obj->run_generic_safe_sacctmgr_cmd(@cmd);

	return $lines unless $lines && ref($lines) eq 'ARRAY';

	my $results = [];
	foreach my $line (@$lines)
	{	chomp $line;
		my @values = split /\|/, $line;
		push @$results, \@values;
	}

	return $results;
}


1;
__END__