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

   1 #!/usr/bin/env perl
   2
   3 use warnings;
   4 use strict;
   5
   6 use lib 't/lib';
   7 use TestCommon;
   8
   9 use File::KDBX::Entry;
  10 use File::KDBX;
  11 use Test::Deep;
  12 use Test::More;
  13
  14 subtest 'Construction' => sub {
  15     my $entry = File::KDBX::Entry->new(my $data = {username => 'foo'});
  16     is $entry, $data, 'Provided data structure becomes the object';
  17     isa_ok $data, 'File::KDBX::Entry', 'Data structure is blessed';
  18     is $entry->{username}, 'foo', 'username is in the object still';
  19     is $entry->username, '', 'username is not the UserName string';
  20
  21     like exception { $entry->kdbx }, qr/disconnected/, 'Dies if disconnected';
  22     $entry->kdbx(my $kdbx = File::KDBX->new);
  23     is $entry->kdbx, $kdbx, 'Set a database after instantiation';
  24
  25     is_deeply $entry, {username => 'foo', strings => {UserName => {value => ''}}},
  26         'Entry data contains what was provided to the constructor plus vivified username';
  27
  28     $entry = File::KDBX::Entry->new(username => 'bar');
  29     is $entry->{username}, undef, 'username is not set on the data';
  30     is $entry->username, 'bar', 'username is set correctly as the UserName string';
  31
  32     cmp_deeply $entry, noclass({
  33         auto_type => {
  34             associations => [],
  35             data_transfer_obfuscation => 0,
  36             default_sequence => "{USERNAME}{TAB}{PASSWORD}{ENTER}",
  37             enabled => bool(1),
  38         },
  39         background_color => "",
  40         binaries => {},
  41         custom_data => {},
  42         custom_icon_uuid => undef,
  43         foreground_color => "",
  44         history => [],
  45         icon_id => "Password",
  46         override_url => "",
  47         previous_parent_group => undef,
  48         quality_check => bool(1),
  49         strings => {
  50             Notes => {
  51                 value => "",
  52             },
  53             Password => {
  54                 protect => bool(1),
  55                 value => "",
  56             },
  57             Title => {
  58                 value => "",
  59             },
  60             URL => {
  61                 value => "",
  62             },
  63             UserName => {
  64                 value => "bar",
  65             },
  66         },
  67         tags => "",
  68         times => {
  69             last_modification_time => isa('Time::Piece'),
  70             creation_time => isa('Time::Piece'),
  71             last_access_time => isa('Time::Piece'),
  72             expiry_time => isa('Time::Piece'),
  73             expires => bool(0),
  74             usage_count => 0,
  75             location_changed => isa('Time::Piece'),
  76         },
  77         uuid => re('^(?s:.){16}$'),
  78     }), 'Entry data contains UserName string and the rest default attributes';
  79 };
  80
  81 subtest 'Accessors' => sub {
  82     my $entry = File::KDBX::Entry->new;
  83
  84     $entry->creation_time('2022-02-02 12:34:56');
  85     cmp_ok $entry->creation_time->epoch, '==', 1643805296, 'Creation time coerced into a Time::Piece (epoch)';
  86     is $entry->creation_time->datetime, '2022-02-02T12:34:56', 'Creation time coerced into a Time::Piece';
  87
  88     $entry->username('foo');
  89     cmp_deeply $entry->strings->{UserName}, {
  90         value   => 'foo',
  91     }, 'Username setter works';
  92
  93     $entry->password('bar');
  94     cmp_deeply $entry->strings->{Password}, {
  95         value   => 'bar',
  96         protect => bool(1),
  97     }, 'Password setter works';
  98 };
  99
 100 subtest 'Custom icons' => sub {
 101     plan tests => 10;
 102     my $gif = pack('H*', '4749463839610100010000ff002c00000000010001000002003b');
 103
 104     my $entry = File::KDBX::Entry->new(my $kdbx = File::KDBX->new, icon_id => 42);
 105     is $entry->custom_icon_uuid, undef, 'UUID is undef if no custom icon is set';
 106     is $entry->custom_icon, undef, 'Icon is undef if no custom icon is set';
 107     is $entry->icon_id, 'KCMMemory', 'Default icon is set to something';
 108
 109     is $entry->custom_icon($gif), $gif, 'Setting a custom icon returns icon';
 110     is $entry->custom_icon, $gif, 'Henceforth the icon is set';
 111     is $entry->icon_id, 'Password', 'Default icon got changed to first icon';
 112     my $uuid = $entry->custom_icon_uuid;
 113     isnt $uuid, undef, 'UUID is now set';
 114
 115     my $found = $entry->kdbx->custom_icon_data($uuid);
 116     is $entry->custom_icon, $found, 'Custom icon on entry matches the database';
 117
 118     is $entry->custom_icon(undef), undef, 'Unsetting a custom icon returns undefined';
 119     $found = $entry->kdbx->custom_icon_data($uuid);
 120     is $found, $gif, 'Custom icon still exists in the database';
 121 };
 122
 123 subtest 'History' => sub {
 124     my $kdbx = File::KDBX->new;
 125     my $entry = $kdbx->add_entry(label => 'Foo');
 126     is scalar @{$entry->history}, 0, 'New entry starts with no history';
 127     is $entry->current_entry, $entry, 'Current new entry is itself';
 128     ok $entry->is_current, 'New entry is current';
 129
 130     my $txn = $entry->begin_work;
 131     $entry->notes('Hello!');
 132     $txn->commit;
 133     is scalar @{$entry->history}, 1, 'Committing creates a historical entry';
 134     ok $entry->is_current, 'New entry is still current';
 135     ok $entry->history->[0]->is_historical, 'Historical entry is not current';
 136     is $entry->notes, 'Hello!', 'New entry is modified after commit';
 137     is $entry->history->[0]->notes, '', 'Historical entry is saved without modification';
 138 };
 139
 140 subtest 'Update UUID' => sub {
 141     my $kdbx = File::KDBX->new;
 142
 143     my $entry1 = $kdbx->add_entry(label => 'Foo');
 144     my $entry2 = $kdbx->add_entry(label => 'Bar');
 145
 146     $entry2->url(sprintf('{REF:T@I:%s} {REF:T@I:%s}', $entry1->id, lc($entry1->id)));
 147     is $entry2->expand_url, 'Foo Foo', 'Field reference expands'
 148         or diag explain $entry2->url;
 149
 150     $entry1->uuid("\1" x 16);
 151
 152     is $entry2->url, '{REF:T@I:01010101010101010101010101010101} {REF:T@I:01010101010101010101010101010101}',
 153         'Replace field references when an entry UUID is changed';
 154     is $entry2->expand_url, 'Foo Foo', 'Field reference expands after UUID is changed'
 155         or diag explain $entry2->url;
 156 };
 157
 158 subtest 'Auto-type' => sub {
 159     my $kdbx = File::KDBX->new;
 160
 161     my $entry = $kdbx->add_entry(title => 'Meh');
 162     $entry->add_auto_type_association({
 163         window              => 'Boring Store',
 164         keystroke_sequence  => 'yeesh',
 165     });
 166     $entry->add_auto_type_association({
 167         window              => 'Friendly Bank',
 168         keystroke_sequence  => 'blah',
 169     });
 170
 171     my $window_title = 'Friendly';
 172     my $entries = $kdbx->entries(auto_type => 1)
 173     ->filter(sub {
 174         my ($ata) = grep { $_->{window} =~ /\Q$window_title\E/i } @{$_->auto_type_associations};
 175         return [$_, $ata->{keystroke_sequence} || $_->auto_type_default_sequence] if $ata;
 176     });
 177     cmp_ok $entries->count, '==', 1, 'Find auto-type window association';
 178
 179     (undef, my $keys) = @{$entries->next};
 180     is $keys, 'blah', 'Select the correct association';
 181 };
 182
 183 subtest 'Memory protection' => sub {
 184     my $kdbx = File::KDBX->new;
 185
 186     is exception { $kdbx->lock }, undef, 'Can lock empty database';
 187     $kdbx->unlock;  # should be no-op since nothing was locked
 188
 189     my $entry = $kdbx->root->add_entry(
 190         title    => 'My Bank',
 191         username => 'mreynolds',
 192         password => 's3cr3t',
 193     );
 194     $entry->string(Custom => 'foo', protect => 1);
 195     $entry->binary(Binary => 'bar', protect => 1);
 196     $entry->binary(UnprotectedBinary => 'baz');
 197
 198     is exception { $kdbx->lock }, undef, 'Can lock new database';
 199     is $entry->username, 'mreynolds', 'UserName does not get locked';
 200     is $entry->password, undef, 'Password is lockable';
 201     is $entry->string_value('Custom'), undef, 'Custom is lockable';
 202     is $entry->binary_value('Binary'), undef, 'Binary is lockable';
 203     is $entry->binary_value('UnprotectedBinary'), 'baz', 'Unprotected binary does not get locked';
 204
 205     $kdbx->unlock;
 206     is $entry->password, 's3cr3t', 'Password is unlockable';
 207     is $entry->string_value('Custom'), 'foo', 'Custom is unlockable';
 208     is $entry->binary_value('Binary'), 'bar', 'Binary is unlockable';
 209 };
 210
 211 done_testing;