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
|
|
|
|
|
|
|
|