From: Rob Kinyon <rob.kinyon@gmail.com>
Date: Wed, 17 Feb 2010 02:33:36 +0000 (-0500)
Subject: Final fixes before releasing last developer release
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=66285e35e40d582589aef424377640ca96745fce;p=dbsrgits%2FDBM-Deep.git

Final fixes before releasing last developer release
---

diff --git a/Changes b/Changes
index 4b51f1c..f29e7a2 100644
--- a/Changes
+++ b/Changes
@@ -1,13 +1,20 @@
 Revision history for DBM::Deep (ordered by revision number).
 
-1.0019_003 Jan XX XX:XX:00 2010 EST
+1.0019_003 Feb 16 22:00:00 2010 EST
     (This is the third developer release for 1.0020.)
-    (This version is compatible with 1.0014)
+    (This version is compatible with 1.0016)
 	- Fixed problem where "./Build test" wouldn't actually -do- anything.
         - (No-one apparently tried to install this till Steven Lembark. Thanks!)
     - Fixed speed regression with keys in the File backend.
         - Introduced in 1.0019_002 to fix #50541
+        - Thanks, SPROUT!
     - (RT #53575) Recursion failure in STORE (Thanks, SPROUT)
+    - Merged the rest of the fixes from 1.0015 and 1.0016
+        - Thanks to our new co-maintainer, SPROUT! :)
+    - Had to turn off singleton support in the File backend because the caching
+      was causing havoc with transactions. Turning on fatal warnings does give
+      apparently important information.
+    - Oh - forgot to mention that fatal warnings are now on in all files.
 
 1.0019_002 Jan 05 22:30:00 2010 EST
     (This is the second developer release for 1.0020.)
diff --git a/lib/DBM/Deep.pm b/lib/DBM/Deep.pm
index 174082c..8e5abe7 100644
--- a/lib/DBM/Deep.pm
+++ b/lib/DBM/Deep.pm
@@ -377,7 +377,7 @@ sub clone {
 }
 
 sub supports {
-    my $self = shift;
+    my $self = shift->_get_self;
     return $self->_engine->supports( @_ );
 }
 
diff --git a/lib/DBM/Deep/Engine.pm b/lib/DBM/Deep/Engine.pm
index 212788d..7248055 100644
--- a/lib/DBM/Deep/Engine.pm
+++ b/lib/DBM/Deep/Engine.pm
@@ -367,8 +367,12 @@ that feature. C<$option> can be one of:
 
 =item * transactions
 
+=item * singletons
+
 =back
 
+Any other value will return false.
+
 =cut
 
 sub supports { die "supports must be implemented in a child class" }
diff --git a/lib/DBM/Deep/Engine/DBI.pm b/lib/DBM/Deep/Engine/DBI.pm
index 8f6e7aa..cfdab69 100644
--- a/lib/DBM/Deep/Engine/DBI.pm
+++ b/lib/DBM/Deep/Engine/DBI.pm
@@ -342,10 +342,8 @@ sub supports {
     my $self = shift;
     my ($feature) = @_;
 
-    if ( $feature eq 'transactions' ) {
-#        return 1 if $self->storage->driver eq 'sqlite';
-        return;
-    }
+    return if $feature eq 'transactions';
+    return 1 if $feature eq 'singletons';
     return;
 }
 
diff --git a/lib/DBM/Deep/Engine/File.pm b/lib/DBM/Deep/Engine/File.pm
index 5218abe..0af33b8 100644
--- a/lib/DBM/Deep/Engine/File.pm
+++ b/lib/DBM/Deep/Engine/File.pm
@@ -1007,6 +1007,7 @@ sub supports {
     my ($feature) = @_;
 
     return 1 if $feature eq 'transactions';
+    return if $feature eq 'singletones';
     return;
 }
 
diff --git a/lib/DBM/Deep/Null.pm b/lib/DBM/Deep/Null.pm
index 4b41cdf..2781a74 100644
--- a/lib/DBM/Deep/Null.pm
+++ b/lib/DBM/Deep/Null.pm
@@ -25,7 +25,7 @@ It is used to represent null sectors in DBM::Deep.
 use overload
     'bool'   => sub { undef },
     '""'     => sub { undef },
-    '0+'     => sub { undef },
+    '0+'     => sub { 0 },
     fallback => 1,
     nomethod => 'AUTOLOAD';
 
diff --git a/lib/DBM/Deep/Sector/DBI/Reference.pm b/lib/DBM/Deep/Sector/DBI/Reference.pm
index 15584dd..4ffbfbd 100644
--- a/lib/DBM/Deep/Sector/DBI/Reference.pm
+++ b/lib/DBM/Deep/Sector/DBI/Reference.pm
@@ -113,7 +113,7 @@ sub data {
     $args ||= {};
 
     my $engine = $self->engine;
-#    if ( !exists $engine->cache->{ $self->offset } ) {
+    if ( !exists $engine->cache->{ $self->offset } ) {
         my $obj = DBM::Deep->new({
             type        => $self->type,
             base_offset => $self->offset,
@@ -121,9 +121,9 @@ sub data {
             engine      => $engine,
         });
 
-#        $engine->cache->{$self->offset} = $obj;
-#    }
-#    my $obj = $engine->cache->{$self->offset};
+        $engine->cache->{$self->offset} = $obj;
+    }
+    my $obj = $engine->cache->{$self->offset};
 
     # We're not exporting, so just return.
     unless ( $args->{export} ) {
diff --git a/lib/DBM/Deep/Sector/File/Reference.pm b/lib/DBM/Deep/Sector/File/Reference.pm
index cae63e5..bf5f052 100644
--- a/lib/DBM/Deep/Sector/File/Reference.pm
+++ b/lib/DBM/Deep/Sector/File/Reference.pm
@@ -408,7 +408,7 @@ sub data {
     $args ||= {};
 
     my $engine = $self->engine;
-#    if ( !exists $engine->cache->{ $self->offset } ) {
+#    if ( !exists $engine->cache->{ $self->offset }{ $engine->trans_id } ) {
         my $obj = DBM::Deep->new({
             type        => $self->type,
             base_offset => $self->offset,
@@ -417,9 +417,9 @@ sub data {
             engine      => $engine,
         });
 
-#        $engine->cache->{$self->offset} = $obj;
+#        $engine->cache->{$self->offset}{ $engine->trans_id } = $obj;
 #    }
-#    my $obj = $engine->cache->{$self->offset};
+#    my $obj = $engine->cache->{$self->offset}{ $engine->trans_id };
 
     # We're not exporting, so just return.
     unless ( $args->{export} ) {
@@ -447,17 +447,19 @@ sub free {
     # We're not ready to be removed yet.
     return if $self->decrement_refcount > 0;
 
+    my $e = $self->engine;
+
     # Rebless the object into DBM::Deep::Null.
-    eval { %{ $self->engine->cache->{ $self->offset } } = (); };
-    eval { @{ $self->engine->cache->{ $self->offset } } = (); };
-    bless $self->engine->cache->{ $self->offset }, 'DBM::Deep::Null';
-    delete $self->engine->cache->{ $self->offset };
+#    eval { %{ $e->cache->{ $self->offset }{ $e->trans_id } } = (); };
+#    eval { @{ $e->cache->{ $self->offset }{ $e->trans_id } } = (); };
+#    bless $e->cache->{ $self->offset }{ $e->trans_id }, 'DBM::Deep::Null';
+#    delete $e->cache->{ $self->offset }{ $e->trans_id };
 
     my $blist_loc = $self->get_blist_loc;
-    $self->engine->load_sector( $blist_loc )->free if $blist_loc;
+    $e->load_sector( $blist_loc )->free if $blist_loc;
 
     my $class_loc = $self->get_class_offset;
-    $self->engine->load_sector( $class_loc )->free if $class_loc;
+    $e->load_sector( $class_loc )->free if $class_loc;
 
     $self->SUPER::free();
 }
diff --git a/t/39_singletons.t b/t/39_singletons.t
index 93526a4..612a44f 100644
--- a/t/39_singletons.t
+++ b/t/39_singletons.t
@@ -14,29 +14,34 @@ my $dbm_factory = new_dbm(
 while ( my $dbm_maker = $dbm_factory->() ) {
     my $db = $dbm_maker->();
 
-    $db->{a} = 1;
-    $db->{foo} = { a => 'b' };
-    my $x = $db->{foo};
-    my $y = $db->{foo};
-
-    is( $x, $y, "The references are the same" );
-
-    delete $db->{foo};
-    is( $x, undef, "After deleting the DB location, external references are also undef (\$x)" );
-    is( $y, undef, "After deleting the DB location, external references are also undef (\$y)" );
-    is( $x + 0, undef, "DBM::Deep::Null can be added to." );
-    is( $y + 0, undef, "DBM::Deep::Null can be added to." );
-    is( $db->{foo}, undef, "The {foo} location is also undef." );
-
-    # These shenanigans work to get another hashref
-    # into the same data location as $db->{foo} was.
-    $db->{foo} = {};
-    delete $db->{foo};
-    $db->{foo} = {};
-    $db->{bar} = {};
-
-    is( $x, undef, "After re-assigning to {foo}, external references to old values are still undef (\$x)" );
-    is( $y, undef, "After re-assigning to {foo}, external references to old values are still undef (\$y)" );
+    SKIP: {
+        skip "This engine doesn't support singletons", 8
+            unless $db->supports( 'singletons' );
+
+        $db->{a} = 1;
+        $db->{foo} = { a => 'b' };
+        my $x = $db->{foo};
+        my $y = $db->{foo};
+
+        is( $x, $y, "The references are the same" );
+
+        delete $db->{foo};
+        is( $x, undef, "After deleting the DB location, external references are also undef (\$x)" );
+        is( $y, undef, "After deleting the DB location, external references are also undef (\$y)" );
+        is( eval { $x + 0 }, undef, "DBM::Deep::Null can be added to." );
+        is( eval { $y + 0 }, undef, "DBM::Deep::Null can be added to." );
+        is( $db->{foo}, undef, "The {foo} location is also undef." );
+
+        # These shenanigans work to get another hashref
+        # into the same data location as $db->{foo} was.
+        $db->{foo} = {};
+        delete $db->{foo};
+        $db->{foo} = {};
+        $db->{bar} = {};
+
+        is( $x, undef, "After re-assigning to {foo}, external references to old values are still undef (\$x)" );
+        is( $y, undef, "After re-assigning to {foo}, external references to old values are still undef (\$y)" );
+    }
 }
 
 SKIP: {
diff --git a/t/common.pm b/t/common.pm
index 146c88b..a4c61d6 100644
--- a/t/common.pm
+++ b/t/common.pm
@@ -30,10 +30,10 @@ sub new_dbm {
     my @args = @_;
     my ($fh, $filename) = new_fh();
 
-    my @reset_funcs;
-    my @extra_args;
+    my (@names, @reset_funcs, @extra_args);
 
     unless ( $ENV{NO_TEST_FILE} ) {
+        push @names, 'File';
         push @reset_funcs, undef;
         push @extra_args, [
             file => $filename,
@@ -42,7 +42,7 @@ sub new_dbm {
 
     if ( $ENV{TEST_SQLITE} ) {
         (undef, my $filename) = new_fh();
-#        $filename = 'test.db';
+        push @names, 'SQLite';
         push @reset_funcs, sub {
             require 'DBI.pm';
             my $dbh = DBI->connect(
@@ -69,6 +69,7 @@ sub new_dbm {
     }
 
     if ( $ENV{TEST_MYSQL_DSN} ) {
+        push @names, 'MySQL';
         push @reset_funcs, sub {
             require 'DBI.pm';
             my $dbh = DBI->connect(
@@ -102,6 +103,7 @@ sub new_dbm {
         if ( my $reset = shift @reset_funcs ) {
             $reset->();
         }
+        Test::More::diag( "Testing '@{[shift @names]}'\n" ) if $ENV{TEST_VERBOSE};
         return sub {
             DBM::Deep->new( @these_args, @args, @_ )
         };