Added has_column and column_info methods

[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / ObjectCache.pm

diff --git a/lib/DBIx/Class/ObjectCache.pm b/lib/DBIx/Class/ObjectCache.pm
index 1d8a082..39fb218 100644 (file)
--- a/lib/DBIx/Class/ObjectCache.pm
+++ b/lib/DBIx/Class/ObjectCache.pm
@@ -7,6 +7,30 @@ use base qw/Class::Data::Inheritable/;
 
 __PACKAGE__->mk_classdata('cache');
 
+=head1 NAME 
+
+    DBIx::Class::ObjectCache - Cache rows by primary key (EXPERIMENTAL)
+
+=head1 SYNOPSIS
+
+    # in your class definition
+    use Cache::FastMmmap;
+    __PACKAGE__->cache(Cache::FastMmap->new);
+
+=head1 DESCRIPTION
+
+This class implements a simple object cache. It should be loaded before most (all?) other 
+L<DBIx::Class> components. Note that, in its current state, this code is rather experimental. 
+The only time the cache is made use of is on calls to $obj->find. This can still result in a 
+significant savings, but more intelligent caching, e.g. of the resultset of a has_many call,
+is currently not possible. It is not difficult, however, to implement additional caching
+on top of this module. 
+
+The cache is stored in a package variable called C<cache>. It can be set to any object that 
+implements the required C<get>, C<set>, and C<remove> methods. 
+
+=cut
+
 sub insert {
   my $self = shift;
   $self->NEXT::ACTUAL::insert(@_);
@@ -22,7 +46,7 @@ sub find {
   # but, it's a start anyway. probably find in PK.pm needs to
   # call a hook, or some such thing. -Dave/ningu
   my ($object,$key);
-  my @pk = keys %{$self->_primaries};
+  my @pk = $self->primary_columns;
   if (ref $vals[0] eq 'HASH') {
     my $cond = $vals[0]->{'-and'};
     $key = $self->_create_ID(%{$cond->[0]}) if ref $cond eq 'ARRAY';
@@ -34,6 +58,7 @@ sub find {
     $key = $self->_create_ID(@vals);
   }
   if ($key and $object = $self->cache->get($key)) {
+    #warn "retrieving cached item $key";
     return $object;
   }
   
@@ -44,8 +69,9 @@ sub find {
 
 sub update {
   my $self = shift;
-  $self->cache->remove($self->ID) if $self->cache;
-  return $self->NEXT::ACTUAL::update(@_);
+  my $new = $self->NEXT::ACTUAL::update(@_);
+  $self->_insert_into_cache if $self->cache;
+  return;
 }
 
 sub delete {
@@ -54,13 +80,29 @@ sub delete {
   return $self->NEXT::ACTUAL::delete(@_);
 }
 
+sub _row_to_object {
+  my $self = shift;
+  my $new = $self->NEXT::ACTUAL::_row_to_object(@_);
+  $new->_insert_into_cache if $self->cache;
+  return $new;
+}
+
 sub _insert_into_cache {
   my ($self) = @_;
   if (my $key = $self->ID) {
-    if (my $object = $self->new( $self->{_column_data} )) {
-      $self->cache->set($key,$object);
-    }
+    my $object = bless { %$self }, ref $self;
+    $self->cache->set($key,$object);
   }
 }
 
 1;
+
+=head1 AUTHORS
+
+David Kamholz <davekam@pobox.com>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut