File Coverage

blib/lib/App/PerlWatcher/Watcher.pm
Criterion Covered Total %
statement 173 173 100.0
branch 28 30 93.3
condition 13 16 81.2
subroutine 34 34 100.0
pod 5 8 62.5
total 253 261 96.9


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__