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) = @_; |
c9495327 |
51 | # compose the query and bind values, like as_query(), |
52 | # so the cache key is only affected by what the database sees |
53 | # and not any other cruft in $attrs |
54 | my $ref = $storage->_select_args_to_query(@{$args}[0..2], $attrs); |
55 | my $connect_info = $storage->_dbi_connect_info; |
56 | my ($dbname, $username); |
57 | if (ref($connect_info->[0]) eq 'CODE') { |
58 | my $dbh = $connect_info->[0]->(); |
59 | $dbname = $dbh->{Name}; |
60 | $username = $dbh->{Username} || ''; |
61 | } else { |
62 | $dbname = $connect_info->[0]; |
63 | $username = $connect_info->[1] || ''; |
64 | } |
65 | |
66 | local $Storable::canonical = 1; |
67 | return Digest::SHA1::sha1_hex(Storable::nfreeze( [ $ref, $dbname, $username ] )); |
68 | |
f3a32bd9 |
69 | } |
70 | |
71 | sub _fill_data { |
72 | my ($self) = @_; |
73 | my $cache = $self->{cache_object}; |
74 | my $key = $self->{cache_key}; |
75 | return $cache->get($key) || do { |
76 | my $data = [ $self->{inner}->all ]; |
77 | $cache->set($key, $data, $self->{cache_for}); |
78 | $data; |
79 | }; |
80 | } |
81 | |
82 | sub clear_cache { |
83 | my ($self) = @_; |
84 | $self->{cache_object}->remove($self->{cache_key}); |
85 | delete $self->{data}; |
86 | } |
87 | |
2ebeca8e |
88 | sub cache_key { shift->{cache_key} } |
89 | |
f3a32bd9 |
90 | 1; |
91 | |
92 | =head1 NAME |
93 | |
94 | DBIx::Class::Cursor::Cached - cursor class with built-in caching support |
95 | |
96 | =head1 SYNOPSIS |
97 | |
98 | my $schema = SchemaClass->connect( |
99 | $dsn, $user, $pass, { cursor_class => 'DBIx::Class::Cursor::Cached' } |
100 | ); |
101 | |
102 | $schema->default_resultset_attributes({ |
103 | cache_object => Cache::FileCache->new({ namespace => 'SchemaClass' }), |
104 | }); |
105 | |
106 | my $rs = $schema->resultset('CD')->search(undef, { cache_for => 300 }); |
107 | |
108 | my @cds = $rs->all; # fills cache |
109 | |
110 | $rs = $schema->resultset('CD')->search(undef, { cache_for => 300 }); |
111 | # refresh resultset |
112 | |
113 | @cds = $rs->all; # uses cache, no SQL run |
114 | |
115 | $rs->cursor->clear_cache; # deletes data from cache |
116 | |
117 | @cds = $rs->all; # refills cache |
118 | |
119 | =head1 AUTHOR |
120 | |
121 | Matt S Trout <mst@shadowcat.co.uk> http://www.shadowcat.co.uk/ |
122 | |
123 | Initial development sponsored by and (c) Takkle, Inc. 2007 |
124 | |
125 | =head1 LICENSE |
126 | |
127 | This library is free software under the same license as perl itself |
128 | |
129 | =cut |