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);
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;
}
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);
}
##############################################################################
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
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 }
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'),
= 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:
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
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';
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;
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;
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
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(@_) }
##############################################################################
+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);
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)],
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)],
$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,
}
}
+=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();
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];
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);
for my $module (@_) {
eval { load $module };
if (my $err = $@) {
- warn $err if $ENV{DEBUG};
+ warn $err if 3 <= DEBUG;
return;
}
}
use warnings;
use strict;
+BEGIN { delete $ENV{DEBUG} }
+
use lib 't/lib';
use TestCommon;
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';
projects / chaz / p5-File-KDBX / commitdiff
