From: rkinyon@cpan.org <rkinyon@cpan.org>
Date: Tue, 27 May 2008 18:44:26 +0000 (+0000)
Subject: Exporting seems to work just fine
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=edd451341044431ec2cddbb62883feeefd3f18f7;p=dbsrgits%2FDBM-Deep.git

Exporting seems to work just fine

git-svn-id: http://svn.ali.as/cpan/trunk/DBM-Deep@3440 88f4d9cd-8a04-0410-9d60-8f63309c3137
---

diff --git a/Changes b/Changes
index 805455e..169c3eb 100644
--- a/Changes
+++ b/Changes
@@ -1,8 +1,14 @@
 Revision history for DBM::Deep.
 
-1.0010 May 14 12:00:00 2008 EST
+1.0010 May 27 12:00:00 2008 EST
     - (This version is compatible with 1.0009)
     - Fix for RT#35140 (invalid POD links)
+    - Fix for RT#34819 (Cannot assign the same value back to the same location)
+    - Fix for RT#29957 (Cannot assign the same value back to the same location)
+    - Fix for RT#33863 (Cannot shift an arrayref from an array)
+    - When something is deleted from a DB, the value is export()ed, allowing it
+      to be saved.
+      - This exporting is only done if the refcount == 0 after the deletion.
 
 1.0009 Mar 19 12:00:00 2008 EDT
     - (This version is compatible with 1.0008)
diff --git a/MANIFEST b/MANIFEST
index b493fc6..34a2d85 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -60,6 +60,7 @@ t/44_upgrade_db.t
 t/45_references.t
 t/46_blist_reindex.t
 t/47_odd_reference_behaviors.t
+t/48_autoexport_after_delete.t
 t/97_dump_file.t
 t/98_pod.t
 t/99_pod_coverage.t
diff --git a/lib/DBM/Deep.pm b/lib/DBM/Deep.pm
index 09c6f85..670f6e0 100644
--- a/lib/DBM/Deep.pm
+++ b/lib/DBM/Deep.pm
@@ -7,6 +7,7 @@ use warnings;
 
 our $VERSION = q(1.0010);
 
+use Data::Dumper ();
 use Fcntl qw( :flock );
 use Scalar::Util ();
 
@@ -152,21 +153,35 @@ sub _copy_value {
     if ( !ref $value ) {
         ${$spot} = $value;
     }
-    elsif ( eval { local $SIG{__DIE__}; $value->isa( 'DBM::Deep' ) } ) {
-        ${$spot} = $value->_repr;
-        $value->_copy_node( ${$spot} );
-    }
     else {
+        # This assumes hash or array only. This is a bad assumption moving forward.
+        # -RobK, 2008-05-27
         my $r = Scalar::Util::reftype( $value );
-        my $c = Scalar::Util::blessed( $value );
+        my $tied;
         if ( $r eq 'ARRAY' ) {
-            ${$spot} = [ @{$value} ];
+            $tied = tied(@$value);
+        }
+        else {
+            $tied = tied(%$value);
+        }
+
+        if ( eval { local $SIG{__DIE__}; $tied->isa( 'DBM::Deep' ) } ) {
+            ${$spot} = $tied->_repr;
+            $tied->_copy_node( ${$spot} );
         }
         else {
-            ${$spot} = { %{$value} };
+            if ( $r eq 'ARRAY' ) {
+                ${$spot} = [ @{$value} ];
+            }
+            else {
+                ${$spot} = { %{$value} };
+            }
+        }
+
+        my $c = Scalar::Util::blessed( $value );
+        if ( defined $c && !$c->isa( 'DBM::Deep') ) {
+            ${$spot} = bless ${$spot}, $c
         }
-        ${$spot} = bless ${$spot}, $c
-            if defined $c;
     }
 
     return 1;
diff --git a/lib/DBM/Deep/Array.pm b/lib/DBM/Deep/Array.pm
index 0ee4abc..395592f 100644
--- a/lib/DBM/Deep/Array.pm
+++ b/lib/DBM/Deep/Array.pm
@@ -269,13 +269,16 @@ sub SHIFT {
         return;
     }
 
-    my $content = $self->FETCH( 0 );
+    my $content = $self->DELETE( 0 );
 
-    for (my $i = 0; $i < $length - 1; $i++) {
-        $self->_move_value( $i+1, $i );
-    }
+    # Unless the deletion above has cleared the array ...
+    if ( $length > 1 ) {
+        for (my $i = 0; $i < $length - 1; $i++) {
+            $self->_move_value( $i+1, $i );
+        }
 
-    $self->DELETE( $length - 1 );
+        $self->DELETE( $length - 1 );
+    }
 
     $self->unlock;
 
@@ -388,8 +391,7 @@ sub _copy_node {
 
     my $length = $self->length();
     for (my $index = 0; $index < $length; $index++) {
-        my $value = $self->get($index);
-        $self->_copy_value( \$db_temp->[$index], $value );
+        $self->_copy_value( \$db_temp->[$index], $self->get($index) );
     }
 
     return 1;
diff --git a/lib/DBM/Deep/Engine.pm b/lib/DBM/Deep/Engine.pm
index 7f716bf..05b24dc 100644
--- a/lib/DBM/Deep/Engine.pm
+++ b/lib/DBM/Deep/Engine.pm
@@ -290,8 +290,13 @@ sub write_value {
             $tmpvar = tied %$value;
         }
 
-        my $is_dbm_deep = eval { local $SIG{'__DIE__'}; $tmpvar->isa( 'DBM::Deep' ); };
-        if ( $is_dbm_deep ) {
+        if ( $tmpvar ) {
+            my $is_dbm_deep = eval { local $SIG{'__DIE__'}; $tmpvar->isa( 'DBM::Deep' ); };
+
+            unless ( $is_dbm_deep ) {
+                DBM::Deep->_throw_error( "Cannot store something that is tied." );
+            }
+
             unless ( $tmpvar->_engine->storage == $self->storage ) {
                 DBM::Deep->_throw_error( "Cannot store values across DBM::Deep files. Please use export() instead." );
             }
@@ -307,6 +312,7 @@ sub write_value {
                 return 1;
             }
 
+            #XXX Can this use $loc?
             my $value_sector = $self->_load_sector( $tmpvar->_base_offset );
             $sector->write_data({
                 key     => $key,
@@ -317,12 +323,7 @@ sub write_value {
 
             return 1;
         }
-        if ( $r eq 'ARRAY' && tied(@$value) ) {
-            DBM::Deep->_throw_error( "Cannot store something that is tied." );
-        }
-        if ( $r eq 'HASH' && tied(%$value) ) {
-            DBM::Deep->_throw_error( "Cannot store something that is tied." );
-        }
+
         $class = 'DBM::Deep::Engine::Sector::Reference';
         $type = substr( $r, 0, 1 );
     }
@@ -1319,6 +1320,8 @@ sub chain_loc {
 
 sub data {
     my $self = shift;
+#    my ($args) = @_;
+#    $args ||= {};
 
     my $data;
     while ( 1 ) {
@@ -1549,7 +1552,7 @@ sub delete_key {
         $blist->mark_deleted( $args );
 
         if ( $old_value ) {
-            $data = $old_value->data;
+            $data = $old_value->data({ export => 1 });
             $old_value->free;
         }
     }
@@ -1758,9 +1761,12 @@ sub get_classname {
 
 sub data {
     my $self = shift;
+    my ($args) = @_;
+    $args ||= {};
 
-    unless ( $self->engine->cache->{ $self->offset } ) {
-        my $new_obj = DBM::Deep->new({
+    my $obj;
+    unless ( $obj = $self->engine->cache->{ $self->offset } ) {
+        $obj = DBM::Deep->new({
             type        => $self->type,
             base_offset => $self->offset,
             staleness   => $self->staleness,
@@ -1771,13 +1777,24 @@ sub data {
         if ( $self->engine->storage->{autobless} ) {
             my $classname = $self->get_classname;
             if ( defined $classname ) {
-                bless $new_obj, $classname;
+                bless $obj, $classname;
             }
         }
 
-        $self->engine->cache->{$self->offset} = $new_obj;
+        $self->engine->cache->{$self->offset} = $obj;
+    }
+
+    # We're not exporting, so just return.
+    unless ( $args->{export} ) {
+        return $obj;
     }
-    return $self->engine->cache->{$self->offset};
+
+    # We shouldn't export if this is still referred to.
+    if ( $self->get_refcount > 1 ) {
+        return $obj;
+    }
+
+    return $obj->export;
 }
 
 sub free {
@@ -2122,7 +2139,7 @@ sub delete_md5 {
     $key_sector->free;
 
     my $data_sector = $self->engine->_load_sector( $location );
-    my $data = $data_sector->data;
+    my $data = $data_sector->data({ export => 1 });
     $data_sector->free;
 
     return $data;
diff --git a/t/39_singletons.t b/t/39_singletons.t
index 45afc60..3676b48 100644
--- a/t/39_singletons.t
+++ b/t/39_singletons.t
@@ -21,11 +21,11 @@ use_ok( 'DBM::Deep' );
     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 );
+    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.
@@ -34,8 +34,8 @@ use_ok( 'DBM::Deep' );
     $db->{foo} = {};
     $db->{bar} = {};
 
-    is( $x, undef );
-    is( $y, undef );
+    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/47_odd_reference_behaviors.t b/t/47_odd_reference_behaviors.t
index 5717284..956adcb 100644
--- a/t/47_odd_reference_behaviors.t
+++ b/t/47_odd_reference_behaviors.t
@@ -3,8 +3,9 @@ use 5.006;
 use strict;
 use warnings FATAL => 'all';
 
-use Scalar::Util qw( reftype );
-use Test::More tests => 12;
+use Test::More tests => 13;
+use Test::Exception;
+use Test::Deep;
 
 use t::common qw( new_fh );
 
@@ -22,7 +23,6 @@ use_ok( 'DBM::Deep' );
 
     eval {
         $db->{bar} = $bar;
-        warn "$db->{bar}: $bar\n";
         $db->{bar} = $bar;
     };
 
@@ -31,8 +31,7 @@ use_ok( 'DBM::Deep' );
 }
 
 # This is bug #29957, reported by HANENKAMP
-TODO: {
-    todo_skip "This crashes the code", 4;
+{
     my ($fh, $filename) = new_fh();
     my $db = DBM::Deep->new(
         file => $filename,
@@ -42,11 +41,14 @@ TODO: {
     $db->{foo} = [];
 
     for my $value ( 1 .. 3 ) {
-        my $ref = $db->{foo};
-        push @$ref, $value;
-        $db->{foo} = $ref;
-        ok( 1, "T $value" );
+        lives_ok {
+            my $ref = $db->{foo};
+            push @$ref, $value;
+            $db->{foo} = $ref;
+        } "Successfully added value $value";
     }
+
+    cmp_deeply( [1,2,3], noclass($db->{foo}), "Everything looks ok" );
 }
 
 # This is bug #33863, reported by PJS
@@ -62,10 +64,9 @@ TODO: {
     cmp_ok( @{ $db->{foo} }, '==', 0, "Shifting a scalar leaves no values" );
     cmp_ok( $foo, '==', 42, "... And the value is correct." );
 
-#    $db->{bar} = [ [] ];
-#    my $bar = shift @{ $db->{bar} };
-#    cmp_ok( @{ $db->{bar} }, '==', 0, "Shifting an arrayref leaves no values" );
-#    use Data::Dumper; warn Dumper $bar;
+    $db->{bar} = [ [] ];
+    my $bar = shift @{ $db->{bar} };
+    cmp_ok( @{ $db->{bar} }, '==', 0, "Shifting an arrayref leaves no values" );
 
     $db->{baz} = { foo => [ 1 .. 3 ] };
     $db->{baz2} = [ $db->{baz} ];
diff --git a/t/48_autoexport_after_delete.t b/t/48_autoexport_after_delete.t
new file mode 100644
index 0000000..b34e0b8
--- /dev/null
+++ b/t/48_autoexport_after_delete.t
@@ -0,0 +1,62 @@
+use 5.006;
+
+use strict;
+use warnings FATAL => 'all';
+
+use Test::More no_plan => 1;
+use Test::Deep;
+
+use t::common qw( new_fh );
+
+use_ok( 'DBM::Deep' );
+
+{
+    my ($fh, $filename) = t::common::new_fh();
+    my $db = DBM::Deep->new(
+        file => $filename,
+        fh => $fh,
+    );
+
+    # Add a self-referencing connection to test export
+    my %struct = (
+        key1 => "value1",
+        key2 => "value2",
+        array1 => [ "elem0", "elem1", "elem2", { foo => 'bar' }, [ 5 ], bless( [], 'Apple' ) ],
+        hash1 => {
+            subkey1 => "subvalue1",
+            subkey2 => "subvalue2",
+            subkey3 => bless( {
+                sub_obj => bless([
+                    bless([], 'Foo'),
+                ], 'Foo'),
+                sub_obj3 => bless([],'Foo'),
+            }, 'Foo' ),
+        },
+    );
+
+    $db->{foo} = \%struct;
+
+    my $x = delete $db->{foo};
+
+    cmp_deeply(
+        $x,
+        {
+            key1 => "value1",
+            key2 => "value2",
+            array1 => [ "elem0", "elem1", "elem2", { foo => 'bar' }, [ 5 ], bless( [], 'Apple' ) ],
+            hash1 => {
+                subkey1 => "subvalue1",
+                subkey2 => "subvalue2",
+                subkey3 => bless( {
+                    sub_obj => bless([
+                        bless([], 'Foo'),
+                    ], 'Foo'),
+                    sub_obj3 => bless([],'Foo'),
+                }, 'Foo' ),
+            },
+        },
+        "Everything matches",
+    );
+}
+
+__END__
diff --git a/utils/upgrade_db.pl b/utils/upgrade_db.pl
index 3c36b31..12b5029 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.0007',
+  version => '1.0010',
   autobless => 1,
 );
 GetOptions( \%opts,
@@ -71,7 +71,10 @@ my %db;
 
 {
   my $ver = $opts{version};
-  if ( $ver =~ /^1\.000[3-9]/) {
+  if ( $ver =~ /^1\.0010/) {
+    $ver = 3;
+  }
+  elsif ( $ver =~ /^1\.000[3-9]/) {
     $ver = 3;
   }
   elsif ( $ver =~ /^1\.000?[0-2]?/) {