line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
#!/usr/local/bin/perl |
2
|
|
|
|
|
|
|
# |
3
|
|
|
|
|
|
|
#Base class for sacctmgr entities |
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
package Slurm::Sacctmgr::EntityBase; |
6
|
753
|
|
|
753
|
|
25275
|
use strict; |
|
753
|
|
|
|
|
766
|
|
|
753
|
|
|
|
|
16697
|
|
7
|
753
|
|
|
753
|
|
2270
|
use warnings; |
|
753
|
|
|
|
|
972
|
|
|
753
|
|
|
|
|
15563
|
|
8
|
753
|
|
|
753
|
|
2180
|
use base qw(Class::Accessor); |
|
753
|
|
|
|
|
953
|
|
|
753
|
|
|
|
|
43574
|
|
9
|
753
|
|
|
753
|
|
4783
|
use Carp qw(carp croak); |
|
753
|
|
|
|
|
791
|
|
|
753
|
|
|
|
|
722155
|
|
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
#------------------------------------------------------------------- |
12
|
|
|
|
|
|
|
# Globals |
13
|
|
|
|
|
|
|
#------------------------------------------------------------------- |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
#------------------------------------------------------------------- |
16
|
|
|
|
|
|
|
# Accessors |
17
|
|
|
|
|
|
|
#------------------------------------------------------------------- |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
sub _ro_fields($) |
20
|
27373
|
|
|
27373
|
|
37241
|
{ return []; |
21
|
|
|
|
|
|
|
} |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
sub _rw_fields($) |
24
|
0
|
|
|
0
|
|
0
|
{ return []; |
25
|
|
|
|
|
|
|
} |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
sub _required_fields($) |
28
|
31861
|
|
|
31861
|
|
40935
|
{ return []; |
29
|
|
|
|
|
|
|
} |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
#2016-03-09: dropping special_fields hash |
32
|
|
|
|
|
|
|
#instead, have custom accessor/mutators handle string input and convert to proper type |
33
|
|
|
|
|
|
|
#for output, output string based on ref type |
34
|
|
|
|
|
|
|
# sub _special_fields($) |
35
|
|
|
|
|
|
|
# #This should be overloaded to return any fields with special data types |
36
|
|
|
|
|
|
|
# #for this class of entity |
37
|
|
|
|
|
|
|
# { my $class = shift; |
38
|
|
|
|
|
|
|
# return {}; |
39
|
|
|
|
|
|
|
# } |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
#------------------------------------------------------------------- |
43
|
|
|
|
|
|
|
# Constructors, etc |
44
|
|
|
|
|
|
|
#------------------------------------------------------------------- |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
sub new($;@) |
47
|
31861
|
|
|
31861
|
1
|
15157199
|
{ my $class = shift; |
48
|
31861
|
|
|
|
|
104105
|
my @args = @_; |
49
|
31861
|
100
|
|
|
|
72728
|
$class = ref($class) if ref($class); |
50
|
|
|
|
|
|
|
|
51
|
31861
|
|
|
|
|
43324
|
my $obj = {}; |
52
|
31861
|
|
|
|
|
78717
|
bless $obj, $class; |
53
|
|
|
|
|
|
|
|
54
|
31861
|
|
|
|
|
79237
|
$obj->_parse_args(@args); |
55
|
31861
|
|
|
|
|
58864
|
$obj->_set_defaults; |
56
|
31861
|
|
|
|
|
63957
|
$obj->_init; |
57
|
|
|
|
|
|
|
|
58
|
31861
|
|
|
|
|
78529
|
return $obj; |
59
|
|
|
|
|
|
|
} |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
sub _parse_args($@) |
62
|
31861
|
|
|
31861
|
|
34226
|
{ my $obj = shift; |
63
|
31861
|
|
|
|
|
162370
|
my %args = @_; |
64
|
|
|
|
|
|
|
|
65
|
31861
|
|
|
|
|
104599
|
my $accessors = $obj->_rw_fields; |
66
|
31861
|
|
|
|
|
36302
|
my ($arg, $meth, $val); |
67
|
31861
|
|
|
|
|
52856
|
RWARG: foreach $arg (@$accessors) |
68
|
283269
|
100
|
|
|
|
1186607
|
{ next RWARG unless exists $args{$arg}; |
69
|
191139
|
|
|
|
|
186953
|
$val = delete $args{$arg}; |
70
|
191139
|
100
|
|
|
|
254597
|
next RWARG unless defined $val; |
71
|
156905
|
|
|
|
|
111865
|
$meth = $arg; |
72
|
156905
|
|
|
|
|
366142
|
$obj->$meth($val); |
73
|
|
|
|
|
|
|
} |
74
|
|
|
|
|
|
|
|
75
|
31861
|
|
|
|
|
89892
|
$accessors = $obj->_ro_fields; |
76
|
31861
|
|
|
|
|
65304
|
ROARG: foreach $arg (@$accessors) |
77
|
4488
|
100
|
|
|
|
9916
|
{ next ROARG unless exists $args{$arg}; |
78
|
2936
|
|
|
|
|
3776
|
$val = delete $args{$arg}; |
79
|
2936
|
100
|
|
|
|
5742
|
next ROARG unless defined $val; |
80
|
2816
|
|
|
|
|
2747
|
$meth = $arg; |
81
|
2816
|
|
|
|
|
5565
|
$obj->set($meth,$val); |
82
|
|
|
|
|
|
|
} |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
#Warn about unknown arguments |
86
|
31861
|
50
|
|
|
|
103243
|
if ( scalar(keys %args) ) |
87
|
0
|
|
|
|
|
0
|
{ my $tmp = join ", ", (keys %args); |
88
|
0
|
|
|
|
|
0
|
croak "Unrecognized arguments [ $tmp ] to constructor at "; |
89
|
|
|
|
|
|
|
}; |
90
|
|
|
|
|
|
|
} |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
sub _set_defaults($) |
93
|
24933
|
|
|
24933
|
|
23939
|
{ my $obj = shift; |
94
|
|
|
|
|
|
|
|
95
|
24933
|
|
|
|
|
23064
|
return; |
96
|
|
|
|
|
|
|
} |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
sub _init($) |
99
|
31861
|
|
|
31861
|
|
30307
|
{ my $obj = shift; |
100
|
|
|
|
|
|
|
|
101
|
31861
|
|
|
|
|
26197
|
my ($fld, $meth, $val); |
102
|
31861
|
|
|
|
|
59597
|
my $req_parms = $obj->_required_fields; |
103
|
31861
|
|
|
|
|
66929
|
foreach $fld (@$req_parms) |
104
|
0
|
|
|
|
|
0
|
{ $meth = $fld; |
105
|
0
|
|
|
|
|
0
|
$val = $obj->$meth; |
106
|
0
|
0
|
|
|
|
0
|
unless ( defined $val ) |
107
|
0
|
|
|
|
|
0
|
{ croak "Missing required argument $fld"; |
108
|
|
|
|
|
|
|
} |
109
|
|
|
|
|
|
|
} |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
} |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
#------------------------------------------------------------------- |
115
|
|
|
|
|
|
|
# Special constructor to generate from a sacctmgr list entry |
116
|
|
|
|
|
|
|
#------------------------------------------------------------------- |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
sub _sacctmgr_fields($) |
119
|
|
|
|
|
|
|
#Should return a list ref of sacctmgr field names known about |
120
|
|
|
|
|
|
|
#Will include field names for ALL known versions of sacctmgr; |
121
|
0
|
|
|
0
|
|
0
|
{ my $class = shift; |
122
|
0
|
0
|
|
|
|
0
|
$class = ref($class) if ref($class); |
123
|
0
|
|
|
|
|
0
|
die "Class $class forgot to overload _sacctmgr_fields"; |
124
|
|
|
|
|
|
|
} |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
sub _sacctmgr_fields_in_order($$) |
128
|
|
|
|
|
|
|
#Should return a list ref of field names in order sacctmgr will return them |
129
|
|
|
|
|
|
|
#Requires Slurm::Sacctmgr instance (as in general may depend on version |
130
|
|
|
|
|
|
|
#of slurm) |
131
|
0
|
|
|
0
|
|
0
|
{ my $class = shift; |
132
|
0
|
|
|
|
|
0
|
my $sacctmgr = shift; |
133
|
0
|
0
|
|
|
|
0
|
$class = ref($class) if ref($class); |
134
|
0
|
|
|
|
|
0
|
die "Class $class forgot to overload _sacctmgr_fields_in_order"; |
135
|
|
|
|
|
|
|
} |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
#------------------------------------------------------------------- |
138
|
|
|
|
|
|
|
# Data conversion routines |
139
|
|
|
|
|
|
|
#------------------------------------------------------------------- |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
sub _string2arrayref($$;$) |
142
|
|
|
|
|
|
|
#This converts a string like 'joe,steve,bob' to [ 'joe', 'steve', 'bob' ] |
143
|
5
|
|
|
5
|
|
1480
|
{ my $class = shift; |
144
|
5
|
|
|
|
|
6
|
my $string = shift; |
145
|
5
|
|
50
|
|
|
18
|
my $me = shift || ( __PACKAGE__ . '::_string2arrayref' ); |
146
|
5
|
50
|
|
|
|
8
|
return unless defined $string; |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
#Strip leading/trailing spaces |
149
|
5
|
|
|
|
|
22
|
$string =~ s/^\s*//; $string =~ s/\s*$//; |
|
5
|
|
|
|
|
22
|
|
150
|
5
|
50
|
|
|
|
10
|
return unless $string; |
151
|
|
|
|
|
|
|
|
152
|
5
|
|
|
|
|
36
|
my @recs = split /\s*,\s*/, $string; |
153
|
5
|
|
|
|
|
15
|
return [ @recs ]; |
154
|
|
|
|
|
|
|
} |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
sub _arrayref2string($$;$) |
157
|
|
|
|
|
|
|
#Reverse of _string2arrayref. |
158
|
|
|
|
|
|
|
#This converts an array ref like [ 'joe', 'steve', 'bob' ] to 'joe,steve,bob' |
159
|
10
|
|
|
10
|
|
2501
|
{ my $class = shift; |
160
|
10
|
|
|
|
|
9
|
my $arrayref = shift; |
161
|
10
|
|
100
|
|
|
27
|
my $me = shift || ( __PACKAGE__ . '::_arrayref2string' ); |
162
|
10
|
50
|
|
|
|
13
|
return unless defined $arrayref; |
163
|
|
|
|
|
|
|
|
164
|
10
|
50
|
33
|
|
|
47
|
croak "$me: arrayref2string given non array ref '$arrayref' at " |
165
|
|
|
|
|
|
|
unless $arrayref && ref($arrayref) eq 'ARRAY'; |
166
|
|
|
|
|
|
|
|
167
|
10
|
|
|
|
|
19
|
my $string = join ',', @$arrayref; |
168
|
10
|
|
|
|
|
20
|
return $string; |
169
|
|
|
|
|
|
|
} |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
sub _string2hashref($$;$) |
173
|
|
|
|
|
|
|
#This converts a string like "cpu=10000,node=50" to { cpu=>10000, node=>50} |
174
|
|
|
|
|
|
|
#hash ref. Intended for use with TRESes |
175
|
2150
|
|
|
2150
|
|
2988
|
{ my $class = shift; |
176
|
2150
|
|
|
|
|
2146
|
my $string = shift; |
177
|
2150
|
|
100
|
|
|
3608
|
my $me = shift || ( __PACKAGE__ . '::_string2hashref' ); |
178
|
2150
|
50
|
|
|
|
3518
|
return unless defined $string; |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
#Strip leading/trailing spaces |
181
|
2150
|
|
|
|
|
8627
|
$string =~ s/^\s*//; $string =~ s/\s*$//; |
|
2150
|
|
|
|
|
9617
|
|
182
|
2150
|
50
|
|
|
|
3396
|
return unless $string; |
183
|
|
|
|
|
|
|
|
184
|
2150
|
|
|
|
|
7853
|
my @recs = split /\s*,\s*/, $string; |
185
|
2150
|
|
|
|
|
2393
|
my $hash = {}; |
186
|
2150
|
|
|
|
|
3165
|
foreach my $rec (@recs) |
187
|
4919
|
50
|
|
|
|
8667
|
{ croak "$me: Invalid component '$rec' in TRES string '$string', no =, at " |
188
|
|
|
|
|
|
|
unless $rec =~ /=/; |
189
|
4919
|
|
|
|
|
14369
|
my ( $fld, $val ) = split /\s*=\s*/, $rec; |
190
|
|
|
|
|
|
|
croak "$me: Duplicate TRES '$fld' in TRES string '$string' at " |
191
|
4919
|
50
|
|
|
|
8787
|
if exists $hash->{$fld}; |
192
|
4919
|
|
|
|
|
8114
|
$hash->{$fld} = $val; |
193
|
|
|
|
|
|
|
} |
194
|
2150
|
|
|
|
|
3464
|
return $hash; |
195
|
|
|
|
|
|
|
} |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
sub _hashref2string($$;$) |
198
|
|
|
|
|
|
|
#Reverse of _string2hashref |
199
|
|
|
|
|
|
|
#This converts a hashref like { node=>50, cpu=>10000} to "cpu=10000,node=50" |
200
|
|
|
|
|
|
|
#NOTE: hash keys are always in order, to provide determinism needed for regression tests |
201
|
|
|
|
|
|
|
#Intended for use with TRESes |
202
|
221
|
|
|
221
|
|
3263
|
{ my $class = shift; |
203
|
221
|
|
|
|
|
404
|
my $hashref = shift; |
204
|
221
|
|
100
|
|
|
729
|
my $me = shift || ( __PACKAGE__ . '::_hashref2string' ); |
205
|
221
|
50
|
|
|
|
516
|
return unless defined $hashref; |
206
|
|
|
|
|
|
|
|
207
|
221
|
50
|
33
|
|
|
1488
|
croak "$me: hashref2string given non hash ref '$hashref' at " |
208
|
|
|
|
|
|
|
unless $hashref && ref($hashref) eq 'HASH'; |
209
|
|
|
|
|
|
|
|
210
|
221
|
|
|
|
|
1253
|
my @recs = map { "$_=$$hashref{$_}" } (sort keys %$hashref ); |
|
464
|
|
|
|
|
1747
|
|
211
|
221
|
|
|
|
|
622
|
my $string = join ',', @recs; |
212
|
221
|
|
|
|
|
772
|
return $string; |
213
|
|
|
|
|
|
|
} |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
sub _stringify_value($$;$) |
216
|
|
|
|
|
|
|
#Converts a value to a string, based on ref type. |
217
|
|
|
|
|
|
|
#Undef => '' |
218
|
|
|
|
|
|
|
#Non-ref scalars passed unchanged |
219
|
|
|
|
|
|
|
#hash ref converted using _hashref2string |
220
|
|
|
|
|
|
|
#array refs converted using _arrayref2string |
221
|
43510
|
|
|
43510
|
|
38895
|
{ my $class = shift; |
222
|
43510
|
|
|
|
|
35034
|
my $value = shift; |
223
|
43510
|
|
100
|
|
|
111416
|
my $me = shift || ( __PACKAGE__ . '::_stringify_value'); |
224
|
|
|
|
|
|
|
|
225
|
43510
|
50
|
|
|
|
61341
|
return '' unless defined $value; |
226
|
43510
|
100
|
|
|
|
107960
|
return $value unless ref($value); |
227
|
|
|
|
|
|
|
|
228
|
223
|
100
|
|
|
|
2058
|
return $class->_hashref2string($value, $me) if ref($value) eq 'HASH'; |
229
|
5
|
50
|
|
|
|
18
|
return $class->_arrayref2string($value, $me) if ref($value) eq 'ARRAY'; |
230
|
|
|
|
|
|
|
|
231
|
0
|
|
|
|
|
0
|
croak "$me: Invalid value '$value', expecting non-ref or hash/array ref at "; |
232
|
|
|
|
|
|
|
} |
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
#------------------------------------------------------------------- |
236
|
|
|
|
|
|
|
# Accessor factories for fields w type conversions |
237
|
|
|
|
|
|
|
#------------------------------------------------------------------- |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
sub mk_arrayref_accessors($@) |
240
|
|
|
|
|
|
|
#Takes a list of fieldnames for which we should construct |
241
|
|
|
|
|
|
|
#array ref typed accessors/mutators. |
242
|
|
|
|
|
|
|
#Such accessors will return an array ref always |
243
|
|
|
|
|
|
|
#Mutators will accept either array ref or comma delimited string |
244
|
|
|
|
|
|
|
# |
245
|
430
|
|
|
430
|
0
|
563
|
{ my $class = shift; |
246
|
430
|
|
|
|
|
659
|
my @array_fields = @_; |
247
|
|
|
|
|
|
|
|
248
|
430
|
|
|
|
|
711
|
foreach my $afld (@array_fields) |
249
|
|
|
|
|
|
|
#Create accessor/mutator for array type field |
250
|
430
|
|
|
|
|
630
|
{ my $fqn = $class . '::' . $afld; |
251
|
753
|
|
|
753
|
|
3457
|
no strict "refs"; |
|
753
|
|
|
|
|
1025
|
|
|
753
|
|
|
|
|
111878
|
|
252
|
430
|
|
|
|
|
1756
|
*{$fqn} = sub |
253
|
5932
|
|
|
5932
|
|
5674
|
{ my $self = shift; |
254
|
5932
|
|
|
|
|
5584
|
my $new = shift; |
255
|
5932
|
|
|
|
|
6380
|
my $me = $fqn; |
256
|
|
|
|
|
|
|
|
257
|
5932
|
50
|
|
|
|
9972
|
if ( defined $new ) |
258
|
0
|
0
|
|
|
|
0
|
{ $new = $self->_string2arrayref($new, $me) unless ref($new); |
259
|
0
|
0
|
0
|
|
|
0
|
croak "$me: Illegal value '$new', expecting arrayref/comma delim string, at " |
260
|
|
|
|
|
|
|
unless $new && ref($new) eq 'ARRAY'; |
261
|
0
|
|
|
|
|
0
|
$self->set($afld, [ @$new ]); |
262
|
|
|
|
|
|
|
} |
263
|
5932
|
|
|
|
|
11494
|
my $val = $self->get($afld); |
264
|
5932
|
|
|
|
|
23644
|
return $val; |
265
|
430
|
|
|
|
|
2341
|
}; |
266
|
|
|
|
|
|
|
} |
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
#Should we create a ${afld}_as_string accessor as well??????? |
269
|
|
|
|
|
|
|
} |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
#------------------------------------------------------------------- |
272
|
|
|
|
|
|
|
# Special accessor factory for TRES/nonTRES stuff |
273
|
|
|
|
|
|
|
#------------------------------------------------------------------- |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
sub mk_tres_nontres_accessors($$@) |
276
|
|
|
|
|
|
|
#Takes the name of a TRES-style field, and a list ref of key=>value |
277
|
|
|
|
|
|
|
#pairs, with key being the name of the nonTRES-style field and |
278
|
|
|
|
|
|
|
#value being the TRES name associated with it. |
279
|
|
|
|
|
|
|
#This method will generate: |
280
|
|
|
|
|
|
|
#1) An accessor/mutator for the TRES-style field. When used as a |
281
|
|
|
|
|
|
|
#mutator, the various nonTRES-style fields will also be set based on |
282
|
|
|
|
|
|
|
#the specified TRES |
283
|
|
|
|
|
|
|
#2) Accessor/mutators for the nonTRES-style fields. When used as |
284
|
|
|
|
|
|
|
#a mutator, these will set the hash key in the TRES-field according |
285
|
|
|
|
|
|
|
#to the TRES listed. |
286
|
|
|
|
|
|
|
# |
287
|
932
|
|
|
932
|
0
|
1039
|
{ my $class = shift; |
288
|
932
|
|
|
|
|
592
|
my $TRESfld = shift; |
289
|
932
|
|
|
|
|
1953
|
my %nonTREShash = @_; |
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
#Create accessor/mutator for TRES field |
292
|
932
|
|
|
|
|
501
|
{ my $fqn = $class . '::' . $TRESfld; |
|
932
|
|
|
|
|
1347
|
|
293
|
753
|
|
|
753
|
|
2839
|
no strict "refs"; |
|
753
|
|
|
|
|
924
|
|
|
753
|
|
|
|
|
144667
|
|
294
|
932
|
|
|
|
|
21196
|
*{$fqn} = sub |
295
|
12383
|
|
|
12383
|
|
393340
|
{ my $self = shift; |
296
|
12383
|
|
|
|
|
9311
|
my $new = shift; |
297
|
12383
|
|
|
|
|
12326
|
my $me = $fqn; |
298
|
|
|
|
|
|
|
|
299
|
12383
|
100
|
|
|
|
17790
|
if ( defined $new ) |
300
|
5423
|
100
|
|
|
|
13081
|
{ $new = $self->_string2hashref($new, $me) unless ref($new); |
301
|
5423
|
50
|
33
|
|
|
20539
|
croak "$me: Illegal value '$new', expecting TRES hashref/string, at " |
|
|
|
33
|
|
|
|
|
302
|
|
|
|
|
|
|
unless $new && |
303
|
|
|
|
|
|
|
( ref($new) eq 'HASH' || ref($new) eq 'ARRAY' ); |
304
|
5423
|
50
|
|
|
|
8769
|
if ( ref($new) eq 'ARRAY' ) |
305
|
0
|
0
|
|
|
|
0
|
{ if ( scalar(@$new) % 2 ) |
306
|
0
|
|
|
|
|
0
|
{ croak "$me: Illegal value '$new'; expecting TRES hashref/string," |
307
|
|
|
|
|
|
|
. " cannot convert aref with odd # of elements to href at "; |
308
|
|
|
|
|
|
|
} |
309
|
0
|
|
|
|
|
0
|
$new = { @$new }; |
310
|
|
|
|
|
|
|
} else |
311
|
5423
|
|
|
|
|
15469
|
{ $new = { %$new }; |
312
|
|
|
|
|
|
|
} |
313
|
5423
|
|
|
|
|
13338
|
$new = { %$new }; |
314
|
5423
|
|
|
|
|
15014
|
$self->set($TRESfld, $new); |
315
|
|
|
|
|
|
|
|
316
|
5423
|
|
|
|
|
27212
|
foreach my $tmpfld (keys %nonTREShash) |
317
|
8734
|
|
|
|
|
19283
|
{ my $tmpTRES = $nonTREShash{$tmpfld}; |
318
|
8734
|
|
|
|
|
8981
|
my $tmpval = $new->{$tmpTRES}; |
319
|
8734
|
|
|
|
|
13138
|
$self->set($tmpfld, $tmpval); |
320
|
|
|
|
|
|
|
} |
321
|
|
|
|
|
|
|
} |
322
|
12383
|
|
|
|
|
34717
|
my $val = $self->get($TRESfld); |
323
|
12383
|
|
|
|
|
47927
|
return $val; |
324
|
932
|
|
|
|
|
2934
|
}; |
325
|
|
|
|
|
|
|
} |
326
|
|
|
|
|
|
|
#Create accessors/mutators for nonTRES fields |
327
|
932
|
|
|
|
|
1820
|
foreach my $nonTRESfld (keys %nonTREShash ) |
328
|
1196
|
|
|
|
|
1400
|
{ my $TRESkey = $nonTREShash{$nonTRESfld}; |
329
|
1196
|
|
|
|
|
1857
|
{ my $fqn = $class . '::' . $nonTRESfld; |
|
1196
|
|
|
|
|
1626
|
|
330
|
753
|
|
|
753
|
|
2905
|
no strict "refs"; |
|
753
|
|
|
|
|
765
|
|
|
753
|
|
|
|
|
198575
|
|
331
|
1196
|
|
|
|
|
4505
|
*{$fqn} = sub |
332
|
7142
|
|
|
7142
|
|
7225
|
{ my $self = shift; |
333
|
7142
|
|
|
|
|
6156
|
my $new = shift; |
334
|
7142
|
|
|
|
|
7539
|
my $me = $fqn; |
335
|
|
|
|
|
|
|
|
336
|
7142
|
100
|
|
|
|
10123
|
if ( defined $new ) |
337
|
5342
|
50
|
|
|
|
7803
|
{ croak "$me: Illegal value '$new', expecting scalar, at " |
338
|
|
|
|
|
|
|
if ref($new); |
339
|
5342
|
|
|
|
|
9272
|
$self->set($nonTRESfld, $new); |
340
|
|
|
|
|
|
|
|
341
|
5342
|
|
|
|
|
24919
|
my $hash = $self->get($TRESfld); |
342
|
5342
|
100
|
66
|
|
|
29549
|
unless ( $hash && ref($hash) eq 'HASH' ) |
343
|
3507
|
|
|
|
|
4172
|
{ $hash = {}; |
344
|
|
|
|
|
|
|
} |
345
|
5342
|
|
|
|
|
8924
|
$hash->{$TRESkey} = $new; |
346
|
5342
|
|
|
|
|
8330
|
$self->set($TRESfld, $hash); |
347
|
|
|
|
|
|
|
} |
348
|
7142
|
|
|
|
|
26320
|
my $val = $self->get($nonTRESfld); |
349
|
7142
|
|
|
|
|
25289
|
return $val; |
350
|
1196
|
|
|
|
|
3312
|
}; |
351
|
|
|
|
|
|
|
} |
352
|
|
|
|
|
|
|
} |
353
|
|
|
|
|
|
|
} |
354
|
|
|
|
|
|
|
|
355
|
|
|
|
|
|
|
#------------------------------------------------------------------- |
356
|
|
|
|
|
|
|
# Lookup entity with sacctmgr |
357
|
|
|
|
|
|
|
#------------------------------------------------------------------- |
358
|
|
|
|
|
|
|
|
359
|
|
|
|
|
|
|
sub _sacctmgr_entity_name($) |
360
|
18749
|
|
|
18749
|
|
26078
|
{ my $class = shift; |
361
|
18749
|
50
|
|
|
|
33736
|
$class = ref($class) if ref($class); |
362
|
|
|
|
|
|
|
|
363
|
18749
|
|
|
|
|
24371
|
my $base = $class; |
364
|
18749
|
|
|
|
|
121059
|
$base =~ s/^.*://; |
365
|
18749
|
|
|
|
|
33642
|
$base = lc $base; |
366
|
18749
|
|
|
|
|
42272
|
return $base; |
367
|
|
|
|
|
|
|
} |
368
|
|
|
|
|
|
|
|
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
sub _sacctmgr_name_field($) |
371
|
0
|
|
|
0
|
|
0
|
{ my $class = shift; |
372
|
0
|
0
|
|
|
|
0
|
$class = ref($class) if ref($class); |
373
|
0
|
|
|
|
|
0
|
die "Class $class did not overload _sacctmgr_name_field "; |
374
|
|
|
|
|
|
|
} |
375
|
|
|
|
|
|
|
|
376
|
|
|
|
|
|
|
sub _my_sacctmgr_where_clause($) |
377
|
|
|
|
|
|
|
#This might need to be overloaded. |
378
|
|
|
|
|
|
|
#Returns a where clause hash that should return the current entity. |
379
|
10466
|
|
|
10466
|
|
12302
|
{ my $obj = shift; |
380
|
10466
|
50
|
33
|
|
|
47680
|
croak "Must be called as an instance method at " |
381
|
|
|
|
|
|
|
unless $obj && ref($obj); |
382
|
10466
|
|
|
|
|
30201
|
my $namefld = $obj->_sacctmgr_name_field; |
383
|
10466
|
|
|
|
|
11844
|
my $meth = $namefld; |
384
|
10466
|
|
|
|
|
23884
|
my $val = $obj->$meth; |
385
|
|
|
|
|
|
|
#$val = '' unless defined $val; |
386
|
10466
|
|
|
|
|
87031
|
$val = $obj->_stringify_value($val); |
387
|
10466
|
|
|
|
|
32646
|
return { $namefld => $val }; |
388
|
|
|
|
|
|
|
} |
389
|
|
|
|
|
|
|
|
390
|
|
|
|
|
|
|
1; |
391
|
|
|
|
|
|
|
__END__ |