license = Perl_5
[@Author::CCM]
+Test::CleanNamespaces.skip[0] = ::Util|::KDF::AES$
[Prereqs / RuntimeRecommends]
File::Spec = 0
package File::KDBX;
-# ABSTRACT: Encrypted databases to store secret text and files
+# ABSTRACT: Encrypted database to store secret text and files
use warnings;
use strict;
+use Crypt::Digest qw(digest_data);
use Crypt::PRNG qw(random_bytes);
use Devel::GlobalDestruction;
use File::KDBX::Constants qw(:all :icon);
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 $self->entries(history => 1)->next(sub {
\&iterator = $kdbx->groups(%options);
\&iterator = $kdbx->groups($base_group, %options);
-Get an iterator over I<groups> within a database. Options:
+Get an L<File::KDBX::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>)
\&iterator = $kdbx->entries(%options);
\&iterator = $kdbx->entries($base_group, %options);
-Get an iterator over I<entries> within a database. Supports the same options as L</groups>, plus some new
-ones:
+Get an L<File::KDBX::Iterator> over I<entries> within a database. Supports the same options as L</groups>,
+plus some new ones:
=for :list
* C<auto_type> - Only include entries with auto-type enabled (default: false, include all)
-* C<searching> - Only include entries within groups with search enabled (default: false, include all)
+* C<searching> - Only include entries within groups with searching enabled (default: false, include all)
* C<history> - Also include historical entries (default: false, include only current entries)
=cut
\&iterator = $kdbx->objects(%options);
\&iterator = $kdbx->objects($base_group, %options);
-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>.
+Get an L<File::KDBX::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
=method add_custom_icon
$uuid = $kdbx->add_custom_icon($image_data, %attributes);
+ $uuid = $kdbx->add_custom_icon(%attributes);
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 (default: autogenerated)
+* C<data> - Image data (same as C<$image_data>)
* C<name> - Name of the icon (text, KDBX4.1+)
* C<last_modification_time> - Just what it says (datetime, KDBX4.1+)
sub add_custom_icon {
my $self = shift;
- my $img = shift or throw 'Must provide image data';
- my %args = @_;
+ my %args = @_ % 2 == 1 ? (data => shift, @_) : @_;
+
+ defined $args{data} or throw 'Must provide image data';
my $uuid = $args{uuid} // generate_uuid;
push @{$self->custom_icons}, {
@_,
uuid => $uuid,
- data => $img,
+ data => $args{data},
};
return $uuid;
}
$wanted && $search_in && nonempty($text) or return;
my %fields = (
- T => 'expanded_title',
- U => 'expanded_username',
- P => 'expanded_password',
- A => 'expanded_url',
- N => 'expanded_notes',
+ T => 'expand_title',
+ U => 'expand_username',
+ P => 'expand_password',
+ A => 'expand_url',
+ N => 'expand_notes',
I => 'uuid',
O => 'other_strings',
);
our %PLACEHOLDERS = (
# 'PLACEHOLDER' => sub { my ($entry, $arg) = @_; ... };
- 'TITLE' => sub { $_[0]->expanded_title },
- 'USERNAME' => sub { $_[0]->expanded_username },
- 'PASSWORD' => sub { $_[0]->expanded_password },
- 'NOTES' => sub { $_[0]->expanded_notes },
+ 'TITLE' => sub { $_[0]->expand_title },
+ 'USERNAME' => sub { $_[0]->expand_username },
+ 'PASSWORD' => sub { $_[0]->expand_password },
+ 'NOTES' => sub { $_[0]->expand_notes },
'S:' => sub { $_[0]->string_value($_[1]) },
- 'URL' => sub { $_[0]->expanded_url },
+ 'URL' => sub { $_[0]->expand_url },
'URL:RMVSCM' => sub { local $_ = $_[0]->url; s!^[^:/\?\#]+://!!; $_ },
'URL:WITHOUTSCHEME' => sub { local $_ = $_[0]->url; s!^[^:/\?\#]+://!!; $_ },
'URL:SCM' => sub { (split_url($_[0]->url))[0] },
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.
+You can call C<code> on an already-locked database to memory-protect any unprotected strings and binaries
+added after the last time the database was locked.
+
=cut
sub _safe {
##############################################################################
+# 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 icons
+# - All data types are valid
+# - date times are correct
+# - boolean fields
+# - All UUIDs refer to things that exist
+# - previous parent group
+# - recycle bin
+# - last selected group
+# - last visible group
+# - Enforce history size limits (ON)
+# - Check headers/meta (ON)
+# - Duplicate deleted objects (ON)
+# - Duplicate window associations (OFF)
+# - Header UUIDs match known ciphers/KDFs?
+# }
+
+=method remove_empty_groups
+
+ $kdbx->remove_empty_groups;
+
+Remove groups with no subgroups and no entries.
+
+=cut
+
+sub remove_empty_groups {
+ my $self = shift;
+ my @removed;
+ $self->groups(algorithm => 'dfs')
+ ->where(-true => 'is_empty')
+ ->each(sub { push @removed, $_->remove });
+ return @removed;
+}
+
+=method remove_unused_icons
+
+ $kdbx->remove_unused_icons;
+
+Remove icons that are not associated with any entry or group in the database.
+
+=cut
+
+sub remove_unused_icons {
+ my $self = shift;
+ my %icons = map { $_->{uuid} => 0 } @{$self->custom_icons};
+
+ $self->objects->each(sub { ++$icons{$_->custom_icon_uuid // ''} });
+
+ my @removed;
+ push @removed, $self->remove_custom_icon($_) for grep { $icons{$_} == 0 } keys %icons;
+ return @removed;
+}
+
+=method remove_duplicate_icons
+
+ $kdbx->remove_duplicate_icons;
+
+Remove duplicate icons as determined by hashing the icon data.
+
+=cut
+
+sub remove_duplicate_icons {
+ my $self = shift;
+
+ my %seen;
+ my %dup;
+ for my $icon (@{$self->custom_icons}) {
+ my $digest = digest_data('SHA256', $icon->{data});
+ if (my $other = $seen{$digest}) {
+ $dup{$icon->{uuid}} = $other->{uuid};
+ }
+ else {
+ $seen{$digest} = $icon;
+ }
+ }
+
+ my @removed;
+ while (my ($old_uuid, $new_uuid) = each %dup) {
+ $self->objects
+ ->where(custom_icon_uuid => $old_uuid)
+ ->each(sub { $_->custom_icon_uuid($new_uuid) });
+ push @removed, $self->remove_custom_icon($old_uuid);
+ }
+ return @removed;
+}
+
+=method prune_history
+
+ $kdbx->prune_history(%options);
+
+Remove just as many older historical entries as necessary to get under certain limits.
+
+=for :list
+* C<max_items> - Maximum number of historical entries to keep (default: value of L</history_max_items>, no
+ limit: -1)
+* C<max_size> - Maximum total size (in bytes) of historical entries to keep (default: value of
+ L</history_max_size>, no limit: -1)
+* C<max_age> - Maximum age (in days) of historical entries to keep (default: 365, no limit: -1)
+
+=cut
+
+sub prune_history {
+ my $self = shift;
+ my %args = @_;
+
+ my $max_items = $args{max_items} // $self->history_max_items // HISTORY_DEFAULT_MAX_ITEMS;
+ my $max_size = $args{max_size} // $self->history_max_size // HISTORY_DEFAULT_MAX_SIZE;
+ my $max_age = $args{max_age} // HISTORY_DEFAULT_MAX_AGE;
+
+ my @removed;
+ $self->entries->each(sub {
+ push @removed, $_->prune_history(
+ max_items => $max_items,
+ max_size => $max_size,
+ max_age => $max_age,
+ );
+ });
+ return @removed;
+}
+
=method randomize_seeds
$kdbx->randomize_seeds;
#########################################################################################
-# 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 icons
-# - All data types are valid
-# - date times are correct
-# - boolean fields
-# - All UUIDs refer to things that exist
-# - previous parent group
-# - recycle bin
-# - last selected group
-# - last visible group
-# - Enforce history size limits (ON)
-# - Check headers/meta (ON)
-# - Duplicate deleted objects (ON)
-# - Duplicate window associations (OFF)
-# - Only one root group (ON)
- # - Header UUIDs match known ciphers/KDFs?
-# }
-
-#########################################################################################
-
sub _handle_signal {
my $self = shift;
my $object = shift;
#########################################################################################
+=attr sig1
+
+=attr sig2
+
+=attr version
+
+=attr headers
+
+=attr inner_headers
+
+=attr meta
+
+=attr binaries
+
+=attr deleted_objects
+
+Hash of UUIDs for objects that have been deleted. This includes groups, entries and even custom icons.
+
+=attr raw
+
+Bytes contained within the encrypted layer of a KDBX file. This is only set when using
+L<File::KDBX::Loader::Raw>.
+
=attr comment
A text string associated with the database. Often unset.
Note: This is purely advisory. It is up to the individual agent software to actually enforce it.
C<File::KDBX> does NOT enforce it.
+=attr custom_icons
+
+Array of custom icons that can be associated with groups and entries.
+
+This list can be managed with the methods L</add_custom_icon> and L</remove_custom_icon>.
+
=attr recycle_bin_enabled
Boolean indicating whether removed groups and entries should go to a recycle bin or be immediately deleted.
=head2 Read an existing database
my $kdbx = File::KDBX->load_file('mypasswords.kdbx', 'master password CHANGEME');
- $kdbx->unlock;
+ $kdbx->unlock; # cause $entry->password below to be defined
$kdbx->entries->each(sub {
my ($entry) = @_;
- say 'Found password for ', $entry->title;
+ say 'Found password for: ', $entry->title;
say ' Username: ', $entry->username;
say ' Password: ', $entry->password;
});
Recycle all entries with the string "too old" appearing in the B<Notes> string.
+=head2 Remove empty groups
+
+ $kdbx->groups(algorithm => 'dfs')
+ ->where(-true => 'is_empty')
+ ->each('remove');
+
+With the search/iteration C<algorithm> set to "dfs", groups will be ordered deepest first and the root group
+will be last. This allows removing groups that only contain empty groups.
+
+This can also be done with one call to L</remove_empty_groups>.
+
=head1 SECURITY
One of the biggest threats to your database security is how easily the encryption key can be brute-forced.
-Strong brute-force protection depends on a couple factors:
+Strong brute-force protection depends on:
=for :list
* Using unguessable passwords, passphrases and key files.
For one thing, the encryption key is stored in the same address space. If core is dumped, the encryption key
is available to be found out. But at least there is the chance that the encryption key and the encrypted
-secrets won't both be paged out while memory-constrained.
+secrets won't both be paged out together while memory-constrained.
Another problem is that some perls (somewhat notoriously) copy around memory behind the scenes willy nilly,
and it's difficult know when perl makes a copy of a secret in order to be able to zero it out later. It might
To find things in a KDBX database, you should use a filtered iterator. If you have an iterator, such as
returned by L</entries>, L</groups> or even L</objects> you can filter it using L<File::KDBX::Iterator/where>.
- my $filtered_results = $kdbx->entries->where($query);
+ my $filtered_entries = $kdbx->entries->where($query);
A C<$query> is just a subroutine that you can either write yourself or have generated for you from either
a L</"Simple Expression"> or L</"Declarative Syntax">. It's easier to have your query generated, so I'll cover
my $entries = $kdbx->entries->where(\'canyon', qw[title]);
-Notice the first argument is a B<scalarref>. This diambiguates a simple expression from other types of queries
-covered below.
+Notice the first argument is a B<scalarref>. This disambiguates a simple expression from other types of
+queries covered below.
As mentioned, a simple expression can have multiple terms. This simple expression query matches any entry that
has the words "red" B<and> "canyon" anywhere in the title:
my $entries = $kdbx->entries->where(\'red -canyon', qw[title]);
-To search over multiple fields simultaneously, just list them. To search for entries with "grocery" in the
-title or notes but not "Foodland":
+To search over multiple fields simultaneously, just list them all. To search for entries with "grocery" (but
+not "Foodland") in the title or notes:
my $entries = $kdbx->entries->where(\'grocery -Foodland', qw[title notes]);
my $entries = $kdbx->entries->where(\5, '>=', qw[usage_count]);
-It helps to read it right-to-left, like "usage_count is >= 5".
+It helps to read it right-to-left, like "usage_count is greater than or equal to 5".
If you find the disambiguating structures to be distracting or confusing, you can also the
L<File::KDBX::Util/simple_expression_query> function as a more intuitive alternative. The following example is
=head2 Declarative Syntax
Structuring a declarative query is similar to L<SQL::Abstract/"WHERE CLAUSES">, but you don't have to be
-familiar with that module. Just learn by examples.
+familiar with that module. Just learn by examples here.
To search for all entries in a database titled "My Bank":
username => 'neo',
]);
-
-
You can use different operators to test different types of attributes. The L<File::KDBX::Entry/icon_id>
attribute is a number, so we should use a number comparison operator. To find entries using the smartphone
icon:
'ne' => uuid('596f7520-6172-6520-7370-656369616c2e'),
},
);
- if (1 < $groups->count) { say "Problem: there can be only one!" }
-Note: L<File::KDBX::Util/uuid> is a little helper function to convert a UUID in its pretty form into bytes.
-This helper function isn't special to this example or to queries generally. It could have been written with
+Note: L<File::KDBX::Util/uuid> is a little utility function to convert a UUID in its pretty form into bytes.
+This utility function isn't special to this example or to queries generally. It could have been written with
a literal such as C<"\x59\x6f\x75\x20\x61...">, but that's harder to read.
Notice we searched for groups this time. Finding groups works exactly the same as it does for entries.
Notice also that we didn't wrap the query in hashref curly-braces or arrayref square-braces. Those are
-optional. By default it will only match ALL attributes (as if there were curly-braces), but it doesn't matter
-if there is only one attribute so it's fine to rely on the implicit behavior.
+optional. By default it will only match ALL attributes (as if there were curly-braces).
Testing the truthiness of an attribute is a little bit different because it isn't a binary operation. To find
all entries with the password quality check disabled:
weird for your taste):
my $entries = $kdbx->entries->where('!!' => 'quality_check');
- my $entries = $kdbx->entries->where(-true => 'quality_check');
+ my $entries = $kdbx->entries->where(-true => 'quality_check'); # same thing
Yes, there is also a C<-false> and a C<-not> if you prefer one of those over C<!>. C<-false> and C<-not>
(along with C<-true>) are also special in that you can use them to invert the logic of a subquery. These are
criteria you want and return true if it matches or false to skip. To do this, just pass your subroutine
coderef to C<where>.
-For example, these are all equivalent to find all entries in the database titled "My Bank":
+To review the different types of queries, these are all equivalent to find all entries in the database titled
+"My Bank":
my $entries = $kdbx->entries->where(\'"My Bank"', 'eq', qw[title]); # simple expression
my $entries = $kdbx->entries->where(title => 'My Bank'); # declarative syntax
}
}
+=head2 Iteration
+
+Iterators are the built-in way to navigate or walk the database tree. You get an iterator from L</entries>,
+L</groups> and L</groups>. You can specify the search algorithm to iterate over objects in different orders
+using the C<algorith> option, which can be one of:
+
+=for :list
+* C<ITERATION_IDS> - Iterative deepending search (default)
+* C<ITERATION_DFS> - Depth-first search
+* C<ITERATION_BFS> - Breatdth-first search
+
+When iterating over objects generically, groups always preceed their direct entries (if any). When the
+C<history> option is used, current entries always preceed historical entries.
+
+If you have a database tree like this:
+
+ Database
+ - Root
+ - Group1
+ - EntryA
+ - Group2
+ - EntryB
+ - Group3
+ - EntryC
+
+IDS order of groups is: Root, Group1, Group2, Group3
+IDS order of entries is: EntryA, EntryB, EntryC
+IDS order of objects is: Root, Group1, EntryA, Group2, EntryB, Group3, EntryC
+
+DFS order of groups is: Group2, Group1, Group3, Root
+DFS order of entries is: EntryB, EntryA, EntryC
+DFS order of objects is: Group2, EntryB, Group1, EntryA, Group3, EntryC, Root
+
+BFS order of groups is: Root, Group1, Group3, Group2
+BFS order of entries is: EntryA, EntryC, EntryB
+BFS order of objects is: Root, Group1, EntryA, Group3, EntryC, Group2, EntryB
+
+=head1 MERGING
+
+B<TODO> - This is a planned feature, not yet implemented.
+
=head1 ERRORS
Errors in this package are constructed as L<File::KDBX::Error> objects and propagated using perl's built-in
L<File::KeePass> is a much older alternative. It's good but has a backlog of bugs and lacks support for newer
KDBX features.
-=attr sig1
-
-=attr sig2
-
-=attr version
-
-=attr headers
-
-=attr inner_headers
-
-=attr meta
-
-=attr binaries
-
-=attr deleted_objects
-
-=attr raw
-
- $value = $kdbx->$attr;
- $kdbx->$attr($value);
-
-Get and set attributes.
-
=cut
},
history => {
__prefix => 'HISTORY',
+ DEFAULT_MAX_AGE => 365,
DEFAULT_MAX_ITEMS => 10,
- DEFAULT_MAX_SIZE => 6_291_456, # 6 M
+ DEFAULT_MAX_SIZE => 6_291_456, # 6 MiB
},
iteration => {
ITERATION_BFS => dualvar(1, 'bfs'),
Constants for history-related default values:
=for :list
+= C<HISTORY_DEFAULT_MAX_AGE>
= C<HISTORY_DEFAULT_MAX_ITEMS>
= C<HISTORY_DEFAULT_MAX_SIZE>
use Encode qw(encode);
use File::KDBX::Constants qw(:history :icon);
use File::KDBX::Error;
-use File::KDBX::Util qw(:class :coercion :erase :function :uri generate_uuid load_optional);
+use File::KDBX::Util qw(:assert :class :coercion :erase :function :uri generate_uuid load_optional);
use Hash::Util::FieldHash;
use List::Util qw(first sum0);
use Ref::Util qw(is_coderef is_hashref is_plain_hashref);
-use Scalar::Util qw(looks_like_number);
+use Scalar::Util qw(blessed looks_like_number);
use Storable qw(dclone);
use Time::Piece;
use boolean;
my %PLACEHOLDERS;
my %STANDARD_STRINGS = map { $_ => 1 } qw(Title UserName Password URL Notes);
-sub _parent_container { 'entries' }
-
=attr uuid
128-bit UUID identifying the entry within the database.
Text string with arbitrary tags which can be used to build a taxonomy.
-=attr auto_type
-
-Auto-type details.
-
- {
- enabled => true,
- data_transfer_obfuscation => 0,
- default_sequence => '{USERNAME}{TAB}{PASSWORD}{ENTER}',
- associations => [
- {
- window => 'My Bank - Mozilla Firefox',
- keystroke_sequence => '{PASSWORD}{ENTER}',
- },
- ],
- }
-
=attr auto_type_enabled
Whether or not the entry is eligible to be matched for auto-typing.
-=attr auto_type_data_transfer_obfuscation
+=attr auto_type_obfuscation
-TODO
+Whether or not to use some kind of obfuscation when sending keystroke sequences to applications.
=attr auto_type_default_sequence
An array of window title / keystroke sequence associations.
+ {
+ window => 'Example Window Title',
+ keystroke_sequence => '{USERNAME}{TAB}{PASSWORD}{ENTER}',
+ }
+
+Keystroke sequences can have </Placeholders>, most commonly C<{USERNAME}> and C<{PASSWORD}>.
+
=attr previous_parent_group
128-bit UUID identifying a group within the database.
MySystem => { value => 'The mainframe' },
}
+There are methods available to provide more convenient access to strings, including L</string>,
+L</string_value>, L</expand_string_value> and L</string_peek>.
+
=attr binaries
-Files or attachments.
+Files or attachments. Binaries are similar to strings except they have a value of bytes instead of test
+characters.
+
+ {
+ 'myfile.txt' => {
+ value => '...',
+ },
+ 'mysecrets.txt' => {
+ value => '...',
+ protect => true,
+ },
+ }
+
+There are methods available to provide more convenient access to binaries, including L</binary> and
+L</binary_value>.
=attr custom_data
=attr location_changed
-Date and time when the entry was last moved to a different group.
+Date and time when the entry was last moved to a different parent group.
=attr notes
has location_changed => sub { gmtime }, store => 'times', coerce => \&to_time;
# has 'auto_type.auto_type_enabled' => true, coerce => \&to_bool;
-has 'auto_type_data_transfer_obfuscation' => 0, path => 'auto_type.data_transfer_obfuscation',
+has 'auto_type_obfuscation' => 0, path => 'auto_type.data_transfer_obfuscation',
coerce => \&to_number;
has 'auto_type_default_sequence' => '{USERNAME}{TAB}{PASSWORD}{ENTER}',
path => 'auto_type.default_sequence', coerce => \&to_string;
while (my ($attr, $string_key) = each %ATTRS_STRINGS) {
no strict 'refs'; ## no critic (ProhibitNoStrict)
*{$attr} = sub { shift->string_value($string_key, @_) };
- *{"expanded_${attr}"} = sub { shift->expanded_string_value($string_key, @_) };
+ *{"expand_${attr}"} = sub { shift->expand_string_value($string_key, @_) };
}
my @ATTRS = qw(uuid custom_data history auto_type_enabled);
return $string->{value};
}
-=method expanded_string_value
+=method expand_string_value
- $string = $entry->expanded_string_value;
+ $string = $entry->expand_string_value;
Same as L</string_value> but will substitute placeholders and resolve field references. Any placeholders that
do not expand to values are left as-is.
return $str;
}
-sub expanded_string_value {
+sub expand_string_value {
my $self = shift;
my $str = $self->string_peek(@_) // return undef;
my $cleanup = erase_scoped $str;
return $self->_expand_string($str);
}
+=attr expand_notes
+
+Shortcut equivalent to C<< ->expand_string_value('Notes') >>.
+
+=attr expand_password
+
+Shortcut equivalent to C<< ->expand_string_value('Password') >>.
+
+=attr expand_title
+
+Shortcut equivalent to C<< ->expand_string_value('Title') >>.
+
+=attr expand_url
+
+Shortcut equivalent to C<< ->expand_string_value('URL') >>.
+
+=attr expand_username
+
+Shortcut equivalent to C<< ->expand_string_value('UserName') >>.
+
=method other_strings
$other = $entry->other_strings;
##############################################################################
+=method add_auto_type_association
+
+ $entry->add_auto_type_association(\%association);
+
+Add a new auto-type association to an entry.
+
+=cut
+
sub add_auto_type_association {
my $self = shift;
my $association = shift;
push @{$self->auto_type_associations}, $association;
}
+=method expand_keystroke_sequence
+
+ $string = $entry->expand_keystroke_sequence($keystroke_sequence);
+ $string = $entry->expand_keystroke_sequence(\%association);
+ $string = $entry->expand_keystroke_sequence; # use default auto-type sequence
+
+Get a keystroke sequence after placeholder expansion.
+
+=cut
+
sub expand_keystroke_sequence {
my $self = shift;
my $association = shift;
- my $keys = is_hashref($association) && exists $association->{keystroke_sequence} ?
+ my $keys;
+ if ($association) {
+ $keys = is_hashref($association) && exists $association->{keystroke_sequence} ?
$association->{keystroke_sequence} : defined $association ? $association : '';
+ }
$keys = $self->auto_type_default_sequence if !$keys;
# TODO - Fall back to getting default sequence from parent group, which probably means we shouldn't be
structure. For example:
$binary = {
- value => 'Password',
+ value => '...',
protect => true, # optional
};
return $self->{binaries}{$key} = $args{value} if is_plain_hashref($args{value});
+ assert { !defined $args{value} || !utf8::is_utf8($args{value}) };
while (my ($field, $value) = each %args) {
$self->{binaries}{$key}{$field} = $value;
}
##############################################################################
-sub searching_enabled {
- my $self = shift;
- my $parent = $self->group;
- return $parent->effective_enable_searching if $parent;
- return true;
-}
-
-sub auto_type_enabled {
- my $self = shift;
- $self->auto_type->{enabled} = to_bool(shift) if @_;
- $self->auto_type->{enabled} //= true;
- return false if !$self->auto_type->{enabled};
- return true if !$self->is_connected;
- my $parent = $self->group;
- return $parent->effective_enable_auto_type if $parent;
- return true;
-}
-
-##############################################################################
-
=method hmac_otp
$otp = $entry->hmac_otp(%options);
sub history {
my $self = shift;
my $entries = $self->{history} //= [];
- # FIXME - Looping through entries on each access is too expensive.
- @$entries = map { $self->_wrap_entry($_, $self->kdbx) } @$entries;
+ if (@$entries && !blessed($entries->[0])) {
+ @$entries = map { $self->_wrap_entry($_, $self->kdbx) } @$entries;
+ }
+ assert { !any { !blessed $_ } @$entries };
return $entries;
}
=method prune_history
- $entry->prune_history(%options);
+ @removed_historical_entries = $entry->prune_history(%options);
-Remove as many older historical entries as necessary to get under the database limits. The limits are taken
-from the connected database (if any) or can be overridden with C<%options>:
+Remove just as many older historical entries as necessary to get under the database limits. The limits are
+taken from the connected database (if any) or can be overridden with C<%options>:
=for :list
* C<max_items> - Maximum number of historical entries to keep (default: 10, no limit: -1)
* C<max_size> - Maximum total size (in bytes) of historical entries to keep (default: 6 MiB, no limit: -1)
+* C<max_age> - Maximum age (in days) of historical entries to keep (default: 365, no limit: -1)
=cut
my $self = shift;
my %args = @_;
- my $max_items = $args{max_items} // eval { $self->kdbx->history_max_items }
- // HISTORY_DEFAULT_MAX_ITEMS;
- my $max_size = $args{max_size} // eval { $self->kdbx->history_max_size }
- // HISTORY_DEFAULT_MAX_SIZE;
+ my $max_items = $args{max_items} // eval { $self->kdbx->history_max_items } // HISTORY_DEFAULT_MAX_ITEMS;
+ my $max_size = $args{max_size} // eval { $self->kdbx->history_max_size } // HISTORY_DEFAULT_MAX_SIZE;
+ my $max_age = $args{max_age} // HISTORY_DEFAULT_MAX_AGE;
- # history is ordered oldest to youngest
+ # history is ordered oldest to newest
my $history = $self->history;
+ my @removed;
+
if (0 <= $max_items && $max_items < @$history) {
- splice @$history, -$max_items;
+ push @removed, splice @$history, -$max_items;
}
if (0 <= $max_size) {
my $current_size = $self->history_size;
while ($max_size < $current_size) {
- my $entry = shift @$history;
+ push @removed, my $entry = shift @$history;
$current_size -= $entry->size;
}
}
+
+ if (0 <= $max_age) {
+ my $cutoff = gmtime - ($max_age * 86400);
+ for (my $i = @$history - 1; 0 <= $i; --$i) {
+ my $entry = $history->[$i];
+ next if $cutoff <= $entry->last_modification_time;
+ push @removed, splice @$history, $i, 1;
+ }
+ }
+
+ @removed = sort { $a->last_modification_time <=> $b->last_modification_time } @removed;
+ return @removed;
}
=method add_historical_entry
push @{$self->{history} //= []}, map { $self->_wrap_entry($_) } @_;
}
+=method remove_historical_entry
+
+ $entry->remove_historical_entry($historical_entry);
+
+Remove an entry from the history.
+
+=cut
+
+sub remove_historical_entry {
+ my $self = shift;
+ my $entry = shift;
+ my $history = $self->history;
+
+ my @removed;
+ for (my $i = @$history - 1; 0 <= $i; --$i) {
+ my $item = $history->[$i];
+ next if Hash::Util::FieldHash::id($entry) != Hash::Util::FieldHash::id($item);
+ push @removed, splice @{$self->{history}}, $i, 1;
+ }
+ return @removed;
+}
+
=method current_entry
$current_entry = $entry->current_entry;
sub current_entry {
my $self = shift;
- my $group = $self->group;
+ my $parent = $self->group;
- if ($group) {
+ if ($parent) {
my $id = $self->uuid;
- my $entry = first { $id eq $_->uuid } @{$group->entries};
+ my $entry = first { $id eq $_->uuid } @{$parent->entries};
return $entry if $entry;
}
sub is_historical { !$_[0]->is_current }
+=method remove
+
+ $entry = $entry->remove;
+
+Remove an entry from its parent group. If the entry is historical, remove it from the history of the current
+entry. If the entry is current, this behaves the same as L<File::KDBX::Object/remove>.
+
+=cut
+
+sub remove {
+ my $self = shift;
+ my $current = $self->current_entry;
+ return $self if $current->remove_historical_entry($self);
+ $self->SUPER::remove(@_);
+}
+
+##############################################################################
+
+=method searching_enabled
+
+ $bool = $entry->searching_enabled;
+
+Get whether or not an entry may show up in search results. This is determine from the entry's parent group's
+L<File::KDBX::Group/effective_enable_searching> value.
+
+Throws if entry has no parent group or if the entry is not connected to a database.
+
+=cut
+
+sub searching_enabled {
+ my $self = shift;
+ my $parent = $self->group;
+ return $parent->effective_enable_searching if $parent;
+ return true;
+}
+
+sub auto_type_enabled {
+ my $self = shift;
+ $self->auto_type->{enabled} = to_bool(shift) if @_;
+ $self->auto_type->{enabled} //= true;
+ return false if !$self->auto_type->{enabled};
+ return true if !$self->is_connected;
+ my $parent = $self->group;
+ return $parent->effective_enable_auto_type if $parent;
+ return true;
+}
+
##############################################################################
sub _signal {
$self->last_access_time($time);
}
-sub label { shift->expanded_title(@_) }
+sub label { shift->expand_title(@_) }
+
+### Name of the parent attribute expected to contain the object
+sub _parent_container { 'entries' }
1;
__END__
+=for Pod::Coverage auto_type times
+
=head1 DESCRIPTION
An entry in a KDBX database is a record that can contains strings (also called "fields") and binaries (also
my $debug = $ENV{DEBUG};
$debug = looks_like_number($debug) ? (0 + $debug) : ($debug ? 1 : 0);
- *DEBUG = $debug == 1 ? sub() { 1 } :
+ *_DEBUG = $debug == 1 ? sub() { 1 } :
$debug == 2 ? sub() { 2 } :
$debug == 3 ? sub() { 3 } :
$debug == 4 ? sub() { 4 } : sub() { 0 };
Stringify an error.
-This does not contain a stack trace, but you can set the C<DEBUG> environment
-variable to truthy to stringify the whole error object.
+This does not contain a stack trace, but you can set the C<DEBUG> environment variable to at least 2 to
+stringify the whole error object.
=cut
my $self = shift;
my $msg = "$self->{trace}[0]";
$msg .= '.' if $msg !~ /[\.\!\?]$/;
- if (2 <= DEBUG) {
+ if (2 <= _DEBUG) {
require Data::Dumper;
local $Data::Dumper::Indent = 1;
local $Data::Dumper::Quotekeys = 0;
use strict;
use Devel::GlobalDestruction;
-use File::KDBX::Constants qw(:bool :icon);
+use File::KDBX::Constants qw(:bool :icon :iteration);
use File::KDBX::Error;
use File::KDBX::Iterator;
use File::KDBX::Util qw(:assert :class :coercion generate_uuid);
our $VERSION = '999.999'; # VERSION
-sub _parent_container { 'groups' }
+=attr uuid
+
+128-bit UUID identifying the group within the database.
+
+=attr name
+
+The human-readable name of the group.
+
+=attr notes
+
+Free form text string associated with the group.
+
+=attr tags
+
+Text string with arbitrary tags which can be used to build a taxonomy.
+
+=attr icon_id
+
+Integer representing a default icon. See L<File::KDBX::Constants/":icon"> for valid values.
+
+=attr custom_icon_uuid
+
+128-bit UUID identifying a custom icon within the database.
+
+=attr is_expanded
+
+Whether or not subgroups are visible when listed for user selection.
+
+=attr default_auto_type_sequence
+
+The default auto-type keystroke sequence, inheritable by entries and subgroups.
+
+=attr enable_auto_type
+
+Whether or not the entry is eligible to be matched for auto-typing, inheritable by entries and subgroups.
+
+=attr enable_searching
+
+Whether or not entries within the group can show up in search results, inheritable by subgroups.
+
+=attr last_top_visible_entry
+
+The UUID of the entry visible at the top of the list.
+
+=attr custom_data
+
+A set of key-value pairs used to store arbitrary data, usually used by software to keep track of state rather
+than by end users (who typically work with the strings and binaries).
+
+=attr previous_parent_group
+
+128-bit UUID identifying a group within the database.
+
+=attr entries
+
+Array of entries contained within the group.
+
+=attr groups
+
+Array of subgroups contained within the group.
+
+=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
+
+TODO
+
+=attr location_changed
+
+Date and time when the entry was last moved to a different parent group.
+
+=cut
# has uuid => sub { generate_uuid(printable => 1) };
has name => '', coerce => \&to_string;
##############################################################################
+=method entries
+
+ \@entries = $group->entries;
+
+Get an array of direct entries within a group.
+
+=cut
+
sub entries {
my $self = shift;
my $entries = $self->{entries} //= [];
return $entries;
}
+=method entries_deeply
+
+ \&iterator = $kdbx->entries_deeply(%options);
+
+Get an L<File::KDBX::Iterator> over I<entries> within a group. Supports the same options as L</groups>,
+plus some new ones:
+
+=for :list
+* C<auto_type> - Only include entries with auto-type enabled (default: false, include all)
+* C<searching> - Only include entries within groups with searching enabled (default: false, include all)
+* C<history> - Also include historical entries (default: false, include only current entries)
+
+=cut
+
sub entries_deeply {
my $self = shift;
my %args = @_;
return $entry->_set_group($self)->_signal('added', $self);
}
+=method remove_entry
+
+ $entry = $group->remove_entry($entry);
+ $entry = $group->remove_entry($entry_uuid);
+
+Remove an entry from a group's array of entries. Returns the entry removed or C<undef> if nothing removed.
+
+=cut
+
sub remove_entry {
my $self = shift;
my $uuid = is_ref($_[0]) ? $self->_wrap_entry(shift)->uuid : shift;
##############################################################################
+=method groups
+
+ \@groups = $group->groups;
+
+Get an array of direct subgroups within a group.
+
+=cut
+
sub groups {
my $self = shift;
my $groups = $self->{groups} //= [];
return $groups;
}
+=method groups_deeply
+
+ \&iterator = $group->groups_deeply(%options);
+
+Get an L<File::KDBX::Iterator> over I<groups> within a groups, deeply. Options:
+
+=for :list
+* C<inclusive> - Include C<$group> itself in the results (default: true)
+* C<algorithm> - Search algorithm, one of C<ids>, C<bfs> or C<dfs> (default: C<ids>)
+
+=cut
+
sub groups_deeply {
my $self = shift;
my %args = @_;
my @groups = ($args{inclusive} // 1) ? $self : @{$self->groups};
my $algo = lc($args{algorithm} || 'ids');
- if ($algo eq 'dfs') {
+ if ($algo eq ITERATION_DFS) {
my %visited;
return File::KDBX::Iterator->new(sub {
my $next = shift @groups or return;
$next;
});
}
- elsif ($algo eq 'bfs') {
+ elsif ($algo eq ITERATION_BFS) {
return File::KDBX::Iterator->new(sub {
my $next = shift @groups or return;
push @groups, @{$next->groups};
return $group->_set_group($self)->_signal('added', $self);
}
+=method remove_group
+
+ $removed_group = $group->remove_group($group);
+ $removed_group = $group->remove_group($group_uuid);
+
+Remove a group from a group's array of subgroups. Returns the group removed or C<undef> if nothing removed.
+
+=cut
+
sub remove_group {
my $self = shift;
my $uuid = is_ref($_[0]) ? $self->_wrap_group(shift)->uuid : shift;
##############################################################################
+=method objects_deeply
+
+ \&iterator = $groups->objects_deeply(%options);
+
+Get an L<File::KDBX::Iterator> over I<objects> within a group, deeply. 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 objects_deeply {
my $self = shift;
my %args = @_;
##############################################################################
+=method effective_default_auto_type_sequence
+
+ $text = $group->effective_default_auto_type_sequence;
+
+Get the value of L</default_auto_type_sequence>, if set, or get the inherited effective default auto-type
+sequence of the parent.
+
+=cut
+
+sub effective_default_auto_type_sequence {
+ my $self = shift;
+ my $sequence = $self->default_auto_type_sequence;
+ return $sequence if defined $sequence;
+
+ my $parent = $self->group or return '{USERNAME}{TAB}{PASSWORD}{ENTER}';
+ return $parent->effective_default_auto_type_sequence;
+}
+
+=method effective_enable_auto_type
+
+ $text = $group->effective_enable_auto_type;
+
+Get the value of L</enable_auto_type>, if set, or get the inherited effective auto-type enabled value of the
+parent.
+
+=cut
+
+sub effective_enable_auto_type {
+ my $self = shift;
+ my $enabled = $self->enable_auto_type;
+ return $enabled if defined $enabled;
+
+ my $parent = $self->group or return true;
+ return $parent->effective_enable_auto_type;
+}
+
+=method effective_enable_searching
+
+ $text = $group->effective_enable_searching;
+
+Get the value of L</enable_searching>, if set, or get the inherited effective searching enabled value of the
+parent.
+
+=cut
+
+sub effective_enable_searching {
+ my $self = shift;
+ my $enabled = $self->enable_searching;
+ return $enabled if defined $enabled;
+
+ my $parent = $self->group or return true;
+ return $parent->effective_enable_searching;
+}
+
+##############################################################################
+
+=method is_empty
+
+ $bool = $group->is_empty;
+
+Get whether or not the group is empty (has no subgroups or entries).
+
+=cut
+
+sub is_empty {
+ my $self = shift;
+ return @{$self->groups} == 0 && @{$self->entries} == 0;
+}
+
=method is_root
$bool = $group->is_root;
=cut
-sub entry_templates {
+sub is_entry_templates {
my $self = shift;
my $kdbx = eval { $self->kdbx } or return FALSE;
my $group = $kdbx->entry_templates;
=cut
-sub last_selected {
+sub is_last_selected {
my $self = shift;
my $kdbx = eval { $self->kdbx } or return FALSE;
my $group = $kdbx->last_selected;
=cut
-sub last_top_visible {
+sub is_last_top_visible {
my $self = shift;
my $kdbx = eval { $self->kdbx } or return FALSE;
my $group = $kdbx->last_top_visible;
sub depth { $_[0]->is_root ? 0 : (scalar @{$_[0]->lineage || []} || -1) }
-sub label { shift->name(@_) }
-
sub _signal {
my $self = shift;
my $type = shift;
$self->last_access_time($time);
}
-sub effective_default_auto_type_sequence {
- my $self = shift;
- my $sequence = $self->default_auto_type_sequence;
- return $sequence if defined $sequence;
-
- my $parent = $self->group or return '{USERNAME}{TAB}{PASSWORD}{ENTER}';
- return $parent->effective_default_auto_type_sequence;
-}
-
-sub effective_enable_auto_type {
- my $self = shift;
- my $enabled = $self->enable_auto_type;
- return $enabled if defined $enabled;
-
- my $parent = $self->group or return true;
- return $parent->effective_enable_auto_type;
-}
-
-sub effective_enable_searching {
- my $self = shift;
- my $enabled = $self->enable_searching;
- return $enabled if defined $enabled;
+sub label { shift->name(@_) }
- my $parent = $self->group or return true;
- return $parent->effective_enable_searching;
-}
+### Name of the parent attribute expected to contain the object
+sub _parent_container { 'groups' }
1;
__END__
-=head1 DESCRIPTION
+=for Pod::Coverage times
-=attr uuid
-
-=attr name
-
-=attr notes
-
-=attr tags
-
-=attr icon_id
-
-=attr custom_icon_uuid
-
-=attr is_expanded
-
-=attr default_auto_type_sequence
-
-=attr enable_auto_type
-
-=attr enable_searching
-
-=attr last_top_visible_entry
-
-=attr custom_data
-
-=attr previous_parent_group
-
-=attr entries
-
-=attr groups
-
-=attr last_modification_time
-
-=attr creation_time
-
-=attr last_access_time
-
-=attr expiry_time
-
-=attr expires
-
-=attr usage_count
+=head1 DESCRIPTION
-=attr location_changed
+A group in a KDBX database is a type of object that can contain entries and other groups.
-Get or set various group fields.
+There is also some metadata associated with a group. Each group in a database is identified uniquely by
+a UUID. An entry can also have an icon associated with it, and there are various timestamps. Take a look at
+the attributes to see what's available.
=cut
use File::KDBX::Util qw(:class :load :search);
use Iterator::Simple;
use Module::Loaded;
-use Ref::Util qw(is_arrayref is_coderef is_scalarref);
+use Ref::Util qw(is_arrayref is_coderef is_ref is_scalarref);
use namespace::clean;
BEGIN { mark_as_loaded('Iterator::Simple::Iterator') }
@items = $iterator->each;
- $iterator->each(sub($item, $num) { ... });
+ $iterator->each(sub($item, $num, @args) { ... }, @args);
-Get the rest of the items. There are two forms: Without arguments, C<each> returns a list of the rest of the
-items. Or pass a coderef to be called once per item, in order. The item is passed as the first argument to the
-given subroutine and is also available as C<$_>.
+ $iterator->each($method_name, ...);
+
+Get or act on the rest of the items. There are three forms:
+
+=for :list
+1. Without arguments, C<each> returns a list of the rest of the items.
+2. Pass a coderef to be called once per item, in order. Arguments to the coderef are the item itself (also
+ C<$_>), its index number and then any extra arguments that were passed to C<each> after the coderef.
+3. Pass a string that is the name of a method to be called on each object, in order. Any extra arguments
+ passed to C<each> after the method name are passed through to each method call. This form requires each
+ item be an object that C<can> the given method.
B<NOTE:> This method drains the iterator completely, leaving it empty. See L</CAVEATS>.
my $self = shift;
my $cb = shift or return @{$self->to_array};
- my $count = 0;
- $cb->($_, $count++) while defined (local $_ = $self->());
+ if (is_coderef($cb)) {
+ my $count = 0;
+ $cb->($_, $count++, @_) while defined (local $_ = $self->());
+ }
+ elsif (!is_ref($cb)) {
+ $_->$cb(@_) while defined (local $_ = $self->());
+ }
return $self;
}
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);
}
return $thing;
}
+=func DEBUG
+
+Constant number indicating the level of debuggingness.
+
=func dumper
$str = dumper $thing;
sub to_string { $_[0] // return; "$_[0]" }
sub to_time {
$_[0] // return;
- return gmtime($_[0]) if looks_like_number($_[0]);
+ return scalar gmtime($_[0]) if looks_like_number($_[0]);
+ return scalar gmtime if $_[0] eq 'now';
return Time::Piece->strptime($_[0], '%Y-%m-%d %H:%M:%S') if !blessed $_[0];
return $_[0];
}
use File::KDBX;
use Test::Deep;
use Test::More;
+use Time::Piece;
subtest 'Create a new database' => sub {
my $kdbx = File::KDBX->new;
}, @objects;
};
+subtest 'Iteration algorithm' => sub {
+ # Database
+ # - Root
+ # - Group1
+ # - EntryA
+ # - Group2
+ # - EntryB
+ # - Group3
+ # - EntryC
+ my $kdbx = File::KDBX->new;
+ my $group1 = $kdbx->add_group(label => 'Group1');
+ my $group2 = $group1->add_group(label => 'Group2');
+ my $group3 = $kdbx->add_group(label => 'Group3');
+ my $entry1 = $group1->add_entry(label => 'EntryA');
+ my $entry2 = $group2->add_entry(label => 'EntryB');
+ my $entry3 = $group3->add_entry(label => 'EntryC');
+
+ cmp_deeply $kdbx->groups->map(sub { $_->label })->to_array,
+ [qw(Root Group1 Group2 Group3)], 'Default group order';
+ cmp_deeply $kdbx->entries->map(sub { $_->label })->to_array,
+ [qw(EntryA EntryB EntryC)], 'Default entry order';
+ cmp_deeply $kdbx->objects->map(sub { $_->label })->to_array,
+ [qw(Root Group1 EntryA Group2 EntryB Group3 EntryC)], 'Default object order';
+
+ cmp_deeply $kdbx->groups(algorithm => 'ids')->map(sub { $_->label })->to_array,
+ [qw(Root Group1 Group2 Group3)], 'IDS group order';
+ cmp_deeply $kdbx->entries(algorithm => 'ids')->map(sub { $_->label })->to_array,
+ [qw(EntryA EntryB EntryC)], 'IDS entry order';
+ cmp_deeply $kdbx->objects(algorithm => 'ids')->map(sub { $_->label })->to_array,
+ [qw(Root Group1 EntryA Group2 EntryB Group3 EntryC)], 'IDS object order';
+
+ cmp_deeply $kdbx->groups(algorithm => 'dfs')->map(sub { $_->label })->to_array,
+ [qw(Group2 Group1 Group3 Root)], 'DFS group order';
+ cmp_deeply $kdbx->entries(algorithm => 'dfs')->map(sub { $_->label })->to_array,
+ [qw(EntryB EntryA EntryC)], 'DFS entry order';
+ cmp_deeply $kdbx->objects(algorithm => 'dfs')->map(sub { $_->label })->to_array,
+ [qw(Group2 EntryB Group1 EntryA Group3 EntryC Root)], 'DFS object order';
+
+ cmp_deeply $kdbx->groups(algorithm => 'bfs')->map(sub { $_->label })->to_array,
+ [qw(Root Group1 Group3 Group2)], 'BFS group order';
+ cmp_deeply $kdbx->entries(algorithm => 'bfs')->map(sub { $_->label })->to_array,
+ [qw(EntryA EntryC EntryB)], 'BFS entry order';
+ cmp_deeply $kdbx->objects(algorithm => 'bfs')->map(sub { $_->label })->to_array,
+ [qw(Root Group1 EntryA Group3 EntryC Group2 EntryB)], 'BFS object order';
+};
+
subtest 'Recycle bin' => sub {
my $kdbx = File::KDBX->new;
my $entry = $kdbx->add_entry(label => 'Meh');
is $kdbx->entries->size, 0, 'Remove entry if it is already in the recycle bin';
};
+subtest 'Maintenance' => sub {
+ my $kdbx = File::KDBX->new;
+ $kdbx->add_group;
+ $kdbx->add_group->add_group;
+ my $entry = $kdbx->add_group->add_entry;
+
+ cmp_ok $kdbx->remove_empty_groups, '==', 3, 'Remove two empty groups';
+ cmp_ok $kdbx->groups->count, '==', 2, 'Two groups remain';
+
+ $entry->begin_work;
+ $entry->commit;
+ cmp_ok $kdbx->prune_history(max_age => 5), '==', 0, 'Do not remove new historical entries';
+
+ $entry->begin_work;
+ $entry->commit;
+ $entry->history->[0]->last_modification_time(scalar gmtime - 86400 * 10);
+ cmp_ok $kdbx->prune_history(max_age => 5), '==', 1, 'Remove a historical entry';
+ cmp_ok scalar @{$entry->history}, '==', 1, 'One historical entry remains';
+
+ cmp_ok $kdbx->remove_unused_icons, '==', 0, 'No icons to remove';
+ $kdbx->add_custom_icon('fake image 1');
+ $kdbx->add_custom_icon('fake image 2');
+ $entry->custom_icon('fake image 3');
+ cmp_ok $kdbx->remove_unused_icons, '==', 2, 'Remove unused icons';
+ cmp_ok scalar @{$kdbx->custom_icons}, '==', 1, 'Only one icon remains';
+
+ my $icon_uuid = $kdbx->add_custom_icon('fake image');
+ $entry->custom_icon('fake image');
+ cmp_ok $kdbx->remove_duplicate_icons, '==', 1, 'Remove duplicate icons';
+ is $entry->custom_icon_uuid, $icon_uuid, 'Uses of removed icon change';
+};
+
done_testing;
my $entry2 = $kdbx->add_entry(label => 'Bar');
$entry2->url(sprintf('{REF:T@I:%s} {REF:T@I:%s}', $entry1->id, lc($entry1->id)));
- is $entry2->expanded_url, 'Foo Foo', 'Field reference expands'
+ is $entry2->expand_url, 'Foo Foo', 'Field reference expands'
or diag explain $entry2->url;
$entry1->uuid("\1" x 16);
is $entry2->url, '{REF:T@I:01010101010101010101010101010101} {REF:T@I:01010101010101010101010101010101}',
'Replace field references when an entry UUID is changed';
- is $entry2->expanded_url, 'Foo Foo', 'Field reference expands after UUID is changed'
+ is $entry2->expand_url, 'Foo Foo', 'Field reference expands after UUID is changed'
or diag explain $entry2->url;
};
$copy = $entry->clone(reference_username => 1);
my $ref = sprintf('{REF:U@I:%s}', format_uuid($entry->uuid));
is $copy->username, $ref, 'Copy has username reference';
- is $copy->expanded_username, $ref, 'Entry copy does not expand username because entry is not in database';
+ is $copy->expand_username, $ref, 'Entry copy does not expand username because entry is not in database';
my $group = $kdbx->add_group(label => 'Passwords');
$group->add_entry($entry);
- is $copy->expanded_username, $entry->username,
+ is $copy->expand_username, $entry->username,
'Entry in database and its copy with username ref have same expanded username';
$copy = $entry->clone;
notes => '%MISSING% %% %NOT AVAR% %LYRIC%',
);
-is $entry1->expanded_username, 'User Foo', 'Basic placeholder expansion';
-is $entry2->expanded_username, 'User Foo', 'Reference to another entry';
-is $entry3->expanded_username, 'User Foo', 'Reference to another entry through another';
+is $entry1->expand_username, 'User Foo', 'Basic placeholder expansion';
+is $entry2->expand_username, 'User Foo', 'Reference to another entry';
+is $entry3->expand_username, 'User Foo', 'Reference to another entry through another';
my $recursive_expected = 'url notes ' x 10 . 'url {NOTES}';
my $recursive;
-my $warning = warning { $recursive = $entry2->expanded_url };
+my $warning = warning { $recursive = $entry2->expand_url };
like $warning, qr/detected deep recursion/i, 'Deep recursion causes a warning'
or diag 'Warnings: ', explain $warning;
is $recursive, $recursive_expected, 'Recursive placeholders resolve to... something';
{
my $entry = File::KDBX::Entry->new(url => 'http://example.com?{EXPLODE}');
- is $entry->expanded_url, 'http://example.com?{EXPLODE}',
+ is $entry->expand_url, 'http://example.com?{EXPLODE}',
'Unhandled placeholders are not replaced';
local $File::KDBX::PLACEHOLDERS{EXPLODE} = sub { 'boom' };
- is $entry->expanded_url, 'http://example.com?boom', 'Custom placeholders can be set';
+ is $entry->expand_url, 'http://example.com?boom', 'Custom placeholders can be set';
$entry->url('{eXplOde}!!');
- is $entry->expanded_url, 'boom!!', 'Placeholder tags are match case-insensitively';
+ is $entry->expand_url, 'boom!!', 'Placeholder tags are match case-insensitively';
}
{
local $ENV{LYRIC} = 'I am the very model of a modern Major-General';
- is $entry3->expanded_password, "lyric:$ENV{LYRIC}", 'Environment variable placeholders';
- is $entry3->expanded_notes, qq{%MISSING% %% %NOT AVAR% $ENV{LYRIC}},
+ is $entry3->expand_password, "lyric:$ENV{LYRIC}", 'Environment variable placeholders';
+ is $entry3->expand_notes, qq{%MISSING% %% %NOT AVAR% $ENV{LYRIC}},
'Do not replace things that look like environment variables but are not';
}
url => '{COUNTER} {USERNAME}',
username => '{COUNTER}x{COUNTER}y{COUNTER:-1}',
);
- like $entry4->expanded_username, qr/^1x1y-1$/,
+ like $entry4->expand_username, qr/^1x1y-1$/,
'Each unique placeholder is evaluated once';
- like $entry4->expanded_url, qr/^2 3x3y-1$/,
+ like $entry4->expand_url, qr/^2 3x3y-1$/,
'Each unique placeholder is evaluated once per string';
}
projects / chaz / p5-File-KDBX / commitdiff
