File Coverage

blib/lib/Slurm/Sacctmgr/EntityBaseAddDel.pm

Criterion	Covered	Total	%
statement	87	100	87.0
branch	20	42	47.6
condition	9	27	33.3
subroutine	12	14	85.7
pod	4	4	100.0
total	132	187	70.5

#!/usr/local/bin/perl
#
#Base class for sacctmgr entities which can be do "add" and "delete"

package Slurm::Sacctmgr::EntityBaseAddDel;
use strict;
use warnings;
use base qw(Slurm::Sacctmgr::EntityBase);
use Carp qw(carp croak);

#This is intended for regression tests only
my $_last_raw_output;
sub _ebadddel_last_raw_output($)
{	return $_last_raw_output;
}
sub _clear_ebadddel_last_raw_output($)
{       $_last_raw_output = [];
}


sub _sacctmgr_add_cmd($)
{	my $class = shift;
	$class = ref($class) if ref($class);

	my $base = $class->_sacctmgr_entity_name;
	return [ '-i', 'add', $base ];
}

sub _sacctmgr_delete_cmd($)
{	my $class = shift;
	$class = ref($class) if ref($class);

	my $base = $class->_sacctmgr_entity_name;
	return [ '-i', 'delete', $base ];
}

sub _sacctmgr_fields_addable($$)
#This lists the fields we can include in a sacctmgr add/create call
#May in general depend on version of slurm, hence sacctmgr argument.
#Should be overloaded in all children classes
{       my $class = shift;
	my $sacctmgr = shift;
        $class = ref($class) if ref($class);
        die "Class $class forgot to overload _sacctmgr_fields_addable";
}

sub _my_sacctmgr_add_clause($$)
#This might need to be overloaded.
#Returns a hash ref for adding this instance into DB with sacctmgr.
{	my $obj = shift;
	my $sacctmgr = shift;
	croak "Must be called as an instance method at "
		unless $obj && ref($obj);
	my $me = ref($obj) . '::_my_sacctmgr_add_clause';
	die "$me: Missing req param sacctmgr at " unless $sacctmgr;

	my $namefld = $obj->_sacctmgr_name_field;
	my $fields = $obj->_sacctmgr_fields_addable($sacctmgr);

	my %hash = ();
	FIELD: foreach my $fld (@$fields)
	{	my $fldname=$fld;
		$fldname = $namefld if $fld eq 'name';
		my $meth = $fld;
		my $val = $obj->$meth;
		next FIELD unless defined $val;
		$hash{$fldname} = $obj->_stringify_value($val, $me);
	}
	return \%hash;
}

sub sacctmgr_add($$@)
#Does sacctmgr list to get a add an entity of this type with specified
#fields (given as key => value pairs).
{	my $class = shift;
	my $sacctmgr = shift;
	my %fields = @_;

	my $me = 'sacctmgr_add';
	croak "No/invalid Slurm::Sacctmgr object passed to $me at "
		unless $sacctmgr && ref($sacctmgr);

	my $cmd = $class->_sacctmgr_add_cmd;
	my @cmd = @$cmd;

	my $ok_if_exists = delete $fields{'--ok-if-previously-exists'};

	#Throw a sort in to make ordering deterministic for regression tests
	KEY: foreach my $key (sort(keys %fields))
	{	my $val = $fields{$key};
		$val = $class->_stringify_value($val);
		#push @cmd, "$key='$val'";
		#Do not add extra quotes around '$val'; they are NOT needed
		#(eventually being passed to execvp call, so NEVER go through
		#shell interpolation, so not needed), and can cause issues
		#on certain sactmgr cmds which do not strip away quotes
		#(e.g. setting defaultqos).
		push @cmd, "$key=$val";
	}

	my $list = $sacctmgr->run_generic_sacctmgr_cmd(@cmd);
	unless ( $list && ref($list) )
	{	#Got an error.
		chomp $list if $list;
		if ( $list =~ /Nothing new added/ )
		{	return [] if $ok_if_exists;
			croak "Trying to add existing object at ";
		}
		croak "Error running add cmd for $class: $list at ";
	}
	$_last_raw_output = $list;
	return $list;

}

sub sacctmgr_add_me($$@)
#Does sacctmgr list to get add an entity record for this Perl object instance.
{	my $obj = shift;
	my $sacctmgr = shift;
	my %extra = @_;

	my $me = 'sacctmgr_add_me';
	croak "$me must be called as an instance method at "
		unless $obj && ref($obj);
	croak "No/invalid Slurm::Sacctmgr object passed to $me at "
		unless $sacctmgr && ref($sacctmgr);

	my $addclause = $obj->_my_sacctmgr_add_clause($sacctmgr);

	#Add extra fields
	$addclause = { %$addclause, %extra };
	return $obj->sacctmgr_add($sacctmgr, %$addclause);

}

sub sacctmgr_delete($$@)
#Does sacctmgr delete to delete all of the entities of this type
#matching specified criteria
{	my $class = shift;
	my $sacctmgr = shift;
	my %where = @_;

	my $me = 'sacctmgr_delete';
	croak "No/invalid Slurm::Sacctmgr object passed to $me at "
		unless $sacctmgr && ref($sacctmgr);

	my $cmd = $class->_sacctmgr_delete_cmd;
	my @cmd = @$cmd;

	my @where = ();
	foreach my $key (sort (keys %where) )
	{	my $val = $where{$key};
		$val = '' unless defined $val;
		#push @where, "$key='$val'";
		#Do not add extra quotes around '$val'; they are NOT needed
		#We do NOT go through shell interpolation
		push @where, "$key=$val";
	}
	if ( @where )
	{	push @cmd, 'where', @where;
	} else
	{	croak "$me refusing to issue delete w/out where clause at ";
	}

	my $list = $sacctmgr->run_generic_sacctmgr_cmd(@cmd);
	unless ( $list && ref($list) )
	{	#"Nothing deleted" is NOT an error
		#return 0 to distinguish from undef for actual deletion case
		return 0 if $list =~ /Nothing deleted/;
		croak "Error running delete cmd for $class: $list at ";
	}
	$_last_raw_output = $list;
	return;
}

sub sacctmgr_delete_me($$)
#Does sacctmgr delete to the sacctmgr entity corresponding to this Perl
#object instance
{	my $obj = shift;
	my $sacctmgr = shift;

	my $me = 'sacctmgr_delete_me';
	croak "$me must be called as an instance method at "
		unless $obj && ref($obj);
	croak "No/invalid Slurm::Sacctmgr object passed to $me at "
		unless $sacctmgr && ref($sacctmgr);

	my $where = $obj->_my_sacctmgr_where_clause;
	return $obj->sacctmgr_delete($sacctmgr, %$where);
}

1;
__END__