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