File Coverage

blib/lib/Starch/Plugin/TimeoutStore.pm
Criterion Covered Total %
statement 20 20 100.0
branch n/a
condition n/a
subroutine 7 7 100.0
pod n/a
total 27 27 100.0


line stmt bran cond sub pod time code
1             package Starch::Plugin::TimeoutStore;
2 1     1   5564 use 5.010001;
  1         5  
3 1     1   8 use strictures 2;
  1         9  
  1         44  
4             our $VERSION = '0.08';
5              
6             =head1 NAME
7              
8             Starch::Plugin::TimeoutStore - Throw an exception if store access surpass 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   246 use Types::Common::Numeric -types;
  1         2  
  1         19  
39 1     1   1563 use Starch::Util qw( croak );
  1         3  
  1         55  
40 1     1   547 use Sys::SigAction qw( timeout_call );
  1         7281  
  1         65  
41              
42 1     1   9 use Moo::Role;
  1         3  
  1         11  
43 1     1   479 use namespace::clean;
  1         7  
  1         9  
44              
45             with qw(
46             Starch::Plugin::ForStore
47             );
48              
49             =head1 OPTIONAL STORE ARGUMENTS
50              
51             These arguments are added to classes which consume the
52             L role.
53              
54             =head2 timeout
55              
56             How many seconds to timeout. Fractional seconds may be passed, but
57             may not be supported on all systems (see L).
58             Set to C<0> to disable timeout checking. Defaults to C<0>.
59              
60             =cut
61              
62             has timeout => (
63             is => 'ro',
64             isa => PositiveOrZeroNum,
65             default => 0,
66             );
67              
68             foreach my $method (qw( set get remove )) {
69             around $method => sub{
70             my $orig = shift;
71             my $self = shift;
72              
73             my $timeout = $self->timeout();
74             return $self->$orig( @_ ) if $timeout == 0;
75              
76             my @args = @_;
77             my $data;
78              
79             if ( timeout_call( $timeout, sub{
80             $data = $self->$orig( @args );
81             }) ) {
82             croak sprintf(
83             'The %s method %s exceeded the timeout of %s seconds',
84             $self->short_class_name(), $method, $timeout,
85             );
86             }
87              
88             return $data if $method eq 'get';
89             return;
90             };
91             }
92              
93             1;
94             __END__