use File::KDBX::Constants qw(:all);
use File::KDBX::Error;
use File::KDBX::Safe;
-use File::KDBX::Util qw(:empty erase generate_uuid search simple_expression_query snakify);
-use List::Util qw(any);
+use File::KDBX::Util qw(:class :coercion :empty :search :uuid erase simple_expression_query snakify);
+use Hash::Util::FieldHash qw(fieldhashes);
+use List::Util qw(any first);
use Ref::Util qw(is_ref is_arrayref is_plain_hashref);
-use Scalar::Util qw(blessed refaddr);
+use Scalar::Util qw(blessed);
use Time::Piece;
use boolean;
-use warnings::register;
use namespace::clean;
our $VERSION = '999.999'; # VERSION
our $WARNINGS = 1;
-my %SAFE;
-my %KEYS;
+fieldhashes \my (%SAFE, %KEYS);
=method new
my $self = bless {}, $class;
$self->init(@_);
- $self->_set_default_attributes if empty $self;
+ $self->_set_nonlazy_attributes if empty $self;
return $self;
}
-sub DESTROY { !in_global_destruction and $_[0]->reset }
+sub DESTROY { local ($., $@, $!, $^E, $?); !in_global_destruction and $_[0]->reset }
=method init
$kdbx = $kdbx->init(%attributes);
-Initialize a L<File::KDBX> with a new set of attributes. Returns itself to allow method chaining.
+Initialize a L<File::KDBX> with a set of attributes. Returns itself to allow method chaining.
This is called by L</new>.
erase $self->inner_headers->{+INNER_HEADER_INNER_RANDOM_STREAM_KEY};
erase $self->{raw};
%$self = ();
- delete $SAFE{refaddr($self)};
$self->_remove_safe;
return $self;
}
my $copy = {%$self};
- return '', $copy, $KEYS{refaddr($self)}, $SAFE{refaddr($self)};
+ return '', $copy, $KEYS{$self} // (), $SAFE{$self} // ();
}
sub STORABLE_thaw {
my $self = shift;
my $cloning = shift;
+ shift;
my $clone = shift;
my $key = shift;
my $safe = shift;
@$self{keys %$clone} = values %$clone;
- $KEYS{refaddr($self)} = $key;
- $SAFE{refaddr($self)} = $safe;
+ $KEYS{$self} = $key;
+ $SAFE{$self} = $safe;
+
+ # 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);
+ }
}
##############################################################################
__PACKAGE__, $VERSION, @Config::Config{qw(package version osname osvers archname)});
}
-=attr sig1
-
-=attr sig2
-
-=attr version
-
-=attr headers
-
-=attr inner_headers
-
-=attr meta
-
-=attr binaries
-
-=attr deleted_objects
-
-=attr raw
-
- $value = $kdbx->$attr;
- $kdbx->$attr($value);
-
-Get and set attributes.
-
-=cut
-
-my %ATTRS = (
- sig1 => KDBX_SIG1,
- sig2 => KDBX_SIG2_2,
- version => KDBX_VERSION_3_1,
- headers => sub { +{} },
- inner_headers => sub { +{} },
- meta => sub { +{} },
- binaries => sub { +{} },
- deleted_objects => sub { +{} },
- raw => undef,
-);
-my %ATTRS_HEADERS = (
- HEADER_COMMENT() => '',
- HEADER_CIPHER_ID() => CIPHER_UUID_CHACHA20,
- HEADER_COMPRESSION_FLAGS() => COMPRESSION_GZIP,
- HEADER_MASTER_SEED() => sub { random_bytes(32) },
- # HEADER_TRANSFORM_SEED() => sub { random_bytes(32) },
- # HEADER_TRANSFORM_ROUNDS() => 100_000,
- HEADER_ENCRYPTION_IV() => sub { random_bytes(16) },
- # HEADER_INNER_RANDOM_STREAM_KEY() => sub { random_bytes(32) }, # 64?
- HEADER_STREAM_START_BYTES() => sub { random_bytes(32) },
- # HEADER_INNER_RANDOM_STREAM_ID() => STREAM_ID_CHACHA20,
- HEADER_KDF_PARAMETERS() => sub {
- +{
- KDF_PARAM_UUID() => KDF_UUID_AES,
- KDF_PARAM_AES_ROUNDS() => $_[0]->headers->{+HEADER_TRANSFORM_ROUNDS} // KDF_DEFAULT_AES_ROUNDS,
- KDF_PARAM_AES_SEED() => $_[0]->headers->{+HEADER_TRANSFORM_SEED} // random_bytes(32),
- };
- },
- # HEADER_PUBLIC_CUSTOM_DATA() => sub { +{} },
-);
-my %ATTRS_META = (
- generator => '',
- header_hash => '',
- database_name => '',
- database_name_changed => sub { gmtime },
- database_description => '',
- database_description_changed => sub { gmtime },
- default_username => '',
- default_username_changed => sub { gmtime },
- maintenance_history_days => 0,
- color => '',
- master_key_changed => sub { gmtime },
- master_key_change_rec => -1,
- master_key_change_force => -1,
- # memory_protection => sub { +{} },
- custom_icons => sub { +{} },
- recycle_bin_enabled => true,
- recycle_bin_uuid => "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0",
- recycle_bin_changed => sub { gmtime },
- entry_templates_group => "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0",
- entry_templates_group_changed => sub { gmtime },
- last_selected_group => "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0",
- last_top_visible_group => "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0",
- history_max_items => HISTORY_DEFAULT_MAX_ITEMS,
- history_max_size => HISTORY_DEFAULT_MAX_SIZE,
- settings_changed => sub { gmtime },
- # binaries => sub { +{} },
- # custom_data => sub { +{} },
-);
-my %ATTRS_MEMORY_PROTECTION = (
- protect_title => false,
- protect_username => false,
- protect_password => true,
- protect_url => false,
- protect_notes => false,
- auto_enable_visual_hiding => false,
-);
-
-sub _update_group_uuid {
- my $self = shift;
- my $old_uuid = shift // return;
- my $new_uuid = shift;
-
- my $meta = $self->meta;
- $self->recycle_bin_uuid($new_uuid) if $old_uuid eq ($meta->{recycle_bin_uuid} // '');
- $self->entry_templates_group($new_uuid) if $old_uuid eq ($meta->{entry_templates_group} // '');
- $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} // '');
- }
-}
-
-sub _update_entry_uuid {
- my $self = shift;
- my $old_uuid = shift // return;
- my $new_uuid = shift;
-
- for my $entry (@{$self->all_entries}) {
- $entry->previous_parent_group($new_uuid) if $old_uuid eq ($entry->{previous_parent_group} // '');
- }
-}
-
-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_HEADERS) {
- no strict 'refs'; ## no critic (ProhibitNoStrict)
- *{$attr} = sub {
- my $self = shift;
- $self->headers->{$attr} = shift if @_;
- $self->headers->{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default;
- };
-}
-while (my ($attr, $default) = each %ATTRS_META) {
- no strict 'refs'; ## no critic (ProhibitNoStrict)
- *{$attr} = sub {
- my $self = shift;
- $self->meta->{$attr} = shift if @_;
- $self->meta->{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default;
+has sig1 => KDBX_SIG1, coerce => \&to_number;
+has sig2 => KDBX_SIG2_2, coerce => \&to_number;
+has version => KDBX_VERSION_3_1, coerce => \&to_number;
+has headers => {};
+has inner_headers => {};
+has meta => {};
+has binaries => {};
+has deleted_objects => {};
+has raw => coerce => \&to_string;
+
+# HEADERS
+has 'headers.comment' => '', coerce => \&to_string;
+has 'headers.cipher_id' => CIPHER_UUID_CHACHA20, coerce => \&to_uuid;
+has 'headers.compression_flags' => COMPRESSION_GZIP, coerce => \&to_compression_constant;
+has 'headers.master_seed' => sub { random_bytes(32) }, coerce => \&to_string;
+has 'headers.encryption_iv' => sub { random_bytes(16) }, coerce => \&to_string;
+has 'headers.stream_start_bytes' => sub { random_bytes(32) }, coerce => \&to_string;
+has 'headers.kdf_parameters' => sub {
+ +{
+ KDF_PARAM_UUID() => KDF_UUID_AES,
+ KDF_PARAM_AES_ROUNDS() => $_[0]->headers->{+HEADER_TRANSFORM_ROUNDS} // KDF_DEFAULT_AES_ROUNDS,
+ KDF_PARAM_AES_SEED() => $_[0]->headers->{+HEADER_TRANSFORM_SEED} // random_bytes(32),
};
-}
-while (my ($attr, $default) = each %ATTRS_MEMORY_PROTECTION) {
- no strict 'refs'; ## no critic (ProhibitNoStrict)
- *{$attr} = sub {
- my $self = shift;
- $self->meta->{$attr} = shift if @_;
- $self->meta->{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default;
- };
-}
-
-my @ATTRS_OTHER = (
+};
+# has 'headers.transform_seed' => sub { random_bytes(32) };
+# has 'headers.transform_rounds' => 100_000;
+# has 'headers.inner_random_stream_key' => sub { random_bytes(32) }; # 64 ?
+# has 'headers.inner_random_stream_id' => STREAM_ID_CHACHA20;
+# has 'headers.public_custom_data' => {};
+
+# META
+has 'meta.generator' => '', coerce => \&to_string;
+has 'meta.header_hash' => '', coerce => \&to_string;
+has 'meta.database_name' => '', coerce => \&to_string;
+has 'meta.database_name_changed' => sub { gmtime }, coerce => \&to_time;
+has 'meta.database_description' => '', coerce => \&to_string;
+has 'meta.database_description_changed' => sub { gmtime }, coerce => \&to_time;
+has 'meta.default_username' => '', coerce => \&to_string;
+has 'meta.default_username_changed' => sub { gmtime }, coerce => \&to_time;
+has 'meta.maintenance_history_days' => 0, coerce => \&to_number;
+has 'meta.color' => '', coerce => \&to_string;
+has 'meta.master_key_changed' => sub { gmtime }, coerce => \&to_time;
+has 'meta.master_key_change_rec' => -1, coerce => \&to_number;
+has 'meta.master_key_change_force' => -1, coerce => \&to_number;
+# has 'meta.memory_protection' => {};
+has 'meta.custom_icons' => [];
+has 'meta.recycle_bin_enabled' => true, coerce => \&to_bool;
+has 'meta.recycle_bin_uuid' => UUID_NULL, coerce => \&to_uuid;
+has 'meta.recycle_bin_changed' => sub { gmtime }, coerce => \&to_time;
+has 'meta.entry_templates_group' => UUID_NULL, coerce => \&to_uuid;
+has 'meta.entry_templates_group_changed' => sub { gmtime }, coerce => \&to_time;
+has 'meta.last_selected_group' => UUID_NULL, coerce => \&to_uuid;
+has 'meta.last_top_visible_group' => UUID_NULL, coerce => \&to_uuid;
+has 'meta.history_max_items' => HISTORY_DEFAULT_MAX_ITEMS, coerce => \&to_number;
+has 'meta.history_max_size' => HISTORY_DEFAULT_MAX_SIZE, coerce => \&to_number;
+has 'meta.settings_changed' => sub { gmtime }, coerce => \&to_time;
+# has 'meta.binaries' => {};
+# has 'meta.custom_data' => {};
+
+has 'memory_protection.protect_title' => false, coerce => \&to_bool;
+has 'memory_protection.protect_username' => false, coerce => \&to_bool;
+has 'memory_protection.protect_password' => true, coerce => \&to_bool;
+has 'memory_protection.protect_url' => false, coerce => \&to_bool;
+has 'memory_protection.protect_notes' => false, coerce => \&to_bool;
+# has 'memory_protection.auto_enable_visual_hiding' => false;
+
+my @ATTRS = (
HEADER_TRANSFORM_SEED,
HEADER_TRANSFORM_ROUNDS,
HEADER_INNER_RANDOM_STREAM_KEY,
HEADER_INNER_RANDOM_STREAM_ID,
+ HEADER_PUBLIC_CUSTOM_DATA,
);
-sub _set_default_attributes {
+sub _set_nonlazy_attributes {
my $self = shift;
- $self->$_ for keys %ATTRS, keys %ATTRS_HEADERS, keys %ATTRS_META, keys %ATTRS_MEMORY_PROTECTION,
- @ATTRS_OTHER;
+ $self->$_ for list_attributes(ref $self), @ATTRS;
}
=method memory_protection
return KDBX_VERSION_4_1 if any {
nonempty $_->{name} || nonempty $_->{last_modification_time}
- } values %{$self->custom_icons};
+ } @{$self->custom_icons};
return KDBX_VERSION_4_1 if any {
nonempty $_->previous_parent_group || nonempty $_->tags ||
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};
+ } @{$self->all_entries(history => 1)};
return KDBX_VERSION_4_0 if $self->kdf->uuid ne KDF_UUID_AES;
return KDBX_VERSION_4_0 if any {
nonempty $_->custom_data
- } @{$self->all_groups}, @{$self->all_entries};
+ } @{$self->all_groups}, @{$self->all_entries(history => 1)};
return KDBX_VERSION_3_1;
}
##############################################################################
-=method add_group
-
-
-=cut
-
-sub add_group {
- my $self = shift;
- my $group = @_ % 2 == 1 ? shift : undef;
- my %args = @_;
-
- my $parent = delete $args{group} // delete $args{parent} // $self->root;
- ($parent) = $self->find_groups({uuid => $parent}) if !ref $parent;
-
- $group = $self->_group($group // [%args]);
- $group->uuid;
-
- return $parent->add_group($group);
-}
-
-sub _group {
- my $self = shift;
- my $group = shift;
- require File::KDBX::Group;
- return File::KDBX::Group->wrap($group, $self);
-}
-
=method root
$group = $kdbx->root;
because it autovivifies when adding entries and groups to the database.
Every database has only a single root group at a time. Some old KDB files might have multiple root groups.
-When reading such files, a single implicit root group is created to contain the other explicit groups. When
+When reading such files, a single implicit root group is created to contain the actual root groups. When
writing to such a format, if the root group looks like it was implicitly created then it won't be written and
the resulting file might have multiple root groups. This allows working with older files without changing
-their written internal structure while still adhering to the modern restrictions while the database is opened.
+their written internal structure while still adhering to modern semantics while the database is opened.
-B<WARNING:> The root group of a KDBX database contains all of the database's entries and other groups. If you
-replace the root group, you are essentially replacing the entire database contents with something else.
+The root group of a KDBX database contains all of the database's entries and other groups. If you replace the
+root group, you are essentially replacing the entire database contents with something else.
=cut
sub root {
my $self = shift;
if (@_) {
- $self->{root} = $self->_group(@_);
+ $self->{root} = $self->_wrap_group(@_);
$self->{root}->kdbx($self);
}
$self->{root} //= $self->_implicit_root;
- return $self->_group($self->{root});
+ return $self->_wrap_group($self->{root});
}
sub _kpx_groups {
my $self = shift;
return [] if !$self->{root};
- return $self->_is_implicit_root ? $self->root->groups : [$self->root];
+ return $self->_has_implicit_root ? $self->root->groups : [$self->root];
}
-sub _is_implicit_root {
+sub _has_implicit_root {
my $self = shift;
my $root = $self->root;
my $temp = __PACKAGE__->_implicit_root;
);
}
-=method group_level
+=method trace_lineage
- $level = $kdbx->group_level($group);
- $level = $kdbx->group_level($group_uuid);
+ \@lineage = $kdbx->trace_lineage($group);
+ \@lineage = $kdbx->trace_lineage($group, $base_group);
+ \@lineage = $kdbx->trace_lineage($entry);
+ \@lineage = $kdbx->trace_lineage($entry, $base_group);
-Determine the depth/level of a group. The root group is level 0, its direct children are level 1, etc.
+Get the direct line of ancestors from C<$base_group> (default: the root group) to a group or entry. The
+lineage includes the base group but I<not> the target group or entry. Returns C<undef> if the target is not in
+the database structure.
=cut
-sub group_level {
+sub trace_lineage {
my $self = shift;
- my $group = $self->_group(shift);
- my $uuid = !is_ref($group) ? $group : $group->uuid; # FIXME can't check if it's a UUID after running
- # through _group
- return _group_level($uuid, $self->root, 0);
+ my $object = shift;
+ return $object->lineage(@_);
}
-sub _group_level {
- my ($uuid, $base, $level) = @_;
+sub _trace_lineage {
+ my $self = shift;
+ my $object = shift;
+ my @lineage = @_;
- return $level if $uuid eq $base->{uuid};
+ push @lineage, $self->root if !@lineage;
+ my $base = $lineage[-1] or return [];
- for my $subgroup (@{$base->{groups} || []}) {
- my $result = _group_level($uuid, $subgroup, $level + 1);
- return $result if 0 <= $result;
+ my $uuid = $object->uuid;
+ return \@lineage if any { $_->uuid eq $uuid } @{$base->groups || []}, @{$base->entries || []};
+
+ for my $subgroup (@{$base->groups || []}) {
+ my $result = $self->_trace_lineage($object, @lineage, $subgroup);
+ return $result if $result;
}
+}
+
+##############################################################################
+
+=method add_group
+
+ $kdbx->add_group($group, %options);
+ $kdbx->add_group(%group_attributes, %options);
+
+Add a group to a database. This is equivalent to identifying a parent group and calling
+L<File::KDBX::Group/add_group> on the parent group, forwarding the arguments. Available options:
- return -1;
+=for :list
+* C<group> (aka C<parent>) - Group object or group UUID to add the group to (default: root group)
+
+=cut
+
+sub add_group {
+ my $self = shift;
+ my $group = @_ % 2 == 1 ? shift : undef;
+ my %args = @_;
+
+ # 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 or throw 'Invalid group';
+
+ return $parent->add_group(defined $group ? $group : (), %args, kdbx => $self);
+}
+
+sub _wrap_group {
+ my $self = shift;
+ my $group = shift;
+ require File::KDBX::Group;
+ return File::KDBX::Group->wrap($group, $self);
}
=method all_groups
my %args = @_ % 2 == 0 ? @_ : (base => shift, @_);
my $base = $args{base} // $self->root;
- my @groups = $args{include_base} // 1 ? $self->_group($base) : ();
+ # 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);
return \@groups;
}
-=method trace_lineage
-
- \@lineage = $kdbx->trace_lineage($group);
- \@lineage = $kdbx->trace_lineage($group, $base_group);
- \@lineage = $kdbx->trace_lineage($entry);
- \@lineage = $kdbx->trace_lineage($entry, $base_group);
-
-Get the direct line of ancestors from C<$base_group> (default: the root group) to a group or entry. The
-lineage includes the base group but I<not> the target group or entry. Returns C<undef> if the target is not in
-the database structure.
-
-=cut
-
-sub trace_lineage {
- my $self = shift;
- my $thing = shift;
- my @lineage = @_;
-
- push @lineage, $self->root if !@lineage;
- my $base = $lineage[-1];
-
- my $uuid = $thing->uuid;
- return \@lineage if any { $_->uuid eq $uuid } @{$base->groups || []}, @{$base->entries || []};
-
- for my $subgroup (@{$base->groups || []}) {
- my $result = $self->trace_lineage($thing, @lineage, $subgroup);
- return $result if $result;
- }
-}
-
=method find_groups
@groups = $kdbx->find_groups($query, %options);
return @{search($self->all_groups(%all_groups), is_arrayref($query) ? @$query : $query)};
}
-sub remove {
- my $self = shift;
- my $object = shift;
-}
-
##############################################################################
=method add_entry
+ $kdbx->add_entry($entry, %options);
+ $kdbx->add_entry(%entry_attributes, %options);
+
+Add a entry to a database. This is equivalent to identifying a parent group and calling
+L<File::KDBX::Group/add_entry> on the parent group, forwarding the arguments. Available options:
+
+=for :list
+* C<group> (aka C<parent>) - Group object or group UUID to add the entry to (default: root group)
=cut
my $entry = @_ % 2 == 1 ? shift : undef;
my %args = @_;
+ # 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 or throw 'Invalid group';
- $entry = $self->_entry($entry // delete $args{entry} // [%args]);
- $entry->uuid;
-
- return $parent->add_entry($entry);
+ return $parent->add_entry(defined $entry ? $entry : (), %args, kdbx => $self);
}
-sub _entry {
+sub _wrap_entry {
my $self = shift;
my $entry = shift;
require File::KDBX::Entry;
my @entries;
if ((!$search || $enable_searching) && (!$auto_type || $enable_auto_type)) {
push @entries,
- map { $self->_entry($_) }
+ map { $self->_wrap_entry($_) }
grep { !$auto_type || $_->{auto_type}{enabled} }
map { $_, $history ? @{$_->{history} || []} : () }
@{$base->{entries} || []};
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},
+ base => $args{base},
+ auto_type => $args{auto_type},
+ search => $args{search},
+ history => $args{history},
);
- return @{search($self->all_entries(%all_entries), is_arrayref($query) ? @$query : $query)};
+ 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)};
+ }
}
sub find_entries_simple {
$kdbx->custom_icon(%icon);
$kdbx->custom_icon(uuid => $value, %icon);
+Get or set custom icons.
=cut
sub custom_icon {
my $self = shift;
- my %args = @_ == 2 ? (uuid => shift, value => shift)
+ my %args = @_ == 2 ? (uuid => shift, data => shift)
: @_ % 2 == 1 ? (uuid => shift, @_) : @_;
- if (!$args{key} && !$args{value}) {
- my %standard = (key => 1, value => 1, last_modification_time => 1);
+ if (!$args{uuid} && !$args{data}) {
+ my %standard = (uuid => 1, data => 1, name => 1, last_modification_time => 1);
my @other_keys = grep { !$standard{$_} } keys %args;
if (@other_keys == 1) {
my $key = $args{key} = $other_keys[0];
- $args{value} = delete $args{$key};
+ $args{data} = delete $args{$key};
}
}
- my $key = $args{key} or throw 'Must provide a custom_icons key to access';
+ my $uuid = $args{uuid} or throw 'Must provide a custom icon UUID to access';
+ my $icon = (first { $_->{uuid} eq $uuid } @{$self->custom_icons}) // do {
+ push @{$self->custom_icons}, my $i = { uuid => $uuid };
+ $i;
+ };
- return $self->{meta}{custom_icons}{$key} = $args{value} if is_plain_hashref($args{value});
+ my $fields = \%args;
+ $fields = $args{data} if is_plain_hashref($args{data});
- while (my ($field, $value) = each %args) {
- $self->{meta}{custom_icons}{$key}{$field} = $value;
+ while (my ($field, $value) = each %$fields) {
+ $icon->{$field} = $value;
}
- return $self->{meta}{custom_icons}{$key};
+ return $icon;
}
=method custom_icon_data
$image_data = $kdbx->custom_icon_data($uuid);
-Get a custom icon.
+Get a custom icon image data.
=cut
sub custom_icon_data {
my $self = shift;
my $uuid = shift // return;
- return if !exists $self->custom_icons->{$uuid};
- return $self->custom_icons->{$uuid}{data};
+ my $icon = first { $_->{uuid} eq $uuid } @{$self->custom_icons} or return;
+ return $icon->{data};
}
=method add_custom_icon
Add a custom icon and get its UUID. If not provided, a random UUID will be generated. Possible attributes:
=for :list
-* C<uuid> - Icon UUID
+* C<uuid> - Icon UUID (default: autogenerated)
* C<name> - Name of the icon (text, KDBX4.1+)
* C<last_modification_time> - Just what it says (datetime, KDBX4.1+)
my $img = shift or throw 'Must provide image data';
my %args = @_;
- my $uuid = $args{uuid} // generate_uuid(sub { !$self->custom_icons->{$_} });
- $self->custom_icons->{$uuid} = {
+ my $uuid = $args{uuid} // generate_uuid;
+ push @{$self->custom_icons}, {
@_,
uuid => $uuid,
data => $img,
sub remove_custom_icon {
my $self = shift;
my $uuid = shift;
- delete $self->custom_icons->{$uuid};
+ my @deleted;
+ @{$self->custom_icons} = grep { $_->{uuid} eq $uuid ? do { push @deleted, $_; 0 } : 1 }
+ @{$self->custom_icons};
+ $self->add_deleted_object($uuid) if @deleted;
+ return @deleted;
}
##############################################################################
=for :list
* can store strings, booleans and up to 64-bit integer values (custom data can only store text values)
* is NOT encrypted within a KDBX file (hence the "public" part of the name)
-* is a flat hash/dict of key-value pairs (no other associated fields like modification times)
+* is a plain hash/dict of key-value pairs with no other associated fields (like modification times)
=cut
# die 'Not implemented';
# }
+=method add_deleted_object
+
+ $kdbx->add_deleted_object($uuid);
+
+Add a UUID to the deleted objects list. This list is used to support automatic database merging.
+
+You typically do not need to call this yourself because the list will be populated automatically as objects
+are removed.
+
+=cut
+
+sub add_deleted_object {
+ my $self = shift;
+ my $uuid = shift;
+
+ # ignore null and meta stream UUIDs
+ return if $uuid eq UUID_NULL || $uuid eq '0' x 16;
+
+ $self->deleted_objects->{$uuid} = {
+ uuid => $uuid,
+ deletion_time => scalar gmtime,
+ };
+}
+
+=method remove_deleted_object
+
+ $kdbx->remove_deleted_object($uuid);
+
+Remove a UUID from the deleted objects list. This list is used to support automatic database merging.
+
+You typically do not need to call this yourself because the list will be maintained automatically as objects
+are added.
+
+=cut
+
+sub remove_deleted_object {
+ my $self = shift;
+ my $uuid = shift;
+ delete $self->deleted_objects->{$uuid};
+}
+
+=method clear_deleted_objects
+
+Remove all UUIDs from the deleted objects list. This list is used to support automatic database merging, but
+if you don't need merging then you can clear deleted objects to reduce the database file size.
+
+=cut
+
+sub clear_deleted_objects {
+ my $self = shift;
+ %{$self->deleted_objects} = ();
+}
+
##############################################################################
=method resolve_reference
P => 'expanded_password',
A => 'expanded_url',
N => 'expanded_notes',
- I => 'id',
+ I => 'uuid',
O => 'other_strings',
);
$wanted = $fields{$wanted} or return;
$search_in = $fields{$search_in} or return;
- my $query = simple_expression_query($text, ($search_in eq 'id' ? 'eq' : '=~'), $search_in);
+ my $query = $search_in eq 'uuid' ? query($search_in => uuid($text))
+ : simple_expression_query($text, '=~', $search_in);
- my ($entry) = $self->find_entries($query);
+ my ($entry) = $self->find_entries($query, limit => 1);
$entry or return;
return $entry->$wanted;
'URL:PASSWORD' => sub { (split_url($_[0]->url))[8] },
'UUID' => sub { local $_ = format_uuid($_[0]->uuid); s/-//g; $_ },
'REF:' => sub { $_[0]->kdbx->resolve_reference($_[1]) },
- 'INTERNETEXPLORER' => sub { load_optional('File::Which'); File::Which::which('iexplore') },
- 'FIREFOX' => sub { load_optional('File::Which'); File::Which::which('firefox') },
- 'GOOGLECHROME' => sub { load_optional('File::Which'); File::Which::which('google-chrome') },
- 'OPERA' => sub { load_optional('File::Which'); File::Which::which('opera') },
- 'SAFARI' => sub { load_optional('File::Which'); File::Which::which('safari') },
+ 'INTERNETEXPLORER' => sub { load_optional('IPC::Cmd'); IPC::Cmd::can_run('iexplore') },
+ 'FIREFOX' => sub { load_optional('IPC::Cmd'); IPC::Cmd::can_run('firefox') },
+ 'GOOGLECHROME' => sub { load_optional('IPC::Cmd'); IPC::Cmd::can_run('google-chrome') },
+ '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 { $_[0]->parent->name },
+ 'GROUP' => sub { my $p = $_[0]->parent; $p ? $p->name : undef },
'GROUP_PATH' => sub { $_[0]->path },
- 'GROUP_NOTES' => sub { $_[0]->parent->notes },
+ 'GROUP_NOTES' => sub { my $p = $_[0]->parent; $p ? $p->notes : undef },
# 'GROUP_SEL'
# 'GROUP_SEL_PATH'
# 'GROUP_SEL_NOTES'
$kdbx->lock;
-Encrypt all protected strings in a database. The encrypted strings are stored in a L<File::KDBX::Safe>
-associated with the database and the actual strings will be replaced with C<undef> to indicate their protected
-state. Returns itself to allow method chaining.
+Encrypt all protected binaries strings in a database. The encrypted strings are stored in
+a L<File::KDBX::Safe> associated with the database and the actual strings will be replaced with C<undef> to
+indicate their protected state. Returns itself to allow method chaining.
=cut
sub _safe {
my $self = shift;
- $SAFE{refaddr($self)} = shift if @_;
- $SAFE{refaddr($self)};
+ $SAFE{$self} = shift if @_;
+ $SAFE{$self};
}
-sub _remove_safe { delete $SAFE{refaddr($_[0])} }
+sub _remove_safe { delete $SAFE{$_[0]} }
sub lock {
my $self = shift;
my $entries = $self->all_entries(history => 1);
for my $entry (@$entries) {
- push @strings, grep { $_->{protect} } values %{$entry->{strings} || {}};
+ push @strings, grep { $_->{protect} } values %{$entry->strings}, values %{$entry->binaries};
}
$self->_safe(File::KDBX::Safe->new(\@strings));
=cut
-sub peek {
- my $self = shift;
- my $string = shift;
- my $safe = $self->_safe or return;
- return $safe->peek($string);
-}
-
sub unlock {
my $self = shift;
my $safe = $self->_safe or return $self;
return $self;
}
-# sub unlock_scoped {
-# my $self = shift;
-# return if !$self->is_locked;
-# require Scope::Guard;
-# my $guard = Scope::Guard->new(sub { $self->lock });
-# $self->unlock;
-# return $guard;
-# }
+=method unlock_scoped
+
+ $guard = $kdbx->unlock_scoped;
+
+Unlock a database temporarily, relocking when the guard is released (typically at the end of a scope). Returns
+C<undef> if the database is already unlocked.
+
+See L</lock> and L</unlock>.
+
+=cut
+
+sub unlock_scoped {
+ throw 'Programmer error: Cannot call unlock_scoped in void context' if !defined wantarray;
+ my $self = shift;
+ return if !$self->is_locked;
+ require Scope::Guard;
+ my $guard = Scope::Guard->new(sub { $self->lock });
+ $self->unlock;
+ return $guard;
+}
+
+=method peek
+
+ $string = $kdbx->peek(\%string);
+ $string = $kdbx->peek(\%binary);
+
+Peek at the value of a protected string or binary without unlocking the whole database. The argument can be
+a string or binary hashref as returned by L<File::KDBX::Entry/string> or L<File::KDBX::Entry/binary>.
+
+=cut
+
+sub peek {
+ my $self = shift;
+ my $string = shift;
+ my $safe = $self->_safe or return;
+ return $safe->peek($string);
+}
=method is_locked
$key = $kdbx->key($key);
$key = $kdbx->key($primitive);
-Get or set a L<File::KDBX::Key>. This is the master key (i.e. a password or a key file that can decrypt
+Get or set a L<File::KDBX::Key>. This is the master key (e.g. a password or a key file that can decrypt
a database). See L<File::KDBX::Key/new> for an explanation of what the primitive can be.
You generally don't need to call this directly because you can provide the key directly to the loader or
-dumper when loading or saving a KDBX file.
+dumper when loading or dumping a KDBX file.
=cut
sub key {
my $self = shift;
- $KEYS{refaddr($self)} = File::KDBX::Key->new(@_) if @_;
- $KEYS{refaddr($self)};
+ $KEYS{$self} = File::KDBX::Key->new(@_) if @_;
+ $KEYS{$self};
}
=method composite_key
#########################################################################################
-sub check {
+# sub check {
# - Fixer tool. Can repair inconsistencies, including:
# - Orphaned binaries... not really a thing anymore since we now distribute binaries amongst entries
# - Unused custom icons (OFF, data loss)
# - Duplicate window associations (OFF)
# - Only one root group (ON)
# - Header UUIDs match known ciphers/KDFs?
+# }
+
+#########################################################################################
+
+sub _handle_signal {
+ my $self = shift;
+ my $object = shift;
+ my $type = shift;
+
+ my %handlers = (
+ 'entry.added' => \&_handle_object_added,
+ 'group.added' => \&_handle_object_added,
+ 'entry.removed' => \&_handle_object_removed,
+ 'group.removed' => \&_handle_object_removed,
+ 'entry.uuid.changed' => \&_handle_entry_uuid_changed,
+ 'group.uuid.changed' => \&_handle_group_uuid_changed,
+ );
+ my $handler = $handlers{$type} or return;
+ $self->$handler($object, @_);
+}
+
+sub _handle_object_added {
+ my $self = shift;
+ my $object = shift;
+ $self->remove_deleted_object($object->uuid);
+}
+
+sub _handle_object_removed {
+ my $self = shift;
+ my $object = shift;
+ my $old_uuid = $object->{uuid} // return;
+
+ my $meta = $self->meta;
+ $self->recycle_bin_uuid(UUID_NULL) if $old_uuid eq ($meta->{recycle_bin_uuid} // '');
+ $self->entry_templates_group(UUID_NULL) if $old_uuid eq ($meta->{entry_templates_group} // '');
+ $self->last_selected_group(UUID_NULL) if $old_uuid eq ($meta->{last_selected_group} // '');
+ $self->last_top_visible_group(UUID_NULL) if $old_uuid eq ($meta->{last_top_visible_group} // '');
+
+ $self->add_deleted_object($old_uuid);
+}
+
+sub _handle_entry_uuid_changed {
+ my $self = shift;
+ my $object = shift;
+ my $new_uuid = shift;
+ my $old_uuid = shift // return;
+
+ my $old_pretty = format_uuid($old_uuid);
+ 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} // '');
+
+ for my $string (values %{$entry->strings}) {
+ next if !defined $string->{value} || $string->{value} !~ $fieldref_match;
+ my $txn = $entry->begin_work;
+ $string->{value} =~ s/$fieldref_match/{REF:$1\@I:$new_pretty}/g;
+ $txn->commit;
+ }
+ }
+}
+
+sub _handle_group_uuid_changed {
+ my $self = shift;
+ my $object = shift;
+ my $new_uuid = shift;
+ my $old_uuid = shift // return;
+
+ my $meta = $self->meta;
+ $self->recycle_bin_uuid($new_uuid) if $old_uuid eq ($meta->{recycle_bin_uuid} // '');
+ $self->entry_templates_group($new_uuid) if $old_uuid eq ($meta->{entry_templates_group} // '');
+ $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} // '');
+ }
}
#########################################################################################
1;
__END__
-=for Pod::Coverage TO_JSON
+=for Pod::Coverage STORABLE_freeze STORABLE_thaw TO_JSON
=head1 SYNOPSIS
L<File::KeePass> is a much older alternative. It's good but has a backlog of bugs and lacks support for newer
KDBX features.
+=attr sig1
+
+=attr sig2
+
+=attr version
+
+=attr headers
+
+=attr inner_headers
+
+=attr meta
+
+=attr binaries
+
+=attr deleted_objects
+
+=attr raw
+
+ $value = $kdbx->$attr;
+ $kdbx->$attr($value);
+
+Get and set attributes.
+
=cut
projects / chaz / p5-File-KDBX / blobdiff