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


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__