1 package DBIx::Class::Cursor::Cached;
8 use Carp::Clan qw/^DBIx::Class/;
10 use vars qw($VERSION);
12 $VERSION = '1.001003';
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}) {
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(@_),
31 return bless(\%args, $class);
33 return $inner; # return object that -would- have been constructed.
38 return @{($self->{data} ||= $self->_fill_data)->[$self->{pos}++]||[]};
43 return @{$self->{data} ||= $self->_fill_data};
50 sub _build_cache_key {
51 my ($class, $storage, $args, $attrs) = @_;
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);
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] };
63 carp "Invoking connector coderef $connect_info->[0] in order to obtain cache-lookup information";
64 $conn = $connect_info->[0]->();
68 return $class->_build_cache_key_hash([ $ref, $conn->{Name}, $conn->{Username} || '' ]);
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 ));
79 my $cache = $self->{cache_object};
80 my $key = $self->{cache_key};
81 return $cache->get($key) || do {
82 my $data = $self->_fill_data_fetch_all();
83 $cache->set($key, $data, $self->{cache_for});
88 sub _fill_data_fetch_all {
90 return [ $self->{inner}->all ];
95 $self->{cache_object}->remove($self->{cache_key});
99 sub cache_key { shift->{cache_key} }
105 DBIx::Class::Cursor::Cached - cursor class with built-in caching support
109 my $schema = SchemaClass->connect(
110 $dsn, $user, $pass, { cursor_class => 'DBIx::Class::Cursor::Cached' }
113 $schema->default_resultset_attributes({
114 cache_object => Cache::FileCache->new({ namespace => 'SchemaClass' }),
117 my $rs = $schema->resultset('CD')->search(undef, { cache_for => 300 });
119 my @cds = $rs->all; # fills cache
121 $rs = $schema->resultset('CD')->search(undef, { cache_for => 300 });
124 @cds = $rs->all; # uses cache, no SQL run
126 $rs->cursor->clear_cache; # deletes data from cache
128 @cds = $rs->all; # refills cache
132 Matt S Trout <mst@shadowcat.co.uk> http://www.shadowcat.co.uk/
134 Initial development sponsored by and (c) Takkle, Inc. 2007
138 This library is free software under the same license as perl itself