Commit | Line | Data |
f3a32bd9 |
1 | package DBIx::Class::Cursor::Cached; |
2 | |
3 | use strict; |
4 | use warnings; |
5fa7c83c |
5 | use 5.008001; |
f3a32bd9 |
6 | use Storable (); |
a91d66a7 |
7 | use Digest::SHA (); |
a7f2916a |
8 | use Carp::Clan qw/^DBIx::Class/; |
f3a32bd9 |
9 | |
748c3136 |
10 | use vars qw($VERSION); |
11 | |
77a75bbf |
12 | $VERSION = '1.001003'; |
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 | } |
c9495327 |
67 | |
9f0680b8 |
68 | return $class->_build_cache_key_hash([ $ref, $conn->{Name}, $conn->{Username} || '' ]); |
69 | } |
70 | |
71 | sub _build_cache_key_hash { |
72 | my ($class, $key_data) = @_; |
73 | local $Storable::canonical = 1; |
74 | return Digest::SHA::sha1_hex(Storable::nfreeze( $key_data )); |
f3a32bd9 |
75 | } |
76 | |
77 | sub _fill_data { |
78 | my ($self) = @_; |
79 | my $cache = $self->{cache_object}; |
80 | my $key = $self->{cache_key}; |
81 | return $cache->get($key) || do { |
9f0680b8 |
82 | my $data = $self->_fill_data_fetch_all(); |
f3a32bd9 |
83 | $cache->set($key, $data, $self->{cache_for}); |
84 | $data; |
85 | }; |
86 | } |
87 | |
9f0680b8 |
88 | sub _fill_data_fetch_all { |
89 | my ($self) = @_; |
90 | return [ $self->{inner}->all ]; |
91 | } |
92 | |
f3a32bd9 |
93 | sub clear_cache { |
94 | my ($self) = @_; |
95 | $self->{cache_object}->remove($self->{cache_key}); |
96 | delete $self->{data}; |
97 | } |
98 | |
2ebeca8e |
99 | sub cache_key { shift->{cache_key} } |
100 | |
f3a32bd9 |
101 | 1; |
102 | |
103 | =head1 NAME |
104 | |
105 | DBIx::Class::Cursor::Cached - cursor class with built-in caching support |
106 | |
107 | =head1 SYNOPSIS |
108 | |
109 | my $schema = SchemaClass->connect( |
110 | $dsn, $user, $pass, { cursor_class => 'DBIx::Class::Cursor::Cached' } |
111 | ); |
112 | |
113 | $schema->default_resultset_attributes({ |
114 | cache_object => Cache::FileCache->new({ namespace => 'SchemaClass' }), |
115 | }); |
116 | |
117 | my $rs = $schema->resultset('CD')->search(undef, { cache_for => 300 }); |
118 | |
119 | my @cds = $rs->all; # fills cache |
120 | |
121 | $rs = $schema->resultset('CD')->search(undef, { cache_for => 300 }); |
122 | # refresh resultset |
123 | |
124 | @cds = $rs->all; # uses cache, no SQL run |
125 | |
126 | $rs->cursor->clear_cache; # deletes data from cache |
127 | |
128 | @cds = $rs->all; # refills cache |
129 | |
130 | =head1 AUTHOR |
131 | |
132 | Matt S Trout <mst@shadowcat.co.uk> http://www.shadowcat.co.uk/ |
133 | |
134 | Initial development sponsored by and (c) Takkle, Inc. 2007 |
135 | |
136 | =head1 LICENSE |
137 | |
138 | This library is free software under the same license as perl itself |
139 | |
140 | =cut |