From 8ccefe1cedea9b0886a44ad096aa5710528eaac7 Mon Sep 17 00:00:00 2001 From: Charles McGarvey Date: Thu, 28 Apr 2022 16:51:25 -0600 Subject: [PATCH] Remove parent Object method --- lib/File/KDBX.pm | 110 ++++++++++++++++-------------- lib/File/KDBX/Entry.pm | 82 +++++++++++++++++++--- lib/File/KDBX/Group.pm | 6 +- lib/File/KDBX/Iterator.pm | 139 +++++++++++++++++++------------------- lib/File/KDBX/Object.pm | 35 ++++------ lib/File/KDBX/Util.pm | 47 ++++++++----- t/entry.t | 32 ++++++++- 7 files changed, 276 insertions(+), 175 deletions(-) diff --git a/lib/File/KDBX.pm b/lib/File/KDBX.pm index 47b49a1..d02199a 100644 --- a/lib/File/KDBX.pm +++ b/lib/File/KDBX.pm @@ -590,7 +590,7 @@ sub last_top_visible { =method add_group - $kdbx->add_group($group, %options); + $kdbx->add_group($group); $kdbx->add_group(%group_attributes, %options); Add a group to a database. This is equivalent to identifying a parent group and calling @@ -1104,9 +1104,9 @@ our %PLACEHOLDERS = ( 'OPERA' => sub { load_optional('IPC::Cmd'); IPC::Cmd::can_run('opera') }, 'SAFARI' => sub { load_optional('IPC::Cmd'); IPC::Cmd::can_run('safari') }, 'APPDIR' => sub { load_optional('FindBin'); $FindBin::Bin }, - 'GROUP' => sub { my $p = $_[0]->parent; $p ? $p->name : undef }, + 'GROUP' => sub { my $p = $_[0]->group; $p ? $p->name : undef }, 'GROUP_PATH' => sub { $_[0]->path }, - 'GROUP_NOTES' => sub { my $p = $_[0]->parent; $p ? $p->notes : undef }, + 'GROUP_NOTES' => sub { my $p = $_[0]->group; $p ? $p->notes : undef }, # 'GROUP_SEL' # 'GROUP_SEL_PATH' # 'GROUP_SEL_NOTES' @@ -1865,7 +1865,7 @@ See L for many more query examples. my $entries = $kdbx->entries(auto_type => 1) ->filter(sub { - my $ata = $_->auto_type_associations->grep(sub { $_->{window} =~ $window_title })->next; + my ($ata) = grep { $_->{window} =~ /\Q$window_title\E/i } @{$_->auto_type_associations}; return [$_, $ata->{keystroke_sequence}] if $ata; }) ->each(sub { @@ -1980,11 +1980,14 @@ unfortunately not portable. =head1 QUERY -B - All these examples are WRONG now. +To find things in a KDBX database, you should use a filtered iterator. If you have an iterator, such as +returned by L, L or even L you can filter it using L. -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. + my $filtered_results = $kdbx->entries->where($query); + +A C<$query> is just a subroutine that you can either write yourself or have generated for you from either +a L or L. It's easier to have your query generated, so I'll cover +that first. =head2 Simple Expression @@ -1997,55 +2000,56 @@ one of the given fields. So a simple expression is something like what you might type into a search engine. You can generate a simple expression query using L or by passing the simple expression as -a B to search methods like L. +a B to C. To search for all entries in a database with the word "canyon" appearing anywhere in the title: - my @entries = $kdbx->find_entries([ \'canyon', qw(title) ]); + my $entries = $kdbx->entries->where(\'canyon', qw[title]); -Notice the first argument is a B. This diambiguates a simple expression from other types of queries +Notice the first argument is a B. This diambiguates a simple expression from other types of queries covered below. As mentioned, a simple expression can have multiple terms. This simple expression query matches any entry that has the words "red" B "canyon" anywhere in the title: - my @entries = $kdbx->find_entries([ \'red canyon', qw(title) ]); + my $entries = $kdbx->entries->where(\'red canyon', qw[title]); Each term in the simple expression must be found for an entry to match. To search for entries with "red" in the title but B "canyon", just prepend "canyon" with a minus sign: - my @entries = $kdbx->find_entries([ \'red -canyon', qw(title) ]); + my $entries = $kdbx->entries->where(\'red -canyon', qw[title]); To search over multiple fields simultaneously, just list them. To search for entries with "grocery" in the title or notes but not "Foodland": - my @entries = $kdbx->find_entries([ \'grocery -Foodland', qw(title notes) ]); + my $entries = $kdbx->entries->where(\'grocery -Foodland', qw[title notes]); The default operator is a case-insensitive regexp match, which is fine for searching text loosely. You can use just about any binary comparison operator that perl supports. To specify an operator, list it after the simple expression. For example, to search for any entry that has been used at least five times: - my @entries = $kdbx->find_entries([ \5, '>=', qw(usage_count) ]); + my $entries = $kdbx->entries->where(\5, '>=', qw[usage_count]); It helps to read it right-to-left, like "usage_count is >= 5". -If you find the disambiguating structures to be confusing, you can also the L method as -a more intuitive alternative. The following example is equivalent to the previous: +If you find the disambiguating structures to be distracting or confusing, you can also the +L function as a more intuitive alternative. The following example is +equivalent to the previous: - my @entries = $kdbx->find_entries_simple(5, '>=', qw(usage_count)); + my $entries = $kdbx->entries->where(simple_expression_query(5, '>=', qw[usage_count])); -=head2 Declarative Query +=head2 Declarative Syntax Structuring a declarative query is similar to L, but you don't have to be familiar with that module. Just learn by examples. To search for all entries in a database titled "My Bank": - my @entries = $kdbx->find_entries({ title => 'My Bank' }); + my $entries = $kdbx->entries->where({ title => 'My Bank' }); -The query here is C<< { title => 'My Bank' } >>. A hashref can contain key-value pairs where the key is -a attribute of the thing being searched for (in this case an entry) and the value is what you want the thing's +The query here is C<< { title => 'My Bank' } >>. A hashref can contain key-value pairs where the key is an +attribute of the thing being searched for (in this case an entry) and the value is what you want the thing's attribute to be to consider it a match. In this case, the attribute we're using as our match criteria is L, a text field. If an entry has its title attribute equal to "My Bank", it's a match. @@ -2054,33 +2058,35 @@ A hashref can contain multiple attributes. The search candidate will be a match attributes are equal to their respective values. For example, to search for all entries with a particular URL B username: - my @entries = $kdbx->find_entries({ + my $entries = $kdbx->entries->where({ url => 'https://example.com', username => 'neo', }); To search for entries matching I criteria, just change the hashref to an arrayref. To search for entries -with a particular URL B a particular username: +with a particular URL B username: - my @entries = $kdbx->find_entries([ # <-- square bracket + my $entries = $kdbx->entries->where([ # <-- Notice the square bracket url => 'https://example.com', username => 'neo', ]); -You can user different operators to test different types of attributes. The L + + +You can use different operators to test different types of attributes. The L attribute is a number, so we should use a number comparison operator. To find entries using the smartphone icon: - my @entries = $kdbx->find_entries({ + my $entries = $kdbx->entries->where({ icon_id => { '==', ICON_SMARTPHONE }, }); Note: L is just a constant from L. It isn't special to this example or to queries generally. We could have just used a literal number. -The important thing to notice here is how we wrapped the condition in another arrayref with a single key-pair -where the key is the name of an operator and the value is the thing to match against. The supported operators -are: +The important thing to notice here is how we wrapped the condition in another arrayref with a single key-value +pair where the key is the name of an operator and the value is the thing to match against. The supported +operators are: =for :list * C - String equal @@ -2107,7 +2113,7 @@ Other special operators: * C<-false> - Boolean false * C<-not> - Boolean false (alias for C<-false>) * C<-defined> - Is defined -* C<-undef> - Is not d efined +* C<-undef> - Is not defined * C<-empty> - Is empty * C<-nonempty> - Is not empty * C<-or> - Logical or @@ -2116,42 +2122,46 @@ Other special operators: Let's see another example using an explicit operator. To find all groups except one in particular (identified by its L), we can use the C (string not equal) operator: - my ($group, @other) = $kdbx->find_groups({ + my $groups = $kdbx->groups->where( uuid => { 'ne' => uuid('596f7520-6172-6520-7370-656369616c2e'), }, - }); - if (@other) { say "Problem: there can be only one!" } + ); + if (1 < $groups->count) { say "Problem: there can be only one!" } -Note: L is a little helper function to convert a UUID in its pretty form into octets. +Note: L is a little helper function to convert a UUID in its pretty form into bytes. This helper function isn't special to this example or to queries generally. It could have been written with a literal such as C<"\x59\x6f\x75\x20\x61...">, but that's harder to read. Notice we searched for groups this time. Finding groups works exactly the same as it does for entries. +Notice also that we didn't wrap the query in hashref curly-braces or arrayref square-braces. Those are +optional. By default it will only match ALL attributes (as if there were curly-braces), but it doesn't matter +if there is only one attribute so it's fine to rely on the implicit behavior. + Testing the truthiness of an attribute is a little bit different because it isn't a binary operation. To find all entries with the password quality check disabled: - my @entries = $kdbx->find_entries({ '!' => 'quality_check' }); + my $entries = $kdbx->entries->where('!' => 'quality_check'); This time the string after the operator is the attribute name rather than a value to compare the attribute against. To test that a boolean value is true, use the C operator (or C<-true> if C seems a little too weird for your taste): - my @entries = $kdbx->find_entries({ '!!' => 'quality_check' }); - my @entries = $kdbx->find_entries({ -true => 'quality_check' }); + my $entries = $kdbx->entries->where('!!' => 'quality_check'); + my $entries = $kdbx->entries->where(-true => 'quality_check'); Yes, there is also a C<-false> and a C<-not> if you prefer one of those over C. C<-false> and C<-not> (along with C<-true>) are also special in that you can use them to invert the logic of a subquery. These are logically equivalent: - my @entries = $kdbx->find_entries([ -not => { title => 'My Bank' } ]); - my @entries = $kdbx->find_entries({ title => { 'ne' => 'My Bank' } }); + my $entries = $kdbx->entries->where(-not => { title => 'My Bank' }); + my $entries = $kdbx->entries->where(title => { 'ne' => 'My Bank' }); These special operators become more useful when combined with two more special operators: C<-and> and C<-or>. With these, it is possible to construct more interesting queries with groups of logic. For example: - my @entries = $kdbx->find_entries({ + my $entries = $kdbx->entries->where({ title => { '=~', qr/bank/ }, -not => { -or => { @@ -2162,22 +2172,20 @@ With these, it is possible to construct more interesting queries with groups of }); In English, find entries where the word "bank" appears anywhere in the title but also do not have either the -word "business" in the notes or is using the full trashcan icon. +word "business" in the notes or are using the full trashcan icon. =head2 Subroutine Query Lastly, as mentioned at the top, you can ignore all this and write your own subroutine. Your subroutine will -be called once for each thing being searched over. The single argument is the search candidate. The subroutine -should match the candidate against whatever criteria you want and return true if it matches. The C -methods collect all matching things and return them. +be called once for each object being searched over. The subroutine should match the candidate against whatever +criteria you want and return true if it matches or false to skip. To do this, just pass your subroutine +coderef to C. -For example, to find all entries in the database titled "My Bank": +For example, these are all equivalent to find all entries in the database titled "My Bank": - my @entries = $kdbx->find_entries(sub { shift->title eq 'My Bank' }); - # logically the same as this declarative structure: - my @entries = $kdbx->find_entries({ title => 'My Bank' }); - # as well as this simple expression: - my @entries = $kdbx->find_entries([ \'My Bank', 'eq', qw{title} ]); + my $entries = $kdbx->entries->where(\'"My Bank"', 'eq', qw[title]); # simple expression + my $entries = $kdbx->entries->where(title => 'My Bank'); # declarative syntax + my $entries = $kdbx->entries->where(sub { $_->title eq 'My Bank' }); # subroutine query This is a trivial example, but of course your subroutine can be arbitrarily complex. diff --git a/lib/File/KDBX/Entry.pm b/lib/File/KDBX/Entry.pm index e9e107f..2afe50f 100644 --- a/lib/File/KDBX/Entry.pm +++ b/lib/File/KDBX/Entry.pm @@ -9,10 +9,10 @@ use Devel::GlobalDestruction; use Encode qw(encode); use File::KDBX::Constants qw(:history :icon); use File::KDBX::Error; -use File::KDBX::Util qw(:class :coercion :function :uri generate_uuid load_optional); +use File::KDBX::Util qw(:class :coercion :erase :function :uri generate_uuid load_optional); use Hash::Util::FieldHash; use List::Util qw(first sum0); -use Ref::Util qw(is_coderef is_plain_hashref); +use Ref::Util qw(is_coderef is_hashref is_plain_hashref); use Scalar::Util qw(looks_like_number); use Storable qw(dclone); use Time::Piece; @@ -73,6 +73,22 @@ Auto-type details. ], } +=attr auto_type_enabled + +Whether or not the entry is eligible to be matched for auto-typing. + +=attr auto_type_data_transfer_obfuscation + +TODO + +=attr auto_type_default_sequence + +The default auto-type keystroke sequence. + +=attr auto_type_associations + +An array of window title / keystroke sequence associations. + =attr previous_parent_group 128-bit UUID identifying a group within the database. @@ -199,6 +215,13 @@ has expires => false, store => 'times', coerce => \&to_ has usage_count => 0, store => 'times', coerce => \&to_number; has location_changed => sub { gmtime }, store => 'times', coerce => \&to_time; +# has 'auto_type.auto_type_enabled' => true, coerce => \&to_bool; +has 'auto_type_data_transfer_obfuscation' => 0, path => 'auto_type.data_transfer_obfuscation', + coerce => \&to_number; +has 'auto_type_default_sequence' => '{USERNAME}{TAB}{PASSWORD}{ENTER}', + path => 'auto_type.default_sequence', coerce => \&to_string; +has 'auto_type_associations' => [], path => 'auto_type.associations'; + my %ATTRS_STRINGS = ( title => 'Title', username => 'UserName', @@ -212,7 +235,7 @@ while (my ($attr, $string_key) = each %ATTRS_STRINGS) { *{"expanded_${attr}"} = sub { shift->expanded_string_value($string_key, @_) }; } -my @ATTRS = qw(uuid custom_data history); +my @ATTRS = qw(uuid custom_data history auto_type_enabled); sub _set_nonlazy_attributes { my $self = shift; $self->$_ for @ATTRS, keys %ATTRS_STRINGS, list_attributes(ref $self); @@ -303,9 +326,15 @@ sub _protect { =method string_value - $string = $entry->string_value; + $string = $entry->string_value($string_key); -Access a string value directly. Returns C if the string is not set. +Access a string value directly. The arguments are the same as for L. Returns C if the string +is not set or is currently memory-protected. This is just a shortcut for: + + my $string = do { + my $s = $entry->string(...); + defined $s ? $s->{value} : undef; + }; =cut @@ -374,7 +403,8 @@ sub _expand_string { sub expanded_string_value { my $self = shift; - my $str = $self->string_value(@_) // return undef; + my $str = $self->string_peek(@_) // return undef; + my $cleanup = erase_scoped $str; return $self->_expand_string($str); } @@ -396,13 +426,42 @@ sub other_strings { return join($delim, @strings); } +=method string_peek + + $string = $entry->string_peek($string_key); + +Same as L but can also retrieve the value from protected-memory if the value is currently +protected. + +=cut + sub string_peek { my $self = shift; my $string = $self->string(@_); return defined $string->{value} ? $string->{value} : $self->kdbx->peek($string); } -sub password_peek { $_[0]->string_peek('Password') } +############################################################################## + +sub add_auto_type_association { + my $self = shift; + my $association = shift; + push @{$self->auto_type_associations}, $association; +} + +sub expand_keystroke_sequence { + my $self = shift; + my $association = shift; + + my $keys = is_hashref($association) && exists $association->{keystroke_sequence} ? + $association->{keystroke_sequence} : defined $association ? $association : ''; + + $keys = $self->auto_type_default_sequence if !$keys; + # TODO - Fall back to getting default sequence from parent group, which probably means we shouldn't be + # setting a default value in the entry.. + + return $self->_expand_string($keys); +} ############################################################################## @@ -440,15 +499,18 @@ sub binary_value { sub searching_enabled { my $self = shift; - my $parent = $self->parent; + my $parent = $self->group; return $parent->effective_enable_searching if $parent; return true; } sub auto_type_enabled { my $self = shift; + $self->auto_type->{enabled} = to_bool(shift) if @_; + $self->auto_type->{enabled} //= true; return false if !$self->auto_type->{enabled}; - my $parent = $self->parent; + return true if !$self->is_connected; + my $parent = $self->group; return $parent->effective_enable_auto_type if $parent; return true; } @@ -811,7 +873,7 @@ Get an entry's current entry. If the entry itself is current (not historical), i sub current_entry { my $self = shift; - my $group = $self->parent; + my $group = $self->group; if ($group) { my $id = $self->uuid; diff --git a/lib/File/KDBX/Group.pm b/lib/File/KDBX/Group.pm index 0c784cd..bbd3fc2 100644 --- a/lib/File/KDBX/Group.pm +++ b/lib/File/KDBX/Group.pm @@ -447,7 +447,7 @@ sub effective_default_auto_type_sequence { my $sequence = $self->default_auto_type_sequence; return $sequence if defined $sequence; - my $parent = $self->parent or return '{USERNAME}{TAB}{PASSWORD}{ENTER}'; + my $parent = $self->group or return '{USERNAME}{TAB}{PASSWORD}{ENTER}'; return $parent->effective_default_auto_type_sequence; } @@ -456,7 +456,7 @@ sub effective_enable_auto_type { my $enabled = $self->enable_auto_type; return $enabled if defined $enabled; - my $parent = $self->parent or return true; + my $parent = $self->group or return true; return $parent->effective_enable_auto_type; } @@ -465,7 +465,7 @@ sub effective_enable_searching { my $enabled = $self->enable_searching; return $enabled if defined $enabled; - my $parent = $self->parent or return true; + my $parent = $self->group or return true; return $parent->effective_enable_searching; } diff --git a/lib/File/KDBX/Iterator.pm b/lib/File/KDBX/Iterator.pm index f661706..c9fc761 100644 --- a/lib/File/KDBX/Iterator.pm +++ b/lib/File/KDBX/Iterator.pm @@ -57,32 +57,17 @@ sub new { $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: +discarding any unmatching items before the matching item. 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, @_); + $code = query_any($code, @_); while (defined (local $_ = $self->())) { return $_ if $code->($_); @@ -136,6 +121,8 @@ Get the rest of the items. There are two forms: Without arguments, C retur 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<$_>. +B This method drains the iterator completely, leaving it empty. See L. + =cut sub each { @@ -147,18 +134,10 @@ sub each { 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 +=method where + \&iterator = $iterator->grep(\&query); \&iterator = $iterator->grep([\'simple expression', @fields]); @@ -167,11 +146,11 @@ by a query. =cut +sub where { shift->grep(@_) } + sub grep { my $self = shift; - my $code = shift; - - $code = $self->_create_query($code, @_); + my $code = query_any(@_); ref($self)->new(sub { while (defined (local $_ = $self->())) { @@ -200,23 +179,6 @@ sub map { }); } -=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); @@ -234,15 +196,11 @@ subroutine is called once for each item and should return a string value. Option 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. +B This method drains the iterator completely and places the sorted items onto the buffer. See +L. =cut -sub sort_by { shift->order_by(@_) } -sub nsort_by { shift->norder_by(@_) } - sub order_by { my $self = shift; my $field = shift; @@ -283,7 +241,13 @@ sub order_by { return $self; } -=method nsort_by +=method sort_by + +Alias for L. + +=cut + +sub sort_by { shift->order_by(@_) } =method norder_by @@ -291,17 +255,16 @@ sub order_by { \&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: +is done numerically using C<< <=> >>. The C<\&get_value> subroutine or C<$field> accessor 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. +B This method drains the iterator completely and places the sorted items onto the buffer. See +L. =cut @@ -326,14 +289,33 @@ sub norder_by { return $self; } +=method nsort_by + +Alias for L. + +=cut + +sub nsort_by { shift->norder_by(@_) } + +=method limit + + \&iterator = $iterator->limit($count); + +Get a new iterator draining from an existing iterator but providing only a limited number of items. + +C as an alias for Lhead($count)">. + +=cut + +sub limit { shift->head(@_) } + =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. +B This method drains the iterator completely, leaving it empty. See L. =cut @@ -347,19 +329,15 @@ sub to_array { =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. +B This method drains the iterator completely but restores it to its pre-drained state. See L. =cut -sub size { +sub count { my $self = shift; my $items = $self->to_array; @@ -367,7 +345,15 @@ sub size { return scalar @$items; } -sub count { shift->size } +=method size + +Alias for L. + +=cut + +sub size { shift->count } + +############################################################################## sub TO_JSON { $_[0]->to_array } @@ -378,9 +364,11 @@ __END__ =head1 SYNOPSIS + my $kdbx = File::KDBX->load('database.kdbx', 'masterpw'); + $kdbx->entries - ->grep(sub { $_->title =~ /bank/i }) - ->sort_by('title') + ->where(sub { $_->title =~ /bank/i }) + ->order_by('title') ->limit(5) ->each(sub { say $_->title; @@ -389,7 +377,8 @@ __END__ =head1 DESCRIPTION A buffered iterator compatible with and expanding upon L, this provides an easy way to -navigate a L database. +navigate a L database. The documentation for B documents functions and methods +supported but this iterator that are not documented here, so consider that additional reading. =head2 Buffer @@ -402,4 +391,12 @@ call it with arguments, however, the arguments are added to the buffer. When cal 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. +=head1 CAVEATS + +Some methods attempt to drain the iterator completely before returning. For obvious reasons, this won't work +for infinite iterators because your computer doesn't have infinite memory. This isn't a practical issue with +B lists which are always finite -- unless you do something weird like force a child group to be +its own ancestor -- but I'm noting it here as a potential issue if you use this iterator class for other +things (which you probably shouldn't do). + =cut diff --git a/lib/File/KDBX/Object.pm b/lib/File/KDBX/Object.pm index 9f25c38..1fd1415 100644 --- a/lib/File/KDBX/Object.pm +++ b/lib/File/KDBX/Object.pm @@ -131,11 +131,11 @@ sub label { die 'Not implemented' } =method clone - $object_copy = $object->clone; + $object_copy = $object->clone(%options); $object_copy = File::KDBX::Object->new($object); Make a clone of an object. By default the clone is indeed an exact copy that is connected to the same database -but not actually included in the object tree (i.e. it has no parent). Some options are allowed to get +but not actually included in the object tree (i.e. it has no parent group). Some options are allowed to get different effects: =for :list @@ -170,7 +170,7 @@ sub clone { if ($args{relabel} and my $label = $self->label) { $copy->label("$label - Copy"); } - if ($args{parent} and my $parent = $self->parent) { + if ($args{parent} and my $parent = $self->group) { $parent->add_object($copy); } @@ -286,13 +286,8 @@ sub id { format_uuid(shift->uuid, @_) } =method group -=method parent - - $group = $object->group; - # OR equivalently - $group = $object->parent; - - $object->group($new_parent); + $parent_group = $object->group; + $object->group($parent_group); Get or set the parent group to which an object belongs or C if it belongs to no group. @@ -322,8 +317,6 @@ sub group { return $group; } -sub parent { shift->group(@_) } - sub _set_group { my $self = shift; if (my $parent = shift) { @@ -358,10 +351,10 @@ sub lineage { # try leaf to root my @path; - my $o = $self; - while ($o = $o->parent) { - unshift @path, $o; - last if $base_addr == Hash::Util::FieldHash::id($o); + my $object = $self; + while ($object = $object->group) { + unshift @path, $object; + last if $base_addr == Hash::Util::FieldHash::id($object); } return \@path if @path && ($base_addr == Hash::Util::FieldHash::id($path[0]) || $path[0]->is_root); @@ -383,7 +376,7 @@ are removed as well. Options: sub remove { my $self = shift; - my $parent = $self->parent; + my $parent = $self->group; $parent->remove_object($self, @_) if $parent; $self->_set_group(undef); return $self; @@ -399,7 +392,7 @@ Remove an object from its parent and add it to the connected database's recycle sub recycle { my $self = shift; - return $self->parent($self->kdbx->recycle_bin); + return $self->group($self->kdbx->recycle_bin); } =method recycle_or_remove @@ -433,7 +426,7 @@ Get whether or not an object is in a recycle bin. sub is_recycled { my $self = shift; eval { $self->kdbx } or return FALSE; - return !!($self->parent && any { $_->is_recycle_bin } @{$self->lineage}); + return !!($self->group && any { $_->is_recycle_bin } @{$self->lineage}); } ############################################################################## @@ -817,7 +810,7 @@ one of: * L It is possible to copy or move objects between databases, but B include the same object in more -than one database at once or there could some strange aliasing effects (i.e. changes in one database might +than one database at once or there could be some strange aliasing effects (i.e. changes in one database might effect another in unexpected ways). This could lead to difficult-to-debug problems. It is similarly not safe or valid to add the same object multiple times to the same database. For example: @@ -838,6 +831,6 @@ Instead, do this: $another_kdbx->add_entry($entry->clone); # OR move an existing entry from one database to another: - $kdbx->add_entry($entry->remove); + $another_kdbx->add_entry($entry->remove); =cut diff --git a/lib/File/KDBX/Util.pm b/lib/File/KDBX/Util.pm index 5b12e9d..9c4e6f6 100644 --- a/lib/File/KDBX/Util.pm +++ b/lib/File/KDBX/Util.pm @@ -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 simple_expression_query)], + search => [qw(query query_any 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)], @@ -442,11 +442,13 @@ sub has { my $store = $args{store}; ($store, $name) = split(/\./, $name, 2) if $name =~ /\./; - push @{$ATTRIBUTES{$package} //= []}, $name; - my $store_code = ''; - $store_code = qq{->$store} if $store; - my $member = qq{\$_[0]$store_code\->{'$name'}}; + my @path = split(/\./, $args{path} || ''); + my $last = pop @path; + my $path = $last ? join('', map { qq{->$_} } @path) . qq{->{'$last'}} + : $store ? qq{->$store\->{'$name'}} : qq{->{'$name'}}; + my $member = qq{\$_[0]$path}; + my $default_code = is_coderef $default ? q{scalar $default->($_[0])} : defined $default ? q{$default} @@ -460,6 +462,7 @@ sub has { : qq{$member = \$_[1] if \$#_;}; } + push @{$ATTRIBUTES{$package} //= []}, $name; $line -= 4; my $code = < for examples. sub query { _query(undef, '-or', \@_) } +=func query_any + +Get either a L or L, depending on the arguments. + +=cut + +sub query_any { + 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, @_); + } +} + =func read_all $size = read_all($fh, my $buffer, $size); @@ -739,23 +762,11 @@ sub recurse_limit { Execute a linear search over an array of records using a L. A "record" is usually a hash. -This is the search engine described with many examples at L. - =cut sub search { my $list = shift; - my $query = shift; - - if (is_coderef($query) && !@_) { - # already a query - } - elsif (is_scalarref($query)) { - $query = simple_expression_query($$query, @_); - } - else { - $query = query($query, @_); - } + my $query = query_any(@_); my @match; for my $item (@$list) { diff --git a/t/entry.t b/t/entry.t index 988e712..8a6d5eb 100644 --- a/t/entry.t +++ b/t/entry.t @@ -30,7 +30,12 @@ subtest 'Construction' => sub { is $entry->username, 'bar', 'username is set correctly as the UserName string'; cmp_deeply $entry, noclass({ - auto_type => {}, + auto_type => { + associations => [], + data_transfer_obfuscation => 0, + default_sequence => "{USERNAME}{TAB}{PASSWORD}{ENTER}", + enabled => bool(1), + }, background_color => "", binaries => {}, custom_data => {}, @@ -139,4 +144,29 @@ subtest 'Update UUID' => sub { or diag explain $entry2->url; }; +subtest 'Auto-type' => sub { + my $kdbx = File::KDBX->new; + + my $entry = $kdbx->add_entry(title => 'Meh'); + $entry->add_auto_type_association({ + window => 'Boring Store', + keystroke_sequence => 'yeesh', + }); + $entry->add_auto_type_association({ + window => 'Friendly Bank', + keystroke_sequence => 'blah', + }); + + my $window_title = 'Friendly'; + my $entries = $kdbx->entries(auto_type => 1) + ->filter(sub { + my ($ata) = grep { $_->{window} =~ /\Q$window_title\E/i } @{$_->auto_type_associations}; + return [$_, $ata->{keystroke_sequence} || $_->auto_type_default_sequence] if $ata; + }); + cmp_ok $entries->count, '==', 1, 'Find auto-type window association'; + + (undef, my $keys) = @{$entries->next}; + is $keys, 'blah', 'Select the correct association'; +}; + done_testing; -- 2.45.2