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(:icon);
   9 use File::KDBX::Error;
  10 use File::KDBX::Util qw(:class :coercion generate_uuid);
  11 use Hash::Util::FieldHash;
  12 use List::Util qw(sum0);
  13 use Ref::Util qw(is_coderef is_ref);
  14 use Scalar::Util qw(blessed);
  15 use Time::Piece;
  16 use boolean;
  17 use namespace::clean;
  18
  19 extends 'File::KDBX::Object';
  20
  21 our $VERSION = '999.999'; # VERSION
  22
  23 sub _parent_container { 'groups' }
  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 sub entries {
  70     my $self = shift;
  71     my $entries = $self->{entries} //= [];
  72     # FIXME - Looping through entries on each access is too expensive.
  73     @$entries = map { $self->_wrap_entry($_, $self->kdbx) } @$entries;
  74     return $entries;
  75 }
  76
  77 sub all_entries {
  78     my $self = shift;
  79     # FIXME - shouldn't have to delegate to the database to get this
  80     return $self->kdbx->all_entries(base => $self);
  81 }
  82
  83 =method add_entry
  84
  85     $entry = $group->add_entry($entry);
  86     $entry = $group->add_entry(%entry_attributes);
  87
  88 Add an entry to a group. If C<$entry> already has a parent group, it will be removed from that group before
  89 being added to C<$group>.
  90
  91 =cut
  92
  93 sub add_entry {
  94     my $self = shift;
  95     my $entry   = @_ % 2 == 1 ? shift : undef;
  96     my %args    = @_;
  97
  98     my $kdbx = delete $args{kdbx} // eval { $self->kdbx };
  99
 100     $entry = $self->_wrap_entry($entry // [%args]);
 101     $entry->uuid;
 102     $entry->kdbx($kdbx) if $kdbx;
 103
 104     push @{$self->{entries} ||= []}, $entry->remove;
 105     return $entry->_set_group($self)->_signal('added', $self);
 106 }
 107
 108 sub remove_entry {
 109     my $self = shift;
 110     my $uuid = is_ref($_[0]) ? $self->_wrap_entry(shift)->uuid : shift;
 111     my $objects = $self->{entries};
 112     for (my $i = 0; $i < @$objects; ++$i) {
 113         my $o = $objects->[$i];
 114         next if $uuid ne $o->uuid;
 115         $o->_set_group(undef)->_signal('removed');
 116         return splice @$objects, $i, 1;
 117     }
 118 }
 119
 120 ##############################################################################
 121
 122 sub groups {
 123     my $self = shift;
 124     my $groups = $self->{groups} //= [];
 125     # FIXME - Looping through groups on each access is too expensive.
 126     @$groups = map { $self->_wrap_group($_, $self->kdbx) } @$groups;
 127     return $groups;
 128 }
 129
 130 =method all_groups
 131
 132     \@groups = $group->all_groups(%options);
 133
 134 Get all groups within a group, deeply, in a flat array. Supported options:
 135
 136 =cut
 137
 138 sub all_groups {
 139     my $self = shift;
 140
 141     my @groups;
 142     for my $subgroup (@{$self->groups}) {
 143         push @groups, @{$subgroup->all_groups};
 144     }
 145
 146     return \@groups;
 147 }
 148
 149 =method find_groups
 150
 151     @groups = $kdbx->find_groups($query, %options);
 152
 153 Find all groups deeply that match to a query. Options are the same as for L</all_groups>.
 154
 155 See L</QUERY> for a description of what C<$query> can be.
 156
 157 =cut
 158
 159 sub find_groups {
 160     my $self = shift;
 161     my $query = shift or throw 'Must provide a query';
 162     my %args = @_;
 163     my %all_groups = ( # FIXME
 164         base        => $args{base},
 165         inclusive   => $args{inclusive},
 166     );
 167     return @{search($self->all_groups(%all_groups), is_arrayref($query) ? @$query : $query)};
 168 }
 169
 170 sub _kpx_groups { shift->groups(@_) }
 171
 172 =method add_group
 173
 174     $new_group = $group->add_group($new_group);
 175     $new_group = $group->add_group(%group_attributes);
 176
 177 Add a group to a group. If C<$new_group> already has a parent group, it will be removed from that group before
 178 being added to C<$group>.
 179
 180 =cut
 181
 182 sub add_group {
 183     my $self    = shift;
 184     my $group   = @_ % 2 == 1 ? shift : undef;
 185     my %args    = @_;
 186
 187     my $kdbx = delete $args{kdbx} // eval { $self->kdbx };
 188
 189     $group = $self->_wrap_group($group // [%args]);
 190     $group->uuid;
 191     $group->kdbx($kdbx) if $kdbx;
 192
 193     push @{$self->{groups} ||= []}, $group->remove;
 194     return $group->_set_group($self)->_signal('added', $self);
 195 }
 196
 197 sub remove_group {
 198     my $self = shift;
 199     my $uuid = is_ref($_[0]) ? $self->_wrap_group(shift)->uuid : shift;
 200     my $objects = $self->{groups};
 201     for (my $i = 0; $i < @$objects; ++$i) {
 202         my $o = $objects->[$i];
 203         next if $uuid ne $o->uuid;
 204         $o->_set_group(undef)->_signal('removed');
 205         return splice @$objects, $i, 1;
 206     }
 207 }
 208
 209 ##############################################################################
 210
 211 =method add_object
 212
 213     $new_entry = $group->add_object($new_entry);
 214     $new_group = $group->add_object($new_group);
 215
 216 Add an object (either a L<File::KDBX::Entry> or a L<File::KDBX::Group>) to a group. This is the generic
 217 equivalent of the object forms of L</add_entry> and L</add_group>.
 218
 219 =cut
 220
 221 sub add_object {
 222     my $self = shift;
 223     my $obj  = shift;
 224     if ($obj->isa('File::KDBX::Entry')) {
 225         $self->add_entry($obj);
 226     }
 227     elsif ($obj->isa('File::KDBX::Group')) {
 228         $self->add_group($obj);
 229     }
 230 }
 231
 232 =method remove_object
 233
 234     $group->remove_object($entry);
 235     $group->remove_object($group);
 236
 237 Remove an object (either a L<File::KDBX::Entry> or a L<File::KDBX::Group>) from a group. This is the generic
 238 equivalent of the object forms of L</remove_entry> and L</remove_group>.
 239
 240 =cut
 241
 242 sub remove_object {
 243     my $self = shift;
 244     my $object = shift;
 245     my $blessed = blessed($object);
 246     return $self->remove_group($object, @_) if $blessed && $object->isa('File::KDBX::Group');
 247     return $self->remove_entry($object, @_) if $blessed && $object->isa('File::KDBX::Entry');
 248     return $self->remove_group($object, @_) || $self->remove_entry($object, @_);
 249 }
 250
 251 ##############################################################################
 252
 253 =method is_root
 254
 255     $bool = $group->is_root;
 256
 257 Determine if a group is the root group of its associated database.
 258
 259 =cut
 260
 261 sub is_root {
 262     my $self = shift;
 263     my $kdbx = eval { $self->kdbx } or return;
 264     return Hash::Util::FieldHash::id($kdbx->root) == Hash::Util::FieldHash::id($self);
 265 }
 266
 267 =method path
 268
 269     $string = $group->path;
 270
 271 Get a string representation of a group's lineage. This is used as the substitution value for the
 272 C<{GROUP_PATH}> placeholder. See L<File::KDBX::Entry/Placeholders>.
 273
 274 For a root group, the path is simply the name of the group. For deeper groups, the path is a period-separated
 275 sequence of group names between the root group and C<$group>, including C<$group> but I<not> the root group.
 276 In other words, paths of deeper groups leave the root group name out.
 277
 278     Database
 279     -> Root         # path is "Root"
 280        -> Foo       # path is "Foo"
 281           -> Bar    # path is "Foo.Bar"
 282
 283 Yeah, it doesn't make much sense to me, either, but this matches the behavior of KeePass.
 284
 285 =cut
 286
 287 sub path {
 288     my $self = shift;
 289     return $self->name if $self->is_root;
 290     my $lineage = $self->lineage or return;
 291     my @parts = (@$lineage, $self);
 292     shift @parts;
 293     return join('.', map { $_->name } @parts);
 294 }
 295
 296 =method size
 297
 298     $size = $group->size;
 299
 300 Get the size (in bytes) of a group, including the size of all subroups and entries, if any.
 301
 302 =cut
 303
 304 sub size {
 305     my $self = shift;
 306     return sum0 map { $_->size } @{$self->groups}, @{$self->entries};
 307 }
 308
 309 =method depth
 310
 311     $depth = $group->depth;
 312
 313 Get the depth of a group within a database. The root group is at depth 0, its direct children are at depth 1,
 314 etc. A group not in a database tree structure returns a depth of -1.
 315
 316 =cut
 317
 318 sub depth { $_[0]->is_root ? 0 : (scalar @{$_[0]->lineage || []} || -1) }
 319
 320 sub label { shift->name(@_) }
 321
 322 sub _signal {
 323     my $self = shift;
 324     my $type = shift;
 325     return $self->SUPER::_signal("group.$type", @_);
 326 }
 327
 328 sub _commit {
 329     my $self = shift;
 330     my $time = gmtime;
 331     $self->last_modification_time($time);
 332     $self->last_access_time($time);
 333 }
 334
 335 sub effective_default_auto_type_sequence {
 336     my $self = shift;
 337     my $sequence = $self->default_auto_type_sequence;
 338     return $sequence if defined $sequence;
 339
 340     my $parent = $self->parent or return '{USERNAME}{TAB}{PASSWORD}{ENTER}';
 341     return $parent->effective_default_auto_type_sequence;
 342 }
 343
 344 sub effective_enable_auto_type {
 345     my $self = shift;
 346     my $enabled = $self->enable_auto_type;
 347     return $enabled if defined $enabled;
 348
 349     my $parent = $self->parent or return true;
 350     return $parent->effective_enable_auto_type;
 351 }
 352
 353 sub effective_enable_searching {
 354     my $self = shift;
 355     my $enabled = $self->enable_searching;
 356     return $enabled if defined $enabled;
 357
 358     my $parent = $self->parent or return true;
 359     return $parent->effective_enable_searching;
 360 }
 361
 362 1;
 363 __END__
 364
 365 =head1 DESCRIPTION
 366
 367 =attr uuid
 368
 369 =attr name
 370
 371 =attr notes
 372
 373 =attr tags
 374
 375 =attr icon_id
 376
 377 =attr custom_icon_uuid
 378
 379 =attr is_expanded
 380
 381 =attr default_auto_type_sequence
 382
 383 =attr enable_auto_type
 384
 385 =attr enable_searching
 386
 387 =attr last_top_visible_entry
 388
 389 =attr custom_data
 390
 391 =attr previous_parent_group
 392
 393 =attr entries
 394
 395 =attr groups
 396
 397 =attr last_modification_time
 398
 399 =attr creation_time
 400
 401 =attr last_access_time
 402
 403 =attr expiry_time
 404
 405 =attr expires
 406
 407 =attr usage_count
 408
 409 =attr location_changed
 410
 411 Get or set various group fields.
 412
 413 =cut