]>
Dogcows Code - chaz/p5-File-KDBX/blob - object.t
d3e766d26d5d402cc665cdba9540c88a88da877a
10 use File
::KDBX
::Util
qw(:uuid);
15 subtest
'Cloning' => sub {
16 my $kdbx = File
::KDBX-
>new;
17 my $entry = File
::KDBX
::Entry-
>new;
19 my $copy = $entry->clone;
20 like exception
{ $copy->kdbx }, qr/disconnected/, 'Disconnected entry copy is also disconnectedisconnected';
21 cmp_deeply
$copy, $entry, 'Disconnected entry and its clone are identical';
24 $copy = $entry->clone;
25 is $entry->kdbx, $copy->kdbx, 'Connected entry copy is also connected';
26 cmp_deeply
$copy, $entry, 'Connected entry and its clone are identical';
28 my $txn = $entry->begin_work;
30 $entry->username('bar');
31 $entry->password('baz');
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';
38 $copy = $entry->clone(history
=> 0);
39 is @{$copy->history}, 0, 'Copy excluding history has no history';
41 $copy = $entry->clone(new_uuid
=> 1);
42 isnt
$copy->uuid, $entry->uuid, 'Entry copy with new UUID has a different UUID';
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->expand_username, $ref, 'Entry copy does not expand username because entry is not in database';
49 my $group = $kdbx->add_group(label
=> 'Passwords');
50 $group->add_entry($entry);
51 is $copy->expand_username, $entry->username,
52 'Entry in database and its copy with username ref have same expanded username';
54 $copy = $entry->clone;
55 is $kdbx->entries->size, 1, 'Still only one entry after cloning';
57 $copy = $entry->clone(parent
=> 1);
58 is $kdbx->entries->size, 2, 'New copy added to database if clone with parent option';
59 my ($e1, $e2) = $kdbx->entries->each;
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';
63 $copy = $entry->clone(parent
=> 1, relabel
=> 1);
64 is $kdbx->entries->size, 3, 'New copy added to database if clone with parent option';
65 my $e3 = $kdbx->entries->skip(2)->next;
66 is $e3, $copy, 'New copy and new entry in the database match';
67 is $e3->title, 'foo - Copy', 'New copy has a modified title';
69 $copy = $group->clone;
70 cmp_deeply
$copy, $group, 'Group and its clone are identical';
71 is @{$copy->entries}, 3, 'Group copy has as many entries as the original';
72 is @{$copy->entries->[0]->history}, 1, 'Entry in group copy has history';
74 $copy = $group->clone(history
=> 0);
75 is @{$copy->entries}, 3, 'Group copy without history has as many entries as the original';
76 is @{$copy->entries->[0]->history}, 0, 'Entry in group copy has no history';
78 $copy = $group->clone(entries
=> 0);
79 is @{$copy->entries}, 0, 'Group copy without entries has no entries';
80 is $copy->name, 'Passwords', 'Group copy label is the same as the original';
82 $copy = $group->clone(relabel
=> 1);
83 is $copy->name, 'Passwords - Copy', 'Group copy relabeled from the original title';
84 is $kdbx->entries->size, 3, 'No new entries were added to the database';
86 $copy = $group->clone(relabel
=> 1, parent
=> 1);
87 is $kdbx->entries->size, 6, 'Copy a group within parent doubles the number of entries in the database';
88 isnt
$group->entries->[0]->uuid, $copy->entries->[0]->uuid,
89 'First entry in group and its copy are different';
92 subtest
'Transactions' => sub {
93 my $kdbx = File
::KDBX-
>new;
95 my $root = $kdbx->root;
96 my $entry = $kdbx->add_entry(
98 last_modification_time
=> Time
::Piece-
>strptime('2022-04-20', '%Y-%m-%d'),
102 my $txn = $root->begin_work;
103 $root->label('Toor');
106 is $root->label, 'Toor', 'Retain change to root label after commit';
109 $root->label('Root');
110 $entry->label('Zap');
112 is $root->label, 'Toor', 'Undo change to root label after rollback';
113 is $entry->label, 'Zap', 'Retain change to entry after rollback';
115 $txn = $root->begin_work(entries
=> 1);
116 $root->label('Root');
117 $entry->label('Zippy');
118 undef $txn; # implicit rollback
119 is $root->label, 'Toor', 'Undo change to root label after implicit rollback';
120 is $entry->label, 'Zap', 'Undo change to entry after rollback with deep transaction';
122 $txn = $entry->begin_work;
123 my $mtime = $entry->last_modification_time;
124 my $username = $entry->string('UserName');
125 $username->{meh
} = 'hi';
126 $entry->username('jinx');
128 is $entry->string('UserName'), $username, 'Rollback keeps original references';
129 is $entry->last_modification_time, $mtime, 'No last modification time change after rollback';
131 $txn = $entry->begin_work;
132 $entry->username('jinx');
134 isnt
$entry->last_modification_time, $mtime, 'Last modification time changes after commit';
137 my $txn1 = $root->begin_work;
138 $root->label('alien');
140 my $txn2 = $root->begin_work;
141 $root->label('truth');
145 is $root->label, 'Toor', 'Changes thrown away after rolling back outer transaction';
148 my $txn1 = $root->begin_work;
149 $root->label('alien');
151 my $txn2 = $root->begin_work;
152 $root->label('truth');
156 is $root->label, 'alien', 'Keep committed change after rolling back inner transaction';
159 my $txn1 = $root->begin_work;
160 $root->label('alien');
162 my $txn2 = $root->begin_work;
163 $root->label('truth');
168 is $root->label, 'truth', 'Keep committed change from inner transaction';
170 $txn = $root->begin_work;
171 $root->label('Lalala');
172 my $dump = $kdbx->dump_string('a');
174 is $root->label, 'Lalala', 'Keep committed label change after dump';
175 my $load = File
::KDBX-
>load_string($dump, 'a');
176 is $load->root->label, 'truth', 'Object dumped before committing matches the pre-transaction state';
This page took 0.055073 seconds and 3 git commands to generate.