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);
}
}
+=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
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
$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)
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);
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;
}
}
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;
}
}
$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;
})
->each(sub {
_read_meta_stream($kdbx, $_);
- $_->remove; # TODO do not signal
+ $_->remove(signal => 0);
});
return $kdbx;
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;
$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)
$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
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
# 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;
+
+ 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;
=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 {
- # 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<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;
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>
}, @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;
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';
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');
projects / chaz / p5-File-KDBX / commitdiff
