line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
#!/usr/local/bin/perl |
2
|
|
|
|
|
|
|
# |
3
|
|
|
|
|
|
|
#Perl wrappers for Slurm sacctmgr |
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
package Slurm::Sacctmgr; |
6
|
761
|
|
|
761
|
|
10277947
|
use strict; |
|
761
|
|
|
|
|
1084
|
|
|
761
|
|
|
|
|
16470
|
|
7
|
761
|
|
|
761
|
|
2292
|
use warnings; |
|
761
|
|
|
|
|
776
|
|
|
761
|
|
|
|
|
15813
|
|
8
|
761
|
|
|
761
|
|
2270
|
use base qw(Class::Accessor); |
|
761
|
|
|
|
|
800
|
|
|
761
|
|
|
|
|
342510
|
|
9
|
761
|
|
|
761
|
|
1031038
|
use Carp qw(carp croak); |
|
761
|
|
|
|
|
880
|
|
|
761
|
|
|
|
|
36228
|
|
10
|
|
|
|
|
|
|
|
11
|
761
|
|
|
761
|
|
268254
|
use version; our $VERSION = qw(1.1.0); |
|
761
|
|
|
|
|
950223
|
|
|
761
|
|
|
|
|
3515
|
|
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
#------------------------------------------------------------------- |
15
|
|
|
|
|
|
|
# Globals |
16
|
|
|
|
|
|
|
#------------------------------------------------------------------- |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
#By default, use the sacctmgr found in your path |
19
|
|
|
|
|
|
|
my $DEFAULT_SACCTMGR_CMD='sacctmgr'; |
20
|
|
|
|
|
|
|
#If you wish to default to something else, you can either modify the |
21
|
|
|
|
|
|
|
#class method default_sacctmgr_path_version, and/or uncomment |
22
|
|
|
|
|
|
|
#and change the line below. |
23
|
|
|
|
|
|
|
#$DEFAULT_SACCTMGR_CMD='/usr/local/slurm/bin/sacctmgr'; |
24
|
|
|
|
|
|
|
#It is also recommended that you set the $DEFAULT_SACCTMGR_VERSION to the |
25
|
|
|
|
|
|
|
#Slurm version number associated with that specified sacctmgr command. |
26
|
|
|
|
|
|
|
#Failure to do so might result in the package needing to issue extra |
27
|
|
|
|
|
|
|
#sacctmgr commands to determine what version of sacctmgr being run, which is inefficient |
28
|
|
|
|
|
|
|
my $DEFAULT_SACCTMGR_VERSION; |
29
|
|
|
|
|
|
|
#Uncomment and modify this if the Slurm version for the sacctmgr command listed |
30
|
|
|
|
|
|
|
#in $DEFAULT_SACCTMGR_CMD is known |
31
|
|
|
|
|
|
|
#$DEFAULT_SACCTMGR_VERSION='15.08.2'; |
32
|
|
|
|
|
|
|
#The default version of default_sacctmgr_path_version just returns these |
33
|
|
|
|
|
|
|
#two values; modified versions might or might not use these values. |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
#This is intended for regression tests only |
36
|
|
|
|
|
|
|
my $_last_raw_output; |
37
|
|
|
|
|
|
|
sub _sacctmgr_last_raw_output($) |
38
|
9467
|
|
|
9467
|
|
31020
|
{ return $_last_raw_output; |
39
|
|
|
|
|
|
|
} |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
my @SACCTMGR_CMD_CAPABILITIES_LIST = |
42
|
|
|
|
|
|
|
( 'trackable_resources', #Supports TRES, at least at basic level |
43
|
|
|
|
|
|
|
); |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
my %SACCTMGR_CMD_CAPABILITIES_HASH = map { $_ => undef } @SACCTMGR_CMD_CAPABILITIES_LIST; |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
#------------------------------------------------------------------- |
49
|
|
|
|
|
|
|
# Accessors |
50
|
|
|
|
|
|
|
#------------------------------------------------------------------- |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
my @rw_accessors = qw( |
53
|
|
|
|
|
|
|
dryrun |
54
|
|
|
|
|
|
|
verbose |
55
|
|
|
|
|
|
|
); |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
my @ro_accessors = qw( |
58
|
|
|
|
|
|
|
sacctmgr |
59
|
|
|
|
|
|
|
slurm_version |
60
|
|
|
|
|
|
|
); |
61
|
|
|
|
|
|
|
# _sacctmgr_cmd_capabilities |
62
|
|
|
|
|
|
|
# _cached_sacctmgr_cmd_capabilities |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
__PACKAGE__->mk_accessors(@rw_accessors); |
65
|
|
|
|
|
|
|
__PACKAGE__->mk_ro_accessors(@ro_accessors); |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
my @required_parms = qw( |
69
|
|
|
|
|
|
|
sacctmgr |
70
|
|
|
|
|
|
|
); |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
#------- Special accessors/mutators |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
sub slurm_version($;$) |
75
|
|
|
|
|
|
|
#Gets version of slurm/sacctmgr cmd |
76
|
|
|
|
|
|
|
#Preferably our cached version, but (unless $cachedonly flag is set) |
77
|
|
|
|
|
|
|
#will call sacctmgr to get it if needed |
78
|
|
|
|
|
|
|
#If unknown and $cachedonly set, will return undef. |
79
|
1337
|
|
|
1337
|
0
|
1700
|
{ my $self = shift; |
80
|
1337
|
|
|
|
|
1613
|
my $cachedonly = shift; |
81
|
|
|
|
|
|
|
|
82
|
1337
|
|
|
|
|
2590
|
my $svers = $self->get('slurm_version'); |
83
|
1337
|
50
|
|
|
|
17211
|
return $svers if $svers; |
84
|
|
|
|
|
|
|
|
85
|
0
|
0
|
|
|
|
0
|
return if $cachedonly; |
86
|
|
|
|
|
|
|
|
87
|
0
|
|
|
|
|
0
|
return $self->_determine_slurm_version; #This sets 'slurm_version' data member |
88
|
|
|
|
|
|
|
} |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
#------------------------------------------------------------------- |
91
|
|
|
|
|
|
|
# Constructors, etc |
92
|
|
|
|
|
|
|
#------------------------------------------------------------------- |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
sub new($;@) |
95
|
4337
|
|
|
4337
|
1
|
6404940
|
{ my $class = shift; |
96
|
4337
|
|
|
|
|
14414
|
my @args = @_; |
97
|
|
|
|
|
|
|
|
98
|
4337
|
|
|
|
|
7119
|
my $obj = {}; |
99
|
4337
|
|
|
|
|
6795
|
bless $obj, $class; |
100
|
|
|
|
|
|
|
|
101
|
4337
|
|
|
|
|
14130
|
$obj->_parse_args(@args); |
102
|
4337
|
|
|
|
|
9581
|
$obj->_set_defaults; |
103
|
4337
|
|
|
|
|
8845
|
$obj->_init; |
104
|
|
|
|
|
|
|
|
105
|
4337
|
|
|
|
|
9682
|
return $obj; |
106
|
|
|
|
|
|
|
} |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
sub _parse_args($@) |
109
|
4337
|
|
|
4337
|
|
5091
|
{ my $obj = shift; |
110
|
4337
|
|
|
|
|
11442
|
my %args = @_; |
111
|
|
|
|
|
|
|
|
112
|
4337
|
|
|
|
|
6064
|
my ($arg, $meth, $val); |
113
|
4337
|
|
|
|
|
12953
|
RWARG: foreach $arg (@rw_accessors) |
114
|
8674
|
50
|
|
|
|
25195
|
{ next RWARG unless exists $args{$arg}; |
115
|
0
|
|
|
|
|
0
|
$val = delete $args{$arg}; |
116
|
0
|
0
|
|
|
|
0
|
next RWARG unless defined $val; |
117
|
0
|
|
|
|
|
0
|
$meth = $arg; |
118
|
0
|
|
|
|
|
0
|
$obj->$meth($val); |
119
|
|
|
|
|
|
|
} |
120
|
|
|
|
|
|
|
|
121
|
4337
|
|
|
|
|
8025
|
ROARG: foreach $arg (@ro_accessors) |
122
|
8674
|
100
|
|
|
|
19456
|
{ next ROARG unless exists $args{$arg}; |
123
|
4337
|
|
|
|
|
8536
|
$val = delete $args{$arg}; |
124
|
4337
|
50
|
|
|
|
10460
|
next ROARG unless defined $val; |
125
|
|
|
|
|
|
|
|
126
|
4337
|
50
|
33
|
|
|
14947
|
if ( $arg eq 'sacctmgr' || $arg eq 'slurm_version' ) |
127
|
|
|
|
|
|
|
{ #This gets handled specially |
128
|
4337
|
|
|
|
|
4175
|
my ($tmppath, $tmpver); |
129
|
4337
|
50
|
|
|
|
10564
|
if ( $arg eq 'sacctmgr' ) |
|
|
0
|
|
|
|
|
|
130
|
4337
|
|
|
|
|
5207
|
{ $tmppath = $val; |
131
|
4337
|
|
|
|
|
8183
|
$tmpver = delete $args{'slurm_version'}; |
132
|
|
|
|
|
|
|
} elsif ( $arg eq 'slurm_version' ) |
133
|
0
|
|
|
|
|
0
|
{ $tmpver = $val; |
134
|
0
|
|
|
|
|
0
|
$tmppath = delete $args{'sacctmgr'}; |
135
|
|
|
|
|
|
|
} else |
136
|
0
|
|
|
|
|
0
|
{ die "Should not reach here at "; |
137
|
|
|
|
|
|
|
} |
138
|
4337
|
|
|
|
|
13605
|
$obj->_set_sacctmgr_path($tmppath, $tmpver); |
139
|
4337
|
|
|
|
|
21139
|
next ROARG; |
140
|
|
|
|
|
|
|
} |
141
|
|
|
|
|
|
|
|
142
|
0
|
|
|
|
|
0
|
$meth = $arg; |
143
|
0
|
|
|
|
|
0
|
$obj->set($meth,$val); |
144
|
|
|
|
|
|
|
} |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
#Warn about unknown arguments |
148
|
4337
|
50
|
|
|
|
14611
|
if ( scalar(keys %args) ) |
149
|
0
|
|
|
|
|
0
|
{ my $tmp = join ", ", (keys %args); |
150
|
0
|
|
|
|
|
0
|
croak "Unrecognized arguments [ $tmp ] to constructor at "; |
151
|
|
|
|
|
|
|
}; |
152
|
|
|
|
|
|
|
} |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
sub _set_defaults($) |
155
|
4337
|
|
|
4337
|
|
5028
|
{ my $obj = shift; |
156
|
|
|
|
|
|
|
|
157
|
4337
|
|
|
|
|
6176
|
my ($tmp); |
158
|
4337
|
|
|
|
|
12703
|
$tmp = $obj->sacctmgr; |
159
|
4337
|
50
|
|
|
|
46164
|
unless ( $tmp ) |
160
|
0
|
|
|
|
|
0
|
{ my @tmp = $obj->default_sacctmgr_path_version; |
161
|
0
|
|
|
|
|
0
|
$obj->_set_sacctmgr_path(@tmp); |
162
|
|
|
|
|
|
|
} |
163
|
|
|
|
|
|
|
|
164
|
4337
|
|
|
|
|
5092
|
return; |
165
|
|
|
|
|
|
|
} |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
sub _init($) |
168
|
4337
|
|
|
4337
|
|
4972
|
{ my $obj = shift; |
169
|
|
|
|
|
|
|
|
170
|
4337
|
|
|
|
|
4716
|
my ($fld, $meth, $val); |
171
|
4337
|
|
|
|
|
9689
|
foreach $fld (@required_parms) |
172
|
4337
|
|
|
|
|
5733
|
{ $meth = $fld; |
173
|
4337
|
|
|
|
|
10880
|
$val = $obj->$meth; |
174
|
4337
|
50
|
|
|
|
28425
|
unless ( defined $val ) |
175
|
0
|
|
|
|
|
0
|
{ croak "Missing required argument $fld"; |
176
|
|
|
|
|
|
|
} |
177
|
|
|
|
|
|
|
} |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
} |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
#------------------------------------------------------------------- |
182
|
|
|
|
|
|
|
# Sacctmgr/slurm versioning stuff |
183
|
|
|
|
|
|
|
#------------------------------------------------------------------- |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
sub default_sacctmgr_path_version($) |
186
|
|
|
|
|
|
|
#This returns the default path to sacctmgr, and the default Slurm |
187
|
|
|
|
|
|
|
#version, for use when defaulting sacctmgr value during construction |
188
|
|
|
|
|
|
|
#of an instance. The path and version are returned as elements |
189
|
|
|
|
|
|
|
#of a 2 value list. |
190
|
|
|
|
|
|
|
# |
191
|
|
|
|
|
|
|
#This version just returns the lexicals |
192
|
|
|
|
|
|
|
# $DEFAULT_SACCTMGR_CMD and |
193
|
|
|
|
|
|
|
# $DEFAULT_SACCTMGR_VERSION |
194
|
|
|
|
|
|
|
#defined at the top of this file. For most cases, it is easiest to |
195
|
|
|
|
|
|
|
#just change those variables. This routine is provided as a hook |
196
|
|
|
|
|
|
|
#in case system admins need to do something more complicated when |
197
|
|
|
|
|
|
|
#defaulting these. |
198
|
0
|
|
|
0
|
0
|
0
|
{ my $class = shift; |
199
|
|
|
|
|
|
|
|
200
|
0
|
|
|
|
|
0
|
return ( $DEFAULT_SACCTMGR_CMD, |
201
|
|
|
|
|
|
|
$DEFAULT_SACCTMGR_VERSION ); |
202
|
|
|
|
|
|
|
} |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
sub sacctmgr_capabilities_by_version($$) |
205
|
|
|
|
|
|
|
#Return the appropriate sacctmgr_cmd_capabilities hash for a given |
206
|
|
|
|
|
|
|
#Slurm version number. This is our "guess" of what various versions |
207
|
|
|
|
|
|
|
#can/cannot do. |
208
|
|
|
|
|
|
|
#Returns hash ref. |
209
|
|
|
|
|
|
|
#This is a class method |
210
|
1337
|
|
|
1337
|
0
|
1820
|
{ my $class = shift; |
211
|
1337
|
|
|
|
|
1516
|
my $slurm_version = shift; |
212
|
1337
|
|
|
|
|
75031
|
my $me = __PACKAGE__ . '::sacctmgr_capabilities_by_version'; |
213
|
|
|
|
|
|
|
|
214
|
1337
|
50
|
|
|
|
2778
|
return unless $slurm_version; |
215
|
|
|
|
|
|
|
#Strip leading/trailing whitespace from version |
216
|
1337
|
|
|
|
|
5969
|
$slurm_version=~ s/^\s*//; $slurm_version =~ s/\s*$//; |
|
1337
|
|
|
|
|
5911
|
|
217
|
|
|
|
|
|
|
|
218
|
1337
|
|
|
|
|
4395
|
my @vcomps = split /\./, $slurm_version; |
219
|
1337
|
|
|
|
|
1918
|
my $slurm_major = $vcomps[0]; |
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
#REturn unknown caps if bad version given |
222
|
1337
|
50
|
|
|
|
5397
|
return unless $slurm_major =~ /^\d+$/; |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
#Guess at capabilities |
225
|
1337
|
100
|
|
|
|
4205
|
if ( $slurm_major < 15 ) |
226
|
|
|
|
|
|
|
{ #Looks like an older, pre-TRES version of slurm |
227
|
|
|
|
|
|
|
return |
228
|
915
|
|
|
|
|
3069
|
{ trackable_resources => 0, |
229
|
|
|
|
|
|
|
}; |
230
|
|
|
|
|
|
|
} else |
231
|
|
|
|
|
|
|
{ #Looks like a newer version of Slurm, with TRES support |
232
|
|
|
|
|
|
|
return |
233
|
422
|
|
|
|
|
2067
|
{ trackable_resources => 1, |
234
|
|
|
|
|
|
|
}; |
235
|
|
|
|
|
|
|
} |
236
|
|
|
|
|
|
|
} |
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
sub _set_sacctmgr_path($$;$) |
239
|
|
|
|
|
|
|
#Sets sacctmgr path and version, and the capabilities hash |
240
|
4337
|
|
|
4337
|
|
4931
|
{ my $obj = shift; |
241
|
4337
|
|
|
|
|
4521
|
my $newpath = shift; |
242
|
4337
|
|
|
|
|
5048
|
my $newversion = shift; |
243
|
|
|
|
|
|
|
#This should only be called via new??? |
244
|
4337
|
|
|
|
|
5701
|
my $me = __PACKAGE__ . '::new'; |
245
|
|
|
|
|
|
|
|
246
|
4337
|
50
|
|
|
|
8530
|
unless ( $newpath ) |
247
|
0
|
|
|
|
|
0
|
{ $newpath = $DEFAULT_SACCTMGR_CMD; |
248
|
0
|
0
|
|
|
|
0
|
unless ( $newversion ) |
249
|
|
|
|
|
|
|
{ #Only default if defaulting path as well |
250
|
0
|
|
|
|
|
0
|
$newversion = $DEFAULT_SACCTMGR_VERSION; |
251
|
|
|
|
|
|
|
} |
252
|
|
|
|
|
|
|
} |
253
|
|
|
|
|
|
|
|
254
|
4337
|
|
|
|
|
21487
|
$obj->set('sacctmgr', $newpath); #newpath should always be set |
255
|
4337
|
100
|
|
|
|
36546
|
if ( $newversion ) |
256
|
4319
|
|
|
|
|
9002
|
{ $obj->set('slurm_version', $newversion); |
257
|
|
|
|
|
|
|
} else |
258
|
|
|
|
|
|
|
{ #No version given, so set version to undef |
259
|
18
|
|
|
|
|
54
|
$obj->set('slurm_version', undef); |
260
|
|
|
|
|
|
|
} |
261
|
|
|
|
|
|
|
#Always clear capabilities_hash |
262
|
4337
|
|
|
|
|
21492
|
$obj->set('_capabilities_hash', undef); |
263
|
|
|
|
|
|
|
} |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
sub _determine_slurm_version($) |
266
|
|
|
|
|
|
|
#Calls 'sacctmgr --version' to get our slurm version |
267
|
|
|
|
|
|
|
#Sets slurm_version data method and returns version |
268
|
0
|
|
|
0
|
|
0
|
{ my $obj = shift; |
269
|
0
|
|
|
|
|
0
|
my $me = __PACKAGE__ . '::_determine_slurm_version'; |
270
|
|
|
|
|
|
|
|
271
|
0
|
|
|
|
|
0
|
my @args = ( '--version' ); |
272
|
|
|
|
|
|
|
|
273
|
0
|
|
|
|
|
0
|
my ( $err, @out) = $obj->_run_generic_sacctmgr_cmd_always(@args); |
274
|
|
|
|
|
|
|
|
275
|
0
|
|
|
|
|
0
|
my $errstr; |
276
|
0
|
0
|
|
|
|
0
|
if ( $err ) |
277
|
0
|
|
|
|
|
0
|
{ $errstr = "Exit code: $err"; |
278
|
0
|
|
|
|
|
0
|
my $output = join "\n", @out; |
279
|
0
|
0
|
|
|
|
0
|
$errstr .= "\n$output" if $output; |
280
|
0
|
|
|
|
|
0
|
croak "$me: Error running sacctmgr --version to get slurm version\n$errstr\nat "; |
281
|
|
|
|
|
|
|
} |
282
|
|
|
|
|
|
|
|
283
|
0
|
|
|
|
|
0
|
my @vlines = grep /^slurm/, @out; |
284
|
0
|
0
|
|
|
|
0
|
unless ( scalar(@vlines) ) |
285
|
0
|
|
|
|
|
0
|
{ $errstr = join "\n", @out; |
286
|
0
|
|
|
|
|
0
|
croak "$me: Unable to get slurm version from 'sacctmgr --version'\n" . |
287
|
|
|
|
|
|
|
"Output was\n$errstr\nat "; |
288
|
|
|
|
|
|
|
} |
289
|
|
|
|
|
|
|
|
290
|
0
|
|
|
|
|
0
|
my $version = $vlines[0]; |
291
|
0
|
|
|
|
|
0
|
$version =~ s/^slurm\s*//; |
292
|
0
|
|
|
|
|
0
|
$obj->set('slurm_version', $version); |
293
|
0
|
|
|
|
|
0
|
return $version; |
294
|
|
|
|
|
|
|
} |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
sub sacctmgr_cmd_supports($$;$) |
297
|
|
|
|
|
|
|
#This checks if the current sshare command supports the named capability. |
298
|
|
|
|
|
|
|
#If $cachedonly is set, will only used cached information (i.e. will |
299
|
|
|
|
|
|
|
#NOT invoke an sacctmgr call to find out the version) |
300
|
|
|
|
|
|
|
#Returns 1 if supports, 0 if doesn't, and undef if unknown (should |
301
|
|
|
|
|
|
|
#only occur if $cachedonly is set) |
302
|
9972
|
|
|
9972
|
0
|
10752
|
{ my $self = shift; |
303
|
9972
|
|
|
|
|
13088
|
my $capname = shift; |
304
|
9972
|
|
|
|
|
9278
|
my $cachedonly = shift; |
305
|
9972
|
|
|
|
|
11239
|
my $me = __PACKAGE__ . '::sacctmgr_cmd_supports'; |
306
|
|
|
|
|
|
|
|
307
|
9972
|
50
|
|
|
|
24968
|
unless ( exists $SACCTMGR_CMD_CAPABILITIES_HASH{$capname} ) |
308
|
0
|
|
|
|
|
0
|
{ warn "$me: Unrecognized capability named '$capname' at "; |
309
|
0
|
|
|
|
|
0
|
return 0; #Unrecognized => unsupported |
310
|
|
|
|
|
|
|
} |
311
|
|
|
|
|
|
|
|
312
|
9972
|
|
|
|
|
40357
|
my $capshash = $self->get('_capabilities_hash'); |
313
|
9972
|
100
|
66
|
|
|
93887
|
unless ( $capshash && ref($capshash) eq 'HASH' ) |
314
|
|
|
|
|
|
|
{ #No capabilities hash, do we have a slurm_version |
315
|
1337
|
|
|
|
|
3990
|
my $svers = $self->slurm_version($cachedonly); |
316
|
|
|
|
|
|
|
|
317
|
|
|
|
|
|
|
#svers should only be undef if cachedonly and need to look up |
318
|
1337
|
50
|
|
|
|
3199
|
return unless defined $svers; |
319
|
|
|
|
|
|
|
|
320
|
1337
|
|
|
|
|
3332
|
$capshash = $self->sacctmgr_capabilities_by_version($svers); |
321
|
1337
|
50
|
33
|
|
|
7633
|
unless ( $capshash && ref($capshash) ) |
322
|
0
|
|
|
|
|
0
|
{ croak "$me: Unable to get capabilities hash for Slurm version $svers at "; |
323
|
|
|
|
|
|
|
} |
324
|
1337
|
|
|
|
|
3867
|
$self->set('_capabilities_hash', $capshash); |
325
|
|
|
|
|
|
|
} |
326
|
|
|
|
|
|
|
|
327
|
9972
|
|
|
|
|
22965
|
my $tmp = $capshash->{$capname}; |
328
|
9972
|
50
|
|
|
|
39780
|
return $tmp if defined $tmp; |
329
|
0
|
|
|
|
|
0
|
warn "$me: Capability $capname not in capshash at "; |
330
|
0
|
|
|
|
|
0
|
return; |
331
|
|
|
|
|
|
|
} |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
# |
334
|
|
|
|
|
|
|
#------------------------------------------------------------------- |
335
|
|
|
|
|
|
|
# Basic sacctmgr commands |
336
|
|
|
|
|
|
|
#------------------------------------------------------------------- |
337
|
|
|
|
|
|
|
|
338
|
|
|
|
|
|
|
sub _noshell_backticks($$@) |
339
|
|
|
|
|
|
|
#Calls an external command using pipes and forks so no shell gets invoked |
340
|
|
|
|
|
|
|
#Returns ($err, @out) where $err is the error is the exit status of |
341
|
|
|
|
|
|
|
#the command, and @out is the list of output returned, line by line. |
342
|
|
|
|
|
|
|
#If $mode is 0, only STDOUT is returned in @out, |
343
|
|
|
|
|
|
|
#If $mode is non-zero, STDERR is dupped onto STDOUT and also returned. |
344
|
15632
|
|
|
15632
|
|
21278
|
{ my $obj = shift; |
345
|
15632
|
|
|
|
|
30919
|
my $mode = shift; |
346
|
15632
|
|
|
|
|
32431
|
my @cmd = @_; |
347
|
|
|
|
|
|
|
|
348
|
|
|
|
|
|
|
#Exit code for errors in exec in child |
349
|
15632
|
|
|
|
|
18762
|
my $chd_excode=254; |
350
|
|
|
|
|
|
|
|
351
|
15632
|
|
|
|
|
19235
|
my ($err, @out, $PIPE, $res); |
352
|
|
|
|
|
|
|
|
353
|
15632
|
100
|
|
|
|
9053605
|
if ( $res = open($PIPE, "-|" ) ) |
354
|
|
|
|
|
|
|
{ #Parent |
355
|
14904
|
50
|
|
|
|
148422
|
if ( ! defined $res ) |
356
|
0
|
|
|
|
|
0
|
{ my $tmp = join ' ', @cmd; |
357
|
0
|
|
|
|
|
0
|
die "Pipe to '$tmp' failed: $!"; |
358
|
|
|
|
|
|
|
} |
359
|
14904
|
|
|
|
|
8119465069
|
@out = <$PIPE>; |
360
|
14904
|
|
|
|
|
425562
|
$res = close $PIPE; |
361
|
14904
|
|
|
|
|
104507
|
$err = $?; |
362
|
14904
|
50
|
33
|
|
|
85038
|
if ( $err && ( ($err >> 8) == $chd_excode ) ) |
363
|
|
|
|
|
|
|
{ #We (probably?) got an exception running exec in child process |
364
|
|
|
|
|
|
|
#Re raise the exception |
365
|
0
|
|
|
|
|
0
|
my $exc = join '', @out; |
366
|
0
|
|
|
|
|
0
|
die $exc; |
367
|
|
|
|
|
|
|
} |
368
|
14904
|
|
|
|
|
375152
|
return ($err, @out); |
369
|
|
|
|
|
|
|
} else |
370
|
|
|
|
|
|
|
{ #Child |
371
|
|
|
|
|
|
|
#Duplicate stderr onto stdout if so requested |
372
|
728
|
50
|
|
|
|
36634
|
if ( $mode ) |
373
|
728
|
50
|
|
|
|
45074
|
{ unless ( open(STDERR, '>&STDOUT') ) |
374
|
0
|
|
|
|
|
0
|
{ print "Cannot dup stderr to stdout in child"; |
375
|
0
|
|
|
|
|
0
|
die "Cannot dup stderr to stdout in child"; |
376
|
|
|
|
|
|
|
} |
377
|
|
|
|
|
|
|
} |
378
|
|
|
|
|
|
|
#Wrap exec in an eval, and exit on error, not die. |
379
|
|
|
|
|
|
|
#Otherwise, if _noshell_backticks is put in an eval block, an exception raised |
380
|
|
|
|
|
|
|
#by exec (e.g. taint issues) will result in both child and parent continuing from |
381
|
|
|
|
|
|
|
#the user's eval block. See e.g. http://www.perlmonks.org/?node_id=166538 |
382
|
728
|
|
|
|
|
12237
|
eval { exec { $cmd[0] } @cmd; #Not subject to shell escapes |
|
728
|
|
|
|
|
5131
|
|
|
728
|
|
|
|
|
0
|
|
383
|
|
|
|
|
|
|
}; |
384
|
|
|
|
|
|
|
#We only reach here if exec raised an exception |
385
|
0
|
0
|
|
|
|
0
|
warn "$@" if $@; |
386
|
0
|
|
|
|
|
0
|
exit $chd_excode; |
387
|
|
|
|
|
|
|
} |
388
|
|
|
|
|
|
|
} |
389
|
|
|
|
|
|
|
|
390
|
|
|
|
|
|
|
sub _run_generic_sacctmgr_cmd_always($@) |
391
|
|
|
|
|
|
|
#Run a generic sacctmgr cmd, returning results |
392
|
|
|
|
|
|
|
#Does NOT honors dryrun. |
393
|
|
|
|
|
|
|
#This should only be called directly for commands which do NOT |
394
|
|
|
|
|
|
|
#modify the database |
395
|
15632
|
|
|
15632
|
|
19303
|
{ my $obj = shift; |
396
|
15632
|
|
|
|
|
30904
|
my @args = @_; |
397
|
|
|
|
|
|
|
|
398
|
15632
|
|
|
|
|
45771
|
my $cmd = $obj->sacctmgr; |
399
|
15632
|
|
|
|
|
122823
|
my $mode = 1; |
400
|
15632
|
100
|
|
|
|
46223
|
if ( $obj->verbose ) |
401
|
|
|
|
|
|
|
{ #Verbose mode: |
402
|
|
|
|
|
|
|
#Output command before executing it |
403
|
15
|
|
|
|
|
133
|
my @tmp = ($obj->sacctmgr, @args); |
404
|
15
|
|
|
|
|
103
|
my $tmpsp = ''; |
405
|
15
|
|
|
|
|
31
|
my $tmpcmd = ''; |
406
|
|
|
|
|
|
|
#Quote any args with whitespace so verbose output looks better |
407
|
15
|
|
|
|
|
40
|
foreach (@tmp) |
408
|
77
|
|
|
|
|
54
|
{ my $tmp = $_; |
409
|
77
|
50
|
|
|
|
249
|
if ( $tmp =~ /\s/ ) |
410
|
|
|
|
|
|
|
{ #Quote it if it has whitespace |
411
|
0
|
|
|
|
|
0
|
$tmp = "'$tmp'"; |
412
|
|
|
|
|
|
|
} |
413
|
77
|
|
|
|
|
84
|
$tmpcmd .= $tmpsp . $tmp; |
414
|
77
|
|
|
|
|
85
|
$tmpsp = " "; |
415
|
|
|
|
|
|
|
} |
416
|
|
|
|
|
|
|
#my $tmpcmd = join ' ', @tmp; |
417
|
15
|
|
|
|
|
481
|
print STDERR "[VERBOSE] $tmpcmd\n"; |
418
|
|
|
|
|
|
|
} |
419
|
15632
|
|
|
|
|
118127
|
my ($err, @out ) = $obj->_noshell_backticks($mode, $cmd, @args); |
420
|
14904
|
|
|
|
|
80048
|
$_last_raw_output = [ @out ]; |
421
|
14904
|
|
|
|
|
121142
|
return ($err, @out); |
422
|
|
|
|
|
|
|
} |
423
|
|
|
|
|
|
|
|
424
|
|
|
|
|
|
|
sub run_generic_sacctmgr_cmd($@) |
425
|
|
|
|
|
|
|
#Run a generic sacctmgr cmd, returning results |
426
|
|
|
|
|
|
|
#Honors dryrun |
427
|
|
|
|
|
|
|
#Returns list ref of output, line by line on success. |
428
|
|
|
|
|
|
|
#Returns non-ref error message on error. |
429
|
8754
|
|
|
8754
|
1
|
31056
|
{ my $obj = shift; |
430
|
8754
|
|
|
|
|
20334
|
my @args = @_; |
431
|
|
|
|
|
|
|
|
432
|
8754
|
100
|
|
|
|
24699
|
if ( $obj->dryrun ) |
433
|
3164
|
|
|
|
|
27205
|
{ unshift @args, $obj->sacctmgr; |
434
|
|
|
|
|
|
|
#my $cmd = join ' ', @args; |
435
|
|
|
|
|
|
|
#Quote any args with whitespace so debug output looks better |
436
|
3164
|
|
|
|
|
23086
|
my $cmd = ''; |
437
|
3164
|
|
|
|
|
4392
|
my $tmpsp = ''; |
438
|
3164
|
|
|
|
|
5517
|
foreach (@args) |
439
|
26672
|
|
|
|
|
18460
|
{ my $tmp = $_; |
440
|
26672
|
100
|
|
|
|
39436
|
if ( $tmp =~ /\s/ ) |
441
|
|
|
|
|
|
|
{ #quote it if has whitespace |
442
|
1292
|
|
|
|
|
2194
|
$tmp = "'$tmp'"; |
443
|
|
|
|
|
|
|
} |
444
|
26672
|
|
|
|
|
22916
|
$cmd .= $tmpsp . $tmp; |
445
|
26672
|
|
|
|
|
22872
|
$tmpsp = ' '; |
446
|
|
|
|
|
|
|
} |
447
|
3164
|
|
|
|
|
192333
|
print STDERR "[DRYRUN] $cmd\n"; |
448
|
3164
|
|
|
|
|
16417
|
return []; |
449
|
|
|
|
|
|
|
} |
450
|
5590
|
|
|
|
|
53702
|
my ($err, @out) = $obj->_run_generic_sacctmgr_cmd_always(@args); |
451
|
5414
|
50
|
|
|
|
27843
|
if ( $err ) |
452
|
0
|
|
|
|
|
0
|
{ my $errstr = "Exit code: $err"; |
453
|
0
|
|
|
|
|
0
|
my $output = join "\n", @out; |
454
|
0
|
0
|
|
|
|
0
|
$errstr .= "\n$output" if $output; |
455
|
0
|
|
|
|
|
0
|
return $errstr; |
456
|
|
|
|
|
|
|
} |
457
|
|
|
|
|
|
|
#return $err if $err; |
458
|
5414
|
|
|
|
|
59714
|
return [ @out ]; |
459
|
|
|
|
|
|
|
|
460
|
|
|
|
|
|
|
} |
461
|
|
|
|
|
|
|
|
462
|
|
|
|
|
|
|
sub run_generic_safe_sacctmgr_cmd($@) |
463
|
|
|
|
|
|
|
#Run a "safe" generic sacctmgr cmd, returning results |
464
|
|
|
|
|
|
|
#which should not modify accounting info. |
465
|
|
|
|
|
|
|
#Does NOT honor dryrun, as command is "safe" |
466
|
|
|
|
|
|
|
#We append a --readonly to command to make sure it IS safe |
467
|
|
|
|
|
|
|
# |
468
|
|
|
|
|
|
|
#Returns list ref of output, line by line on success. |
469
|
|
|
|
|
|
|
#Returns non-ref error message on error. |
470
|
10042
|
|
|
10042
|
1
|
46629
|
{ my $obj = shift; |
471
|
10042
|
|
|
|
|
16550
|
my @args = @_; |
472
|
|
|
|
|
|
|
|
473
|
10042
|
|
|
|
|
14029
|
push @args, '--readonly'; |
474
|
10042
|
|
|
|
|
25753
|
my ($err, @out) = $obj->_run_generic_sacctmgr_cmd_always(@args); |
475
|
9490
|
50
|
|
|
|
32775
|
if ( $err ) |
476
|
0
|
|
|
|
|
0
|
{ my $errstr = "Exit code: $err"; |
477
|
0
|
|
|
|
|
0
|
my $output = join "\n", @out; |
478
|
0
|
0
|
|
|
|
0
|
$errstr .= "\n$output" if $output; |
479
|
0
|
|
|
|
|
0
|
return $errstr; |
480
|
|
|
|
|
|
|
} |
481
|
|
|
|
|
|
|
#return $err if $err; |
482
|
9490
|
|
|
|
|
46643
|
return [ @out ]; |
483
|
|
|
|
|
|
|
} |
484
|
|
|
|
|
|
|
|
485
|
|
|
|
|
|
|
sub run_generic_sacctmgr_list_command($@) |
486
|
|
|
|
|
|
|
#Runs a sacctmgr list command, returns output as a list ref of list refs |
487
|
|
|
|
|
|
|
#of the fields in order. |
488
|
|
|
|
|
|
|
#(Tried using hash refs, but those get abbreviated. Ugh!) |
489
|
|
|
|
|
|
|
#'list' should be included in the command spec |
490
|
|
|
|
|
|
|
# |
491
|
|
|
|
|
|
|
#On error, returns non-ref error message/error code |
492
|
|
|
|
|
|
|
# |
493
|
|
|
|
|
|
|
#Appends --parsable2 and --noheader to the command |
494
|
|
|
|
|
|
|
#Does NOT honor dryrun (as --readonly) |
495
|
10026
|
|
|
10026
|
1
|
45667
|
{ my $obj = shift; |
496
|
10026
|
|
|
|
|
18263
|
my @cmd = @_; |
497
|
|
|
|
|
|
|
|
498
|
10026
|
|
|
|
|
18719
|
push @cmd, '--parsable2', '--noheader'; |
499
|
10026
|
|
|
|
|
24122
|
my $lines = $obj->run_generic_safe_sacctmgr_cmd(@cmd); |
500
|
|
|
|
|
|
|
|
501
|
9477
|
50
|
33
|
|
|
100193
|
return $lines unless $lines && ref($lines) eq 'ARRAY'; |
502
|
|
|
|
|
|
|
|
503
|
9477
|
|
|
|
|
17946
|
my $results = []; |
504
|
9477
|
|
|
|
|
33347
|
foreach my $line (@$lines) |
505
|
11305
|
|
|
|
|
30091
|
{ chomp $line; |
506
|
11305
|
|
|
|
|
66631
|
my @values = split /\|/, $line; |
507
|
11305
|
|
|
|
|
34338
|
push @$results, \@values; |
508
|
|
|
|
|
|
|
} |
509
|
|
|
|
|
|
|
|
510
|
9477
|
|
|
|
|
92987
|
return $results; |
511
|
|
|
|
|
|
|
} |
512
|
|
|
|
|
|
|
|
513
|
|
|
|
|
|
|
|
514
|
|
|
|
|
|
|
1; |
515
|
|
|
|
|
|
|
__END__ |