X-Git-Url: https://git.dogcows.com/gitweb?a=blobdiff_plain;f=lib%2FFile%2FKDBX%2FObject.pm;h=7c538bf3df44d7b234b942b03df91713155dd119;hb=c98fc7d0294e641cf8844306808333bdec4fea2f;hp=09c790f68dbff33c0b00136bc5e1da6c16448f86;hpb=f63182fc62b25269b1c38588dca2b3535ed1a1a2;p=chaz%2Fp5-File-KDBX diff --git a/lib/File/KDBX/Object.pm b/lib/File/KDBX/Object.pm index 09c790f..7c538bf 100644 --- a/lib/File/KDBX/Object.pm +++ b/lib/File/KDBX/Object.pm @@ -7,20 +7,22 @@ use strict; use Devel::GlobalDestruction; use File::KDBX::Error; use File::KDBX::Util qw(:uuid); -use Ref::Util qw(is_arrayref is_plain_hashref is_ref); -use Scalar::Util qw(blessed refaddr weaken); +use Hash::Util::FieldHash qw(fieldhashes); +use List::Util qw(first); +use Ref::Util qw(is_arrayref is_plain_arrayref is_plain_hashref is_ref); +use Scalar::Util qw(blessed weaken); use namespace::clean; our $VERSION = '999.999'; # VERSION -my %KDBX; +fieldhashes \my (%KDBX, %PARENT, %TXNS, %REFS, %SIGNALS); =method new - $object = File::KDBX::Entry->new; - $object = File::KDBX::Entry->new(%attributes); - $object = File::KDBX::Entry->new($data); - $object = File::KDBX::Entry->new($data, $kdbx); + $object = File::KDBX::Object->new; + $object = File::KDBX::Object->new(%attributes); + $object = File::KDBX::Object->new(\%data); + $object = File::KDBX::Object->new(\%data, $kdbx); Construct a new KDBX object. @@ -32,11 +34,11 @@ and: File::KDBX::Entry->new({username => 'iambatman'}); # WRONG -In the first, an empty entry is first created and then initialized with whatever I are given. In -the second, a hashref is blessed and essentially becomes the entry. The significance is that the hashref -key-value pairs will remain as-is so the structure is expected to adhere to the shape of a raw B, -whereas with the first the attributes will set the structure in the correct way (just like using the entry -object accessors / getters / setters). +In the first, an empty object is first created and then initialized with whatever I are given. In +the second, a hashref is blessed and essentially becomes the object. The significance is that the hashref +key-value pairs will remain as-is so the structure is expected to adhere to the shape of a raw B +(which varies based on the type of object), whereas with the first the attributes will set the structure in +the correct way (just like using the object accessors / getters / setters). The second example isn't I wrong -- this type of construction is supported for a reason, to allow for working with KDBX objects at a low level -- but it is wrong in this specific case only because @@ -71,10 +73,20 @@ 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_nonlazy_attributes { die 'Not implemented' } + +=method init + + $object = $object->init(%attributes); + +Called by the constructor to set attributes. You normally should not call this. + +=cut + sub init { my $self = shift; my %args = @_; @@ -88,12 +100,6 @@ sub init { return $self; } -sub DESTROY { - return if in_global_destruction; - my $self = shift; - delete $KDBX{refaddr($self)}; -} - =method wrap $object = File::KDBX::Object->wrap($object); @@ -103,8 +109,8 @@ Ensure that a KDBX object is blessed. =cut sub wrap { - my $class = shift; - my $object = shift; + my $class = shift; + my $object = shift; return $object if blessed $object && $object->isa($class); return $class->new(@_, @$object) if is_arrayref($object); return $class->new($object, @_); @@ -116,33 +122,32 @@ sub wrap { $object->label($label); Get or set the object's label, a text string that can act as a non-unique identifier. For an entry, the label -is its title. For a group, the label is its name. +is its title string. For a group, the label is its name. =cut -sub label { die "Not implemented" } +sub label { die 'Not implemented' } =method clone $object_copy = $object->clone; $object_copy = File::KDBX::Object->new($object); -Make a clone of an entry. 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), but some options are allowed to +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: =for :list -* C - Set a new UUID; value can be the new UUID, truthy to generate a random UUID, or falsy to keep - the original UUID (default: same value as C) -* C - If set, add the copy to the same parent (default: false) -* C - If set, change the name or title of the copy to "C<$original_title> - Copy". -* C - Toggle whether or not to copy child entries, if any (default: true) -* C - Toggle whether or not to copy child groups, if any (default: true) -* C - Toggle whether or not to copy the entry history, if any (default: true) -* C - Toggle whether or not cloned entry's Password string should be set to a reference to - their original entry's Password string. -* C - Toggle whether or not cloned entry's UserName string should be set to a reference to - their original entry's UserName string. +* C - If set, generate a new UUID for the copy (default: false) +* C - If set, add the copy to the same parent group, if any (default: false) +* C - If set, append " - Copy" to the object's title or name (default: false) +* C - If set, copy child entries, if any (default: true) +* C - If set, copy child groups, if any (default: true) +* C - If set, copy entry history, if any (default: true) +* C - Toggle whether or not cloned entry's Password string should be set as a field + reference to the original entry's Password string (default: false) +* C - Toggle whether or not cloned entry's UserName string should be set as a field + reference to the original entry's UserName string (default: false) =cut @@ -180,22 +185,24 @@ sub STORABLE_freeze { delete $copy->{groups} if !$CLONE{groups}; delete $copy->{history} if !$CLONE{history}; - return refaddr($self) || '', $copy; + return ($cloning ? Hash::Util::FieldHash::id($self) : ''), $copy; } sub STORABLE_thaw { my $self = shift; my $cloning = shift; my $addr = shift; - my $clone = shift; + my $copy = shift; - @$self{keys %$clone} = values %$clone; + @$self{keys %$copy} = values %$copy; - my $kdbx = $KDBX{$addr}; - $self->kdbx($kdbx) if $kdbx; + if ($cloning) { + my $kdbx = $KDBX{$addr}; + $self->kdbx($kdbx) if $kdbx; + } - if ($self->{uuid}) { - if (($CLONE{reference_password} || $CLONE{reference_username}) && $self->isa('File::KDBX::Entry')) { + if (defined $self->{uuid}) { + if (($CLONE{reference_password} || $CLONE{reference_username}) && $self->can('strings')) { my $uuid = format_uuid($self->{uuid}); my $clone_obj = do { local $CLONE{new_uuid} = 0; @@ -204,9 +211,10 @@ sub STORABLE_thaw { local $CLONE{history} = 1; local $CLONE{reference_password} = 0; local $CLONE{reference_username} = 0; - bless Storable::dclone({%$clone}), 'File::KDBX::Entry'; + # Clone only the entry's data and manually bless to avoid infinite recursion. + bless Storable::dclone({%$copy}), 'File::KDBX::Entry'; }; - my $txn = $self->begin_work($clone_obj); + my $txn = $self->begin_work(snapshot => $clone_obj); if ($CLONE{reference_password}) { $self->password("{REF:P\@I:$uuid}"); } @@ -217,6 +225,9 @@ sub STORABLE_thaw { } $self->uuid(generate_uuid) if $CLONE{new_uuid}; } + + # Dualvars aren't cloned as dualvars, so dualify the icon. + $self->icon_id($self->{icon_id}) if defined $self->{icon_id}; } =attr kdbx @@ -231,17 +242,16 @@ Get or set the L instance associated with this object. sub kdbx { my $self = shift; $self = $self->new if !ref $self; - my $addr = refaddr($self); if (@_) { - $KDBX{$addr} = shift; - if (defined $KDBX{$addr}) { - weaken $KDBX{$addr}; + if (my $kdbx = shift) { + $KDBX{$self} = $kdbx; + weaken $KDBX{$self}; } else { - delete $KDBX{$addr}; + delete $KDBX{$self}; } } - $KDBX{$addr} or throw 'Object is disassociated from a KDBX database', object => $self; + $KDBX{$self} or throw 'Object is disassociated from a KDBX database', object => $self; } =method id @@ -262,22 +272,78 @@ sub id { format_uuid(shift->uuid, @_) } =method group +=method parent + $group = $object->group; + # OR equivalently + $group = $object->parent; Get the parent group to which an object belongs or C if it belongs to no group. -Alias: C - =cut sub group { my $self = shift; - my $lineage = $self->kdbx->trace_lineage($self) or return; - return pop @$lineage; + my $id = Hash::Util::FieldHash::id($self); + if (my $group = $PARENT{$self}) { + my $method = $self->_parent_container; + return $group if first { $id == Hash::Util::FieldHash::id($_) } @{$group->$method}; + delete $PARENT{$self}; + } + # always get lineage from root to leaf because the other way requires parent, so it would be recursive + my $lineage = $self->kdbx->_trace_lineage($self) or return; + my $group = pop @$lineage or return; + $PARENT{$self} = $group; weaken $PARENT{$self}; + return $group; } sub parent { shift->group(@_) } +sub _set_group { + my $self = shift; + if (my $parent = shift) { + $PARENT{$self} = $parent; + weaken $PARENT{$self}; + } + else { + delete $PARENT{$self}; + } + return $self; +} + +### Name of the parent attribute expected to contain the object +sub _parent_container { die 'Not implemented' } + +=method lineage + + \@lineage = $object->lineage; + \@lineage = $object->lineage($base_group); + +Get the direct line of ancestors from C<$base_group> (default: the root group) to an object. The lineage +includes the base group but I the target object. Returns C if the target is not in the database +structure. Returns an empty arrayref is the object itself is a root group. + +=cut + +sub lineage { + my $self = shift; + my $base = shift; + + my $base_addr = $base ? Hash::Util::FieldHash::id($base) : 0; + + # 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); + } + return \@path if @path && ($base_addr == Hash::Util::FieldHash::id($path[0]) || $path[0]->is_root); + + # try root to leaf + return $self->kdbx->_trace_lineage($self, $base); +} + =method remove $object = $object->remove; @@ -287,6 +353,8 @@ Remove the object from the database. If the object is a group, all contained obj =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; @@ -401,9 +469,252 @@ sub custom_data_value { return $data->{value}; } +############################################################################## + +=method begin_work + + $txn = $object->begin_work(%options); + $object->begin_work(%options); + +Begin a new transaction. Returns a L object that can be scoped to ensure a rollback +occurs if exceptions are thrown. Alternatively, if called in void context, there will be no +B and it is instead your responsibility to call L or L as +appropriate. It is undefined behavior to call these if a B exists. Recursive +transactions are allowed. + +Signals created during a transaction are delayed until all transactions are resolved. If the outermost +transaction is committed, then the signals are de-duplicated and delivered. Otherwise the signals are dropped. +This means that the KDBX database will not fix broken references or mark itself dirty until after the +transaction is committed. + +How it works: With the beginning of a transaction, a snapshot of the object is created. In the event of +a rollback, the object's data is replaced with data from the snapshot. + +By default, the snapshot is shallow (i.e. does not include subroups, entries or historical entries). This +means that only modifications to the object itself (its data, fields, strings, etc.) are atomic; modifications +to subroups etc., including adding or removing items, are auto-committed instantly and will persist regardless +of the result of the pending transaction. You can override this for groups, entries and history independently +using options: + +=for :list +* C - If set, snapshot entries within a group, deeply (default: false) +* C - If set, snapshot subroups within a group, deeply (default: false) +* C - If set, snapshot historical entries within an entry (default: false) + +For example, if you begin a transaction on a group object using the C option, like this: + + $group->begin_work(entries => 1); + +Then if you modify any of the group's entries OR add new entries OR delete entries, all of that will be undone +if the transaction is rolled back. With a default-configured transaction, however, changes to entries are kept +even if the transaction is rolled back. + +=cut + +sub begin_work { + my $self = shift; + + if (defined wantarray) { + require File::KDBX::Transaction; + return File::KDBX::Transaction->new($self, @_); + } + + my %args = @_; + my $orig = $args{snapshot} // do { + my $c = $self->clone( + entries => $args{entries} // 0, + groups => $args{groups} // 0, + history => $args{history} // 0, + ); + $c->{entries} = $self->{entries} if !$args{entries}; + $c->{groups} = $self->{groups} if !$args{groups}; + $c->{history} = $self->{history} if !$args{history}; + $c; + }; + + my $id = Hash::Util::FieldHash::id($orig); + _save_references($id, $self, $orig); + + $self->_signal_begin_work; + + push @{$self->_txns}, $orig; +} + +=method commit + + $object->commit; + +Commit a transaction, making updates to C<$object> permanent. Returns itself to allow method chaining. + +=cut + +sub commit { + my $self = shift; + my $orig = pop @{$self->_txns} or return $self; + $self->_commit($orig); + my $signals = $self->_signal_commit; + $self->_signal_send($signals) if !$self->_in_txn; + return $self; +} + +=method rollback + + $object->rollback; + +Roll back the most recent transaction, throwing away any updates to the L made since the transaction +began. Returns itself to allow method chaining. + +=cut + +sub rollback { + my $self = shift; + + my $orig = pop @{$self->_txns} or return $self; + + my $id = Hash::Util::FieldHash::id($orig); + _restore_references($id, $orig); + + $self->_signal_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; + my $orig = shift; + + if (is_plain_arrayref($orig)) { + for (my $i = 0; $i < @$orig; ++$i) { + _save_references($id, $self->[$i], $orig->[$i]); + } + $REFS{$id}{Hash::Util::FieldHash::id($orig)} = $self; + } + elsif (is_plain_hashref($orig) || (blessed $orig && $orig->isa(__PACKAGE__))) { + for my $key (keys %$orig) { + _save_references($id, $self->{$key}, $orig->{$key}); + } + $REFS{$id}{Hash::Util::FieldHash::id($orig)} = $self; + } +} + +# During a rollback, copy data from the snapshot back into the original internal structures. +sub _restore_references { + my $id = shift; + my $orig = shift // return; + my $self = delete $REFS{$id}{Hash::Util::FieldHash::id($orig) // ''} // return $orig; + + if (is_plain_arrayref($orig)) { + @$self = map { _restore_references($id, $_) } @$orig; + } + elsif (is_plain_hashref($orig) || (blessed $orig && $orig->isa(__PACKAGE__))) { + for my $key (keys %$orig) { + # next if is_ref($orig->{$key}) && + # (Hash::Util::FieldHash::id($self->{$key}) // 0) == Hash::Util::FieldHash::id($orig->{$key}); + $self->{$key} = _restore_references($id, $orig->{$key}); + } + } + + return $self; +} + +############################################################################## + +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, @_]]); + + 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); + } +} + +############################################################################## + +sub _wrap_group { + my $self = shift; + my $group = shift; + require File::KDBX::Group; + return File::KDBX::Group->wrap($group, $KDBX{$self}); +} + +sub _wrap_entry { + my $self = shift; + my $entry = shift; + require File::KDBX::Entry; + return File::KDBX::Entry->wrap($entry, $KDBX{$self}); +} + +sub TO_JSON { +{%{$_[0]}} } + 1; __END__ +=for Pod::Coverage STORABLE_freeze STORABLE_thaw TO_JSON + =head1 DESCRIPTION KDBX is an object database. This abstract class represents an object. You should not use this class directly @@ -415,4 +726,40 @@ 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: + +=for :list +* L +* L +* L +* L +* L + +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 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: + + my $entry = File::KDBX::Entry->(title => 'Whatever'); + + # DO NOT DO THIS: + $kdbx->add_entry($entry); + $another_kdbx->add_entry($entry); + + # DO NOT DO THIS: + $kdbx->add_entry($entry); + $kdbx->add_entry($entry); # again + +Instead, do this: + + # Copy an entry to multiple databases: + $kdbx->add_entry($entry); + $another_kdbx->add_entry($entry->clone); + + # OR move an existing entry from one database to another: + $kdbx->add_entry($entry->remove); + =cut