From: Charles McGarvey Date: Wed, 27 Apr 2022 06:49:47 +0000 (-0600) Subject: Add iterator X-Git-Tag: v0.800~12 X-Git-Url: https://git.dogcows.com/gitweb?a=commitdiff_plain;h=c98fc7d0294e641cf8844306808333bdec4fea2f;p=chaz%2Fp5-File-KDBX Add iterator --- diff --git a/lib/File/KDBX.pm b/lib/File/KDBX.pm index 6784ced..54bb768 100644 --- a/lib/File/KDBX.pm +++ b/lib/File/KDBX.pm @@ -8,6 +8,7 @@ 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); @@ -123,9 +124,7 @@ sub STORABLE_thaw { # Dualvars aren't cloned as dualvars, so coerce the compression flags. $self->compression_flags($self->compression_flags); - for my $object (@{$self->all_groups}, @{$self->all_entries(history => 1)}) { - $object->kdbx($self); - } + $self->objects(history => 1)->each(sub { $_->kdbx($self) }); } ############################################################################## @@ -363,23 +362,31 @@ sub minimum_version { nonempty $_->{name} || nonempty $_->{last_modification_time} } @{$self->custom_icons}; - return KDBX_VERSION_4_1 if any { - nonempty $_->previous_parent_group || nonempty $_->tags || - any { nonempty $_->{last_modification_time} } values %{$_->custom_data} - } @{$self->all_groups}; + return KDBX_VERSION_4_1 if $self->groups->next(sub { + nonempty $_->previous_parent_group || + nonempty $_->tags || + (any { nonempty $_->{last_modification_time} } values %{$_->custom_data}) + # TODO replace next paragraph with this + # || $_->entries(history => 1)->next(sub { + # nonempty $_->previous_parent_group || + # (defined $_->quality_check && !$_->quality_check) || + # (any { nonempty $_->{last_modification_time} } values %{$_->custom_data}) + # }) + }); - return KDBX_VERSION_4_1 if any { - nonempty $_->previous_parent_group || (defined $_->quality_check && !$_->quality_check) || - any { nonempty $_->{last_modification_time} } values %{$_->custom_data} - } @{$self->all_entries(history => 1)}; + return KDBX_VERSION_4_1 if $self->entries(history => 1)->next(sub { + nonempty $_->previous_parent_group || + (defined $_->quality_check && !$_->quality_check) || + (any { nonempty $_->{last_modification_time} } values %{$_->custom_data}) + }); return KDBX_VERSION_4_0 if $self->kdf->uuid ne KDF_UUID_AES; return KDBX_VERSION_4_0 if nonempty $self->public_custom_data; - return KDBX_VERSION_4_0 if any { + return KDBX_VERSION_4_0 if $self->objects->next(sub { nonempty $_->custom_data - } @{$self->all_groups}, @{$self->all_entries(history => 1)}; + }); return KDBX_VERSION_3_1; } @@ -415,6 +422,9 @@ sub root { return $self->_wrap_group($self->{root}); } +# Called by File::KeePass::KDBX so that a File::KDBX an be treated as a File::KDBX::Group in that both types +# can have subgroups. File::KDBX already has a `groups' method that does something different from the +# File::KDBX::Groups `groups' method. sub _kpx_groups { my $self = shift; return [] if !$self->{root}; @@ -508,7 +518,7 @@ sub add_group { # find the right group to add the group to my $parent = delete $args{group} // delete $args{parent} // $self->root; - ($parent) = $self->find_groups({uuid => $parent}) if !ref $parent; + $parent = $self->groups->grep({uuid => $parent})->next if !ref $parent; $parent or throw 'Invalid group'; return $parent->add_group(defined $group ? $group : (), %args, kdbx => $self); @@ -521,58 +531,54 @@ sub _wrap_group { return File::KDBX::Group->wrap($group, $self); } -=method all_groups +=method groups - \@groups = $kdbx->all_groups(%options); - \@groups = $kdbx->all_groups($base_group, %options); + \&iterator = $kdbx->groups(%options); + \&iterator = $kdbx->groups($base_group, %options); -Get all groups deeply in a database, or all groups within a specified base group, in a flat array. Supported -options: +Get an iterator over I within a database. Options: =for :list -* C - Only include groups within a base group (same as C<$base_group>) (default: root) -* C - Include the base group in the results (default: true) +* C - Only include groups within a base group (same as C<$base_group>) (default: L) +* C - Include the base group in the results (default: true) +* C - Search algorithm, one of C, C or C (default: C) =cut -sub all_groups { +sub groups { my $self = shift; my %args = @_ % 2 == 0 ? @_ : (base => shift, @_); my $base = $args{base} // $self->root; - # my @groups; - # push @groups, $self->_wrap_group($base) if $args{include_base} // 1; - # push @groups, @{$base->all_groups}; - # return \@groups; - my @groups = $args{include_base} // 1 ? $self->_wrap_group($base) : (); - - for my $subgroup (@{$base->{groups} || []}) { - my $more = $self->all_groups($subgroup); - push @groups, @$more; + 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; + }); } - - 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 = ( - base => $args{base}, - include_base => $args{include_base}, - ); - 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; + }); } ############################################################################## @@ -597,7 +603,7 @@ sub add_entry { # find the right group to add the entry to my $parent = delete $args{group} // delete $args{parent} // $self->root; - ($parent) = $self->find_groups({uuid => $parent}) if !ref $parent; + $parent = $self->groups->grep({uuid => $parent})->next if !ref $parent; $parent or throw 'Invalid group'; return $parent->add_entry(defined $entry ? $entry : (), %args, kdbx => $self); @@ -610,97 +616,88 @@ sub _wrap_entry { return File::KDBX::Entry->wrap($entry, $self); } -=method all_entries +=method entries - \@entries = $kdbx->all_entries(%options); - \@entries = $kdbx->all_entries($base_group, %options); + \&iterator = $kdbx->entries(%options); + \&iterator = $kdbx->entries($base_group, %options); -Get entries deeply in a database, in a flat array. Supported options: +Get an iterator over I within a database. Supports the same options as L, plus some new +ones: =for :list -* C - Only include entries within a base group (same as C<$base_group>) (default: root) * C - Only include entries with auto-type enabled (default: false, include all) -* C - Only include entries within groups with search enabled (default: false, include all) -* C - Also include historical entries (default: false, include only active entries) +* C - Only include entries within groups with search enabled (default: false, include all) +* C - Also include historical entries (default: false, include only current entries) =cut -sub all_entries { +sub entries { my $self = shift; my %args = @_ % 2 == 0 ? @_ : (base => shift, @_); - my $base = $args{base} // $self->root; - my $history = $args{history}; - my $search = $args{search}; + my $searching = $args{searching}; my $auto_type = $args{auto_type}; + my $history = $args{history}; - my $enable_auto_type = $base->{enable_auto_type} // true; - my $enable_searching = $base->{enable_searching} // true; - + my $groups = $self->groups(%args); my @entries; - if ((!$search || $enable_searching) && (!$auto_type || $enable_auto_type)) { - push @entries, - map { $self->_wrap_entry($_) } - grep { !$auto_type || $_->{auto_type}{enabled} } - map { $_, $history ? @{$_->{history} || []} : () } - @{$base->{entries} || []}; - } - for my $subgroup (@{$base->{groups} || []}) { - my $more = $self->all_entries($subgroup, - auto_type => $auto_type, - search => $search, - history => $history, - ); - push @entries, @$more; - } - - return \@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 find_entries - -=method find_entries_simple - - @entries = $kdbx->find_entries($query, %options); +############################################################################## - @entries = $kdbx->find_entries_simple($expression, \@fields, %options); - @entries = $kdbx->find_entries_simple($expression, $operator, \@fields, %options); +=method objects -Find all entries deeply that match a query. Options are the same as for L. + \&iterator = $kdbx->entries(%options); + \&iterator = $kdbx->entries($base_group, %options); -See L for a description of what C<$query> can be. +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 +for maintenance tasks. This method takes the same options as L and L. =cut -sub find_entries { +sub objects { my $self = shift; - my $query = shift or throw 'Must provide a query'; - my %args = @_; - my %all_entries = ( - base => $args{base}, - auto_type => $args{auto_type}, - search => $args{search}, - history => $args{history}, - ); - my $limit = delete $args{limit}; - if (defined $limit) { - return @{search_limited($self->all_entries(%all_entries), is_arrayref($query) ? @$query : $query, $limit)}; - } - else { - return @{search($self->all_entries(%all_entries), is_arrayref($query) ? @$query : $query)}; - } -} + my %args = @_ % 2 == 0 ? @_ : (base => shift, @_); -sub find_entries_simple { - my $self = shift; - my $text = shift; - my $op = @_ && !is_ref($_[0]) ? shift : undef; - my $fields = shift; - is_arrayref($fields) or throw q{Usage: find_entries_simple($expression, [$op,] \@fields)}; - return $self->find_entries([\$text, $op, $fields], @_); + 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; + }); } +sub __iter__ { $_[0]->objects } + ############################################################################## =method custom_icon @@ -983,8 +980,8 @@ references are resolved automatically while expanding entry strings (i.e. replac use this method to resolve on-the-fly references that aren't part of any actual string in the database. If the reference does not resolve to any field, C is returned. If the reference resolves to multiple -fields, only the first one is returned (in the same order as L). To avoid ambiguity, you can -refer to a specific entry by its UUID. +fields, only the first one is returned (in the same order as iterated by L). To avoid ambiguity, you +can refer to a specific entry by its UUID. The syntax of a reference is: C<< {REF:@:} >>. C is a L. C and C are both single character codes representing a field: @@ -1046,14 +1043,14 @@ sub resolve_reference { my $query = $search_in eq 'uuid' ? query($search_in => uuid($text)) : simple_expression_query($text, '=~', $search_in); - my ($entry) = $self->find_entries($query, limit => 1); + my $entry = $self->entries->grep($query)->next; $entry or return; return $entry->$wanted; } our %PLACEHOLDERS = ( - # placeholder => sub { my ($entry, $arg) = @_; ... }; + # 'PLACEHOLDER' => sub { my ($entry, $arg) = @_; ... }; 'TITLE' => sub { $_[0]->expanded_title }, 'USERNAME' => sub { $_[0]->expanded_username }, 'PASSWORD' => sub { $_[0]->expanded_password }, @@ -1154,10 +1151,9 @@ sub lock { my @strings; - my $entries = $self->all_entries(history => 1); - for my $entry (@$entries) { - push @strings, grep { $_->{protect} } values %{$entry->strings}, values %{$entry->binaries}; - } + $self->entries(history => 1)->each(sub { + push @strings, grep { $_->{protect} } values %{$_->strings}, values %{$_->binaries}; + }); $self->_safe(File::KDBX::Safe->new(\@strings)); @@ -1516,16 +1512,16 @@ sub _handle_entry_uuid_changed { my $new_pretty = format_uuid($new_uuid); my $fieldref_match = qr/\{REF:([TUPANI])\@I:\Q$old_pretty\E\}/is; - for my $entry (@{$self->all_entries}) { - $entry->previous_parent_group($new_uuid) if $old_uuid eq ($entry->{previous_parent_group} // ''); + $self->entries->each(sub { + $_->previous_parent_group($new_uuid) if $old_uuid eq ($_->{previous_parent_group} // ''); - for my $string (values %{$entry->strings}) { + for my $string (values %{$_->strings}) { next if !defined $string->{value} || $string->{value} !~ $fieldref_match; - my $txn = $entry->begin_work; + my $txn = $_->begin_work; $string->{value} =~ s/$fieldref_match/{REF:$1\@I:$new_pretty}/g; $txn->commit; } - } + }); } sub _handle_group_uuid_changed { @@ -1540,13 +1536,13 @@ sub _handle_group_uuid_changed { $self->last_selected_group($new_uuid) if $old_uuid eq ($meta->{last_selected_group} // ''); $self->last_top_visible_group($new_uuid) if $old_uuid eq ($meta->{last_top_visible_group} // ''); - for my $group (@{$self->all_groups}) { - $group->last_top_visible_entry($new_uuid) if $old_uuid eq ($group->{last_top_visible_entry} // ''); - $group->previous_parent_group($new_uuid) if $old_uuid eq ($group->{previous_parent_group} // ''); - } - for my $entry (@{$self->all_entries}) { - $entry->previous_parent_group($new_uuid) if $old_uuid eq ($entry->{previous_parent_group} // ''); - } + $self->groups->each(sub { + $_->last_top_visible_entry($new_uuid) if $old_uuid eq ($_->{last_top_visible_entry} // ''); + $_->previous_parent_group($new_uuid) if $old_uuid eq ($_->{previous_parent_group} // ''); + }); + $self->entries->each(sub { + $_->previous_parent_group($new_uuid) if $old_uuid eq ($_->{previous_parent_group} // ''); + }); } ######################################################################################### @@ -1760,9 +1756,10 @@ __END__ $kdbx = File::KDBX->load_file('passwords.kdbx', 'M@st3rP@ssw0rd!'); - for my $entry (@{ $kdbx->all_entries }) { + kdbx->entries->each(sub { + my ($entry) = @_; say 'Entry: ', $entry->title; - } + }); =head1 DESCRIPTION @@ -1818,32 +1815,50 @@ considerations. my $kdbx = File::KDBX->load_file('mypasswords.kdbx', 'master password CHANGEME'); $kdbx->unlock; - for my $entry (@{ $kdbx->all_entries }) { - say 'Found password for ', $entry->title, ':'; + $kdbx->entries->each(sub { + my ($entry) = @_; + say 'Found password for ', $entry->title; say ' Username: ', $entry->username; say ' Password: ', $entry->password; - } + }); =head2 Search for entries - my @entries = $kdbx->find_entries({ - title => 'WayneCorp', - }, search => 1); + my @entries = $kdbx->entries(searching => 1) + ->grep(title => 'WayneCorp') + ->each; # return all matches + +The C option limits results to only entries within groups with searching enabled. Other options are +also available. See L. See L for many more query examples. =head2 Search for entries by auto-type window association - my @entry_key_sequences = $kdbx->find_entries_for_window('WayneCorp - Mozilla Firefox'); - for my $pair (@entry_key_sequences) { - my ($entry, $key_sequence) = @$pair; - say 'Entry title: ', $entry->title, ', key sequence: ', $key_sequence; - } + my $window_title = 'WayneCorp - Mozilla Firefox'; + + my $entries = $kdbx->entries(auto_type => 1) + ->filter(sub { + my $ata = $_->auto_type_associations->grep(sub { $_->{window} =~ $window_title })->next; + return [$_, $ata->{keystroke_sequence}] if $ata; + }) + ->each(sub { + my ($entry, $keys) = @$_; + say 'Entry title: ', $entry->title, ', key sequence: ', $keys; + }); Example output: Entry title: WayneCorp, key sequence: {PASSWORD}{ENTER} +=head2 Remove entries from a database + + $kdbx->entries + ->grep(notes => {'=~' => qr/too old/i}) + ->each(sub { $_->recycle }); + +Recycle all entries with the string "too old" appearing in the B string. + =head1 SECURITY One of the biggest threats to your database security is how easily the encryption key can be brute-forced. @@ -1939,6 +1954,8 @@ unfortunately not portable. =head1 QUERY +B - All these examples are WRONG now. + Several methods take a I as an argument (e.g. L). A query is just a subroutine that you can either write yourself or have generated for you based on either a simple expression or a declarative structure. It's easier to have your query generated, so I'll cover that first. @@ -2142,7 +2159,8 @@ All of these query mechanisms described in this section are just tools, each wit If the tools are getting in your way, you can of course iterate over the contents of a database and implement your own query logic, like this: - for my $entry (@{ $kdbx->all_entries }) { + my $entries = $kdbx->entries; + while (my $entry = $entries->next) { if (wanted($entry)) { do_something($entry); } diff --git a/lib/File/KDBX/Dumper/V4.pm b/lib/File/KDBX/Dumper/V4.pm index c002f0b..d3381b6 100644 --- a/lib/File/KDBX/Dumper/V4.pm +++ b/lib/File/KDBX/Dumper/V4.pm @@ -317,8 +317,8 @@ sub _write_binaries { my $new_ref = 0; my $written = $self->_binaries_written; - my $entries = $kdbx->all_entries(history => true); - for my $entry (@$entries) { + my $entries = $kdbx->entries(history => 1); + while (my $entry = $entries->next) { for my $key (keys %{$entry->binaries}) { my $binary = $entry->binaries->{$key}; if (defined $binary->{ref} && defined $kdbx->binaries->{$binary->{ref}}) { diff --git a/lib/File/KDBX/Dumper/XML.pm b/lib/File/KDBX/Dumper/XML.pm index 86eb5c9..5b376b9 100644 --- a/lib/File/KDBX/Dumper/XML.pm +++ b/lib/File/KDBX/Dumper/XML.pm @@ -178,8 +178,8 @@ sub _write_xml_binaries { my $new_ref = keys %{$self->_binaries_written}; my $written = $self->_binaries_written; - my $entries = $kdbx->all_entries(history => true); - for my $entry (@$entries) { + my $entries = $kdbx->entries(history => 1); + while (my $entry = $entries->next) { for my $key (keys %{$entry->binaries}) { my $binary = $entry->binaries->{$key}; if (defined $binary->{ref} && defined $kdbx->binaries->{$binary->{ref}}) { diff --git a/lib/File/KDBX/Entry.pm b/lib/File/KDBX/Entry.pm index 0ad08a0..a242def 100644 --- a/lib/File/KDBX/Entry.pm +++ b/lib/File/KDBX/Entry.pm @@ -438,9 +438,19 @@ sub binary_value { return $binary->{value}; } +sub searching_enabled { + my $self = shift; + my $parent = $self->parent; + return $parent->effective_enable_searching if $parent; + return true; +} + sub auto_type_enabled { - my $entry = shift; - # TODO + my $self = shift; + return false if !$self->auto_type->{enabled}; + my $parent = $self->parent; + return $parent->effective_enable_auto_type if $parent; + return true; } ############################################################################## diff --git a/lib/File/KDBX/Group.pm b/lib/File/KDBX/Group.pm index f89d933..e801a8d 100644 --- a/lib/File/KDBX/Group.pm +++ b/lib/File/KDBX/Group.pm @@ -161,8 +161,8 @@ sub find_groups { my $query = shift or throw 'Must provide a query'; my %args = @_; my %all_groups = ( # FIXME - base => $args{base}, - include_base => $args{include_base}, + base => $args{base}, + inclusive => $args{inclusive}, ); return @{search($self->all_groups(%all_groups), is_arrayref($query) ? @$query : $query)}; } @@ -332,6 +332,33 @@ sub _commit { $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 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__ diff --git a/lib/File/KDBX/Iterator.pm b/lib/File/KDBX/Iterator.pm new file mode 100644 index 0000000..8d79b2a --- /dev/null +++ b/lib/File/KDBX/Iterator.pm @@ -0,0 +1,403 @@ +package File::KDBX::Iterator; +# PACKAGE: KDBX database iterator + +use warnings; +use strict; + +use File::KDBX::Error; +use File::KDBX::Util qw(:class :load :search); +use Iterator::Simple; +use Ref::Util qw(is_arrayref is_coderef is_scalarref); +use namespace::clean; + +extends 'Iterator::Simple::Iterator'; + +our $VERSION = '999.999'; # VERSION + +=method new + + \&iterator = File::KDBX::Iterator->new(\&iterator); + +Blesses an iterator to augment it with buffering plus some useful utility methods. + +=cut + +sub new { + my $class = shift; + my $code = is_coderef($_[0]) ? shift : sub { undef }; + + my $items = @_ == 1 && is_arrayref($_[0]) ? $_[0] : \@_; + return $class->SUPER::new(sub { + if (@_) { # put back + if (@_ == 1 && is_arrayref($_[0])) { + $items = $_[0]; + } + else { + unshift @$items, @_; + } + return; + } + else { + my $next = shift @$items; + return $next if defined $next; + return $code->(); + } + }); +} + +=method next + + $item = $iterator->next; + # OR equivalently + $item = $iterator->(); + + $item = $iterator->next(\&query); + $item = $iterator->next([\'simple expression', @fields]); + +Get the next item or C if there are no more items. If a query is passed, get the next matching item, +discarding any items before the matching item that do not match. Example: + + my $item = $iterator->next(sub { $_->label =~ /Gym/ }); + +=cut + +sub _create_query { + my $self = shift; + my $code = shift; + + if (is_coderef($code) || overload::Method($code, '&{}')) { + return $code; + } + elsif (is_scalarref($code)) { + return simple_expression_query($$code, @_); + } + else { + return query($code, @_); + } +} + +sub next { + my $self = shift; + my $code = shift or return $self->(); + + $code = $self->_create_query($code, @_); + + while (defined (local $_ = $self->())) { + return $_ if $code->($_); + } + return; +} + +=method peek + + $item = $iterator->peek; + +Peek at the next item. Returns C if the iterator is empty. This allows you to access the next item +without draining it from the iterator. The same item will be returned the next time L is called. + +=cut + +sub peek { + my $self = shift; + + my $next = $self->(); + $self->($next) if defined $next; + return $next; +} + +=method unget + + $iterator->unget(\@items); + $iterator->unget(...); + # OR equivalently + $iterator->(\@items); + $iterator->(...); + +Replace the buffer or unshift one or more items to the current buffer. + +See L. + +=cut + +sub unget { + my $self = shift; # Must shift in a statement before calling. + $self->(@_); +} + +=method each + + @items = $iterator->each; + + $iterator->each(sub($item, $num) { ... }); + +Get the rest of the items. There are two forms: Without arguments, C returns a list of the rest of the +items. Or pass a coderef to be called once per item, in order. The item is passed as the first argument to the +given subroutine and is also available as C<$_>. + +=cut + +sub each { + my $self = shift; + my $cb = shift or return @{$self->to_array}; + + my $count = 0; + $cb->($_, $count++) while defined (local $_ = $self->()); + return $self; +} + +=method limit + + \&iterator = $iterator->limit($count); + +Get a new iterator draining from an existing iterator but providing only a limited number of items. + +=cut + +sub limit { shift->head(@_) } + +=method grep + + \&iterator = $iterator->grep(\&query); + \&iterator = $iterator->grep([\'simple expression', @fields]); + +Get a new iterator draining from an existing iterator but providing only items that pass a test or are matched +by a query. + +=cut + +sub grep { + my $self = shift; + my $code = shift; + + $code = $self->_create_query($code, @_); + + ref($self)->new(sub { + while (defined (local $_ = $self->())) { + return $_ if $code->($_); + } + return; + }); +} + +=method map + + \&iterator = $iterator->map(\&code); + +Get a new iterator draining from an existing iterator but providing modified items. + +=cut + +sub map { + my $self = shift; + my $code = shift; + + ref($self)->new(sub { + local $_ = $self->(); + return if !defined $_; + return $code->(); + }); +} + +=method filter + + \&iterator = $iterator->filter(\&query); + \&iterator = $iterator->filter([\'simple expression', @fields]); + +See L. + +=cut + +sub filter { + my $self = shift; + my $code = shift; + return $self->SUPER::filter($self->_create_query($code, @_)); +} + +=method sort_by + +=method order_by + + \&iterator = $iterator->sort_by($field, %options); + \&iterator = $iterator->sort_by(\&get_value, %options); + +Get a new iterator draining from an existing iterator but providing items sorted by an object field. Sorting +is done using L (if available) or C to sort alphanumerically. The C<\&get_value> +subroutine is called once for each item and should return a string value. Options: + +=for :list +* C - Order ascending if true, descending otherwise (default: true) +* C - If true, take case into account, otherwise ignore case (default: true) +* C - If true, use B (if available), otherwise use perl built-ins (default: true) +* Any B option is also supported. + +C and C are aliases. + +B This method drains the iterator completely but adds items back onto the buffer, so the iterator is +still usable afterward. Nevertheless, you mustn't call this on an infinite iterator or it will run until +available memory is depleted. + +=cut + +sub sort_by { shift->order_by(@_) } +sub nsort_by { shift->norder_by(@_) } + +sub order_by { + my $self = shift; + my $field = shift; + my %args = @_; + + my $ascending = delete $args{ascending} // !delete $args{descending} // 1; + my $case = delete $args{case} // !delete $args{no_case} // 1; + my $collate = (delete $args{collate} // !delete $args{no_collate} // 1) + && try_load_optional('Unicode::Collate'); + + if ($collate && !$case) { + $case = 1; + # use a proper Unicode::Collate level to ignore case + $args{level} //= 2; + } + $args{upper_before_lower} //= 1; + + my $value = $field; + $value = $case ? sub { $_[0]->$field // '' } : sub { uc($_[0]->$field) // '' } if !is_coderef($value); + my @all = CORE::map { [$_, $value->($_)] } @{$self->to_array}; + + if ($collate) { + my $c = Unicode::Collate->new(%args); + if ($ascending) { + @all = CORE::map { $_->[0] } CORE::sort { $c->cmp($a->[1], $b->[1]) } @all; + } else { + @all = CORE::map { $_->[0] } CORE::sort { $c->cmp($b->[1], $a->[1]) } @all; + } + } else { + if ($ascending) { + @all = CORE::map { $_->[0] } CORE::sort { $a->[1] cmp $b->[1] } @all; + } else { + @all = CORE::map { $_->[0] } CORE::sort { $b->[1] cmp $a->[1] } @all; + } + } + + $self->(\@all); + return $self; +} + +=method nsort_by + +=method norder_by + + \&iterator = $iterator->nsort_by($field, %options); + \&iterator = $iterator->nsort_by(\&get_value, %options); + +Get a new iterator draining from an existing iterator but providing items sorted by an object field. Sorting +is done numerically using C<< <=> >>. The C<\&get_value> subroutine is called once for each item and should +return a numerical value. Options: + +=for :list +* C - Order ascending if true, descending otherwise (default: true) + +C and C are aliases. + +B This method drains the iterator completely but adds items back onto the buffer, so the iterator is +still usable afterward. Nevertheless, you mustn't call this on an infinite iterator or it will run until +available memory is depleted. + +=cut + +sub norder_by { + my $self = shift; + my $field = shift; + my %args = @_; + + my $ascending = $args{ascending} // !$args{descending} // 1; + + my $value = $field; + $value = sub { $_[0]->$field // 0 } if !is_coderef($value); + my @all = CORE::map { [$_, $value->($_)] } @{$self->to_array}; + + if ($ascending) { + @all = CORE::map { $_->[0] } CORE::sort { $a->[1] <=> $b->[1] } @all; + } else { + @all = CORE::map { $_->[0] } CORE::sort { $b->[1] <=> $a->[1] } @all; + } + + $self->(\@all); + return $self; +} + +=method to_array + + \@array = $iterator->to_array; + +Get the rest of the items from an iterator as an arrayref. + +B This method drains the iterator completely, leaving the iterator empty. You mustn't call this on an +infinite iterator or it will run until available memory is depleted. + +=cut + +sub to_array { + my $self = shift; + + my @all; + push @all, $_ while defined (local $_ = $self->()); + return \@all; +} + +=method count + +=method size + + $size = $iterator->count; + +Count the rest of the items from an iterator. + +B This method drains the iterator completely but adds items back onto the buffer, so the iterator is +still usable afterward. Nevertheless, you mustn't call this on an infinite iterator or it will run until +available memory is depleted. + +=cut + +sub size { + my $self = shift; + + my $items = $self->to_array; + $self->($items); + return scalar @$items; +} + +sub count { shift->size } + +sub TO_JSON { $_[0]->to_array } + +1; +__END__ + +=for Pod::Coverage TO_JSON + +=head1 SYNOPSIS + + $kdbx->entries + ->grep(sub { $_->title =~ /bank/i }) + ->sort_by('title') + ->limit(5) + ->each(sub { + say $_->title; + }); + +=head1 DESCRIPTION + +A buffered iterator compatible with and expanding upon L, this provides an easy way to +navigate a L database. + +=head2 Buffer + +This iterator is buffered, meaning it can drain from an iterator subroutine under the hood, storing items +temporarily to be accessed later. This allows features like L and L which might be useful in the +context of KDBX databases which are normally pretty small so draining an iterator isn't cost-prohibitive. + +The way this works is that if you call an iterator without arguments, it acts like a normal iterator. If you +call it with arguments, however, the arguments are added to the buffer. When called without arguments, the +buffer is drained before the iterator function is. Using L is equivalent to calling the iterator with +arguments, and as L is equivalent to calling the iterator without arguments. + +=cut diff --git a/lib/File/KDBX/Loader/KDB.pm b/lib/File/KDBX/Loader/KDB.pm index 1b18f7b..9feaaac 100644 --- a/lib/File/KDBX/Loader/KDB.pm +++ b/lib/File/KDBX/Loader/KDB.pm @@ -90,16 +90,18 @@ sub convert_keepass_to_kdbx { } } - for my $entry ($kdbx->find_entries({ + $kdbx->entries + ->grep({ title => 'Meta-Info', username => 'SYSTEM', url => '$', icon_id => 0, -nonempty => 'notes', - })) { - _read_meta_stream($kdbx, $entry); - $entry->remove; - } + }) + ->each(sub { + _read_meta_stream($kdbx, $_); + $_->remove; # TODO do not signal + }); return $kdbx; } @@ -120,7 +122,7 @@ sub _read_meta_stream { read_all $fh, $buf, 5 or goto PARSE_ERROR; my ($group_id, $expanded) = unpack('L< C', $buf); my $uuid = _decode_uuid($group_id) // next; - my ($group) = $kdbx->find_groups({uuid => $uuid}); + my $group = $kdbx->groups->grep({uuid => $uuid})->next; $group->is_expanded($expanded) if $group; } } @@ -139,7 +141,7 @@ sub _read_meta_stream { read_all $fh, $buf, 20 or goto PARSE_ERROR; my ($uuid, $icon_index) = unpack('a16 L<', $buf); next if !$icons[$icon_index]; - my ($entry) = $kdbx->find_entries({uuid => $uuid}); + my $entry = $kdbx->entries->grep({uuid => $uuid})->next; $entry->custom_icon_uuid($icons[$icon_index]) if $entry; } for (my $i = 0; $i < $num_groups; ++$i) { @@ -147,7 +149,7 @@ sub _read_meta_stream { my ($group_id, $icon_index) = unpack('L<2', $buf); next if !$icons[$icon_index]; my $uuid = _decode_uuid($group_id) // next; - my ($group) = $kdbx->find_groups({uuid => $uuid}); + my $group = $kdbx->groups->grep({uuid => $uuid})->next; $group->custom_icon_uuid($icons[$icon_index]) if $group; } } diff --git a/lib/File/KDBX/Loader/XML.pm b/lib/File/KDBX/Loader/XML.pm index 1b9be6b..00676a1 100644 --- a/lib/File/KDBX/Loader/XML.pm +++ b/lib/File/KDBX/Loader/XML.pm @@ -367,10 +367,10 @@ sub _resolve_binary_refs { my $self = shift; my $kdbx = $self->kdbx; - my $entries = $kdbx->all_entries(history => 1); my $pool = $kdbx->binaries; - for my $entry (@$entries) { + my $entries = $kdbx->entries(history => 1); + while (my $entry = $entries->next) { while (my ($key, $binary) = each %{$entry->binaries}) { my $ref = $binary->{ref} // next; next if defined $binary->{value}; diff --git a/lib/File/KDBX/Object.pm b/lib/File/KDBX/Object.pm index bcbfd58..7c538bf 100644 --- a/lib/File/KDBX/Object.pm +++ b/lib/File/KDBX/Object.pm @@ -353,6 +353,8 @@ Remove the object from the database. If the object is a group, all contained obj =cut sub remove { + # TODO - need a way to not signal database because there are times like in the KDB loader and meta streams + # where we do not want to add UUIDs to deleted objects my $self = shift; my $parent = $self->parent; $parent->remove_object($self) if $parent; diff --git a/lib/File/KDBX/Util.pm b/lib/File/KDBX/Util.pm index f1b9976..b1795a7 100644 --- a/lib/File/KDBX/Util.pm +++ b/lib/File/KDBX/Util.pm @@ -376,7 +376,8 @@ Set up the current module to inheret from another module. sub extends { my $parent = shift; my $caller = caller; - load $parent; + # load $parent; + eval qq[require $parent]; no strict 'refs'; ## no critic (ProhibitNoStrict) @{"${caller}::ISA"} = $parent; } @@ -758,6 +759,7 @@ sub search_limited { =func simple_expression_query $query = simple_expression_query($expression, @fields); + $query = simple_expression_query($expression, $operator, @fields); Generate a query, like L, to be used with L but built from a "simple expression" as L. diff --git a/t/database.t b/t/database.t index 86c6f4d..5d7b991 100644 --- a/t/database.t +++ b/t/database.t @@ -44,7 +44,7 @@ subtest 'Clone' => sub { isnt $kdbx->root->groups->[0]->entries->[0], $copy->root->groups->[0]->entries->[0], 'Clone entry is a different object'; - my @objects = (@{$copy->all_groups}, @{$copy->all_entries}); + my @objects = $copy->objects->each; subtest 'Cloned objects refer to the cloned database' => sub { plan tests => scalar @_; for my $object (@objects) { diff --git a/t/hash-block.t b/t/hash-block.t index 78008ab..b42aa23 100644 --- a/t/hash-block.t +++ b/t/hash-block.t @@ -28,7 +28,7 @@ use Test::More; } SKIP: { - skip 'Tests require fork' if !can_fork; + skip 'fork required to test long data streams' if !can_fork; my $expected_plaintext = "\x64" x (1024*1024*12 - 57); diff --git a/t/hmac-block.t b/t/hmac-block.t index d0488c6..87f2809 100644 --- a/t/hmac-block.t +++ b/t/hmac-block.t @@ -32,7 +32,7 @@ my $KEY = "\x01" x 64; } SKIP: { - skip 'Tests require fork' if !can_fork; + skip 'fork required to test long data streams' if !can_fork; my $expected_plaintext = "\x64" x (1024*1024*12 - 57); diff --git a/t/iterator.t b/t/iterator.t new file mode 100755 index 0000000..02d4733 --- /dev/null +++ b/t/iterator.t @@ -0,0 +1,101 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use File::KDBX::Iterator; +use File::KDBX::Entry; +use File::KDBX::Util qw(:load); +use Iterator::Simple qw(:all); +use Test::More; + +subtest 'Basic' => sub { + my $it = File::KDBX::Iterator->new(1..10); + + is $it->(), 1, 'Get next item (1)'; + is $it->(), 2, 'Get next item (2)'; + $it->unget(-5); + is $it->(), -5, 'Unget'; + is $it->peek, 3, 'Peek at next'; + is $it->(), 3, 'Get next item (3)'; + is $it->count, 7, 'Get current size'; + + my $limited = $it->limit(3); + is $limited->count, 3, 'Get current size'; + my $enum = ienumerate $limited; + is_deeply $enum->to_array, [[0, 4], [1, 5], [2, 6]], 'Use Iterator::Simple functions'; + + is $it->(), 7, 'Original iterator is drained by composing iterator'; + + is $it->next(sub { $_ == 9 }), 9, 'Find next matching item'; + is $it->next, 10, 'Item got skipped while finding next match'; + is $it->peek, undef, 'No more items (peek)'; + is $it->next, undef, 'No more items (next)'; + + $it->(qw{10 20 30}); + is_deeply [$it->each], [qw{10 20 30}], 'Fill buffer and get each item (list)'; + is $it->(), undef, 'Empty'; + + $it->(my $buffer = [qw{a b c}]); + my @each; + $it->each(sub { push @each, $_ }); + is_deeply \@each, [qw{a b c}], 'Fill buffer and get each item (function)'; + is_deeply $buffer, [], 'Buffer is empty'; +}; + +subtest 'Sorting' => sub { + my $new_it = sub { + File::KDBX::Iterator->new( + File::KDBX::Entry->new(label => 'foo', icon_id => 1), + File::KDBX::Entry->new(label => 'bar', icon_id => 5), + File::KDBX::Entry->new(label => 'BaZ', icon_id => 3), + File::KDBX::Entry->new(label => 'qux', icon_id => 2), + File::KDBX::Entry->new(label => 'Muf', icon_id => 4), + ); + }; + + my @sort = (label => collate => 0); + + my $it = $new_it->(); + is_deeply $it->sort_by(@sort)->map(sub { $_->label })->to_array, + [qw{BaZ Muf bar foo qux}], 'Sort text ascending'; + + $it = $new_it->(); + is_deeply $it->sort_by(@sort, case => 0)->map(sub { $_->label })->to_array, + [qw{bar BaZ foo Muf qux}], 'Sort text ascending, ignore-case'; + + $it = $new_it->(); + is_deeply $it->sort_by(@sort, ascending => 0)->map(sub { $_->label })->to_array, + [qw{qux foo bar Muf BaZ}], 'Sort text descending'; + + $it = $new_it->(); + is_deeply $it->sort_by(@sort, ascending => 0, case => 0)->map(sub { $_->label })->to_array, + [qw{qux Muf foo BaZ bar}], 'Sort text descending, ignore-case'; + + SKIP: { + plan skip_all => 'Unicode::Collate required to test collation sorting' + if !try_load_optional('Unicode::Collate'); + + # FIXME I'm missing something.... + # $it = $new_it->(); + # is_deeply $it->sort_by('label')->map(sub { $_->label })->to_array, + # [qw{BaZ Muf bar foo qux}], 'Sort text ascending using Unicode::Collate'; + + $it = $new_it->(); + is_deeply $it->sort_by('label', case => 0)->map(sub { $_->label })->to_array, + [qw{bar BaZ foo Muf qux}], 'Sort text ascending, ignore-case using Unicode::Collate'; + } + + $it = $new_it->(); + is_deeply $it->nsort_by('icon_id')->map(sub { $_->label })->to_array, + [qw{foo qux BaZ Muf bar}], 'Sort text numerically, ascending'; + + $it = $new_it->(); + is_deeply $it->nsort_by('icon_id', ascending => 0)->map(sub { $_->label })->to_array, + [qw{bar Muf BaZ qux foo}], 'Sort text numerically, descending'; +}; + +done_testing; diff --git a/t/kdbx3.t b/t/kdbx3.t index 847712d..5fe53f7 100644 --- a/t/kdbx3.t +++ b/t/kdbx3.t @@ -107,7 +107,7 @@ subtest 'Verify ProtectedStrings' => sub { $kdbx->unlock; - my ($entry) = @{$kdbx->all_entries}; + my $entry = $kdbx->entries->next; is $entry->title, 'Sample Entry', 'Get entry title'; is $entry->username, 'Protected User Name', 'Get protected username from entry'; is $entry->password, 'ProtectedPassword', 'Get protected password from entry'; diff --git a/t/kdbx4.t b/t/kdbx4.t index 5fee086..f1e9cbc 100644 --- a/t/kdbx4.t +++ b/t/kdbx4.t @@ -37,8 +37,8 @@ subtest 'Verify Format400' => sub { is $kdbx->meta->{database_name}, 'Format400', 'Extract database name from meta'; is $kdbx->root->name, 'Format400', 'Extract name of root group'; - my ($entry, @other) = $kdbx->find_entries([\'400', 'title']); - is @other, 0, 'Database has one entry'; + my ($entry, @other) = $kdbx->entries->grep(\'400', 'title')->each; + is scalar @other, 0, 'Database has one entry'; is $entry->title, 'Format400', 'Entry is titled'; is $entry->username, 'Format400', 'Entry has a username set'; @@ -81,9 +81,9 @@ subtest 'KDBX4 upgrade' => sub { subtest 'KDBX4.1 upgrade' => sub { my $kdbx = File::KDBX->new; - my $group1 = $kdbx->add_group; - my $group2 = $kdbx->add_group; - my $entry1 = $kdbx->add_entry; + my $group1 = $kdbx->add_group(label => 'One'); + my $group2 = $kdbx->add_group(label => 'Two'); + my $entry1 = $kdbx->add_entry(label => 'Meh'); $group1->tags('hi'); is $kdbx->minimum_version, KDBX_VERSION_4_1, 'Groups with tags requires upgrade'; @@ -205,12 +205,12 @@ subtest 'Custom data' => sub { ok isBoolean($kdbx2->public_custom_data->{bool}), 'Boolean is indeed a boolean'; is $kdbx2->public_custom_data->{bytes}, "\1\2\3\4", 'Store some bytes in public custom data'; - my ($group2) = $kdbx2->find_groups({label => 'Group'}); + my $group2 = $kdbx2->groups->grep(label => 'Group')->next; is_deeply $group2->custom_data_value('str'), '你好', 'Store a string in group custom data'; is_deeply $group2->custom_data_value('num'), '42', 'Store a number in group custom data'; is_deeply $group2->custom_data_value('bool'), '1', 'Store a boolean in group custom data'; - my ($entry2) = $kdbx2->find_entries({label => 'Entry'}); + my $entry2 = $kdbx2->entries->grep(label => 'Entry')->next; is_deeply $entry2->custom_data_value('str'), '你好', 'Store a string in entry custom data'; is_deeply $entry2->custom_data_value('num'), '42', 'Store a number in entry custom data'; is_deeply $entry2->custom_data_value('bool'), '0', 'Store a boolean in entry custom data'; diff --git a/t/object.t b/t/object.t index ff46cf8..b176c77 100644 --- a/t/object.t +++ b/t/object.t @@ -52,18 +52,19 @@ subtest 'Cloning' => sub { 'Entry in database and its copy with username ref have same expanded username'; $copy = $entry->clone; - is @{$kdbx->all_entries}, 1, 'Still only one entry after cloning'; + is $kdbx->entries->size, 1, 'Still only one entry after cloning'; $copy = $entry->clone(parent => 1); - is @{$kdbx->all_entries}, 2, 'New copy added to database if clone with parent option'; - my ($e1, $e2) = @{$kdbx->all_entries}; + is $kdbx->entries->size, 2, 'New copy added to database if clone with parent option'; + my ($e1, $e2) = $kdbx->entries->each; isnt $e1, $e2, 'Entry and its copy in the database are different objects'; is $e1->title, $e2->title, 'Entry copy has the same title as the original entry'; $copy = $entry->clone(parent => 1, relabel => 1); - is @{$kdbx->all_entries}, 3, 'New copy added to database if clone with parent option'; - is $kdbx->all_entries->[2], $copy, 'New copy and new entry in the database match'; - is $kdbx->all_entries->[2]->title, "foo - Copy", 'New copy has a modified title'; + is $kdbx->entries->size, 3, 'New copy added to database if clone with parent option'; + my $e3 = $kdbx->entries->skip(2)->next; + is $e3, $copy, 'New copy and new entry in the database match'; + is $e3->title, 'foo - Copy', 'New copy has a modified title'; $copy = $group->clone; cmp_deeply $copy, $group, 'Group and its clone are identical'; @@ -80,10 +81,10 @@ subtest 'Cloning' => sub { $copy = $group->clone(relabel => 1); is $copy->name, 'Passwords - Copy', 'Group copy relabeled from the original title'; - is @{$kdbx->all_entries}, 3, 'No new entries were added to the database'; + is $kdbx->entries->size, 3, 'No new entries were added to the database'; $copy = $group->clone(relabel => 1, parent => 1); - is @{$kdbx->all_entries}, 6, 'Copy a group within parent doubles the number of entries in the database'; + is $kdbx->entries->size, 6, 'Copy a group within parent doubles the number of entries in the database'; isnt $group->entries->[0]->uuid, $copy->entries->[0]->uuid, 'First entry in group and its copy are different'; };