X-Git-Url: https://git.dogcows.com/gitweb?a=blobdiff_plain;ds=sidebyside;f=lib%2FFile%2FKDBX%2FObject.pm;h=63eadcca0dbd03da9881221e2ef2b54c35c59ede;hb=63d73bf382edfb0089b36a45193fc2835cb58b6d;hp=afede78ae0894c4a1e5677f5592490510d9dab4d;hpb=05e0bcef1c2165c556b910314312866dc4a667b7;p=chaz%2Fp5-File-KDBX diff --git a/lib/File/KDBX/Object.pm b/lib/File/KDBX/Object.pm index afede78..63eadcc 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; @@ -73,11 +74,11 @@ sub new { 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 @@ -130,12 +131,12 @@ sub label { die 'Not implemented' } =method clone - $object_copy = $object->clone; + $object_copy = $object->clone(%options); $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 group). Some options are allowed to get +different effects: =for :list * C - If set, generate a new UUID for the copy (default: false) @@ -169,7 +170,7 @@ sub clone { if ($args{relabel} and my $label = $self->label) { $copy->label("$label - Copy"); } - if ($args{parent} and my $parent = $self->parent) { + if ($args{parent} and my $parent = $self->group) { $parent->add_object($copy); } @@ -235,7 +236,9 @@ 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. Throws if the object is disconnected. Other +object methods might only work if the object is connected to a database and so they might also throw if the +object is disconnected. If you're not sure if an object is connected, try L. =cut @@ -251,7 +254,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 @@ -272,18 +288,25 @@ sub id { format_uuid(shift->uuid, @_) } =method group -=method parent - - $group = $object->group; - # OR equivalently - $group = $object->parent; + $parent_group = $object->group; + $object->group($parent_group); -Get the parent group to which an object belongs or C if it belongs to no group. +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; + $self->location_changed('now'); + $new_group->add_object($self); + } + my $id = Hash::Util::FieldHash::id($self); if (my $group = $PARENT{$self}) { my $method = $self->_parent_container; @@ -297,8 +320,6 @@ sub group { return $group; } -sub parent { shift->group(@_) } - sub _set_group { my $self = shift; if (my $parent = shift) { @@ -333,10 +354,10 @@ sub lineage { # try leaf to root my @path; - my $o = $self; - while ($o = $o->parent) { - unshift @path, $o; - last if $base_addr == Hash::Util::FieldHash::id($o); + my $object = $self; + while ($object = $object->group) { + unshift @path, $object; + last if $base_addr == Hash::Util::FieldHash::id($object); } return \@path if @path && ($base_addr == Hash::Util::FieldHash::id($path[0]) || $path[0]->is_root); @@ -346,19 +367,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, just like cutting off a branch takes the leafs 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 { my $self = shift; - my $parent = $self->parent; - $parent->remove_object($self) if $parent; + my $parent = $self->group; + $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->group($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->group && any { $_->is_recycle_bin } @{$self->lineage}); +} + +############################################################################## + =method tag_list @tags = $entry->tag_list; @@ -411,7 +486,9 @@ sub custom_icon { $object->custom_data(%data); $object->custom_data(key => $value, %data); -Get and set custom data. Custom data is metadata associated with an object. +Get and set custom data. Custom data is metadata associated with an object. It is a set of key-value pairs +used to store arbitrary data, usually used by software like plug-ins to keep track of state rather than by end +users. Each data item can have a few attributes associated with it. @@ -469,56 +546,6 @@ sub custom_data_value { ############################################################################## -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); @@ -605,10 +632,6 @@ sub commit { return $self; } -sub _commit { die 'Not implemented' } -sub _in_txn { scalar @{$_[0]->_txns} } -sub _txns { $TXNS{$_[0]} //= [] } - =method rollback $object->rollback; @@ -631,6 +654,28 @@ sub 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; @@ -650,6 +695,7 @@ sub _save_references { } } +# During a rollback, copy data from the snapshot back into the original internal structures. sub _restore_references { my $id = shift; my $orig = shift // return; @@ -669,10 +715,56 @@ sub _restore_references { 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); + } } ############################################################################## @@ -709,10 +801,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 @@ -721,8 +814,8 @@ object or an object not part of the object tree of a database can be added to a * L * L -It is possible to copy or move objects between databases, but you B include the same object in more -than one database at once or there could some strange aliasing effects (i.e. changes in one database might +It is possible to copy or move objects between databases, but B include the same object in more +than one database at once or there could be some strange aliasing effects (i.e. changes in one database might effect another in unexpected ways). This could lead to difficult-to-debug problems. It is similarly not safe or valid to add the same object multiple times to the same database. For example: @@ -743,6 +836,55 @@ Instead, do this: $another_kdbx->add_entry($entry->clone); # OR move an existing entry from one database to another: - $kdbx->add_entry($entry->remove); + $another_kdbx->add_entry($entry->remove); + +=attr uuid + +128-bit UUID identifying the object within the connected database. + +=attr icon_id + +Integer representing a default icon. See L for valid values. + +=attr custom_icon_uuid + +128-bit UUID identifying a custom icon within the connected database. + +=attr tags + +Text string with arbitrary tags which can be used to build a taxonomy. + +=attr previous_parent_group + +128-bit UUID identifying a group within the connected database the previously contained the object. + +=attr last_modification_time + +Date and time when the entry was last modified. + +=attr creation_time + +Date and time when the entry was created. + +=attr last_access_time + +Date and time when the entry was last accessed. + +=attr expiry_time + +Date and time when the entry expired or will expire. + +=attr expires + +Boolean value indicating whether or not an entry is expired. + +=attr usage_count + +The number of times an entry has been used, which typically means how many times the B string has +been accessed. + +=attr location_changed + +Date and time when the entry was last moved to a different parent group. =cut