File Coverage

blib/lib/Slurm/Sacctmgr/EntityBaseModifiable.pm

Criterion	Covered	Total	%
statement	57	66	86.3
branch	10	22	45.4
condition	9	22	40.9
subroutine	9	10	90.0
pod	2	2	100.0
total	87	122	71.3

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

package Slurm::Sacctmgr::EntityBaseModifiable;
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 _ebmod_last_raw_output($)
{       return $_last_raw_output;
}
sub _clear_ebmod_last_raw_output($)
{	$_last_raw_output = [];
}

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

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

sub _sacctmgr_fields_updatable($$)
#This lists the fields we can include in a sacctmgr modify 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_updatable";
}

sub sacctmgr_modify($$$$;$)
#Does sacctmgr update one or more entities of this type, as specified
#by $where hash ref (as key=>value pairs) to values in $update hash ref
#(again key=>value pairs).  Any non-string values in update hash are
#stringified using _stringify_value.
{	my $class = shift;
	my $sacctmgr = shift;
	my $where = shift || {};
	my $update = shift;
	my $quiet = shift;

	my $me = 'sacctmgr_modify';
	croak "No/invalid Slurm::Sacctmgr object passed to $me at "
		unless $sacctmgr && ref($sacctmgr);
	croak "No/invalid update hash passed to $me at "
		unless $update && ref($update) eq 'HASH' &&
		scalar(keys %$update);

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

	my ($key, $val);

	my @where = ();
	foreach $key (sort (keys %$where))
	{	$val = $where->{$key};
		#$val = '' unless defined $val;
		$val = $class->_stringify_value($val);
		#push @where, "$key='$val'";
		#No need for quoting argument, not going through shell
		#and in some cases might cause problems with sacctmgr interpretting
		#quotes as part of text
		push @where, "$key=$val";
	}
	if (@where )
	{	push @cmd, 'where', @where;
	}

	my @set = ();
	foreach $key (sort (keys %$update))
	{	$val = $update->{$key};
		#$val = '' unless defined $val;
		$val = $class->_stringify_value($val);
		#push @set, "$key='$val'";
		#No need for quoting argument, not going through shell
		#and in some cases might cause problems with sacctmgr interpretting
		#quotes as part of text (e.g. setting grptresmins)
		push @set, "$key=$val";
	}
	unless (@set )
	{	croak "No fields to set for $me at ";
	}
	push @cmd, 'set', @set;

	my $list = $sacctmgr->run_generic_sacctmgr_cmd(@cmd);
	unless ( $list && ref($list) eq 'ARRAY' )
	{	croak "Error running modify cmd for $class: $list at ";
	}

	if ( scalar(@$list) && ! $quiet )
	{	my $tmp = join "\n", @$list;
		if ( $tmp !~ /^\s*Modified / )
		{	#We got something other than the normal
			#' Modified _entity_ ...' message
			warn "sacctmgr_modify returned:\n$tmp\n at ";
		}
	}
	$_last_raw_output = $list;
	return;
}

sub sacctmgr_modify_me($$@)
#Does sacctmgr update to the sacctmgr entity corresponding to this Perl
#object instance, setting to the %update values as key => value
{	my $obj = shift;
	my $sacctmgr = shift;
	my %update = @_;
	my $quiet = delete $update{QUIET};

	my $me = 'sacctmgr_modify_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_modify($sacctmgr, $where, \%update, $quiet);
}

1;
__END__