use File::KDBX::Constants qw(:all);
use File::KDBX::Error;
use File::KDBX::Safe;
-use File::KDBX::Util qw(:class :coercion :empty :uuid :search erase simple_expression_query snakify);
+use File::KDBX::Util qw(:class :coercion :empty :search :uuid erase simple_expression_query snakify);
use Hash::Util::FieldHash qw(fieldhashes);
use List::Util qw(any first);
use Ref::Util qw(is_ref is_arrayref is_plain_hashref);
$kdbx = $kdbx->init(%attributes);
-Initialize a L<File::KDBX> with a new set of attributes. Returns itself to allow method chaining.
+Initialize a L<File::KDBX> with a set of attributes. Returns itself to allow method chaining.
This is called by L</new>.
# has 'meta.memory_protection' => {};
has 'meta.custom_icons' => [];
has 'meta.recycle_bin_enabled' => true, coerce => \&to_bool;
-has 'meta.recycle_bin_uuid' => "\0" x 16, coerce => \&to_uuid;
+has 'meta.recycle_bin_uuid' => UUID_NULL, coerce => \&to_uuid;
has 'meta.recycle_bin_changed' => sub { gmtime }, coerce => \&to_time;
-has 'meta.entry_templates_group' => "\0" x 16, coerce => \&to_uuid;
+has 'meta.entry_templates_group' => UUID_NULL, coerce => \&to_uuid;
has 'meta.entry_templates_group_changed' => sub { gmtime }, coerce => \&to_time;
-has 'meta.last_selected_group' => "\0" x 16, coerce => \&to_uuid;
-has 'meta.last_top_visible_group' => "\0" x 16, coerce => \&to_uuid;
+has 'meta.last_selected_group' => UUID_NULL, coerce => \&to_uuid;
+has 'meta.last_top_visible_group' => UUID_NULL, coerce => \&to_uuid;
has 'meta.history_max_items' => HISTORY_DEFAULT_MAX_ITEMS, coerce => \&to_number;
has 'meta.history_max_size' => HISTORY_DEFAULT_MAX_SIZE, coerce => \&to_number;
has 'meta.settings_changed' => sub { gmtime }, coerce => \&to_time;
L<File::KDBX::Group/add_group> on the parent group, forwarding the arguments. Available options:
=for :list
-* C<group> (aka C<parent>) - Group (object or group UUID) to add the group to (default: root group)
+* C<group> (aka C<parent>) - Group object or group UUID to add the group to (default: root group)
=cut
my %args = @_ % 2 == 0 ? @_ : (base => shift, @_);
my $base = $args{base} // $self->root;
+ # my @groups;
+ # push @groups, $self->_wrap_group($base) if $args{include_base} // 1;
+ # push @groups, @{$base->all_groups};
+ # return \@groups;
my @groups = $args{include_base} // 1 ? $self->_wrap_group($base) : ();
for my $subgroup (@{$base->{groups} || []}) {
L<File::KDBX::Group/add_entry> on the parent group, forwarding the arguments. Available options:
=for :list
-* C<group> (aka C<parent>) - Group (object or group UUID) to add the entry to (default: root group)
+* C<group> (aka C<parent>) - Group object or group UUID to add the entry to (default: root group)
=cut
sub add_deleted_object {
my $self = shift;
my $uuid = shift;
+
+ # ignore null and meta stream UUIDs
+ return if $uuid eq UUID_NULL || $uuid eq '0' x 16;
+
$self->deleted_objects->{$uuid} = {
uuid => $uuid,
deletion_time => scalar gmtime,
};
}
+=method remove_deleted_object
+
+ $kdbx->remove_deleted_object($uuid);
+
+Remove a UUID from the deleted objects list. This list is used to support automatic database merging.
+
+You typically do not need to call this yourself because the list will be maintained automatically as objects
+are added.
+
+=cut
+
+sub remove_deleted_object {
+ my $self = shift;
+ my $uuid = shift;
+ delete $self->deleted_objects->{$uuid};
+}
+
+=method clear_deleted_objects
+
+Remove all UUIDs from the deleted objects list. This list is used to support automatic database merging, but
+if you don't need merging then you can clear deleted objects to reduce the database file size.
+
+=cut
+
+sub clear_deleted_objects {
+ my $self = shift;
+ %{$self->deleted_objects} = ();
+}
+
##############################################################################
=method resolve_reference
my $type = shift;
my %handlers = (
+ 'entry.added' => \&_handle_object_added,
+ 'group.added' => \&_handle_object_added,
+ 'entry.removed' => \&_handle_object_removed,
+ 'group.removed' => \&_handle_object_removed,
'entry.uuid.changed' => \&_handle_entry_uuid_changed,
'group.uuid.changed' => \&_handle_group_uuid_changed,
- 'entry.uuid.removed' => \&_handle_object_removed,
- 'group.uuid.removed' => \&_handle_object_removed,
);
my $handler = $handlers{$type} or return;
$self->$handler($object, @_);
}
-sub _handle_group_uuid_changed {
+sub _handle_object_added {
+ my $self = shift;
+ my $object = shift;
+ $self->remove_deleted_object($object->uuid);
+}
+
+sub _handle_object_removed {
my $self = shift;
my $object = shift;
- my $new_uuid = shift;
- my $old_uuid = shift // return;
+ my $old_uuid = $object->{uuid} // return;
my $meta = $self->meta;
- $self->recycle_bin_uuid($new_uuid) if $old_uuid eq ($meta->{recycle_bin_uuid} // '');
- $self->entry_templates_group($new_uuid) if $old_uuid eq ($meta->{entry_templates_group} // '');
- $self->last_selected_group($new_uuid) if $old_uuid eq ($meta->{last_selected_group} // '');
- $self->last_top_visible_group($new_uuid) if $old_uuid eq ($meta->{last_top_visible_group} // '');
+ $self->recycle_bin_uuid(UUID_NULL) if $old_uuid eq ($meta->{recycle_bin_uuid} // '');
+ $self->entry_templates_group(UUID_NULL) if $old_uuid eq ($meta->{entry_templates_group} // '');
+ $self->last_selected_group(UUID_NULL) if $old_uuid eq ($meta->{last_selected_group} // '');
+ $self->last_top_visible_group(UUID_NULL) if $old_uuid eq ($meta->{last_top_visible_group} // '');
- for my $group (@{$self->all_groups}) {
- $group->last_top_visible_entry($new_uuid) if $old_uuid eq ($group->{last_top_visible_entry} // '');
- $group->previous_parent_group($new_uuid) if $old_uuid eq ($group->{previous_parent_group} // '');
- }
- for my $entry (@{$self->all_entries}) {
- $entry->previous_parent_group($new_uuid) if $old_uuid eq ($entry->{previous_parent_group} // '');
- }
+ $self->add_deleted_object($old_uuid);
}
sub _handle_entry_uuid_changed {
}
}
-sub _handle_object_removed {
- my $self = shift;
- my $object = shift;
- $self->add_delete_object($object->uuid);
+sub _handle_group_uuid_changed {
+ my $self = shift;
+ my $object = shift;
+ my $new_uuid = shift;
+ my $old_uuid = shift // return;
+
+ my $meta = $self->meta;
+ $self->recycle_bin_uuid($new_uuid) if $old_uuid eq ($meta->{recycle_bin_uuid} // '');
+ $self->entry_templates_group($new_uuid) if $old_uuid eq ($meta->{entry_templates_group} // '');
+ $self->last_selected_group($new_uuid) if $old_uuid eq ($meta->{last_selected_group} // '');
+ $self->last_top_visible_group($new_uuid) if $old_uuid eq ($meta->{last_top_visible_group} // '');
+
+ for my $group (@{$self->all_groups}) {
+ $group->last_top_visible_entry($new_uuid) if $old_uuid eq ($group->{last_top_visible_entry} // '');
+ $group->previous_parent_group($new_uuid) if $old_uuid eq ($group->{previous_parent_group} // '');
+ }
+ for my $entry (@{$self->all_entries}) {
+ $entry->previous_parent_group($new_uuid) if $old_uuid eq ($entry->{previous_parent_group} // '');
+ }
}
#########################################################################################
if (my $group = $kdbx->root) {
my $group_node = $node->addNewChild(undef, 'Group');
- $self->_write_xml_group($group_node, $group->_confirmed);
+ $self->_write_xml_group($group_node, $group->_committed);
}
undef $guard; # re-lock if needed, as early as possible
for my $entry (@{$group->entries}) {
my $entry_node = $node->addNewChild(undef, 'Entry');
- $self->_write_xml_entry($entry_node, $entry->_confirmed);
+ $self->_write_xml_entry($entry_node, $entry->_committed);
}
for my $group (@{$group->groups}) {
my $group_node = $node->addNewChild(undef, 'Group');
- $self->_write_xml_group($group_node, $group->_confirmed);
+ $self->_write_xml_group($group_node, $group->_committed);
}
}
my $history_node = $node->addNewChild(undef, 'History');
for my $historical (@history) {
my $historical_node = $history_node->addNewChild(undef, 'Entry');
- $self->_write_xml_entry($historical_node, $historical->_confirmed, 1);
+ $self->_write_xml_entry($historical_node, $historical->_committed, 1);
}
}
}
$entry->kdbx($kdbx) if $kdbx;
push @{$self->{entries} ||= []}, $entry->remove;
- return $entry->_set_group($self);
+ return $entry->_set_group($self)->_signal('added', $self);
}
sub remove_entry {
for (my $i = 0; $i < @$objects; ++$i) {
my $o = $objects->[$i];
next if $uuid ne $o->uuid;
+ $o->_set_group(undef)->_signal('removed');
return splice @$objects, $i, 1;
- $o->_set_group(undef);
- return @$objects, $i, 1;
}
}
return $groups;
}
+=method all_groups
+
+ \@groups = $group->all_groups(%options);
+
+Get all groups within a group, deeply, in a flat array. Supported options:
+
+=cut
+
sub all_groups {
my $self = shift;
- # FIXME - shouldn't have to delegate to the database to get this
- return $self->kdbx->all_groups(base => $self, include_base => false);
+
+ my @groups;
+ for my $subgroup (@{$self->groups}) {
+ push @groups, @{$subgroup->all_groups};
+ }
+
+ return \@groups;
+}
+
+=method find_groups
+
+ @groups = $kdbx->find_groups($query, %options);
+
+Find all groups deeply that match to a query. Options are the same as for L</all_groups>.
+
+See L</QUERY> for a description of what C<$query> can be.
+
+=cut
+
+sub find_groups {
+ my $self = shift;
+ my $query = shift or throw 'Must provide a query';
+ my %args = @_;
+ my %all_groups = ( # FIXME
+ base => $args{base},
+ include_base => $args{include_base},
+ );
+ return @{search($self->all_groups(%all_groups), is_arrayref($query) ? @$query : $query)};
}
sub _kpx_groups { shift->groups(@_) }
$group->kdbx($kdbx) if $kdbx;
push @{$self->{groups} ||= []}, $group->remove;
- return $group->_set_group($self);
+ return $group->_set_group($self)->_signal('added', $self);
}
sub remove_group {
for (my $i = 0; $i < @$objects; ++$i) {
my $o = $objects->[$i];
next if $uuid ne $o->uuid;
- $o->_set_group(undef);
+ $o->_set_group(undef)->_signal('removed');
return splice @$objects, $i, 1;
}
}
##############################################################################
-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);
+ }
}
##############################################################################
load => [qw(load_optional load_xs try_load_optional)],
search => [qw(query search search_limited simple_expression_query)],
text => [qw(snakify trim)],
- uuid => [qw(format_uuid generate_uuid is_uuid uuid)],
+ uuid => [qw(format_uuid generate_uuid is_uuid uuid UUID_NULL)],
uri => [qw(split_url uri_escape_utf8 uri_unescape_utf8)],
);
}
+=func UUID_NULL
+
+Get the null UUID (i.e. string of 16 null bytes).
+
+=cut
+
+sub UUID_NULL() { "\0" x 16 }
+
### --------------------------------------------------------------------------
# Determine if an array looks like keypairs from a hash.
transform_seed => "\227\264\n^\230\2\301:!f\364\336\251\277\241[\3`\314RG\343\16U\333\305eT3:\240\257",
}), 'Get expected headers from KDB file' or diag explain $kdbx->headers;
- is keys %{$kdbx->deleted_objects}, 0, 'There are no deleted objects';
- is scalar @{$kdbx->root->groups}, 2, 'Root group has two children.';
+ is keys %{$kdbx->deleted_objects}, 0, 'There are no deleted objects' or dumper $kdbx->deleted_objects;
+ is scalar @{$kdbx->root->groups}, 2, 'Root group has two children';
my $group1 = $kdbx->root->groups->[0];
isnt $group1->uuid, undef, 'Group 1 has a UUID';
projects / chaz / p5-File-KDBX / commitdiff
