Dogcows Code - chaz/p5-File-KDBX/blob - t/database.t

   1 #!/usr/bin/env perl
   2
   3 use utf8;
   4 use warnings;
   5 use strict;
   6
   7 use FindBin qw($Bin);
   8 use lib "$Bin/lib";
   9 use TestCommon;
  10
  11 use File::KDBX::Constants qw(:cipher :version);
  12 use File::KDBX;
  13 use File::Temp qw(tempfile);
  14 use Test::Deep;
  15 use Test::More 1.001004_001;
  16 use Time::Piece;
  17
  18 subtest 'Create a new database' => sub {
  19     my $kdbx = File::KDBX->new;
  20
  21     $kdbx->add_group(name => 'Meh');
  22     ok $kdbx->_has_implicit_root, 'Database starts off with implicit root';
  23
  24     my $entry = $kdbx->add_entry({
  25         username    => 'hello',
  26         password    => {value => 'This is a secret!!!!!', protect => 1},
  27     });
  28
  29     ok !$kdbx->_has_implicit_root, 'Adding an entry to the root group makes it explicit';
  30
  31     $entry->remove;
  32     ok $kdbx->_has_implicit_root, 'Removing group makes the root group implicit again';
  33
  34     cmp_ok $kdbx->version, '==', KDBX_VERSION_3_1, 'Default KDBX file version is 3.1';
  35     is $kdbx->cipher_id, CIPHER_UUID_AES256, 'Cipher of new database is AES256';
  36     cmp_ok length($kdbx->encryption_iv), '==', 16, 'Encryption IV of new databse is 16 bytes';
  37
  38     my $kdbx2 = File::KDBX->new(version => KDBX_VERSION_4_0);
  39     is $kdbx2->cipher_id, CIPHER_UUID_CHACHA20, 'Cipher of new v4 database is ChaCha20';
  40     cmp_ok length($kdbx2->encryption_iv), '==', 12, 'Encryption IV of new databse is 12 bytes';
  41 };
  42
  43 subtest 'Clone' => sub {
  44     my $kdbx = File::KDBX->new;
  45     $kdbx->add_group(name => 'Passwords')->add_entry(title => 'My Entry');
  46
  47     my $copy = $kdbx->clone;
  48     cmp_deeply $copy, $kdbx, 'Clone keeps the same structure and data' or dumper $copy;
  49
  50     isnt $kdbx, $copy, 'Clone is a different object';
  51     isnt $kdbx->root, $copy->root,
  52         'Clone root group is a different object';
  53     isnt $kdbx->root->groups->[0], $copy->root->groups->[0],
  54         'Clone group is a different object';
  55     isnt $kdbx->root->groups->[0]->entries->[0], $copy->root->groups->[0]->entries->[0],
  56         'Clone entry is a different object';
  57
  58     my @objects = $copy->objects->each;
  59     subtest 'Cloned objects refer to the cloned database' => sub {
  60         plan tests => scalar @_;
  61         for my $object (@_) {
  62             my $object_kdbx = eval { $object->kdbx };
  63             is $object_kdbx, $copy, 'Object: ' . $object->label;
  64         }
  65     }, @objects;
  66 };
  67
  68 subtest 'Iteration algorithm' => sub {
  69     # Database
  70     # - Root
  71     #   - Group1
  72     #     - EntryA
  73     #     - Group2
  74     #       - EntryB
  75     #   - Group3
  76     #     - EntryC
  77     my $kdbx = File::KDBX->new;
  78     my $group1 = $kdbx->add_group(label => 'Group1');
  79     my $group2 = $group1->add_group(label => 'Group2');
  80     my $group3 = $kdbx->add_group(label => 'Group3');
  81     my $entry1 = $group1->add_entry(label => 'EntryA');
  82     my $entry2 = $group2->add_entry(label => 'EntryB');
  83     my $entry3 = $group3->add_entry(label => 'EntryC');
  84
  85     cmp_deeply $kdbx->groups->map(sub { $_->label })->to_array,
  86         [qw(Root Group1 Group2 Group3)], 'Default group order';
  87     cmp_deeply $kdbx->entries->map(sub { $_->label })->to_array,
  88         [qw(EntryA EntryB EntryC)], 'Default entry order';
  89     cmp_deeply $kdbx->objects->map(sub { $_->label })->to_array,
  90         [qw(Root Group1 EntryA Group2 EntryB Group3 EntryC)], 'Default object order';
  91
  92     cmp_deeply $kdbx->groups(algorithm => 'ids')->map(sub { $_->label })->to_array,
  93         [qw(Root Group1 Group2 Group3)], 'IDS group order';
  94     cmp_deeply $kdbx->entries(algorithm => 'ids')->map(sub { $_->label })->to_array,
  95         [qw(EntryA EntryB EntryC)], 'IDS entry order';
  96     cmp_deeply $kdbx->objects(algorithm => 'ids')->map(sub { $_->label })->to_array,
  97         [qw(Root Group1 EntryA Group2 EntryB Group3 EntryC)], 'IDS object order';
  98
  99     cmp_deeply $kdbx->groups(algorithm => 'dfs')->map(sub { $_->label })->to_array,
 100         [qw(Group2 Group1 Group3 Root)], 'DFS group order';
 101     cmp_deeply $kdbx->entries(algorithm => 'dfs')->map(sub { $_->label })->to_array,
 102         [qw(EntryB EntryA EntryC)], 'DFS entry order';
 103     cmp_deeply $kdbx->objects(algorithm => 'dfs')->map(sub { $_->label })->to_array,
 104         [qw(Group2 EntryB Group1 EntryA Group3 EntryC Root)], 'DFS object order';
 105
 106     cmp_deeply $kdbx->groups(algorithm => 'bfs')->map(sub { $_->label })->to_array,
 107         [qw(Root Group1 Group3 Group2)], 'BFS group order';
 108     cmp_deeply $kdbx->entries(algorithm => 'bfs')->map(sub { $_->label })->to_array,
 109         [qw(EntryA EntryC EntryB)], 'BFS entry order';
 110     cmp_deeply $kdbx->objects(algorithm => 'bfs')->map(sub { $_->label })->to_array,
 111         [qw(Root Group1 EntryA Group3 EntryC Group2 EntryB)], 'BFS object order';
 112 };
 113
 114 subtest 'Recycle bin' => sub {
 115     my $kdbx = File::KDBX->new;
 116     my $entry = $kdbx->add_entry(label => 'Meh');
 117
 118     my $bin = $kdbx->groups->grep(name => 'Recycle Bin')->next;
 119     ok !$bin, 'New database has no recycle bin';
 120
 121     is $kdbx->recycle_bin_enabled, 1, 'Recycle bin is enabled';
 122     $kdbx->recycle_bin_enabled(0);
 123
 124     $entry->recycle_or_remove;
 125     cmp_ok $entry->is_recycled, '==', 0, 'Entry is not recycle if recycle bin is disabled';
 126
 127     $bin = $kdbx->groups->grep(name => 'Recycle Bin')->next;
 128     ok !$bin, 'Recycle bin not autovivified if recycle bin is disabled';
 129     is $kdbx->entries->size, 0, 'Database is empty after removing entry';
 130
 131     $kdbx->recycle_bin_enabled(1);
 132
 133     $entry = $kdbx->add_entry(label => 'Another one');
 134     $entry->recycle_or_remove;
 135     cmp_ok $entry->is_recycled, '==', 1, 'Entry is recycled';
 136
 137     $bin = $kdbx->groups->grep(name => 'Recycle Bin')->next;
 138     ok $bin, 'Recycle bin group autovivifies';
 139     cmp_ok $bin->icon_id, '==', 43, 'Recycle bin has the trash icon';
 140     cmp_ok $bin->enable_auto_type, '==', 0, 'Recycle bin has auto type disabled';
 141     cmp_ok $bin->enable_searching, '==', 0, 'Recycle bin has searching disabled';
 142
 143     is $kdbx->entries->size, 1, 'Database is not empty';
 144     is $kdbx->entries(searching => 1)->size, 0, 'Database has no entries if searching';
 145     cmp_ok $bin->all_entries->size, '==', 1, 'Recycle bin has an entry';
 146
 147     $entry->recycle_or_remove;
 148     is $kdbx->entries->size, 0, 'Remove entry if it is already in the recycle bin';
 149 };
 150
 151 subtest 'Maintenance' => sub {
 152     my $kdbx = File::KDBX->new;
 153     $kdbx->add_group;
 154     $kdbx->add_group->add_group;
 155     my $entry = $kdbx->add_group->add_entry;
 156
 157     cmp_ok $kdbx->remove_empty_groups, '==', 3, 'Remove two empty groups';
 158     cmp_ok $kdbx->groups->count, '==', 2, 'Two groups remain';
 159
 160     $entry->begin_work;
 161     $entry->commit;
 162     cmp_ok $kdbx->prune_history(max_age => 5), '==', 0, 'Do not remove new historical entries';
 163
 164     $entry->begin_work;
 165     $entry->commit;
 166     $entry->history->[0]->last_modification_time(scalar gmtime - 86400 * 10);
 167     cmp_ok $kdbx->prune_history(max_age => 5), '==', 1, 'Remove a historical entry';
 168     cmp_ok scalar @{$entry->history}, '==', 1, 'One historical entry remains';
 169
 170     cmp_ok $kdbx->remove_unused_icons, '==', 0, 'No icons to remove';
 171     $kdbx->add_custom_icon('fake image 1');
 172     $kdbx->add_custom_icon('fake image 2');
 173     $entry->custom_icon('fake image 3');
 174     cmp_ok $kdbx->remove_unused_icons, '==', 2, 'Remove unused icons';
 175     cmp_ok scalar @{$kdbx->custom_icons}, '==', 1, 'Only one icon remains';
 176
 177     my $icon_uuid = $kdbx->add_custom_icon('fake image');
 178     $entry->custom_icon('fake image');
 179     cmp_ok $kdbx->remove_duplicate_icons, '==', 1, 'Remove duplicate icons';
 180     is $entry->custom_icon_uuid, $icon_uuid, 'Uses of removed icon change';
 181 };
 182
 183 subtest 'Dumping to filesystem' => sub {
 184     my $kdbx = File::KDBX->new;
 185     $kdbx->add_entry(title => 'Foo', password => 'whatever');
 186
 187     my ($fh, $filepath) = tempfile('kdbx-XXXXXX', TMPDIR => 1, UNLINK => 1);
 188     close($fh);
 189
 190     $kdbx->dump($filepath, 'a');
 191
 192     my $kdbx2 = File::KDBX->load($filepath, 'a');
 193     my $entry = $kdbx2->entries->map(sub { $_->title.'/'.$_->expand_password })->next;
 194     is $entry, 'Foo/whatever', 'Dump and load an entry';
 195
 196     $kdbx->dump($filepath, key => 'a', atomic => 0);
 197
 198     $kdbx2 = File::KDBX->load($filepath, 'a');
 199     $entry = $kdbx2->entries->map(sub { $_->title.'/'.$_->expand_password })->next;
 200     is $entry, 'Foo/whatever', 'Dump and load an entry (non-atomic)';
 201 };
 202
 203 done_testing;