X-Git-Url: https://git.dogcows.com/gitweb?a=blobdiff_plain;f=lib%2FFile%2FKDBX%2FGroup.pm;h=9ef603b891c58bc286c0b7e96126f2ae1b15b22e;hb=b334578b1eb03deabcdcc02f324e7d2323c7965e;hp=733e931217040bdde6149717b85e9c871641c872;hpb=f63182fc62b25269b1c38588dca2b3535ed1a1a2;p=chaz%2Fp5-File-KDBX diff --git a/lib/File/KDBX/Group.pm b/lib/File/KDBX/Group.pm index 733e931..9ef603b 100644 --- a/lib/File/KDBX/Group.pm +++ b/lib/File/KDBX/Group.pm @@ -5,68 +5,89 @@ use warnings; use strict; use Devel::GlobalDestruction; -use File::KDBX::Constants qw(:icon); +use File::KDBX::Constants qw(:bool :icon :iteration); use File::KDBX::Error; -use File::KDBX::Util qw(generate_uuid); -use List::Util qw(sum0); -use Ref::Util qw(is_ref); +use File::KDBX::Iterator; +use File::KDBX::Util qw(:assert :class :coercion generate_uuid); +use Hash::Util::FieldHash; +use List::Util qw(any sum0); +use Ref::Util qw(is_coderef is_ref); use Scalar::Util qw(blessed); use Time::Piece; use boolean; use namespace::clean; -use parent 'File::KDBX::Object'; +extends 'File::KDBX::Object'; our $VERSION = '999.999'; # VERSION +=attr name + +The human-readable name of the group. + +=attr notes + +Free form text string associated with the group. + +=attr is_expanded + +Whether or not subgroups are visible when listed for user selection. + +=attr default_auto_type_sequence + +The default auto-type keystroke sequence, inheritable by entries and subgroups. + +=attr enable_auto_type + +Whether or not the entry is eligible to be matched for auto-typing, inheritable by entries and subgroups. + +=attr enable_searching + +Whether or not entries within the group can show up in search results, inheritable by subgroups. + +=attr last_top_visible_entry + +The UUID of the entry visible at the top of the list. + +=attr entries + +Array of entries contained within the group. + +=attr groups + +Array of subgroups contained within the group. + +=cut + +# has uuid => sub { generate_uuid(printable => 1) }; +has name => '', coerce => \&to_string; +has notes => '', coerce => \&to_string; +has tags => '', coerce => \&to_string; +has icon_id => ICON_FOLDER, coerce => \&to_icon_constant; +has custom_icon_uuid => undef, coerce => \&to_uuid; +has is_expanded => false, coerce => \&to_bool; +has default_auto_type_sequence => '', coerce => \&to_string; +has enable_auto_type => undef, coerce => \&to_tristate; +has enable_searching => undef, coerce => \&to_tristate; +has last_top_visible_entry => undef, coerce => \&to_uuid; +# has custom_data => {}; +has previous_parent_group => undef, coerce => \&to_uuid; +# has entries => []; +# has groups => []; +has times => {}; + +has last_modification_time => sub { gmtime }, store => 'times', coerce => \&to_time; +has creation_time => sub { gmtime }, store => 'times', coerce => \&to_time; +has last_access_time => sub { gmtime }, store => 'times', coerce => \&to_time; +has expiry_time => sub { gmtime }, store => 'times', coerce => \&to_time; +has expires => false, store => 'times', coerce => \&to_bool; +has usage_count => 0, store => 'times', coerce => \&to_number; +has location_changed => sub { gmtime }, store => 'times', coerce => \&to_time; + my @ATTRS = qw(uuid custom_data entries groups); -my %ATTRS = ( - # uuid => sub { generate_uuid(printable => 1) }, - name => '', - notes => '', - tags => '', - icon_id => ICON_FOLDER, - custom_icon_uuid => undef, - is_expanded => false, - default_auto_type_sequence => '', - enable_auto_type => undef, - enable_searching => undef, - last_top_visible_entry => undef, - # custom_data => sub { +{} }, - previous_parent_group => undef, - # entries => sub { +[] }, - # groups => sub { +[] }, -); -my %ATTRS_TIMES = ( - last_modification_time => sub { gmtime }, - creation_time => sub { gmtime }, - last_access_time => sub { gmtime }, - expiry_time => sub { gmtime }, - expires => false, - usage_count => 0, - location_changed => sub { gmtime }, -); - -while (my ($attr, $default) = each %ATTRS) { - no strict 'refs'; ## no critic (ProhibitNoStrict) - *{$attr} = sub { - my $self = shift; - $self->{$attr} = shift if @_; - $self->{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default; - }; -} -while (my ($attr, $default) = each %ATTRS_TIMES) { - no strict 'refs'; ## no critic (ProhibitNoStrict) - *{$attr} = sub { - my $self = shift; - $self->{times}{$attr} = shift if @_; - $self->{times}{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default; - }; -} - -sub _set_default_attributes { - my $self = shift; - $self->$_ for @ATTRS, keys %ATTRS, keys %ATTRS_TIMES; +sub _set_nonlazy_attributes { + my $self = shift; + $self->$_ for @ATTRS, list_attributes(ref $self); } sub uuid { @@ -75,69 +96,284 @@ sub uuid { my %args = @_ % 2 == 1 ? (uuid => shift, @_) : @_; my $old_uuid = $self->{uuid}; my $uuid = $self->{uuid} = delete $args{uuid} // generate_uuid; - # if (defined $old_uuid and my $kdbx = $KDBX{refaddr($self)}) { - # $kdbx->_update_group_uuid($old_uuid, $uuid, $self); - # } + $self->_signal('uuid.changed', $uuid, $old_uuid) if defined $old_uuid; } $self->{uuid}; } -sub label { shift->name(@_) } +############################################################################## + +=method entries + + \@entries = $group->entries; + +Get an array of direct child entries within a group. + +=cut sub entries { my $self = shift; my $entries = $self->{entries} //= []; - require File::KDBX::Entry; - @$entries = map { File::KDBX::Entry->wrap($_, $self->kdbx) } @$entries; + if (@$entries && !blessed($entries->[0])) { + @$entries = map { $self->_wrap_entry($_, $self->kdbx) } @$entries; + } + assert { !any { !blessed $_ } @$entries }; return $entries; } +=method all_entries + + \&iterator = $kdbx->all_entries(%options); + +Get an L over I within a group. Supports the same options as L, +plus some new ones: + +=for :list +* C - Only include entries with auto-type enabled (default: false, include all) +* C - Only include entries within groups with searching enabled (default: false, include all) +* C - Also include historical entries (default: false, include only current entries) + +=cut + +sub all_entries { + my $self = shift; + my %args = @_; + + my $searching = delete $args{searching}; + my $auto_type = delete $args{auto_type}; + my $history = delete $args{history}; + + my $groups = $self->all_groups(%args); + my @entries; + + return File::KDBX::Iterator->new(sub { + if (!@entries) { + while (my $group = $groups->next) { + next if $searching && !$group->effective_enable_searching; + next if $auto_type && !$group->effective_enable_auto_type; + @entries = @{$group->entries}; + @entries = grep { $_->auto_type->{enabled} } @entries if $auto_type; + @entries = map { ($_, @{$_->history}) } @entries if $history; + last if @entries; + } + } + shift @entries; + }); +} + +=method add_entry + + $entry = $group->add_entry($entry); + $entry = $group->add_entry(%entry_attributes); + +Add an entry to a group. If C<$entry> already has a parent group, it will be removed from that group before +being added to C<$group>. + +=cut + +sub add_entry { + my $self = shift; + my $entry = @_ % 2 == 1 ? shift : undef; + my %args = @_; + + my $kdbx = delete $args{kdbx} // eval { $self->kdbx }; + + $entry = $self->_wrap_entry($entry // [%args]); + $entry->uuid; + $entry->kdbx($kdbx) if $kdbx; + + push @{$self->{entries} ||= []}, $entry->remove; + return $entry->_set_group($self)->_signal('added', $self); +} + +=method remove_entry + + $entry = $group->remove_entry($entry); + $entry = $group->remove_entry($entry_uuid); + +Remove an entry from a group's array of entries. Returns the entry removed or C if nothing removed. + +=cut + +sub remove_entry { + my $self = shift; + my $uuid = is_ref($_[0]) ? $self->_wrap_entry(shift)->uuid : shift; + my %args = @_; + my $objects = $self->{entries}; + for (my $i = 0; $i < @$objects; ++$i) { + my $object = $objects->[$i]; + next if $uuid ne $object->uuid; + $object->_set_group(undef); + $object->_signal('removed') if $args{signal} // 1; + return splice @$objects, $i, 1; + } +} + +############################################################################## + +=method groups + + \@groups = $group->groups; + +Get an array of direct subgroups within a group. + +=cut + sub groups { my $self = shift; my $groups = $self->{groups} //= []; - @$groups = map { File::KDBX::Group->wrap($_, $self->kdbx) } @$groups; + if (@$groups && !blessed($groups->[0])) { + @$groups = map { $self->_wrap_group($_, $self->kdbx) } @$groups; + } + assert { !any { !blessed $_ } @$groups }; return $groups; } -sub _kpx_groups { shift->groups(@_) } +=method all_groups + + \&iterator = $group->all_groups(%options); + +Get an L over I within a groups, deeply. Options: + +=for :list +* C - Include C<$group> itself in the results (default: true) +* C - Search algorithm, one of C, C or C (default: C) + +=cut sub all_groups { my $self = shift; - return $self->kdbx->all_groups(base => $self, include_base => false); + my %args = @_; + + my @groups = ($args{inclusive} // 1) ? $self : @{$self->groups}; + my $algo = lc($args{algorithm} || 'ids'); + + if ($algo eq ITERATION_DFS) { + my %visited; + return File::KDBX::Iterator->new(sub { + my $next = shift @groups or return; + if (!$visited{Hash::Util::FieldHash::id($next)}++) { + while (my @children = @{$next->groups}) { + unshift @groups, @children, $next; + $next = shift @groups; + $visited{Hash::Util::FieldHash::id($next)}++; + } + } + $next; + }); + } + elsif ($algo eq ITERATION_BFS) { + return File::KDBX::Iterator->new(sub { + my $next = shift @groups or return; + push @groups, @{$next->groups}; + $next; + }); + } + return File::KDBX::Iterator->new(sub { + my $next = shift @groups or return; + unshift @groups, @{$next->groups}; + $next; + }); } -sub all_entries { - my $self = shift; - return $self->kdbx->all_entries(base => $self); -} +sub _kpx_groups { shift->groups(@_) } -sub _group { - my $self = shift; - my $group = shift; - return File::KDBX::Group->wrap($group, $self); -} +=method add_group + + $new_group = $group->add_group($new_group); + $new_group = $group->add_group(%group_attributes); -sub _entry { - my $self = shift; - my $entry = shift; - require File::KDBX::Entry; - return File::KDBX::Entry->wrap($entry, $self); +Add a group to a group. If C<$new_group> already has a parent group, it will be removed from that group before +being added to C<$group>. + +=cut + +sub add_group { + my $self = shift; + my $group = @_ % 2 == 1 ? shift : undef; + my %args = @_; + + my $kdbx = delete $args{kdbx} // eval { $self->kdbx }; + + $group = $self->_wrap_group($group // [%args]); + $group->uuid; + $group->kdbx($kdbx) if $kdbx; + + push @{$self->{groups} ||= []}, $group->remove; + return $group->_set_group($self)->_signal('added', $self); } -sub add_entry { +=method remove_group + + $removed_group = $group->remove_group($group); + $removed_group = $group->remove_group($group_uuid); + +Remove a group from a group's array of subgroups. Returns the group removed or C if nothing removed. + +=cut + +sub remove_group { my $self = shift; - my $entry = shift; - push @{$self->{entries} ||= []}, $entry; - return $entry; + my $uuid = is_ref($_[0]) ? $self->_wrap_group(shift)->uuid : shift; + my %args = @_; + my $objects = $self->{groups}; + for (my $i = 0; $i < @$objects; ++$i) { + my $object = $objects->[$i]; + next if $uuid ne $object->uuid; + $object->_set_group(undef); + $object->_signal('removed') if $args{signal} // 1; + return splice @$objects, $i, 1; + } } -sub add_group { +############################################################################## + +=method all_objects + + \&iterator = $groups->all_objects(%options); + +Get an L over I within a group, deeply. Groups and entries are considered +objects, so this is essentially a combination of L and L. This won't often be useful, but +it can be convenient for maintenance tasks. This method takes the same options as L and L. + +=cut + +sub all_objects { my $self = shift; - my $group = shift; - push @{$self->{groups} ||= []}, $group; - return $group; + my %args = @_; + + my $searching = delete $args{searching}; + my $auto_type = delete $args{auto_type}; + my $history = delete $args{history}; + + my $groups = $self->all_groups(%args); + my @entries; + + return File::KDBX::Iterator->new(sub { + if (!@entries) { + while (my $group = $groups->next) { + next if $searching && !$group->effective_enable_searching; + next if $auto_type && !$group->effective_enable_auto_type; + @entries = @{$group->entries}; + @entries = grep { $_->auto_type->{enabled} } @entries if $auto_type; + @entries = map { ($_, @{$_->history}) } @entries if $history; + return $group; + } + } + shift @entries; + }); } +=method add_object + + $new_entry = $group->add_object($new_entry); + $new_group = $group->add_object($new_group); + +Add an object (either a L or a L) to a group. This is the generic +equivalent of the object forms of L and L. + +=cut + sub add_object { my $self = shift; my $obj = shift; @@ -149,6 +385,16 @@ sub add_object { } } +=method remove_object + + $group->remove_object($entry); + $group->remove_object($group); + +Remove an object (either a L or a L) from a group. This is the generic +equivalent of the object forms of L and L. + +=cut + sub remove_object { my $self = shift; my $object = shift; @@ -158,92 +404,236 @@ sub remove_object { return $self->remove_group($object, @_) || $self->remove_entry($object, @_); } -sub remove_group { +############################################################################## + +=method effective_default_auto_type_sequence + + $text = $group->effective_default_auto_type_sequence; + +Get the value of L, if set, or get the inherited effective default auto-type +sequence of the parent. + +=cut + +sub effective_default_auto_type_sequence { my $self = shift; - my $uuid = is_ref($_[0]) ? $self->_group(shift)->uuid : shift; - my $objects = $self->{groups}; - for (my $i = 0; $i < @$objects; ++$i) { - my $o = $objects->[$i]; - next if $uuid ne $o->uuid; - return splice @$objects, $i, 1; - } + my $sequence = $self->default_auto_type_sequence; + return $sequence if defined $sequence; + + my $parent = $self->group or return '{USERNAME}{TAB}{PASSWORD}{ENTER}'; + return $parent->effective_default_auto_type_sequence; } -sub remove_entry { +=method effective_enable_auto_type + + $text = $group->effective_enable_auto_type; + +Get the value of L, if set, or get the inherited effective auto-type enabled value of the +parent. + +=cut + +sub effective_enable_auto_type { my $self = shift; - my $uuid = is_ref($_[0]) ? $self->_entry(shift)->uuid : shift; - my $objects = $self->{entries}; - for (my $i = 0; $i < @$objects; ++$i) { - my $o = $objects->[$i]; - next if $uuid ne $o->uuid; - return splice @$objects, $i, 1; - } + my $enabled = $self->enable_auto_type; + return $enabled if defined $enabled; + + my $parent = $self->group or return true; + return $parent->effective_enable_auto_type; } -sub path { +=method effective_enable_searching + + $text = $group->effective_enable_searching; + +Get the value of L, if set, or get the inherited effective searching enabled value of the +parent. + +=cut + +sub effective_enable_searching { my $self = shift; - my $lineage = $self->kdbx->trace_lineage($self) or return; - return join('.', map { $_->name } @$lineage); + my $enabled = $self->enable_searching; + return $enabled if defined $enabled; + + my $parent = $self->group or return true; + return $parent->effective_enable_searching; } -sub size { +############################################################################## + +=method is_empty + + $bool = $group->is_empty; + +Get whether or not the group is empty (has no subgroups or entries). + +=cut + +sub is_empty { my $self = shift; - return sum0 map { $_->size } @{$self->groups}, @{$self->entries}; + return @{$self->groups} == 0 && @{$self->entries} == 0; } -sub level { $_[0]->kdbx->group_level($_[0]) } +=method is_root -sub TO_JSON { +{%{$_[0]}} } + $bool = $group->is_root; -1; -__END__ +Determine if a group is the root group of its connected database. -=head1 DESCRIPTION +=cut -=attr uuid +sub is_root { + my $self = shift; + my $kdbx = eval { $self->kdbx } or return FALSE; + return Hash::Util::FieldHash::id($kdbx->root) == Hash::Util::FieldHash::id($self); +} -=attr name +=method is_recycle_bin -=attr notes + $bool = $group->is_recycle_bin; -=attr tags +Get whether or not a group is the recycle bin of its connected database. -=attr icon_id +=cut -=attr custom_icon_uuid +sub is_recycle_bin { + my $self = shift; + my $kdbx = eval { $self->kdbx } or return FALSE; + my $group = $kdbx->recycle_bin; + return $group && Hash::Util::FieldHash::id($group) == Hash::Util::FieldHash::id($self); +} -=attr is_expanded +=method is_entry_templates -=attr default_auto_type_sequence + $bool = $group->is_entry_templates; -=attr enable_auto_type +Get whether or not a group is the group containing entry template in its connected database. -=attr enable_searching +=cut -=attr last_top_visible_entry +sub is_entry_templates { + my $self = shift; + my $kdbx = eval { $self->kdbx } or return FALSE; + my $group = $kdbx->entry_templates; + return $group && Hash::Util::FieldHash::id($group) == Hash::Util::FieldHash::id($self); +} -=attr custom_data +=method is_last_selected -=attr previous_parent_group + $bool = $group->is_last_selected; -=attr entries +Get whether or not a group is the prior selected group of its connected database. -=attr groups +=cut + +sub is_last_selected { + my $self = shift; + my $kdbx = eval { $self->kdbx } or return FALSE; + my $group = $kdbx->last_selected; + return $group && Hash::Util::FieldHash::id($group) == Hash::Util::FieldHash::id($self); +} + +=method is_last_top_visible + + $bool = $group->is_last_top_visible; + +Get whether or not a group is the latest top visible group of its connected database. + +=cut + +sub is_last_top_visible { + my $self = shift; + my $kdbx = eval { $self->kdbx } or return FALSE; + my $group = $kdbx->last_top_visible; + return $group && Hash::Util::FieldHash::id($group) == Hash::Util::FieldHash::id($self); +} + +=method path + + $string = $group->path; + +Get a string representation of a group's lineage. This is used as the substitution value for the +C<{GROUP_PATH}> placeholder. See L. + +For a root group, the path is simply the name of the group. For deeper groups, the path is a period-separated +sequence of group names between the root group and C<$group>, including C<$group> but I the root group. +In other words, paths of deeper groups leave the root group name out. + + Database + -> Root # path is "Root" + -> Foo # path is "Foo" + -> Bar # path is "Foo.Bar" + +Yeah, it doesn't make much sense to me, either, but this matches the behavior of KeePass. + +=cut + +sub path { + my $self = shift; + return $self->name if $self->is_root; + my $lineage = $self->lineage or return; + my @parts = (@$lineage, $self); + shift @parts; + return join('.', map { $_->name } @parts); +} + +=method size -=attr last_modification_time + $size = $group->size; -=attr creation_time +Get the size (in bytes) of a group, including the size of all subroups and entries, if any. -=attr last_access_time +=cut + +sub size { + my $self = shift; + return sum0 map { $_->size } @{$self->groups}, @{$self->entries}; +} + +=method depth + + $depth = $group->depth; + +Get the depth of a group within a database. The root group is at depth 0, its direct children are at depth 1, +etc. A group not in a database tree structure returns a depth of -1. + +=cut -=attr expiry_time +sub depth { $_[0]->is_root ? 0 : (scalar @{$_[0]->lineage || []} || -1) } -=attr expires +sub _signal { + my $self = shift; + my $type = shift; + return $self->SUPER::_signal("group.$type", @_); +} + +sub _commit { + my $self = shift; + my $time = gmtime; + $self->last_modification_time($time); + $self->last_access_time($time); +} + +sub label { shift->name(@_) } + +### Name of the parent attribute expected to contain the object +sub _parent_container { 'groups' } + +1; +__END__ + +=for Pod::Coverage times + +=head1 DESCRIPTION -=attr usage_count +A group in a KDBX database is a type of object that can contain entries and other groups. -=attr location_changed +There is also some metadata associated with a group. Each group in a database is identified uniquely by +a UUID. An entry can also have an icon associated with it, and there are various timestamps. Take a look at +the attributes to see what's available. -Get or set various group fields. +A B is a subclass of L. View its documentation to see other attributes +and methods available on groups. =cut