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   local $Storable::canonical = 1;
  69   return Digest::SHA::sha1_hex(Storable::nfreeze( [ $ref, $conn->{Name}, $conn->{Username} || '' ] ));
  70
  71 }
  72
  73 sub _fill_data {
  74   my ($self) = @_;
  75   my $cache = $self->{cache_object};
  76   my $key = $self->{cache_key};
  77   return $cache->get($key) || do {
  78     my $data = [ $self->{inner}->all ];
  79     $cache->set($key, $data, $self->{cache_for});
  80     $data;
  81   };
  82 }
  83
  84 sub clear_cache {
  85   my ($self) = @_;
  86   $self->{cache_object}->remove($self->{cache_key});
  87   delete $self->{data};
  88 }
  89
  90 sub cache_key { shift->{cache_key} }
  91
  92 1;
  93
  94 =head1 NAME
  95
  96 DBIx::Class::Cursor::Cached - cursor class with built-in caching support
  97
  98 =head1 SYNOPSIS
  99
 100   my $schema = SchemaClass->connect(
 101     $dsn, $user, $pass, { cursor_class => 'DBIx::Class::Cursor::Cached' }
 102   );
 103
 104   $schema->default_resultset_attributes({
 105     cache_object => Cache::FileCache->new({ namespace => 'SchemaClass' }),
 106   });
 107
 108   my $rs = $schema->resultset('CD')->search(undef, { cache_for => 300 });
 109
 110   my @cds = $rs->all; # fills cache
 111
 112   $rs = $schema->resultset('CD')->search(undef, { cache_for => 300 });
 113     # refresh resultset
 114
 115   @cds = $rs->all; # uses cache, no SQL run
 116
 117   $rs->cursor->clear_cache; # deletes data from cache
 118
 119   @cds = $rs->all; # refills cache
 120
 121 =head1 AUTHOR
 122
 123 Matt S Trout <mst@shadowcat.co.uk> http://www.shadowcat.co.uk/
 124
 125 Initial development sponsored by and (c) Takkle, Inc. 2007
 126
 127 =head1 LICENSE
 128
 129 This library is free software under the same license as perl itself
 130
 131 =cut