line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Pb; |
2
|
|
|
|
|
|
|
|
3
|
1
|
|
|
1
|
|
96565
|
use 5.14.0; |
|
1
|
|
|
|
|
12
|
|
4
|
1
|
|
|
1
|
|
4
|
use warnings; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
21
|
|
5
|
1
|
|
|
1
|
|
411
|
use autodie ':all'; |
|
1
|
|
|
|
|
12731
|
|
|
1
|
|
|
|
|
4
|
|
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
our $VERSION = '0.01_03'; # TRIAL VERSION |
8
|
|
|
|
|
|
|
|
9
|
1
|
|
|
1
|
|
19035
|
use Exporter; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
65
|
|
10
|
|
|
|
|
|
|
our @EXPORT = |
11
|
|
|
|
|
|
|
( |
12
|
|
|
|
|
|
|
qw< command base_command flow >, # base structure of the command itself |
13
|
|
|
|
|
|
|
qw< arg opt must_be one_of also >, # for declaring command arguments and options |
14
|
|
|
|
|
|
|
qw< log_to control_via >, # attributes of the command |
15
|
|
|
|
|
|
|
qw< verify SH CODE RUN >, # keywords inside a flow |
16
|
|
|
|
|
|
|
qw< $FLOW %OPT >, # variable containers that flows need access to |
17
|
|
|
|
|
|
|
qw< pwd >, # pass-through from PerlX::bash |
18
|
|
|
|
|
|
|
); |
19
|
|
|
|
|
|
|
|
20
|
1
|
|
|
1
|
|
467
|
use Moo; |
|
1
|
|
|
|
|
9644
|
|
|
1
|
|
|
|
|
5
|
|
21
|
1
|
|
|
1
|
|
1816
|
use CLI::Osprey; |
|
1
|
|
|
|
|
19888
|
|
|
1
|
|
|
|
|
6
|
|
22
|
|
|
|
|
|
|
|
23
|
1
|
|
|
1
|
|
61591
|
use Safe::Isa; |
|
1
|
|
|
|
|
397
|
|
|
1
|
|
|
|
|
106
|
|
24
|
1
|
|
|
1
|
|
477
|
use Type::Tiny; |
|
1
|
|
|
|
|
12274
|
|
|
1
|
|
|
|
|
31
|
|
25
|
1
|
|
|
1
|
|
397
|
use PerlX::bash qw< bash pwd >; |
|
1
|
|
|
|
|
16680
|
|
|
1
|
|
|
|
|
50
|
|
26
|
1
|
|
|
1
|
|
407
|
use Import::Into; |
|
1
|
|
|
|
|
442
|
|
|
1
|
|
|
|
|
28
|
|
27
|
1
|
|
|
1
|
|
7
|
use Sub::Install qw< install_sub >; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
7
|
|
28
|
1
|
|
|
1
|
|
150
|
use File::Basename; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
70
|
|
29
|
|
|
|
|
|
|
|
30
|
1
|
|
|
1
|
|
443
|
use Pb::Command::Context; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
2516
|
|
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
sub import |
34
|
|
|
|
|
|
|
{ |
35
|
1
|
|
|
1
|
|
9
|
my $caller = caller; |
36
|
1
|
|
|
|
|
16
|
_setup_signal_handlers(); |
37
|
1
|
|
|
|
|
424
|
strict->import::into($caller); |
38
|
1
|
|
|
|
|
171
|
warnings->import::into($caller); |
39
|
1
|
|
|
|
|
146
|
feature->import::into($caller, ':5.14'); |
40
|
1
|
|
|
|
|
236
|
autodie->import::into({level=>1}, ':all'); # `autodie` requires a bit of magic ... |
41
|
1
|
|
|
|
|
5078
|
goto \&Exporter::import; |
42
|
|
|
|
|
|
|
} |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
# This is a global, sort of ... it has a global lifetime, certainly, but not global visibility. |
46
|
|
|
|
|
|
|
# Think of it like a singleton. Most of our methods can either be called as object methods, in |
47
|
|
|
|
|
|
|
# which case they operate on the object invocant, or just as straight functions, in which case they |
48
|
|
|
|
|
|
|
# operate on this guy. `$CMD` is set by `Pb->go` (which is down at the very bottom of this file). |
49
|
|
|
|
|
|
|
my $CMD; |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
# And this is how we implement that optional invocant. |
52
|
0
|
0
|
|
0
|
|
0
|
sub _pb_args { $_[0]->$_can('_osprey_config') ? @_ : ($CMD, @_) } |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
################### |
56
|
|
|
|
|
|
|
# CONTEXT OBJECTS # |
57
|
|
|
|
|
|
|
################### |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
# This will be cloned and have command-specific values added to it when the flow executes. |
60
|
|
|
|
|
|
|
our $FLOW = Pb::Command::Context->new; |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
our %OPT; # key == option name, value == option value |
63
|
|
|
|
|
|
|
our %CONTROL; # key == command name, value == control structure |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
################## |
67
|
|
|
|
|
|
|
# GLOBAL OPTIONS # |
68
|
|
|
|
|
|
|
################## |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
option pretend => |
71
|
|
|
|
|
|
|
( |
72
|
|
|
|
|
|
|
is => 'ro', doc => "don't run commands; just print them", |
73
|
|
|
|
|
|
|
); |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
############### |
77
|
|
|
|
|
|
|
# SCAFFOLDING # |
78
|
|
|
|
|
|
|
############### |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
# this will hold all the different flows |
81
|
|
|
|
|
|
|
my %FLOWS; |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
# this is for the `base_command` (if there is one) |
84
|
|
|
|
|
|
|
my $BASE_CMD; |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
# This takes an option def (i.e. a hashref built from the properties of an `opt` clause) and turns |
88
|
|
|
|
|
|
|
# it into the arguments to an `option` call (`option` is defined by CLI::Osprey). |
89
|
|
|
|
|
|
|
sub _option_args |
90
|
|
|
|
|
|
|
{ |
91
|
0
|
|
|
0
|
|
0
|
my $def = shift; |
92
|
0
|
|
|
|
|
0
|
my %props = ( is => 'ro' ); |
93
|
0
|
0
|
|
|
|
0
|
unless ( $def->{type}->is_a_type_of('Bool') ) |
94
|
|
|
|
|
|
|
{ |
95
|
0
|
|
|
|
|
0
|
$props{format} = 's'; |
96
|
|
|
|
|
|
|
} |
97
|
0
|
|
|
|
|
0
|
return $def->{name} => %props; |
98
|
|
|
|
|
|
|
} |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
# This builds subcommands. If it weren't for the fact that we need our subcommands to be able to |
101
|
|
|
|
|
|
|
# have their own options, we could simply do `subcommand $name => $cmd`. However, that creates an |
102
|
|
|
|
|
|
|
# object of class CLI::Osprey::InlineSubcommand, and those can't have options. :-( |
103
|
|
|
|
|
|
|
sub _install_subcommand |
104
|
|
|
|
|
|
|
{ |
105
|
0
|
|
|
0
|
|
0
|
my ($name, $action, $optdefs) = @_; |
106
|
0
|
|
|
|
|
0
|
my $pkg = $name =~ s/-/_/r; |
107
|
0
|
0
|
|
|
|
0
|
fatal("illegal command name [$name]") if $pkg !~ /\A[a-zA-Z_][a-zA-Z0-9_]*\z/; |
108
|
0
|
|
|
|
|
0
|
$pkg = "Pb::Subcommand::$pkg"; |
109
|
0
|
|
|
|
|
0
|
eval "package $pkg { use Moo; use CLI::Osprey; }"; |
110
|
0
|
|
|
|
|
0
|
install_sub({ code => $action, into => $pkg, as => 'run' }); |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
# handle options |
113
|
0
|
|
0
|
|
|
0
|
my $option = $pkg->can('option') // die("Can't install options into subcommand package! [$name]"); |
114
|
0
|
|
|
|
|
0
|
$option->( _option_args($_) ) foreach @$optdefs; |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
# NOTE: can pass a `desc =>` to the `subcommand` (useful for help?) |
117
|
0
|
|
|
|
|
0
|
subcommand $name => $pkg; |
118
|
|
|
|
|
|
|
} |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
# This build the "base command," which is really just the default subcommand. |
121
|
|
|
|
|
|
|
sub _install_base_command |
122
|
|
|
|
|
|
|
{ |
123
|
0
|
|
|
0
|
|
0
|
my ($action, $optdefs) = @_; |
124
|
0
|
|
|
|
|
0
|
option( _option_args($_) ) foreach @$optdefs; |
125
|
0
|
|
|
|
|
0
|
$BASE_CMD = $action; |
126
|
|
|
|
|
|
|
} |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
# This guarantees that `END` blocks are not only called when your program `exit`s or `die`s, but |
130
|
|
|
|
|
|
|
# also when it's terminated due to a signal (where possible to catch). This is super-important for |
131
|
|
|
|
|
|
|
# things like making sure pidfiles get cleaned up. I'm pretty sure that the only times your `END` |
132
|
|
|
|
|
|
|
# blocks won't get called if your program exits after this runs is for uncatchable signals (i.e. |
133
|
|
|
|
|
|
|
# `KILL`) and if you call `exec`. I'd worry more about that latter one, but it seems pretty |
134
|
|
|
|
|
|
|
# unlikely in a Leadpipe context. |
135
|
|
|
|
|
|
|
sub _setup_signal_handlers |
136
|
|
|
|
|
|
|
{ |
137
|
|
|
|
|
|
|
# This list compiled via the following methodology: |
138
|
|
|
|
|
|
|
# * Examine the signal(7) man page on a current (at the time) Linux version (this one just |
139
|
|
|
|
|
|
|
# so happened to be Linux Mint 18.2, kernel 4.10.0-38-generic). |
140
|
|
|
|
|
|
|
# * Find all signals which are labeled either "Term" or "Core" (i.e. all signals which will |
141
|
|
|
|
|
|
|
# actually cause your process to exit). |
142
|
|
|
|
|
|
|
# * Eliminate everything already in sigtrap.pm's "normal-signals" list. |
143
|
|
|
|
|
|
|
# * Eliminate everything already in sigtrap.pm's "error-signals" list. |
144
|
|
|
|
|
|
|
# * Eliminate "KILL," because you can't catch it anyway. |
145
|
|
|
|
|
|
|
# * Eliminate "USR1" and "USR2" on the grounds that we shouldn't assume anything about |
146
|
|
|
|
|
|
|
# "user-defined signals." |
147
|
|
|
|
|
|
|
# * Whatever was leftover is the list below. |
148
|
1
|
|
|
1
|
|
5
|
my @EXTRA_SIGNALS = qw< ALRM POLL PROF VTALRM XCPU XFSZ IOT STKFLT IO PWR LOST UNUSED >; |
149
|
1
|
|
|
|
|
391
|
require sigtrap; |
150
|
|
|
|
|
|
|
# Because of the `untrapped`, this won't bork any signals you've previously set yourself. |
151
|
|
|
|
|
|
|
# Signals you _subsequently_ set yourself will of course override these. |
152
|
|
|
|
|
|
|
sigtrap->import( handler => sub |
153
|
|
|
|
|
|
|
{ |
154
|
0
|
|
|
0
|
|
0
|
my $signal = shift; |
155
|
|
|
|
|
|
|
# Weirdly (or maybe not so much; I dunno), while `END` blocks don't get called if a |
156
|
|
|
|
|
|
|
# `'DEFAULT'` signal handler leads to an exit, they _do_ for custom handlers. So this |
157
|
|
|
|
|
|
|
# `sub` literally doesn't need to do _anything_. But, hey: while we're here, may as |
158
|
|
|
|
|
|
|
# well alert the user as to what's going down. |
159
|
0
|
|
|
|
|
0
|
$FLOW->raise_error("terminated due to signal $signal"); |
160
|
0
|
|
|
|
|
0
|
say STDERR "received signal: $signal"; |
161
|
|
|
|
|
|
|
}, |
162
|
|
|
|
|
|
|
untrapped => 'normal-signals', 'error-signals', |
163
|
1
|
|
|
|
|
978
|
grep { exists $SIG{$_} } @EXTRA_SIGNALS |
|
12
|
|
|
|
|
29
|
|
164
|
|
|
|
|
|
|
); |
165
|
|
|
|
|
|
|
} |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
##################### |
169
|
|
|
|
|
|
|
# COMMAND STRUCTURE # |
170
|
|
|
|
|
|
|
##################### |
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
sub command |
174
|
|
|
|
|
|
|
{ |
175
|
0
|
|
|
0
|
1
|
|
state $PASSTHRU_ARGS = { map { $_ => 1 } qw< log_to flow > }; |
|
0
|
|
|
|
|
|
|
176
|
0
|
|
|
|
|
|
state $CONTEXT_VAR_XLATE = { LOGFILE => 'log_to', }; |
177
|
0
|
|
|
|
|
|
my $name = shift; |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
# these are all used in the closure below |
180
|
0
|
|
|
|
|
|
my %args; # arguments to this command definition |
181
|
0
|
|
|
|
|
|
my $argdefs = []; # definition of args to the command invocation |
182
|
0
|
|
|
|
|
|
my $optdefs = []; # definition of opts to the command invocation |
183
|
|
|
|
|
|
|
# process args: most are simple, some are trickier |
184
|
0
|
|
|
|
|
|
while (@_) |
185
|
|
|
|
|
|
|
{ |
186
|
0
|
0
|
|
|
|
|
if ($PASSTHRU_ARGS->{$_[0]}) |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
187
|
|
|
|
|
|
|
{ |
188
|
0
|
|
|
|
|
|
my $arg = shift; |
189
|
0
|
|
|
|
|
|
$args{$arg} = shift; |
190
|
|
|
|
|
|
|
} |
191
|
|
|
|
|
|
|
elsif ($_[0] eq 'arg') |
192
|
|
|
|
|
|
|
{ |
193
|
0
|
|
|
|
|
|
shift; # just the 'arg' marker |
194
|
0
|
0
|
|
|
|
|
fatal("base commands cannot take arguments (try an option instead)") if $name eq ':DEFAULT'; |
195
|
0
|
|
|
|
|
|
my $arg = {}; |
196
|
0
|
|
|
|
|
|
$arg->{name} = shift; |
197
|
0
|
|
|
|
|
|
$arg->{type} = shift; |
198
|
|
|
|
|
|
|
fatal("not a constraint [" . (ref $arg->{type} || $arg->{type}) . "]") |
199
|
0
|
0
|
0
|
|
|
|
unless $arg->{type}->$_isa('Type::Tiny'); |
200
|
0
|
|
|
|
|
|
push @$argdefs, $arg; |
201
|
|
|
|
|
|
|
} |
202
|
|
|
|
|
|
|
elsif ($_[0] eq 'opt') |
203
|
|
|
|
|
|
|
{ |
204
|
0
|
|
|
|
|
|
shift; # just the 'opt' marker |
205
|
0
|
|
|
|
|
|
my $opt = {}; |
206
|
0
|
|
|
|
|
|
$opt->{name} = shift; |
207
|
0
|
0
|
|
|
|
|
$opt->{type} = $_[0]->$_isa('Type::Tiny') ? shift : must_be('Bool'); |
208
|
0
|
0
|
|
|
|
|
if ($_[0] eq 'properties') |
209
|
|
|
|
|
|
|
{ |
210
|
0
|
|
|
|
|
|
shift; |
211
|
0
|
|
|
|
|
|
my $extra_props = shift; |
212
|
0
|
|
|
|
|
|
$opt->{$_} = $extra_props->{$_} foreach keys %$extra_props; |
213
|
|
|
|
|
|
|
} |
214
|
0
|
|
|
|
|
|
push @$optdefs, $opt; |
215
|
|
|
|
|
|
|
} |
216
|
|
|
|
|
|
|
elsif ($_[0] eq 'control') |
217
|
|
|
|
|
|
|
{ |
218
|
0
|
|
|
|
|
|
shift; # just the 'control' marker |
219
|
0
|
|
|
|
|
|
my $control = shift; |
220
|
0
|
0
|
|
|
|
|
fatal("`control_via' requires hashref") unless ref $control eq 'HASH'; |
221
|
0
|
|
|
|
|
|
$CONTROL{$name} = $control; |
222
|
|
|
|
|
|
|
} |
223
|
|
|
|
|
|
|
else |
224
|
|
|
|
|
|
|
{ |
225
|
0
|
|
|
|
|
|
fatal("unknown command attribute [$_[0]]"); |
226
|
|
|
|
|
|
|
} |
227
|
|
|
|
|
|
|
} |
228
|
|
|
|
|
|
|
|
229
|
|
|
|
|
|
|
# Save the flow (including processing any args) under our name. Doing args here rather than in |
230
|
|
|
|
|
|
|
# the `$subcmd` below enables the `RUN` directive to pass args as well. |
231
|
|
|
|
|
|
|
$FLOWS{$name} = sub |
232
|
|
|
|
|
|
|
{ |
233
|
0
|
|
|
0
|
|
|
$FLOW->validate_args(@_, $argdefs); |
234
|
0
|
0
|
|
|
|
|
fatal($FLOW->error) if $FLOW->error; |
235
|
0
|
|
|
|
|
|
$args{flow}->(); |
236
|
0
|
|
|
|
|
|
}; |
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
my $subcmd = sub |
239
|
|
|
|
|
|
|
{ |
240
|
0
|
|
|
0
|
|
|
my ($osprey) = @_; # currently unused |
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
# Figure out what context vars we need to set based on our the `command` properties. |
243
|
0
|
|
|
|
|
|
my $context_vars = {}; |
244
|
0
|
|
|
|
|
|
foreach ( keys %$CONTEXT_VAR_XLATE ) |
245
|
|
|
|
|
|
|
{ |
246
|
0
|
|
|
|
|
|
my $arg = $CONTEXT_VAR_XLATE->{$_}; |
247
|
0
|
0
|
|
|
|
|
$context_vars->{$_} = $args{$arg} if exists $args{$arg}; |
248
|
|
|
|
|
|
|
} |
249
|
|
|
|
|
|
|
|
250
|
|
|
|
|
|
|
# Build the context for this command based on the (skeletal) global one, doing 3 major |
251
|
|
|
|
|
|
|
# things: adding in new context vars from our `command` definition, validing any |
252
|
|
|
|
|
|
|
# command-specific opts, and processing the control structure (if any). |
253
|
0
|
|
|
|
|
|
my $context = $FLOW->setup_context($context_vars, $optdefs, $CONTROL{$name}); |
254
|
0
|
0
|
|
|
|
|
if ($context->error) # either an opt didn't validate or the control structure had an error |
255
|
|
|
|
|
|
|
{ |
256
|
0
|
|
|
|
|
|
fatal($context->error); |
257
|
|
|
|
|
|
|
} |
258
|
|
|
|
|
|
|
else # set global access vars for flows |
259
|
|
|
|
|
|
|
{ |
260
|
0
|
|
|
|
|
|
$FLOW = $context; |
261
|
0
|
|
|
|
|
|
%OPT = $FLOW->opts; |
262
|
|
|
|
|
|
|
} |
263
|
|
|
|
|
|
|
|
264
|
|
|
|
|
|
|
# Script args are flow args (switches were already processed by Osprey and validated above). |
265
|
0
|
|
|
|
|
|
$FLOWS{$name}->(@ARGV); |
266
|
0
|
|
|
|
|
|
}; |
267
|
0
|
0
|
|
|
|
|
$name eq ':DEFAULT' ? _install_base_command($subcmd, $optdefs) : _install_subcommand($name => $subcmd, $optdefs); |
268
|
|
|
|
|
|
|
} |
269
|
|
|
|
|
|
|
|
270
|
|
|
|
|
|
|
|
271
|
0
|
|
|
0
|
1
|
|
sub base_command { unshift @_, ':DEFAULT'; &command } |
|
0
|
|
|
|
|
|
|
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
|
274
|
|
|
|
|
|
|
|
275
|
0
|
|
|
0
|
1
|
|
sub arg ($) { arg => shift } |
276
|
|
|
|
|
|
|
|
277
|
0
|
|
|
0
|
1
|
|
sub opt (@) { opt => @_ } |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
sub must_be ($) |
280
|
|
|
|
|
|
|
{ |
281
|
0
|
|
|
0
|
1
|
|
my $type = shift; |
282
|
|
|
|
|
|
|
# slightly cheating, but this private method handles the widest range of things that might be a |
283
|
|
|
|
|
|
|
# type (including if it's already a Type::Tiny to start with) |
284
|
0
|
|
|
|
|
|
my ($t) = eval { Type::Tiny::_loose_to_TypeTiny($type) }; |
|
0
|
|
|
|
|
|
|
285
|
0
|
0
|
|
|
|
|
fatal("not a valid type [$type]") unless defined $t; |
286
|
0
|
|
0
|
0
|
|
|
$t->create_child_type(message => sub { ($_ // '<>') . " is not a " . $t->name }); |
|
0
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
} |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
sub one_of ($) |
290
|
|
|
|
|
|
|
{ |
291
|
0
|
|
|
0
|
1
|
|
require Type::Tiny::Enum; |
292
|
0
|
|
|
|
|
|
my $v = shift; |
293
|
0
|
|
0
|
0
|
|
|
Type::Tiny::Enum->new( values => $v, message => sub { ($_ // '<>') . " must be one of: " . join(', ', @$v) }); |
|
0
|
|
|
|
|
|
|
294
|
|
|
|
|
|
|
} |
295
|
|
|
|
|
|
|
|
296
|
0
|
0
|
|
0
|
1
|
|
sub also { properties => { map { s/^-// ? ($_ => 1) : $_ } @_ } } |
|
0
|
|
|
|
|
|
|
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
|
299
|
|
|
|
|
|
|
|
300
|
0
|
|
|
0
|
1
|
|
sub log_to ($) { log_to => shift } |
301
|
|
|
|
|
|
|
|
302
|
0
|
|
|
0
|
1
|
|
sub control_via ($) { control => shift } |
303
|
|
|
|
|
|
|
|
304
|
|
|
|
|
|
|
|
305
|
|
|
|
|
|
|
|
306
|
0
|
|
|
0
|
1
|
|
sub flow (&) { flow => shift } |
307
|
|
|
|
|
|
|
|
308
|
|
|
|
|
|
|
|
309
|
|
|
|
|
|
|
############## |
310
|
|
|
|
|
|
|
# DIRECTIVES # |
311
|
|
|
|
|
|
|
############## |
312
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
|
314
|
|
|
|
|
|
|
sub verify (&$) |
315
|
|
|
|
|
|
|
{ |
316
|
0
|
|
|
0
|
1
|
|
my ($check, $fail_msg) = @_; |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
# we need to ensure verify code gets executed no matter what |
319
|
0
|
|
|
|
|
|
my $save_runmode = $FLOW->runmode; |
320
|
0
|
|
|
|
|
|
$FLOW->_set_runmode('VERIFY'); |
321
|
0
|
0
|
|
|
|
|
unless ( $check->() ) |
322
|
|
|
|
|
|
|
{ |
323
|
|
|
|
|
|
|
# Doing the error this way is a bit roundabout, but it guarantees failure here won't create |
324
|
|
|
|
|
|
|
# a statusfile that might keep our next run from happening due to `unless_clean_exit`. |
325
|
0
|
|
|
|
|
|
$FLOW->start_conditions_not_met("pre-flow check failed [$fail_msg]"); |
326
|
0
|
|
|
|
|
|
fatal($FLOW->error); |
327
|
|
|
|
|
|
|
} |
328
|
0
|
|
|
|
|
|
$FLOW->_set_runmode($save_runmode); |
329
|
|
|
|
|
|
|
} |
330
|
|
|
|
|
|
|
|
331
|
|
|
|
|
|
|
|
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
sub SH (@) |
334
|
|
|
|
|
|
|
{ |
335
|
0
|
|
|
0
|
1
|
|
my @cmd = @_; |
336
|
|
|
|
|
|
|
|
337
|
0
|
0
|
|
|
|
|
if ( $FLOW->runmode eq 'NOACTION' ) |
338
|
|
|
|
|
|
|
{ |
339
|
0
|
|
|
|
|
|
say "would run: @cmd"; |
340
|
0
|
|
|
|
|
|
return; |
341
|
|
|
|
|
|
|
} |
342
|
|
|
|
|
|
|
|
343
|
|
|
|
|
|
|
# In the rare case where `--pretend` is set but `runmode` is *not* "NOACTION," don't send our |
344
|
|
|
|
|
|
|
# output to the logfile. |
345
|
0
|
0
|
0
|
|
|
|
push @cmd, ">>$FLOW->{LOGFILE}" if exists $FLOW->{LOGFILE} and not $OPT{pretend}; |
346
|
|
|
|
|
|
|
|
347
|
0
|
|
|
|
|
|
my $exitval = bash @cmd; |
348
|
0
|
0
|
|
|
|
|
if (defined wantarray) # someone cares about our exit value |
349
|
|
|
|
|
|
|
{ |
350
|
0
|
|
|
|
|
|
return $exitval; |
351
|
|
|
|
|
|
|
} |
352
|
|
|
|
|
|
|
else # just a straight `SH` directive; die unless clean exit |
353
|
|
|
|
|
|
|
{ |
354
|
0
|
0
|
|
|
|
|
fatal("command [@_] exited non-zero [$exitval]") unless $exitval == 0; |
355
|
|
|
|
|
|
|
} |
356
|
|
|
|
|
|
|
} |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
|
359
|
|
|
|
|
|
|
|
360
|
|
|
|
|
|
|
sub CODE (@) |
361
|
|
|
|
|
|
|
{ |
362
|
0
|
|
|
0
|
1
|
|
my $block = pop; |
363
|
0
|
|
|
|
|
|
my ($name) = @_; |
364
|
|
|
|
|
|
|
|
365
|
0
|
0
|
|
|
|
|
if ( $FLOW->runmode eq 'NOACTION' ) |
366
|
|
|
|
|
|
|
{ |
367
|
0
|
|
|
|
|
|
my $msg = "would run code block"; |
368
|
0
|
0
|
|
|
|
|
$msg .= " [$name]" if $name; |
369
|
0
|
|
|
|
|
|
say $msg; |
370
|
0
|
|
|
|
|
|
return; |
371
|
|
|
|
|
|
|
} |
372
|
|
|
|
|
|
|
|
373
|
|
|
|
|
|
|
# If we have a logfile, better make sure our code block is printing to it rather than STDOUT, if |
374
|
|
|
|
|
|
|
# it prints anything. |
375
|
0
|
|
|
|
|
|
my $log; |
376
|
0
|
0
|
|
|
|
|
if ( my $logfile = $FLOW->logfile ) |
377
|
|
|
|
|
|
|
{ |
378
|
0
|
|
|
|
|
|
open($log, '>>', $logfile); |
379
|
|
|
|
|
|
|
} |
380
|
|
|
|
|
|
|
|
381
|
0
|
|
|
|
|
|
my $retval; |
382
|
|
|
|
|
|
|
do |
383
|
0
|
|
|
|
|
|
{ |
384
|
0
|
0
|
|
|
|
|
local *STDOUT = $log if $log; |
385
|
0
|
|
|
|
|
|
$retval = $block->(); |
386
|
|
|
|
|
|
|
}; |
387
|
0
|
0
|
|
|
|
|
unless ($retval) |
388
|
|
|
|
|
|
|
{ |
389
|
0
|
0
|
0
|
|
|
|
my $msg = "code block" . ($name ? " [$name]" : '') . " returned false value [" . ($retval // 'undef') . "]"; |
390
|
0
|
|
|
|
|
|
fatal($msg); |
391
|
|
|
|
|
|
|
} |
392
|
|
|
|
|
|
|
} |
393
|
|
|
|
|
|
|
|
394
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
|
396
|
|
|
|
|
|
|
sub RUN (@) |
397
|
|
|
|
|
|
|
{ |
398
|
0
|
|
|
0
|
1
|
|
my ($flow, @args) = @_; |
399
|
0
|
|
|
|
|
|
$FLOWS{$flow}->(@args); |
400
|
|
|
|
|
|
|
} |
401
|
|
|
|
|
|
|
|
402
|
|
|
|
|
|
|
|
403
|
|
|
|
|
|
|
#################### |
404
|
|
|
|
|
|
|
# SUPPORT ROUTINES # |
405
|
|
|
|
|
|
|
#################### |
406
|
|
|
|
|
|
|
|
407
|
|
|
|
|
|
|
|
408
|
|
|
|
|
|
|
sub fatal |
409
|
|
|
|
|
|
|
{ |
410
|
0
|
|
|
0
|
1
|
|
my ($self, $msg) = &_pb_args; |
411
|
0
|
|
0
|
|
|
|
my $me = $FLOW->{ME} // basename($0); |
412
|
0
|
|
|
|
|
|
say STDERR "$me: $msg"; |
413
|
0
|
|
|
|
|
|
$FLOW->raise_error($msg); |
414
|
0
|
|
|
|
|
|
exit 1; |
415
|
|
|
|
|
|
|
} |
416
|
|
|
|
|
|
|
|
417
|
|
|
|
|
|
|
|
418
|
|
|
|
|
|
|
#################### |
419
|
|
|
|
|
|
|
# DEFAULT COMMANDS # |
420
|
|
|
|
|
|
|
#################### |
421
|
|
|
|
|
|
|
|
422
|
|
|
|
|
|
|
subcommand help => sub { shift->osprey_help }; |
423
|
|
|
|
|
|
|
subcommand commands => sub |
424
|
|
|
|
|
|
|
{ |
425
|
|
|
|
|
|
|
my $class = shift; |
426
|
|
|
|
|
|
|
my %sc = $class->_osprey_subcommands; |
427
|
|
|
|
|
|
|
say foreach sort keys %sc; |
428
|
|
|
|
|
|
|
}; |
429
|
|
|
|
|
|
|
|
430
|
|
|
|
|
|
|
subcommand info => sub |
431
|
|
|
|
|
|
|
{ |
432
|
|
|
|
|
|
|
my $self = shift; |
433
|
|
|
|
|
|
|
foreach (@_) |
434
|
|
|
|
|
|
|
{ |
435
|
|
|
|
|
|
|
$self->fatal("no such setting [$_]") unless $FLOW->has_var($_); |
436
|
|
|
|
|
|
|
say $FLOW->{$_}; |
437
|
|
|
|
|
|
|
} |
438
|
|
|
|
|
|
|
}; |
439
|
|
|
|
|
|
|
|
440
|
|
|
|
|
|
|
|
441
|
|
|
|
|
|
|
############## |
442
|
|
|
|
|
|
|
# GO GO GO!! # |
443
|
|
|
|
|
|
|
############## |
444
|
|
|
|
|
|
|
|
445
|
|
|
|
|
|
|
|
446
|
|
|
|
|
|
|
# This is only used when there's a base command (but Osprey needs it regardless). |
447
|
|
|
|
|
|
|
sub run |
448
|
|
|
|
|
|
|
{ |
449
|
0
|
0
|
|
0
|
0
|
|
$BASE_CMD->(@_) if $BASE_CMD; |
450
|
|
|
|
|
|
|
} |
451
|
|
|
|
|
|
|
|
452
|
|
|
|
|
|
|
sub go |
453
|
|
|
|
|
|
|
{ |
454
|
0
|
0
|
0
|
0
|
0
|
|
shift @ARGV and $FLOW->set_debug($1) if @ARGV and $ARGV[0] =~ /^DEBUG=(\d+)$/; |
|
|
|
0
|
|
|
|
|
455
|
|
|
|
|
|
|
|
456
|
0
|
|
|
|
|
|
$CMD = shift->new_with_options; |
457
|
0
|
|
|
|
|
|
$FLOW->connect_to($CMD); # this connects the context to the command |
458
|
|
|
|
|
|
|
|
459
|
0
|
|
|
|
|
|
$CMD->run; |
460
|
|
|
|
|
|
|
} |
461
|
|
|
|
|
|
|
|
462
|
|
|
|
|
|
|
|
463
|
|
|
|
|
|
|
1; |
464
|
|
|
|
|
|
|
|
465
|
|
|
|
|
|
|
|
466
|
|
|
|
|
|
|
|
467
|
|
|
|
|
|
|
# ABSTRACT: a workflow system made from Perl and bash |
468
|
|
|
|
|
|
|
# COPYRIGHT |
469
|
|
|
|
|
|
|
|
470
|
|
|
|
|
|
|
__END__ |