From 00078cf200c23f392322f4fdc29e4f44ddf73f41 Mon Sep 17 00:00:00 2001 From: Charles McGarvey Date: Wed, 27 Apr 2022 14:23:54 -0600 Subject: [PATCH] Fill out recycle bin functionality --- lib/File/KDBX.pm | 93 +++++++++++++++++++++++++++++- lib/File/KDBX/Entry.pm | 6 +- lib/File/KDBX/Group.pm | 82 ++++++++++++++++++++++++--- lib/File/KDBX/Loader/KDB.pm | 2 +- lib/File/KDBX/Object.pm | 110 ++++++++++++++++++++++++++++++------ t/database.t | 37 ++++++++++++ t/entry.t | 2 +- t/object.t | 8 +-- 8 files changed, 305 insertions(+), 35 deletions(-) diff --git a/lib/File/KDBX.pm b/lib/File/KDBX.pm index b69d556..47b49a1 100644 --- 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 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); @@ -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 if there is no recycle bin and L 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 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 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 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 diff --git a/lib/File/KDBX/Entry.pm b/lib/File/KDBX/Entry.pm index a242def..e9e107f 100644 --- 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. -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 @@ -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 -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 - 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 3b8b458..0c784cd 100644 --- a/lib/File/KDBX/Group.pm +++ b/lib/File/KDBX/Group.pm @@ -5,7 +5,7 @@ use warnings; 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); @@ -131,11 +131,13 @@ sub add_entry { 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 $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; } } @@ -217,11 +219,13 @@ sub add_group { 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 $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; } } @@ -300,16 +304,76 @@ sub remove_object { $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; - 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); } +=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; diff --git a/lib/File/KDBX/Loader/KDB.pm b/lib/File/KDBX/Loader/KDB.pm index 9feaaac..cc9104c 100644 --- 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, $_); - $_->remove; # TODO do not signal + $_->remove(signal => 0); }); return $kdbx; diff --git a/lib/File/KDBX/Object.pm b/lib/File/KDBX/Object.pm index 7c538bf..9f25c38 100644 --- a/lib/File/KDBX/Object.pm +++ b/lib/File/KDBX/Object.pm @@ -5,10 +5,11 @@ use warnings; 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 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; @@ -133,9 +134,9 @@ sub label { die 'Not implemented' } $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 - If set, generate a new UUID for the copy (default: false) @@ -235,7 +236,7 @@ sub STORABLE_thaw { $kdbx = $object->kdbx; $object->kdbx($kdbx); -Get or set the L instance associated with this object. +Get or set the L instance connected with this object. =cut @@ -251,7 +252,20 @@ sub kdbx { 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 @@ -278,12 +292,23 @@ sub id { format_uuid(shift->uuid, @_) } # OR equivalently $group = $object->parent; -Get the parent group to which an object belongs or C if it belongs to no group. + $object->group($new_parent); + +Get or set the parent group to which an object belongs or C if it belongs to no group. =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; @@ -346,21 +371,73 @@ sub lineage { =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 Whether or not to signal the removal to the connected database (default: true) =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; - $parent->remove_object($self) if $parent; + $parent->remove_object($self, @_) if $parent; + $self->_set_group(undef); 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. 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; @@ -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. -Each object can be associated with a L 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 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 diff --git a/t/database.t b/t/database.t index 5d7b991..d4a523c 100644 --- a/t/database.t +++ b/t/database.t @@ -54,4 +54,41 @@ subtest 'Clone' => sub { }, @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; diff --git a/t/entry.t b/t/entry.t index 3a6267d..988e712 100644 --- 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'; - 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'; diff --git a/t/object.t b/t/object.t index b176c77..ebf039f 100644 --- 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; - 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; - 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'); -- 2.43.0