Commit | Line | Data |
f3a32bd9 |
1 | package DBIx::Class::Cursor::Cached; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | use 5.6.1; |
6 | use Storable (); |
7 | use Digest::SHA1 (); |
8 | |
748c3136 |
9 | use vars qw($VERSION); |
10 | |
e0d8ca03 |
11 | $VERSION = '1.000001'; |
748c3136 |
12 | |
f3a32bd9 |
13 | sub new { |
14 | my $class = shift; |
15 | my ($storage, $args, $attrs) = @_; |
16 | $class = ref $class if ref $class; |
17 | # This gives us the class the storage object -would- have used |
18 | # (since cursor_class is inherited Class::Accessor::Grouped type) |
19 | my $inner_class = (ref $storage)->cursor_class; |
20 | my $inner = $inner_class->new(@_); |
21 | if ($attrs->{cache_for}) { |
22 | my %args = ( |
23 | inner => $inner, |
24 | cache_for => delete $attrs->{cache_for}, |
25 | cache_object => delete $attrs->{cache_object}, |
26 | # this must be here to ensure the deletes have happened |
27 | cache_key => $class->_build_cache_key(@_), |
28 | pos => 0 |
29 | ); |
30 | return bless(\%args, $class); |
31 | } |
32 | return $inner; # return object that -would- have been constructed. |
33 | } |
34 | |
35 | sub next { |
36 | my ($self) = @_; |
e0d8ca03 |
37 | return @{($self->{data} ||= $self->_fill_data)->[$self->{pos}++]||[]}; |
f3a32bd9 |
38 | } |
39 | |
40 | sub all { |
41 | my ($self) = @_; |
42 | return @{$self->{data} ||= $self->_fill_data}; |
43 | } |
44 | |
45 | sub reset { |
46 | shift->{pos} = 0; |
47 | } |
48 | |
49 | sub _build_cache_key { |
50 | my ($class, $storage, $args, $attrs) = @_; |
51 | return Digest::SHA1::sha1_hex(Storable::nfreeze([ $args, $attrs ])); |
52 | } |
53 | |
54 | sub _fill_data { |
55 | my ($self) = @_; |
56 | my $cache = $self->{cache_object}; |
57 | my $key = $self->{cache_key}; |
58 | return $cache->get($key) || do { |
59 | my $data = [ $self->{inner}->all ]; |
60 | $cache->set($key, $data, $self->{cache_for}); |
61 | $data; |
62 | }; |
63 | } |
64 | |
65 | sub clear_cache { |
66 | my ($self) = @_; |
67 | $self->{cache_object}->remove($self->{cache_key}); |
68 | delete $self->{data}; |
69 | } |
70 | |
2ebeca8e |
71 | sub cache_key { shift->{cache_key} } |
72 | |
f3a32bd9 |
73 | 1; |
74 | |
75 | =head1 NAME |
76 | |
77 | DBIx::Class::Cursor::Cached - cursor class with built-in caching support |
78 | |
79 | =head1 SYNOPSIS |
80 | |
81 | my $schema = SchemaClass->connect( |
82 | $dsn, $user, $pass, { cursor_class => 'DBIx::Class::Cursor::Cached' } |
83 | ); |
84 | |
85 | $schema->default_resultset_attributes({ |
86 | cache_object => Cache::FileCache->new({ namespace => 'SchemaClass' }), |
87 | }); |
88 | |
89 | my $rs = $schema->resultset('CD')->search(undef, { cache_for => 300 }); |
90 | |
91 | my @cds = $rs->all; # fills cache |
92 | |
93 | $rs = $schema->resultset('CD')->search(undef, { cache_for => 300 }); |
94 | # refresh resultset |
95 | |
96 | @cds = $rs->all; # uses cache, no SQL run |
97 | |
98 | $rs->cursor->clear_cache; # deletes data from cache |
99 | |
100 | @cds = $rs->all; # refills cache |
101 | |
102 | =head1 AUTHOR |
103 | |
104 | Matt S Trout <mst@shadowcat.co.uk> http://www.shadowcat.co.uk/ |
105 | |
106 | Initial development sponsored by and (c) Takkle, Inc. 2007 |
107 | |
108 | =head1 LICENSE |
109 | |
110 | This library is free software under the same license as perl itself |
111 | |
112 | =cut |