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


line stmt bran cond sub pod time code
1             #!/usr/local/bin/perl
2             #
3             #Base class for sacctmgr entities which can do all of
4             #"list", "modify", "add" and "delete".
5             #I.e. have full read/write capabilities
6              
7             package Slurm::Sacctmgr::EntityBaseRW;
8 516     516   3466 use strict;
  516         518  
  516         10639  
9 516     516   1392 use warnings;
  516         517  
  516         10792  
10 516         203253 use base qw(
11             Slurm::Sacctmgr::EntityBaseListable
12             Slurm::Sacctmgr::EntityBaseModifiable
13             Slurm::Sacctmgr::EntityBaseAddDel
14 516     516   1394 );
  516         727  
15 516     516   2026 use Carp qw(carp croak);
  516         871  
  516         423493  
16              
17             sub _compare_values_deeply($$$)
18             #Takes a pair of values and compares them
19             #Returns false if they are equal, true if they are different
20             #Values can be:
21             # undef: only equal to undef
22             # non-ref scalar: if both look like number, compare using '==',
23             # otherwise compare using 'eq'
24             # array ref: Returns false unless are of same length
25             # if of same length, compare recursively on each element.
26             # hash ref: Returns false unless list of keys are same,
27             # if same, compare recursively on each element
28             #
29             #
30             #Returns false if the two are equal
31             #Returns true (text on diff) if not equal
32 19053     19053   27191 { my $class = shift;
33 19053         18742 my $val1 = shift;
34 19053         14701 my $val2 = shift;
35 19053         16692 my $me = __PACKAGE__ . '::_compare_values_deeply';
36              
37 19053         13022 my ($i, $len1, $len2, $tmp, $tmp1, $tmp2);
38              
39 19053 100       28842 unless ( defined $val1 )
40             { #val1 undefined, mismatch unless val2 also undef
41 3252 100       7199 return 'val1 undef, val2 defined' if defined $val2;
42             #both undef
43 3249         4166 return 0;
44             }
45              
46             #val1 is defined if reach here
47              
48 15801 100       21387 return 'val1 defined, val2 not' unless defined $val2;
49              
50             #Both val1 and val2 defined after this point
51              
52 15600 100       23818 if ( ref($val1) eq 'ARRAY' )
53 331 100       847 { return 'val1 aref, val2 not' unless ref($val2) eq 'ARRAY';
54              
55             #Compare array refs
56 329         442 my $len1 = scalar(@$val1);
57 329         288 my $len2 = scalar(@$val2);
58 329 100       988 return 'arefs of different lengths' unless $len1 == $len2;
59              
60 86         163 $i=0;
61 86         255 AREF_LOOP: while ( $i < $len1 )
62 246         246 { $tmp1 = $val1->[$i];
63 246         227 $tmp2 = $val2->[$i];
64 246         508 $tmp = $class->_compare_values_deeply($tmp1,$tmp2);
65              
66 246 100       365 if ( $tmp )
67 3         11 { return "arefs differ elem# $i: $tmp";
68             }
69 243         376 $i++;
70             }
71             #All elements agree, so matches
72 83         170 return 0;
73             }
74              
75 15269 100       20865 if ( ref($val1) eq 'HASH' )
76 312 100       773 { return 'val1 href, val2 not' unless ref($val2) eq 'HASH';
77              
78             #Compare hash refs
79 311         2968 my @keys1 = sort ( keys %$val1);
80 311         1220 my @keys2 = sort ( keys %$val2);
81 311         1465 $tmp = $class->_compare_values_deeply( [@keys1], [@keys2] );
82 311 100       1251 return "hrefs with different keys: $tmp" if $tmp;
83              
84 69         226 HREF_LOOP: foreach $i (@keys1)
85 197         228 { $tmp1 = $val1->{$i};
86 197         223 $tmp2 = $val2->{$i};
87 197         293 $tmp = $class->_compare_values_deeply($tmp1,$tmp2);
88 197 100       453 next HREF_LOOP unless $tmp;
89              
90 5         11 return "arefs differ at key '$i': $tmp";
91             }
92             #All elements agree, so matches
93 64         161 return 0;
94             }
95              
96 14957 50       20461 if ( ref($val1) )
97 0         0 { $tmp1 = ref($val1);
98 0         0 $tmp2 = ref($val2);
99 0   0     0 $tmp = $tmp2 || '';
100 0 0       0 return "val1 is $tmp2, val2 is $tmp" unless $tmp1 eq $tmp2;
101              
102 0         0 carp "$me: Don't know how to handle ref type $tmp1, treating as equal???";
103 0         0 return 0;
104             }
105              
106             #val1 is non-ref scalar
107 14957         14062 $tmp = ref($val2);
108 14957 50       18714 return "val1 is non-ref scalar, val2 is $tmp" if $tmp;
109              
110             #val1 and val2 are both non-ref scalars
111              
112             #Does val1 look like a number
113             #First regexp should be true for any pos/neg int or real number (but not scientific notation)
114             #However, will also accept some non-numbers, eg. "+", "-.", ".", or " ", so require a digit as well
115             #Probably is a better way
116 14957 100 66     77187 if ( $val1 =~ /^\s*[-+]?\d*\.?\d*\s*$/ && $val1 =~ /\d/ )
117             { #val1 looks like a number
118 3579 100 100     15575 if ( $val2 =~ /^\s*[-+]?\d*\.?\d*\s*$/ && $val2 =~ /\d/ )
119             { #val1 and val2 both look like numbers
120 3575 100       10829 return 0 if $val1 == $val2;
121 413         1762 return "$val1 != $val2";
122             }
123             }
124             #At least one did not look like a number, so do string comparison
125 11382 100       23686 return 0 if $val1 eq $val2;
126 2015         6910 return "$val1 ne $val2";
127             }
128              
129             sub compare($$)
130             #Compare two instances, field by field (using
131             #Returns a list ref of triplets [ fieldname, value1, value2 ] for every
132             #field that differs. If no differences, returns undef.
133             #value1 is the value for the invocant, value2 is the value of the field
134             #of the explicit argument.
135             #
136             #Compares fieldsd from _sacctmgr_fields;
137 3100     3100 1 4923 { my $obj1 = shift;
138 3100         4865 my $obj2 = shift;
139              
140 3100         8703 my $me = 'compare';
141 3100 50 33     18008 croak "$me must be called as an instance method at "
142             unless $obj1 && ref($obj1);
143 3100 50 33     18560 croak "Bad invalid argument to $me: $obj2"
144             unless $obj2 && ref($obj2) eq ref($obj1);
145              
146 3100         11454 my $fields = $obj1->_sacctmgr_fields;
147              
148 3100         5517 my @diffs = ();
149 3100         6715 foreach my $fld (@$fields)
150 18262         15604 { my $meth = $fld;
151 18262         41914 my $val1 = $obj1->$meth;
152 18262         103517 my $val2 = $obj2->$meth;
153              
154 18262         84968 my $tmp = $obj1->_compare_values_deeply($val1,$val2);
155 18262 100       35229 push @diffs, [ $fld, $val1, $val2 ] if $tmp;
156             }
157              
158 3100 100       9201 return unless @diffs;
159 2022         6271 return [@diffs];
160             }
161              
162             sub sacctmgr_save_me($$@)
163 3758     3758 1 57551 { my $obj = shift;
164 3758         5233 my $sacctmgr = shift;
165 3758         9625 my %extra = @_;
166 3758         7923 my $quiet = delete $extra{QUIET};
167              
168 3758         5400 my $me = 'sacctmgr_save_me';
169 3758 50 33     24535 croak "$me must be called as an instance method at "
170             unless $obj && ref($obj);
171 3758 50 33     22162 croak "No/invalid Slurm::Sacctmgr object passed to $me at "
172             unless $sacctmgr && ref($sacctmgr);
173              
174 3758         17737 my $current = $obj->sacctmgr_list_me($sacctmgr);
175 3638 100       14259 unless ( defined $current )
176             { #No current entity matching me, so just do sacctmgr_add_me
177 538         7729 return $obj->sacctmgr_add_me($sacctmgr, %extra);
178             }
179 3100 50       12408 croak "Error looking up entity in $me : $current at"
180             unless ref($current);
181              
182 3100         17514 my $diffs = $obj->compare($current);
183 3100 100 100     16835 return unless ( $diffs || scalar(%extra) ); #Nothing to do
184              
185 2608   50     10442 my $modifiable_fields = $obj->_sacctmgr_fields_updatable($sacctmgr) || [];
186 2608         9950 my %modifiable = map { $_ => undef } @$modifiable_fields;
  12947         21115  
187 2608         6035 my $mdiffs = [ grep { exists $modifiable{$_->[0]} } @$diffs ];
  2859         8591  
188            
189             #Should we alert here if there are diffs we cannot save?
190             #But how to determine. Certainly mdiffs empty indicates such an issue,
191             #but there are many other cases. And mdiffs will in general not equal
192             #diffs; e.g. even when changing a TRES value which is available nonTRES.
193             #For now, warn on nothing since cant figure out how to easily warn
194 2608 100 100     9652 return unless ( scalar(@$mdiffs) || scalar(%extra) );
195            
196 2550         4928 my %updates = ();
197 2550         6700 foreach my $rec (@$mdiffs)
198 2620         7325 { my ($fld, $val1, $val2) = @$rec;
199             #$val1 = '' unless defined $val1;
200 2620         11387 $updates{$fld} = $obj->_stringify_value($val1, $me);
201             }
202 2550         9738 %updates = ( %updates, %extra );
203              
204 2550         16095 $obj->sacctmgr_modify_me($sacctmgr, %updates, QUIET=>$quiet);
205             }
206              
207              
208             1;
209             __END__