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__ |