Broke everything (C3 branch)
[dbsrgits/DBIx-Class.git] / 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::method(@_);
37   $self->_insert_into_cache if $self->cache;  
38   return $self;
39 }
40
41 sub find {
42   my ($self,@vals) = @_;
43   return $self->next::method(@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::method(@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::method(@_);
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::method(@_);
81 }
82
83 sub _row_to_object {
84   my $self = shift;
85   my $new = $self->next::method(@_);
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