lib/DBIx/Class/Cursor/Cached.pm

   1 package DBIx::Class::Cursor::Cached;
   2
   3 use strict;
   4 use warnings;
   5 use 5.008001;
   6 use Storable ();
   7 use Digest::SHA ();
   8 use Carp::Clan qw/^DBIx::Class/;
   9
  10 use vars qw($VERSION);
  11
  12 $VERSION = '1.001002';
  13
  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) = @_;
  38   return @{($self->{data} ||= $self->_fill_data)->[$self->{pos}++]||[]};
  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) = @_;
  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);
  56
  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     }
  66   }
  67
  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 ));
  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 {
  82     my $data = $self->_fill_data_fetch_all();
  83     $cache->set($key, $data, $self->{cache_for});
  84     $data;
  85   };
  86 }
  87
  88 sub _fill_data_fetch_all {
  89     my ($self) = @_;
  90     return [ $self->{inner}->all ];
  91 }
  92
  93 sub clear_cache {
  94   my ($self) = @_;
  95   $self->{cache_object}->remove($self->{cache_key});
  96   delete $self->{data};
  97 }
  98
  99 sub cache_key { shift->{cache_key} }
 100
 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