X-Git-Url: https://git.dogcows.com/gitweb?a=blobdiff_plain;f=t%2Fdatabase.t;h=5d7b9916e9e0c4a34cbaceb8fc9f0da8548a0b6b;hb=c98fc7d0294e641cf8844306808333bdec4fea2f;hp=951ff74fc80cff167002a8de0b41e15b26f1cfc7;hpb=f63182fc62b25269b1c38588dca2b3535ed1a1a2;p=chaz%2Fp5-File-KDBX

diff --git a/t/database.t b/t/database.t
index 951ff74..5d7b991 100644
--- a/t/database.t
+++ b/t/database.t
@@ -8,28 +8,50 @@ use FindBin qw($Bin);
 use lib "$Bin/lib";
 use TestCommon;
 
+use File::KDBX;
+use Test::Deep;
 use Test::More;
 
-BEGIN { use_ok 'File::KDBX' }
-
 subtest 'Create a new database' => sub {
     my $kdbx = File::KDBX->new;
 
     $kdbx->add_group(name => 'Meh');
-    ok $kdbx->_is_implicit_root, 'Database starts off with implicit root';
+    ok $kdbx->_has_implicit_root, 'Database starts off with implicit root';
 
-    $kdbx->add_entry({
+    my $entry = $kdbx->add_entry({
         username    => 'hello',
         password    => {value => 'This is a secret!!!!!', protect => 1},
     });
 
-    ok !$kdbx->_is_implicit_root, 'Adding an entry to the root group makes it explicit';
-
-    $kdbx->unlock;
+    ok !$kdbx->_has_implicit_root, 'Adding an entry to the root group makes it explicit';
 
-    # dumper $kdbx->groups;
+    $entry->remove;
+    ok $kdbx->_has_implicit_root, 'Removing group makes the root group implicit again';
+};
 
-    pass;
+subtest 'Clone' => sub {
+    my $kdbx = File::KDBX->new;
+    $kdbx->add_group(name => 'Passwords')->add_entry(title => 'My Entry');
+
+    my $copy = $kdbx->clone;
+    cmp_deeply $copy, $kdbx, 'Clone keeps the same structure and data' or dumper $copy;
+
+    isnt $kdbx, $copy, 'Clone is a different object';
+    isnt $kdbx->root, $copy->root,
+        'Clone root group is a different object';
+    isnt $kdbx->root->groups->[0], $copy->root->groups->[0],
+        'Clone group is a different object';
+    isnt $kdbx->root->groups->[0]->entries->[0], $copy->root->groups->[0]->entries->[0],
+        'Clone entry is a different object';
+
+    my @objects = $copy->objects->each;
+    subtest 'Cloned objects refer to the cloned database' => sub {
+        plan tests => scalar @_;
+        for my $object (@objects) {
+            my $object_kdbx = eval { $object->kdbx };
+            is $object_kdbx, $copy, 'Object: ' . $object->label;
+        }
+    }, @objects;
 };
 
 done_testing;