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