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