Merge 'trunk' into 'DBIx-Class-C3'
[dbsrgits/DBIx-Class-Historic.git] / lib / DBIx / Class / ObjectCache.pm
CommitLineData
bb37a8cf 1package DBIx::Class::ObjectCache;
2
3use strict;
4use warnings;
5
1edd1722 6use base qw/DBIx::Class/;
bb37a8cf 7
8__PACKAGE__->mk_classdata('cache');
9
81c92ae6 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
22This class implements a simple object cache. It should be loaded before most (all?) other
23L<DBIx::Class> components. Note that, in its current state, this code is rather experimental.
24The only time the cache is made use of is on calls to $obj->find. This can still result in a
25significant savings, but more intelligent caching, e.g. of the resultset of a has_many call,
26is currently not possible. It is not difficult, however, to implement additional caching
27on top of this module.
28
29The cache is stored in a package variable called C<cache>. It can be set to any object that
30implements the required C<get>, C<set>, and C<remove> methods.
31
32=cut
33
bb37a8cf 34sub insert {
35 my $self = shift;
147dd158 36 $self->next::method(@_);
bb37a8cf 37 $self->_insert_into_cache if $self->cache;
38 return $self;
39}
40
41sub find {
42 my ($self,@vals) = @_;
147dd158 43 return $self->next::method(@vals) unless $self->cache;
bb37a8cf 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);
103647d5 49 my @pk = $self->primary_columns;
bb37a8cf 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)) {
81c92ae6 61 #warn "retrieving cached item $key";
bb37a8cf 62 return $object;
63 }
64
147dd158 65 $object = $self->next::method(@vals);
bb37a8cf 66 $object->_insert_into_cache if $object;
67 return $object;
68}
69
70sub update {
71 my $self = shift;
147dd158 72 my $new = $self->next::method(@_);
81c92ae6 73 $self->_insert_into_cache if $self->cache;
74 return;
bb37a8cf 75}
76
77sub delete {
78 my $self = shift;
79 $self->cache->remove($self->ID) if $self->cache;
147dd158 80 return $self->next::method(@_);
bb37a8cf 81}
82
81c92ae6 83sub _row_to_object {
84 my $self = shift;
147dd158 85 my $new = $self->next::method(@_);
81c92ae6 86 $new->_insert_into_cache if $self->cache;
87 return $new;
88}
89
bb37a8cf 90sub _insert_into_cache {
91 my ($self) = @_;
92 if (my $key = $self->ID) {
81c92ae6 93 my $object = bless { %$self }, ref $self;
94 $self->cache->set($key,$object);
bb37a8cf 95 }
96}
97
981;
81c92ae6 99
100=head1 AUTHORS
101
102David Kamholz <davekam@pobox.com>
103
104=head1 LICENSE
105
106You may distribute this code under the same terms as Perl itself.
107
108=cut