lib/DBIx/Class/ObjectCache.pm

   1 package DBIx::Class::ObjectCache;
   2
   3 use strict;
   4 use warnings;
   5
   6 use base qw/Class::Data::Inheritable/;
   7
   8 __PACKAGE__->mk_classdata('cache');
   9
  10 =head1 NAME
  11
  12     DBIx::Class::ObjectCache - Cache rows by primary key (EXPERIMENTAL)
  13
  14 =head1 SYNOPSIS
  15
  16     # in your class definition
  17     use Cache::FastMmmap;
  18     __PACKAGE__->cache(Cache::FastMmap->new);
  19
  20 =head1 DESCRIPTION
  21
  22 This class implements a simple object cache. It should be loaded before most (all?) other
  23 L<DBIx::Class> components. Note that, in its current state, this code is rather experimental.
  24 The only time the cache is made use of is on calls to $obj->find. This can still result in a
  25 significant savings, but more intelligent caching, e.g. of the resultset of a has_many call,
  26 is currently not possible. It is not difficult, however, to implement additional caching
  27 on top of this module.
  28
  29 The cache is stored in a package variable called C<cache>. It can be set to any object that
  30 implements the required C<get>, C<set>, and C<remove> methods.
  31
  32 =cut
  33
  34 sub insert {
  35   my $self = shift;
  36   $self->NEXT::ACTUAL::insert(@_);
  37   $self->_insert_into_cache if $self->cache;
  38   return $self;
  39 }
  40
  41 sub find {
  42   my ($self,@vals) = @_;
  43   return $self->NEXT::ACTUAL::find(@vals) unless $self->cache;
  44
  45   # this is a terrible hack here. I know it can be improved.
  46   # but, it's a start anyway. probably find in PK.pm needs to
  47   # call a hook, or some such thing. -Dave/ningu
  48   my ($object,$key);
  49   my @pk = $self->primary_columns;
  50   if (ref $vals[0] eq 'HASH') {
  51     my $cond = $vals[0]->{'-and'};
  52     $key = $self->_create_ID(%{$cond->[0]}) if ref $cond eq 'ARRAY';
  53   } elsif (@pk == @vals) {
  54     my %data;
  55     @data{@pk} = @vals;
  56     $key = $self->_create_ID(%data);
  57   } else {
  58     $key = $self->_create_ID(@vals);
  59   }
  60   if ($key and $object = $self->cache->get($key)) {
  61     #warn "retrieving cached item $key";
  62     return $object;
  63   }
  64
  65   $object = $self->NEXT::ACTUAL::find(@vals);
  66   $object->_insert_into_cache if $object;
  67   return $object;
  68 }
  69
  70 sub update {
  71   my $self = shift;
  72   my $new = $self->NEXT::ACTUAL::update(@_);
  73   $self->_insert_into_cache if $self->cache;
  74   return;
  75 }
  76
  77 sub delete {
  78   my $self = shift;
  79   $self->cache->remove($self->ID) if $self->cache;
  80   return $self->NEXT::ACTUAL::delete(@_);
  81 }
  82
  83 sub _row_to_object {
  84   my $self = shift;
  85   my $new = $self->NEXT::ACTUAL::_row_to_object(@_);
  86   $new->_insert_into_cache if $self->cache;
  87   return $new;
  88 }
  89
  90 sub _insert_into_cache {
  91   my ($self) = @_;
  92   if (my $key = $self->ID) {
  93     my $object = bless { %$self }, ref $self;
  94     $self->cache->set($key,$object);
  95   }
  96 }
  97
  98 1;
  99
 100 =head1 AUTHORS
 101
 102 David Kamholz <davekam@pobox.com>
 103
 104 =head1 LICENSE
 105
 106 You may distribute this code under the same terms as Perl itself.
 107
 108 =cut