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