Dogcows Code - chaz/p5-File-KDBX/blob - 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;
  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 entries_deeply
 125
 126     \&iterator = $kdbx->entries_deeply(%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 entries_deeply {
 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->groups_deeply(%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 groups_deeply
 233
 234     \&iterator = $group->groups_deeply(%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 groups_deeply {
 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 objects_deeply
 332
 333     \&iterator = $groups->objects_deeply(%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 objects_deeply {
 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->groups_deeply(%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 =cut