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);
   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 sub _parent_container { 'groups' }
  25
  26 # has uuid                        => sub { generate_uuid(printable => 1) };
  27 has name                        => '',          coerce => \&to_string;
  28 has notes                       => '',          coerce => \&to_string;
  29 has tags                        => '',          coerce => \&to_string;
  30 has icon_id                     => ICON_FOLDER, coerce => \&to_icon_constant;
  31 has custom_icon_uuid            => undef,       coerce => \&to_uuid;
  32 has is_expanded                 => false,       coerce => \&to_bool;
  33 has default_auto_type_sequence  => '',          coerce => \&to_string;
  34 has enable_auto_type            => undef,       coerce => \&to_tristate;
  35 has enable_searching            => undef,       coerce => \&to_tristate;
  36 has last_top_visible_entry      => undef,       coerce => \&to_uuid;
  37 # has custom_data                 => {};
  38 has previous_parent_group       => undef,       coerce => \&to_uuid;
  39 # has entries                     => [];
  40 # has groups                      => [];
  41 has times                       => {};
  42
  43 has last_modification_time  => sub { gmtime }, store => 'times', coerce => \&to_time;
  44 has creation_time           => sub { gmtime }, store => 'times', coerce => \&to_time;
  45 has last_access_time        => sub { gmtime }, store => 'times', coerce => \&to_time;
  46 has expiry_time             => sub { gmtime }, store => 'times', coerce => \&to_time;
  47 has expires                 => false,          store => 'times', coerce => \&to_bool;
  48 has usage_count             => 0,              store => 'times', coerce => \&to_number;
  49 has location_changed        => sub { gmtime }, store => 'times', coerce => \&to_time;
  50
  51 my @ATTRS = qw(uuid custom_data entries groups);
  52 sub _set_nonlazy_attributes {
  53     my $self = shift;
  54     $self->$_ for @ATTRS, list_attributes(ref $self);
  55 }
  56
  57 sub uuid {
  58     my $self = shift;
  59     if (@_ || !defined $self->{uuid}) {
  60         my %args = @_ % 2 == 1 ? (uuid => shift, @_) : @_;
  61         my $old_uuid = $self->{uuid};
  62         my $uuid = $self->{uuid} = delete $args{uuid} // generate_uuid;
  63         $self->_signal('uuid.changed', $uuid, $old_uuid) if defined $old_uuid;
  64     }
  65     $self->{uuid};
  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 sub entries_deeply {
  81     my $self = shift;
  82     my %args = @_;
  83
  84     my $searching   = delete $args{searching};
  85     my $auto_type   = delete $args{auto_type};
  86     my $history     = delete $args{history};
  87
  88     my $groups = $self->groups_deeply(%args);
  89     my @entries;
  90
  91     return File::KDBX::Iterator->new(sub {
  92         if (!@entries) {
  93             while (my $group = $groups->next) {
  94                 next if $searching && !$group->effective_enable_searching;
  95                 next if $auto_type && !$group->effective_enable_auto_type;
  96                 @entries = @{$group->entries};
  97                 @entries = grep { $_->auto_type->{enabled} } @entries if $auto_type;
  98                 @entries = map { ($_, @{$_->history}) } @entries if $history;
  99                 last if @entries;
 100             }
 101         }
 102         shift @entries;
 103     });
 104 }
 105
 106 =method add_entry
 107
 108     $entry = $group->add_entry($entry);
 109     $entry = $group->add_entry(%entry_attributes);
 110
 111 Add an entry to a group. If C<$entry> already has a parent group, it will be removed from that group before
 112 being added to C<$group>.
 113
 114 =cut
 115
 116 sub add_entry {
 117     my $self = shift;
 118     my $entry   = @_ % 2 == 1 ? shift : undef;
 119     my %args    = @_;
 120
 121     my $kdbx = delete $args{kdbx} // eval { $self->kdbx };
 122
 123     $entry = $self->_wrap_entry($entry // [%args]);
 124     $entry->uuid;
 125     $entry->kdbx($kdbx) if $kdbx;
 126
 127     push @{$self->{entries} ||= []}, $entry->remove;
 128     return $entry->_set_group($self)->_signal('added', $self);
 129 }
 130
 131 sub remove_entry {
 132     my $self = shift;
 133     my $uuid = is_ref($_[0]) ? $self->_wrap_entry(shift)->uuid : shift;
 134     my %args = @_;
 135     my $objects = $self->{entries};
 136     for (my $i = 0; $i < @$objects; ++$i) {
 137         my $object = $objects->[$i];
 138         next if $uuid ne $object->uuid;
 139         $object->_set_group(undef);
 140         $object->_signal('removed') if $args{signal} // 1;
 141         return splice @$objects, $i, 1;
 142     }
 143 }
 144
 145 ##############################################################################
 146
 147 sub groups {
 148     my $self = shift;
 149     my $groups = $self->{groups} //= [];
 150     if (@$groups && !blessed($groups->[0])) {
 151         @$groups = map { $self->_wrap_group($_, $self->kdbx) } @$groups;
 152     }
 153     assert { !any { !blessed $_ } @$groups };
 154     return $groups;
 155 }
 156
 157 sub groups_deeply {
 158     my $self = shift;
 159     my %args = @_;
 160
 161     my @groups = ($args{inclusive} // 1) ? $self : @{$self->groups};
 162     my $algo = lc($args{algorithm} || 'ids');
 163
 164     if ($algo eq 'dfs') {
 165         my %visited;
 166         return File::KDBX::Iterator->new(sub {
 167             my $next = shift @groups or return;
 168             if (!$visited{Hash::Util::FieldHash::id($next)}++) {
 169                 while (my @children = @{$next->groups}) {
 170                     unshift @groups, @children, $next;
 171                     $next = shift @groups;
 172                     $visited{Hash::Util::FieldHash::id($next)}++;
 173                 }
 174             }
 175             $next;
 176         });
 177     }
 178     elsif ($algo eq 'bfs') {
 179         return File::KDBX::Iterator->new(sub {
 180             my $next = shift @groups or return;
 181             push @groups, @{$next->groups};
 182             $next;
 183         });
 184     }
 185     return File::KDBX::Iterator->new(sub {
 186         my $next = shift @groups or return;
 187         unshift @groups, @{$next->groups};
 188         $next;
 189     });
 190 }
 191
 192 sub _kpx_groups { shift->groups(@_) }
 193
 194 =method add_group
 195
 196     $new_group = $group->add_group($new_group);
 197     $new_group = $group->add_group(%group_attributes);
 198
 199 Add a group to a group. If C<$new_group> already has a parent group, it will be removed from that group before
 200 being added to C<$group>.
 201
 202 =cut
 203
 204 sub add_group {
 205     my $self    = shift;
 206     my $group   = @_ % 2 == 1 ? shift : undef;
 207     my %args    = @_;
 208
 209     my $kdbx = delete $args{kdbx} // eval { $self->kdbx };
 210
 211     $group = $self->_wrap_group($group // [%args]);
 212     $group->uuid;
 213     $group->kdbx($kdbx) if $kdbx;
 214
 215     push @{$self->{groups} ||= []}, $group->remove;
 216     return $group->_set_group($self)->_signal('added', $self);
 217 }
 218
 219 sub remove_group {
 220     my $self = shift;
 221     my $uuid = is_ref($_[0]) ? $self->_wrap_group(shift)->uuid : shift;
 222     my %args = @_;
 223     my $objects = $self->{groups};
 224     for (my $i = 0; $i < @$objects; ++$i) {
 225         my $object = $objects->[$i];
 226         next if $uuid ne $object->uuid;
 227         $object->_set_group(undef);
 228         $object->_signal('removed') if $args{signal} // 1;
 229         return splice @$objects, $i, 1;
 230     }
 231 }
 232
 233 ##############################################################################
 234
 235 sub objects_deeply {
 236     my $self = shift;
 237     my %args = @_;
 238
 239     my $searching   = delete $args{searching};
 240     my $auto_type   = delete $args{auto_type};
 241     my $history     = delete $args{history};
 242
 243     my $groups = $self->groups_deeply(%args);
 244     my @entries;
 245
 246     return File::KDBX::Iterator->new(sub {
 247         if (!@entries) {
 248             while (my $group = $groups->next) {
 249                 next if $searching && !$group->effective_enable_searching;
 250                 next if $auto_type && !$group->effective_enable_auto_type;
 251                 @entries = @{$group->entries};
 252                 @entries = grep { $_->auto_type->{enabled} } @entries if $auto_type;
 253                 @entries = map { ($_, @{$_->history}) } @entries if $history;
 254                 return $group;
 255             }
 256         }
 257         shift @entries;
 258     });
 259 }
 260
 261 =method add_object
 262
 263     $new_entry = $group->add_object($new_entry);
 264     $new_group = $group->add_object($new_group);
 265
 266 Add an object (either a L<File::KDBX::Entry> or a L<File::KDBX::Group>) to a group. This is the generic
 267 equivalent of the object forms of L</add_entry> and L</add_group>.
 268
 269 =cut
 270
 271 sub add_object {
 272     my $self = shift;
 273     my $obj  = shift;
 274     if ($obj->isa('File::KDBX::Entry')) {
 275         $self->add_entry($obj);
 276     }
 277     elsif ($obj->isa('File::KDBX::Group')) {
 278         $self->add_group($obj);
 279     }
 280 }
 281
 282 =method remove_object
 283
 284     $group->remove_object($entry);
 285     $group->remove_object($group);
 286
 287 Remove an object (either a L<File::KDBX::Entry> or a L<File::KDBX::Group>) from a group. This is the generic
 288 equivalent of the object forms of L</remove_entry> and L</remove_group>.
 289
 290 =cut
 291
 292 sub remove_object {
 293     my $self = shift;
 294     my $object = shift;
 295     my $blessed = blessed($object);
 296     return $self->remove_group($object, @_) if $blessed && $object->isa('File::KDBX::Group');
 297     return $self->remove_entry($object, @_) if $blessed && $object->isa('File::KDBX::Entry');
 298     return $self->remove_group($object, @_) || $self->remove_entry($object, @_);
 299 }
 300
 301 ##############################################################################
 302
 303 =method is_root
 304
 305     $bool = $group->is_root;
 306
 307 Determine if a group is the root group of its connected database.
 308
 309 =cut
 310
 311 sub is_root {
 312     my $self = shift;
 313     my $kdbx = eval { $self->kdbx } or return FALSE;
 314     return Hash::Util::FieldHash::id($kdbx->root) == Hash::Util::FieldHash::id($self);
 315 }
 316
 317 =method is_recycle_bin
 318
 319     $bool = $group->is_recycle_bin;
 320
 321 Get whether or not a group is the recycle bin of its connected database.
 322
 323 =cut
 324
 325 sub is_recycle_bin {
 326     my $self    = shift;
 327     my $kdbx    = eval { $self->kdbx } or return FALSE;
 328     my $group   = $kdbx->recycle_bin;
 329     return $group && Hash::Util::FieldHash::id($group) == Hash::Util::FieldHash::id($self);
 330 }
 331
 332 =method is_entry_templates
 333
 334     $bool = $group->is_entry_templates;
 335
 336 Get whether or not a group is the group containing entry template of its connected database.
 337
 338 =cut
 339
 340 sub entry_templates {
 341     my $self    = shift;
 342     my $kdbx    = eval { $self->kdbx } or return FALSE;
 343     my $group   = $kdbx->entry_templates;
 344     return $group && Hash::Util::FieldHash::id($group) == Hash::Util::FieldHash::id($self);
 345 }
 346
 347 =method is_last_selected
 348
 349     $bool = $group->is_last_selected;
 350
 351 Get whether or not a group is the prior selected group of its connected database.
 352
 353 =cut
 354
 355 sub last_selected {
 356     my $self    = shift;
 357     my $kdbx    = eval { $self->kdbx } or return FALSE;
 358     my $group   = $kdbx->last_selected;
 359     return $group && Hash::Util::FieldHash::id($group) == Hash::Util::FieldHash::id($self);
 360 }
 361
 362 =method is_last_top_visible
 363
 364     $bool = $group->is_last_top_visible;
 365
 366 Get whether or not a group is the latest top visible group of its connected database.
 367
 368 =cut
 369
 370 sub last_top_visible {
 371     my $self    = shift;
 372     my $kdbx    = eval { $self->kdbx } or return FALSE;
 373     my $group   = $kdbx->last_top_visible;
 374     return $group && Hash::Util::FieldHash::id($group) == Hash::Util::FieldHash::id($self);
 375 }
 376
 377 =method path
 378
 379     $string = $group->path;
 380
 381 Get a string representation of a group's lineage. This is used as the substitution value for the
 382 C<{GROUP_PATH}> placeholder. See L<File::KDBX::Entry/Placeholders>.
 383
 384 For a root group, the path is simply the name of the group. For deeper groups, the path is a period-separated
 385 sequence of group names between the root group and C<$group>, including C<$group> but I<not> the root group.
 386 In other words, paths of deeper groups leave the root group name out.
 387
 388     Database
 389     -> Root         # path is "Root"
 390        -> Foo       # path is "Foo"
 391           -> Bar    # path is "Foo.Bar"
 392
 393 Yeah, it doesn't make much sense to me, either, but this matches the behavior of KeePass.
 394
 395 =cut
 396
 397 sub path {
 398     my $self = shift;
 399     return $self->name if $self->is_root;
 400     my $lineage = $self->lineage or return;
 401     my @parts = (@$lineage, $self);
 402     shift @parts;
 403     return join('.', map { $_->name } @parts);
 404 }
 405
 406 =method size
 407
 408     $size = $group->size;
 409
 410 Get the size (in bytes) of a group, including the size of all subroups and entries, if any.
 411
 412 =cut
 413
 414 sub size {
 415     my $self = shift;
 416     return sum0 map { $_->size } @{$self->groups}, @{$self->entries};
 417 }
 418
 419 =method depth
 420
 421     $depth = $group->depth;
 422
 423 Get the depth of a group within a database. The root group is at depth 0, its direct children are at depth 1,
 424 etc. A group not in a database tree structure returns a depth of -1.
 425
 426 =cut
 427
 428 sub depth { $_[0]->is_root ? 0 : (scalar @{$_[0]->lineage || []} || -1) }
 429
 430 sub label { shift->name(@_) }
 431
 432 sub _signal {
 433     my $self = shift;
 434     my $type = shift;
 435     return $self->SUPER::_signal("group.$type", @_);
 436 }
 437
 438 sub _commit {
 439     my $self = shift;
 440     my $time = gmtime;
 441     $self->last_modification_time($time);
 442     $self->last_access_time($time);
 443 }
 444
 445 sub effective_default_auto_type_sequence {
 446     my $self = shift;
 447     my $sequence = $self->default_auto_type_sequence;
 448     return $sequence if defined $sequence;
 449
 450     my $parent = $self->parent or return '{USERNAME}{TAB}{PASSWORD}{ENTER}';
 451     return $parent->effective_default_auto_type_sequence;
 452 }
 453
 454 sub effective_enable_auto_type {
 455     my $self = shift;
 456     my $enabled = $self->enable_auto_type;
 457     return $enabled if defined $enabled;
 458
 459     my $parent = $self->parent or return true;
 460     return $parent->effective_enable_auto_type;
 461 }
 462
 463 sub effective_enable_searching {
 464     my $self = shift;
 465     my $enabled = $self->enable_searching;
 466     return $enabled if defined $enabled;
 467
 468     my $parent = $self->parent or return true;
 469     return $parent->effective_enable_searching;
 470 }
 471
 472 1;
 473 __END__
 474
 475 =head1 DESCRIPTION
 476
 477 =attr uuid
 478
 479 =attr name
 480
 481 =attr notes
 482
 483 =attr tags
 484
 485 =attr icon_id
 486
 487 =attr custom_icon_uuid
 488
 489 =attr is_expanded
 490
 491 =attr default_auto_type_sequence
 492
 493 =attr enable_auto_type
 494
 495 =attr enable_searching
 496
 497 =attr last_top_visible_entry
 498
 499 =attr custom_data
 500
 501 =attr previous_parent_group
 502
 503 =attr entries
 504
 505 =attr groups
 506
 507 =attr last_modification_time
 508
 509 =attr creation_time
 510
 511 =attr last_access_time
 512
 513 =attr expiry_time
 514
 515 =attr expires
 516
 517 =attr usage_count
 518
 519 =attr location_changed
 520
 521 Get or set various group fields.
 522
 523 =cut