File Coverage

blib/lib/CHI/Cascade.pm
Criterion Covered Total %
statement 181 224 80.8
branch 74 124 59.6
condition 34 80 42.5
subroutine 26 31 83.8
pod 6 19 31.5
total 321 478 67.1


line stmt bran cond sub pod time code
1             package CHI::Cascade;
2              
3 15     15   1987249 use strict;
  15         98  
  15         466  
4 15     15   87 use warnings;
  15         34  
  15         596  
5              
6             our $VERSION = 0.300_003;
7              
8 15     15   86 use Carp;
  15         30  
  15         938  
9              
10 15     15   3760 use CHI::Cascade::Value ':state';
  15         43  
  15         2664  
11 15     15   6852 use CHI::Cascade::Rule;
  15         47  
  15         517  
12 15     15   6184 use CHI::Cascade::Target;
  15         41  
  15         453  
13 15     15   97 use Time::HiRes ();
  15         33  
  15         199  
14 15     15   7917 use POSIX ();
  15         99714  
  15         44411  
15              
16 0 0   0 0 0 sub min ($$) { $_[0] < $_[1] ? $_[0] : $_[1] }
17              
18             sub new {
19 1     1 1 132292 my ($class, %opts) = @_;
20              
21 1   33     82 my $self = bless {
22             %opts,
23             plain_targets => {},
24             qr_targets => [],
25             stats => { recompute => 0, run => 0, dependencies_lookup => 0 }
26              
27             }, ref($class) || $class;
28              
29 1   33     43 $self->{target_chi} ||= $self->{chi};
30              
31 1         11 $self;
32             }
33              
34             sub rule {
35 3     3 1 1209 my ($self, %opts) = @_;
36              
37 3         41 my $rule = CHI::Cascade::Rule->new( cascade => $self, %opts );
38              
39 3 100       16 if (ref($rule->{target}) eq 'Regexp') {
    50          
40 1         2 push @{ $self->{qr_targets} }, $rule;
  1         6  
41             }
42             elsif (! ref($rule->{target})) {
43 2         11 $self->{plain_targets}{$rule->{target}} = $rule;
44             }
45             else {
46 0         0 croak qq{The rule's target "$rule->{target}" is unknown type};
47             }
48             }
49              
50             sub target_computing {
51 29     29 0 42 my $trg_obj;
52              
53             ( $trg_obj = $_[0]->{target_chi}->get("t:$_[1]") )
54 29 50       136 ? ( ( ${ $_[2] } = $trg_obj->ttl ), $trg_obj->locked ? 1 : 0 )
  25 100       79  
55             : 0;
56             }
57              
58             sub target_is_actual {
59 6     6 0 16 my ( $self, $target, $actual_term ) = @_;
60              
61 6         9 my $trg_obj;
62              
63 6 100       41 ( $trg_obj = $self->{target_chi}->get("t:$target") )
64             ? $trg_obj->is_actual( $actual_term )
65             : 0;
66             }
67              
68             sub target_time {
69 40     40 0 81 my ($self, $target) = @_;
70              
71 40         55 my $trg_obj;
72              
73 40 100       152 return ( ( $trg_obj = $self->{target_chi}->get("t:$target") )
74             ? $trg_obj->time
75             : 0
76             );
77             }
78              
79             sub get_value {
80 11     11 0 22 my ($self, $target) = @_;
81              
82 11         41 my $value = $self->{chi}->get("v:$target");
83              
84 11 50       3657 return $value->state( CASCADE_FROM_CACHE )
85             if ($value);
86              
87 0         0 CHI::Cascade::Value->new( state => CASCADE_NO_CACHE );
88             }
89              
90             sub target_lock {
91 11     11 0 625 my ( $self, $rule ) = @_;
92              
93 11         46 my $target = $rule->target;
94              
95             # If target is already locked - a return
96             return
97 11 100       46 if ( $self->target_locked( $rule ) );
98              
99 8         14 my $trg_obj;
100             $trg_obj = CHI::Cascade::Target->new
101 8 100       29 unless ( ( $trg_obj = $self->{target_chi}->get("t:$target") ) );
102              
103 8         1323 $trg_obj->lock;
104 8         38 $self->{target_chi}->set( "t:$target", $trg_obj, $rule->target_expires( $trg_obj ) );
105              
106 8         7284 $rule->{run_instance}{target_locks}{$target} = 1;
107             }
108              
109             sub target_unlock {
110 8     8 0 17 my ( $self, $rule, $value ) = @_;
111              
112 8         16 my $target = $rule->target;
113              
114 8 50       35 if ( my $trg_obj = $self->{target_chi}->get( "t:$target" ) ) {
115 8         2493 $trg_obj->unlock;
116              
117 8 50 33     40 if ( $value && $value->state & CASCADE_RECOMPUTED ) {
118 8         33 $trg_obj->touch;
119             $trg_obj->actual_stamp
120 8 100 66     40 if $rule->{run_instance}{run_opts}{actual_term} && $rule->{run_instance}{orig_target} eq $target;
121             }
122              
123 8         38 $self->{target_chi}->set( "t:$target", $trg_obj, $rule->target_expires( $trg_obj ) );
124             }
125              
126 8         4556 delete $rule->{run_instance}{target_locks}{$target};
127             }
128              
129             sub target_actual_stamp {
130 0     0 0 0 my ( $self, $rule, $value ) = @_;
131              
132 0         0 my $target = $rule->target;
133              
134 0 0 0     0 if ( $value && $value->state & CASCADE_ACTUAL_VALUE && ( my $trg_obj = $self->{target_chi}->get( "t:$target" ) ) ) {
      0        
135 0         0 $trg_obj->actual_stamp;
136 0         0 $self->{target_chi}->set( "t:$target", $trg_obj, $rule->target_expires( $trg_obj ) );
137             }
138             }
139              
140             sub target_start_ttl {
141 0     0 0 0 my ( $self, $rule, $start_time ) = @_;
142              
143 0         0 my $target = $rule->target;
144              
145 0 0       0 if ( my $trg_obj = $self->{target_chi}->get( "t:$target" ) ) {
146 0         0 $trg_obj->ttl( $rule->ttl, $start_time );
147 0         0 $self->{target_chi}->set( "t:$target", $trg_obj, $rule->target_expires( $trg_obj ) );
148             }
149             }
150              
151             sub target_remove {
152 0     0 1 0 my ($self, $target) = @_;
153              
154 0         0 $self->{target_chi}->remove("t:$target");
155             }
156              
157             sub touch {
158 2     2 1 13 my ( $self, $target ) = @_;
159              
160 2 50       28 if ( my $trg_obj = $self->{target_chi}->get("t:$target") ) {
161 2         989 $trg_obj->touch;
162 2         12 $self->{target_chi}->set( "t:$target", $trg_obj, $self->find( $target )->target_expires( $trg_obj ) );
163             }
164             }
165              
166             sub target_locked {
167 91     91 0 163 my ( $self, $rule ) = @_;
168              
169 91         305 exists $rule->{run_instance}{target_locks}{ $rule->target };
170             }
171              
172             sub recompute {
173 8     8 0 22 my ( $self, $rule, $target, $dep_values) = @_;
174              
175             die CHI::Cascade::Value->new( state => CASCADE_DEFERRED )
176 8 50       21 if $rule->{run_instance}{run_opts}{defer};
177              
178 8         17 my $ret = eval { $rule->{code}->( $rule, $target, $rule->{dep_values} = $dep_values ) };
  8         51  
179              
180 8         69 $self->{stats}{recompute}++;
181              
182 8 50       21 if ($@) {
183 0         0 my $error = $@;
184 0 0       0 die( ( eval { $error->isa('CHI::Cascade::Value') } ) ? $error->thrown_from_code(1) : "CHI::Cascade: the target $target - error in the code: $error" );
  0         0  
185             }
186              
187 8         13 my $value;
188              
189             # For performance a value should not expire in anyway (only target marker if need)
190 8         47 $self->{chi}->set( "v:$target", $value = CHI::Cascade::Value->new->value($ret), 'never' );
191              
192 8         5348 $value->state( CASCADE_ACTUAL_VALUE | CASCADE_RECOMPUTED );
193              
194             $rule->{recomputed}->( $rule, $target, $value )
195 8 100       45 if ( ref $rule->{recomputed} eq 'CODE' );
196              
197 8         74 return $value;
198             }
199              
200             sub value_ref_if_recomputed {
201 29     29 0 76 my ( $self, $rule, $target, $only_from_cache ) = @_;
202              
203             return undef
204 29 50       66 unless defined $rule;
205              
206 29         41 my $run_instance = $rule->{run_instance};
207              
208 29         72 my @qr_params = $rule->qr_params;
209              
210 29         59 my ( $ret_state, $ttl, $should_be_recomputed ) = ( CASCADE_ACTUAL_VALUE );
211              
212 29 50       76 if ( $self->target_computing( $target, \$ttl ) ) {
213             # If we have any target as a being computed (dependencie/original)
214             # there is no need to compute anything - trying to return original target value
215 0         0 die CHI::Cascade::Value->new->state( CASCADE_COMPUTING );
216             }
217              
218 29         953 my ( %dep_values, $dep_name );
219              
220 29 100       58 if ( $only_from_cache ) {
221              
222             # Trying to get value from cache
223 9         27 my $value = $self->get_value($target);
224              
225 9 50       22 return $value
226             if $value->is_value;
227              
228             # If no in cache - we should recompute it again
229 0         0 $self->target_lock($rule);
230             }
231              
232 20         32 push @{ $run_instance->{target_stack} }, $target;
  20         53  
233              
234 20         35 my $ret = eval {
235 20         32 my $dep_target;
236              
237             my $catcher = sub {
238 17     17   27 my $sub = shift;
239              
240 17         24 my $ret = eval { $sub->() };
  17         33  
241              
242 17 50       43 if ($@) {
243 0         0 my $exception = $@;
244              
245             $rule->{depends_catch}->( $rule, $exception, $dep_values{$dep_target}->[0], $dep_target )
246             if ( exists $rule->{depends_catch}
247             && ref $rule->{depends_catch} eq 'CODE'
248 0 0 0     0 && eval { $exception->isa('CHI::Cascade::Value') }
  0   0     0  
      0        
249             && $exception->thrown_from_code );
250              
251 0         0 die $exception;
252             }
253              
254 17         110 return $ret;
255 20         116 };
256              
257 20 100       56 $self->target_lock($rule)
258             if ! $self->target_time($target);
259              
260 20         79 $should_be_recomputed = $self->target_locked($rule);
261              
262 20 50 33     73 if ( defined $ttl && $ttl > 0 && ! $should_be_recomputed ) {
      33        
263 0         0 $ret_state = CASCADE_TTL_INVOLVED;
264 0         0 $run_instance->{ttl} = $ttl;
265             }
266             else {
267             my (
268 20 50       59 $rule_ttl,
269             $circle_hash,
270             $start_time,
271             $min_start_time
272             ) = (
273             $rule->ttl,
274             $only_from_cache ? 'only_cache_chain' : 'chain'
275             );
276              
277 20         33 foreach my $depend (@{ $rule->depends }) {
  20         55  
278 11 50       27 $dep_target = ref($depend) eq 'CODE' ? $depend->( $rule, @qr_params ) : $depend;
279              
280 11         32 $dep_values{$dep_target}->[0] = $self->find( $dep_target, $rule->{run_instance} );
281              
282 0         0 die "Found circle dependencies (trace: " . join( '->', @{ $run_instance->{target_stack} }, $dep_target ) . ") - aborted!"
283 11 50       38 if ( exists $run_instance->{ $circle_hash }{$target}{$dep_target} );
284              
285 11         30 $run_instance->{ $circle_hash }{$target}{$dep_target} = 1;
286              
287             $catcher->( sub {
288 11 100 100 11   82 if ( ! $only_from_cache
      66        
289             && ( $start_time = ( $self->{stats}{dependencies_lookup}++,
290             ( $dep_values{$dep_target}->[1] = $self->value_ref_if_recomputed( $dep_values{$dep_target}->[0], $dep_target ) )->state & CASCADE_RECOMPUTED && Time::HiRes::time
291             || ( $start_time = $self->target_time($dep_target) ) > $self->target_time($target) && $start_time ) ) )
292             {
293 7 50 66     67 if ( ! $should_be_recomputed
      66        
      33        
      33        
294             && ! defined $ttl
295             && defined $rule_ttl
296             && $rule_ttl > 0
297             && ( $start_time + $rule_ttl ) > Time::HiRes::time )
298             {
299 0 0       0 $min_start_time = defined $min_start_time ? min( $start_time, $min_start_time ) : $start_time;
300             }
301             else {
302 7         21 $self->target_lock($rule);
303             }
304             }
305 11         81 } );
306              
307 11         105 delete $run_instance->{ $circle_hash }{$target}{$dep_target};
308             }
309              
310 20 50       62 if ( defined $min_start_time ) {
311 0         0 $ret_state = CASCADE_TTL_INVOLVED;
312 0         0 $self->target_start_ttl( $rule, $min_start_time );
313 0         0 $run_instance->{ttl} = $min_start_time + $rule_ttl - Time::HiRes::time;
314             }
315             }
316              
317 20 100       47 if ( $self->target_locked($rule) ) {
318             # We should recompute this target
319             # So we should recompute values for other dependencies
320 8         26 foreach $dep_target (keys %dep_values) {
321 7 100 66     48 if ( ! defined $dep_values{$dep_target}->[1]
322             || ! $dep_values{$dep_target}->[1]->is_value )
323             {
324 6         13 $self->{stats}{dependencies_lookup}++;
325             $catcher->( sub {
326 6 50   6   20 if ( ! ( $dep_values{$dep_target}->[1] = $self->value_ref_if_recomputed( $dep_values{$dep_target}->[0], $dep_target, 1 ) )->is_value ) {
327 0         0 $self->target_remove($dep_target);
328 0         0 return 1;
329             }
330 6         17 return 0;
331 6 50       40 } ) == 1 && return undef;
332             }
333             }
334             }
335              
336 20 100       51 return $self->recompute( $rule, $target, { map { $_ => $dep_values{$_}->[1]->value } keys %dep_values } )
  7         26  
337             if $self->target_locked($rule);
338              
339 12         75 return CHI::Cascade::Value->new( state => $ret_state );
340             };
341              
342 20         33 pop @{ $run_instance->{target_stack} };
  20         42  
343              
344 20         33 my $e = $@;
345              
346 20 100 66     50 if ( $self->target_locked($rule) ) {
    50 66        
347 8         25 $self->target_unlock( $rule, $ret );
348             }
349             elsif ( $run_instance->{run_opts}{actual_term} && ! $only_from_cache && $run_instance->{orig_target} eq $target ) {
350 0         0 $self->target_actual_stamp( $rule, $ret );
351             }
352              
353 20 50       56 die $e if $e;
354              
355 20   33     160 return $ret || CHI::Cascade::Value->new;
356             }
357              
358 0 0 0 0 1 0 sub stash { exists $_[0]->{stash} && $_[0]->{stash} || die "The stash method from outside run method!" }
359              
360             sub run {
361 12     12 1 434 my ( $self, $target, %opts ) = @_;
362              
363 12         35 my $view_dependencies = 1;
364              
365             # The run's instance parameters. This instance to be needed to give ability to run the run method from deep inside run calls.
366             # It's for internal using.
367 12         27 my $run_instance = {};
368              
369 12   50     104 $run_instance->{stash} = $opts{stash} && ref $opts{stash} eq 'HASH' && $opts{stash} || {};
370              
371 12         29 $run_instance->{run_opts} = \%opts;
372 12         26 $run_instance->{ttl} = undef;
373 12         23 $run_instance->{target_locks} = {};
374              
375 12   100     53 $opts{actual_term} ||= $self->find($target)->{actual_term};
376 12         29 $self->{stats}{run}++;
377              
378              
379             # FIXME to delete in future. Now it's depricated
380 12         28 $self->{stash} = $run_instance->{stash};
381              
382             $view_dependencies = ! $self->target_is_actual( $target, $opts{actual_term} )
383 12 100       44 if ( $opts{actual_term} );
384              
385 12         224 my $res = $self->_run( ! $view_dependencies, $target, $run_instance );
386              
387             $res->state( CASCADE_ACTUAL_TERM )
388 12 100 100     60 if ( $opts{actual_term} && ! $view_dependencies );
389              
390 12 50 33     33 if ( defined $run_instance->{ttl} && $run_instance->{ttl} > 0 ) {
391 0         0 $res->state( CASCADE_TTL_INVOLVED );
392             }
393              
394 0         0 ${ $opts{ttl} } = $run_instance->{ttl}
395 12 50       29 if ( $opts{ttl} );
396              
397 6         13 ${ $opts{state} } = $res->state
398 12 100       35 if ( $opts{state} );
399              
400 12         31 $res->value;
401             }
402              
403             sub _run {
404 12     12   31 my ( $self, $only_from_cache, $target, $run_instance ) = @_;
405              
406 12 50       29 croak qq{The target ($target) for run should be string} if ref($target);
407 12 50       29 croak qq{The target for run is empty} if $target eq '';
408              
409 12         30 $run_instance->{chain} = {};
410 12         28 $run_instance->{only_cache_chain} = {};
411 12         27 $run_instance->{target_stack} = [];
412              
413 12         21 my $ret = eval {
414 12         46 $run_instance->{orig_target} = $target;
415              
416 12         32 return $self->value_ref_if_recomputed( $run_instance->{orig_rule} = $self->find( $target, $run_instance ), $target, $only_from_cache );
417             };
418              
419 12         24 my $terminated;
420              
421 12 50       32 if ( $terminated = $@ ) {
422 0         0 $ret = $@;
423              
424             die $ret
425 0 0       0 unless eval { $ret->isa('CHI::Cascade::Value') };
  0         0  
426              
427 0 0       0 $ret->state( CASCADE_CODE_EXCEPTION )
428             unless $ret->state;
429             }
430              
431 12 100       35 if ( ! $ret->is_value ) {
432 2         6 my $from_cache = $self->get_value( $target );
433              
434 2 50 33     18 return $from_cache->state( $ret->state )
435             if ( $terminated || $from_cache->is_value );
436              
437 0 0       0 return $self->_run( 1, $target )
438             if ! $only_from_cache;
439             }
440              
441 10         22 return $ret;
442             }
443              
444             sub find {
445 34     34 0 100 my ($self, $plain_target, $run_instance) = @_;
446              
447 34 50       70 die "CHI::Cascade::find : got empty target\n" if $plain_target eq '';
448              
449 34         45 my $new_rule;
450              
451             # If target is flat text
452 34 100       81 if (exists $self->{plain_targets}{$plain_target}) {
453 17 100       60 return $self->{plain_targets}{$plain_target}
454             unless $run_instance;
455 12         44 ( $new_rule = $self->{plain_targets}{$plain_target}->new( run_instance => $run_instance ) )->{matched_target} = $plain_target;
456 12         41 return $new_rule;
457             }
458              
459             # If rule's target is Regexp type
460 17         23 foreach my $rule (@{$self->{qr_targets}}) {
  17         47  
461 17         32 my @qr_params;
462              
463 17 50       157 if (@qr_params = $plain_target =~ $rule->{target}) {
464 17 100       59 return $rule
465             unless $run_instance;
466 11         50 ( $new_rule = $rule->new( run_instance => $run_instance ) )->qr_params(@qr_params);
467 11         18 $new_rule->{matched_target} = $plain_target;
468 11         49 return $new_rule;
469             }
470             }
471              
472 0           die "CHI::Cascade::find : cannot find the target $plain_target\n";
473             }
474              
475              
476             1;
477             __END__