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