line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Starch::Plugin::TimeoutStore; |
2
|
1
|
|
|
1
|
|
5171
|
use 5.010001; |
|
1
|
|
|
|
|
4
|
|
3
|
1
|
|
|
1
|
|
5
|
use strictures 2; |
|
1
|
|
|
|
|
7
|
|
|
1
|
|
|
|
|
39
|
|
4
|
|
|
|
|
|
|
our $VERSION = '0.09'; |
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
=head1 NAME |
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
Starch::Plugin::TimeoutStore - Throw an exception if store access surpasses a timeout. |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
=head1 SYNOPSIS |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
my $starch = Starch->new( |
13
|
|
|
|
|
|
|
plugins => ['::TimeoutStore'], |
14
|
|
|
|
|
|
|
store => { |
15
|
|
|
|
|
|
|
class => '::Memory', |
16
|
|
|
|
|
|
|
timeout => 0.1, # 1/10th of a second |
17
|
|
|
|
|
|
|
}, |
18
|
|
|
|
|
|
|
..., |
19
|
|
|
|
|
|
|
); |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
=head1 DESCRIPTION |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
This plugin causes all calls to C, C, and C to throw |
24
|
|
|
|
|
|
|
an exception if they surpass a timeout period. |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
The timeout is implemented using L. |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
Note that some stores implement timeouts themselves and their native |
29
|
|
|
|
|
|
|
may be better than this naive implementation. |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
The whole point of detecting timeouts is so that you can still serve |
32
|
|
|
|
|
|
|
a web page even if the underlying store backend is failing, so |
33
|
|
|
|
|
|
|
using this plugin with L is |
34
|
|
|
|
|
|
|
probably a good idea. |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
=cut |
37
|
|
|
|
|
|
|
|
38
|
1
|
|
|
1
|
|
224
|
use Types::Common::Numeric -types; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
15
|
|
39
|
1
|
|
|
1
|
|
1484
|
use Starch::Util qw( croak ); |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
51
|
|
40
|
1
|
|
|
1
|
|
531
|
use Sys::SigAction qw( timeout_call ); |
|
1
|
|
|
|
|
8733
|
|
|
1
|
|
|
|
|
110
|
|
41
|
|
|
|
|
|
|
|
42
|
1
|
|
|
1
|
|
75
|
use Moo::Role; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
13
|
|
43
|
1
|
|
|
1
|
|
604
|
use namespace::clean; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
9
|
|
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
with 'Starch::Plugin::ForStore'; |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
=head1 OPTIONAL STORE ARGUMENTS |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
These arguments are added to classes which consume the |
50
|
|
|
|
|
|
|
L role. |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
=head2 timeout |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
How many seconds to timeout. Fractional seconds may be passed, but |
55
|
|
|
|
|
|
|
may not be supported on all systems (see L). |
56
|
|
|
|
|
|
|
Set to C<0> to disable timeout checking. Defaults to C<0>. |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
=cut |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
has timeout => ( |
61
|
|
|
|
|
|
|
is => 'ro', |
62
|
|
|
|
|
|
|
isa => PositiveOrZeroNum, |
63
|
|
|
|
|
|
|
default => 0, |
64
|
|
|
|
|
|
|
); |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
foreach my $method (qw( set get remove )) { |
67
|
|
|
|
|
|
|
around $method => sub{ |
68
|
|
|
|
|
|
|
my $orig = shift; |
69
|
|
|
|
|
|
|
my $self = shift; |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
my $timeout = $self->timeout(); |
72
|
|
|
|
|
|
|
return $self->$orig( @_ ) if $timeout == 0; |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
my @args = @_; |
75
|
|
|
|
|
|
|
my $data; |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
if ( timeout_call( $timeout, sub{ |
78
|
|
|
|
|
|
|
$data = $self->$orig( @args ); |
79
|
|
|
|
|
|
|
}) ) { |
80
|
|
|
|
|
|
|
croak sprintf( |
81
|
|
|
|
|
|
|
'The %s method %s exceeded the timeout of %s seconds', |
82
|
|
|
|
|
|
|
$self->short_class_name(), $method, $timeout, |
83
|
|
|
|
|
|
|
); |
84
|
|
|
|
|
|
|
} |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
return $data if $method eq 'get'; |
87
|
|
|
|
|
|
|
return; |
88
|
|
|
|
|
|
|
}; |
89
|
|
|
|
|
|
|
} |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
1; |
92
|
|
|
|
|
|
|
__END__ |