Dogcows Code - chaz/p5-File-KDBX/blob - t/object.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::Util qw(:uuid);
  11 use File::KDBX;
  12 use Test::Deep;
  13 use Test::More;
  14
  15 subtest 'Cloning' => sub {
  16     my $kdbx = File::KDBX->new;
  17     my $entry = File::KDBX::Entry->new;
  18
  19     my $copy = $entry->clone;
  20     like exception { $copy->kdbx }, qr/disassociated/, 'Disassociated entry copy is also disassociated';
  21     cmp_deeply $copy, $entry, 'Disassociated entry and its clone are identical';
  22
  23     $entry->kdbx($kdbx);
  24     $copy = $entry->clone;
  25     is $entry->kdbx, $copy->kdbx, 'Associated entry copy is also associated';
  26     cmp_deeply $copy, $entry, 'Associated entry and its clone are identical';
  27
  28     my $txn = $entry->begin_work;
  29     $entry->title('foo');
  30     $entry->username('bar');
  31     $entry->password('baz');
  32     $txn->commit;
  33
  34     $copy = $entry->clone;
  35     is @{$copy->history}, 1, 'Copy has a historical entry' or dumper $copy->history;
  36     cmp_deeply $copy, $entry, 'Entry with history and its clone are identical';
  37
  38     $copy = $entry->clone(history => 0);
  39     is @{$copy->history}, 0, 'Copy excluding history has no history';
  40
  41     $copy = $entry->clone(new_uuid => 1);
  42     isnt $copy->uuid, $entry->uuid, 'Entry copy with new UUID has a different UUID';
  43
  44     $copy = $entry->clone(reference_username => 1);
  45     my $ref = sprintf('{REF:U@I:%s}', format_uuid($entry->uuid));
  46     is $copy->username, $ref, 'Copy has username reference';
  47     is $copy->expanded_username, $ref, 'Entry copy does not expand username because entry is not in database';
  48
  49     my $group = $kdbx->add_group(label => 'Passwords');
  50     $group->add_entry($entry);
  51     is $copy->expanded_username, $entry->username,
  52         'Entry in database and its copy with username ref have same expanded username';
  53
  54     $copy = $entry->clone;
  55     is @{$kdbx->all_entries}, 1, 'Still only one entry after cloning';
  56
  57     $copy = $entry->clone(parent => 1);
  58     is @{$kdbx->all_entries}, 2, 'New copy added to database if clone with parent option';
  59     my ($e1, $e2) = @{$kdbx->all_entries};
  60     isnt $e1, $e2, 'Entry and its copy in the database are different objects';
  61     is $e1->title, $e2->title, 'Entry copy has the same title as the original entry';
  62
  63     $copy = $entry->clone(parent => 1, relabel => 1);
  64     is @{$kdbx->all_entries}, 3, 'New copy added to database if clone with parent option';
  65     is $kdbx->all_entries->[2], $copy, 'New copy and new entry in the database match';
  66     is $kdbx->all_entries->[2]->title, "foo - Copy", 'New copy has a modified title';
  67
  68     $copy = $group->clone;
  69     cmp_deeply $copy, $group, 'Group and its clone are identical';
  70     is @{$copy->entries}, 3, 'Group copy has as many entries as the original';
  71     is @{$copy->entries->[0]->history}, 1, 'Entry in group copy has history';
  72
  73     $copy = $group->clone(history => 0);
  74     is @{$copy->entries}, 3, 'Group copy without history has as many entries as the original';
  75     is @{$copy->entries->[0]->history}, 0, 'Entry in group copy has no history';
  76
  77     $copy = $group->clone(entries => 0);
  78     is @{$copy->entries}, 0, 'Group copy without entries has no entries';
  79     is $copy->name, 'Passwords', 'Group copy label is the same as the original';
  80
  81     $copy = $group->clone(relabel => 1);
  82     is $copy->name, 'Passwords - Copy', 'Group copy relabeled from the original title';
  83     is @{$kdbx->all_entries}, 3, 'No new entries were added to the database';
  84
  85     $copy = $group->clone(relabel => 1, parent => 1);
  86     is @{$kdbx->all_entries}, 6, 'Copy a group within parent doubles the number of entries in the database';
  87     isnt $group->entries->[0]->uuid, $copy->entries->[0]->uuid,
  88         'First entry in group and its copy are different';
  89 };
  90
  91 subtest 'Transactions' => sub {
  92     my $kdbx = File::KDBX->new;
  93
  94     my $root    = $kdbx->root;
  95     my $entry   = $kdbx->add_entry(
  96         label => 'One',
  97         last_modification_time => Time::Piece->strptime('2022-04-20', '%Y-%m-%d'),
  98         username => 'Fred',
  99     );
 100
 101     my $txn = $root->begin_work;
 102     $root->label('Toor');
 103     $root->notes('');
 104     $txn->commit;
 105     is $root->label, 'Toor', 'Retain change to root label after commit';
 106
 107     $root->begin_work;
 108     $root->label('Root');
 109     $entry->label('Zap');
 110     $root->rollback;
 111     is $root->label, 'Toor', 'Undo change to root label after rollback';
 112     is $entry->label, 'Zap', 'Retain change to entry after rollback';
 113
 114     $txn = $root->begin_work(entries => 1);
 115     $root->label('Root');
 116     $entry->label('Zippy');
 117     undef $txn; # implicit rollback
 118     is $root->label, 'Toor', 'Undo change to root label after implicit rollback';
 119     is $entry->label, 'Zap', 'Undo change to entry after rollback with deep transaction';
 120
 121     $txn = $entry->begin_work;
 122     my $mtime = $entry->last_modification_time;
 123     my $username = $entry->string('UserName');
 124     $username->{meh} = 'hi';
 125     $entry->username('jinx');
 126     $txn->rollback;
 127     is $entry->string('UserName'), $username, 'Rollback keeps original references';
 128     is $entry->last_modification_time, $mtime, 'No last modification time change after rollback';
 129
 130     $txn = $entry->begin_work;
 131     $entry->username('jinx');
 132     $txn->commit;
 133     isnt $entry->last_modification_time, $mtime, 'Last modification time changes after commit';
 134
 135     {
 136         my $txn1 = $root->begin_work;
 137         $root->label('alien');
 138         {
 139             my $txn2 = $root->begin_work;
 140             $root->label('truth');
 141             $txn2->commit;
 142         }
 143     }
 144     is $root->label, 'Toor', 'Changes thrown away after rolling back outer transaction';
 145
 146     {
 147         my $txn1 = $root->begin_work;
 148         $root->label('alien');
 149         {
 150             my $txn2 = $root->begin_work;
 151             $root->label('truth');
 152         }
 153         $txn1->commit;
 154     }
 155     is $root->label, 'alien', 'Keep committed change after rolling back inner transaction';
 156
 157     {
 158         my $txn1 = $root->begin_work;
 159         $root->label('alien');
 160         {
 161             my $txn2 = $root->begin_work;
 162             $root->label('truth');
 163             $txn2->commit;
 164         }
 165         $txn1->commit;
 166     }
 167     is $root->label, 'truth', 'Keep committed change from inner transaction';
 168
 169     $txn = $root->begin_work;
 170     $root->label('Lalala');
 171     my $dump = $kdbx->dump_string('a');
 172     $txn->commit;
 173     is $root->label, 'Lalala', 'Keep committed label change after dump';
 174     my $load = File::KDBX->load_string($dump, 'a');
 175     is $load->root->label, 'truth', 'Object dumped before committing matches the pre-transaction state';
 176 };
 177
 178 done_testing;