Have a 98% solution to making references work.

diff --git a/Changes b/Changes
index 94c7011..7d732fe 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,5 +1,14 @@
 Revision history for DBM::Deep.
 
+1.0005 Sep 28 12:15:00 2007 EDT
+    - (This version is compatible with 1.0004)
+    - Added proper singleton support. This means that the following now works:
+        $db->{foo} = [ 1 .. 3];
+        my $x = $db->{foo};
+        my $y = $db->{foo};
+        is( $x == $y ); # Now passes
+      - This means that Data::Dumper now properly reports when $db->{foo} = $db->{bar}
+
 1.0004 Sep 28 12:15:00 2007 EDT
     - (This version is compatible with 1.0003)
     - Fixed the Changes file (wrong version was displayed for 1.0003)

diff --git a/lib/DBM/Deep.pm b/lib/DBM/Deep.pm
index a72833d..2c1b190 100644 (file)
--- a/lib/DBM/Deep.pm
+++ b/lib/DBM/Deep.pm
@@ -251,7 +251,7 @@ sub optimize {
     );
 
     $self->lock();
-    #DBM::Deep::Engine::Sector::Reference->_clear_cache;
+    $self->_engine->clear_cache;
     $self->_copy_node( $db_temp );
     undef $db_temp;
 

diff --git a/lib/DBM/Deep/Engine.pm b/lib/DBM/Deep/Engine.pm
index 99198fe..bae762a 100644 (file)
--- a/lib/DBM/Deep/Engine.pm
+++ b/lib/DBM/Deep/Engine.pm
@@ -725,7 +725,7 @@ sub _load_sector {
     my ($offset) = @_;
 
     # Add a catch for offset of 0 or 1
-    return if $offset <= 1;
+    return if !$offset || $offset <= 1;
 
     my $type = $self->storage->read_at( $offset, 1 );
     return if $type eq chr(0);
@@ -875,6 +875,9 @@ sub set_trans_loc { $_[0]{trans_loc} = $_[1] }
 sub chains_loc     { $_[0]{chains_loc} }
 sub set_chains_loc { $_[0]{chains_loc} = $_[1] }
 
+sub cache       { $_[0]{cache} ||= {} }
+sub clear_cache { %{$_[0]->cache} = () }
+
 sub _dump_file {
     my $self = shift;
 
@@ -894,6 +897,10 @@ sub _dump_file {
     );
 
     my $return = "";
+
+    # Header values
+    $return .= "NumTxns: " . $self->num_txns . $/;
+
     # Read the free sector chains
     my %sectors;
     foreach my $multiple ( 0 .. 2 ) {
@@ -948,10 +955,17 @@ sub _dump_file {
                     $return .= sprintf "%08d", unpack($StP{$self->byte_size},
                         substr( $bucket->[-1], $self->hash_size, $self->byte_size),
                     );
-                    foreach my $txn ( 0 .. $self->num_txns - 1 ) {
+                    my $l = unpack( $StP{$self->byte_size},
+                        substr( $bucket->[-1],
+                            $self->hash_size + $self->byte_size,
+                            $self->byte_size,
+                        ),
+                    );
+                    $return .= sprintf " %08d", $l;
+                    foreach my $txn ( 0 .. $self->num_txns - 2 ) {
                         my $l = unpack( $StP{$self->byte_size},
                             substr( $bucket->[-1],
-                                $self->hash_size + $self->byte_size + $txn * ($self->byte_size + $STALE_SIZE),
+                                $self->hash_size + 2 * $self->byte_size + $txn * ($self->byte_size + $STALE_SIZE),
                                 $self->byte_size,
                             ),
                         );
@@ -1673,55 +1687,50 @@ sub get_classname {
     return $self->engine->_load_sector( $class_offset )->data;
 }
 
-#XXX Add singleton handling here
-{
-    my %cache;
-    # XXX This is insufficient
-#    sub _clear_cache { %cache = (); }
-    sub data {
-        my $self = shift;
+sub data {
+    my $self = shift;
 
-#        unless ( $cache{ $self->offset } ) {
-            my $new_obj = DBM::Deep->new({
-                type        => $self->type,
-                base_offset => $self->offset,
-                staleness   => $self->staleness,
-                storage     => $self->engine->storage,
-                engine      => $self->engine,
-            });
+    unless ( $self->engine->cache->{ $self->offset } ) {
+        my $new_obj = DBM::Deep->new({
+            type        => $self->type,
+            base_offset => $self->offset,
+            staleness   => $self->staleness,
+            storage     => $self->engine->storage,
+            engine      => $self->engine,
+        });
 
-            if ( $self->engine->storage->{autobless} ) {
-                my $classname = $self->get_classname;
-                if ( defined $classname ) {
-                    bless $new_obj, $classname;
-                }
+        if ( $self->engine->storage->{autobless} ) {
+            my $classname = $self->get_classname;
+            if ( defined $classname ) {
+                bless $new_obj, $classname;
             }
+        }
 
-            $cache{$self->offset} = $new_obj;
-#        }
-        return $cache{$self->offset};
+        $self->engine->cache->{$self->offset} = $new_obj;
     }
+    return $self->engine->cache->{$self->offset};
+}
 
-    sub free {
-        my $self = shift;
+sub free {
+    my $self = shift;
 
-        # We're not ready to be removed yet.
-        if ( $self->decrement_refcount > 0 ) {
-            return;
-        }
+    # We're not ready to be removed yet.
+    if ( $self->decrement_refcount > 0 ) {
+        return;
+    }
 
-        # Rebless the object into DBM::Deep::Null.
-#        %{$cache{ $self->offset }} = ();
-#        bless $cache{$self->offset}, 'DBM::Deep::Null';
+    # Rebless the object into DBM::Deep::Null.
+    my $x = $self->engine->cache->{ $self->offset };
+    %{ $self->engine->cache->{ $self->offset } } = ();
+    bless $self->engine->cache->{ $self->offset }, 'DBM::Deep::Null';
 
-        my $blist_loc = $self->get_blist_loc;
-        $self->engine->_load_sector( $blist_loc )->free if $blist_loc;
+    my $blist_loc = $self->get_blist_loc;
+    $self->engine->_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;
+    my $class_loc = $self->get_class_offset;
+    $self->engine->_load_sector( $class_loc )->free if $class_loc;
 
-        $self->SUPER::free();
-    }
+    $self->SUPER::free();
 }
 
 sub increment_refcount {
@@ -1828,10 +1837,19 @@ sub free {
         my $l = unpack( $StP{$e->byte_size}, substr( $rest, $e->hash_size, $e->byte_size ) );
         my $s = $e->_load_sector( $l ); $s->free if $s;
 
-        foreach my $txn ( 0 .. $e->num_txns - 1 ) {
+        # Delete the HEAD sector
+        $l = unpack( $StP{$e->byte_size},
+            substr( $rest,
+                $e->hash_size + $e->byte_size,
+                $e->byte_size,
+            ),
+        );
+        $s = $e->_load_sector( $l ); $s->free if $s;
+
+        foreach my $txn ( 0 .. $e->num_txns - 2 ) {
             my $l = unpack( $StP{$e->byte_size},
                 substr( $rest,
-                    $e->hash_size + $e->byte_size + $txn * ($e->byte_size + $STALE_SIZE),
+                    $e->hash_size + 2 * $e->byte_size + $txn * ($e->byte_size + $STALE_SIZE),
                     $e->byte_size,
                 ),
             );
@@ -2208,10 +2226,11 @@ sub set_entry {
 package DBM::Deep::Null;
 
 use overload
-    'bool'   => sub { undef},
+    'bool'   => sub { undef },
     '""'     => sub { undef },
-    '0+'     => sub { undef},
-    fallback => 1;
+    '0+'     => sub { undef },
+    fallback => 1,
+    nomethod => 'AUTOLOAD';
 
 sub AUTOLOAD { return; }
 

diff --git a/t/39_singletons.t b/t/39_singletons.t
index 8a3573e..9f7a5ea 100644 (file)
--- a/t/39_singletons.t
+++ b/t/39_singletons.t
@@ -1,5 +1,5 @@
 use strict;
-use Test::More tests => 5;
+use Test::More tests => 9;
 use Test::Deep;
 use t::common qw( new_fh );
 
@@ -12,18 +12,27 @@ my $db = DBM::Deep->new(
     autoflush => 1,
 );
 
+$db->{a} = 1;
 $db->{foo} = { a => 'b' };
 my $x = $db->{foo};
 my $y = $db->{foo};
 
-print "$x -> $y\n";
+is( $x, $y, "The references are the same" );
 
-TODO: {
-    local $TODO = "Singletons are unimplmeneted yet";
-    is( $x, $y, "The references are the same" );
-
-    delete $db->{foo};
-    is( $x, undef );
-    is( $y, undef );
-}
+delete $db->{foo};
+is( $x, undef );
+is( $y, undef );
+warn "$x\n";
+is( $x + 0, 0 );
+is( $y + 0, 0 );
 is( $db->{foo}, 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 );
+is( $y, undef );

diff --git a/t/41_transaction_multilevel.t b/t/41_transaction_multilevel.t
index aa2a959..3351e98 100644 (file)
--- a/t/41_transaction_multilevel.t
+++ b/t/41_transaction_multilevel.t
@@ -10,14 +10,14 @@ my $db1 = DBM::Deep->new(
     file => $filename,
     locking => 1,
     autoflush => 1,
-    num_txns  => 16,
+    num_txns  => 2,
 );
 
 my $db2 = DBM::Deep->new(
     file => $filename,
     locking => 1,
     autoflush => 1,
-    num_txns  => 16,
+    num_txns  => 2,
 );
 
 $db1->{x} = { foo => 'y' };

diff --git a/t/97_dump_file.t b/t/97_dump_file.t
index 931cb07..1445517 100644 (file)
--- a/t/97_dump_file.t
+++ b/t/97_dump_file.t
@@ -11,6 +11,7 @@ my $db = DBM::Deep->new(
 );
 
 is( $db->_dump_file, <<"__END_DUMP__", "Dump of initial file correct" );
+NumTxns: 1
 Chains(B):
 Chains(D):
 Chains(I):
@@ -20,6 +21,7 @@ __END_DUMP__
 $db->{foo} = 'bar';
 
 is( $db->_dump_file, <<"__END_DUMP__", "Dump of initial file correct" );
+NumTxns: 1
 Chains(B):
 Chains(D):
 Chains(I):