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