File Coverage

blib/lib/File/KDBX/Object.pm
Criterion Covered Total %
statement 284 300 94.6
branch 98 128 76.5
condition 77 106 72.6
subroutine 48 54 88.8
pod 21 24 87.5
total 528 612 86.2


line stmt bran cond sub pod time code
1             package File::KDBX::Object;
2             # ABSTRACT: A KDBX database object
3              
4 11     11   6890 use warnings;
  11         24  
  11         354  
5 11     11   50 use strict;
  11         21  
  11         215  
6              
7 11     11   47 use Devel::GlobalDestruction;
  11         18  
  11         65  
8 11     11   651 use File::KDBX::Constants qw(:bool);
  11         19  
  11         1375  
9 11     11   70 use File::KDBX::Error;
  11         17  
  11         436  
10 11     11   56 use File::KDBX::Util qw(:uuid);
  11         18  
  11         940  
11 11     11   107 use Hash::Util::FieldHash qw(fieldhashes);
  11         16  
  11         518  
12 11     11   59 use List::Util qw(any first);
  11         17  
  11         597  
13 11     11   58 use Ref::Util qw(is_arrayref is_plain_arrayref is_plain_hashref is_ref);
  11         27  
  11         526  
14 11     11   65 use Scalar::Util qw(blessed weaken);
  11         25  
  11         450  
15 11     11   58 use namespace::clean;
  11         17  
  11         61  
16              
17             our $VERSION = '0.904'; # VERSION
18              
19             fieldhashes \my (%KDBX, %PARENT, %TXNS, %REFS, %SIGNALS);
20              
21              
22             sub new {
23 237     237 1 97656 my $class = shift;
24              
25             # copy constructor
26 237 50 100     736 return $_[0]->clone if @_ == 1 && blessed $_[0] && $_[0]->isa($class);
      66        
27              
28 237         319 my $data;
29 237 100       669 $data = shift if is_plain_hashref($_[0]);
30              
31 237         306 my $kdbx;
32 237 100       526 $kdbx = shift if @_ % 2 == 1;
33              
34 237         606 my %args = @_;
35 237 100 33     784 $args{kdbx} //= $kdbx if defined $kdbx;
36              
37 237   100     760 my $self = bless $data // {}, $class;
38 237         1001 $self->init(%args);
39 237 100       823 $self->_set_nonlazy_attributes if !$data;
40 237         5473 return $self;
41             }
42              
43 0     0   0 sub _set_nonlazy_attributes { die 'Not implemented' }
44              
45              
46             sub init {
47 133     133 1 180 my $self = shift;
48 133         327 my %args = @_;
49              
50 133         454 while (my ($key, $val) = each %args) {
51 331 50       1355 if (my $method = $self->can($key)) {
52 331         1164 $self->$method($val);
53             }
54             }
55              
56 133         339 return $self;
57             }
58              
59              
60             sub wrap {
61 798     798 1 1169 my $class = shift;
62 798         1048 my $object = shift;
63 798 100 66     5204 return $object if blessed $object && $object->isa($class);
64 114 100       333 return $class->new(@_, @$object) if is_arrayref($object);
65 72         277 return $class->new($object, @_);
66             }
67              
68              
69 0     0 1 0 sub label { die 'Not implemented' }
70              
71              
72             my %CLONE = (entries => 1, groups => 1, history => 1);
73             sub clone {
74 31     31 1 62 my $self = shift;
75 31         80 my %args = @_;
76              
77 31   100     159 local $CLONE{new_uuid} = $args{new_uuid} // $args{parent} // 0;
      100        
78 31   100     92 local $CLONE{entries} = $args{entries} // 1;
79 31   100     76 local $CLONE{groups} = $args{groups} // 1;
80 31   100     69 local $CLONE{history} = $args{history} // 1;
81 31   50     81 local $CLONE{reference_password} = $args{reference_password} // 0;
82 31   100     79 local $CLONE{reference_username} = $args{reference_username} // 0;
83              
84 31         126 require Storable;
85 31         467 my $copy = Storable::dclone($self);
86              
87 31 100 66     101 if ($args{relabel} and my $label = $self->label) {
88 3         12 $copy->label("$label - Copy");
89             }
90 31 100 66     79 if ($args{parent} and my $parent = $self->group) {
91 3         12 $parent->add_object($copy);
92             }
93              
94 31         342 return $copy;
95             }
96              
97             sub STORABLE_freeze {
98 64     64 0 126 my $self = shift;
99 64         79 my $cloning = shift;
100              
101 64         567 my $copy = {%$self};
102 64 100       190 delete $copy->{entries} if !$CLONE{entries};
103 64 100       119 delete $copy->{groups} if !$CLONE{groups};
104 64 100       105 delete $copy->{history} if !$CLONE{history};
105              
106 64 50       4006 return ($cloning ? Hash::Util::FieldHash::id($self) : ''), $copy;
107             }
108              
109             sub STORABLE_thaw {
110 64     64 0 136 my $self = shift;
111 64         80 my $cloning = shift;
112 64         88 my $addr = shift;
113 64         74 my $copy = shift;
114              
115 64         478 @$self{keys %$copy} = values %$copy;
116              
117 64 50       179 if ($cloning) {
118 64         183 my $kdbx = $KDBX{$addr};
119 64 100       147 $self->kdbx($kdbx) if $kdbx;
120             }
121              
122 64 50       124 if (defined $self->{uuid}) {
123 64 100 66     241 if (($CLONE{reference_password} || $CLONE{reference_username}) && $self->can('strings')) {
      66        
124 2         7 my $uuid = format_uuid($self->{uuid});
125 2         5 my $clone_obj = do {
126 2         3 local $CLONE{new_uuid} = 0;
127 2         4 local $CLONE{entries} = 1;
128 2         5 local $CLONE{groups} = 1;
129 2         3 local $CLONE{history} = 1;
130 2         3 local $CLONE{reference_password} = 0;
131 2         4 local $CLONE{reference_username} = 0;
132             # Clone only the entry's data and manually bless to avoid infinite recursion.
133 2         95 bless Storable::dclone({%$copy}), 'File::KDBX::Entry';
134             };
135 2         9 my $txn = $self->begin_work(snapshot => $clone_obj);
136 2 50       6 if ($CLONE{reference_password}) {
137 0         0 $self->password("{REF:P\@I:$uuid}");
138             }
139 2 50       4 if ($CLONE{reference_username}) {
140 2         12 $self->username("{REF:U\@I:$uuid}");
141             }
142 2         6 $txn->commit;
143             }
144 64 100       127 $self->uuid(generate_uuid) if $CLONE{new_uuid};
145             }
146              
147             # Dualvars aren't cloned as dualvars, so dualify the icon.
148 64 50       224 $self->icon_id($self->{icon_id}) if defined $self->{icon_id};
149             }
150              
151              
152             sub kdbx {
153 978     978 1 4937 my $self = shift;
154 978 50       1753 $self = $self->new if !ref $self;
155 978 100       1749 if (@_) {
156 310 50       591 if (my $kdbx = shift) {
157 310         1668 $KDBX{$self} = $kdbx;
158 310         881 weaken $KDBX{$self};
159             }
160             else {
161 0         0 delete $KDBX{$self};
162             }
163             }
164 978 100       3538 $KDBX{$self} or throw 'Object is disconnected', object => $self;
165             }
166              
167              
168             sub is_connected {
169 84     84 1 125 my $self = shift;
170 84         119 return !!eval { $self->kdbx };
  84         166  
171             }
172              
173              
174 5     5 1 39 sub id { format_uuid(shift->uuid, @_) }
175              
176              
177             sub group {
178 154     154 1 204 my $self = shift;
179              
180 154 100       309 if (my $new_group = shift) {
181 1         5 my $old_group = $self->group;
182 1 50       6 return $new_group if Hash::Util::FieldHash::id($old_group) == Hash::Util::FieldHash::id($new_group);
183             # move to a new parent
184 1 50       6 $self->remove(signal => 0) if $old_group;
185 1         5 $self->location_changed('now');
186 1         16 $new_group->add_object($self);
187             }
188              
189 154         290 my $id = Hash::Util::FieldHash::id($self);
190 154 100       337 if (my $group = $PARENT{$self}) {
191 31         70 my $method = $self->_parent_container;
192 31 50   31   86 return $group if first { $id == Hash::Util::FieldHash::id($_) } @{$group->$method};
  31         154  
  31         82  
193 0         0 delete $PARENT{$self};
194             }
195             # always get lineage from root to leaf because the other way requires parent, so it would be recursive
196 123 100       210 my $lineage = $self->kdbx->_trace_lineage($self) or return;
197 1 50       4 my $group = pop @$lineage or return;
198 1         5 $PARENT{$self} = $group; weaken $PARENT{$self};
  1         4  
199 1         3 return $group;
200             }
201              
202             sub _set_group {
203 110     110   143 my $self = shift;
204 110 100       188 if (my $parent = shift) {
205 48         448 $PARENT{$self} = $parent;
206 48         139 weaken $PARENT{$self};
207             }
208             else {
209 62         181 delete $PARENT{$self};
210             }
211 110         221 return $self;
212             }
213              
214             ### Name of the parent attribute expected to contain the object
215 0     0   0 sub _parent_container { die 'Not implemented' }
216              
217              
218             sub lineage {
219 5     5 1 8 my $self = shift;
220 5         8 my $base = shift;
221              
222 5 50       12 my $base_addr = $base ? Hash::Util::FieldHash::id($base) : 0;
223              
224             # try leaf to root
225 5         7 my @path;
226 5         7 my $object = $self;
227 5         12 while ($object = $object->group) {
228 8         16 unshift @path, $object;
229 8 50       21 last if $base_addr == Hash::Util::FieldHash::id($object);
230             }
231 5 50 33     32 return \@path if @path && ($base_addr == Hash::Util::FieldHash::id($path[0]) || $path[0]->is_root);
      33        
232              
233             # try root to leaf
234 0         0 return $self->kdbx->_trace_lineage($self, $base);
235             }
236              
237              
238             sub remove {
239 55     55 1 78 my $self = shift;
240 55         174 my $parent = $self->group;
241 55 100       139 $parent->remove_object($self, @_) if $parent;
242 55         197 $self->_set_group(undef);
243 55         115 return $self;
244             }
245              
246              
247             sub recycle {
248 1     1 1 3 my $self = shift;
249 1         3 return $self->group($self->kdbx->recycle_bin);
250             }
251              
252              
253             sub recycle_or_remove {
254 3     3 1 23 my $self = shift;
255 3         4 my $kdbx = eval { $self->kdbx };
  3         7  
256 3 100 66     14 if ($kdbx && $kdbx->recycle_bin_enabled && !$self->is_recycled) {
      100        
257 1         6 $self->recycle;
258             }
259             else {
260 2         23 $self->remove;
261             }
262             }
263              
264              
265             sub is_recycled {
266 4     4 1 41 my $self = shift;
267 4 50       6 eval { $self->kdbx } or return FALSE;
  4         6  
268 4   100 5   9 return !!($self->group && any { $_->is_recycle_bin } @{$self->lineage});
  5         14  
269             }
270              
271             ##############################################################################
272              
273              
274             sub tag_list {
275 0     0 1 0 my $self = shift;
276 0   0     0 return grep { $_ ne '' } split(/[,\.:;]|\s+/, trim($self->tags) // '');
  0         0  
277             }
278              
279              
280             sub custom_icon {
281 7     7 1 16 my $self = shift;
282 7         26 my $kdbx = $self->kdbx;
283 7 100       16 if (@_) {
284 4         9 my $img = shift;
285 4 100       15 my $uuid = defined $img ? $kdbx->add_custom_icon($img, @_) : undef;
286 4 100       16 $self->icon_id(0) if $uuid;
287 4         11 $self->custom_icon_uuid($uuid);
288 4         11 return $img;
289             }
290 3         10 return $kdbx->custom_icon_data($self->custom_icon_uuid);
291             }
292              
293              
294             sub custom_data {
295 517     517 1 751 my $self = shift;
296 517 50 66     1089 $self->{custom_data} = shift if @_ == 1 && is_plain_hashref($_[0]);
297 517 100 100     2505 return $self->{custom_data} //= {} if !@_;
298              
299 19 100       90 my %args = @_ == 2 ? (key => shift, value => shift)
    100          
300             : @_ % 2 == 1 ? (key => shift, @_) : @_;
301              
302 19 50 66     53 if (!$args{key} && !$args{value}) {
303 2         9 my %standard = (key => 1, value => 1, last_modification_time => 1);
304 2         6 my @other_keys = grep { !$standard{$_} } keys %args;
  4         13  
305 2 50       7 if (@other_keys == 1) {
306 2         4 my $key = $args{key} = $other_keys[0];
307 2         6 $args{value} = delete $args{$key};
308             }
309             }
310              
311 19 50       43 my $key = $args{key} or throw 'Must provide a custom_data key to access';
312              
313 19 50       53 return $self->{custom_data}{$key} = $args{value} if is_plain_hashref($args{value});
314              
315 19         58 while (my ($field, $value) = each %args) {
316 34         117 $self->{custom_data}{$key}{$field} = $value;
317             }
318 19         55 return $self->{custom_data}{$key};
319             }
320              
321              
322             sub custom_data_value {
323 6     6 1 58 my $self = shift;
324 6   50     16 my $data = $self->custom_data(@_) // return undef;
325 6         26 return $data->{value};
326             }
327              
328             ##############################################################################
329              
330              
331             sub begin_work {
332 35     35 1 1421 my $self = shift;
333              
334 35 100       73 if (defined wantarray) {
335 16         969 require File::KDBX::Transaction;
336 16         75 return File::KDBX::Transaction->new($self, @_);
337             }
338              
339 19         40 my %args = @_;
340 19   66     50 my $orig = $args{snapshot} // do {
341             my $c = $self->clone(
342             entries => $args{entries} // 0,
343             groups => $args{groups} // 0,
344 17   100     160 history => $args{history} // 0,
      50        
      50        
345             );
346 17 100       50 $c->{entries} = $self->{entries} if !$args{entries};
347 17 50       57 $c->{groups} = $self->{groups} if !$args{groups};
348 17 50       47 $c->{history} = $self->{history} if !$args{history};
349 17         39 $c;
350             };
351              
352 19         45 my $id = Hash::Util::FieldHash::id($orig);
353 19         49 _save_references($id, $self, $orig);
354              
355 19         60 $self->_signal_begin_work;
356              
357 19         28 push @{$self->_txns}, $orig;
  19         38  
358             }
359              
360              
361             sub commit {
362 14     14 1 23 my $self = shift;
363 14 50       21 my $orig = pop @{$self->_txns} or return $self;
  14         23  
364 14         52 $self->_commit($orig);
365 14         191 my $signals = $self->_signal_commit;
366 14 100       35 $self->_signal_send($signals) if !$self->_in_txn;
367 14         80 return $self;
368             }
369              
370              
371             sub rollback {
372 5     5 1 7 my $self = shift;
373              
374 5 50       7 my $orig = pop @{$self->_txns} or return $self;
  5         7  
375              
376 5         13 my $id = Hash::Util::FieldHash::id($orig);
377 5         13 _restore_references($id, $orig);
378              
379 5         19 $self->_signal_rollback;
380              
381 5         45 return $self;
382             }
383              
384             # Get whether or not there is at least one pending transaction.
385 82     82   102 sub _in_txn { scalar @{$_[0]->_txns} }
  82         174  
386              
387             # Get an array ref of pending transactions.
388 152   100 152   892 sub _txns { $TXNS{$_[0]} //= [] }
389              
390             # The _commit hook notifies subclasses that a commit has occurred.
391 0     0   0 sub _commit { die 'Not implemented' }
392              
393             # Get a reference to an object that represents an object's committed state. If there is no pending
394             # transaction, this is just $self. If there is a transaction, this is the snapshot take before the transaction
395             # began. This method is private because it provides direct access to the actual snapshot. It is important that
396             # the snapshot not be changed or a rollback would roll back to an altered state.
397             # This is used by File::KDBX::Dumper::XML so as to not dump uncommitted changes.
398             sub _committed {
399 32     32   56 my $self = shift;
400 32         46 my ($orig) = @{$self->_txns};
  32         97  
401 32   66     223 return $orig // $self;
402             }
403              
404             # In addition to cloning an object when beginning work, we also keep track its hashrefs and arrayrefs
405             # internally so that we can restore to the very same structures in the case of a rollback.
406             sub _save_references {
407 1406     1406   1626 my $id = shift;
408 1406         1526 my $self = shift;
409 1406         1443 my $orig = shift;
410              
411 1406 100 100     4376 if (is_plain_arrayref($orig)) {
    100 66        
412 67         128 for (my $i = 0; $i < @$orig; ++$i) {
413 20         50 _save_references($id, $self->[$i], $orig->[$i]);
414             }
415 67         208 $REFS{$id}{Hash::Util::FieldHash::id($orig)} = $self;
416             }
417             elsif (is_plain_hashref($orig) || (blessed $orig && $orig->isa(__PACKAGE__))) {
418 349         744 for my $key (keys %$orig) {
419 1367         2031 _save_references($id, $self->{$key}, $orig->{$key});
420             }
421 349         1082 $REFS{$id}{Hash::Util::FieldHash::id($orig)} = $self;
422             }
423             }
424              
425             # During a rollback, copy data from the snapshot back into the original internal structures.
426             sub _restore_references {
427 377     377   395 my $id = shift;
428 377   100     553 my $orig = shift // return;
429 329   50     1668 my $self = delete $REFS{$id}{Hash::Util::FieldHash::id($orig) // ''} // return $orig;
      100        
430              
431 108 100 33     269 if (is_plain_arrayref($orig)) {
    50 66        
432 19         33 @$self = map { _restore_references($id, $_) } @$orig;
  6         10  
433             }
434             elsif (is_plain_hashref($orig) || (blessed $orig && $orig->isa(__PACKAGE__))) {
435 89         161 for my $key (keys %$orig) {
436             # next if is_ref($orig->{$key}) &&
437             # (Hash::Util::FieldHash::id($self->{$key}) // 0) == Hash::Util::FieldHash::id($orig->{$key});
438 366         483 $self->{$key} = _restore_references($id, $orig->{$key});
439             }
440             }
441              
442 108         191 return $self;
443             }
444              
445             ##############################################################################
446              
447             sub _signal {
448 68     68   95 my $self = shift;
449 68         90 my $type = shift;
450              
451 68 50       151 if ($self->_in_txn) {
452 0         0 my $stack = $self->_signal_stack;
453 0         0 my $queue = $stack->[-1];
454 0         0 push @$queue, [$type, @_];
455             }
456              
457 68         270 $self->_signal_send([[$type, @_]]);
458              
459 68         272 return $self;
460             }
461              
462 52   100 52   238 sub _signal_stack { $SIGNALS{$_[0]} //= [] }
463              
464             sub _signal_begin_work {
465 19     19   24 my $self = shift;
466 19         24 push @{$self->_signal_stack}, [];
  19         46  
467             }
468              
469             sub _signal_commit {
470 14     14   22 my $self = shift;
471 14         18 my $signals = pop @{$self->_signal_stack};
  14         34  
472 14   100     32 my $previous = $self->_signal_stack->[-1] // [];
473 14         29 push @$previous, @$signals;
474 14         25 return $previous;
475             }
476              
477             sub _signal_rollback {
478 5     5   9 my $self = shift;
479 5         6 pop @{$self->_signal_stack};
  5         8  
480             }
481              
482             sub _signal_send {
483 80     80   109 my $self = shift;
484 80   50     183 my $signals = shift // [];
485              
486 80 50       212 my $kdbx = $KDBX{$self} or return;
487              
488             # de-duplicate, keeping the most recent signal for each type
489 80         101 my %seen;
490 80         151 my @signals = grep { !$seen{$_->[0]}++ } reverse @$signals;
  68         290  
491              
492 80         164 for my $sig (reverse @signals) {
493 68         193 $kdbx->_handle_signal($self, @$sig);
494             }
495             }
496              
497             ##############################################################################
498              
499             sub _wrap_group {
500 54     54   78 my $self = shift;
501 54         64 my $group = shift;
502 54         168 require File::KDBX::Group;
503 54         145 return File::KDBX::Group->wrap($group, $KDBX{$self});
504             }
505              
506             sub _wrap_entry {
507 59     59   103 my $self = shift;
508 59         122 my $entry = shift;
509 59         3113 require File::KDBX::Entry;
510 59         291 return File::KDBX::Entry->wrap($entry, $KDBX{$self});
511             }
512              
513 0     0 0   sub TO_JSON { +{%{$_[0]}} }
  0            
514              
515             1;
516              
517             __END__