Emulate $CDBI::Weaken_Not_Available and CDBI::Plugin::NoCache

diff --git a/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm b/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm
index 11238dc..445282c 100644 (file)
--- a/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm
+++ b/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm
@@ -12,6 +12,21 @@ __PACKAGE__->mk_classdata('purge_object_index_every' => 1000);
 __PACKAGE__->mk_classdata('live_object_index' => { });
 __PACKAGE__->mk_classdata('live_object_init_count' => { });
 
+# Caching is on by default, but a classic CDBI hack to turn it off is to
+# set this variable false.
+$Class::DBI::Weaken_Is_Available = 1
+    unless defined $Class::DBI::Weaken_Is_Available;
+__PACKAGE__->mk_classdata('__nocache' => 0);
+
+sub nocache {
+    my $class = shift;
+    
+    return $class->__nocache(@_) if @_;
+    
+    return 1 if $Class::DBI::Weaken_Is_Available == 0;
+    return $class->__nocache;
+}
+
 # Ripped from Class::DBI 0.999, all credit due to Tony Bowden for this code,
 # all blame due to me for whatever bugs I introduced porting it.
 
@@ -30,11 +45,15 @@ sub clear_object_index {
   delete @$live{ keys %$live };
 }
 
+
 # And now the fragments to tie it in to DBIx::Class::Table
 
 sub insert {
   my ($self, @rest) = @_;
   $self->next::method(@rest);
+  
+  return $self if $self->nocache;
+
     # Because the insert will die() if it can't insert into the db (or should)
     # we can be sure the object *was* inserted if we got this far. In which
     # case, given primary keys are unique and ID only returns a
@@ -55,6 +74,9 @@ sub insert {
 sub inflate_result {
   my ($class, @rest) = @_;
   my $new = $class->next::method(@rest);
+  
+  return $new if $new->nocache;
+  
   if (my $key = $new->ID) {
     #warn "Key $key";
     my $live = $class->live_object_index;

diff --git a/t/cdbi-t/object_cache.t b/t/cdbi-t/object_cache.t
new file mode 100644 (file)
index 0000000..e194a31
--- /dev/null
+++ b/t/cdbi-t/object_cache.t
@@ -0,0 +1,76 @@
+use strict;
+use Test::More;
+$| = 1;
+
+BEGIN {
+  eval "use DBIx::Class::CDBICompat;";
+  if ($@) {
+    plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+    next;
+  }
+  eval "use DBD::SQLite";
+  plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 5);
+}
+
+INIT {
+    use lib 't/testlib';
+    use Film;
+}
+
+ok +Film->create({
+    Title       => 'This Is Spinal Tap',
+    Director    => 'Rob Reiner',
+    Rating      => 'R',
+});
+
+{
+    my $film1 = Film->retrieve( "This Is Spinal Tap" );
+    my $film2 = Film->retrieve( "This Is Spinal Tap" );
+
+    $film1->Director("Marty DiBergi");
+    is $film2->Director, "Marty DiBergi", 'retrieve returns the same object';
+
+    $film1->discard_changes;
+}
+
+{
+    Film->nocache(1);
+    
+    my $film1 = Film->retrieve( "This Is Spinal Tap" );
+    my $film2 = Film->retrieve( "This Is Spinal Tap" );
+
+    $film1->Director("Marty DiBergi");
+    is $film2->Director, "Rob Reiner",
+       'caching turned off';
+    
+    $film1->discard_changes;
+}
+
+{
+    Film->nocache(0);
+
+    my $film1 = Film->retrieve( "This Is Spinal Tap" );
+    my $film2 = Film->retrieve( "This Is Spinal Tap" );
+
+    $film1->Director("Marty DiBergi");
+    is $film2->Director, "Marty DiBergi",
+       'caching back on';
+
+    $film1->discard_changes;
+}
+
+
+{
+    Film->nocache(1);
+
+    local $Class::DBI::Weaken_Is_Available = 0;
+
+    my $film1 = Film->retrieve( "This Is Spinal Tap" );
+    my $film2 = Film->retrieve( "This Is Spinal Tap" );
+
+    $film1->Director("Marty DiBergi");
+    is $film2->Director, "Rob Reiner",
+       'CDBI::Weaken_Is_Available turns off all caching';
+
+    $film1->discard_changes;
+}