From: Charles McGarvey Date: Wed, 27 Apr 2022 17:34:38 +0000 (-0600) Subject: Move iteration code into Group X-Git-Tag: v0.800~11 X-Git-Url: https://git.dogcows.com/gitweb?a=commitdiff_plain;h=331a54019664704eb4a10186cb4abd7a2a722f30;p=chaz%2Fp5-File-KDBX Move iteration code into Group --- diff --git a/lib/File/KDBX.pm b/lib/File/KDBX.pm index 54bb768..b69d556 100644 --- a/lib/File/KDBX.pm +++ b/lib/File/KDBX.pm @@ -8,7 +8,6 @@ use Crypt::PRNG qw(random_bytes); use Devel::GlobalDestruction; use File::KDBX::Constants qw(:all); use File::KDBX::Error; -use File::KDBX::Iterator; use File::KDBX::Safe; use File::KDBX::Util qw(:class :coercion :empty :search :uuid erase simple_expression_query snakify); use Hash::Util::FieldHash qw(fieldhashes); @@ -488,9 +487,9 @@ sub _trace_lineage { my $base = $lineage[-1] or return []; my $uuid = $object->uuid; - return \@lineage if any { $_->uuid eq $uuid } @{$base->groups || []}, @{$base->entries || []}; + return \@lineage if any { $_->uuid eq $uuid } @{$base->groups}, @{$base->entries}; - for my $subgroup (@{$base->groups || []}) { + for my $subgroup (@{$base->groups}) { my $result = $self->_trace_lineage($object, @lineage, $subgroup); return $result if $result; } @@ -548,37 +547,9 @@ Get an iterator over I within a database. Options: sub groups { my $self = shift; my %args = @_ % 2 == 0 ? @_ : (base => shift, @_); - my $base = $args{base} // $self->root; - - my @groups = ($args{inclusive} // 1) ? $base : @{$base->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; - }); + my $base = delete $args{base} // $self->root; + + return $base->groups_deeply(%args); } ############################################################################## @@ -634,35 +605,17 @@ ones: sub entries { my $self = shift; my %args = @_ % 2 == 0 ? @_ : (base => shift, @_); + my $base = delete $args{base} // $self->root; - my $searching = $args{searching}; - my $auto_type = $args{auto_type}; - my $history = $args{history}; - - my $groups = $self->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; - }); + return $base->entries_deeply(%args); } ############################################################################## =method objects - \&iterator = $kdbx->entries(%options); - \&iterator = $kdbx->entries($base_group, %options); + \&iterator = $kdbx->objects(%options); + \&iterator = $kdbx->objects($base_group, %options); Get an iterator over I within a database. 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 @@ -673,27 +626,9 @@ for maintenance tasks. This method takes the same options as L and L shift, @_); + my $base = delete $args{base} // $self->root; - my $searching = $args{searching}; - my $auto_type = $args{auto_type}; - my $history = $args{history}; - - my $groups = $self->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; - }); + return $base->objects_deeply(%args); } sub __iter__ { $_[0]->objects } diff --git a/lib/File/KDBX/Constants.pm b/lib/File/KDBX/Constants.pm index 6f88b25..a099ec8 100644 --- a/lib/File/KDBX/Constants.pm +++ b/lib/File/KDBX/Constants.pm @@ -129,6 +129,11 @@ BEGIN { DEFAULT_MAX_ITEMS => 10, DEFAULT_MAX_SIZE => 6_291_456, # 6 M }, + iteration => { + ITERATION_BFS => dualvar(1, 'bfs'), + ITERATION_DFS => dualvar(2, 'dfs'), + ITERATION_IDS => dualvar(3, 'ids'), + }, icon => { __prefix => 'ICON', PASSWORD => dualvar( 0, 'Password'), @@ -529,6 +534,15 @@ Constants for history-related default values: = C = C +=head2 :iteration + +Constants for searching algorithms. + +=for :list += C - Iterative deepening search += C - Breadth-first search += C - Depth-first search + =head2 :icon Constants for default icons used by KeePass password safe implementations: diff --git a/lib/File/KDBX/Error.pm b/lib/File/KDBX/Error.pm index d12d080..86442f3 100644 --- a/lib/File/KDBX/Error.pm +++ b/lib/File/KDBX/Error.pm @@ -5,7 +5,7 @@ use warnings; use strict; use Exporter qw(import); -use Scalar::Util qw(blessed); +use Scalar::Util qw(blessed looks_like_number); use namespace::clean -except => 'import'; our $VERSION = '999.999'; # VERSION @@ -21,6 +21,13 @@ BEGIN { else { eval qq{package $WARNINGS_CATEGORY; use warnings::register; 1}; ## no critic ProhibitStringyEval } + + my $debug = $ENV{DEBUG}; + $debug = looks_like_number($debug) ? (0 + $debug) : ($debug ? 1 : 0); + *DEBUG = $debug == 1 ? sub() { 1 } : + $debug == 2 ? sub() { 2 } : + $debug == 3 ? sub() { 3 } : + $debug == 4 ? sub() { 4 } : sub() { 0 }; } use overload '""' => 'to_string', cmp => '_cmp'; @@ -151,7 +158,7 @@ sub to_string { my $self = shift; my $msg = "$self->{trace}[0]"; $msg .= '.' if $msg !~ /[\.\!\?]$/; - if ($ENV{DEBUG}) { + if (2 <= DEBUG) { require Data::Dumper; local $Data::Dumper::Indent = 1; local $Data::Dumper::Quotekeys = 0; diff --git a/lib/File/KDBX/Group.pm b/lib/File/KDBX/Group.pm index e801a8d..3b8b458 100644 --- a/lib/File/KDBX/Group.pm +++ b/lib/File/KDBX/Group.pm @@ -7,9 +7,10 @@ use strict; use Devel::GlobalDestruction; use File::KDBX::Constants qw(:icon); use File::KDBX::Error; -use File::KDBX::Util qw(:class :coercion generate_uuid); +use File::KDBX::Iterator; +use File::KDBX::Util qw(:assert :class :coercion generate_uuid); use Hash::Util::FieldHash; -use List::Util qw(sum0); +use List::Util qw(any sum0); use Ref::Util qw(is_coderef is_ref); use Scalar::Util qw(blessed); use Time::Piece; @@ -69,15 +70,37 @@ sub uuid { sub entries { my $self = shift; my $entries = $self->{entries} //= []; - # FIXME - Looping through entries on each access is too expensive. - @$entries = map { $self->_wrap_entry($_, $self->kdbx) } @$entries; + if (@$entries && !blessed($entries->[0])) { + @$entries = map { $self->_wrap_entry($_, $self->kdbx) } @$entries; + } + assert { !any { !blessed $_ } @$entries }; return $entries; } -sub all_entries { +sub entries_deeply { my $self = shift; - # FIXME - shouldn't have to delegate to the database to get this - return $self->kdbx->all_entries(base => $self); + 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; + }); } =method add_entry @@ -122,49 +145,46 @@ sub remove_entry { sub groups { my $self = shift; my $groups = $self->{groups} //= []; - # FIXME - Looping through groups on each access is too expensive. - @$groups = map { $self->_wrap_group($_, $self->kdbx) } @$groups; + if (@$groups && !blessed($groups->[0])) { + @$groups = map { $self->_wrap_group($_, $self->kdbx) } @$groups; + } + assert { !any { !blessed $_ } @$groups }; return $groups; } -=method all_groups - - \@groups = $group->all_groups(%options); - -Get all groups within a group, deeply, in a flat array. Supported options: - -=cut - -sub all_groups { +sub groups_deeply { my $self = shift; + my %args = @_; - my @groups; - for my $subgroup (@{$self->groups}) { - push @groups, @{$subgroup->all_groups}; + 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; + }); } - - return \@groups; -} - -=method find_groups - - @groups = $kdbx->find_groups($query, %options); - -Find all groups deeply that match to a query. Options are the same as for L. - -See L for a description of what C<$query> can be. - -=cut - -sub find_groups { - my $self = shift; - my $query = shift or throw 'Must provide a query'; - my %args = @_; - my %all_groups = ( # FIXME - base => $args{base}, - inclusive => $args{inclusive}, - ); - return @{search($self->all_groups(%all_groups), is_arrayref($query) ? @$query : $query)}; + 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(@_) } @@ -208,6 +228,32 @@ sub remove_group { ############################################################################## +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); diff --git a/lib/File/KDBX/Util.pm b/lib/File/KDBX/Util.pm index b1795a7..a09d286 100644 --- a/lib/File/KDBX/Util.pm +++ b/lib/File/KDBX/Util.pm @@ -20,12 +20,12 @@ use namespace::clean -except => 'import'; our $VERSION = '999.999'; # VERSION our %EXPORT_TAGS = ( - assert => [qw(assert_64bit)], + assert => [qw(DEBUG assert assert_64bit)], class => [qw(extends has list_attributes)], clone => [qw(clone clone_nomagic)], coercion => [qw(to_bool to_number to_string to_time to_tristate to_uuid)], crypt => [qw(pad_pkcs7)], - debug => [qw(dumper)], + debug => [qw(DEBUG dumper)], fork => [qw(can_fork)], function => [qw(memoize recurse_limit)], empty => [qw(empty nonempty)], @@ -33,7 +33,7 @@ our %EXPORT_TAGS = ( gzip => [qw(gzip gunzip)], io => [qw(is_readable is_writable read_all)], load => [qw(load_optional load_xs try_load_optional)], - search => [qw(query search search_limited simple_expression_query)], + search => [qw(query search simple_expression_query)], text => [qw(snakify trim)], uuid => [qw(format_uuid generate_uuid is_uuid uuid UUID_NULL)], uri => [qw(split_url uri_escape_utf8 uri_unescape_utf8)], @@ -42,6 +42,15 @@ our %EXPORT_TAGS = ( $EXPORT_TAGS{all} = [map { @$_ } values %EXPORT_TAGS]; our @EXPORT_OK = @{$EXPORT_TAGS{all}}; +BEGIN { + my $debug = $ENV{DEBUG}; + $debug = looks_like_number($debug) ? (0 + $debug) : ($debug ? 1 : 0); + *DEBUG = $debug == 1 ? sub() { 1 } : + $debug == 2 ? sub() { 2 } : + $debug == 3 ? sub() { 3 } : + $debug == 4 ? sub() { 4 } : sub() { 0 }; +} + my %OPS = ( 'eq' => 2, # binary 'ne' => 2, @@ -117,6 +126,32 @@ sub load_xs { } } +=func assert + + assert { ... }; + +Write an executable comment. Only executed if C is set in the environment. + +=cut + +sub assert(&) { ## no critic (ProhibitSubroutinePrototypes) + return if !DEBUG; + my $code = shift; + return if $code->(); + + (undef, my $file, my $line) = caller; + $file =~ s!([^/\\]+)$!$1!; + my $assertion = ''; + if (try_load_optional('B::Deparse')) { + my $deparse = B::Deparse->new(qw{-P -x9}); + $assertion = $deparse->coderef2text($code); + $assertion =~ s/^\{(?:\s*(?:package[^;]+|use[^;]+);)*\s*(.*?);\s*\}$/$1/s; + $assertion =~ s/\s+/ /gs; + $assertion = ": $assertion"; + } + die "$0: $file:$line: Assertion failed$assertion\n"; +} + =func assert_64bit assert_64bit(); @@ -590,8 +625,9 @@ sub load_optional { for my $module (@_) { eval { load $module }; if (my $err = $@) { - warn $err if $ENV{DEBUG}; - throw "Missing dependency: Please install $module to use this feature.\n", module => $module; + throw "Missing dependency: Please install $module to use this feature.\n", + module => $module, + error => $err; } } return wantarray ? @_ : $_[0]; @@ -729,33 +765,6 @@ sub search { return \@match; } -=for Pod::Coverage search_limited - -=cut - -sub search_limited { - my $list = shift; - my $query = shift; - my $limit = shift // 1; - - if (is_coderef($query) && !@_) { - # already a query - } - elsif (is_scalarref($query)) { - $query = simple_expression_query($$query, @_); - } - else { - $query = query($query, @_); - } - - my @match; - for my $item (@$list) { - push @match, $item if $query->($item); - last if $limit <= @match; - } - return \@match; -} - =func simple_expression_query $query = simple_expression_query($expression, @fields); @@ -921,7 +930,7 @@ sub try_load_optional { for my $module (@_) { eval { load $module }; if (my $err = $@) { - warn $err if $ENV{DEBUG}; + warn $err if 3 <= DEBUG; return; } } diff --git a/t/error.t b/t/error.t index 2caab01..fabaa17 100644 --- a/t/error.t +++ b/t/error.t @@ -3,6 +3,8 @@ use warnings; use strict; +BEGIN { delete $ENV{DEBUG} } + use lib 't/lib'; use TestCommon; @@ -29,17 +31,6 @@ subtest 'Errors' => sub { ok 0 < @$trace, 'Errors record a stacktrace'; like $trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct'; - { - local $ENV{DEBUG} = ''; - like "$error", qr!^uh oh at \H+error\.t line \d+\.$!, 'Errors stringify without stacktrace'; - } - - { - local $ENV{DEBUG} = '1'; - like "$error", qr!^uh oh at \H+error\.t line \d+\.\nbless!, - 'Errors stringify with stacktrace when DEBUG environment variable is set'; - } - $error = exception { File::KDBX::Error->throw('uh oh') }; like $error, qr/uh oh/, 'Errors can be thrown using the "throw" constructor'; like $error->trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct';