File Coverage

blib/lib/Slurm/Sacctmgr/EntityBase.pm

Criterion	Covered	Total	%
statement	170	194	87.6
branch	41	74	55.4
condition	16	31	51.6
subroutine	25	29	86.2
pod	1	3	33.3
total	253	331	76.4

#!/usr/local/bin/perl
#
#Base class for sacctmgr entities

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

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

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

sub _ro_fields($)
{	return [];
}

sub _rw_fields($)
{	return [];
}

sub _required_fields($)
{	return [];
}

#2016-03-09: dropping special_fields hash
#instead, have custom accessor/mutators handle string input and convert to proper type
#for output, output string based on ref type
# sub _special_fields($)
# #This should be overloaded to return any fields with special data types
# #for this class of entity
# {	my $class = shift;
# 	return {};
# }


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

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

	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 $accessors = $obj->_rw_fields;
	my ($arg, $meth, $val);
	RWARG: foreach $arg (@$accessors)
	{	next RWARG unless exists $args{$arg};
		$val = delete $args{$arg};
		next RWARG unless defined $val;
		$meth = $arg;
		$obj->$meth($val);
	}

	$accessors = $obj->_ro_fields;
	ROARG: foreach $arg (@$accessors)
	{	next ROARG unless exists $args{$arg};
		$val = delete $args{$arg};
		next ROARG unless defined $val;
		$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;

	return;
}

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

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

}


#-------------------------------------------------------------------
#	Special constructor to generate from a sacctmgr list entry
#-------------------------------------------------------------------

sub _sacctmgr_fields($)
#Should return a list ref of sacctmgr field names known about
#Will include field names for ALL known versions of sacctmgr;
{	my $class = shift;
	$class = ref($class) if ref($class);
	die "Class $class forgot to overload _sacctmgr_fields";
}


sub _sacctmgr_fields_in_order($$)
#Should return a list ref of field names in order sacctmgr will return them
#Requires Slurm::Sacctmgr instance (as in general may depend on version
#of slurm)
{	my $class = shift;
	my $sacctmgr = shift;
	$class = ref($class) if ref($class);
	die "Class $class forgot to overload _sacctmgr_fields_in_order";
}

#-------------------------------------------------------------------
#	Data conversion routines
#-------------------------------------------------------------------

sub _string2arrayref($$;$)
#This converts a string like 'joe,steve,bob' to [ 'joe', 'steve', 'bob' ]
{	my $class = shift;
	my $string = shift;
	my $me = shift || ( __PACKAGE__ . '::_string2arrayref' );
	return unless defined $string;

	#Strip leading/trailing spaces
	$string =~ s/^\s*//; $string =~ s/\s*$//;
	return unless $string;

	my @recs = split /\s*,\s*/, $string;
	return [ @recs ];
}

sub _arrayref2string($$;$)
#Reverse of _string2arrayref.
#This converts an array ref  like [ 'joe', 'steve', 'bob' ] to 'joe,steve,bob'
{	my $class = shift;
	my $arrayref = shift;
	my $me = shift || ( __PACKAGE__ . '::_arrayref2string' );
	return unless defined $arrayref;

	croak "$me: arrayref2string given non array ref '$arrayref' at "
		unless $arrayref && ref($arrayref) eq 'ARRAY';

	my $string = join ',', @$arrayref;
	return $string;
}


sub _string2hashref($$;$)
#This converts a string like "cpu=10000,node=50" to { cpu=>10000, node=>50}
#hash ref.  Intended for use with TRESes
{	my $class = shift;
	my $string = shift;
	my $me = shift || ( __PACKAGE__ . '::_string2hashref' );
	return unless defined $string;

	#Strip leading/trailing spaces
	$string =~ s/^\s*//; $string =~ s/\s*$//;
	return unless $string;

	my @recs = split /\s*,\s*/, $string;
	my $hash = {};
	foreach my $rec (@recs)
	{	croak "$me: Invalid component '$rec' in TRES string '$string', no =, at "
			unless $rec =~ /=/;
		my ( $fld, $val ) = split /\s*=\s*/, $rec;
		croak "$me: Duplicate TRES '$fld' in TRES string '$string' at "
			if exists $hash->{$fld};
		$hash->{$fld} = $val;
	}
	return $hash;
}

sub _hashref2string($$;$)
#Reverse of _string2hashref
#This converts a hashref like { node=>50, cpu=>10000} to "cpu=10000,node=50"
#NOTE: hash keys are always in order, to provide determinism needed for regression tests
#Intended for use with TRESes
{	my $class = shift;
	my $hashref = shift;
	my $me = shift || ( __PACKAGE__ . '::_hashref2string' );
	return unless defined $hashref;

	croak "$me: hashref2string given non hash ref '$hashref' at "
		unless $hashref && ref($hashref) eq 'HASH';

	my @recs = map { "$_=$$hashref{$_}" } (sort keys %$hashref );
	my $string = join ',', @recs;
	return $string;
}

sub _stringify_value($$;$)
#Converts a value to a string, based on ref type.
#Undef => ''
#Non-ref scalars passed unchanged
#hash ref converted using _hashref2string
#array refs converted using _arrayref2string
{	my $class = shift;
	my $value = shift;
	my $me = shift || ( __PACKAGE__ . '::_stringify_value');

	return '' unless defined $value;
	return $value unless ref($value);

	return $class->_hashref2string($value, $me) if ref($value) eq 'HASH';
	return $class->_arrayref2string($value, $me) if ref($value) eq 'ARRAY';

	croak "$me: Invalid value '$value', expecting non-ref or hash/array ref at ";
}


#-------------------------------------------------------------------
#	Accessor factories for fields w type conversions
#-------------------------------------------------------------------

sub mk_arrayref_accessors($@)
#Takes a list of fieldnames for which we should construct
#array ref typed accessors/mutators.
#Such accessors will return an array ref always
#Mutators will accept either array ref or comma delimited string
#
{	my $class = shift;
	my @array_fields = @_;

	foreach my $afld (@array_fields)
	#Create accessor/mutator for array type field
	{   my $fqn = $class . '::' . $afld;
	    no strict "refs";
	    *{$fqn} = sub
	    {	my $self = shift;
		my $new = shift;
		my $me = $fqn;

		if ( defined $new )
		{	$new = $self->_string2arrayref($new, $me) unless ref($new);
			croak "$me: Illegal value '$new', expecting arrayref/comma delim string, at "
				unless $new && ref($new) eq 'ARRAY';
			$self->set($afld, [ @$new ]);
		}
		my $val = $self->get($afld);
		return $val;
	    };
	}

	#Should we create a ${afld}_as_string accessor as well???????
}

#-------------------------------------------------------------------
#	Special accessor factory for TRES/nonTRES stuff
#-------------------------------------------------------------------

sub mk_tres_nontres_accessors($$@)
#Takes the name of a TRES-style field, and a list ref of key=>value
#pairs, with key being the name of the   nonTRES-style field and
#value being the TRES name associated with it.
#This method will generate:
#1) An accessor/mutator for the TRES-style field.  When used as a
#mutator, the various nonTRES-style fields will also be set based on
#the specified TRES
#2) Accessor/mutators for the nonTRES-style fields.  When used as
#a mutator, these will set the hash key in the TRES-field according
#to the TRES listed.
#
{	my $class = shift;
	my $TRESfld = shift;
	my %nonTREShash = @_;

	#Create accessor/mutator for TRES field
	{   my $fqn = $class . '::' . $TRESfld;
	    no strict "refs";
	    *{$fqn} = sub
	    {	my $self = shift;
		my $new = shift;
		my $me = $fqn;

		if ( defined $new )
		{	$new = $self->_string2hashref($new, $me) unless ref($new);
			croak "$me: Illegal value '$new', expecting TRES hashref/string, at "
				unless $new &&
				( ref($new) eq 'HASH' || ref($new) eq 'ARRAY' );
			if ( ref($new) eq 'ARRAY' )
			{	if ( scalar(@$new) % 2 )
				{	croak "$me: Illegal value '$new'; expecting TRES hashref/string,"
						. " cannot convert aref with odd # of elements to href at ";
				}
				$new = { @$new };
			} else
			{	$new = { %$new };
			}
			$new = { %$new };
			$self->set($TRESfld, $new);

			foreach my $tmpfld (keys %nonTREShash)
			{	my $tmpTRES = $nonTREShash{$tmpfld};
				my $tmpval = $new->{$tmpTRES};
				$self->set($tmpfld, $tmpval);
			}
		}
		my $val = $self->get($TRESfld);
		return $val;
	    };
	}
	#Create accessors/mutators for nonTRES fields
	foreach my $nonTRESfld (keys %nonTREShash )
	{	my $TRESkey = $nonTREShash{$nonTRESfld};
		{   my $fqn = $class . '::' . $nonTRESfld;
		    no strict "refs";
		    *{$fqn} = sub
		    {	my $self = shift;
			my $new = shift;
			my $me = $fqn;

			if ( defined $new )
			{	croak "$me: Illegal value '$new', expecting scalar, at "
					if ref($new);
				$self->set($nonTRESfld, $new);

				my $hash = $self->get($TRESfld);
				unless ( $hash && ref($hash) eq 'HASH' )
				{	$hash = {};
				}
				$hash->{$TRESkey} = $new;
				$self->set($TRESfld, $hash);
			}
			my $val = $self->get($nonTRESfld);
			return $val;
		    };
		}
	}
}

#-------------------------------------------------------------------
#	Lookup entity with sacctmgr
#-------------------------------------------------------------------

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

	my $base = $class;
	$base =~ s/^.*://;
	$base = lc $base;
	return $base;
}


sub _sacctmgr_name_field($)
{	my $class = shift;
	$class = ref($class) if ref($class);
	die "Class $class did not overload _sacctmgr_name_field ";
}

sub _my_sacctmgr_where_clause($)
#This might need to be overloaded.
#Returns a where clause hash that should return the current entity.
{	my $obj = shift;
	croak "Must be called as an instance method at "
		unless $obj && ref($obj);
	my $namefld = $obj->_sacctmgr_name_field;
	my $meth = $namefld;
	my $val = $obj->$meth;
	#$val = '' unless defined $val;
	$val = $obj->_stringify_value($val);
	return { $namefld => $val };
}

1;
__END__