From: rkinyon <rkinyon@50811bd7-b8ce-0310-adc1-d9db26280581>
Date: Mon, 1 Oct 2007 15:18:50 +0000 (+0000)
Subject:  r8208@rob-kinyons-computer-2 (orig r10033):  rkinyon | 2007-10-01 11:17:40 -0400
X-Git-Tag: 1-0005~1
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c57b19c6ae9b7bd8b23581479afa8664d69023b2;p=dbsrgits%2FDBM-Deep.git

 r8208@rob-kinyons-computer-2 (orig r10033):  rkinyon | 2007-10-01 11:17:40 -0400
  r8204@rob-kinyons-computer-2 (orig r10021):  rkinyon | 2007-09-28 20:00:36 -0400
  Have a 98% solution to making references work.
  r8205@rob-kinyons-computer-2 (orig r10027):  rkinyon | 2007-09-30 13:59:07 -0400
  cached singletons for most cases. The external reference issue is starting to come into larger focus
  r8206@rob-kinyons-computer-2 (orig r10031):  rkinyon | 2007-10-01 11:15:50 -0400
  Added coverage report and tests that were wrong
  r8207@rob-kinyons-computer-2 (orig r10032):  rkinyon | 2007-10-01 11:16:12 -0400
  Fixed date on release of 1.0005
---

diff --git a/Changes b/Changes
index 94c7011..8618e7c 100644
--- a/Changes
+++ b/Changes
@@ -1,5 +1,14 @@
 Revision history for DBM::Deep.
 
+1.0005 Oct 01 11: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..8eb36b9 100644
--- a/lib/DBM/Deep.pm
+++ b/lib/DBM/Deep.pm
@@ -5,7 +5,7 @@ use 5.006_000;
 use strict;
 use warnings;
 
-our $VERSION = q(1.0004);
+our $VERSION = q(1.0005);
 
 use Fcntl qw( :flock );
 
@@ -17,6 +17,10 @@ use Scalar::Util ();
 use DBM::Deep::Engine;
 use DBM::Deep::File;
 
+use overload
+    '""' => sub { overload::StrVal( $_[0] ) },
+    fallback => 1;
+
 ##
 # Setup constants for users to pass to new()
 ##
@@ -251,7 +255,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.pod b/lib/DBM/Deep.pod
index 8b4b689..6b5b2e6 100644
--- a/lib/DBM/Deep.pod
+++ b/lib/DBM/Deep.pod
@@ -945,12 +945,13 @@ the reference. Again, this would generally be considered a feature.
 
 =back
 
-=head2 Data::Dumper and references
+=head2 External references and transactions
 
-As of 1.0003, support for independent Perl datastructures was added (q.v. L</CIRCULAR REFERENCES>
-for more info). However, because DBM::Deep doesn't properly provide the same
-in-memory data-structure for a given location on disk, Data::Dumper (and
-friends) doesn't properly note this. This will be addressed in a future release.
+If you do C<my $x = $db-E<gt>{foo};>, then start a transaction, $x will be
+referencing the database from outside the transaction. A fix for this (and other
+issues with how external references into the database) is being looked into. This
+is the skipped set of tests in t/39_singletons.t and a related issue is the focus
+of t/37_delete_edge_cases.t
 
 =head2 File corruption
 
@@ -1026,12 +1027,12 @@ B<Devel::Cover> report on this distribution's test suite.
   ------------------------------------------ ------ ------ ------ ------ ------
   File                                         stmt   bran   cond    sub  total
   ------------------------------------------ ------ ------ ------ ------ ------
-  blib/lib/DBM/Deep.pm                         94.5   85.0   90.5  100.0   93.6
-  blib/lib/DBM/Deep/Array.pm                  100.0   94.3  100.0  100.0   98.7
-  blib/lib/DBM/Deep/Engine.pm                  95.9   84.9   81.7  100.0   92.8
+  blib/lib/DBM/Deep.pm                         96.9   88.3   90.5  100.0   95.7
+  blib/lib/DBM/Deep/Array.pm                  100.0   95.7  100.0  100.0   99.0
+  blib/lib/DBM/Deep/Engine.pm                  95.5   84.7   81.6   98.4   92.4
   blib/lib/DBM/Deep/File.pm                    97.2   81.6   66.7  100.0   91.9
   blib/lib/DBM/Deep/Hash.pm                   100.0  100.0  100.0  100.0  100.0
-  Total                                        96.5   86.5   83.5  100.0   94.0
+  Total                                        96.7   87.0   83.3   99.2   94.1
   ------------------------------------------ ------ ------ ------ ------ ------
 
 =head1 MORE INFORMATION
diff --git a/lib/DBM/Deep/Array.pm b/lib/DBM/Deep/Array.pm
index f9b9af2..eb092ac 100644
--- a/lib/DBM/Deep/Array.pm
+++ b/lib/DBM/Deep/Array.pm
@@ -5,7 +5,7 @@ use 5.006_000;
 use strict;
 use warnings;
 
-our $VERSION = q(1.0004);
+our $VERSION = q(1.0005);
 
 # This is to allow DBM::Deep::Array to handle negative indices on
 # its own. Otherwise, Perl would intercept the call to negative
diff --git a/lib/DBM/Deep/Engine.pm b/lib/DBM/Deep/Engine.pm
index 99198fe..f8656a3 100644
--- a/lib/DBM/Deep/Engine.pm
+++ b/lib/DBM/Deep/Engine.pm
@@ -5,7 +5,7 @@ use 5.006_000;
 use strict;
 use warnings;
 
-our $VERSION = q(1.0004);
+our $VERSION = q(1.0005);
 
 use Scalar::Util ();
 
@@ -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.
+    %{ $self->engine->cache->{ $self->offset } } = ();
+    bless $self->engine->cache->{ $self->offset }, 'DBM::Deep::Null';
+    delete $self->engine->cache->{ $self->offset };
 
-        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/lib/DBM/Deep/File.pm b/lib/DBM/Deep/File.pm
index ccedf04..6571c2e 100644
--- a/lib/DBM/Deep/File.pm
+++ b/lib/DBM/Deep/File.pm
@@ -5,7 +5,7 @@ use 5.006_000;
 use strict;
 use warnings;
 
-our $VERSION = q(1.0004);
+our $VERSION = q(1.0005);
 
 use Fcntl qw( :DEFAULT :flock :seek );
 
diff --git a/lib/DBM/Deep/Hash.pm b/lib/DBM/Deep/Hash.pm
index b703705..a342d62 100644
--- a/lib/DBM/Deep/Hash.pm
+++ b/lib/DBM/Deep/Hash.pm
@@ -5,7 +5,7 @@ use 5.006_000;
 use strict;
 use warnings;
 
-our $VERSION = q(1.0004);
+our $VERSION = q(1.0005);
 
 use base 'DBM::Deep';
 
diff --git a/t/31_references.t b/t/31_references.t
index 0184795..af9bc30 100644
--- a/t/31_references.t
+++ b/t/31_references.t
@@ -1,6 +1,7 @@
 use strict;
 
 use Test::More tests => 16;
+use Test::Deep;
 use Test::Exception;
 use t::common qw( new_fh );
 
@@ -19,8 +20,8 @@ $db->{hash} = \%hash;
 isa_ok( tied(%hash), 'DBM::Deep::Hash' );
 
 is( $db->{hash}{foo}, 1 );
-is_deeply( $db->{hash}{bar}, [ 1 .. 3 ] );
-is_deeply( $db->{hash}{baz}, { a => 42 } );
+cmp_deeply( $db->{hash}{bar}, noclass([ 1 .. 3 ]) );
+cmp_deeply( $db->{hash}{baz}, noclass({ a => 42 }) );
 
 $hash{foo} = 2;
 is( $db->{hash}{foo}, 2 );
@@ -39,8 +40,8 @@ $db->{array} = \@array;
 isa_ok( tied(@array), 'DBM::Deep::Array' );
 
 is( $db->{array}[0], 1 );
-is_deeply( $db->{array}[1], [ 1 .. 3 ] );
-is_deeply( $db->{array}[2], { a => 42 } );
+cmp_deeply( $db->{array}[1], noclass([ 1 .. 3 ]) );
+cmp_deeply( $db->{array}[2], noclass({ a => 42 }) );
 
 $array[0] = 2;
 is( $db->{array}[0], 2 );
diff --git a/t/33_transactions.t b/t/33_transactions.t
index cdf18ad..1edd082 100644
--- a/t/33_transactions.t
+++ b/t/33_transactions.t
@@ -233,7 +233,3 @@ SKIP: {
 }
 
 __END__
-
-Tests to add:
-* Two transactions running at the same time
-* Doing a clear on the head while a transaction is running
diff --git a/t/39_singletons.t b/t/39_singletons.t
index 8a3573e..45afc60 100644
--- a/t/39_singletons.t
+++ b/t/39_singletons.t
@@ -1,29 +1,64 @@
 use strict;
-use Test::More tests => 5;
+use Test::More tests => 11;
 use Test::Deep;
 use t::common qw( new_fh );
 
 use_ok( 'DBM::Deep' );
 
-my ($fh, $filename) = new_fh();
-my $db = DBM::Deep->new(
-    file => $filename,
-    locking => 1,
-    autoflush => 1,
-);
+{
+    my ($fh, $filename) = new_fh();
+    my $db = DBM::Deep->new(
+        file => $filename,
+        locking => 1,
+        autoflush => 1,
+    );
 
-$db->{foo} = { a => 'b' };
-my $x = $db->{foo};
-my $y = $db->{foo};
+    $db->{a} = 1;
+    $db->{foo} = { a => 'b' };
+    my $x = $db->{foo};
+    my $y = $db->{foo};
 
-print "$x -> $y\n";
-
-TODO: {
-    local $TODO = "Singletons are unimplmeneted yet";
     is( $x, $y, "The references are the same" );
 
     delete $db->{foo};
     is( $x, undef );
     is( $y, undef );
+    is( $x + 0, undef );
+    is( $y + 0, undef );
+    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 );
+}
+
+SKIP: {
+    skip "What do we do with external references and txns?", 2;
+    my ($fh, $filename) = new_fh();
+    my $db = DBM::Deep->new(
+        file => $filename,
+        locking => 1,
+        autoflush => 1,
+        num_txns => 2,
+    );
+
+    $db->{foo} = { a => 'b' };
+    my $x = $db->{foo};
+
+    $db->begin_work;
+    
+        $db->{foo} = { c => 'd' };
+        my $y = $db->{foo};
+
+        # XXX What should happen here with $x and $y?
+        is( $x, $y );
+        is( $x->{c}, 'd' );
+
+    $db->rollback;
 }
-is( $db->{foo}, undef );
diff --git a/t/41_transaction_multilevel.t b/t/41_transaction_multilevel.t
index aa2a959..3351e98 100644
--- 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/44_upgrade_db.t b/t/44_upgrade_db.t
index c39d153..759dbf0 100644
--- a/t/44_upgrade_db.t
+++ b/t/44_upgrade_db.t
@@ -13,7 +13,7 @@ BEGIN {
     }
 }
 
-plan tests => 202;
+plan tests => 212;
 
 use t::common qw( new_fh );
 use File::Spec;
@@ -63,7 +63,7 @@ my @output_versions = (
     '0.981', '0.982', '0.983',
     '0.99_01', '0.99_02', '0.99_03', '0.99_04',
     '1.00', '1.000', '1.0000', '1.0001', '1.0002',
-    '1.0003', '1.0004',
+    '1.0003', '1.0004', '1.0005',
 );
 
 foreach my $input_filename (
@@ -117,7 +117,7 @@ foreach my $input_filename (
             eval "use DBM::Deep::10002";
             $db = DBM::Deep::10002->new( $output_filename );
         }
-        elsif ( $v =~ /^1\.000[34]/ ) {
+        elsif ( $v =~ /^1\.000[3-5]/ ) {
             push @INC, 'lib';
             eval "use DBM::Deep";
             $db = DBM::Deep->new( $output_filename );
diff --git a/t/97_dump_file.t b/t/97_dump_file.t
index 931cb07..1445517 100644
--- 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):
diff --git a/utils/upgrade_db.pl b/utils/upgrade_db.pl
index 960abce..3a7c86d 100755
--- a/utils/upgrade_db.pl
+++ b/utils/upgrade_db.pl
@@ -28,7 +28,7 @@ my %is_dev = (
 my %opts = (
   man => 0,
   help => 0,
-  version => '1.0004',
+  version => '1.0005',
   autobless => 1,
 );
 GetOptions( \%opts,
@@ -77,7 +77,7 @@ my %db;
   elsif ( $ver =~ /^1\.000?[0-2]?/) {
     $ver = 2;
   }
-  elsif ( $ver =~ /^1\.000[34]/) {
+  elsif ( $ver =~ /^1\.000[3-5]/) {
     $ver = 3;
   }
   else {