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(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 use parent 'File::KDBX::Object';
  20
  21 our $VERSION = '999.999'; # VERSION
  22
  23 sub _parent_container { 'groups' }
  24
  25 my @ATTRS = qw(uuid custom_data entries groups);
  26 my %ATTRS = (
  27     # uuid                        => sub { generate_uuid(printable => 1) },
  28     name                        => '',
  29     notes                       => '',
  30     tags                        => '',
  31     icon_id                     => sub { defined $_[1] ? icon($_[1]) : ICON_FOLDER },
  32     custom_icon_uuid            => undef,
  33     is_expanded                 => false,
  34     default_auto_type_sequence  => '',
  35     enable_auto_type            => undef,
  36     enable_searching            => undef,
  37     last_top_visible_entry      => undef,
  38     # custom_data                 => sub { +{} },
  39     previous_parent_group       => undef,
  40     # entries                     => sub { +[] },
  41     # groups                      => sub { +[] },
  42 );
  43 my %ATTRS_TIMES = (
  44     last_modification_time  => sub { scalar gmtime },
  45     creation_time           => sub { scalar gmtime },
  46     last_access_time        => sub { scalar gmtime },
  47     expiry_time             => sub { scalar gmtime },
  48     expires                 => false,
  49     usage_count             => 0,
  50     location_changed        => sub { scalar gmtime },
  51 );
  52
  53 while (my ($attr, $setter) = each %ATTRS) {
  54     no strict 'refs'; ## no critic (ProhibitNoStrict)
  55     *{$attr} = is_coderef $setter ? sub {
  56         my $self = shift;
  57         $self->{$attr} = $setter->($self, shift) if @_;
  58         $self->{$attr} //= $setter->($self);
  59     } : sub {
  60         my $self = shift;
  61         $self->{$attr} = shift if @_;
  62         $self->{$attr} //= $setter;
  63     };
  64 }
  65 while (my ($attr, $default) = each %ATTRS_TIMES) {
  66     no strict 'refs'; ## no critic (ProhibitNoStrict)
  67     *{$attr} = sub {
  68         my $self = shift;
  69         $self->{times}{$attr} = shift if @_;
  70         $self->{times}{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default;
  71     };
  72 }
  73
  74 sub _set_default_attributes {
  75     my $self = shift;
  76     $self->$_ for @ATTRS, keys %ATTRS, keys %ATTRS_TIMES;
  77 }
  78
  79 sub uuid {
  80     my $self = shift;
  81     if (@_ || !defined $self->{uuid}) {
  82         my %args = @_ % 2 == 1 ? (uuid => shift, @_) : @_;
  83         my $old_uuid = $self->{uuid};
  84         my $uuid = $self->{uuid} = delete $args{uuid} // generate_uuid;
  85         $self->_signal('uuid.changed', $uuid, $old_uuid) if defined $old_uuid;
  86     }
  87     $self->{uuid};
  88 }
  89
  90 ##############################################################################
  91
  92 sub entries {
  93     my $self = shift;
  94     my $entries = $self->{entries} //= [];
  95     # FIXME - Looping through entries on each access is too expensive.
  96     @$entries = map { $self->_wrap_entry($_, $self->kdbx) } @$entries;
  97     return $entries;
  98 }
  99
 100 sub all_entries {
 101     my $self = shift;
 102     # FIXME - shouldn't have to delegate to the database to get this
 103     return $self->kdbx->all_entries(base => $self);
 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);
 129 }
 130
 131 sub remove_entry {
 132     my $self = shift;
 133     my $uuid = is_ref($_[0]) ? $self->_wrap_entry(shift)->uuid : shift;
 134     my $objects = $self->{entries};
 135     for (my $i = 0; $i < @$objects; ++$i) {
 136         my $o = $objects->[$i];
 137         next if $uuid ne $o->uuid;
 138         return splice @$objects, $i, 1;
 139         $o->_set_group(undef);
 140         return @$objects, $i, 1;
 141     }
 142 }
 143
 144 ##############################################################################
 145
 146 sub groups {
 147     my $self = shift;
 148     my $groups = $self->{groups} //= [];
 149     # FIXME - Looping through groups on each access is too expensive.
 150     @$groups = map { $self->_wrap_group($_, $self->kdbx) } @$groups;
 151     return $groups;
 152 }
 153
 154 sub all_groups {
 155     my $self = shift;
 156     # FIXME - shouldn't have to delegate to the database to get this
 157     return $self->kdbx->all_groups(base => $self, include_base => false);
 158 }
 159
 160 sub _kpx_groups { shift->groups(@_) }
 161
 162 =method add_group
 163
 164     $new_group = $group->add_group($new_group);
 165     $new_group = $group->add_group(%group_attributes);
 166
 167 Add a group to a group. If C<$new_group> already has a parent group, it will be removed from that group before
 168 being added to C<$group>.
 169
 170 =cut
 171
 172 sub add_group {
 173     my $self    = shift;
 174     my $group   = @_ % 2 == 1 ? shift : undef;
 175     my %args    = @_;
 176
 177     my $kdbx = delete $args{kdbx} // eval { $self->kdbx };
 178
 179     $group = $self->_wrap_group($group // [%args]);
 180     $group->uuid;
 181     $group->kdbx($kdbx) if $kdbx;
 182
 183     push @{$self->{groups} ||= []}, $group->remove;
 184     return $group->_set_group($self);
 185 }
 186
 187 sub remove_group {
 188     my $self = shift;
 189     my $uuid = is_ref($_[0]) ? $self->_wrap_group(shift)->uuid : shift;
 190     my $objects = $self->{groups};
 191     for (my $i = 0; $i < @$objects; ++$i) {
 192         my $o = $objects->[$i];
 193         next if $uuid ne $o->uuid;
 194         $o->_set_group(undef);
 195         return splice @$objects, $i, 1;
 196     }
 197 }
 198
 199 ##############################################################################
 200
 201 =method add_object
 202
 203     $new_entry = $group->add_object($new_entry);
 204     $new_group = $group->add_object($new_group);
 205
 206 Add an object (either a L<File::KDBX::Entry> or a L<File::KDBX::Group>) to a group. This is the generic
 207 equivalent of the object forms of L</add_entry> and L</add_group>.
 208
 209 =cut
 210
 211 sub add_object {
 212     my $self = shift;
 213     my $obj  = shift;
 214     if ($obj->isa('File::KDBX::Entry')) {
 215         $self->add_entry($obj);
 216     }
 217     elsif ($obj->isa('File::KDBX::Group')) {
 218         $self->add_group($obj);
 219     }
 220 }
 221
 222 =method remove_object
 223
 224     $group->remove_object($entry);
 225     $group->remove_object($group);
 226
 227 Remove an object (either a L<File::KDBX::Entry> or a L<File::KDBX::Group>) from a group. This is the generic
 228 equivalent of the object forms of L</remove_entry> and L</remove_group>.
 229
 230 =cut
 231
 232 sub remove_object {
 233     my $self = shift;
 234     my $object = shift;
 235     my $blessed = blessed($object);
 236     return $self->remove_group($object, @_) if $blessed && $object->isa('File::KDBX::Group');
 237     return $self->remove_entry($object, @_) if $blessed && $object->isa('File::KDBX::Entry');
 238     return $self->remove_group($object, @_) || $self->remove_entry($object, @_);
 239 }
 240
 241 ##############################################################################
 242
 243 =method is_root
 244
 245     $bool = $group->is_root;
 246
 247 Determine if a group is the root group of its associated database.
 248
 249 =cut
 250
 251 sub is_root {
 252     my $self = shift;
 253     my $kdbx = eval { $self->kdbx } or return;
 254     return Hash::Util::FieldHash::id($kdbx->root) == Hash::Util::FieldHash::id($self);
 255 }
 256
 257 =method path
 258
 259     $string = $group->path;
 260
 261 Get a string representation of a group's lineage. This is used as the substitution value for the
 262 C<{GROUP_PATH}> placeholder. See L<File::KDBX::Entry/Placeholders>.
 263
 264 For a root group, the path is simply the name of the group. For deeper groups, the path is a period-separated
 265 sequence of group names between the root group and C<$group>, including C<$group> but I<not> the root group.
 266 In other words, paths of deeper groups leave the root group name out.
 267
 268     Database
 269     -> Root         # path is "Root"
 270        -> Foo       # path is "Foo"
 271           -> Bar    # path is "Foo.Bar"
 272
 273 Yeah, it doesn't make much sense to me, either, but this matches the behavior of KeePass.
 274
 275 =cut
 276
 277 sub path {
 278     my $self = shift;
 279     return $self->name if $self->is_root;
 280     my $lineage = $self->lineage or return;
 281     my @parts = (@$lineage, $self);
 282     shift @parts;
 283     return join('.', map { $_->name } @parts);
 284 }
 285
 286 =method size
 287
 288     $size = $group->size;
 289
 290 Get the size (in bytes) of a group, including the size of all subroups and entries, if any.
 291
 292 =cut
 293
 294 sub size {
 295     my $self = shift;
 296     return sum0 map { $_->size } @{$self->groups}, @{$self->entries};
 297 }
 298
 299 =method depth
 300
 301     $depth = $group->depth;
 302
 303 Get the depth of a group within a database. The root group is at depth 0, its direct children are at depth 1,
 304 etc. A group not in a database tree structure returns a depth of -1.
 305
 306 =cut
 307
 308 sub depth { $_[0]->is_root ? 0 : (scalar @{$_[0]->lineage || []} || -1) }
 309
 310 sub label { shift->name(@_) }
 311
 312 sub _signal {
 313     my $self = shift;
 314     my $type = shift;
 315     return $self->SUPER::_signal("group.$type", @_);
 316 }
 317
 318 sub _commit {
 319     my $self = shift;
 320     my $time = gmtime;
 321     $self->last_modification_time($time);
 322     $self->last_access_time($time);
 323 }
 324
 325 1;
 326 __END__
 327
 328 =head1 DESCRIPTION
 329
 330 =attr uuid
 331
 332 =attr name
 333
 334 =attr notes
 335
 336 =attr tags
 337
 338 =attr icon_id
 339
 340 =attr custom_icon_uuid
 341
 342 =attr is_expanded
 343
 344 =attr default_auto_type_sequence
 345
 346 =attr enable_auto_type
 347
 348 =attr enable_searching
 349
 350 =attr last_top_visible_entry
 351
 352 =attr custom_data
 353
 354 =attr previous_parent_group
 355
 356 =attr entries
 357
 358 =attr groups
 359
 360 =attr last_modification_time
 361
 362 =attr creation_time
 363
 364 =attr last_access_time
 365
 366 =attr expiry_time
 367
 368 =attr expires
 369
 370 =attr usage_count
 371
 372 =attr location_changed
 373
 374 Get or set various group fields.
 375
 376 =cut