X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2F24_autobless.t;h=4f41fced00d799a36421c1b6a3df073744118d65;hb=24b0b7b9c405df7f75babe1e6ebd48680c9853a5;hp=f4151afd58c00d0bc02ba94f393125c838e99afe;hpb=d6e6e91b72fe5c8940c01f2b85988fe74c173f18;p=dbsrgits%2FDBM-Deep.git

diff --git a/t/24_autobless.t b/t/24_autobless.t
index f4151af..4f41fce 100644
--- a/t/24_autobless.t
+++ b/t/24_autobless.t
@@ -1,4 +1,5 @@
 use strict;
+use warnings FATAL => 'all';
 
 {
     package Foo;
@@ -7,79 +8,184 @@ use strict;
     sub foo { 'foo' };
 }
 
-use Test::More no_plan => 1;
+use Test::More;
+use t::common qw( new_dbm );
 
 use_ok( 'DBM::Deep' );
 
-unlink 't/test.db';
-my $db = DBM::Deep->new(
-    file     => "t/test.db",
-    autobless => 1,
-);
-if ($db->error()) {
-	die "ERROR: " . $db->error();
+my $dbm_factory = new_dbm( autobless => 1 );
+while ( my $dbm_maker = $dbm_factory->() ) {
+    {
+        my $db = $dbm_maker->();
+
+        my $obj = bless {
+            a => 1,
+            b => [ 1 .. 3 ],
+        }, 'Foo';
+
+        $db->{blessed} = $obj;
+        is( $db->{blessed}{a}, 1 );
+        is( $db->{blessed}{b}[0], 1 );
+        is( $db->{blessed}{b}[1], 2 );
+        is( $db->{blessed}{b}[2], 3 );
+
+        my $obj2 = bless [
+            { a => 'foo' },
+            2,
+        ], 'Foo';
+        $db->{blessed2} = $obj2;
+
+        is( $db->{blessed2}[0]{a}, 'foo' );
+        is( $db->{blessed2}[1], '2' );
+
+        $db->{unblessed} = {};
+        $db->{unblessed}{a} = 1;
+        $db->{unblessed}{b} = [];
+        $db->{unblessed}{b}[0] = 1;
+        $db->{unblessed}{b}[1] = 2;
+        $db->{unblessed}{b}[2] = 3;
+
+        is( $db->{unblessed}{a}, 1 );
+        is( $db->{unblessed}{b}[0], 1 );
+        is( $db->{unblessed}{b}[1], 2 );
+        is( $db->{unblessed}{b}[2], 3 );
+
+        $db->{blessed_long} = bless {}, 'a' x 1000;
+        $db->_get_self->_engine->storage->close( $db->_get_self );
+    }
+
+    {
+        my $db = $dbm_maker->();
+
+        my $obj = $db->{blessed};
+        isa_ok( $obj, 'Foo' );
+        can_ok( $obj, 'export', 'foo' );
+        ok( !$obj->can( 'STORE' ), "... but it cannot 'STORE'" );
+
+        is( $obj->{a}, 1 );
+        is( $obj->{b}[0], 1 );
+        is( $obj->{b}[1], 2 );
+        is( $obj->{b}[2], 3 );
+
+        my $obj2 = $db->{blessed2};
+        isa_ok( $obj2, 'Foo' );
+        can_ok( $obj2, 'export', 'foo' );
+        ok( !$obj2->can( 'STORE' ), "... but it cannot 'STORE'" );
+
+        is( $obj2->[0]{a}, 'foo' );
+        is( $obj2->[1], '2' );
+
+        is( $db->{unblessed}{a}, 1 );
+        is( $db->{unblessed}{b}[0], 1 );
+        is( $db->{unblessed}{b}[1], 2 );
+        is( $db->{unblessed}{b}[2], 3 );
+
+        $obj->{c} = 'new';
+        is( $db->{blessed}{c}, 'new' );
+
+        isa_ok( $db->{blessed_long}, 'a' x 1000 );
+        $db->_get_self->_engine->storage->close( $db->_get_self );
+    }
+
+    {
+        my $db = $dbm_maker->();
+        is( $db->{blessed}{c}, 'new' );
+
+        my $structure = $db->export();
+        use Data::Dumper;print Dumper $structure;
+
+        my $obj = $structure->{blessed};
+        isa_ok( $obj, 'Foo' );
+        can_ok( $obj, 'export', 'foo' );
+        ok( !$obj->can( 'STORE' ), "... but it cannot 'STORE'" );
+
+        is( $obj->{a}, 1 );
+        is( $obj->{b}[0], 1 );
+        is( $obj->{b}[1], 2 );
+        is( $obj->{b}[2], 3 );
+
+        my $obj2 = $structure->{blessed2};
+        isa_ok( $obj2, 'Foo' );
+        can_ok( $obj2, 'export', 'foo' );
+        ok( !$obj2->can( 'STORE' ), "... but it cannot 'STORE'" );
+
+        is( $obj2->[0]{a}, 'foo' );
+        is( $obj2->[1], '2' );
+
+        is( $structure->{unblessed}{a}, 1 );
+        is( $structure->{unblessed}{b}[0], 1 );
+        is( $structure->{unblessed}{b}[1], 2 );
+        is( $structure->{unblessed}{b}[2], 3 );
+        $db->_get_self->_engine->storage->close( $db->_get_self );
+    }
+
+    {
+        my $db = $dbm_maker->( autobless => 0 );
+
+        my $obj = $db->{blessed};
+        isa_ok( $obj, 'DBM::Deep' );
+        can_ok( $obj, 'export', 'STORE' );
+        ok( !$obj->can( 'foo' ), "... but it cannot 'foo'" );
+
+        is( $obj->{a}, 1 );
+        is( $obj->{b}[0], 1 );
+        is( $obj->{b}[1], 2 );
+        is( $obj->{b}[2], 3 );
+
+        my $obj2 = $db->{blessed2};
+        isa_ok( $obj2, 'DBM::Deep' );
+        can_ok( $obj2, 'export', 'STORE' );
+        ok( !$obj2->can( 'foo' ), "... but it cannot 'foo'" );
+
+        is( $obj2->[0]{a}, 'foo' );
+        is( $obj2->[1], '2' );
+
+        is( $db->{unblessed}{a}, 1 );
+        is( $db->{unblessed}{b}[0], 1 );
+        is( $db->{unblessed}{b}[1], 2 );
+        is( $db->{unblessed}{b}[2], 3 );
+        $db->_get_self->_engine->storage->close( $db->_get_self );
+    }
 }
 
-my $obj = bless {
-    a => 1,
-    b => [ 1 .. 3 ],
-}, 'Foo';
-
-$db->{blessed} = $obj;
-
-$db->{unblessed} = {};
-$db->{unblessed}{a} = 1;
-$db->{unblessed}{b} = [];
-$db->{unblessed}{b}[0] = 1;
-$db->{unblessed}{b}[1] = 2;
-$db->{unblessed}{b}[2] = 3;
-
-undef $db;
-
-my $db2 = DBM::Deep->new(
-    file     => 't/test.db',
-    autoflush => 1,
-    autobless => 1,
-);
-if ($db2->error()) {
-	die "ERROR: " . $db2->error();
+$dbm_factory = new_dbm( autobless => 1 );
+while ( my $dbm_maker = $dbm_factory->() ) {
+    {
+        my $db = $dbm_maker->();
+        my $obj = bless {
+            a => 1,
+            b => [ 1 .. 3 ],
+        }, 'Foo';
+
+        $db->import( { blessed => $obj } );
+    }
+
+    {
+        my $db = $dbm_maker->();
+
+        my $blessed = $db->{blessed};
+        isa_ok( $blessed, 'Foo' );
+        is( $blessed->{a}, 1 );
+    }
 }
 
-my $obj2 = $db2->{blessed};
-isa_ok( $obj2, 'Foo' );
-can_ok( $obj2, 'export', 'foo' );
-ok( !$obj2->can( 'STORE' ), "... but it cannot 'STORE'" );
-
-is( $obj2->{a}, 1 );
-is( $obj2->{b}[0], 1 );
-is( $obj2->{b}[1], 2 );
-is( $obj2->{b}[2], 3 );
-
-is( $db2->{unblessed}{a}, 1 );
-is( $db2->{unblessed}{b}[0], 1 );
-is( $db2->{unblessed}{b}[1], 2 );
-is( $db2->{unblessed}{b}[2], 3 );
-
-my $db3 = DBM::Deep->new(
-    file     => 't/test.db',
-    autoflush => 1,
-#    autobless => 0,
-);
-if ($db3->error()) {
-	die "ERROR: " . $db3->error();
-}
+# test blessing hash into short named class (Foo), then re-blessing into
+# longer named class (FooFoo) and replacing key in db file, then validating
+# content after that point in file to check for corruption.
+$dbm_factory = new_dbm( autobless => 1 );
+while ( my $dbm_maker = $dbm_factory->() ) {
+    my $db = $dbm_maker->();
+
+    my $obj = bless {}, 'Foo';
+
+    $db->{blessed} = $obj;
+    $db->{after} = "hello";
 
-my $obj3 = $db3->{blessed};
-isa_ok( $obj3, 'DBM::Deep' );
-can_ok( $obj3, 'export', 'STORE' );
-ok( !$obj3->can( 'foo' ), "... but it cannot 'foo'" );
+    my $obj2 = bless {}, 'FooFoo';
 
-is( $obj3->{a}, 1 );
-is( $obj3->{b}[0], 1 );
-is( $obj3->{b}[1], 2 );
-is( $obj3->{b}[2], 3 );
+    $db->{blessed} = $obj2;
+
+    is( $db->{after}, "hello" );
+}
 
-is( $db3->{unblessed}{a}, 1 );
-is( $db3->{unblessed}{b}[0], 1 );
-is( $db3->{unblessed}{b}[1], 2 );
-is( $db3->{unblessed}{b}[2], 3 );
+done_testing;