use Devel::GlobalDestruction;
use File::KDBX::Constants qw(:all);
use File::KDBX::Error;
+use File::KDBX::Iterator;
use File::KDBX::Safe;
-use File::KDBX::Util qw(: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);
+use List::Util qw(any first);
use Ref::Util qw(is_ref is_arrayref is_plain_hashref);
use Scalar::Util qw(blessed);
use Time::Piece;
my $self = bless {}, $class;
$self->init(@_);
- $self->_set_default_attributes if empty $self;
+ $self->_set_nonlazy_attributes if empty $self;
return $self;
}
$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>.
$KEYS{$self} = $key;
$SAFE{$self} = $safe;
- for my $object (@{$self->all_groups}, @{$self->all_entries(history => 1)}) {
- $object->kdbx($self);
- }
+ # Dualvars aren't cloned as dualvars, so coerce the compression flags.
+ $self->compression_flags($self->compression_flags);
+
+ $self->objects(history => 1)->each(sub { $_->kdbx($self) });
}
##############################################################################
__PACKAGE__, $VERSION, @Config::Config{qw(package version osname osvers archname)});
}
-my %ATTRS = (
- sig1 => KDBX_SIG1,
- sig2 => KDBX_SIG2_2,
- version => KDBX_VERSION_3_1,
- headers => sub { +{} },
- inner_headers => sub { +{} },
- meta => sub { +{} },
- binaries => sub { +{} },
- deleted_objects => sub { +{} },
- raw => undef,
-);
-my %ATTRS_HEADERS = (
- HEADER_COMMENT() => '',
- HEADER_CIPHER_ID() => CIPHER_UUID_CHACHA20,
- HEADER_COMPRESSION_FLAGS() => COMPRESSION_GZIP,
- HEADER_MASTER_SEED() => sub { random_bytes(32) },
- # HEADER_TRANSFORM_SEED() => sub { random_bytes(32) },
- # HEADER_TRANSFORM_ROUNDS() => 100_000,
- HEADER_ENCRYPTION_IV() => sub { random_bytes(16) },
- # HEADER_INNER_RANDOM_STREAM_KEY() => sub { random_bytes(32) }, # 64?
- HEADER_STREAM_START_BYTES() => sub { random_bytes(32) },
- # HEADER_INNER_RANDOM_STREAM_ID() => STREAM_ID_CHACHA20,
- HEADER_KDF_PARAMETERS() => sub {
- +{
- KDF_PARAM_UUID() => KDF_UUID_AES,
- KDF_PARAM_AES_ROUNDS() => $_[0]->headers->{+HEADER_TRANSFORM_ROUNDS} // KDF_DEFAULT_AES_ROUNDS,
- KDF_PARAM_AES_SEED() => $_[0]->headers->{+HEADER_TRANSFORM_SEED} // random_bytes(32),
- };
- },
- # HEADER_PUBLIC_CUSTOM_DATA() => sub { +{} },
-);
-my %ATTRS_META = (
- generator => '',
- header_hash => '',
- database_name => '',
- database_name_changed => sub { scalar gmtime },
- database_description => '',
- database_description_changed => sub { scalar gmtime },
- default_username => '',
- default_username_changed => sub { scalar gmtime },
- maintenance_history_days => 0,
- color => '',
- master_key_changed => sub { scalar gmtime },
- master_key_change_rec => -1,
- master_key_change_force => -1,
- # memory_protection => sub { +{} },
- custom_icons => sub { +{} },
- recycle_bin_enabled => true,
- recycle_bin_uuid => "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0",
- recycle_bin_changed => sub { scalar gmtime },
- entry_templates_group => "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0",
- entry_templates_group_changed => sub { scalar gmtime },
- last_selected_group => "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0",
- last_top_visible_group => "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0",
- history_max_items => HISTORY_DEFAULT_MAX_ITEMS,
- history_max_size => HISTORY_DEFAULT_MAX_SIZE,
- settings_changed => sub { scalar gmtime },
- # binaries => sub { +{} },
- # custom_data => sub { +{} },
-);
-my %ATTRS_MEMORY_PROTECTION = (
- protect_title => false,
- protect_username => false,
- protect_password => true,
- protect_url => false,
- protect_notes => false,
- # auto_enable_visual_hiding => false,
-);
-
-while (my ($attr, $default) = each %ATTRS) {
- no strict 'refs'; ## no critic (ProhibitNoStrict)
- *{$attr} = sub {
- my $self = shift;
- $self->{$attr} = shift if @_;
- $self->{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default;
- };
-}
-while (my ($attr, $default) = each %ATTRS_HEADERS) {
- no strict 'refs'; ## no critic (ProhibitNoStrict)
- *{$attr} = sub {
- my $self = shift;
- $self->headers->{$attr} = shift if @_;
- $self->headers->{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default;
- };
-}
-while (my ($attr, $default) = each %ATTRS_META) {
- no strict 'refs'; ## no critic (ProhibitNoStrict)
- *{$attr} = sub {
- my $self = shift;
- $self->meta->{$attr} = shift if @_;
- $self->meta->{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default;
- };
-}
-while (my ($attr, $default) = each %ATTRS_MEMORY_PROTECTION) {
- no strict 'refs'; ## no critic (ProhibitNoStrict)
- *{$attr} = sub {
- my $self = shift;
- $self->meta->{$attr} = shift if @_;
- $self->meta->{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default;
+has sig1 => KDBX_SIG1, coerce => \&to_number;
+has sig2 => KDBX_SIG2_2, coerce => \&to_number;
+has version => KDBX_VERSION_3_1, coerce => \&to_number;
+has headers => {};
+has inner_headers => {};
+has meta => {};
+has binaries => {};
+has deleted_objects => {};
+has raw => coerce => \&to_string;
+
+# HEADERS
+has 'headers.comment' => '', coerce => \&to_string;
+has 'headers.cipher_id' => CIPHER_UUID_CHACHA20, coerce => \&to_uuid;
+has 'headers.compression_flags' => COMPRESSION_GZIP, coerce => \&to_compression_constant;
+has 'headers.master_seed' => sub { random_bytes(32) }, coerce => \&to_string;
+has 'headers.encryption_iv' => sub { random_bytes(16) }, coerce => \&to_string;
+has 'headers.stream_start_bytes' => sub { random_bytes(32) }, coerce => \&to_string;
+has 'headers.kdf_parameters' => sub {
+ +{
+ KDF_PARAM_UUID() => KDF_UUID_AES,
+ KDF_PARAM_AES_ROUNDS() => $_[0]->headers->{+HEADER_TRANSFORM_ROUNDS} // KDF_DEFAULT_AES_ROUNDS,
+ KDF_PARAM_AES_SEED() => $_[0]->headers->{+HEADER_TRANSFORM_SEED} // random_bytes(32),
};
-}
-
-my @ATTRS_OTHER = (
+};
+# has 'headers.transform_seed' => sub { random_bytes(32) };
+# has 'headers.transform_rounds' => 100_000;
+# has 'headers.inner_random_stream_key' => sub { random_bytes(32) }; # 64 ?
+# has 'headers.inner_random_stream_id' => STREAM_ID_CHACHA20;
+# has 'headers.public_custom_data' => {};
+
+# META
+has 'meta.generator' => '', coerce => \&to_string;
+has 'meta.header_hash' => '', coerce => \&to_string;
+has 'meta.database_name' => '', coerce => \&to_string;
+has 'meta.database_name_changed' => sub { gmtime }, coerce => \&to_time;
+has 'meta.database_description' => '', coerce => \&to_string;
+has 'meta.database_description_changed' => sub { gmtime }, coerce => \&to_time;
+has 'meta.default_username' => '', coerce => \&to_string;
+has 'meta.default_username_changed' => sub { gmtime }, coerce => \&to_time;
+has 'meta.maintenance_history_days' => 0, coerce => \&to_number;
+has 'meta.color' => '', coerce => \&to_string;
+has 'meta.master_key_changed' => sub { gmtime }, coerce => \&to_time;
+has 'meta.master_key_change_rec' => -1, coerce => \&to_number;
+has 'meta.master_key_change_force' => -1, coerce => \&to_number;
+# has 'meta.memory_protection' => {};
+has 'meta.custom_icons' => [];
+has 'meta.recycle_bin_enabled' => true, coerce => \&to_bool;
+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' => UUID_NULL, coerce => \&to_uuid;
+has 'meta.entry_templates_group_changed' => sub { gmtime }, coerce => \&to_time;
+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;
+# has 'meta.binaries' => {};
+# has 'meta.custom_data' => {};
+
+has 'memory_protection.protect_title' => false, coerce => \&to_bool;
+has 'memory_protection.protect_username' => false, coerce => \&to_bool;
+has 'memory_protection.protect_password' => true, coerce => \&to_bool;
+has 'memory_protection.protect_url' => false, coerce => \&to_bool;
+has 'memory_protection.protect_notes' => false, coerce => \&to_bool;
+# has 'memory_protection.auto_enable_visual_hiding' => false;
+
+my @ATTRS = (
HEADER_TRANSFORM_SEED,
HEADER_TRANSFORM_ROUNDS,
HEADER_INNER_RANDOM_STREAM_KEY,
HEADER_INNER_RANDOM_STREAM_ID,
+ HEADER_PUBLIC_CUSTOM_DATA,
);
-sub _set_default_attributes {
+sub _set_nonlazy_attributes {
my $self = shift;
- $self->$_ for keys %ATTRS, keys %ATTRS_HEADERS, keys %ATTRS_META, keys %ATTRS_MEMORY_PROTECTION,
- @ATTRS_OTHER;
+ $self->$_ for list_attributes(ref $self), @ATTRS;
}
=method memory_protection
return KDBX_VERSION_4_1 if any {
nonempty $_->{name} || nonempty $_->{last_modification_time}
- } values %{$self->custom_icons};
-
- return KDBX_VERSION_4_1 if any {
- nonempty $_->previous_parent_group || nonempty $_->tags ||
- any { nonempty $_->{last_modification_time} } values %{$_->custom_data}
- } @{$self->all_groups};
+ } @{$self->custom_icons};
+
+ return KDBX_VERSION_4_1 if $self->groups->next(sub {
+ nonempty $_->previous_parent_group ||
+ nonempty $_->tags ||
+ (any { nonempty $_->{last_modification_time} } values %{$_->custom_data})
+ # TODO replace next paragraph with this
+ # || $_->entries(history => 1)->next(sub {
+ # nonempty $_->previous_parent_group ||
+ # (defined $_->quality_check && !$_->quality_check) ||
+ # (any { nonempty $_->{last_modification_time} } values %{$_->custom_data})
+ # })
+ });
- return KDBX_VERSION_4_1 if any {
- nonempty $_->previous_parent_group || (defined $_->quality_check && !$_->quality_check) ||
- any { nonempty $_->{last_modification_time} } values %{$_->custom_data}
- } @{$self->all_entries(history => 1)};
+ return KDBX_VERSION_4_1 if $self->entries(history => 1)->next(sub {
+ nonempty $_->previous_parent_group ||
+ (defined $_->quality_check && !$_->quality_check) ||
+ (any { nonempty $_->{last_modification_time} } values %{$_->custom_data})
+ });
return KDBX_VERSION_4_0 if $self->kdf->uuid ne KDF_UUID_AES;
return KDBX_VERSION_4_0 if nonempty $self->public_custom_data;
- return KDBX_VERSION_4_0 if any {
+ return KDBX_VERSION_4_0 if $self->objects->next(sub {
nonempty $_->custom_data
- } @{$self->all_groups}, @{$self->all_entries(history => 1)};
+ });
return KDBX_VERSION_3_1;
}
##############################################################################
-=method add_group
-
- $kdbx->add_group($group, %options);
- $kdbx->add_group(%group_attributes, %options);
-
-Add a group to a database. This is equivalent to identifying a parent group and calling
-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)
-
-=cut
-
-sub add_group {
- my $self = shift;
- my $group = @_ % 2 == 1 ? shift : undef;
- my %args = @_;
-
- # find the right group to add the group to
- my $parent = delete $args{group} // delete $args{parent} // $self->root;
- ($parent) = $self->find_groups({uuid => $parent}) if !ref $parent;
- $parent or throw 'Invalid group';
-
- return $parent->add_group(defined $group ? $group : (), %args, kdbx => $self);
-}
-
-sub _wrap_group {
- my $self = shift;
- my $group = shift;
- require File::KDBX::Group;
- return File::KDBX::Group->wrap($group, $self);
-}
-
=method root
$group = $kdbx->root;
because it autovivifies when adding entries and groups to the database.
Every database has only a single root group at a time. Some old KDB files might have multiple root groups.
-When reading such files, a single implicit root group is created to contain the other explicit groups. When
+When reading such files, a single implicit root group is created to contain the actual root groups. When
writing to such a format, if the root group looks like it was implicitly created then it won't be written and
the resulting file might have multiple root groups. This allows working with older files without changing
their written internal structure while still adhering to modern semantics while the database is opened.
-B<WARNING:> The root group of a KDBX database contains all of the database's entries and other groups. If you
-replace the root group, you are essentially replacing the entire database contents with something else.
+The root group of a KDBX database contains all of the database's entries and other groups. If you replace the
+root group, you are essentially replacing the entire database contents with something else.
=cut
return $self->_wrap_group($self->{root});
}
+# Called by File::KeePass::KDBX so that a File::KDBX an be treated as a File::KDBX::Group in that both types
+# can have subgroups. File::KDBX already has a `groups' method that does something different from the
+# File::KDBX::Groups `groups' method.
sub _kpx_groups {
my $self = shift;
return [] if !$self->{root};
);
}
-=method all_groups
-
- \@groups = $kdbx->all_groups(%options);
- \@groups = $kdbx->all_groups($base_group, %options);
-
-Get all groups deeply in a database, or all groups within a specified base group, in a flat array. Supported
-options:
-
-=for :list
-* C<base> - Only include groups within a base group (same as C<$base_group>) (default: root)
-* C<include_base> - Include the base group in the results (default: true)
-
-=cut
-
-sub all_groups {
- my $self = shift;
- my %args = @_ % 2 == 0 ? @_ : (base => shift, @_);
- my $base = $args{base} // $self->root;
-
- my @groups = $args{include_base} // 1 ? $self->_wrap_group($base) : ();
-
- for my $subgroup (@{$base->{groups} || []}) {
- my $more = $self->all_groups($subgroup);
- push @groups, @$more;
- }
-
- return \@groups;
-}
-
=method trace_lineage
\@lineage = $kdbx->trace_lineage($group);
}
}
-=method find_groups
+##############################################################################
- @groups = $kdbx->find_groups($query, %options);
+=method add_group
-Find all groups deeply that match to a query. Options are the same as for L</all_groups>.
+ $kdbx->add_group($group, %options);
+ $kdbx->add_group(%group_attributes, %options);
-See L</QUERY> for a description of what C<$query> can be.
+Add a group to a database. This is equivalent to identifying a parent group and calling
+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)
=cut
-sub find_groups {
- my $self = shift;
- my $query = shift or throw 'Must provide a query';
- my %args = @_;
- my %all_groups = (
- base => $args{base},
- include_base => $args{include_base},
- );
- return @{search($self->all_groups(%all_groups), is_arrayref($query) ? @$query : $query)};
+sub add_group {
+ my $self = shift;
+ my $group = @_ % 2 == 1 ? shift : undef;
+ my %args = @_;
+
+ # find the right group to add the group to
+ my $parent = delete $args{group} // delete $args{parent} // $self->root;
+ $parent = $self->groups->grep({uuid => $parent})->next if !ref $parent;
+ $parent or throw 'Invalid group';
+
+ return $parent->add_group(defined $group ? $group : (), %args, kdbx => $self);
+}
+
+sub _wrap_group {
+ my $self = shift;
+ my $group = shift;
+ require File::KDBX::Group;
+ return File::KDBX::Group->wrap($group, $self);
}
-sub remove {
+=method groups
+
+ \&iterator = $kdbx->groups(%options);
+ \&iterator = $kdbx->groups($base_group, %options);
+
+Get an iterator over I<groups> within a database. Options:
+
+=for :list
+* C<base> - Only include groups within a base group (same as C<$base_group>) (default: L</root>)
+* C<inclusive> - Include the base group in the results (default: true)
+* C<algorithm> - Search algorithm, one of C<ids>, C<bfs> or C<dfs> (default: C<ids>)
+
+=cut
+
+sub groups {
my $self = shift;
- my $object = shift;
+ my %args = @_ % 2 == 0 ? @_ : (base => shift, @_);
+ my $base = $args{base} // $self->root;
+
+ my @groups = ($args{inclusive} // 1) ? $base : @{$base->groups};
+ my $algo = lc($args{algorithm} || 'ids');
+
+ if ($algo eq 'dfs') {
+ my %visited;
+ return File::KDBX::Iterator->new(sub {
+ my $next = shift @groups or return;
+ if (!$visited{Hash::Util::FieldHash::id($next)}++) {
+ while (my @children = @{$next->groups}) {
+ unshift @groups, @children, $next;
+ $next = shift @groups;
+ $visited{Hash::Util::FieldHash::id($next)}++;
+ }
+ }
+ $next;
+ });
+ }
+ elsif ($algo eq 'bfs') {
+ return File::KDBX::Iterator->new(sub {
+ my $next = shift @groups or return;
+ push @groups, @{$next->groups};
+ $next;
+ });
+ }
+ return File::KDBX::Iterator->new(sub {
+ my $next = shift @groups or return;
+ unshift @groups, @{$next->groups};
+ $next;
+ });
}
##############################################################################
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
# find the right group to add the entry to
my $parent = delete $args{group} // delete $args{parent} // $self->root;
- ($parent) = $self->find_groups({uuid => $parent}) if !ref $parent;
+ $parent = $self->groups->grep({uuid => $parent})->next if !ref $parent;
$parent or throw 'Invalid group';
return $parent->add_entry(defined $entry ? $entry : (), %args, kdbx => $self);
return File::KDBX::Entry->wrap($entry, $self);
}
-=method all_entries
+=method entries
- \@entries = $kdbx->all_entries(%options);
- \@entries = $kdbx->all_entries($base_group, %options);
+ \&iterator = $kdbx->entries(%options);
+ \&iterator = $kdbx->entries($base_group, %options);
-Get entries deeply in a database, in a flat array. Supported options:
+Get an iterator over I<entries> within a database. Supports the same options as L</groups>, plus some new
+ones:
=for :list
-* C<base> - Only include entries within a base group (same as C<$base_group>) (default: root)
* C<auto_type> - Only include entries with auto-type enabled (default: false, include all)
-* C<search> - Only include entries within groups with search enabled (default: false, include all)
-* C<history> - Also include historical entries (default: false, include only active entries)
+* C<searching> - Only include entries within groups with search enabled (default: false, include all)
+* C<history> - Also include historical entries (default: false, include only current entries)
=cut
-sub all_entries {
+sub entries {
my $self = shift;
my %args = @_ % 2 == 0 ? @_ : (base => shift, @_);
- my $base = $args{base} // $self->root;
- my $history = $args{history};
- my $search = $args{search};
+ my $searching = $args{searching};
my $auto_type = $args{auto_type};
+ my $history = $args{history};
- my $enable_auto_type = $base->{enable_auto_type} // true;
- my $enable_searching = $base->{enable_searching} // true;
-
+ my $groups = $self->groups(%args);
my @entries;
- if ((!$search || $enable_searching) && (!$auto_type || $enable_auto_type)) {
- push @entries,
- map { $self->_wrap_entry($_) }
- grep { !$auto_type || $_->{auto_type}{enabled} }
- map { $_, $history ? @{$_->{history} || []} : () }
- @{$base->{entries} || []};
- }
-
- for my $subgroup (@{$base->{groups} || []}) {
- my $more = $self->all_entries($subgroup,
- auto_type => $auto_type,
- search => $search,
- history => $history,
- );
- push @entries, @$more;
- }
- return \@entries;
+ return File::KDBX::Iterator->new(sub {
+ if (!@entries) {
+ while (my $group = $groups->next) {
+ next if $searching && !$group->effective_enable_searching;
+ next if $auto_type && !$group->effective_enable_auto_type;
+ @entries = @{$group->entries};
+ @entries = grep { $_->auto_type->{enabled} } @entries if $auto_type;
+ @entries = map { ($_, @{$_->history}) } @entries if $history;
+ last if @entries;
+ }
+ }
+ shift @entries;
+ });
}
-=method find_entries
-
-=method find_entries_simple
-
- @entries = $kdbx->find_entries($query, %options);
+##############################################################################
- @entries = $kdbx->find_entries_simple($expression, \@fields, %options);
- @entries = $kdbx->find_entries_simple($expression, $operator, \@fields, %options);
+=method objects
-Find all entries deeply that match a query. Options are the same as for L</all_entries>.
+ \&iterator = $kdbx->entries(%options);
+ \&iterator = $kdbx->entries($base_group, %options);
-See L</QUERY> for a description of what C<$query> can be.
+Get an iterator over I<objects> within a database. Groups and entries are considered objects, so this is
+essentially a combination of L</groups> and L</entries>. This won't often be useful, but it can be convenient
+for maintenance tasks. This method takes the same options as L</groups> and L</entries>.
=cut
-sub find_entries {
+sub objects {
my $self = shift;
- my $query = shift or throw 'Must provide a query';
- my %args = @_;
- my %all_entries = (
- base => $args{base},
- auto_type => $args{auto_type},
- search => $args{search},
- history => $args{history},
- );
- my $limit = delete $args{limit};
- if (defined $limit) {
- return @{search_limited($self->all_entries(%all_entries), is_arrayref($query) ? @$query : $query, $limit)};
- }
- else {
- return @{search($self->all_entries(%all_entries), is_arrayref($query) ? @$query : $query)};
- }
-}
+ my %args = @_ % 2 == 0 ? @_ : (base => shift, @_);
-sub find_entries_simple {
- my $self = shift;
- my $text = shift;
- my $op = @_ && !is_ref($_[0]) ? shift : undef;
- my $fields = shift;
- is_arrayref($fields) or throw q{Usage: find_entries_simple($expression, [$op,] \@fields)};
- return $self->find_entries([\$text, $op, $fields], @_);
+ my $searching = $args{searching};
+ my $auto_type = $args{auto_type};
+ my $history = $args{history};
+
+ my $groups = $self->groups(%args);
+ my @entries;
+
+ return File::KDBX::Iterator->new(sub {
+ if (!@entries) {
+ while (my $group = $groups->next) {
+ next if $searching && !$group->effective_enable_searching;
+ next if $auto_type && !$group->effective_enable_auto_type;
+ @entries = @{$group->entries};
+ @entries = grep { $_->auto_type->{enabled} } @entries if $auto_type;
+ @entries = map { ($_, @{$_->history}) } @entries if $history;
+ return $group;
+ }
+ }
+ shift @entries;
+ });
}
+sub __iter__ { $_[0]->objects }
+
##############################################################################
=method custom_icon
$kdbx->custom_icon(%icon);
$kdbx->custom_icon(uuid => $value, %icon);
+Get or set custom icons.
=cut
sub custom_icon {
my $self = shift;
- my %args = @_ == 2 ? (uuid => shift, value => shift)
+ my %args = @_ == 2 ? (uuid => shift, data => shift)
: @_ % 2 == 1 ? (uuid => shift, @_) : @_;
- if (!$args{key} && !$args{value}) {
- my %standard = (key => 1, value => 1, last_modification_time => 1);
+ if (!$args{uuid} && !$args{data}) {
+ my %standard = (uuid => 1, data => 1, name => 1, last_modification_time => 1);
my @other_keys = grep { !$standard{$_} } keys %args;
if (@other_keys == 1) {
my $key = $args{key} = $other_keys[0];
- $args{value} = delete $args{$key};
+ $args{data} = delete $args{$key};
}
}
- my $key = $args{key} or throw 'Must provide a custom_icons key to access';
+ my $uuid = $args{uuid} or throw 'Must provide a custom icon UUID to access';
+ my $icon = (first { $_->{uuid} eq $uuid } @{$self->custom_icons}) // do {
+ push @{$self->custom_icons}, my $i = { uuid => $uuid };
+ $i;
+ };
- return $self->{meta}{custom_icons}{$key} = $args{value} if is_plain_hashref($args{value});
+ my $fields = \%args;
+ $fields = $args{data} if is_plain_hashref($args{data});
- while (my ($field, $value) = each %args) {
- $self->{meta}{custom_icons}{$key}{$field} = $value;
+ while (my ($field, $value) = each %$fields) {
+ $icon->{$field} = $value;
}
- return $self->{meta}{custom_icons}{$key};
+ return $icon;
}
=method custom_icon_data
$image_data = $kdbx->custom_icon_data($uuid);
-Get a custom icon.
+Get a custom icon image data.
=cut
sub custom_icon_data {
my $self = shift;
my $uuid = shift // return;
- return if !exists $self->custom_icons->{$uuid};
- return $self->custom_icons->{$uuid}{data};
+ my $icon = first { $_->{uuid} eq $uuid } @{$self->custom_icons} or return;
+ return $icon->{data};
}
=method add_custom_icon
Add a custom icon and get its UUID. If not provided, a random UUID will be generated. Possible attributes:
=for :list
-* C<uuid> - Icon UUID
+* C<uuid> - Icon UUID (default: autogenerated)
* C<name> - Name of the icon (text, KDBX4.1+)
* C<last_modification_time> - Just what it says (datetime, KDBX4.1+)
my $img = shift or throw 'Must provide image data';
my %args = @_;
- my $uuid = $args{uuid} // generate_uuid(sub { !$self->custom_icons->{$_} });
- $self->custom_icons->{$uuid} = {
+ my $uuid = $args{uuid} // generate_uuid;
+ push @{$self->custom_icons}, {
@_,
uuid => $uuid,
data => $img,
sub remove_custom_icon {
my $self = shift;
my $uuid = shift;
- delete $self->custom_icons->{$uuid};
+ my @deleted;
+ @{$self->custom_icons} = grep { $_->{uuid} eq $uuid ? do { push @deleted, $_; 0 } : 1 }
+ @{$self->custom_icons};
+ $self->add_deleted_object($uuid) if @deleted;
+ return @deleted;
}
##############################################################################
=for :list
* can store strings, booleans and up to 64-bit integer values (custom data can only store text values)
* is NOT encrypted within a KDBX file (hence the "public" part of the name)
-* is a flat hash/dict of key-value pairs (no other associated fields like modification times)
+* is a plain hash/dict of key-value pairs with no other associated fields (like modification times)
=cut
# die 'Not implemented';
# }
+=method add_deleted_object
+
+ $kdbx->add_deleted_object($uuid);
+
+Add a UUID to 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 populated automatically as objects
+are removed.
+
+=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
use this method to resolve on-the-fly references that aren't part of any actual string in the database.
If the reference does not resolve to any field, C<undef> is returned. If the reference resolves to multiple
-fields, only the first one is returned (in the same order as L</all_entries>). To avoid ambiguity, you can
-refer to a specific entry by its UUID.
+fields, only the first one is returned (in the same order as iterated by L</entries>). To avoid ambiguity, you
+can refer to a specific entry by its UUID.
The syntax of a reference is: C<< {REF:<WantedField>@<SearchIn>:<Text>} >>. C<Text> is a
L</"Simple Expression">. C<WantedField> and C<SearchIn> are both single character codes representing a field:
my $query = $search_in eq 'uuid' ? query($search_in => uuid($text))
: simple_expression_query($text, '=~', $search_in);
- my ($entry) = $self->find_entries($query, limit => 1);
+ my $entry = $self->entries->grep($query)->next;
$entry or return;
return $entry->$wanted;
}
our %PLACEHOLDERS = (
- # placeholder => sub { my ($entry, $arg) = @_; ... };
+ # 'PLACEHOLDER' => sub { my ($entry, $arg) = @_; ... };
'TITLE' => sub { $_[0]->expanded_title },
'USERNAME' => sub { $_[0]->expanded_username },
'PASSWORD' => sub { $_[0]->expanded_password },
$kdbx->lock;
-Encrypt all protected strings in a database. The encrypted strings are stored in a L<File::KDBX::Safe>
-associated with the database and the actual strings will be replaced with C<undef> to indicate their protected
-state. Returns itself to allow method chaining.
+Encrypt all protected binaries strings in a database. The encrypted strings are stored in
+a L<File::KDBX::Safe> associated with the database and the actual strings will be replaced with C<undef> to
+indicate their protected state. Returns itself to allow method chaining.
=cut
my @strings;
- my $entries = $self->all_entries(history => 1);
- for my $entry (@$entries) {
- push @strings, grep { $_->{protect} } values %{$entry->{strings} || {}};
- }
+ $self->entries(history => 1)->each(sub {
+ push @strings, grep { $_->{protect} } values %{$_->strings}, values %{$_->binaries};
+ });
$self->_safe(File::KDBX::Safe->new(\@strings));
$key = $kdbx->key($key);
$key = $kdbx->key($primitive);
-Get or set a L<File::KDBX::Key>. This is the master key (i.e. a password or a key file that can decrypt
+Get or set a L<File::KDBX::Key>. This is the master key (e.g. a password or a key file that can decrypt
a database). See L<File::KDBX::Key/new> for an explanation of what the primitive can be.
You generally don't need to call this directly because you can provide the key directly to the loader or
-dumper when loading or saving a KDBX file.
+dumper when loading or dumping a KDBX file.
=cut
#########################################################################################
-sub check {
+# sub check {
# - Fixer tool. Can repair inconsistencies, including:
# - Orphaned binaries... not really a thing anymore since we now distribute binaries amongst entries
# - Unused custom icons (OFF, data loss)
# - Duplicate window associations (OFF)
# - Only one root group (ON)
# - Header UUIDs match known ciphers/KDFs?
-}
+# }
#########################################################################################
my $type = shift;
my %handlers = (
- 'entry.uuid.changed' => \&_update_entry_uuid,
- 'group.uuid.changed' => \&_update_group_uuid,
+ '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,
);
my $handler = $handlers{$type} or return;
$self->$handler($object, @_);
}
-sub _update_group_uuid {
+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} // '');
-
- 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->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} // '');
+
+ $self->add_deleted_object($old_uuid);
}
-sub _update_entry_uuid {
+sub _handle_entry_uuid_changed {
my $self = shift;
my $object = shift;
my $new_uuid = shift;
my $new_pretty = format_uuid($new_uuid);
my $fieldref_match = qr/\{REF:([TUPANI])\@I:\Q$old_pretty\E\}/is;
- for my $entry (@{$self->all_entries}) {
- $entry->previous_parent_group($new_uuid) if $old_uuid eq ($entry->{previous_parent_group} // '');
+ $self->entries->each(sub {
+ $_->previous_parent_group($new_uuid) if $old_uuid eq ($_->{previous_parent_group} // '');
- for my $string (values %{$entry->strings}) {
+ for my $string (values %{$_->strings}) {
next if !defined $string->{value} || $string->{value} !~ $fieldref_match;
- my $txn = $entry->begin_work;
+ my $txn = $_->begin_work;
$string->{value} =~ s/$fieldref_match/{REF:$1\@I:$new_pretty}/g;
$txn->commit;
}
- }
+ });
+}
+
+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} // '');
+
+ $self->groups->each(sub {
+ $_->last_top_visible_entry($new_uuid) if $old_uuid eq ($_->{last_top_visible_entry} // '');
+ $_->previous_parent_group($new_uuid) if $old_uuid eq ($_->{previous_parent_group} // '');
+ });
+ $self->entries->each(sub {
+ $_->previous_parent_group($new_uuid) if $old_uuid eq ($_->{previous_parent_group} // '');
+ });
}
#########################################################################################
$kdbx = File::KDBX->load_file('passwords.kdbx', 'M@st3rP@ssw0rd!');
- for my $entry (@{ $kdbx->all_entries }) {
+ kdbx->entries->each(sub {
+ my ($entry) = @_;
say 'Entry: ', $entry->title;
- }
+ });
=head1 DESCRIPTION
my $kdbx = File::KDBX->load_file('mypasswords.kdbx', 'master password CHANGEME');
$kdbx->unlock;
- for my $entry (@{ $kdbx->all_entries }) {
- say 'Found password for ', $entry->title, ':';
+ $kdbx->entries->each(sub {
+ my ($entry) = @_;
+ say 'Found password for ', $entry->title;
say ' Username: ', $entry->username;
say ' Password: ', $entry->password;
- }
+ });
=head2 Search for entries
- my @entries = $kdbx->find_entries({
- title => 'WayneCorp',
- }, search => 1);
+ my @entries = $kdbx->entries(searching => 1)
+ ->grep(title => 'WayneCorp')
+ ->each; # return all matches
+
+The C<searching> option limits results to only entries within groups with searching enabled. Other options are
+also available. See L</entries>.
See L</QUERY> for many more query examples.
=head2 Search for entries by auto-type window association
- my @entry_key_sequences = $kdbx->find_entries_for_window('WayneCorp - Mozilla Firefox');
- for my $pair (@entry_key_sequences) {
- my ($entry, $key_sequence) = @$pair;
- say 'Entry title: ', $entry->title, ', key sequence: ', $key_sequence;
- }
+ my $window_title = 'WayneCorp - Mozilla Firefox';
+
+ my $entries = $kdbx->entries(auto_type => 1)
+ ->filter(sub {
+ my $ata = $_->auto_type_associations->grep(sub { $_->{window} =~ $window_title })->next;
+ return [$_, $ata->{keystroke_sequence}] if $ata;
+ })
+ ->each(sub {
+ my ($entry, $keys) = @$_;
+ say 'Entry title: ', $entry->title, ', key sequence: ', $keys;
+ });
Example output:
Entry title: WayneCorp, key sequence: {PASSWORD}{ENTER}
+=head2 Remove entries from a database
+
+ $kdbx->entries
+ ->grep(notes => {'=~' => qr/too old/i})
+ ->each(sub { $_->recycle });
+
+Recycle all entries with the string "too old" appearing in the B<Notes> string.
+
=head1 SECURITY
One of the biggest threats to your database security is how easily the encryption key can be brute-forced.
=head1 QUERY
+B<TODO> - All these examples are WRONG now.
+
Several methods take a I<query> as an argument (e.g. L</find_entries>). A query is just a subroutine that you
can either write yourself or have generated for you based on either a simple expression or a declarative
structure. It's easier to have your query generated, so I'll cover that first.
If the tools are getting in your way, you can of course iterate over the contents of a database and implement
your own query logic, like this:
- for my $entry (@{ $kdbx->all_entries }) {
+ my $entries = $kdbx->entries;
+ while (my $entry = $entries->next) {
if (wanted($entry)) {
do_something($entry);
}
projects / chaz / p5-File-KDBX / blobdiff