X-Git-Url: https://git.dogcows.com/gitweb?a=blobdiff_plain;f=lib%2FFile%2FKDBX%2FEntry.pm;h=4e5d7a4e44479c68f519204e95c95cc6cbbbcee6;hb=ed23544f026c074e2aeed0028cacee6409b48c77;hp=c124b94203adf169a84aeec91374b2a6ad4e6324;hpb=81604125cc023132207802b4ae0ab4cea12c17fd;p=chaz%2Fp5-File-KDBX diff --git a/lib/File/KDBX/Entry.pm b/lib/File/KDBX/Entry.pm index c124b94..4e5d7a4 100644 --- a/lib/File/KDBX/Entry.pm +++ b/lib/File/KDBX/Entry.pm @@ -4,22 +4,22 @@ package File::KDBX::Entry; use warnings; use strict; -use Crypt::Misc 0.029 qw(encode_b32r decode_b64); +use Crypt::Misc 0.029 qw(decode_b64 encode_b32r); use Devel::GlobalDestruction; use Encode qw(encode); use File::KDBX::Constants qw(:history :icon); use File::KDBX::Error; -use File::KDBX::Util qw(: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(sum0); -use Ref::Util qw(is_plain_hashref); +use List::Util qw(first sum0); +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; use boolean; use namespace::clean; -use parent 'File::KDBX::Object'; +extends 'File::KDBX::Object'; our $VERSION = '999.999'; # VERSION @@ -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. @@ -132,7 +148,7 @@ Boolean value indicating whether or not an entry is expired. =attr usage_count -The number of times an entry has been used, which typically means how many times the C string has +The number of times an entry has been used, which typically means how many times the B string has been accessed. =attr location_changed @@ -141,23 +157,23 @@ Date and time when the entry was last moved to a different group. =attr notes -Alias for the C string value. +Alias for the B string value. =attr password -Alias for the C string value. +Alias for the B string value. =attr title -Alias for the C string value. +Alias for the B<Title> string value. =attr url -Alias for the C<URL> string value. +Alias for the B<URL> string value. =attr username -Aliases for the C<UserName> string value. +Aliases for the B<UserName> string value. =cut @@ -170,39 +186,42 @@ sub uuid { for my $entry (@{$self->history}) { $entry->{uuid} = $uuid; } - # if (defined $old_uuid and my $kdbx = $KDBX{$self}) { - # $kdbx->_update_entry_uuid($old_uuid, $uuid, $self); - # } + $self->_signal('uuid.changed', $uuid, $old_uuid) if defined $old_uuid && $self->is_current; } $self->{uuid}; } -my @ATTRS = qw(uuid custom_data history); -my %ATTRS = ( - # uuid => sub { generate_uuid(printable => 1) }, - icon_id => ICON_PASSWORD, - custom_icon_uuid => undef, - foreground_color => '', - background_color => '', - override_url => '', - tags => '', - auto_type => sub { +{} }, - previous_parent_group => undef, - quality_check => true, - strings => sub { +{} }, - binaries => sub { +{} }, - # custom_data => sub { +{} }, - # history => sub { +[] }, -); -my %ATTRS_TIMES = ( - last_modification_time => sub { gmtime }, - creation_time => sub { gmtime }, - last_access_time => sub { gmtime }, - expiry_time => sub { gmtime }, - expires => false, - usage_count => 0, - location_changed => sub { gmtime }, -); +# has uuid => sub { generate_uuid(printable => 1) }; +has icon_id => ICON_PASSWORD, coerce => \&to_icon_constant; +has custom_icon_uuid => undef, coerce => \&to_uuid; +has foreground_color => '', coerce => \&to_string; +has background_color => '', coerce => \&to_string; +has override_url => '', coerce => \&to_string; +has tags => '', coerce => \&to_string; +has auto_type => {}; +has previous_parent_group => undef, coerce => \&to_uuid; +has quality_check => true, coerce => \&to_bool; +has strings => {}; +has binaries => {}; +has times => {}; +# has custom_data => {}; +# has history => []; + +has last_modification_time => sub { gmtime }, store => 'times', coerce => \&to_time; +has creation_time => sub { gmtime }, store => 'times', coerce => \&to_time; +has last_access_time => sub { gmtime }, store => 'times', coerce => \&to_time; +has expiry_time => sub { gmtime }, store => 'times', coerce => \&to_time; +has expires => false, store => 'times', coerce => \&to_bool; +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', @@ -210,33 +229,16 @@ my %ATTRS_STRINGS = ( url => 'URL', notes => 'Notes', ); - -while (my ($attr, $default) = each %ATTRS) { - no strict 'refs'; ## no critic (ProhibitNoStrict) - *{$attr} = sub { - my $self = shift; - $self->{$attr} = shift if @_; - $self->{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default; - }; -} -while (my ($attr, $default) = each %ATTRS_TIMES) { - no strict 'refs'; ## no critic (ProhibitNoStrict) - *{$attr} = sub { - my $self = shift; - $self->{times} //= {}; - $self->{times}{$attr} = shift if @_; - $self->{times}{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default; - }; -} while (my ($attr, $string_key) = each %ATTRS_STRINGS) { no strict 'refs'; ## no critic (ProhibitNoStrict) *{$attr} = sub { shift->string_value($string_key, @_) }; *{"expanded_${attr}"} = sub { shift->expanded_string_value($string_key, @_) }; } -sub _set_default_attributes { +my @ATTRS = qw(uuid custom_data history auto_type_enabled); +sub _set_nonlazy_attributes { my $self = shift; - $self->$_ for @ATTRS, keys %ATTRS, keys %ATTRS_TIMES, keys %ATTRS_STRINGS; + $self->$_ for @ATTRS, keys %ATTRS_STRINGS, list_attributes(ref $self); } sub init { @@ -324,9 +326,15 @@ sub _protect { =method string_value - $string = $entry->string_value; + $string = $entry->string_value($string_key); + +Access a string value directly. The arguments are the same as for L</string>. Returns C<undef> if the string +is not set or is currently memory-protected. This is just a shortcut for: -Access a string value directly. Returns C<undef> if the string is not set. + my $string = do { + my $s = $entry->string(...); + defined $s ? $s->{value} : undef; + }; =cut @@ -345,8 +353,8 @@ do not expand to values are left as-is. See L</Placeholders>. -Some placeholders (notably field references) require the entry be associated with a database and will throw an -error if there is no association. +Some placeholders (notably field references) require the entry be connected to a database and will throw an +error if it is not. =cut @@ -395,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); } @@ -417,51 +426,131 @@ sub other_strings { return join($delim, @strings); } +=method string_peek + + $string = $entry->string_peek($string_key); + +Same as L</string_value> 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); +} ############################################################################## +=method binary + + \%binary = $entry->binary($binary_key); + + $entry->binary($binary_key, \%binary); + $entry->binary($binary_key, %attributes); + $entry->binary($binary_key, $value); # same as: value => $value + +Get or set a binary. Every binary has a unique (to the entry) key and flags and so are returned as a hash +structure. For example: + + $binary = { + value => 'Password', + protect => true, # optional + }; + +Every binary should have a value (but might be C<undef> due to memory protection) and these optional flags +which might exist: + +=for :list +* C<protect> - Whether or not the binary value should be memory-protected. + +=cut + sub binary { my $self = shift; - my $key = shift or throw 'Must provide a binary key to access'; - if (@_) { - my $arg = @_ == 1 ? shift : undef; - my %args; - @args{keys %$arg} = values %$arg if ref $arg eq 'HASH'; - $args{value} = $arg if !ref $arg; - while (my ($field, $value) = each %args) { - $self->{binaries}{$key}{$field} = $value; + my %args = @_ == 2 ? (key => shift, value => shift) + : @_ % 2 == 1 ? (key => shift, @_) : @_; + + if (!defined $args{key} && !defined $args{value}) { + my %standard = (value => 1, protect => 1); + my @other_keys = grep { !$standard{$_} } keys %args; + if (@other_keys == 1) { + my $key = $args{key} = $other_keys[0]; + $args{value} = delete $args{$key}; } } - my $binary = $self->{binaries}{$key} //= {value => ''}; - if (defined (my $ref = $binary->{ref})) { - $binary = $self->{binaries}{$key} = dclone($self->kdbx->binaries->{$ref}); + + my $key = delete $args{key} or throw 'Must provide a binary key to access'; + + return $self->{binaries}{$key} = $args{value} if is_plain_hashref($args{value}); + + while (my ($field, $value) = each %args) { + $self->{binaries}{$key}{$field} = $value; } - return $binary; + return $self->{binaries}{$key}; } -sub binary_novivify { - my $self = shift; - my $binary_key = shift; - return if !$self->{binaries}{$binary_key} && !@_; - return $self->binary($binary_key, @_); -} +=method binary_value + + $binary = $entry->binary_value($binary_key); + +Access a binary value directly. The arguments are the same as for L</binary>. Returns C<undef> if the binary +is not set or is currently memory-protected. This is just a shortcut for: + + my $binary = do { + my $b = $entry->binary(...); + defined $b ? $b->{value} : undef; + }; + +=cut sub binary_value { my $self = shift; - my $binary = $self->binary_novivify(@_) // return undef; + my $binary = $self->binary(@_) // return undef; return $binary->{value}; } +############################################################################## + +sub searching_enabled { + my $self = shift; + my $parent = $self->group; + return $parent->effective_enable_searching if $parent; + return true; +} + sub auto_type_enabled { - my $entry = shift; - # TODO + my $self = shift; + $self->auto_type->{enabled} = to_bool(shift) if @_; + $self->auto_type->{enabled} //= true; + return false if !$self->auto_type->{enabled}; + return true if !$self->is_connected; + my $parent = $self->group; + return $parent->effective_enable_auto_type if $parent; + return true; } ############################################################################## @@ -765,7 +854,7 @@ sub history_size { $entry->prune_history(%options); Remove as many older historical entries as necessary to get under the database limits. The limits are taken -from the associated database (if any) or can be overridden with C<%options>: +from the connected database (if any) or can be overridden with C<%options>: =for :list * C<max_items> - Maximum number of historical entries to keep (default: 10, no limit: -1) @@ -798,25 +887,83 @@ sub prune_history { } } -sub add_history { +=method add_historical_entry + + $entry->add_historical_entry($entry); + +Add an entry to the history. + +=cut + +sub add_historical_entry { my $self = shift; delete $_->{history} for @_; push @{$self->{history} //= []}, map { $self->_wrap_entry($_) } @_; } +=method current_entry + + $current_entry = $entry->current_entry; + +Get an entry's current entry. If the entry itself is current (not historical), itself is returned. + +=cut + +sub current_entry { + my $self = shift; + my $group = $self->group; + + if ($group) { + my $id = $self->uuid; + my $entry = first { $id eq $_->uuid } @{$group->entries}; + return $entry if $entry; + } + + return $self; +} + +=method is_current + + $bool = $entry->is_current; + +Get whether or not an entry is considered current (i.e. not historical). An entry is current if it is directly +in the parent group's entry list. + +=cut + +sub is_current { + my $self = shift; + my $current = $self->current_entry; + return Hash::Util::FieldHash::id($self) == Hash::Util::FieldHash::id($current); +} + +=method is_historical + + $bool = $entry->is_historical; + +Get whether or not an entry is considered historical (i.e. not current). + +This is just the inverse of L</is_current>. + +=cut + +sub is_historical { !$_[0]->is_current } + ############################################################################## -sub begin_work { +sub _signal { my $self = shift; - require File::KDBX::Transaction; - return File::KDBX::Transaction->new($self, @_); + my $type = shift; + return $self->SUPER::_signal("entry.$type", @_); } sub _commit { my $self = shift; - my $txn = shift; - $self->add_history($txn->original); - $self->last_modification_time(gmtime); + my $orig = shift; + $self->add_historical_entry($orig); + my $time = gmtime; + $self->last_modification_time($time); + $self->last_access_time($time); } sub label { shift->expanded_title(@_) } @@ -831,11 +978,11 @@ called "files" or "attachments"). Every string and binary has a key or name. The that every entry has: =for :list -* C<Title> -* C<UserName> -* C<Password> -* C<URL> -* C<Notes> +* B<Title> +* B<UserName> +* B<Password> +* B<URL> +* B<Notes> Beyond this, you can store any number of other strings and any number of binaries that you can use for whatever purpose you want. @@ -844,12 +991,14 @@ There is also some metadata associated with an entry. Each entry in a database i a UUID. An entry can also have an icon associated with it, and there are various timestamps. Take a look at the attributes to see what's available. +A B<File::KDBX::Entry> is a subclass of L<File::KDBX::Object>. + =head2 Placeholders Entry string and auto-type key sequences can have placeholders or template tags that can be replaced by other values. Placeholders can appear like C<{PLACEHOLDER}>. For example, a B<URL> string might have a value of C<http://example.com?user={USERNAME}>. C<{USERNAME}> is a placeholder for the value of the B<UserName> string -of the same entry. If the C<UserName> string had a value of "batman", the B<URL> string would expand to +of the same entry. If the B<UserName> string had a value of "batman", the B<URL> string would expand to C<http://example.com?user=batman>. Some placeholders take an argument, where the argument follows the tag after a colon but before the closing @@ -962,7 +1111,7 @@ C<{NUMPAD4}>, C<{NUMPAD5}>, C<{NUMPAD6}>, C<{NUMPAD7}>, C<{NUMPAD8}>, C<{NUMPAD9 * ☒ C<{CLIPBOARD}> * ☒ C<{CMD:/CommandLine/Options/}> * ☑ C<{C:Comment}> - Comments are simply replaced by nothing -* ☑ C<{ENV:} and C<%ENV%> - Environment variables +* ☑ C<{ENV:}> and C<%ENV%> - Environment variables * ☒ C<{GROUP_SEL_NOTES}> * ☒ C<{GROUP_SEL_PATH}> * ☒ C<{GROUP_SEL}> @@ -996,7 +1145,7 @@ strings or auto-complete key sequences. If the name of the placeholder ends in a colon, then it is expected to receive an argument. During expansion, everything after the colon and before the end of the placeholder is passed to your placeholder handler -subroutine. So if the placeholder is C<{MY_PLACEHOLDER:whatever}>, C<$arg> will have the value C<whatever>. +subroutine. So if the placeholder is C<{MY_PLACEHOLDER:whatever}>, C<$arg> will have the value B<whatever>. An argument is required for placeholders than take one. I.e. The placeholder handler won't be called if there is no argument. If you want a placeholder to support an optional argument, you'll need to set the placeholder