File Coverage

blib/lib/Slurm/Sacctmgr/EntityBaseRW.pm

Criterion	Covered	Total	%
statement	97	103	94.1
branch	47	56	83.9
condition	14	26	53.8
subroutine	7	7	100.0
pod	2	2	100.0
total	167	194	86.0

#!/usr/local/bin/perl
#
#Base class for sacctmgr entities which can do all of
#"list", "modify", "add" and "delete".
#I.e. have full read/write capabilities

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

sub _compare_values_deeply($$$)
#Takes a pair of values and compares them
#Returns false if they are equal, true if they are different
#Values can be:
#	undef: only equal to undef
#	non-ref scalar: if both look like number, compare using '==',
#		otherwise compare using 'eq'
#	array ref: Returns false unless are of same length
# 		if of same length, compare recursively on each element.
#	hash ref: Returns false unless list of keys are same,
#		if same, compare recursively on each element
#
#
#Returns false if the two are equal
#Returns true (text on diff) if not equal
{	my $class = shift;
	my $val1 = shift;
	my $val2 = shift;
	my $me = __PACKAGE__ . '::_compare_values_deeply';

	my ($i, $len1, $len2, $tmp, $tmp1, $tmp2);

	unless ( defined $val1 )
	{	#val1 undefined, mismatch unless val2 also undef
		return 'val1 undef, val2 defined' if defined $val2;
		#both undef
		return 0;
	}

	#val1 is defined if reach here

	return 'val1 defined, val2 not' unless defined $val2;

	#Both val1 and val2 defined after this point

	if ( ref($val1) eq 'ARRAY' )
	{	return 'val1 aref, val2 not' unless ref($val2) eq 'ARRAY';

		#Compare array refs
		my $len1 = scalar(@$val1);
		my $len2 = scalar(@$val2);
		return 'arefs of different lengths' unless $len1 == $len2;

		$i=0;
		AREF_LOOP: while ( $i < $len1 )
		{	$tmp1 = $val1->[$i];
			$tmp2 = $val2->[$i];
			$tmp = $class->_compare_values_deeply($tmp1,$tmp2);

			if ( $tmp )
			{	return "arefs differ elem# $i: $tmp";
			}
			$i++;
		}
		#All elements agree, so matches
		return 0;
	}

	if ( ref($val1) eq 'HASH' )
	{	return 'val1 href, val2 not' unless ref($val2) eq 'HASH';

		#Compare hash refs
		my @keys1 = sort ( keys %$val1);
		my @keys2 = sort ( keys %$val2);
		$tmp = $class->_compare_values_deeply( [@keys1], [@keys2] );
		return "hrefs with different keys: $tmp" if $tmp;

		HREF_LOOP: foreach $i (@keys1)
		{	$tmp1 = $val1->{$i};
			$tmp2 = $val2->{$i};
			$tmp = $class->_compare_values_deeply($tmp1,$tmp2);
			next HREF_LOOP unless $tmp;

			return "arefs differ at key '$i': $tmp";
		}
		#All elements agree, so matches
		return 0;
	}

	if ( ref($val1) )
	{	$tmp1 = ref($val1);
		$tmp2 = ref($val2);
		$tmp = $tmp2 || '';
		return "val1 is $tmp2, val2 is $tmp" unless $tmp1 eq $tmp2;

		carp "$me: Don't know how to handle ref type $tmp1, treating as equal???";
		return 0;
	}

	#val1 is non-ref scalar
	$tmp = ref($val2);
	return "val1 is non-ref scalar, val2 is $tmp" if $tmp;

	#val1 and val2 are both non-ref scalars

	#Does val1 look like a number
	#First regexp should be true for any pos/neg int or real number (but not scientific notation)
	#However, will also accept some non-numbers, eg. "+", "-.", ".", or "   ", so require a digit as well
	#Probably is a better way
	if ( $val1 =~ /^\s*[-+]?\d*\.?\d*\s*$/ && $val1 =~ /\d/ )
	{	#val1 looks like a number
		if ( $val2 =~ /^\s*[-+]?\d*\.?\d*\s*$/ && $val2 =~ /\d/ )
		{	#val1 and val2 both look like numbers
			return 0 if $val1 == $val2;
			return "$val1 != $val2";
		}
	}
	#At least one did not look like a number, so do string comparison
	return 0 if $val1 eq $val2;
	return "$val1 ne $val2";
}

sub compare($$)
#Compare two instances, field by field (using
#Returns a list ref of triplets [ fieldname, value1, value2 ] for every
#field that differs.  If no differences, returns undef.
#value1 is the value for the invocant, value2 is the value of the field
#of the explicit argument.
#
#Compares fieldsd from _sacctmgr_fields;
{	my $obj1 = shift;
	my $obj2 = shift;

	my $me = 'compare';
	croak "$me must be called as an instance method at "
		unless $obj1 && ref($obj1);
	croak "Bad invalid argument to $me: $obj2"
		unless $obj2 && ref($obj2) eq ref($obj1);

	my $fields = $obj1->_sacctmgr_fields;

	my @diffs = ();
	foreach my $fld (@$fields)
	{	my $meth = $fld;
		my $val1 = $obj1->$meth;
		my $val2 = $obj2->$meth;

		my $tmp = $obj1->_compare_values_deeply($val1,$val2);
		push @diffs, [ $fld, $val1, $val2 ] if $tmp;
	}

	return unless @diffs;
	return [@diffs];
}

sub sacctmgr_save_me($$@)
{	my $obj = shift;
	my $sacctmgr = shift;
	my %extra = @_;
	my $quiet = delete $extra{QUIET};

	my $me = 'sacctmgr_save_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 $current = $obj->sacctmgr_list_me($sacctmgr);
	unless ( defined $current )
	{	#No current entity matching me, so just do sacctmgr_add_me
		return $obj->sacctmgr_add_me($sacctmgr, %extra);
	}
	croak "Error looking up entity in $me : $current at"
		unless ref($current);

	my $diffs = $obj->compare($current);
	return unless ( $diffs || scalar(%extra) ); #Nothing to do

	my $modifiable_fields = $obj->_sacctmgr_fields_updatable($sacctmgr) || [];
	my %modifiable = map { $_ => undef } @$modifiable_fields;
	my $mdiffs = [ grep { exists $modifiable{$_->[0]} } @$diffs ];

	#Should we alert here if there are diffs we cannot save?
	#But how to determine.  Certainly mdiffs empty indicates such an issue,
	#but there are many other cases.  And mdiffs will in general not equal
	#diffs; e.g. even when changing a TRES value which is available nonTRES.
	#For now, warn on nothing since cant figure out how to easily warn
	return unless ( scalar(@$mdiffs) || scalar(%extra) );

	my %updates = ();
	foreach my $rec (@$mdiffs)
	{	my ($fld, $val1, $val2) = @$rec;
		#$val1 = '' unless defined $val1;
		$updates{$fld} = $obj->_stringify_value($val1, $me);
	}
	%updates = ( %updates, %extra );

	$obj->sacctmgr_modify_me($sacctmgr, %updates, QUIET=>$quiet);
}


1;
__END__