]> Dogcows Code - chaz/p5-File-KDBX/commitdiff
Move iteration code into Group
authorCharles McGarvey <ccm@cpan.org>
Wed, 27 Apr 2022 17:34:38 +0000 (11:34 -0600)
committerCharles McGarvey <ccm@cpan.org>
Sun, 1 May 2022 00:29:00 +0000 (18:29 -0600)
lib/File/KDBX.pm
lib/File/KDBX/Constants.pm
lib/File/KDBX/Error.pm
lib/File/KDBX/Group.pm
lib/File/KDBX/Util.pm
t/error.t

index 54bb76867e268aba6f4736b324daa28d96c36621..b69d556133535a3e060a6574488ef4326d3ad85b 100644 (file)
@@ -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<groups> 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<objects> within a database. Groups and entries are considered objects, so this is
 essentially a combination of L</groups> and L</entries>. 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</groups> and L</e
 sub objects {
     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;
-                return $group;
-            }
-        }
-        shift @entries;
-    });
+    return $base->objects_deeply(%args);
 }
 
 sub __iter__ { $_[0]->objects }
index 6f88b252cb35092be24d1b59d1dc744776336f34..a099ec8517f75909ac4ff700ec943a33aaffbaea 100644 (file)
@@ -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<HISTORY_DEFAULT_MAX_ITEMS>
 = C<HISTORY_DEFAULT_MAX_SIZE>
 
+=head2 :iteration
+
+Constants for searching algorithms.
+
+=for :list
+= C<ITERATION_IDS> - Iterative deepening search
+= C<ITERATION_BFS> - Breadth-first search
+= C<ITERATION_DFS> - Depth-first search
+
 =head2 :icon
 
 Constants for default icons used by KeePass password safe implementations:
index d12d0806588e35ae67bddfe1148847fc504055c8..86442f3bdc306a071a2101cb462e6f3b9dbfbd2b 100644 (file)
@@ -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;
index e801a8d01b4f736eed14c53ae6ec5fc5a0dd7955..3b8b458ada0fccfaced3a9390f14b632cf7e4255 100644 (file)
@@ -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</all_groups>.
-
-See L</QUERY> 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);
index b1795a71c111d1144995dc7e82d7769f47e018fa..a09d2863d9177d69f902140f2159c0083bf50bc0 100644 (file)
@@ -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<DEBUG> 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;
         }
     }
index 2caab016bec28de11d39c874ebc169a38dc35701..fabaa172cf2a9f9644f267d4bd5eec93fe377546 100644 (file)
--- 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';
This page took 0.036698 seconds and 4 git commands to generate.