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 (); |
a7f2916a |
8 | use Carp::Clan qw/^DBIx::Class/; |
f3a32bd9 |
9 | |
748c3136 |
10 | use vars qw($VERSION); |
11 | |
2c7ed9c8 |
12 | $VERSION = '1.001000'; |
748c3136 |
13 | |
f3a32bd9 |
14 | sub new { |
15 | my $class = shift; |
16 | my ($storage, $args, $attrs) = @_; |
17 | $class = ref $class if ref $class; |
18 | # This gives us the class the storage object -would- have used |
19 | # (since cursor_class is inherited Class::Accessor::Grouped type) |
20 | my $inner_class = (ref $storage)->cursor_class; |
21 | my $inner = $inner_class->new(@_); |
22 | if ($attrs->{cache_for}) { |
23 | my %args = ( |
24 | inner => $inner, |
25 | cache_for => delete $attrs->{cache_for}, |
26 | cache_object => delete $attrs->{cache_object}, |
27 | # this must be here to ensure the deletes have happened |
28 | cache_key => $class->_build_cache_key(@_), |
29 | pos => 0 |
30 | ); |
31 | return bless(\%args, $class); |
32 | } |
33 | return $inner; # return object that -would- have been constructed. |
34 | } |
35 | |
36 | sub next { |
37 | my ($self) = @_; |
e0d8ca03 |
38 | return @{($self->{data} ||= $self->_fill_data)->[$self->{pos}++]||[]}; |
f3a32bd9 |
39 | } |
40 | |
41 | sub all { |
42 | my ($self) = @_; |
43 | return @{$self->{data} ||= $self->_fill_data}; |
44 | } |
45 | |
46 | sub reset { |
47 | shift->{pos} = 0; |
48 | } |
49 | |
50 | sub _build_cache_key { |
51 | my ($class, $storage, $args, $attrs) = @_; |
c9495327 |
52 | # compose the query and bind values, like as_query(), |
53 | # so the cache key is only affected by what the database sees |
54 | # and not any other cruft in $attrs |
55 | my $ref = $storage->_select_args_to_query(@{$args}[0..2], $attrs); |
a7f2916a |
56 | |
366de7a2 |
57 | my $conn; |
58 | if (! ($conn = $storage->_dbh) ) { |
59 | my $connect_info = $storage->_dbi_connect_info; |
60 | if (! ref($connect_info->[0]) ) { |
61 | $conn = { Name => $connect_info->[0], Username => $connect_info->[1] }; |
62 | } else { |
63 | carp "Invoking connector coderef $connect_info->[0] in order to obtain cache-lookup information"; |
64 | $conn = $connect_info->[0]->(); |
65 | } |
c9495327 |
66 | } |
67 | |
68 | local $Storable::canonical = 1; |
366de7a2 |
69 | return Digest::SHA1::sha1_hex(Storable::nfreeze( [ $ref, $conn->{Name}, $conn->{Username} || '' ] )); |
c9495327 |
70 | |
f3a32bd9 |
71 | } |
72 | |
73 | sub _fill_data { |
74 | my ($self) = @_; |
75 | my $cache = $self->{cache_object}; |
76 | my $key = $self->{cache_key}; |
77 | return $cache->get($key) || do { |
78 | my $data = [ $self->{inner}->all ]; |
79 | $cache->set($key, $data, $self->{cache_for}); |
80 | $data; |
81 | }; |
82 | } |
83 | |
84 | sub clear_cache { |
85 | my ($self) = @_; |
86 | $self->{cache_object}->remove($self->{cache_key}); |
87 | delete $self->{data}; |
88 | } |
89 | |
2ebeca8e |
90 | sub cache_key { shift->{cache_key} } |
91 | |
f3a32bd9 |
92 | 1; |
93 | |
94 | =head1 NAME |
95 | |
96 | DBIx::Class::Cursor::Cached - cursor class with built-in caching support |
97 | |
98 | =head1 SYNOPSIS |
99 | |
100 | my $schema = SchemaClass->connect( |
101 | $dsn, $user, $pass, { cursor_class => 'DBIx::Class::Cursor::Cached' } |
102 | ); |
103 | |
104 | $schema->default_resultset_attributes({ |
105 | cache_object => Cache::FileCache->new({ namespace => 'SchemaClass' }), |
106 | }); |
107 | |
108 | my $rs = $schema->resultset('CD')->search(undef, { cache_for => 300 }); |
109 | |
110 | my @cds = $rs->all; # fills cache |
111 | |
112 | $rs = $schema->resultset('CD')->search(undef, { cache_for => 300 }); |
113 | # refresh resultset |
114 | |
115 | @cds = $rs->all; # uses cache, no SQL run |
116 | |
117 | $rs->cursor->clear_cache; # deletes data from cache |
118 | |
119 | @cds = $rs->all; # refills cache |
120 | |
121 | =head1 AUTHOR |
122 | |
123 | Matt S Trout <mst@shadowcat.co.uk> http://www.shadowcat.co.uk/ |
124 | |
125 | Initial development sponsored by and (c) Takkle, Inc. 2007 |
126 | |
127 | =head1 LICENSE |
128 | |
129 | This library is free software under the same license as perl itself |
130 | |
131 | =cut |