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 = '1.000001';
  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   # compose the query and bind values, like as_query(),
  52   # so the cache key is only affected by what the database sees
  53   # and not any other cruft in $attrs
  54   my $ref = $storage->_select_args_to_query(@{$args}[0..2], $attrs);
  55   my $connect_info = $storage->_dbi_connect_info;
  56   my ($dbname, $username);
  57   if (ref($connect_info->[0]) eq 'CODE') {
  58     my $dbh = $connect_info->[0]->();
  59     $dbname = $dbh->{Name};
  60     $username = $dbh->{Username} || '';
  61   } else {
  62     $dbname = $connect_info->[0];
  63     $username = $connect_info->[1] || '';
  64   }
  65
  66   local $Storable::canonical = 1;
  67   return Digest::SHA1::sha1_hex(Storable::nfreeze( [ $ref, $dbname, $username ] ));
  68
  69 }
  70
  71 sub _fill_data {
  72   my ($self) = @_;
  73   my $cache = $self->{cache_object};
  74   my $key = $self->{cache_key};
  75   return $cache->get($key) || do {
  76     my $data = [ $self->{inner}->all ];
  77     $cache->set($key, $data, $self->{cache_for});
  78     $data;
  79   };
  80 }
  81
  82 sub clear_cache {
  83   my ($self) = @_;
  84   $self->{cache_object}->remove($self->{cache_key});
  85   delete $self->{data};
  86 }
  87
  88 sub cache_key { shift->{cache_key} }
  89
  90 1;
  91
  92 =head1 NAME
  93
  94 DBIx::Class::Cursor::Cached - cursor class with built-in caching support
  95
  96 =head1 SYNOPSIS
  97
  98   my $schema = SchemaClass->connect(
  99     $dsn, $user, $pass, { cursor_class => 'DBIx::Class::Cursor::Cached' }
 100   );
 101
 102   $schema->default_resultset_attributes({
 103     cache_object => Cache::FileCache->new({ namespace => 'SchemaClass' }),
 104   });
 105
 106   my $rs = $schema->resultset('CD')->search(undef, { cache_for => 300 });
 107
 108   my @cds = $rs->all; # fills cache
 109
 110   $rs = $schema->resultset('CD')->search(undef, { cache_for => 300 });
 111     # refresh resultset
 112
 113   @cds = $rs->all; # uses cache, no SQL run
 114
 115   $rs->cursor->clear_cache; # deletes data from cache
 116
 117   @cds = $rs->all; # refills cache
 118
 119 =head1 AUTHOR
 120
 121 Matt S Trout <mst@shadowcat.co.uk> http://www.shadowcat.co.uk/
 122
 123 Initial development sponsored by and (c) Takkle, Inc. 2007
 124
 125 =head1 LICENSE
 126
 127 This library is free software under the same license as perl itself
 128
 129 =cut