; B::COW might speed up the memory erase feature, maybe
B::COW = 0
File::Spec = 0
-File::Which = 0
[Prereqs / TestSuggests]
POSIX::1003 = 0
my $copy = {%$self};
- return '', $copy, $KEYS{refaddr($self)}, $SAFE{refaddr($self)};
+ return '', $copy, $KEYS{refaddr($self)} // (), $SAFE{refaddr($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;
+
+ for my $object (@{$self->all_groups}, @{$self->all_entries(history => 1)}) {
+ $object->kdbx($self);
+ }
}
##############################################################################
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;
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)};
}
'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'
1;
__END__
-=for Pod::Coverage TO_JSON
+=for Pod::Coverage STORABLE_freeze STORABLE_thaw TO_JSON
=head1 SYNOPSIS
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.
return $self;
}
-sub label { shift->title(@_) }
-
##############################################################################
=method string
$string = {
value => 'Password',
- protect => true,
+ protect => true, # optional
};
-Every string should have a value and these optional flags which might exist:
+Every string 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 string value should be memory-protected.
sub string {
my $self = shift;
- # use Data::Dumper;
- # $self->{strings} = shift if @_ == 1 && is_plain_hashref($_[0]);
- # return $self->{strings} //= {} if !@_;
-
my %args = @_ == 2 ? (key => shift, value => shift)
: @_ % 2 == 1 ? (key => shift, @_) : @_;
return $binary->{value};
}
+sub auto_type_enabled {
+ my $entry = shift;
+ # TODO
+}
+
##############################################################################
=method hmac_otp
sub history {
my $self = shift;
- return [map { __PACKAGE__->wrap($_, $self->kdbx) } @{$self->{history} || []}];
+ my $entries = $self->{history} //= [];
+ # FIXME - Looping through entries on each access is too expensive.
+ @$entries = map { $self->_wrap_entry($_, $self->kdbx) } @$entries;
+ return $entries;
}
=method 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 database or can be specified with C<%options>:
+from the associated 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)
sub add_history {
my $self = shift;
delete $_->{history} for @_;
- push @{$self->{history} //= []}, @_;
+ push @{$self->{history} //= []}, map { $self->_wrap_entry($_) } @_;
}
##############################################################################
$self->last_modification_time(gmtime);
}
-sub TO_JSON { +{%{$_[0]}} }
+sub label { shift->expanded_title(@_) }
1;
__END__
=head2 Placeholders
-Entry strings and auto-type key sequences can have placeholders or template tags that can be replaced by other
+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
C<http://example.com?user=batman>.
-Some placeholders take an argument, where the argument follows the tag after a colon. The syntax for this is
-C<{PLACEHOLDER:ARGUMENT}>.
+Some placeholders take an argument, where the argument follows the tag after a colon but before the closing
+brace, like C<{PLACEHOLDER:ARGUMENT}>.
Placeholders are documented in the L<KeePass Help Center|https://keepass.info/help/base/placeholders.html>.
This software supports many (but not all) of the placeholders documented there.
* ☑ C<{URL:RMVSCM}> / C<{URL:WITHOUTSCHEME}>
* ☑ C<{S:Name}> - Custom string where C<Name> is the name or key of the string
* ☑ C<{UUID}> - Identifier (32 hexidecimal characters)
-* ☑ C<{HMACOTP}> - Generate an HMAC-based one-time password
+* ☑ C<{HMACOTP}> - Generate an HMAC-based one-time password (its counter B<will> be incremented)
* ☑ C<{TIMEOTP}> - Generate a time-based one-time password
* ☑ C<{GROUP_NOTES}> - Notes of the parent group
* ☑ C<{GROUP_PATH}> - Full path of the parent group
use File::KDBX::Util qw(generate_uuid);
use List::Util qw(sum0);
use Ref::Util qw(is_ref);
-use Scalar::Util qw(blessed);
+use Scalar::Util qw(blessed refaddr);
use Time::Piece;
use boolean;
use namespace::clean;
our $VERSION = '999.999'; # VERSION
+sub _parent_container { 'groups' }
+
my @ATTRS = qw(uuid custom_data entries groups);
my %ATTRS = (
# uuid => sub { generate_uuid(printable => 1) },
$self->{uuid};
}
-sub label { shift->name(@_) }
+##############################################################################
sub entries {
my $self = shift;
my $entries = $self->{entries} //= [];
- require File::KDBX::Entry;
- @$entries = map { File::KDBX::Entry->wrap($_, $self->kdbx) } @$entries;
+ # FIXME - Looping through entries on each access is too expensive.
+ @$entries = map { $self->_wrap_entry($_, $self->kdbx) } @$entries;
return $entries;
}
-sub groups {
+sub all_entries {
my $self = shift;
- my $groups = $self->{groups} //= [];
- @$groups = map { File::KDBX::Group->wrap($_, $self->kdbx) } @$groups;
- return $groups;
+ # FIXME - shouldn't have to delegate to the database to get this
+ return $self->kdbx->all_entries(base => $self);
}
-sub _kpx_groups { shift->groups(@_) }
+=method add_entry
-sub all_groups {
+ $entry = $group->add_entry($entry);
+ $entry = $group->add_entry(%entry_attributes);
+
+Add an entry to a group. If C<$entry> already has a parent group, it will be removed from that group before
+being added to C<$group>.
+
+=cut
+
+sub add_entry {
my $self = shift;
- return $self->kdbx->all_groups(base => $self, include_base => false);
+ my $entry = @_ % 2 == 1 ? shift : undef;
+ my %args = @_;
+
+ my $kdbx = delete $args{kdbx} // eval { $self->kdbx };
+
+ $entry = $self->_wrap_entry($entry // [%args]);
+ $entry->uuid;
+ $entry->kdbx($kdbx) if $kdbx;
+
+ push @{$self->{entries} ||= []}, $entry->remove;
+ return $entry->_set_group($self);
}
-sub all_entries {
+sub remove_entry {
my $self = shift;
- return $self->kdbx->all_entries(base => $self);
+ my $uuid = is_ref($_[0]) ? $self->_wrap_entry(shift)->uuid : shift;
+ my $objects = $self->{entries};
+ for (my $i = 0; $i < @$objects; ++$i) {
+ my $o = $objects->[$i];
+ next if $uuid ne $o->uuid;
+ return splice @$objects, $i, 1;
+ $o->_set_group(undef);
+ return @$objects, $i, 1;
+ }
}
-sub _group {
- my $self = shift;
- my $group = shift;
- return File::KDBX::Group->wrap($group, $self);
-}
+##############################################################################
-sub _entry {
- my $self = shift;
- my $entry = shift;
- require File::KDBX::Entry;
- return File::KDBX::Entry->wrap($entry, $self);
+sub groups {
+ my $self = shift;
+ my $groups = $self->{groups} //= [];
+ # FIXME - Looping through groups on each access is too expensive.
+ @$groups = map { $self->_wrap_group($_, $self->kdbx) } @$groups;
+ return $groups;
}
-sub add_entry {
+sub all_groups {
my $self = shift;
- my $entry = shift;
- push @{$self->{entries} ||= []}, $entry;
- return $entry;
+ # FIXME - shouldn't have to delegate to the database to get this
+ return $self->kdbx->all_groups(base => $self, include_base => false);
}
+sub _kpx_groups { shift->groups(@_) }
+
+=method add_group
+
+ $new_group = $group->add_group($new_group);
+ $new_group = $group->add_group(%group_attributes);
+
+Add a group to a group. If C<$new_group> already has a parent group, it will be removed from that group before
+being added to C<$group>.
+
+=cut
+
sub add_group {
+ my $self = shift;
+ my $group = @_ % 2 == 1 ? shift : undef;
+ my %args = @_;
+
+ my $kdbx = delete $args{kdbx} // eval { $self->kdbx };
+
+ $group = $self->_wrap_group($group // [%args]);
+ $group->uuid;
+ $group->kdbx($kdbx) if $kdbx;
+
+ push @{$self->{groups} ||= []}, $group->remove;
+ return $group->_set_group($self);
+}
+
+sub remove_group {
my $self = shift;
- my $group = shift;
- push @{$self->{groups} ||= []}, $group;
- return $group;
+ my $uuid = is_ref($_[0]) ? $self->_wrap_group(shift)->uuid : shift;
+ my $objects = $self->{groups};
+ for (my $i = 0; $i < @$objects; ++$i) {
+ my $o = $objects->[$i];
+ next if $uuid ne $o->uuid;
+ $o->_set_group(undef);
+ return splice @$objects, $i, 1;
+ }
}
+##############################################################################
+
+=method add_object
+
+ $new_entry = $group->add_object($new_entry);
+ $new_group = $group->add_object($new_group);
+
+Add an object (either a L<File::KDBX::Entry> or a L<File::KDBX::Group>) to a group. This is the generic
+equivalent of the object forms of L</add_entry> and L</add_group>.
+
+=cut
+
sub add_object {
my $self = shift;
my $obj = shift;
}
}
+=method remove_object
+
+ $group->remove_object($entry);
+ $group->remove_object($group);
+
+Remove an object (either a L<File::KDBX::Entry> or a L<File::KDBX::Group>) from a group. This is the generic
+equivalent of the object forms of L</remove_entry> and L</remove_group>.
+
+=cut
+
sub remove_object {
my $self = shift;
my $object = shift;
return $self->remove_group($object, @_) || $self->remove_entry($object, @_);
}
-sub remove_group {
- my $self = shift;
- my $uuid = is_ref($_[0]) ? $self->_group(shift)->uuid : shift;
- my $objects = $self->{groups};
- for (my $i = 0; $i < @$objects; ++$i) {
- my $o = $objects->[$i];
- next if $uuid ne $o->uuid;
- return splice @$objects, $i, 1;
- }
-}
+##############################################################################
-sub remove_entry {
+=method is_root
+
+ $bool = $group->is_root;
+
+Determine if a group is the root group of its associated database.
+
+=cut
+
+sub is_root {
my $self = shift;
- my $uuid = is_ref($_[0]) ? $self->_entry(shift)->uuid : shift;
- my $objects = $self->{entries};
- for (my $i = 0; $i < @$objects; ++$i) {
- my $o = $objects->[$i];
- next if $uuid ne $o->uuid;
- return splice @$objects, $i, 1;
- }
+ my $kdbx = eval { $self->kdbx } or return;
+ return refaddr($kdbx->root) == refaddr($self);
}
+=method path
+
+ $string = $group->path;
+
+Get a string representation of a group's lineage. This is used as the substitution value for the
+C<{GROUP_PATH}> placeholder. See L<File::KDBX::Entry/Placeholders>.
+
+For a root group, the path is simply the name of the group. For deeper groups, the path is a period-separated
+sequence of group names between the root group and C<$group>, including C<$group> but I<not> the root group.
+In other words, paths of deeper groups leave the root group name out.
+
+ Database
+ -> Root # path is "Root"
+ -> Foo # path is "Foo"
+ -> Bar # path is "Foo.Bar"
+
+Yeah, it doesn't make much sense to me, either, but this matches the behavior of KeePass.
+
+=cut
+
sub path {
my $self = shift;
- my $lineage = $self->kdbx->trace_lineage($self) or return;
- return join('.', map { $_->name } @$lineage);
+ return $self->name if $self->is_root;
+ my $lineage = $self->lineage or return;
+ my @parts = (@$lineage, $self);
+ shift @parts;
+ return join('.', map { $_->name } @parts);
}
+=method size
+
+ $size = $group->size;
+
+Get the size (in bytes) of a group, including the size of all subroups and entries, if any.
+
+=cut
+
sub size {
my $self = shift;
return sum0 map { $_->size } @{$self->groups}, @{$self->entries};
}
-sub level { $_[0]->kdbx->group_level($_[0]) }
+=method depth
-sub TO_JSON { +{%{$_[0]}} }
+ $depth = $group->depth;
+
+Get the depth of a group within a database. The root group is at depth 0, its direct children are at depth 1,
+etc. A group not in a database tree structure returns a depth of -1.
+
+=cut
+
+sub depth { $_[0]->is_root ? 0 : (scalar @{$_[0]->lineage || []} || -1) }
+
+sub label { shift->name(@_) }
1;
__END__
return $self->init(%args, %registration_args);
}
+=method init
+
+ $kdf = $kdf->init(%attributes);
+
+Called by method to set attributes. You normally shouldn't call this.
+
+=cut
+
sub init {
my $self = shift;
my %args = @_;
my $use_fork = 1;
$use_fork = 0 if $ENV{NO_FORK} || !can_fork;
- *USE_FORK = $use_fork ? sub() { 1 } : sub() { 0 };
+ *_USE_FORK = $use_fork ? sub() { 1 } : sub() { 0 };
}
sub init {
my ($key_l, $key_r) = unpack('(a16)2', $key);
- goto NO_FORK if !USE_FORK || $rounds < $FORK_OPTIMIZATION_THRESHOLD;
+ goto NO_FORK if !_USE_FORK || $rounds < $FORK_OPTIMIZATION_THRESHOLD;
{
my $pid = open(my $read, '-|') // do { alert "fork failed: $!"; goto NO_FORK };
if ($pid == 0) { # child
return digest_data('SHA256', $l, $r);
}
- # FIXME: This used to work but now it crashes frequently. threads are discouraged anyway
+ # FIXME: This used to work but now it crashes frequently. Threads are now discouraged anyway, but it might
+ # be nice if this was available for no-fork platforms.
# if ($ENV{THREADS} && eval 'use threads; 1') {
# my $l = threads->create(\&_transform_half, $key_l, $seed, $rounds);
# my $r = _transform_half($key_r, $seed, $rounds);
challenge-response type keys and is ignored by other types.
B<NOTE:> The raw key is sensitive information and so is memory-protected while not being accessed. If you
-access it, you should L<File::KDBX::Util/erase> it when you're done.
+access it, you should memzero or L<File::KDBX::Util/erase> it when you're done.
=cut
$key = $key->hide;
-Encrypt the raw key for L<File::KDBX/"Memory Protection>. Returns itself to allow method chaining.
+Put the raw key in L<File::KDBX/"Memory Protection">. Does nothing if the raw key is already in memory
+protection. Returns itself to allow method chaining.
=cut
$key = $key->show;
-Decrypt the raw key so it can be accessed. Returns itself to allow method chaining.
-
-You normally don't need to call this because L</raw_key> calls this implicitly.
+Bring the raw key out of memory protection. Does nothing if the raw key is already out of memory protection.
+Returns itself to allow method chaining.
=cut
return $self;
}
-sub is_hidden { !!$SAFE{refaddr($_[0])} }
+=method is_hidden
+
+ $bool = $key->is_hidden;
+
+Get whether or not the key's raw secret is currently in memory protection.
-# sub show_scoped {
-# my $self = shift;
-# require Scope::Guard;
-# $self-
-# return
-# }
+=cut
+
+sub is_hidden { !!$SAFE{refaddr($_[0])} }
sub _safe { $SAFE{refaddr($_[0])} }
sub _new_safe { $SAFE{refaddr($_[0])} = File::KDBX::Safe->new }
return $self->hide;
}
+=method raw_key
+
+ $raw_key = $key->raw_key;
+ $raw_key = $key->raw_key($challenge);
+
+Get the raw key which is the response to a challenge. The response will be saved so that subsequent calls
+(with or without the challenge) can provide the response without challenging the responder again. Only once
+response is saved at a time; if you call this with a different challenge, the new response is saved over any
+previous response.
+
+=cut
+
sub raw_key {
my $self = shift;
if (@_) {
$response = $key->challenge($challenge, @options);
-Issue a challenge and get a response, or throw if the responder failed.
+Issue a challenge and get a response, or throw if the responder failed to provide one.
=cut
=head1 SYNOPSIS
- my $key = File::KDBX::Key::ChallengeResponse->(
- responder => sub { my $challenge = shift; ...; return $response },
- );
+ use File::KDBX::Key::ChallengeResponse;
+
+ my $responder = sub {
+ my $challenge = shift;
+ ...; # generate a response based on a secret of some sort
+ return $response;
+ };
+ my $key = File::KDBX::Key::ChallengeResponse->new($responder);
=head1 DESCRIPTION
+A challenge-response key is kind of like multifactor authentication, except you don't really I<authenticate>
+to a KDBX database because it's not a service. Specifically it would be the "what you have" component. It
+assumes there is some device that can store a key that is only known to the unlocker of a database.
+A challenge is made to the device and the response generated based on the key is used as the raw key.
+
+Inherets methods and attributes from L<File::KDBX::Key>.
+
+This is a generic implementation where a responder subroutine is provided to provide the response. There is
+also L<File::KDBX::Key::YubiKey> which is a subclass that allows YubiKeys to be responder devices.
+
=cut
return $self->hide;
}
+=method raw_key
+
+ $raw_key = $key->raw_key;
+ $raw_key = $key->raw_key($challenge);
+
+Get the raw key from each component key and return a generated composite raw key.
+
+=cut
+
sub raw_key {
my $self = shift;
my $challenge = shift;
);
}
+=attr keys
+
+ \@keys = $key->keys;
+
+Get one or more component L<File::KDBX::Key>.
+
+=cut
+
+sub keys {
+ my $self = shift;
+ $self->{keys} = shift if @_;
+ return $self->{keys} ||= [];
+}
+
+=method challenge
+
+ $response = $key->challenge(...);
+
+Issues a challenge to any L<File::KDBX::Key::ChallengeResponse> components keys. Arguments are passed through
+to each component key. The responses are hashed together and the composite response is returned.
+
+Returns empty string if there are no challenge-response components keys.
+
+=cut
+
+sub challenge {
+ my $self = shift;
+
+ my @chalresp_keys = grep { $_->can('challenge') } @{$self->keys} or return '';
+
+ my @responses = map { $_->challenge(@_) } @chalresp_keys;
+ my $cleanup = erase_scoped \@responses;
+
+ return digest_data('SHA256', @responses);
+}
+
sub hide {
my $self = shift;
$_->hide for @{$self->keys};
return $self;
}
-sub challenge {
- my $self = shift;
- my @args = @_;
+1;
+__END__
- my @chalresp_keys = grep { $_->can('challenge') } @{$self->keys} or return '';
+=head1 SYNOPSIS
- my @responses = map { $_->challenge(@args) } @chalresp_keys;
- my $cleanup = erase_scoped \@responses;
+ use File::KDBX::Key::Composite;
- return digest_data('SHA256', @responses);
-}
+ my $key = File::KDBX::Key::Composite->(\@component_keys);
-=attr keys
+=head1 DESCRIPTION
- \@keys = $key->keys;
+A composite key is a collection of other keys. A master key capable of unlocking a KDBX database is always
+a composite key, even if it only has a single component.
-Get one or more component L<File::KDBX::Key>.
+Inherets methods and attributes from L<File::KDBX::Key>.
=cut
-
-sub keys {
- my $self = shift;
- $self->{keys} = shift if @_;
- return $self->{keys} ||= [];
-}
-
-1;
use strict;
use Crypt::Digest qw(digest_data);
-use Crypt::Misc 0.029 qw(decode_b64);
+use Crypt::Misc 0.029 qw(decode_b64 encode_b64);
+use Crypt::PRNG qw(random_bytes);
use File::KDBX::Constants qw(:key_file);
use File::KDBX::Error;
use File::KDBX::Util qw(:erase trim);
our $VERSION = '999.999'; # VERSION
-sub init {
+=method load
+
+ $key = $key->load($filepath);
+ $key = $key->load(\$string);
+ $key = $key->load($fh);
+ $key = $key->load(*IO);
+
+Load a key file.
+
+=cut
+
+sub init { shift->load(@_) }
+
+sub load {
my $self = shift;
my $primitive = shift // throw 'Missing key primitive';
sub filepath { $_[0]->{filepath} }
+=method save
+
+ $key->save;
+ $key->save(%options);
+
+Write a key file. Available options:
+
+=for :list
+* C<type> - Type of key file (default: value of L</type>, or C<KEY_FILE_TYPE_XML>)
+* C<verson> - Version of key file (default: value of L</version>, or 2)
+* C<filepath> - Where to save the file (default: value of L</filepath>)
+* C<fh> - IO handle to write to (overrides C<filepath>, one of which must be defined)
+* C<raw_key> - Raw key (default: value of L</raw_key>)
+
+=cut
+
+sub save {
+ my $self = shift;
+ my %args = @_;
+
+ my @cleanup;
+ my $raw_key = $args{raw_key} // $self->raw_key // random_bytes(32);
+ push @cleanup, erase_scoped $raw_key;
+ length($raw_key) == 32 or throw 'Raw key must be exactly 256 bits (32 bytes)', length => length($raw_key);
+
+ my $type = $args{type} // $self->type // KEY_FILE_TYPE_XML;
+ my $version = $args{version} // $self->version // 2;
+ my $filepath = $args{filepath} // $self->filepath;
+ my $fh = $args{fh};
+
+ if (!openhandle($fh)) {
+ $filepath or throw 'Must specify where to safe the key file to';
+ open($fh, '>:raw', $filepath) or throw "Failed to open key file for writing: $!";
+ }
+
+ if ($type == KEY_FILE_TYPE_XML) {
+ $self->_save_xml($fh, $raw_key, $version);
+ }
+ elsif ($type == KEY_FILE_TYPE_BINARY) {
+ print $fh $raw_key;
+ }
+ elsif ($type == KEY_FILE_TYPE_HEX) {
+ my $hex = uc(unpack('H*', $raw_key));
+ push @cleanup, erase_scoped $hex;
+ print $fh $hex;
+ }
+ else {
+ throw "Cannot save $type key file (invalid type)", type => $type;
+ }
+}
+
##############################################################################
sub _load_xml {
$$out = pack('H*', $data);
$hash = pack('H*', $hash);
my $got_hash = digest_data('SHA256', $$out);
- $hash eq substr($got_hash, 0, 4)
+ $hash eq substr($got_hash, 0, length($hash))
or throw 'Checksum mismatch', got => $got_hash, expected => $hash;
return (KEY_FILE_TYPE_XML, $version);
}
throw 'Unexpected data in key file', version => $version, data => $data;
}
+sub _save_xml {
+ my $self = shift;
+ my $fh = shift;
+ my $raw_key = shift;
+ my $version = shift // 2;
+
+ my @cleanup;
+
+ my $dom = XML::LibXML::Document->new('1.0', 'UTF-8');
+ my $doc = XML::LibXML::Element->new('KeyFile');
+ $dom->setDocumentElement($doc);
+ my $meta_node = XML::LibXML::Element->new('Meta');
+ $doc->appendChild($meta_node);
+ my $version_node = XML::LibXML::Element->new('Version');
+ $version_node->appendText(sprintf('%.1f', $version));
+ $meta_node->appendChild($version_node);
+ my $key_node = XML::LibXML::Element->new('Key');
+ $doc->appendChild($key_node);
+ my $data_node = XML::LibXML::Element->new('Data');
+ $key_node->appendChild($data_node);
+
+ if (int($version) == 1) {
+ my $b64 = encode_b64($raw_key);
+ push @cleanup, erase_scoped $b64;
+ $data_node->appendText($b64);
+ }
+ elsif (int($version) == 2) {
+ my @hex = unpack('(H8)8', $raw_key);
+ my $hex = uc(sprintf("\n %s\n %s\n ", join(' ', @hex[0..3]), join(' ', @hex[4..7])));
+ push @cleanup, erase_scoped $hex, @hex;
+ $data_node->appendText($hex);
+ my $hash = digest_data('SHA256', $raw_key);
+ substr($hash, 4) = '';
+ $hash = uc(unpack('H*', $hash));
+ $data_node->setAttribute('Hash', $hash);
+ }
+ else {
+ throw 'Failed to save unsupported key file version', version => $version;
+ }
+
+ $dom->toFH($fh, 1);
+}
+
1;
+__END__
+
+=head1 SYNOPSIS
+
+ use File::KDBX::Constants qw(:key_file);
+ use File::KDBX::Key::File;
+
+ ### Create a key file:
+
+ my $key = File::KDBX::Key::File->new(
+ filepath => 'path/to/file.keyx',
+ type => KEY_FILE_TYPE_XML, # optional
+ version => 2, # optional
+ raw_key => $raw_key, # optional - leave undefined to generate a random key
+ );
+ $key->save;
+
+ ### Use a key file:
+
+ my $key2 = File::KDBX::Key::File->new('path/to/file.keyx');
+ # OR
+ my $key2 = File::KDBX::Key::File->new(\$secret);
+ # OR
+ my $key2 = File::KDBX::Key::File->new($fh); # or *IO
+
+=head1 DESCRIPTION
+
+A file key (or "key file") is the type of key where the secret is a file. The secret is either the file
+contents or is generated based on the file contents. In order to lock and unlock a KDBX database with a key
+file, the same file must be presented. The database cannot be opened without the file.
+
+Inherets methods and attributes from L<File::KDBX::Key>.
+
+There are multiple types of key files supported. See L</type>. This module can read and write key files.
+
+=cut
}
1;
+__END__
+
+=head1 SYNOPSIS
+
+ use File::KDBX::Key::Password;
+
+ my $key = File::KDBX::Key::Password->new($password);
+
+=head1 DESCRIPTION
+
+A password key is as simple as it sounds. It's just a password or passphrase.
+
+Inherets methods and attributes from L<File::KDBX::Key>.
+
+=cut
challenge-response implementation, so this might not work at all with incompatible challenge-response
implementations (e.g. KeeChallenge).
+Inherets methods and attributes from L<File::KDBX::Key::ChallengeResponse>.
+
To use this type of key to secure a L<File::KDBX> database, you also need to install the
L<YubiKey Personalization Tool (CLI)|https://developers.yubico.com/yubikey-personalization/> and configure at
least one of the slots on your YubiKey for HMAC-SHA1 challenge response mode. You can use the YubiKey
=for :list
* C<YKCHALRESP> - Path to the L<ykchalresp(1)> program
-* C<YKCHALRESP_FLAGS> - Extra arguments to the B<ykchalresp> program
* C<YKINFO> - Path to the L<ykinfo(1)> program
-* C<YKINFO_FLAGS> - Extra arguments to the B<ykinfo> program
+* C<YKCHALRESP_FLAGS> - Extra arguments to the B<ykchalresp(1)> program
+* C<YKINFO_FLAGS> - Extra arguments to the B<ykinfo(1)> program
B<YubiKey> searches for these programs in the same way perl typically searches for executables (using the
C<PATH> environment variable on many platforms). If the programs aren't installed normally, or if you want to
various quirks to L<IPC::Open3> and L<IPC::Cmd> implementations but never quite got it to worked reliably
without deadlocks. Maybe I'll revisit this later. Hit me up so I know if there's demand.
+It would also be possible to implement this is an XS module that incorporated ykcore, using libusb-1 which
+would probably make it more portable with Windows. Perhaps if I get around to it.
+
=cut
our $VERSION = '999.999'; # VERSION
my %KDBX;
+my %PARENT;
=method new
- $object = File::KDBX::Entry->new;
- $object = File::KDBX::Entry->new(%attributes);
- $object = File::KDBX::Entry->new($data);
- $object = File::KDBX::Entry->new($data, $kdbx);
+ $object = File::KDBX::Object->new;
+ $object = File::KDBX::Object->new(%attributes);
+ $object = File::KDBX::Object->new(\%data);
+ $object = File::KDBX::Object->new(\%data, $kdbx);
Construct a new KDBX object.
File::KDBX::Entry->new({username => 'iambatman'}); # WRONG
-In the first, an empty
entry is first created and then initialized with whatever I<attributes> are given. In
-the second, a hashref is blessed and essentially becomes the entry. The significance is that the hashref
-key-value pairs will remain as-is so the structure is expected to adhere to the shape of a raw B<Entry>,
-whereas with the first the attributes will set the structure in the correct way (just like using the entry
-object accessors / getters / setters).
+In the first, an empty
object is first created and then initialized with whatever I<attributes> are given. In
+the second, a hashref is blessed and essentially becomes the object. The significance is that the hashref
+key-value pairs will remain as-is so the structure is expected to adhere to the shape of a raw B<Object>
+(which varies based on the type of object), whereas with the first the attributes will set the structure in
+the correct way (just like using the object accessors / getters / setters).
The second example isn't I<generally> wrong -- this type of construction is supported for a reason, to allow
for working with KDBX objects at a low level -- but it is wrong in this specific case only because
return $self;
}
+sub _set_default_attributes { die 'Not implemented' }
+
+=method init
+
+ $object = $object->init(%attributes);
+
+Called by the constructor to set attributes. You normally should not call this.
+
+=cut
+
sub init {
my $self = shift;
my %args = @_;
return if in_global_destruction;
my $self = shift;
delete $KDBX{refaddr($self)};
+ delete $PARENT{refaddr($self)};
}
=method wrap
=cut
sub wrap {
- my $class = shift;
- my $object = shift;
+ my $class = shift;
+ my $object = shift;
return $object if blessed $object && $object->isa($class);
return $class->new(@_, @$object) if is_arrayref($object);
return $class->new($object, @_);
$object->label($label);
Get or set the object's label, a text string that can act as a non-unique identifier. For an entry, the label
-is its title. For a group, the label is its name.
+is its title string. For a group, the label is its name.
=cut
-sub label { die "Not implemented" }
+sub label { die 'Not implemented' }
=method clone
$object_copy = $object->clone;
$object_copy = File::KDBX::Object->new($object);
-Make a clone of an entry. By default the clone is indeed an exact copy that is associated with the same
-database but not actually included in the object tree (i.e. it has no parent), but some options are allowed to
+Make a clone of an object. By default the clone is indeed an exact copy that is associated with the same
+database but not actually included in the object tree (i.e. it has no parent). Some options are allowed to
get different effects:
=for :list
-* C<new_uuid> - Set a new UUID; value can be the new UUID, truthy to generate a random UUID, or falsy to keep
- the original UUID (default: same value as C<parent>)
-* C<parent> - If set, add the copy to the same parent (default: false)
-* C<relabel> - If set, change the name or title of the copy to "C<$original_title> - Copy".
-* C<entries> - Toggle whether or not to copy child entries, if any (default: true)
-* C<groups> - Toggle whether or not to copy child groups, if any (default: true)
-* C<history> - Toggle whether or not to copy the entry history, if any (default: true)
-* C<reference_password> - Toggle whether or not cloned entry's Password string should be set to a reference to
- their original entry's Password string.
-* C<reference_username> - Toggle whether or not cloned entry's UserName string should be set to a reference to
- their original entry's UserName string.
+* C<new_uuid> - If set, generate a new UUID for the copy (default: false)
+* C<parent> - If set, add the copy to the same parent group, if any (default: false)
+* C<relabel> - If set, append " - Copy" to the object's title or name (default: false)
+* C<entries> - If set, copy child entries, if any (default: true)
+* C<groups> - If set, copy child groups, if any (default: true)
+* C<history> - If set, copy entry history, if any (default: true)
+* C<reference_password> - Toggle whether or not cloned entry's Password string should be set as a field
+ reference to the original entry's Password string (default: false)
+* C<reference_username> - Toggle whether or not cloned entry's UserName string should be set as a field
+ reference to the original entry's UserName string (default: false)
=cut
my $kdbx = $KDBX{$addr};
$self->kdbx($kdbx) if $kdbx;
- if ($self->{uuid}) {
- if (($CLONE{reference_password} || $CLONE{reference_username}) && $self->isa('File::KDBX::Entry')) {
+ if (defined $self->{uuid}) {
+ if (($CLONE{reference_password} || $CLONE{reference_username}) && $self->can('strings')) {
my $uuid = format_uuid($self->{uuid});
my $clone_obj = do {
local $CLONE{new_uuid} = 0;
local $CLONE{history} = 1;
local $CLONE{reference_password} = 0;
local $CLONE{reference_username} = 0;
- bless Storable::dclone({%$clone}), 'File::KDBX::Entry';
+ bless Storable::dclone({%$clone}), 'File::KDBX::Entry';
};
my $txn = $self->begin_work($clone_obj);
if ($CLONE{reference_password}) {
=method group
+=method parent
+
$group = $object->group;
+ # OR equivalently
+ $group = $object->parent;
Get the parent group to which an object belongs or C<undef> if it belongs to no group.
-Alias: C<parent>
-
=cut
sub group {
my $self = shift;
- my $lineage = $self->kdbx->trace_lineage($self) or return;
- return pop @$lineage;
+ my $addr = refaddr($self);
+ if (my $group = $PARENT{$addr}) {
+ my $method = $self->_parent_container;
+ for my $object (@{$group->$method}) {
+ return $group if $addr == refaddr($object);
+ }
+ delete $PARENT{$addr};
+ }
+ # always get lineage from root to leaf because the other way requires parent, so it would be recursive
+ my $lineage = $self->kdbx->_trace_lineage($self) or return;
+ my $group = pop @$lineage or return;
+ $PARENT{$addr} = $group; weaken $PARENT{$addr};
+ return $group;
}
sub parent { shift->group(@_) }
+sub _set_group {
+ my $self = shift;
+ if (my $parent = shift) {
+ $PARENT{refaddr($self)} = $parent;
+ }
+ else {
+ delete $PARENT{refaddr($self)};
+ }
+ return $self;
+}
+
+### Name of the parent attribute expected to contain the object
+sub _parent_container { die 'Not implemented' }
+
+=method lineage
+
+ \@lineage = $object->lineage;
+ \@lineage = $object->lineage($base_group);
+
+Get the direct line of ancestors from C<$base_group> (default: the root group) to an object. The lineage
+includes the base group but I<not> the target object. Returns C<undef> if the target is not in the database
+structure. Returns an empty arrayref is the object itself is a root group.
+
+=cut
+
+sub lineage {
+ my $self = shift;
+ my $base = shift;
+
+ my $base_addr = $base ? refaddr($base) : 0;
+
+ # try leaf to root
+ my @path;
+ my $o = $self;
+ while ($o = $o->parent) {
+ unshift @path, $o;
+ last if $base_addr == refaddr($o);
+ }
+ return \@path if @path && ($base_addr == refaddr($path[0]) || $path[0]->is_root);
+
+ # try root to leaf
+ return $self->kdbx->_trace_lineage($self, $base);
+}
+
=method remove
$object = $object->remove;
return $data->{value};
}
+sub _wrap_group {
+ my $self = shift;
+ my $group = shift;
+ require File::KDBX::Group;
+ return File::KDBX::Group->wrap($group, $KDBX{refaddr($self)});
+}
+
+sub _wrap_entry {
+ my $self = shift;
+ my $entry = shift;
+ require File::KDBX::Entry;
+ return File::KDBX::Entry->wrap($entry, $KDBX{refaddr($self)});
+}
+
+sub TO_JSON { +{%{$_[0]}} }
+
1;
__END__
+=for Pod::Coverage STORABLE_freeze STORABLE_thaw TO_JSON
+
=head1 DESCRIPTION
KDBX is an object database. This abstract class represents an object. You should not use this class directly
=method clear
- $safe->clear;
+ $safe = $safe->clear;
-Clear a safe, removing all store contents permanently.
+Clear a safe, removing all store contents permanently. Returns itself to allow method chaining.
=cut
return $self;
}
+=method lock
+
=method add
$safe = $safe->lock(@strings);
$safe = $safe->lock(\@strings);
-Add strings to be encrypted.
-
-Alias: C<lock>
+Add one or more strings to the memory protection stream. Returns itself to allow method chaining.
=cut
return $self;
}
+=method lock_protected
+
=method add_protected
- $safe = $safe->add_protected(@strings);
- $safe = $safe->add_protected(\@strings);
+ $safe = $safe->lock_protected(@strings);
+ $safe = $safe->lock_protected(\@strings);
-Add strings that are already encrypted.
+Add strings that are already encrypted. Returns itself to allow method chaining.
-B<WARNING:> You must add already-encrypted strings in the order in which they were original encrypted or they
-will not decrypt correctly. You almost certainly do not want to add both unprotected and protected strings to
-a safe.
+B<WARNING:> The cipher must be the same as was used to originally encrypt the strings. You must add
+already-encrypted strings in the order in which they were original encrypted or they will not decrypt
+correctly. You almost certainly do not want to add both unprotected and protected strings to a safe.
=cut
+sub lock_protected { shift->add_protected(@_) }
+
sub add_protected {
my $self = shift;
my $filter = is_coderef($_[0]) ? shift : undef;
$safe = $safe->unlock;
-Decrypt all the strings. Each stored string is set to its original value.
+Decrypt all the strings. Each stored string is set to its original value, potentially overwriting any value
+that might have been set after locking the string (so you probably should avoid modification to strings while
+locked). The safe is implicitly cleared. Returns itself to allow method chaining.
This happens automatically when the safe is garbage-collected.
Peek into the safe at a particular string without decrypting the whole safe. A copy of the string is returned,
and in order to ensure integrity of the memory protection you should erase the copy when you're done.
+Returns C<undef> if the given C<$string> is not in memory protection.
+
=cut
sub peek {
return 1;
}
-=func clone_nomagic
+=func clone
- $clone = clone_nomagic($thing);
+ $clone = clone($thing);
-Clone deeply without keeping [most of] the magic.
-
-B<NOTE:> At the moment the implementation is naïve and won't respond well to nontrivial data.
+Clone deeply. This is an unadorned alias to L<Storable> C<dclone>.
=cut
goto &Storable::dclone;
}
+=func clone_nomagic
+
+ $clone = clone_nomagic($thing);
+
+Clone deeply without keeping [most of] the magic.
+
+B<WARNING:> At the moment the implementation is naïve and won't respond well to nontrivial data or recursive
+structures.
+
+=cut
+
sub clone_nomagic {
my $thing = shift;
if (is_arrayref($thing)) {
=func dumper
- $str = dumper $struct;
+ $str = dumper $thing;
+ dumper $thing; # in void context, prints to STDERR
Like L<Data::Dumper> but slightly terser in some cases relevent to L<File::KDBX>.
for (@_) {
if (!is_ref($_)) {
next if !defined $_ || readonly $_;
- if (USE_COWREFCNT()) {
+ if (_USE_COWREFCNT()) {
my $cowrefcnt = B::COW::cowrefcnt($_);
goto FREE_NONREF if defined $cowrefcnt && 1 < $cowrefcnt;
}
}
elsif (is_scalarref($_)) {
next if !defined $$_ || readonly $$_;
- if (USE_COWREFCNT()) {
+ if (_USE_COWREFCNT()) {
my $cowrefcnt = B::COW::cowrefcnt($$_);
goto FREE_REF if defined $cowrefcnt && 1 < $cowrefcnt;
}
return $out;
}
-=func gunzip
+=func gzip
$zipped = gzip($string);
return $_;
}
+=func uri_unescape_utf8
+
+ $string = uri_unescape_utf8($string);
+
+Inverse of L</uri_escape_utf8>.
+
+=cut
+
sub uri_unescape_utf8 {
local $_ = shift // return;
s/\%([A-Fa-f0-9]{2})/chr(hex($1))/;
BEGIN {
my $use_cowrefcnt = eval { require B::COW; 1 };
- *USE_COWREFCNT = $use_cowrefcnt ? sub() { 1 } : sub() { 0 };
+ *_USE_COWREFCNT = $use_cowrefcnt ? sub() { 1 } : sub() { 0 };
}
### --------------------------------------------------------------------------
use TestCommon;
use Crypt::Misc 0.029 qw(decode_b64 encode_b64);
+use File::KDBX::Cipher;
use File::KDBX::Constants qw(CIPHER_UUID_AES256);
use IO::Handle;
+use PerlIO::via::File::KDBX::Crypt;
use Test::More;
-BEGIN { use_ok 'File::KDBX::Cipher' }
-BEGIN { use_ok 'PerlIO::via::File::KDBX::Crypt' }
-
subtest 'Round-trip block stream' => sub {
plan tests => 3;
my $block_cipher = File::KDBX::Cipher->new(uuid => CIPHER_UUID_AES256, key => 0x01 x 32, iv => 0x01 x 16);
use lib "$Bin/lib";
use TestCommon;
+use File::KDBX;
+use Test::Deep;
use Test::More;
-BEGIN { use_ok 'File::KDBX' }
-
subtest 'Create a new database' => sub {
my $kdbx = File::KDBX->new;
$kdbx->add_group(name => 'Meh');
- ok $kdbx->_is_implicit_root, 'Database starts off with implicit root';
+ ok $kdbx->_has_implicit_root, 'Database starts off with implicit root';
- $kdbx->add_entry({
+ my $entry = $kdbx->add_entry({
username => 'hello',
password => {value => 'This is a secret!!!!!', protect => 1},
});
- ok !$kdbx->_is_implicit_root, 'Adding an entry to the root group makes it explicit';
-
- $kdbx->unlock;
+ ok !$kdbx->_has_implicit_root, 'Adding an entry to the root group makes it explicit';
- # dumper $kdbx->groups;
+ $entry->remove;
+ ok $kdbx->_has_implicit_root, 'Removing group makes the root group implicit again';
+};
- pass;
+subtest 'Clone' => sub {
+ my $kdbx = File::KDBX->new;
+ $kdbx->add_group(name => 'Passwords')->add_entry(title => 'My Entry');
+
+ my $copy = $kdbx->clone;
+ cmp_deeply $copy, $kdbx, 'Clone keeps the same structure and data' or dumper $copy;
+
+ isnt $kdbx, $copy, 'Clone is a different object';
+ isnt $kdbx->root, $copy->root,
+ 'Clone root group is a different object';
+ isnt $kdbx->root->groups->[0], $copy->root->groups->[0],
+ 'Clone group is a different object';
+ isnt $kdbx->root->groups->[0]->entries->[0], $copy->root->groups->[0]->entries->[0],
+ 'Clone entry is a different object';
+
+ my @objects = (@{$copy->all_groups}, @{$copy->all_entries});
+ subtest 'Cloned objects refer to the cloned database' => sub {
+ plan tests => scalar @_;
+ for my $object (@objects) {
+ my $object_kdbx = eval { $object->kdbx };
+ is $object_kdbx, $copy, 'Object: ' . $object->label;
+ }
+ }, @objects;
};
done_testing;
use lib 't/lib';
use TestCommon;
+use File::KDBX::Entry;
use File::KDBX;
use Test::Deep;
use Test::More;
-BEGIN { use_ok 'File::KDBX::Entry' }
-
subtest 'Construction' => sub {
my $entry = File::KDBX::Entry->new(my $data = {username => 'foo'});
is $entry, $data, 'Provided data structure becomes the object';
custom_data => {},
custom_icon_uuid => undef,
foreground_color => "",
+ history => [],
icon_id => "Password",
override_url => "",
previous_parent_group => undef,
use lib 't/lib';
use TestCommon;
+use File::KDBX::Error;
use File::KDBX;
use Test::More;
-BEGIN { use_ok 'File::KDBX::Error' }
-
subtest 'Errors' => sub {
my $error = exception {
local $! = 1;
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use File::KDBX::Group;
+use File::KDBX;
+use Test::More;
+
+subtest 'Path' => sub {
+ my $kdbx = File::KDBX->new;
+ my $group_a = $kdbx->add_group(name => 'Group A');
+ my $group_b = $group_a->add_group(name => 'Group B');
+ is $kdbx->root->path, 'Root', 'Root group has path';
+ is $group_a->path, 'Group A', 'Layer 1 group has path';
+ is $group_b->path, 'Group A.Group B', 'Layer 2 group has path';
+};
+
+done_testing;
use File::KDBX::Util qw(can_fork);
use IO::Handle;
+use PerlIO::via::File::KDBX::HashBlock;
use Test::More;
-BEGIN { use_ok 'PerlIO::via::File::KDBX::HashBlock' }
-
{
my $expected_plaintext = 'Tiny food from Spain!';
is $plaintext, $expected_plaintext, 'Hash-block just a little bit';
}
-subtest 'Error handling' => sub {
- pipe(my $read, my $write) or die "pipe failed: $!\n";
-
- PerlIO::via::File::KDBX::HashBlock->push($read);
-
- print $write 'blah blah blah';
- close($write) or die "close failed: $!";
-
- is $read->error, 0, 'Read handle starts out fine';
- my $data = do { local $/; <$read> };
- is $read->error, 1, 'Read handle can enter and error state';
-
- like $PerlIO::via::File::KDBX::HashBlock::ERROR, qr/invalid block index/i,
- 'Error object is available';
-};
-
SKIP: {
skip 'Tests require fork' if !can_fork;
waitpid($pid, 0) or die "wait failed: $!\n";
}
+subtest 'Error handling' => sub {
+ pipe(my $read, my $write) or die "pipe failed: $!\n";
+
+ PerlIO::via::File::KDBX::HashBlock->push($read);
+
+ print $write 'blah blah blah';
+ close($write) or die "close failed: $!";
+
+ is $read->error, 0, 'Read handle starts out fine';
+ my $data = do { local $/; <$read> };
+ is $read->error, 1, 'Read handle can enter and error state';
+
+ like $PerlIO::via::File::KDBX::HashBlock::ERROR, qr/invalid block index/i,
+ 'Error object is available';
+};
+
done_testing;
use File::KDBX::Util qw(can_fork);
use IO::Handle;
+use PerlIO::via::File::KDBX::HmacBlock;
use Test::More;
-BEGIN { use_ok 'PerlIO::via::File::KDBX::HmacBlock' }
-
my $KEY = "\x01" x 64;
{
is $plaintext, $expected_plaintext, 'HMAC-block just a little bit';
}
-subtest 'Error handling' => sub {
- pipe(my $read, my $write) or die "pipe failed: $!\n";
-
- PerlIO::via::File::KDBX::HmacBlock->push($read, key => $KEY);
-
- print $write 'blah blah blah';
- close($write) or die "close failed: $!";
-
- is $read->error, 0, 'Read handle starts out fine';
- my $data = do { local $/; <$read> };
- is $read->error, 1, 'Read handle can enter and error state';
-
- like $PerlIO::via::File::KDBX::HmacBlock::ERROR, qr/failed to read HMAC/i,
- 'Error object is available';
-};
-
SKIP: {
skip 'Tests require fork' if !can_fork;
waitpid($pid, 0) or die "wait failed: $!\n";
}
+subtest 'Error handling' => sub {
+ pipe(my $read, my $write) or die "pipe failed: $!\n";
+
+ PerlIO::via::File::KDBX::HmacBlock->push($read, key => $KEY);
+
+ print $write 'blah blah blah';
+ close($write) or die "close failed: $!";
+
+ is $read->error, 0, 'Read handle starts out fine';
+ my $data = do { local $/; <$read> };
+ is $read->error, 1, 'Read handle can enter and error state';
+
+ like $PerlIO::via::File::KDBX::HmacBlock::ERROR, qr/failed to read HMAC/i,
+ 'Error object is available';
+};
+
done_testing;
use lib 't/lib';
use TestCommon;
+BEGIN { $ENV{PERL_FILE_KDBX_XS} = 0 }
+use File::KDBX::KDF;
+
use File::KDBX::Constants qw(:kdf);
use Test::More;
-BEGIN {
- $ENV{PERL_FILE_KDBX_XS} = 0;
- use_ok('File::KDBX::KDF');
-}
-
my $kdf = File::KDBX::KDF->new(uuid => KDF_UUID_AES, seed => "\1" x 32, rounds => 10);
is File::KDBX::XS_LOADED(), 0, 'XS can be avoided';
use TestCommon;
use File::KDBX::Constants qw(:kdf);
+use File::KDBX::KDF;
use Test::More;
-BEGIN { use_ok('File::KDBX::KDF') }
-
subtest 'AES KDF' => sub {
my $kdf1 = File::KDBX::KDF->new(uuid => KDF_UUID_AES, seed => "\1" x 32, rounds => 10);
my $result1 = $kdf1->transform("\2" x 32);
use TestCommon;
use Crypt::Misc 0.029 qw(decode_b64 encode_b64);
+use File::KDBX::Constants qw(:key_file);
+use File::KDBX::Key;
+use File::Temp qw(tempfile);
use Test::More;
-BEGIN { use_ok 'File::KDBX::Key' }
-
subtest 'Primitives' => sub {
my $pkey = File::KDBX::Key->new('password');
isa_ok $pkey, 'File::KDBX::Key::Password';
'Can calculate raw key from composite' or diag encode_b64($ckey->raw_key);
};
-subtest 'File keys' => sub {
- my $key = File::KDBX::Key::File->new(testfile(qw{keys xmlv1.key}));
- is $key->raw_key, decode_b64('OF9tj+tfww1kHNWQaJlZWIlBdoTVXOazP8g/vZK7NcI='),
- 'Can calculate raw key from XML file' or diag encode_b64($key->raw_key);
- is $key->type, 'xml', 'file type is detected as xml';
- is $key->version, '1.0', 'file version is detected as xml';
-
- $key = File::KDBX::Key::File->new(testfile(qw{keys xmlv2.key}));
- is $key->raw_key, decode_b64('OF9tj+tfww1kHNWQaJlZWIlBdoTVXOazP8g/vZK7NcI='),
- 'Can calculate raw key from XML file' or diag encode_b64($key->raw_key);
- is $key->type, 'xml', 'file type is detected as xml';
- is $key->version, '2.0', 'file version is detected as xml';
-
- $key = File::KDBX::Key::File->new(testfile(qw{keys binary.key}));
- is $key->raw_key, decode_b64('QlkDxuYbDPDpDXdK1470EwVBL+AJBH2gvPA9lxNkFEk='),
- 'Can calculate raw key from binary file' or diag encode_b64($key->raw_key);
- is $key->type, 'binary', 'file type is detected as binary';
-
- $key = File::KDBX::Key::File->new(testfile(qw{keys hex.key}));
- is $key->raw_key, decode_b64('QlkDxuYbDPDpDXdK1470EwVBL+AJBH2gvPA9lxNkFEk='),
- 'Can calculate raw key from hex file' or diag encode_b64($key->raw_key);
- is $key->type, 'hex', 'file type is detected as hex';
-
- $key = File::KDBX::Key::File->new(testfile(qw{keys hashed.key}));
- is $key->raw_key, decode_b64('8vAO4mrMeq6iCa1FHeWm/Mj5al8HIv2ajqsqsSeUC6U='),
- 'Can calculate raw key from binary file' or diag encode_b64($key->raw_key);
- is $key->type, 'hashed', 'file type is detected as hashed';
-
+for my $test (
+ [KEY_FILE_TYPE_XML, 'xmlv1.key', 'OF9tj+tfww1kHNWQaJlZWIlBdoTVXOazP8g/vZK7NcI=', '1.0'],
+ [KEY_FILE_TYPE_XML, 'xmlv2.key', 'OF9tj+tfww1kHNWQaJlZWIlBdoTVXOazP8g/vZK7NcI=', '2.0'],
+ [KEY_FILE_TYPE_BINARY, 'binary.key', 'QlkDxuYbDPDpDXdK1470EwVBL+AJBH2gvPA9lxNkFEk='],
+ [KEY_FILE_TYPE_HEX, 'hex.key', 'QlkDxuYbDPDpDXdK1470EwVBL+AJBH2gvPA9lxNkFEk='],
+ [KEY_FILE_TYPE_HASHED, 'hashed.key', '8vAO4mrMeq6iCa1FHeWm/Mj5al8HIv2ajqsqsSeUC6U='],
+) {
+ my ($type) = @$test;
+ subtest "Load $type key file" => sub {
+ my ($type, $filename, $expected_key, $version) = @_;
+
+ my $key = File::KDBX::Key::File->new(testfile('keys', $filename));
+ is $key->raw_key, decode_b64($expected_key),
+ "Can calculate raw key from $type file" or diag encode_b64($key->raw_key);
+ is $key->type, $type, "File type is detected as $type";
+ is $key->version, $version, "File version is detected as $version" if defined $version;
+ }, @$test;
+
+ subtest "Save $type key file" => sub {
+ my ($type, $filename, $expected_key, $version) = @_;
+
+ my ($fh, $filepath) = tempfile('keyfile-XXXXXX', TMPDIR => 1, UNLINK => 1, SUFFIX => '.key');
+ note $filepath;
+ my $key = File::KDBX::Key::File->new(
+ filepath => $filepath,
+ type => $type,
+ version => $version,
+ raw_key => decode_b64($expected_key),
+ );
+
+ my $e = exception { $key->save };
+ close($fh);
+
+ if ($type == KEY_FILE_TYPE_HASHED) {
+ like $e, qr/invalid type/i, "Cannot save $type file";
+ return;
+ }
+ is $e, undef, "Save $type file";
+
+ my $key2 = File::KDBX::Key::File->new($filepath);
+ is $key2->type, $key->type, 'Loaded key file has the same type';
+ is $key2->raw_key, $key->raw_key, 'Loaded key file has the same raw key';
+ }, @$test;
+}
+
+subtest 'IO handle key files' => sub {
my $buf = 'password';
open(my $fh, '<', \$buf) or die "open failed: $!\n";
- $key = File::KDBX::Key::File->new($fh);
+ my $key = File::KDBX::Key::File->new($fh);
is $key->raw_key, decode_b64('XohImNooBHFR0OVvjcYpJ3NgPQ1qq73WKhHvch0VQtg='),
'Can calculate raw key from file handle' or diag encode_b64($key->raw_key);
is $key->type, 'hashed', 'file type is detected as hashed';
- is exception { File::KDBX::Key::File->new }, undef, 'Can instantiate uninitialized';
+ my ($fh_save, $filepath) = tempfile('keyfile-XXXXXX', TMPDIR => 1, UNLINK => 1, SUFFIX => '.key');
+ ok $key->save(fh => $fh_save, type => KEY_FILE_TYPE_XML), 'Save key file using IO handle';
+ close($fh_save);
+
+ my $key2 = File::KDBX::Key::File->new($filepath);
+ is $key2->type, KEY_FILE_TYPE_XML, 'Loaded key file has the same type';
+ is $key2->filepath, $filepath, 'Loaded key remembers the filepath';
+ is $key2->raw_key, $key->raw_key, 'Loaded key file has the same raw key';
+ $key2->reload;
+ is $key2->raw_key, $key->raw_key, 'Raw key is the same when reloaded same file';
+
+ my $easy_raw_key = "\1" x 32;
+ $key->init(\$easy_raw_key);
+ $key->save(filepath => $filepath);
+
+ $key2->reload;
+ is $key2->raw_key, "\1" x 32, 'Raw key is changed after reload';
+};
+
+subtest 'Key file error handling' => sub {
+ is exception { File::KDBX::Key::File->new }, undef, 'Cannot instantiate uninitialized';
like exception { File::KDBX::Key::File->init },
- qr/^Missing key primitive/, 'Throws if no primitive is provided';
+ qr/^Missing key primitive/, 'Throw if no primitive is provided';
like exception { File::KDBX::Key::File->new(testfile(qw{keys nonexistent})) },
- qr/^Failed to open key file/, 'Throws if file is missing';
+ qr/^Failed to open key file/, 'Throw if file is missing';
like exception { File::KDBX::Key::File->new({}) },
- qr/^Unexpected primitive type/, 'Throws if primitive is the wrong type';
+ qr/^Unexpected primitive type/, 'Throw if primitive is the wrong type';
};
done_testing;
use lib 't/lib';
use TestCommon;
+use File::KDBX::Safe;
use Test::Deep;
use Test::More;
-BEGIN { use_ok 'File::KDBX::Safe' }
-
my $secret = 'secret';
my @strings = (
use lib 't/lib';
use TestCommon;
+use File::KDBX::Util qw(:all);
use Test::More;
-BEGIN { use_ok('File::KDBX::Util', qw{empty format_uuid generate_uuid nonempty pad_pkcs7 snakify uuid}) }
-
can_ok('File::KDBX::Util', qw{
assert_64bit
can_fork
projects / chaz / p5-File-KDBX / commitdiff
