]> Dogcows Code - chaz/p5-File-KDBX/blob - lib/File/KDBX/Group.pm
c5dbafed1ee1ffeaed2ade421b8e4d25b3f422fd
[chaz/p5-File-KDBX] / lib / File / KDBX / Group.pm
1 package File::KDBX::Group;
2 # ABSTRACT: A KDBX database group
3
4 use warnings;
5 use strict;
6
7 use Devel::GlobalDestruction;
8 use File::KDBX::Constants qw(:bool :icon :iteration);
9 use File::KDBX::Error;
10 use File::KDBX::Iterator;
11 use File::KDBX::Util qw(:assert :class :coercion generate_uuid);
12 use Hash::Util::FieldHash;
13 use List::Util qw(any sum0);
14 use Ref::Util qw(is_coderef is_ref);
15 use Scalar::Util qw(blessed);
16 use Time::Piece 1.33;
17 use boolean;
18 use namespace::clean;
19
20 extends 'File::KDBX::Object';
21
22 our $VERSION = '999.999'; # VERSION
23
24 =attr name
25
26 The human-readable name of the group.
27
28 =attr notes
29
30 Free form text string associated with the group.
31
32 =attr is_expanded
33
34 Whether or not subgroups are visible when listed for user selection.
35
36 =attr default_auto_type_sequence
37
38 The default auto-type keystroke sequence, inheritable by entries and subgroups.
39
40 =attr enable_auto_type
41
42 Whether or not the entry is eligible to be matched for auto-typing, inheritable by entries and subgroups.
43
44 =attr enable_searching
45
46 Whether or not entries within the group can show up in search results, inheritable by subgroups.
47
48 =attr last_top_visible_entry
49
50 The UUID of the entry visible at the top of the list.
51
52 =attr entries
53
54 Array of entries contained within the group.
55
56 =attr groups
57
58 Array of subgroups contained within the group.
59
60 =cut
61
62 # has uuid => sub { generate_uuid(printable => 1) };
63 has name => '', coerce => \&to_string;
64 has notes => '', coerce => \&to_string;
65 has tags => '', coerce => \&to_string;
66 has icon_id => ICON_FOLDER, coerce => \&to_icon_constant;
67 has custom_icon_uuid => undef, coerce => \&to_uuid;
68 has is_expanded => false, coerce => \&to_bool;
69 has default_auto_type_sequence => '', coerce => \&to_string;
70 has enable_auto_type => undef, coerce => \&to_tristate;
71 has enable_searching => undef, coerce => \&to_tristate;
72 has last_top_visible_entry => undef, coerce => \&to_uuid;
73 # has custom_data => {};
74 has previous_parent_group => undef, coerce => \&to_uuid;
75 # has entries => [];
76 # has groups => [];
77 has times => {};
78
79 has last_modification_time => sub { gmtime }, store => 'times', coerce => \&to_time;
80 has creation_time => sub { gmtime }, store => 'times', coerce => \&to_time;
81 has last_access_time => sub { gmtime }, store => 'times', coerce => \&to_time;
82 has expiry_time => sub { gmtime }, store => 'times', coerce => \&to_time;
83 has expires => false, store => 'times', coerce => \&to_bool;
84 has usage_count => 0, store => 'times', coerce => \&to_number;
85 has location_changed => sub { gmtime }, store => 'times', coerce => \&to_time;
86
87 my @ATTRS = qw(uuid custom_data entries groups);
88 sub _set_nonlazy_attributes {
89 my $self = shift;
90 $self->$_ for @ATTRS, list_attributes(ref $self);
91 }
92
93 sub uuid {
94 my $self = shift;
95 if (@_ || !defined $self->{uuid}) {
96 my %args = @_ % 2 == 1 ? (uuid => shift, @_) : @_;
97 my $old_uuid = $self->{uuid};
98 my $uuid = $self->{uuid} = delete $args{uuid} // generate_uuid;
99 $self->_signal('uuid.changed', $uuid, $old_uuid) if defined $old_uuid;
100 }
101 $self->{uuid};
102 }
103
104 ##############################################################################
105
106 =method entries
107
108 \@entries = $group->entries;
109
110 Get an array of direct child entries within a group.
111
112 =cut
113
114 sub entries {
115 my $self = shift;
116 my $entries = $self->{entries} //= [];
117 if (@$entries && !blessed($entries->[0])) {
118 @$entries = map { $self->_wrap_entry($_, $self->kdbx) } @$entries;
119 }
120 assert { !any { !blessed $_ } @$entries };
121 return $entries;
122 }
123
124 =method all_entries
125
126 \&iterator = $kdbx->all_entries(%options);
127
128 Get an L<File::KDBX::Iterator> over I<entries> within a group. Supports the same options as L</groups>,
129 plus some new ones:
130
131 =for :list
132 * C<auto_type> - Only include entries with auto-type enabled (default: false, include all)
133 * C<searching> - Only include entries within groups with searching enabled (default: false, include all)
134 * C<history> - Also include historical entries (default: false, include only current entries)
135
136 =cut
137
138 sub all_entries {
139 my $self = shift;
140 my %args = @_;
141
142 my $searching = delete $args{searching};
143 my $auto_type = delete $args{auto_type};
144 my $history = delete $args{history};
145
146 my $groups = $self->all_groups(%args);
147 my @entries;
148
149 return File::KDBX::Iterator->new(sub {
150 if (!@entries) {
151 while (my $group = $groups->next) {
152 next if $searching && !$group->effective_enable_searching;
153 next if $auto_type && !$group->effective_enable_auto_type;
154 @entries = @{$group->entries};
155 @entries = grep { $_->auto_type->{enabled} } @entries if $auto_type;
156 @entries = map { ($_, @{$_->history}) } @entries if $history;
157 last if @entries;
158 }
159 }
160 shift @entries;
161 });
162 }
163
164 =method add_entry
165
166 $entry = $group->add_entry($entry);
167 $entry = $group->add_entry(%entry_attributes);
168
169 Add an entry to a group. If C<$entry> already has a parent group, it will be removed from that group before
170 being added to C<$group>.
171
172 =cut
173
174 sub add_entry {
175 my $self = shift;
176 my $entry = @_ % 2 == 1 ? shift : undef;
177 my %args = @_;
178
179 my $kdbx = delete $args{kdbx} // eval { $self->kdbx };
180
181 $entry = $self->_wrap_entry($entry // [%args]);
182 $entry->uuid;
183 $entry->kdbx($kdbx) if $kdbx;
184
185 push @{$self->{entries} ||= []}, $entry->remove;
186 return $entry->_set_group($self)->_signal('added', $self);
187 }
188
189 =method remove_entry
190
191 $entry = $group->remove_entry($entry);
192 $entry = $group->remove_entry($entry_uuid);
193
194 Remove an entry from a group's array of entries. Returns the entry removed or C<undef> if nothing removed.
195
196 =cut
197
198 sub remove_entry {
199 my $self = shift;
200 my $uuid = is_ref($_[0]) ? $self->_wrap_entry(shift)->uuid : shift;
201 my %args = @_;
202 my $objects = $self->{entries};
203 for (my $i = 0; $i < @$objects; ++$i) {
204 my $object = $objects->[$i];
205 next if $uuid ne $object->uuid;
206 $object->_set_group(undef);
207 $object->_signal('removed') if $args{signal} // 1;
208 return splice @$objects, $i, 1;
209 }
210 }
211
212 ##############################################################################
213
214 =method groups
215
216 \@groups = $group->groups;
217
218 Get an array of direct subgroups within a group.
219
220 =cut
221
222 sub groups {
223 my $self = shift;
224 my $groups = $self->{groups} //= [];
225 if (@$groups && !blessed($groups->[0])) {
226 @$groups = map { $self->_wrap_group($_, $self->kdbx) } @$groups;
227 }
228 assert { !any { !blessed $_ } @$groups };
229 return $groups;
230 }
231
232 =method all_groups
233
234 \&iterator = $group->all_groups(%options);
235
236 Get an L<File::KDBX::Iterator> over I<groups> within a groups, deeply. Options:
237
238 =for :list
239 * C<inclusive> - Include C<$group> itself in the results (default: true)
240 * C<algorithm> - Search algorithm, one of C<ids>, C<bfs> or C<dfs> (default: C<ids>)
241
242 =cut
243
244 sub all_groups {
245 my $self = shift;
246 my %args = @_;
247
248 my @groups = ($args{inclusive} // 1) ? $self : @{$self->groups};
249 my $algo = lc($args{algorithm} || 'ids');
250
251 if ($algo eq ITERATION_DFS) {
252 my %visited;
253 return File::KDBX::Iterator->new(sub {
254 my $next = shift @groups or return;
255 if (!$visited{Hash::Util::FieldHash::id($next)}++) {
256 while (my @children = @{$next->groups}) {
257 unshift @groups, @children, $next;
258 $next = shift @groups;
259 $visited{Hash::Util::FieldHash::id($next)}++;
260 }
261 }
262 $next;
263 });
264 }
265 elsif ($algo eq ITERATION_BFS) {
266 return File::KDBX::Iterator->new(sub {
267 my $next = shift @groups or return;
268 push @groups, @{$next->groups};
269 $next;
270 });
271 }
272 return File::KDBX::Iterator->new(sub {
273 my $next = shift @groups or return;
274 unshift @groups, @{$next->groups};
275 $next;
276 });
277 }
278
279 sub _kpx_groups { shift->groups(@_) }
280
281 =method add_group
282
283 $new_group = $group->add_group($new_group);
284 $new_group = $group->add_group(%group_attributes);
285
286 Add a group to a group. If C<$new_group> already has a parent group, it will be removed from that group before
287 being added to C<$group>.
288
289 =cut
290
291 sub add_group {
292 my $self = shift;
293 my $group = @_ % 2 == 1 ? shift : undef;
294 my %args = @_;
295
296 my $kdbx = delete $args{kdbx} // eval { $self->kdbx };
297
298 $group = $self->_wrap_group($group // [%args]);
299 $group->uuid;
300 $group->kdbx($kdbx) if $kdbx;
301
302 push @{$self->{groups} ||= []}, $group->remove;
303 return $group->_set_group($self)->_signal('added', $self);
304 }
305
306 =method remove_group
307
308 $removed_group = $group->remove_group($group);
309 $removed_group = $group->remove_group($group_uuid);
310
311 Remove a group from a group's array of subgroups. Returns the group removed or C<undef> if nothing removed.
312
313 =cut
314
315 sub remove_group {
316 my $self = shift;
317 my $uuid = is_ref($_[0]) ? $self->_wrap_group(shift)->uuid : shift;
318 my %args = @_;
319 my $objects = $self->{groups};
320 for (my $i = 0; $i < @$objects; ++$i) {
321 my $object = $objects->[$i];
322 next if $uuid ne $object->uuid;
323 $object->_set_group(undef);
324 $object->_signal('removed') if $args{signal} // 1;
325 return splice @$objects, $i, 1;
326 }
327 }
328
329 ##############################################################################
330
331 =method all_objects
332
333 \&iterator = $groups->all_objects(%options);
334
335 Get an L<File::KDBX::Iterator> over I<objects> within a group, deeply. Groups and entries are considered
336 objects, so this is essentially a combination of L</groups> and L</entries>. This won't often be useful, but
337 it can be convenient for maintenance tasks. This method takes the same options as L</groups> and L</entries>.
338
339 =cut
340
341 sub all_objects {
342 my $self = shift;
343 my %args = @_;
344
345 my $searching = delete $args{searching};
346 my $auto_type = delete $args{auto_type};
347 my $history = delete $args{history};
348
349 my $groups = $self->all_groups(%args);
350 my @entries;
351
352 return File::KDBX::Iterator->new(sub {
353 if (!@entries) {
354 while (my $group = $groups->next) {
355 next if $searching && !$group->effective_enable_searching;
356 next if $auto_type && !$group->effective_enable_auto_type;
357 @entries = @{$group->entries};
358 @entries = grep { $_->auto_type->{enabled} } @entries if $auto_type;
359 @entries = map { ($_, @{$_->history}) } @entries if $history;
360 return $group;
361 }
362 }
363 shift @entries;
364 });
365 }
366
367 =method add_object
368
369 $new_entry = $group->add_object($new_entry);
370 $new_group = $group->add_object($new_group);
371
372 Add an object (either a L<File::KDBX::Entry> or a L<File::KDBX::Group>) to a group. This is the generic
373 equivalent of the object forms of L</add_entry> and L</add_group>.
374
375 =cut
376
377 sub add_object {
378 my $self = shift;
379 my $obj = shift;
380 if ($obj->isa('File::KDBX::Entry')) {
381 $self->add_entry($obj);
382 }
383 elsif ($obj->isa('File::KDBX::Group')) {
384 $self->add_group($obj);
385 }
386 }
387
388 =method remove_object
389
390 $group->remove_object($entry);
391 $group->remove_object($group);
392
393 Remove an object (either a L<File::KDBX::Entry> or a L<File::KDBX::Group>) from a group. This is the generic
394 equivalent of the object forms of L</remove_entry> and L</remove_group>.
395
396 =cut
397
398 sub remove_object {
399 my $self = shift;
400 my $object = shift;
401 my $blessed = blessed($object);
402 return $self->remove_group($object, @_) if $blessed && $object->isa('File::KDBX::Group');
403 return $self->remove_entry($object, @_) if $blessed && $object->isa('File::KDBX::Entry');
404 return $self->remove_group($object, @_) || $self->remove_entry($object, @_);
405 }
406
407 ##############################################################################
408
409 =method effective_default_auto_type_sequence
410
411 $text = $group->effective_default_auto_type_sequence;
412
413 Get the value of L</default_auto_type_sequence>, if set, or get the inherited effective default auto-type
414 sequence of the parent.
415
416 =cut
417
418 sub effective_default_auto_type_sequence {
419 my $self = shift;
420 my $sequence = $self->default_auto_type_sequence;
421 return $sequence if defined $sequence;
422
423 my $parent = $self->group or return '{USERNAME}{TAB}{PASSWORD}{ENTER}';
424 return $parent->effective_default_auto_type_sequence;
425 }
426
427 =method effective_enable_auto_type
428
429 $text = $group->effective_enable_auto_type;
430
431 Get the value of L</enable_auto_type>, if set, or get the inherited effective auto-type enabled value of the
432 parent.
433
434 =cut
435
436 sub effective_enable_auto_type {
437 my $self = shift;
438 my $enabled = $self->enable_auto_type;
439 return $enabled if defined $enabled;
440
441 my $parent = $self->group or return true;
442 return $parent->effective_enable_auto_type;
443 }
444
445 =method effective_enable_searching
446
447 $text = $group->effective_enable_searching;
448
449 Get the value of L</enable_searching>, if set, or get the inherited effective searching enabled value of the
450 parent.
451
452 =cut
453
454 sub effective_enable_searching {
455 my $self = shift;
456 my $enabled = $self->enable_searching;
457 return $enabled if defined $enabled;
458
459 my $parent = $self->group or return true;
460 return $parent->effective_enable_searching;
461 }
462
463 ##############################################################################
464
465 =method is_empty
466
467 $bool = $group->is_empty;
468
469 Get whether or not the group is empty (has no subgroups or entries).
470
471 =cut
472
473 sub is_empty {
474 my $self = shift;
475 return @{$self->groups} == 0 && @{$self->entries} == 0;
476 }
477
478 =method is_root
479
480 $bool = $group->is_root;
481
482 Determine if a group is the root group of its connected database.
483
484 =cut
485
486 sub is_root {
487 my $self = shift;
488 my $kdbx = eval { $self->kdbx } or return FALSE;
489 return Hash::Util::FieldHash::id($kdbx->root) == Hash::Util::FieldHash::id($self);
490 }
491
492 =method is_recycle_bin
493
494 $bool = $group->is_recycle_bin;
495
496 Get whether or not a group is the recycle bin of its connected database.
497
498 =cut
499
500 sub is_recycle_bin {
501 my $self = shift;
502 my $kdbx = eval { $self->kdbx } or return FALSE;
503 my $group = $kdbx->recycle_bin;
504 return $group && Hash::Util::FieldHash::id($group) == Hash::Util::FieldHash::id($self);
505 }
506
507 =method is_entry_templates
508
509 $bool = $group->is_entry_templates;
510
511 Get whether or not a group is the group containing entry template in its connected database.
512
513 =cut
514
515 sub is_entry_templates {
516 my $self = shift;
517 my $kdbx = eval { $self->kdbx } or return FALSE;
518 my $group = $kdbx->entry_templates;
519 return $group && Hash::Util::FieldHash::id($group) == Hash::Util::FieldHash::id($self);
520 }
521
522 =method is_last_selected
523
524 $bool = $group->is_last_selected;
525
526 Get whether or not a group is the prior selected group of its connected database.
527
528 =cut
529
530 sub is_last_selected {
531 my $self = shift;
532 my $kdbx = eval { $self->kdbx } or return FALSE;
533 my $group = $kdbx->last_selected;
534 return $group && Hash::Util::FieldHash::id($group) == Hash::Util::FieldHash::id($self);
535 }
536
537 =method is_last_top_visible
538
539 $bool = $group->is_last_top_visible;
540
541 Get whether or not a group is the latest top visible group of its connected database.
542
543 =cut
544
545 sub is_last_top_visible {
546 my $self = shift;
547 my $kdbx = eval { $self->kdbx } or return FALSE;
548 my $group = $kdbx->last_top_visible;
549 return $group && Hash::Util::FieldHash::id($group) == Hash::Util::FieldHash::id($self);
550 }
551
552 =method path
553
554 $string = $group->path;
555
556 Get a string representation of a group's lineage. This is used as the substitution value for the
557 C<{GROUP_PATH}> placeholder. See L<File::KDBX::Entry/Placeholders>.
558
559 For a root group, the path is simply the name of the group. For deeper groups, the path is a period-separated
560 sequence of group names between the root group and C<$group>, including C<$group> but I<not> the root group.
561 In other words, paths of deeper groups leave the root group name out.
562
563 Database
564 -> Root # path is "Root"
565 -> Foo # path is "Foo"
566 -> Bar # path is "Foo.Bar"
567
568 Yeah, it doesn't make much sense to me, either, but this matches the behavior of KeePass.
569
570 =cut
571
572 sub path {
573 my $self = shift;
574 return $self->name if $self->is_root;
575 my $lineage = $self->lineage or return;
576 my @parts = (@$lineage, $self);
577 shift @parts;
578 return join('.', map { $_->name } @parts);
579 }
580
581 =method size
582
583 $size = $group->size;
584
585 Get the size (in bytes) of a group, including the size of all subroups and entries, if any.
586
587 =cut
588
589 sub size {
590 my $self = shift;
591 return sum0 map { $_->size } @{$self->groups}, @{$self->entries};
592 }
593
594 =method depth
595
596 $depth = $group->depth;
597
598 Get the depth of a group within a database. The root group is at depth 0, its direct children are at depth 1,
599 etc. A group not in a database tree structure returns a depth of -1.
600
601 =cut
602
603 sub depth { $_[0]->is_root ? 0 : (scalar @{$_[0]->lineage || []} || -1) }
604
605 sub _signal {
606 my $self = shift;
607 my $type = shift;
608 return $self->SUPER::_signal("group.$type", @_);
609 }
610
611 sub _commit {
612 my $self = shift;
613 my $time = gmtime;
614 $self->last_modification_time($time);
615 $self->last_access_time($time);
616 }
617
618 sub label { shift->name(@_) }
619
620 ### Name of the parent attribute expected to contain the object
621 sub _parent_container { 'groups' }
622
623 1;
624 __END__
625
626 =for Pod::Coverage times
627
628 =head1 DESCRIPTION
629
630 A group in a KDBX database is a type of object that can contain entries and other groups.
631
632 There is also some metadata associated with a group. Each group in a database is identified uniquely by
633 a UUID. An entry can also have an icon associated with it, and there are various timestamps. Take a look at
634 the attributes to see what's available.
635
636 A B<File::KDBX::Group> is a subclass of L<File::KDBX::Object>. View its documentation to see other attributes
637 and methods available on groups.
638
639 =cut
This page took 0.085025 seconds and 4 git commands to generate.