File Coverage

blib/lib/Message/Inform.pm
Criterion Covered Total %
statement 159 168 94.6
branch 42 60 70.0
condition 9 21 42.8
subroutine 17 18 94.4
pod 7 7 100.0
total 234 274 85.4


line stmt bran cond sub pod time code
1             package Message::Inform;
2             {
3             $Message::Inform::VERSION = '1.132270';
4             }
5              
6 6     6   265922 use 5.006;
  6         23  
  6         601  
7 6     6   39 use strict;
  6         13  
  6         345  
8 6     6   36 use warnings FATAL => 'all';
  6         21  
  6         298  
9 6     6   33 use Carp;
  6         11  
  6         488  
10 6     6   5701 use Message::Match qw(mmatch);
  6         4702  
  6         440  
11 6     6   5892 use Message::Transform qw(mtransform);
  6         3203  
  6         445  
12 6     6   36712 use Data::Dumper;
  6         18853  
  6         1107  
13              
14             =head1 NAME
15              
16             Message::Inform - Intelligently distribute messages over time
17              
18             =cut
19              
20             our $config = {};
21             our $instances = {};
22             our $tick = 0;
23             #$instances->{$instance} = {
24             # message => $merged_message,
25             # config => $most_recently_merged_config,
26             # initial_ts => $ts_when_this_appeared
27             #};
28              
29              
30             =head1 SYNOPSIS
31              
32             use Message::Inform;
33              
34             sub a1 {
35             my %args = @_;
36             #$args{message}
37             #$args{action}
38             #$args{inform_instance}
39             #$args{inform_instance_name}
40             #$args{interval_time}
41             }
42             my $inform = Message::Inform->new;
43             $inform->config({
44             informs => [
45             { inform_name => 'i1',
46             match => { x => 'y' },
47             close_match => { x => 'y', level => 'OK' },
48             instance => ' specials/"i1:$message->{a}"',
49             intervals => {
50             '0' => [ #right away
51             { action_type => 'open',
52             action_name => 'a1',
53             },{ action_type => 'close',
54             action_name => 'a1',
55             }
56             ],
57             '2' => [ #2 seconds
58             { action_type => 'open',
59             action_name => 'a1',
60             },{ action_type => 'intermediate',
61             action_name => 'a1',
62             }
63             ],
64             }
65             }
66             ],
67             action_map => {
68             a1 => 'main::a1',
69             },
70             });
71              
72             $inform->message({x => 'y', a => 'b'});
73             #main::a1() calls with this message immediately.
74             for (1..4) {
75             $inform->message();
76             sleep 1;
77             }
78             #main::a1() calls with the previous message as an 'open' in 2
79             #seconds
80             $inform->message({x => 'y', a => 'b', something => 'else'});
81             #main::a1() immediately calls as an 'intermediate'
82             $inform->message({x => 'y', a => 'b', level => 'OK'});
83             #main::a1() immediately calls as a 'close'
84              
85             =head1 DESCRIPTION
86              
87             This module obviously has some 'deep' and 'subtle' behaviour; this
88             0.1 release won't describe that, but future releases certainly will.
89              
90             =head1 SUBROUTINES/METHODS
91              
92             =head2 new(state => $previous_state)
93              
94             Typical constructor. Pass in the output from get_state() to resume
95             operations as they were at that time.
96              
97             =cut
98             sub new {
99 5     5 1 80 my $class = shift;
100 5         13 my $self = {};
101              
102 5         15 bless ($self, $class);
103 5         40 return $self;
104             }
105              
106             =head2 config($config)
107              
108             Set initial config or update running config at any time.
109            
110             =cut
111             sub config {
112 5     5 1 13 my $self = shift;
113 5         10 my $new_config = shift;
114 5         14 $config = $new_config;
115 5         39 return $config;
116             }
117              
118             #select the fastest possible way to clone (and be portable too)
119             #For now, Storable is what I know
120             sub _fast_clone {
121 6     6   13757 use Storable;
  6         28120  
  6         13872  
122 60     60   91 my $thing = shift;
123 60         4002 return Storable::dclone $thing;
124             }
125              
126             =head2 get_message_configs($message)
127              
128             Returns all of the merged configs that will apply to the passed in
129             message.
130              
131             =cut
132             sub get_message_configs {
133 18     18 1 2158 my $self = shift;
134 18         33 my $message = shift;
135 18         80 my $my_configs = {
136             match => {},
137             close_match => {},
138             };
139              
140 18         66 my $relevant_informs = $self->get_relevant_informs($message);
141 18         97 foreach my $type ('match','close_match') {
142 36         978 foreach my $inform (@{$relevant_informs->{$type}}) {
  36         118  
143 18         724 mtransform($message, { inform_instance => $inform->{instance}});
144 18         2242 my $instance = $message->{inform_instance};
145 18 100       79 $my_configs->{$type}->{$instance} = _fast_clone($message)
146             unless $my_configs->{$type}->{$instance};
147 18         60 mtransform($my_configs->{$type}->{$instance}, _fast_clone($inform));
148             }
149             }
150 18         546 return $my_configs;
151             }
152              
153             =head2 get_relevant_informs($message)
154              
155             Returns all of the informs that would apply to the passed in message.
156              
157             =cut
158             sub get_relevant_informs {
159 18     18 1 35 my $self = shift;
160 18         31 my $message = shift;
161 18         86 my $informs = {
162             match => [],
163             close_match => [],
164             };
165 18         89 foreach my $inform (@{$config->{informs}}) {
  18         66  
166 26 100 66     286 push @{$informs->{match}}, $inform
  12         425  
167             if $inform->{match} and
168             mmatch $message, $inform->{match};
169 26 100 66     560 push @{$informs->{close_match}}, $inform
  6         236  
170             if $inform->{close_match} and
171             mmatch $message, $inform->{close_match};
172             }
173 18         419 return $informs;
174             }
175              
176             #housekeeping for timing
177             {
178             my $last_tick_ts;
179             sub _handle_tick {
180 14     14   29 my $self = shift;
181 14 100       56 $last_tick_ts = time unless $last_tick_ts;
182 14         33 my $tick_delta = time - $last_tick_ts;
183 14         65 $tick+=$tick_delta;
184             #now we need to handle all of the intervals scheduled from
185             #$tick-$tick_delta until now ($tick)
186              
187             #for now, we do it dumb: full-blown iteration
188 14         17 foreach my $instance_name (keys %{$instances}) {
  14         51  
189 10         25 my $instance = $instances->{$instance_name};
190 10         28 my $previous_instance_tick_offset = $instance->{last_update_tick} - $instance->{initial_tick};
191 10         16 my $new_instance_tick_offset = $previous_instance_tick_offset + $tick_delta;
192             #so we need to fire all of the opens between
193             #$previous_instance_tick_offset and $new_instance_tick_offset
194             #exclusive to inclusive
195             #meaning we do NOT fire anything at $previous_instance_tick_offset
196             #and we DO fire anything at $new_instance_tick_offset
197            
198 10         36 my $local_config = _fast_clone($instance->{config});
199 10         26 foreach my $interval_time (sort {$a <=> $b} keys %{$local_config->{intervals}}) {
  8         47  
  10         70  
200 18 100       106 next if $interval_time <= $previous_instance_tick_offset;
201 4 100       39 next if $interval_time > $new_instance_tick_offset;
202 1         5 my $interval = $local_config->{intervals}->{$interval_time};
203 1         5 $instance->{last_update_tick} = $new_instance_tick_offset;
204 1         2 foreach my $action (@{$interval}) {
  1         3  
205 2 50       8 next unless $action->{action_type};
206 2 100       16 next if $action->{action_type} ne 'open';
207 1         2 eval {
208 1         14 my $ret = $self->fire_action($instance->{message}, $action,
209             inform_instance => $instances->{$instance_name},
210             inform_instance_name => $instance_name,
211             interval_time => $interval_time,
212             );
213             };
214 1 50       5 if($@) {
215 0         0 print "Exception: $@\n";
216             }
217             }
218             }
219             }
220             }
221             }
222              
223             =head2 message($message)
224              
225             Send a message into Inform. This can be called with no arguments
226             to trigger timed Inform fires if there's no other messages to be
227             sent.
228              
229             =cut
230             sub message {
231 14     14 1 35 my $self = shift;
232 14         34 my $message = shift;
233 14 50       65 if(not $message) { #special case; just keep the pump primed
234 0         0 $self->_handle_tick();
235 0         0 return 1;
236             }
237 14         61 my $message_configs = $self->get_message_configs($message);
238              
239 14         27 my $closed_instances = {}; #so we can skip these if we see any opens
240 14         32 foreach my $instance_name (keys %{$message_configs->{close_match}}) {
  14         56  
241 2         6 $closed_instances->{$instance_name} = $message_configs->{close_match}->{$instance_name};
242 2         8 my $local_config = _fast_clone($message_configs->{close_match}->{$instance_name});
243             #now we iterate on the intervals backwards
244             #TODO: start on our current interval
245 2         5 foreach my $interval_time (sort {$a <=> $b} keys %{$local_config->{intervals}}) {
  1         4  
  2         11  
246 3         8 my $interval = $local_config->{intervals}->{$interval_time};
247 3         5 foreach my $action (@{$interval}) {
  3         7  
248 6 50       19 next unless $action->{action_type};
249 6 100       20 next if $action->{action_type} ne 'close';
250 2         5 eval {
251 2         14 my $ret = $self->fire_action($message, $action,
252             inform_instance => $instances->{$instance_name},
253             inform_instance_name => $instance_name,
254             interval_time => $interval_time,
255             );
256             };
257 2 50       10 if($@) {
258 0         0 print "exception: $@";
259             }
260             }
261 3         20 delete $instances->{$instance_name};
262             }
263             }
264              
265 14         32 foreach my $instance_name (keys %{$message_configs->{match}}) {
  14         50  
266 6 100       20 next if $closed_instances->{$instance_name}; #this was closed before; that trumps
267 4         17 my $local_config = _fast_clone($message_configs->{match}->{$instance_name});
268 4 100       18 if(not $instances->{$instance_name}) { #this is an 'open'
269 3         11 $instances->{$instance_name} = {
270             message => _fast_clone($message),
271             config => $local_config,
272             initial_ts => time,
273             initial_tick => $tick,
274             last_message_ts => time,
275             last_message_tick => $tick,
276             last_update_ts => time,
277             last_update_tick => $tick,
278             };
279             #Here we look for any intervals at '0', and fire them
280 3 50       14 if($local_config->{intervals}->{'0'}) {
281 3         6 foreach my $action (@{$local_config->{intervals}->{'0'}}) {
  3         8  
282 6 50       17 next unless $action->{action_type};
283 6 100       25 next if $action->{action_type} ne 'open';
284 3         5 eval {
285 3         14 my $ret = $self->fire_action($message, $action,
286             inform_instance => $instances->{$instance_name},
287             inform_instance_name => $instance_name,
288             interval_time => 0,
289             );
290             };
291 3 50       11 if($@) {
292 0         0 print "exception: $@";
293             }
294             }
295             }
296             } else { #this is an 'intermediate'
297 1         5 my $instance = $instances->{$instance_name};
298 1         5 $instance->{last_message_ts} = time;
299 1         4 $instance->{last_message_tick} = $tick;
300 1         4 $instance->{last_update_ts} = time;
301 1         3 $instance->{last_update_tick} = $tick;
302 1         4 $instance->{config} = $local_config;
303 1         17 mtransform($instance->{message}, $message);
304             #Here we fire any defined 'intermediates' at the current interval
305 1         42 my $instance_tick_offset = $instance->{last_update_tick} - $instance->{initial_tick};
306 1         6 my $local_config = _fast_clone($instance->{config});
307 1         3 my $interval;
308             my $run_interval_time;
309 1         5 foreach my $interval_time (sort {$a <=> $b} keys %{$local_config->{intervals}}) {
  1         8  
  1         10  
310 2 50       12 next if $interval_time > $instance_tick_offset;
311 2         7 $interval = $local_config->{intervals}->{$interval_time};
312 2         8 $run_interval_time = $interval_time;
313             }
314 1         5 $instance->{last_update_tick} = $tick; ##????
315 1         4 foreach my $action (@{$interval}) {
  1         5  
316 2 50       9 next unless $action->{action_type};
317 2 100       12 next if $action->{action_type} ne 'intermediate';
318 1         4 eval {
319 1         9 my $ret = $self->fire_action($instance->{message}, $action,
320             inform_instance => $instances->{$instance_name},
321             inform_instance_name => $instance_name,
322             interval_time => $run_interval_time,
323             );
324             };
325 1 50       17 if($@) {
326 0         0 print "Exception: $@\n";
327             }
328             }
329             }
330             }
331 14         55 $self->_handle_tick();
332 14         152 return $message;
333             }
334              
335             =head2 get_state()
336              
337             Called with no argument, this returns the necessary state to be passed
338             into a future constructor. The module will then continue to function
339             in exactly the same state as it was when get_state() was called.
340             =cut
341             sub get_state {
342             return {
343 0     0 1 0 tick => $tick,
344             config => $config,
345             instances => $instances,
346             };
347             }
348              
349             =head2 fire_action($message, $action)
350              
351             This might not want to be a public method, but it is for now.
352              
353             =cut
354             sub fire_action {
355 8     8 1 36 my ($self, $message, $action, @args) = @_;
356 8 50 33     93 croak 'first argument must be message, a HASH reference'
      33        
357             if not $message or
358             not ref $message or
359             ref $message ne 'HASH';
360 8 50       34 croak 'even number of arguments required'
361             if scalar @args % 2;
362 8         38 my %args = @args;
363 8 50 33     81 croak 'passed action must be a HASH reference'
      33        
364             if not $action or
365             not ref $action or
366             ref $action ne 'HASH';
367 8 50 33     67 croak 'passed action must have "action_name" as a defined scalar'
368             if not $action->{action_name} or
369             ref $action->{action_name};
370 8 50       34 croak "passed action had 'action_name' $action->{action_name} did not have defined action_map"
371             unless $config->{action_map}->{$action->{action_name}};
372 8         19 my $action_message = _fast_clone($message);
373 8 50       50 if($action->{transform}) {
374 0         0 mtransform($action_message, $action->{transform});
375             }
376 8         13 my $ret;
377 8         13 eval {
378 6     6   76 no strict 'refs';
  6         25  
  6         1022  
379 8         23 $ret = &{$config->{action_map}->{$action->{action_name}}}(
  8         61  
380             message => $action_message,
381             action => $action,
382             %args
383             );
384 8 50       130 if($@) {
385 0         0 croak "action '$action->{action_name}' failed: $@";
386             }
387             };
388 8         36 return $ret;
389             }
390              
391             =head1 AUTHOR
392              
393             Dana M. Diederich, C<diederich@gmail.com>
394              
395             =head1 BUGS
396              
397             Please report any bugs or feature requests through L<https://github.com/dana/perl-Message-Inform/issues>. I will be notified, and then you'll
398             automatically be notified of progress on your bug as I make changes.
399              
400             =head1 SUPPORT
401              
402             You can find documentation for this module with the perldoc command.
403              
404             perldoc Message::Inform
405              
406             You can also look for information at:
407              
408             =over 4
409              
410             =item * Report bugs here:
411              
412             L<https://github.com/dana/perl-Message-Inform/issues>
413              
414             =item * AnnoCPAN: Annotated CPAN documentation
415              
416             L<http://annocpan.org/dist/Message-Inform>
417              
418             =item * CPAN Ratings
419              
420             L<http://cpanratings.perl.org/d/Message-Inform>
421              
422             =item * Search CPAN
423              
424             L<https://metacpan.org/module/Message::Inform>
425              
426             =back
427              
428              
429             =head1 LICENSE AND COPYRIGHT
430              
431             Copyright 2013 Dana M. Diederich.
432              
433             This program is free software; you can redistribute it and/or modify it
434             under the terms of the the Artistic License (2.0). You may obtain a
435             copy of the full license at:
436              
437             L<http://www.perlfoundation.org/artistic_license_2_0>
438              
439             Any use, modification, and distribution of the Standard or Modified
440             Versions is governed by this Artistic License. By using, modifying or
441             distributing the Package, you accept this license. Do not use, modify,
442             or distribute the Package, if you do not accept this license.
443              
444             If your Modified Version has been derived from a Modified Version made
445             by someone other than you, you are nevertheless required to ensure that
446             your Modified Version complies with the requirements of this license.
447              
448             This license does not grant you the right to use any trademark, service
449             mark, tradename, or logo of the Copyright Holder.
450              
451             This license includes the non-exclusive, worldwide, free-of-charge
452             patent license to make, have made, use, offer to sell, sell, import and
453             otherwise transfer the Package with respect to any patent claims
454             licensable by the Copyright Holder that are necessarily infringed by the
455             Package. If you institute patent litigation (including a cross-claim or
456             counterclaim) against any party alleging that the Package constitutes
457             direct or contributory patent infringement, then this Artistic License
458             to you shall terminate on the date that such litigation is filed.
459              
460             Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER
461             AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES.
462             THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
463             PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY
464             YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR
465             CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR
466             CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE,
467             EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
468              
469              
470             =cut
471              
472             1; # End of Message::Inform
473              
474