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