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 = '0.800'; # 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 entries_deeply {
  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->groups_deeply(%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 groups_deeply {
 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 objects_deeply {
 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->groups_deeply(%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.800
 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 =head1 ATTRIBUTES
 412
 413 =head2 uuid
 414
 415 128-bit UUID identifying the group within the database.
 416
 417 =head2 name
 418
 419 The human-readable name of the group.
 420
 421 =head2 notes
 422
 423 Free form text string associated with the group.
 424
 425 =head2 tags
 426
 427 Text string with arbitrary tags which can be used to build a taxonomy.
 428
 429 =head2 icon_id
 430
 431 Integer representing a default icon. See L<File::KDBX::Constants/":icon"> for valid values.
 432
 433 =head2 custom_icon_uuid
 434
 435 128-bit UUID identifying a custom icon within the database.
 436
 437 =head2 is_expanded
 438
 439 Whether or not subgroups are visible when listed for user selection.
 440
 441 =head2 default_auto_type_sequence
 442
 443 The default auto-type keystroke sequence, inheritable by entries and subgroups.
 444
 445 =head2 enable_auto_type
 446
 447 Whether or not the entry is eligible to be matched for auto-typing, inheritable by entries and subgroups.
 448
 449 =head2 enable_searching
 450
 451 Whether or not entries within the group can show up in search results, inheritable by subgroups.
 452
 453 =head2 last_top_visible_entry
 454
 455 The UUID of the entry visible at the top of the list.
 456
 457 =head2 custom_data
 458
 459 A set of key-value pairs used to store arbitrary data, usually used by software to keep track of state rather
 460 than by end users (who typically work with the strings and binaries).
 461
 462 =head2 previous_parent_group
 463
 464 128-bit UUID identifying a group within the database.
 465
 466 =head2 entries
 467
 468 Array of entries contained within the group.
 469
 470 =head2 groups
 471
 472 Array of subgroups contained within the group.
 473
 474 =head2 last_modification_time
 475
 476 Date and time when the entry was last modified.
 477
 478 =head2 creation_time
 479
 480 Date and time when the entry was created.
 481
 482 =head2 last_access_time
 483
 484 Date and time when the entry was last accessed.
 485
 486 =head2 expiry_time
 487
 488 Date and time when the entry expired or will expire.
 489
 490 =head2 expires
 491
 492 Boolean value indicating whether or not an entry is expired.
 493
 494 =head2 usage_count
 495
 496 TODO
 497
 498 =head2 location_changed
 499
 500 Date and time when the entry was last moved to a different parent group.
 501
 502 =head1 METHODS
 503
 504 =head2 entries
 505
 506     \@entries = $group->entries;
 507
 508 Get an array of direct entries within a group.
 509
 510 =head2 entries_deeply
 511
 512     \&iterator = $kdbx->entries_deeply(%options);
 513
 514 Get an L<File::KDBX::Iterator> over I<entries> within a group. Supports the same options as L</groups>,
 515 plus some new ones:
 516
 517 =over 4
 518
 519 =item *
 520
 521 C<auto_type> - Only include entries with auto-type enabled (default: false, include all)
 522
 523 =item *
 524
 525 C<searching> - Only include entries within groups with searching enabled (default: false, include all)
 526
 527 =item *
 528
 529 C<history> - Also include historical entries (default: false, include only current entries)
 530
 531 =back
 532
 533 =head2 add_entry
 534
 535     $entry = $group->add_entry($entry);
 536     $entry = $group->add_entry(%entry_attributes);
 537
 538 Add an entry to a group. If C<$entry> already has a parent group, it will be removed from that group before
 539 being added to C<$group>.
 540
 541 =head2 remove_entry
 542
 543     $entry = $group->remove_entry($entry);
 544     $entry = $group->remove_entry($entry_uuid);
 545
 546 Remove an entry from a group's array of entries. Returns the entry removed or C<undef> if nothing removed.
 547
 548 =head2 groups
 549
 550     \@groups = $group->groups;
 551
 552 Get an array of direct subgroups within a group.
 553
 554 =head2 groups_deeply
 555
 556     \&iterator = $group->groups_deeply(%options);
 557
 558 Get an L<File::KDBX::Iterator> over I<groups> within a groups, deeply. Options:
 559
 560 =over 4
 561
 562 =item *
 563
 564 C<inclusive> - Include C<$group> itself in the results (default: true)
 565
 566 =item *
 567
 568 C<algorithm> - Search algorithm, one of C<ids>, C<bfs> or C<dfs> (default: C<ids>)
 569
 570 =back
 571
 572 =head2 add_group
 573
 574     $new_group = $group->add_group($new_group);
 575     $new_group = $group->add_group(%group_attributes);
 576
 577 Add a group to a group. If C<$new_group> already has a parent group, it will be removed from that group before
 578 being added to C<$group>.
 579
 580 =head2 remove_group
 581
 582     $removed_group = $group->remove_group($group);
 583     $removed_group = $group->remove_group($group_uuid);
 584
 585 Remove a group from a group's array of subgroups. Returns the group removed or C<undef> if nothing removed.
 586
 587 =head2 objects_deeply
 588
 589     \&iterator = $groups->objects_deeply(%options);
 590
 591 Get an L<File::KDBX::Iterator> over I<objects> within a group, deeply. Groups and entries are considered
 592 objects, so this is essentially a combination of L</groups> and L</entries>. This won't often be useful, but
 593 it can be convenient for maintenance tasks. This method takes the same options as L</groups> and L</entries>.
 594
 595 =head2 add_object
 596
 597     $new_entry = $group->add_object($new_entry);
 598     $new_group = $group->add_object($new_group);
 599
 600 Add an object (either a L<File::KDBX::Entry> or a L<File::KDBX::Group>) to a group. This is the generic
 601 equivalent of the object forms of L</add_entry> and L</add_group>.
 602
 603 =head2 remove_object
 604
 605     $group->remove_object($entry);
 606     $group->remove_object($group);
 607
 608 Remove an object (either a L<File::KDBX::Entry> or a L<File::KDBX::Group>) from a group. This is the generic
 609 equivalent of the object forms of L</remove_entry> and L</remove_group>.
 610
 611 =head2 effective_default_auto_type_sequence
 612
 613     $text = $group->effective_default_auto_type_sequence;
 614
 615 Get the value of L</default_auto_type_sequence>, if set, or get the inherited effective default auto-type
 616 sequence of the parent.
 617
 618 =head2 effective_enable_auto_type
 619
 620     $text = $group->effective_enable_auto_type;
 621
 622 Get the value of L</enable_auto_type>, if set, or get the inherited effective auto-type enabled value of the
 623 parent.
 624
 625 =head2 effective_enable_searching
 626
 627     $text = $group->effective_enable_searching;
 628
 629 Get the value of L</enable_searching>, if set, or get the inherited effective searching enabled value of the
 630 parent.
 631
 632 =head2 is_empty
 633
 634     $bool = $group->is_empty;
 635
 636 Get whether or not the group is empty (has no subgroups or entries).
 637
 638 =head2 is_root
 639
 640     $bool = $group->is_root;
 641
 642 Determine if a group is the root group of its connected database.
 643
 644 =head2 is_recycle_bin
 645
 646     $bool = $group->is_recycle_bin;
 647
 648 Get whether or not a group is the recycle bin of its connected database.
 649
 650 =head2 is_entry_templates
 651
 652     $bool = $group->is_entry_templates;
 653
 654 Get whether or not a group is the group containing entry template of its connected database.
 655
 656 =head2 is_last_selected
 657
 658     $bool = $group->is_last_selected;
 659
 660 Get whether or not a group is the prior selected group of its connected database.
 661
 662 =head2 is_last_top_visible
 663
 664     $bool = $group->is_last_top_visible;
 665
 666 Get whether or not a group is the latest top visible group of its connected database.
 667
 668 =head2 path
 669
 670     $string = $group->path;
 671
 672 Get a string representation of a group's lineage. This is used as the substitution value for the
 673 C<{GROUP_PATH}> placeholder. See L<File::KDBX::Entry/Placeholders>.
 674
 675 For a root group, the path is simply the name of the group. For deeper groups, the path is a period-separated
 676 sequence of group names between the root group and C<$group>, including C<$group> but I<not> the root group.
 677 In other words, paths of deeper groups leave the root group name out.
 678
 679     Database
 680     -> Root         # path is "Root"
 681        -> Foo       # path is "Foo"
 682           -> Bar    # path is "Foo.Bar"
 683
 684 Yeah, it doesn't make much sense to me, either, but this matches the behavior of KeePass.
 685
 686 =head2 size
 687
 688     $size = $group->size;
 689
 690 Get the size (in bytes) of a group, including the size of all subroups and entries, if any.
 691
 692 =head2 depth
 693
 694     $depth = $group->depth;
 695
 696 Get the depth of a group within a database. The root group is at depth 0, its direct children are at depth 1,
 697 etc. A group not in a database tree structure returns a depth of -1.
 698
 699 =for Pod::Coverage times
 700
 701 =head1 BUGS
 702
 703 Please report any bugs or feature requests on the bugtracker website
 704 L<https://github.com/chazmcgarvey/File-KDBX/issues>
 705
 706 When submitting a bug or request, please include a test-file or a
 707 patch to an existing test-file that illustrates the bug or desired
 708 feature.
 709
 710 =head1 AUTHOR
 711
 712 Charles McGarvey <ccm@cpan.org>
 713
 714 =head1 COPYRIGHT AND LICENSE
 715
 716 This software is copyright (c) 2022 by Charles McGarvey.
 717
 718 This is free software; you can redistribute it and/or modify it under
 719 the same terms as the Perl 5 programming language system itself.
 720
 721 =cut