Fill out recycle bin functionality

diff --git a/lib/File/KDBX.pm b/lib/File/KDBX.pm
index b69d556133535a3e060a6574488ef4326d3ad85b..47b49a1dd342a31cd4bf926326c1a3f93588c592 100644 (file)
--- a/lib/File/KDBX.pm
+++ b/lib/File/KDBX.pm
@@ -6,7 +6,7 @@ use strict;
 
 use Crypt::PRNG qw(random_bytes);
 use Devel::GlobalDestruction;
 
 use Crypt::PRNG qw(random_bytes);
 use Devel::GlobalDestruction;

-use File::KDBX::Constants qw(:all);
+use File::KDBX::Constants qw(:all :icon);

 use File::KDBX::Error;
 use File::KDBX::Safe;
 use File::KDBX::Util qw(:class :coercion :empty :search :uuid erase simple_expression_query snakify);
 use File::KDBX::Error;
 use File::KDBX::Safe;
 use File::KDBX::Util qw(:class :coercion :empty :search :uuid erase simple_expression_query snakify);


@@ -495,6 +495,97 @@ sub _trace_lineage {
     }
 }
 
     }
 }
 

+=method recycle_bin
+
+    $group = $kdbx->recycle_bin;
+    $kdbx->recycle_bin($group);
+
+Get or set the recycle bin group. Returns C<undef> if there is no recycle bin and L</recycle_bin_enabled> is
+false, otherwise the current recycle bin or an autovivified recycle bin group is returned.
+
+=cut
+
+sub recycle_bin {
+    my $self = shift;
+    if (my $group = shift) {
+        $self->recycle_bin_uuid($group->uuid);
+        return $group;
+    }
+    my $group;
+    my $uuid = $self->recycle_bin_uuid;
+    $group = $self->groups->grep(uuid => $uuid)->next if $uuid ne UUID_NULL;
+    if (!$group && $self->recycle_bin_enabled) {
+        $group = $self->add_group(
+            name                => 'Recycle Bin',
+            icon_id             => ICON_TRASHCAN_FULL,
+            enable_auto_type    => false,
+            enable_searching    => false,
+        );
+        $self->recycle_bin_uuid($group->uuid);
+    }
+    return $group;
+}
+
+=method entry_templates
+
+    $group = $kdbx->entry_templates;
+    $kdbx->entry_templates($group);
+
+Get or set the entry templates group. May return C<undef> if unset.
+
+=cut
+
+sub entry_templates {
+    my $self = shift;
+    if (my $group = shift) {
+        $self->entry_templates_group($group->uuid);
+        return $group;
+    }
+    my $uuid = $self->entry_templates_group;
+    return if $uuid eq UUID_NULL;
+    return $self->groups->grep(uuid => $uuid)->next;
+}
+
+=method last_selected
+
+    $group = $kdbx->last_selected;
+    $kdbx->last_selected($group);
+
+Get or set the last selected group. May return C<undef> if unset.
+
+=cut
+
+sub last_selected {
+    my $self = shift;
+    if (my $group = shift) {
+        $self->last_selected_group($group->uuid);
+        return $group;
+    }
+    my $uuid = $self->last_selected_group;
+    return if $uuid eq UUID_NULL;
+    return $self->groups->grep(uuid => $uuid)->next;
+}
+
+=method last_top_visible
+
+    $group = $kdbx->last_top_visible;
+    $kdbx->last_top_visible($group);
+
+Get or set the last top visible group. May return C<undef> if unset.
+
+=cut
+
+sub last_top_visible {
+    my $self = shift;
+    if (my $group = shift) {
+        $self->last_top_visible_group($group->uuid);
+        return $group;
+    }
+    my $uuid = $self->last_top_visible_group;
+    return if $uuid eq UUID_NULL;
+    return $self->groups->grep(uuid => $uuid)->next;
+}
+

 ##############################################################################
 
 =method add_group
 ##############################################################################
 
 =method add_group

diff --git a/lib/File/KDBX/Entry.pm b/lib/File/KDBX/Entry.pm
index a242def254fd6bcbc8e17dcf31225c26d3a08acc..e9e107f589a47d4c7cfd1d71d41da130833714d6 100644 (file)
--- a/lib/File/KDBX/Entry.pm
+++ b/lib/File/KDBX/Entry.pm
@@ -324,8 +324,8 @@ do not expand to values are left as-is.
 
 See L</Placeholders>.
 
 
 See L</Placeholders>.
 

-Some placeholders (notably field references) require the entry be associated with a database and will throw an
-error if there is no association.
+Some placeholders (notably field references) require the entry be connected to a database and will throw an
+error if it is not.

 
 =cut
 
 
 =cut
 


@@ -754,7 +754,7 @@ sub history_size {
     $entry->prune_history(%options);
 
 Remove as many older historical entries as necessary to get under the database limits. The limits are taken
     $entry->prune_history(%options);
 
 Remove as many older historical entries as necessary to get under the database limits. The limits are taken

-from the associated database (if any) or can be overridden with C<%options>:
+from the connected database (if any) or can be overridden with C<%options>:

 
 =for :list
 * C<max_items> - Maximum number of historical entries to keep (default: 10, no limit: -1)
 
 =for :list
 * C<max_items> - Maximum number of historical entries to keep (default: 10, no limit: -1)

diff --git a/lib/File/KDBX/Group.pm b/lib/File/KDBX/Group.pm
index 3b8b458ada0fccfaced3a9390f14b632cf7e4255..0c784cdbf5712df4d82d06aa077e9dca515f7f59 100644 (file)
--- a/lib/File/KDBX/Group.pm
+++ b/lib/File/KDBX/Group.pm
@@ -5,7 +5,7 @@ use warnings;
 use strict;
 
 use Devel::GlobalDestruction;
 use strict;
 
 use Devel::GlobalDestruction;

-use File::KDBX::Constants qw(:icon);
+use File::KDBX::Constants qw(:bool :icon);

 use File::KDBX::Error;
 use File::KDBX::Iterator;
 use File::KDBX::Util qw(:assert :class :coercion generate_uuid);
 use File::KDBX::Error;
 use File::KDBX::Iterator;
 use File::KDBX::Util qw(:assert :class :coercion generate_uuid);


@@ -131,11 +131,13 @@ sub add_entry {
 sub remove_entry {
     my $self = shift;
     my $uuid = is_ref($_[0]) ? $self->_wrap_entry(shift)->uuid : shift;
 sub remove_entry {
     my $self = shift;
     my $uuid = is_ref($_[0]) ? $self->_wrap_entry(shift)->uuid : shift;

+    my %args = @_;

     my $objects = $self->{entries};
     for (my $i = 0; $i < @$objects; ++$i) {
     my $objects = $self->{entries};
     for (my $i = 0; $i < @$objects; ++$i) {

-        my $o = $objects->[$i];
-        next if $uuid ne $o->uuid;
-        $o->_set_group(undef)->_signal('removed');
+        my $object = $objects->[$i];
+        next if $uuid ne $object->uuid;
+        $object->_set_group(undef);
+        $object->_signal('removed') if $args{signal} // 1;

         return splice @$objects, $i, 1;
     }
 }
         return splice @$objects, $i, 1;
     }
 }


@@ -217,11 +219,13 @@ sub add_group {
 sub remove_group {
     my $self = shift;
     my $uuid = is_ref($_[0]) ? $self->_wrap_group(shift)->uuid : shift;
 sub remove_group {
     my $self = shift;
     my $uuid = is_ref($_[0]) ? $self->_wrap_group(shift)->uuid : shift;

+    my %args = @_;

     my $objects = $self->{groups};
     for (my $i = 0; $i < @$objects; ++$i) {
     my $objects = $self->{groups};
     for (my $i = 0; $i < @$objects; ++$i) {

-        my $o = $objects->[$i];
-        next if $uuid ne $o->uuid;
-        $o->_set_group(undef)->_signal('removed');
+        my $object = $objects->[$i];
+        next if $uuid ne $object->uuid;
+        $object->_set_group(undef);
+        $object->_signal('removed') if $args{signal} // 1;

         return splice @$objects, $i, 1;
     }
 }
         return splice @$objects, $i, 1;
     }
 }


@@ -300,16 +304,76 @@ sub remove_object {
 
     $bool = $group->is_root;
 
 
     $bool = $group->is_root;
 

-Determine if a group is the root group of its associated database.
+Determine if a group is the root group of its connected database.

 
 =cut
 
 sub is_root {
     my $self = shift;
 
 =cut
 
 sub is_root {
     my $self = shift;

-    my $kdbx = eval { $self->kdbx } or return;
+    my $kdbx = eval { $self->kdbx } or return FALSE;

     return Hash::Util::FieldHash::id($kdbx->root) == Hash::Util::FieldHash::id($self);
 }
 
     return Hash::Util::FieldHash::id($kdbx->root) == Hash::Util::FieldHash::id($self);
 }
 

+=method is_recycle_bin
+
+    $bool = $group->is_recycle_bin;
+
+Get whether or not a group is the recycle bin of its connected database.
+
+=cut
+
+sub is_recycle_bin {
+    my $self    = shift;
+    my $kdbx    = eval { $self->kdbx } or return FALSE;
+    my $group   = $kdbx->recycle_bin;
+    return $group && Hash::Util::FieldHash::id($group) == Hash::Util::FieldHash::id($self);
+}
+
+=method is_entry_templates
+
+    $bool = $group->is_entry_templates;
+
+Get whether or not a group is the group containing entry template of its connected database.
+
+=cut
+
+sub entry_templates {
+    my $self    = shift;
+    my $kdbx    = eval { $self->kdbx } or return FALSE;
+    my $group   = $kdbx->entry_templates;
+    return $group && Hash::Util::FieldHash::id($group) == Hash::Util::FieldHash::id($self);
+}
+
+=method is_last_selected
+
+    $bool = $group->is_last_selected;
+
+Get whether or not a group is the prior selected group of its connected database.
+
+=cut
+
+sub last_selected {
+    my $self    = shift;
+    my $kdbx    = eval { $self->kdbx } or return FALSE;
+    my $group   = $kdbx->last_selected;
+    return $group && Hash::Util::FieldHash::id($group) == Hash::Util::FieldHash::id($self);
+}
+
+=method is_last_top_visible
+
+    $bool = $group->is_last_top_visible;
+
+Get whether or not a group is the latest top visible group of its connected database.
+
+=cut
+
+sub last_top_visible {
+    my $self    = shift;
+    my $kdbx    = eval { $self->kdbx } or return FALSE;
+    my $group   = $kdbx->last_top_visible;
+    return $group && Hash::Util::FieldHash::id($group) == Hash::Util::FieldHash::id($self);
+}
+

 =method path
 
     $string = $group->path;
 =method path
 
     $string = $group->path;

diff --git a/lib/File/KDBX/Loader/KDB.pm b/lib/File/KDBX/Loader/KDB.pm
index 9feaaacf7e4bb3972fe944266eb9f1d372d3eefd..cc9104c3eb94c85dae9c3321cec0e4c6ad474bda 100644 (file)
--- a/lib/File/KDBX/Loader/KDB.pm
+++ b/lib/File/KDBX/Loader/KDB.pm
@@ -100,7 +100,7 @@ sub convert_keepass_to_kdbx {
     })
     ->each(sub {
         _read_meta_stream($kdbx, $_);
     })
     ->each(sub {
         _read_meta_stream($kdbx, $_);

-        $_->remove; # TODO do not signal
+        $_->remove(signal => 0);

     });
 
     return $kdbx;
     });
 
     return $kdbx;

diff --git a/lib/File/KDBX/Object.pm b/lib/File/KDBX/Object.pm
index 7c538bf3df44d7b234b942b03df91713155dd119..9f25c3897b95bae4b6226dd26a07418954e2cf53 100644 (file)
--- a/lib/File/KDBX/Object.pm
+++ b/lib/File/KDBX/Object.pm
@@ -5,10 +5,11 @@ use warnings;
 use strict;
 
 use Devel::GlobalDestruction;
 use strict;
 
 use Devel::GlobalDestruction;

+use File::KDBX::Constants qw(:bool);

 use File::KDBX::Error;
 use File::KDBX::Util qw(:uuid);
 use Hash::Util::FieldHash qw(fieldhashes);
 use File::KDBX::Error;
 use File::KDBX::Util qw(:uuid);
 use Hash::Util::FieldHash qw(fieldhashes);

-use List::Util qw(first);
+use List::Util qw(any first);

 use Ref::Util qw(is_arrayref is_plain_arrayref is_plain_hashref is_ref);
 use Scalar::Util qw(blessed weaken);
 use namespace::clean;
 use Ref::Util qw(is_arrayref is_plain_arrayref is_plain_hashref is_ref);
 use Scalar::Util qw(blessed weaken);
 use namespace::clean;


@@ -133,9 +134,9 @@ sub label { die 'Not implemented' }
     $object_copy = $object->clone;
     $object_copy = File::KDBX::Object->new($object);
 
     $object_copy = $object->clone;
     $object_copy = File::KDBX::Object->new($object);
 

-Make a clone of an object. By default the clone is indeed an exact copy that is associated with the same
-database but not actually included in the object tree (i.e. it has no parent). Some options are allowed to
-get different effects:
+Make a clone of an object. By default the clone is indeed an exact copy that is connected to the same database
+but not actually included in the object tree (i.e. it has no parent). Some options are allowed to get
+different effects:

 
 =for :list
 * C<new_uuid> - If set, generate a new UUID for the copy (default: false)
 
 =for :list
 * C<new_uuid> - If set, generate a new UUID for the copy (default: false)


@@ -235,7 +236,7 @@ sub STORABLE_thaw {
     $kdbx = $object->kdbx;
     $object->kdbx($kdbx);
 
     $kdbx = $object->kdbx;
     $object->kdbx($kdbx);
 

-Get or set the L<File::KDBX> instance associated with this object.
+Get or set the L<File::KDBX> instance connected with this object.

 
 =cut
 
 
 =cut
 


@@ -251,7 +252,20 @@ sub kdbx {
             delete $KDBX{$self};
         }
     }
             delete $KDBX{$self};
         }
     }

-    $KDBX{$self} or throw 'Object is disassociated from a KDBX database', object => $self;
+    $KDBX{$self} or throw 'Object is disconnected', object => $self;
+}
+
+=method is_connected
+
+    $bool = $object->is_connected;
+
+Determine whether or not an object is connected to a database.
+
+=cut
+
+sub is_connected {
+    my $self = shift;
+    return !!eval { $self->kdbx };

 }
 
 =method id
 }
 
 =method id


@@ -278,12 +292,23 @@ sub id { format_uuid(shift->uuid, @_) }
     # OR equivalently
     $group = $object->parent;
 
     # OR equivalently
     $group = $object->parent;
 

-Get the parent group to which an object belongs or C<undef> if it belongs to no group.
+    $object->group($new_parent);
+
+Get or set the parent group to which an object belongs or C<undef> if it belongs to no group.

 
 =cut
 
 sub group {
     my $self = shift;
 
 =cut
 
 sub group {
     my $self = shift;

+
+    if (my $new_group = shift) {
+        my $old_group = $self->group;
+        return $new_group if Hash::Util::FieldHash::id($old_group) == Hash::Util::FieldHash::id($new_group);
+        # move to a new parent
+        $self->remove(signal => 0) if $old_group;
+        $new_group->add_object($self);
+    }
+

     my $id   = Hash::Util::FieldHash::id($self);
     if (my $group = $PARENT{$self}) {
         my $method = $self->_parent_container;
     my $id   = Hash::Util::FieldHash::id($self);
     if (my $group = $PARENT{$self}) {
         my $method = $self->_parent_container;


@@ -346,21 +371,73 @@ sub lineage {
 
 =method remove
 
 
 =method remove
 

-    $object = $object->remove;
+    $object = $object->remove(%options);
+
+Remove an object from its parent. If the object is a group, all contained objects stay with the object and so
+are removed as well. Options:

 
 

-Remove the object from the database. If the object is a group, all contained objects are removed as well.
+=for :list
+* C<signal> Whether or not to signal the removal to the connected database (default: true)

 
 =cut
 
 sub remove {
 
 =cut
 
 sub remove {

-    # TODO - need a way to not signal database because there are times like in the KDB loader and meta streams
-    # where we do not want to add UUIDs to deleted objects

     my $self = shift;
     my $parent = $self->parent;
     my $self = shift;
     my $parent = $self->parent;

-    $parent->remove_object($self) if $parent;
+    $parent->remove_object($self, @_) if $parent;
+    $self->_set_group(undef);

     return $self;
 }
 
     return $self;
 }
 

+=method recycle
+
+    $object = $object->recycle;
+
+Remove an object from its parent and add it to the connected database's recycle bin group.
+
+=cut
+
+sub recycle {
+    my $self = shift;
+    return $self->parent($self->kdbx->recycle_bin);
+}
+
+=method recycle_or_remove
+
+    $object = $object->recycle_or_remove;
+
+Recycle or remove an object, depending on the connected database's L<File::KDBX/recycle_bin_enabled>. If the
+object is not connected to a database or is already in the recycle bin, remove it.
+
+=cut
+
+sub recycle_or_remove {
+    my $self = shift;
+    my $kdbx = eval { $self->kdbx };
+    if ($kdbx && $kdbx->recycle_bin_enabled && !$self->is_recycled) {
+        $self->recycle;
+    }
+    else {
+        $self->remove;
+    }
+}
+
+=method is_recycled
+
+    $bool = $object->is_recycled;
+
+Get whether or not an object is in a recycle bin.
+
+=cut
+
+sub is_recycled {
+    my $self = shift;
+    eval { $self->kdbx } or return FALSE;
+    return !!($self->parent && any { $_->is_recycle_bin } @{$self->lineage});
+}
+
+##############################################################################
+

 =method tag_list
 
     @tags = $entry->tag_list;
 =method tag_list
 
     @tags = $entry->tag_list;


@@ -726,10 +803,11 @@ but instead use its subclasses:
 
 There is some functionality shared by both types of objects, and that's what this class provides.
 
 
 There is some functionality shared by both types of objects, and that's what this class provides.
 

-Each object can be associated with a L<File::KDBX> database or be disassociated. A disassociated object will
-not be persisted when dumping a database. It is also possible for an object to be associated with a database
-but not be part of the object tree (i.e. is not the root group or any subroup or entry). A disassociated
-object or an object not part of the object tree of a database can be added to a database using one of:
+Each object can be connected with a L<File::KDBX> database or be disconnected. A disconnected object exists in
+memory but will not be persisted when dumping a database. It is also possible for an object to be connected
+with a database but not be part of the object tree (i.e. is not the root group or any subroup or entry).
+A disconnected object or an object not part of the object tree of a database can be added to a database using
+one of:

 
 =for :list
 * L<File::KDBX/add_entry>
 
 =for :list
 * L<File::KDBX/add_entry>

diff --git a/t/database.t b/t/database.t
index 5d7b9916e9e0c4a34cbaceb8fc9f0da8548a0b6b..d4a523cb5145701bf5d668eccbf3623f2b8496e9 100644 (file)
--- a/t/database.t
+++ b/t/database.t
@@ -54,4 +54,41 @@ subtest 'Clone' => sub {
     }, @objects;
 };
 
     }, @objects;
 };
 

+subtest 'Recycle bin' => sub {
+    my $kdbx = File::KDBX->new;
+    my $entry = $kdbx->add_entry(label => 'Meh');
+
+    my $bin = $kdbx->groups->grep(name => 'Recycle Bin')->next;
+    ok !$bin, 'New database has no recycle bin';
+
+    is $kdbx->recycle_bin_enabled, 1, 'Recycle bin is enabled';
+    $kdbx->recycle_bin_enabled(0);
+
+    $entry->recycle_or_remove;
+    cmp_ok $entry->is_recycled, '==', 0, 'Entry is not recycle if recycle bin is disabled';
+
+    $bin = $kdbx->groups->grep(name => 'Recycle Bin')->next;
+    ok !$bin, 'Recycle bin not autovivified if recycle bin is disabled';
+    is $kdbx->entries->size, 0, 'Database is empty after removing entry';
+
+    $kdbx->recycle_bin_enabled(1);
+
+    $entry = $kdbx->add_entry(label => 'Another one');
+    $entry->recycle_or_remove;
+    cmp_ok $entry->is_recycled, '==', 1, 'Entry is recycled';
+
+    $bin = $kdbx->groups->grep(name => 'Recycle Bin')->next;
+    ok $bin, 'Recycle bin group autovivifies';
+    cmp_ok $bin->icon_id, '==', 43, 'Recycle bin has the trash icon';
+    cmp_ok $bin->enable_auto_type, '==', 0, 'Recycle bin has auto type disabled';
+    cmp_ok $bin->enable_searching, '==', 0, 'Recycle bin has searching disabled';
+
+    is $kdbx->entries->size, 1, 'Database is not empty';
+    is $kdbx->entries(searching => 1)->size, 0, 'Database has no entries if searching';
+    cmp_ok $bin->entries_deeply->size, '==', 1, 'Recycle bin has an entry';
+
+    $entry->recycle_or_remove;
+    is $kdbx->entries->size, 0, 'Remove entry if it is already in the recycle bin';
+};
+

 done_testing;
 done_testing;

diff --git a/t/entry.t b/t/entry.t
index 3a6267d4a4059301f1d110fef993a80261e8a6ba..988e71214c0ba441315798fb12bfcc2cfe24cb6a 100644 (file)
--- a/t/entry.t
+++ b/t/entry.t
@@ -18,7 +18,7 @@ subtest 'Construction' => sub {
     is $entry->{username}, 'foo', 'username is in the object still';
     is $entry->username, '', 'username is not the UserName string';
 
     is $entry->{username}, 'foo', 'username is in the object still';
     is $entry->username, '', 'username is not the UserName string';
 

-    like exception { $entry->kdbx }, qr/disassociated from a KDBX database/, 'Dies if disassociated';
+    like exception { $entry->kdbx }, qr/disconnected/, 'Dies if disconnected';

     $entry->kdbx(my $kdbx = File::KDBX->new);
     is $entry->kdbx, $kdbx, 'Set a database after instantiation';
 
     $entry->kdbx(my $kdbx = File::KDBX->new);
     is $entry->kdbx, $kdbx, 'Set a database after instantiation';
 

diff --git a/t/object.t b/t/object.t
index b176c7793a0b90d0cff9bd694c691a59df1a7a85..ebf039fc0895ebd0e2402e98f46ad7de01ee7754 100644 (file)
--- a/t/object.t
+++ b/t/object.t
@@ -17,13 +17,13 @@ subtest 'Cloning' => sub {
     my $entry = File::KDBX::Entry->new;
 
     my $copy = $entry->clone;
     my $entry = File::KDBX::Entry->new;
 
     my $copy = $entry->clone;

-    like exception { $copy->kdbx }, qr/disassociated/, 'Disassociated entry copy is also disassociated';
-    cmp_deeply $copy, $entry, 'Disassociated entry and its clone are identical';
+    like exception { $copy->kdbx }, qr/disconnected/, 'Disconnected entry copy is also disconnectedisconnected';
+    cmp_deeply $copy, $entry, 'Disconnected entry and its clone are identical';

 
     $entry->kdbx($kdbx);
     $copy = $entry->clone;
 
     $entry->kdbx($kdbx);
     $copy = $entry->clone;

-    is $entry->kdbx, $copy->kdbx, 'Associated entry copy is also associated';
-    cmp_deeply $copy, $entry, 'Associated entry and its clone are identical';
+    is $entry->kdbx, $copy->kdbx, 'Connected entry copy is also connected';
+    cmp_deeply $copy, $entry, 'Connected entry and its clone are identical';

 
     my $txn = $entry->begin_work;
     $entry->title('foo');
 
     my $txn = $entry->begin_work;
     $entry->title('foo');