From: Matt S Trout <mst@shadowcat.co.uk>
Date: Sun, 5 Aug 2007 15:43:08 +0000 (+0000)
Subject: initial import of DBIx::Class::Cursor::Cached
X-Git-Tag: v1.1.0~12
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f3a32bd9e5d9793973b2a4d17eb695465c72bdc0;p=dbsrgits%2FDBIx-Class-Cursor-Cached.git

initial import of DBIx::Class::Cursor::Cached
---

f3a32bd9e5d9793973b2a4d17eb695465c72bdc0
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644
index 0000000..dab0fc1
--- /dev/null
+++ b/Makefile.PL
@@ -0,0 +1,13 @@
+use strict;
+use warnings;
+use inc::Module::Install 0.67;
+
+name 'DBIx-Class-Cursor-Cached';
+all_from 'lib/DBIx/Class/Cursor/Cached.pm';
+
+requires 'DBIx::Class' => '0.08004';
+requires 'Digest::SHA1';
+
+auto_install;
+
+WriteAll;
diff --git a/lib/DBIx/Class/Cursor/Cached.pm b/lib/DBIx/Class/Cursor/Cached.pm
new file mode 100644
index 0000000..b27ed81
--- /dev/null
+++ b/lib/DBIx/Class/Cursor/Cached.pm
@@ -0,0 +1,106 @@
+package DBIx::Class::Cursor::Cached;
+
+use strict;
+use warnings;
+use 5.6.1;
+use Storable ();
+use Digest::SHA1 ();
+
+sub new {
+  my $class = shift;
+  my ($storage, $args, $attrs) = @_;
+  $class = ref $class if ref $class;
+  # This gives us the class the storage object -would- have used
+  # (since cursor_class is inherited Class::Accessor::Grouped type)
+  my $inner_class = (ref $storage)->cursor_class;
+  my $inner = $inner_class->new(@_);
+  if ($attrs->{cache_for}) {
+    my %args = (
+      inner => $inner,
+      cache_for => delete $attrs->{cache_for},
+      cache_object => delete $attrs->{cache_object},
+      # this must be here to ensure the deletes have happened
+      cache_key => $class->_build_cache_key(@_),
+      pos => 0
+    );
+    return bless(\%args, $class);
+  }
+  return $inner; # return object that -would- have been constructed.
+}
+
+sub next {
+  my ($self) = @_;
+  return @{($self->{data} ||= $self->_fill_data)->{$self->{pos}++}||[]};
+}
+
+sub all {
+  my ($self) = @_;
+  return @{$self->{data} ||= $self->_fill_data};
+}
+
+sub reset {
+  shift->{pos} = 0;
+}
+
+sub _build_cache_key {
+  my ($class, $storage, $args, $attrs) = @_;
+  return Digest::SHA1::sha1_hex(Storable::nfreeze([ $args, $attrs ]));
+}
+
+sub _fill_data {
+  my ($self) = @_;
+  my $cache = $self->{cache_object};
+  my $key = $self->{cache_key};
+  return $cache->get($key) || do {
+    my $data = [ $self->{inner}->all ];
+    $cache->set($key, $data, $self->{cache_for});
+    $data;
+  };
+}
+
+sub clear_cache {
+  my ($self) = @_;
+  $self->{cache_object}->remove($self->{cache_key});
+  delete $self->{data};
+}
+
+1;
+
+=head1 NAME
+
+DBIx::Class::Cursor::Cached - cursor class with built-in caching support
+
+=head1 SYNOPSIS
+
+  my $schema = SchemaClass->connect(
+    $dsn, $user, $pass, { cursor_class => 'DBIx::Class::Cursor::Cached' }
+  );
+
+  $schema->default_resultset_attributes({
+    cache_object => Cache::FileCache->new({ namespace => 'SchemaClass' }),
+  });
+
+  my $rs = $schema->resultset('CD')->search(undef, { cache_for => 300 });
+
+  my @cds = $rs->all; # fills cache
+
+  $rs = $schema->resultset('CD')->search(undef, { cache_for => 300 });
+    # refresh resultset
+
+  @cds = $rs->all; # uses cache, no SQL run
+
+  $rs->cursor->clear_cache; # deletes data from cache
+
+  @cds = $rs->all; # refills cache
+
+=head1 AUTHOR
+
+Matt S Trout <mst@shadowcat.co.uk> http://www.shadowcat.co.uk/
+
+Initial development sponsored by and (c) Takkle, Inc. 2007
+
+=head1 LICENSE
+
+This library is free software under the same license as perl itself
+
+=cut