Dogcows Code - chaz/p5-File-KDBX/blob - t/kdb.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 Encode qw(decode);
  10 use File::KDBX;
  11 use Test::Deep;
  12 use Test::More;
  13
  14 eval { require File::KeePass; require File::KeePass::KDBX }
  15     or plan skip_all => 'File::KeePass and File::KeePass::KDBX required to test KDB files';
  16
  17 my $kdbx = File::KDBX->load(testfile('basic.kdb'), 'masterpw');
  18
  19 sub test_basic {
  20     my $kdbx = shift;
  21
  22     cmp_deeply $kdbx->headers, superhashof({
  23         cipher_id => "1\301\362\346\277qCP\276X\5!j\374Z\377",
  24         encryption_iv => "\250\354q\362\13\247\353\247\222!\232\364Lj\315w",
  25         master_seed => "\212z\356\256\340+\n\243ms2\364'!7\216",
  26         transform_rounds => 713,
  27         transform_seed => "\227\264\n^\230\2\301:!f\364\336\251\277\241[\3`\314RG\343\16U\333\305eT3:\240\257",
  28     }), 'Get expected headers from KDB file' or diag explain $kdbx->headers;
  29
  30     is keys %{$kdbx->deleted_objects}, 0, 'There are no deleted objects' or dumper $kdbx->deleted_objects;
  31     is scalar @{$kdbx->root->groups}, 2, 'Root group has two children';
  32
  33     my $group1 = $kdbx->root->groups->[0];
  34     isnt $group1->uuid, undef, 'Group 1 has a UUID';
  35     is $group1->name, 'Internet', 'Group 1 has a name';
  36     is scalar @{$group1->groups}, 2, 'Group 1 has subgroups';
  37     is scalar @{$group1->entries}, 2, 'Group 1 has entries';
  38     is $group1->icon_id, 1, 'Group 1 has an icon';
  39
  40     my ($entry11, $entry12, @other) = @{$group1->entries};
  41
  42     isnt $entry11->uuid, undef, 'Entry has a UUID';
  43     is $entry11->title, 'Test entry', 'Entry has a title';
  44     is $entry11->icon_id, 1, 'Entry has an icon';
  45     is $entry11->username, 'I', 'Entry has a username';
  46     is $entry11->url, 'http://example.com/', 'Entry has a URL';
  47     is $entry11->password, 'secretpassword', 'Entry has a password';
  48     is $entry11->notes, "Lorem ipsum\ndolor sit amet", 'Entry has notes';
  49     ok $entry11->expires, 'Entry is expired';
  50     is $entry11->expiry_time, 'Wed May  9 10:32:00 2012', 'Entry has an expiration time';
  51     is scalar keys %{$entry11->binaries}, 1, 'Entry has a binary';
  52     is $entry11->binary_value('attachment.txt'), "hello world\n", 'Entry has a binary';
  53
  54     is $entry12->title, '', 'Entry 2 has an empty title';
  55     is $entry12->icon_id, 0, 'Entry 2 has an icon';
  56     is $entry12->username, '', 'Entry 2 has an empty username';
  57     is $entry12->url, '', 'Entry 2 has an empty URL';
  58     is $entry12->password, '', 'Entry 2 has an empty password';
  59     is $entry12->notes, '', 'Entry 2 has empty notes';
  60     ok !$entry12->expires, 'Entry 2 is not expired';
  61     is scalar keys %{$entry12->binaries}, 0, 'Entry has no binaries';
  62
  63     my $group11 = $group1->groups->[0];
  64     is $group11->label, 'Subgroup 1', 'Group has subgroup';
  65     is scalar @{$group11->groups}, 1, 'Subgroup has subgroup';
  66
  67     my $group111 = $group11->groups->[0];
  68     is $group111->label, 'Unexpanded', 'Has unexpanded group';
  69     is scalar @{$group111->groups}, 1, 'Subgroup has subgroup';
  70
  71     my $group1111 = $group111->groups->[0];
  72     is $group1111->label, 'abc', 'Group has subsubsubroup';
  73     is scalar @{$group1111->groups}, 0, 'No more subgroups';
  74
  75     my $group12 = $group1->groups->[1];
  76     is $group12->label, 'Subgroup 2', 'Group has another subgroup';
  77     is scalar @{$group12->groups}, 0, 'No more subgroups';
  78
  79     my $group2 = $kdbx->root->groups->[1];
  80     is $group2->label, 'eMail', 'Root has another subgroup';
  81     is scalar @{$group2->entries}, 1, 'eMail group has an entry';
  82     is $group2->icon_id, 19, 'Group has a standard icon';
  83 }
  84 for my $test (
  85     ['Basic' => $kdbx],
  86     ['Basic after dump & load roundtrip'
  87         => File::KDBX->load_string($kdbx->dump_string('a', randomize_seeds => 0), 'a')],
  88 ) {
  89     my ($name, $kdbx) = @$test;
  90     subtest $name, \&test_basic, $kdbx;
  91 }
  92
  93 sub test_custom_icons {
  94     my $kdbx = shift;
  95     $kdbx = $kdbx->() if ref $kdbx eq 'CODE';
  96
  97     my ($icon, @other) = @{$kdbx->custom_icons};
  98     ok $icon, 'Database has a custom icon';
  99     is scalar @other, 0, 'Database has no other icons';
 100
 101     like $icon->{data}, qr/^\x89PNG\r\n/, 'Custom icon is a PNG';
 102 }
 103 for my $test (
 104     ['Custom icons' => $kdbx],
 105     ['Custom icons after dump & load roundtrip' => sub {
 106         File::KDBX->load_string($kdbx->dump_string('a', allow_upgrade => 0, randomize_seeds => 0), 'a');
 107     }],
 108 ) {
 109     my ($name, $kdbx) = @$test;
 110     subtest $name, \&test_custom_icons, $kdbx;
 111 }
 112
 113 subtest 'Group expansion' => sub {
 114     is $kdbx->root->groups->[0]->is_expanded, 1, 'Group is expanded';
 115     is $kdbx->root->groups->[0]->groups->[0]->is_expanded, 1, 'Subgroup is expanded';
 116     is $kdbx->root->groups->[0]->groups->[0]->groups->[0]->is_expanded, 0, 'Subsubgroup is not expanded';
 117 };
 118
 119 subtest 'Autotype' => sub {
 120     my $group = $kdbx->root->groups->[0]->groups->[0];
 121     is scalar @{$group->entries}, 2, 'Group has two entries';
 122
 123     my ($entry1, $entry2) = @{$group->entries};
 124
 125     is $entry1->notes, "\nlast line", 'First entry has a note';
 126     TODO: {
 127         local $TODO = 'File::KeePass fails to parse out the default key sequence';
 128         is $entry1->auto_type->{default_sequence}, '{USERNAME}{ENTER}', 'First entry has a default sequence';
 129     };
 130     cmp_deeply $entry1->auto_type->{associations}, set(
 131         {
 132             keystroke_sequence => "{USERNAME}{ENTER}",
 133             window => "a window",
 134         },
 135         {
 136             keystroke_sequence => "{USERNAME}{ENTER}",
 137             window => "a second window",
 138         },
 139         {
 140             keystroke_sequence => "{PASSWORD}{ENTER}",
 141             window => "Window Nr 1a",
 142         },
 143         {
 144             keystroke_sequence => "{PASSWORD}{ENTER}",
 145             window => "Window Nr 1b",
 146         },
 147         {
 148             keystroke_sequence => "{USERNAME}{ENTER}",
 149             window => "Window 2",
 150         },
 151     ), 'First entry has auto-type window associations';
 152
 153     is $entry2->notes, "start line\nend line", 'Second entry has notes';
 154     TODO: {
 155         local $TODO = 'File::KeePass fails to parse out the default key sequence';
 156         is $entry2->auto_type->{default_sequence}, '', 'Second entry has no default sequence';
 157         cmp_deeply $entry2->auto_type->{associations}, set(
 158             {
 159                 keystroke_sequence => "",
 160                 window => "Main Window",
 161             },
 162             {
 163                 keystroke_sequence => "",
 164                 window => "Test Window",
 165             },
 166         ), 'Second entry has auto-type window associations' or diag explain $entry2->auto_type->{associations};
 167     };
 168 };
 169
 170 subtest 'KDB file keys' => sub {
 171     while (@_) {
 172         my ($name, $key) = splice @_, 0, 2;
 173         my $kdb_filepath = testfile("$name.kdb");
 174         my $kdbx = File::KDBX->load($kdb_filepath, $key);
 175
 176         is $kdbx->root->name, $name, "Loaded KDB database with root group is named $name";
 177     }
 178 }, (
 179     FileKeyBinary   => {file => testfile('FileKeyBinary.key')},
 180     FileKeyHex      => {file => testfile('FileKeyHex.key')},
 181     FileKeyHashed   => {file => testfile('FileKeyHashed.key')},
 182     CompositeKey    => ['mypassword', {file => testfile('FileKeyHex.key')}],
 183 );
 184
 185 subtest 'Twofish' => sub {
 186     plan skip_all => 'File::KeePass does not implement the Twofish cipher';
 187     my $name = 'Twofish';
 188     my $kdbx = File::KDBX->load(testfile("$name.kdb"), 'masterpw');
 189     is $kdbx->root->name, $name, "Loaded KDB database with root group is named $name";
 190 };
 191
 192 subtest 'CP-1252 password' => sub {
 193     my $name = 'CP-1252';
 194     my $kdbx = File::KDBX->load(testfile("$name.kdb"),
 195         decode('UTF-8', "\xe2\x80\x9e\x70\x61\x73\x73\x77\x6f\x72\x64\xe2\x80\x9d"));
 196     is $kdbx->root->name, $name, "Loaded KDB database with root group is named $name";
 197 };
 198
 199 done_testing;