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