File Coverage

blib/lib/Slurm/Sacctmgr/EntityBaseListable.pm

Criterion	Covered	Total	%
statement	67	87	77.0
branch	14	30	46.6
condition	9	27	33.3
subroutine	9	11	81.8
pod	4	4	100.0
total	103	159	64.7

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

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


#2016-03-09: dropping this.
#Accessors/mutators for non-string types should convert strings as needed
# #-------------------------------------------------------------------
# #	Data conversion routines
# #-------------------------------------------------------------------
#
# sub _data_converter_csv($)
# #Takes a csv and returns a list ref
# {	my $csv = shift;
# 	return unless $csv;
#
# 	my @data = split /\s*,\s*/, $csv;
# 	return [ @data ];
# }
#
# my %DATA_TYPES =
# (	csv => \&_data_converter_csv,
# );

#-------------------------------------------------------------------
#	List command
#-------------------------------------------------------------------

sub _sacctmgr_list_cmd($$)
{	my $class = shift;
	my $sacctmgr = shift;
	$class = ref($class) if ref($class);
	my $me = $class . '::_sacctmgr_list_cmd';

	die "$me: Missing sacctmgr param at " unless $sacctmgr && ref($sacctmgr);

	my $base = $class->_sacctmgr_entity_name;
	my $fields = $class->_sacctmgr_fields_in_order($sacctmgr);
	my $fmtstr = join ",", @$fields;
	return [ 'list', $base, "format=$fmtstr" ];
}

sub new_from_sacctmgr_list_record($$$)
#Generates a new instance from a list ref as obtained from one of the
#sacctmgr list commands
{	my $class = shift;
	my $record = shift;
	my $sacctmgr = shift; #Needed for slurm_version specific stuff
	my $me = __PACKAGE__ . '::new_from_sacctmgr_list_record';

	croak "$me: Missing req parameter sacctmgr at " unless $sacctmgr && ref($sacctmgr);

	my $fields = $class->_sacctmgr_fields_in_order($sacctmgr);
#2016-03-09: dropping special_fields; instead have accessors customized to handle either
#the real type or a string as input.  On output convert to string based on ref type
#	my $special = $class->_special_fields;
	my @record = @$record;

	my @newargs = ();

	foreach my $fld (@$fields)
	{	my $val = shift @record;
		$fld = lc $fld;

		$val = undef if defined $val && $val eq '';

#		my $type = $special->{$fld};
#		if ( $type )
#		{	my $dcf = $DATA_TYPES{$type};
#			unless ( $dcf )
#			{	die "Class $class: invalid data type $type for field $fld";
#			}
#			$val = &$dcf($val);
#		}
		push @newargs, $fld, $val;
	}

	my $obj = $class->new(@newargs);
	return $obj;
}

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

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

	my $cmd = $class->_sacctmgr_list_cmd($sacctmgr);
	my @cmd = @$cmd;

	#Throw a sort in to make ordering deterministic for regression tests
	foreach my $key (sort (keys %where) )
	{	my $val = $where{$key};
		$val = '' unless defined $val;
		#push @cmd, "$key='$val'";
		#Do NOT put extra quotes around $val; they are NOT needed
		#(we do not go through shell interpolation)
		push @cmd, "$key=$val";
	}

	my $list = $sacctmgr->run_generic_sacctmgr_list_command(@cmd);
	unless ( $list && ref($list) )
	{	croak "Error running list cmd for $class: $list at ";
	}
	$_last_raw_output = $sacctmgr->_sacctmgr_last_raw_output;

	my @objects = ();
	foreach my $rec (@$list)
	{	my $obj = $class->new_from_sacctmgr_list_record($rec, $sacctmgr);
		push @objects, $obj;
	}

	return [@objects];
}

sub sacctmgr_list_me($$)
#Takes an instance of an entity, and does a sacctmgr list to find the
#current value in SlurmDB for this entity instance
#Returns undef if no matches (I don't exist)
#Returns a new instance with that info
#On error, returns a non-ref error string
{	my $obj = shift;
	my $sacctmgr = shift;

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

	my $where = $obj->_my_sacctmgr_where_clause;
	my $list = $obj->sacctmgr_list($sacctmgr, %$where);
	return $list unless $list && ref($list) eq 'ARRAY';
	return unless scalar(@$list); #No matches, I don't exist

	if ( scalar(@$list) > 1 )
	{	my @tmp = map { "$_='" .  $where->{$_} . "'" } (keys %$where);
		my $tmp = join ", ", @tmp;
		my $class = ref($obj);
		return "Multiple  objects of type $class found with [$tmp]";
	}

	my $obj2 = $list->[0];
	return $obj2;
}

sub new_from_sacctmgr_by_name($$$)
#Get a new object for this entity class by looking up the appropriate
#entity from sacctmgr by the entity's name.
#
#Returns undef if no object with that name exists.
#Returns non-ref true value if encountered error (error message)
#Returns the object ref if succeeded.
{	my $class = shift;
	my $sacctmgr = shift;
	my $name = shift;

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

	my %where = ( name => $name );
	my $list = $class->sacctmgr_list($sacctmgr, %where);

	return $list unless $list && ref($list) eq 'ARRAY'; #Error
	return unless scalar(@$list); #No matches, I don't exist

	if ( scalar(@$list) > 1 )
	{	croak "$me: Error, multiple entities of type $class named '$name' found, aborting at ";
	}
	my $obj = $list->[0];
	return $obj;
}

1;
__END__