X-Git-Url: https://git.dogcows.com/gitweb?p=chaz%2Fp5-File-KDBX;a=blobdiff_plain;f=lib%2FFile%2FKDBX%2FEntry.pm;h=e97e30a7228d7b8e0d6e9ef0995637331d3d93a3;hp=bc81d5ac87948c2f0aa8db79949e60c7b05c7e2f;hb=63d73bf382edfb0089b36a45193fc2835cb58b6d;hpb=05e0bcef1c2165c556b910314312866dc4a667b7 diff --git a/lib/File/KDBX/Entry.pm b/lib/File/KDBX/Entry.pm index bc81d5a..e97e30a 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(:assert :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 Scalar::Util qw(looks_like_number); +use Ref::Util qw(is_coderef is_hashref is_plain_hashref); +use Scalar::Util qw(blessed 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 @@ -27,20 +27,6 @@ my $PLACEHOLDER_MAX_DEPTH = 10; my %PLACEHOLDERS; my %STANDARD_STRINGS = map { $_ => 1 } qw(Title UserName Password URL Notes); -sub _parent_container { 'entries' } - -=attr uuid - -128-bit UUID identifying the entry within the database. - -=attr icon_id - -Integer representing a default icon. See L for valid values. - -=attr custom_icon_uuid - -128-bit UUID identifying a custom icon within the database. - =attr foreground_color Text color represented as a string of the form C<#000000>. @@ -53,29 +39,28 @@ Background color represented as a string of the form C<#FFFFFF>. TODO -=attr tags +=attr auto_type_enabled + +Whether or not the entry is eligible to be matched for auto-typing. + +=attr auto_type_obfuscation -Text string with arbitrary tags which can be used to build a taxonomy. +Whether or not to use some kind of obfuscation when sending keystroke sequences to applications. -=attr auto_type +=attr auto_type_default_sequence -Auto-type details. +The default auto-type keystroke sequence. + +=attr auto_type_associations + +An array of window title / keystroke sequence associations. { - enabled => true, - data_transfer_obfuscation => 0, - default_sequence => '{USERNAME}{TAB}{PASSWORD}{ENTER}', - associations => [ - { - window => 'My Bank - Mozilla Firefox', - keystroke_sequence => '{PASSWORD}{ENTER}', - }, - ], + window => 'Example Window Title', + keystroke_sequence => '{USERNAME}{TAB}{PASSWORD}{ENTER}', } -=attr previous_parent_group - -128-bit UUID identifying a group within the database. +Keystroke sequences can have , most commonly C<{USERNAME}> and C<{PASSWORD}>. =attr quality_check @@ -96,49 +81,32 @@ Hash with entry strings, including the standard strings as well as any custom on MySystem => { value => 'The mainframe' }, } +There are methods available to provide more convenient access to strings, including L, +L, L and L. + =attr binaries -Files or attachments. +Files or attachments. Binaries are similar to strings except they have a value of bytes instead of test +characters. -=attr custom_data + { + 'myfile.txt' => { + value => '...', + }, + 'mysecrets.txt' => { + value => '...', + protect => true, + }, + } -A set of key-value pairs used to store arbitrary data, usually used by software to keep track of state rather -than by end users (who typically work with the strings and binaries). +There are methods available to provide more convenient access to binaries, including L and +L. =attr history Array of historical entries. Historical entries are prior versions of the same entry so they all share the same UUID with the current entry. -=attr last_modification_time - -Date and time when the entry was last modified. - -=attr creation_time - -Date and time when the entry was created. - -=attr last_access_time - -Date and time when the entry was last accessed. - -=attr expiry_time - -Date and time when the entry expired or will expire. - -=attr expires - -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 B string has -been accessed. - -=attr location_changed - -Date and time when the entry was last moved to a different group. - =attr notes Alias for the B string value. @@ -175,32 +143,37 @@ sub uuid { $self->{uuid}; } -my @ATTRS = qw(uuid custom_data history); -my %ATTRS = ( - # uuid => sub { generate_uuid(printable => 1) }, - icon_id => sub { defined $_[1] ? icon($_[1]) : 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 { scalar gmtime }, - creation_time => sub { scalar gmtime }, - last_access_time => sub { scalar gmtime }, - expiry_time => sub { scalar gmtime }, - expires => false, - usage_count => 0, - location_changed => sub { scalar 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_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', @@ -208,37 +181,16 @@ my %ATTRS_STRINGS = ( url => 'URL', notes => 'Notes', ); - -while (my ($attr, $setter) = each %ATTRS) { - no strict 'refs'; ## no critic (ProhibitNoStrict) - *{$attr} = is_coderef $setter ? sub { - my $self = shift; - $self->{$attr} = $setter->($self, shift) if @_; - $self->{$attr} //= $setter->($self); - } : sub { - my $self = shift; - $self->{$attr} = shift if @_; - $self->{$attr} //= $setter; - }; -} -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, @_) }; + *{"expand_${attr}"} = sub { shift->expand_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 { @@ -326,9 +278,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 @@ -338,17 +296,17 @@ sub string_value { return $string->{value}; } -=method expanded_string_value +=method expand_string_value - $string = $entry->expanded_string_value; + $string = $entry->expand_string_value; Same as L but will substitute placeholders and resolve field references. Any placeholders that do not expand to values are left as-is. See L. -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,12 +353,33 @@ sub _expand_string { return $str; } -sub expanded_string_value { +sub expand_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); } +=attr expand_notes + +Shortcut equivalent to C<< ->expand_string_value('Notes') >>. + +=attr expand_password + +Shortcut equivalent to C<< ->expand_string_value('Password') >>. + +=attr expand_title + +Shortcut equivalent to C<< ->expand_string_value('Title') >>. + +=attr expand_url + +Shortcut equivalent to C<< ->expand_string_value('URL') >>. + +=attr expand_username + +Shortcut equivalent to C<< ->expand_string_value('UserName') >>. + =method other_strings $other = $entry->other_strings; @@ -419,53 +398,135 @@ 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') } +############################################################################## + +=method add_auto_type_association + + $entry->add_auto_type_association(\%association); + +Add a new auto-type association to an entry. + +=cut + +sub add_auto_type_association { + my $self = shift; + my $association = shift; + push @{$self->auto_type_associations}, $association; +} + +=method expand_keystroke_sequence + + $string = $entry->expand_keystroke_sequence($keystroke_sequence); + $string = $entry->expand_keystroke_sequence(\%association); + $string = $entry->expand_keystroke_sequence; # use default auto-type sequence + +Get a keystroke sequence after placeholder expansion. + +=cut + +sub expand_keystroke_sequence { + my $self = shift; + my $association = shift; + + my $keys; + if ($association) { + $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 => '...', + protect => true, # optional + }; + +Every binary should have a value (but might be C due to memory protection) and these optional flags +which might exist: + +=for :list +* C - 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}); + + assert { !defined $args{value} || !utf8::is_utf8($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. Returns C 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 auto_type_enabled { - my $entry = shift; - # TODO -} - ############################################################################## =method hmac_otp @@ -744,8 +805,10 @@ sub size { sub history { my $self = shift; my $entries = $self->{history} //= []; - # FIXME - Looping through entries on each access is too expensive. - @$entries = map { $self->_wrap_entry($_, $self->kdbx) } @$entries; + if (@$entries && !blessed($entries->[0])) { + @$entries = map { $self->_wrap_entry($_, $self->kdbx) } @$entries; + } + assert { !any { !blessed $_ } @$entries }; return $entries; } @@ -764,14 +827,15 @@ sub history_size { =method prune_history - $entry->prune_history(%options); + @removed_historical_entries = $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>: +Remove just as many older historical entries as necessary to get under the database limits. The limits are +taken from the connected database (if any) or can be overridden with C<%options>: =for :list * C - Maximum number of historical entries to keep (default: 10, no limit: -1) * C - Maximum total size (in bytes) of historical entries to keep (default: 6 MiB, no limit: -1) +* C - Maximum age (in days) of historical entries to keep (default: 365, no limit: -1) =cut @@ -779,25 +843,38 @@ sub prune_history { my $self = shift; my %args = @_; - my $max_items = $args{max_items} // eval { $self->kdbx->history_max_items } - // HISTORY_DEFAULT_MAX_ITEMS; - my $max_size = $args{max_size} // eval { $self->kdbx->history_max_size } - // HISTORY_DEFAULT_MAX_SIZE; + my $max_items = $args{max_items} // eval { $self->kdbx->history_max_items } // HISTORY_DEFAULT_MAX_ITEMS; + my $max_size = $args{max_size} // eval { $self->kdbx->history_max_size } // HISTORY_DEFAULT_MAX_SIZE; + my $max_age = $args{max_age} // HISTORY_DEFAULT_MAX_AGE; - # history is ordered oldest to youngest + # history is ordered oldest to newest my $history = $self->history; + my @removed; + if (0 <= $max_items && $max_items < @$history) { - splice @$history, -$max_items; + push @removed, splice @$history, -$max_items; } if (0 <= $max_size) { my $current_size = $self->history_size; while ($max_size < $current_size) { - my $entry = shift @$history; + push @removed, my $entry = shift @$history; $current_size -= $entry->size; } } + + if (0 <= $max_age) { + my $cutoff = gmtime - ($max_age * 86400); + for (my $i = @$history - 1; 0 <= $i; --$i) { + my $entry = $history->[$i]; + next if $cutoff <= $entry->last_modification_time; + push @removed, splice @$history, $i, 1; + } + } + + @removed = sort { $a->last_modification_time <=> $b->last_modification_time } @removed; + return @removed; } =method add_historical_entry @@ -814,6 +891,28 @@ sub add_historical_entry { push @{$self->{history} //= []}, map { $self->_wrap_entry($_) } @_; } +=method remove_historical_entry + + $entry->remove_historical_entry($historical_entry); + +Remove an entry from the history. + +=cut + +sub remove_historical_entry { + my $self = shift; + my $entry = shift; + my $history = $self->history; + + my @removed; + for (my $i = @$history - 1; 0 <= $i; --$i) { + my $item = $history->[$i]; + next if Hash::Util::FieldHash::id($entry) != Hash::Util::FieldHash::id($item); + push @removed, splice @{$self->{history}}, $i, 1; + } + return @removed; +} + =method current_entry $current_entry = $entry->current_entry; @@ -824,11 +923,11 @@ 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 $parent = $self->group; - if ($group) { + if ($parent) { my $id = $self->uuid; - my $entry = first { $id eq $_->uuid } @{$group->entries}; + my $entry = first { $id eq $_->uuid } @{$parent->entries}; return $entry if $entry; } @@ -862,6 +961,53 @@ This is just the inverse of L. sub is_historical { !$_[0]->is_current } +=method remove + + $entry = $entry->remove; + +Remove an entry from its parent group. If the entry is historical, remove it from the history of the current +entry. If the entry is current, this behaves the same as L. + +=cut + +sub remove { + my $self = shift; + my $current = $self->current_entry; + return $self if $current->remove_historical_entry($self); + $self->SUPER::remove(@_); +} + +############################################################################## + +=method searching_enabled + + $bool = $entry->searching_enabled; + +Get whether or not an entry may show up in search results. This is determine from the entry's parent group's +L value. + +Throws if entry has no parent group or if the entry is not connected to a database. + +=cut + +sub searching_enabled { + my $self = shift; + 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}; + return true if !$self->is_connected; + my $parent = $self->group; + return $parent->effective_enable_auto_type if $parent; + return true; +} + ############################################################################## sub _signal { @@ -879,11 +1025,16 @@ sub _commit { $self->last_access_time($time); } -sub label { shift->expanded_title(@_) } +sub label { shift->expand_title(@_) } + +### Name of the parent attribute expected to contain the object +sub _parent_container { 'entries' } 1; __END__ +=for Pod::Coverage auto_type times + =head1 DESCRIPTION An entry in a KDBX database is a record that can contains strings (also called "fields") and binaries (also @@ -986,7 +1137,7 @@ This software supports many (but not all) of the placeholders documented there. * ☑ C<{DT_UTC_MINUTE}> Minute Year component of the current UTC time * ☑ C<{DT_UTC_SECOND}> - Second component of the current UTC time -If the current date and time is <2012-07-25 17:05:34>, the "simple" form would be C<20120725170534>. +If the current date and time is C<2012-07-25 17:05:34>, the "simple" form would be C<20120725170534>. =head3 Special Key Placeholders @@ -1049,7 +1200,7 @@ a placeholder, just set it in the C<%File::KDBX::PLACEHOLDERS> hash. For example If the placeholder is expanded in the context of an entry, C<$entry> is the B object in context. Otherwise it is C. An entry is in context if, for example, the placeholder is in an entry's -strings or auto-complete key sequences. +strings or auto-type key sequences. $File::KDBX::PLACEHOLDERS{'MY_PLACEHOLDER:'} = sub { my ($entry, $arg) = @_; # ^ Notice the colon here