File Coverage

blib/lib/Slurm/Sacctmgr/EntityBaseModifiable.pm
Criterion Covered Total %
statement 57 66 86.3
branch 10 22 45.4
condition 9 22 40.9
subroutine 9 10 90.0
pod 2 2 100.0
total 87 122 71.3


line stmt bran cond sub pod time code
1             #!/usr/local/bin/perl
2             #
3             #Base class for sacctmgr entities which can be do "modify"
4              
5             package Slurm::Sacctmgr::EntityBaseModifiable;
6 516     516   2945 use strict;
  516         557  
  516         11219  
7 516     516   1690 use warnings;
  516         411  
  516         10377  
8 516     516   1412 use base qw(Slurm::Sacctmgr::EntityBase);
  516         491  
  516         27785  
9 516     516   1791 use Carp qw(carp croak);
  516         5476  
  516         260631  
10              
11             #This is intended for regression tests only
12             my $_last_raw_output;
13             sub _ebmod_last_raw_output($)
14 5428     5428   85311 { return $_last_raw_output;
15             }
16             sub _clear_ebmod_last_raw_output($)
17 1476     1476   44388 { $_last_raw_output = [];
18             }
19              
20             sub _sacctmgr_modify_cmd($)
21 4978     4978   6594 { my $class = shift;
22 4978 100       13824 $class = ref($class) if ref($class);
23              
24 4978         17106 my $base = $class->_sacctmgr_entity_name;
25 4978         15208 return [ '-i', 'modify', $base ];
26             }
27              
28             sub _sacctmgr_fields_updatable($$)
29             #This lists the fields we can include in a sacctmgr modify call
30             #May in general depend on version of slurm, hence sacctmgr argument.
31             #Should be overloaded in all children classes
32 0     0   0 { my $class = shift;
33 0         0 my $sacctmgr = shift;
34 0 0       0 $class = ref($class) if ref($class);
35 0         0 die "Class $class forgot to overload _sacctmgr_fields_updatable";
36             }
37              
38             sub sacctmgr_modify($$$$;$)
39             #Does sacctmgr update one or more entities of this type, as specified
40             #by $where hash ref (as key=>value pairs) to values in $update hash ref
41             #(again key=>value pairs). Any non-string values in update hash are
42             #stringified using _stringify_value.
43 4978     4978 1 443831 { my $class = shift;
44 4978         6518 my $sacctmgr = shift;
45 4978   50     11239 my $where = shift || {};
46 4978         5393 my $update = shift;
47 4978         4992 my $quiet = shift;
48              
49 4978         9041 my $me = 'sacctmgr_modify';
50 4978 50 33     20853 croak "No/invalid Slurm::Sacctmgr object passed to $me at "
51             unless $sacctmgr && ref($sacctmgr);
52 4978 50 33     39100 croak "No/invalid update hash passed to $me at "
      50        
53             unless $update && ref($update) eq 'HASH' &&
54             scalar(keys %$update);
55              
56 4978         13379 my $cmd = $class->_sacctmgr_modify_cmd;
57 4978         12995 my @cmd = @$cmd;
58              
59 4978         10606 my ($key, $val);
60              
61 4978         6666 my @where = ();
62 4978         18639 foreach $key (sort (keys %$where))
63 6102         14576 { $val = $where->{$key};
64             #$val = '' unless defined $val;
65 6102         15742 $val = $class->_stringify_value($val);
66             #push @where, "$key='$val'";
67             #No need for quoting argument, not going through shell
68             #and in some cases might cause problems with sacctmgr interpretting
69             #quotes as part of text
70 6102         15125 push @where, "$key=$val";
71             }
72 4978 50       11043 if (@where )
73 4978         8024 { push @cmd, 'where', @where;
74             }
75              
76 4978         6455 my @set = ();
77 4978         13252 foreach $key (sort (keys %$update))
78 8454         8767 { $val = $update->{$key};
79             #$val = '' unless defined $val;
80 8454         15820 $val = $class->_stringify_value($val);
81             #push @set, "$key='$val'";
82             #No need for quoting argument, not going through shell
83             #and in some cases might cause problems with sacctmgr interpretting
84             #quotes as part of text (e.g. setting grptresmins)
85 8454         18222 push @set, "$key=$val";
86             }
87 4978 50       11016 unless (@set )
88 0         0 { croak "No fields to set for $me at ";
89             }
90 4978         8549 push @cmd, 'set', @set;
91              
92 4978         18375 my $list = $sacctmgr->run_generic_sacctmgr_cmd(@cmd);
93 4878 50 33     47444 unless ( $list && ref($list) eq 'ARRAY' )
94 0         0 { croak "Error running modify cmd for $class: $list at ";
95             }
96              
97 4878 50 66     32597 if ( scalar(@$list) && ! $quiet )
98 0         0 { my $tmp = join "\n", @$list;
99 0 0       0 if ( $tmp !~ /^\s*Modified / )
100             { #We got something other than the normal
101             #' Modified _entity_ ...' message
102 0         0 warn "sacctmgr_modify returned:\n$tmp\n at ";
103             }
104             }
105 4878         11750 $_last_raw_output = $list;
106 4878         107821 return;
107             }
108              
109             sub sacctmgr_modify_me($$@)
110             #Does sacctmgr update to the sacctmgr entity corresponding to this Perl
111             #object instance, setting to the %update values as key => value
112 4630     4630 1 22088 { my $obj = shift;
113 4630         7756 my $sacctmgr = shift;
114 4630         15900 my %update = @_;
115 4630         9802 my $quiet = delete $update{QUIET};
116              
117 4630         10253 my $me = 'sacctmgr_modify_me';
118 4630 50 33     26663 croak "$me must be called as an instance method at "
119             unless $obj && ref($obj);
120 4630 50 33     24547 croak "No/invalid Slurm::Sacctmgr object passed to $me at "
121             unless $sacctmgr && ref($sacctmgr);
122              
123 4630         16710 my $where = $obj->_my_sacctmgr_where_clause;
124 4630         16521 return $obj->sacctmgr_modify($sacctmgr, $where, \%update, $quiet);
125             }
126              
127             1;
128             __END__