File Coverage

blib/lib/Slurm/Sacctmgr/EntityBaseAddDel.pm
Criterion Covered Total %
statement 87 100 87.0
branch 20 42 47.6
condition 9 27 33.3
subroutine 12 14 85.7
pod 4 4 100.0
total 132 187 70.5


line stmt bran cond sub pod time code
1             #!/usr/local/bin/perl
2             #
3             #Base class for sacctmgr entities which can be do "add" and "delete"
4              
5             package Slurm::Sacctmgr::EntityBaseAddDel;
6 516     516   3011 use strict;
  516         502  
  516         11111  
7 516     516   1531 use warnings;
  516         624  
  516         10104  
8 516     516   1424 use base qw(Slurm::Sacctmgr::EntityBase);
  516         457  
  516         29396  
9 516     516   1732 use Carp qw(carp croak);
  516         926  
  516         377971  
10              
11             #This is intended for regression tests only
12             my $_last_raw_output;
13             sub _ebadddel_last_raw_output($)
14 3684     3684   58948 { return $_last_raw_output;
15             }
16             sub _clear_ebadddel_last_raw_output($)
17 0     0   0 { $_last_raw_output = [];
18             }
19              
20              
21             sub _sacctmgr_add_cmd($)
22 1440     1440   2400 { my $class = shift;
23 1440 100       4214 $class = ref($class) if ref($class);
24              
25 1440         9024 my $base = $class->_sacctmgr_entity_name;
26 1440         5407 return [ '-i', 'add', $base ];
27             }
28              
29             sub _sacctmgr_delete_cmd($)
30 2318     2318   2877 { my $class = shift;
31 2318 100       5380 $class = ref($class) if ref($class);
32              
33 2318         8316 my $base = $class->_sacctmgr_entity_name;
34 2318         5566 return [ '-i', 'delete', $base ];
35             }
36              
37             sub _sacctmgr_fields_addable($$)
38             #This lists the fields we can include in a sacctmgr add/create call
39             #May in general depend on version of slurm, hence sacctmgr argument.
40             #Should be overloaded in all children classes
41 0     0   0 { my $class = shift;
42 0         0 my $sacctmgr = shift;
43 0 0       0 $class = ref($class) if ref($class);
44 0         0 die "Class $class forgot to overload _sacctmgr_fields_addable";
45             }
46              
47             sub _my_sacctmgr_add_clause($$)
48             #This might need to be overloaded.
49             #Returns a hash ref for adding this instance into DB with sacctmgr.
50 1202     1202   1732 { my $obj = shift;
51 1202         1531 my $sacctmgr = shift;
52 1202 50 33     6115 croak "Must be called as an instance method at "
53             unless $obj && ref($obj);
54 1202         3613 my $me = ref($obj) . '::_my_sacctmgr_add_clause';
55 1202 50       2920 die "$me: Missing req param sacctmgr at " unless $sacctmgr;
56            
57 1202         5576 my $namefld = $obj->_sacctmgr_name_field;
58 1202         4341 my $fields = $obj->_sacctmgr_fields_addable($sacctmgr);
59              
60 1202         2442 my %hash = ();
61 1202         3072 FIELD: foreach my $fld (@$fields)
62 7595         5720 { my $fldname=$fld;
63 7595 100       10833 $fldname = $namefld if $fld eq 'name';
64 7595         6690 my $meth = $fld;
65 7595         19226 my $val = $obj->$meth;
66 7595 100       43243 next FIELD unless defined $val;
67 6771         14399 $hash{$fldname} = $obj->_stringify_value($val, $me);
68             }
69 1202         3324 return \%hash;
70             }
71              
72             sub sacctmgr_add($$@)
73             #Does sacctmgr list to get a add an entity of this type with specified
74             #fields (given as key => value pairs).
75 1440     1440 1 616452 { my $class = shift;
76 1440         2046 my $sacctmgr = shift;
77 1440         4804 my %fields = @_;
78              
79 1440         2443 my $me = 'sacctmgr_add';
80 1440 50 33     9021 croak "No/invalid Slurm::Sacctmgr object passed to $me at "
81             unless $sacctmgr && ref($sacctmgr);
82              
83 1440         5925 my $cmd = $class->_sacctmgr_add_cmd;
84 1440         3810 my @cmd = @$cmd;
85              
86 1440         2593 my $ok_if_exists = delete $fields{'--ok-if-previously-exists'};
87              
88             #Throw a sort in to make ordering deterministic for regression tests
89 1440         10270 KEY: foreach my $key (sort(keys %fields))
90 9089         8662 { my $val = $fields{$key};
91 9089         14885 $val = $class->_stringify_value($val);
92             #push @cmd, "$key='$val'";
93             #Do not add extra quotes around '$val'; they are NOT needed
94             #(eventually being passed to execvp call, so NEVER go through
95             #shell interpolation, so not needed), and can cause issues
96             #on certain sactmgr cmds which do not strip away quotes
97             #(e.g. setting defaultqos).
98 9089         16723 push @cmd, "$key=$val";
99             }
100              
101 1440         6417 my $list = $sacctmgr->run_generic_sacctmgr_cmd(@cmd);
102 1408 50 33     15237 unless ( $list && ref($list) )
103             { #Got an error.
104 0 0       0 chomp $list if $list;
105 0 0       0 if ( $list =~ /Nothing new added/ )
106 0 0       0 { return [] if $ok_if_exists;
107 0         0 croak "Trying to add existing object at ";
108             }
109 0         0 croak "Error running add cmd for $class: $list at ";
110             }
111 1408         3756 $_last_raw_output = $list;
112 1408         27087 return $list;
113              
114             }
115              
116             sub sacctmgr_add_me($$@)
117             #Does sacctmgr list to get add an entity record for this Perl object instance.
118 1202     1202 1 9306 { my $obj = shift;
119 1202         2287 my $sacctmgr = shift;
120 1202         3266 my %extra = @_;
121              
122 1202         3248 my $me = 'sacctmgr_add_me';
123 1202 50 33     9602 croak "$me must be called as an instance method at "
124             unless $obj && ref($obj);
125 1202 50 33     9097 croak "No/invalid Slurm::Sacctmgr object passed to $me at "
126             unless $sacctmgr && ref($sacctmgr);
127              
128 1202         7095 my $addclause = $obj->_my_sacctmgr_add_clause($sacctmgr);
129              
130             #Add extra fields
131 1202         6107 $addclause = { %$addclause, %extra };
132 1202         7521 return $obj->sacctmgr_add($sacctmgr, %$addclause);
133              
134             }
135              
136             sub sacctmgr_delete($$@)
137             #Does sacctmgr delete to delete all of the entities of this type
138             #matching specified criteria
139 2318     2318 1 241788 { my $class = shift;
140 2318         6842 my $sacctmgr = shift;
141 2318         5317 my %where = @_;
142              
143 2318         3426 my $me = 'sacctmgr_delete';
144 2318 50 33     10653 croak "No/invalid Slurm::Sacctmgr object passed to $me at "
145             unless $sacctmgr && ref($sacctmgr);
146              
147 2318         7198 my $cmd = $class->_sacctmgr_delete_cmd;
148 2318         5673 my @cmd = @$cmd;
149              
150 2318         3369 my @where = ();
151 2318         7307 foreach my $key (sort (keys %where) )
152 2762         4069 { my $val = $where{$key};
153 2762 50       4889 $val = '' unless defined $val;
154             #push @where, "$key='$val'";
155             #Do not add extra quotes around '$val'; they are NOT needed
156             #We do NOT go through shell interpolation
157 2762         6928 push @where, "$key=$val";
158             }
159 2318 50       5333 if ( @where )
160 2318         4223 { push @cmd, 'where', @where;
161             } else
162 0         0 { croak "$me refusing to issue delete w/out where clause at ";
163             }
164              
165 2318         7527 my $list = $sacctmgr->run_generic_sacctmgr_cmd(@cmd);
166 2276 50 33     24462 unless ( $list && ref($list) )
167             { #"Nothing deleted" is NOT an error
168             #return 0 to distinguish from undef for actual deletion case
169 0 0       0 return 0 if $list =~ /Nothing deleted/;
170 0         0 croak "Error running delete cmd for $class: $list at ";
171             }
172 2276         5203 $_last_raw_output = $list;
173 2276         30404 return;
174             }
175              
176             sub sacctmgr_delete_me($$)
177             #Does sacctmgr delete to the sacctmgr entity corresponding to this Perl
178             #object instance
179 2188     2188 1 22568 { my $obj = shift;
180 2188         2755 my $sacctmgr = shift;
181              
182 2188         3662 my $me = 'sacctmgr_delete_me';
183 2188 50 33     13357 croak "$me must be called as an instance method at "
184             unless $obj && ref($obj);
185 2188 50 33     11117 croak "No/invalid Slurm::Sacctmgr object passed to $me at "
186             unless $sacctmgr && ref($sacctmgr);
187              
188 2188         8733 my $where = $obj->_my_sacctmgr_where_clause;
189 2188         8505 return $obj->sacctmgr_delete($sacctmgr, %$where);
190             }
191              
192             1;
193             __END__