File Coverage

blib/lib/ScriptX.pm
Criterion Covered Total %
statement 24 184 13.0
branch 14 100 14.0
condition 1 28 3.5
subroutine 2 10 20.0
pod 4 4 100.0
total 45 326 13.8


line stmt bran cond sub pod time code
1             package ScriptX;
2              
3             our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
4             our $DATE = '2020-10-01'; # DATE
5             our $DIST = 'ScriptX'; # DIST
6             our $VERSION = '0.000002'; # VERSION
7              
8             # IFUNBUILT
9             # use strict;
10             # use warnings;
11             # END IFUNBUILT
12 1     1   74814 use Log::ger;
  1         61  
  1         5  
13              
14             our %Plugins;
15             our %Handlers;
16              
17             my $Stash = {
18             plugins => \%Plugins,
19             handlers => \%Handlers,
20             };
21              
22             sub run_event {
23 0     0 1 0 my %args = @_;
24              
25 0         0 my $name = $args{name};
26 0         0 log_trace "[scriptx] -> run_event(%s)", \%args;
27 0 0       0 defined $name or die "Please supply 'name'";
28 0   0     0 $Handlers{$name} ||= [];
29              
30 0         0 my $before_name = "before_$name";
31 0   0     0 $Handlers{$before_name} ||= [];
32              
33 0         0 my $after_name = "after_$name";
34 0   0     0 $Handlers{$after_name} ||= [];
35              
36 0 0       0 my $req_handler = $args{req_handler}; $req_handler = 0 unless defined $req_handler;
  0         0  
37 0 0       0 my $run_all_handlers = $args{run_all_handlers}; $run_all_handlers = 1 unless defined $run_all_handlers;
  0         0  
38 0 0       0 my $allow_before_handler_to_cancel_event = $args{allow_before_handler_to_cancel_event}; $allow_before_handler_to_cancel_event = 1 unless defined $allow_before_handler_to_cancel_event;
  0         0  
39 0 0       0 my $allow_before_handler_to_skip_rest = $args{allow_before_handler_to_skip_rest}; $allow_before_handler_to_skip_rest = 1 unless defined $allow_before_handler_to_skip_rest;
  0         0  
40 0 0       0 my $allow_handler_to_skip_rest = $args{allow_handler_to_skip_rest}; $allow_handler_to_skip_rest = 1 unless defined $allow_handler_to_skip_rest;
  0         0  
41 0 0       0 my $allow_handler_to_repeat_event = $args{allow_handler_to_repeat_event}; $allow_handler_to_repeat_event = 1 unless defined $allow_handler_to_repeat_event;
  0         0  
42 0 0       0 my $allow_after_handler_to_repeat_event = $args{allow_after_handler_to_repeat_event}; $allow_after_handler_to_repeat_event = 1 unless defined $allow_after_handler_to_repeat_event;
  0         0  
43 0 0       0 my $allow_after_handler_to_skip_rest = $args{allow_after_handler_to_skip_rest}; $allow_after_handler_to_skip_rest = 1 unless defined $allow_after_handler_to_skip_rest;
  0         0  
44 0 0       0 my $stop_after_first_handler_failure = $args{stop_after_first_handler_failure}; $stop_after_first_handler_failure = 1 unless defined $stop_after_first_handler_failure;
  0         0  
45              
46 0         0 my ($res, $is_success);
47              
48             RUN_BEFORE_EVENT_HANDLERS:
49             {
50 0 0       0 last if $name =~ /\A(after|before)_/;
  0         0  
51 0         0 local $Stash->{event} = $before_name;
52 0         0 my $i = 0;
53 0         0 for my $rec (@{ $Handlers{$before_name} }) {
  0         0  
54 0         0 $i++;
55 0         0 my ($label, $prio, $handler) = @$rec;
56             log_trace "[scriptx] [event %s] [%d/%d] -> handler %s ...",
57 0         0 $before_name, $i, scalar(@{ $Handlers{$before_name} }), $label;
  0         0  
58 0         0 $res = $handler->($Stash);
59 0         0 $is_success = $res->[0] =~ /\A[123]/;
60             log_trace "[scriptx] [event %s] [%d/%d] <- handler %s: %s (%s)",
61 0 0       0 $before_name, $i, scalar(@{ $Handlers{$before_name} }), $label,
  0         0  
62             $res, $is_success ? "success" : "fail";
63 0 0       0 if ($res->[0] == 601) {
64 0 0       0 if ($allow_before_handler_to_cancel_event) {
65 0         0 log_trace "[scriptx] Cancelling event $name (status 601)";
66 0         0 goto RETURN;
67             } else {
68 0         0 die "$before_name handler returns 601 when allow_before_handler_to_cancel_event is set to false";
69             }
70             }
71 0 0       0 if ($res->[0] == 201) {
72 0 0       0 if ($allow_before_handler_to_skip_rest) {
73 0         0 log_trace "[scriptx] Skipping the rest of the $before_name handlers (status 201)";
74 0         0 last RUN_BEFORE_EVENT_HANDLERS;
75             } else {
76 0         0 log_trace "[scriptx] $before_name handler returns 201, but we ignore it because allow_before_handler_to_skip_rest is set to false";
77             }
78             }
79             }
80             }
81              
82             RUN_EVENT_HANDLERS:
83             {
84 0         0 local $Stash->{event} = $name;
  0         0  
85 0         0 my $i = 0;
86 0         0 $res = [304, "There is no handler for event $name"];
87 0         0 $is_success = 1;
88 0 0       0 if ($req_handler) {
89             die "There is no handler for event $name"
90 0 0       0 unless @{ $Handlers{$name} };
  0         0  
91             }
92              
93 0         0 for my $rec (@{ $Handlers{$name} }) {
  0         0  
94 0         0 $i++;
95 0         0 my ($label, $prio, $handler) = @$rec;
96             log_trace "[scriptx] [event %s] [%d/%d] -> handler %s ...",
97 0         0 $name, $i, scalar(@{ $Handlers{$name} }), $label;
  0         0  
98 0         0 $res = $handler->($Stash);
99 0         0 $is_success = $res->[0] =~ /\A[123]/;
100             log_trace "[scriptx] [event %s] [%d/%d] <- handler %s: %s (%s)",
101 0 0       0 $name, $i, scalar(@{ $Handlers{$name} }), $label,
  0         0  
102             $res, $is_success ? "success" : "fail";
103 0 0 0     0 last RUN_EVENT_HANDLERS if $is_success && !$run_all_handlers;
104 0 0       0 if ($res->[0] == 601) {
105 0         0 die "$name handler is not allowed to return 601";
106             }
107 0 0       0 if ($res->[0] == 602) {
108 0 0       0 if ($allow_handler_to_repeat_event) {
109 0         0 log_trace "[scriptx] Repeating event $name (handler returns 602)";
110 0         0 goto RUN_EVENT_HANDLERS;
111             } else {
112 0         0 die "$name handler returns 602 when allow_handler_to_repeat_event is set to false";
113             }
114             }
115 0 0       0 if ($res->[0] == 201) {
116 0 0       0 if ($allow_handler_to_skip_rest) {
117 0         0 log_trace "[scriptx] Skipping the rest of the $name handlers (status 201)";
118 0         0 last RUN_EVENT_HANDLERS;
119             } else {
120 0         0 log_trace "[scriptx] $name handler returns 201, but we ignore it because allow_handler_to_skip_rest is set to false";
121             }
122             }
123 0 0 0     0 last RUN_EVENT_HANDLERS if !$is_success && $stop_after_first_handler_failure;
124             }
125             }
126              
127 0 0 0     0 if ($is_success && $args{on_success}) {
    0 0        
128 0         0 log_trace "[scriptx] Running on_success ...";
129 0         0 $args{on_success}->($Stash);
130             } elsif (!$is_success && $args{on_failure}) {
131 0         0 log_trace "[scriptx] Running on_failure ...";
132 0         0 $args{on_failure}->($Stash);
133             }
134              
135             RUN_AFTER_EVENT_HANDLERS:
136             {
137 0 0       0 last if $name =~ /\A(after|before)_/;
  0         0  
138 0         0 local $Stash->{event} = $after_name;
139 0         0 my $i = 0;
140 0         0 for my $rec (@{ $Handlers{$after_name} }) {
  0         0  
141 0         0 $i++;
142 0         0 my ($label, $prio, $handler) = @$rec;
143             log_trace "[scriptx] [event %s] [%d/%d] -> handler %s ...",
144 0         0 $after_name, $i, scalar(@{ $Handlers{$after_name} }), $label;
  0         0  
145 0         0 $res = $handler->($Stash);
146 0         0 $is_success = $res->[0] =~ /\A[123]/;
147             log_trace "[scriptx] [event %s] [%d/%d] <- handler %s: %s (%s)",
148 0 0       0 $after_name, $i, scalar(@{ $Handlers{$after_name} }), $label,
  0         0  
149             $res, $is_success ? "success" : "fail";
150 0 0       0 if ($res->[0] == 602) {
151 0 0       0 if ($allow_after_handler_to_repeat_event) {
152 0         0 log_trace "[scriptx] Repeating event $name (status 602)";
153 0         0 goto RUN_EVENT_HANDLERS;
154             } else {
155 0         0 die "$after_name handler returns 602 when allow_after_handler_to_repeat_event it set to false";
156             }
157             }
158 0 0       0 if ($res->[0] == 201) {
159 0 0       0 if ($allow_after_handler_to_skip_rest) {
160 0         0 log_trace "[scriptx] Skipping the rest of the $after_name handlers (status 201)";
161 0         0 last RUN_AFTER_EVENT_HANDLERS;
162             } else {
163 0         0 log_trace "[scriptx] $after_name handler returns 201, but we ignore it because allow_after_handler_to_skip_rest is set to false";
164             }
165             }
166             }
167             }
168              
169             RETURN:
170 0         0 log_trace "[scriptx] <- run_event(name=%s)", $name;
171 0         0 undef;
172             }
173              
174             sub run {
175 0     0 1 0 run_event(
176             name => 'run',
177             );
178             }
179              
180             my $handler_seq = 0;
181             sub add_handler {
182 0     0 1 0 my ($event, $label, $prio, $handler) = @_;
183              
184             # XXX check for known events?
185 0   0     0 $Handlers{$event} ||= [];
186              
187             # keep sorted
188 0         0 splice @{ $Handlers{$event} }, 0, scalar(@{ $Handlers{$event} }),
  0         0  
189 0 0       0 (sort { $a->[1] <=> $b->[1] || $a->[3] <=> $b->[3] } @{ $Handlers{$event} }, [$label, $prio, $handler, $handler_seq++]);
  0         0  
  0         0  
190             }
191              
192             sub activate_plugin {
193 0     0 1 0 my ($plugin_name0, $args) = @_;
194              
195 0 0       0 my ($plugin_name, $wanted_event, $wanted_prio) =
196             $plugin_name0 =~ /\A(\w+(?:::\w+)*)(?:\@(\w+)(?:\@(\d+))?)?\z/
197             or die "Invalid plugin name syntax, please use Foo::Bar or ".
198             "Foo::Bar\@event or Foo::Bar\@event\@prio\n";
199              
200 0         0 local $Stash->{plugin_name} = $plugin_name;
201 0         0 local $Stash->{plugin_args} = $args;
202              
203             run_event(
204             name => 'activate_plugin',
205             on_success => sub {
206 0     0   0 my $package = "ScriptX::$plugin_name";
207 0         0 (my $package_pm = "$package.pm") =~ s!::!/!g;
208 0         0 log_trace "[scriptx] Loading module $package ...";
209 0         0 require $package_pm;
210 0 0       0 my $obj = $package->new(%{ $args || {} });
  0         0  
211 0         0 $obj->activate($wanted_event, $wanted_prio);
212             },
213             on_failure => sub {
214 0     0   0 die "Cannot activate plugin $plugin_name";
215             },
216 0         0 );
217             }
218              
219             sub _import {
220             #log_trace "_import(%s)", \@_;
221 0     0   0 while (@_) {
222 0         0 my $plugin_name0 = shift;
223 0 0 0     0 my $plugin_args = @_ && ref($_[0]) eq 'HASH' ? shift : {};
224 0         0 activate_plugin($plugin_name0, $plugin_args);
225             }
226             }
227              
228             sub _unflatten_import {
229 6     6   1225 my ($env, $what) = @_;
230              
231 6   50     31 $what ||= "import";
232 6         14 my @imports;
233             my $plugin_name0;
234 6         0 my @plugin_args;
235              
236 6 50       28 my @elems = ref $env eq 'ARRAY' ? @$env : split /,/, $env;
237 6         15 while (@elems) {
238 15         23 my $el = shift @elems;
239             # dash prefix to disambiguate between plugin name and arguments, e.g.
240             # '-PluginName,argname,argval,argname2,argval2,-Plugin2Name,...'
241 15 100       47 if ($el =~ /\A-(\w+(?:::\w+)*(?:\@.+)?)\z/) {
242 6 100       14 if (defined $plugin_name0) {
243 2         4 push @imports, $plugin_name0;
244 2 100       8 push @imports, {@plugin_args} if @plugin_args;
245             }
246 6         15 $plugin_name0 = $1;
247 6         9 @plugin_args = ();
248 6 100       16 if (!@elems) {
249 3         10 push @imports, $1;
250             }
251             } else {
252 9 100       29 die "Invalid syntax in $what, first element needs to be ".
253             "a plugin name (e.g. -Foo), not '$el'"
254             unless defined $plugin_name0;
255 8         11 push @plugin_args, $el;
256 8 100       19 if (!@elems) {
257 1         2 push @imports, $plugin_name0;
258 1 50       6 push @imports, {@plugin_args} if @plugin_args;
259             }
260             }
261             }
262 5         35 @imports;
263             }
264              
265             my $read_env;
266             sub import {
267 0     0     my $class = shift;
268              
269             READ_ENV:
270             {
271 0 0         last if $read_env;
  0            
272             READ_SCRIPTX_IMPORT:
273             {
274 0 0         last unless defined $ENV{SCRIPTX_IMPORT};
  0            
275 0           log_trace "[scriptx] Reading env variable SCRIPTX_IMPORT ...";
276 0           _import(_unflatten_import($ENV{SCRIPTX_IMPORT}, "SCRIPTX_IMPORT"));
277 0           $read_env++;
278 0           last READ_ENV;
279             }
280              
281             READ_SCRIPTX_IMPORT_JSON:
282             {
283 0 0         last unless defined $ENV{SCRIPTX_IMPORT_JSON};
  0            
284 0           require JSON::PP;
285 0           log_trace "[scriptx] Reading env variable SCRIPTX_IMPORT_JSON ...";
286 0           my $imports = JSON::PP::decode_json($ENV{SCRIPTX_IMPORT_JSON});
287 0           _import(@$imports);
288 0           $read_env++;
289 0           last READ_ENV;
290             }
291             }
292              
293 0 0 0       if (@_ && $_[0] =~ /\A-/) {
294             # user that specify imports on command-line, e.g. using -MScriptX=...
295             # can use the ENV syntax so she can specify plugin arguments more
296             # easily: -MScriptX=-Run,command,foobar,-AnotherPlugin,...
297 0           _import(_unflatten_import(\@_, "import arguments"));
298             } else {
299 0           _import(@_);
300             }
301             }
302              
303             1;
304             # ABSTRACT: A plugin-based script framework
305              
306             __END__