insert_final_newline = true
trim_trailing_whitespace = true
-[{**.pl,**.pm,**.pod,**.t,bin/graphql}]
+[{**.pl,**.pm,**.pod,**.t,bin/fkpx-agent}]
indent_style = space
indent_size = 4
-max_line_length = 120
+max_line_length = 110
[{.editorconfig,**.ini}]
indent_style = space
--- /dev/null
+# We don't really do much using the return value for error-checking. I think
+# in this codebase bugs would more likely be in the form if unintentionally
+# returning empty list in list context.
+[-Subroutines::ProhibitExplicitReturnUndef]
CPANM = cpanm
COVER = cover
DZIL = dzil
+PERL = perl
PROVE = prove
-.PHONY: all bootstrap clean cover dist test
+cpanm_env = AUTHOR_TESTING=0 RELEASE_TESTING=0
-all: bootstrap dist
+all: dist
bootstrap:
- $(CPANM) Dist::Zilla
- $(DZIL) authordeps --missing | $(CPANM)
- $(DZIL) listdeps --develop --missing | $(CPANM)
+ $(cpanm_env) $(CPANM) -nq Dist::Zilla
+ $(DZIL) authordeps --missing |$(cpanm_env) $(CPANM) -nq
+ $(DZIL) listdeps --develop --missing |$(cpanm_env) $(CPANM) -nq
clean:
$(DZIL) $@
$(DZIL) build
test:
- $(PROVE) -l $(if $(V),-v)
+ $(PROVE) -l $(if $(V),-vj1)
+smoke:
+ smoke-all file-kdbx File-KDBX-$V.tar.gz
+
+smokers:
+ $(DZIL) listdeps --no-recommends --no-suggests --no-develop --cpanm-versions \
+ |$(PERL) -pe 's/"//g' \
+ |build-perl-smokers file-kdbx
+
+.PHONY: all bootstrap clean cover dist smoke smokers test
name = File-KDBX
-author = Charles McGarvey <chazmcgarvey@brokenzipper.com>
+author = Charles McGarvey <ccm@cpan.org>
copyright_holder = Charles McGarvey
copyright_year = 2022
license = Perl_5
[@Author::CCM]
+:version = 0.011
+; the PerlIO layers are an implementation detail that might change
+no_index = lib/PerlIO/via/File/KDBX t xt
+
+[Prereqs / RuntimeRecommends]
+; B::COW might speed up the memory erase feature, maybe
+B::COW = 0
+File::Spec = 0
+File::Which = 0
+
+[Prereqs / TestSuggests]
+POSIX::1003 = 0
+
+[OptionalFeature / xs]
+-description = speed improvements (requires C compiler)
+-prompt = 0
+-always_recommend = 1
+File::KDBX::XS = 0
+
+[OptionalFeature / compression]
+-description = ability to read and write compressed KDBX files
+-prompt = 0
+-always_recommend = 1
+Compress::Raw::Zlib = 0
+
+[OptionalFeature / otp]
+-description = ability to generate one-time passwords from configured database entries
+-prompt = 0
+-always_recommend = 1
+Pass::OTP = 0
+
+; https://github.com/Perl-Toolchain-Gang/toolchain-site/blob/master/berlin-consensus.md#need-for-a-post-install-recommendations-key
+; I'd like to suggest File::KeePass::KDBX, but that would create a circular
+; dependency. If/when there exists a post-install recommendations key, we can
+; use that.
+; [OptionalFeature / kdb]
+; -description = ability to read and write old KDB files
+; -prompt = 0
+; -always_suggests = 1
+; File::KeePass = 0
+; File::KeePass::KDBX = 0
+[Prereqs::Soften / BreakCycle]
+to_relationship = none
+module = File::KeePass
+module = File::KeePass::KDBX
+
+[Prereqs::Soften]
+modules_from_features = 1
+
+[Encoding]
+encoding = bytes
+matches = \.(key|kdbx?)$
--- /dev/null
+package File::KDBX;
+# ABSTRACT: Encrypted databases to store secret text and files
+
+use warnings;
+use strict;
+
+use Crypt::PRNG qw(random_bytes);
+use Devel::GlobalDestruction;
+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 Ref::Util qw(is_ref is_arrayref is_plain_hashref);
+use Scalar::Util qw(blessed refaddr);
+use Time::Piece;
+use boolean;
+use warnings::register;
+use namespace::clean;
+
+our $VERSION = '999.999'; # VERSION
+our $WARNINGS = 1;
+
+my %SAFE;
+my %KEYS;
+
+=method new
+
+ $kdbx = File::KDBX->new(%attributes);
+ $kdbx = File::KDBX->new($kdbx); # copy constructor
+
+Construct a new L<File::KDBX>.
+
+=cut
+
+sub new {
+ my $class = shift;
+
+ # copy constructor
+ return $_[0]->clone if @_ == 1 && blessed $_[0] && $_[0]->isa($class);
+
+ my $self = bless {}, $class;
+ $self->init(@_);
+ $self->_set_default_attributes if empty $self;
+ return $self;
+}
+
+sub DESTROY { !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.
+
+This is called by L</new>.
+
+=cut
+
+sub init {
+ my $self = shift;
+ my %args = @_;
+
+ @$self{keys %args} = values %args;
+
+ return $self;
+}
+
+=method reset
+
+ $kdbx = $kdbx->reset;
+
+Set a L<File::KDBX> to an empty state, ready to load a KDBX file or build a new one. Returns itself to allow
+method chaining.
+
+=cut
+
+sub reset {
+ my $self = shift;
+ erase $self->headers->{+HEADER_INNER_RANDOM_STREAM_KEY};
+ erase $self->inner_headers->{+INNER_HEADER_INNER_RANDOM_STREAM_KEY};
+ erase $self->{raw};
+ %$self = ();
+ delete $SAFE{refaddr($self)};
+ $self->_remove_safe;
+ return $self;
+}
+
+=method clone
+
+ $kdbx_copy = $kdbx->clone;
+ $kdbx_copy = File::KDBX->new($kdbx);
+
+Clone a L<File::KDBX>. The clone will be an exact copy and completely independent of the original.
+
+=cut
+
+sub clone {
+ my $self = shift;
+ require Storable;
+ return Storable::dclone($self);
+}
+
+sub STORABLE_freeze {
+ my $self = shift;
+ my $cloning = shift;
+
+ my $copy = {%$self};
+
+ return '', $copy, $KEYS{refaddr($self)}, $SAFE{refaddr($self)};
+}
+
+sub STORABLE_thaw {
+ my $self = shift;
+ my $cloning = shift;
+ my $clone = shift;
+ my $key = shift;
+ my $safe = shift;
+
+ @$self{keys %$clone} = values %$clone;
+ $KEYS{refaddr($self)} = $key;
+ $SAFE{refaddr($self)} = $safe;
+}
+
+##############################################################################
+
+=method load
+
+=method load_string
+
+=method load_file
+
+=method load_handle
+
+ $kdbx = KDBX::File->load(\$string, $key);
+ $kdbx = KDBX::File->load(*IO, $key);
+ $kdbx = KDBX::File->load($filepath, $key);
+ $kdbx->load(...); # also instance method
+
+ $kdbx = File::KDBX->load_string($string, $key);
+ $kdbx = File::KDBX->load_string(\$string, $key);
+ $kdbx->load_string(...); # also instance method
+
+ $kdbx = File::KDBX->load_file($filepath, $key);
+ $kdbx->load_file(...); # also instance method
+
+ $kdbx = File::KDBX->load_handle($fh, $key);
+ $kdbx = File::KDBX->load_handle(*IO, $key);
+ $kdbx->load_handle(...); # also instance method
+
+Load a KDBX file from a string buffer, IO handle or file from a filesystem.
+
+L<File::KDBX::Loader> does the heavy lifting.
+
+=cut
+
+sub load { shift->_loader->load(@_) }
+sub load_string { shift->_loader->load_string(@_) }
+sub load_file { shift->_loader->load_file(@_) }
+sub load_handle { shift->_loader->load_handle(@_) }
+
+sub _loader {
+ my $self = shift;
+ $self = $self->new if !ref $self;
+ require File::KDBX::Loader;
+ File::KDBX::Loader->new(kdbx => $self);
+}
+
+=method dump
+
+=method dump_string
+
+=method dump_file
+
+=method dump_handle
+
+ $kdbx->dump(\$string, $key);
+ $kdbx->dump(*IO, $key);
+ $kdbx->dump($filepath, $key);
+
+ $kdbx->dump_string(\$string, $key);
+ \$string = $kdbx->dump_string($key);
+
+ $kdbx->dump_file($filepath, $key);
+
+ $kdbx->dump_handle($fh, $key);
+ $kdbx->dump_handle(*IO, $key);
+
+Dump a KDBX file to a string buffer, IO handle or file in a filesystem.
+
+L<File::KDBX::Dumper> does the heavy lifting.
+
+=cut
+
+sub dump { shift->_dumper->dump(@_) }
+sub dump_string { shift->_dumper->dump_string(@_) }
+sub dump_file { shift->_dumper->dump_file(@_) }
+sub dump_handle { shift->_dumper->dump_handle(@_) }
+
+sub _dumper {
+ my $self = shift;
+ $self = $self->new if !ref $self;
+ require File::KDBX::Dumper;
+ File::KDBX::Dumper->new(kdbx => $self);
+}
+
+##############################################################################
+
+=method user_agent_string
+
+ $string = $kdbx->user_agent_string;
+
+Get a text string identifying the database client software.
+
+=cut
+
+sub user_agent_string {
+ require Config;
+ sprintf('%s/%s (%s/%s; %s/%s; %s)',
+ __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;
+ };
+}
+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 = (
+ HEADER_TRANSFORM_SEED,
+ HEADER_TRANSFORM_ROUNDS,
+ HEADER_INNER_RANDOM_STREAM_KEY,
+ HEADER_INNER_RANDOM_STREAM_ID,
+);
+sub _set_default_attributes {
+ my $self = shift;
+ $self->$_ for keys %ATTRS, keys %ATTRS_HEADERS, keys %ATTRS_META, keys %ATTRS_MEMORY_PROTECTION,
+ @ATTRS_OTHER;
+}
+
+=method memory_protection
+
+ \%settings = $kdbx->memory_protection
+ $kdbx->memory_protection(\%settings);
+
+ $bool = $kdbx->memory_protection($string_key);
+ $kdbx->memory_protection($string_key => $bool);
+
+Get or set memory protection settings. This globally (for the whole database) configures whether and which of
+the standard strings should be memory-protected. The default setting is to memory-protect only I<Password>
+strings.
+
+Memory protection can be toggled individually for each entry string, and individual settings take precedence
+over these global settings.
+
+=cut
+
+sub memory_protection {
+ my $self = shift;
+ $self->{meta}{memory_protection} = shift if @_ == 1 && is_plain_hashref($_[0]);
+ return $self->{meta}{memory_protection} //= {} if !@_;
+
+ my $string_key = shift;
+ my $key = 'protect_' . lc($string_key);
+
+ $self->meta->{memory_protection}{$key} = shift if @_;
+ $self->meta->{memory_protection}{$key};
+}
+
+=method minimum_version
+
+ $version = $kdbx->minimum_version;
+
+Determine the minimum file version required to save a database losslessly. Using certain databases features
+might increase this value. For example, setting the KDF to Argon2 will increase the minimum version to at
+least C<KDBX_VERSION_4_0> (i.e. C<0x00040000>) because Argon2 was introduced with KDBX4.
+
+This method never returns less than C<KDBX_VERSION_3_1> (i.e. C<0x00030001>). That file version is so
+ubiquitious and well-supported, there are seldom reasons to dump in a lesser format nowadays.
+
+B<WARNING:> If you dump a database with a minimum version higher than the current L</version>, the dumper will
+typically issue a warning and automatically upgrade the database. This seems like the safest behavior in order
+to avoid data loss, but lower versions have the benefit of being compatible with more software. It is possible
+to prevent auto-upgrades by explicitly telling the dumper which version to use, but you do run the risk of
+data loss. A database will never be automatically downgraded.
+
+=cut
+
+sub minimum_version {
+ my $self = shift;
+
+ return KDBX_VERSION_4_1 if any {
+ nonempty $_->{last_modification_time}
+ } values %{$self->custom_data};
+
+ return KDBX_VERSION_4_1 if any {
+ nonempty $_->{name} || nonempty $_->{last_modification_time}
+ } values %{$self->custom_icons};
+
+ return KDBX_VERSION_4_1 if any {
+ nonempty $_->previous_parent_group || nonempty $_->tags ||
+ any { nonempty $_->{last_modification_time} } values %{$_->custom_data}
+ } @{$self->all_groups};
+
+ 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};
+
+ return KDBX_VERSION_4_0 if $self->kdf->uuid ne KDF_UUID_AES;
+
+ return KDBX_VERSION_4_0 if nonempty $self->public_custom_data;
+
+ return KDBX_VERSION_4_0 if any {
+ nonempty $_->custom_data
+ } @{$self->all_groups}, @{$self->all_entries};
+
+ 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;
+ $kdbx->root($group);
+
+Get or set a database's root group. You don't necessarily need to explicitly create or set a root group
+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
+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.
+
+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.
+
+=cut
+
+sub root {
+ my $self = shift;
+ if (@_) {
+ $self->{root} = $self->_group(@_);
+ $self->{root}->kdbx($self);
+ }
+ $self->{root} //= $self->_implicit_root;
+ return $self->_group($self->{root});
+}
+
+sub _kpx_groups {
+ my $self = shift;
+ return [] if !$self->{root};
+ return $self->_is_implicit_root ? $self->root->groups : [$self->root];
+}
+
+sub _is_implicit_root {
+ my $self = shift;
+ my $root = $self->root;
+ my $temp = __PACKAGE__->_implicit_root;
+ # If an implicit root group has been changed in any significant way, it is no longer implicit.
+ return $root->name eq $temp->name &&
+ $root->is_expanded ^ $temp->is_expanded &&
+ $root->notes eq $temp->notes &&
+ !@{$root->entries} &&
+ !defined $root->custom_icon_uuid &&
+ !keys %{$root->custom_data} &&
+ $root->icon_id == $temp->icon_id &&
+ $root->expires ^ $temp->expires &&
+ $root->default_auto_type_sequence eq $temp->default_auto_type_sequence &&
+ !defined $root->enable_auto_type &&
+ !defined $root->enable_searching;
+}
+
+sub _implicit_root {
+ my $self = shift;
+ require File::KDBX::Group;
+ return File::KDBX::Group->new(
+ name => 'Root',
+ is_expanded => true,
+ notes => 'Added as an implicit root group by '.__PACKAGE__.'.',
+ ref $self ? (kdbx => $self) : (),
+ );
+}
+
+=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);
+ \@groups = $kdbx->all_groups($base_group, %options);
+
+Get all groups deeply in a database, or all groups within a specified base group, in a flat array. Supported
+options:
+
+=for :list
+* C<base> - Only include groups within a base group (same as C<$base_group>) (default: root)
+* C<include_base> - Include the base group in the results (default: true)
+
+=cut
+
+sub all_groups {
+ my $self = shift;
+ my %args = @_ % 2 == 0 ? @_ : (base => shift, @_);
+ my $base = $args{base} // $self->root;
+
+ my @groups = $args{include_base} // 1 ? $self->_group($base) : ();
+
+ for my $subgroup (@{$base->{groups} || []}) {
+ my $more = $self->all_groups($subgroup);
+ push @groups, @$more;
+ }
+
+ 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);
+
+Find all groups deeply that match to a query. Options are the same as for L</all_groups>.
+
+See L</QUERY> for a description of what C<$query> can be.
+
+=cut
+
+sub find_groups {
+ my $self = shift;
+ my $query = shift or throw 'Must provide a query';
+ my %args = @_;
+ my %all_groups = (
+ base => $args{base},
+ include_base => $args{include_base},
+ );
+ return @{search($self->all_groups(%all_groups), is_arrayref($query) ? @$query : $query)};
+}
+
+sub remove {
+ my $self = shift;
+ my $object = shift;
+}
+
+##############################################################################
+
+=method add_entry
+
+
+=cut
+
+sub add_entry {
+ my $self = shift;
+ my $entry = @_ % 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;
+
+ $entry = $self->_entry($entry // delete $args{entry} // [%args]);
+ $entry->uuid;
+
+ return $parent->add_entry($entry);
+}
+
+sub _entry {
+ my $self = shift;
+ my $entry = shift;
+ require File::KDBX::Entry;
+ return File::KDBX::Entry->wrap($entry, $self);
+}
+
+=method all_entries
+
+ \@entries = $kdbx->all_entries(%options);
+ \@entries = $kdbx->all_entries($base_group, %options);
+
+Get entries deeply in a database, in a flat array. Supported options:
+
+=for :list
+* C<base> - Only include entries within a base group (same as C<$base_group>) (default: root)
+* C<auto_type> - Only include entries with auto-type enabled (default: false, include all)
+* C<search> - Only include entries within groups with search enabled (default: false, include all)
+* C<history> - Also include historical entries (default: false, include only active entries)
+
+=cut
+
+sub all_entries {
+ my $self = shift;
+ my %args = @_ % 2 == 0 ? @_ : (base => shift, @_);
+
+ my $base = $args{base} // $self->root;
+ my $history = $args{history};
+ my $search = $args{search};
+ my $auto_type = $args{auto_type};
+
+ my $enable_auto_type = $base->{enable_auto_type} // true;
+ my $enable_searching = $base->{enable_searching} // true;
+
+ my @entries;
+ if ((!$search || $enable_searching) && (!$auto_type || $enable_auto_type)) {
+ push @entries,
+ map { $self->_entry($_) }
+ grep { !$auto_type || $_->{auto_type}{enabled} }
+ map { $_, $history ? @{$_->{history} || []} : () }
+ @{$base->{entries} || []};
+ }
+
+ for my $subgroup (@{$base->{groups} || []}) {
+ my $more = $self->all_entries($subgroup,
+ auto_type => $auto_type,
+ search => $search,
+ history => $history,
+ );
+ push @entries, @$more;
+ }
+
+ return \@entries;
+}
+
+=method find_entries
+
+=method find_entries_simple
+
+ @entries = $kdbx->find_entries($query, %options);
+
+ @entries = $kdbx->find_entries_simple($expression, \@fields, %options);
+ @entries = $kdbx->find_entries_simple($expression, $operator, \@fields, %options);
+
+Find all entries deeply that match a query. Options are the same as for L</all_entries>.
+
+See L</QUERY> for a description of what C<$query> can be.
+
+=cut
+
+sub find_entries {
+ my $self = shift;
+ 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},
+ );
+ return @{search($self->all_entries(%all_entries), is_arrayref($query) ? @$query : $query)};
+}
+
+sub find_entries_simple {
+ my $self = shift;
+ my $text = shift;
+ my $op = @_ && !is_ref($_[0]) ? shift : undef;
+ my $fields = shift;
+ is_arrayref($fields) or throw q{Usage: find_entries_simple($expression, [$op,] \@fields)};
+ return $self->find_entries([\$text, $op, $fields], @_);
+}
+
+##############################################################################
+
+=method custom_icon
+
+ \%icon = $kdbx->custom_icon($uuid);
+ $kdbx->custom_icon($uuid => \%icon);
+ $kdbx->custom_icon(%icon);
+ $kdbx->custom_icon(uuid => $value, %icon);
+
+
+=cut
+
+sub custom_icon {
+ my $self = shift;
+ my %args = @_ == 2 ? (uuid => shift, value => shift)
+ : @_ % 2 == 1 ? (uuid => shift, @_) : @_;
+
+ if (!$args{key} && !$args{value}) {
+ my %standard = (key => 1, value => 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};
+ }
+ }
+
+ my $key = $args{key} or throw 'Must provide a custom_icons key to access';
+
+ return $self->{meta}{custom_icons}{$key} = $args{value} if is_plain_hashref($args{value});
+
+ while (my ($field, $value) = each %args) {
+ $self->{meta}{custom_icons}{$key}{$field} = $value;
+ }
+ return $self->{meta}{custom_icons}{$key};
+}
+
+=method custom_icon_data
+
+ $image_data = $kdbx->custom_icon_data($uuid);
+
+Get a custom icon.
+
+=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};
+}
+
+=method add_custom_icon
+
+ $uuid = $kdbx->add_custom_icon($image_data, %attributes);
+
+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<name> - Name of the icon (text, KDBX4.1+)
+* C<last_modification_time> - Just what it says (datetime, KDBX4.1+)
+
+=cut
+
+sub add_custom_icon {
+ my $self = shift;
+ 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} = {
+ @_,
+ uuid => $uuid,
+ data => $img,
+ };
+ return $uuid;
+}
+
+=method remove_custom_icon
+
+ $kdbx->remove_custom_icon($uuid);
+
+Remove a custom icon.
+
+=cut
+
+sub remove_custom_icon {
+ my $self = shift;
+ my $uuid = shift;
+ delete $self->custom_icons->{$uuid};
+}
+
+##############################################################################
+
+=method custom_data
+
+ \%all_data = $kdbx->custom_data;
+ $kdbx->custom_data(\%all_data);
+
+ \%data = $kdbx->custom_data($key);
+ $kdbx->custom_data($key => \%data);
+ $kdbx->custom_data(%data);
+ $kdbx->custom_data(key => $value, %data);
+
+Get and set custom data. Custom data is metadata associated with a database.
+
+Each data item can have a few attributes associated with it.
+
+=for :list
+* C<key> - A unique text string identifier used to look up the data item (required)
+* C<value> - A text string value (required)
+* C<last_modification_time> (optional, KDBX4.1+)
+
+=cut
+
+sub custom_data {
+ my $self = shift;
+ $self->{meta}{custom_data} = shift if @_ == 1 && is_plain_hashref($_[0]);
+ return $self->{meta}{custom_data} //= {} if !@_;
+
+ my %args = @_ == 2 ? (key => shift, value => shift)
+ : @_ % 2 == 1 ? (key => shift, @_) : @_;
+
+ if (!$args{key} && !$args{value}) {
+ my %standard = (key => 1, value => 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};
+ }
+ }
+
+ my $key = $args{key} or throw 'Must provide a custom_data key to access';
+
+ return $self->{meta}{custom_data}{$key} = $args{value} if is_plain_hashref($args{value});
+
+ while (my ($field, $value) = each %args) {
+ $self->{meta}{custom_data}{$key}{$field} = $value;
+ }
+ return $self->{meta}{custom_data}{$key};
+}
+
+=method custom_data_value
+
+ $value = $kdbx->custom_data_value($key);
+
+Exactly the same as L</custom_data> except returns just the custom data's value rather than a structure of
+attributes. This is a shortcut for:
+
+ my $data = $kdbx->custom_data($key);
+ my $value = defined $data ? $data->{value} : undef;
+
+=cut
+
+sub custom_data_value {
+ my $self = shift;
+ my $data = $self->custom_data(@_) // return;
+ return $data->{value};
+}
+
+=method public_custom_data
+
+ \%all_data = $kdbx->public_custom_data;
+ $kdbx->public_custom_data(\%all_data);
+
+ $value = $kdbx->public_custom_data($key);
+ $kdbx->public_custom_data($key => $value);
+
+Get and set public custom data. Public custom data is similar to custom data but different in some important
+ways. Public custom data:
+
+=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)
+
+=cut
+
+sub public_custom_data {
+ my $self = shift;
+ $self->{headers}{+HEADER_PUBLIC_CUSTOM_DATA} = shift if @_ == 1 && is_plain_hashref($_[0]);
+ return $self->{headers}{+HEADER_PUBLIC_CUSTOM_DATA} //= {} if !@_;
+
+ my $key = shift or throw 'Must provide a public_custom_data key to access';
+ $self->{headers}{+HEADER_PUBLIC_CUSTOM_DATA}{$key} = shift if @_;
+ return $self->{headers}{+HEADER_PUBLIC_CUSTOM_DATA}{$key};
+}
+
+##############################################################################
+
+# TODO
+
+# sub merge_to {
+# my $self = shift;
+# my $other = shift;
+# my %options = @_; # prefer_old / prefer_new
+# $other->merge_from($self);
+# }
+
+# sub merge_from {
+# my $self = shift;
+# my $other = shift;
+
+# die 'Not implemented';
+# }
+
+##############################################################################
+
+=method resolve_reference
+
+ $string = $kdbx->resolve_reference($reference);
+ $string = $kdbx->resolve_reference($wanted, $search_in, $expression);
+
+Resolve a L<field reference|https://keepass.info/help/base/fieldrefs.html>. A field reference is a kind of
+string placeholder. You can use a field reference to refer directly to a standard field within an entry. Field
+references are resolved automatically while expanding entry strings (i.e. replacing placeholders), but you can
+use this method to resolve on-the-fly references that aren't part of any actual string in the database.
+
+If the reference does not resolve to any field, C<undef> is returned. If the reference resolves to multiple
+fields, only the first one is returned (in the same order as L</all_entries>). To avoid ambiguity, you can
+refer to a specific entry by its UUID.
+
+The syntax of a reference is: C<< {REF:<WantedField>@<SearchIn>:<Text>} >>. C<Text> is a
+L</"Simple Expression">. C<WantedField> and C<SearchIn> are both single character codes representing a field:
+
+=for :list
+* C<T> - Title
+* C<U> - UserName
+* C<P> - Password
+* C<A> - URL
+* C<N> - Notes
+* C<I> - UUID
+* C<O> - Other custom strings
+
+Since C<O> does not represent any specific field, it cannot be used as the C<WantedField>.
+
+Examples:
+
+To get the value of the I<UserName> string of the first entry with "My Bank" in the title:
+
+ my $username = $kdbx->resolve_reference('{REF:U@T:"My Bank"}');
+ # OR the {REF:...} wrapper is optional
+ my $username = $kdbx->resolve_reference('U@T:"My Bank"');
+ # OR separate the arguments
+ my $username = $kdbx->resolve_reference(U => T => '"My Bank"');
+
+Note how the text is a L</"Simple Expression">, so search terms with spaces must be surrounded in double
+quotes.
+
+To get the I<Password> string of a specific entry (identified by its UUID):
+
+ my $password = $kdbx->resolve_reference('{REF:P@I:46C9B1FFBD4ABC4BBB260C6190BAD20C}');
+
+=cut
+
+sub resolve_reference {
+ my $self = shift;
+ my $wanted = shift // return;
+ my $search_in = shift;
+ my $text = shift;
+
+ if (!defined $text) {
+ $wanted =~ s/^\{REF:([^\}]+)\}$/$1/i;
+ ($wanted, $search_in, $text) = $wanted =~ /^([TUPANI])\@([TUPANIO]):(.*)$/i;
+ }
+ $wanted && $search_in && nonempty($text) or return;
+
+ my %fields = (
+ T => 'expanded_title',
+ U => 'expanded_username',
+ P => 'expanded_password',
+ A => 'expanded_url',
+ N => 'expanded_notes',
+ I => 'id',
+ 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 ($entry) = $self->find_entries($query);
+ $entry or return;
+
+ return $entry->$wanted;
+}
+
+our %PLACEHOLDERS = (
+ # placeholder => sub { my ($entry, $arg) = @_; ... };
+ 'TITLE' => sub { $_[0]->expanded_title },
+ 'USERNAME' => sub { $_[0]->expanded_username },
+ 'PASSWORD' => sub { $_[0]->expanded_password },
+ 'NOTES' => sub { $_[0]->expanded_notes },
+ 'S:' => sub { $_[0]->string_value($_[1]) },
+ 'URL' => sub { $_[0]->expanded_url },
+ 'URL:RMVSCM' => sub { local $_ = $_[0]->url; s!^[^:/\?\#]+://!!; $_ },
+ 'URL:WITHOUTSCHEME' => sub { local $_ = $_[0]->url; s!^[^:/\?\#]+://!!; $_ },
+ 'URL:SCM' => sub { (split_url($_[0]->url))[0] },
+ 'URL:SCHEME' => sub { (split_url($_[0]->url))[0] }, # non-standard
+ 'URL:HOST' => sub { (split_url($_[0]->url))[2] },
+ 'URL:PORT' => sub { (split_url($_[0]->url))[3] },
+ 'URL:PATH' => sub { (split_url($_[0]->url))[4] },
+ 'URL:QUERY' => sub { (split_url($_[0]->url))[5] },
+ 'URL:HASH' => sub { (split_url($_[0]->url))[6] }, # non-standard
+ 'URL:FRAGMENT' => sub { (split_url($_[0]->url))[6] }, # non-standard
+ 'URL:USERINFO' => sub { (split_url($_[0]->url))[1] },
+ 'URL:USERNAME' => sub { (split_url($_[0]->url))[7] },
+ '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') },
+ 'APPDIR' => sub { load_optional('FindBin'); $FindBin::Bin },
+ 'GROUP' => sub { $_[0]->parent->name },
+ 'GROUP_PATH' => sub { $_[0]->path },
+ 'GROUP_NOTES' => sub { $_[0]->parent->notes },
+ # 'GROUP_SEL'
+ # 'GROUP_SEL_PATH'
+ # 'GROUP_SEL_NOTES'
+ # 'DB_PATH'
+ # 'DB_DIR'
+ # 'DB_NAME'
+ # 'DB_BASENAME'
+ # 'DB_EXT'
+ 'ENV:' => sub { $ENV{$_[1]} },
+ 'ENV_DIRSEP' => sub { load_optional('File::Spec')->catfile('', '') },
+ 'ENV_PROGRAMFILES_X86' => sub { $ENV{'ProgramFiles(x86)'} || $ENV{'ProgramFiles'} },
+ # 'T-REPLACE-RX:'
+ # 'T-CONV:'
+ 'DT_SIMPLE' => sub { localtime->strftime('%Y%m%d%H%M%S') },
+ 'DT_YEAR' => sub { localtime->strftime('%Y') },
+ 'DT_MONTH' => sub { localtime->strftime('%m') },
+ 'DT_DAY' => sub { localtime->strftime('%d') },
+ 'DT_HOUR' => sub { localtime->strftime('%H') },
+ 'DT_MINUTE' => sub { localtime->strftime('%M') },
+ 'DT_SECOND' => sub { localtime->strftime('%S') },
+ 'DT_UTC_SIMPLE' => sub { gmtime->strftime('%Y%m%d%H%M%S') },
+ 'DT_UTC_YEAR' => sub { gmtime->strftime('%Y') },
+ 'DT_UTC_MONTH' => sub { gmtime->strftime('%m') },
+ 'DT_UTC_DAY' => sub { gmtime->strftime('%d') },
+ 'DT_UTC_HOUR' => sub { gmtime->strftime('%H') },
+ 'DT_UTC_MINUTE' => sub { gmtime->strftime('%M') },
+ 'DT_UTC_SECOND' => sub { gmtime->strftime('%S') },
+ # 'PICKCHARS'
+ # 'PICKCHARS:'
+ # 'PICKFIELD'
+ # 'NEWPASSWORD'
+ # 'NEWPASSWORD:'
+ # 'PASSWORD_ENC'
+ 'HMACOTP' => sub { $_[0]->hmac_otp },
+ 'TIMEOTP' => sub { $_[0]->time_otp },
+ 'C:' => sub { '' }, # comment
+ # 'BASE'
+ # 'BASE:'
+ # 'CLIPBOARD'
+ # 'CLIPBOARD-SET:'
+ # 'CMD:'
+);
+
+##############################################################################
+
+=method lock
+
+ $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.
+
+=cut
+
+sub _safe {
+ my $self = shift;
+ $SAFE{refaddr($self)} = shift if @_;
+ $SAFE{refaddr($self)};
+}
+
+sub _remove_safe { delete $SAFE{refaddr($_[0])} }
+
+sub lock {
+ my $self = shift;
+
+ $self->_safe and return $self;
+
+ my @strings;
+
+ my $entries = $self->all_entries(history => 1);
+ for my $entry (@$entries) {
+ push @strings, grep { $_->{protect} } values %{$entry->{strings} || {}};
+ }
+
+ $self->_safe(File::KDBX::Safe->new(\@strings));
+
+ return $self;
+}
+
+=method unlock
+
+ $kdbx->unlock;
+
+Decrypt all protected strings in a database, replacing C<undef> placeholders with unprotected values. Returns
+itself to allow method chaining.
+
+=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;
+
+ $safe->unlock;
+ $self->_remove_safe;
+
+ 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 is_locked
+
+ $bool = $kdbx->is_locked;
+
+Get whether or not a database's strings are memory-protected. If this is true, then some or all of the
+protected strings within the database will be unavailable (literally have C<undef> values) until L</unlock> is
+called.
+
+=cut
+
+sub is_locked { $_[0]->_safe ? 1 : 0 }
+
+##############################################################################
+
+=method randomize_seeds
+
+ $kdbx->randomize_seeds;
+
+Set various keys, seeds and IVs to random values. These values are used by the cryptographic functions that
+secure the database when dumped. The attributes that will be randomized are:
+
+=for :list
+* L</encryption_iv>
+* L</inner_random_stream_key>
+* L</master_seed>
+* L</stream_start_bytes>
+* L</transform_seed>
+
+Randomizing these values has no effect on a loaded database. These are only used when a database is dumped.
+You normally do not need to call this method explicitly because the dumper does it explicitly by default.
+
+=cut
+
+sub randomize_seeds {
+ my $self = shift;
+ $self->encryption_iv(random_bytes(16));
+ $self->inner_random_stream_key(random_bytes(64));
+ $self->master_seed(random_bytes(32));
+ $self->stream_start_bytes(random_bytes(32));
+ $self->transform_seed(random_bytes(32));
+}
+
+##############################################################################
+
+=method key
+
+ $key = $kdbx->key;
+ $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
+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.
+
+=cut
+
+sub key {
+ my $self = shift;
+ $KEYS{refaddr($self)} = File::KDBX::Key->new(@_) if @_;
+ $KEYS{refaddr($self)};
+}
+
+=method composite_key
+
+ $key = $kdbx->composite_key($key);
+ $key = $kdbx->composite_key($primitive);
+
+Construct a L<File::KDBX::Key::Composite> from a primitive. See L<File::KDBX::Key/new> for an explanation of
+what the primitive can be. If the primitive does not represent a composite key, it will be wrapped.
+
+You generally don't need to call this directly. The parser and writer use it to transform a master key into
+a raw encryption key.
+
+=cut
+
+sub composite_key {
+ my $self = shift;
+ require File::KDBX::Key::Composite;
+ return File::KDBX::Key::Composite->new(@_);
+}
+
+=method kdf
+
+ $kdf = $kdbx->kdf(%options);
+ $kdf = $kdbx->kdf(\%parameters, %options);
+
+Get a L<File::KDBX::KDF> (key derivation function).
+
+Options:
+
+=for :list
+* C<params> - KDF parameters, same as C<\%parameters> (default: value of L</kdf_parameters>)
+
+=cut
+
+sub kdf {
+ my $self = shift;
+ my %args = @_ % 2 == 1 ? (params => shift, @_) : @_;
+
+ my $params = $args{params};
+ my $compat = $args{compatible} // 1;
+
+ $params //= $self->kdf_parameters;
+ $params = {%{$params || {}}};
+
+ if (empty $params || !defined $params->{+KDF_PARAM_UUID}) {
+ $params->{+KDF_PARAM_UUID} = KDF_UUID_AES;
+ }
+ if ($params->{+KDF_PARAM_UUID} eq KDF_UUID_AES) {
+ # AES_CHALLENGE_RESPONSE is equivalent to AES if there are no challenge-response keys, and since
+ # non-KeePassXC implementations don't support challenge-response keys anyway, there's no problem with
+ # always using AES_CHALLENGE_RESPONSE for all KDBX4+ databases.
+ # For compatibility, we should not *write* AES_CHALLENGE_RESPONSE, but the dumper handles that.
+ if ($self->version >= KDBX_VERSION_4_0) {
+ $params->{+KDF_PARAM_UUID} = KDF_UUID_AES_CHALLENGE_RESPONSE;
+ }
+ $params->{+KDF_PARAM_AES_SEED} //= $self->transform_seed;
+ $params->{+KDF_PARAM_AES_ROUNDS} //= $self->transform_rounds;
+ }
+
+ require File::KDBX::KDF;
+ return File::KDBX::KDF->new(%$params);
+}
+
+sub transform_seed {
+ my $self = shift;
+ $self->headers->{+HEADER_TRANSFORM_SEED} =
+ $self->headers->{+HEADER_KDF_PARAMETERS}{+KDF_PARAM_AES_SEED} = shift if @_;
+ $self->headers->{+HEADER_TRANSFORM_SEED} =
+ $self->headers->{+HEADER_KDF_PARAMETERS}{+KDF_PARAM_AES_SEED} //= random_bytes(32);
+}
+
+sub transform_rounds {
+ my $self = shift;
+ $self->headers->{+HEADER_TRANSFORM_ROUNDS} =
+ $self->headers->{+HEADER_KDF_PARAMETERS}{+KDF_PARAM_AES_ROUNDS} = shift if @_;
+ $self->headers->{+HEADER_TRANSFORM_ROUNDS} =
+ $self->headers->{+HEADER_KDF_PARAMETERS}{+KDF_PARAM_AES_ROUNDS} //= 100_000;
+}
+
+=method cipher
+
+ $cipher = $kdbx->cipher(key => $key);
+ $cipher = $kdbx->cipher(key => $key, iv => $iv, uuid => $uuid);
+
+Get a L<File::KDBX::Cipher> capable of encrypting and decrypting the body of a database file.
+
+A key is required. This should be a raw encryption key made up of a fixed number of octets (depending on the
+cipher), not a L<File::KDBX::Key> or primitive.
+
+If not passed, the UUID comes from C<< $kdbx->headers->{cipher_id} >> and the encryption IV comes from
+C<< $kdbx->headers->{encryption_iv} >>.
+
+You generally don't need to call this directly. The parser and writer use it to decrypt and encrypt KDBX
+files.
+
+=cut
+
+sub cipher {
+ my $self = shift;
+ my %args = @_;
+
+ $args{uuid} //= $self->headers->{+HEADER_CIPHER_ID};
+ $args{iv} //= $self->headers->{+HEADER_ENCRYPTION_IV};
+
+ require File::KDBX::Cipher;
+ return File::KDBX::Cipher->new(%args);
+}
+
+=method random_stream
+
+ $cipher = $kdbx->random_stream;
+ $cipher = $kdbx->random_stream(id => $stream_id, key => $key);
+
+Get a L<File::KDBX::Cipher::Stream> for decrypting and encrypting protected values.
+
+If not passed, the ID and encryption key comes from C<< $kdbx->headers->{inner_random_stream_id} >> and
+C<< $kdbx->headers->{inner_random_stream_key} >> (respectively) for KDBX3 files and from
+C<< $kdbx->inner_headers->{inner_random_stream_key} >> and
+C<< $kdbx->inner_headers->{inner_random_stream_id} >> (respectively) for KDBX4 files.
+
+You generally don't need to call this directly. The parser and writer use it to scramble protected strings.
+
+=cut
+
+sub random_stream {
+ my $self = shift;
+ my %args = @_;
+
+ $args{stream_id} //= delete $args{id} // $self->inner_random_stream_id;
+ $args{key} //= $self->inner_random_stream_key;
+
+ require File::KDBX::Cipher;
+ File::KDBX::Cipher->new(%args);
+}
+
+sub inner_random_stream_id {
+ my $self = shift;
+ $self->inner_headers->{+INNER_HEADER_INNER_RANDOM_STREAM_ID}
+ = $self->headers->{+HEADER_INNER_RANDOM_STREAM_ID} = shift if @_;
+ $self->inner_headers->{+INNER_HEADER_INNER_RANDOM_STREAM_ID}
+ //= $self->headers->{+HEADER_INNER_RANDOM_STREAM_ID} //= do {
+ my $version = $self->minimum_version;
+ $version < KDBX_VERSION_4_0 ? STREAM_ID_SALSA20 : STREAM_ID_CHACHA20;
+ };
+}
+
+sub inner_random_stream_key {
+ my $self = shift;
+ if (@_) {
+ # These are probably the same SvPV so erasing one will CoW, but erasing the second should do the
+ # trick anyway.
+ erase \$self->inner_headers->{+INNER_HEADER_INNER_RANDOM_STREAM_KEY};
+ erase \$self->headers->{+HEADER_INNER_RANDOM_STREAM_KEY};
+ $self->inner_headers->{+INNER_HEADER_INNER_RANDOM_STREAM_KEY}
+ = $self->headers->{+HEADER_INNER_RANDOM_STREAM_KEY} = shift;
+ }
+ $self->inner_headers->{+INNER_HEADER_INNER_RANDOM_STREAM_KEY}
+ //= $self->headers->{+HEADER_INNER_RANDOM_STREAM_KEY} //= random_bytes(64); # 32
+}
+
+#########################################################################################
+
+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 icons
+# - All data types are valid
+# - date times are correct
+# - boolean fields
+# - All UUIDs refer to things that exist
+# - previous parent group
+# - recycle bin
+# - last selected group
+# - last visible group
+# - Enforce history size limits (ON)
+# - Check headers/meta (ON)
+# - Duplicate deleted objects (ON)
+# - Duplicate window associations (OFF)
+# - Only one root group (ON)
+ # - Header UUIDs match known ciphers/KDFs?
+}
+
+#########################################################################################
+
+=attr comment
+
+A text string associated with the database. Often unset.
+
+=attr cipher_id
+
+The UUID of a cipher used to encrypt the database when stored as a file.
+
+See L</File::KDBX::Cipher>.
+
+=attr compression_flags
+
+Configuration for whether or not and how the database gets compressed. See
+L<File::KDBX::Constants/":compression">.
+
+=attr master_seed
+
+The master seed is a string of 32 random bytes that is used as salt in hashing the master key when loading
+and saving the database. If a challenge-response key is used in the master key, the master seed is also the
+challenge.
+
+The master seed I<should> be changed each time the database is saved to file.
+
+=attr transform_seed
+
+The transform seed is a string of 32 random bytes that is used in the key derivation function, either as the
+salt or the key (depending on the algorithm).
+
+The transform seed I<should> be changed each time the database is saved to file.
+
+=attr transform_rounds
+
+The number of rounds or iterations used in the key derivation function. Increasing this number makes loading
+and saving the database slower by design in order to make dictionary and brute force attacks more costly.
+
+=attr encryption_iv
+
+The initialization vector used by the cipher.
+
+The encryption IV I<should> be changed each time the database is saved to file.
+
+=attr inner_random_stream_key
+
+The encryption key (possibly including the IV, depending on the cipher) used to encrypt the protected strings
+within the database.
+
+=attr stream_start_bytes
+
+A string of 32 random bytes written in the header and encrypted in the body. If the bytes do not match when
+loading a file then the wrong master key was used or the file is corrupt. Only KDBX 2 and KDBX 3 files use
+this. KDBX 4 files use an improved HMAC method to verify the master key and data integrity of the header and
+entire file body.
+
+=attr inner_random_stream_id
+
+A number indicating the cipher algorithm used to encrypt the protected strings within the database, usually
+Salsa20 or ChaCha20. See L<File::KDBX::Constants/":random_stream">.
+
+=attr kdf_parameters
+
+A hash/dict of key-value pairs used to configure the key derivation function. This is the KDBX4+ way to
+configure the KDF, superceding L</transform_seed> and L</transform_rounds>.
+
+=attr generator
+
+The name of the software used to generate the KDBX file.
+
+=attr header_hash
+
+The header hash used to verify that the file header is not corrupt. (KDBX 2 - KDBX 3.1, removed KDBX 4.0)
+
+=attr database_name
+
+Name of the database.
+
+=attr database_name_changed
+
+Timestamp indicating when the database name was last changed.
+
+=attr database_description
+
+Description of the database
+
+=attr database_description_changed
+
+Timestamp indicating when the database description was last changed.
+
+=attr default_username
+
+When a new entry is created, the I<UserName> string will be populated with this value.
+
+=attr default_username_changed
+
+Timestamp indicating when the default username was last changed.
+
+=attr maintenance_history_days
+
+TODO... not really sure what this is. 😀
+
+=attr color
+
+A color associated with the database (in the form C<#ffffff> where "f" is a hexidecimal digit). Some agents
+use this to help users visually distinguish between different databases.
+
+=attr master_key_changed
+
+Timestamp indicating when the master key was last changed.
+
+=attr master_key_change_rec
+
+Number of days until the agent should prompt to recommend changing the master key.
+
+=attr master_key_change_force
+
+Number of days until the agent should prompt to force changing the master key.
+
+Note: This is purely advisory. It is up to the individual agent software to actually enforce it.
+C<File::KDBX> does NOT enforce it.
+
+=attr recycle_bin_enabled
+
+Boolean indicating whether removed groups and entries should go to a recycle bin or be immediately deleted.
+
+=attr recycle_bin_uuid
+
+The UUID of a group used to store thrown-away groups and entries.
+
+=attr recycle_bin_changed
+
+Timestamp indicating when the recycle bin was last changed.
+
+=attr entry_templates_group
+
+The UUID of a group containing template entries used when creating new entries.
+
+=attr entry_templates_group_changed
+
+Timestamp indicating when the entry templates group was last changed.
+
+=attr last_selected_group
+
+The UUID of the previously-selected group.
+
+=attr last_top_visible_group
+
+The UUID of the group visible at the top of the list.
+
+=attr history_max_items
+
+The maximum number of historical entries allowed to be saved for each entry.
+
+=attr history_max_size
+
+The maximum total size (in bytes) that each individual entry's history is allowed to grow.
+
+=attr settings_changed
+
+Timestamp indicating when the database settings were last updated.
+
+=attr protect_title
+
+Alias of the L</memory_protection> setting for the I<Title> string.
+
+=attr protect_username
+
+Alias of the L</memory_protection> setting for the I<UserName> string.
+
+=attr protect_password
+
+Alias of the L</memory_protection> setting for the I<Password> string.
+
+=attr protect_url
+
+Alias of the L</memory_protection> setting for the I<URL> string.
+
+=attr protect_notes
+
+Alias of the L</memory_protection> setting for the I<Notes> string.
+
+=cut
+
+#########################################################################################
+
+sub TO_JSON { +{%{$_[0]}} }
+
+1;
+__END__
+
+=for Pod::Coverage TO_JSON
+
+=head1 SYNOPSIS
+
+ use File::KDBX;
+
+ my $kdbx = File::KDBX->new;
+
+ my $group = $kdbx->add_group(
+ name => 'Passwords',
+ );
+
+ my $entry = $group->add_entry(
+ title => 'My Bank',
+ password => 's3cr3t',
+ );
+
+ $kdbx->dump_file('passwords.kdbx', 'M@st3rP@ssw0rd!');
+
+ $kdbx = File::KDBX->load_file('passwords.kdbx', 'M@st3rP@ssw0rd!');
+
+ for my $entry (@{ $kdbx->all_entries }) {
+ say 'Entry: ', $entry->title;
+ }
+
+=head1 DESCRIPTION
+
+B<File::KDBX> provides everything you need to work with a KDBX database. A KDBX database is a hierarchical
+object database which is commonly used to store secret information securely. It was developed for the KeePass
+password safe. See L</"KDBX Introduction"> for more information about KDBX.
+
+This module lets you query entries, create new entries, delete entries and modify entries. The distribution
+also includes various parsers and generators for serializing and persisting databases.
+
+This design of this software was influenced by the L<KeePassXC|https://github.com/keepassxreboot/keepassxc>
+implementation of KeePass as well as the L<File::KeePass> module. B<File::KeePass> is an alternative module
+that works well in most cases but has a small backlog of bugs and security issues and also does not work with
+newer KDBX version 4 files. If you're coming here from the B<File::KeePass> world, you might be interested in
+L<File::KeePass::KDBX> that is a drop-in replacement for B<File::KeePass> that uses B<File::KDBX> for storage.
+
+=head2 KDBX Introduction
+
+A KDBX database consists of a hierarchical I<group> of I<entries>. Entries can contain zero or more key-value
+pairs of I<strings> and zero or more I<binaries> (i.e. octet strings). Groups, entries, strings and binaries:
+that's the KDBX vernacular. A small amount of metadata (timestamps, etc.) is associated with each entry, group
+and the database as a whole.
+
+You can think of a KDBX database kind of like a file system, where groups are directories, entries are files,
+and strings and binaries make up a file's contents.
+
+Databases are typically persisted as a encrypted, compressed files. They are usually accessed directly (i.e.
+not over a network). The primary focus of this type of database is data security. It is ideal for storing
+relatively small amounts of data (strings and binaries) that must remain secret except to such individuals as
+have the correct I<master key>. Even if the database file were to be "leaked" to the public Internet, it
+should be virtually impossible to crack with a strong key. See L</SECURITY> for an overview of security
+considerations.
+
+=head1 RECIPES
+
+=head2 Create a new database
+
+ my $kdbx = File::KDBX->new;
+
+ my $group = $kdbx->add_group(name => 'Passwords);
+ my $entry = $group->add_entry(
+ title => 'WayneCorp',
+ username => 'bwayne',
+ password => 'iambatman',
+ url => 'https://example.com/login'
+ );
+ $entry->add_auto_type_window_association('WayneCorp - Mozilla Firefox', '{PASSWORD}{ENTER}');
+
+ $kdbx->dump_file('mypasswords.kdbx', 'master password CHANGEME');
+
+=head2 Read an existing database
+
+ my $kdbx = File::KDBX->load_file('mypasswords.kdbx', 'master password CHANGEME');
+ $kdbx->unlock;
+
+ for my $entry (@{ $kdbx->all_entries }) {
+ say 'Found password for ', $entry->title, ':';
+ say ' Username: ', $entry->username;
+ say ' Password: ', $entry->password;
+ }
+
+=head2 Search for entries
+
+ my @entries = $kdbx->find_entries({
+ title => 'WayneCorp',
+ }, search => 1);
+
+See L</QUERY> for many more query examples.
+
+=head2 Search for entries by auto-type window association
+
+ my @entry_key_sequences = $kdbx->find_entries_for_window('WayneCorp - Mozilla Firefox');
+ for my $pair (@entry_key_sequences) {
+ my ($entry, $key_sequence) = @$pair;
+ say 'Entry title: ', $entry->title, ', key sequence: ', $key_sequence;
+ }
+
+Example output:
+
+ Entry title: WayneCorp, key sequence: {PASSWORD}{ENTER}
+
+=head1 SECURITY
+
+One of the biggest threats to your database security is how easily the encryption key can be brute-forced.
+Strong brute-force protection depends on a couple factors:
+
+=for :list
+* Using unguessable passwords, passphrases and key files.
+* Using a brute-force resistent key derivation function.
+
+The first factor is up to you. This module does not enforce strong master keys. It is up to you to pick or
+generate strong keys.
+
+The KDBX format allows for the key derivation function to be tuned. The idea is that you want each single
+brute-foce attempt to be expensive (in terms of time, CPU usage or memory usage), so that making a lot of
+attempts (which would be required if you have a strong master key) gets I<really> expensive.
+
+How expensive you want to make each attempt is up to you and can depend on the application.
+
+This and other KDBX-related security issues are covered here more in depth:
+L<https://keepass.info/help/base/security.html>
+
+Here are other security risks you should be thinking about:
+
+=head2 Cryptography
+
+This distribution uses the excellent L<CryptX> and L<Crypt::Argon2> packages to handle all crypto-related
+functions. As such, a lot of the security depends on the quality of these dependencies. Fortunately these
+modules are maintained and appear to have good track records.
+
+The KDBX format has evolved over time to incorporate improved security practices and cryptographic functions.
+This package uses the following functions for authentication, hashing, encryption and random number
+generation:
+
+=for :list
+* AES-128 (legacy)
+* AES-256
+* Argon2d & Argon2id
+* CBC block mode
+* HMAC-SHA256
+* SHA256
+* SHA512
+* Salsa20 & ChaCha20
+* Twofish
+
+At the time of this writing, I am not aware of any successful attacks against any of these functions. These
+are among the most-analyzed and widely-adopted crypto functions available.
+
+The KDBX format allows the body cipher and key derivation function to be configured. If a flaw is discovered
+in one of these functions, you can hopefully just switch to a better function without needing to update this
+software. A later software release may phase out the use of any functions which are no longer secure.
+
+=head2 Memory Protection
+
+It is not a good idea to keep secret information unencrypted in system memory for longer than is needed. The
+address space of your program can generally be read by a user with elevated privileges on the system. If your
+system is memory-constrained or goes into a hibernation mode, the contents of your address space could be
+written to a disk where it might be persisted for long time.
+
+There might be system-level things you can do to reduce your risk, like using swap encryption and limiting
+system access to your program's address space while your program is running.
+
+B<File::KDBX> helps minimize (but not eliminate) risk by keeping secrets encrypted in memory until accessed
+and zeroing out memory that holds secrets after they're no longer needed, but it's not a silver bullet.
+
+For one thing, the encryption key is stored in the same address space. If core is dumped, the encryption key
+is available to be found out. But at least there is the chance that the encryption key and the encrypted
+secrets won't both be paged out while memory-constrained.
+
+Another problem is that some perls (somewhat notoriously) copy around memory behind the scenes willy nilly,
+and it's difficult know when perl makes a copy of a secret in order to be able to zero it out later. It might
+be impossible. The good news is that perls with SvPV copy-on-write (enabled by default beginning with perl
+5.20) are much better in this regard. With COW, it's mostly possible to know what operations will cause perl
+to copy the memory of a scalar string, and the number of copies will be significantly reduced. There is a unit
+test named F<t/memory-protection.t> in this distribution that can be run on POSIX systems to determine how
+well B<File::KDBX> memory protection is working.
+
+Memory protection also depends on how your application handles secrets. If your app code is handling scalar
+strings with secret information, it's up to you to make sure its memory is zeroed out when no longer needed.
+L<File::KDBX::Util/erase> et al. provide some tools to help accomplish this. Or if you're not too concerned
+about the risks memory protection is meant to mitigate, then maybe don't worry about it. The security policy
+of B<File::KDBX> is to try hard to keep secrets protected while in memory so that your app might claim a high
+level of security, in case you care about that.
+
+There are some memory protection strategies that B<File::KDBX> does NOT use today but could in the future:
+
+Many systems allow programs to mark unswappable pages. Secret information should ideally be stored in such
+pages. You could potentially use L<mlockall(2)> (or equivalent for your system) in your own application to
+prevent the entire address space from being swapped.
+
+Some systems provide special syscalls for storing secrets in memory while keeping the encryption key outside
+of the program's address space, like C<CryptProtectMemory> for Windows. This could be a good option, though
+unfortunately not portable.
+
+=head1 QUERY
+
+Several methods take a I<query> as an argument (e.g. L</find_entries>). A query is just a subroutine that you
+can either write yourself or have generated for you based on either a simple expression or a declarative
+structure. It's easier to have your query generated, so I'll cover that first.
+
+=head2 Simple Expression
+
+A simple expression is mostly compatible with the KeePass 2 implementation
+L<described here|https://keepass.info/help/base/search.html#mode_se>.
+
+An expression is a string with one or more space-separated terms. Terms with spaces can be enclosed in double
+quotes. Terms are negated if they are prefixed with a minus sign. A record must match every term on at least
+one of the given fields.
+
+So a simple expression is something like what you might type into a search engine. You can generate a simple
+expression query using L<File::KDBX::Util/simple_expression_query> or by passing the simple expression as
+a B<string reference> to search methods like L</find_entries>.
+
+To search for all entries in a database with the word "canyon" appearing anywhere in the title:
+
+ my @entries = $kdbx->find_entries([ \'canyon', qw(title) ]);
+
+Notice the first argument is a B<stringref>. This diambiguates a simple expression from other types of queries
+covered below.
+
+As mentioned, a simple expression can have multiple terms. This simple expression query matches any entry that
+has the words "red" B<and> "canyon" anywhere in the title:
+
+ my @entries = $kdbx->find_entries([ \'red canyon', qw(title) ]);
+
+Each term in the simple expression must be found for an entry to match.
+
+To search for entries with "red" in the title but B<not> "canyon", just prepend "canyon" with a minus sign:
+
+ my @entries = $kdbx->find_entries([ \'red -canyon', qw(title) ]);
+
+To search over multiple fields simultaneously, just list them. To search for entries with "grocery" in the
+title or notes but not "Foodland":
+
+ my @entries = $kdbx->find_entries([ \'grocery -Foodland', qw(title notes) ]);
+
+The default operator is a case-insensitive regexp match, which is fine for searching text loosely. You can use
+just about any binary comparison operator that perl supports. To specify an operator, list it after the simple
+expression. For example, to search for any entry that has been used at least five times:
+
+ my @entries = $kdbx->find_entries([ \5, '>=', qw(usage_count) ]);
+
+It helps to read it right-to-left, like "usage_count is >= 5".
+
+If you find the disambiguating structures to be confusing, you can also the L</find_entries_simple> method as
+a more intuitive alternative. The following example is equivalent to the previous:
+
+ my @entries = $kdbx->find_entries_simple(5, '>=', qw(usage_count));
+
+=head2 Declarative Query
+
+Structuring a declarative query is similar to L<SQL::Abstract/"WHERE CLAUSES">, but you don't have to be
+familiar with that module. Just learn by examples.
+
+To search for all entries in a database titled "My Bank":
+
+ my @entries = $kdbx->find_entries({ title => 'My Bank' });
+
+The query here is C<< { title => 'My Bank' } >>. A hashref can contain key-value pairs where the key is
+a attribute of the thing being searched for (in this case an entry) and the value is what you want the thing's
+attribute to be to consider it a match. In this case, the attribute we're using as our match criteria is
+L<File::KDBX::Entry/title>, a text field. If an entry has its title attribute equal to "My Bank", it's
+a match.
+
+A hashref can contain multiple attributes. The search candidate will be a match if I<all> of the specified
+attributes are equal to their respective values. For example, to search for all entries with a particular URL
+B<AND> username:
+
+ my @entries = $kdbx->find_entries({
+ url => 'https://example.com',
+ username => 'neo',
+ });
+
+To search for entries matching I<any> criteria, just change the hashref to an arrayref. To search for entries
+with a particular URL B<OR> a particular username:
+
+ my @entries = $kdbx->find_entries([ # <-- square bracket
+ url => 'https://example.com',
+ username => 'neo',
+ ]);
+
+You can user different operators to test different types of attributes. The L<File::KDBX::Entry/icon_id>
+attribute is a number, so we should use a number comparison operator. To find entries using the smartphone
+icon:
+
+ my @entries = $kdbx->find_entries({
+ icon_id => { '==', ICON_SMARTPHONE },
+ });
+
+Note: L<File::KDBX::Constants/ICON_SMARTPHONE> is just a constant from L<File::KDBX::Constants>. It isn't
+special to this example or to queries generally. We could have just used a literal number.
+
+The important thing to notice here is how we wrapped the condition in another arrayref with a single key-pair
+where the key is the name of an operator and the value is the thing to match against. The supported operators
+are:
+
+=for :list
+* C<eq> - String equal
+* C<ne> - String not equal
+* C<lt> - String less than
+* C<gt> - String greater than
+* C<le> - String less than or equal
+* C<ge> - String greater than or equal
+* C<==> - Number equal
+* C<!=> - Number not equal
+* C<< < >> - Number less than
+* C<< > >>> - Number greater than
+* C<< <= >> - Number less than or equal
+* C<< >= >> - Number less than or equal
+* C<=~> - String match regular expression
+* C<!~> - String does not match regular expression
+* C<!> - Boolean false
+* C<!!> - Boolean true
+
+Other special operators:
+
+=for :list
+* C<-true> - Boolean true
+* C<-false> - Boolean false
+* C<-not> - Boolean false (alias for C<-false>)
+* C<-defined> - Is defined
+* C<-undef> - Is not d efined
+* C<-empty> - Is empty
+* C<-nonempty> - Is not empty
+* C<-or> - Logical or
+* C<-and> - Logical and
+
+Let's see another example using an explicit operator. To find all groups except one in particular (identified
+by its L<File::KDBX::Group/uuid>), we can use the C<ne> (string not equal) operator:
+
+ my ($group, @other) = $kdbx->find_groups({
+ uuid => {
+ 'ne' => uuid('596f7520-6172-6520-7370-656369616c2e'),
+ },
+ });
+ if (@other) { say "Problem: there can be only one!" }
+
+Note: L<File::KDBX::Util/uuid> is a little helper function to convert a UUID in its pretty form into octets.
+This helper function isn't special to this example or to queries generally. It could have been written with
+a literal such as C<"\x59\x6f\x75\x20\x61...">, but that's harder to read.
+
+Notice we searched for groups this time. Finding groups works exactly the same as it does for entries.
+
+Testing the truthiness of an attribute is a little bit different because it isn't a binary operation. To find
+all entries with the password quality check disabled:
+
+ my @entries = $kdbx->find_entries({ '!' => 'quality_check' });
+
+This time the string after the operator is the attribute name rather than a value to compare the attribute
+against. To test that a boolean value is true, use the C<!!> operator (or C<-true> if C<!!> seems a little too
+weird for your taste):
+
+ my @entries = $kdbx->find_entries({ '!!' => 'quality_check' });
+ my @entries = $kdbx->find_entries({ -true => 'quality_check' });
+
+Yes, there is also a C<-false> and a C<-not> if you prefer one of those over C<!>. C<-false> and C<-not>
+(along with C<-true>) are also special in that you can use them to invert the logic of a subquery. These are
+logically equivalent:
+
+ my @entries = $kdbx->find_entries([ -not => { title => 'My Bank' } ]);
+ my @entries = $kdbx->find_entries({ title => { 'ne' => 'My Bank' } });
+
+These special operators become more useful when combined with two more special operators: C<-and> and C<-or>.
+With these, it is possible to construct more interesting queries with groups of logic. For example:
+
+ my @entries = $kdbx->find_entries({
+ title => { '=~', qr/bank/ },
+ -not => {
+ -or => {
+ notes => { '=~', qr/business/ },
+ icon_id => { '==', ICON_TRASHCAN_FULL },
+ },
+ },
+ });
+
+In English, find entries where the word "bank" appears anywhere in the title but also do not have either the
+word "business" in the notes or is using the full trashcan icon.
+
+=head2 Subroutine Query
+
+Lastly, as mentioned at the top, you can ignore all this and write your own subroutine. Your subroutine will
+be called once for each thing being searched over. The single argument is the search candidate. The subroutine
+should match the candidate against whatever criteria you want and return true if it matches. The C<find_*>
+methods collect all matching things and return them.
+
+For example, to find all entries in the database titled "My Bank":
+
+ my @entries = $kdbx->find_entries(sub { shift->title eq 'My Bank' });
+ # logically the same as this declarative structure:
+ my @entries = $kdbx->find_entries({ title => 'My Bank' });
+ # as well as this simple expression:
+ my @entries = $kdbx->find_entries([ \'My Bank', 'eq', qw{title} ]);
+
+This is a trivial example, but of course your subroutine can be arbitrarily complex.
+
+All of these query mechanisms described in this section are just tools, each with its own set of limitations.
+If the tools are getting in your way, you can of course iterate over the contents of a database and implement
+your own query logic, like this:
+
+ for my $entry (@{ $kdbx->all_entries }) {
+ if (wanted($entry)) {
+ do_something($entry);
+ }
+ else {
+ ...
+ }
+ }
+
+=head1 ERRORS
+
+Errors in this package are constructed as L<File::KDBX::Error> objects and propagated using perl's built-in
+mechanisms. Fatal errors are propagated using L<functions/die> and non-fatal errors (a.k.a. warnings) are
+propagated using L<functions/warn> while adhering to perl's L<warnings> system. If you're already familiar
+with these mechanisms, you can skip this section.
+
+You can catch fatal errors using L<functions/eval> (or something like L<Try::Tiny>) and non-fatal errors using
+C<$SIG{__WARN__}> (see L<variables/%SIG>). Examples:
+
+ use File::KDBX::Error qw(error);
+
+ my $key = ''; # uh oh
+ eval {
+ $kdbx->load_file('whatever.kdbx', $key);
+ };
+ if (my $error = error($@)) {
+ handle_missing_key($error) if $error->type eq 'key.missing';
+ $error->throw;
+ }
+
+or using C<Try::Tiny>:
+
+ try {
+ $kdbx->load_file('whatever.kdbx', $key);
+ }
+ catch {
+ handle_error($_);
+ };
+
+Catching non-fatal errors:
+
+ my @warnings;
+ local $SIG{__WARN__} = sub { push @warnings, $_[0] };
+
+ $kdbx->load_file('whatever.kdbx', $key);
+
+ handle_warnings(@warnings) if @warnings;
+
+By default perl prints warnings to C<STDERR> if you don't catch them. If you don't want to catch them and also
+don't want them printed to C<STDERR>, you can suppress them lexically (perl v5.28 or higher required):
+
+ {
+ no warnings 'File::KDBX';
+ ...
+ }
+
+or locally:
+
+ {
+ local $File::KDBX::WARNINGS = 0;
+ ...
+ }
+
+or globally in your program:
+
+ $File::KDBX::WARNINGS = 0;
+
+You cannot suppress fatal errors, and if you don't catch them your program will exit.
+
+=head1 ENVIRONMENT
+
+This software will alter its behavior depending on the value of certain environment variables:
+
+=for :list
+* C<PERL_FILE_KDBX_XS> - Do not use L<File::KDBX::XS> if false (default: true)
+* C<PERL_ONLY> - Do not use L<File::KDBX::XS> if true (default: false)
+* C<NO_FORK> - Do not fork if true (default: false)
+
+=head1 CAVEATS
+
+Some features (e.g. parsing) require 64-bit perl. It should be possible and actually pretty easy to make it
+work using L<Math::BigInt>, but I need to build a 32-bit perl in order to test it and frankly I'm still
+figuring out how. I'm sure it's simple so I'll mark this one "TODO", but for now an exception will be thrown
+when trying to use such features with undersized IVs.
+
+=head1 SEE ALSO
+
+L<File::KeePass> is a much older alternative. It's good but has a backlog of bugs and lacks support for newer
+KDBX features.
+
+=cut
--- /dev/null
+package File::KDBX::Cipher;
+# ABSTRACT: A block cipher mode or cipher stream
+
+use warnings;
+use strict;
+
+use Devel::GlobalDestruction;
+use File::KDBX::Constants qw(:cipher :random_stream);
+use File::KDBX::Error;
+use File::KDBX::Util qw(erase format_uuid);
+use Module::Load;
+use Scalar::Util qw(looks_like_number);
+use namespace::clean;
+
+our $VERSION = '999.999'; # VERSION
+
+my %CIPHERS;
+
+=method new
+
+=method new_from_uuid
+
+=method new_from_stream_id
+
+ $cipher = File::KDBX::Cipher->new(uuid => $uuid, key => $key, iv => $iv);
+ # OR
+ $cipher = File::KDBX::Cipher->new_from_uuid($uuid, key => $key, iv => $iv);
+
+ $cipher = File::KDBX::Cipher->new(stream_id => $id, key => $key);
+ # OR
+ $cipher = File::KDBX::Cipher->new_from_stream_id($id, key => $key);
+
+Construct a new L<File::KDBX::Cipher>.
+
+This is a factory method which returns a subclass.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my %args = @_;
+
+ return $class->new_from_uuid(delete $args{uuid}, %args) if defined $args{uuid};
+ return $class->new_from_stream_id(delete $args{stream_id}, %args) if defined $args{stream_id};
+
+ throw 'Must pass uuid or stream_id';
+}
+
+sub new_from_uuid {
+ my $class = shift;
+ my $uuid = shift;
+ my %args = @_;
+
+ $args{key} or throw 'Missing encryption key';
+ $args{iv} or throw 'Missing encryption IV';
+
+ my $formatted_uuid = format_uuid($uuid);
+
+ my $cipher = $CIPHERS{$uuid} or throw "Unsupported cipher ($formatted_uuid)", uuid => $uuid;
+ ($class, my %registration_args) = @$cipher;
+
+ my @args = (%args, %registration_args, uuid => $uuid);
+ load $class;
+ my $self = bless {@args}, $class;
+ return $self->init(@args);
+}
+
+sub new_from_stream_id {
+ my $class = shift;
+ my $id = shift;
+ my %args = @_;
+
+ $args{key} or throw 'Missing encryption key';
+
+ my $cipher = $CIPHERS{$id} or throw "Unsupported stream cipher ($id)", id => $id;
+ ($class, my %registration_args) = @$cipher;
+
+ my @args = (%args, %registration_args, stream_id => $id);
+ load $class;
+ my $self = bless {@args}, $class;
+ return $self->init(@args);
+}
+
+=method init
+
+ $self->init;
+
+Initialize the cipher. Called by </new>.
+
+=cut
+
+sub init { $_[0] }
+
+sub DESTROY { !in_global_destruction and erase \$_[0]->{key} }
+
+=attr uuid
+
+ $uuid = $cipher->uuid;
+
+Get the UUID if the cipher was constructed with one.
+
+=cut
+
+sub uuid { $_[0]->{uuid} }
+
+=attr stream_id
+
+ $stream_id = $cipher->stream_id;
+
+Get the stream ID if the cipher was constructed with one.
+
+=cut
+
+sub stream_id { $_[0]->{stream_id} }
+
+=attr key
+
+ $key = $cipher->key;
+
+Get the raw encryption key.
+
+=cut
+
+sub key { $_[0]->{key} }
+
+=attr iv
+
+ $iv = $cipher->iv;
+
+Get the initialization vector.
+
+=cut
+
+sub iv { $_[0]->{iv} }
+
+=attr default_iv_size
+
+ $size = $cipher->default_iv_size;
+
+Get the default size of the initialization vector, in bytes.
+
+=cut
+
+sub key_size { -1 }
+
+=attr key_size
+
+ $size = $cipher->key_size;
+
+Get the size the mode expects the key to be, in bytes.
+
+=cut
+
+sub iv_size { 0 }
+
+=attr block_size
+
+ $size = $cipher->block_size;
+
+Get the block size, in bytes.
+
+=cut
+
+sub block_size { 0 }
+
+=method encrypt
+
+ $ciphertext = $cipher->encrypt($plaintext, ...);
+
+Encrypt some data.
+
+=cut
+
+sub encrypt { die "Not implemented" }
+
+=method decrypt
+
+ $plaintext = $cipher->decrypt($ciphertext, ...);
+
+Decrypt some data.
+
+=cut
+
+sub decrypt { die "Not implemented" }
+
+=method finish
+
+ $ciphertext .= $cipher->finish; # if encrypting
+ $plaintext .= $cipher->finish; # if decrypting
+
+Finish the stream.
+
+=cut
+
+sub finish { '' }
+
+=method encrypt_finish
+
+ $ciphertext = $cipher->encrypt_finish($plaintext, ...);
+
+Encrypt and finish a stream in one call.
+
+=cut
+
+sub encrypt_finish {
+ my $self = shift;
+ my $out = $self->encrypt(@_);
+ $out .= $self->finish;
+ return $out;
+}
+
+=method decrypt_finish
+
+ $plaintext = $cipher->decrypt_finish($ciphertext, ...);
+
+Decrypt and finish a stream in one call.
+
+=cut
+
+sub decrypt_finish {
+ my $self = shift;
+ my $out = $self->decrypt(@_);
+ $out .= $self->finish;
+ return $out;
+}
+
+=method register
+
+ File::KDBX::Cipher->register($uuid => $package, %args);
+
+Register a cipher. Registered ciphers can be used to encrypt and decrypt KDBX databases. A cipher's UUID
+B<must> be unique and B<musn't change>. A cipher UUID is written into each KDBX file and the associated cipher
+must be registered with the same UUID in order to decrypt the KDBX file.
+
+C<$package> should be a Perl package relative to C<File::KDBX::Cipher::> or prefixed with a C<+> if it is
+a fully-qualified package. C<%args> are passed as-is to the cipher's L</init> method.
+
+=cut
+
+sub register {
+ my $class = shift;
+ my $id = shift;
+ my $package = shift;
+ my @args = @_;
+
+ my $formatted_id = looks_like_number($id) ? $id : format_uuid($id);
+ $package = "${class}::${package}" if $package !~ s/^\+// && $package !~ /^\Q${class}::\E/;
+
+ my %blacklist = map { (looks_like_number($_) ? $_ : File::KDBX::Util::uuid($_)) => 1 }
+ split(/,/, $ENV{FILE_KDBX_CIPHER_BLACKLIST} // '');
+ if ($blacklist{$id} || $blacklist{$package}) {
+ alert "Ignoring blacklisted cipher ($formatted_id)", id => $id, package => $package;
+ return;
+ }
+
+ if (defined $CIPHERS{$id}) {
+ alert "Overriding already-registered cipher ($formatted_id) with package $package",
+ id => $id,
+ package => $package;
+ }
+
+ $CIPHERS{$id} = [$package, @args];
+}
+
+=method unregister
+
+ File::KDBX::Cipher->unregister($uuid);
+
+Unregister a cipher. Unregistered ciphers can no longer be used to encrypt and decrypt KDBX databases, until
+reregistered (see L</register>).
+
+=cut
+
+sub unregister {
+ delete $CIPHERS{$_} for @_;
+}
+
+BEGIN {
+ __PACKAGE__->register(CIPHER_UUID_AES128, 'CBC', algorithm => 'AES', key_size => 16);
+ __PACKAGE__->register(CIPHER_UUID_AES256, 'CBC', algorithm => 'AES', key_size => 32);
+ __PACKAGE__->register(CIPHER_UUID_SERPENT, 'CBC', algorithm => 'Serpent', key_size => 32);
+ __PACKAGE__->register(CIPHER_UUID_TWOFISH, 'CBC', algorithm => 'Twofish', key_size => 32);
+ __PACKAGE__->register(CIPHER_UUID_CHACHA20, 'Stream', algorithm => 'ChaCha');
+ __PACKAGE__->register(CIPHER_UUID_SALSA20, 'Stream', algorithm => 'Salsa20');
+ __PACKAGE__->register(STREAM_ID_CHACHA20, 'Stream', algorithm => 'ChaCha');
+ __PACKAGE__->register(STREAM_ID_SALSA20, 'Stream', algorithm => 'Salsa20');
+}
+
+1;
+__END__
+
+=head1 SYNOPSIS
+
+ use File::KDBX::Cipher;
+
+ my $cipher = File::KDBX::Cipher->new(uuid => $uuid, key => $key, iv => $iv);
+
+ my $ciphertext = $cipher->encrypt('data');
+ $ciphertext .= $cipher->encrypt('more data');
+ $ciphertext .= $cipher->finish;
+
+ my $plaintext = $cipher->decrypt('data');
+ $plaintext .= $cipher->decrypt('more data');
+ $plaintext .= $cipher->finish;
+
+=head1 DESCRIPTION
+
+A cipher is used to encrypt and decrypt KDBX files. The L<File::KDBX> distribution comes with several
+pre-registered ciphers ready to go:
+
+=for :list
+* C<61AB05A1-9464-41C3-8D74-3A563DF8DD35> - AES128 (legacy)
+* C<31C1F2E6-BF71-4350-BE58-05216AFC5AFF> - AES256
+* C<D6038A2B-8B6F-4CB5-A524-339A31DBB59A> - ChaCha20
+* C<716E1C8A-EE17-4BDC-93AE-A977B882833A> - Salsa20
+* C<098563FF-DDF7-4F98-8619-8079F6DB897A> - Serpent
+* C<AD68F29F-576F-4BB9-A36A-D47AF965346C> - Twofish
+
+B<NOTE:> If you want your KDBX file to be readable by other KeePass implementations, you must use a UUID and
+algorithm that they support. From the list above, AES256 and ChaCha20 are well-supported. You should avoid
+AES128 for new databases.
+
+You can also L</register> your own cipher. Here is a skeleton:
+
+ package File::KDBX::Cipher::MyCipher;
+
+ use parent 'File::KDBX::Cipher';
+
+ File::KDBX::Cipher->register(
+ # $uuid, $package, %args
+ "\x12\x34\x56\x78\x9a\xbc\xde\xfg\x12\x34\x56\x78\x9a\xbc\xde\xfg" => __PACKAGE__,
+ );
+
+ sub init { ... } # optional
+
+ sub encrypt { ... }
+ sub decrypt { ... }
+ sub finish { ... }
+
+ sub key_size { ... }
+ sub iv_size { ... }
+ sub block_size { ... }
+
+=cut
--- /dev/null
+package File::KDBX::Cipher::CBC;
+# ABSTRACT: A CBC block cipher mode encrypter/decrypter
+
+use warnings;
+use strict;
+
+use Crypt::Mode::CBC;
+use File::KDBX::Error;
+use namespace::clean;
+
+use parent 'File::KDBX::Cipher';
+
+our $VERSION = '999.999'; # VERSION
+
+sub encrypt {
+ my $self = shift;
+
+ my $mode = $self->{mode} ||= do {
+ my $m = Crypt::Mode::CBC->new($self->algorithm);
+ $m->start_encrypt($self->key, $self->iv);
+ $m;
+ };
+
+ return join('', map { $mode->add(ref $_ ? $$_ : $_) } grep { defined } @_);
+}
+
+sub decrypt {
+ my $self = shift;
+
+ my $mode = $self->{mode} ||= do {
+ my $m = Crypt::Mode::CBC->new($self->algorithm);
+ $m->start_decrypt($self->key, $self->iv);
+ $m;
+ };
+
+ return join('', map { $mode->add(ref $_ ? $$_ : $_) } grep { defined } @_);
+}
+
+sub finish {
+ my $self = shift;
+ return '' if !$self->{mode};
+ my $out = $self->{mode}->finish;
+ delete $self->{mode};
+ return $out;
+}
+
+=attr algorithm
+
+Get the symmetric cipher algorithm.
+
+=cut
+
+sub algorithm { $_[0]->{algorithm} or throw 'Block cipher algorithm is not set' }
+sub key_size { $_[0]->{key_size} // 32 }
+sub iv_size { 16 }
+sub block_size { 16 }
+
+1;
+__END__
+
+=head1 SYNOPSIS
+
+ use File::KDBX::Cipher::CBC;
+
+ my $cipher = File::KDBX::Cipher::CBC->new(algorithm => $algo, key => $key, iv => $iv);
+
+=head1 DESCRIPTION
+
+A subclass of L<File::KDBX::Cipher> for encrypting and decrypting data using the CBC block cipher mode.
+
+=cut
--- /dev/null
+package File::KDBX::Cipher::Stream;
+# ABSTRACT: A cipher stream encrypter/decrypter
+
+use warnings;
+use strict;
+
+use Crypt::Digest qw(digest_data);
+use File::KDBX::Constants qw(:cipher :random_stream);
+use File::KDBX::Error;
+use Module::Load;
+use namespace::clean;
+
+use parent 'File::KDBX::Cipher';
+
+our $VERSION = '999.999'; # VERSION
+
+sub init {
+ my $self = shift;
+ my %args = @_;
+
+ if (my $uuid = $args{uuid}) {
+ if ($uuid eq CIPHER_UUID_CHACHA20 && length($args{iv}) == 16) {
+ # extract the counter
+ my $buf = substr($self->{iv}, 0, 4, '');
+ $self->{counter} = unpack('L<', $buf);
+ }
+ elsif ($uuid eq CIPHER_UUID_SALSA20) {
+ # only need eight bytes...
+ $self->{iv} = substr($args{iv}, 8);
+ }
+ }
+ elsif (my $id = $args{stream_id}) {
+ my $key_ref = ref $args{key} ? $args{key} : \$args{key};
+ if ($id == STREAM_ID_CHACHA20) {
+ ($self->{key}, $self->{iv}) = unpack('a32 a12', digest_data('SHA512', $$key_ref));
+ }
+ elsif ($id == STREAM_ID_SALSA20) {
+ ($self->{key}, $self->{iv}) = (digest_data('SHA256', $$key_ref), STREAM_SALSA20_IV);
+ }
+ }
+
+ return $self;
+}
+
+sub crypt {
+ my $self = shift;
+ my $stream = $self->_stream;
+ return join('', map { $stream->crypt(ref $_ ? $$_ : $_) } grep { defined } @_);
+}
+
+sub keystream {
+ my $self = shift;
+ return $self->_stream->keystream(@_);
+}
+
+sub dup {
+ my $self = shift;
+ my $dup = File::KDBX::Cipher->new(
+ stream_id => $self->stream_id,
+ key => $self->key,
+ @_,
+ );
+ $dup->{key} = $self->key;
+ $dup->{iv} = $self->iv;
+ # FIXME - probably turn this into a proper clone method
+ return $dup;
+}
+
+sub _stream {
+ my $self = shift;
+
+ $self->{stream} //= do {
+ my $s = eval {
+ my $pkg = 'Crypt::Stream::'.$self->algorithm;
+ my $counter = $self->counter;
+ my $pos = 0;
+ if (defined (my $offset = $self->offset)) {
+ $counter = int($offset / 64);
+ $pos = $offset % 64;
+ }
+ my $s = $pkg->new($self->key, $self->iv, $counter);
+ # seek to correct position within block
+ $s->keystream($pos) if $pos;
+ $s;
+ };
+ if (my $err = $@) {
+ throw 'Failed to initialize stream cipher library',
+ error => $err,
+ algorithm => $self->algorithm,
+ key_length => length($self->key),
+ iv_length => length($self->iv),
+ iv => unpack('H*', $self->iv),
+ key => unpack('H*', $self->key);
+ }
+ $s;
+ };
+}
+
+sub encrypt { goto &crypt }
+sub decrypt { goto &crypt }
+
+sub finish { delete $_[0]->{stream}; '' }
+
+sub counter { $_[0]->{counter} // 0 }
+sub offset { $_[0]->{offset} }
+
+=attr algorithm
+
+Get the stream cipher algorithm. Can be one of C<Salsa20> and C<ChaCha>.
+
+=cut
+
+sub algorithm { $_[0]->{algorithm} or throw 'Stream cipher algorithm is not set' }
+sub key_size { { Salsa20 => 32, ChaCha => 32 }->{$_[0]->{algorithm} || ''} // 0 }
+sub iv_size { { Salsa20 => 8, ChaCha => 12 }->{$_[0]->{algorithm} || ''} // -1 }
+sub block_size { 1 }
+
+1;
+__END__
+
+=head1 SYNOPSIS
+
+ use File::KDBX::Cipher::Stream;
+
+ my $cipher = File::KDBX::Cipher::Stream->new(algorithm => $algorithm, key => $key, iv => $iv);
+
+=head1 DESCRIPTION
+
+A subclass of L<File::KDBX::Cipher> for encrypting and decrypting data using a stream cipher.
+
+=cut
--- /dev/null
+package File::KDBX::Constants;
+# ABSTRACT: All the KDBX-related constants you could ever want
+
+# HOW TO add new constants:
+# 1. Add it to the %CONSTANTS structure below.
+# 2. List it in the pod at the bottom of this file in the section corresponding to its tag.
+# 3. There is no step three.
+
+use warnings;
+use strict;
+
+use Exporter qw(import);
+use Scalar::Util qw(dualvar);
+use namespace::clean -except => 'import';
+
+our $VERSION = '999.999'; # VERSION
+
+BEGIN {
+ my %CONSTANTS = (
+ magic => {
+ __prefix => 'KDBX',
+ SIG1 => 0x9aa2d903,
+ SIG1_FIRST_BYTE => 0x03,
+ SIG2_1 => 0xb54bfb65,
+ SIG2_2 => 0xb54bfb67,
+ },
+ version => {
+ __prefix => 'KDBX_VERSION',
+ _2_0 => 0x00020000,
+ _3_0 => 0x00030000,
+ _3_1 => 0x00030001,
+ _4_0 => 0x00040000,
+ _4_1 => 0x00040001,
+ OLDEST => 0x00020000,
+ LATEST => 0x00040001,
+ MAJOR_MASK => 0xffff0000,
+ MINOR_MASK => 0x0000ffff,
+ },
+ header => {
+ __prefix => 'HEADER',
+ END => dualvar( 0, 'end'),
+ COMMENT => dualvar( 1, 'comment'),
+ CIPHER_ID => dualvar( 2, 'cipher_id'),
+ COMPRESSION_FLAGS => dualvar( 3, 'compression_flags'),
+ MASTER_SEED => dualvar( 4, 'master_seed'),
+ TRANSFORM_SEED => dualvar( 5, 'transform_seed'),
+ TRANSFORM_ROUNDS => dualvar( 6, 'transform_rounds'),
+ ENCRYPTION_IV => dualvar( 7, 'encryption_iv'),
+ INNER_RANDOM_STREAM_KEY => dualvar( 8, 'inner_random_stream_key'),
+ STREAM_START_BYTES => dualvar( 9, 'stream_start_bytes'),
+ INNER_RANDOM_STREAM_ID => dualvar( 10, 'inner_random_stream_id'),
+ KDF_PARAMETERS => dualvar( 11, 'kdf_parameters'),
+ PUBLIC_CUSTOM_DATA => dualvar( 12, 'public_custom_data'),
+ },
+ compression => {
+ __prefix => 'COMPRESSION',
+ NONE => dualvar( 0, 'none'),
+ GZIP => dualvar( 1, 'gzip'),
+ },
+ cipher => {
+ __prefix => 'CIPHER',
+ UUID_AES128 => "\x61\xab\x05\xa1\x94\x64\x41\xc3\x8d\x74\x3a\x56\x3d\xf8\xdd\x35",
+ UUID_AES256 => "\x31\xc1\xf2\xe6\xbf\x71\x43\x50\xbe\x58\x05\x21\x6a\xfc\x5a\xff",
+ UUID_CHACHA20 => "\xd6\x03\x8a\x2b\x8b\x6f\x4c\xb5\xa5\x24\x33\x9a\x31\xdb\xb5\x9a",
+ UUID_SALSA20 => "\x71\x6e\x1c\x8a\xee\x17\x4b\xdc\x93\xae\xa9\x77\xb8\x82\x83\x3a",
+ UUID_SERPENT => "\x09\x85\x63\xff\xdd\xf7\x4f\x98\x86\x19\x80\x79\xf6\xdb\x89\x7a",
+ UUID_TWOFISH => "\xad\x68\xf2\x9f\x57\x6f\x4b\xb9\xa3\x6a\xd4\x7a\xf9\x65\x34\x6c",
+ },
+ kdf => {
+ __prefix => 'KDF',
+ UUID_AES => "\xc9\xd9\xf3\x9a\x62\x8a\x44\x60\xbf\x74\x0d\x08\xc1\x8a\x4f\xea",
+ UUID_AES_CHALLENGE_RESPONSE => "\x7c\x02\xbb\x82\x79\xa7\x4a\xc0\x92\x7d\x11\x4a\x00\x64\x82\x38",
+ UUID_ARGON2D => "\xef\x63\x6d\xdf\x8c\x29\x44\x4b\x91\xf7\xa9\xa4\x03\xe3\x0a\x0c",
+ UUID_ARGON2ID => "\x9e\x29\x8b\x19\x56\xdb\x47\x73\xb2\x3d\xfc\x3e\xc6\xf0\xa1\xe6",
+ PARAM_UUID => '$UUID',
+ PARAM_AES_ROUNDS => 'R',
+ PARAM_AES_SEED => 'S',
+ PARAM_ARGON2_SALT => 'S',
+ PARAM_ARGON2_PARALLELISM => 'P',
+ PARAM_ARGON2_MEMORY => 'M',
+ PARAM_ARGON2_ITERATIONS => 'I',
+ PARAM_ARGON2_VERSION => 'V',
+ PARAM_ARGON2_SECRET => 'K',
+ PARAM_ARGON2_ASSOCDATA => 'A',
+ DEFAULT_AES_ROUNDS => 100_000,
+ DEFAULT_ARGON2_ITERATIONS => 10,
+ DEFAULT_ARGON2_MEMORY => 1 << 16,
+ DEFAULT_ARGON2_PARALLELISM => 2,
+ DEFAULT_ARGON2_VERSION => 0x13,
+ },
+ random_stream => {
+ __prefix => 'STREAM',
+ ID_RC4_VARIANT => 1,
+ ID_SALSA20 => 2,
+ ID_CHACHA20 => 3,
+ SALSA20_IV => "\xe8\x30\x09\x4b\x97\x20\x5d\x2a",
+
+ },
+ variant_map => {
+ __prefix => 'VMAP',
+ VERSION => 0x0100,
+ VERSION_MAJOR_MASK => 0xff00,
+ TYPE_END => 0x00,
+ TYPE_UINT32 => 0x04,
+ TYPE_UINT64 => 0x05,
+ TYPE_BOOL => 0x08,
+ TYPE_INT32 => 0x0C,
+ TYPE_INT64 => 0x0D,
+ TYPE_STRING => 0x18,
+ TYPE_BYTEARRAY => 0x42,
+ },
+ inner_header => {
+ __prefix => 'INNER_HEADER',
+ END => dualvar( 0, 'end'),
+ INNER_RANDOM_STREAM_ID => dualvar( 1, 'inner_random_stream_id'),
+ INNER_RANDOM_STREAM_KEY => dualvar( 2, 'inner_random_stream_key'),
+ BINARY => dualvar( 3, 'binary'),
+ BINARY_FLAG_PROTECT => 1,
+ },
+ key_file => {
+ __prefix => 'KEY_FILE',
+ TYPE_BINARY => dualvar( 1, 'binary'),
+ TYPE_HASHED => dualvar( 3, 'hashed'),
+ TYPE_HEX => dualvar( 2, 'hex'),
+ TYPE_XML => dualvar( 4, 'xml'),
+ },
+ history => {
+ __prefix => 'HISTORY',
+ DEFAULT_MAX_ITEMS => 10,
+ DEFAULT_MAX_SIZE => 6_291_456, # 6 M
+ },
+ icon => {
+ __prefix => 'ICON',
+ PASSWORD => dualvar( 0, 'Password'),
+ PACKAGE_NETWORK => dualvar( 1, 'Package_Network'),
+ MESSAGEBOX_WARNING => dualvar( 2, 'MessageBox_Warning'),
+ SERVER => dualvar( 3, 'Server'),
+ KLIPPER => dualvar( 4, 'Klipper'),
+ EDU_LANGUAGES => dualvar( 5, 'Edu_Languages'),
+ KCMDF => dualvar( 6, 'KCMDF'),
+ KATE => dualvar( 7, 'Kate'),
+ SOCKET => dualvar( 8, 'Socket'),
+ IDENTITY => dualvar( 9, 'Identity'),
+ KONTACT => dualvar( 10, 'Kontact'),
+ CAMERA => dualvar( 11, 'Camera'),
+ IRKICKFLASH => dualvar( 12, 'IRKickFlash'),
+ KGPG_KEY3 => dualvar( 13, 'KGPG_Key3'),
+ LAPTOP_POWER => dualvar( 14, 'Laptop_Power'),
+ SCANNER => dualvar( 15, 'Scanner'),
+ MOZILLA_FIREBIRD => dualvar( 16, 'Mozilla_Firebird'),
+ CDROM_UNMOUNT => dualvar( 17, 'CDROM_Unmount'),
+ DISPLAY => dualvar( 18, 'Display'),
+ MAIL_GENERIC => dualvar( 19, 'Mail_Generic'),
+ MISC => dualvar( 20, 'Misc'),
+ KORGANIZER => dualvar( 21, 'KOrganizer'),
+ ASCII => dualvar( 22, 'ASCII'),
+ ICONS => dualvar( 23, 'Icons'),
+ CONNECT_ESTABLISHED => dualvar( 24, 'Connect_Established'),
+ FOLDER_MAIL => dualvar( 25, 'Folder_Mail'),
+ FILESAVE => dualvar( 26, 'FileSave'),
+ NFS_UNMOUNT => dualvar( 27, 'NFS_Unmount'),
+ MESSAGE => dualvar( 28, 'Message'),
+ KGPG_TERM => dualvar( 29, 'KGPG_Term'),
+ KONSOLE => dualvar( 30, 'Konsole'),
+ FILEPRINT => dualvar( 31, 'FilePrint'),
+ FSVIEW => dualvar( 32, 'FSView'),
+ RUN => dualvar( 33, 'Run'),
+ CONFIGURE => dualvar( 34, 'Configure'),
+ KRFB => dualvar( 35, 'KRFB'),
+ ARK => dualvar( 36, 'Ark'),
+ KPERCENTAGE => dualvar( 37, 'KPercentage'),
+ SAMBA_UNMOUNT => dualvar( 38, 'Samba_Unmount'),
+ HISTORY => dualvar( 39, 'History'),
+ MAIL_FIND => dualvar( 40, 'Mail_Find'),
+ VECTORGFX => dualvar( 41, 'VectorGfx'),
+ KCMMEMORY => dualvar( 42, 'KCMMemory'),
+ TRASHCAN_FULL => dualvar( 43, 'Trashcan_Full'),
+ KNOTES => dualvar( 44, 'KNotes'),
+ CANCEL => dualvar( 45, 'Cancel'),
+ HELP => dualvar( 46, 'Help'),
+ KPACKAGE => dualvar( 47, 'KPackage'),
+ FOLDER => dualvar( 48, 'Folder'),
+ FOLDER_BLUE_OPEN => dualvar( 49, 'Folder_Blue_Open'),
+ FOLDER_TAR => dualvar( 50, 'Folder_Tar'),
+ DECRYPTED => dualvar( 51, 'Decrypted'),
+ ENCRYPTED => dualvar( 52, 'Encrypted'),
+ APPLY => dualvar( 53, 'Apply'),
+ SIGNATURE => dualvar( 54, 'Signature'),
+ THUMBNAIL => dualvar( 55, 'Thumbnail'),
+ KADDRESSBOOK => dualvar( 56, 'KAddressBook'),
+ VIEW_TEXT => dualvar( 57, 'View_Text'),
+ KGPG => dualvar( 58, 'KGPG'),
+ PACKAGE_DEVELOPMENT => dualvar( 59, 'Package_Development'),
+ KFM_HOME => dualvar( 60, 'KFM_Home'),
+ SERVICES => dualvar( 61, 'Services'),
+ TUX => dualvar( 62, 'Tux'),
+ FEATHER => dualvar( 63, 'Feather'),
+ APPLE => dualvar( 64, 'Apple'),
+ W => dualvar( 65, 'W'),
+ MONEY => dualvar( 66, 'Money'),
+ CERTIFICATE => dualvar( 67, 'Certificate'),
+ SMARTPHONE => dualvar( 68, 'Smartphone'),
+ },
+ time => {
+ __prefix => 'TIME',
+ SECONDS_AD1_TO_UNIX_EPOCH => 62_135_596_800,
+ },
+ yubikey => {
+ YUBICO_VID => dualvar( 0x1050, 'Yubico'),
+ YUBIKEY_PID => dualvar( 0x0010, 'YubiKey 1/2'),
+ NEO_OTP_PID => dualvar( 0x0110, 'YubiKey NEO OTP'),
+ NEO_OTP_CCID_PID => dualvar( 0x0111, 'YubiKey NEO OTP+CCID'),
+ NEO_CCID_PID => dualvar( 0x0112, 'YubiKey NEO CCID'),
+ NEO_U2F_PID => dualvar( 0x0113, 'YubiKey NEO FIDO'),
+ NEO_OTP_U2F_PID => dualvar( 0x0114, 'YubiKey NEO OTP+FIDO'),
+ NEO_U2F_CCID_PID => dualvar( 0x0115, 'YubiKey NEO FIDO+CCID'),
+ NEO_OTP_U2F_CCID_PID => dualvar( 0x0116, 'YubiKey NEO OTP+FIDO+CCID'),
+ YK4_OTP_PID => dualvar( 0x0401, 'YubiKey 4/5 OTP'),
+ YK4_U2F_PID => dualvar( 0x0402, 'YubiKey 4/5 FIDO'),
+ YK4_OTP_U2F_PID => dualvar( 0x0403, 'YubiKey 4/5 OTP+FIDO'),
+ YK4_CCID_PID => dualvar( 0x0404, 'YubiKey 4/5 CCID'),
+ YK4_OTP_CCID_PID => dualvar( 0x0405, 'YubiKey 4/5 OTP+CCID'),
+ YK4_U2F_CCID_PID => dualvar( 0x0406, 'YubiKey 4/5 FIDO+CCID'),
+ YK4_OTP_U2F_CCID_PID => dualvar( 0x0407, 'YubiKey 4/5 OTP+FIDO+CCID'),
+ PLUS_U2F_OTP_PID => dualvar( 0x0410, 'YubiKey Plus OTP+FIDO'),
+
+ ONLYKEY_VID => dualvar( 0x1d50, 'OnlyKey'),
+ ONLYKEY_PID => dualvar( 0x60fc, 'OnlyKey'),
+
+ YK_EUSBERR => dualvar( 0x01, 'USB error'),
+ YK_EWRONGSIZ => dualvar( 0x02, 'wrong size'),
+ YK_EWRITEERR => dualvar( 0x03, 'write error'),
+ YK_ETIMEOUT => dualvar( 0x04, 'timeout'),
+ YK_ENOKEY => dualvar( 0x05, 'no yubikey present'),
+ YK_EFIRMWARE => dualvar( 0x06, 'unsupported firmware version'),
+ YK_ENOMEM => dualvar( 0x07, 'out of memory'),
+ YK_ENOSTATUS => dualvar( 0x08, 'no status structure given'),
+ YK_ENOTYETIMPL => dualvar( 0x09, 'not yet implemented'),
+ YK_ECHECKSUM => dualvar( 0x0a, 'checksum mismatch'),
+ YK_EWOULDBLOCK => dualvar( 0x0b, 'operation would block'),
+ YK_EINVALIDCMD => dualvar( 0x0c, 'invalid command for operation'),
+ YK_EMORETHANONE => dualvar( 0x0d, 'expected only one YubiKey but serveral present'),
+ YK_ENODATA => dualvar( 0x0e, 'no data returned from device'),
+
+ CONFIG1_VALID => 0x01,
+ CONFIG2_VALID => 0x02,
+ CONFIG1_TOUCH => 0x04,
+ CONFIG2_TOUCH => 0x08,
+ CONFIG_LED_INV => 0x10,
+ CONFIG_STATUS_MASK => 0x1f,
+ },
+ );
+
+ our %EXPORT_TAGS;
+ my %seen;
+ no strict 'refs'; ## no critic (ProhibitNoStrict)
+ while (my ($tag, $constants) = each %CONSTANTS) {
+ my $prefix = delete $constants->{__prefix};
+ while (my ($name, $value) = each %$constants) {
+ my $val = $value;
+ $val = $val+0 if $tag eq 'icon'; # TODO
+ $name =~ s/^_+//;
+ my $full_name = $prefix ? "${prefix}_${name}" : $name;
+ die "Duplicate constant: $full_name\n" if $seen{$full_name};
+ *{$full_name} = sub() { $value };
+ push @{$EXPORT_TAGS{$tag} //= []}, $full_name;
+ $seen{$full_name}++;
+ }
+ }
+}
+
+our %EXPORT_TAGS;
+push @{$EXPORT_TAGS{header}}, 'KDBX_HEADER';
+push @{$EXPORT_TAGS{inner_header}}, 'KDBX_INNER_HEADER';
+
+$EXPORT_TAGS{all} = [map { @$_ } values %EXPORT_TAGS];
+our @EXPORT_OK = sort @{$EXPORT_TAGS{all}};
+
+my %HEADER;
+for my $header (
+ HEADER_END, HEADER_COMMENT, HEADER_CIPHER_ID, HEADER_COMPRESSION_FLAGS,
+ HEADER_MASTER_SEED, HEADER_TRANSFORM_SEED, HEADER_TRANSFORM_ROUNDS,
+ HEADER_ENCRYPTION_IV, HEADER_INNER_RANDOM_STREAM_KEY, HEADER_STREAM_START_BYTES,
+ HEADER_INNER_RANDOM_STREAM_ID, HEADER_KDF_PARAMETERS, HEADER_PUBLIC_CUSTOM_DATA,
+) {
+ $HEADER{$header} = $HEADER{0+$header} = $header;
+}
+sub KDBX_HEADER { $HEADER{$_[0]} }
+
+
+my %INNER_HEADER;
+for my $inner_header (
+ INNER_HEADER_END, INNER_HEADER_INNER_RANDOM_STREAM_ID,
+ INNER_HEADER_INNER_RANDOM_STREAM_KEY, INNER_HEADER_BINARY,
+) {
+ $INNER_HEADER{$inner_header} = $INNER_HEADER{0+$inner_header} = $inner_header;
+}
+sub KDBX_INNER_HEADER { $INNER_HEADER{$_[0]} }
+
+1;
+__END__
+
+=head1 SYNOPSIS
+
+ use File::KDBX::Constants qw(:all);
+
+ say KDBX_VERSION_4_1;
+
+=head1 DESCRIPTION
+
+This module provides importable constants related to KDBX. Constants can be imported individually or in groups
+(by tag). The available tags are:
+
+=for :list
+* L</:magic>
+* L</:version>
+* L</:header>
+* L</:compression>
+* L</:cipher>
+* L</:random_stream>
+* L</:kdf>
+* L</:variant_map>
+* L</:inner_header>
+* L</:key_file>
+* L</:history>
+* L</:icon>
+* L</:time>
+* L</:yubikey>
+* C<:all> - All of the above
+
+View the source of this module to see the constant values (but really you shouldn't care).
+
+=head1 CONSTANTS
+
+=head2 :magic
+
+Constants related to identifying the file types:
+
+=for :list
+= C<KDBX_SIG1>
+= C<KDBX_SIG1_FIRST_BYTE>
+= C<KDBX_SIG2_1>
+= C<KDBX_SIG2_2>
+
+=head2 :version
+
+Constants related to identifying the format version of a file:
+
+=for :list
+= C<KDBX_VERSION_2_0>
+= C<KDBX_VERSION_3_0>
+= C<KDBX_VERSION_3_1>
+= C<KDBX_VERSION_4_0>
+= C<KDBX_VERSION_4_1>
+= C<KDBX_VERSION_OLDEST>
+= C<KDBX_VERSION_LATEST>
+= C<KDBX_VERSION_MAJOR_MASK>
+= C<KDBX_VERSION_MINOR_MASK>
+
+=head2 :header
+
+Constants related to parsing and generating KDBX file headers:
+
+=for :list
+= C<HEADER_END>
+= C<HEADER_COMMENT>
+= C<HEADER_CIPHER_ID>
+= C<HEADER_COMPRESSION_FLAGS>
+= C<HEADER_MASTER_SEED>
+= C<HEADER_TRANSFORM_SEED>
+= C<HEADER_TRANSFORM_ROUNDS>
+= C<HEADER_ENCRYPTION_IV>
+= C<HEADER_INNER_RANDOM_STREAM_KEY>
+= C<HEADER_STREAM_START_BYTES>
+= C<HEADER_INNER_RANDOM_STREAM_ID>
+= C<HEADER_KDF_PARAMETERS>
+= C<HEADER_PUBLIC_CUSTOM_DATA>
+= C<KDBX_HEADER>
+
+=head2 :compression
+
+Constants related to identifying the compression state of a file:
+
+=for :list
+= C<COMPRESSION_NONE>
+= C<COMPRESSION_GZIP>
+
+=head2 :cipher
+
+Constants related ciphers:
+
+=for :list
+= C<CIPHER_UUID_AES128>
+= C<CIPHER_UUID_AES256>
+= C<CIPHER_UUID_CHACHA20>
+= C<CIPHER_UUID_SALSA20>
+= C<CIPHER_UUID_SERPENT>
+= C<CIPHER_UUID_TWOFISH>
+
+=head2 :random_stream
+
+Constants related to memory protection stream ciphers:
+
+=for :list
+= C<STREAM_ID_RC4_VARIANT>
+This is insecure and not implemented.
+= C<STREAM_ID_SALSA20>
+= C<STREAM_ID_CHACHA20>
+= C<STREAM_SALSA20_IV>
+
+=head2 :kdf
+
+Constants related to key derivation functions and configuration:
+
+=for :list
+= C<KDF_UUID_AES>
+= C<KDF_UUID_AES_CHALLENGE_RESPONSE>
+This is what KeePassXC calls C<KDF_AES_KDBX4>.
+= C<KDF_UUID_ARGON2D>
+= C<KDF_UUID_ARGON2ID>
+= C<KDF_PARAM_UUID>
+= C<KDF_PARAM_AES_ROUNDS>
+= C<KDF_PARAM_AES_SEED>
+= C<KDF_PARAM_ARGON2_SALT>
+= C<KDF_PARAM_ARGON2_PARALLELISM>
+= C<KDF_PARAM_ARGON2_MEMORY>
+= C<KDF_PARAM_ARGON2_ITERATIONS>
+= C<KDF_PARAM_ARGON2_VERSION>
+= C<KDF_PARAM_ARGON2_SECRET>
+= C<KDF_PARAM_ARGON2_ASSOCDATA>
+= C<KDF_DEFAULT_AES_ROUNDS>
+= C<KDF_DEFAULT_ARGON2_ITERATIONS>
+= C<KDF_DEFAULT_ARGON2_MEMORY>
+= C<KDF_DEFAULT_ARGON2_PARALLELISM>
+= C<KDF_DEFAULT_ARGON2_VERSION>
+
+=head2 :variant_map
+
+Constants related to parsing and generating KDBX4 variant maps:
+
+=for :list
+= C<VMAP_VERSION>
+= C<VMAP_VERSION_MAJOR_MASK>
+= C<VMAP_TYPE_END>
+= C<VMAP_TYPE_UINT32>
+= C<VMAP_TYPE_UINT64>
+= C<VMAP_TYPE_BOOL>
+= C<VMAP_TYPE_INT32>
+= C<VMAP_TYPE_INT64>
+= C<VMAP_TYPE_STRING>
+= C<VMAP_TYPE_BYTEARRAY>
+
+=head2 :inner_header
+
+Constants related to parsing and generating KDBX4 inner headers:
+
+=for :list
+= C<INNER_HEADER_END>
+= C<INNER_HEADER_INNER_RANDOM_STREAM_ID>
+= C<INNER_HEADER_INNER_RANDOM_STREAM_KEY>
+= C<INNER_HEADER_BINARY>
+= C<INNER_HEADER_BINARY_FLAG_PROTECT>
+= C<KDBX_INNER_HEADER>
+
+=head2 :key_file
+
+Constants related to identifying key file types:
+
+=for :list
+= C<KEY_FILE_TYPE_BINARY>
+= C<KEY_FILE_TYPE_HASHED>
+= C<KEY_FILE_TYPE_HEX>
+= C<KEY_FILE_TYPE_XML>
+
+=head2 :history
+
+Constants for history-related default values:
+
+=for :list
+= C<HISTORY_DEFAULT_MAX_ITEMS>
+= C<HISTORY_DEFAULT_MAX_SIZE>
+
+=head2 :icon
+
+Constants for default icons used by KeePass password safe implementations:
+
+=for :list
+= C<ICON_PASSWORD>
+= C<ICON_PACKAGE_NETWORK>
+= C<ICON_MESSAGEBOX_WARNING>
+= C<ICON_SERVER>
+= C<ICON_KLIPPER>
+= C<ICON_EDU_LANGUAGES>
+= C<ICON_KCMDF>
+= C<ICON_KATE>
+= C<ICON_SOCKET>
+= C<ICON_IDENTITY>
+= C<ICON_KONTACT>
+= C<ICON_CAMERA>
+= C<ICON_IRKICKFLASH>
+= C<ICON_KGPG_KEY3>
+= C<ICON_LAPTOP_POWER>
+= C<ICON_SCANNER>
+= C<ICON_MOZILLA_FIREBIRD>
+= C<ICON_CDROM_UNMOUNT>
+= C<ICON_DISPLAY>
+= C<ICON_MAIL_GENERIC>
+= C<ICON_MISC>
+= C<ICON_KORGANIZER>
+= C<ICON_ASCII>
+= C<ICON_ICONS>
+= C<ICON_CONNECT_ESTABLISHED>
+= C<ICON_FOLDER_MAIL>
+= C<ICON_FILESAVE>
+= C<ICON_NFS_UNMOUNT>
+= C<ICON_MESSAGE>
+= C<ICON_KGPG_TERM>
+= C<ICON_KONSOLE>
+= C<ICON_FILEPRINT>
+= C<ICON_FSVIEW>
+= C<ICON_RUN>
+= C<ICON_CONFIGURE>
+= C<ICON_KRFB>
+= C<ICON_ARK>
+= C<ICON_KPERCENTAGE>
+= C<ICON_SAMBA_UNMOUNT>
+= C<ICON_HISTORY>
+= C<ICON_MAIL_FIND>
+= C<ICON_VECTORGFX>
+= C<ICON_KCMMEMORY>
+= C<ICON_TRASHCAN_FULL>
+= C<ICON_KNOTES>
+= C<ICON_CANCEL>
+= C<ICON_HELP>
+= C<ICON_KPACKAGE>
+= C<ICON_FOLDER>
+= C<ICON_FOLDER_BLUE_OPEN>
+= C<ICON_FOLDER_TAR>
+= C<ICON_DECRYPTED>
+= C<ICON_ENCRYPTED>
+= C<ICON_APPLY>
+= C<ICON_SIGNATURE>
+= C<ICON_THUMBNAIL>
+= C<ICON_KADDRESSBOOK>
+= C<ICON_VIEW_TEXT>
+= C<ICON_KGPG>
+= C<ICON_PACKAGE_DEVELOPMENT>
+= C<ICON_KFM_HOME>
+= C<ICON_SERVICES>
+= C<ICON_TUX>
+= C<ICON_FEATHER>
+= C<ICON_APPLE>
+= C<ICON_W>
+= C<ICON_MONEY>
+= C<ICON_CERTIFICATE>
+= C<ICON_SMARTPHONE>
+
+=head2 :time
+
+Constants related to time:
+
+=for :list
+= C<TIME_SECONDS_AD1_TO_UNIX_EPOCH>
+
+=head2 :yubikey
+
+Constants related to working with YubiKeys:
+
+=for :list
+= C<YUBICO_VID>
+= C<YUBIKEY_PID>
+= C<NEO_OTP_PID>
+= C<NEO_OTP_CCID_PID>
+= C<NEO_CCID_PID>
+= C<NEO_U2F_PID>
+= C<NEO_OTP_U2F_PID>
+= C<NEO_U2F_CCID_PID>
+= C<NEO_OTP_U2F_CCID_PID>
+= C<YK4_OTP_PID>
+= C<YK4_U2F_PID>
+= C<YK4_OTP_U2F_PID>
+= C<YK4_CCID_PID>
+= C<YK4_OTP_CCID_PID>
+= C<YK4_U2F_CCID_PID>
+= C<YK4_OTP_U2F_CCID_PID>
+= C<PLUS_U2F_OTP_PID>
+= C<ONLYKEY_VID>
+= C<ONLYKEY_PID>
+= C<YK_EUSBERR>
+= C<YK_EWRONGSIZ>
+= C<YK_EWRITEERR>
+= C<YK_ETIMEOUT>
+= C<YK_ENOKEY>
+= C<YK_EFIRMWARE>
+= C<YK_ENOMEM>
+= C<YK_ENOSTATUS>
+= C<YK_ENOTYETIMPL>
+= C<YK_ECHECKSUM>
+= C<YK_EWOULDBLOCK>
+= C<YK_EINVALIDCMD>
+= C<YK_EMORETHANONE>
+= C<YK_ENODATA>
+= C<CONFIG1_VALID>
+= C<CONFIG2_VALID>
+= C<CONFIG1_TOUCH>
+= C<CONFIG2_TOUCH>
+= C<CONFIG_LED_INV>
+= C<CONFIG_STATUS_MASK>
+
+=cut
--- /dev/null
+package File::KDBX::Dumper;
+# ABSTRACT: Write KDBX files
+
+use warnings;
+use strict;
+
+use Crypt::Digest qw(digest_data);
+use File::KDBX::Constants qw(:magic :header :version :random_stream);
+use File::KDBX::Error;
+use File::KDBX;
+use IO::Handle;
+use Module::Load;
+use Ref::Util qw(is_ref is_scalarref);
+use Scalar::Util qw(looks_like_number openhandle);
+use namespace::clean;
+
+our $VERSION = '999.999'; # VERSION
+
+=method new
+
+ $dumper = File::KDBX::Dumper->new(%attributes);
+
+Construct a new L<File::KDBX::Dumper>.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my $self = bless {}, $class;
+ $self->init(@_);
+}
+
+=method init
+
+ $dumper = $dumper->init(%attributes);
+
+Initialize a L<File::KDBX::Dumper> with a new set of attributes.
+
+This is called by L</new>.
+
+=cut
+
+sub init {
+ my $self = shift;
+ my %args = @_;
+
+ @$self{keys %args} = values %args;
+
+ return $self;
+}
+
+sub _rebless {
+ my $self = shift;
+ my $format = shift // $self->format;
+
+ my $version = $self->kdbx->version;
+
+ my $subclass;
+
+ if (defined $format) {
+ $subclass = $format;
+ }
+ elsif (!defined $version) {
+ $subclass = 'XML';
+ }
+ elsif ($self->kdbx->sig2 == KDBX_SIG2_1) {
+ $subclass = 'KDB';
+ }
+ elsif (looks_like_number($version)) {
+ my $major = $version & KDBX_VERSION_MAJOR_MASK;
+ my %subclasses = (
+ KDBX_VERSION_2_0() => 'V3',
+ KDBX_VERSION_3_0() => 'V3',
+ KDBX_VERSION_4_0() => 'V4',
+ );
+ if ($major == KDBX_VERSION_2_0) {
+ alert sprintf("Upgrading KDBX version %x to version %x\n", $version, KDBX_VERSION_3_1);
+ $self->kdbx->version(KDBX_VERSION_3_1);
+ }
+ $subclass = $subclasses{$major}
+ or throw sprintf('Unsupported KDBX file version: %x', $version), version => $version;
+ }
+ else {
+ throw sprintf('Unknown file version: %s', $version), version => $version;
+ }
+
+ load "File::KDBX::Dumper::$subclass";
+ bless $self, "File::KDBX::Dumper::$subclass";
+}
+
+=method reset
+
+ $dumper = $dumper->reset;
+
+Set a L<File::KDBX::Dumper> to a blank state, ready to dumper another KDBX file.
+
+=cut
+
+sub reset {
+ my $self = shift;
+ %$self = ();
+ return $self;
+}
+
+=method dump
+
+ $dumper->dump(\$string, $key);
+ $dumper->dump(*IO, $key);
+ $dumper->dump($filepath, $key);
+
+Dump a KDBX file.
+
+The C<$key> is either a L<File::KDBX::Key> or a primitive that can be converted to a Key object.
+
+=cut
+
+sub dump {
+ my $self = shift;
+ my $dst = shift;
+ return $self->dump_handle($dst, @_) if openhandle($dst);
+ return $self->dump_string($dst, @_) if is_scalarref($dst);
+ return $self->dump_file($dst, @_) if defined $dst && !is_ref($dst);
+ throw 'Programmer error: Must pass a stringref, filepath or IO handle to dump';
+}
+
+=method dump_string
+
+ $dumper->dump_string(\$string, $key);
+ \$string = $dumper->dump_string($key);
+
+Dump a KDBX file to a string / memory buffer.
+
+=cut
+
+sub dump_string {
+ my $self = shift;
+ my $ref = is_scalarref($_[0]) ? shift : undef;
+ my %args = @_ % 2 == 0 ? @_ : (key => shift, @_);
+
+ my $key = delete $args{key};
+ $args{kdbx} //= $self->kdbx;
+
+ $ref //= do {
+ my $buf = '';
+ \$buf;
+ };
+
+ open(my $fh, '>', $ref) or throw "Failed to open string buffer: $!";
+
+ $self = $self->new if !ref $self;
+ $self->init(%args, fh => $fh)->_dump($fh, $key);
+
+ return $ref;
+}
+
+=method dump_file
+
+ $dumper->dump_file($filepath, $key);
+
+Dump a KDBX file to a filesystem.
+
+=cut
+
+sub dump_file {
+ my $self = shift;
+ my $filepath = shift;
+ my %args = @_ % 2 == 0 ? @_ : (key => shift, @_);
+
+ my $key = delete $args{key};
+ $args{kdbx} //= $self->kdbx;
+
+ # require File::Temp;
+ # # my ($fh, $filepath_temp) = eval { File::Temp::tempfile("${filepath}-XXXXXX", CLEANUP => 1) };
+ # my $fh = eval { File::Temp->new(TEMPLATE => "${filepath}-XXXXXX", CLEANUP => 1) };
+ # my $filepath_temp = $fh->filename;
+ # if (!$fh or my $err = $@) {
+ # $err //= 'Unknown error';
+ # throw sprintf('Open file failed (%s): %s', $filepath_temp, $err),
+ # error => $err,
+ # filepath => $filepath_temp;
+ # }
+ open(my $fh, '>:raw', $filepath) or die "open failed ($filepath): $!";
+ binmode($fh);
+ # $fh->autoflush(1);
+
+ $self = $self->new if !ref $self;
+ $self->init(%args, fh => $fh, filepath => $filepath);
+ # binmode($fh);
+ $self->_dump($fh, $key);
+
+ # binmode($fh, ':raw');
+ # close($fh);
+
+ # my ($file_mode, $file_uid, $file_gid) = (stat($filepath))[2, 4, 5];
+
+ # my $mode = $args{mode} // $file_mode // do { my $m = umask; defined $m ? oct(666) &~ $m : undef };
+ # my $uid = $args{uid} // $file_uid // -1;
+ # my $gid = $args{gid} // $file_gid // -1;
+ # chmod($mode, $filepath_temp) if defined $mode;
+ # chown($uid, $gid, $filepath_temp);
+ # rename($filepath_temp, $filepath) or throw "Failed to write file ($filepath): $!", filepath => $filepath;
+
+ return $self;
+}
+
+=method dump_handle
+
+ $dumper->dump_handle($fh, $key);
+ $dumper->dump_handle(*IO, $key);
+
+Dump a KDBX file to an input stream / file handle.
+
+=cut
+
+sub dump_handle {
+ my $self = shift;
+ my $fh = shift;
+ my %args = @_ % 2 == 0 ? @_ : (key => shift, @_);
+
+ $fh = *STDOUT if $fh eq '-';
+
+ my $key = delete $args{key};
+ $args{kdbx} //= $self->kdbx;
+
+ $self = $self->new if !ref $self;
+ $self->init(%args, fh => $fh)->_dump($fh, $key);
+}
+
+=attr kdbx
+
+ $kdbx = $dumper->kdbx;
+ $dumper->kdbx($kdbx);
+
+Get or set the L<File::KDBX> instance with the data to be dumped.
+
+=cut
+
+sub kdbx {
+ my $self = shift;
+ return File::KDBX->new if !ref $self;
+ $self->{kdbx} = shift if @_;
+ $self->{kdbx} //= File::KDBX->new;
+}
+
+=attr format
+
+=cut
+
+sub format { $_[0]->{format} }
+sub inner_format { $_[0]->{inner_format} // 'XML' }
+
+=attr min_version
+
+ $min_version = File::KDBX::Dumper->min_version;
+
+Get the minimum KDBX file version supported, which is 3.0 or C<0x00030000> as
+it is encoded.
+
+To generate older KDBX files unsupported by this module, try L<File::KeePass>.
+
+=cut
+
+sub min_version { KDBX_VERSION_OLDEST }
+
+sub upgrade { $_[0]->{upgrade} // 1 }
+
+sub randomize_seeds { $_[0]->{randomize_seeds} // 1 }
+
+sub _fh { $_[0]->{fh} or throw 'IO handle not set' }
+
+sub _dump {
+ my $self = shift;
+ my $fh = shift;
+ my $key = shift;
+
+ my $kdbx = $self->kdbx;
+
+ my $min_version = $kdbx->minimum_version;
+ if ($kdbx->version < $min_version && $self->upgrade) {
+ alert sprintf("Implicitly upgrading database from %x to %x\n", $kdbx->version, $min_version),
+ version => $kdbx->version, min_version => $min_version;
+ $kdbx->version($min_version);
+ }
+ $self->_rebless;
+
+ if (ref($self) =~ /::(?:KDB|V[34])$/) {
+ $key //= $kdbx->key ? $kdbx->key->reload : undef;
+ defined $key or throw 'Must provide a master key', type => 'key.missing';
+ }
+
+ $self->_prepare;
+
+ my $magic = $self->_write_magic_numbers($fh);
+ my $headers = $self->_write_headers($fh);
+
+ $kdbx->unlock;
+
+ $self->_write_body($fh, $key, "$magic$headers");
+
+ return $kdbx;
+}
+
+sub _prepare {
+ my $self = shift;
+ my $kdbx = $self->kdbx;
+
+ if ($kdbx->version < KDBX_VERSION_4_0) {
+ # force Salsa20 inner random stream
+ $kdbx->inner_random_stream_id(STREAM_ID_SALSA20);
+ my $key = $kdbx->inner_random_stream_key;
+ substr($key, 32) = '';
+ $kdbx->inner_random_stream_key($key);
+ }
+
+ $kdbx->randomize_seeds if $self->randomize_seeds;
+}
+
+sub _write_magic_numbers {
+ my $self = shift;
+ my $fh = shift;
+
+ my $kdbx = $self->kdbx;
+
+ $kdbx->sig1 == KDBX_SIG1 or throw 'Invalid file signature', sig1 => $kdbx->sig1;
+ $kdbx->version < $self->min_version || KDBX_VERSION_LATEST < $kdbx->version
+ and throw 'Unsupported file version', version => $kdbx->version;
+
+ my @magic = ($kdbx->sig1, $kdbx->sig2, $kdbx->version);
+
+ my $buf = pack('L<3', @magic);
+ $fh->print($buf) or throw 'Failed to write file signature';
+
+ return $buf;
+}
+
+sub _write_headers { die "Not implemented" }
+
+sub _write_body { die "Not implemented" }
+
+sub _write_inner_body {
+ my $self = shift;
+
+ my $current_pkg = ref $self;
+ require Scope::Guard;
+ my $guard = Scope::Guard->new(sub { bless $self, $current_pkg });
+
+ $self->_rebless($self->inner_format);
+ $self->_write_inner_body(@_);
+}
+
+1;
--- /dev/null
+package File::KDBX::Dumper::KDB;
+# ABSTRACT: Write KDB files
+
+use warnings;
+use strict;
+
+use Crypt::PRNG qw(irand);
+use Encode qw(encode);
+use File::KDBX::Constants qw(:magic);
+use File::KDBX::Error;
+use File::KDBX::Loader::KDB;
+use File::KDBX::Util qw(:uuid load_optional);
+use namespace::clean;
+
+use parent 'File::KDBX::Dumper';
+
+our $VERSION = '999.999'; # VERSION
+
+sub _write_magic_numbers { '' }
+sub _write_headers { '' }
+
+sub _write_body {
+ my $self = shift;
+ my $fh = shift;
+ my $key = shift;
+
+ load_optional(qw{File::KeePass File::KeePass::KDBX});
+
+ my $k = File::KeePass::KDBX->new($self->kdbx)->to_fkp;
+ $self->_write_custom_icons($self->kdbx, $k);
+
+ # TODO create a KPX_CUSTOM_ICONS_4 meta stream. FKP itself handles KPX_GROUP_TREE_STATE
+
+ substr($k->header->{seed_rand}, 16) = '';
+
+ $key = $self->kdbx->composite_key($key, keep_primitive => 1);
+
+ my $dump = eval { $k->gen_db(File::KDBX::Loader::KDB::_convert_kdbx_to_keepass_master_key($key)) };
+ if (my $err = $@) {
+ throw 'Failed to generate KDB file', error => $err;
+ }
+
+ $self->kdbx->key($key);
+
+ print $fh $dump;
+}
+
+sub _write_custom_icons {
+ my $self = shift;
+ my $kdbx = shift;
+ my $k = shift;
+
+ return if $kdbx->sig2 != KDBX_SIG2_1;
+ return if $k->find_entries({
+ title => 'Meta-Info',
+ username => 'SYSTEM',
+ url => '$',
+ comment => 'KPX_CUSTOM_ICONS_4',
+ });
+
+ my @icons; # icon data
+ my %icons; # icon uuid -> index
+ my %entries; # id -> index
+ my %groups; # id -> index
+ my %gid;
+
+ for my $uuid (sort keys %{$kdbx->custom_icons}) {
+ my $icon = $kdbx->custom_icons->{$uuid};
+ my $data = $icon->{data} or next;
+ push @icons, $data;
+ $icons{$uuid} = $#icons;
+ }
+ for my $entry ($k->find_entries({})) {
+ my $icon_uuid = $entry->{custom_icon_uuid} // next;
+ my $icon_index = $icons{$icon_uuid} // next;
+
+ $entry->{id} //= generate_uuid;
+ next if $entries{$entry->{id}};
+
+ $entries{$entry->{id}} = $icon_index;
+ }
+ for my $group ($k->find_groups({})) {
+ $gid{$group->{id} || ''}++;
+ my $icon_uuid = $group->{custom_icon_uuid} // next;
+ my $icon_index = $icons{$icon_uuid} // next;
+
+ if ($group->{id} =~ /^[A-Fa-f0-9]{16}$/) {
+ $group->{id} = hex($group->{id});
+ }
+ elsif ($group->{id} !~ /^\d+$/) {
+ do {
+ $group->{id} = irand;
+ } while $gid{$group->{id}};
+ }
+ $gid{$group->{id}}++;
+ next if $groups{$group->{id}};
+
+ $groups{$group->{id}} = $icon_index;
+ }
+
+ return if !@icons;
+
+ my $stream = '';
+ $stream .= pack('L<3', scalar @icons, scalar keys %entries, scalar keys %groups);
+ for (my $i = 0; $i < @icons; ++$i) {
+ $stream .= pack('L<', length($icons[$i]));
+ $stream .= $icons[$i];
+ }
+ while (my ($id, $icon_index) = each %entries) {
+ $stream .= pack('a16 L<', $id, $icon_index);
+ }
+ while (my ($id, $icon_index) = each %groups) {
+ $stream .= pack('L<2', $id, $icon_index);
+ }
+
+ $k->add_entry({
+ comment => 'KPX_CUSTOM_ICONS_4',
+ title => 'Meta-Info',
+ username => 'SYSTEM',
+ url => '$',
+ id => '0' x 16,
+ icon => 0,
+ binary => {'bin-stream' => $stream},
+ });
+}
+
+1;
+__END__
+
+=head1 DESCRIPTION
+
+Dump older KDB (KeePass 1) files. This feature requires additional modules to be installed:
+
+=for :list
+* L<File::KeePass>
+* L<File::KeePass::KDBX>
+
+=cut
--- /dev/null
+package File::KDBX::Dumper::Raw;
+# ABSTRACT: A no-op dumper that dumps content as-is
+
+use warnings;
+use strict;
+
+use parent 'File::KDBX::Dumper';
+
+our $VERSION = '999.999'; # VERSION
+
+sub _dump {
+ my $self = shift;
+ my $fh = shift;
+
+ $self->_write_body($fh);
+}
+
+sub _write_headers { '' }
+
+sub _write_body {
+ my $self = shift;
+ my $fh = shift;
+
+ $self->_write_inner_body($fh);
+}
+
+sub _write_inner_body {
+ my $self = shift;
+ my $fh = shift;
+
+ $fh->print($self->kdbx->raw);
+}
+
+1;
+__END__
+
+=head1 SYNOPSIS
+
+ use File::KDBX::Dumper;
+ use File::KDBX;
+
+ my $kdbx = File::KDBX->new;
+ $kdbx->raw("Secret file contents\n");
+
+ $kdbx->dump_file('file.kdbx', $key, inner_format => 'Raw');
+ # OR
+ File::KDBX::Dumper->dump_file('file.kdbx', $key,
+ kdbx => $kdbx,
+ inner_format => 'Raw',
+ );
+
+=head1 DESCRIPTION
+
+A typical KDBX file is made up of an outer section (with headers) and an inner section (with the body). The
+inner section is usually dumped using L<File::KDBX::Dumper::XML>, but you can use the
+B<File::KDBX::Dumper::Raw> dumper to just write some arbitrary data as the body content. The result won't
+necessarily be parseable by typical KeePass implementations, but it can be read back using
+L<File::KDBX::Loader::Raw>. It's a way to encrypt any file with the same high level of security as a KDBX
+database.
+
+=cut
--- /dev/null
+package File::KDBX::Dumper::V3;
+# ABSTRACT: Dump KDBX3 files
+
+use warnings;
+use strict;
+
+use Crypt::Digest qw(digest_data);
+use Encode qw(encode);
+use File::KDBX::Constants qw(:header :compression);
+use File::KDBX::Error;
+use File::KDBX::Util qw(:empty assert_64bit erase_scoped);
+use IO::Handle;
+use PerlIO::via::File::KDBX::Crypt;
+use PerlIO::via::File::KDBX::HashBlock;
+use namespace::clean;
+
+use parent 'File::KDBX::Dumper';
+
+our $VERSION = '999.999'; # VERSION
+
+sub _write_headers {
+ my $self = shift;
+ my $fh = shift;
+
+ my $kdbx = $self->kdbx;
+ my $headers = $kdbx->headers;
+ my $buf = '';
+
+ # FIXME kinda janky - maybe add a "prepare" hook to massage the KDBX into the correct shape before we get
+ # this far
+ local $headers->{+HEADER_TRANSFORM_SEED} = $kdbx->transform_seed;
+ local $headers->{+HEADER_TRANSFORM_ROUNDS} = $kdbx->transform_rounds;
+
+ if (nonempty (my $comment = $headers->{+HEADER_COMMENT})) {
+ $buf .= $self->_write_header($fh, HEADER_COMMENT, $comment);
+ }
+ for my $type (
+ HEADER_CIPHER_ID,
+ HEADER_COMPRESSION_FLAGS,
+ HEADER_MASTER_SEED,
+ HEADER_TRANSFORM_SEED,
+ HEADER_TRANSFORM_ROUNDS,
+ HEADER_ENCRYPTION_IV,
+ HEADER_INNER_RANDOM_STREAM_KEY,
+ HEADER_STREAM_START_BYTES,
+ HEADER_INNER_RANDOM_STREAM_ID,
+ ) {
+ defined $headers->{$type} or throw "Missing value for required header: $type", type => $type;
+ $buf .= $self->_write_header($fh, $type, $headers->{$type});
+ }
+ $buf .= $self->_write_header($fh, HEADER_END);
+
+ return $buf;
+}
+
+sub _write_header {
+ my $self = shift;
+ my $fh = shift;
+ my $type = shift;
+ my $val = shift // '';
+
+ $type = KDBX_HEADER($type);
+ if ($type == HEADER_END) {
+ $val = "\r\n\r\n";
+ }
+ elsif ($type == HEADER_COMMENT) {
+ $val = encode('UTF-8', $val);
+ }
+ elsif ($type == HEADER_CIPHER_ID) {
+ my $size = length($val);
+ $size == 16 or throw 'Invalid cipher UUID length', got => $size, expected => $size;
+ }
+ elsif ($type == HEADER_COMPRESSION_FLAGS) {
+ $val = pack('L<', $val);
+ }
+ elsif ($type == HEADER_MASTER_SEED) {
+ my $size = length($val);
+ $size == 32 or throw 'Invalid master seed length', got => $size, expected => $size;
+ }
+ elsif ($type == HEADER_TRANSFORM_SEED) {
+ # nothing
+ }
+ elsif ($type == HEADER_TRANSFORM_ROUNDS) {
+ assert_64bit;
+ $val = pack('Q<', $val);
+ }
+ elsif ($type == HEADER_ENCRYPTION_IV) {
+ # nothing
+ }
+ elsif ($type == HEADER_INNER_RANDOM_STREAM_KEY) {
+ # nothing
+ }
+ elsif ($type == HEADER_STREAM_START_BYTES) {
+ # nothing
+ }
+ elsif ($type == HEADER_INNER_RANDOM_STREAM_ID) {
+ $val = pack('L<', $val);
+ }
+ elsif ($type == HEADER_KDF_PARAMETERS ||
+ $type == HEADER_PUBLIC_CUSTOM_DATA) {
+ throw "Unexpected KDBX4 header: $type", type => $type;
+ }
+ elsif ($type == HEADER_COMMENT) {
+ throw "Unexpected KDB header: $type", type => $type;
+ }
+ else {
+ alert "Unknown header: $type", type => $type;
+ }
+
+ my $size = length($val);
+ my $buf = pack('C S<', 0+$type, $size);
+
+ $fh->print($buf, $val) or throw 'Failed to write header';
+
+ return "$buf$val";
+}
+
+sub _write_body {
+ my $self = shift;
+ my $fh = shift;
+ my $key = shift;
+ my $header_data = shift;
+ my $kdbx = $self->kdbx;
+
+ # assert all required headers present
+ for my $field (
+ HEADER_CIPHER_ID,
+ HEADER_ENCRYPTION_IV,
+ HEADER_MASTER_SEED,
+ HEADER_INNER_RANDOM_STREAM_KEY,
+ HEADER_STREAM_START_BYTES,
+ ) {
+ defined $kdbx->headers->{$field} or throw "Missing $field";
+ }
+
+ my $master_seed = $kdbx->headers->{+HEADER_MASTER_SEED};
+
+ my @cleanup;
+ $key = $kdbx->composite_key($key);
+
+ my $response = $key->challenge($master_seed);
+ push @cleanup, erase_scoped $response;
+
+ my $transformed_key = $kdbx->kdf->transform($key);
+ push @cleanup, erase_scoped $transformed_key;
+
+ my $final_key = digest_data('SHA256', $master_seed, $response, $transformed_key);
+ push @cleanup, erase_scoped $final_key;
+
+ my $cipher = $kdbx->cipher(key => $final_key);
+ PerlIO::via::File::KDBX::Crypt->push($fh, $cipher);
+
+ $fh->print($kdbx->headers->{+HEADER_STREAM_START_BYTES})
+ or throw 'Failed to write start bytes';
+ $fh->flush;
+
+ $kdbx->key($key);
+
+ PerlIO::via::File::KDBX::HashBlock->push($fh);
+
+ my $compress = $kdbx->headers->{+HEADER_COMPRESSION_FLAGS};
+ if ($compress == COMPRESSION_GZIP) {
+ require PerlIO::via::File::KDBX::Compression;
+ PerlIO::via::File::KDBX::Compression->push($fh);
+ }
+ elsif ($compress != COMPRESSION_NONE) {
+ throw "Unsupported compression ($compress)\n", compression_flags => $compress;
+ }
+
+ my $header_hash = digest_data('SHA256', $header_data);
+ $self->_write_inner_body($fh, $header_hash);
+
+ binmode($fh, ':pop') if $compress;
+ binmode($fh, ':pop:pop');
+}
+
+1;
--- /dev/null
+package File::KDBX::Dumper::V4;
+# ABSTRACT: Dump KDBX4 files
+
+use warnings;
+use strict;
+
+use Crypt::Digest qw(digest_data);
+use Crypt::Mac::HMAC qw(hmac);
+use Encode qw(encode is_utf8);
+use File::KDBX::Constants qw(:header :inner_header :compression :kdf :variant_map);
+use File::KDBX::Error;
+use File::KDBX::Util qw(:empty assert_64bit erase_scoped);
+use IO::Handle;
+use PerlIO::via::File::KDBX::Crypt;
+use PerlIO::via::File::KDBX::HmacBlock;
+use Scalar::Util qw(looks_like_number);
+use boolean qw(:all);
+use namespace::clean;
+
+use parent 'File::KDBX::Dumper';
+
+our $VERSION = '999.999'; # VERSION
+
+sub _binaries_written { $_[0]->{_binaries_written} //= {} }
+
+sub _write_headers {
+ my $self = shift;
+ my $fh = shift;
+
+ my $kdbx = $self->kdbx;
+ my $headers = $kdbx->headers;
+ my $buf = '';
+
+ # Always write the standard AES KDF UUID, for compatibility
+ local $headers->{+HEADER_KDF_PARAMETERS}->{+KDF_PARAM_UUID} = KDF_UUID_AES
+ if $headers->{+HEADER_KDF_PARAMETERS}->{+KDF_PARAM_UUID} eq KDF_UUID_AES_CHALLENGE_RESPONSE;
+
+ if (nonempty (my $comment = $headers->{+HEADER_COMMENT})) {
+ $buf .= $self->_write_header($fh, HEADER_COMMENT, $comment);
+ }
+ for my $type (
+ HEADER_CIPHER_ID,
+ HEADER_COMPRESSION_FLAGS,
+ HEADER_MASTER_SEED,
+ HEADER_ENCRYPTION_IV,
+ HEADER_KDF_PARAMETERS,
+ ) {
+ defined $headers->{$type} or throw "Missing value for required header: $type", type => $type;
+ $buf .= $self->_write_header($fh, $type, $headers->{$type});
+ }
+ $buf .= $self->_write_header($fh, HEADER_PUBLIC_CUSTOM_DATA, $headers->{+HEADER_PUBLIC_CUSTOM_DATA})
+ if defined $headers->{+HEADER_PUBLIC_CUSTOM_DATA} && keys %{$headers->{+HEADER_PUBLIC_CUSTOM_DATA}};
+ $buf .= $self->_write_header($fh, HEADER_END);
+
+ return $buf;
+}
+
+sub _write_header {
+ my $self = shift;
+ my $fh = shift;
+ my $type = shift;
+ my $val = shift // '';
+
+ $type = KDBX_HEADER($type);
+ if ($type == HEADER_END) {
+ # nothing
+ }
+ elsif ($type == HEADER_COMMENT) {
+ $val = encode('UTF-8', $val);
+ }
+ elsif ($type == HEADER_CIPHER_ID) {
+ my $size = length($val);
+ $size == 16 or throw 'Invalid cipher UUID length', got => $size, expected => $size;
+ }
+ elsif ($type == HEADER_COMPRESSION_FLAGS) {
+ $val = pack('L<', $val);
+ }
+ elsif ($type == HEADER_MASTER_SEED) {
+ my $size = length($val);
+ $size == 32 or throw 'Invalid master seed length', got => $size, expected => $size;
+ }
+ elsif ($type == HEADER_ENCRYPTION_IV) {
+ # nothing
+ }
+ elsif ($type == HEADER_KDF_PARAMETERS) {
+ $val = $self->_write_variant_dictionary($val, {
+ KDF_PARAM_UUID() => VMAP_TYPE_BYTEARRAY,
+ KDF_PARAM_AES_ROUNDS() => VMAP_TYPE_UINT64,
+ KDF_PARAM_AES_SEED() => VMAP_TYPE_BYTEARRAY,
+ KDF_PARAM_ARGON2_SALT() => VMAP_TYPE_BYTEARRAY,
+ KDF_PARAM_ARGON2_PARALLELISM() => VMAP_TYPE_UINT32,
+ KDF_PARAM_ARGON2_MEMORY() => VMAP_TYPE_UINT64,
+ KDF_PARAM_ARGON2_ITERATIONS() => VMAP_TYPE_UINT64,
+ KDF_PARAM_ARGON2_VERSION() => VMAP_TYPE_UINT32,
+ KDF_PARAM_ARGON2_SECRET() => VMAP_TYPE_BYTEARRAY,
+ KDF_PARAM_ARGON2_ASSOCDATA() => VMAP_TYPE_BYTEARRAY,
+ });
+ }
+ elsif ($type == HEADER_PUBLIC_CUSTOM_DATA) {
+ $val = $self->_write_variant_dictionary($val);
+ }
+ elsif ($type == HEADER_INNER_RANDOM_STREAM_ID ||
+ $type == HEADER_INNER_RANDOM_STREAM_KEY ||
+ $type == HEADER_TRANSFORM_SEED ||
+ $type == HEADER_TRANSFORM_ROUNDS ||
+ $type == HEADER_STREAM_START_BYTES) {
+ throw "Unexpected KDBX3 header: $type", type => $type;
+ }
+ elsif ($type == HEADER_COMMENT) {
+ throw "Unexpected KDB header: $type", type => $type;
+ }
+ else {
+ alert "Unknown header: $type", type => $type;
+ }
+
+ my $size = length($val);
+ my $buf = pack('C L<', 0+$type, $size);
+
+ $fh->print($buf, $val) or throw 'Failed to write header';
+
+ return "$buf$val";
+}
+
+sub _intuit_variant_type {
+ my $self = shift;
+ my $variant = shift;
+
+ if (isBoolean($variant)) {
+ return VMAP_TYPE_BOOL;
+ }
+ elsif (looks_like_number($variant) && ($variant + 0) =~ /^\d+$/) {
+ assert_64bit;
+ my $neg = $variant < 0;
+ my @b = unpack('L>2', pack('Q>', $variant));
+ return VMAP_TYPE_INT64 if $b[0] && $neg;
+ return VMAP_TYPE_UINT64 if $b[0];
+ return VMAP_TYPE_INT32 if $neg;
+ return VMAP_TYPE_UINT32;
+ }
+ elsif (is_utf8($variant)) {
+ return VMAP_TYPE_STRING;
+ }
+ return VMAP_TYPE_BYTEARRAY;
+}
+
+sub _write_variant_dictionary {
+ my $self = shift;
+ my $dict = shift || {};
+ my $types = shift || {};
+
+ my $buf = '';
+
+ $buf .= pack('S<', VMAP_VERSION);
+
+ for my $key (sort keys %$dict) {
+ my $val = $dict->{$key};
+
+ my $type = $types->{$key} // $self->_intuit_variant_type($val);
+ $buf .= pack('C', $type);
+
+ if ($type == VMAP_TYPE_UINT32) {
+ $val = pack('L<', $val);
+ }
+ elsif ($type == VMAP_TYPE_UINT64) {
+ assert_64bit;
+ $val = pack('Q<', $val);
+ }
+ elsif ($type == VMAP_TYPE_BOOL) {
+ $val = pack('C', $val);
+ }
+ elsif ($type == VMAP_TYPE_INT32) {
+ $val = pack('l', $val);
+ }
+ elsif ($type == VMAP_TYPE_INT64) {
+ assert_64bit;
+ $val = pack('q<', $val);
+ }
+ elsif ($type == VMAP_TYPE_STRING) {
+ $val = encode('UTF-8', $val);
+ }
+ elsif ($type == VMAP_TYPE_BYTEARRAY) {
+ # $val = substr($$buf, $pos, $vlen);
+ # $val = [split //, $val];
+ }
+ else {
+ throw 'Unknown variant dictionary value type', type => $type;
+ }
+
+ my ($klen, $vlen) = (length($key), length($val));
+ $buf .= pack("L< a$klen L< a$vlen", $klen, $key, $vlen, $val);
+ }
+
+ $buf .= pack('C', VMAP_TYPE_END);
+
+ return $buf;
+}
+
+sub _write_body {
+ my $self = shift;
+ my $fh = shift;
+ my $key = shift;
+ my $header_data = shift;
+ my $kdbx = $self->kdbx;
+
+ # assert all required headers present
+ for my $field (
+ HEADER_CIPHER_ID,
+ HEADER_ENCRYPTION_IV,
+ HEADER_MASTER_SEED,
+ ) {
+ defined $kdbx->headers->{$field} or throw "Missing header: $field";
+ }
+
+ my @cleanup;
+
+ # write 32-byte checksum
+ my $header_hash = digest_data('SHA256', $header_data);
+ $fh->print($header_hash) or throw 'Failed to write header hash';
+
+ $key = $kdbx->composite_key($key);
+ my $transformed_key = $kdbx->kdf->transform($key);
+ push @cleanup, erase_scoped $transformed_key;
+
+ # write 32-byte HMAC for header
+ my $hmac_key = digest_data('SHA512', $kdbx->headers->{master_seed}, $transformed_key, "\x01");
+ push @cleanup, erase_scoped $hmac_key;
+ my $header_hmac = hmac('SHA256',
+ digest_data('SHA512', "\xff\xff\xff\xff\xff\xff\xff\xff", $hmac_key),
+ $header_data,
+ );
+ $fh->print($header_hmac) or throw 'Failed to write header HMAC';
+
+ $kdbx->key($key);
+
+ # HMAC-block the rest of the stream
+ PerlIO::via::File::KDBX::HmacBlock->push($fh, $hmac_key);
+
+ my $final_key = digest_data('SHA256', $kdbx->headers->{master_seed}, $transformed_key);
+ push @cleanup, erase_scoped $final_key;
+
+ my $cipher = $kdbx->cipher(key => $final_key);
+ PerlIO::via::File::KDBX::Crypt->push($fh, $cipher);
+
+ my $compress = $kdbx->headers->{+HEADER_COMPRESSION_FLAGS};
+ if ($compress == COMPRESSION_GZIP) {
+ require PerlIO::via::File::KDBX::Compression;
+ PerlIO::via::File::KDBX::Compression->push($fh);
+ }
+ elsif ($compress != COMPRESSION_NONE) {
+ throw "Unsupported compression ($compress)\n", compression_flags => $compress;
+ }
+
+ $self->_write_inner_headers($fh);
+
+ local $self->{compress_datetimes} = 1;
+ $self->_write_inner_body($fh, $header_hash);
+
+ binmode($fh, ':pop') if $compress;
+ binmode($fh, ':pop:pop');
+}
+
+sub _write_inner_headers {
+ my $self = shift;
+ my $fh = shift;
+
+ my $kdbx = $self->kdbx;
+ my $headers = $kdbx->inner_headers;
+
+ for my $type (
+ INNER_HEADER_INNER_RANDOM_STREAM_ID,
+ INNER_HEADER_INNER_RANDOM_STREAM_KEY,
+ ) {
+ defined $headers->{$type} or throw "Missing inner header: $type";
+ $self->_write_inner_header($fh, $type => $headers->{$type});
+ }
+
+ $self->_write_binaries($fh);
+
+ $self->_write_inner_header($fh, INNER_HEADER_END);
+}
+
+sub _write_inner_header {
+ my $self = shift;
+ my $fh = shift;
+ my $type = shift;
+ my $val = shift // '';
+
+ my $buf = pack('C', $type);
+ $fh->print($buf) or throw 'Failed to write inner header type';
+
+ $type = KDBX_INNER_HEADER($type);
+
+ if ($type == INNER_HEADER_END) {
+ # nothing
+ }
+ elsif ($type == INNER_HEADER_INNER_RANDOM_STREAM_ID) {
+ $val = pack('L<', $val);
+ }
+ elsif ($type == INNER_HEADER_INNER_RANDOM_STREAM_KEY) {
+ # nothing
+ }
+ elsif ($type == INNER_HEADER_BINARY) {
+ # nothing
+ }
+
+ $buf = pack('L<', length($val));
+ $fh->print($buf) or throw 'Failed to write inner header value size';
+ $fh->print($val) or throw 'Failed to write inner header value';
+}
+
+sub _write_binaries {
+ my $self = shift;
+ my $fh = shift;
+
+ my $kdbx = $self->kdbx;
+
+ my $new_ref = 0;
+ my $written = $self->_binaries_written;
+
+ my $entries = $kdbx->all_entries(history => true);
+ for my $entry (@$entries) {
+ for my $key (keys %{$entry->binaries}) {
+ my $binary = $entry->binaries->{$key};
+ if (defined $binary->{ref} && defined $kdbx->binaries->{$binary->{ref}}) {
+ $binary = $kdbx->binaries->{$binary->{ref}};
+ }
+
+ if (!defined $binary->{value}) {
+ alert "Skipping binary which has no value: $key", key => $key;
+ next;
+ }
+
+ my $hash = digest_data('SHA256', $binary->{value});
+ if (defined $written->{$hash}) {
+ # nothing
+ }
+ else {
+ my $flags = 0;
+ $flags &= INNER_HEADER_BINARY_FLAG_PROTECT if $binary->{protect};
+
+ $self->_write_binary($fh, \$binary->{value}, $flags);
+ $written->{$hash} = $new_ref++;
+ }
+ }
+ }
+}
+
+sub _write_binary {
+ my $self = shift;
+ my $fh = shift;
+ my $data = shift;
+ my $flags = shift || 0;
+
+ my $buf = pack('C', 0 + INNER_HEADER_BINARY);
+ $fh->print($buf) or throw 'Failed to write inner header type';
+
+ $buf = pack('L<', 1 + length($$data));
+ $fh->print($buf) or throw 'Failed to write inner header value size';
+
+ $buf = pack('C', $flags);
+ $fh->print($buf) or throw 'Failed to write inner header binary flags';
+
+ $fh->print($$data) or throw 'Failed to write inner header value';
+}
+
+1;
--- /dev/null
+package File::KDBX::Dumper::XML;
+# ABSTRACT: Dump unencrypted XML KeePass files
+
+use warnings;
+use strict;
+
+use Crypt::Digest qw(digest_data);
+use Crypt::Misc 0.029 qw(encode_b64);
+use Encode qw(encode);
+use File::KDBX::Constants qw(:version :time);
+use File::KDBX::Error;
+use File::KDBX::Util qw(assert_64bit erase_scoped gzip snakify);
+use IO::Handle;
+use Scalar::Util qw(isdual looks_like_number);
+use Scope::Guard;
+use Time::Piece;
+use XML::LibXML;
+use boolean;
+use namespace::clean;
+
+use parent 'File::KDBX::Dumper';
+
+our $VERSION = '999.999'; # VERSION
+
+sub protect {
+ my $self = shift;
+ $self->{protect} = shift if @_;
+ $self->{protect} //= 1;
+}
+
+sub binaries {
+ my $self = shift;
+ $self->{binaries} = shift if @_;
+ $self->{binaries} //= $self->kdbx->version < KDBX_VERSION_4_0;
+}
+
+sub compress_binaries {
+ my $self = shift;
+ $self->{compress_binaries} = shift if @_;
+ $self->{compress_binaries};
+}
+
+sub compress_datetimes {
+ my $self = shift;
+ $self->{compress_datetimes} = shift if @_;
+ $self->{compress_datetimes};
+}
+
+sub header_hash { $_[0]->{header_hash} }
+
+sub _binaries_written { $_[0]->{_binaries_written} //= {} }
+
+sub _random_stream { $_[0]->{random_stream} //= $_[0]->kdbx->random_stream }
+
+sub _dump {
+ my $self = shift;
+ my $fh = shift;
+
+ $self->_write_inner_body($fh, $self->header_hash);
+}
+
+sub _write_inner_body {
+ my $self = shift;
+ my $fh = shift;
+ my $header_hash = shift;
+
+ my $dom = XML::LibXML::Document->new('1.0', 'UTF-8');
+ $dom->setStandalone(1);
+
+ my $doc = XML::LibXML::Element->new('KeePassFile');
+ $dom->setDocumentElement($doc);
+
+ my $meta = XML::LibXML::Element->new('Meta');
+ $doc->appendChild($meta);
+ $self->_write_xml_meta($meta, $header_hash);
+
+ my $root = XML::LibXML::Element->new('Root');
+ $doc->appendChild($root);
+ $self->_write_xml_root($root);
+
+ $dom->toFH($fh, 1);
+}
+
+sub _write_xml_meta {
+ my $self = shift;
+ my $node = shift;
+ my $header_hash = shift;
+
+ my $meta = $self->kdbx->meta;
+ local $meta->{generator} = $self->kdbx->user_agent_string // __PACKAGE__;
+ local $meta->{header_hash} = $header_hash;
+
+ $self->_write_xml_from_pairs($node, $meta,
+ Generator => 'text',
+ $self->kdbx->version < KDBX_VERSION_4_0 && defined $meta->{header_hash} ? (
+ HeaderHash => 'binary',
+ ) : (),
+ DatabaseName => 'text',
+ DatabaseNameChanged => 'datetime',
+ DatabaseDescription => 'text',
+ DatabaseDescriptionChanged => 'datetime',
+ DefaultUserName => 'text',
+ DefaultUserNameChanged => 'datetime',
+ MaintenanceHistoryDays => 'number',
+ Color => 'text',
+ MasterKeyChanged => 'datetime',
+ MasterKeyChangeRec => 'number',
+ MasterKeyChangeForce => 'number',
+ MemoryProtection => \&_write_xml_memory_protection,
+ CustomIcons => \&_write_xml_custom_icons,
+ RecycleBinEnabled => 'bool',
+ RecycleBinUUID => 'uuid',
+ RecycleBinChanged => 'datetime',
+ EntryTemplatesGroup => 'uuid',
+ EntryTemplatesGroupChanged => 'datetime',
+ LastSelectedGroup => 'uuid',
+ LastTopVisibleGroup => 'uuid',
+ HistoryMaxItems => 'number',
+ HistoryMaxSize => 'number',
+ $self->kdbx->version >= KDBX_VERSION_4_0 ? (
+ SettingsChanged => 'datetime',
+ ) : (),
+ $self->kdbx->version < KDBX_VERSION_4_0 || $self->binaries ? (
+ Binaries => \&_write_xml_binaries,
+ ) : (),
+ CustomData => \&_write_xml_custom_data,
+ );
+}
+
+sub _write_xml_memory_protection {
+ my $self = shift;
+ my $node = shift;
+
+ my $memory_protection = $self->kdbx->meta->{memory_protection};
+
+ $self->_write_xml_from_pairs($node, $memory_protection,
+ ProtectTitle => 'bool',
+ ProtectUserName => 'bool',
+ ProtectPassword => 'bool',
+ ProtectURL => 'bool',
+ ProtectNotes => 'bool',
+ # AutoEnableVisualHiding => 'bool',
+ );
+}
+
+sub _write_xml_binaries {
+ my $self = shift;
+ my $node = shift;
+
+ my $kdbx = $self->kdbx;
+
+ my $new_ref = keys %{$self->_binaries_written};
+ my $written = $self->_binaries_written;
+
+ my $entries = $kdbx->all_entries(history => true);
+ for my $entry (@$entries) {
+ for my $key (keys %{$entry->binaries}) {
+ my $binary = $entry->binaries->{$key};
+ if (defined $binary->{ref} && defined $kdbx->binaries->{$binary->{ref}}) {
+ $binary = $kdbx->binaries->{$binary->{ref}};
+ }
+
+ if (!defined $binary->{value}) {
+ alert "Skipping binary which has no value: $key", key => $key;
+ next;
+ }
+
+ my $hash = digest_data('SHA256', $binary->{value});
+ if (defined $written->{$hash}) {
+ # nothing
+ }
+ else {
+ my $binary_node = $node->addNewChild(undef, 'Binary');
+ $binary_node->setAttribute('ID', _encode_text($new_ref));
+ $binary_node->setAttribute('Protected', _encode_bool(true)) if $binary->{protect};
+ $self->_write_xml_compressed_content($binary_node, \$binary->{value}, $binary->{protect});
+ $written->{$hash} = $new_ref++;
+ }
+ }
+ }
+}
+
+sub _write_xml_compressed_content {
+ my $self = shift;
+ my $node = shift;
+ my $value = shift;
+ my $protect = shift;
+
+ my @cleanup;
+
+ my $encoded;
+ if (utf8::is_utf8($$value)) {
+ $encoded = encode('UTF-8', $$value);
+ push @cleanup, erase_scoped $encoded;
+ $value = \$encoded;
+ }
+
+ my $always_compress = $self->compress_binaries;
+ my $try_compress = $always_compress || !defined $always_compress;
+
+ my $compressed;
+ if ($try_compress) {
+ $compressed = gzip($$value);
+ push @cleanup, erase_scoped $compressed;
+
+ if ($always_compress || length($compressed) < length($$value)) {
+ $value = \$compressed;
+ $node->setAttribute('Compressed', _encode_bool(true));
+ }
+ }
+
+ my $encrypted;
+ if ($protect) {
+ $encrypted = $self->_random_stream->crypt($$value);
+ push @cleanup, erase_scoped $encrypted;
+ $value = \$encrypted;
+ }
+
+ $node->appendText(_encode_binary($$value));
+}
+
+sub _write_xml_custom_icons {
+ my $self = shift;
+ my $node = shift;
+
+ my $custom_icons = $self->kdbx->meta->{custom_icons} || {};
+
+ for my $uuid (sort keys %$custom_icons) {
+ my $icon = $custom_icons->{$uuid};
+ my $icon_node = $node->addNewChild(undef, 'Icon');
+
+ $self->_write_xml_from_pairs($icon_node, $icon,
+ UUID => 'uuid',
+ Data => 'binary',
+ KDBX_VERSION_4_1 <= $self->kdbx->version ? (
+ Name => 'text',
+ LastModificationTime => 'datetime',
+ ) : (),
+ );
+ }
+}
+
+sub _write_xml_custom_data {
+ my $self = shift;
+ my $node = shift;
+ my $custom_data = shift || {};
+
+ for my $key (sort keys %$custom_data) {
+ my $item = $custom_data->{$key};
+ my $item_node = $node->addNewChild(undef, 'Item');
+
+ local $item->{key} = $key if !defined $item->{key};
+
+ $self->_write_xml_from_pairs($item_node, $item,
+ Key => 'text',
+ Value => 'text',
+ KDBX_VERSION_4_1 <= $self->kdbx->version ? (
+ LastModificationTime => 'datetime',
+ ) : (),
+ );
+ }
+}
+
+sub _write_xml_root {
+ my $self = shift;
+ my $node = shift;
+ my $kdbx = $self->kdbx;
+
+ my $is_locked = $kdbx->is_locked;
+ my $guard = Scope::Guard->new(sub { $kdbx->lock if $is_locked });
+ $kdbx->unlock;
+
+ if (my $group = $kdbx->{root}) {
+ my $group_node = $node->addNewChild(undef, 'Group');
+ $self->_write_xml_group($group_node, $group);
+ }
+
+ undef $guard; # re-lock if needed, as early as possible
+
+ my $deleted_objects_node = $node->addNewChild(undef, 'DeletedObjects');
+ $self->_write_xml_deleted_objects($deleted_objects_node);
+}
+
+sub _write_xml_group {
+ my $self = shift;
+ my $node = shift;
+ my $group = shift;
+
+ $self->_write_xml_from_pairs($node, $group,
+ UUID => 'uuid',
+ Name => 'text',
+ Notes => 'text',
+ KDBX_VERSION_4_1 <= $self->kdbx->version ? (
+ Tags => 'text',
+ ) : (),
+ IconID => 'number',
+ defined $group->{custom_icon_uuid} ? (
+ CustomIconUUID => 'uuid',
+ ) : (),
+ Times => \&_write_xml_times,
+ IsExpanded => 'bool',
+ DefaultAutoTypeSequence => 'text',
+ EnableAutoType => 'tristate',
+ EnableSearching => 'tristate',
+ LastTopVisibleEntry => 'uuid',
+ KDBX_VERSION_4_0 <= $self->kdbx->version ? (
+ CustomData => \&_write_xml_custom_data,
+ ) : (),
+ KDBX_VERSION_4_1 <= $self->kdbx->version ? (
+ PreviousParentGroup => 'uuid',
+ ) : (),
+ );
+
+ for my $entry (@{$group->{entries} || []}) {
+ my $entry_node = $node->addNewChild(undef, 'Entry');
+ $self->_write_xml_entry($entry_node, $entry);
+ }
+
+ for my $group (@{$group->{groups} || []}) {
+ my $group_node = $node->addNewChild(undef, 'Group');
+ $self->_write_xml_group($group_node, $group);
+ }
+}
+
+sub _write_xml_entry {
+ my $self = shift;
+ my $node = shift;
+ my $entry = shift;
+ my $in_history = shift;
+
+ $self->_write_xml_from_pairs($node, $entry,
+ UUID => 'uuid',
+ IconID => 'number',
+ defined $entry->{custom_icon_uuid} ? (
+ CustomIconUUID => 'uuid',
+ ) : (),
+ ForegroundColor => 'text',
+ BackgroundColor => 'text',
+ OverrideURL => 'text',
+ Tags => 'text',
+ Times => \&_write_xml_times,
+ KDBX_VERSION_4_1 <= $self->kdbx->version ? (
+ QualityCheck => 'bool',
+ PreviousParentGroup => 'uuid',
+ ) : (),
+ );
+
+ for my $key (sort keys %{$entry->{strings} || {}}) {
+ my $string = $entry->{strings}{$key};
+ my $string_node = $node->addNewChild(undef, 'String');
+ local $string->{key} = $string->{key} // $key;
+ $self->_write_xml_entry_string($string_node, $string);
+ }
+
+ my $kdbx = $self->kdbx;
+ my $new_ref = keys %{$self->_binaries_written};
+ my $written = $self->_binaries_written;
+
+ for my $key (sort keys %{$entry->{binaries} || {}}) {
+ my $binary = $entry->binaries->{$key};
+ if (defined $binary->{ref} && defined $kdbx->binaries->{$binary->{ref}}) {
+ $binary = $kdbx->binaries->{$binary->{ref}};
+ }
+
+ if (!defined $binary->{value}) {
+ alert "Skipping binary which has no value: $key", key => $key;
+ next;
+ }
+
+ my $binary_node = $node->addNewChild(undef, 'Binary');
+ $binary_node->addNewChild(undef, 'Key')->appendText(_encode_text($key));
+ my $value_node = $binary_node->addNewChild(undef, 'Value');
+
+ my $hash = digest_data('SHA256', $binary->{value});
+ if (defined $written->{$hash}) {
+ # write reference
+ $value_node->setAttribute('Ref', _encode_text($written->{$hash}));
+ }
+ else {
+ # write actual binary
+ $value_node->setAttribute('Protected', _encode_bool(true)) if $binary->{protect};
+ $self->_write_xml_compressed_content($value_node, \$binary->{value}, $binary->{protect});
+ $written->{$hash} = $new_ref++;
+ }
+ }
+
+ $self->_write_xml_from_pairs($node, $entry,
+ AutoType => \&_write_xml_entry_auto_type,
+ );
+
+ $self->_write_xml_from_pairs($node, $entry,
+ KDBX_VERSION_4_0 <= $self->kdbx->version ? (
+ CustomData => \&_write_xml_custom_data,
+ ) : (),
+ );
+
+ if (!$in_history) {
+ if (my @history = @{$entry->{history} || []}) {
+ my $history_node = $node->addNewChild(undef, 'History');
+ for my $historical (@history) {
+ my $historical_node = $history_node->addNewChild(undef, 'Entry');
+ $self->_write_xml_entry($historical_node, $historical, 1);
+ }
+ }
+ }
+}
+
+sub _write_xml_entry_auto_type {
+ my $self = shift;
+ my $node = shift;
+ my $autotype = shift;
+
+ $self->_write_xml_from_pairs($node, $autotype,
+ Enabled => 'bool',
+ DataTransferObfuscation => 'number',
+ DefaultSequence => 'text',
+ );
+
+ for my $association (@{$autotype->{associations} || []}) {
+ my $association_node = $node->addNewChild(undef, 'Association');
+ $self->_write_xml_from_pairs($association_node, $association,
+ Window => 'text',
+ KeystrokeSequence => 'text',
+ );
+ }
+}
+
+sub _write_xml_times {
+ my $self = shift;
+ my $node = shift;
+ my $times = shift;
+
+ $self->_write_xml_from_pairs($node, $times,
+ LastModificationTime => 'datetime',
+ CreationTime => 'datetime',
+ LastAccessTime => 'datetime',
+ ExpiryTime => 'datetime',
+ Expires => 'bool',
+ UsageCount => 'number',
+ LocationChanged => 'datetime',
+ );
+}
+
+sub _write_xml_entry_string {
+ my $self = shift;
+ my $node = shift;
+ my $string = shift;
+
+ my @cleanup;
+
+ my $kdbx = $self->kdbx;
+ my $key = $string->{key};
+
+ $node->addNewChild(undef, 'Key')->appendText(_encode_text($key));
+ my $value_node = $node->addNewChild(undef, 'Value');
+
+ my $value = $string->{value} || '';
+
+ my $memory_protection = $kdbx->meta->{memory_protection};
+ my $memprot_key = 'protect_' . snakify($key);
+ my $protect = $string->{protect} || $memory_protection->{$memprot_key};
+
+ if ($protect) {
+ if ($self->protect) {
+ my $encoded;
+ if (utf8::is_utf8($value)) {
+ $encoded = encode('UTF-8', $value);
+ push @cleanup, erase_scoped $encoded;
+ $value = $encoded;
+ }
+
+ $value_node->setAttribute('Protected', _encode_bool(true));
+ $value = _encode_binary($self->_random_stream->crypt(\$value));
+ }
+ else {
+ $value_node->setAttribute('ProtectInMemory', _encode_bool(true));
+ $value = _encode_text($value);
+ }
+ }
+ else {
+ $value = _encode_text($value);
+ }
+
+ $value_node->appendText($value) if defined $value;
+}
+
+sub _write_xml_deleted_objects {
+ my $self = shift;
+ my $node = shift;
+
+ my $objects = $self->kdbx->deleted_objects;
+
+ for my $uuid (sort keys %{$objects || {}}) {
+ my $object = $objects->{$uuid};
+ local $object->{uuid} = $uuid;
+ my $object_node = $node->addNewChild(undef, 'DeletedObject');
+ $self->_write_xml_from_pairs($object_node, $object,
+ UUID => 'uuid',
+ DeletionTime => 'datetime',
+ );
+ }
+}
+
+##############################################################################
+
+sub _write_xml_from_pairs {
+ my $self = shift;
+ my $node = shift;
+ my $hash = shift;
+ my @spec = @_;
+
+ while (@spec) {
+ my ($name, $type) = splice @spec, 0, 2;
+ my $key = snakify($name);
+
+ if (ref $type eq 'CODE') {
+ my $child_node = $node->addNewChild(undef, $name);
+ $self->$type($child_node, $hash->{$key});
+ }
+ else {
+ next if !exists $hash->{$key};
+ my $child_node = $node->addNewChild(undef, $name);
+ $type = 'datetime_binary' if $type eq 'datetime' && $self->compress_datetimes;
+ $child_node->appendText(_encode_primitive($hash->{$key}, $type));
+ }
+ }
+}
+
+##############################################################################
+
+sub _encode_primitive { goto &{__PACKAGE__."::_encode_$_[1]"} }
+
+sub _encode_binary {
+ return '' if !defined $_[0] || (ref $_[0] && !defined $$_[0]);
+ return encode_b64(ref $_[0] ? $$_[0] : $_[0]);
+}
+
+sub _encode_bool {
+ local $_ = shift;
+ return $_ ? 'True' : 'False';
+}
+
+sub _encode_datetime {
+ goto &_encode_datetime_binary if defined $_[2] && KDBX_VERSION_4_0 <= $_[2];
+ local $_ = shift;
+ return $_->strftime('%Y-%m-%dT%H:%M:%SZ');
+}
+
+sub _encode_datetime_binary {
+ local $_ = shift;
+ assert_64bit;
+ my $seconds_since_ad1 = $_ + TIME_SECONDS_AD1_TO_UNIX_EPOCH;
+ my $buf = pack('Q<', $seconds_since_ad1->epoch);
+ return eval { encode_b64($buf) };
+}
+
+sub _encode_tristate {
+ local $_ = shift // return 'null';
+ return $_ ? 'True' : 'False';
+}
+
+sub _encode_number {
+ local $_ = shift // return;
+ looks_like_number($_) || isdual($_) or throw 'Expected number', text => $_;
+ return _encode_text($_+0);
+}
+
+sub _encode_text {
+ return '' if !defined $_[0];
+ return $_[0];
+}
+
+sub _encode_uuid { _encode_binary(@_) }
+
+1;
--- /dev/null
+package File::KDBX::Entry;
+# ABSTRACT: A KDBX database entry
+
+use warnings;
+use strict;
+
+use Crypt::Misc 0.029 qw(encode_b32r decode_b64);
+use Devel::GlobalDestruction;
+use Encode qw(encode);
+use File::KDBX::Constants qw(:history :icon);
+use File::KDBX::Error;
+use File::KDBX::Util qw(:function :uri generate_uuid load_optional);
+use List::Util qw(sum0);
+use Ref::Util qw(is_plain_hashref is_ref);
+use Scalar::Util qw(looks_like_number refaddr);
+use Storable qw(dclone);
+use Time::Piece;
+use boolean;
+use namespace::clean;
+
+use parent 'File::KDBX::Object';
+
+our $VERSION = '999.999'; # VERSION
+
+my $PLACEHOLDER_MAX_DEPTH = 10;
+my %PLACEHOLDERS;
+my %STANDARD_STRINGS = map { $_ => 1 } qw(Title UserName Password URL Notes);
+
+=attr uuid
+
+128-bit UUID identifying the entry within the database.
+
+=attr icon_id
+
+Integer representing a default icon. See L<File::KDBX::Constants/":icon"> for valid values.
+
+=attr custom_icon_uuid
+
+128-bit UUID identifying a custom icon within the database.
+
+=attr foreground_color
+
+Text color represented as a string of the form C<#000000>.
+
+=attr background_color
+
+Background color represented as a string of the form C<#FFFFFF>.
+
+=attr override_url
+
+TODO
+
+=attr tags
+
+Text string with arbitrary tags which can be used to build a taxonomy.
+
+=attr auto_type
+
+Auto-type details.
+
+ {
+ enabled => true,
+ data_transfer_obfuscation => 0,
+ default_sequence => '{USERNAME}{TAB}{PASSWORD}{ENTER}',
+ associations => [
+ {
+ window => 'My Bank - Mozilla Firefox',
+ keystroke_sequence => '{PASSWORD}{ENTER}',
+ },
+ ],
+ }
+
+=attr previous_parent_group
+
+128-bit UUID identifying a group within the database.
+
+=attr quality_check
+
+Boolean indicating whether the entry password should be tested for weakness and show up in reports.
+
+=attr strings
+
+Hash with entry strings, including the standard strings as well as any custom ones.
+
+ {
+ # Every entry has these five strings:
+ Title => { value => 'Example Entry' },
+ UserName => { value => 'jdoe' },
+ Password => { value => 's3cr3t', protect => true },
+ URL => { value => 'https://example.com' }
+ Notes => { value => '' },
+ # May also have custom strings:
+ MySystem => { value => 'The mainframe' },
+ }
+
+=attr binaries
+
+Files or attachments.
+
+=attr custom_data
+
+A set of key-value pairs used to store arbitrary data, usually used by software to keep track of state rather
+than by end users (who typically work with the strings and binaries).
+
+=attr history
+
+Array of historical entries. Historical entries are prior versions of the same entry so they all share the
+same UUID with the current entry.
+
+=attr last_modification_time
+
+Date and time when the entry was last modified.
+
+=attr creation_time
+
+Date and time when the entry was created.
+
+=attr last_access_time
+
+Date and time when the entry was last accessed.
+
+=attr expiry_time
+
+Date and time when the entry expired or will expire.
+
+=attr expires
+
+Boolean value indicating whether or not an entry is expired.
+
+=attr usage_count
+
+The number of times an entry has been used, which typically means how many times the C<Password> string has
+been accessed.
+
+=attr location_changed
+
+Date and time when the entry was last moved to a different group.
+
+=attr notes
+
+Alias for the C<Notes> string value.
+
+=attr password
+
+Alias for the C<Password> string value.
+
+=attr title
+
+Alias for the C<Title> string value.
+
+=attr url
+
+Alias for the C<URL> string value.
+
+=attr username
+
+Aliases for the C<UserName> string value.
+
+=cut
+
+sub uuid {
+ my $self = shift;
+ if (@_ || !defined $self->{uuid}) {
+ my %args = @_ % 2 == 1 ? (uuid => shift, @_) : @_;
+ my $old_uuid = $self->{uuid};
+ my $uuid = $self->{uuid} = delete $args{uuid} // generate_uuid;
+ for my $entry (@{$self->history}) {
+ $entry->{uuid} = $uuid;
+ }
+ # if (defined $old_uuid and my $kdbx = $KDBX{refaddr($self)}) {
+ # $kdbx->_update_entry_uuid($old_uuid, $uuid, $self);
+ # }
+ }
+ $self->{uuid};
+}
+
+my @ATTRS = qw(uuid custom_data history);
+my %ATTRS = (
+ # uuid => sub { generate_uuid(printable => 1) },
+ icon_id => ICON_PASSWORD,
+ custom_icon_uuid => undef,
+ foreground_color => '',
+ background_color => '',
+ override_url => '',
+ tags => '',
+ auto_type => sub { +{} },
+ previous_parent_group => undef,
+ quality_check => true,
+ strings => sub { +{} },
+ binaries => sub { +{} },
+ # custom_data => sub { +{} },
+ # history => sub { +[] },
+);
+my %ATTRS_TIMES = (
+ last_modification_time => sub { gmtime },
+ creation_time => sub { gmtime },
+ last_access_time => sub { gmtime },
+ expiry_time => sub { gmtime },
+ expires => false,
+ usage_count => 0,
+ location_changed => sub { gmtime },
+);
+my %ATTRS_STRINGS = (
+ title => 'Title',
+ username => 'UserName',
+ password => 'Password',
+ url => 'URL',
+ notes => 'Notes',
+);
+
+while (my ($attr, $default) = each %ATTRS) {
+ no strict 'refs'; ## no critic (ProhibitNoStrict)
+ *{$attr} = sub {
+ my $self = shift;
+ $self->{$attr} = shift if @_;
+ $self->{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default;
+ };
+}
+while (my ($attr, $default) = each %ATTRS_TIMES) {
+ no strict 'refs'; ## no critic (ProhibitNoStrict)
+ *{$attr} = sub {
+ my $self = shift;
+ $self->{times} //= {};
+ $self->{times}{$attr} = shift if @_;
+ $self->{times}{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default;
+ };
+}
+while (my ($attr, $string_key) = each %ATTRS_STRINGS) {
+ no strict 'refs'; ## no critic (ProhibitNoStrict)
+ *{$attr} = sub { shift->string_value($string_key, @_) };
+ *{"expanded_${attr}"} = sub { shift->expanded_string_value($string_key, @_) };
+}
+
+sub _set_default_attributes {
+ my $self = shift;
+ $self->$_ for @ATTRS, keys %ATTRS, keys %ATTRS_TIMES, keys %ATTRS_STRINGS;
+}
+
+sub init {
+ my $self = shift;
+ my %args = @_;
+
+ while (my ($key, $val) = each %args) {
+ if (my $method = $self->can($key)) {
+ $self->$method($val);
+ }
+ else {
+ $self->string($key => $val);
+ }
+ }
+
+ return $self;
+}
+
+sub label { shift->title(@_) }
+
+##############################################################################
+
+=method string
+
+ \%string = $entry->string($string_key);
+
+ $entry->string($string_key, \%string);
+ $entry->string($string_key, %attributes);
+ $entry->string($string_key, $value); # same as: value => $value
+
+Get or set a string. Every string has a unique (to the entry) key and flags and so are returned as a hash
+structure. For example:
+
+ $string = {
+ value => 'Password',
+ protect => true,
+ };
+
+Every string should have a value and these optional flags which might exist:
+
+=for :list
+* C<protect> - Whether or not the string value should be memory-protected.
+
+=cut
+
+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, @_) : @_;
+
+ if (!defined $args{key} && !defined $args{value}) {
+ my %standard = (value => 1, protect => 1);
+ my @other_keys = grep { !$standard{$_} } keys %args;
+ if (@other_keys == 1) {
+ my $key = $args{key} = $other_keys[0];
+ $args{value} = delete $args{$key};
+ }
+ }
+
+ my $key = delete $args{key} or throw 'Must provide a string key to access';
+
+ return $self->{strings}{$key} = $args{value} if is_plain_hashref($args{value});
+
+ while (my ($field, $value) = each %args) {
+ $self->{strings}{$key}{$field} = $value;
+ }
+
+ # Auto-vivify the standard strings.
+ if ($STANDARD_STRINGS{$key}) {
+ return $self->{strings}{$key} //= {value => '', $self->_protect($key) ? (protect => true) : ()};
+ }
+ return $self->{strings}{$key};
+}
+
+### Get whether or not a standard string is configured to be protected
+sub _protect {
+ my $self = shift;
+ my $key = shift;
+ return false if !$STANDARD_STRINGS{$key};
+ if (my $kdbx = eval { $self->kdbx }) {
+ my $protect = $kdbx->memory_protection($key);
+ return $protect if defined $protect;
+ }
+ return $key eq 'Password';
+}
+
+=method string_value
+
+ $string = $entry->string_value;
+
+Access a string value directly. Returns C<undef> if the string is not set.
+
+=cut
+
+sub string_value {
+ my $self = shift;
+ my $string = $self->string(@_) // return undef;
+ return $string->{value};
+}
+
+=method expanded_string_value
+
+ $string = $entry->expanded_string_value;
+
+Same as L</string_value> but will substitute placeholders and resolve field references. Any placeholders that
+do not expand to values are left as-is.
+
+See L</Placeholders>.
+
+Some placeholders (notably field references) require the entry be associated with a database and will throw an
+error if there is no association.
+
+=cut
+
+sub _expand_placeholder {
+ my $self = shift;
+ my $placeholder = shift;
+ my $arg = shift;
+
+ require File::KDBX;
+
+ my $placeholder_key = $placeholder;
+ if (defined $arg) {
+ $placeholder_key = $File::KDBX::PLACEHOLDERS{"${placeholder}:${arg}"} ? "${placeholder}:${arg}"
+ : "${placeholder}:";
+ }
+ return if !defined $File::KDBX::PLACEHOLDERS{$placeholder_key};
+
+ my $local_key = join('/', refaddr($self), $placeholder_key);
+ local $PLACEHOLDERS{$local_key} = my $handler = $PLACEHOLDERS{$local_key} // do {
+ my $handler = $File::KDBX::PLACEHOLDERS{$placeholder_key} or next;
+ memoize recurse_limit($handler, $PLACEHOLDER_MAX_DEPTH, sub {
+ alert "Detected deep recursion while expanding $placeholder placeholder",
+ placeholder => $placeholder;
+ return; # undef
+ });
+ };
+
+ return $handler->($self, $arg, $placeholder);
+}
+
+sub _expand_string {
+ my $self = shift;
+ my $str = shift;
+
+ my $expand = memoize $self->can('_expand_placeholder'), $self;
+
+ # placeholders (including field references):
+ $str =~ s!\{([^:\}]+)(?::([^\}]*))?\}!$expand->(uc($1), $2, @_) // $&!egi;
+
+ # environment variables (alt syntax):
+ my $vars = join('|', map { quotemeta($_) } keys %ENV);
+ $str =~ s!\%($vars)\%!$expand->(ENV => $1, @_) // $&!eg;
+
+ return $str;
+}
+
+sub expanded_string_value {
+ my $self = shift;
+ my $str = $self->string_value(@_) // return undef;
+ return $self->_expand_string($str);
+}
+
+=method other_strings
+
+ $other = $entry->other_strings;
+ $other = $entry->other_strings($delimiter);
+
+Get a concatenation of all non-standard string values. The default delimiter is a newline. This is is useful
+for executing queries to search for entities based on the contents of these other strings (if any).
+
+=cut
+
+sub other_strings {
+ my $self = shift;
+ my $delim = shift // "\n";
+
+ my @strings = map { $self->string_value($_) } grep { !$STANDARD_STRINGS{$_} } sort keys %{$self->strings};
+ return join($delim, @strings);
+}
+
+sub string_peek {
+ my $self = shift;
+ my $string = $self->string(@_);
+ return defined $string->{value} ? $string->{value} : $self->kdbx->peek($string);
+}
+
+sub password_peek { $_[0]->string_peek('Password') }
+
+##############################################################################
+
+sub binary {
+ my $self = shift;
+ my $key = shift or throw 'Must provide a binary key to access';
+ if (@_) {
+ my $arg = @_ == 1 ? shift : undef;
+ my %args;
+ @args{keys %$arg} = values %$arg if ref $arg eq 'HASH';
+ $args{value} = $arg if !ref $arg;
+ while (my ($field, $value) = each %args) {
+ $self->{binaries}{$key}{$field} = $value;
+ }
+ }
+ my $binary = $self->{binaries}{$key} //= {value => ''};
+ if (defined (my $ref = $binary->{ref})) {
+ $binary = $self->{binaries}{$key} = dclone($self->kdbx->binaries->{$ref});
+ }
+ return $binary;
+}
+
+sub binary_novivify {
+ my $self = shift;
+ my $binary_key = shift;
+ return if !$self->{binaries}{$binary_key} && !@_;
+ return $self->binary($binary_key, @_);
+}
+
+sub binary_value {
+ my $self = shift;
+ my $binary = $self->binary_novivify(@_) // return undef;
+ return $binary->{value};
+}
+
+##############################################################################
+
+=method hmac_otp
+
+ $otp = $entry->hmac_otp(%options);
+
+Generate an HMAC-based one-time password, or C<undef> if HOTP is not configured for the entry. The entry's
+strings generally must first be unprotected, just like when accessing the password. Valid options are:
+
+=for :list
+* C<counter> - Specify the counter value
+
+To configure HOTP, see L</"One-time Passwords">.
+
+=cut
+
+sub hmac_otp {
+ my $self = shift;
+ load_optional('Pass::OTP');
+
+ my %params = ($self->_hotp_params, @_);
+ return if !defined $params{type} || !defined $params{secret};
+
+ $params{secret} = encode_b32r($params{secret}) if !$params{base32};
+ $params{base32} = 1;
+
+ my $otp = eval {Pass::OTP::otp(%params, @_) };
+ if (my $err = $@) {
+ throw 'Unable to generate HOTP', error => $err;
+ }
+
+ $self->_hotp_increment_counter($params{counter});
+
+ return $otp;
+}
+
+=method time_otp
+
+ $otp = $entry->time_otp(%options);
+
+Generate a time-based one-time password, or C<undef> if TOTP is not configured for the entry. The entry's
+strings generally must first be unprotected, just like when accessing the password. Valid options are:
+
+=for :list
+* C<now> - Specify the value for determining the time-step counter
+
+To configure TOTP, see L</"One-time Passwords">.
+
+=cut
+
+sub time_otp {
+ my $self = shift;
+ load_optional('Pass::OTP');
+
+ my %params = ($self->_totp_params, @_);
+ return if !defined $params{type} || !defined $params{secret};
+
+ $params{secret} = encode_b32r($params{secret}) if !$params{base32};
+ $params{base32} = 1;
+
+ my $otp = eval {Pass::OTP::otp(%params, @_) };
+ if (my $err = $@) {
+ throw 'Unable to generate TOTP', error => $err;
+ }
+
+ return $otp;
+}
+
+=method hmac_otp_uri
+
+=method time_otp_uri
+
+ $uri_string = $entry->hmac_otp_uri;
+ $uri_string = $entry->time_otp_uri;
+
+Get a HOTP or TOTP otpauth URI for the entry, if available.
+
+To configure OTP, see L</"One-time Passwords">.
+
+=cut
+
+sub hmac_otp_uri { $_[0]->_otp_uri($_[0]->_hotp_params) }
+sub time_otp_uri { $_[0]->_otp_uri($_[0]->_totp_params) }
+
+sub _otp_uri {
+ my $self = shift;
+ my %params = @_;
+
+ return if 4 != grep { defined } @params{qw(type secret issuer account)};
+ return if $params{type} !~ /^[ht]otp$/i;
+
+ my $label = delete $params{label};
+ $params{$_} = uri_escape_utf8($params{$_}) for keys %params;
+
+ my $type = lc($params{type});
+ my $issuer = $params{issuer};
+ my $account = $params{account};
+
+ $label //= "$issuer:$account";
+
+ my $secret = $params{secret};
+ $secret = uc(encode_b32r($secret)) if !$params{base32};
+
+ delete $params{algorithm} if defined $params{algorithm} && $params{algorithm} eq 'sha1';
+ delete $params{period} if defined $params{period} && $params{period} == 30;
+ delete $params{digits} if defined $params{digits} && $params{digits} == 6;
+ delete $params{counter} if defined $params{counter} && $params{counter} == 0;
+
+ my $uri = "otpauth://$type/$label?secret=$secret&issuer=$issuer";
+
+ if (defined $params{encoder}) {
+ $uri .= "&encoder=$params{encoder}";
+ return $uri;
+ }
+ $uri .= '&algorithm=' . uc($params{algorithm}) if defined $params{algorithm};
+ $uri .= "&digits=$params{digits}" if defined $params{digits};
+ $uri .= "&counter=$params{counter}" if defined $params{counter};
+ $uri .= "&period=$params{period}" if defined $params{period};
+
+ return $uri;
+}
+
+sub _hotp_params {
+ my $self = shift;
+
+ my %params = (
+ type => 'hotp',
+ issuer => $self->title || 'KDBX',
+ account => $self->username || 'none',
+ digits => 6,
+ counter => $self->string_value('HmacOtp-Counter') // 0,
+ $self->_otp_secret_params('Hmac'),
+ );
+ return %params if $params{secret};
+
+ my %otp_params = $self->_otp_params;
+ return () if !$otp_params{secret} || $otp_params{type} ne 'hotp';
+
+ # $otp_params{counter} = 0
+
+ return (%params, %otp_params);
+}
+
+sub _totp_params {
+ my $self = shift;
+
+ my %algorithms = (
+ 'HMAC-SHA-1' => 'sha1',
+ 'HMAC-SHA-256' => 'sha256',
+ 'HMAC-SHA-512' => 'sha512',
+ );
+ my %params = (
+ type => 'totp',
+ issuer => $self->title || 'KDBX',
+ account => $self->username || 'none',
+ digits => $self->string_value('TimeOtp-Length') // 6,
+ algorithm => $algorithms{$self->string_value('TimeOtp-Algorithm') || ''} || 'sha1',
+ period => $self->string_value('TimeOtp-Period') // 30,
+ $self->_otp_secret_params('Time'),
+ );
+ return %params if $params{secret};
+
+ my %otp_params = $self->_otp_params;
+ return () if !$otp_params{secret} || $otp_params{type} ne 'totp';
+
+ return (%params, %otp_params);
+}
+
+# KeePassXC style
+sub _otp_params {
+ my $self = shift;
+ load_optional('Pass::OTP::URI');
+
+ my $uri = $self->string_value('otp') || '';
+ my %params;
+ %params = Pass::OTP::URI::parse($uri) if $uri =~ m!^otpauth://!;
+ return () if !$params{secret} || !$params{type};
+
+ if (($params{encoder} // '') eq 'steam') {
+ $params{digits} = 5;
+ $params{chars} = '23456789BCDFGHJKMNPQRTVWXY';
+ }
+
+ # Pass::OTP::URI doesn't provide the issuer and account separately, so get them from the label
+ my ($issuer, $user) = split(':', $params{label} // ':', 2);
+ $params{issuer} //= uri_unescape_utf8($issuer);
+ $params{account} //= uri_unescape_utf8($user);
+
+ $params{algorithm} = lc($params{algorithm}) if $params{algorithm};
+ $params{counter} = $self->string_value('HmacOtp-Counter') if $params{type} eq 'hotp';
+
+ return %params;
+}
+
+sub _otp_secret_params {
+ my $self = shift;
+ my $type = shift // return ();
+
+ my $secret_txt = $self->string_value("${type}Otp-Secret");
+ my $secret_hex = $self->string_value("${type}Otp-Secret-Hex");
+ my $secret_b32 = $self->string_value("${type}Otp-Secret-Base32");
+ my $secret_b64 = $self->string_value("${type}Otp-Secret-Base64");
+
+ my $count = grep { defined } ($secret_txt, $secret_hex, $secret_b32, $secret_b64);
+ return () if $count == 0;
+ alert "Found multiple ${type}Otp-Secret strings", count => $count if 1 < $count;
+
+ return (secret => $secret_b32, base32 => 1) if defined $secret_b32;
+ return (secret => decode_b64($secret_b64)) if defined $secret_b64;
+ return (secret => pack('H*', $secret_hex)) if defined $secret_hex;
+ return (secret => encode('UTF-8', $secret_txt));
+}
+
+sub _hotp_increment_counter {
+ my $self = shift;
+ my $counter = shift // $self->string_value('HmacOtp-Counter') || 0;
+
+ looks_like_number($counter) or throw 'HmacOtp-Counter value must be a number', value => $counter;
+ my $next = $counter + 1;
+ $self->string('HmacOtp-Counter', $next);
+ return $next;
+}
+
+##############################################################################
+
+=method size
+
+ $size = $entry->size;
+
+Get the size (in bytes) of an entry.
+
+B<NOTE:> This is not an exact figure because there is no canonical serialization of an entry. This size should
+only be used as a rough estimate for comparison with other entries or to impose data size limitations.
+
+=cut
+
+sub size {
+ my $self = shift;
+
+ my $size = 0;
+
+ # tags
+ $size += length(encode('UTF-8', $self->tags // ''));
+
+ # attributes (strings)
+ while (my ($key, $string) = each %{$self->strings}) {
+ next if !defined $string->{value};
+ $size += length(encode('UTF-8', $key)) + length(encode('UTF-8', $string->{value} // ''));
+ }
+
+ # custom data
+ while (my ($key, $item) = each %{$self->custom_data}) {
+ next if !defined $item->{value};
+ $size += length(encode('UTF-8', $key)) + length(encode('UTF-8', $item->{value} // ''));
+ }
+
+ # binaries
+ while (my ($key, $binary) = each %{$self->binaries}) {
+ next if !defined $binary->{value};
+ my $value_len = utf8::is_utf8($binary->{value}) ? length(encode('UTF-8', $binary->{value}))
+ : length($binary->{value});
+ $size += length(encode('UTF-8', $key)) + $value_len;
+ }
+
+ # autotype associations
+ for my $association (@{$self->auto_type->{associations} || []}) {
+ $size += length(encode('UTF-8', $association->{window}))
+ + length(encode('UTF-8', $association->{keystroke_sequence} // ''));
+ }
+
+ return $size;
+}
+
+##############################################################################
+
+sub history {
+ my $self = shift;
+ return [map { __PACKAGE__->wrap($_, $self->kdbx) } @{$self->{history} || []}];
+}
+
+=method history_size
+
+ $size = $entry->history_size;
+
+Get the size (in bytes) of all historical entries combined.
+
+=cut
+
+sub history_size {
+ my $self = shift;
+ return sum0 map { $_->size } @{$self->history};
+}
+
+=method prune_history
+
+ $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>:
+
+=for :list
+* C<max_items> - Maximum number of historical entries to keep (default: 10, no limit: -1)
+* C<max_size> - Maximum total size (in bytes) of historical entries to keep (default: 6 MiB, no limit: -1)
+
+=cut
+
+sub prune_history {
+ my $self = shift;
+ my %args = @_;
+
+ my $max_items = $args{max_items} // eval { $self->kdbx->history_max_items }
+ // HISTORY_DEFAULT_MAX_ITEMS;
+ my $max_size = $args{max_size} // eval { $self->kdbx->history_max_size }
+ // HISTORY_DEFAULT_MAX_SIZE;
+
+ # history is ordered oldest to youngest
+ my $history = $self->history;
+
+ if (0 <= $max_items && $max_items < @$history) {
+ splice @$history, -$max_items;
+ }
+
+ if (0 <= $max_size) {
+ my $current_size = $self->history_size;
+ while ($max_size < $current_size) {
+ my $entry = shift @$history;
+ $current_size -= $entry->size;
+ }
+ }
+}
+
+sub add_history {
+ my $self = shift;
+ delete $_->{history} for @_;
+ push @{$self->{history} //= []}, @_;
+}
+
+##############################################################################
+
+sub begin_work {
+ my $self = shift;
+ require File::KDBX::Transaction;
+ return File::KDBX::Transaction->new($self, @_);
+}
+
+sub _commit {
+ my $self = shift;
+ my $txn = shift;
+ $self->add_history($txn->original);
+ $self->last_modification_time(gmtime);
+}
+
+sub TO_JSON { +{%{$_[0]}} }
+
+1;
+__END__
+
+=head1 DESCRIPTION
+
+An entry in a KDBX database is a record that can contains strings (also called "fields") and binaries (also
+called "files" or "attachments"). Every string and binary has a key or name. There is a default set of strings
+that every entry has:
+
+=for :list
+* C<Title>
+* C<UserName>
+* C<Password>
+* C<URL>
+* C<Notes>
+
+Beyond this, you can store any number of other strings and any number of binaries that you can use for
+whatever purpose you want.
+
+There is also some metadata associated with an entry. Each entry in a database is identified uniquely by
+a UUID. An entry can also have an icon associated with it, and there are various timestamps. Take a look at
+the attributes to see what's available.
+
+=head2 Placeholders
+
+Entry strings 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}>.
+
+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.
+
+=head3 Entry Placeholders
+
+=for :list
+* ☑ C<{TITLE}> - B<Title> string
+* ☑ C<{USERNAME}> - B<UserName> string
+* ☑ C<{PASSWORD}> - B<Password> string
+* ☑ C<{NOTES}> - B<Notes> string
+* ☑ C<{URL}> - B<URL> string
+* ☑ C<{URL:SCM}> / C<{URL:SCHEME}>
+* ☑ C<{URL:USERINFO}>
+* ☑ C<{URL:USERNAME}>
+* ☑ C<{URL:PASSWORD}>
+* ☑ C<{URL:HOST}>
+* ☑ C<{URL:PORT}>
+* ☑ C<{URL:PATH}>
+* ☑ C<{URL:QUERY}>
+* ☑ C<{URL:FRAGMENT}> / C<{URL:HASH}>
+* ☑ 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<{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
+* ☑ C<{GROUP}> - Name of the parent group
+
+=head3 Field References
+
+=for :list
+* ☑ C<{REF:Wanted@SearchIn:Text}> - See L<File::KDBX/resolve_reference>
+
+=head3 File path Placeholders
+
+=for :list
+* ☑ C<{APPDIR}> - Program directory path
+* ☑ C<{FIREFOX}> - Path to the Firefox browser executable
+* ☑ C<{GOOGLECHROME}> - Path to the Chrome browser executable
+* ☑ C<{INTERNETEXPLORER}> - Path to the Firefox browser executable
+* ☑ C<{OPERA}> - Path to the Opera browser executable
+* ☑ C<{SAFARI}> - Path to the Safari browser executable
+* ☒ C<{DB_PATH}> - Full file path of the database
+* ☒ C<{DB_DIR}> - Directory path of the database
+* ☒ C<{DB_NAME}> - File name (including extension) of the database
+* ☒ C<{DB_BASENAME}> - File name (excluding extension) of the database
+* ☒ C<{DB_EXT}> - File name extension
+* ☑ C<{ENV_DIRSEP}> - Directory separator
+* ☑ C<{ENV_PROGRAMFILES_X86}> - One of C<%ProgramFiles(x86)%> or C<%ProgramFiles%>
+
+=head3 Date and Time Placeholders
+
+=for :list
+* ☑ C<{DT_SIMPLE}> - Current local date and time as a sortable string
+* ☑ C<{DT_YEAR}> - Year component of the current local date
+* ☑ C<{DT_MONTH}> - Month component of the current local date
+* ☑ C<{DT_DAY}> - Day component of the current local date
+* ☑ C<{DT_HOUR}> - Hour component of the current local time
+* ☑ C<{DT_MINUTE}> - Minute component of the current local time
+* ☑ C<{DT_SECOND}> - Second component of the current local time
+* ☑ C<{DT_UTC_SIMPLE}> - Current UTC date and time as a sortable string
+* ☑ C<{DT_UTC_YEAR}> - Year component of the current UTC date
+* ☑ C<{DT_UTC_MONTH}> - Month component of the current UTC date
+* ☑ C<{DT_UTC_DAY}> - Day component of the current UTC date
+* ☑ C<{DT_UTC_HOUR}> - Hour component of the current UTC time
+* ☑ C<{DT_UTC_MINUTE}> Minute Year component of the current UTC time
+* ☑ C<{DT_UTC_SECOND}> - Second component of the current UTC time
+
+If the current date and time is <2012-07-25 17:05:34>, the "simple" form would be C<20120725170534>.
+
+=head3 Special Key Placeholders
+
+Certain placeholders for use in auto-type key sequences are not supported for replacement, but they will
+remain as-is so that an auto-type engine (not included) can parse and replace them with the appropriate
+virtual key presses. For completeness, here is the list that the KeePass program claims to support:
+
+C<{TAB}>, C<{ENTER}>, C<{UP}>, C<{DOWN}>, C<{LEFT}>, C<{RIGHT}>, C<{HOME}>, C<{END}>, C<{PGUP}>, C<{PGDN}>,
+C<{INSERT}>, C<{DELETE}>, C<{SPACE}>
+
+C<{BACKSPACE}>, C<{BREAK}>, C<{CAPSLOCK}>, C<{ESC}>, C<{WIN}>, C<{LWIN}>, C<{RWIN}>, C<{APPS}>, C<{HELP}>,
+C<{NUMLOCK}>, C<{PRTSC}>, C<{SCROLLLOCK}>
+
+C<{F1}>, C<{F2}>, C<{F3}>, C<{F4}>, C<{F5}>, C<{F6}>, C<{F7}>, C<{F8}>, C<{F9}>, C<{F10}>, C<{F11}>, C<{F12}>,
+C<{F13}>, C<{F14}>, C<{F15}>, C<{F16}>
+
+C<{ADD}>, C<{SUBTRACT}>, C<{MULTIPLY}>, C<{DIVIDE}>, C<{NUMPAD0}>, C<{NUMPAD1}>, C<{NUMPAD2}>, C<{NUMPAD3}>,
+C<{NUMPAD4}>, C<{NUMPAD5}>, C<{NUMPAD6}>, C<{NUMPAD7}>, C<{NUMPAD8}>, C<{NUMPAD9}>
+
+=head3 Miscellaneous Placeholders
+
+=for :list
+* ☒ C<{BASE}>
+* ☒ C<{BASE:SCM}> / C<{BASE:SCHEME}>
+* ☒ C<{BASE:USERINFO}>
+* ☒ C<{BASE:USERNAME}>
+* ☒ C<{BASE:PASSWORD}>
+* ☒ C<{BASE:HOST}>
+* ☒ C<{BASE:PORT}>
+* ☒ C<{BASE:PATH}>
+* ☒ C<{BASE:QUERY}>
+* ☒ C<{BASE:FRAGMENT}> / C<{BASE:HASH}>
+* ☒ C<{BASE:RMVSCM}> / C<{BASE:WITHOUTSCHEME}>
+* ☒ C<{CLIPBOARD-SET:/Text/}>
+* ☒ C<{CLIPBOARD}>
+* ☒ C<{CMD:/CommandLine/Options/}>
+* ☑ C<{C:Comment}> - Comments are simply replaced by nothing
+* ☑ C<{ENV:} and C<%ENV%> - Environment variables
+* ☒ C<{GROUP_SEL_NOTES}>
+* ☒ C<{GROUP_SEL_PATH}>
+* ☒ C<{GROUP_SEL}>
+* ☒ C<{NEWPASSWORD}>
+* ☒ C<{NEWPASSWORD:/Profile/}>
+* ☒ C<{PASSWORD_ENC}>
+* ☒ C<{PICKCHARS}>
+* ☒ C<{PICKCHARS:Field:Options}>
+* ☒ C<{PICKFIELD}>
+* ☒ C<{T-CONV:/Text/Type/}>
+* ☒ C<{T-REPLACE-RX:/Text/Type/Replace/}>
+
+Some of these that remain unimplemented, such as C<{CLIPBOARD}>, cannot be implemented portably. Some of these
+I haven't implemented (yet) just because they don't seem very useful. You can create your own placeholder to
+augment the list of default supported placeholders or to replace a built-in placeholder handler. To create
+a placeholder, just set it in the C<%File::KDBX::PLACEHOLDERS> hash. For example:
+
+ $File::KDBX::PLACEHOLDERS{'MY_PLACEHOLDER'} = sub {
+ my ($entry) = @_;
+ ...;
+ };
+
+If the placeholder is expanded in the context of an entry, C<$entry> is the B<File::KDBX::Entry> object in
+context. Otherwise it is C<undef>. An entry is in context if, for example, the placeholder is in an entry's
+strings or auto-complete key sequences.
+
+ $File::KDBX::PLACEHOLDERS{'MY_PLACEHOLDER:'} = sub {
+ my ($entry, $arg) = @_; # ^ Notice the colon here
+ ...;
+ };
+
+If the name of the placeholder ends in a colon, then it is expected to receive an argument. During expansion,
+everything after the colon and before the end of the placeholder is passed to your placeholder handler
+subroutine. So if the placeholder is C<{MY_PLACEHOLDER:whatever}>, C<$arg> will have the value C<whatever>.
+
+An argument is required for placeholders than take one. I.e. The placeholder handler won't be called if there
+is no argument. If you want a placeholder to support an optional argument, you'll need to set the placeholder
+both with and without a colon (or they could be different subroutines):
+
+ $File::KDBX::PLACEHOLDERS{'RAND'} = $File::KDBX::PLACEHOLDERS{'RAND:'} = sub {
+ (undef, my $arg) = @_;
+ return defined $arg ? rand($arg) : rand;
+ };
+
+You can also remove placeholder handlers. If you want to disable placeholder expansion entirely, just delete
+all the handlers:
+
+ %File::KDBX::PLACEHOLDERS = ();
+
+=head2 One-time Passwords
+
+An entry can be configured to generate one-time passwords, both HOTP (HMAC-based) and TOTP (time-based). The
+configuration storage isn't completely standardized, but this module supports two predominant configuration
+styles:
+
+=for :list
+* L<KeePass 2|https://keepass.info/help/base/placeholders.html#otp>
+* KeePassXC
+
+B<NOTE:> To use this feature, you must install the suggested dependency:
+
+=for :list
+* L<Pass::OTP>
+
+To configure TOTP in the KeePassXC style, there is only one string to set: C<otp>. The value should be any
+valid otpauth URI. When generating an OTP, all of the relevant OTP properties are parsed from the URI.
+
+To configure TOTP in the KeePass 2 style, set the following strings:
+
+=for :list
+* C<TimeOtp-Algorithm> - Cryptographic algorithm, one of C<HMAC-SHA-1> (default), C<HMAC-SHA-256> and
+ C<HMAC-SHA-512>
+* C<TimeOtp-Length> - Number of digits each one-time password is (default: 6, maximum: 8)
+* C<TimeOtp-Period> - Time-step size in seconds (default: 30)
+* C<TimeOtp-Secret> - Text string secret, OR
+* C<TimeOtp-Secret-Hex> - Hexidecimal-encoded secret, OR
+* C<TimeOtp-Secret-Base32> - Base32-encoded secret (most common), OR
+* C<TimeOtp-Secret-Base64> - Base64-encoded secret
+
+To configure HOTP in the KeePass 2 style, set the following strings:
+
+=for :list
+* C<HmacOtp-Counter> - Counting value in decimal, starts on C<0> by default and increments when L</hmac_otp>
+ is called
+* C<HmacOtp-Secret> - Text string secret, OR
+* C<HmacOtp-Secret-Hex> - Hexidecimal-encoded secret, OR
+* C<HmacOtp-Secret-Base32> - Base32-encoded secret (most common), OR
+* C<HmacOtp-Secret-Base64> - Base64-encoded secret
+
+B<NOTE:> The multiple "Secret" strings are simply a way to store a secret in different formats. Only one of
+these should actually be set or an error will be thrown.
+
+Here's a basic example:
+
+ $entry->string(otp => 'otpauth://totp/Issuer:user?secret=NBSWY3DP&issuer=Issuer');
+ # OR
+ $entry->string('TimeOtp-Secret-Base32' => 'NBSWY3DP');
+
+ my $otp = $entry->time_otp;
+
+=cut
--- /dev/null
+package File::KDBX::Error;
+# ABSTRACT: Represents something bad that happened
+
+use warnings;
+use strict;
+
+use Exporter qw(import);
+use Scalar::Util qw(blessed);
+use namespace::clean -except => 'import';
+
+our $VERSION = '999.999'; # VERSION
+
+our @EXPORT = qw(alert error throw);
+
+my $WARNINGS_CATEGORY;
+BEGIN {
+ $WARNINGS_CATEGORY = 'File::KDBX';
+ warnings::register_categories($WARNINGS_CATEGORY) if warnings->can('register_categories');
+}
+
+use overload '""' => 'to_string', cmp => '_cmp';
+
+=method new
+
+ $error = File::KDBX::Error->new($message, %details);
+
+Construct a new error.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my %args = @_ % 2 == 0 ? @_ : (_error => shift, @_);
+
+ my $error = delete $args{_error};
+ my $e = $error;
+ # $e =~ s/ at \H+ line \d+.*//g;
+
+ my $self = bless {
+ details => \%args,
+ error => $e // 'Something happened',
+ errno => $!,
+ previous => $@,
+ trace => do {
+ require Carp;
+ local $Carp::CarpInternal{''.__PACKAGE__} = 1;
+ my $mess = $error =~ /at \H+ line \d+/ ? $error : Carp::longmess($error);
+ [map { /^\h*(.*?)\.?$/ ? $1 : $_ } split(/\n/, $mess)];
+ },
+ }, $class;
+ chomp $self->{error};
+ return $self;
+}
+
+=method error
+
+ $error = error($error);
+ $error = error($message, %details);
+ $error = File::KDBX::Error->error($error);
+ $error = File::KDBX::Error->error($message, %details);
+
+Wrap a thing to make it an error object. If the thing is already an error, it gets returned. Otherwise what is
+passed will be forwarded to L</new> to create a new error object.
+
+This can be convenient for error handling when you're not sure what the exception is but you want to treat it
+as a B<File::KDBX::Error>. Example:
+
+ eval { .... };
+ if (my $error = error(@_)) {
+ if ($error->type eq 'key.missing') {
+ handle_missing_key($error);
+ }
+ else {
+ handle_other_error($error);
+ }
+ }
+
+=cut
+
+sub error {
+ my $self = (blessed($_[0]) && $_[0]->isa('File::KDBX::Error'))
+ ? shift
+ : (@_ && $_[0] eq __PACKAGE__)
+ ? shift->new(@_)
+ : __PACKAGE__->new(@_);
+ return $self;
+}
+
+=attr details
+
+ \%details = $error->details;
+
+Get the error details.
+
+=cut
+
+sub details {
+ my $self = shift;
+ my %args = @_;
+ my $details = $self->{details} //= {};
+ @$details{keys %args} = values %args;
+ return $details;
+}
+
+sub errno { $_[0]->{errno} }
+
+sub previous { $_[0]->{previous} }
+
+sub trace { $_[0]->{trace} // [] }
+
+sub type { $_[0]->details->{type} // '' }
+
+=method to_string
+
+ $message = $error->to_string;
+ $message = "$error";
+
+Stringify an error.
+
+This does not contain a stack trace, but you can set the C<DEBUG> environment
+variable to truthy to stringify the whole error object.
+
+=cut
+
+sub _cmp { "$_[0]" cmp "$_[1]" }
+
+sub PROPAGATE {
+ 'wat';
+}
+
+sub to_string {
+ my $self = shift;
+ # return "uh oh\n";
+ my $msg = "$self->{trace}[0]";
+ $msg .= '.' if $msg !~ /[\.\!\?]$/; # Why does this cause infinite recursion on some perls?
+ # $msg .= '.' if $msg !~ /(?:\.|!|\?)$/;
+ if ($ENV{DEBUG}) {
+ require Data::Dumper;
+ local $Data::Dumper::Indent = 1;
+ local $Data::Dumper::Quotekeys = 0;
+ local $Data::Dumper::Sortkeys = 1;
+ local $Data::Dumper::Terse = 1;
+ local $Data::Dumper::Trailingcomma = 1;
+ local $Data::Dumper::Useqq = 1;
+ $msg .= "\n" . Data::Dumper::Dumper $self;
+ }
+ $msg .= "\n" if $msg !~ /\n$/;
+ return $msg;
+}
+
+=method throw
+
+ File::KDBX::Error::throw($message, %details);
+ $error->throw;
+
+Throw an error.
+
+=cut
+
+sub throw {
+ my $self = error(@_);
+ die $self;
+}
+
+=method warn
+
+ File::KDBX::Error::warn($message, %details);
+ $error->warn;
+
+Log a warning.
+
+=cut
+
+sub warn {
+ return if !($File::KDBX::WARNINGS // 1);
+
+ my $self = error(@_);
+
+ # Use die and warn directly instead of warnings::warnif because the latter only provides the stringified
+ # error to the warning signal handler (perl 5.34). Maybe that's a warnings.pm bug?
+
+ if (my $fatal = warnings->can('fatal_enabled_at_level')) {
+ my $blame = _find_blame_frame();
+ die $self if $fatal->($WARNINGS_CATEGORY, $blame);
+ }
+
+ if (my $enabled = warnings->can('enabled_at_level')) {
+ my $blame = _find_blame_frame();
+ warn $self if $enabled->($WARNINGS_CATEGORY, $blame);
+ }
+ elsif ($enabled = warnings->can('enabled')) {
+ warn $self if $enabled->($WARNINGS_CATEGORY);
+ }
+ else {
+ warn $self;
+ }
+ return $self;
+}
+
+=method alert
+
+ alert $error;
+
+Importable alias for L</warn>.
+
+=cut
+
+sub alert { goto &warn }
+
+sub _find_blame_frame {
+ my $frame = 1;
+ while (1) {
+ my ($package) = caller($frame);
+ last if !$package;
+ return $frame - 1 if $package !~ /^\Q$WARNINGS_CATEGORY\E/;
+ $frame++;
+ }
+ return 0;
+}
+
+1;
--- /dev/null
+package File::KDBX::Group;
+# ABSTRACT: A KDBX database group
+
+use warnings;
+use strict;
+
+use Devel::GlobalDestruction;
+use File::KDBX::Constants qw(:icon);
+use File::KDBX::Error;
+use File::KDBX::Util qw(generate_uuid);
+use List::Util qw(sum0);
+use Ref::Util qw(is_ref);
+use Scalar::Util qw(blessed);
+use Time::Piece;
+use boolean;
+use namespace::clean;
+
+use parent 'File::KDBX::Object';
+
+our $VERSION = '999.999'; # VERSION
+
+my @ATTRS = qw(uuid custom_data entries groups);
+my %ATTRS = (
+ # uuid => sub { generate_uuid(printable => 1) },
+ name => '',
+ notes => '',
+ tags => '',
+ icon_id => ICON_FOLDER,
+ custom_icon_uuid => undef,
+ is_expanded => false,
+ default_auto_type_sequence => '',
+ enable_auto_type => undef,
+ enable_searching => undef,
+ last_top_visible_entry => undef,
+ # custom_data => sub { +{} },
+ previous_parent_group => undef,
+ # entries => sub { +[] },
+ # groups => sub { +[] },
+);
+my %ATTRS_TIMES = (
+ last_modification_time => sub { gmtime },
+ creation_time => sub { gmtime },
+ last_access_time => sub { gmtime },
+ expiry_time => sub { gmtime },
+ expires => false,
+ usage_count => 0,
+ location_changed => sub { gmtime },
+);
+
+while (my ($attr, $default) = each %ATTRS) {
+ no strict 'refs'; ## no critic (ProhibitNoStrict)
+ *{$attr} = sub {
+ my $self = shift;
+ $self->{$attr} = shift if @_;
+ $self->{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default;
+ };
+}
+while (my ($attr, $default) = each %ATTRS_TIMES) {
+ no strict 'refs'; ## no critic (ProhibitNoStrict)
+ *{$attr} = sub {
+ my $self = shift;
+ $self->{times}{$attr} = shift if @_;
+ $self->{times}{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default;
+ };
+}
+
+sub _set_default_attributes {
+ my $self = shift;
+ $self->$_ for @ATTRS, keys %ATTRS, keys %ATTRS_TIMES;
+}
+
+sub uuid {
+ my $self = shift;
+ if (@_ || !defined $self->{uuid}) {
+ my %args = @_ % 2 == 1 ? (uuid => shift, @_) : @_;
+ my $old_uuid = $self->{uuid};
+ my $uuid = $self->{uuid} = delete $args{uuid} // generate_uuid;
+ # if (defined $old_uuid and my $kdbx = $KDBX{refaddr($self)}) {
+ # $kdbx->_update_group_uuid($old_uuid, $uuid, $self);
+ # }
+ }
+ $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;
+ return $entries;
+}
+
+sub groups {
+ my $self = shift;
+ my $groups = $self->{groups} //= [];
+ @$groups = map { File::KDBX::Group->wrap($_, $self->kdbx) } @$groups;
+ return $groups;
+}
+
+sub _kpx_groups { shift->groups(@_) }
+
+sub all_groups {
+ my $self = shift;
+ return $self->kdbx->all_groups(base => $self, include_base => false);
+}
+
+sub all_entries {
+ my $self = shift;
+ return $self->kdbx->all_entries(base => $self);
+}
+
+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 add_entry {
+ my $self = shift;
+ my $entry = shift;
+ push @{$self->{entries} ||= []}, $entry;
+ return $entry;
+}
+
+sub add_group {
+ my $self = shift;
+ my $group = shift;
+ push @{$self->{groups} ||= []}, $group;
+ return $group;
+}
+
+sub add_object {
+ my $self = shift;
+ my $obj = shift;
+ if ($obj->isa('File::KDBX::Entry')) {
+ $self->add_entry($obj);
+ }
+ elsif ($obj->isa('File::KDBX::Group')) {
+ $self->add_group($obj);
+ }
+}
+
+sub remove_object {
+ my $self = shift;
+ my $object = shift;
+ my $blessed = blessed($object);
+ return $self->remove_group($object, @_) if $blessed && $object->isa('File::KDBX::Group');
+ return $self->remove_entry($object, @_) if $blessed && $object->isa('File::KDBX::Entry');
+ 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 {
+ 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;
+ }
+}
+
+sub path {
+ my $self = shift;
+ my $lineage = $self->kdbx->trace_lineage($self) or return;
+ return join('.', map { $_->name } @$lineage);
+}
+
+sub size {
+ my $self = shift;
+ return sum0 map { $_->size } @{$self->groups}, @{$self->entries};
+}
+
+sub level { $_[0]->kdbx->group_level($_[0]) }
+
+sub TO_JSON { +{%{$_[0]}} }
+
+1;
+__END__
+
+=head1 DESCRIPTION
+
+=attr uuid
+
+=attr name
+
+=attr notes
+
+=attr tags
+
+=attr icon_id
+
+=attr custom_icon_uuid
+
+=attr is_expanded
+
+=attr default_auto_type_sequence
+
+=attr enable_auto_type
+
+=attr enable_searching
+
+=attr last_top_visible_entry
+
+=attr custom_data
+
+=attr previous_parent_group
+
+=attr entries
+
+=attr groups
+
+=attr last_modification_time
+
+=attr creation_time
+
+=attr last_access_time
+
+=attr expiry_time
+
+=attr expires
+
+=attr usage_count
+
+=attr location_changed
+
+Get or set various group fields.
+
+=cut
--- /dev/null
+package File::KDBX::KDF;
+# ABSTRACT: A key derivation function
+
+use warnings;
+use strict;
+
+use Crypt::PRNG qw(random_bytes);
+use File::KDBX::Constants qw(:version :kdf);
+use File::KDBX::Error;
+use File::KDBX::Util qw(format_uuid);
+use Module::Load;
+use Scalar::Util qw(blessed);
+use namespace::clean;
+
+our $VERSION = '999.999'; # VERSION
+
+my %KDFS;
+
+=method new
+
+ $kdf = File::KDBX::KDF->new(parameters => \%params);
+
+Construct a new KDF.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my %args = @_;
+
+ my $uuid = $args{+KDF_PARAM_UUID} //= delete $args{uuid} or throw 'Missing KDF UUID', args => \%args;
+ my $formatted_uuid = format_uuid($uuid);
+
+ my $kdf = $KDFS{$uuid} or throw "Unsupported KDF ($formatted_uuid)", uuid => $uuid;
+ ($class, my %registration_args) = @$kdf;
+
+ load $class;
+ my $self = bless {KDF_PARAM_UUID() => $uuid}, $class;
+ return $self->init(%args, %registration_args);
+}
+
+sub init {
+ my $self = shift;
+ my %args = @_;
+
+ @$self{keys %args} = values %args;
+
+ return $self;
+}
+
+=attr uuid
+
+ $uuid => $kdf->uuid;
+
+Get the UUID used to determine which function to use.
+
+=cut
+
+sub uuid { $_[0]->{+KDF_PARAM_UUID} }
+
+=attr seed
+
+ $seed = $kdf->seed;
+
+Get the seed (or salt, depending on the function).
+
+=cut
+
+sub seed { die "Not implemented" }
+
+=method transform
+
+ $transformed_key = $kdf->transform($key);
+ $transformed_key = $kdf->transform($key, $challenge);
+
+Transform a key. The input key can be either a L<File::KDBX::Key> or a raw binary key, and the
+transformed key will be a raw key.
+
+This can take awhile, depending on the KDF parameters.
+
+If a challenge is provided (and the KDF is AES except for the KeePassXC variant), it will be passed to the key
+so challenge-response keys can produce raw keys. See L<File::KDBX::Key/raw_key>.
+
+=cut
+
+sub transform {
+ my $self = shift;
+ my $key = shift;
+
+ if (blessed $key && $key->can('raw_key')) {
+ return $self->_transform($key->raw_key) if $self->uuid eq KDF_UUID_AES;
+ return $self->_transform($key->raw_key($self->seed, @_));
+ }
+
+ return $self->_transform($key);
+}
+
+sub _transform { die "Not implemented" }
+
+=method randomize_seed
+
+ $kdf->randomize_seed;
+
+Generate a new random seed/salt.
+
+=cut
+
+sub randomize_seed {
+ my $self = shift;
+ $self->{+KDF_PARAM_AES_SEED} = random_bytes(length($self->seed));
+}
+
+=method register
+
+ File::KDBX::KDF->register($uuid => $package, %args);
+
+Register a KDF. Registered KDFs can be used to encrypt and decrypt KDBX databases. A KDF's UUID B<must> be
+unique and B<musn't change>. A KDF UUID is written into each KDBX file and the associated KDF must be
+registered with the same UUID in order to decrypt the KDBX file.
+
+C<$package> should be a Perl package relative to C<File::KDBX::KDF::> or prefixed with a C<+> if it is
+a fully-qualified package. C<%args> are passed as-is to the KDF's L</init> method.
+
+=cut
+
+sub register {
+ my $class = shift;
+ my $id = shift;
+ my $package = shift;
+ my @args = @_;
+
+ my $formatted_id = format_uuid($id);
+ $package = "${class}::${package}" if $package !~ s/^\+// && $package !~ /^\Q${class}::\E/;
+
+ my %blacklist = map { File::KDBX::Util::uuid($_) => 1 } split(/,/, $ENV{FILE_KDBX_KDF_BLACKLIST} // '');
+ if ($blacklist{$id} || $blacklist{$package}) {
+ alert "Ignoring blacklisted KDF ($formatted_id)", id => $id, package => $package;
+ return;
+ }
+
+ if (defined $KDFS{$id}) {
+ alert "Overriding already-registered KDF ($formatted_id) with package $package",
+ id => $id,
+ package => $package;
+ }
+
+ $KDFS{$id} = [$package, @args];
+}
+
+=method unregister
+
+ File::KDBX::KDF->unregister($uuid);
+
+Unregister a KDF. Unregistered KDFs can no longer be used to encrypt and decrypt KDBX databases, until
+reregistered (see L</register>).
+
+=cut
+
+sub unregister {
+ delete $KDFS{$_} for @_;
+}
+
+BEGIN {
+ __PACKAGE__->register(KDF_UUID_AES, 'AES');
+ __PACKAGE__->register(KDF_UUID_AES_CHALLENGE_RESPONSE, 'AES');
+ __PACKAGE__->register(KDF_UUID_ARGON2D, 'Argon2');
+ __PACKAGE__->register(KDF_UUID_ARGON2ID, 'Argon2');
+}
+
+1;
+__END__
+
+=head1 DESCRIPTION
+
+A KDF (key derivation function) is used in the transformation of a master key (i.e. one or more component
+keys) to produce the final encryption key protecting a KDBX database. The L<File::KDBX> distribution comes
+with several pre-registered KDFs ready to go:
+
+=for :list
+* C<C9D9F39A-628A-4460-BF74-0D08C18A4FEA> - AES
+* C<7C02BB82-79A7-4AC0-927D-114A00648238> - AES (challenge-response variant)
+* C<EF636DDF-8C29-444B-91F7-A9A403E30A0C> - Argon2d
+* C<9E298B19-56DB-4773-B23D-FC3EC6F0A1E6> - Argon2id
+
+B<NOTE:> If you want your KDBX file to be readable by other KeePass implementations, you must use a UUID and
+algorithm that they support. From the list above, all are well-supported except the AES challenge-response
+variant which is kind of a pseudo KDF and isn't usually written into files. All of these are good. AES has
+a longer track record, but Argon2 has better ASIC resistance.
+
+You can also L</register> your own KDF. Here is a skeleton:
+
+ package File::KDBX::KDF::MyKDF;
+
+ use parent 'File::KDBX::KDF';
+
+ File::KDBX::KDF->register(
+ # $uuid, $package, %args
+ "\x12\x34\x56\x78\x9a\xbc\xde\xfg\x12\x34\x56\x78\x9a\xbc\xde\xfg" => __PACKAGE__,
+ );
+
+ sub init { ... } # optional
+
+ sub _transform { my ($key) = @_; ... }
+
+=cut
--- /dev/null
+package File::KDBX::KDF::AES;
+# ABSTRACT: Using the AES cipher as a key derivation function
+
+use warnings;
+use strict;
+
+use Crypt::Cipher;
+use Crypt::Digest qw(digest_data);
+use File::KDBX::Constants qw(:kdf);
+use File::KDBX::Error;
+use File::KDBX::Util qw(:load can_fork);
+use namespace::clean;
+
+use parent 'File::KDBX::KDF';
+
+our $VERSION = '999.999'; # VERSION
+
+# Rounds higher than this are eligible for forking:
+my $FORK_OPTIMIZATION_THRESHOLD = 100_000;
+
+BEGIN {
+ load_xs;
+
+ my $use_fork = 1;
+ $use_fork = 0 if $ENV{NO_FORK} || !can_fork;
+ *USE_FORK = $use_fork ? sub() { 1 } : sub() { 0 };
+}
+
+sub init {
+ my $self = shift;
+ my %args = @_;
+ return $self->SUPER::init(
+ KDF_PARAM_AES_ROUNDS() => $args{+KDF_PARAM_AES_ROUNDS} // $args{rounds},
+ KDF_PARAM_AES_SEED() => $args{+KDF_PARAM_AES_SEED} // $args{seed},
+ );
+}
+
+=attr rounds
+
+ $rounds = $kdf->rounds;
+
+Get the number of times to run the function during transformation.
+
+=cut
+
+sub rounds { $_[0]->{+KDF_PARAM_AES_ROUNDS} || KDF_DEFAULT_AES_ROUNDS }
+sub seed { $_[0]->{+KDF_PARAM_AES_SEED} }
+
+sub _transform {
+ my $self = shift;
+ my $key = shift;
+
+ my $seed = $self->seed;
+ my $rounds = $self->rounds;
+
+ length($key) == 32 or throw 'Raw key must be 32 bytes', size => length($key);
+ length($seed) == 32 or throw 'Invalid seed length', size => length($seed);
+
+ my ($key_l, $key_r) = unpack('(a16)2', $key);
+
+ 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
+ my $l = _transform_half($seed, $key_l, $rounds);
+ require POSIX;
+ print $l or POSIX::_exit(1);
+ POSIX::_exit(0);
+ }
+ my $r = _transform_half($seed, $key_r, $rounds);
+ read($read, my $l, length($key_l)) == length($key_l) or do { alert "read failed: $!", goto NO_FORK };
+ close($read) or do { alert "worker thread exited abnormally", status => $?; goto NO_FORK };
+ return digest_data('SHA256', $l, $r);
+ }
+
+ # FIXME: This used to work but now it crashes frequently. threads are discouraged anyway
+ # 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);
+ # return digest_data('SHA256', $l->join, $r);
+ # }
+
+ NO_FORK:
+ my $l = _transform_half($seed, $key_l, $rounds);
+ my $r = _transform_half($seed, $key_r, $rounds);
+ return digest_data('SHA256', $l, $r);
+}
+
+sub _transform_half {
+ my $xs = __PACKAGE__->can('_transform_half_xs');
+ goto $xs if $xs;
+
+ my $seed = shift;
+ my $key = shift;
+ my $rounds = shift;
+
+ my $c = Crypt::Cipher->new('AES', $seed);
+
+ my $result = $key;
+ for (my $i = 0; $i < $rounds; ++$i) {
+ $result = $c->encrypt($result);
+ }
+
+ return $result;
+}
+
+1;
+__END__
+
+=head1 DESCRIPTION
+
+An AES-256-based key derivation function. This is a L<File::KDBX::KDF> subclass.
+
+This KDF has a long, solid track record. It is supported in both KDBX3 and KDBX4.
+
+=head1 CAVEATS
+
+This module can be pretty slow when the number of rounds is high. If you have L<File::KDBX::XS>, that will
+help. If your perl has C<fork>, that will also help. If you need to turn off one or both of these
+optimizations for some reason, set the C<PERL_ONLY> (to prevent Loading C<File::KDBX::XS>) and C<NO_FORK>
+environment variables.
+
+=cut
--- /dev/null
+package File::KDBX::KDF::Argon2;
+# ABSTRACT: The Argon2 family of key derivation functions
+
+use warnings;
+use strict;
+
+use Crypt::Argon2 qw(argon2d_raw argon2id_raw);
+use File::KDBX::Constants qw(:kdf);
+use File::KDBX::Error;
+use namespace::clean;
+
+use parent 'File::KDBX::KDF';
+
+our $VERSION = '999.999'; # VERSION
+
+sub init {
+ my $self = shift;
+ my %args = @_;
+ return $self->SUPER::init(
+ KDF_PARAM_ARGON2_SALT() => $args{+KDF_PARAM_ARGON2_SALT} // $args{salt},
+ KDF_PARAM_ARGON2_PARALLELISM() => $args{+KDF_PARAM_ARGON2_PARALLELISM} // $args{parallelism},
+ KDF_PARAM_ARGON2_MEMORY() => $args{+KDF_PARAM_ARGON2_MEMORY} // $args{memory},
+ KDF_PARAM_ARGON2_ITERATIONS() => $args{+KDF_PARAM_ARGON2_ITERATIONS} // $args{iterations},
+ KDF_PARAM_ARGON2_VERSION() => $args{+KDF_PARAM_ARGON2_VERSION} // $args{version},
+ KDF_PARAM_ARGON2_SECRET() => $args{+KDF_PARAM_ARGON2_SECRET} // $args{secret},
+ KDF_PARAM_ARGON2_ASSOCDATA() => $args{+KDF_PARAM_ARGON2_ASSOCDATA} // $args{assocdata},
+ );
+}
+
+=attr salt
+
+=attr parallelism
+
+=attr memory
+
+=attr iterations
+
+=attr version
+
+=attr secret
+
+=attr assocdata
+
+Get various KDF parameters.
+
+C<version>, C<secret> and C<assocdata> are currently unused.
+
+=cut
+
+sub salt { $_[0]->{+KDF_PARAM_ARGON2_SALT} or throw 'Salt is not set' }
+sub parallelism { $_[0]->{+KDF_PARAM_ARGON2_PARALLELISM} //= KDF_DEFAULT_ARGON2_PARALLELISM }
+sub memory { $_[0]->{+KDF_PARAM_ARGON2_MEMORY} //= KDF_DEFAULT_ARGON2_MEMORY }
+sub iterations { $_[0]->{+KDF_PARAM_ARGON2_ITERATIONS} //= KDF_DEFAULT_ARGON2_ITERATIONS }
+sub version { $_[0]->{+KDF_PARAM_ARGON2_VERSION} //= KDF_DEFAULT_ARGON2_VERSION }
+sub secret { $_[0]->{+KDF_PARAM_ARGON2_SECRET} }
+sub assocdata { $_[0]->{+KDF_PARAM_ARGON2_ASSOCDATA} }
+
+sub seed { $_[0]->salt }
+
+sub _transform {
+ my $self = shift;
+ my $key = shift;
+
+ my ($uuid, $salt, $iterations, $memory, $parallelism)
+ = ($self->uuid, $self->salt, $self->iterations, $self->memory, $self->parallelism);
+
+ if ($uuid eq KDF_UUID_ARGON2D) {
+ return argon2d_raw($key, $salt, $iterations, $memory, $parallelism, length($salt));
+ }
+ elsif ($uuid eq KDF_UUID_ARGON2ID) {
+ return argon2id_raw($key, $salt, $iterations, $memory, $parallelism, length($salt));
+ }
+
+ throw 'Unknown Argon2 type', uuid => $uuid;
+}
+
+1;
+__END__
+
+=head1 DESCRIPTION
+
+An Argon2 key derivation function. This is a L<File::KDBX::KDF> subclass.
+
+This KDF allows for excellent resistance to ASIC password cracking. It's a solid choice but doesn't have the
+track record of L<File::KDBX::KDF::AES> and requires using the KDBX4+ file format.
+
+=cut
--- /dev/null
+package File::KDBX::Key;
+# ABSTRACT: A credential that can protect a KDBX file
+
+use warnings;
+use strict;
+
+use Devel::GlobalDestruction;
+use File::KDBX::Error;
+use File::KDBX::Safe;
+use File::KDBX::Util qw(erase);
+use Module::Load;
+use Ref::Util qw(is_arrayref is_coderef is_hashref is_ref is_scalarref);
+use Scalar::Util qw(blessed openhandle refaddr);
+use namespace::clean;
+
+our $VERSION = '999.999'; # VERSION
+
+my %SAFE;
+
+=method new
+
+ $key = File::KDBX::Key->new({ password => $password });
+ $key = File::KDBX::Key->new($password);
+
+ $key = File::KDBX::Key->new({ file => $filepath });
+ $key = File::KDBX::Key->new(\$file);
+ $key = File::KDBX::Key->new(\*FILE);
+
+ $key = File::KDBX::Key->new({ composite => [...] });
+ $key = File::KDBX::Key->new([...]); # composite key
+
+ $key = File::KDBX::Key->new({ responder => \&responder });
+ $key = File::KDBX::Key->new(\&responder); # challenge-response key
+
+Construct a new key.
+
+The primitive used to construct the key is not saved but is immediately converted to a raw encryption key (see
+L</raw_key>).
+
+A L<File::KDBX::Key::Composite> is somewhat special in that it does retain a reference to its component keys,
+and its raw key is calculated from its components on demand.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my %args = @_ % 2 == 1 ? (primitive => shift, @_) : @_;
+
+ my $primitive = $args{primitive};
+ delete $args{primitive} if !$args{keep_primitive};
+ return $primitive->hide if blessed $primitive && $primitive->isa($class);
+
+ my $self = bless \%args, $class;
+ return $self->init($primitive) if defined $primitive;
+ return $self;
+}
+
+sub DESTROY { !in_global_destruction and do { $_[0]->_clear_raw_key; erase \$_[0]->{primitive} } }
+
+=method init
+
+ $key = $key->init($primitive);
+
+Initialize a L<File::KDBX::Key> with a new primitive. Returns itself to allow method chaining.
+
+=cut
+
+sub init {
+ my $self = shift;
+ my $primitive = shift // throw 'Missing key primitive';
+
+ my $pkg;
+
+ if (is_arrayref($primitive)) {
+ $pkg = __PACKAGE__.'::Composite';
+ }
+ elsif (is_scalarref($primitive) || openhandle($primitive)) {
+ $pkg = __PACKAGE__.'::File';
+ }
+ elsif (is_coderef($primitive)) {
+ $pkg = __PACKAGE__.'::ChallengeResponse';
+ }
+ elsif (!is_ref($primitive)) {
+ $pkg = __PACKAGE__.'::Password';
+ }
+ elsif (is_hashref($primitive) && defined $primitive->{composite}) {
+ $pkg = __PACKAGE__.'::Composite';
+ $primitive = $primitive->{composite};
+ }
+ elsif (is_hashref($primitive) && defined $primitive->{password}) {
+ $pkg = __PACKAGE__.'::Password';
+ $primitive = $primitive->{password};
+ }
+ elsif (is_hashref($primitive) && defined $primitive->{file}) {
+ $pkg = __PACKAGE__.'::File';
+ $primitive = $primitive->{file};
+ }
+ elsif (is_hashref($primitive) && defined $primitive->{responder}) {
+ $pkg = __PACKAGE__.'::ChallengeResponse';
+ $primitive = $primitive->{responder};
+ }
+ else {
+ throw 'Invalid key primitive', primitive => $primitive;
+ }
+
+ load $pkg;
+ bless $self, $pkg;
+ return $self->init($primitive);
+}
+
+=method reload
+
+ $key = $key->reload;
+
+Reload a key by re-reading the key source and recalculating the raw key. Returns itself to allow method
+chaining.
+
+=cut
+
+sub reload { $_[0] }
+
+=method raw_key
+
+ $raw_key = $key->raw_key;
+ $raw_key = $key->raw_key($challenge);
+
+Get the raw encryption key. This is calculated based on the primitive(s). The C<$challenge> argument is for
+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.
+
+=cut
+
+sub raw_key {
+ my $self = shift;
+ return $self->{raw_key} if !$self->is_hidden;
+ return $self->_safe->peek(\$self->{raw_key});
+}
+
+sub _set_raw_key {
+ my $self = shift;
+ $self->_clear_raw_key;
+ $self->{raw_key} = shift; # after clear
+ $self->_new_safe->add(\$self->{raw_key}); # auto-hide
+}
+
+sub _clear_raw_key {
+ my $self = shift;
+ my $safe = $self->_safe;
+ $safe->clear if $safe;
+ erase \$self->{raw_key};
+}
+
+=method hide
+
+ $key = $key->hide;
+
+Encrypt the raw key for L<File::KDBX/"Memory Protection>. Returns itself to allow method chaining.
+
+=cut
+
+sub hide {
+ my $self = shift;
+ $self->_new_safe->add(\$self->{raw_key}) if defined $self->{raw_key};
+ return $self;
+}
+
+=method show
+
+ $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.
+
+=cut
+
+sub show {
+ my $self = shift;
+ my $safe = $self->_safe;
+ $safe->unlock if $safe;
+ return $self;
+}
+
+sub is_hidden { !!$SAFE{refaddr($_[0])} }
+
+# sub show_scoped {
+# my $self = shift;
+# require Scope::Guard;
+# $self-
+# return
+# }
+
+sub _safe { $SAFE{refaddr($_[0])} }
+sub _new_safe { $SAFE{refaddr($_[0])} = File::KDBX::Safe->new }
+
+1;
+__END__
+
+=head1 DESCRIPTION
+
+A master key is one or more credentials that can protect a KDBX database. When you encrypt a database with
+a master key, you will need the master key to decrypt it. B<Keep your master key safe!> If someone gains
+access to your master key, they can open your database. If you forget or lose any part of your master key, all
+data in the database is lost.
+
+There are several different types of keys, each implemented as a subclass:
+
+=for :list
+* L<File::KDBX::Key::Password> - Password or passphrase, knowledge of a string of characters
+* L<File::KDBX::Key::File> - Possession of a file ("key file") with a secret.
+* L<File::KDBX::Key::ChallengeResponse> - Possession of a device that responds correctly when challenged
+* L<File::KDBX::Key::YubiKey> - Possession of a YubiKey hardware device (a type of challenge-response)
+* L<File::KDBX::Key::Composite> - One or more keys combined as one
+
+A good master key is produced from a high amount of "entropy" (unpredictability). The more entropy the better.
+Combining multiple keys into a B<Composite> key combines the entropy of each individual key. For example, if
+you have a weak password and you combine it with other keys, the composite key is stronger than the weak
+password key by itself. (Of course it's much better to not have any weak components of your master key.)
+
+B<COMPATIBILITY NOTE:> Most KeePass implementations are limited in the types and numbers of keys they support.
+B<Password> keys are pretty much universally supported. B<File> keys are pretty well-supported. Many do not
+support challenge-response keys. If you are concerned about compatibility, you should stick with one of these
+configurations:
+
+=for :list
+* One password
+* One key file
+* One password and one key file
+
+=cut
--- /dev/null
+package File::KDBX::Key::ChallengeResponse;
+# ABSTRACT: A challenge-response key
+
+use warnings;
+use strict;
+
+use File::KDBX::Error;
+use namespace::clean;
+
+use parent 'File::KDBX::Key';
+
+our $VERSION = '999.999'; # VERSION
+
+sub init {
+ my $self = shift;
+ my $primitive = shift or throw 'Missing key primitive';
+
+ $self->{responder} = $primitive;
+
+ return $self->hide;
+}
+
+sub raw_key {
+ my $self = shift;
+ if (@_) {
+ my $challenge = shift // '';
+ # Don't challenge if we already have the response.
+ return $self->SUPER::raw_key if $challenge eq ($self->{challenge} // '');
+ $self->_set_raw_key($self->challenge($challenge, @_));
+ $self->{challenge} = $challenge;
+ }
+ $self->SUPER::raw_key;
+}
+
+=method challenge
+
+ $response = $key->challenge($challenge, @options);
+
+Issue a challenge and get a response, or throw if the responder failed.
+
+=cut
+
+sub challenge {
+ my $self = shift;
+
+ my $responder = $self->{responder} or throw 'Cannot issue challenge without a responder';
+ return $responder->(@_);
+}
+
+1;
+__END__
+
+=head1 SYNOPSIS
+
+ my $key = File::KDBX::Key::ChallengeResponse->(
+ responder => sub { my $challenge = shift; ...; return $response },
+ );
+
+=head1 DESCRIPTION
+
+=cut
--- /dev/null
+package File::KDBX::Key::Composite;
+# ABSTRACT: A composite key made up of component keys
+
+use warnings;
+use strict;
+
+use Crypt::Digest qw(digest_data);
+use File::KDBX::Error;
+use File::KDBX::Util qw(:erase);
+use Ref::Util qw(is_arrayref);
+use Scalar::Util qw(blessed);
+use namespace::clean;
+
+use parent 'File::KDBX::Key';
+
+our $VERSION = '999.999'; # VERSION
+
+sub init {
+ my $self = shift;
+ my $primitive = shift // throw 'Missing key primitive';
+
+ my @primitive = grep { defined } is_arrayref($primitive) ? @$primitive : $primitive;
+ @primitive or throw 'Composite key must have at least one component key', count => scalar @primitive;
+
+ my @keys = map { blessed $_ && $_->can('raw_key') ? $_ : File::KDBX::Key->new($_,
+ keep_primitive => $self->{keep_primitive}) } @primitive;
+ $self->{keys} = \@keys;
+
+ return $self->hide;
+}
+
+sub raw_key {
+ my $self = shift;
+ my $challenge = shift;
+
+ my @keys = @{$self->keys} or throw 'Cannot generate a raw key from an empty composite key';
+
+ my @basic_keys = map { $_->raw_key } grep { !$_->can('challenge') } @keys;
+ my $response;
+ $response = $self->challenge($challenge, @_) if defined $challenge;
+ my $cleanup = erase_scoped \@basic_keys, $response;
+
+ return digest_data('SHA256',
+ @basic_keys,
+ defined $response ? $response : (),
+ );
+}
+
+sub hide {
+ my $self = shift;
+ $_->hide for @{$self->keys};
+ return $self;
+}
+
+sub show {
+ my $self = shift;
+ $_->show for @{$self->keys};
+ return $self;
+}
+
+sub challenge {
+ my $self = shift;
+ my @args = @_;
+
+ my @chalresp_keys = grep { $_->can('challenge') } @{$self->keys} or return '';
+
+ my @responses = map { $_->challenge(@args) } @chalresp_keys;
+ my $cleanup = erase_scoped \@responses;
+
+ return digest_data('SHA256', @responses);
+}
+
+=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} ||= [];
+}
+
+1;
--- /dev/null
+package File::KDBX::Key::File;
+# ABSTRACT: A file key
+
+use warnings;
+use strict;
+
+use Crypt::Digest qw(digest_data);
+use Crypt::Misc 0.029 qw(decode_b64);
+use File::KDBX::Constants qw(:key_file);
+use File::KDBX::Error;
+use File::KDBX::Util qw(:erase trim);
+use Ref::Util qw(is_ref is_scalarref);
+use Scalar::Util qw(openhandle);
+use XML::LibXML::Reader;
+use namespace::clean;
+
+use parent 'File::KDBX::Key';
+
+our $VERSION = '999.999'; # VERSION
+
+sub init {
+ my $self = shift;
+ my $primitive = shift // throw 'Missing key primitive';
+
+ my $data;
+ my $cleanup;
+
+ if (openhandle($primitive)) {
+ seek $primitive, 0, 0; # not using ->seek method so it works on perl 5.10
+ my $buf = do { local $/; <$primitive> };
+ $data = \$buf;
+ $cleanup = erase_scoped $data;
+ }
+ elsif (is_scalarref($primitive)) {
+ $data = $primitive;
+ }
+ elsif (defined $primitive && !is_ref($primitive)) {
+ open(my $fh, '<:raw', $primitive)
+ or throw "Failed to open key file ($primitive)", filepath => $primitive;
+ my $buf = do { local $/; <$fh> };
+ $data = \$buf;
+ $cleanup = erase_scoped $data;
+ $self->{filepath} = $primitive;
+ }
+ else {
+ throw 'Unexpected primitive type', type => ref $primitive;
+ }
+
+ my $raw_key;
+ if (substr($$data, 0, 120) =~ /<KeyFile>/
+ and my ($type, $version) = $self->_load_xml($data, \$raw_key)) {
+ $self->{type} = $type;
+ $self->{version} = $version;
+ $self->_set_raw_key($raw_key);
+ }
+ elsif (length($$data) == 32) {
+ $self->{type} = KEY_FILE_TYPE_BINARY;
+ $self->_set_raw_key($$data);
+ }
+ elsif ($$data =~ /^[A-Fa-f0-9]{64}$/) {
+ $self->{type} = KEY_FILE_TYPE_HEX;
+ $self->_set_raw_key(pack('H64', $$data));
+ }
+ else {
+ $self->{type} = KEY_FILE_TYPE_HASHED;
+ $self->_set_raw_key(digest_data('SHA256', $$data));
+ }
+
+ return $self->hide;
+}
+
+=method reload
+
+ $key->reload;
+
+Re-read the key file, if possible, and update the raw key if the key changed.
+
+=cut
+
+sub reload {
+ my $self = shift;
+ $self->init($self->{filepath}) if defined $self->{filepath};
+ return $self;
+}
+
+=attr type
+
+ $type = $key->type;
+
+Get the type of key file. Can be one of:
+
+=for :list
+* C<KEY_FILE_TYPE_BINARY>
+* C<KEY_FILE_TYPE_HEX>
+* C<KEY_FILE_TYPE_XML>
+* C<KEY_FILE_TYPE_HASHED>
+
+=cut
+
+sub type { $_[0]->{type} }
+
+=attr version
+
+ $version = $key->version;
+
+Get the file version. Only applies to XML key files.
+
+=cut
+
+sub version { $_[0]->{version} }
+
+=attr filepath
+
+ $filepath = $key->filepath;
+
+Get the filepath to the key file, if known.
+
+=cut
+
+sub filepath { $_[0]->{filepath} }
+
+##############################################################################
+
+sub _load_xml {
+ my $self = shift;
+ my $buf = shift;
+ my $out = shift;
+
+ my ($version, $hash, $data);
+
+ my $reader = XML::LibXML::Reader->new(string => $$buf);
+ my $pattern = XML::LibXML::Pattern->new('/KeyFile/Meta/Version|/KeyFile/Key/Data');
+
+ while ($reader->nextPatternMatch($pattern) == 1) {
+ next if $reader->nodeType != XML_READER_TYPE_ELEMENT;
+ my $name = $reader->localName;
+ if ($name eq 'Version') {
+ $reader->read if !$reader->isEmptyElement;
+ $reader->nodeType == XML_READER_TYPE_TEXT
+ or alert 'Expected text node with version', line => $reader->lineNumber;
+ my $val = trim($reader->value);
+ defined $version
+ and alert 'Overwriting version', previous => $version, new => $val, line => $reader->lineNumber;
+ $version = $val;
+ }
+ elsif ($name eq 'Data') {
+ $hash = trim($reader->getAttribute('Hash')) if $reader->hasAttributes;
+ $reader->read if !$reader->isEmptyElement;
+ $reader->nodeType == XML_READER_TYPE_TEXT
+ or alert 'Expected text node with data', line => $reader->lineNumber;
+ $data = $reader->value;
+ $data =~ s/\s+//g if defined $data;
+ }
+ }
+
+ return if !defined $version || !defined $data;
+
+ if ($version =~ /^1\.0/ && $data =~ /^[A-Za-z0-9+\/=]+$/) {
+ $$out = eval { decode_b64($data) };
+ if (my $err = $@) {
+ throw 'Failed to decode key in key file', version => $version, data => $data, error => $err;
+ }
+ return (KEY_FILE_TYPE_XML, $version);
+ }
+ elsif ($version =~ /^2\.0/ && $data =~ /^[A-Fa-f0-9]+$/ && defined $hash && $hash =~ /^[A-Fa-f0-9]+$/) {
+ $$out = pack('H*', $data);
+ $hash = pack('H*', $hash);
+ my $got_hash = digest_data('SHA256', $$out);
+ $hash eq substr($got_hash, 0, 4)
+ 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;
+}
+
+1;
--- /dev/null
+package File::KDBX::Key::Password;
+# ABSTRACT: A password key
+
+use warnings;
+use strict;
+
+use Crypt::Digest qw(digest_data);
+use Encode qw(encode);
+use File::KDBX::Error;
+use File::KDBX::Util qw(erase);
+use namespace::clean;
+
+use parent 'File::KDBX::Key';
+
+our $VERSION = '999.999'; # VERSION
+
+sub init {
+ my $self = shift;
+ my $primitive = shift // throw 'Missing key primitive';
+
+ $self->_set_raw_key(digest_data('SHA256', encode('UTF-8', $primitive)));
+
+ return $self->hide;
+}
+
+1;
--- /dev/null
+package File::KDBX::Key::YubiKey;
+# ABSTRACT: A Yubico challenge-response key
+
+use warnings;
+use strict;
+
+use File::KDBX::Constants qw(:yubikey);
+use File::KDBX::Error;
+use File::KDBX::Util qw(pad_pkcs7);
+use IPC::Open3;
+use Scope::Guard;
+use Symbol qw(gensym);
+use namespace::clean;
+
+use parent 'File::KDBX::Key::ChallengeResponse';
+
+our $VERSION = '999.999'; # VERSION
+
+my @CONFIG_VALID = (0, CONFIG1_VALID, CONFIG2_VALID);
+my @CONFIG_TOUCH = (0, CONFIG1_TOUCH, CONFIG2_TOUCH);
+
+sub challenge {
+ my $self = shift;
+ my $challenge = shift;
+ my %args = @_;
+
+ my @cleanup;
+
+ my $device = $args{device} // $self->device;
+ my $slot = $args{slot} // $self->slot;
+ my $timeout = $args{timeout} // $self->timeout;
+ local $self->{device} = $device;
+ local $self->{slot} = $slot;
+ local $self->{timeout} = $timeout;
+
+ my $hooks = $challenge ne 'test';
+ if ($hooks and my $hook = $self->{pre_challenge}) {
+ $hook->($self, $challenge);
+ }
+
+ my @cmd = ($self->ykchalresp, "-n$device", "-$slot", qw{-H -i-}, $timeout == 0 ? '-N' : ());
+ my ($pid, $child_in, $child_out, $child_err) = _run_ykpers(@cmd);
+ push @cleanup, Scope::Guard->new(sub { kill $pid if defined $pid });
+
+ # Set up an alarm [mostly] safely
+ my $prev_alarm = 0;
+ local $SIG{ALRM} = sub {
+ $prev_alarm -= $timeout;
+ throw 'Timed out while waiting for challenge response',
+ command => \@cmd,
+ challenge => $challenge,
+ timeout => $timeout,
+ };
+ $prev_alarm = alarm $timeout if 0 < $timeout;
+ push @cleanup, Scope::Guard->new(sub { alarm($prev_alarm < 1 ? 1 : $prev_alarm) }) if $prev_alarm;
+
+ local $SIG{PIPE} = 'IGNORE';
+ binmode($child_in);
+ print $child_in pad_pkcs7($challenge, 64);
+ close($child_in);
+
+ binmode($child_out);
+ binmode($child_err);
+ my $resp = do { local $/; <$child_out> };
+ my $err = do { local $/; <$child_err> };
+ chomp($resp, $err);
+
+ waitpid($pid, 0);
+ undef $pid;
+ my $exit_status = $? >> 8;
+ alarm 0;
+
+ my $yk_errno = _yk_errno($err);
+ $exit_status == 0 or throw 'Failed to receive challenge response: ' . ($err ? $err : ''),
+ error => $err,
+ yk_errno => $yk_errno || 0;
+
+ $resp =~ /^[A-Fa-f0-9]+$/ or throw 'Unexpected response from challenge', response => $resp;
+ $resp = pack('H*', $resp);
+
+ # HMAC-SHA1 response is only 20 bytes
+ substr($resp, 20) = '';
+
+ if ($hooks and my $hook = $self->{post_challenge}) {
+ $hook->($self, $challenge, $resp);
+ }
+
+ return $resp;
+}
+
+=method scan
+
+ @keys = File::KDBX::Key::YubiKey->scan(%options);
+
+Find connected, configured YubiKeys that are capable of responding to a challenge. This can take several
+second.
+
+Options:
+
+=for :list
+* C<limit> - Scan for only up to this many YubiKeys (default: 4)
+
+Other options are passed as-is as attributes to the key constructors of found keys (if any).
+
+=cut
+
+sub scan {
+ my $self = shift;
+ my %args = @_;
+
+ my $limit = delete $args{limit} // 4;
+
+ my @keys;
+ for (my $device = 0; $device < $limit; ++$device) {
+ my %info = $self->_get_yubikey_info($device) or last;
+
+ for (my $slot = 1; $slot <= 2; ++$slot) {
+ my $config = $CONFIG_VALID[$slot] // next;
+ next unless $info{touch_level} & $config;
+
+ my $key = $self->new(%args, device => $device, slot => $slot, %info);
+ if ($info{product_id} <= NEO_OTP_U2F_CCID_PID) {
+ # NEO and earlier always require touch, so forego testing
+ $key->touch_level($info{touch_level} | $CONFIG_TOUCH[$slot]);
+ push @keys, $key;
+ }
+ else {
+ eval { $key->challenge('test', timeout => 0) };
+ if (my $err = $@) {
+ my $yk_errno = ref $err && $err->details->{yk_errno} || 0;
+ if ($yk_errno == YK_EWOULDBLOCK) {
+ $key->touch_level($info{touch_level} | $CONFIG_TOUCH[$slot]);
+ }
+ elsif ($yk_errno != 0) {
+ # alert $err;
+ next;
+ }
+ }
+ push @keys, $key;
+ }
+ }
+ }
+
+ return @keys;
+}
+
+=attr device
+
+ $device = $key->device($device);
+
+Get or set the device number, which is the index number starting and incrementing from zero assigned
+to the YubiKey device. If there is only one detected YubiKey device, it's number is C<0>.
+
+Defaults to C<0>.
+
+=attr slot
+
+ $slot = $key->slot($slot);
+
+Get or set the slot number, which is a number starting and incrementing from one. A YubiKey can have
+multiple slots (often just two) which can be independently configured.
+
+Defaults to C<1>.
+
+=attr timeout
+
+ $timeout = $key->timeout($timeout);
+
+Get or set the timeout, in seconds. If the challenge takes longer than this, the challenge will be
+cancelled and an error is thrown.
+
+If the timeout is zero, the challenge is non-blocking; an error is thrown if the challenge would
+block. If the timeout is negative, timeout is disabled and the challenge will block forever or until
+a response is received.
+
+Defaults to C<0>.
+
+=attr pre_challenge
+
+ $callback = $key->pre_challenge($callback);
+
+Get or set a callback function that will be called immediately before any challenge is issued. This might be
+used to prompt the user so they are aware that they are expected to interact with their YubiKey.
+
+ $key->pre_challenge(sub {
+ my ($key, $challenge) = @_;
+
+ if ($key->requires_interaction) {
+ say 'Please touch your key device to proceed with decrypting your KDBX file.';
+ }
+ say 'Key: ', $key->name;
+ if (0 < $key->timeout) {
+ say 'Key access request expires: ' . localtime(time + $key->timeout);
+ }
+ });
+
+You can throw from this subroutine to abort the challenge. If the challenge is part of loading or dumping
+a KDBX database, the entire load/dump will be aborted.
+
+=attr post_challenge
+
+ $callback = $key->post_challenge($callback);
+
+Get or set a callback function that will be called immediately after a challenge response has been received.
+
+You can throw from this subroutine to abort the challenge. If the challenge is part of loading or dumping
+a KDBX database, the entire load/dump will be aborted.
+
+=attr ykchalresp
+
+ $program = $key->ykchalresp;
+
+Get or set the L<ykchalresp(1)> program name or filepath. Defaults to C<$ENV{YKCHALRESP}> or C<ykchalresp>.
+
+=attr ykinfo
+
+ $program = $key->ykinfo;
+
+Get or set the L<ykinfo(1)> program name or filepath. Defaults to C<$ENV{YKINFO}> or C<ykinfo>.
+
+=cut
+
+my %ATTRS = (
+ device => 0,
+ slot => 1,
+ timeout => 10,
+ pre_challenge => undef,
+ post_challenge => undef,
+ ykchalresp => sub { $ENV{YKCHALRESP} || 'ykchalresp' },
+ ykinfo => sub { $ENV{YKINFO} || 'ykinfo' },
+);
+while (my ($subname, $default) = each %ATTRS) {
+ no strict 'refs'; ## no critic (ProhibitNoStrict)
+ *{$subname} = sub {
+ my $self = shift;
+ $self->{$subname} = shift if @_;
+ $self->{$subname} //= (ref $default eq 'CODE') ? $default->($self) : $default;
+ };
+}
+
+my %INFO = (
+ serial => undef,
+ version => undef,
+ touch_level => undef,
+ vendor_id => undef,
+ product_id => undef,
+);
+while (my ($subname, $default) = each %INFO) {
+ no strict 'refs'; ## no critic (ProhibitNoStrict)
+ *{$subname} = sub {
+ my $self = shift;
+ $self->{$subname} = shift if @_;
+ defined $self->{$subname} or $self->_set_yubikey_info;
+ $self->{$subname} // $default;
+ };
+}
+
+=method serial
+
+Get the device serial number, as a number, or C<undef> if there is no such device.
+
+=method version
+
+Get the device firmware version (or C<undef>).
+
+=method touch_level
+
+Get the "touch level" value for the device associated with this key (or C<undef>).
+
+=method vendor_id
+
+=method product_id
+
+Get the vendor ID or product ID for the device associated with this key (or C<undef>).
+
+=method name
+
+ $name = $key->name;
+
+Get a human-readable string identifying the YubiKey (or C<undef>).
+
+=cut
+
+sub name {
+ my $self = shift;
+ my $name = _product_name($self->vendor_id, $self->product_id // return);
+ my $serial = $self->serial;
+ my $version = $self->version || '?';
+ my $slot = $self->slot;
+ my $touch = $self->requires_interaction ? ' - Interaction required' : '';
+ return sprintf('%s v%s [%d] (slot #%d)', $name, $version, $serial, $slot);
+}
+
+=method requires_interaction
+
+Get whether or not the key requires interaction (e.g. a touch) to provide a challenge response (or C<undef>).
+
+=cut
+
+sub requires_interaction {
+ my $self = shift;
+ my $touch = $self->touch_level // return;
+ return $touch & $CONFIG_TOUCH[$self->slot];
+}
+
+##############################################################################
+
+### Call ykinfo to get some information about a YubiKey
+sub _get_yubikey_info {
+ my $self = shift;
+ my $device = shift;
+
+ my @cmd = ($self->ykinfo, "-n$device", qw{-a});
+
+ my $try = 0;
+ TRY:
+ my ($pid, $child_in, $child_out, $child_err) = _run_ykpers(@cmd);
+
+ close($child_in);
+
+ local $SIG{PIPE} = 'IGNORE';
+ binmode($child_out);
+ binmode($child_err);
+ my $out = do { local $/; <$child_out> };
+ my $err = do { local $/; <$child_err> };
+ chomp $err;
+
+ waitpid($pid, 0);
+ my $exit_status = $? >> 8;
+
+ if ($exit_status != 0) {
+ my $yk_errno = _yk_errno($err);
+ return if $yk_errno == YK_ENOKEY;
+ if ($yk_errno == YK_EWOULDBLOCK && ++$try <= 3) {
+ sleep 0.1;
+ goto TRY;
+ }
+ alert 'Failed to get YubiKey device info: ' . ($err ? $err : 'Something happened'),
+ error => $err,
+ yk_errno => $yk_errno || 0;
+ return;
+ }
+
+ if (!$out) {
+ alert 'Failed to get YubiKey device info: no output';
+ return;
+ }
+
+ my %info = map { $_ => ($out =~ /^\Q$_\E: (.+)$/m)[0] }
+ qw(serial version touch_level vendor_id product_id);
+ $info{vendor_id} = hex($info{vendor_id}) if defined $info{vendor_id};
+ $info{product_id} = hex($info{product_id}) if defined $info{product_id};
+
+ return %info;
+}
+
+### Set the YubiKey information as attributes of a Key object
+sub _set_yubikey_info {
+ my $self = shift;
+ my %info = $self->_get_yubikey_info($self->device);
+ @$self{keys %info} = values %info;
+}
+
+sub _run_ykpers {
+ my ($child_err, $child_in, $child_out) = (gensym);
+ my $pid = eval { open3($child_in, $child_out, $child_err, @_) };
+ if (my $err = $@) {
+ throw "Failed to run $_[0] - Make sure you have the YubiKey Personalization Tool (CLI) package installed.\n",
+ error => $err;
+ }
+ return ($pid, $child_in, $child_out, $child_err);
+}
+
+sub _yk_errno {
+ local $_ = shift or return 0;
+ return YK_EUSBERR if $_ =~ YK_EUSBERR;
+ return YK_EWRONGSIZ if $_ =~ YK_EWRONGSIZ;
+ return YK_EWRITEERR if $_ =~ YK_EWRITEERR;
+ return YK_ETIMEOUT if $_ =~ YK_ETIMEOUT;
+ return YK_ENOKEY if $_ =~ YK_ENOKEY;
+ return YK_EFIRMWARE if $_ =~ YK_EFIRMWARE;
+ return YK_ENOMEM if $_ =~ YK_ENOMEM;
+ return YK_ENOSTATUS if $_ =~ YK_ENOSTATUS;
+ return YK_ENOTYETIMPL if $_ =~ YK_ENOTYETIMPL;
+ return YK_ECHECKSUM if $_ =~ YK_ECHECKSUM;
+ return YK_EWOULDBLOCK if $_ =~ YK_EWOULDBLOCK;
+ return YK_EINVALIDCMD if $_ =~ YK_EINVALIDCMD;
+ return YK_EMORETHANONE if $_ =~ YK_EMORETHANONE;
+ return YK_ENODATA if $_ =~ YK_ENODATA;
+ return -1;
+}
+
+my %PIDS;
+for my $pid (
+ YUBIKEY_PID, NEO_OTP_PID, NEO_OTP_CCID_PID, NEO_CCID_PID, NEO_U2F_PID, NEO_OTP_U2F_PID, NEO_U2F_CCID_PID,
+ NEO_OTP_U2F_CCID_PID, YK4_OTP_PID, YK4_U2F_PID, YK4_OTP_U2F_PID, YK4_CCID_PID, YK4_OTP_CCID_PID,
+ YK4_U2F_CCID_PID, YK4_OTP_U2F_CCID_PID, PLUS_U2F_OTP_PID, ONLYKEY_PID,
+) {
+ $PIDS{$pid} = $PIDS{0+$pid} = $pid;
+}
+sub _product_name { $PIDS{$_[1]} // 'Unknown' }
+
+1;
+__END__
+
+=head1 SYNOPSIS
+
+ use File::KDBX::Key::YubiKey;
+ use File::KDBX;
+
+ my $yubikey = File::KDBX::Key::YubiKey->new(%attributes);
+
+ my $kdbx = File::KDBX->load_file('database.kdbx', $yubikey);
+ # OR
+ my $kdbx = File::KDBX->load_file('database.kdbx', ['password', $yubikey]);
+
+ # Scan for USB YubiKeys:
+ my ($first_key, @other_keys) = File::KDBX::Key::YubiKey->scan;
+
+ my $response = $first_key->challenge('hello');
+
+=head1 DESCRIPTION
+
+A L<File::KDBX::Key::YubiKey> is a type of challenge-response key. This module follows the KeePassXC-style
+challenge-response implementation, so this might not work at all with incompatible challenge-response
+implementations (e.g. KeeChallenge).
+
+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
+Personalization Tool GUI to do this.
+
+See L<https://keepassxc.org/docs/#faq-yubikey-howto> for more information.
+
+=head1 ENVIRONMENT
+
+=for :list
+* C<YKCHALRESP> - Path to the L<ykchalresp(1)> program
+* C<YKINFO> - Path to the L<ykinfo(1)> program
+
+C<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
+override the default programs, these environment variables can be used.
+
+=cut
--- /dev/null
+package File::KDBX::Loader;
+# ABSTRACT: Load KDBX files
+
+use warnings;
+use strict;
+
+use File::KDBX::Constants qw(:magic :header :version);
+use File::KDBX::Error;
+use File::KDBX::Util qw(:io);
+use File::KDBX;
+use IO::Handle;
+use Module::Load ();
+use Ref::Util qw(is_ref is_scalarref);
+use Scalar::Util qw(looks_like_number openhandle);
+use namespace::clean;
+
+our $VERSION = '999.999'; # VERSION
+
+=method new
+
+ $loader = File::KDBX::Loader->new(%attributes);
+
+Construct a new L<File::KDBX::Loader>.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my $self = bless {}, $class;
+ $self->init(@_);
+}
+
+=method init
+
+ $loader = $loader->init(%attributes);
+
+Initialize a L<File::KDBX::Loader> with a new set of attributes.
+
+This is called by L</new>.
+
+=cut
+
+sub init {
+ my $self = shift;
+ my %args = @_;
+
+ @$self{keys %args} = values %args;
+
+ return $self;
+}
+
+sub _rebless {
+ my $self = shift;
+ my $format = shift // $self->format;
+
+ my $sig2 = $self->kdbx->sig2;
+ my $version = $self->kdbx->version;
+
+ my $subclass;
+
+ if (defined $format) {
+ $subclass = $format;
+ }
+ elsif (defined $sig2 && $sig2 == KDBX_SIG2_1) {
+ $subclass = 'KDB';
+ }
+ elsif (looks_like_number($version)) {
+ my $major = $version & KDBX_VERSION_MAJOR_MASK;
+ my %subclasses = (
+ KDBX_VERSION_2_0() => 'V3',
+ KDBX_VERSION_3_0() => 'V3',
+ KDBX_VERSION_4_0() => 'V4',
+ );
+ $subclass = $subclasses{$major}
+ or throw sprintf('Unsupported KDBX file version: %x', $version), version => $version;
+ }
+ else {
+ throw sprintf('Unknown file version: %s', $version), version => $version;
+ }
+
+ Module::Load::load "File::KDBX::Loader::$subclass";
+ bless $self, "File::KDBX::Loader::$subclass";
+}
+
+=method reset
+
+ $loader = $loader->reset;
+
+Set a L<File::KDBX::Loader> to a blank state, ready to load another KDBX file.
+
+=cut
+
+sub reset {
+ my $self = shift;
+ %$self = ();
+ return $self;
+}
+
+=method load
+
+ $kdbx = File::KDBX::Loader->load(\$string, $key);
+ $kdbx = File::KDBX::Loader->load(*IO, $key);
+ $kdbx = File::KDBX::Loader->load($filepath, $key);
+ $kdbx = $loader->load(...); # also instance method
+
+Load a KDBX file.
+
+The C<$key> is either a L<File::KDBX::Key> or a primitive that can be converted to a Key object.
+
+=cut
+
+sub load {
+ my $self = shift;
+ my $src = shift;
+ return $self->load_handle($src, @_) if openhandle($src) || $src eq '-';
+ return $self->load_string($src, @_) if is_scalarref($src);
+ return $self->load_file($src, @_) if !is_ref($src) && defined $src;
+ throw 'Programmer error: Must pass a stringref, filepath or IO handle to read';
+}
+
+=method load_string
+
+ $kdbx = File::KDBX::Loader->load_string($string, $key);
+ $kdbx = File::KDBX::Loader->load_string(\$string, $key);
+ $kdbx = $loader->load_string(...); # also instance method
+
+Load a KDBX file from a string / memory buffer.
+
+=cut
+
+sub load_string {
+ my $self = shift;
+ my $str = shift or throw 'Expected string to load';
+ my %args = @_ % 2 == 0 ? @_ : (key => shift, @_);
+
+ my $key = delete $args{key};
+ $args{kdbx} //= $self->kdbx;
+
+ my $ref = is_scalarref($str) ? $str : \$str;
+
+ open(my $fh, '<', $ref) or throw "Failed to open string buffer: $!";
+
+ $self = $self->new if !ref $self;
+ $self->init(%args, fh => $fh)->_read($fh, $key);
+ return $args{kdbx};
+}
+
+=method load_file
+
+ $kdbx = File::KDBX::Loader->load_file($filepath, $key);
+ $kdbx = $loader->load_file(...); # also instance method
+
+Read a KDBX file from a filesystem.
+
+=cut
+
+sub load_file {
+ my $self = shift;
+ my $filepath = shift;
+ my %args = @_ % 2 == 0 ? @_ : (key => shift, @_);
+
+ my $key = delete $args{key};
+ $args{kdbx} //= $self->kdbx;
+
+ open(my $fh, '<:raw', $filepath) or throw 'Open file failed', filepath => $filepath;
+
+ $self = $self->new if !ref $self;
+ $self->init(%args, fh => $fh, filepath => $filepath)->_read($fh, $key);
+ return $args{kdbx};
+}
+
+=method load_handle
+
+ $kdbx = File::KDBX::Loader->load_handle($fh, $key);
+ $kdbx = File::KDBX::Loader->load_handle(*IO, $key);
+ $kdbx->load_handle(...); # also instance method
+
+Read a KDBX file from an input stream / file handle.
+
+=cut
+
+sub load_handle {
+ my $self = shift;
+ my $fh = shift;
+ my %args = @_ % 2 == 0 ? @_ : (key => shift, @_);
+
+ $fh = *STDIN if $fh eq '-';
+
+ my $key = delete $args{key};
+ $args{kdbx} //= $self->kdbx;
+
+ $self = $self->new if !ref $self;
+ $self->init(%args, fh => $fh)->_read($fh, $key);
+ return $args{kdbx};
+}
+
+=attr kdbx
+
+ $kdbx = $loader->kdbx;
+ $loader->kdbx($kdbx);
+
+Get or set the L<File::KDBX> instance for storing the loaded data into.
+
+=cut
+
+sub kdbx {
+ my $self = shift;
+ return File::KDBX->new if !ref $self;
+ $self->{kdbx} = shift if @_;
+ $self->{kdbx} //= File::KDBX->new;
+}
+
+=attr format
+
+TODO
+
+=cut
+
+sub format { $_[0]->{format} }
+sub inner_format { $_[0]->{inner_format} // 'XML' }
+
+=attr min_version
+
+ $min_version = File::KDBX::Loader->min_version;
+
+Get the minimum KDBX file version supported, which is 3.0 or C<0x00030000> as
+it is encoded.
+
+To read older KDBX files unsupported by this module, try L<File::KeePass>.
+
+=cut
+
+sub min_version { KDBX_VERSION_OLDEST }
+
+=method read_magic_numbers
+
+ $magic = File::KDBX::Loader->read_magic_numbers($fh);
+ ($sig1, $sig2, $version, $magic) = File::KDBX::Loader->read_magic_numbers($fh);
+
+ $magic = $loader->read_magic_numbers($fh);
+ ($sig1, $sig2, $version, $magic) = $loader->read_magic_numbers($fh);
+
+Read exactly 12 bytes from an IO handle and parse them into the three magic numbers that begin
+a KDBX file. This is a quick way to determine if a file is actually a KDBX file.
+
+C<$sig1> should always be C<KDBX_SIG1> if reading an actual KDB or KDBX file.
+
+C<$sig2> should be C<KDBX_SIG2_1> for KeePass 1 files and C<KDBX_SIG2_2> for KeePass 2 files.
+
+C<$version> is the file version (e.g. C<0x00040001>).
+
+C<$magic> is the raw 12 bytes read from the IO handle.
+
+If called on an instance, the C<sig1>, C<sig2> and C<version> attributes will be set in the L</kdbx>
+and the instance will be blessed into the correct loader subclass.
+
+=cut
+
+sub read_magic_numbers {
+ my $self = shift;
+ my $fh = shift;
+ my $kdbx = shift // $self->kdbx;
+
+ read_all $fh, my $magic, 12 or throw 'Failed to read file signature';
+
+ my ($sig1, $sig2, $version) = unpack('L<3', $magic);
+
+ if ($kdbx) {
+ $kdbx->sig1($sig1);
+ $kdbx->sig2($sig2);
+ $kdbx->version($version);
+ $self->_rebless if ref $self;
+ }
+
+ return wantarray ? ($sig1, $sig2, $version, $magic) : $magic;
+}
+
+sub _fh { $_[0]->{fh} or throw 'IO handle not set' }
+
+sub _read {
+ my $self = shift;
+ my $fh = shift;
+ my $key = shift;
+
+ my $kdbx = $self->kdbx;
+ $key //= $kdbx->key ? $kdbx->key->reload : undef;
+ $kdbx->reset;
+
+ read_all $fh, my $buf, 1 or throw 'Failed to read the first byte', type => 'parser';
+ my $first = ord($buf);
+ $fh->ungetc($first);
+ if ($first != KDBX_SIG1_FIRST_BYTE) {
+ # not a KDBX file... try skipping the outer layer
+ return $self->_read_inner_body($fh);
+ }
+
+ my $magic = $self->read_magic_numbers($fh, $kdbx);
+ $kdbx->sig1 == KDBX_SIG1 or throw 'Invalid file signature', type => 'parser', sig1 => $kdbx->sig1;
+
+ if (ref($self) =~ /::(?:KDB|V[34])$/) {
+ defined $key or throw 'Must provide a master key', type => 'key.missing';
+ }
+
+ my $headers = $self->_read_headers($fh);
+
+ $self->_read_body($fh, $key, "$magic$headers");
+}
+
+sub _read_headers {
+ my $self = shift;
+ my $fh = shift;
+
+ my $headers = $self->kdbx->headers;
+ my $all_raw = '';
+
+ while (my ($type, $val, $raw) = $self->_read_header($fh)) {
+ $all_raw .= $raw;
+ last if $type == HEADER_END;
+ $headers->{$type} = $val;
+ }
+
+ return $all_raw;
+}
+
+sub _read_body { die "Not implemented" }
+
+sub _read_inner_body {
+ my $self = shift;
+
+ my $current_pkg = ref $self;
+ require Scope::Guard;
+ my $guard = Scope::Guard->new(sub { bless $self, $current_pkg });
+
+ $self->_rebless($self->inner_format);
+ $self->_read_inner_body(@_);
+}
+
+1;
--- /dev/null
+package File::KDBX::Loader::KDB;
+# ABSTRACT: Read KDB files
+
+use warnings;
+use strict;
+
+use Encode qw(encode);
+use File::KDBX::Constants qw(:header :cipher :random_stream :icon);
+use File::KDBX::Error;
+use File::KDBX::Util qw(:empty :io :uuid load_optional);
+use File::KDBX;
+use Ref::Util qw(is_arrayref is_hashref);
+use Scalar::Util qw(looks_like_number);
+use Time::Piece;
+use boolean;
+use namespace::clean;
+
+use parent 'File::KDBX::Loader';
+
+our $VERSION = '999.999'; # VERSION
+
+my $DEFAULT_EXPIRATION = Time::Piece->new(32503677839); # 2999-12-31 23:59:59
+
+sub _read_headers { '' }
+
+sub _read_body {
+ my $self = shift;
+ my $fh = shift;
+ my $key = shift;
+ my $buf = shift;
+
+ load_optional('File::KeePass');
+
+ $buf .= do { local $/; <$fh> };
+
+ $key = $self->kdbx->composite_key($key, keep_primitive => 1);
+
+ my $k = eval { File::KeePass->new->parse_db(\$buf, _convert_kdbx_to_keepass_master_key($key)) };
+ if (my $err = $@) {
+ throw 'Failed to parse KDB file', error => $err;
+ }
+
+ $k->unlock;
+ $self->kdbx->key($key);
+
+ return convert_keepass_to_kdbx($k, $self->kdbx);
+}
+
+# This is also used by File::KDBX::Dumper::KDB.
+sub _convert_kdbx_to_keepass_master_key {
+ my $key = shift;
+
+ my @keys = @{$key->keys};
+ if (@keys == 1 && !$keys[0]->can('filepath')) {
+ return [encode('CP-1252', $keys[0]->{primitive})]; # just a password
+ }
+ elsif (@keys == 1) {
+ return [undef, \$keys[0]->raw_key]; # just a keyfile
+ }
+ elsif (@keys == 2 && !$keys[0]->can('filepath') && $keys[1]->can('filepath')) {
+ return [encode('CP-1252', $keys[0]->{primitive}), \$keys[1]->raw_key];
+ }
+ throw 'Cannot use this key to load a KDB file', key => $key;
+}
+
+=func convert_keepass_to_kdbx
+
+ $kdbx = convert_keepass_to_kdbx($keepass);
+ $kdbx = convert_keepass_to_kdbx($keepass, $kdbx);
+
+Convert a L<File::KeePass> to a L<File::KDBX>.
+
+=cut
+
+sub convert_keepass_to_kdbx {
+ my $k = shift;
+ my $kdbx = shift // File::KDBX->new;
+
+ $kdbx->{headers} //= {};
+ _convert_keepass_to_kdbx_headers($k->{header}, $kdbx);
+
+ my @groups = @{$k->{groups} || []};
+ if (@groups == 1) {
+ $kdbx->{root} = _convert_keepass_to_kdbx_group($k->{groups}[0]);
+ }
+ elsif (1 < @groups) {
+ my $root = $kdbx->{root} = {%{File::KDBX->_implicit_root}};
+ for my $group (@groups) {
+ push @{$root->{groups} //= []}, _convert_keepass_to_kdbx_group($group);
+ }
+ }
+
+ for my $entry ($kdbx->find_entries({
+ title => 'Meta-Info',
+ username => 'SYSTEM',
+ url => '$',
+ icon_id => 0,
+ -nonempty => 'notes',
+ })) {
+ _read_meta_stream($kdbx, $entry);
+ $entry->remove;
+ }
+
+ return $kdbx;
+}
+
+sub _read_meta_stream {
+ my $kdbx = shift;
+ my $entry = shift;
+
+ my $type = $entry->notes;
+ my $data = $entry->binary_value('bin-stream');
+ open(my $fh, '<', \$data) or throw "Failed to open memory buffer for reading: $!";
+
+ if ($type eq 'KPX_GROUP_TREE_STATE') {
+ read_all $fh, my $buf, 4 or goto PARSE_ERROR;
+ my ($num) = unpack('L<', $buf);
+ $num * 5 + 4 == length($data) or goto PARSE_ERROR;
+ for (my $i = 0; $i < $num; ++$i) {
+ read_all $fh, $buf, 5 or goto PARSE_ERROR;
+ my ($group_id, $expanded) = unpack('L< C', $buf);
+ my $uuid = _decode_uuid($group_id) // next;
+ my ($group) = $kdbx->find_groups({uuid => $uuid});
+ $group->is_expanded($expanded) if $group;
+ }
+ }
+ elsif ($type eq 'KPX_CUSTOM_ICONS_4') {
+ read_all $fh, my $buf, 12 or goto PARSE_ERROR;
+ my ($num_icons, $num_entries, $num_groups) = unpack('L<3', $buf);
+ my @icons;
+ for (my $i = 0; $i < $num_icons; ++$i) {
+ read_all $fh, $buf, 4 or goto PARSE_ERROR;
+ my ($icon_size) = unpack('L<', $buf);
+ read_all $fh, $buf, $icon_size or goto PARSE_ERROR;
+ my $uuid = $kdbx->add_custom_icon($buf);
+ push @icons, $uuid;
+ }
+ for (my $i = 0; $i < $num_entries; ++$i) {
+ read_all $fh, $buf, 20 or goto PARSE_ERROR;
+ my ($uuid, $icon_index) = unpack('a16 L<', $buf);
+ next if !$icons[$icon_index];
+ my ($entry) = $kdbx->find_entries({uuid => $uuid});
+ $entry->custom_icon_uuid($icons[$icon_index]) if $entry;
+ }
+ for (my $i = 0; $i < $num_groups; ++$i) {
+ read_all $fh, $buf, 8 or goto PARSE_ERROR;
+ my ($group_id, $icon_index) = unpack('L<2', $buf);
+ next if !$icons[$icon_index];
+ my $uuid = _decode_uuid($group_id) // next;
+ my ($group) = $kdbx->find_groups({uuid => $uuid});
+ $group->custom_icon_uuid($icons[$icon_index]) if $group;
+ }
+ }
+ else {
+ alert "Ignoring unknown meta stream: $type\n", type => $type;
+ return;
+ }
+
+ return;
+
+ PARSE_ERROR:
+ alert "Ignoring unparsable meta stream: $type\n", type => $type;
+}
+
+sub _convert_keepass_to_kdbx_headers {
+ my $from = shift;
+ my $kdbx = shift;
+
+ my $headers = $kdbx->{headers} //= {};
+ my $meta = $kdbx->{meta} //= {};
+
+ $kdbx->{sig1} = $from->{sig1};
+ $kdbx->{sig2} = $from->{sig2};
+ $kdbx->{version} = $from->{vers};
+
+ my %enc_type = (
+ rijndael => CIPHER_UUID_AES256,
+ aes => CIPHER_UUID_AES256,
+ twofish => CIPHER_UUID_TWOFISH,
+ chacha20 => CIPHER_UUID_CHACHA20,
+ salsa20 => CIPHER_UUID_SALSA20,
+ serpent => CIPHER_UUID_SERPENT,
+ );
+ my $cipher_uuid = $enc_type{$from->{cipher} || ''} // $enc_type{$from->{enc_type} || ''};
+
+ my %protected_stream = (
+ rc4 => STREAM_ID_RC4_VARIANT,
+ salsa20 => STREAM_ID_SALSA20,
+ chacha20 => STREAM_ID_CHACHA20,
+ );
+ my $protected_stream_id = $protected_stream{$from->{protected_stream} || ''} || STREAM_ID_SALSA20;
+
+ $headers->{+HEADER_COMMENT} = $from->{comment};
+ $headers->{+HEADER_CIPHER_ID} = $cipher_uuid if $cipher_uuid;
+ $headers->{+HEADER_MASTER_SEED} = $from->{seed_rand};
+ $headers->{+HEADER_COMPRESSION_FLAGS} = $from->{compression} // 0;
+ $headers->{+HEADER_TRANSFORM_SEED} = $from->{seed_key};
+ $headers->{+HEADER_TRANSFORM_ROUNDS} = $from->{rounds};
+ $headers->{+HEADER_ENCRYPTION_IV} = $from->{enc_iv};
+ $headers->{+HEADER_INNER_RANDOM_STREAM_ID} = $protected_stream_id;
+ $headers->{+HEADER_INNER_RANDOM_STREAM_KEY} = $from->{protected_stream_key};
+ $headers->{+HEADER_STREAM_START_BYTES} = $from->{start_bytes} // '';
+
+ # TODO for KeePass 1 files these are all not available. Leave undefined or set default values?
+ $meta->{memory_protection}{protect_notes} = boolean($from->{protect_notes});
+ $meta->{memory_protection}{protect_password} = boolean($from->{protect_password});
+ $meta->{memory_protection}{protect_username} = boolean($from->{protect_username});
+ $meta->{memory_protection}{protect_url} = boolean($from->{protect_url});
+ $meta->{memory_protection}{protect_title} = boolean($from->{protect_title});
+ $meta->{generator} = $from->{generator} // '';
+ $meta->{header_hash} = $from->{header_hash};
+ $meta->{database_name} = $from->{database_name} // '';
+ $meta->{database_name_changed} = _decode_datetime($from->{database_name_changed});
+ $meta->{database_description} = $from->{database_description} // '';
+ $meta->{database_description_changed} = _decode_datetime($from->{database_description_changed});
+ $meta->{default_username} = $from->{default_user_name} // '';
+ $meta->{default_username_changed} = _decode_datetime($from->{default_user_name_changed});
+ $meta->{maintenance_history_days} = $from->{maintenance_history_days};
+ $meta->{color} = $from->{color};
+ $meta->{master_key_changed} = _decode_datetime($from->{master_key_changed});
+ $meta->{master_key_change_rec} = $from->{master_key_change_rec};
+ $meta->{master_key_change_force} = $from->{master_key_change_force};
+ $meta->{recycle_bin_enabled} = boolean($from->{recycle_bin_enabled});
+ $meta->{recycle_bin_uuid} = $from->{recycle_bin_uuid};
+ $meta->{recycle_bin_changed} = _decode_datetime($from->{recycle_bin_changed});
+ $meta->{entry_templates_group} = $from->{entry_templates_group};
+ $meta->{entry_templates_group_changed} = _decode_datetime($from->{entry_templates_group_changed});
+ $meta->{last_selected_group} = $from->{last_selected_group};
+ $meta->{last_top_visible_group} = $from->{last_top_visible_group};
+ $meta->{history_max_items} = $from->{history_max_items};
+ $meta->{history_max_size} = $from->{history_max_size};
+ $meta->{settings_changed} = _decode_datetime($from->{settings_changed});
+
+ while (my ($key, $value) = each %{$from->{custom_icons} || {}}) {
+ $meta->{custom_icons}{$key} = {value => $value};
+ }
+ while (my ($key, $value) = each %{$from->{custom_data} || {}}) {
+ $meta->{custom_data}{$key} = {value => $value};
+ }
+
+ return $kdbx;
+}
+
+sub _convert_keepass_to_kdbx_group {
+ my $from = shift;
+ my $to = shift // {};
+ my %args = @_;
+
+ $to->{times}{last_access_time} = _decode_datetime($from->{accessed});
+ $to->{times}{usage_count} = $from->{usage_count} || 0;
+ $to->{times}{expiry_time} = _decode_datetime($from->{expires}, $DEFAULT_EXPIRATION);
+ $to->{times}{expires} = defined $from->{expires_enabled}
+ ? boolean($from->{expires_enabled})
+ : boolean($to->{times}{expiry_time} <= gmtime);
+ $to->{times}{creation_time} = _decode_datetime($from->{created});
+ $to->{times}{last_modification_time} = _decode_datetime($from->{modified});
+ $to->{times}{location_changed} = _decode_datetime($from->{location_changed});
+ $to->{notes} = $from->{notes} // '';
+ $to->{uuid} = _decode_uuid($from->{id});
+ $to->{is_expanded} = boolean($from->{expanded});
+ $to->{icon_id} = $from->{icon} // ICON_FOLDER;
+ $to->{name} = $from->{title} // '';
+ $to->{default_auto_type_sequence} = $from->{auto_type_default} // '';
+ $to->{enable_auto_type} = _decode_tristate($from->{auto_type_enabled});
+ $to->{enable_searching} = _decode_tristate($from->{enable_searching});
+ $to->{groups} = [];
+ $to->{entries} = [];
+
+ if (!$args{shallow}) {
+ for my $group (@{$from->{groups} || []}) {
+ push @{$to->{groups}}, _convert_keepass_to_kdbx_group($group);
+ }
+ for my $entry (@{$from->{entries} || []}) {
+ push @{$to->{entries}}, _convert_keepass_to_kdbx_entry($entry);
+ }
+ }
+
+ return $to;
+}
+
+sub _convert_keepass_to_kdbx_entry {
+ my $from = shift;
+ my $to = shift // {};
+ my %args = @_;
+
+ $to->{times}{last_access_time} = _decode_datetime($from->{accessed});
+ $to->{times}{usage_count} = $from->{usage_count} || 0;
+ $to->{times}{expiry_time} = _decode_datetime($from->{expires}, $DEFAULT_EXPIRATION);
+ $to->{times}{expires} = defined $from->{expires_enabled}
+ ? boolean($from->{expires_enabled})
+ : boolean($to->{times}{expiry_time} <= gmtime);
+ $to->{times}{creation_time} = _decode_datetime($from->{created});
+ $to->{times}{last_modification_time} = _decode_datetime($from->{modified});
+ $to->{times}{location_changed} = _decode_datetime($from->{location_changed});
+
+ $to->{auto_type}{data_transfer_obfuscation} = $from->{auto_type_munge} || false;
+ $to->{auto_type}{enabled} = boolean($from->{auto_type_enabled} // 1);
+
+ my $comment = $from->{comment};
+ my @auto_type = is_arrayref($from->{auto_type}) ? @{$from->{auto_type}} : ();
+
+ if (!@auto_type && nonempty $from->{auto_type} && nonempty $from->{auto_type_window}
+ && !is_hashref($from->{auto_type})) {
+ @auto_type = ({window => $from->{auto_type_window}, keys => $from->{auto_type}});
+ }
+ if (nonempty $comment) {
+ my @AT;
+ my %atw = my @atw = $comment =~ m{ ^Auto-Type-Window((?:-?\d+)?): [\t ]* (.*?) [\t ]*$ }mxg;
+ my %atk = my @atk = $comment =~ m{ ^Auto-Type((?:-?\d+)?): [\t ]* (.*?) [\t ]*$ }mxg;
+ $comment =~ s{ ^Auto-Type(?:-Window)?(?:-?\d+)?: .* \n? }{}mxg;
+ while (@atw) {
+ my ($n, $w) = (shift(@atw), shift(@atw));
+ push @AT, {window => $w, keys => exists($atk{$n}) ? $atk{$n} : $atk{''}};
+ }
+ while (@atk) {
+ my ($n, $k) = (shift(@atk), shift(@atk));
+ push @AT, {keys => $k, window => exists($atw{$n}) ? $atw{$n} : $atw{''}};
+ }
+ for (@AT) {
+ $_->{'window'} //= '';
+ $_->{'keys'} //= '';
+ }
+ my %uniq;
+ @AT = grep {!$uniq{"$_->{'window'}\e$_->{'keys'}"}++} @AT;
+ push @auto_type, @AT;
+ }
+ $to->{auto_type}{associations} = [
+ map { +{window => $_->{window}, keystroke_sequence => $_->{keys}} } @auto_type,
+ ];
+
+ $to->{strings}{Notes}{value} = $comment;
+ $to->{strings}{UserName}{value} = $from->{username};
+ $to->{strings}{Password}{value} = $from->{password};
+ $to->{strings}{URL}{value} = $from->{url};
+ $to->{strings}{Title}{value} = $from->{title};
+ $to->{strings}{Notes}{protect} = true if defined $from->{protected}{comment};
+ $to->{strings}{UserName}{protect} = true if defined $from->{protected}{username};
+ $to->{strings}{Password}{protect} = true if $from->{protected}{password} // 1;
+ $to->{strings}{URL}{protect} = true if defined $from->{protected}{url};
+ $to->{strings}{Title}{protect} = true if defined $from->{protected}{title};
+
+ # other strings
+ while (my ($key, $value) = each %{$from->{strings} || {}}) {
+ $to->{strings}{$key} = {
+ value => $value,
+ $from->{protected}{$key} ? (protect => true) : (),
+ };
+ }
+
+ $to->{override_url} = $from->{override_url};
+ $to->{tags} = $from->{tags} // '';
+ $to->{icon_id} = $from->{icon} // ICON_PASSWORD;
+ $to->{uuid} = _decode_uuid($from->{id});
+ $to->{foreground_color} = $from->{foreground_color} // '';
+ $to->{background_color} = $from->{background_color} // '';
+ $to->{custom_icon_uuid} = $from->{custom_icon_uuid};
+ $to->{history} = [];
+
+ local $from->{binary} = {$from->{binary_name} => $from->{binary}}
+ if nonempty $from->{binary} && nonempty $from->{binary_name} && !is_hashref($from->{binary});
+ while (my ($key, $value) = each %{$from->{binary} || {}}) {
+ $to->{binaries}{$key} = {value => $value};
+ }
+
+ if (!$args{shallow}) {
+ for my $entry (@{$from->{history} || []}) {
+ my $new_entry = {};
+ push @{$to->{entries}}, _convert_keepass_to_kdbx_entry($entry, $new_entry);
+ }
+ }
+
+ return $to;
+}
+
+sub _decode_datetime {
+ local $_ = shift // return shift // gmtime;
+ return Time::Piece->strptime($_, '%Y-%m-%d %H:%M:%S');
+}
+
+sub _decode_uuid {
+ local $_ = shift // return;
+ # Group IDs in KDB files are 32-bit integers
+ return sprintf('%016x', $_) if length($_) != 16 && looks_like_number($_);
+ return $_;
+}
+
+sub _decode_tristate {
+ local $_ = shift // return;
+ return boolean($_);
+}
+
+1;
+__END__
+
+=head1 DESCRIPTION
+
+Read older KDB (KeePass 1) files. This feature requires an additional module to be installed:
+
+=for :list
+* L<File::KeePass>
+
+=cut
--- /dev/null
+package File::KDBX::Loader::Raw;
+# ABSTRACT: A no-op loader that doesn't do any parsing
+
+use warnings;
+use strict;
+
+use parent 'File::KDBX::Loader';
+
+our $VERSION = '999.999'; # VERSION
+
+sub _read {
+ my $self = shift;
+ my $fh = shift;
+
+ $self->_read_body($fh);
+}
+
+sub _read_body {
+ my $self = shift;
+ my $fh = shift;
+
+ $self->_read_inner_body($fh);
+}
+
+sub _read_inner_body {
+ my $self = shift;
+ my $fh = shift;
+
+ my $content = do { local $/; <$fh> };
+ $self->kdbx->raw($content);
+}
+
+1;
+__END__
+
+=head1 SYNOPSIS
+
+ use File::KDBX::Loader;
+
+ my $kdbx = File::KDBX::Loader->load_file('file.kdbx', $key, inner_format => 'Raw');
+ print $kdbx->raw;
+
+=head1 DESCRIPTION
+
+A typical KDBX file is made up of an outer section (with headers) and an inner section (with the body). The
+inner section is usually loaded using L<File::KDBX::Loader::XML>, but you can use the
+B<File::KDBX::Loader::Raw> loader to not parse the body at all and just get the raw body content. This can be
+useful for debugging or creating KDBX files with arbitrary content (see L<File::KDBX::Dumper::Raw>).
+
+=cut
--- /dev/null
+package File::KDBX::Loader::V3;
+# ABSTRACT: Load KDBX3 files
+
+# magic
+# headers
+# body
+# CRYPT(
+# start bytes
+# HASH(
+# COMPRESS(
+# xml
+# )
+# )
+# )
+
+use warnings;
+use strict;
+
+use Crypt::Digest qw(digest_data);
+use Encode qw(decode);
+use File::KDBX::Constants qw(:header :compression :kdf);
+use File::KDBX::Error;
+use File::KDBX::Util qw(:io assert_64bit erase_scoped);
+use PerlIO::via::File::KDBX::Crypt;
+use PerlIO::via::File::KDBX::HashBlock;
+use namespace::clean;
+
+use parent 'File::KDBX::Loader';
+
+our $VERSION = '999.999'; # VERSION
+
+sub _read_header {
+ my $self = shift;
+ my $fh = shift;
+
+ read_all $fh, my $buf, 3 or throw 'Malformed header field, expected header type and size';
+ my ($type, $size) = unpack('C S<', $buf);
+
+ my $val;
+ if (0 < $size) {
+ read_all $fh, $val, $size or throw 'Expected header value', type => $type, size => $size;
+ $buf .= $val;
+ }
+
+ $type = KDBX_HEADER($type);
+ if ($type == HEADER_END) {
+ # done
+ }
+ elsif ($type == HEADER_COMMENT) {
+ $val = decode('UTF-8', $val);
+ }
+ elsif ($type == HEADER_CIPHER_ID) {
+ $size == 16 or throw 'Invalid cipher UUID length', got => $size, expected => $size;
+ }
+ elsif ($type == HEADER_COMPRESSION_FLAGS) {
+ $val = unpack('L<', $val);
+ }
+ elsif ($type == HEADER_MASTER_SEED) {
+ $size == 32 or throw 'Invalid master seed length', got => $size, expected => $size;
+ }
+ elsif ($type == HEADER_TRANSFORM_SEED) {
+ # nothing
+ }
+ elsif ($type == HEADER_TRANSFORM_ROUNDS) {
+ assert_64bit;
+ $val = unpack('Q<', $val);
+ }
+ elsif ($type == HEADER_ENCRYPTION_IV) {
+ # nothing
+ }
+ elsif ($type == HEADER_INNER_RANDOM_STREAM_KEY) {
+ # nothing
+ }
+ elsif ($type == HEADER_STREAM_START_BYTES) {
+ # nothing
+ }
+ elsif ($type == HEADER_INNER_RANDOM_STREAM_ID) {
+ $val = unpack('L<', $val);
+ }
+ elsif ($type == HEADER_KDF_PARAMETERS ||
+ $type == HEADER_PUBLIC_CUSTOM_DATA) {
+ throw "Unexpected KDBX4 header: $type", type => $type;
+ }
+ else {
+ alert "Unknown header: $type", type => $type;
+ }
+
+ return wantarray ? ($type => $val, $buf) : $buf;
+}
+
+sub _read_body {
+ my $self = shift;
+ my $fh = shift;
+ my $key = shift;
+ my $header_data = shift;
+ my $kdbx = $self->kdbx;
+
+ # assert all required headers present
+ for my $field (
+ HEADER_CIPHER_ID,
+ HEADER_ENCRYPTION_IV,
+ HEADER_MASTER_SEED,
+ HEADER_INNER_RANDOM_STREAM_KEY,
+ HEADER_STREAM_START_BYTES,
+ ) {
+ defined $kdbx->headers->{$field} or throw "Missing $field";
+ }
+
+ $kdbx->kdf_parameters({
+ KDF_PARAM_UUID() => KDF_UUID_AES,
+ KDF_PARAM_AES_ROUNDS() => delete $kdbx->headers->{+HEADER_TRANSFORM_ROUNDS},
+ KDF_PARAM_AES_SEED() => delete $kdbx->headers->{+HEADER_TRANSFORM_SEED},
+ });
+
+ my $master_seed = $kdbx->headers->{+HEADER_MASTER_SEED};
+
+ my @cleanup;
+ $key = $kdbx->composite_key($key);
+
+ my $response = $key->challenge($master_seed);
+ push @cleanup, erase_scoped $response;
+
+ my $transformed_key = $kdbx->kdf->transform($key);
+ push @cleanup, erase_scoped $transformed_key;
+
+ my $final_key = digest_data('SHA256', $master_seed, $response, $transformed_key);
+ push @cleanup, erase_scoped $final_key;
+
+ my $cipher = $kdbx->cipher(key => $final_key);
+ PerlIO::via::File::KDBX::Crypt->push($fh, $cipher);
+
+ read_all $fh, my $start_bytes, 32 or throw 'Failed to read starting bytes';
+
+ my $expected_start_bytes = $kdbx->headers->{stream_start_bytes};
+ $start_bytes eq $expected_start_bytes
+ or throw "Invalid credentials or data is corrupt (wrong starting bytes)\n",
+ got => $start_bytes, expected => $expected_start_bytes, headers => $kdbx->headers;
+
+ $kdbx->key($key);
+
+ PerlIO::via::File::KDBX::HashBlock->push($fh);
+
+ my $compress = $kdbx->headers->{+HEADER_COMPRESSION_FLAGS};
+ if ($compress == COMPRESSION_GZIP) {
+ require PerlIO::via::File::KDBX::Compression;
+ PerlIO::via::File::KDBX::Compression->push($fh);
+ }
+ elsif ($compress != COMPRESSION_NONE) {
+ throw "Unsupported compression ($compress)\n", compression_flags => $compress;
+ }
+
+ $self->_read_inner_body($fh);
+
+ binmode($fh, ':pop') if $compress;
+ binmode($fh, ':pop:pop');
+
+ if (my $header_hash = $kdbx->meta->{header_hash}) {
+ my $got_header_hash = digest_data('SHA256', $header_data);
+ $header_hash eq $got_header_hash
+ or throw 'Header hash does not match', got => $got_header_hash, expected => $header_hash;
+ }
+}
+
+1;
--- /dev/null
+package File::KDBX::Loader::V4;
+# ABSTRACT: Load KDBX4 files
+
+# magic
+# headers
+# headers checksum
+# headers hmac
+# body
+# HMAC(
+# CRYPT(
+# COMPRESS(
+# xml
+# )
+# )
+# )
+
+use warnings;
+use strict;
+
+use Crypt::Digest qw(digest_data);
+use Crypt::Mac::HMAC qw(hmac);
+use Encode qw(decode);
+use File::KDBX::Constants qw(:header :inner_header :variant_map :compression);
+use File::KDBX::Error;
+use File::KDBX::Util qw(:io assert_64bit erase_scoped);
+use PerlIO::via::File::KDBX::Crypt;
+use PerlIO::via::File::KDBX::HmacBlock;
+use boolean;
+use namespace::clean;
+
+use parent 'File::KDBX::Loader';
+
+our $VERSION = '999.999'; # VERSION
+
+sub _read_header {
+ my $self = shift;
+ my $fh = shift;
+
+ read_all $fh, my $buf, 5 or throw 'Malformed header field, expected header type and size';
+ my ($type, $size) = unpack('C L<', $buf);
+
+ my $val;
+ if (0 < $size) {
+ read_all $fh, $val, $size or throw 'Expected header value', type => $type, size => $size;
+ $buf .= $val;
+ }
+
+ $type = KDBX_HEADER($type);
+ if ($type == HEADER_END) {
+ # done
+ }
+ elsif ($type == HEADER_COMMENT) {
+ $val = decode('UTF-8', $val);
+ }
+ elsif ($type == HEADER_CIPHER_ID) {
+ $size == 16 or throw 'Invalid cipher UUID length', got => $size, expected => $size;
+ }
+ elsif ($type == HEADER_COMPRESSION_FLAGS) {
+ $val = unpack('L<', $val);
+ }
+ elsif ($type == HEADER_MASTER_SEED) {
+ $size == 32 or throw 'Invalid master seed length', got => $size, expected => $size;
+ }
+ elsif ($type == HEADER_ENCRYPTION_IV) {
+ # nothing
+ }
+ elsif ($type == HEADER_KDF_PARAMETERS) {
+ open(my $dict_fh, '<', \$val);
+ $val = $self->_read_variant_dictionary($dict_fh);
+ }
+ elsif ($type == HEADER_PUBLIC_CUSTOM_DATA) {
+ open(my $dict_fh, '<', \$val);
+ $val = $self->_read_variant_dictionary($dict_fh);
+ }
+ elsif ($type == HEADER_INNER_RANDOM_STREAM_ID ||
+ $type == HEADER_INNER_RANDOM_STREAM_KEY ||
+ $type == HEADER_TRANSFORM_SEED ||
+ $type == HEADER_TRANSFORM_ROUNDS ||
+ $type == HEADER_STREAM_START_BYTES) {
+ throw "Unexpected KDBX3 header: $type", type => $type;
+ }
+ else {
+ alert "Unknown header: $type", type => $type;
+ }
+
+ return wantarray ? ($type => $val, $buf) : $buf;
+}
+
+sub _read_variant_dictionary {
+ my $self = shift;
+ my $fh = shift;
+
+ read_all $fh, my $buf, 2 or throw 'Failed to read variant dictionary version';
+ my ($version) = unpack('S<', $buf);
+ VMAP_VERSION == ($version & VMAP_VERSION_MAJOR_MASK)
+ or throw 'Unsupported variant dictionary version', version => $version;
+
+ my %dict;
+
+ while (1) {
+ read_all $fh, $buf, 1 or throw 'Failed to read variant type';
+ my ($type) = unpack('C', $buf);
+ last if $type == VMAP_TYPE_END; # terminating null
+
+ read_all $fh, $buf, 4 or throw 'Failed to read variant key size';
+ my ($klen) = unpack('L<', $buf);
+
+ read_all $fh, my $key, $klen or throw 'Failed to read variant key';
+
+ read_all $fh, $buf, 4 or throw 'Failed to read variant size';
+ my ($vlen) = unpack('L<', $buf);
+
+ read_all $fh, my $val, $vlen or throw 'Failed to read variant';
+
+ if ($type == VMAP_TYPE_UINT32) {
+ ($val) = unpack('L<', $val);
+ }
+ elsif ($type == VMAP_TYPE_UINT64) {
+ assert_64bit;
+ ($val) = unpack('Q<', $val);
+ }
+ elsif ($type == VMAP_TYPE_BOOL) {
+ ($val) = unpack('C', $val);
+ $val = boolean($val);
+ }
+ elsif ($type == VMAP_TYPE_INT32) {
+ ($val) = unpack('l<', $val);
+ }
+ elsif ($type == VMAP_TYPE_INT64) {
+ assert_64bit;
+ ($val) = unpack('q<', $val);
+ }
+ elsif ($type == VMAP_TYPE_STRING) {
+ $val = decode('UTF-8', $val);
+ }
+ elsif ($type == VMAP_TYPE_BYTEARRAY) {
+ # nothing
+ }
+ else {
+ throw 'Unknown variant type', type => $type;
+ }
+ $dict{$key} = $val;
+ }
+
+ return \%dict;
+}
+
+sub _read_body {
+ my $self = shift;
+ my $fh = shift;
+ my $key = shift;
+ my $header_data = shift;
+ my $kdbx = $self->kdbx;
+
+ # assert all required headers present
+ for my $field (
+ HEADER_CIPHER_ID,
+ HEADER_ENCRYPTION_IV,
+ HEADER_MASTER_SEED,
+ ) {
+ defined $kdbx->headers->{$field} or throw "Missing $field";
+ }
+
+ my @cleanup;
+
+ # checksum check
+ read_all $fh, my $header_hash, 32 or throw 'Failed to read header hash';
+ my $got_header_hash = digest_data('SHA256', $header_data);
+ $got_header_hash eq $header_hash
+ or throw 'Data is corrupt (header checksum mismatch)',
+ got => $got_header_hash, expected => $header_hash;
+
+ $key = $kdbx->composite_key($key);
+ my $transformed_key = $kdbx->kdf->transform($key);
+ push @cleanup, erase_scoped $transformed_key;
+
+ # authentication check
+ read_all $fh, my $header_hmac, 32 or throw 'Failed to read header HMAC';
+ my $hmac_key = digest_data('SHA512', $kdbx->headers->{master_seed}, $transformed_key, "\x01");
+ push @cleanup, erase_scoped $hmac_key;
+ my $got_header_hmac = hmac('SHA256',
+ digest_data('SHA512', "\xff\xff\xff\xff\xff\xff\xff\xff", $hmac_key),
+ $header_data,
+ );
+ $got_header_hmac eq $header_hmac
+ or throw "Invalid credentials or data is corrupt (header HMAC mismatch)\n",
+ got => $got_header_hmac, expected => $header_hmac;
+
+ $kdbx->key($key);
+
+ PerlIO::via::File::KDBX::HmacBlock->push($fh, $hmac_key);
+
+ my $final_key = digest_data('SHA256', $kdbx->headers->{master_seed}, $transformed_key);
+ push @cleanup, erase_scoped $final_key;
+
+ my $cipher = $kdbx->cipher(key => $final_key);
+ PerlIO::via::File::KDBX::Crypt->push($fh, $cipher);
+
+ my $compress = $kdbx->headers->{+HEADER_COMPRESSION_FLAGS};
+ if ($compress == COMPRESSION_GZIP) {
+ require PerlIO::via::File::KDBX::Compression;
+ PerlIO::via::File::KDBX::Compression->push($fh);
+ }
+ elsif ($compress != COMPRESSION_NONE) {
+ throw "Unsupported compression ($compress)\n", compression_flags => $compress;
+ }
+
+ $self->_read_inner_headers($fh);
+ $self->_read_inner_body($fh);
+
+ binmode($fh, ':pop') if $compress;
+ binmode($fh, ':pop:pop');
+}
+
+sub _read_inner_headers {
+ my $self = shift;
+ my $fh = shift;
+
+ while (my ($type, $val) = $self->_read_inner_header($fh)) {
+ last if $type == INNER_HEADER_END;
+ }
+}
+
+sub _read_inner_header {
+ my $self = shift;
+ my $fh = shift;
+ my $kdbx = $self->kdbx;
+
+ read_all $fh, my $buf, 1 or throw 'Expected inner header type';
+ my ($type) = unpack('C', $buf);
+
+ read_all $fh, $buf, 4 or throw 'Expected inner header size', type => $type;
+ my ($size) = unpack('L<', $buf);
+
+ my $val;
+ if (0 < $size) {
+ read_all $fh, $val, $size or throw 'Expected inner header value', type => $type, size => $size;
+ }
+
+ $type = KDBX_INNER_HEADER($type);
+
+ if ($type == INNER_HEADER_END) {
+ # nothing
+ }
+ elsif ($type == INNER_HEADER_INNER_RANDOM_STREAM_ID) {
+ $val = unpack('L<', $val);
+ $kdbx->inner_headers->{$type} = $val;
+ }
+ elsif ($type == INNER_HEADER_INNER_RANDOM_STREAM_KEY) {
+ $kdbx->inner_headers->{$type} = $val;
+ }
+ elsif ($type == INNER_HEADER_BINARY) {
+ my $msize = $size - 1;
+ my ($flags, $data) = unpack("C a$msize", $val);
+ my $id = scalar keys %{$kdbx->binaries};
+ $kdbx->binaries->{$id} = {
+ value => $data,
+ $flags & INNER_HEADER_BINARY_FLAG_PROTECT ? (protect => true) : (),
+ };
+ }
+
+ return wantarray ? ($type => $val) : $type;
+}
+
+1;
--- /dev/null
+package File::KDBX::Loader::XML;
+# ABSTRACT: Load unencrypted XML KeePass files
+
+use warnings;
+use strict;
+
+use Crypt::Misc 0.029 qw(decode_b64);
+use Encode qw(decode);
+use File::KDBX::Constants qw(:version :time);
+use File::KDBX::Error;
+use File::KDBX::Safe;
+use File::KDBX::Util qw(:text assert_64bit gunzip erase_scoped);
+use Scalar::Util qw(looks_like_number);
+use Time::Piece;
+use XML::LibXML::Reader;
+use boolean;
+use namespace::clean;
+
+use parent 'File::KDBX::Loader';
+
+our $VERSION = '999.999'; # VERSION
+
+sub _reader { $_[0]->{_reader} }
+
+sub _binaries { $_[0]->{binaries} //= {} }
+
+sub _safe { $_[0]->{safe} //= File::KDBX::Safe->new(cipher => $_[0]->kdbx->random_stream) }
+
+sub _read {
+ my $self = shift;
+ my $fh = shift;
+
+ $self->_read_inner_body($fh);
+}
+
+sub _read_inner_body {
+ my $self = shift;
+ my $fh = shift;
+
+ # print do { local $/; <$fh> };
+ # exit;
+ my $reader = $self->{_reader} = XML::LibXML::Reader->new(IO => $fh);
+
+ delete $self->{safe};
+ my $root_done;
+
+ my $pattern = XML::LibXML::Pattern->new('/KeePassFile/Meta|/KeePassFile/Root');
+ while ($reader->nextPatternMatch($pattern) == 1) {
+ next if $reader->nodeType != XML_READER_TYPE_ELEMENT;
+ my $name = $reader->localName;
+ if ($name eq 'Meta') {
+ $self->_read_xml_meta;
+ }
+ elsif ($name eq 'Root') {
+ if ($root_done) {
+ alert 'Ignoring extra Root element in KeePass XML file', line => $reader->lineNumber;
+ next;
+ }
+ $self->_read_xml_root;
+ $root_done = 1;
+ }
+ }
+
+ if ($reader->readState == XML_READER_ERROR) {
+ throw 'Failed to parse KeePass XML';
+ }
+
+ $self->kdbx->_safe($self->_safe) if $self->{safe};
+
+ $self->_resolve_binary_refs;
+}
+
+sub _read_xml_meta {
+ my $self = shift;
+
+ $self->_read_xml_element($self->kdbx->meta,
+ Generator => 'text',
+ HeaderHash => 'binary',
+ DatabaseName => 'text',
+ DatabaseNameChanged => 'datetime',
+ DatabaseDescription => 'text',
+ DatabaseDescriptionChanged => 'datetime',
+ DefaultUserName => 'text',
+ DefaultUserNameChanged => 'datetime',
+ MaintenanceHistoryDays => 'number',
+ Color => 'text',
+ MasterKeyChanged => 'datetime',
+ MasterKeyChangeRec => 'number',
+ MasterKeyChangeForce => 'number',
+ MemoryProtection => \&_read_xml_memory_protection,
+ CustomIcons => \&_read_xml_custom_icons,
+ RecycleBinEnabled => 'bool',
+ RecycleBinUUID => 'uuid',
+ RecycleBinChanged => 'datetime',
+ EntryTemplatesGroup => 'uuid',
+ EntryTemplatesGroupChanged => 'datetime',
+ LastSelectedGroup => 'uuid',
+ LastTopVisibleGroup => 'uuid',
+ HistoryMaxItems => 'number',
+ HistoryMaxSize => 'number',
+ SettingsChanged => 'datetime',
+ Binaries => \&_read_xml_binaries,
+ CustomData => \&_read_xml_custom_data,
+ );
+}
+
+sub _read_xml_memory_protection {
+ my $self = shift;
+ my $meta = shift // $self->kdbx->meta;
+
+ return $self->_read_xml_element(
+ ProtectTitle => 'bool',
+ ProtectUserName => 'bool',
+ ProtectPassword => 'bool',
+ ProtectURL => 'bool',
+ ProtectNotes => 'bool',
+ AutoEnableVisualHiding => 'bool',
+ );
+}
+
+sub _read_xml_binaries {
+ my $self = shift;
+ my $kdbx = $self->kdbx;
+
+ my $binaries = $self->_read_xml_element(
+ Binary => sub {
+ my $self = shift;
+ my $id = $self->_read_xml_attribute('ID');
+ my $compressed = $self->_read_xml_attribute('Compressed', 'bool', false);
+ my $protected = $self->_read_xml_attribute('Protected', 'bool', false);
+ my $data = $self->_read_xml_content('binary');
+
+ my $binary = {
+ value => $data,
+ $protected ? (protect => true) : (),
+ };
+
+ if ($protected) {
+ # if compressed, decompress later when the safe is unlocked
+ $self->_safe->add_protected($compressed ? \&gunzip : (), $binary);
+ }
+ elsif ($compressed) {
+ $binary->{value} = gunzip($data);
+ }
+
+ $id => $binary;
+ },
+ );
+
+ $kdbx->binaries({%{$kdbx->binaries}, %$binaries});
+ return (); # do not add to meta
+}
+
+sub _read_xml_custom_data {
+ my $self = shift;
+
+ return $self->_read_xml_element(
+ Item => sub {
+ my $self = shift;
+ my $item = $self->_read_xml_element(
+ Key => 'text',
+ Value => 'text',
+ LastModificationTime => 'datetime', # KDBX4.1
+ );
+ $item->{key} => $item;
+ },
+ );
+}
+
+sub _read_xml_custom_icons {
+ my $self = shift;
+
+ return $self->_read_xml_element(
+ Icon => sub {
+ my $self = shift;
+ my $icon = $self->_read_xml_element(
+ UUID => 'uuid',
+ Data => 'binary',
+ Name => 'text', # KDBX4.1
+ LastModificationTime => 'datetime', # KDBX4.1
+ );
+ $icon->{uuid} => $icon;
+ },
+ );
+}
+
+sub _read_xml_root {
+ my $self = shift;
+ my $kdbx = $self->kdbx;
+
+ my $root = $self->_read_xml_element(
+ Group => \&_read_xml_group,
+ DeletedObjects => \&_read_xml_deleted_objects,
+ );
+
+ $kdbx->deleted_objects($root->{deleted_objects});
+ $kdbx->root($root->{group}) if $root->{group};
+}
+
+sub _read_xml_group {
+ my $self = shift;
+
+ return $self->_read_xml_element({entries => [], groups => []},
+ UUID => 'uuid',
+ Name => 'text',
+ Notes => 'text',
+ Tags => 'text', # KDBX4.1
+ IconID => 'number',
+ CustomIconUUID => 'uuid',
+ Times => \&_read_xml_times,
+ IsExpanded => 'bool',
+ DefaultAutoTypeSequence => 'text',
+ EnableAutoType => 'tristate',
+ EnableSearching => 'tristate',
+ LastTopVisibleEntry => 'uuid',
+ CustomData => \&_read_xml_custom_data, # KDBX4
+ PreviousParentGroup => 'uuid', # KDBX4.1
+ Entry => [entries => \&_read_xml_entry],
+ Group => [groups => \&_read_xml_group],
+ );
+}
+
+sub _read_xml_entry {
+ my $self = shift;
+
+ my $entry = $self->_read_xml_element({strings => [], binaries => []},
+ UUID => 'uuid',
+ IconID => 'number',
+ CustomIconUUID => 'uuid',
+ ForegroundColor => 'text',
+ BackgroundColor => 'text',
+ OverrideURL => 'text',
+ Tags => 'text',
+ Times => \&_read_xml_times,
+ AutoType => \&_read_xml_entry_auto_type,
+ PreviousParentGroup => 'uuid', # KDBX4.1
+ QualityCheck => 'bool', # KDBX4.1
+ String => [strings => \&_read_xml_entry_string],
+ Binary => [binaries => \&_read_xml_entry_binary],
+ CustomData => \&_read_xml_custom_data, # KDBX4
+ History => sub {
+ my $self = shift;
+ return $self->_read_xml_element([],
+ Entry => \&_read_xml_entry,
+ );
+ },
+ );
+
+ my %strings;
+ for my $string (@{$entry->{strings} || []}) {
+ $strings{$string->{key}} = $string->{value};
+ }
+ $entry->{strings} = \%strings;
+
+ my %binaries;
+ for my $binary (@{$entry->{binaries} || []}) {
+ $binaries{$binary->{key}} = $binary->{value};
+ }
+ $entry->{binaries} = \%binaries;
+
+ return $entry;
+}
+
+sub _read_xml_times {
+ my $self = shift;
+
+ return $self->_read_xml_element(
+ LastModificationTime => 'datetime',
+ CreationTime => 'datetime',
+ LastAccessTime => 'datetime',
+ ExpiryTime => 'datetime',
+ Expires => 'bool',
+ UsageCount => 'number',
+ LocationChanged => 'datetime',
+ );
+}
+
+sub _read_xml_entry_string {
+ my $self = shift;
+
+ return $self->_read_xml_element(
+ Key => 'text',
+ Value => sub {
+ my $self = shift;
+
+ my $protected = $self->_read_xml_attribute('Protected', 'bool', false);
+ my $protect_in_memory = $self->_read_xml_attribute('ProtectInMemory', 'bool', false);
+ my $protect = $protected || $protect_in_memory;
+
+ my $val = $self->_read_xml_content($protected ? 'binary' : 'text');
+
+ my $string = {
+ value => $val,
+ $protect ? (protect => true) : (),
+ };
+
+ $self->_safe->add_protected(sub { decode('UTF-8', $_[0]) }, $string) if $protected;
+
+ $string;
+ },
+ );
+}
+
+sub _read_xml_entry_binary {
+ my $self = shift;
+
+ return $self->_read_xml_element(
+ Key => 'text',
+ Value => sub {
+ my $self = shift;
+
+ my $ref = $self->_read_xml_attribute('Ref');
+ my $compressed = $self->_read_xml_attribute('Compressed', 'bool', false);
+ my $protected = $self->_read_xml_attribute('Protected', 'bool', false);
+ my $binary = {};
+
+ if (defined $ref) {
+ $binary->{ref} = $ref;
+ }
+ else {
+ $binary->{value} = $self->_read_xml_content('binary');
+ $binary->{protect} = true if $protected;
+
+ if ($protected) {
+ # if compressed, decompress later when the safe is unlocked
+ $self->_safe->add_protected($compressed ? \&gunzip : (), $binary);
+ }
+ elsif ($compressed) {
+ $binary->{value} = gunzip($binary->{value});
+ }
+ }
+
+ $binary;
+ },
+ );
+}
+
+sub _read_xml_entry_auto_type {
+ my $self = shift;
+
+ return $self->_read_xml_element({associations => []},
+ Enabled => 'bool',
+ DataTransferObfuscation => 'number',
+ DefaultSequence => 'text',
+ Association => [associations => sub {
+ my $self = shift;
+ return $self->_read_xml_element(
+ Window => 'text',
+ KeystrokeSequence => 'text',
+ );
+ }],
+ );
+}
+
+sub _read_xml_deleted_objects {
+ my $self = shift;
+
+ return $self->_read_xml_element(
+ DeletedObject => sub {
+ my $self = shift;
+ my $object = $self->_read_xml_element(
+ UUID => 'uuid',
+ DeletionTime => 'datetime',
+ );
+ $object->{uuid} => $object;
+ }
+ );
+}
+
+##############################################################################
+
+sub _resolve_binary_refs {
+ my $self = shift;
+ my $kdbx = $self->kdbx;
+
+ my $entries = $kdbx->all_entries(history => 1);
+ my $pool = $kdbx->binaries;
+
+ for my $entry (@$entries) {
+ while (my ($key, $binary) = each %{$entry->binaries}) {
+ my $ref = $binary->{ref} // next;
+ next if defined $binary->{value};
+
+ my $data = $pool->{$ref};
+ if (!defined $data || !defined $data->{value}) {
+ alert "Found a reference to a missing binary: $key", key => $key, ref => $ref;
+ next;
+ }
+ $binary->{value} = $data->{value};
+ $binary->{protect} = true if $data->{protect};
+ delete $binary->{ref};
+ }
+ }
+}
+
+##############################################################################
+
+sub _read_xml_element {
+ my $self = shift;
+ my $args = @_ % 2 == 1 ? shift : {};
+ my %spec = @_;
+
+ my $reader = $self->_reader;
+ my $path = $reader->nodePath;
+ $path =~ s!\Q/text()\E$!!;
+
+ return $args if $reader->isEmptyElement;
+
+ my $store = ref $args eq 'CODE' ? $args
+ : ref $args eq 'HASH' ? sub {
+ my ($key, $val) = @_;
+ if (ref $args->{$key} eq 'HASH') {
+ $args->{$key}{$key} = $val;
+ }
+ elsif (ref $args->{$key} eq 'ARRAY') {
+ push @{$args->{$key}}, $val;
+ }
+ else {
+ exists $args->{$key}
+ and alert 'Overwriting value', node => $reader->nodePath, line => $reader->lineNumber;
+ $args->{$key} = $val;
+ }
+ } : ref $args eq 'ARRAY' ? sub {
+ my ($key, $val) = @_;
+ push @$args, $val;
+ } : sub {};
+
+ my $pattern = XML::LibXML::Pattern->new("${path}|${path}/*");
+ while ($reader->nextPatternMatch($pattern) == 1) {
+ last if $reader->nodePath eq $path && $reader->nodeType == XML_READER_TYPE_END_ELEMENT;
+ next if $reader->nodeType != XML_READER_TYPE_ELEMENT;
+
+ my $name = $reader->localName;
+ my $key = snakify($name);
+ my $type = $spec{$name};
+ ($key, $type) = @$type if ref $type eq 'ARRAY';
+
+ if (!defined $type) {
+ exists $spec{$name} or alert "Ignoring unknown element: $name",
+ node => $reader->nodePath,
+ line => $reader->lineNumber;
+ next;
+ }
+
+ if (ref $type eq 'CODE') {
+ my @result = $self->$type($args, $reader->nodePath);
+ if (@result == 2) {
+ $store->(@result);
+ }
+ elsif (@result == 1) {
+ $store->($key, @result);
+ }
+ }
+ else {
+ $store->($key, $self->_read_xml_content($type));
+ }
+ }
+
+ return $args;
+}
+
+sub _read_xml_attribute {
+ my $self = shift;
+ my $name = shift;
+ my $type = shift // 'text';
+ my $default = shift;
+ my $reader = $self->_reader;
+
+ return $default if !$reader->hasAttributes;
+
+ my $value = trim($reader->getAttribute($name));
+ if (!defined $value) {
+ # try again after reading in all the attributes
+ $reader->moveToFirstAttribute;
+ while ($self->_reader->readAttributeValue == 1) {}
+ $reader->moveToElement;
+
+ $value = trim($reader->getAttribute($name));
+ }
+
+ return $default if !defined $value;
+
+ my $decoded = eval { _decode_primitive($value, $type) };
+ if (my $err = $@) {
+ ref $err and $err->details(attribute => $name, node => $reader->nodePath, line => $reader->lineNumber);
+ throw $err
+ }
+
+ return $decoded;
+}
+
+sub _read_xml_content {
+ my $self = shift;
+ my $type = shift;
+ my $reader = $self->_reader;
+
+ $reader->read if !$reader->isEmptyElement; # step into element
+ return '' if !$reader->hasValue;
+
+ my $content = trim($reader->value);
+
+ my $decoded = eval { _decode_primitive($content, $type) };
+ if (my $err = $@) {
+ ref $err and $err->details(node => $reader->nodePath, line => $reader->lineNumber);
+ throw $err
+ }
+
+ return $decoded;
+}
+
+##############################################################################
+
+sub _decode_primitive { goto &{__PACKAGE__."::_decode_$_[1]"} }
+
+sub _decode_binary {
+ local $_ = shift;
+ return '' if !defined || (ref && !defined $$_);
+ $_ = eval { decode_b64(ref $_ ? $$_ : $_) };
+ my $err = $@;
+ my $cleanup = erase_scoped $_;
+ $err and throw 'Failed to parse binary', error => $err;
+ return $_;
+}
+
+sub _decode_bool {
+ local $_ = shift;
+ return true if /^True$/i;
+ return false if /^False$/i;
+ return false if length($_) == 0;
+ throw 'Expected boolean', text => $_;
+}
+
+sub _decode_datetime {
+ local $_ = shift;
+
+ if (/^[A-Za-z0-9\+\/\=]+$/) {
+ my $binary = eval { decode_b64($_) };
+ if (my $err = $@) {
+ throw 'Failed to parse binary datetime', text => $_, error => $err;
+ }
+ throw $@ if $@;
+ assert_64bit;
+ $binary .= \0 x (8 - length($binary)) if length($binary) < 8;
+ my ($seconds_since_ad1) = unpack('Q<', $binary);
+ my $epoch = $seconds_since_ad1 - TIME_SECONDS_AD1_TO_UNIX_EPOCH;
+ return Time::Piece->new($epoch);
+ }
+
+
+ my $dt = eval { Time::Piece->strptime($_, '%Y-%m-%dT%H:%M:%SZ') };
+ if (my $err = $@) {
+ throw 'Failed to parse datetime', text => $_, error => $err;
+ }
+ return $dt;
+}
+
+sub _decode_tristate {
+ local $_ = shift;
+ return undef if /^null$/i;
+ my $tristate = eval { _decode_bool($_) };
+ $@ and throw 'Expected tristate', text => $_, error => $@;
+ return $tristate;
+}
+
+sub _decode_number {
+ local $_ = shift;
+ $_ = _decode_text($_);
+ looks_like_number($_) or throw 'Expected number', text => $_;
+ return $_+0;
+}
+
+sub _decode_text {
+ local $_ = shift;
+ return '' if !defined;
+ return $_;
+}
+
+sub _decode_uuid {
+ local $_ = shift;
+ my $uuid = eval { _decode_binary($_) };
+ $@ and throw 'Expected UUID', text => $_, error => $@;
+ length($uuid) == 16 or throw 'Invalid UUID size', size => length($uuid);
+ return $uuid;
+}
+
+1;
--- /dev/null
+package File::KDBX::Object;
+# ABSTRACT: A KDBX database object
+
+use warnings;
+use strict;
+
+use Devel::GlobalDestruction;
+use File::KDBX::Error;
+use File::KDBX::Util qw(:uuid);
+use Ref::Util qw(is_arrayref is_plain_hashref is_ref);
+use Scalar::Util qw(blessed refaddr weaken);
+use namespace::clean;
+
+our $VERSION = '999.999'; # VERSION
+
+my %KDBX;
+
+=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);
+
+Construct a new KDBX object.
+
+There is a subtlety to take note of. There is a significant difference between:
+
+ File::KDBX::Entry->new(username => 'iambatman');
+
+and:
+
+ 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).
+
+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
+C<< {username => $str} >> isn't a valid raw KDBX entry object. The L</username> attribute is really a proxy
+for the C<UserName> string, so the equivalent raw entry object should be
+C<< {strings => {UserName => {value => $str}}} >>. These are roughly equivalent:
+
+ File::KDBX::Entry->new(username => 'iambatman');
+ File::KDBX::Entry->new({strings => {UserName => {value => 'iambatman'}}});
+
+If this explanation went over your head, that's fine. Just stick with the attributes since they are typically
+easier to use correctly and provide the most convenience. If in the future you think of some kind of KDBX
+object manipulation you want to do that isn't supported by the accessors and methods, just know you I<can>
+access an object's data directly.
+
+=cut
+
+sub new {
+ my $class = shift;
+
+ # copy constructor
+ return $_[0]->clone if @_ == 1 && blessed $_[0] && $_[0]->isa($class);
+
+ my $data;
+ $data = shift if is_plain_hashref($_[0]);
+
+ my $kdbx;
+ $kdbx = shift if @_ % 2 == 1;
+
+ my %args = @_;
+ $args{kdbx} //= $kdbx if defined $kdbx;
+
+ my $self = bless $data // {}, $class;
+ $self->init(%args);
+ $self->_set_default_attributes if !$data;
+ return $self;
+}
+
+sub init {
+ my $self = shift;
+ my %args = @_;
+
+ while (my ($key, $val) = each %args) {
+ if (my $method = $self->can($key)) {
+ $self->$method($val);
+ }
+ }
+
+ return $self;
+}
+
+sub DESTROY {
+ return if in_global_destruction;
+ my $self = shift;
+ delete $KDBX{refaddr($self)};
+}
+
+=method wrap
+
+ $object = File::KDBX::Object->wrap($object);
+
+Ensure that a KDBX object is blessed.
+
+=cut
+
+sub wrap {
+ 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, @_);
+}
+
+=method label
+
+ $label = $object->label;
+ $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.
+
+=cut
+
+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
+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.
+
+=cut
+
+my %CLONE = (entries => 1, groups => 1, history => 1);
+sub clone {
+ my $self = shift;
+ my %args = @_;
+
+ local $CLONE{new_uuid} = $args{new_uuid} // $args{parent} // 0;
+ local $CLONE{entries} = $args{entries} // 1;
+ local $CLONE{groups} = $args{groups} // 1;
+ local $CLONE{history} = $args{history} // 1;
+ local $CLONE{reference_password} = $args{reference_password} // 0;
+ local $CLONE{reference_username} = $args{reference_username} // 0;
+
+ require Storable;
+ my $copy = Storable::dclone($self);
+
+ if ($args{relabel} and my $label = $self->label) {
+ $copy->label("$label - Copy");
+ }
+ if ($args{parent} and my $parent = $self->parent) {
+ $parent->add_object($copy);
+ }
+
+ return $copy;
+}
+
+sub STORABLE_freeze {
+ my $self = shift;
+ my $cloning = shift;
+
+ my $copy = {%$self};
+ delete $copy->{entries} if !$CLONE{entries};
+ delete $copy->{groups} if !$CLONE{groups};
+ delete $copy->{history} if !$CLONE{history};
+
+ return refaddr($self) || '', $copy;
+}
+
+sub STORABLE_thaw {
+ my $self = shift;
+ my $cloning = shift;
+ my $addr = shift;
+ my $clone = shift;
+
+ @$self{keys %$clone} = values %$clone;
+
+ my $kdbx = $KDBX{$addr};
+ $self->kdbx($kdbx) if $kdbx;
+
+ if ($self->{uuid}) {
+ if (($CLONE{reference_password} || $CLONE{reference_username}) && $self->isa('File::KDBX::Entry')) {
+ my $uuid = format_uuid($self->{uuid});
+ my $clone_obj = do {
+ local $CLONE{new_uuid} = 0;
+ local $CLONE{entries} = 1;
+ local $CLONE{groups} = 1;
+ local $CLONE{history} = 1;
+ local $CLONE{reference_password} = 0;
+ local $CLONE{reference_username} = 0;
+ bless Storable::dclone({%$clone}), 'File::KDBX::Entry';
+ };
+ my $txn = $self->begin_work($clone_obj);
+ if ($CLONE{reference_password}) {
+ $self->password("{REF:P\@I:$uuid}");
+ }
+ if ($CLONE{reference_username}) {
+ $self->username("{REF:U\@I:$uuid}");
+ }
+ $txn->commit;
+ }
+ $self->uuid(generate_uuid) if $CLONE{new_uuid};
+ }
+}
+
+=attr kdbx
+
+ $kdbx = $object->kdbx;
+ $object->kdbx($kdbx);
+
+Get or set the L<File::KDBX> instance associated with this object.
+
+=cut
+
+sub kdbx {
+ my $self = shift;
+ $self = $self->new if !ref $self;
+ my $addr = refaddr($self);
+ if (@_) {
+ $KDBX{$addr} = shift;
+ if (defined $KDBX{$addr}) {
+ weaken $KDBX{$addr};
+ }
+ else {
+ delete $KDBX{$addr};
+ }
+ }
+ $KDBX{$addr} or throw 'Object is disassociated from a KDBX database', object => $self;
+}
+
+=method id
+
+ $string_uuid = $object->id;
+ $string_uuid = $object->id($delimiter);
+
+Get the unique identifier for this object as a B<formatted> UUID string, typically for display purposes. You
+could use this to compare with other identifiers formatted with the same delimiter, but it is more efficient
+to use the raw UUID for that purpose (see L</uuid>).
+
+A delimiter can optionally be provided to break up the UUID string visually. See
+L<File::KDBX::Util/format_uuid>.
+
+=cut
+
+sub id { format_uuid(shift->uuid, @_) }
+
+=method group
+
+ $group = $object->group;
+
+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;
+}
+
+sub parent { shift->group(@_) }
+
+=method remove
+
+ $object = $object->remove;
+
+Remove the object from the database. If the object is a group, all contained objects are removed as well.
+
+=cut
+
+sub remove {
+ my $self = shift;
+ my $parent = $self->parent;
+ $parent->remove_object($self) if $parent;
+ return $self;
+}
+
+=method tag_list
+
+ @tags = $entry->tag_list;
+
+Get a list of tags, split from L</tag> using delimiters C<,>, C<.>, C<:>, C<;> and whitespace.
+
+=cut
+
+sub tag_list {
+ my $self = shift;
+ return grep { $_ ne '' } split(/[,\.:;]|\s+/, trim($self->tags) // '');
+}
+
+=method custom_icon
+
+ $image_data = $object->custom_icon;
+ $image_data = $object->custom_icon($image_data, %attributes);
+
+Get or set an icon image. Returns C<undef> if there is no custom icon set. Setting a custom icon will change
+the L</custom_icon_uuid> attribute.
+
+Custom icon attributes (supported in KDBX4.1 and greater):
+
+=for :list
+* C<name> - Name of the icon (text)
+* C<last_modification_time> - Just what it says (datetime)
+
+=cut
+
+sub custom_icon {
+ my $self = shift;
+ my $kdbx = $self->kdbx;
+ if (@_) {
+ my $img = shift;
+ my $uuid = defined $img ? $kdbx->add_custom_icon($img, @_) : undef;
+ $self->icon_id(0) if $uuid;
+ $self->custom_icon_uuid($uuid);
+ return $img;
+ }
+ return $kdbx->custom_icon_data($self->custom_icon_uuid);
+}
+
+=method custom_data
+
+ \%all_data = $object->custom_data;
+ $object->custom_data(\%all_data);
+
+ \%data = $object->custom_data($key);
+ $object->custom_data($key => \%data);
+ $object->custom_data(%data);
+ $object->custom_data(key => $value, %data);
+
+Get and set custom data. Custom data is metadata associated with an object.
+
+Each data item can have a few attributes associated with it.
+
+=for :list
+* C<key> - A unique text string identifier used to look up the data item (required)
+* C<value> - A text string value (required)
+* C<last_modification_time> (optional, KDBX4.1+)
+
+=cut
+
+sub custom_data {
+ my $self = shift;
+ $self->{custom_data} = shift if @_ == 1 && is_plain_hashref($_[0]);
+ return $self->{custom_data} //= {} if !@_;
+
+ my %args = @_ == 2 ? (key => shift, value => shift)
+ : @_ % 2 == 1 ? (key => shift, @_) : @_;
+
+ if (!$args{key} && !$args{value}) {
+ my %standard = (key => 1, value => 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};
+ }
+ }
+
+ my $key = $args{key} or throw 'Must provide a custom_data key to access';
+
+ return $self->{custom_data}{$key} = $args{value} if is_plain_hashref($args{value});
+
+ while (my ($field, $value) = each %args) {
+ $self->{custom_data}{$key}{$field} = $value;
+ }
+ return $self->{custom_data}{$key};
+}
+
+=method custom_data_value
+
+ $value = $object->custom_data_value($key);
+
+Exactly the same as L</custom_data> except returns just the custom data's value rather than a structure of
+attributes. This is a shortcut for:
+
+ my $data = $object->custom_data($key);
+ my $value = defined $data ? $data->{value} : undef;
+
+=cut
+
+sub custom_data_value {
+ my $self = shift;
+ my $data = $self->custom_data(@_) // return undef;
+ return $data->{value};
+}
+
+1;
+__END__
+
+=head1 DESCRIPTION
+
+KDBX is an object database. This abstract class represents an object. You should not use this class directly
+but instead use its subclasses:
+
+=for :list
+* L<File::KDBX::Entry>
+* L<File::KDBX::Group>
+
+There is some functionality shared by both types of objects, and that's what this class provides.
+
+=cut
--- /dev/null
+package File::KDBX::Safe;
+# ABSTRACT: Keep strings encrypted while in memory
+
+use warnings;
+use strict;
+
+use Crypt::PRNG qw(random_bytes);
+use Devel::GlobalDestruction;
+use Encode qw(encode decode);
+use File::KDBX::Constants qw(:random_stream);
+use File::KDBX::Error;
+use File::KDBX::Util qw(erase erase_scoped);
+use Ref::Util qw(is_arrayref is_coderef is_hashref is_scalarref);
+use Scalar::Util qw(refaddr);
+use namespace::clean;
+
+our $VERSION = '999.999'; # VERSION
+
+=method new
+
+ $safe = File::KDBX::Safe->new(%attributes);
+ $safe = File::KDBX::Safe->new(\@strings, %attributes);
+
+Create a new safe for storing secret strings encrypted in memory.
+
+If a cipher is passed, its stream will be reset.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my %args = @_ % 2 == 0 ? @_ : (strings => shift, @_);
+
+ if (!$args{cipher} && $args{key}) {
+ require File::KDBX::Cipher;
+ $args{cipher} = File::KDBX::Cipher->new(stream_id => STREAM_ID_CHACHA20, key => $args{key});
+ }
+
+ my $self = bless \%args, $class;
+ $self->cipher->finish;
+ $self->{counter} = 0;
+
+ my $strings = delete $args{strings};
+ $self->{items} = [];
+ $self->{index} = {};
+ $self->add($strings) if $strings;
+
+ return $self;
+}
+
+sub DESTROY { !in_global_destruction and $_[0]->unlock }
+
+=method clear
+
+ $safe->clear;
+
+Clear a safe, removing all store contents permanently.
+
+=cut
+
+sub clear {
+ my $self = shift;
+ $self->{items} = [];
+ $self->{index} = {};
+ $self->{counter} = 0;
+ return $self;
+}
+
+=method add
+
+ $safe = $safe->lock(@strings);
+ $safe = $safe->lock(\@strings);
+
+Add strings to be encrypted.
+
+Alias: C<lock>
+
+=cut
+
+sub lock { shift->add(@_) }
+
+sub add {
+ my $self = shift;
+ my @strings = map { is_arrayref($_) ? @$_ : $_ } @_;
+
+ @strings or throw 'Must provide strings to lock';
+
+ my $cipher = $self->cipher;
+
+ for my $string (@strings) {
+ my $item = {str => $string, off => $self->{counter}};
+ if (is_scalarref($string)) {
+ next if !defined $$string;
+ $item->{enc} = 'UTF-8' if utf8::is_utf8($$string);
+ if (my $encoding = $item->{enc}) {
+ my $encoded = encode($encoding, $$string);
+ $item->{val} = $cipher->crypt(\$encoded);
+ erase $encoded;
+ }
+ else {
+ $item->{val} = $cipher->crypt($string);
+ }
+ erase $string;
+ }
+ elsif (is_hashref($string)) {
+ next if !defined $string->{value};
+ $item->{enc} = 'UTF-8' if utf8::is_utf8($string->{value});
+ if (my $encoding = $item->{enc}) {
+ my $encoded = encode($encoding, $string->{value});
+ $item->{val} = $cipher->crypt(\$encoded);
+ erase $encoded;
+ }
+ else {
+ $item->{val} = $cipher->crypt(\$string->{value});
+ }
+ erase \$string->{value};
+ }
+ else {
+ throw 'Safe strings must be a hashref or stringref', type => ref $string;
+ }
+ push @{$self->{items}}, $item;
+ $self->{index}{refaddr($string)} = $item;
+ $self->{counter} += length($item->{val});
+ }
+
+ return $self;
+}
+
+=method add_protected
+
+ $safe = $safe->add_protected(@strings);
+ $safe = $safe->add_protected(\@strings);
+
+Add strings that are already encrypted.
+
+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.
+
+=cut
+
+sub add_protected {
+ my $self = shift;
+ my $filter = is_coderef($_[0]) ? shift : undef;
+ my @strings = map { is_arrayref($_) ? @$_ : $_ } @_;
+
+ @strings or throw 'Must provide strings to lock';
+
+ for my $string (@strings) {
+ my $item = {str => $string};
+ $item->{filter} = $filter if defined $filter;
+ if (is_scalarref($string)) {
+ next if !defined $$string;
+ $item->{val} = $$string;
+ erase $string;
+ }
+ elsif (is_hashref($string)) {
+ next if !defined $string->{value};
+ $item->{val} = $string->{value};
+ erase \$string->{value};
+ }
+ else {
+ throw 'Safe strings must be a hashref or stringref', type => ref $string;
+ }
+ push @{$self->{items}}, $item;
+ $self->{index}{refaddr($string)} = $item;
+ $self->{counter} += length($item->{val});
+ }
+
+ return $self;
+}
+
+=method unlock
+
+ $safe = $safe->unlock;
+
+Decrypt all the strings. Each stored string is set to its original value.
+
+This happens automatically when the safe is garbage-collected.
+
+=cut
+
+sub unlock {
+ my $self = shift;
+
+ my $cipher = $self->cipher;
+ $cipher->finish;
+ $self->{counter} = 0;
+
+ for my $item (@{$self->{items}}) {
+ my $string = $item->{str};
+ my $cleanup = erase_scoped \$item->{val};
+ my $str_ref;
+ if (is_scalarref($string)) {
+ $$string = $cipher->crypt(\$item->{val});
+ if (my $encoding = $item->{enc}) {
+ my $decoded = decode($encoding, $string->{value});
+ erase $string;
+ $$string = $decoded;
+ }
+ $str_ref = $string;
+ }
+ elsif (is_hashref($string)) {
+ $string->{value} = $cipher->crypt(\$item->{val});
+ if (my $encoding = $item->{enc}) {
+ my $decoded = decode($encoding, $string->{value});
+ erase \$string->{value};
+ $string->{value} = $decoded;
+ }
+ $str_ref = \$string->{value};
+ }
+ else {
+ die 'Unexpected';
+ }
+ if (my $filter = $item->{filter}) {
+ my $filtered = $filter->($$str_ref);
+ erase $str_ref;
+ $$str_ref = $filtered;
+ }
+ }
+
+ return $self->clear;
+}
+
+=method peek
+
+ $string_value = $safe->peek($string);
+ ...
+ erase $string_value;
+
+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.
+
+=cut
+
+sub peek {
+ my $self = shift;
+ my $string = shift;
+
+ my $item = $self->{index}{refaddr($string)} // return;
+
+ my $cipher = $self->cipher->dup(offset => $item->{off});
+
+ my $value = $cipher->crypt(\$item->{val});
+ if (my $encoding = $item->{enc}) {
+ my $decoded = decode($encoding, $value);
+ erase $value;
+ return $decoded;
+ }
+ return $value;
+}
+
+=attr cipher
+
+ $cipher = $safe->cipher;
+
+Get the L<File::KDBX::Cipher::Stream> protecting a safe.
+
+=cut
+
+sub cipher {
+ my $self = shift;
+ $self->{cipher} //= do {
+ require File::KDBX::Cipher;
+ File::KDBX::Cipher->new(stream_id => STREAM_ID_CHACHA20, key => random_bytes(64));
+ };
+}
+
+1;
+__END__
+
+=head1 SYNOPSIS
+
+ use File::KDBX::Safe;
+
+ $safe = File::KDBX::Safe->new;
+
+ my $msg = 'Secret text';
+ $safe->add(\$msg);
+ # $msg is now undef, the original message no longer in RAM
+
+ my $obj = { value => 'Also secret' };
+ $safe->add($obj);
+ # $obj is now { value => undef }
+
+ say $safe->peek($msg); # Secret text
+
+ $safe->unlock;
+ say $msg; # Secret text
+ say $obj->{value}; # Also secret
+
+=head1 DESCRIPTION
+
+This module provides memory protection functionality. It keeps strings encrypted in memory and decrypts them
+as-needed. Encryption and decryption is done using a L<File::KDBX::Cipher::Stream>.
+
+A safe can protect one or more (possibly many) strings. When a string is added to a safe, it gets added to an
+internal list so it will be decrypted when the entire safe is unlocked.
+
+=cut
--- /dev/null
+package File::KDBX::Transaction;
+# ABSTRACT: Make multiple database edits atomically
+
+use warnings;
+use strict;
+
+use Devel::GlobalDestruction;
+use namespace::clean;
+
+our $VERSION = '999.999'; # VERSION
+
+sub new {
+ my $class = shift;
+ my $object = shift;
+ my $orig = shift // $object->clone;
+ return bless {object => $object, original => $orig}, $class;
+}
+
+sub DESTROY { !in_global_destruction and $_[0]->rollback }
+
+sub object { $_[0]->{object} }
+sub original { $_[0]->{original} }
+
+sub commit {
+ my $self = shift;
+ my $obj = $self->object;
+ if (my $commit = $obj->can('_commit')) {
+ $commit->($obj, $self);
+ }
+ $self->{committed} = 1;
+ return $obj;
+}
+
+sub rollback {
+ my $self = shift;
+ return if $self->{committed};
+
+ my $obj = $self->object;
+ my $orig = $self->original;
+
+ %$obj = ();
+ @$obj{keys %$orig} = values %$orig;
+
+ return $obj;
+}
+
+1;
--- /dev/null
+package File::KDBX::Util;
+# ABSTRACT: Utility functions for working with KDBX files
+
+use warnings;
+use strict;
+
+use Crypt::PRNG qw(random_bytes random_string);
+use Encode qw(decode encode);
+use Exporter qw(import);
+use File::KDBX::Error;
+use List::Util 1.33 qw(any all);
+use Module::Load;
+use Ref::Util qw(is_arrayref is_coderef is_hashref is_ref is_refref is_scalarref is_ref);
+use Scalar::Util qw(blessed isdual looks_like_number readonly refaddr);
+use namespace::clean -except => 'import';
+
+our $VERSION = '999.999'; # VERSION
+
+our %EXPORT_TAGS = (
+ assert => [qw(assert_64bit)],
+ clone => [qw(clone clone_nomagic)],
+ crypt => [qw(pad_pkcs7)],
+ debug => [qw(dumper)],
+ fork => [qw(can_fork)],
+ function => [qw(memoize recurse_limit)],
+ empty => [qw(empty nonempty)],
+ erase => [qw(erase erase_scoped)],
+ gzip => [qw(gzip gunzip)],
+ io => [qw(read_all)],
+ load => [qw(load_optional load_xs try_load_optional)],
+ search => [qw(query search simple_expression_query)],
+ text => [qw(snakify trim)],
+ uuid => [qw(format_uuid generate_uuid is_uuid uuid)],
+ uri => [qw(split_url uri_escape_utf8 uri_unescape_utf8)],
+);
+
+$EXPORT_TAGS{all} = [map { @$_ } values %EXPORT_TAGS];
+our @EXPORT_OK = @{$EXPORT_TAGS{all}};
+
+my %OPS = (
+ 'eq' => 2, # binary
+ 'ne' => 2,
+ 'lt' => 2,
+ 'gt' => 2,
+ 'le' => 2,
+ 'ge' => 2,
+ '==' => 2,
+ '!=' => 2,
+ '<' => 2,
+ '>' => 2,
+ '<=' => 2,
+ '>=' => 2,
+ '=~' => 2,
+ '!~' => 2,
+ '!' => 1, # unary
+ '!!' => 1,
+ '-not' => 1, # special
+ '-false' => 1,
+ '-true' => 1,
+ '-defined' => 1,
+ '-undef' => 1,
+ '-empty' => 1,
+ '-nonempty' => 1,
+ '-or' => -1,
+ '-and' => -1,
+);
+my %OP_NEG = (
+ 'eq' => 'ne',
+ 'ne' => 'eq',
+ 'lt' => 'ge',
+ 'gt' => 'le',
+ 'le' => 'gt',
+ 'ge' => 'lt',
+ '==' => '!=',
+ '!=' => '==',
+ '<' => '>=',
+ '>' => '<=',
+ '<=' => '>',
+ '>=' => '<',
+ '=~' => '!~',
+ '!~' => '=~',
+);
+
+=func assert_64bit
+
+ assert_64bit();
+
+Throw if perl doesn't support 64-bit IVs.
+
+=cut
+
+sub assert_64bit() {
+ require Config;
+ $Config::Config{ivsize} < 8
+ and throw "64-bit perl is required to use this feature.\n", ivsize => $Config::Config{ivsize};
+}
+
+=func can_fork
+
+ $bool = can_fork;
+
+Determine if perl can fork, with logic lifted from L<Test2::Util/CAN_FORK>.
+
+=cut
+
+sub can_fork {
+ require Config;
+ return 1 if $Config::Config{d_fork};
+ return 0 if $^O ne 'MSWin32' && $^O ne 'NetWare';
+ return 0 if !$Config::Config{useithreads};
+ return 0 if $Config::Config{ccflags} !~ /-DPERL_IMPLICIT_SYS/;
+ return 0 if $] < 5.008001;
+ if ($] == 5.010000 && $Config::Config{ccname} eq 'gcc' && $Config::Config{gccversion}) {
+ return 0 if $Config::Config{gccversion} !~ m/^(\d+)\.(\d+)/;
+ my @parts = split(/[\.\s]+/, $Config::Config{gccversion});
+ return 0 if $parts[0] > 4 || ($parts[0] == 4 && $parts[1] >= 8);
+ }
+ return 0 if $INC{'Devel/Cover.pm'};
+ return 1;
+}
+
+=func clone_nomagic
+
+ $clone = clone_nomagic($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.
+
+=cut
+
+sub clone {
+ require Storable;
+ goto &Storable::dclone;
+}
+
+sub clone_nomagic {
+ my $thing = shift;
+ if (is_arrayref($thing)) {
+ my @arr = map { clone_nomagic($_) } @$thing;
+ return \@arr;
+ }
+ elsif (is_hashref($thing)) {
+ my %hash;
+ $hash{$_} = clone_nomagic($thing->{$_}) for keys %$thing;
+ return \%hash;
+ }
+ elsif (is_ref($thing)) {
+ return clone($thing);
+ }
+ return $thing;
+}
+
+=func dumper
+
+ $str = dumper $struct;
+
+Like L<Data::Dumper> but slightly terser in some cases relevent to L<File::KDBX>.
+
+=cut
+
+sub dumper {
+ require Data::Dumper;
+ # avoid "once" warnings
+ local $Data::Dumper::Deepcopy = $Data::Dumper::Deepcopy = 1;
+ local $Data::Dumper::Deparse = $Data::Dumper::Deparse = 1;
+ local $Data::Dumper::Indent = 1;
+ local $Data::Dumper::Quotekeys = 0;
+ local $Data::Dumper::Sortkeys = 1;
+ local $Data::Dumper::Terse = 1;
+ local $Data::Dumper::Trailingcomma = 1;
+ local $Data::Dumper::Useqq = 1;
+
+ my @dumps;
+ for my $struct (@_) {
+ my $str = Data::Dumper::Dumper($struct);
+
+ # boolean
+ $str =~ s/bless\( do\{\\\(my \$o = ([01])\)\}, 'boolean' \)/boolean($1)/gs;
+ # Time::Piece
+ $str =~ s/bless\([^\)]+?(\d+)'?,\s+\d+,?\s+\], 'Time::Piece' \)/Time::Piece->new($1)/gs;
+
+ print STDERR $str if !defined wantarray;
+ push @dumps, $str;
+ return $str;
+ }
+ return join("\n", @dumps);
+}
+
+=func empty
+
+=func nonempty
+
+ $bool = empty $thing;
+
+ $bool = nonempty $thing;
+
+Test whether a thing is empty (or nonempty). An empty thing is one of these:
+
+=for :list
+* nonexistent
+* C<undef>
+* zero-length string
+* zero-length array
+* hash with zero keys
+* reference to an empty thing (recursive)
+
+Note in particular that zero C<0> is not considered empty because it is an actual value.
+
+=cut
+
+sub empty { _empty(@_) }
+sub nonempty { !_empty(@_) }
+
+sub _empty {
+ return 1 if @_ == 0;
+ local $_ = shift;
+ return !defined $_
+ || $_ eq ''
+ || (is_arrayref($_) && @$_ == 0)
+ || (is_hashref($_) && keys %$_ == 0)
+ || (is_scalarref($_) && (!defined $$_ || $$_ eq ''))
+ || (is_refref($_) && _empty($$_));
+}
+
+=func erase
+
+ erase($string, ...);
+ erase(\$string, ...);
+
+Overwrite the memory used by one or more string.
+
+=cut
+
+# use File::KDBX::XS;
+
+sub erase {
+ # Only bother zeroing out memory if we have the last SvPV COW reference, otherwise we'll end up just
+ # creating a copy and erasing the copy.
+ # TODO - Is this worth doing? Need some benchmarking.
+ for (@_) {
+ if (!is_ref($_)) {
+ next if !defined $_ || readonly $_;
+ if (USE_COWREFCNT()) {
+ my $cowrefcnt = B::COW::cowrefcnt($_);
+ goto FREE_NONREF if defined $cowrefcnt && 1 < $cowrefcnt;
+ }
+ # if (__PACKAGE__->can('erase_xs')) {
+ # erase_xs($_);
+ # }
+ # else {
+ substr($_, 0, length($_), "\0" x length($_));
+ # }
+ FREE_NONREF: {
+ no warnings 'uninitialized';
+ undef $_;
+ }
+ }
+ elsif (is_scalarref($_)) {
+ next if !defined $$_ || readonly $$_;
+ if (USE_COWREFCNT()) {
+ my $cowrefcnt = B::COW::cowrefcnt($$_);
+ goto FREE_REF if defined $cowrefcnt && 1 < $cowrefcnt;
+ }
+ # if (__PACKAGE__->can('erase_xs')) {
+ # erase_xs($$_);
+ # }
+ # else {
+ substr($$_, 0, length($$_), "\0" x length($$_));
+ # }
+ FREE_REF: {
+ no warnings 'uninitialized';
+ undef $$_;
+ }
+ }
+ elsif (is_arrayref($_)) {
+ erase(@$_);
+ @$_ = ();
+ }
+ elsif (is_hashref($_)) {
+ erase(values %$_);
+ %$_ = ();
+ }
+ else {
+ throw 'Cannot erase this type of scalar', type => ref $_, what => $_;
+ }
+ }
+}
+
+=func erase_scoped
+
+ $scope_guard = erase_scoped($string, ...);
+ $scope_guard = erase_scoped(\$string, ...);
+ undef $scope_guard; # erase happens here
+
+Get a scope guard that will cause scalars to be erased later (i.e. when the scope ends). This is useful if you
+want to make sure a string gets erased after you're done with it, even if the scope ends abnormally.
+
+See L</erase>.
+
+=cut
+
+sub erase_scoped {
+ my @args;
+ for (@_) {
+ !is_ref($_) || is_arrayref($_) || is_hashref($_) || is_scalarref($_)
+ or throw 'Cannot erase this type of scalar', type => ref $_, what => $_;
+ push @args, is_ref($_) ? $_ : \$_;
+ }
+ require Scope::Guard;
+ return Scope::Guard->new(sub { erase(@args) });
+}
+
+=func format_uuid
+
+ $string_uuid = format_uuid($raw_uuid);
+ $string_uuid = format_uuid($raw_uuid, $delimiter);
+
+Format a 128-bit UUID (given as a string of 16 octets) into a hexidecimal string, optionally with a delimiter
+to break up the UUID visually into five parts. Examples:
+
+ my $uuid = uuid('01234567-89AB-CDEF-0123-456789ABCDEF');
+ say format_uuid($uuid); # -> 0123456789ABCDEF0123456789ABCDEF
+ say format_uuid($uuid, '-'); # -> 01234567-89AB-CDEF-0123-456789ABCDEF
+
+This is the inverse of L</uuid>.
+
+=cut
+
+sub format_uuid {
+ local $_ = shift // "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
+ my $delim = shift // '';
+ length($_) == 16 or throw 'Must provide a 16-bytes UUID', size => length($_), str => $_;
+ return uc(join($delim, unpack('H8 H4 H4 H4 H12', $_)));
+}
+
+=func generate_uuid
+
+ $uuid = generate_uuid;
+ $uuid = generate_uuid(\%set);
+ $uuid = generate_uuid(\&test_uuid);
+
+Generate a new random UUID. It's pretty unlikely that this will generate a repeat, but if you're worried about
+that you can provide either a set of existing UUIDs (as a hashref where the keys are the elements of a set) or
+a function to check for existing UUIDs, and this will be sure to not return a UUID already in provided set.
+Perhaps an example will make it clear:
+
+ my %uuid_set = (
+ uuid('12345678-9ABC-DEFG-1234-56789ABCDEFG') => 'whatever',
+ );
+ $uuid = generate_uuid(\%uuid_set);
+ # OR
+ $uuid = generate_uuid(sub { !$uuid_set{$_} });
+
+Here, C<$uuid> can't be "12345678-9ABC-DEFG-1234-56789ABCDEFG". This example uses L</uuid> to easily pack
+a 16-byte UUID from a literal, but it otherwise is not a consequential part of the example.
+
+=cut
+
+sub generate_uuid {
+ my $set = @_ % 2 == 1 ? shift : undef;
+ my %args = @_;
+ my $test = $set //= $args{test};
+ $test = sub { !$set->{$_} } if is_hashref($test);
+ $test //= sub { 1 };
+ my $printable = $args{printable} // $args{print};
+ local $_ = '';
+ do {
+ $_ = $printable ? random_string(16) : random_bytes(16);
+ } while (!$test->($_));
+ return $_;
+}
+
+=func gunzip
+
+ $unzipped = gunzip($string);
+
+Decompress an octet stream.
+
+=cut
+
+sub gunzip {
+ load_optional('Compress::Raw::Zlib');
+ local $_ = shift;
+ my ($i, $status) = Compress::Raw::Zlib::Inflate->new(-WindowBits => 31);
+ $status == Compress::Raw::Zlib::Z_OK()
+ or throw 'Failed to initialize compression library', status => $status;
+ $status = $i->inflate($_, my $out);
+ $status == Compress::Raw::Zlib::Z_STREAM_END()
+ or throw 'Failed to decompress data', status => $status;
+ return $out;
+}
+
+=func gunzip
+
+ $zipped = gzip($string);
+
+Compress an octet stream.
+
+=cut
+
+sub gzip {
+ load_optional('Compress::Raw::Zlib');
+ local $_ = shift;
+ my ($d, $status) = Compress::Raw::Zlib::Deflate->new(-WindowBits => 31, -AppendOutput => 1);
+ $status == Compress::Raw::Zlib::Z_OK()
+ or throw 'Failed to initialize compression library', status => $status;
+ $status = $d->deflate($_, my $out);
+ $status == Compress::Raw::Zlib::Z_OK()
+ or throw 'Failed to compress data', status => $status;
+ $status = $d->flush($out);
+ $status == Compress::Raw::Zlib::Z_OK()
+ or throw 'Failed to compress data', status => $status;
+ return $out;
+}
+
+=func is_uuid
+
+ $bool = is_uuid($thing);
+
+Check if a thing is a UUID (i.e. scalar string of length 16).
+
+=cut
+
+sub is_uuid { defined $_[0] && !is_ref($_[0]) && length($_[0]) == 16 }
+
+=func load_optional
+
+ $package = load_optional($package);
+
+Load a module that isn't required but can provide extra functionality. Throw if the module is not available.
+
+=cut
+
+sub load_optional {
+ for my $module (@_) {
+ eval { load $module };
+ if (my $err = $@) {
+ warn $err if $ENV{DEBUG};
+ throw "Missing dependency: Please install $module to use this feature.\n", module => $module;
+ }
+ }
+ return wantarray ? @_ : $_[0];
+}
+
+=func load_xs
+
+ $bool = load_xs();
+ $bool = load_xs($version);
+
+Attempt to load L<File::KDBX::XS>. Return truthy if C<XS> is loaded. If C<$version> is given, it will check
+that at least the given version is loaded.
+
+=cut
+
+sub load_xs {
+ my $version = shift;
+
+ require File::KDBX;
+
+ my $has_xs = File::KDBX->can('XS_LOADED');
+ return $has_xs->() && ($version ? eval { File::KDBX::XS->VERSION($version); 1 } : 1) if $has_xs;
+
+ my $try_xs = 1;
+ $try_xs = 0 if $ENV{PERL_ONLY} || (exists $ENV{PERL_FILE_KDBX_XS} && !$ENV{PERL_FILE_KDBX_XS});
+
+ my $use_xs = 0;
+ $use_xs = try_load_optional('File::KDBX::XS') if $try_xs;
+
+ *File::KDBX::XS_LOADED = *File::KDBX::XS_LOADED = $use_xs ? sub() { 1 } : sub() { 0 };
+ return $version ? eval { File::KDBX::XS->VERSION($version); 1 } : 1;
+}
+
+=func memoize
+
+ \&memoized_code = memoize(\&code, ...);
+
+Memoize a function. Extra arguments are passed through to C<&code> when it is called.
+
+=cut
+
+sub memoize {
+ my $func = shift;
+ my @args = @_;
+ my %cache;
+ return sub { $cache{join("\0", grep { defined } @_)} //= $func->(@args, @_) };
+}
+
+=func pad_pkcs7
+
+ $padded_string = pad_pkcs7($string, $block_size),
+
+Pad a block using the PKCS#7 method.
+
+=cut
+
+sub pad_pkcs7 {
+ my $data = shift // throw 'Must provide a string to pad';
+ my $size = shift or throw 'Must provide block size';
+
+ 0 <= $size && $size < 256
+ or throw 'Cannot add PKCS7 padding to a large block size', size => $size;
+
+ my $pad_len = $size - length($data) % $size;
+ $data .= chr($pad_len) x $pad_len;
+}
+
+=func query
+
+ $query = query(@where);
+ $query->(\%data);
+
+Generate a function that will run a series of tests on a passed hashref and return true or false depending on
+if the data record in the hash matched the specified logic.
+
+The logic can be specified in a manner similar to L<SQL::Abstract/"WHERE CLAUSES"> which was the inspiration
+for this function, but this code is distinct, supporting an overlapping but not identical feature set and
+having its own bugs.
+
+See L<File::KDBX/QUERY> for examples.
+
+=cut
+
+sub query { _query(undef, '-or', \@_) }
+
+=func read_all
+
+ $size = read_all($fh, my $buffer, $size);
+ $size = read_all($fh, my $buffer, $size, $offset);
+
+Like L<functions/read> but returns C<undef> if not all C<$size> bytes are read. This is considered an error,
+distinguishable from other errors by C<$!> not being set.
+
+=cut
+
+sub read_all($$$;$) { ## no critic (ProhibitSubroutinePrototypes)
+ my $result = @_ == 3 ? read($_[0], $_[1], $_[2])
+ : read($_[0], $_[1], $_[2], $_[3]);
+ return if !defined $result;
+ return if $result != $_[2];
+ return $result;
+}
+
+=func recurse_limit
+
+ \&limited_code = recurse_limit(\&code);
+ \&limited_code = recurse_limit(\&code, $max_depth);
+ \&limited_code = recurse_limit(\&code, $max_depth, \&error_handler);
+
+Wrap a function with a guard to prevent deep recursion.
+
+=cut
+
+sub recurse_limit {
+ my $func = shift;
+ my $max_depth = shift // 200;
+ my $error = shift // sub {};
+ my $depth = 0;
+ return sub { return $error->(@_) if $max_depth < ++$depth; $func->(@_) };
+};
+
+=func search
+
+ # Generate a query on-the-fly:
+ \@matches = search(\@records, @where);
+
+ # Use a pre-compiled query:
+ $query = query(@where);
+ \@matches = search(\@records, $query);
+
+ # Use a simple expression:
+ \@matches = search(\@records, \'query terms', @fields);
+ \@matches = search(\@records, \'query terms', $operator, @fields);
+
+ # Use your own subroutine:
+ \@matches = search(\@records, \&query);
+ \@matches = search(\@records, sub { $record = shift; ... });
+
+Execute a linear search over an array of records using a L</query>. A "record" is usually a hash.
+
+This is the search engine described with many examples at L<File::KDBX/QUERY>.
+
+=cut
+
+sub search {
+ my $list = shift;
+ my $query = shift;
+ # my %args = @_;
+
+ if (is_coderef($query) && !@_) {
+ # already a query
+ }
+ elsif (is_scalarref($query)) {
+ $query = simple_expression_query($$query, @_);
+ }
+ else {
+ $query = query($query, @_);
+ }
+
+ # my $limit = $args{limit};
+
+ my @match;
+ for my $item (@$list) {
+ push @match, $item if $query->($item);
+ # last if defined $limit && $limit <= @match;
+ }
+ return \@match;
+}
+
+=func simple_expression_query
+
+ $query = simple_expression_query($expression, @fields);
+
+Generate a query, like L</query>, to be used with L</search> but built from a "simple expression" as
+L<described here|https://keepass.info/help/base/search.html#mode_se>.
+
+An expression is a string with one or more space-separated terms. Terms with spaces can be enclosed in double
+quotes. Terms are negated if they are prefixed with a minus sign. A record must match every term on at least
+one of the given fields.
+
+=cut
+
+sub simple_expression_query {
+ my $expr = shift;
+ my $op = @_ && ($OPS{$_[0] || ''} || 0) == 2 ? shift : '=~';
+
+ my $neg_op = $OP_NEG{$op};
+ my $is_re = $op eq '=~' || $op eq '!~';
+
+ require Text::ParseWords;
+ my @terms = Text::ParseWords::shellwords($expr);
+
+ my @query = qw(-and);
+
+ for my $term (@terms) {
+ my @subquery = qw(-or);
+
+ my $neg = $term =~ s/^-//;
+ my $condition = [($neg ? $neg_op : $op) => ($is_re ? qr/\Q$term\E/i : $term)];
+
+ for my $field (@_) {
+ push @subquery, $field => $condition;
+ }
+
+ push @query, \@subquery;
+ }
+
+ return query(\@query);
+}
+
+=func snakify
+
+ $string = snakify($string);
+
+Turn a CamelCase string into snake_case.
+
+=cut
+
+sub snakify {
+ local $_ = shift;
+ s/UserName/Username/g;
+ s/([a-z])([A-Z0-9])/${1}_${2}/g;
+ s/([A-Z0-9]+)([A-Z0-9])(?![A-Z0-9]|$)/${1}_${2}/g;
+ return lc($_);
+}
+
+=func split_url
+
+ ($scheme, $auth, $host, $port, $path, $query, $hash, $usename, $password) = split_url($url);
+
+Split a URL into its parts.
+
+For example, C<http://user:pass@localhost:4000/path?query#hash> gets split like:
+
+=for :list
+* C<http>
+* C<user:pass>
+* C<host>
+* C<4000>
+* C</path>
+* C<?query>
+* C<#hash>
+* C<user>
+* C<pass>
+
+=cut
+
+sub split_url {
+ local $_ = shift;
+ my ($scheme, $auth, $host, $port, $path, $query, $hash) =~ m!
+ ^([^:/\?\#]+) ://
+ (?:([^\@]+)\@)
+ ([^:/\?\#]*)
+ (?::(\d+))?
+ ([^\?\#]*)
+ (\?[^\#]*)?
+ (\#(.*))?
+ !x;
+
+ $scheme = lc($scheme);
+
+ $host ||= 'localhost';
+ $host = lc($host);
+
+ $path = "/$path" if $path !~ m!^/!;
+
+ $port ||= $scheme eq 'http' ? 80 : $scheme eq 'https' ? 433 : undef;
+
+ my ($username, $password) = split($auth, ':', 2);
+
+ return ($scheme, $auth, $host, $port, $path, $query, $hash, $username, $password);
+}
+
+=func trim
+
+ $string = trim($string);
+
+The ubiquitous C<trim> function. Removes all whitespace from both ends of a string.
+
+=cut
+
+sub trim($) { ## no critic (ProhibitSubroutinePrototypes)
+ local $_ = shift // return;
+ s/^\s*//;
+ s/\s*$//;
+ return $_;
+}
+
+=func try_load_optional
+
+ $package = try_load_optional($package);
+
+Try to load a module that isn't required but can provide extra functionality, and return true if successful.
+
+=cut
+
+sub try_load_optional {
+ for my $module (@_) {
+ eval { load $module };
+ if (my $err = $@) {
+ warn $err if $ENV{DEBUG};
+ return;
+ }
+ }
+ return @_;
+}
+
+=func uri_escape_utf8
+
+ $string = uri_escape_utf8($string);
+
+Percent-encode arbitrary text strings, like for a URI.
+
+=cut
+
+my %ESC = map { chr($_) => sprintf('%%%02X', $_) } 0..255;
+sub uri_escape_utf8 {
+ local $_ = shift // return;
+ $_ = encode('UTF-8', $_);
+ # RFC 3986 section 2.3 unreserved characters
+ s/([^A-Za-z0-9\-\._~])/$ESC{$1}/ge;
+ return $_;
+}
+
+sub uri_unescape_utf8 {
+ local $_ = shift // return;
+ s/\%([A-Fa-f0-9]{2})/chr(hex($1))/;
+ return decode('UTF-8', $_);
+}
+
+=func uuid
+
+ $raw_uuid = uuid($string_uuid);
+
+Pack a 128-bit UUID (given as a hexidecimal string with optional C<->'s, like
+C<12345678-9ABC-DEFG-1234-56789ABCDEFG>) into a string of exactly 16 octets.
+
+This is the inverse of L</format_uuid>.
+
+=cut
+
+sub uuid {
+ local $_ = shift // return "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
+ s/-//g;
+ /^[A-Fa-f0-9]{32}$/ or throw 'Must provide a formatted 128-bit UUID';
+ return pack('H32', $_);
+
+}
+
+BEGIN {
+ my $use_cowrefcnt = eval { require B::COW; 1 };
+ *USE_COWREFCNT = $use_cowrefcnt ? sub() { 1 } : sub() { 0 };
+}
+
+### --------------------------------------------------------------------------
+
+# Determine if an array looks like keypairs from a hash.
+sub _looks_like_keypairs {
+ my $arr = shift;
+ return 0 if @$arr % 2 == 1;
+ for (my $i = 0; $i < @$arr; $i += 2) {
+ return 0 if is_ref($arr->[$i]);
+ }
+ return 1;
+}
+
+sub _is_operand_plain {
+ local $_ = shift;
+ return !(is_hashref($_) || is_arrayref($_));
+}
+
+sub _query {
+ # dumper \@_;
+ my $subject = shift;
+ my $op = shift // throw 'Must specify a query operator';
+ my $operand = shift;
+
+ return _query_simple($op, $subject) if defined $subject && !is_ref($op) && ($OPS{$subject} || 2) < 2;
+ return _query_simple($subject, $op, $operand) if _is_operand_plain($operand);
+ return _query_inverse(_query($subject, '-or', $operand)) if $op eq '-not' || $op eq '-false';
+ return _query($subject, '-and', [%$operand]) if is_hashref($operand);
+
+ my @queries;
+
+ my @atoms = @$operand;
+ while (@atoms) {
+ if (_looks_like_keypairs(\@atoms)) {
+ my ($atom, $operand) = splice @atoms, 0, 2;
+ if (my $op_type = $OPS{$atom}) {
+ if ($op_type == 1 && _is_operand_plain($operand)) { # unary
+ push @queries, _query_simple($operand, $atom);
+ }
+ else {
+ push @queries, _query($subject, $atom, $operand);
+ }
+ }
+ elsif (!is_ref($atom)) {
+ push @queries, _query($atom, 'eq', $operand);
+ }
+ }
+ else {
+ my $atom = shift @atoms;
+ if ($OPS{$atom}) { # apply new operator over the rest
+ push @queries, _query($subject, $atom, \@atoms);
+ last;
+ }
+ else { # apply original operator over this one
+ push @queries, _query($subject, $op, $atom);
+ }
+ }
+ }
+
+ if (@queries == 1) {
+ return $queries[0];
+ }
+ elsif ($op eq '-and') {
+ return _query_all(@queries);
+ }
+ elsif ($op eq '-or') {
+ return _query_any(@queries);
+ }
+ throw 'Malformed query';
+}
+
+sub _query_simple {
+ my $subject = shift;
+ my $op = shift // 'eq';
+ my $operand = shift;
+
+ # these special operators can also act as simple operators
+ $op = '!!' if $op eq '-true';
+ $op = '!' if $op eq '-false';
+ $op = '!' if $op eq '-not';
+
+ defined $subject or throw 'Subject is not set in query';
+ $OPS{$op} >= 0 or throw 'Cannot use a non-simple operator in a simple query';
+ if (empty($operand)) {
+ if ($OPS{$op} < 2) {
+ # no operand needed
+ }
+ # Allow field => undef and field => {'ne' => undef} to do the (arguably) right thing.
+ elsif ($op eq 'eq' || $op eq '==') {
+ $op = '-empty';
+ }
+ elsif ($op eq 'ne' || $op eq '!=') {
+ $op = '-nonempty';
+ }
+ else {
+ throw 'Operand is required';
+ }
+ }
+
+ my $field = sub { blessed $_[0] && $_[0]->can($subject) ? $_[0]->$subject : $_[0]->{$subject} };
+
+ my %map = (
+ 'eq' => sub { local $_ = $field->(@_); defined && $_ eq $operand },
+ 'ne' => sub { local $_ = $field->(@_); defined && $_ ne $operand },
+ 'lt' => sub { local $_ = $field->(@_); defined && $_ lt $operand },
+ 'gt' => sub { local $_ = $field->(@_); defined && $_ gt $operand },
+ 'le' => sub { local $_ = $field->(@_); defined && $_ le $operand },
+ 'ge' => sub { local $_ = $field->(@_); defined && $_ ge $operand },
+ '==' => sub { local $_ = $field->(@_); defined && $_ == $operand },
+ '!=' => sub { local $_ = $field->(@_); defined && $_ != $operand },
+ '<' => sub { local $_ = $field->(@_); defined && $_ < $operand },
+ '>' => sub { local $_ = $field->(@_); defined && $_ > $operand },
+ '<=' => sub { local $_ = $field->(@_); defined && $_ <= $operand },
+ '>=' => sub { local $_ = $field->(@_); defined && $_ >= $operand },
+ '=~' => sub { local $_ = $field->(@_); defined && $_ =~ $operand },
+ '!~' => sub { local $_ = $field->(@_); defined && $_ !~ $operand },
+ '!' => sub { local $_ = $field->(@_); ! $_ },
+ '!!' => sub { local $_ = $field->(@_); !!$_ },
+ '-defined' => sub { local $_ = $field->(@_); defined $_ },
+ '-undef' => sub { local $_ = $field->(@_); !defined $_ },
+ '-nonempty' => sub { local $_ = $field->(@_); nonempty $_ },
+ '-empty' => sub { local $_ = $field->(@_); empty $_ },
+ );
+
+ return $map{$op} // throw "Unexpected operator in query: $op",
+ subject => $subject,
+ operator => $op,
+ operand => $operand;
+}
+
+sub _query_inverse {
+ my $query = shift;
+ return sub { !$query->(@_) };
+}
+
+sub _query_all {
+ my @queries = @_;
+ return sub {
+ my $val = shift;
+ all { $_->($val) } @queries;
+ };
+}
+
+sub _query_any {
+ my @queries = @_;
+ return sub {
+ my $val = shift;
+ any { $_->($val) } @queries;
+ };
+}
+
+1;
--- /dev/null
+package PerlIO::via::File::KDBX::Compression;
+# ABSTRACT: [De]compressor PerlIO layer
+
+use warnings;
+use strict;
+
+use Errno;
+use File::KDBX::Error;
+use File::KDBX::Util qw(load_optional);
+use IO::Handle;
+use namespace::clean;
+
+our $VERSION = '999.999'; # VERSION
+our $BUFFER_SIZE = 8192;
+our $ERROR;
+
+=method push
+
+ PerlIO::via::File::KDBX::Compression->push($fh);
+ PerlIO::via::File::KDBX::Compression->push($fh, %options);
+
+Push a compression or decompression layer onto a filehandle. Data read from the handle is decompressed, and
+data written to a handle is compressed.
+
+Any arguments are passed along to the Inflate or Deflate constructors of C<Compress::Raw::Zlib>.
+
+This is identical to:
+
+ binmode($fh, ':via(File::KDBX::Compression)');
+
+except this allows you to specify compression options.
+
+B<WARNING:> When writing, you mustn't close the filehandle before popping this layer (using
+C<binmode($fh, ':pop')>) or the stream will be truncated. The layer needs to know when there is no more data
+before the filehandle closes so it can finish the compression correctly, and the way to indicate that is by
+popping the layer.
+
+=cut
+
+my @PUSHED_ARGS;
+sub push {
+ @PUSHED_ARGS and throw 'Pushing Compression layer would stomp existing arguments';
+ my $class = shift;
+ my $fh = shift;
+ @PUSHED_ARGS = @_;
+ binmode($fh, ':via(' . __PACKAGE__ . ')');
+}
+
+sub PUSHED {
+ my ($class, $mode) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "PUSHED\t$class\n";
+ my $buf = '';
+
+ my $self = bless {
+ buffer => \$buf,
+ mode => $mode,
+ $mode =~ /^r/ ? (inflator => _inflator(@PUSHED_ARGS)) : (),
+ $mode =~ /^w/ ? (deflator => _deflator(@PUSHED_ARGS)) : (),
+ }, $class;
+ @PUSHED_ARGS = ();
+ return $self;
+}
+
+sub FILL {
+ my ($self, $fh) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "FILL\t$self\n";
+ return if $self->EOF($fh);
+
+ $fh->read(my $buf, $BUFFER_SIZE);
+ if (0 < length($buf)) {
+ my $status = $self->inflator->inflate($buf, my $out);
+ $status == Compress::Raw::Zlib::Z_OK() || $status == Compress::Raw::Zlib::Z_STREAM_END() or do {
+ $self->_set_error("Failed to uncompress: $status", status => $status);
+ return;
+ };
+ return $out;
+ }
+
+ delete $self->{inflator};
+ return undef;
+}
+
+sub WRITE {
+ my ($self, $buf, $fh) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "WRITE\t$self\n";
+ return 0 if $self->EOF($fh);
+
+ my $status = $self->deflator->deflate($buf, my $out);
+ $status == Compress::Raw::Zlib::Z_OK() or do {
+ $self->_set_error("Failed to compress: $status", status => $status);
+ return 0;
+ };
+
+ ${$self->buffer} .= $out;
+ return length($buf);
+}
+
+sub POPPED {
+ my ($self, $fh) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "POPPED\t$self\n";
+ return if $self->EOF($fh) || $self->mode !~ /^w/;
+
+ # finish
+ my $status = $self->deflator->flush(my $out, Compress::Raw::Zlib::Z_FINISH());
+ delete $self->{deflator};
+ $status == Compress::Raw::Zlib::Z_OK() or do {
+ $self->_set_error("Failed to compress: $status", status => $status);
+ return;
+ };
+
+ ${$self->buffer} .= $out;
+ $self->FLUSH($fh);
+}
+
+sub FLUSH {
+ my ($self, $fh) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "FLUSH\t$self\n";
+ return 0 if !ref $self;
+
+ my $buf = $self->buffer;
+ print $fh $$buf or return -1 if 0 < length($$buf);
+ $$buf = '';
+ return 0;
+}
+
+sub EOF {
+ $ENV{DEBUG_STREAM} and print STDERR "EOF\t$_[0]\n";
+ (!$_[0]->inflator && !$_[0]->deflator) || $_[0]->ERROR($_[1]);
+}
+sub ERROR {
+ $ENV{DEBUG_STREAM} and print STDERR "ERROR\t$_[0] : ", $_[0]->{error} // 'ok', "\n";
+ $ERROR = $_[0]->{error} if $_[0]->{error};
+ $_[0]->{error} ? 1 : 0;
+}
+sub CLEARERR {
+ $ENV{DEBUG_STREAM} and print STDERR "CLEARERR\t$_[0]\n";
+ # delete $_[0]->{error};
+}
+
+sub inflator { $_[0]->{inflator} }
+sub deflator { $_[0]->{deflator} }
+sub mode { $_[0]->{mode} }
+sub buffer { $_[0]->{buffer} }
+
+sub _inflator {
+ load_optional('Compress::Raw::Zlib');
+ my ($inflator, $status)
+ = Compress::Raw::Zlib::Inflate->new(-WindowBits => Compress::Raw::Zlib::WANT_GZIP(), @_);
+ $status == Compress::Raw::Zlib::Z_OK()
+ or throw 'Failed to initialize inflator', status => $status;
+ return $inflator;
+}
+
+sub _deflator {
+ load_optional('Compress::Raw::Zlib');
+ my ($deflator, $status)
+ = Compress::Raw::Zlib::Deflate->new(-WindowBits => Compress::Raw::Zlib::WANT_GZIP(), @_);
+ $status == Compress::Raw::Zlib::Z_OK()
+ or throw 'Failed to initialize deflator', status => $status;
+ return $deflator;
+}
+
+sub _set_error {
+ my $self = shift;
+ $ENV{DEBUG_STREAM} and print STDERR "err\t$self\n";
+ delete $self->{inflator};
+ delete $self->{deflator};
+ if (exists &Errno::EPROTO) {
+ $! = &Errno::EPROTO;
+ }
+ elsif (exists &Errno::EIO) {
+ $! = &Errno::EIO;
+ }
+ $self->{error} = $ERROR = File::KDBX::Error->new(@_);
+}
+
+1;
--- /dev/null
+package PerlIO::via::File::KDBX::Crypt;
+# ABSTRACT: Encrypter/decrypter PerlIO layer
+
+use warnings;
+use strict;
+
+use File::KDBX::Error;
+use IO::Handle;
+use namespace::clean;
+
+our $VERSION = '999.999'; # VERSION
+our $BUFFER_SIZE = 8192;
+our $ERROR;
+
+=method push
+
+ PerlIO::via::File::KDBX::Crypt->push($fh, cipher => $cipher);
+
+Push an encryption or decryption layer onto a filehandle. C<$cipher> must be compatible with
+L<File::KDBX::Cipher>.
+
+You mustn't push this layer using C<binmode> directly because the layer needs to be initialized with the
+required cipher object.
+
+B<WARNING:> When writing, you mustn't close the filehandle before popping this layer (using
+C<binmode($fh, ':pop')>) or the stream will be truncated. The layer needs to know when there is no more data
+before the filehandle closes so it can finish the encryption correctly, and the way to indicate that is by
+popping the layer.
+
+=cut
+
+my %PUSHED_ARGS;
+sub push {
+ %PUSHED_ARGS and throw 'Pushing Crypt layer would stomp existing arguments';
+ my $class = shift;
+ my $fh = shift;
+ my %args = @_ % 2 == 0 ? @_ : (cipher => @_);
+ $args{cipher} or throw 'Must pass a cipher';
+ $args{cipher}->finish if defined $args{finish} && !$args{finish};
+
+ %PUSHED_ARGS = %args;
+ binmode($fh, ':via(' . __PACKAGE__ . ')');
+}
+
+sub PUSHED {
+ my ($class, $mode) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "PUSHED\t$class\n";
+ %PUSHED_ARGS or throw 'Programmer error: Use PerlIO::via::File::KDBX::Crypt->push instead of binmode';
+
+ my $buf = '';
+ my $self = bless {
+ buffer => \$buf,
+ cipher => $PUSHED_ARGS{cipher},
+ mode => $mode,
+ }, $class;
+ %PUSHED_ARGS = ();
+ return $self;
+}
+
+sub FILL {
+ my ($self, $fh) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "FILL\t$self\n";
+ return if $self->EOF($fh);
+
+ $fh->read(my $buf, $BUFFER_SIZE);
+ if (0 < length($buf)) {
+ my $plaintext = eval { $self->cipher->decrypt($buf) };
+ if (my $err = $@) {
+ $self->_set_error($err);
+ return;
+ }
+ return $plaintext;
+ }
+
+ # finish
+ my $plaintext = eval { $self->cipher->finish };
+ if (my $err = $@) {
+ $self->_set_error($err);
+ return;
+ }
+ delete $self->{cipher};
+ return $plaintext;
+}
+
+sub WRITE {
+ my ($self, $buf, $fh) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "WRITE\t$self\n";
+ return 0 if $self->EOF($fh);
+
+ ${$self->buffer} .= eval { $self->cipher->encrypt($buf) } || '';
+ if (my $err = $@) {
+ $self->_set_error($err);
+ return 0;
+ }
+ return length($buf);
+}
+
+sub POPPED {
+ my ($self, $fh) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "POPPED\t$self\n";
+ return if $self->EOF($fh) || $self->mode !~ /^w/;
+
+ ${$self->buffer} .= eval { $self->cipher->finish } || '';
+ if (my $err = $@) {
+ $self->_set_error($err);
+ return;
+ }
+
+ delete $self->{cipher};
+ $self->FLUSH($fh);
+}
+
+sub FLUSH {
+ my ($self, $fh) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "FLUSH\t$self\n";
+ return 0 if !ref $self;
+
+ my $buf = $self->buffer;
+ print $fh $$buf or return -1 if 0 < length($$buf);
+ $$buf = '';
+ return 0;
+}
+
+# sub EOF { !$_[0]->cipher || $_[0]->ERROR($_[1]) }
+# sub ERROR { $_[0]->{error} ? 1 : 0 }
+# sub CLEARERR { delete $_[0]->{error}; 0 }
+
+sub EOF {
+ $ENV{DEBUG_STREAM} and print STDERR "EOF\t$_[0]\n";
+ !$_[0]->cipher || $_[0]->ERROR($_[1]);
+}
+sub ERROR {
+ $ENV{DEBUG_STREAM} and print STDERR "ERROR\t$_[0] : ", $_[0]->{error} // 'ok', "\n";
+ $_[0]->{error} ? 1 : 0;
+}
+sub CLEARERR {
+ $ENV{DEBUG_STREAM} and print STDERR "CLEARERR\t$_[0]\n";
+ # delete $_[0]->{error};
+}
+
+sub cipher { $_[0]->{cipher} }
+sub mode { $_[0]->{mode} }
+sub buffer { $_[0]->{buffer} }
+
+sub _set_error {
+ my $self = shift;
+ $ENV{DEBUG_STREAM} and print STDERR "err\t$self\n";
+ delete $self->{cipher};
+ if (exists &Errno::EPROTO) {
+ $! = &Errno::EPROTO;
+ }
+ elsif (exists &Errno::EIO) {
+ $! = &Errno::EIO;
+ }
+ $self->{error} = $ERROR = File::KDBX::Error->new(@_);
+}
+
+1;
+__END__
+
+=head1 SYNOPSIS
+
+ use PerlIO::via::File::KDBX::Crypt;
+ use File::KDBX::Cipher;
+
+ my $cipher = File::KDBX::Cipher->new(...);
+
+ open(my $out_fh, '>:raw', 'ciphertext.bin');
+ PerlIO::via::File::KDBX::Crypt->push($out_fh, cipher => $cipher);
+
+ print $out_fh $plaintext;
+
+ binmode($out_fh, ':pop'); # <-- This is required.
+ close($out_fh);
+
+ open(my $in_fh, '<:raw', 'ciphertext.bin');
+ PerlIO::via::File::KDBX::Crypt->push($in_fh, cipher => $cipher);
+
+ my $plaintext = do { local $/; <$in_fh> );
+
+ close($in_fh);
+
+=cut
--- /dev/null
+package PerlIO::via::File::KDBX::HashBlock;
+# ABSTRACT: Hash block stream PerlIO layer
+
+use warnings;
+use strict;
+
+use Crypt::Digest qw(digest_data);
+use File::KDBX::Error;
+use File::KDBX::Util qw(:io);
+use IO::Handle;
+use namespace::clean;
+
+our $VERSION = '999.999'; # VERSION
+our $ALGORITHM = 'SHA256';
+our $BLOCK_SIZE = 1048576;
+our $ERROR;
+
+=method push
+
+ PerlIO::via::File::KDBX::HashBlock->push($fh, %attributes);
+
+Push a new HashBlock layer, optionally with attributes.
+
+This is identical to:
+
+ binmode($fh, ':via(File::KDBX::HashBlock)');
+
+except this allows you to customize the process with attributes.
+
+B<WARNING:> When writing, you mustn't close the filehandle before popping this layer (using
+C<binmode($fh, ':pop')>) or the stream will be truncated. The layer needs to know when there is no more data
+before the filehandle closes so it can write the final block (which will likely be shorter than the other
+blocks), and the way to indicate that is by popping the layer.
+
+=cut
+
+my %PUSHED_ARGS;
+sub push {
+ %PUSHED_ARGS and throw 'Pushing Hash layer would stomp existing arguments';
+ my $class = shift;
+ my $fh = shift;
+ %PUSHED_ARGS = @_;
+ binmode($fh, ':via(' . __PACKAGE__ . ')');
+}
+
+sub PUSHED {
+ my ($class, $mode) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "PUSHED\t$class\n";
+ my $buf = '';
+ my $self = bless {
+ algorithm => $PUSHED_ARGS{algorithm} || $ALGORITHM,
+ block_index => 0,
+ block_size => $PUSHED_ARGS{block_size} || $BLOCK_SIZE,
+ buffer => \$buf,
+ eof => 0,
+ mode => $mode,
+ }, $class;
+ %PUSHED_ARGS = ();
+ return $self;
+}
+
+sub FILL {
+ my ($self, $fh) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "FILL\t$self\n";
+ return if $self->EOF($fh);
+
+ my $block = eval { $self->_read_hash_block($fh) };
+ if (my $err = $@) {
+ $self->_set_error($err);
+ return;
+ }
+ return $$block if defined $block;
+}
+
+sub WRITE {
+ my ($self, $buf, $fh) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "WRITE\t$self\n";
+ return 0 if $self->EOF($fh);
+
+ ${$self->{buffer}} .= $buf;
+
+ $self->FLUSH($fh);
+
+ return length($buf);
+}
+
+sub POPPED {
+ my ($self, $fh) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "POPPED\t$self\n";
+ return if $self->EOF($fh) || $self->mode !~ /^w/;
+
+ $self->FLUSH($fh);
+ eval {
+ $self->_write_next_hash_block($fh); # partial block with remaining content
+ $self->_write_final_hash_block($fh); # terminating block
+ };
+ $self->_set_error($@) if $@;
+}
+
+sub FLUSH {
+ my ($self, $fh) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "FLUSH\t$self\n";
+ return 0 if !ref $self;
+
+ eval {
+ while ($self->block_size <= length(${$self->{buffer}})) {
+ $self->_write_next_hash_block($fh);
+ }
+ };
+ if (my $err = $@) {
+ $self->_set_error($err);
+ return -1;
+ }
+
+ return 0;
+}
+
+sub EOF {
+ $ENV{DEBUG_STREAM} and print STDERR "EOF\t$_[0]\n";
+ $_[0]->{eof} || $_[0]->ERROR($_[1]);
+}
+sub ERROR {
+ $ENV{DEBUG_STREAM} and print STDERR "ERROR\t$_[0] : ", $_[0]->{error} // 'ok', "\n";
+ $ERROR = $_[0]->{error} if $_[0]->{error};
+ $_[0]->{error} ? 1 : 0;
+}
+sub CLEARERR {
+ $ENV{DEBUG_STREAM} and print STDERR "CLEARERR\t$_[0]\n";
+ # delete $_[0]->{error};
+}
+
+=attr algorithm
+
+ $algo = $hash_block->algorithm;
+
+Get the hash algorithm. Default is C<SHA256>.
+
+=cut
+
+sub algorithm { $_[0]->{algorithm} //= $ALGORITHM }
+
+=attr block_size
+
+ $size = $hash_block->block_size;
+
+Get the block size. Default is C<$PerlIO::via::File::KDBX::HashBlock::BLOCK_SIZE>.
+
+This only matters in write mode. When reading, block size is detected from the stream.
+
+=cut
+
+sub block_size { $_[0]->{block_size} //= $BLOCK_SIZE }
+
+=attr block_index
+
+=attr buffer
+
+=attr mode
+
+Internal attributes.
+
+=cut
+
+sub block_index { $_[0]->{block_index} ||= 0 }
+sub buffer { $_[0]->{buffer} }
+sub mode { $_[0]->{mode} }
+
+sub _read_hash_block {
+ my $self = shift;
+ my $fh = shift;
+
+ read_all $fh, my $buf, 4 or throw 'Failed to read hash block index';
+ my ($index) = unpack('L<', $buf);
+
+ $index == $self->block_index
+ or throw 'Invalid block index', index => $index;
+
+ read_all $fh, my $hash, 32 or throw 'Failed to read hash';
+
+ read_all $fh, $buf, 4 or throw 'Failed to read hash block size';
+ my ($size) = unpack('L<', $buf);
+
+ if ($size == 0) {
+ $hash eq ("\0" x 32)
+ or throw 'Invalid final block hash', hash => $hash;
+ $self->{eof} = 1;
+ return undef;
+ }
+
+ read_all $fh, my $block, $size or throw 'Failed to read hash block', index => $index, size => $size;
+
+ my $got_hash = digest_data('SHA256', $block);
+ $hash eq $got_hash
+ or throw 'Hash mismatch', index => $index, size => $size, got => $got_hash, expected => $hash;
+
+ $self->{block_index}++;
+ return \$block;
+}
+
+sub _write_next_hash_block {
+ my $self = shift;
+ my $fh = shift;
+
+ my $size = length(${$self->buffer});
+ $size = $self->block_size if $self->block_size < $size;
+ return 0 if $size == 0;
+
+ my $block = substr(${$self->buffer}, 0, $size, '');
+
+ my $buf = pack('L<', $self->block_index);
+ print $fh $buf or throw 'Failed to write hash block index';
+
+ my $hash = digest_data('SHA256', $block);
+ print $fh $hash or throw 'Failed to write hash';
+
+ $buf = pack('L<', length($block));
+ print $fh $buf or throw 'Failed to write hash block size';
+
+ # $fh->write($block, $size) or throw 'Failed to hash write block';
+ print $fh $block or throw 'Failed to hash write block';
+
+ $self->{block_index}++;
+ return 0;
+}
+
+sub _write_final_hash_block {
+ my $self = shift;
+ my $fh = shift;
+
+ my $buf = pack('L<', $self->block_index);
+ print $fh $buf or throw 'Failed to write hash block index';
+
+ my $hash = "\0" x 32;
+ print $fh $hash or throw 'Failed to write hash';
+
+ $buf = pack('L<', 0);
+ print $fh $buf or throw 'Failed to write hash block size';
+
+ $self->{eof} = 1;
+ return 0;
+}
+
+sub _set_error {
+ my $self = shift;
+ $ENV{DEBUG_STREAM} and print STDERR "err\t$self\n";
+ if (exists &Errno::EPROTO) {
+ $! = &Errno::EPROTO;
+ }
+ elsif (exists &Errno::EIO) {
+ $! = &Errno::EIO;
+ }
+ $self->{error} = $ERROR = File::KDBX::Error->new(@_);
+}
+
+1;
+__END__
+
+=head1 DESCRIPTION
+
+Writing to a handle with this layer will transform the data in a series of blocks. Each block is hashed, and
+the hash is included with the block in the stream.
+
+Reading from a handle, each hash block will be verified as the blocks are disassembled back into a data
+stream.
+
+Each block is encoded thusly:
+
+=for :list
+* Block index - Little-endian unsigned 32-bit integer, increments starting with 0
+* Hash - 32 bytes
+* Block size - Little-endian unsigned 32-bit (counting only the data)
+* Data - String of bytes
+
+The terminating block is an empty block where hash is 32 null bytes, block size is 0 and there is no data.
+
+=cut
--- /dev/null
+package PerlIO::via::File::KDBX::HmacBlock;
+# ABSTRACT: HMAC block-stream PerlIO layer
+
+use warnings;
+use strict;
+
+use Crypt::Digest qw(digest_data);
+use Crypt::Mac::HMAC qw(hmac);
+use File::KDBX::Error;
+use File::KDBX::Util qw(:io assert_64bit);
+use namespace::clean;
+
+our $VERSION = '999.999'; # VERSION
+our $BLOCK_SIZE = 1048576;
+our $ERROR;
+
+=method push
+
+ PerlIO::via::File::KDBX::HmacBlock->push($fh, key => $key);
+ PerlIO::via::File::KDBX::HmacBlock->push($fh, key => $key, block_size => $size);
+
+Push a new HMAC-block layer with arguments. A key is required.
+
+B<WARNING:> You mustn't push this layer using C<binmode> directly because the layer needs to be initialized
+with the key and any other desired attributes.
+
+B<WARNING:> When writing, you mustn't close the filehandle before popping this layer (using
+C<binmode($fh, ':pop')>) or the stream will be truncated. The layer needs to know when there is no more data
+before the filehandle closes so it can write the final block (which will likely be shorter than the other
+blocks), and the way to indicate that is by popping the layer.
+
+=cut
+
+my %PUSHED_ARGS;
+sub push {
+ assert_64bit;
+
+ %PUSHED_ARGS and throw 'Pushing HmacBlock layer would stomp existing arguments';
+
+ my $class = shift;
+ my $fh = shift;
+ my %args = @_ % 2 == 0 ? @_ : (key => @_);
+ $args{key} or throw 'Must pass a key';
+
+ my $key_size = length($args{key});
+ $key_size == 64 or throw 'Key must be 64 bytes in length', size => $key_size;
+
+ %PUSHED_ARGS = %args;
+ binmode($fh, ':via(' . __PACKAGE__ . ')');
+}
+
+sub PUSHED {
+ my ($class, $mode) = @_;
+
+ %PUSHED_ARGS or throw 'Programmer error: Use PerlIO::via::File::KDBX::HmacBlock->push instead of binmode';
+
+ $ENV{DEBUG_STREAM} and print STDERR "PUSHED\t$class\n";
+ my $buf = '';
+ my $self = bless {
+ block_index => 0,
+ block_size => $PUSHED_ARGS{block_size} || $BLOCK_SIZE,
+ buffer => \$buf,
+ key => $PUSHED_ARGS{key},
+ mode => $mode,
+ }, $class;
+ %PUSHED_ARGS = ();
+ return $self;
+}
+
+sub FILL {
+ my ($self, $fh) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "FILL\t$self\n";
+ return if $self->EOF($fh);
+
+ my $block = eval { $self->_read_hashed_block($fh) };
+ if (my $err = $@) {
+ $self->_set_error($err);
+ return;
+ }
+ if (length($block) == 0) {
+ $self->{eof} = 1;
+ return;
+ }
+ return $block;
+}
+
+sub WRITE {
+ my ($self, $buf, $fh) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "WRITE\t$self\n";
+ return 0 if $self->EOF($fh);
+
+ ${$self->{buffer}} .= $buf;
+
+ $self->FLUSH($fh);
+
+ return length($buf);
+}
+
+sub POPPED {
+ my ($self, $fh) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "POPPED\t$self\n";
+ return if $self->mode !~ /^w/;
+
+ $self->FLUSH($fh);
+ eval {
+ $self->_write_next_hmac_block($fh); # partial block with remaining content
+ $self->_write_final_hmac_block($fh); # terminating block
+ };
+ $self->_set_error($@) if $@;
+}
+
+sub FLUSH {
+ my ($self, $fh) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "FLUSH\t$self\n";
+ return 0 if !ref $self;
+
+ eval {
+ while ($self->block_size <= length(${$self->{buffer}})) {
+ $self->_write_next_hmac_block($fh);
+ }
+ };
+ if (my $err = $@) {
+ $self->_set_error($err);
+ return -1;
+ }
+
+ return 0;
+}
+
+sub EOF {
+ $ENV{DEBUG_STREAM} and print STDERR "EOF\t$_[0]\n";
+ $_[0]->{eof} || $_[0]->ERROR($_[1]);
+}
+sub ERROR {
+ $ENV{DEBUG_STREAM} and print STDERR "ERROR\t$_[0] : ", $_[0]->{error} // 'ok', "\n";
+ $ERROR = $_[0]->{error} if $_[0]->{error};
+ $_[0]->{error} ? 1 : 0;
+}
+sub CLEARERR {
+ $ENV{DEBUG_STREAM} and print STDERR "CLEARERR\t$_[0]\n";
+ # delete $_[0]->{error};
+}
+
+=attr key
+
+ $key = $hmac_block->key;
+
+Get the key used for authentication. The key must be exactly 64 bytes in size.
+
+=cut
+
+sub key { $_[0]->{key} or throw 'Key is not set' }
+
+=attr block_size
+
+ $size = $hmac_block->block_size;
+
+Get the block size. Default is C<$PerlIO::via::File::KDBX::HmacBlock::BLOCK_SIZE>.
+
+This only matters in write mode. When reading, block size is detected from the stream.
+
+=cut
+
+sub block_size { $_[0]->{block_size} ||= $BLOCK_SIZE }
+
+=attr block_index
+
+=attr buffer
+
+=attr mode
+
+Internal attributes.
+
+=cut
+
+sub block_index { $_[0]->{block_index} ||= 0 }
+sub buffer { $_[0]->{buffer} }
+sub mode { $_[0]->{mode} }
+
+sub _read_hashed_block {
+ my $self = shift;
+ my $fh = shift;
+
+ read_all $fh, my $hmac, 32 or throw 'Failed to read HMAC';
+
+ read_all $fh, my $size_buf, 4 or throw 'Failed to read HMAC block size';
+ my ($size) = unpack('L<', $size_buf);
+
+ my $block = '';
+ if (0 < $size) {
+ read_all $fh, $block, $size
+ or throw 'Failed to read HMAC block', index => $self->block_index, size => $size;
+ }
+
+ my $index_buf = pack('Q<', $self->block_index);
+ my $got_hmac = hmac('SHA256', $self->_hmac_key,
+ $index_buf,
+ $size_buf,
+ $block,
+ );
+
+ $hmac eq $got_hmac
+ or throw 'Block authentication failed', index => $self->block_index, got => $got_hmac, expected => $hmac;
+
+ $self->{block_index}++;
+
+ return $block;
+}
+
+sub _write_next_hmac_block {
+ my $self = shift;
+ my $fh = shift;
+ my $buffer = shift // $self->buffer;
+ my $allow_empty = shift;
+
+ my $size = length($$buffer);
+ $size = $self->block_size if $self->block_size < $size;
+ return 0 if $size == 0 && !$allow_empty;
+
+ my $block = '';
+ $block = substr($$buffer, 0, $size, '') if 0 < $size;
+
+ my $index_buf = pack('Q<', $self->block_index);
+ my $size_buf = pack('L<', $size);
+ my $hmac = hmac('SHA256', $self->_hmac_key,
+ $index_buf,
+ $size_buf,
+ $block,
+ );
+
+ print $fh $hmac, $size_buf, $block
+ or throw 'Failed to write HMAC block', hmac => $hmac, block_size => $size, err => $fh->error;
+
+ $self->{block_index}++;
+ return 0;
+}
+
+sub _write_final_hmac_block {
+ my $self = shift;
+ my $fh = shift;
+
+ $self->_write_next_hmac_block($fh, \'', 1);
+}
+
+sub _hmac_key {
+ my $self = shift;
+ my $key = shift // $self->key;
+ my $index = shift // $self->block_index;
+
+ my $index_buf = pack('Q<', $index);
+ my $hmac_key = digest_data('SHA512', $index_buf, $key);
+ return $hmac_key;
+}
+
+sub _set_error {
+ my $self = shift;
+ $ENV{DEBUG_STREAM} and print STDERR "err\t$self\n";
+ if (exists &Errno::EPROTO) {
+ $! = &Errno::EPROTO;
+ }
+ elsif (exists &Errno::EIO) {
+ $! = &Errno::EIO;
+ }
+ $self->{error} = $ERROR = File::KDBX::Error->new(@_);
+}
+
+1;
+__END__
+
+=head1 DESCRIPTION
+
+Writing to a handle with this layer will transform the data in a series of blocks. An HMAC is calculated for
+each block and is included in the output.
+
+Reading from a handle, each block will be verified and authenticated as the blocks are disassembled back into
+a data stream.
+
+Each block is encoded thusly:
+
+=for :list
+* HMAC - 32 bytes, calculated over [block index (increments starting with 0), block size and data]
+* Block size - Little-endian unsigned 32-bit (counting only the data)
+* Data - String of bytes
+
+The terminating block is an empty block encoded as usual but block size is 0 and there is no data.
+
+=cut
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use IO::Handle;
+use PerlIO::via::File::KDBX::Compression;
+use Test::More;
+
+eval { require Compress::Raw::Zlib }
+ or plan skip_all => 'Compress::Zlib::Raw required to test compression';
+
+my $expected_plaintext = 'Tiny food from Spain!';
+
+pipe(my $read, my $write) or die "pipe failed: $!";
+PerlIO::via::File::KDBX::Compression->push($read);
+PerlIO::via::File::KDBX::Compression->push($write);
+
+print $write $expected_plaintext or die "print failed: $!";
+binmode($write, ':pop'); # finish stream
+close($write) or die "close failed: $!";
+
+my $plaintext = do { local $/; <$read> };
+close($read);
+is $plaintext, $expected_plaintext, 'Deflate and inflate a string';
+
+{
+ pipe(my $read, my $write) or die "pipe failed: $!";
+ PerlIO::via::File::KDBX::Compression->push($read);
+
+ print $write 'blah blah blah' or die "print failed: $!";
+ close($write) or die "close failed: $!";
+
+ is $read->error, 0, 'Read handle starts out fine';
+ my $plaintext = do { local $/; <$read> };
+ is $read->error, 1, 'Read handle can enter and error state';
+
+ like $PerlIO::via::File::KDBX::Compression::ERROR, qr/failed to uncompress/i,
+ 'Error object is available';
+}
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use Crypt::Misc 0.029 qw(decode_b64 encode_b64);
+use File::KDBX::Constants qw(CIPHER_UUID_AES256);
+use IO::Handle;
+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);
+ test_roundtrip($block_cipher,
+ 'Smell the pretty flowers.',
+ decode_b64('pB10mV+mhTuh7bKg0KEUl5H1ajFMaP4uPnTZNcDgq6s='),
+ );
+};
+
+subtest 'Round-trip cipher stream' => sub {
+ plan tests => 3;
+ my $cipher_stream = File::KDBX::Cipher->new(stream_id => 2, key => 0x01 x 16);
+ test_roundtrip($cipher_stream,
+ 'Smell the pretty flowers.',
+ decode_b64('gNj2Ud9tWtFDy+xDN/U01RxmCoI6MAlTKQ=='),
+ );
+};
+
+subtest 'Error handling' => sub {
+ plan tests => 3;
+
+ my $block_cipher = File::KDBX::Cipher->new(uuid => CIPHER_UUID_AES256, key => 0x01 x 32, iv => 0x01 x 16);
+ pipe(my $read, my $write) or die "pipe failed: $!";
+ PerlIO::via::File::KDBX::Crypt->push($read, $block_cipher);
+
+ print $write 'blah blah blah!!';
+ close($write) or die "close failed: $!";
+
+ is $read->error, 0, 'Read handle starts out fine';
+ my $plaintext = do { local $/; <$read> };
+ is $read->error, 1, 'Read handle can enter and error state';
+
+ like $PerlIO::via::File::KDBX::Crypt::ERROR, qr/fatal/i,
+ 'Error object is available';
+};
+
+done_testing;
+exit;
+
+sub test_roundtrip {
+ my $cipher = shift;
+ my $expected_plaintext = shift;
+ my $expected_ciphertext = shift;
+
+ pipe(my $read, my $write) or die "pipe failed: $!";
+ PerlIO::via::File::KDBX::Crypt->push($write, $cipher);
+
+ print $write $expected_plaintext;
+ binmode($write, ':pop'); # finish stream
+ close($write) or die "close failed: $!";
+
+ my $ciphertext = do { local $/; <$read> };
+ close($read);
+ is $ciphertext, $expected_ciphertext, 'Encrypted a string'
+ or diag encode_b64($ciphertext);
+
+ my $ciphertext2 = $cipher->encrypt_finish($expected_plaintext);
+ is $ciphertext, $ciphertext2, 'Same result';
+
+ open(my $fh, '<', \$ciphertext) or die "open failed: $!\n";
+ PerlIO::via::File::KDBX::Crypt->push($fh, $cipher);
+
+ my $plaintext = do { local $/; <$fh> };
+ close($fh);
+ is $plaintext, $expected_plaintext, 'Decrypted a string'
+ or diag encode_b64($plaintext);
+}
--- /dev/null
+#!/usr/bin/env perl
+
+use utf8;
+use warnings;
+use strict;
+
+use FindBin qw($Bin);
+use lib "$Bin/lib";
+use TestCommon;
+
+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';
+
+ $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;
+
+ # dumper $kdbx->groups;
+
+ pass;
+};
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+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';
+ isa_ok $data, 'File::KDBX::Entry', 'Data structure is blessed';
+ is $entry->{username}, 'foo', 'username is in the object still';
+ is $entry->username, '', 'username is not the UserName string';
+
+ like exception { $entry->kdbx }, qr/disassociated from a KDBX database/, 'Dies if disassociated';
+ $entry->kdbx(my $kdbx = File::KDBX->new);
+ is $entry->kdbx, $kdbx, 'Set a database after instantiation';
+
+ is_deeply $entry, {username => 'foo', strings => {UserName => {value => ''}}},
+ 'Entry data contains what was provided to the constructor plus vivified username';
+
+ $entry = File::KDBX::Entry->new(username => 'bar');
+ is $entry->{username}, undef, 'username is not set on the data';
+ is $entry->username, 'bar', 'username is set correctly as the UserName string';
+
+ cmp_deeply $entry, noclass({
+ auto_type => {},
+ background_color => "",
+ binaries => {},
+ custom_data => {},
+ custom_icon_uuid => undef,
+ foreground_color => "",
+ icon_id => "Password",
+ override_url => "",
+ previous_parent_group => undef,
+ quality_check => bool(1),
+ strings => {
+ Notes => {
+ value => "",
+ },
+ Password => {
+ protect => bool(1),
+ value => "",
+ },
+ Title => {
+ value => "",
+ },
+ URL => {
+ value => "",
+ },
+ UserName => {
+ value => "bar",
+ },
+ },
+ tags => "",
+ times => {
+ last_modification_time => isa('Time::Piece'),
+ creation_time => isa('Time::Piece'),
+ last_access_time => isa('Time::Piece'),
+ expiry_time => isa('Time::Piece'),
+ expires => bool(0),
+ usage_count => 0,
+ location_changed => isa('Time::Piece'),
+ },
+ uuid => re('^(?s:.){16}$'),
+ }), 'Entry data contains UserName string and the rest default attributes';
+};
+
+subtest 'Custom icons' => sub {
+ plan tests => 10;
+ my $gif = pack('H*', '4749463839610100010000ff002c00000000010001000002003b');
+
+ my $entry = File::KDBX::Entry->new(my $kdbx = File::KDBX->new, icon_id => 42);
+ is $entry->custom_icon_uuid, undef, 'UUID is undef if no custom icon is set';
+ is $entry->custom_icon, undef, 'Icon is undef if no custom icon is set';
+ is $entry->icon_id, 42, 'Default icon is set to something';
+
+ is $entry->custom_icon($gif), $gif, 'Setting a custom icon returns icon';
+ is $entry->custom_icon, $gif, 'Henceforth the icon is set';
+ is $entry->icon_id, 0, 'Default icon got changed to first icon';
+ my $uuid = $entry->custom_icon_uuid;
+ isnt $uuid, undef, 'UUID is now set';
+
+ my $found = $entry->kdbx->custom_icon_data($uuid);
+ is $entry->custom_icon, $found, 'Custom icon on entry matches the database';
+
+ is $entry->custom_icon(undef), undef, 'Unsetting a custom icon returns undefined';
+ $found = $entry->kdbx->custom_icon_data($uuid);
+ is $found, $gif, 'Custom icon still exists in the database';
+};
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use File::KDBX::Util qw(erase erase_scoped);
+use Test::More;
+
+my $data1 = 'hello';
+my $data2 = 'hello';
+my $hash1 = {foo => 'secret'};
+my $array1 = [qw(bar baz)];
+
+erase $data1, \$data2, $hash1, $array1;
+is $data1, undef, 'Erase by alias';
+is $data2, undef, 'Erase by reference';
+is scalar keys %$hash1, 0, 'Erase by hashref';
+is scalar @$array1, 0, 'Erase by arrayref';
+
+{
+ my $data3 = 'hello';
+ my $cleanup = erase_scoped $data3;
+ is $data3, 'hello', 'Data not yet erased';
+ undef $cleanup;
+ is $data3, undef, 'Scoped erased';
+}
+
+sub get_secret {
+ my $secret = 'conspiracy';
+ my $cleanup = erase_scoped \$secret;
+ return $secret;
+}
+
+my $another;
+{
+ my $thing = get_secret();
+ $another = $thing;
+ is $thing, 'conspiracy', 'Data not yet erased';
+ undef $thing;
+ is $thing, undef, 'Scope erased';
+}
+is $another, 'conspiracy', 'Data not erased in the other scalar';
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use File::KDBX;
+use Test::More;
+
+BEGIN { use_ok 'File::KDBX::Error' }
+
+subtest 'Errors' => sub {
+ my $error = exception {
+ local $! = 1;
+ $@ = 'last exception';
+ throw 'uh oh', foo => 'bar';
+ };
+ like $error, qr/uh oh/, 'Errors can be thrown using the "throw" function';
+
+ $error = exception { $error->throw };
+ like $error, qr/uh oh/, 'Errors can be rethrown';
+
+ is $error->details->{foo}, 'bar', 'Errors can have details';
+ is $error->errno+0, 1, 'Errors record copy of errno when thrown';
+ is $error->previous, 'last exception', 'Warnings record copy of the last exception';
+
+ my $trace = $error->trace;
+ ok 0 < @$trace, 'Errors record a stacktrace';
+ like $trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct';
+
+ {
+ local $ENV{DEBUG} = '';
+ like "$error", qr!^uh oh at \H+error\.t line \d+\.$!, 'Errors stringify without stacktrace';
+ }
+
+ {
+ local $ENV{DEBUG} = '1';
+ like "$error", qr!^uh oh at \H+error\.t line \d+\.\nbless!,
+ 'Errors stringify with stacktrace when DEBUG environment variable is set';
+ }
+
+ $error = exception { File::KDBX::Error->throw('uh oh') };
+ like $error, qr/uh oh/, 'Errors can be thrown using the "throw" constructor';
+ like $error->trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct';
+
+ $error = File::KDBX::Error->new('uh oh');
+ $error = exception { $error->throw };
+ like $error, qr/uh oh/, 'Errors can be thrown using the "throw" method';
+ like $error->trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct';
+};
+
+subtest 'Warnings' => sub {
+ my $warning = warning {
+ local $! = 1;
+ $@ = 'last exception';
+ alert 'uh oh', foo => 'bar';
+ };
+ like $warning, qr/uh oh/, 'Warnings are enabled by default' or diag 'Warnings: ', explain $warning;
+
+ SKIP: {
+ skip 'Warning object requires Perl 5.14 or later' if $] < 5.014;
+ is $warning->details->{foo}, 'bar', 'Warnings can have details';
+ is $warning->errno+0, 1, 'Warnings record copy of errno when logged';
+ is $warning->previous, 'last exception', 'Warnings record copy of the last exception';
+ like $warning->trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct';
+ };
+
+ $warning = warning { File::KDBX::Error->warn('uh oh') };
+ like $warning, qr/uh oh/, 'Warnings can be logged using the "alert" constructor';
+ SKIP: {
+ skip 'Warning object requires Perl 5.14 or later' if $] < 5.014;
+ like $warning->trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct';
+ };
+
+ my $error = File::KDBX::Error->new('uh oh');
+ $warning = warning { $error->alert };
+ like $warning, qr/uh oh/, 'Warnings can be logged using the "alert" method';
+ SKIP: {
+ skip 'Warning object requires Perl 5.14 or later' if $] < 5.014;
+ like $warning->trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct';
+ };
+
+ {
+ local $File::KDBX::WARNINGS = 0;
+ my @warnings = warnings { alert 'uh oh' };
+ is @warnings, 0, 'Warnings can be disabled locally'
+ or diag 'Warnings: ', explain(\@warnings);
+ }
+
+ SKIP: {
+ skip 'warnings::warnif_at_level is required', 1 if !warnings->can('warnif_at_level');
+ no warnings 'File::KDBX';
+ my @warnings = warnings { alert 'uh oh' };
+ is @warnings, 0, 'Warnings can be disabled lexically'
+ or diag 'Warnings: ', explain(\@warnings);
+ }
+
+ SKIP: {
+ skip 'warnings::fatal_enabled_at_level is required', 1 if !warnings->can('fatal_enabled_at_level');
+ use warnings FATAL => 'File::KDBX';
+ my $exception = exception { alert 'uh oh' };
+ like $exception, qr/uh oh/, 'Warnings can be fatal';
+ }
+
+ {
+ my $warning;
+ local $SIG{__WARN__} = sub { $warning = shift };
+ alert 'uh oh';
+ like $warning, qr/uh oh/, 'Warnings can be caught';
+ }
+};
+
+done_testing;
--- /dev/null
+\ 1\ 2\ 3\ 4\ 5\ 6\a\b \10\11\12\13\14\15\16\17\18\19 !"#$%&'()012
\ No newline at end of file
--- /dev/null
+0123456789abcdeffedcba98765432100123456789abcdeffedcba9876543210
\ No newline at end of file
--- /dev/null
+#!/bin/sh
+
+# This is a fake ykchalresp program that provides canned responses, for testing.
+
+device=
+slot=
+blocking=1
+hmac=
+in=
+
+while getopts 12HNn:i: arg
+do
+ case "$arg" in
+ n)
+ device="$OPTARG"
+ ;;
+ 1)
+ slot=1
+ ;;
+ 2)
+ slot=2
+ ;;
+ H)
+ hmac=1
+ ;;
+ N)
+ blocking=0
+ ;;
+ i)
+ in="$OPTARG"
+ ;;
+ esac
+done
+
+if [ -z "$hmac" ]
+then
+ echo 'HMAC-SHA1 not requested' >&2
+ exit 3
+fi
+
+if [ "$in" != '-' ]
+then
+ echo "Unexpected input file: $in" >&2
+ exit 3
+fi
+
+read challenge
+
+succeed() {
+ echo "${YKCHALRESP_RESPONSE:-f000000000000000000000000000000000000000}"
+ exit 0
+}
+
+case "$YKCHALRESP_MOCK" in
+ block)
+ if [ "$blocking" -eq 0 ]
+ then
+ echo "Yubikey core error: operation would block" >&2
+ exit 1
+ fi
+ sleep 2
+ succeed
+ ;;
+ error)
+ echo "Yubikey core error: ${YKCHALRESP_ERROR:-not yet implemented}" >&2
+ exit 1
+ ;;
+ usberror)
+ echo "USB error: something happened" >&2
+ exit 1
+ ;;
+ *) # OK
+ succeed
+ ;;
+esac
+exit 2
--- /dev/null
+#!/bin/sh
+
+# This is a fake ykinfo program that provides canned responses, for testing.
+
+device=
+all=
+
+while getopts an: arg
+do
+ case "$arg" in
+ n)
+ device="$OPTARG"
+ ;;
+ a)
+ all=1
+ ;;
+ esac
+done
+
+case "$device" in
+ 0)
+ printf 'serial: 123
+version: 2.0.0
+touch_level: 0
+vendor_id: 1050
+product_id: 113
+'
+ exit 0
+ ;;
+ 1)
+ printf 'serial: 456
+version: 3.0.1
+touch_level: 10
+vendor_id: 1050
+product_id: 401
+'
+ exit 0
+ ;;
+ *)
+ echo "Yubikey core error: no yubikey present" >&2
+ exit 1
+esac
+
--- /dev/null
+BY\ 3Ææ\e\fðé\rwJ×\8eô\13\ 5A/à \ 4} ¼ð=\97\13d\14I
\ No newline at end of file
--- /dev/null
+We are all Satoshi.
--- /dev/null
+425903c6e61b0cf0e90d774ad78ef41305412fe009047da0bcf03d9713641449
\ No newline at end of file
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<KeyFile>
+ <Meta>
+ <Version>1.0</Version>
+ </Meta>
+ <Key>
+ <Data>
+ OF9tj+tfww1kHNWQaJlZWIlBdoTVXOazP8g/vZK7NcI=
+ </Data>
+ </Key>
+</KeyFile>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<KeyFile>
+ <Meta>
+ <Version>2.0</Version>
+ </Meta>
+ <Key>
+ <Data Hash="984A141E">
+ 385F6D8F EB5FC30D 641CD590 68995958
+ 89417684 D55CE6B3 3FC83FBD 92BB35C2
+ </Data>
+ </Key>
+</KeyFile>
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon qw(:no_warnings_test);
+
+use File::KDBX::Util qw(can_fork);
+use IO::Handle;
+use Test::More;
+
+BEGIN { use_ok 'PerlIO::via::File::KDBX::HashBlock' }
+
+{
+ my $expected_plaintext = 'Tiny food from Spain!';
+
+ pipe(my $read, my $write) or die "pipe failed: $!\n";
+
+ PerlIO::via::File::KDBX::HashBlock->push($write, block_size => 3);
+ print $write $expected_plaintext;
+ binmode($write, ':pop'); # finish stream
+ close($write) or die "close failed: $!";
+
+ PerlIO::via::File::KDBX::HashBlock->push($read);
+ my $plaintext = do { local $/; <$read> };
+ close($read);
+
+ 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;
+
+ my $expected_plaintext = "\x64" x (1024*1024*12 - 57);
+
+ pipe(my $read, my $write) or die "pipe failed: $!\n";
+
+ defined(my $pid = fork) or die "fork failed: $!\n";
+ if ($pid == 0) {
+ PerlIO::via::File::KDBX::HashBlock->push($write);
+ print $write $expected_plaintext;
+ binmode($write, ':pop'); # finish stream
+ close($write) or die "close failed: $!";
+ exit;
+ }
+
+ PerlIO::via::File::KDBX::HashBlock->push($read);
+ my $plaintext = do { local $/; <$read> };
+ close($read);
+
+ is $plaintext, $expected_plaintext, 'Hash-block a lot';
+
+ waitpid($pid, 0) or die "wait failed: $!\n";
+}
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon qw(:no_warnings_test);
+
+use File::KDBX::Util qw(can_fork);
+use IO::Handle;
+use Test::More;
+
+BEGIN { use_ok 'PerlIO::via::File::KDBX::HmacBlock' }
+
+my $KEY = "\x01" x 64;
+
+{
+ my $expected_plaintext = 'Tiny food from Spain!';
+
+ pipe(my $read, my $write) or die "pipe failed: $!\n";
+
+ PerlIO::via::File::KDBX::HmacBlock->push($write, block_size => 3, key => $KEY);
+ print $write $expected_plaintext;
+ binmode($write, ':pop'); # finish stream
+ close($write) or die "close failed: $!";
+
+ PerlIO::via::File::KDBX::HmacBlock->push($read, key => $KEY);
+ my $plaintext = do { local $/; <$read> };
+ close($read);
+
+ 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;
+
+ my $expected_plaintext = "\x64" x (1024*1024*12 - 57);
+
+ pipe(my $read, my $write) or die "pipe failed: $!\n";
+
+ defined(my $pid = fork) or die "fork failed: $!\n";
+ if ($pid == 0) {
+ PerlIO::via::File::KDBX::HmacBlock->push($write, key => $KEY);
+ print $write $expected_plaintext;
+ binmode($write, ':pop'); # finish stream
+ close($write) or die "close failed: $!";
+ exit;
+ }
+
+ PerlIO::via::File::KDBX::HmacBlock->push($read, key => $KEY);
+ my $plaintext = do { local $/; <$read> };
+ close($read);
+
+ is $plaintext, $expected_plaintext, 'HMAC-block a lot';
+
+ waitpid($pid, 0) or die "wait failed: $!\n";
+}
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use Encode qw(decode);
+use File::KDBX;
+use Test::Deep;
+use Test::More;
+
+eval { require File::KeePass; require File::KeePass::KDBX }
+ or plan skip_all => 'File::KeePass and File::KeePass::KDBX required to test KDB files';
+
+my $kdbx = File::KDBX->load(testfile('basic.kdb'), 'masterpw');
+
+sub test_basic {
+ my $kdbx = shift;
+
+ cmp_deeply $kdbx->headers, superhashof({
+ cipher_id => "1\301\362\346\277qCP\276X\5!j\374Z\377",
+ encryption_iv => "\250\354q\362\13\247\353\247\222!\232\364Lj\315w",
+ master_seed => "\212z\356\256\340+\n\243ms2\364'!7\216",
+ transform_rounds => 713,
+ transform_seed => "\227\264\n^\230\2\301:!f\364\336\251\277\241[\3`\314RG\343\16U\333\305eT3:\240\257",
+ }), 'Get expected headers from KDB file' or diag explain $kdbx->headers;
+
+ is keys %{$kdbx->deleted_objects}, 0, 'There are no deleted objects';
+ is scalar @{$kdbx->root->groups}, 2, 'Root group has two children.';
+
+ my $group1 = $kdbx->root->groups->[0];
+ isnt $group1->uuid, undef, 'Group 1 has a UUID';
+ is $group1->name, 'Internet', 'Group 1 has a name';
+ is scalar @{$group1->groups}, 2, 'Group 1 has subgroups';
+ is scalar @{$group1->entries}, 2, 'Group 1 has entries';
+ is $group1->icon_id, 1, 'Group 1 has an icon';
+
+ my ($entry11, $entry12, @other) = @{$group1->entries};
+
+ isnt $entry11->uuid, undef, 'Entry has a UUID';
+ is $entry11->title, 'Test entry', 'Entry has a title';
+ is $entry11->icon_id, 1, 'Entry has an icon';
+ is $entry11->username, 'I', 'Entry has a username';
+ is $entry11->url, 'http://example.com/', 'Entry has a URL';
+ is $entry11->password, 'secretpassword', 'Entry has a password';
+ is $entry11->notes, "Lorem ipsum\ndolor sit amet", 'Entry has notes';
+ ok $entry11->expires, 'Entry is expired';
+ is $entry11->expiry_time, 'Wed May 9 10:32:00 2012', 'Entry has an expiration time';
+ is scalar keys %{$entry11->binaries}, 1, 'Entry has a binary';
+ is $entry11->binary_value('attachment.txt'), "hello world\n", 'Entry has a binary';
+
+ is $entry12->title, '', 'Entry 2 has an empty title';
+ is $entry12->icon_id, 0, 'Entry 2 has an icon';
+ is $entry12->username, '', 'Entry 2 has an empty username';
+ is $entry12->url, '', 'Entry 2 has an empty URL';
+ is $entry12->password, '', 'Entry 2 has an empty password';
+ is $entry12->notes, '', 'Entry 2 has empty notes';
+ ok !$entry12->expires, 'Entry 2 is not expired';
+ is scalar keys %{$entry12->binaries}, 0, 'Entry has no binaries';
+
+ my $group11 = $group1->groups->[0];
+ is $group11->label, 'Subgroup 1', 'Group has subgroup';
+ is scalar @{$group11->groups}, 1, 'Subgroup has subgroup';
+
+ my $group111 = $group11->groups->[0];
+ is $group111->label, 'Unexpanded', 'Has unexpanded group';
+ is scalar @{$group111->groups}, 1, 'Subgroup has subgroup';
+
+ my $group1111 = $group111->groups->[0];
+ is $group1111->label, 'abc', 'Group has subsubsubroup';
+ is scalar @{$group1111->groups}, 0, 'No more subgroups';
+
+ my $group12 = $group1->groups->[1];
+ is $group12->label, 'Subgroup 2', 'Group has another subgroup';
+ is scalar @{$group12->groups}, 0, 'No more subgroups';
+
+ my $group2 = $kdbx->root->groups->[1];
+ is $group2->label, 'eMail', 'Root has another subgroup';
+ is scalar @{$group2->entries}, 1, 'eMail group has an entry';
+ is $group2->icon_id, 19, 'Group has a standard icon';
+}
+for my $test (
+ ['Basic' => $kdbx],
+ ['Basic after dump & load roundtrip'
+ => File::KDBX->load_string($kdbx->dump_string('a', randomize_seeds => 0), 'a')],
+) {
+ my ($name, $kdbx) = @$test;
+ subtest $name, \&test_basic, $kdbx;
+}
+
+sub test_custom_icons {
+ my $kdbx = shift;
+
+ my ($uuid, @other) = keys %{$kdbx->custom_icons};
+ ok $uuid, 'Database has a custom icon';
+ is scalar @other, 0, 'Database has no other icons';
+
+ my $data = $kdbx->custom_icon_data($uuid);
+ like $data, qr/^\x89PNG\r\n/, 'Custom icon is a PNG';
+}
+for my $test (
+ ['Custom icons' => $kdbx],
+ ['Custom icons after dump & load roundtrip'
+ => File::KDBX->load_string($kdbx->dump_string('a', upgrade => 0, randomize_seeds => 0), 'a')],
+) {
+ my ($name, $kdbx) = @$test;
+ subtest $name, \&test_custom_icons, $kdbx;
+}
+
+subtest 'Group expansion' => sub {
+ is $kdbx->root->groups->[0]->is_expanded, 1, 'Group is expanded';
+ is $kdbx->root->groups->[0]->groups->[0]->is_expanded, 1, 'Subgroup is expanded';
+ is $kdbx->root->groups->[0]->groups->[0]->groups->[0]->is_expanded, 0, 'Subsubgroup is not expanded';
+};
+
+subtest 'Autotype' => sub {
+ my $group = $kdbx->root->groups->[0]->groups->[0];
+ is scalar @{$group->entries}, 2, 'Group has two entries';
+
+ my ($entry1, $entry2) = @{$group->entries};
+
+ is $entry1->notes, "\nlast line", 'First entry has a note';
+ TODO: {
+ local $TODO = 'File::KeePass fails to parse out the default key sequence';
+ is $entry1->auto_type->{default_sequence}, '{USERNAME}{ENTER}', 'First entry has a default sequence';
+ };
+ cmp_deeply $entry1->auto_type->{associations}, set(
+ {
+ keystroke_sequence => "{USERNAME}{ENTER}",
+ window => "a window",
+ },
+ {
+ keystroke_sequence => "{USERNAME}{ENTER}",
+ window => "a second window",
+ },
+ {
+ keystroke_sequence => "{PASSWORD}{ENTER}",
+ window => "Window Nr 1a",
+ },
+ {
+ keystroke_sequence => "{PASSWORD}{ENTER}",
+ window => "Window Nr 1b",
+ },
+ {
+ keystroke_sequence => "{USERNAME}{ENTER}",
+ window => "Window 2",
+ },
+ ), 'First entry has auto-type window associations';
+
+ is $entry2->notes, "start line\nend line", 'Second entry has notes';
+ TODO: {
+ local $TODO = 'File::KeePass fails to parse out the default key sequence';
+ is $entry2->auto_type->{default_sequence}, '', 'Second entry has no default sequence';
+ cmp_deeply $entry2->auto_type->{associations}, set(
+ {
+ keystroke_sequence => "",
+ window => "Main Window",
+ },
+ {
+ keystroke_sequence => "",
+ window => "Test Window",
+ },
+ ), 'Second entry has auto-type window associations' or diag explain $entry2->auto_type->{associations};
+ };
+};
+
+subtest 'KDB file keys' => sub {
+ while (@_) {
+ my ($name, $key) = splice @_, 0, 2;
+ my $kdb_filepath = testfile("$name.kdb");
+ my $kdbx = File::KDBX->load($kdb_filepath, $key);
+
+ is $kdbx->root->name, $name, "Loaded KDB database with root group is named $name";
+ }
+}, (
+ FileKeyBinary => {file => testfile('FileKeyBinary.key')},
+ FileKeyHex => {file => testfile('FileKeyHex.key')},
+ FileKeyHashed => {file => testfile('FileKeyHashed.key')},
+ CompositeKey => ['mypassword', {file => testfile('FileKeyHex.key')}],
+);
+
+subtest 'Twofish' => sub {
+ plan skip_all => 'File::KeePass does not implement the Twofish cipher';
+ my $name = 'Twofish';
+ my $kdbx = File::KDBX->load(testfile("$name.kdb"), 'masterpw');
+ is $kdbx->root->name, $name, "Loaded KDB database with root group is named $name";
+};
+
+subtest 'CP-1252 password' => sub {
+ my $name = 'CP-1252';
+ my $kdbx = File::KDBX->load(testfile("$name.kdb"),
+ decode('UTF-8', "\xe2\x80\x9e\x70\x61\x73\x73\x77\x6f\x72\x64\xe2\x80\x9d"));
+ is $kdbx->root->name, $name, "Loaded KDB database with root group is named $name";
+};
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use File::KDBX;
+use File::KDBX::Constants qw(:version :kdf);
+use Test::Deep;
+use Test::More;
+
+my $kdbx = File::KDBX->load(testfile('Format200.kdbx'), 'a');
+
+verify_kdbx2($kdbx, KDBX_VERSION_2_0);
+is $kdbx->kdf->uuid, KDF_UUID_AES, 'KDBX2 file has a usable KDF configured';
+
+my $dump;
+like warning { $dump = $kdbx->dump_string('a', randomize_seeds => 0) }, qr/upgrading database/i,
+ 'There is a warning about a change in file version when writing';
+
+my $kdbx_from_dump = File::KDBX->load_string($dump, 'a');
+verify_kdbx2($kdbx_from_dump, KDBX_VERSION_3_1);
+is $kdbx->kdf->uuid, KDF_UUID_AES, 'New KDBX3 file has the same KDF';
+
+sub verify_kdbx2 {
+ my $kdbx = shift;
+ my $vers = shift;
+
+ ok_magic $kdbx, $vers, 'Get the correct KDBX2 file magic';
+
+ cmp_deeply $kdbx->headers, superhashof({
+ cipher_id => "1\301\362\346\277qCP\276X\5!j\374Z\377",
+ compression_flags => 1,
+ encryption_iv => "D+VZ\277\274>\226K\225\3237\255\231\35\4",
+ inner_random_stream_id => 2,
+ inner_random_stream_key => "\214\aW\253\362\177<\346n`\263l\245\353T\25\261BnFp\177\357\335\36(b\372z\231b\355",
+ kdf_parameters => {
+ "\$UUID" => "\311\331\363\232b\212D`\277t\r\b\301\212O\352",
+ R => 6000,
+ S => "S\202\207A\3475\265\177\220\331\263[\334\326\365\324B\\\2222zb-f\263m\220\333S\361L\332",
+ },
+ master_seed => "\253!\2\241\r*|{\227\0276Lx\215\32\\\17\372d\254\255*\21r\376\251\313+gMI\343",
+ stream_start_bytes => "\24W\24\3262oU\t>\242B\2666:\231\377\36\3\353 \217M\330U\35\367|'\230\367\221^",
+ }), 'Get expected headers from KDBX2 file' or diag explain $kdbx->headers;
+
+ cmp_deeply $kdbx->meta, superhashof({
+ custom_data => {},
+ database_description => "",
+ database_description_changed => obj_isa('Time::Piece'),
+ database_name => "",
+ database_name_changed => obj_isa('Time::Piece'),
+ default_username => "",
+ default_username_changed => obj_isa('Time::Piece'),
+ entry_templates_group => "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0",
+ entry_templates_group_changed => obj_isa('Time::Piece'),
+ generator => ignore(),
+ last_selected_group => "\226Y\251\22\356zB\@\214\222ns\273a\263\221",
+ last_top_visible_group => "\226Y\251\22\356zB\@\214\222ns\273a\263\221",
+ maintenance_history_days => 365,
+ memory_protection => superhashof({
+ protect_notes => bool(0),
+ protect_password => bool(0),
+ protect_title => bool(0),
+ protect_url => bool(1),
+ protect_username => bool(1),
+ }),
+ recycle_bin_changed => obj_isa('Time::Piece'),
+ recycle_bin_enabled => bool(1),
+ recycle_bin_uuid => "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0",
+ }), 'Get expected metadata from KDBX2 file' or diag explain $kdbx->meta;
+
+ $kdbx->unlock;
+
+ is scalar @{$kdbx->root->entries}, 1, 'Get one entry in root';
+
+ my $entry = $kdbx->root->entries->[0];
+ is $entry->title, 'Sample Entry', 'Get the correct title';
+ is $entry->username, 'User Name', 'Get the correct username';
+
+ cmp_deeply $entry->binaries, {
+ "myattach.txt" => {
+ value => "abcdefghijk",
+ },
+ "test.txt" => {
+ value => "this is a test",
+ },
+ }, 'Get two attachments from the entry' or diag explain $entry->binaries;
+
+ my @history = @{$entry->history};
+ is scalar @history, 2, 'Get two historical entries';
+ is scalar keys %{$history[0]->binaries}, 0, 'First historical entry has no attachments';
+ is scalar keys %{$history[1]->binaries}, 1, 'Second historical entry has one attachment';
+ cmp_deeply $history[1]->binary('myattach.txt'), {
+ value => 'abcdefghijk',
+ }, 'The attachment has the correct content';
+}
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use utf8;
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use File::KDBX;
+use File::KDBX::Constants qw(:version);
+use Test::Deep;
+use Test::More;
+
+subtest 'Verify Format300' => sub {
+ my $kdbx = File::KDBX->load(testfile('Format300.kdbx'), 'a');
+
+ ok_magic $kdbx, KDBX_VERSION_3_0, 'Get the correct KDBX3 file magic';
+
+ cmp_deeply $kdbx->headers, {
+ cipher_id => "1\301\362\346\277qCP\276X\5!j\374Z\377",
+ compression_flags => 1,
+ encryption_iv => "\214\306\310\0322\a9P\230\306\253\326\17\214\344\255",
+ inner_random_stream_id => 2,
+ inner_random_stream_key => "\346\n8\2\322\264i\5\5\274\22\377+\16tB\353\210\1\2m\2U%\326\347\355\313\313\340A\305",
+ kdf_parameters => {
+ "\$UUID" => "\311\331\363\232b\212D`\277t\r\b\301\212O\352",
+ R => 6000,
+ S => "\340\377\235\255\222o\1(\226m\373\tC{K\352\f\332M\302|~P\e\346J\@\275A\227\236\366",
+ },
+ master_seed => "Z\230\355\353\2303\361\237-p\345\27nM\22<E\252\314k\20\257\302\343p\"y\5sfw ",
+ stream_start_bytes => "\276\277jI1_\325\a\375\22\3\366\2V\"\316\370\316E\250B\317\232\232\207K\345.P\256b/",
+ }, 'Extract headers' or diag explain $kdbx->headers;
+
+ is $kdbx->meta->{database_name}, 'Test Database Format 0x00030000', 'Extract database name from meta';
+ is $kdbx->root->name, 'Format300', 'Extract name of root group';
+};
+
+subtest 'Verify NonAscii' => sub {
+ my $kdbx = File::KDBX->load(testfile('NonAscii.kdbx'), 'Δöض');
+
+ ok_magic $kdbx, KDBX_VERSION_3_1, 'Get the correct KDBX3 file magic';
+
+ cmp_deeply $kdbx->headers, {
+ cipher_id => "1\301\362\346\277qCP\276X\5!j\374Z\377",
+ compression_flags => 0,
+ encryption_iv => "\264\256\210m\311\312s\274U\206\t^\202\323\365]",
+ inner_random_stream_id => 2,
+ inner_random_stream_key => "Z\244]\373\13`\2108=>\r\224\351\373\316\276\253\6\317z\356\302\36\fW\1776Q\366\32\34,",
+ kdf_parameters => {
+ "\$UUID" => "\311\331\363\232b\212D`\277t\r\b\301\212O\352",
+ R => 6000,
+ S => "l\254\250\255\240U\313\364\336\316#\254\306\231\f%U\207J\235\275\34\b\25036\26\241\a\300\26\332",
+ },
+ master_seed => "\13\350\370\214{\0276\17dv\31W[H\26\272\4\335\377\356\275N\"\2A1\364\213\226\237\303M",
+ stream_start_bytes => "\220Ph\27\"h\233^\263mf\3339\262U\313\236zF\f\23\b9\323\346=\272\305})\240T",
+ }, 'Extract headers' or diag explain $kdbx->headers;
+
+ is $kdbx->meta->{database_name}, 'NonAsciiTest', 'Extract database name from meta';
+};
+
+subtest 'Verify Compressed' => sub {
+ my $kdbx = File::KDBX->load(testfile('Compressed.kdbx'), '');
+
+ ok_magic $kdbx, KDBX_VERSION_3_1, 'Get the correct KDBX3 file magic';
+
+ cmp_deeply $kdbx->headers, {
+ cipher_id => "1\301\362\346\277qCP\276X\5!j\374Z\377",
+ compression_flags => 1,
+ encryption_iv => "Z(\313\342\212x\f\326\322\342\313\320\352\354:S",
+ inner_random_stream_id => 2,
+ inner_random_stream_key => "+\232\222\302\20\333\254\342YD\371\34\373,\302:\303\247\t\26\$\a\370g\314\32J\240\371;U\234",
+ kdf_parameters => {
+ "\$UUID" => "\311\331\363\232b\212D`\277t\r\b\301\212O\352",
+ R => 6000,
+ S => "\3!\230hx\363\220nV\23\340\316\262\210\26Z\al?\343\240\260\325\262\31i\223y\b\306\344V",
+ },
+ master_seed => "\0206\244\265\203m14\257T\372o\16\271\306\347\215\365\376\304\20\356\344\3713\3\303\363\a\5\205\325",
+ stream_start_bytes => "i%Ln\30\r\261\212Q\266\b\201\et\342\203\203\374\374E\303\332\277\320\13\304a\223\215#~\266",
+ }, 'Extract headers' or diag explain $kdbx->headers;
+
+ is $kdbx->meta->{database_name}, 'Compressed', 'Extract database name from meta';
+};
+
+subtest 'Verify ProtectedStrings' => sub {
+ my $kdbx = File::KDBX->load(testfile('ProtectedStrings.kdbx'), 'masterpw');
+
+ ok_magic $kdbx, KDBX_VERSION_3_1, 'Get the correct KDBX3 file magic';
+
+ cmp_deeply $kdbx->headers, {
+ cipher_id => "1\301\362\346\277qCP\276X\5!j\374Z\377",
+ compression_flags => 1,
+ encryption_iv => "\0177y\356&\217\215\244\341\312\317Z\246m\363\251",
+ inner_random_stream_id => 2,
+ inner_random_stream_key => "%M\333Z\345\22T\363\257\27\364\206\352\334\r\3\361\250\360\314\213\253\237\23B\252h\306\243(7\13",
+ kdf_parameters => ignore(),
+ kdf_parameters => {
+ "\$UUID" => "\311\331\363\232b\212D`\277t\r\b\301\212O\352",
+ R => 6000,
+ S => "y\251\327\312mW8B\351\273\364#T#m:\370k1\240v\360E\245\304\325\265\313\337\245\211E",
+ },
+ master_seed => "\355\32<1\311\320\315\24\204\325\250\35+\2525\321\224x?\361\355\310V\322\20\331\324\"\372\334\210\233",
+ stream_start_bytes => "D#\337\260,\340.\276\312\302N\336y\233\275\360\250|\272\346*.\360\256\232\220\263>\303\aQ\371",
+ }, 'Extract headers' or diag explain $kdbx->headers;
+
+ is $kdbx->meta->{database_name}, 'Protected Strings Test', 'Extract database name from meta';
+
+ $kdbx->unlock;
+
+ my ($entry) = @{$kdbx->all_entries};
+ is $entry->title, 'Sample Entry', 'Get entry title';
+ is $entry->username, 'Protected User Name', 'Get protected username from entry';
+ is $entry->password, 'ProtectedPassword', 'Get protected password from entry';
+ is $entry->string_value('TestProtected'), 'ABC', 'Get ABC string from entry';
+ is $entry->string_value('TestUnprotected'), 'DEF', 'Get DEF string from entry';
+
+ ok $kdbx->meta->{memory_protection}{protect_password}, 'Memory protection is ON for passwords';
+ ok $entry->string('TestProtected')->{protect}, 'Protection is ON for TestProtected';
+ ok !$entry->string('TestUnprotected')->{protect}, 'Protection is OFF for TestUnprotected';
+};
+
+subtest 'Verify BrokenHeaderHash' => sub {
+ like exception { File::KDBX->load(testfile('BrokenHeaderHash.kdbx'), '') },
+ qr/header hash does not match/i, 'Fail to load a database with a corrupted header hash';
+};
+
+subtest 'Dump and load' => sub {
+ my $kdbx = File::KDBX->new;
+ my $dump = $kdbx->dump_string('foo');
+ ok $dump;
+};
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use utf8;
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use File::KDBX;
+use File::KDBX::Constants qw(:version :kdf);
+use Test::Deep;
+use Test::More;
+use boolean qw(:all);
+
+subtest 'Verify Format400' => sub {
+ my $kdbx = File::KDBX->load(testfile('Format400.kdbx'), 't');
+ $kdbx->unlock;
+
+ ok_magic $kdbx, KDBX_VERSION_4_0, 'Get the correct KDBX4 file magic';
+
+ cmp_deeply $kdbx->headers, {
+ cipher_id => "\326\3\212+\213oL\265\245\$3\2321\333\265\232",
+ compression_flags => 1,
+ encryption_iv => "3?\207P\233or\220\215h\2240",
+ kdf_parameters => {
+ "\$UUID" => "\357cm\337\214)DK\221\367\251\244\3\343\n\f",
+ I => 2,
+ M => 1048576,
+ P => 2,
+ S => "V\254\6m-\206*\260\305\f\0\366\24:4\235\364A\362\346\221\13)}\250\217P\303\303\2\331\245",
+ V => 19,
+ },
+ master_seed => ";\372y\300yS%\3331\177\231\364u\265Y\361\225\3273h\332R,\22\240a\240\302\271\357\313\23",
+ }, 'Extract headers' or diag explain $kdbx->headers;
+
+ is $kdbx->meta->{database_name}, 'Format400', 'Extract database name from meta';
+ is $kdbx->root->name, 'Format400', 'Extract name of root group';
+
+ my ($entry, @other) = $kdbx->find_entries([\'400', 'title']);
+ is @other, 0, 'Database has one entry';
+
+ is $entry->title, 'Format400', 'Entry is titled';
+ is $entry->username, 'Format400', 'Entry has a username set';
+ is keys %{$entry->strings}, 6, 'Entry has six strings';
+ is $entry->string_value('Format400'), 'Format400', 'Entry has a custom string';
+ is keys %{$entry->binaries}, 1, 'Entry has one binary';
+ is $entry->binary_value('Format400'), "Format400\n", 'Entry has a binary string';
+};
+
+subtest 'KDBX4 upgrade' => sub {
+ my $kdbx = File::KDBX->new;
+
+ $kdbx->kdf_parameters->{+KDF_PARAM_UUID} = KDF_UUID_AES_CHALLENGE_RESPONSE;
+ is $kdbx->minimum_version, KDBX_VERSION_4_0, 'AES challenge-response KDF requires upgrade';
+ $kdbx->kdf_parameters->{+KDF_PARAM_UUID} = KDF_UUID_ARGON2D;
+ is $kdbx->minimum_version, KDBX_VERSION_4_0, 'Argon2D KDF requires upgrade';
+ $kdbx->kdf_parameters->{+KDF_PARAM_UUID} = KDF_UUID_ARGON2ID;
+ is $kdbx->minimum_version, KDBX_VERSION_4_0, 'Argon2ID KDF requires upgrade';
+ $kdbx->kdf_parameters->{+KDF_PARAM_UUID} = KDF_UUID_AES;
+ is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement';
+
+ $kdbx->public_custom_data->{foo} = 42;
+ is $kdbx->minimum_version, KDBX_VERSION_4_0, 'Public custom data requires upgrade';
+ delete $kdbx->public_custom_data->{foo};
+ is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement';
+
+ my $entry = $kdbx->add_entry;
+ $entry->custom_data(foo => 'bar');
+ is $kdbx->minimum_version, KDBX_VERSION_4_0, 'Entry custom data requires upgrade';
+ delete $entry->custom_data->{foo};
+ is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement';
+
+ my $group = $kdbx->add_group;
+ $group->custom_data(foo => 'bar');
+ is $kdbx->minimum_version, KDBX_VERSION_4_0, 'Group custom data requires upgrade';
+ delete $group->custom_data->{foo};
+ is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement';
+};
+
+subtest 'KDBX4.1 upgrade' => sub {
+ my $kdbx = File::KDBX->new;
+
+ my $group1 = $kdbx->add_group;
+ my $group2 = $kdbx->add_group;
+ my $entry1 = $kdbx->add_entry;
+
+ $group1->tags('hi');
+ is $kdbx->minimum_version, KDBX_VERSION_4_1, 'Groups with tags requires upgrade';
+ $group1->tags('');
+ is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement';
+
+ $entry1->quality_check(0);
+ is $kdbx->minimum_version, KDBX_VERSION_4_1, 'Disable entry quality check requires upgrade';
+ $entry1->quality_check(1);
+ is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement';
+
+ $group1->previous_parent_group($group2->uuid);
+ is $kdbx->minimum_version, KDBX_VERSION_4_1, 'Previous parent group on group requires upgrade';
+ $group1->previous_parent_group(undef);
+ is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement';
+
+ $entry1->previous_parent_group($group2->uuid);
+ is $kdbx->minimum_version, KDBX_VERSION_4_1, 'Previous parent group on entry requires upgrade';
+ $entry1->previous_parent_group(undef);
+ is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement';
+
+ $kdbx->add_custom_icon('data');
+ is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Icon with no metadata requires no upgrade';
+ my $icon_uuid = $kdbx->add_custom_icon('data2', name => 'icon name');
+ is $kdbx->minimum_version, KDBX_VERSION_4_1, 'Icon with name requires upgrade';
+ delete $kdbx->custom_icons->{$icon_uuid};
+ is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement';
+ $icon_uuid = $kdbx->add_custom_icon('data2', last_modification_time => gmtime);
+ is $kdbx->minimum_version, KDBX_VERSION_4_1, 'Icon with modtime requires upgrade';
+ delete $kdbx->custom_icons->{$icon_uuid};
+ is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement';
+
+ $entry1->custom_data(foo => 'bar', last_modification_time => scalar gmtime);
+ is $kdbx->minimum_version, KDBX_VERSION_4_1, 'Entry custom data modtime requires upgrade';
+ delete $entry1->custom_data->{foo};
+ is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement';
+
+ $group1->custom_data(foo => 'bar', last_modification_time => scalar gmtime);
+ is $kdbx->minimum_version, KDBX_VERSION_4_1, 'Group custom data modtime requires upgrade';
+ delete $group1->custom_data->{foo};
+ is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement';
+};
+
+sub test_upgrade_master_key_integrity {
+ my ($modifier, $expected_version) = @_;
+ plan tests => $expected_version >= KDBX_VERSION_4_0 ? 6 : 5;
+
+ my $kdbx = File::KDBX->new;
+ $kdbx->kdf_parameters(fast_kdf);
+
+ is $kdbx->kdf->uuid, KDF_UUID_AES, 'Default KDF is AES';
+
+ {
+ local $_ = $kdbx;
+ $modifier->($kdbx);
+ }
+ is $kdbx->minimum_version, $expected_version,
+ sprintf('Got expected minimum version after modification: %x', $kdbx->minimum_version);
+
+ my $master_key = ['fffqcvq4rc', \'this is a keyfile', sub { 'chalresp 523rf2' }];
+ my $dump;
+ warnings { $kdbx->dump_string(\$dump, $master_key) };
+ ok $dump, 'Can dump the database' or diag explain $dump;
+
+ like exception { File::KDBX->load_string($dump, 'wrong key') },
+ qr/invalid credentials/i, 'Cannot load a KDBX with the wrong key';
+
+ # print STDERR "DUMP: [$dump]\n";
+
+ my $kdbx2 = File::KDBX->load_string($dump, $master_key);
+
+ is $kdbx2->version, $expected_version, sprintf('Got expected version: %x', $kdbx2->version);
+ isnt $kdbx2->kdf->uuid, KDF_UUID_AES, 'No unexpected KDF' if $kdbx2->version >= KDBX_VERSION_4_0;
+
+ # diag explain(File::KDBX->load_string($dump, $master_key, inner_format => 'Raw')->raw);
+}
+for my $test (
+ [KDBX_VERSION_3_1, 'nothing', sub {}],
+ [KDBX_VERSION_3_1, 'AES KDF', sub { $_->kdf_parameters(fast_kdf(KDF_UUID_AES)) }],
+ [KDBX_VERSION_4_0, 'Argon2D KDF', sub { $_->kdf_parameters(fast_kdf(KDF_UUID_ARGON2D)) }],
+ [KDBX_VERSION_4_0, 'Argon2ID KDF', sub { $_->kdf_parameters(fast_kdf(KDF_UUID_ARGON2ID)) }],
+ [KDBX_VERSION_4_0, 'public custom data', sub { $_->public_custom_data->{foo} = 'bar' }],
+ [KDBX_VERSION_3_1, 'custom data', sub { $_->custom_data(foo => 'bar') }],
+ [KDBX_VERSION_4_0, 'root group custom data', sub { $_->root->custom_data(baz => 'qux') }],
+ [KDBX_VERSION_4_0, 'group custom data', sub { $_->add_group->custom_data(baz => 'qux') }],
+ [KDBX_VERSION_4_0, 'entry custom data', sub { $_->add_entry->custom_data(baz => 'qux') }],
+) {
+ my ($expected_version, $name, $modifier) = @$test;
+ subtest "Master key integrity: $name" => \&test_upgrade_master_key_integrity,
+ $modifier, $expected_version;
+}
+
+subtest 'Custom data' => sub {
+ my $kdbx = File::KDBX->new;
+ $kdbx->kdf_parameters(fast_kdf(KDF_UUID_AES));
+ $kdbx->version(KDBX_VERSION_4_0);
+
+ $kdbx->public_custom_data->{str} = '你好';
+ $kdbx->public_custom_data->{num} = 42;
+ $kdbx->public_custom_data->{bool} = true;
+ $kdbx->public_custom_data->{bytes} = "\1\2\3\4";
+
+ my $group = $kdbx->add_group(label => 'Group');
+ $group->custom_data(str => '你好');
+ $group->custom_data(num => 42);
+ $group->custom_data(bool => true);
+
+ my $entry = $kdbx->add_entry(label => 'Entry');
+ $entry->custom_data(str => '你好');
+ $entry->custom_data(num => 42);
+ $entry->custom_data(bool => false);
+
+ my $dump = $kdbx->dump_string('a');
+ my $kdbx2 = File::KDBX->load_string($dump, 'a');
+
+ is $kdbx2->public_custom_data->{str}, '你好', 'Store a string in public custom data';
+ cmp_ok $kdbx2->public_custom_data->{num}, '==', 42, 'Store a number in public custom data';
+ is $kdbx2->public_custom_data->{bool}, true, 'Store a boolean in public custom data';
+ ok isBoolean($kdbx2->public_custom_data->{bool}), 'Boolean is indeed a boolean';
+ is $kdbx2->public_custom_data->{bytes}, "\1\2\3\4", 'Store some bytes in public custom data';
+
+ my ($group2) = $kdbx2->find_groups({label => 'Group'});
+ is_deeply $group2->custom_data_value('str'), '你好', 'Store a string in group custom data';
+ is_deeply $group2->custom_data_value('num'), '42', 'Store a number in group custom data';
+ is_deeply $group2->custom_data_value('bool'), '1', 'Store a boolean in group custom data';
+
+ my ($entry2) = $kdbx2->find_entries({label => 'Entry'});
+ is_deeply $entry2->custom_data_value('str'), '你好', 'Store a string in entry custom data';
+ is_deeply $entry2->custom_data_value('num'), '42', 'Store a number in entry custom data';
+ is_deeply $entry2->custom_data_value('bool'), '0', 'Store a boolean in entry custom data';
+};
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+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';
+
+my $r = $kdf->transform("\2" x 32);
+is $r, "\342\234cp\375\\p\253]\213\f\246\345\230\266\260\r\222j\332Z\204:\322 p\224mhm\360\222",
+ 'AES KDF works without XS';
+
+like exception { $kdf->transform("\2" x 33) }, qr/raw key must be 32 bytes/i,
+ 'Transformation requires valid arguments';
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use File::KDBX::Constants qw(: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);
+ is $result1, "\342\234cp\375\\p\253]\213\f\246\345\230\266\260\r\222j\332Z\204:\322 p\224mhm\360\222",
+ 'AES KDF basically works';
+
+ like exception { $kdf1->transform("\2" x 33) }, qr/raw key must be 32 bytes/i,
+ 'Transformation requires valid arguments';
+};
+
+subtest 'Argon2 KDF' => sub {
+ my $kdf1 = File::KDBX::KDF->new(
+ uuid => KDF_UUID_ARGON2D,
+ salt => "\2" x 32,
+ iterations => 2,
+ parallelism => 2,
+ );
+ my $r1 = $kdf1->transform("\2" x 32);
+ is $r1, "\352\333\247\347+x#\"C\340\224\30\316\350\3068E\246\347H\263\214V\310\5\375\16N.K\320\255",
+ 'Argon2D KDF works';
+
+ my $kdf2 = File::KDBX::KDF->new(
+ uuid => KDF_UUID_ARGON2ID,
+ salt => "\2" x 32,
+ iterations => 2,
+ parallelism => 3,
+ );
+ my $r2 = $kdf2->transform("\2" x 32);
+ is $r2, "S\304\304u\316\311\202^\214JW{\312=\236\307P\345\253\323\313\23\215\247\210O!#F\16\1x",
+ 'Argon2ID KDF works';
+};
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use Crypt::Misc 0.029 qw(decode_b64 encode_b64);
+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';
+ is $pkey->raw_key, decode_b64('XohImNooBHFR0OVvjcYpJ3NgPQ1qq73WKhHvch0VQtg='),
+ 'Can calculate raw key from password' or diag encode_b64($pkey->raw_key);
+
+ my $fkey = File::KDBX::Key->new(\'password');
+ isa_ok $fkey, 'File::KDBX::Key::File';
+ is $fkey->raw_key, decode_b64('XohImNooBHFR0OVvjcYpJ3NgPQ1qq73WKhHvch0VQtg='),
+ 'Can calculate raw key from file' or diag encode_b64($fkey->raw_key);
+
+ my $ckey = File::KDBX::Key->new([
+ $pkey,
+ $fkey,
+ 'another password',
+ File::KDBX::Key::File->new(testfile(qw{keys hashed.key})),
+ ]);
+ isa_ok $ckey, 'File::KDBX::Key::Composite';
+ is $ckey->raw_key, decode_b64('FLV8/zOT9mEL8QKkzizq7mJflnb25ITblIPq608MGrk='),
+ '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';
+
+ my $buf = 'password';
+ open(my $fh, '<', \$buf) or die "open failed: $!\n";
+
+ $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';
+
+ like exception { File::KDBX::Key::File->init },
+ qr/^Missing key primitive/, 'Throws 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';
+
+ like exception { File::KDBX::Key::File->new({}) },
+ qr/^Unexpected primitive type/, 'Throws if primitive is the wrong type';
+};
+
+done_testing;
--- /dev/null
+package TestCommon;
+
+use warnings;
+use strict;
+
+use Data::Dumper;
+use File::KDBX::Constants qw(:magic :kdf);
+use File::KDBX::Util qw(can_fork dumper);
+use File::Spec::Functions qw(catfile);
+use FindBin qw($Bin);
+use Test::Fatal;
+use Test::Deep;
+
+BEGIN {
+ $Data::Dumper::Deepcopy = 1;
+ $Data::Dumper::Deparse = 1;
+ $Data::Dumper::Indent = 1;
+ $Data::Dumper::Quotekeys = 0;
+ $Data::Dumper::Sortkeys = 1;
+ $Data::Dumper::Terse = 1;
+ $Data::Dumper::Trailingcomma = 1;
+ $Data::Dumper::Useqq = 1;
+}
+
+sub import {
+ my $self = shift;
+ my @args = @_;
+
+ my $caller = caller;
+
+ require Test::Warnings;
+ my @warnings_flags;
+ push @warnings_flags, ':no_end_test' if !$ENV{AUTHOR_TESTING} || grep { $_ eq ':no_warnings_test' } @args;
+ Test::Warnings->import(@warnings_flags);
+
+ # Just export a random assortment of things useful for testing.
+ no strict 'refs';
+ *{"${caller}::dumper"} = \&File::KDBX::Util::dumper;
+ *{"${caller}::catfile"} = \&File::Spec::Functions::catfile;
+
+ *{"${caller}::exception"} = \&Test::Fatal::exception;
+ *{"${caller}::warning"} = \&Test::Warnings::warning;
+ *{"${caller}::warnings"} = \&Test::Warnings::warnings;
+
+ *{"${caller}::dump_test_deep_template"} = \&dump_test_deep_template;
+ *{"${caller}::ok_magic"} = \&ok_magic;
+ *{"${caller}::fast_kdf"} = \&fast_kdf;
+ *{"${caller}::can_fork"} = \&can_fork;
+ *{"${caller}::testfile"} = \&testfile;
+}
+
+sub testfile {
+ return catfile($Bin, 'files', @_);
+}
+
+sub dump_test_deep_template {
+ my $struct = shift;
+
+ my $str = Dumper $struct;
+ # booleans: bless( do{\(my $o = 1)}, 'boolean' )
+ $str =~ s/bless\( do\{\\\(my \$o = ([01])\)\}, 'boolean' \)/bool($1)/gs;
+ # objects
+ $str =~ s/bless\(.+?'([^']+)' \)/obj_isa('$1')/gs;
+ # convert two to four space indentation
+ $str =~ s/^( +)/' ' x (length($1) * 2)/gme;
+
+ open(my $fh, '>>', 'TEST-DEEP-TEMPLATES.pl') or die "open failed: $!";
+ print $fh $str, "\n";
+}
+
+sub ok_magic {
+ my $kdbx = shift;
+ my $vers = shift;
+ my $note = shift;
+
+ my $magic = [$kdbx->sig1, $kdbx->sig2, $kdbx->version];
+ cmp_deeply $magic, [
+ KDBX_SIG1,
+ KDBX_SIG2_2,
+ $vers,
+ ], $note // 'KDBX magic numbers are correct';
+}
+
+sub fast_kdf {
+ my $uuid = shift // KDF_UUID_AES;
+ my $params = {
+ KDF_PARAM_UUID() => $uuid,
+ };
+ if ($uuid eq KDF_UUID_AES || $uuid eq KDF_UUID_AES_CHALLENGE_RESPONSE) {
+ $params->{+KDF_PARAM_AES_ROUNDS} = 17;
+ $params->{+KDF_PARAM_AES_SEED} = "\1" x 32;
+ }
+ else { # Argon2
+ $params->{+KDF_PARAM_ARGON2_SALT} = "\1" x 32;
+ $params->{+KDF_PARAM_ARGON2_PARALLELISM} = 1;
+ $params->{+KDF_PARAM_ARGON2_MEMORY} = 1 << 13;
+ $params->{+KDF_PARAM_ARGON2_ITERATIONS} = 2;
+ $params->{+KDF_PARAM_ARGON2_VERSION} = 0x13;
+ }
+ return $params;
+}
+1;
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use Crypt::Digest qw(digest_data);
+use Crypt::PRNG qw(random_bytes);
+use Crypt::Misc qw(decode_b64);
+use File::KDBX::Key;
+use File::KDBX::Util qw(:erase :load);
+use File::KDBX;
+use IO::Handle;
+use List::Util qw(max);
+use POSIX ();
+use Scalar::Util qw(looks_like_number);
+use Scope::Guard;
+use Test::More;
+
+BEGIN {
+ if (!$ENV{AUTHOR_TESTING}) {
+ plan skip_all => 'AUTHOR_TESTING required to test memory protection';
+ exit;
+ }
+ if (!can_fork || !try_load_optional('POSIX::1003')) {
+ plan skip_all => 'fork and POSIX::1003 required to test memory protection';
+ exit;
+ }
+ POSIX::1003->import(':rlimit');
+}
+
+my $BLOCK_SIZE = 8196;
+
+-e 'core' && die "Remove or move the core dump!\n";
+my $cleanup = Scope::Guard->new(sub { unlink('core') });
+
+my ($cur, $max, $success) = getrlimit('RLIMIT_CORE');
+$success or die "getrlimit failed: $!\n";
+if ($cur < 1<<16) {
+ setrlimit('RLIMIT_CORE', RLIM_INFINITY, RLIM_INFINITY) or die "setrlimit failed: $!\n";
+}
+
+my $SECRET = 'c3VwZXJjYWxpZnJhZ2lsaXN0aWM=';
+my $SECRET_SHA256 = 'y1cOWidI80n5EZQx24NrOiP9tlca/uNMBDLYciDyQxs=';
+
+for my $test (
+ {
+ test => 'secret in scope',
+ run => sub {
+ my $secret = decode_b64($SECRET);
+ dump_core();
+ },
+ strings => [
+ $SECRET => 1,
+ ],
+ },
+ {
+ test => 'erased secret',
+ run => sub {
+ my $secret = decode_b64($SECRET);
+ erase $secret;
+ dump_core();
+ },
+ strings => [
+ $SECRET => 0,
+ ],
+ },
+ {
+ test => 'Key password',
+ run => sub {
+ my $password = decode_b64($SECRET);
+ my $key = File::KDBX::Key->new($password);
+ erase $password;
+ dump_core();
+ },
+ strings => [
+ $SECRET => 0,
+ ],
+ },
+ {
+ test => 'Key password, raw key shown',
+ run => sub {
+ my $password = decode_b64($SECRET);
+ my $key = File::KDBX::Key->new($password);
+ erase $password;
+ $key->show;
+ dump_core();
+ },
+ strings => [
+ $SECRET => 0,
+ $SECRET_SHA256 => 1,
+ ],
+ },
+ {
+ test => 'Key password, raw key hidden',
+ run => sub {
+ my $password = decode_b64($SECRET);
+ my $key = File::KDBX::Key->new($password);
+ erase $password;
+ $key->show->hide for 0..500;
+ dump_core();
+ },
+ strings => [
+ $SECRET => 0,
+ $SECRET_SHA256 => 0,
+ ],
+ },
+ {
+ test => 'protected strings and keys',
+ run => sub {
+ my $kdbx = File::KDBX->load(testfile('MemoryProtection.kdbx'), 'masterpw');
+ dump_core();
+ },
+ strings => [
+ 'TXkgcGFzc3dvcmQgaXMgYSBzZWNyZXQgdG8gZXZlcnlvbmUu' => 0, # Password
+ 'QSB0cmVhc3VyZSBtYXAgaXMgb24gdGhlIGJhY2sgb2YgdGhlIERlY2xhcmF0aW9uIG9mIEluZGVwZW5kZW5jZS4=' => 0,
+ # Secret A:
+ 'SmVmZnJleSBFcHN0ZWluIGRpZG4ndCBraWxsIGhpbXNlbGYu' => 0, # Secret B
+ 'c3VwZXJjYWxpZnJhZ2lsaXN0aWNleHBpYWxpZG9jaW91cw==' => 1, # Nonsecret
+ 'SlHA3Eyhomr/UQ6vznWMRZtxlrqIm/tM3qVZv7G31DU=' => 0, # Final key
+ 'LuVqNfGluvLPcg2W699/Q6WGxIztX7Jvw0ONwQEi/Jc=' => 0, # Transformed key
+ # HMAC key:
+ 'kDEMVEcGR32UXTwG8j3SxsfdF+l124Ni6iHeogCWGd2z0KSG5PosDTloxC0zg7Ucn2CNR6f2wpgzcVGKmDNFCA==' => 0,
+ # Inner random stream key:
+ 'SwJSukmQdZKpHm8PywqLu1EHfUzS/gyJsg61Cm74YeRJeOpDlFblbVd5d4p+lU2/7Q28Vk4j/E2RRMC81DXdUw==' => 1,
+ 'RREzJd4fKHtFkjRIi+xucGPW2q+mov+LRWL4RkPql7Y=' => 1, # Random stream key (actual)
+ ],
+ },
+ {
+ test => 'inner random stream key replaced',
+ run => sub {
+ my $kdbx = File::KDBX->load(testfile('MemoryProtection.kdbx'), 'masterpw');
+ $kdbx->inner_random_stream_key("\1" x 64);
+ dump_core();
+ },
+ strings => [
+ # Inner random stream key:
+ # FIXME - there is second copy of this key somewhere... in another SvPV?
+ 'SwJSukmQdZKpHm8PywqLu1EHfUzS/gyJsg61Cm74YeRJeOpDlFblbVd5d4p+lU2/7Q28Vk4j/E2RRMC81DXdUw==' => undef,
+ ],
+ },
+ {
+ test => 'protected strings revealed',
+ run => sub {
+ my $kdbx = File::KDBX->load(testfile('MemoryProtection.kdbx'), 'masterpw');
+ $kdbx->unlock;
+ dump_core();
+ },
+ strings => [
+ 'TXkgcGFzc3dvcmQgaXMgYSBzZWNyZXQgdG8gZXZlcnlvbmUu' => 1, # Password
+ # Secret A:
+ 'QSB0cmVhc3VyZSBtYXAgaXMgb24gdGhlIGJhY2sgb2YgdGhlIERlY2xhcmF0aW9uIG9mIEluZGVwZW5kZW5jZS4=' => 1,
+ 'SmVmZnJleSBFcHN0ZWluIGRpZG4ndCBraWxsIGhpbXNlbGYu' => 1, # Secret B
+ 'c3VwZXJjYWxpZnJhZ2lsaXN0aWNleHBpYWxpZG9jaW91cw==' => 1, # Nonsecret
+ 'RREzJd4fKHtFkjRIi+xucGPW2q+mov+LRWL4RkPql7Y=' => 0, # Random stream key (actual)
+ ],
+ },
+ {
+ test => 'protected strings previously-revealed',
+ run => sub {
+ my $kdbx = File::KDBX->load(testfile('MemoryProtection.kdbx'), 'masterpw');
+ $kdbx->unlock;
+ $kdbx->lock;
+ dump_core();
+ },
+ strings => [
+ 'TXkgcGFzc3dvcmQgaXMgYSBzZWNyZXQgdG8gZXZlcnlvbmUu' => 0, # Password
+ # Secret A:
+ 'QSB0cmVhc3VyZSBtYXAgaXMgb24gdGhlIGJhY2sgb2YgdGhlIERlY2xhcmF0aW9uIG9mIEluZGVwZW5kZW5jZS4=' => 0,
+ 'SmVmZnJleSBFcHN0ZWluIGRpZG4ndCBraWxsIGhpbXNlbGYu' => 0, # Secret B
+ 'c3VwZXJjYWxpZnJhZ2lsaXN0aWNleHBpYWxpZG9jaW91cw==' => 1, # Nonsecret
+ 'RREzJd4fKHtFkjRIi+xucGPW2q+mov+LRWL4RkPql7Y=' => 0, # Random stream key (actual)
+ ],
+ },
+) {
+ my ($description, $run, $strings) = @$test{qw(test run strings)};
+
+ subtest "Dump core with $description" => sub {
+ my @strings = @_;
+ my $num_strings = @strings / 2;
+ plan tests => 2 + $num_strings * 2;
+
+ my (@encoded_strings, @expected);
+ while (@strings) {
+ my ($string, $expected) = splice @strings, 0, 2;
+ push @encoded_strings, $string;
+ push @expected, $expected;
+ }
+
+ my ($dumped, $has_core, @matches) = run_test($run, @encoded_strings);
+
+ ok $dumped, 'Test process signaled that it core-dumped';
+ ok $has_core, 'Found core dump' or return;
+
+ note sprintf('core dump is %.1f MiB', (-s 'core')/1048576);
+
+ for (my $i = 1; $i <= $num_strings; ++$i) {
+ my $count = $matches[$i - 1];
+ my $string = $encoded_strings[$i - 1];
+ my $expected = $expected[$i - 1];
+
+ ok defined $count, "[#$i] Got result from test environment";
+
+ TODO: {
+ local $TODO = 'Unprotected memory!' if !defined $expected;
+ if ($expected) {
+ ok 0 < $count, "[#$i] String FOUND"
+ or diag "Found $count copies of string #$i\nString: $string";
+ }
+ else {
+ is $count, 0, "[#$i] String MISSING"
+ or diag "Found $count copies of string #$i\nString: $string";
+ }
+ }
+ }
+ }, @$strings;
+}
+
+done_testing;
+exit;
+
+##############################################################################
+
+sub dump_core { kill 'QUIT', $$ }
+
+sub file_grep {
+ my $filepath = shift;
+ my @strings = @_;
+
+ my $counter = 0;
+ my %counts = map { $_ => $counter++ } @strings;
+ my @counts = map { 0 } @strings;
+
+ my $pattern = join('|', map { quotemeta($_) } @strings);
+
+ my $overlap = (max map { length } @strings) - 1;
+
+ open(my $fh, '<:raw', $filepath) or die "open failed: $!\n";
+
+ my $previous;
+ while (read $fh, my $block, $BLOCK_SIZE) {
+ substr($block, 0, 0, substr($previous, -$overlap)) if defined $previous;
+
+ while ($block =~ /($pattern)/gs) {
+ ++$counts[$counts{$1}];
+ }
+ $previous = substr($block, $overlap);
+ }
+ die "read error: $!" if $fh->error;
+
+ return @counts;
+}
+
+sub run_test {
+ my $code = shift;
+ my @strings = @_;
+
+ my $seed = random_bytes(32);
+
+ pipe(my $read, my $write) or die "pipe failed: $!\n";
+
+ defined(my $pid = fork) or die "fork failed: $!\n";
+ if (!$pid) { # child
+ close($read);
+
+ my $exit_status = run_doomed_child($code, $seed);
+ my $dumped = $exit_status & 127 && $exit_status & 128;
+
+ my @decoded_strings = map { decode_b64($_) } @strings;
+
+ my @matches = file_grep('core', @decoded_strings);
+ print $write join('|', $dumped, -f 'core' ? 1 : 0, @matches);
+ close($write);
+
+ POSIX::_exit(0);
+ }
+
+ close($write);
+ my $results = do { local $/; <$read> };
+
+ waitpid($pid, 0);
+ my $exit_status = $? >> 8;
+ $exit_status == 0 or die "test environment exited non-zero: $exit_status\n";
+
+ return split(/\|/, $results);
+}
+
+sub run_doomed_child {
+ my $code = shift;
+ my $seed = shift;
+
+ unlink('core') or die "unlink failed: $!\n" if -f 'core';
+
+ defined(my $pid = fork) or die "fork failed: $!\n";
+ if (!$pid) { # child
+ $code->();
+ dump_core(); # doomed
+ POSIX::_exit(1); # paranoid
+ }
+
+ waitpid($pid, 0);
+ return $?;
+}
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use File::KDBX::Entry;
+use File::KDBX::Util qw(:uuid);
+use File::KDBX;
+use Test::Deep;
+use Test::More;
+
+subtest 'Cloning' => sub {
+ my $kdbx = File::KDBX->new;
+ my $entry = File::KDBX::Entry->new;
+
+ my $copy = $entry->clone;
+ like exception { $copy->kdbx }, qr/disassociated/, 'Disassociated entry copy is also disassociated';
+ cmp_deeply $copy, $entry, 'Disassociated entry and its clone are identical';
+
+ $entry->kdbx($kdbx);
+ $copy = $entry->clone;
+ is $entry->kdbx, $copy->kdbx, 'Associated entry copy is also associated';
+ cmp_deeply $copy, $entry, 'Associated entry and its clone are identical';
+
+ my $txn = $entry->begin_work;
+ $entry->title('foo');
+ $entry->username('bar');
+ $entry->password('baz');
+ $txn->commit;
+
+ $copy = $entry->clone;
+ is @{$copy->history}, 1, 'Copy has a historical entry';
+ cmp_deeply $copy, $entry, 'Entry with history and its clone are identical';
+
+ $copy = $entry->clone(history => 0);
+ is @{$copy->history}, 0, 'Copy excluding history has no history';
+
+ $copy = $entry->clone(new_uuid => 1);
+ isnt $copy->uuid, $entry->uuid, 'Entry copy with new UUID has a different UUID';
+
+ $copy = $entry->clone(reference_username => 1);
+ my $ref = sprintf('{REF:U@I:%s}', format_uuid($entry->uuid));
+ is $copy->username, $ref, 'Copy has username reference';
+ is $copy->expanded_username, $ref, 'Entry copy does not expand username because entry is not in database';
+
+ my $group = $kdbx->add_group(label => 'Passwords');
+ $group->add_entry($entry);
+ is $copy->expanded_username, $entry->username,
+ 'Entry in database and its copy with username ref have same expanded username';
+
+ $copy = $entry->clone;
+ is @{$kdbx->all_entries}, 1, 'Still only one entry after cloning';
+
+ $copy = $entry->clone(parent => 1);
+ is @{$kdbx->all_entries}, 2, 'New copy added to database if clone with parent option';
+ my ($e1, $e2) = @{$kdbx->all_entries};
+ isnt $e1, $e2, 'Entry and its copy in the database are different objects';
+ is $e1->title, $e2->title, 'Entry copy has the same title as the original entry';
+
+ $copy = $entry->clone(parent => 1, relabel => 1);
+ is @{$kdbx->all_entries}, 3, 'New copy added to database if clone with parent option';
+ is $kdbx->all_entries->[2], $copy, 'New copy and new entry in the database match';
+ is $kdbx->all_entries->[2]->title, "foo - Copy", 'New copy has a modified title';
+
+ $copy = $group->clone;
+ cmp_deeply $copy, $group, 'Group and its clone are identical';
+ is @{$copy->entries}, 3, 'Group copy has as many entries as the original';
+ is @{$copy->entries->[0]->history}, 1, 'Entry in group copy has history';
+
+ $copy = $group->clone(history => 0);
+ is @{$copy->entries}, 3, 'Group copy without history has as many entries as the original';
+ is @{$copy->entries->[0]->history}, 0, 'Entry in group copy has no history';
+
+ $copy = $group->clone(entries => 0);
+ is @{$copy->entries}, 0, 'Group copy without entries has no entries';
+ is $copy->name, 'Passwords', 'Group copy label is the same as the original';
+
+ $copy = $group->clone(relabel => 1);
+ is $copy->name, 'Passwords - Copy', 'Group copy relabeled from the original title';
+ is @{$kdbx->all_entries}, 3, 'No new entries were added to the database';
+
+ $copy = $group->clone(relabel => 1, parent => 1);
+ is @{$kdbx->all_entries}, 6, 'Copy a group within parent doubles the number of entries in the database';
+ isnt $group->entries->[0]->uuid, $copy->entries->[0]->uuid,
+ 'First entry in group and its copy are different';
+};
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use File::KDBX::Entry;
+use Test::More;
+
+eval { require Pass::OTP } or plan skip_all => 'Pass::OTP required to test one-time-passwords';
+
+my $secret_txt = 'hello';
+my $secret_b32 = 'NBSWY3DP';
+my $secret_b64 = 'aGVsbG8=';
+my $secret_hex = '68656c6c6f';
+my $when = 1655488780;
+
+for my $test (
+ {
+ name => 'HOTP - Basic',
+ input => {otp => "otpauth://hotp/Issuer:user?secret=${secret_b32}&issuer=Issuer"},
+ codes => [qw(029578 825147 676217)],
+ uri => 'otpauth://hotp/Issuer:user?secret=NBSWY3DP&issuer=Issuer',
+ },
+ {
+ name => 'HOTP - Start from 42',
+ input => {
+ otp => "otpauth://hotp/Issuer:user?secret=${secret_b32}&issuer=Issuer",
+ 'HmacOtp-Counter' => 42,
+ },
+ codes => [qw(528783 171971 115730)],
+ uri => 'otpauth://hotp/Issuer:user?secret=NBSWY3DP&issuer=Issuer&counter=42',
+ },
+ {
+ name => 'HOTP - 7 digits',
+ input => {otp => "otpauth://hotp/Issuer:user?secret=${secret_b32}&issuer=Issuer&digits=7"},
+ codes => [qw(3029578 9825147 9676217)],
+ uri => 'otpauth://hotp/Issuer:user?secret=NBSWY3DP&issuer=Issuer&digits=7',
+ },
+ {
+ name => 'HOTP - KeePass 2 storage (Base32)',
+ input => {'HmacOtp-Secret-Base32' => $secret_b32},
+ codes => [qw(029578 825147 676217)],
+ uri => 'otpauth://hotp/KDBX:none?secret=NBSWY3DP&issuer=KDBX',
+ },
+ {
+ name => 'HOTP - KeePass 2 storage (Base64)',
+ input => {'HmacOtp-Secret-Base64' => $secret_b64},
+ codes => [qw(029578 825147 676217)],
+ uri => 'otpauth://hotp/KDBX:none?secret=NBSWY3DP&issuer=KDBX',
+ },
+ {
+ name => 'HOTP - KeePass 2 storage (Hex)',
+ input => {'HmacOtp-Secret-Hex' => $secret_hex},
+ codes => [qw(029578 825147 676217)],
+ uri => 'otpauth://hotp/KDBX:none?secret=NBSWY3DP&issuer=KDBX',
+ },
+ {
+ name => 'HOTP - KeePass 2 storage (Text)',
+ input => {'HmacOtp-Secret' => $secret_txt},
+ codes => [qw(029578 825147 676217)],
+ uri => 'otpauth://hotp/KDBX:none?secret=NBSWY3DP&issuer=KDBX',
+ },
+ {
+ name => 'HOTP - KeePass 2, start from 42',
+ input => {'HmacOtp-Secret' => $secret_txt, 'HmacOtp-Counter' => 42},
+ codes => [qw(528783 171971 115730)],
+ uri => 'otpauth://hotp/KDBX:none?secret=NBSWY3DP&issuer=KDBX&counter=42',
+ },
+ {
+ name => 'HOTP - Non-default attributes',
+ input => {'HmacOtp-Secret' => $secret_txt, Title => 'Website', UserName => 'foo!?'},
+ codes => [qw(029578 825147 676217)],
+ uri => 'otpauth://hotp/Website:foo%21%3F?secret=NBSWY3DP&issuer=Website',
+ },
+) {
+ my $entry = File::KDBX::Entry->new;
+ $entry->string($_ => $test->{input}{$_}) for keys %{$test->{input}};
+ is $entry->hmac_otp_uri, $test->{uri}, "$test->{name}: Valid URI";
+ for my $code (@{$test->{codes}}) {
+ my $counter = $entry->string_value('HmacOtp-Counter') || 'undef';
+ is $entry->hmac_otp, $code, "$test->{name}: Valid OTP ($counter)";
+ }
+}
+
+for my $test (
+ {
+ name => 'TOTP - Basic',
+ input => {otp => "otpauth://totp/Issuer:user?secret=${secret_b32}&period=30&digits=6&issuer=Issuer"},
+ code => '875357',
+ uri => 'otpauth://totp/Issuer:user?secret=NBSWY3DP&issuer=Issuer',
+ },
+ {
+ name => 'TOTP - SHA256',
+ input => {otp => "otpauth://totp/Issuer:user?secret=${secret_b32}&period=30&algorithm=SHA256"},
+ code => '630489',
+ uri => 'otpauth://totp/Issuer:user?secret=NBSWY3DP&issuer=Issuer&algorithm=SHA256',
+ },
+ {
+ name => 'TOTP - 60s period',
+ input => {otp => "otpauth://totp/Issuer:user?secret=${secret_b32}&period=60&digits=6&issuer=Issuer"},
+ code => '647601',
+ uri => 'otpauth://totp/Issuer:user?secret=NBSWY3DP&issuer=Issuer&period=60',
+ },
+ {
+ name => 'TOTP - 7 digits',
+ input => {otp => "otpauth://totp/Issuer:user?secret=${secret_b32}&period=30&digits=7&issuer=Issuer"},
+ code => '9875357',
+ uri => 'otpauth://totp/Issuer:user?secret=NBSWY3DP&issuer=Issuer&digits=7',
+ },
+ {
+ name => 'TOTP - Steam',
+ input => {otp => "otpauth://totp/Issuer:user?secret=${secret_b32}&issuer=Issuer&encoder=steam"},
+ code => '55YH2',
+ uri => 'otpauth://totp/Issuer:user?secret=NBSWY3DP&issuer=Issuer&encoder=steam',
+ },
+ {
+ name => 'TOTP - KeePass 2 storage',
+ input => {'TimeOtp-Secret-Base32' => $secret_b32},
+ code => '875357',
+ uri => 'otpauth://totp/KDBX:none?secret=NBSWY3DP&issuer=KDBX',
+ },
+ {
+ name => 'TOTP - KeePass 2 storage, SHA256',
+ input => {'TimeOtp-Secret-Base32' => $secret_b32, 'TimeOtp-Algorithm' => 'HMAC-SHA-256'},
+ code => '630489',
+ uri => 'otpauth://totp/KDBX:none?secret=NBSWY3DP&issuer=KDBX&algorithm=SHA256',
+ },
+ {
+ name => 'TOTP - KeePass 2 storage, 60s period',
+ input => {'TimeOtp-Secret-Base32' => $secret_b32, 'TimeOtp-Period' => '60'},
+ code => '647601',
+ uri => 'otpauth://totp/KDBX:none?secret=NBSWY3DP&issuer=KDBX&period=60',
+ },
+ {
+ name => 'TOTP - KeePass 2 storage, 7 digits',
+ input => {'TimeOtp-Secret-Base32' => $secret_b32, 'TimeOtp-Length' => '7'},
+ code => '9875357',
+ uri => 'otpauth://totp/KDBX:none?secret=NBSWY3DP&issuer=KDBX&digits=7',
+ },
+ {
+ name => 'TOTP - Non-default attributes',
+ input => {'TimeOtp-Secret-Base32' => $secret_b32, Title => 'Website', UserName => 'foo!?'},
+ code => '875357',
+ uri => 'otpauth://totp/Website:foo%21%3F?secret=NBSWY3DP&issuer=Website',
+ },
+) {
+ my $entry = File::KDBX::Entry->new;
+ $entry->string($_ => $test->{input}{$_}) for keys %{$test->{input}};
+ is $entry->time_otp_uri, $test->{uri}, "$test->{name}: Valid URI";
+ is $entry->time_otp(now => $when), $test->{code}, "$test->{name}: Valid OTP";
+}
+
+{
+ my $entry = File::KDBX::Entry->new;
+ $entry->string('TimeOtp-Secret-Base32' => $secret_b32);
+ $entry->string('TimeOtp-Secret' => 'wat');
+ my $warning = warning { $entry->time_otp_uri };
+ like $warning, qr/Found multiple/, 'Alert if redundant secrets'
+ or diag 'Warnings: ', explain $warning;
+}
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use File::KDBX::Entry;
+use File::KDBX;
+use Test::More;
+
+my $kdbx = File::KDBX->new;
+
+my $entry1 = $kdbx->add_entry(
+ title => 'Foo',
+ username => 'User {TITLE}',
+);
+my $entry2 = $kdbx->add_entry(
+ title => 'Bar',
+ username => sprintf('{REF:U@I:%s}', $entry1->id),
+ notes => 'notes {URL}',
+ url => 'url {NOTES}',
+);
+my $entry3 = $kdbx->add_entry(
+ username => sprintf('{REF:U@I:%s}', $entry2->id),
+ password => 'lyric:%LYRIC%',
+ notes => '%MISSING% %% %NOT AVAR% %LYRIC%',
+);
+
+is $entry1->expanded_username, 'User Foo', 'Basic placeholder expansion';
+is $entry2->expanded_username, 'User Foo', 'Reference to another entry';
+is $entry3->expanded_username, 'User Foo', 'Reference to another entry through another';
+
+my $recursive_expected = 'url notes ' x 10 . 'url {NOTES}';
+my $recursive;
+my $warning = warning { $recursive = $entry2->expanded_url };
+like $warning, qr/detected deep recursion/i, 'Deep recursion causes a warning'
+ or diag 'Warnings: ', explain $warning;
+is $recursive, $recursive_expected, 'Recursive placeholders resolve to... something';
+
+{
+ my $entry = File::KDBX::Entry->new(url => 'http://example.com?{EXPLODE}');
+ is $entry->expanded_url, 'http://example.com?{EXPLODE}',
+ 'Unhandled placeholders are not replaced';
+
+ local $File::KDBX::PLACEHOLDERS{EXPLODE} = sub { 'boom' };
+ is $entry->expanded_url, 'http://example.com?boom', 'Custom placeholders can be set';
+
+ $entry->url('{eXplOde}!!');
+ is $entry->expanded_url, 'boom!!', 'Placeholder tags are match case-insensitively';
+}
+
+{
+ local $ENV{LYRIC} = 'I am the very model of a modern Major-General';
+ is $entry3->expanded_password, "lyric:$ENV{LYRIC}", 'Environment variable placeholders';
+ is $entry3->expanded_notes, qq{%MISSING% %% %NOT AVAR% $ENV{LYRIC}},
+ 'Do not replace things that look like environment variables but are not';
+}
+
+{
+ my $counter = 0;
+ local $File::KDBX::PLACEHOLDERS{'COUNTER'} = $File::KDBX::PLACEHOLDERS{'COUNTER:'} = sub {
+ (undef, my $arg) = @_;
+ return defined $arg ? $arg : ++$counter;
+ };
+ my $entry4 = $kdbx->add_entry(
+ url => '{COUNTER} {USERNAME}',
+ username => '{COUNTER}x{COUNTER}y{COUNTER:-1}',
+ );
+ like $entry4->expanded_username, qr/^1x1y-1$/,
+ 'Each unique placeholder is evaluated once';
+ like $entry4->expanded_url, qr/^2 3x3y-1$/,
+ 'Each unique placeholder is evaluated once per string';
+}
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use File::KDBX::Util qw(query search simple_expression_query);
+use Test::Deep;
+use Test::More;
+
+my $list = [
+ {
+ id => 1,
+ name => 'Bob',
+ age => 34,
+ married => 1,
+ notes => 'Enjoys bowling on Thursdays',
+ },
+ {
+ id => 2,
+ name => 'Ken',
+ age => 17,
+ married => 0,
+ notes => 'Eats dessert first',
+ color => '',
+ },
+ {
+ id => 3,
+ name => 'Becky',
+ age => 25,
+ married => 1,
+ notes => 'Listens to rap music on repeat',
+ color => 'orange',
+ },
+ {
+ id => 4,
+ name => 'Bobby',
+ age => 5,
+ notes => 'Loves candy and running around like a crazy person',
+ color => 'blue',
+ },
+];
+
+subtest 'Declarative structure' => sub {
+ my $result = search($list, name => 'Bob');
+ cmp_deeply $result, [shallow($list->[0])], 'Find Bob'
+ or diag explain $result;
+
+ $result = search($list, name => 'Ken');
+ cmp_deeply $result, [$list->[1]], 'Find Ken'
+ or diag explain $result;
+
+ $result = search($list, age => 25);
+ cmp_deeply $result, [$list->[2]], 'Find Becky by age'
+ or diag explain $result;
+
+ $result = search($list, {name => 'Becky', age => 25});
+ cmp_deeply $result, [$list->[2]], 'Find Becky by name AND age'
+ or diag explain $result;
+
+ $result = search($list, {name => 'Becky', age => 99});
+ cmp_deeply $result, [], 'Miss Becky with wrong age'
+ or diag explain $result;
+
+ $result = search($list, [name => 'Becky', age => 17]);
+ cmp_deeply $result, [$list->[1], $list->[2]], 'Find Ken and Becky with different criteria'
+ or diag explain $result;
+
+ $result = search($list, name => 'Becky', age => 17);
+ cmp_deeply $result, [$list->[1], $list->[2]], 'Query list defaults to OR logic'
+ or diag explain $result;
+
+ $result = search($list, age => {'>=', 18});
+ cmp_deeply $result, [$list->[0], $list->[2]], 'Find adults'
+ or diag explain $result;
+
+ $result = search($list, name => {'=~', qr/^Bob/});
+ cmp_deeply $result, [$list->[0], $list->[3]], 'Find both Bobs'
+ or diag explain $result;
+
+ $result = search($list, -and => [name => 'Becky', age => 99]);
+ cmp_deeply $result, [], 'Specify AND logic explicitly'
+ or diag explain $result;
+
+ $result = search($list, {name => 'Becky', age => 99});
+ cmp_deeply $result, [], 'Specify AND logic implicitly'
+ or diag explain $result;
+
+ $result = search($list, '!' => 'married');
+ cmp_deeply $result, [$list->[1], $list->[3]], 'Find unmarried (using normal operator)'
+ or diag explain $result;
+
+ $result = search($list, -false => 'married');
+ cmp_deeply $result, [$list->[1], $list->[3]], 'Find unmarried (using special operator)'
+ or diag explain $result;
+
+ $result = search($list, -true => 'married');
+ cmp_deeply $result, [$list->[0], $list->[2]], 'Find married persons (using special operator)'
+ or diag explain $result;
+
+ $result = search($list, -not => {name => {'=~', qr/^Bob/}});
+ cmp_deeply $result, [$list->[1], $list->[2]], 'What about Bob? Inverse a complex query'
+ or diag explain $result;
+
+ $result = search($list, -nonempty => 'color');
+ cmp_deeply $result, [$list->[2], $list->[3]], 'Find the colorful'
+ or diag explain $result;
+
+ $result = search($list, color => {ne => undef});
+ cmp_deeply $result, [$list->[2], $list->[3]], 'Find the colorful (compare to undef)'
+ or diag explain $result;
+
+ $result = search($list, -empty => 'color');
+ cmp_deeply $result, [$list->[0], $list->[1]], 'Find those without color'
+ or diag explain $result;
+
+ $result = search($list, color => {eq => undef});
+ cmp_deeply $result, [$list->[0], $list->[1]], 'Find those without color (compare to undef)'
+ or diag explain $result;
+
+ $result = search($list, -defined => 'color');
+ cmp_deeply $result, [$list->[1], $list->[2], $list->[3]], 'Find defined colors'
+ or diag explain $result;
+
+ $result = search($list, -undef => 'color');
+ cmp_deeply $result, [$list->[0]], 'Find undefined colors'
+ or diag explain $result;
+
+ $result = search($list,
+ -and => [
+ name => {'=~', qr/^Bob/},
+ -and => {
+ name => {'ne', 'Bob'},
+ },
+ ],
+ -not => {'!' => 'Bobby'},
+ );
+ cmp_deeply $result, [$list->[3]], 'Complex query'
+ or diag explain $result;
+
+ my $query = query(name => 'Ken');
+ $result = search($list, $query);
+ cmp_deeply $result, [$list->[1]], 'Search using a pre-compiled query'
+ or diag explain $result;
+
+ my $custom_query = sub { shift->{name} eq 'Bobby' };
+ $result = search($list, $custom_query);
+ cmp_deeply $result, [$list->[3]], 'Search using a custom query subroutine'
+ or diag explain $result;
+};
+
+##############################################################################
+
+subtest 'Simple expressions' => sub {
+ my $simple_query = simple_expression_query('bob', qw{name notes});
+ my $result = search($list, $simple_query);
+ cmp_deeply $result, [$list->[0], $list->[3]], 'Basic one-term expression'
+ or diag explain $result;
+
+ $result = search($list, \'bob', qw{name notes});
+ cmp_deeply $result, [$list->[0], $list->[3]], 'Basic one-term expression on search'
+ or diag explain $result;
+
+ $simple_query = simple_expression_query(' Dessert ', qw{notes});
+ $result = search($list, $simple_query);
+ cmp_deeply $result, [$list->[1]], 'Whitespace is ignored'
+ or diag explain $result;
+
+ $simple_query = simple_expression_query('to music', qw{notes});
+ $result = search($list, $simple_query);
+ cmp_deeply $result, [$list->[2]], 'Multiple terms'
+ or diag explain $result;
+
+ $simple_query = simple_expression_query('"to music"', qw{notes});
+ $result = search($list, $simple_query);
+ cmp_deeply $result, [], 'One quoted term'
+ or diag explain $result;
+
+ $simple_query = simple_expression_query('candy "CRAZY PERSON" ', qw{notes});
+ $result = search($list, $simple_query);
+ cmp_deeply $result, [$list->[3]], 'Multiple terms, one quoted term'
+ or diag explain $result;
+
+ $simple_query = simple_expression_query(" bob\tcandy\n\n", qw{name notes});
+ $result = search($list, $simple_query);
+ cmp_deeply $result, [$list->[3]], 'Multiple terms in different fields'
+ or diag explain $result;
+
+ $simple_query = simple_expression_query('music -repeat', qw{notes});
+ $result = search($list, $simple_query);
+ cmp_deeply $result, [], 'Multiple terms, one negative term'
+ or diag explain $result;
+
+ $simple_query = simple_expression_query('-bob', qw{name});
+ $result = search($list, $simple_query);
+ cmp_deeply $result, [$list->[1], $list->[2]], 'Negative term'
+ or diag explain $result;
+
+ $simple_query = simple_expression_query('bob -bobby', qw{name});
+ $result = search($list, $simple_query);
+ cmp_deeply $result, [$list->[0]], 'Multiple mixed terms'
+ or diag explain $result;
+
+ $simple_query = simple_expression_query(25, '==', qw{age});
+ $result = search($list, $simple_query);
+ cmp_deeply $result, [$list->[2]], 'Custom operator'
+ or diag explain $result;
+
+ $simple_query = simple_expression_query('-25', '==', qw{age});
+ $result = search($list, $simple_query);
+ cmp_deeply $result, [$list->[0], $list->[1], $list->[3]], 'Negative term, custom operator'
+ or diag explain $result;
+};
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use File::KDBX;
+use Test::More;
+
+my $kdbx = File::KDBX->new;
+my $entry1 = $kdbx->add_entry(
+ title => 'Sun Valley Bank Inc.',
+ username => 'fred',
+ password => 'secr3t',
+);
+my $entry2 = $kdbx->add_entry(
+ title => 'Donut Shoppe',
+ username => 'freddy',
+ password => '1234',
+ testcustom => 'a custom string',
+);
+my $entry3 = $kdbx->add_entry(
+ title => 'Sun Clinic Inc.',
+ username => 'jerry',
+ password => 'password',
+ mycustom => 'this is another custom string',
+);
+
+for my $test (
+ ['{REF:U@T:donut}', 'freddy'],
+ ['U@T:donut', 'freddy'],
+ [[U => T => 'donut'], 'freddy', 'A reference can be pre-parsed parameters'],
+
+ ['{REF:U@T:sun inc}', 'fred'],
+ ['{REF:U@T:"Sun Clinic Inc."}', 'jerry'],
+
+ ['{REF:U@I:' . $entry2->id . '}', 'freddy', 'Resolve a field by UUID'],
+
+ ['{REF:U@O:custom}', 'freddy'],
+ ['{REF:U@O:"another custom"}', 'jerry'],
+
+ ['{REF:U@T:donut meh}', undef],
+ ['{REF:O@U:freddy}', undef],
+) {
+ my ($ref, $expected, $note) = @$test;
+ $note //= "Reference: $ref";
+ is $kdbx->resolve_reference(ref $ref eq 'ARRAY' ? @$ref : $ref), $expected, $note;
+}
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use utf8;
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use Test::Deep;
+use Test::More;
+
+BEGIN { use_ok 'File::KDBX::Safe' }
+
+my $secret = 'secret';
+
+my @strings = (
+ {
+ value => 'classified',
+ },
+ {
+ value => 'bar',
+ meh => 'ignored',
+ },
+ {
+ value => '你好',
+ },
+);
+
+my $safe = File::KDBX::Safe->new([@strings, \$secret]);
+cmp_deeply \@strings, [
+ {
+ value => undef,
+ },
+ {
+ value => undef,
+ meh => 'ignored',
+ },
+ {
+ value => undef,
+ },
+], 'Encrypt strings in a safe' or diag explain \@strings;
+is $secret, undef, 'Scalar was set to undef';
+
+my $val = $safe->peek($strings[1]);
+is $val, 'bar', 'Peek at a string';
+
+$safe->unlock;
+cmp_deeply \@strings, [
+ {
+ value => 'classified',
+ },
+ {
+ value => 'bar',
+ meh => 'ignored',
+ },
+ {
+ value => '你好',
+ },
+], 'Decrypt strings in a safe' or diag explain \@strings;
+is $secret, 'secret', 'Scalar was set back to secret';
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+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
+ dumper
+ empty
+ erase
+ erase_scoped
+ format_uuid
+ generate_uuid
+ gunzip
+ gzip
+ load_optional
+ nonempty
+ pad_pkcs7
+ query
+ search
+ simple_expression_query
+ snakify
+ split_url
+ trim
+ uri_escape_utf8
+ uri_unescape_utf8
+ uuid
+});
+
+subtest 'Emptiness' => sub {
+ my @empty;
+ my @nonempty = 0;
+ ok empty(@empty), 'Empty array should be empty';
+ ok !nonempty(@empty), 'Empty array should be !nonempty';
+ ok !empty(@nonempty), 'Array should be !empty';
+ ok nonempty(@nonempty), 'Array should be nonempty';
+
+ my %empty;
+ my %nonempty = (a => 'b');
+ ok empty(%empty), 'Empty hash should be empty';
+ ok !nonempty(%empty), 'Empty hash should be !nonempty';
+ ok !empty(%nonempty), 'Hash should be !empty';
+ ok nonempty(%nonempty), 'Hash should be nonempty';
+
+ my $empty = '';
+ my $nonempty = '0';
+ my $eref1 = \$empty;
+ my $eref2 = \$eref1;
+ my $nref1 = \$nonempty;
+ my $nref2 = \$nref1;
+
+ for my $test (
+ [0, $empty, 'Empty string'],
+ [0, undef, 'Undef'],
+ [0, \undef, 'Reference to undef'],
+ [0, {}, 'Empty hashref'],
+ [0, [], 'Empty arrayref'],
+ [0, $eref1, 'Reference to empty string'],
+ [0, $eref2, 'Reference to reference to empty string'],
+ [0, \\\\\\\'', 'Deep reference to empty string'],
+ [1, $nonempty, 'String'],
+ [1, 'hi', 'String'],
+ [1, 1, 'Number'],
+ [1, 0, 'Zero'],
+ [1, {a => 'b'}, 'Hashref'],
+ [1, [0], 'Arrayref'],
+ [1, $nref1, 'Reference to string'],
+ [1, $nref2, 'Reference to reference to string'],
+ [1, \\\\\\\'z', 'Deep reference to string'],
+ ) {
+ my ($expected, $thing, $note) = @$test;
+ if ($expected) {
+ ok !empty($thing), "$note should be !empty";
+ ok nonempty($thing), "$note should be nonempty";
+ }
+ else {
+ ok empty($thing), "$note should be empty";
+ ok !nonempty($thing), "$note should be !nonempty";
+ }
+ }
+};
+
+subtest 'UUIDs' => sub {
+ my $uuid = "\x01\x23\x45\x67\x89\xab\xcd\xef\x01\x23\x45\x67\x89\xab\xcd\xef";
+ my $uuid1 = uuid('01234567-89AB-CDEF-0123-456789ABCDEF');
+ my $uuid2 = uuid('0123456789ABCDEF0123456789ABCDEF');
+ my $uuid3 = uuid('012-3-4-56-789AB-CDEF---012-34567-89ABC-DEF');
+
+ is $uuid1, $uuid, 'Formatted UUID is packed';
+ is $uuid2, $uuid, 'Formatted UUID does not need dashes';
+ is $uuid2, $uuid, 'Formatted UUID can have weird dashes';
+
+ is format_uuid($uuid), '0123456789ABCDEF0123456789ABCDEF', 'UUID unpacks to hex string';
+ is format_uuid($uuid, '-'), '01234567-89AB-CDEF-0123-456789ABCDEF', 'Formatted UUID can be delimited';
+
+ my %uuid_set = ($uuid => 'whatever');
+
+ my $new_uuid = generate_uuid(\%uuid_set);
+ isnt $new_uuid, $uuid, 'Generated UUID is not in set';
+
+ $new_uuid = generate_uuid(sub { !$uuid_set{$_} });
+ isnt $new_uuid, $uuid, 'Generated UUID passes a test function';
+
+ like generate_uuid(print => 1), qr/^[A-Za-z0-9]+$/, 'Printable UUID is printable (1)';
+ like generate_uuid(printable => 1), qr/^[A-Za-z0-9]+$/, 'Printable UUID is printable (2)';
+};
+
+subtest 'Snakification' => sub {
+ is snakify('FooBar'), 'foo_bar', 'Basic snakification';
+ is snakify('MyUUIDSet'), 'my_uuid_set', 'Acronym snakification';
+ is snakify('Numbers123'), 'numbers_123', 'Snake case with numbers';
+ is snakify('456Baz'), '456_baz', 'Prefixed numbers';
+};
+
+subtest 'Padding' => sub {
+ plan tests => 8;
+
+ is pad_pkcs7('foo', 2), "foo\x01", 'Pad one byte to fill the second block';
+ is pad_pkcs7('foo', 4), "foo\x01", 'Pad one byte to fill one block';
+ is pad_pkcs7('foo', 8), "foo\x05\x05\x05\x05\x05", 'Pad to fill one block';
+ is pad_pkcs7('moof', 4), "moof\x04\x04\x04\x04", 'Add a whole block of padding';
+ is pad_pkcs7('', 3), "\x03\x03\x03", 'Pad an empty string';
+ like exception { pad_pkcs7(undef, 8) }, qr/must provide a string/i, 'String must be defined';
+ like exception { pad_pkcs7('bar') }, qr/must provide block size/i, 'Size must defined';
+ like exception { pad_pkcs7('bar', 0) }, qr/must provide block size/i, 'Size must be non-zero';
+};
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use Test::More;
+
+BEGIN { use_ok 'File::KDBX::Key::YubiKey' }
+
+local $ENV{YKCHALRESP} = testfile(qw{bin ykchalresp});
+local $ENV{YKINFO} = testfile(qw{bin ykinfo});
+
+{
+ my ($pre, $post);
+ my $key = File::KDBX::Key::YubiKey->new(
+ pre_challenge => sub { ++$pre },
+ post_challenge => sub { ++$post },
+ );
+ my $resp;
+ is exception { $resp = $key->challenge('foo') }, undef,
+ 'Do not throw during non-blocking response';
+ is $resp, "\xf0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0", 'Get a non-blocking challenge response';
+ is length($resp), 20, 'Response is the proper length';
+ is $pre, 1, 'The pre-challenge callback is called';
+ is $post, 1, 'The post-challenge callback is called';
+}
+
+{
+ my $key = File::KDBX::Key::YubiKey->new;
+ local $ENV{YKCHALRESP_MOCK} = 'error';
+ like exception { $key->challenge('foo') }, qr/Yubikey core error:/i,
+ 'Throw if challenge-response program errored out';
+}
+
+{
+ my $key = File::KDBX::Key::YubiKey->new;
+ local $ENV{YKCHALRESP_MOCK} = 'usberror';
+ like exception { $key->challenge('foo') }, qr/USB error:/i,
+ 'Throw if challenge-response program had a USB error';
+}
+
+{
+ my $key = File::KDBX::Key::YubiKey->new(timeout => 0, device => 3, slot => 2);
+ local $ENV{YKCHALRESP_MOCK} = 'block';
+
+ like exception { $key->challenge('foo') }, qr/operation would block/i,
+ 'Throw if challenge would block but we do not want to wait';
+
+ $key->timeout(1);
+ like exception { $key->challenge('foo') }, qr/timed out/i,
+ 'Timed out while waiting for response';
+
+ $key->timeout(-1);
+ my $resp;
+ is exception { $resp = $key->challenge('foo') }, undef,
+ 'Do not throw during blocking response';
+ is $resp, "\xf0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0", 'Get a blocking challenge response';
+}
+
+{
+ my $key = File::KDBX::Key::YubiKey->new(device => 0, slot => 1);
+ is $key->name, 'YubiKey NEO FIDO v2.0.0 [123] (slot #1)',
+ 'Get name for a new, unscanned key';
+ is $key->serial, 123, 'We have the serial number of the new key';
+}
+
+{
+ my ($key, @other) = File::KDBX::Key::YubiKey->scan;
+ is $key->name, 'YubiKey 4/5 OTP v3.0.1 [456] (slot #2)',
+ 'Find expected YubiKey';
+ is $key->serial, 456, 'We have the serial number of the scanned key';
+ is scalar @other, 0, 'Do not find any other YubiKeys';
+}
+
+{
+ local $ENV{YKCHALRESP} = testfile(qw{bin nonexistent});
+ my $key = File::KDBX::Key::YubiKey->new;
+ like exception { $key->challenge('foo') }, qr/failed to run|failed to receive challenge response/i,
+ 'Throw if the program failed to run';
+}
+
+done_testing;
projects / chaz / p5-File-KDBX / commitdiff
