File Coverage

blib/lib/MarpaX/Languages/C/AST/Callback.pm
Criterion Covered Total %
statement 335 410 81.7
branch 108 210 51.4
condition 30 86 34.8
subroutine 22 26 84.6
pod 0 9 0.0
total 495 741 66.8


line stmt bran cond sub pod time code
1 2     2   916 use strict;
  2         3  
  2         68  
2 2     2   8 use warnings FATAL => 'all';
  2         3  
  2         69  
3              
4             package MarpaX::Languages::C::AST::Callback;
5 2     2   9 use MarpaX::Languages::C::AST::Util qw/whoami/;
  2         4  
  2         70  
6 2     2   705 use MarpaX::Languages::C::AST::Callback::Method;
  2         4  
  2         100  
7              
8             use Class::Struct
9             #
10             # External attributes
11             #
12 2         8 log_prefix => '$', # Prepended to every log
13             hscratchpad => '%', # User working area
14             ascratchpad => '@', # User working area
15             sscratchpad => '$', # User working area
16             #
17             # Internal attributes
18             #
19             cb => '@', # List of methods.
20             cb_unregistered => '@', # List of unregistered methods, post-processed if done during fire()
21             topic_fired => '%', # Remember what are the eligible cb's topics.
22             topic_fired_data => '%', # Remember what are the eligible cb's topics data.
23             topic_fired_persistence => '%', # Remember what are the eligible cb's topics persistence.
24             topic_level => '@', # Topic levels
25             ncb => '$', # Number of methods.
26             prioritized_cb => '@', # Prioritized list of methods, for efficiency.
27             prioritized_cb_tofire => '@', # Remember what cb are eligible.
28             prioritized_cb_fired => '@', # Remember what cb were fired
29             arguments => '@', # List of arguments to the exec method.
30             firing => '$'
31 2     2   8 ;
  2         3  
32              
33             # ABSTRACT: Simple but powerful callback generic framework that depend on nothing else but core modules.
34              
35 2     2   4164 use Carp qw/croak/;
  2         3  
  2         6265  
36              
37             our $VERSION = '0.45'; # VERSION
38              
39              
40             sub _sort_by_option_priority_desc {
41 281     281   15610 return $b->option->priority <=> $a->option->priority;
42             }
43              
44             sub _sort_by_numeric_desc {
45 0     0   0 return $b <=> $a;
46             }
47              
48             sub register {
49 37     37 0 3937 my ($self, $cb) = @_;
50              
51 37 50       90 if (ref($cb) ne 'MarpaX::Languages::C::AST::Callback::Method') {
52 0         0 croak 'argument bust be a reference to a MarpaX::Languages::C::AST::Callback::Method object';
53             }
54             #
55             # Sanitize self
56             #
57 37 100       636 if (! defined($self->log_prefix)) {
58 1         20 $self->log_prefix('');
59             }
60              
61             #
62             # Sanitize cb
63             #
64 37 50 33     708 if (defined($cb->method) && ref($cb->method) ne 'ARRAY') {
65 0         0 croak 'method must be an ARRAY ref';
66             }
67 37 50       1418 if (defined($cb->method)) {
68 37 50       168 if (! @{$cb->method}) {
  37         520  
69 0         0 croak 'method is a reference to an empty array';
70             }
71 37 0 0     639 if (ref(($cb->method)->[0]) ne 'CODE' && (! ref($cb->method) && $cb->method eq 'auto')) {
      33        
72 0         0 croak 'method must be an ARRAY ref starting with a CODE reference, or the string \'auto\'';
73             }
74             }
75 37 100       656 if (! defined($cb->method_mode)) {
76 22         398 $cb->method_mode('push');
77             }
78 37 50 66     809 if ($cb->method_mode ne 'push' && $cb->method_mode ne 'replace') {
79 0         0 croak 'method_mode must be \'push\' or \'replace\'';
80             }
81             #
82             # Sanitize $cb->option
83             #
84 37 50       828 if (! defined($cb->option)) {
85 0         0 $cb->option(MarpaX::Languages::C::AST::Callback::Option->new());
86             }
87 37         719 my $option = $cb->option;
88 37         176 foreach (@{$option->condition}) {
  37         503  
89 38 50 33     446 if (! defined($_) || (! (ref($_) eq 'ARRAY')) || (! (ref($_->[0]) eq 'CODE' || (! ref($_->[0]) && $_->[0] eq 'auto')))) {
      66        
      33        
90 0         0 croak 'A condition is not an ARRAY reference, that must start with a CODE reference or the "auto" keyword"';
91             }
92             }
93              
94 37 50       527 if (! defined($option->conditionMode)) {
95 37         658 $option->conditionMode('and');
96             }
97 37 50       173 if (! grep {$option->conditionMode eq $_} qw/and or/) {
  74         1124  
98 0         0 croak 'condition mode must be "and" or "or"';
99             }
100              
101 37 50       690 if (! defined($option->subscriptionMode)) {
102 37         659 $option->subscriptionMode('required');
103             }
104 37 50       172 if (! grep {$option->subscriptionMode eq $_} qw/required optional/) {
  74         1128  
105 0         0 croak 'condition mode must be "and" or "or"';
106             }
107              
108 37 100       735 if (! defined($option->topic_persistence)) {
109 11         202 $option->topic_persistence('none');
110             }
111 37 50       201 if (! grep {$option->topic_persistence eq $_} qw/none any level/) {
  111         1761  
112 0         0 croak 'topic persistence mode must be "none", "any" or "level"';
113             }
114              
115 37 100       695 if (! defined($option->priority)) {
116 6         110 $option->priority(0);
117             }
118 37         642 my $priority = $option->priority;
119 37 50       267 if (! ("$priority" =~ /^[+-]?\d+$/)) {
120 0         0 croak 'priority must be a number';
121             }
122              
123 37 100       559 $self->ncb(0) if (! defined($self->ncb));
124 37         738 $self->cb($self->ncb, $cb);
125 37         820 $self->ncb($self->ncb + 1);
126 37         252 $self->prioritized_cb([sort _sort_by_option_priority_desc @{$self->cb}]);
  37         483  
127              
128             #
129             # Invalid cache if any
130             #
131 37         2792 $self->hscratchpad('_cache', 0);
132              
133             #
134             # We return the indice within Callback
135             #
136 37         723 return $self->ncb - 1;
137             }
138              
139             sub _unregister {
140 20     20   96 my $self = shift;
141              
142 20         67 foreach (sort _sort_by_numeric_desc @_) {
143              
144 0         0 my $cb = $self->cb($_);
145 0 0       0 croak "Unknown callback indice $_" if (! defined($cb));
146              
147 0         0 splice(@{$self->cb}, $_, 1);
  0         0  
148 0         0 $self->ncb($self->ncb - 1);
149 0         0 $self->prioritized_cb([sort _sort_by_option_priority_desc @{$self->cb}]);
  0         0  
150              
151             }
152              
153 20         23 return;
154              
155             }
156              
157             sub unregister {
158 0     0 0 0 my $self = shift;
159              
160 0   0     0 my $firing = $self->firing() || 0;
161 0 0       0 if (! $firing) {
162 0         0 $self->_unregister(@_);
163             } else {
164 0         0 push(@{$self->cb_unregistered}, @_);
  0         0  
165             }
166              
167 0         0 return;
168             }
169              
170             sub exec {
171 20     20 0 26 my $self = shift;
172             #
173             # Remember our arguments, if the callback need it
174             #
175 20         29 my $argumentsp = \@_;
176 20         355 $self->arguments($argumentsp);
177             #
178             # Localize cache mode for faster lookup
179             #
180 20   50     413 my $cache = $self->hscratchpad('_cache') || 0;
181 20 50       460 local $__PACKAGE__::_cacheNcb = $cache ? $self->hscratchpad('_cacheNcb') : undef;
182 20 50       146 local $__PACKAGE__::_cacheArgumentsp = $cache ? $argumentsp : undef;
183 20 50       284 local $__PACKAGE__::_cachePrioritized_cbp = $cache ? $self->hscratchpad('_cachePrioritized_cb') : undef;
184 20 50       401 local $__PACKAGE__::_cachePrioritized_cb_tofirep = $cache ? $self->hscratchpad('_cachePrioritized_cb_tofire') : undef;
185 20 50       403 local $__PACKAGE__::_cachePrioritized_cb_firedp = $cache ? $self->hscratchpad('_cachePrioritized_cb_fired') : undef;
186 20 50       430 local $__PACKAGE__::_cacheOptionp = $cache ? $self->hscratchpad('_cacheOption') : undef;
187 20 50       406 local $__PACKAGE__::_cacheOptionConditionModep = $cache ? $self->hscratchpad('_cacheOptionConditionMode') : undef;
188 20 50       389 local $__PACKAGE__::_cacheOptionConditionp = $cache ? $self->hscratchpad('_cacheOptionCondition') : undef;
189 20 50       397 local $__PACKAGE__::_cacheOptionSubscriptionp = $cache ? $self->hscratchpad('_cacheOptionSubscription') : undef;
190 20 50       398 local $__PACKAGE__::_cacheOptionSubscriptionModep = $cache ? $self->hscratchpad('_cacheOptionSubscriptionMode') : undef;
191 20 50       411 local $__PACKAGE__::_cacheOptionTopicp = $cache ? $self->hscratchpad('_cacheOptionTopic') : undef;
192 20 50       396 local $__PACKAGE__::_cacheOptionTopic_persistencep = $cache ? $self->hscratchpad('_cacheOptionTopic_persistence') : undef;
193 20 50       409 local $__PACKAGE__::_cacheCbDescriptionp = $cache ? $self->hscratchpad('_cacheCbDescription') : undef;
194 20 50       396 local $__PACKAGE__::_cacheCbMethodp = $cache ? $self->hscratchpad('_cacheCbMethod') : undef;
195 20 50       386 local $__PACKAGE__::_cacheCbMethod_voidp = $cache ? $self->hscratchpad('_cacheCbMethod_void') : undef;
196              
197             #
198             # Do an inventory of eligible callbacks and topics
199             #
200 20         152 $self->_inventory_fire();
201             #
202             # Fire everything that is eligible
203             #
204 20         45 $self->_fire();
205             #
206             # And post-process eventual unregistrations
207             #
208 20         21 $self->_unregister(@{$self->cb_unregistered});
  20         277  
209 20         314 $self->cb_unregistered([]);
210              
211 20         223 return;
212             }
213              
214             sub _inventory_condition_tofire {
215 20     20   24 my $self = shift;
216 20         16 my $nbNewTopics = 0;
217 20   33     33 my $ncb = $__PACKAGE__::_cacheNcb // $self->ncb;
218 20   33     40 my $prioritized_cbp = $__PACKAGE__::_cachePrioritized_cbp // $self->prioritized_cb;
219 20   33     32 my $prioritized_cb_tofirep = $__PACKAGE__::_cachePrioritized_cb_tofirep // $self->prioritized_cb_tofire;
220 20   33     35 my $argumentsp = $__PACKAGE__::_cacheArgumentsp // $self->arguments;
221 20         287 my $topic_firedp = $self->topic_fired;
222 20         355 my $topic_fired_datap = $self->topic_fired_data;
223 20         319 my $topic_fired_persistencep = $self->topic_fired_persistence;
224              
225 20         109 foreach (my $i = 0; $i < $ncb; $i++) {
226 155         152 my $cb = $prioritized_cbp->[$i];
227 155 50       205 my $option = defined($__PACKAGE__::_cacheOptionp) ? $__PACKAGE__::_cacheOptionp->[$i] : $cb->option;
228 155 50       298 my $conditionMode = ((defined($__PACKAGE__::_cacheOptionConditionModep) ? $__PACKAGE__::_cacheOptionConditionModep->[$i] : $option->conditionMode) eq 'and') ? 1 : 0;
    50          
229              
230 155         132 my @condition = ();
231 155 50       213 my $description = defined($__PACKAGE__::_cacheCbDescriptionp) ? $__PACKAGE__::_cacheCbDescriptionp->[$i] : $cb->description;
232 155 50       185 foreach my $condition (defined($__PACKAGE__::_cacheOptionConditionp) ? @{$__PACKAGE__::_cacheOptionConditionp->[$i]} : @{$option->condition}) {
  155         251  
  0         0  
233 160         101 my ($coderef, @arguments) = @{$condition};
  160         229  
234 160 100       289 if (ref($coderef) eq 'CODE') {
    50          
235 45 100       134 push(@condition, &$coderef($cb, $self, $argumentsp, @arguments) ? 1 :0);
236             } elsif (defined($description)) {
237             #
238             # Per def condition is the string 'auto'
239             #
240 115 100       83 push(@condition, (grep {$_ eq $description} @{$argumentsp}) ? 1 :0);
  151         350  
  115         121  
241             }
242             }
243             #
244             ## Apply conditionMethod. If none, then the callback will never be
245             ## executed. Only the subscription methods can make it eligible.
246             #
247 155         150 my $condition = 0;
248 155 50       210 if (@condition) {
249 155         124 $condition = shift(@condition);
250 155 50       173 if ($conditionMode) {
251             #
252             # Per def, this is 'and'
253             #
254 155         182 foreach (@condition) {
255 5   100     31 $condition &&= $_;
256             }
257             } else {
258             #
259             # Per def, this is 'or'
260             #
261 0         0 foreach (@condition) {
262 0   0     0 $condition ||= $_;
263             }
264             }
265             }
266 155 100       200 if ($condition) {
267 28         26 $prioritized_cb_tofirep->[$i] = 1;
268             #
269             # Initialize the associated topics if needed
270             #
271 28 50       28 foreach my $topic (keys %{defined($__PACKAGE__::_cacheOptionTopicp) ? $__PACKAGE__::_cacheOptionTopicp->[$i] : $option->topic}) {
  28         102  
272 29 50       73 next if (! defined(defined($__PACKAGE__::_cacheOptionTopicp) ? $__PACKAGE__::_cacheOptionTopicp->[$i]->{$topic} : $option->topic($topic)));
    50          
273 29 50       75 next if (! (defined($__PACKAGE__::_cacheOptionTopicp) ? $__PACKAGE__::_cacheOptionTopicp->[$i]->{$topic} : $option->topic($topic)));
    50          
274 29 100       62 if (! defined($topic_firedp->{$topic})) {
275 17         24 $topic_firedp->{$topic} = 1;
276 17 50       37 $topic_fired_persistencep->{$topic} = defined($__PACKAGE__::_cacheOptionTopic_persistencep) ? $__PACKAGE__::_cacheOptionTopic_persistencep->[$i] : $option->topic_persistence;
277 17 50       30 if (! defined($topic_fired_datap->{$topic})) {
278 17         22 $topic_fired_datap->{$topic} = [];
279 17         48 ++$nbNewTopics;
280             }
281             }
282             }
283             } else {
284 127 100       356 if (@condition) {
285 4         13 $prioritized_cb_tofirep->[$i] = -1;
286             }
287             }
288             }
289              
290 20         43 return $nbNewTopics;
291             }
292              
293             #
294             # Class::Struct is great but introduces overhead
295             # The most critical accesses, identified using
296             # Devel::NYTProf are cached here.
297             #
298             sub cache {
299 5     5 0 7 my $self = shift;
300              
301 5         6 my @cacheOption = ();
302 5         6 my @cacheOptionConditionMode = ();
303 5         4 my @cacheOptionCondition = ();
304 5         7 my @cacheOptionSubscription = ();
305 5         6 my @cacheOptionSubscriptionMode = ();
306 5         6 my @cacheOptionTopic = ();
307 5         4 my @cacheOptionTopic_persistence = ();
308 5         5 my @cacheCbDescription = ();
309 5         4 my @cacheCbMethod = ();
310 5         5 my @cacheCbMethod_void = ();
311 5         77 my $prioritized_cbp = $self->prioritized_cb;
312 5         89 my $prioritized_cb_tofirep = $self->prioritized_cb_tofire;
313 5         107 my $prioritized_cb_firedp = $self->prioritized_cb_fired;
314 5         87 my $ncb = $self->ncb;
315 5         29 foreach (my $i = 0; $i < $ncb; $i++) {
316 37         200 my $cb = $prioritized_cbp->[$i];
317 37         541 my $option = $cb->option;
318 37         200 push(@cacheOption, $option);
319 37         493 push(@cacheOptionConditionMode, $option->conditionMode);
320 37         676 push(@cacheOptionCondition, $option->condition);
321 37         632 push(@cacheOptionSubscription, $option->subscription);
322 37         596 push(@cacheOptionSubscriptionMode, $option->subscriptionMode);
323 37         624 push(@cacheOptionTopic, $option->topic);
324 37         580 push(@cacheOptionTopic_persistence, $option->topic_persistence);
325 37         620 push(@cacheCbDescription, $cb->description);
326 37         633 push(@cacheCbMethod, $cb->method);
327 37         595 push(@cacheCbMethod_void, $cb->method_void);
328             }
329 5         98 $self->hscratchpad('_cacheNcb', $ncb);
330 5         103 $self->hscratchpad('_cachePrioritized_cb', $prioritized_cbp);
331 5         92 $self->hscratchpad('_cachePrioritized_cb_tofire', $prioritized_cb_tofirep);
332 5         98 $self->hscratchpad('_cachePrioritized_cb_fired', $prioritized_cb_firedp);
333 5         102 $self->hscratchpad('_cacheOption', \@cacheOption);
334 5         91 $self->hscratchpad('_cacheOptionConditionMode', \@cacheOptionConditionMode);
335 5         94 $self->hscratchpad('_cacheOptionCondition', \@cacheOptionCondition);
336 5         101 $self->hscratchpad('_cacheOptionSubscription', \@cacheOptionSubscription);
337 5         96 $self->hscratchpad('_cacheOptionSubscriptionMode', \@cacheOptionSubscriptionMode);
338 5         96 $self->hscratchpad('_cacheOptionTopic', \@cacheOptionTopic);
339 5         92 $self->hscratchpad('_cacheOptionTopic_persistence', \@cacheOptionTopic_persistence);
340 5         94 $self->hscratchpad('_cacheCbDescription', \@cacheCbDescription);
341 5         99 $self->hscratchpad('_cacheCbMethod', \@cacheCbMethod);
342 5         89 $self->hscratchpad('_cacheCbMethod_void', \@cacheCbMethod_void);
343              
344 5         98 $self->hscratchpad('_cache', 1);
345              
346 5         45 return;
347             }
348              
349             sub _fire {
350 32     32   31 my $self = shift;
351              
352 32         551 $self->firing(1);
353              
354             #
355             # Make sure the raised topic data always exist.
356             # It is very important that this routine is safe v.s. any on-the-fly registration
357             # or unregistration. Thus all dependencies are expressed in the beginning.
358             # This mean that nay on-the-flu registration/unregistration will happend at NEXT round.
359             #
360 32   33     181 my $ncb = $__PACKAGE__::_cacheNcb // $self->ncb;
361 32   33     56 my $prioritized_cb_tofirep = $__PACKAGE__::_cachePrioritized_cb_tofirep // $self->prioritized_cb_tofire;
362 32   33     52 my $prioritized_cb_firedp = $__PACKAGE__::_cachePrioritized_cb_firedp // $self->prioritized_cb_fired;
363 32   33     53 my $prioritized_cbp = $__PACKAGE__::_cachePrioritized_cbp // $self->prioritized_cb;
364 32   33     49 my $argumentsp = $__PACKAGE__::_cacheArgumentsp // $self->arguments;
365 32         475 my $topic_fired_datap = $self->topic_fired_data;
366              
367 32         165 foreach (my $i = 0; $i < $ncb; $i++) {
368 237 100       324 if ($prioritized_cb_tofirep->[$i] <= 0) {
369             # -1: Condition KO
370             # -2: Condition NA and Subscription NA
371             # -3: Subscription KO
372 194         280 next;
373             }
374 43         39 my $cb = $prioritized_cbp->[$i];
375 43 100       65 if ($prioritized_cb_firedp->[$i]) {
376             # already fired
377 15         25 next;
378             }
379             #
380             # Fire the callback (if there is a method)
381             #
382 28         29 $prioritized_cb_firedp->[$i] = 1;
383 28 50       53 my $method = defined($__PACKAGE__::_cacheCbMethodp) ? $__PACKAGE__::_cacheCbMethodp->[$i] : $cb->method;
384 28 50       49 if (defined($method)) {
385 28         20 my @rc;
386 28 50       57 if (ref($method) eq 'ARRAY') {
387 28         25 my ($method, @arguments) = @{$method};
  28         69  
388 28 50       42 if (ref($method) eq 'CODE') {
389 28         86 @rc = &$method($cb, $self, $argumentsp, @arguments);
390             } else {
391             #
392             # Per def method is the string 'auto'
393             #
394 0   0     0 @rc = $topic_fired_datap->{$cb->description} || [];
395             }
396             }
397             #
398             # Push result to data attached to every topic of this callback
399             #
400 28         452 my $option = $cb->option;
401 28 50       190 my $method_void = defined($__PACKAGE__::_cacheCbMethod_voidp) ? $__PACKAGE__::_cacheCbMethod_voidp->[$i] : $cb->method_void;
402 28 100       51 if (! $method_void) {
403 27 50       19 foreach my $topic (keys %{defined($__PACKAGE__::_cacheOptionTopicp) ? $__PACKAGE__::_cacheOptionTopicp->[$i] : $option->topic}) {
  27         110  
404 27 50       65 next if (! defined(defined($__PACKAGE__::_cacheOptionTopicp) ? $__PACKAGE__::_cacheOptionTopicp->[$i]->{$topic} : $option->topic($topic)));
    50          
405 27 50       75 next if ((defined($__PACKAGE__::_cacheOptionTopicp) ? $__PACKAGE__::_cacheOptionTopicp->[$i]->{$topic} : $option->topic($topic)) != 1);
    100          
406 21   50     40 my $topic_fired_data = $topic_fired_datap->{$topic} || [];
407 21 50       346 if (ref($cb->method) eq 'ARRAY') {
408 21 100       375 if ($cb->method_mode eq 'push') {
409 7         40 push(@{$topic_fired_data}, @rc);
  7         13  
410             } else {
411 14         75 @{$topic_fired_data} = @rc;
  14         24  
412             }
413             } else {
414 0 0       0 if ($cb->method_mode eq 'push') {
415 0         0 push(@{$topic_fired_data}, @rc);
  0         0  
416             } else {
417 0         0 @{$topic_fired_data} = @rc;
  0         0  
418             }
419             }
420 21         70 $topic_fired_datap->{$topic} = $topic_fired_data;
421             }
422             }
423             }
424             }
425              
426 32         483 $self->firing(0);
427              
428 32         157 return;
429             }
430              
431             sub topic_level_fired_data {
432 1     1 0 2 my $self = shift;
433 1         2 my $topic = shift;
434 1         2 my $level = shift;
435              
436 1   50     3 $level //= 0;
437              
438             #
439             # Level MUST be 0 for current or a negative number
440             #
441 1         2 $level = int($level);
442 1 50       3 if ($level > 0) {
443 0         0 croak 'int(level) must be 0 or a negative number';
444             }
445 1 50       4 if ($level == 0) {
446 0 0       0 if (@_) {
447 0         0 $self->topic_fired_data($topic, shift);
448             }
449 0         0 return $self->topic_fired_data($topic);
450             } else {
451 1         1 my ($old_topic_firedp, $old_topic_persistencep, $old_topic_datap) = @{$self->topic_level($level)};
  1         20  
452 1 50       20 if (@_) {
453 0         0 $old_topic_datap->{$topic} = shift;
454             }
455 1         5 return $old_topic_datap->{$topic};
456             }
457             }
458              
459             sub _inventory_initialize_topic {
460 20     20   21 my $self = shift;
461             #
462             # For topics, we want to keep those that have a persistence of 'level' or 'any'
463             #
464 20         282 my $topic_firedp = $self->topic_fired;
465 20         328 my $topic_fired_datap = $self->topic_fired_data;
466 20         333 my $topic_fired_persistencep = $self->topic_fired_persistence;
467              
468 20         90 my $keep_topic_firedp = {};
469 20         25 my $keep_topic_fired_persistencep = {};
470 20         18 my $keep_topic_fired_datap = {};
471              
472 20         20 foreach my $topic (keys %{$topic_firedp}) {
  20         48  
473 26         31 my $persistence = $topic_fired_persistencep->{$topic};
474 26 50       24 if (grep {$_ eq $persistence} qw/any level/) {
  52         88  
475 26         37 $keep_topic_firedp->{$topic} = $topic_firedp->{$topic};
476 26         33 $keep_topic_fired_persistencep->{$topic} = $topic_fired_persistencep->{$topic};
477 26         46 $keep_topic_fired_datap->{$topic} = $topic_fired_datap->{$topic};
478             }
479             }
480 20         314 $self->topic_fired($keep_topic_firedp);
481 20         390 $self->topic_fired_persistence($keep_topic_fired_persistencep);
482 20         363 $self->topic_fired_data($keep_topic_fired_datap);
483              
484 20         158 return;
485             }
486              
487             sub _inventory_initialize_tofire {
488 20     20   42 my ($self) = @_;
489 20   33     49 my $ncb = $__PACKAGE__::_cacheNcb // $self->ncb;
490 20         47 my $prioritized_cb_tofirep = [ (0) x $ncb ];
491 20         311 $self->prioritized_cb_tofire($prioritized_cb_tofirep);
492 20 50       160 if (defined($__PACKAGE__::_cachePrioritized_cb_tofirep)) {
493 20         21 $__PACKAGE__::_cachePrioritized_cb_tofirep = $prioritized_cb_tofirep;
494             }
495 20         27 return;
496             }
497              
498             sub _inventory_initialize_fired {
499 20     20   21 my ($self) = @_;
500 20   33     41 my $ncb = $__PACKAGE__::_cacheNcb // $self->ncb;
501 20         37 my $prioritized_cb_firedp = [ (0) x $ncb ];
502 20         286 $self->prioritized_cb_fired($prioritized_cb_firedp);
503 20 50       161 if (defined($__PACKAGE__::_cachePrioritized_cb_firedp)) {
504 20         22 $__PACKAGE__::_cachePrioritized_cb_firedp = $prioritized_cb_firedp;
505             }
506 20         23 return;
507             }
508              
509             sub _inventory_fire {
510 20     20   27 my ($self) = @_;
511              
512             #
513             # Inventory
514             #
515 20         50 $self->_inventory_initialize_topic();
516 20         43 $self->_inventory();
517 20         21 return;
518             }
519              
520             sub _inventory {
521 20     20   19 my ($self) = @_;
522 20         23 my $nbTopicsCreated = 0;
523 20         15 do {
524 20         35 $self->_inventory_initialize_tofire();
525 20         36 $self->_inventory_initialize_fired();
526 20         42 $nbTopicsCreated += $self->_inventory_condition_tofire();
527 20         55 $nbTopicsCreated += $self->_inventory_subscription_tofire();
528 20 100       53 if ($nbTopicsCreated > 0) {
529 12         30 $self->_fire();
530 12         27 $nbTopicsCreated = 0;
531             }
532             } while ($nbTopicsCreated > 0);
533 20         26 return;
534             }
535              
536             sub _inventory_subscription_tofire {
537 20     20   19 my $self = shift;
538             #
539             # This is a loop because when a new callback is eligible there might be new topics
540             #
541 20         20 my $nbNewTopics = 0;
542 20         20 my $nbSubscriptionOK = 0;
543 20   33     35 my $ncb = $__PACKAGE__::_cacheNcb // $self->ncb;
544 20         385 my $prioritized_cbp = $self->prioritized_cb;
545 20         350 my $prioritized_cb_tofirep = $self->prioritized_cb_tofire;
546 20         332 my $topic_firedp = $self->topic_fired;
547 20         321 my $topic_fired_datap = $self->topic_fired_data;
548 20         329 my $topic_fired_persistencep = $self->topic_fired_persistence;
549 20         79 my @keys_topic_fired = keys %{$topic_firedp};
  20         57  
550              
551 20         47 foreach (my $i = 0; $i < $ncb; $i++) {
552 155         130 my $cb = $prioritized_cbp->[$i];
553 155 50       186 my $option = defined($__PACKAGE__::_cacheOptionp) ? $__PACKAGE__::_cacheOptionp->[$i] : $cb->option;
554             #
555             # Here the values can be:
556             # -1: condition KO
557             # 0: no condition applied
558             # 1: condition OK
559 155 100       239 next if ($prioritized_cb_tofirep->[$i] < 0);
560              
561 151         132 my %subscribed = ();
562 151         104 my $nbSubscription = 0;
563 151 50       123 foreach my $subscription (keys %{defined($__PACKAGE__::_cacheOptionSubscriptionp) ? $__PACKAGE__::_cacheOptionSubscriptionp->[$i] : $option->subscription}) {
  151         338  
564 0 0       0 next if (! defined(defined($__PACKAGE__::_cacheOptionSubscriptionp) ? $__PACKAGE__::_cacheOptionSubscriptionp->[$i]->{$subscription} : $option->subscription($subscription)));
    0          
565 0 0       0 next if (! (defined($__PACKAGE__::_cacheOptionSubscriptionp) ? $__PACKAGE__::_cacheOptionSubscriptionp->[$i]->{$subscription} : $option->subscription($subscription)));
    0          
566 0         0 ++$nbSubscription;
567 0 0       0 if (ref($subscription) eq 'Regexp') {
568 0         0 foreach (@keys_topic_fired) {
569 0 0       0 if ($_ =~ $subscription) {
570 0         0 $subscribed{$_} = 1;
571             }
572             }
573             } else {
574 0         0 foreach (@keys_topic_fired) {
575 0 0       0 if ("$_" eq "$subscription") {
576 0         0 $subscribed{$_} = 1;
577             }
578             }
579             }
580             }
581              
582 151 100 66     448 if ($prioritized_cb_tofirep->[$i] == 0 && ! %subscribed) {
583             #
584             # no condition was setted and no subscription is raised
585             #
586 123         105 $prioritized_cb_tofirep->[$i] = -2;
587 123         247 next;
588             }
589              
590 28 0 33     55 if ($nbSubscription > 0 && (defined($__PACKAGE__::_cacheOptionSubscriptionModep) ? $__PACKAGE__::_cacheOptionSubscriptionModep->[$i] : $option->subscriptionMode) eq 'required' && $nbSubscription != keys %subscribed) {
    0 33        
591             #
592             # There are active subscription not raised, and subscriptionMode is 'required'
593             #
594 0         0 $prioritized_cb_tofirep->[$i] = -3;
595 0         0 next;
596             }
597              
598 28 50       44 if ($prioritized_cb_tofirep->[$i] == 0) {
599             #
600             # There must have been topic subscription being raised
601             #
602 0         0 $prioritized_cb_tofirep->[$i] = 1;
603 0         0 ++$nbSubscriptionOK;
604             }
605              
606 28 50       23 foreach my $topic (keys %{defined($__PACKAGE__::_cacheOptionTopicp) ? $__PACKAGE__::_cacheOptionTopicp->[$i] : $option->topic}) {
  28         71  
607 29 50       69 next if (! defined(defined($__PACKAGE__::_cacheOptionTopicp) ? $__PACKAGE__::_cacheOptionTopicp->[$i]->{$topic} : $option->topic($topic)));
    50          
608 29 50       67 next if (! (defined($__PACKAGE__::_cacheOptionTopicp) ? $__PACKAGE__::_cacheOptionTopicp->[$i]->{$topic} : $option->topic($topic)));
    50          
609 29 50       86 if (! defined($topic_firedp->{$topic})) {
610 0         0 $topic_firedp->{$topic} = 1;
611 0         0 $topic_fired_persistencep->{$topic} = $option->topic_persistence;
612 0         0 $topic_fired_datap->{$topic} = [];
613 0         0 ++$nbNewTopics;
614             }
615             }
616             }
617              
618 20         44 return $nbNewTopics;
619             }
620              
621             sub currentTopicLevel {
622 0     0 0 0 my $self = shift;
623              
624 0         0 return scalar(@{$self->topic_level});
  0         0  
625             }
626              
627             sub pushTopicLevel {
628 5     5 0 5 my $self = shift;
629              
630 5         78 my $topic_firedp = $self->topic_fired;
631 5         82 my $topic_fired_datap = $self->topic_fired_data;
632 5         83 my $topic_fired_persistencep = $self->topic_fired_persistence;
633              
634             #
635             # Since we are going to replace the entire hash, keeping a copy of them
636             # in @{$self->topic_level} is enough
637             #
638 5         19 push(@{$self->topic_level}, [ $topic_firedp, $topic_fired_persistencep, $topic_fired_datap ]);
  5         73  
639             #
640             # We remove from current topics those that do not have the 'any' persistence
641             #
642 5         28 my $new_topic_firedp = {};
643 5         7 my $new_topic_fired_persistencep = {};
644 5         5 my $new_topic_fired_datap = {};
645 5         5 foreach my $topic (keys %{$topic_firedp}) {
  5         13  
646 14         15 my $persistence = $topic_fired_persistencep->{$topic};
647 14 100       11 if (grep {$_ eq $persistence} qw/any/) {
  14         41  
648 2         4 $new_topic_firedp->{$topic} = $topic_firedp->{$topic};
649 2         122 $new_topic_fired_persistencep->{$topic} = $topic_fired_persistencep->{$topic};
650 2         9 $new_topic_fired_datap->{$topic} = $topic_fired_datap->{$topic};
651             }
652             }
653             #
654             # These lines guarantee that what we have pushed will not be touched using $self->topic_fired() etc... accessors
655             # because we replace the entire hash.
656             #
657 5         84 $self->topic_fired($new_topic_firedp);
658 5         97 $self->topic_fired_persistence($new_topic_fired_persistencep);
659 5         92 $self->topic_fired_data($new_topic_fired_datap);
660              
661 5         39 return;
662              
663             }
664              
665             sub popTopicLevel {
666 5     5 0 7 my $self = shift;
667              
668             #
669             # We pop current topics and their persistence from the topic_level
670             #
671 5         6 my ($old_topic_firedp, $old_topic_persistencep, $old_topic_datap) = @{$self->topic_level(-1)};
  5         91  
672 5         38 pop(@{$self->topic_level});
  5         71  
673 5         83 $self->topic_fired($old_topic_firedp);
674 5         101 $self->topic_fired_persistence($old_topic_persistencep);
675 5         99 $self->topic_fired_data($old_topic_datap);
676              
677 5         38 return;
678              
679             }
680              
681             sub reset_topic_fired_data {
682 0     0 0   my ($self, $topic, $value, $level) = @_;
683              
684 0   0       $value //= [];
685 0   0       $level //= 0;
686              
687 0 0         if (ref($value) ne 'ARRAY') {
688 0           croak 'Topic fired data must be an ARRAY reference';
689             }
690              
691             #
692             # Level MUST be 0 or a negative number
693             # It is okay if $value is undef
694             #
695 0           $level = int($level);
696 0 0         if ($level > 0) {
697 0           croak 'int(level) must be 0 or a negative number';
698             }
699 0 0         if ($level == 0) {
700 0           $self->topic_fired_data($topic, $value);
701             } else {
702 0           my ($old_topic_fired, $old_topic_persistence, $old_topic_data) = @{$self->topic_level($level)};
  0            
703 0           $old_topic_data->{$topic} = $value;
704             }
705              
706 0           return;
707              
708             }
709              
710             1;
711              
712             __END__