lib/DBIx/Class/Cursor/Cached.pm

   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
   9 use vars qw($VERSION);
  10
  11 $VERSION = '0.999001_01';
  12
  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) = @_;
  37   return @{($self->{data} ||= $self->_fill_data)->{$self->{pos}++}||[]};
  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
  71 sub cache_key { shift->{cache_key} }
  72
  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