X-Git-Url: https://git.dogcows.com/gitweb?a=blobdiff_plain;f=lib%2FFile%2FKDBX%2FGroup.pm;h=3b8b458ada0fccfaced3a9390f14b632cf7e4255;hb=331a54019664704eb4a10186cb4abd7a2a722f30;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..3b8b458 100644 --- a/lib/File/KDBX/Group.pm +++ b/lib/File/KDBX/Group.pm @@ -7,66 +7,51 @@ use strict; use Devel::GlobalDestruction; use File::KDBX::Constants qw(:icon); 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 +sub _parent_container { 'groups' } + +# 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 +60,210 @@ 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(@_) } +############################################################################## 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; } -sub groups { +sub entries_deeply { my $self = shift; - my $groups = $self->{groups} //= []; - @$groups = map { File::KDBX::Group->wrap($_, $self->kdbx) } @$groups; - return $groups; + my %args = @_; + + my $searching = delete $args{searching}; + my $auto_type = delete $args{auto_type}; + my $history = delete $args{history}; + + my $groups = $self->groups_deeply(%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; + }); } -sub _kpx_groups { shift->groups(@_) } +=method add_entry -sub all_groups { + $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; - return $self->kdbx->all_groups(base => $self, include_base => false); + 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); } -sub all_entries { +sub remove_entry { my $self = shift; - return $self->kdbx->all_entries(base => $self); + my $uuid = is_ref($_[0]) ? $self->_wrap_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; + $o->_set_group(undef)->_signal('removed'); + return splice @$objects, $i, 1; + } } -sub _group { - my $self = shift; - my $group = shift; - return File::KDBX::Group->wrap($group, $self); -} +############################################################################## -sub _entry { - my $self = shift; - my $entry = shift; - require File::KDBX::Entry; - return File::KDBX::Entry->wrap($entry, $self); +sub groups { + my $self = shift; + my $groups = $self->{groups} //= []; + if (@$groups && !blessed($groups->[0])) { + @$groups = map { $self->_wrap_group($_, $self->kdbx) } @$groups; + } + assert { !any { !blessed $_ } @$groups }; + return $groups; } -sub add_entry { +sub groups_deeply { my $self = shift; - my $entry = shift; - push @{$self->{entries} ||= []}, $entry; - return $entry; + my %args = @_; + + my @groups = ($args{inclusive} // 1) ? $self : @{$self->groups}; + my $algo = lc($args{algorithm} || 'ids'); + + if ($algo eq '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 '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 _kpx_groups { shift->groups(@_) } + +=method add_group + + $new_group = $group->add_group($new_group); + $new_group = $group->add_group(%group_attributes); + +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 remove_group { my $self = shift; - my $group = shift; - push @{$self->{groups} ||= []}, $group; - return $group; + my $uuid = is_ref($_[0]) ? $self->_wrap_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; + $o->_set_group(undef)->_signal('removed'); + return splice @$objects, $i, 1; + } +} + +############################################################################## + +sub objects_deeply { + 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->groups_deeply(%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 +275,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,42 +294,116 @@ sub remove_object { return $self->remove_group($object, @_) || $self->remove_entry($object, @_); } -sub remove_group { - 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; - } -} +############################################################################## -sub remove_entry { +=method is_root + + $bool = $group->is_root; + +Determine if a group is the root group of its associated database. + +=cut + +sub is_root { 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 $kdbx = eval { $self->kdbx } or return; + return Hash::Util::FieldHash::id($kdbx->root) == 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; - my $lineage = $self->kdbx->trace_lineage($self) or return; - return join('.', map { $_->name } @$lineage); + 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 + + $size = $group->size; + +Get the size (in bytes) of a group, including the size of all subroups and entries, if any. + +=cut + sub size { my $self = shift; return sum0 map { $_->size } @{$self->groups}, @{$self->entries}; } -sub level { $_[0]->kdbx->group_level($_[0]) } +=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 + +sub depth { $_[0]->is_root ? 0 : (scalar @{$_[0]->lineage || []} || -1) } + +sub label { shift->name(@_) } + +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 effective_default_auto_type_sequence { + my $self = shift; + my $sequence = $self->default_auto_type_sequence; + return $sequence if defined $sequence; + + my $parent = $self->parent or return '{USERNAME}{TAB}{PASSWORD}{ENTER}'; + return $parent->effective_default_auto_type_sequence; +} -sub TO_JSON { +{%{$_[0]}} } +sub effective_enable_auto_type { + my $self = shift; + my $enabled = $self->enable_auto_type; + return $enabled if defined $enabled; + + my $parent = $self->parent or return true; + return $parent->effective_enable_auto_type; +} + +sub effective_enable_searching { + my $self = shift; + my $enabled = $self->enable_searching; + return $enabled if defined $enabled; + + my $parent = $self->parent or return true; + return $parent->effective_enable_searching; +} 1; __END__