line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package App::PerlWatcher::Watcher; |
2
|
|
|
|
|
|
|
{ |
3
|
|
|
|
|
|
|
$App::PerlWatcher::Watcher::VERSION = '0.20'; |
4
|
|
|
|
|
|
|
} |
5
|
|
|
|
|
|
|
# ABSTRACT: Observes some external source of events and emits the result of polling them |
6
|
|
|
|
|
|
|
|
7
|
11
|
|
|
11
|
|
136680
|
use 5.12.0; |
|
11
|
|
|
|
|
42
|
|
|
11
|
|
|
|
|
534
|
|
8
|
11
|
|
|
11
|
|
89
|
use strict; |
|
11
|
|
|
|
|
21
|
|
|
11
|
|
|
|
|
1036
|
|
9
|
11
|
|
|
11
|
|
67
|
use warnings; |
|
11
|
|
|
|
|
56
|
|
|
11
|
|
|
|
|
388
|
|
10
|
|
|
|
|
|
|
|
11
|
11
|
|
|
11
|
|
3555
|
use App::PerlWatcher::Levels; |
|
11
|
|
|
|
|
30
|
|
|
11
|
|
|
|
|
929
|
|
12
|
11
|
|
|
11
|
|
4943
|
use App::PerlWatcher::Memory qw /memory_patch/; |
|
11
|
|
|
|
|
31
|
|
|
11
|
|
|
|
|
614
|
|
13
|
11
|
|
|
11
|
|
7766
|
use App::PerlWatcher::Status; |
|
11
|
|
|
|
|
58
|
|
|
11
|
|
|
|
|
431
|
|
14
|
|
|
|
|
|
|
|
15
|
11
|
|
|
11
|
|
79
|
use Carp; |
|
11
|
|
|
|
|
26
|
|
|
11
|
|
|
|
|
686
|
|
16
|
11
|
|
|
11
|
|
16466
|
use Data::Dump::Filtered qw/dump_filtered/; |
|
11
|
|
|
|
|
100580
|
|
|
11
|
|
|
|
|
887
|
|
17
|
11
|
|
|
11
|
|
120
|
use Smart::Comments -ENV; |
|
11
|
|
|
|
|
25
|
|
|
11
|
|
|
|
|
138
|
|
18
|
11
|
|
|
11
|
|
31129
|
use Digest::MD5 qw(md5_base64); |
|
11
|
|
|
|
|
29
|
|
|
11
|
|
|
|
|
690
|
|
19
|
11
|
|
|
11
|
|
67
|
use List::Util qw( max ); |
|
11
|
|
|
|
|
24
|
|
|
11
|
|
|
|
|
686
|
|
20
|
11
|
|
|
11
|
|
8413
|
use Storable qw/freeze/; |
|
11
|
|
|
|
|
21396
|
|
|
11
|
|
|
|
|
759
|
|
21
|
|
|
|
|
|
|
|
22
|
11
|
|
|
11
|
|
5923
|
use Moo::Role; |
|
11
|
|
|
|
|
2281226
|
|
|
11
|
|
|
|
|
96
|
|
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
with qw/App::PerlWatcher::Describable/; |
25
|
|
|
|
|
|
|
with qw/App::PerlWatcher::Memorizable/; |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
has 'engine_config' => ( is => 'ro', required => 1); |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
has 'init_args' => ( is => 'rw'); |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
has 'config' => ( is => 'lazy'); |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
has 'unique_id' => ( is => 'lazy'); |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
memory_patch(__PACKAGE__, 'active'); |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
memory_patch(__PACKAGE__, 'thresholds_map'); |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
memory_patch(__PACKAGE__, 'last_status'); |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
has 'poll_callback' => (is => 'rw', default => sub { sub{}; } ); |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
has 'callback' => ( is => 'rw', required => 1); |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
has 'watcher_guard' => ( is => 'rw'); |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
requires 'build_watcher_guard'; |
59
|
|
|
|
|
|
|
|
60
|
11
|
|
|
11
|
|
6877
|
use overload fallback => 1, q/""/ => sub { $_[0]->unique_id; }; |
|
11
|
|
|
134
|
|
23
|
|
|
11
|
|
|
|
|
167
|
|
|
134
|
|
|
|
|
7900
|
|
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
sub BUILD { |
63
|
34
|
|
|
34
|
0
|
1470
|
my ($self, $init_args) = @_; |
64
|
34
|
|
|
|
|
521
|
$self->init_args($init_args); |
65
|
34
|
|
|
|
|
352
|
$self->_init_thresholds_map; |
66
|
34
|
|
|
|
|
142
|
$self->active(1); |
67
|
|
|
|
|
|
|
} |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
sub _build_config { |
70
|
34
|
|
|
34
|
|
5381
|
my $self = shift; |
71
|
202
|
|
|
|
|
423
|
my @clean_init_keys = |
72
|
34
|
|
|
|
|
177
|
grep {$_ ne 'engine_config'} |
73
|
34
|
|
|
|
|
66
|
keys %{ $self->init_args }; |
74
|
34
|
|
|
|
|
8672
|
my %config; |
75
|
34
|
|
|
|
|
71
|
@config{ @clean_init_keys} = @{ $self->init_args }{ @clean_init_keys }; |
|
34
|
|
|
|
|
226
|
|
76
|
34
|
|
|
|
|
494
|
return \%config; |
77
|
|
|
|
|
|
|
} |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
sub _init_thresholds_map { |
80
|
34
|
|
|
34
|
|
165
|
my $self = shift; |
81
|
34
|
|
100
|
|
|
200
|
my ( $l, $r ) = ( |
82
|
|
|
|
|
|
|
$self->config -> {on} // {}, |
83
|
|
|
|
|
|
|
$self->engine_config -> {defaults}->{behaviour}, |
84
|
|
|
|
|
|
|
); |
85
|
34
|
|
|
|
|
141
|
my $map = calculate_threshods($l, $r); |
86
|
34
|
|
|
|
|
172
|
$self->thresholds_map($map); |
87
|
|
|
|
|
|
|
} |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
sub _build_unique_id { |
90
|
28
|
|
|
28
|
|
5517
|
my $self = shift; |
91
|
28
|
|
|
|
|
67
|
my $class = ref($self); |
92
|
|
|
|
|
|
|
# Filter strips down the subroutine references |
93
|
|
|
|
|
|
|
# and transforms hashes to arrays sorted by keys. |
94
|
|
|
|
|
|
|
# this is needed to always have the same string |
95
|
|
|
|
|
|
|
# for the same config, any change will lead |
96
|
|
|
|
|
|
|
# to change of md5, and the id will be different. |
97
|
28
|
|
|
|
|
45
|
my $filter; $filter = sub { |
98
|
775
|
|
|
775
|
|
74753
|
my($ctx, $object_ref) = @_; |
99
|
775
|
|
|
|
|
1430
|
my $ref_type = ref($object_ref); |
100
|
775
|
100
|
|
|
|
1829
|
return { object => 'FILTERED' } if ($ref_type eq 'CODE'); |
101
|
710
|
100
|
|
|
|
2484
|
return undef if ($ref_type ne 'HASH'); |
102
|
184
|
|
|
|
|
595
|
my @determined_array = |
103
|
|
|
|
|
|
|
map { |
104
|
57
|
|
|
|
|
296
|
my $stringized_value = dump_filtered($object_ref->{$_}, $filter); |
105
|
184
|
|
|
|
|
31409
|
my $value = eval $stringized_value; |
106
|
184
|
|
|
|
|
757
|
($_ => $value); |
107
|
|
|
|
|
|
|
} sort keys %$object_ref; |
108
|
57
|
|
|
|
|
228
|
return { dump => dump_filtered(\@determined_array, $filter) }; |
109
|
28
|
|
|
|
|
198
|
}; |
110
|
28
|
|
|
|
|
120
|
my $dumped_config = dump_filtered($self->config, $filter); |
111
|
28
|
|
|
|
|
8593
|
my $hash = md5_base64($dumped_config); |
112
|
28
|
|
|
|
|
406
|
my $id = "$class/$hash"; |
113
|
|
|
|
|
|
|
} |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
sub force_poll { |
117
|
6
|
|
|
6
|
1
|
8818
|
my $self = shift; |
118
|
6
|
|
|
|
|
34
|
$self->activate(0); |
119
|
6
|
|
|
|
|
17
|
$self->activate(1); |
120
|
|
|
|
|
|
|
} |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
sub activate { |
124
|
13
|
|
|
13
|
1
|
758
|
my ( $self, $value ) = @_; |
125
|
13
|
50
|
|
|
|
46
|
if ( defined($value) ) { |
126
|
13
|
|
|
|
|
69
|
$self->active($value); |
127
|
13
|
100
|
|
|
|
167
|
$self->watcher_guard(undef) |
128
|
|
|
|
|
|
|
unless $value; |
129
|
13
|
100
|
|
|
|
72
|
$self->start if $value; |
130
|
|
|
|
|
|
|
} |
131
|
13
|
|
|
|
|
99
|
return $self->active; |
132
|
|
|
|
|
|
|
} |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
sub start { |
136
|
13
|
|
|
13
|
1
|
3796
|
my $self = shift; |
137
|
13
|
50
|
|
|
|
62
|
$self->watcher_guard( $self->build_watcher_guard ) |
138
|
|
|
|
|
|
|
if $self->active; |
139
|
|
|
|
|
|
|
} |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
sub calculate_threshods { |
144
|
34
|
|
|
34
|
1
|
62
|
my ($l, $r) = @_; |
145
|
34
|
|
|
|
|
53
|
my $thresholds_map; |
146
|
34
|
|
|
|
|
110
|
for my $k ('ok', 'fail') { |
147
|
68
|
|
|
|
|
328
|
my $merged = _merge($l->{$k}, $r->{$k}); |
148
|
|
|
|
|
|
|
# from human strings to numbers |
149
|
68
|
|
|
|
|
380
|
while (my ($key, $value) = each %$merged ){ |
150
|
82
|
|
|
|
|
218
|
$merged->{$key} = get_by_description($value); |
151
|
|
|
|
|
|
|
} |
152
|
68
|
|
|
|
|
223
|
$thresholds_map->{$k} = $merged; |
153
|
|
|
|
|
|
|
} |
154
|
34
|
|
|
|
|
88
|
return $thresholds_map; |
155
|
|
|
|
|
|
|
} |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
# |
158
|
|
|
|
|
|
|
# protected methods |
159
|
|
|
|
|
|
|
# |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
sub _merge { |
162
|
72
|
|
|
72
|
|
3884
|
my ($l, $r) = @_; |
163
|
|
|
|
|
|
|
|
164
|
72
|
|
|
|
|
409
|
my $max_re = qr/(.*)\/max/; |
165
|
|
|
|
|
|
|
my $level = sub { |
166
|
116
|
|
|
116
|
|
168
|
my $a = shift; |
167
|
116
|
100
|
|
|
|
745
|
return ($a =~ /$max_re/) ? $1 : $a; |
168
|
72
|
|
|
|
|
308
|
}; |
169
|
|
|
|
|
|
|
my $wrap = sub { |
170
|
144
|
|
|
144
|
|
184
|
my $hash_ref = shift; |
171
|
144
|
|
|
|
|
357
|
my %cleaned = map { $_ => ( $level->($hash_ref->{$_}) ) } |
|
116
|
|
|
|
|
314
|
|
172
|
|
|
|
|
|
|
keys %$hash_ref; |
173
|
|
|
|
|
|
|
## %cleaned |
174
|
144
|
|
|
|
|
623
|
my %level_for = reverse %cleaned; |
175
|
144
|
|
|
|
|
288
|
my @levels = keys %level_for; |
176
|
|
|
|
|
|
|
## @levels; |
177
|
46
|
|
|
|
|
145
|
my @prepared_result = |
178
|
116
|
|
|
|
|
1758
|
sort { $a->{weight} <=> $b->{weight} } |
179
|
|
|
|
|
|
|
map { |
180
|
144
|
|
|
|
|
257
|
my $value = $level_for{$_}; |
181
|
116
|
|
|
|
|
466
|
my $max = $hash_ref->{ $value } =~ /$max_re/; |
182
|
|
|
|
|
|
|
{ |
183
|
116
|
|
|
|
|
415
|
level => $_, |
184
|
|
|
|
|
|
|
value => $value, |
185
|
|
|
|
|
|
|
weight => get_by_description($_)->value, |
186
|
|
|
|
|
|
|
max => $max, |
187
|
|
|
|
|
|
|
}; |
188
|
|
|
|
|
|
|
} @levels; |
189
|
144
|
|
|
|
|
569
|
return @prepared_result; |
190
|
72
|
|
|
|
|
515
|
}; |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
# prepare/wrap left part |
193
|
72
|
|
|
|
|
185
|
my @l_result = $wrap->($l); |
194
|
|
|
|
|
|
|
## @l_result |
195
|
4
|
|
|
|
|
15
|
my $max_weight = max |
196
|
18
|
|
|
|
|
94
|
map { $_->{weight} } |
197
|
72
|
|
|
|
|
268
|
grep { $_->{max} } @l_result; |
198
|
72
|
|
|
|
|
128
|
my %l_value_of = map { $_->{level} => $_ } @l_result; |
|
18
|
|
|
|
|
61
|
|
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
# join with right part (if there was no key in left) |
201
|
81
|
100
|
|
|
|
222
|
my @r_result = |
202
|
98
|
|
|
|
|
319
|
grep { $max_weight ? ($_->{weight} <= $max_weight) : 1 } |
203
|
72
|
|
|
|
|
159
|
grep { !exists $l_value_of{ $_->{level} } } |
204
|
|
|
|
|
|
|
$wrap->($r); |
205
|
72
|
|
|
|
|
246
|
push @l_result, $_ for ( @r_result ); |
206
|
|
|
|
|
|
|
## @l_result |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
# unwrap |
209
|
72
|
|
|
|
|
240
|
return { map { $_->{value} => $_->{level} } @l_result }; |
|
93
|
|
|
|
|
1087
|
|
210
|
|
|
|
|
|
|
} |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
sub interpret_result { |
214
|
15
|
|
|
15
|
1
|
150
|
my ($self, $result, $callback, $items) = @_; |
215
|
|
|
|
|
|
|
|
216
|
15
|
|
|
|
|
205
|
my $prev_status = $self->last_status; |
217
|
15
|
|
66
|
|
|
139
|
my $prev_level = $prev_status && $prev_status->level; |
218
|
15
|
|
|
|
|
85
|
my $level = $self->_interpret_result_as_level($result, $prev_level); |
219
|
15
|
|
|
|
|
63
|
$self->_emit_event($level, $callback, $items); |
220
|
|
|
|
|
|
|
} |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
sub _interpret_result_as_level { |
223
|
41
|
|
|
41
|
|
12583
|
my ($self, $result, $last_level) = @_; |
224
|
41
|
|
100
|
|
|
253
|
$last_level //= LEVEL_NOTICE; |
225
|
41
|
|
|
|
|
178
|
my $threshold_map = $self->thresholds_map; |
226
|
|
|
|
|
|
|
|
227
|
41
|
|
100
|
|
|
241
|
$self->memory->data->{_last_result} //= $result; |
228
|
41
|
100
|
|
|
|
144
|
my ($meta_key, $opposite_key) |
229
|
|
|
|
|
|
|
= $result ? ('ok', 'fail') |
230
|
|
|
|
|
|
|
: ('fail', 'ok' ); |
231
|
|
|
|
|
|
|
|
232
|
41
|
|
|
|
|
109
|
my $counter_key = "_$meta_key" . "_counter"; |
233
|
41
|
|
|
|
|
84
|
my $opposite_counter_key = "_$opposite_key" . "_counter"; |
234
|
|
|
|
|
|
|
|
235
|
41
|
|
|
|
|
142
|
my $result_changed = $self->memory->data->{_last_result} ne $result; |
236
|
|
|
|
|
|
|
# reset values |
237
|
41
|
100
|
|
|
|
104
|
if ($result_changed) { |
238
|
5
|
|
|
|
|
34
|
$self->memory->data->{$counter_key} |
239
|
|
|
|
|
|
|
= $self->memory->data->{$opposite_counter_key} |
240
|
|
|
|
|
|
|
= 0; |
241
|
|
|
|
|
|
|
} |
242
|
41
|
|
|
|
|
171
|
my $counter = ++$self->memory->data->{$counter_key}; |
243
|
|
|
|
|
|
|
|
244
|
41
|
|
|
|
|
59
|
my @levels = sort keys (%{ $threshold_map -> {$meta_key} }); |
|
41
|
|
|
|
|
237
|
|
245
|
|
|
|
|
|
|
# @levels |
246
|
|
|
|
|
|
|
# $counter |
247
|
41
|
|
|
|
|
102
|
my $level_key = max grep { $_ <= $counter } @levels; |
|
57
|
|
|
|
|
263
|
|
248
|
|
|
|
|
|
|
# $level_key |
249
|
|
|
|
|
|
|
|
250
|
41
|
100
|
|
|
|
157
|
my $result_level = ( defined $level_key ) |
251
|
|
|
|
|
|
|
? $threshold_map->{$meta_key}->{$level_key} |
252
|
|
|
|
|
|
|
: $last_level; |
253
|
41
|
|
|
|
|
140
|
$self->memory->data->{_last_result} = $result; |
254
|
|
|
|
|
|
|
|
255
|
41
|
|
|
|
|
160
|
return $result_level; |
256
|
|
|
|
|
|
|
} |
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
sub _emit_event { |
259
|
17
|
|
|
17
|
|
40
|
my ($self, $level, $callback, $items) = @_; |
260
|
17
|
|
|
|
|
61
|
my $prev_status = $self->last_status; |
261
|
17
|
100
|
|
|
|
85
|
my $prev_items = $prev_status ? $prev_status->items : undef; |
262
|
17
|
|
|
|
|
68
|
_merge_items($prev_items, $items); |
263
|
|
|
|
|
|
|
my $status = App::PerlWatcher::Status->new( |
264
|
|
|
|
|
|
|
watcher => $self, |
265
|
|
|
|
|
|
|
level => $level, |
266
|
7
|
|
|
7
|
|
558
|
description => sub { $self->describe }, |
267
|
17
|
|
|
|
|
725
|
items => $items, |
268
|
|
|
|
|
|
|
); |
269
|
|
|
|
|
|
|
# remember it |
270
|
17
|
|
|
|
|
196
|
$self->last_status($status); |
271
|
17
|
|
|
|
|
70
|
$callback->($status); |
272
|
|
|
|
|
|
|
} |
273
|
|
|
|
|
|
|
|
274
|
|
|
|
|
|
|
# move the matching by content EventItems from old to new |
275
|
|
|
|
|
|
|
sub _merge_items { |
276
|
17
|
|
|
17
|
|
31
|
my ($old_items_fun, $new_items_fun) = @_; |
277
|
17
|
100
|
66
|
|
|
83
|
return if(!$old_items_fun || !$new_items_fun); |
278
|
|
|
|
|
|
|
|
279
|
2
|
|
|
|
|
4
|
my ($old_items, $new_items) = map { $_->() } @_; |
|
4
|
|
|
|
|
13
|
|
280
|
|
|
|
|
|
|
|
281
|
2
|
|
|
|
|
7
|
my %copied; |
282
|
2
|
|
|
|
|
9
|
for my $i (0 .. @$new_items-1) { |
283
|
5
|
|
|
|
|
8
|
for my $j (0 .. @$old_items-1) { |
284
|
12
|
100
|
66
|
|
|
31
|
if ($new_items->[$i]->content eq $old_items->[$j]->content |
285
|
|
|
|
|
|
|
&& !$copied{$j}) { |
286
|
3
|
|
|
|
|
5
|
$new_items->[$i] = $old_items->[$j]; |
287
|
3
|
|
|
|
|
20
|
$copied{$j} = 1; |
288
|
3
|
|
|
|
|
9
|
last; |
289
|
|
|
|
|
|
|
} |
290
|
|
|
|
|
|
|
} |
291
|
|
|
|
|
|
|
} |
292
|
|
|
|
|
|
|
} |
293
|
|
|
|
|
|
|
|
294
|
|
|
|
|
|
|
# storable-methods |
295
|
|
|
|
|
|
|
sub STORABLE_freeze { |
296
|
8
|
|
|
8
|
0
|
29
|
"$_[0]"; |
297
|
|
|
|
|
|
|
}; |
298
|
|
|
|
|
|
|
|
299
|
|
|
|
|
|
|
sub STORABLE_attach { |
300
|
8
|
|
|
8
|
0
|
213
|
my ($class, $cloning, $serialized) = @_; |
301
|
8
|
|
|
|
|
13
|
my $id = $serialized; |
302
|
8
|
|
|
|
|
18
|
my $w = $App::PerlWatcher::Util::Storable::Watchers_Pool{$id}; |
303
|
|
|
|
|
|
|
|
304
|
|
|
|
|
|
|
# we are forced to return dummy App::PerlWatcher::Watcher |
305
|
|
|
|
|
|
|
# it will be filtered later |
306
|
8
|
100
|
|
|
|
22
|
unless($w){ |
307
|
1
|
|
|
|
|
3
|
$w = { _unique_id => 'dummy-id'}; |
308
|
1
|
|
|
|
|
3
|
bless $w => $class; |
309
|
|
|
|
|
|
|
} |
310
|
8
|
|
|
|
|
300
|
return $w; |
311
|
|
|
|
|
|
|
} |
312
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
1; |
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
__END__ |