File-KDBX/t/database.t
#!/usr/bin/env perl
use utf8;
use warnings;
use strict;
use FindBin qw($Bin);
use lib "$Bin/lib";
use TestCommon;
use File::KDBX::Constants qw(:cipher :version);
use File::KDBX;
use File::Temp qw(tempfile);
use Test::Deep;
use Test::More 1.001004_001;
use Time::Piece;
subtest 'Create a new database' => sub {
my $kdbx = File::KDBX->new;
$kdbx->add_group(name => 'Meh');
ok $kdbx->_has_implicit_root, 'Database starts off with implicit root';
my $entry = $kdbx->add_entry({
username => 'hello',
password => {value => 'This is a secret!!!!!', protect => 1},
});
ok !$kdbx->_has_implicit_root, 'Adding an entry to the root group makes it explicit';
$entry->remove;
ok $kdbx->_has_implicit_root, 'Removing group makes the root group implicit again';
cmp_ok $kdbx->version, '==', KDBX_VERSION_3_1, 'Default KDBX file version is 3.1';
is $kdbx->cipher_id, CIPHER_UUID_AES256, 'Cipher of new database is AES256';
cmp_ok length($kdbx->encryption_iv), '==', 16, 'Encryption IV of new databse is 16 bytes';
my $kdbx2 = File::KDBX->new(version => KDBX_VERSION_4_0);
is $kdbx2->cipher_id, CIPHER_UUID_CHACHA20, 'Cipher of new v4 database is ChaCha20';
cmp_ok length($kdbx2->encryption_iv), '==', 12, 'Encryption IV of new databse is 12 bytes';
};
subtest 'Clone' => sub {
my $kdbx = File::KDBX->new;
$kdbx->add_group(name => 'Passwords')->add_entry(title => 'My Entry');
my $copy = $kdbx->clone;
cmp_deeply $copy, $kdbx, 'Clone keeps the same structure and data' or dumper $copy;
isnt $kdbx, $copy, 'Clone is a different object';
isnt $kdbx->root, $copy->root,
'Clone root group is a different object';
isnt $kdbx->root->groups->[0], $copy->root->groups->[0],
'Clone group is a different object';
isnt $kdbx->root->groups->[0]->entries->[0], $copy->root->groups->[0]->entries->[0],
'Clone entry is a different object';
my @objects = $copy->objects->each;
subtest 'Cloned objects refer to the cloned database' => sub {
plan tests => scalar @_;
for my $object (@_) {
my $object_kdbx = eval { $object->kdbx };
is $object_kdbx, $copy, 'Object: ' . $object->label;
}
}, @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');
my $bin = $kdbx->groups->grep(name => 'Recycle Bin')->next;
ok !$bin, 'New database has no recycle bin';
is $kdbx->recycle_bin_enabled, 1, 'Recycle bin is enabled';
$kdbx->recycle_bin_enabled(0);
$entry->recycle_or_remove;
cmp_ok $entry->is_recycled, '==', 0, 'Entry is not recycle if recycle bin is disabled';
$bin = $kdbx->groups->grep(name => 'Recycle Bin')->next;
ok !$bin, 'Recycle bin not autovivified if recycle bin is disabled';
is $kdbx->entries->size, 0, 'Database is empty after removing entry';
$kdbx->recycle_bin_enabled(1);
$entry = $kdbx->add_entry(label => 'Another one');
$entry->recycle_or_remove;
cmp_ok $entry->is_recycled, '==', 1, 'Entry is recycled';
$bin = $kdbx->groups->grep(name => 'Recycle Bin')->next;
ok $bin, 'Recycle bin group autovivifies';
cmp_ok $bin->icon_id, '==', 43, 'Recycle bin has the trash icon';
cmp_ok $bin->enable_auto_type, '==', 0, 'Recycle bin has auto type disabled';
cmp_ok $bin->enable_searching, '==', 0, 'Recycle bin has searching disabled';
is $kdbx->entries->size, 1, 'Database is not empty';
is $kdbx->entries(searching => 1)->size, 0, 'Database has no entries if searching';
cmp_ok $bin->all_entries->size, '==', 1, 'Recycle bin has an entry';
$entry->recycle_or_remove;
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';
};
subtest 'Dumping to filesystem' => sub {
my $kdbx = File::KDBX->new;
$kdbx->add_entry(title => 'Foo', password => 'whatever');
my ($fh, $filepath) = tempfile('kdbx-XXXXXX', TMPDIR => 1, UNLINK => 1);
close($fh);
$kdbx->dump($filepath, 'a');
my $kdbx2 = File::KDBX->load($filepath, 'a');
my $entry = $kdbx2->entries->map(sub { $_->title.'/'.$_->expand_password })->next;
is $entry, 'Foo/whatever', 'Dump and load an entry';
$kdbx->dump($filepath, key => 'a', atomic => 0);
$kdbx2 = File::KDBX->load($filepath, 'a');
$entry = $kdbx2->entries->map(sub { $_->title.'/'.$_->expand_password })->next;
is $entry, 'Foo/whatever', 'Dump and load an entry (non-atomic)';
};
done_testing;