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 File::KDBX::Util qw(:empty :uuid :search erase simple_expression_query snakify);
+use Hash::Util::FieldHash qw(fieldhashes);
use List::Util qw(any);
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
return $self;
}
-sub DESTROY { !in_global_destruction and $_[0]->reset }
+sub DESTROY { local ($., $@, $!, $^E, $?); !in_global_destruction and $_[0]->reset }
=method init
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;
+
+ 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,
generator => '',
header_hash => '',
database_name => '',
- database_name_changed => sub { gmtime },
+ database_name_changed => sub { scalar gmtime },
database_description => '',
- database_description_changed => sub { gmtime },
+ database_description_changed => sub { scalar gmtime },
default_username => '',
- default_username_changed => sub { gmtime },
+ default_username_changed => sub { scalar gmtime },
maintenance_history_days => 0,
color => '',
- master_key_changed => sub { gmtime },
+ master_key_changed => sub { scalar 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 },
+ recycle_bin_changed => sub { scalar 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 },
+ entry_templates_group_changed => sub { scalar 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 },
+ settings_changed => sub { scalar gmtime },
# binaries => sub { +{} },
# custom_data => sub { +{} },
);
protect_password => true,
protect_url => false,
protect_notes => false,
- auto_enable_visual_hiding => 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 {
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
+ $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:
+
+=for :list
+* C<group> (aka C<parent>) - Group (object or group UUID) to add the group to (default: root group)
=cut
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';
- $group = $self->_group($group // [%args]);
- $group->uuid;
-
- return $parent->add_group($group);
+ return $parent->add_group(defined $group ? $group : (), %args, kdbx => $self);
}
-sub _group {
+sub _wrap_group {
my $self = shift;
my $group = shift;
require File::KDBX::Group;
When reading such files, a single implicit root group is created to contain the other explicit 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.
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
-
- $level = $kdbx->group_level($group);
- $level = $kdbx->group_level($group_uuid);
-
-Determine the depth/level of a group. The root group is level 0, its direct children are level 1, etc.
-
-=cut
-
-sub group_level {
- 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);
-}
-
-sub _group_level {
- my ($uuid, $base, $level) = @_;
-
- return $level if $uuid eq $base->{uuid};
-
- for my $subgroup (@{$base->{groups} || []}) {
- my $result = _group_level($uuid, $subgroup, $level + 1);
- return $result if 0 <= $result;
- }
-
- return -1;
-}
-
=method all_groups
\@groups = $kdbx->all_groups(%options);
my %args = @_ % 2 == 0 ? @_ : (base => shift, @_);
my $base = $args{base} // $self->root;
- my @groups = $args{include_base} // 1 ? $self->_group($base) : ();
+ my @groups = $args{include_base} // 1 ? $self->_wrap_group($base) : ();
for my $subgroup (@{$base->{groups} || []}) {
my $more = $self->all_groups($subgroup);
sub trace_lineage {
my $self = shift;
- my $thing = shift;
+ my $object = shift;
+ return $object->lineage(@_);
+}
+
+sub _trace_lineage {
+ my $self = shift;
+ my $object = shift;
my @lineage = @_;
push @lineage, $self->root if !@lineage;
- my $base = $lineage[-1];
+ my $base = $lineage[-1] or return [];
- my $uuid = $thing->uuid;
+ 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($thing, @lineage, $subgroup);
+ my $result = $self->_trace_lineage($object, @lineage, $subgroup);
return $result if $result;
}
}
=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 {
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'
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;
=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
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 _handle_signal {
+ my $self = shift;
+ my $object = shift;
+ my $type = shift;
+
+ my %handlers = (
+ 'entry.uuid.changed' => \&_update_entry_uuid,
+ 'group.uuid.changed' => \&_update_group_uuid,
+ );
+ my $handler = $handlers{$type} or return;
+ $self->$handler($object, @_);
+}
+
+sub _update_group_uuid {
+ 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} // '');
+ }
+}
+
+sub _update_entry_uuid {
+ 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;
+ }
+ }
+}
+
+#########################################################################################
+
=attr comment
A text string associated with the database. Often unset.
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