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