File Coverage

blib/lib/Class/Simple/Cached.pm
Criterion Covered Total %
statement 91 97 93.8
branch 50 60 83.3
condition 6 9 66.6
subroutine 6 7 85.7
pod 1 1 100.0
total 154 174 88.5


line stmt bran cond sub pod time code
1             package Class::Simple::Cached;
2              
3 6     6   821362 use strict;
  6         48  
  6         177  
4 6     6   33 use warnings;
  6         13  
  6         147  
5 6     6   32 use Carp;
  6         11  
  6         371  
6 6     6   3259 use Class::Simple;
  6         34746  
  6         5002  
7              
8             my @ISA = ('Class::Simple');
9              
10             =head1 NAME
11              
12             Class::Simple::Cached - cache messages to an object
13              
14             =head1 VERSION
15              
16             Version 0.04
17              
18             =cut
19              
20             our $VERSION = '0.04';
21              
22             =head1 SYNOPSIS
23              
24             A sub-class of L<Class::Simple> which caches calls to read
25             the status of an object that are otherwise expensive.
26              
27             It is up to the caller to maintain the cache if the object comes out of sync with the cache,
28             for example by changing its state.
29              
30             You can use this class to create a caching layer to an object of any class
31             that works on objects with a get/set model such as:
32              
33             use Class::Simple;
34             my $obj = Class::Simple->new();
35             $obj->val($newval);
36             $oldval = $obj->val();
37              
38             =head1 SUBROUTINES/METHODS
39              
40             =head2 new
41              
42             Creates a Class::Simple::Cached object.
43              
44             It takes one mandatory parameter: cache,
45             which is either an object which understands clear(), get() and set() calls,
46             such as an L<CHI> object;
47             or is a reference to a hash where the return values are to be stored.
48              
49             It takes one optional argument: object,
50             which is an object which is taken to be the object to be cached.
51             If not given, an object of the class L<Class::Simple> is instantiated
52             and that is used.
53              
54             =cut
55              
56             sub new {
57 12     12 1 250642 my $proto = shift;
58 12   66     73 my $class = ref($proto) || $proto;
59              
60             # Use Class::Simple::Cached->new(), not Class::Simple::Cached::new()
61 12 100       39 if(!defined($class)) {
62 1         13 carp(__PACKAGE__, ' use ->new() not ::new() to instantiate');
63 1         192 return;
64             }
65              
66 11         20 my %args;
67 11 100       75 if(ref($_[0]) eq 'HASH') {
    100          
    100          
68 1         3 %args = %{$_[0]};
  1         5  
69             } elsif(ref($_[0])) {
70 1         13 Carp::carp('Usage: ', __PACKAGE__, '->new(cache => $cache [, object => $object ], %args)');
71 1         275 return;
72             } elsif(@_ % 2 == 0) {
73 8         31 %args = @_;
74             }
75              
76 10 100       36 if(!defined($args{'object'})) {
77 7         41 $args{'object'} = Class::Simple->new(%args);
78             }
79              
80 10 100 100     1727 if($args{'cache'} && ref($args{'cache'})) {
81 5         27 return bless \%args, $class;
82             }
83 5         50 Carp::carp('Usage: ', __PACKAGE__, '->new(cache => $cache [, object => $object ], %args)');
84 5         1689 return; # undef
85             }
86              
87             sub _caller_class
88             {
89 0     0   0 my $self = shift;
90              
91 0 0       0 if(ref($self->{'object'}) eq 'Class::Simple') {
92             # return $self->SUPER::_caller_class(@_);
93 0         0 return $self->Class::Simple::_caller_class(@_);
94             }
95             }
96              
97             sub AUTOLOAD {
98 38     38   16569 our $AUTOLOAD;
99 38         69 my $param = $AUTOLOAD;
100 38         223 $param =~ s/.*:://;
101              
102 38         83 my $self = shift;
103 38         74 my $cache = $self->{'cache'};
104              
105 38 100       135 if($param eq 'DESTROY') {
106 5 100       30 if(ref($cache) eq 'HASH') {
107 2         5 while(my($key, $value) = each %{$cache}) {
  6         21  
108 4         10 delete $cache->{$key};
109             }
110 2         18 return;
111             }
112 3 50 33     132 if(defined($^V) && ($^V ge 'v5.14.0')) {
113 3 50       37 return if ${^GLOBAL_PHASE} eq 'DESTRUCT'; # >= 5.14.0 only
114             }
115 3         34 $cache->clear();
116 3         66 return;
117             }
118              
119             # my $func = $self->{'object'} . "::$param";
120 33         60 my $func = $param;
121 33         55 my $object = $self->{'object'};
122              
123             # if($param =~ /^[gs]et_/) {
124             # # $param = "SUPER::$param";
125             # return $object->$func(\@_);
126             # }
127              
128 33 100       105 if(scalar(@_) == 0) {
129             # Retrieving a value
130 28         76 my $rc;
131 28 100       84 if(ref($cache) eq 'HASH') {
132 12         21 $rc = $cache->{$param};
133             } else {
134 16         63 $rc = $cache->get($param);
135             }
136 28 100       1269 if($rc) {
137 15 50       40 die $param if($rc eq 'never');
138 15 100       36 if(ref($rc) eq 'ARRAY') {
139 4         9 my @foo = @{$rc};
  4         12  
140 4 50       14 die $param if($foo[0] eq __PACKAGE__ . '>UNDEF<');
141 4 50       10 die $param if($foo[0] eq 'never');
142 4         6 return @{$rc};
  4         30  
143             }
144 11 100       24 if($rc eq __PACKAGE__ . '>UNDEF<') {
145 1         9 return;
146             }
147 10         56 return $rc;
148             }
149 13 100       52 if(wantarray) {
150 8         38 my @rc = $object->$func();
151 8 100       128 if(scalar(@rc) == 0) {
152 3         10 return;
153             }
154 5 100       18 if(ref($cache) eq 'HASH') {
155 2         4 $cache->{$param} = \@rc;
156             } else {
157 3         13 $cache->set($param, \@rc, 'never');
158             }
159 5         439 return @rc;
160             }
161 5 100       23 if(defined(my $rc = $object->$func())) {
162 4 100       34 if(ref($cache) eq 'HASH') {
163 2         12 return $cache->{$param} = $rc;
164             }
165 2         12 return $cache->set($param, $rc, 'never');
166             }
167 1 50       15 if(ref($cache) eq 'HASH') {
168 0         0 return $cache->{$param} = __PACKAGE__ . '>UNDEF<';
169             }
170 1         15 $cache->set($param, __PACKAGE__ . '>UNDEF<', 'never');
171 1         131 return;
172             }
173              
174             # $param = "SUPER::$param";
175             # return $cache->set($param, $self->$param(@_), 'never');
176 5 100       28 if($_[1]) {
177             # Storing an array
178             # We store a ref to the array, and dereference on retrieval
179 2 100       13 if(defined(my $val = $object->$func(\@_))) {
180 1 50       89 if(ref($cache) eq 'HASH') {
181 0         0 $cache->{$param} = $val;
182             } else {
183 1         5 $cache->set($param, $val, 'never');
184             }
185 1         148 return @{$val};
  1         6  
186             }
187 1 50       8 if(ref($cache) eq 'HASH') {
188 0         0 return $cache->{$param} = __PACKAGE__ . '>UNDEF<';
189             }
190 1         6 $cache->set($param, __PACKAGE__ . '>UNDEF<', 'never');
191 1         128 return;
192             }
193             # Storing a scalar
194 3 100       14 if(ref($cache) eq 'HASH') {
195 1         6 return $cache->{$param} = $object->$func($_[0]);
196             }
197 2         23 return $cache->set($param, $object->$func($_[0]), 'never');
198             }
199              
200             =head1 AUTHOR
201              
202             Nigel Horne, C<< <njh at bandsman.co.uk> >>
203              
204             =head1 BUGS
205              
206             Doesn't work with L<Memoize>.
207              
208             Only works on messages that take no arguments.
209              
210             Please report any bugs or feature requests to L<https://github.com/nigelhorne/Class-Simple-Readonly/issues>.
211             I will be notified, and then you'll
212             automatically be notified of progress on your bug as I make changes.
213              
214             =head1 SEE ALSO
215              
216             L<Class::Simple>, L<CHI>
217              
218             =head1 SUPPORT
219              
220             You can find documentation for this module with the perldoc command.
221              
222             perldoc Class::Simple::Cached
223              
224             You can also look for information at:
225              
226             =over 4
227              
228             =item * MetaCPAN
229              
230             L<https://metacpan.org/release/Class-Simple-Cached>
231              
232             =item * Source Repository
233              
234             L<https://github.com/nigelhorne/Class-Simple-Readonly-Cached>
235              
236             =item * CPANTS
237              
238             L<http://cpants.cpanauthors.org/dist/Class-Simple-Cached>
239              
240             =item * CPAN Testers' Matrix
241              
242             L<http://matrix.cpantesters.org/?dist=Class-Simple-Cached>
243              
244             =item * CPAN Ratings
245              
246             L<http://cpanratings.perl.org/d/Class-Simple-Cached>
247              
248             =item * CPAN Testers Dependencies
249              
250             L<http://deps.cpantesters.org/?module=Class::Simple::Cached>
251              
252             =back
253              
254             =head1 LICENCE AND COPYRIGHT
255              
256             Author Nigel Horne: C<njh@bandsman.co.uk>
257             Copyright (C) 2019-2021, Nigel Horne
258              
259             Usage is subject to licence terms.
260             The licence terms of this software are as follows:
261             Personal single user, single computer use: GPL2
262             All other users (including Commercial, Charity, Educational, Government)
263             must apply in writing for a licence for use from Nigel Horne at the
264             above e-mail.
265             =cut
266              
267             1;