File Coverage

blib/lib/Spike/Cache.pm
Criterion Covered Total %
statement 12 45 26.6
branch 0 16 0.0
condition 0 10 0.0
subroutine 4 8 50.0
pod 0 4 0.0
total 16 83 19.2


line stmt bran cond sub pod time code
1             package Spike::Cache;
2              
3 1     1   3 use strict;
  1         1  
  1         22  
4 1     1   3 use warnings;
  1         1  
  1         24  
5              
6 1     1   3 use base qw(Spike::Object);
  1         0  
  1         57  
7              
8 1     1   3 use Carp;
  1         1  
  1         385  
9              
10             sub new {
11 0     0 0   my $proto = shift;
12 0   0       my $class = ref $proto || $proto;
13              
14 0           return $class->SUPER::new(last_purge => time(), @_);
15             }
16              
17             sub store {
18 0     0 0   my ($self, $key) = splice @_, 0, 2;
19              
20 0           $self->purge;
21              
22 0           $self->{cache}{$key} = { ctime => $_ = time(), atime => $_, data => [ @_ ] };
23              
24 0 0         if ($self->debug) {
25 0   0       carp(($self->name || "Cache").": record '$key' stored");
26             }
27             }
28              
29             sub get {
30 0     0 0   my ($self, $key) = @_;
31              
32 0           $self->purge;
33              
34 0           my $cached = $self->{cache}{$key};
35 0 0         return if !$cached;
36              
37 0           $cached->{atime} = time();
38              
39 0 0         return wantarray ? @{$cached->{data}} : $cached->{data}[0];
  0            
40             }
41              
42             sub purge {
43 0     0 0   my ($self, $force) = shift;
44              
45 0           my $time = time();
46              
47 0 0 0       if ($force || $time - $self->last_purge > $self->purge_time) {
48             my @outdated = grep {
49 0           my $v = $self->{cache}{$_};
50 0 0         $time - $v->{ctime} > $self->max_ttl || $time - $v->{atime} > $self->max_idle_time
51 0           } keys %{$self->{cache}};
  0            
52              
53 0 0         delete @{$self->{cache}}{@outdated} if @outdated;
  0            
54              
55             my @oversized = sort {
56             $self->{cache}{$b}{atime} <=> $self->{cache}{$a}{atime}
57 0           } keys %{$self->{cache}};
  0            
  0            
58              
59 0           splice @oversized, 0, $self->max_records;
60              
61 0 0         delete @{$self->{cache}}{@oversized} if @oversized;
  0            
62              
63 0           $self->last_purge(time());
64              
65 0 0         if ($self->debug) {
66 0   0       carp(($self->name || "Cache").": ".(scalar @outdated + scalar @oversized)." records deleted");
67             }
68             }
69             }
70              
71             __PACKAGE__->mk_accessors(qw(debug name max_records max_ttl max_idle_time purge_time last_purge));
72              
73             1;