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 sub new {
  10   my $class = shift;
  11   my ($storage, $args, $attrs) = @_;
  12   $class = ref $class if ref $class;
  13   # This gives us the class the storage object -would- have used
  14   # (since cursor_class is inherited Class::Accessor::Grouped type)
  15   my $inner_class = (ref $storage)->cursor_class;
  16   my $inner = $inner_class->new(@_);
  17   if ($attrs->{cache_for}) {
  18     my %args = (
  19       inner => $inner,
  20       cache_for => delete $attrs->{cache_for},
  21       cache_object => delete $attrs->{cache_object},
  22       # this must be here to ensure the deletes have happened
  23       cache_key => $class->_build_cache_key(@_),
  24       pos => 0
  25     );
  26     return bless(\%args, $class);
  27   }
  28   return $inner; # return object that -would- have been constructed.
  29 }
  30
  31 sub next {
  32   my ($self) = @_;
  33   return @{($self->{data} ||= $self->_fill_data)->{$self->{pos}++}||[]};
  34 }
  35
  36 sub all {
  37   my ($self) = @_;
  38   return @{$self->{data} ||= $self->_fill_data};
  39 }
  40
  41 sub reset {
  42   shift->{pos} = 0;
  43 }
  44
  45 sub _build_cache_key {
  46   my ($class, $storage, $args, $attrs) = @_;
  47   return Digest::SHA1::sha1_hex(Storable::nfreeze([ $args, $attrs ]));
  48 }
  49
  50 sub _fill_data {
  51   my ($self) = @_;
  52   my $cache = $self->{cache_object};
  53   my $key = $self->{cache_key};
  54   return $cache->get($key) || do {
  55     my $data = [ $self->{inner}->all ];
  56     $cache->set($key, $data, $self->{cache_for});
  57     $data;
  58   };
  59 }
  60
  61 sub clear_cache {
  62   my ($self) = @_;
  63   $self->{cache_object}->remove($self->{cache_key});
  64   delete $self->{data};
  65 }
  66
  67 1;
  68
  69 =head1 NAME
  70
  71 DBIx::Class::Cursor::Cached - cursor class with built-in caching support
  72
  73 =head1 SYNOPSIS
  74
  75   my $schema = SchemaClass->connect(
  76     $dsn, $user, $pass, { cursor_class => 'DBIx::Class::Cursor::Cached' }
  77   );
  78
  79   $schema->default_resultset_attributes({
  80     cache_object => Cache::FileCache->new({ namespace => 'SchemaClass' }),
  81   });
  82
  83   my $rs = $schema->resultset('CD')->search(undef, { cache_for => 300 });
  84
  85   my @cds = $rs->all; # fills cache
  86
  87   $rs = $schema->resultset('CD')->search(undef, { cache_for => 300 });
  88     # refresh resultset
  89
  90   @cds = $rs->all; # uses cache, no SQL run
  91
  92   $rs->cursor->clear_cache; # deletes data from cache
  93
  94   @cds = $rs->all; # refills cache
  95
  96 =head1 AUTHOR
  97
  98 Matt S Trout <mst@shadowcat.co.uk> http://www.shadowcat.co.uk/
  99
 100 Initial development sponsored by and (c) Takkle, Inc. 2007
 101
 102 =head1 LICENSE
 103
 104 This library is free software under the same license as perl itself
 105
 106 =cut