]> Dogcows Code - chaz/p5-File-KDBX/blob - lib/File/KDBX/Group.pm
Remove objects from deleted objects when added
[chaz/p5-File-KDBX] / 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 include_base => $args{include_base},
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 1;
336 __END__
337
338 =head1 DESCRIPTION
339
340 =attr uuid
341
342 =attr name
343
344 =attr notes
345
346 =attr tags
347
348 =attr icon_id
349
350 =attr custom_icon_uuid
351
352 =attr is_expanded
353
354 =attr default_auto_type_sequence
355
356 =attr enable_auto_type
357
358 =attr enable_searching
359
360 =attr last_top_visible_entry
361
362 =attr custom_data
363
364 =attr previous_parent_group
365
366 =attr entries
367
368 =attr groups
369
370 =attr last_modification_time
371
372 =attr creation_time
373
374 =attr last_access_time
375
376 =attr expiry_time
377
378 =attr expires
379
380 =attr usage_count
381
382 =attr location_changed
383
384 Get or set various group fields.
385
386 =cut
This page took 0.065788 seconds and 4 git commands to generate.