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;
my $self = bless $data // {}, $class;
$self->init(%args);
- $self->_set_default_attributes if !$data;
+ $self->_set_nonlazy_attributes if !$data;
return $self;
}
-sub _set_default_attributes { die 'Not implemented' }
+sub _set_nonlazy_attributes { die 'Not implemented' }
=method init
$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 the object from the database. If the object is a group, all contained objects are removed as well.
+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:
+
+=for :list
+* C<signal> Whether or not to signal the removal to the connected database (default: true)
=cut
sub remove {
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;
##############################################################################
-sub _signal {
- my $self = shift;
- my $type = shift;
-
- if ($self->_in_txn) {
- my $stack = $self->_signal_stack;
- my $queue = $stack->[-1];
- push @$queue, [$type, @_];
- }
-
- $self->_signal_send([[$type, @_]]);
-}
-
-sub _signal_stack { $SIGNALS{$_[0]} //= [] }
-
-sub _signal_begin_work {
- my $self = shift;
- push @{$self->_signal_stack}, [];
-}
-
-sub _signal_commit {
- my $self = shift;
- my $signals = pop @{$self->_signal_stack};
- my $previous = $self->_signal_stack->[-1] // [];
- push @$previous, @$signals;
- return $previous;
-}
-
-sub _signal_rollback {
- my $self = shift;
- pop @{$self->_signal_stack};
-}
-
-sub _signal_send {
- my $self = shift;
- my $signals = shift // [];
-
- my $kdbx = $KDBX{$self} or return;
-
- # de-duplicate, keeping the most recent signal for each type
- my %seen;
- my @signals = grep { !$seen{$_->[0]}++ } reverse @$signals;
-
- for my $sig (reverse @signals) {
- $kdbx->_handle_signal($self, @$sig);
- }
-}
-
-##############################################################################
-
=method begin_work
$txn = $object->begin_work(%options);
return $self;
}
-sub _commit { die 'Not implemented' }
-sub _in_txn { scalar @{$_[0]->_txns} }
-sub _txns { $TXNS{$_[0]} //= [] }
-
=method rollback
$object->rollback;
return $self;
}
+# Get whether or not there is at least one pending transaction.
+sub _in_txn { scalar @{$_[0]->_txns} }
+
+# Get an array ref of pending transactions.
+sub _txns { $TXNS{$_[0]} //= [] }
+
+# The _commit hook notifies subclasses that a commit has occurred.
+sub _commit { die 'Not implemented' }
+
+# Get a reference to an object that represents an object's committed state. If there is no pending
+# transaction, this is just $self. If there is a transaction, this is the snapshot take before the transaction
+# began. This method is private because it provides direct access to the actual snapshot. It is important that
+# the snapshot not be changed or a rollback would roll back to an altered state.
+# This is used by File::KDBX::Dumper::XML so as to not dump uncommitted changes.
+sub _committed {
+ my $self = shift;
+ my ($orig) = @{$self->_txns};
+ return $orig // $self;
+}
+
+# In addition to cloning an object when beginning work, we also keep track its hashrefs and arrayrefs
+# internally so that we can restore to the very same structures in the case of a rollback.
sub _save_references {
my $id = shift;
my $self = shift;
}
}
+# During a rollback, copy data from the snapshot back into the original internal structures.
sub _restore_references {
my $id = shift;
my $orig = shift // return;
return $self;
}
-sub _confirmed {
+##############################################################################
+
+sub _signal {
my $self = shift;
- my ($orig) = @{$self->_txns};
- return $orig // $self;
+ my $type = shift;
+
+ if ($self->_in_txn) {
+ my $stack = $self->_signal_stack;
+ my $queue = $stack->[-1];
+ push @$queue, [$type, @_];
+ }
+
+ $self->_signal_send([[$type, @_]]);
+
+ return $self;
+}
+
+sub _signal_stack { $SIGNALS{$_[0]} //= [] }
+
+sub _signal_begin_work {
+ my $self = shift;
+ push @{$self->_signal_stack}, [];
+}
+
+sub _signal_commit {
+ my $self = shift;
+ my $signals = pop @{$self->_signal_stack};
+ my $previous = $self->_signal_stack->[-1] // [];
+ push @$previous, @$signals;
+ return $previous;
+}
+
+sub _signal_rollback {
+ my $self = shift;
+ pop @{$self->_signal_stack};
+}
+
+sub _signal_send {
+ my $self = shift;
+ my $signals = shift // [];
+
+ my $kdbx = $KDBX{$self} or return;
+
+ # de-duplicate, keeping the most recent signal for each type
+ my %seen;
+ my @signals = grep { !$seen{$_->[0]}++ } reverse @$signals;
+
+ for my $sig (reverse @signals) {
+ $kdbx->_handle_signal($self, @$sig);
+ }
}
##############################################################################
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>