File Coverage

blib/lib/File/KDBX.pm

Criterion	Covered	Total	%
statement	565	648	87.1
branch	225	398	56.5
condition	158	308	51.3
subroutine	140	157	89.1
pod	101	104	97.1
total	1189	1615	73.6

package File::KDBX;
# ABSTRACT: Encrypted database to store secret text and files

use 5.010;
use warnings;
use strict;

use Crypt::Digest qw(digest_data);
use Crypt::PRNG qw(random_bytes);
use Devel::GlobalDestruction;
use File::KDBX::Constants qw(:all :icon);
use File::KDBX::Error;
use File::KDBX::Safe;
use File::KDBX::Util qw(:class :coercion :empty :search :uuid erase simple_expression_query snakify);
use Hash::Util::FieldHash qw(fieldhashes);
use List::Util qw(any first);
use Ref::Util qw(is_ref is_arrayref is_plain_hashref);
use Scalar::Util qw(blessed);
use Time::Piece 1.33;
use boolean;
use namespace::clean;

our $VERSION = '0.906'; # VERSION
our $WARNINGS = 1;

fieldhashes \my (%SAFE, %KEYS);


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 $self = bless $data // {}, $class;
    $self->init(@_);
    $self->_set_nonlazy_attributes if !$data;
    return $self;
}

sub DESTROY { local ($., $@, $!, $^E, $?); !in_global_destruction and $_[0]->reset }


sub init {
    my $self = shift;
    my %args = @_;

    @$self{keys %args} = values %args;

    return $self;
}


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 = ();
    $self->_remove_safe;
    return $self;
}


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{$self} // (), $SAFE{$self} // ();
}

sub STORABLE_thaw {
    my $self    = shift;
    my $cloning = shift;
    shift;
    my $clone   = shift;
    my $key     = shift;
    my $safe    = shift;

    @$self{keys %$clone} = values %$clone;
    $KEYS{$self} = $key;
    $SAFE{$self} = $safe;

    # Dualvars aren't cloned as dualvars, so coerce the compression flags.
    $self->compression_flags($self->compression_flags);

    $self->objects(history => 1)->each(sub { $_->kdbx($self) });
}

##############################################################################


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);
}


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);
}

##############################################################################


sub user_agent_string {
    require Config;
    sprintf('%s/%s (%s/%s; %s/%s; %s)',
        __PACKAGE__, $VERSION, @Config::Config{qw(package version osname osvers archname)});
}

has sig1            => KDBX_SIG1,        coerce => \&to_number;
has sig2            => KDBX_SIG2_2,      coerce => \&to_number;
has version         => KDBX_VERSION_3_1, coerce => \&to_number;
has headers         => {};
has inner_headers   => {};
has meta            => {};
has binaries        => {};
has deleted_objects => {};
has raw             => coerce => \&to_string;

# HEADERS
has 'headers.comment'               => '',                          coerce => \&to_string;
has 'headers.cipher_id'             => sub { $_[0]->version < KDBX_VERSION_4_0 ? CIPHER_UUID_AES256 : CIPHER_UUID_CHACHA20 },
                                                                    coerce => \&to_uuid;
has 'headers.compression_flags'     => COMPRESSION_GZIP,            coerce => \&to_compression_constant;
has 'headers.master_seed'           => sub { random_bytes(32) },    coerce => \&to_string;
has 'headers.encryption_iv'         => sub { random_bytes($_[0]->version < KDBX_VERSION_4_0 ? 16 : 12) },
                                                                    coerce => \&to_string;
has 'headers.stream_start_bytes'    => sub { random_bytes(32) },    coerce => \&to_string;
has 'headers.kdf_parameters'        => sub {
    +{
        KDF_PARAM_UUID()        => KDF_UUID_AES,
        KDF_PARAM_AES_ROUNDS()  => $_[0]->headers->{+HEADER_TRANSFORM_ROUNDS} // KDF_DEFAULT_AES_ROUNDS,
        KDF_PARAM_AES_SEED()    => $_[0]->headers->{+HEADER_TRANSFORM_SEED} // random_bytes(32),
    };
};
# has 'headers.transform_seed'            => sub { random_bytes(32) };
# has 'headers.transform_rounds'          => 100_000;
# has 'headers.inner_random_stream_key'   => sub { random_bytes(32) }; # 64 ?
# has 'headers.inner_random_stream_id'    => STREAM_ID_CHACHA20;
# has 'headers.public_custom_data'        => {};

# META
has 'meta.generator'                        => '',                          coerce => \&to_string;
has 'meta.header_hash'                      => '',                          coerce => \&to_string;
has 'meta.database_name'                    => '',                          coerce => \&to_string;
has 'meta.database_name_changed'            => sub { gmtime },              coerce => \&to_time;
has 'meta.database_description'             => '',                          coerce => \&to_string;
has 'meta.database_description_changed'     => sub { gmtime },              coerce => \&to_time;
has 'meta.default_username'                 => '',                          coerce => \&to_string;
has 'meta.default_username_changed'         => sub { gmtime },              coerce => \&to_time;
has 'meta.maintenance_history_days'         => HISTORY_DEFAULT_MAX_AGE,     coerce => \&to_number;
has 'meta.color'                            => '',                          coerce => \&to_string;
has 'meta.master_key_changed'               => sub { gmtime },              coerce => \&to_time;
has 'meta.master_key_change_rec'            => -1,                          coerce => \&to_number;
has 'meta.master_key_change_force'          => -1,                          coerce => \&to_number;
# has 'meta.memory_protection'                => {};
has 'meta.custom_icons'                     => [];
has 'meta.recycle_bin_enabled'              => true,                        coerce => \&to_bool;
has 'meta.recycle_bin_uuid'                 => UUID_NULL,                   coerce => \&to_uuid;
has 'meta.recycle_bin_changed'              => sub { gmtime },              coerce => \&to_time;
has 'meta.entry_templates_group'            => UUID_NULL,                   coerce => \&to_uuid;
has 'meta.entry_templates_group_changed'    => sub { gmtime },              coerce => \&to_time;
has 'meta.last_selected_group'              => UUID_NULL,                   coerce => \&to_uuid;
has 'meta.last_top_visible_group'           => UUID_NULL,                   coerce => \&to_uuid;
has 'meta.history_max_items'                => HISTORY_DEFAULT_MAX_ITEMS,   coerce => \&to_number;
has 'meta.history_max_size'                 => HISTORY_DEFAULT_MAX_SIZE,    coerce => \&to_number;
has 'meta.settings_changed'                 => sub { gmtime },              coerce => \&to_time;
# has 'meta.binaries'                         => {};
# has 'meta.custom_data'                      => {};

has 'memory_protection.protect_title'       => false,   coerce => \&to_bool;
has 'memory_protection.protect_username'    => false,   coerce => \&to_bool;
has 'memory_protection.protect_password'    => true,    coerce => \&to_bool;
has 'memory_protection.protect_url'         => false,   coerce => \&to_bool;
has 'memory_protection.protect_notes'       => false,   coerce => \&to_bool;
# has 'memory_protection.auto_enable_visual_hiding'   => false;

my @ATTRS = (
    HEADER_TRANSFORM_SEED,
    HEADER_TRANSFORM_ROUNDS,
    HEADER_INNER_RANDOM_STREAM_KEY,
    HEADER_INNER_RANDOM_STREAM_ID,
    HEADER_PUBLIC_CUSTOM_DATA,
);
sub _set_nonlazy_attributes {
    my $self = shift;
    $self->$_ for list_attributes(ref $self), @ATTRS;
}


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};
}


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}
    } @{$self->custom_icons};

    return KDBX_VERSION_4_1 if $self->groups->next(sub {
        nonempty $_->previous_parent_group ||
        nonempty $_->tags ||
        (any { nonempty $_->{last_modification_time} } values %{$_->custom_data})
    });

    return KDBX_VERSION_4_1 if $self->entries(history => 1)->next(sub {
        nonempty $_->previous_parent_group ||
        (defined $_->quality_check && !$_->quality_check) ||
        (any { nonempty $_->{last_modification_time} } values %{$_->custom_data})
    });

    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 $self->objects->next(sub {
        nonempty $_->custom_data
    });

    return KDBX_VERSION_3_1;
}

##############################################################################


sub root {
    my $self = shift;
    if (@_) {
        $self->{root} = $self->_wrap_group(@_);
        $self->{root}->kdbx($self);
    }
    $self->{root} //= $self->_implicit_root;
    return $self->_wrap_group($self->{root});
}

# Called by File::KeePass::KDBX so that a File::KDBX an be treated as a File::KDBX::Group in that both types
# can have subgroups. File::KDBX already has a `groups' method that does something different from the
# File::KDBX::Groups `groups' method.
sub _kpx_groups {
    my $self = shift;
    return [] if !$self->{root};
    return $self->_has_implicit_root ? $self->root->groups : [$self->root];
}

sub _has_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) : (),
    );
}


sub trace_lineage {
    my $self    = shift;
    my $object  = shift;
    return $object->lineage(@_);
}

sub _trace_lineage {
    my $self    = shift;
    my $object  = shift;
    my @lineage = @_;

    push @lineage, $self->root if !@lineage;
    my $base = $lineage[-1] or return [];

    my $uuid = $object->uuid;
    return \@lineage if any { $_->uuid eq $uuid } @{$base->groups}, @{$base->entries};

    for my $subgroup (@{$base->groups}) {
        my $result = $self->_trace_lineage($object, @lineage, $subgroup);
        return $result if $result;
    }
}


sub recycle_bin {
    my $self = shift;
    if (my $group = shift) {
        $self->recycle_bin_uuid($group->uuid);
        return $group;
    }
    my $group;
    my $uuid = $self->recycle_bin_uuid;
    $group = $self->groups->grep(uuid => $uuid)->next if $uuid ne UUID_NULL;
    if (!$group && $self->recycle_bin_enabled) {
        $group = $self->add_group(
            name                => 'Recycle Bin',
            icon_id             => ICON_TRASHCAN_FULL,
            enable_auto_type    => false,
            enable_searching    => false,
        );
        $self->recycle_bin_uuid($group->uuid);
    }
    return $group;
}


sub entry_templates {
    my $self = shift;
    if (my $group = shift) {
        $self->entry_templates_group($group->uuid);
        return $group;
    }
    my $uuid = $self->entry_templates_group;
    return if $uuid eq UUID_NULL;
    return $self->groups->grep(uuid => $uuid)->next;
}


sub last_selected {
    my $self = shift;
    if (my $group = shift) {
        $self->last_selected_group($group->uuid);
        return $group;
    }
    my $uuid = $self->last_selected_group;
    return if $uuid eq UUID_NULL;
    return $self->groups->grep(uuid => $uuid)->next;
}


sub last_top_visible {
    my $self = shift;
    if (my $group = shift) {
        $self->last_top_visible_group($group->uuid);
        return $group;
    }
    my $uuid = $self->last_top_visible_group;
    return if $uuid eq UUID_NULL;
    return $self->groups->grep(uuid => $uuid)->next;
}

##############################################################################


sub add_group {
    my $self    = shift;
    my $group   = @_ % 2 == 1 ? shift : undef;
    my %args    = @_;

    # find the right group to add the group to
    my $parent = delete $args{group} // $self->root;
    $parent = $self->groups->grep({uuid => $parent})->next if !ref $parent;
    $parent or throw 'Invalid group';

    return $parent->add_group(defined $group ? $group : (), %args, kdbx => $self);
}

sub _wrap_group {
    my $self  = shift;
    my $group = shift;
    require File::KDBX::Group;
    return File::KDBX::Group->wrap($group, $self);
}


sub groups {
    my $self = shift;
    my %args = @_ % 2 == 0 ? @_ : (base => shift, @_);
    my $base = delete $args{base} // $self->root;

    return $base->all_groups(%args);
}

##############################################################################


sub add_entry {
    my $self    = shift;
    my $entry   = @_ % 2 == 1 ? shift : undef;
    my %args    = @_;

    # find the right group to add the entry to
    my $parent = delete $args{group} // $self->root;
    $parent = $self->groups->grep({uuid => $parent})->next if !ref $parent;
    $parent or throw 'Invalid group';

    return $parent->add_entry(defined $entry ? $entry : (), %args, kdbx => $self);
}

sub _wrap_entry {
    my $self  = shift;
    my $entry = shift;
    require File::KDBX::Entry;
    return File::KDBX::Entry->wrap($entry, $self);
}


sub entries {
    my $self = shift;
    my %args = @_ % 2 == 0 ? @_ : (base => shift, @_);
    my $base = delete $args{base} // $self->root;

    return $base->all_entries(%args);
}

##############################################################################


sub objects {
    my $self = shift;
    my %args = @_ % 2 == 0 ? @_ : (base => shift, @_);
    my $base = delete $args{base} // $self->root;

    return $base->all_objects(%args);
}

sub __iter__ { $_[0]->objects }

##############################################################################


sub custom_icon {
    my $self = shift;
    my %args = @_     == 2 ? (uuid => shift, data => shift)
             : @_ % 2 == 1 ? (uuid => shift, @_) : @_;

    if (!$args{uuid} && !$args{data}) {
        my %standard = (uuid => 1, data => 1, name => 1, last_modification_time => 1);
        my @other_keys = grep { !$standard{$_} } keys %args;
        if (@other_keys == 1) {
            my $key = $args{key} = $other_keys[0];
            $args{data} = delete $args{$key};
        }
    }

    my $uuid = $args{uuid} or throw 'Must provide a custom icon UUID to access';
    my $icon = (first { $_->{uuid} eq $uuid } @{$self->custom_icons}) // do {
        push @{$self->custom_icons}, my $i = { uuid => $uuid };
        $i;
    };

    my $fields = \%args;
    $fields = $args{data} if is_plain_hashref($args{data});

    while (my ($field, $value) = each %$fields) {
        $icon->{$field} = $value;
    }
    return $icon;
}


sub custom_icon_data {
    my $self = shift;
    my $uuid = shift // return;
    my $icon = first { $_->{uuid} eq $uuid } @{$self->custom_icons} or return;
    return $icon->{data};
}


sub add_custom_icon {
    my $self = shift;
    my %args = @_ % 2 == 1 ? (data => shift, @_) : @_;

    defined $args{data} or throw 'Must provide image data';

    my $uuid = $args{uuid} // generate_uuid;
    push @{$self->custom_icons}, {
        @_,
        uuid    => $uuid,
        data    => $args{data},
    };
    return $uuid;
}


sub remove_custom_icon {
    my $self = shift;
    my $uuid = shift;
    my @deleted;
    @{$self->custom_icons} = grep { $_->{uuid} eq $uuid ? do { push @deleted, $_; 0 } : 1 }
        @{$self->custom_icons};
    $self->add_deleted_object($uuid) if @deleted;
    return @deleted;
}

##############################################################################


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};
}


sub custom_data_value {
    my $self = shift;
    my $data = $self->custom_data(@_) // return;
    return $data->{value};
}


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';
# }


sub add_deleted_object {
    my $self = shift;
    my $uuid = shift;

    # ignore null and meta stream UUIDs
    return if $uuid eq UUID_NULL || $uuid eq '0' x 16;

    $self->deleted_objects->{$uuid} = {
        uuid            => $uuid,
        deletion_time   => scalar gmtime,
    };
}


sub remove_deleted_object {
    my $self = shift;
    my $uuid = shift;
    delete $self->deleted_objects->{$uuid};
}


sub clear_deleted_objects {
    my $self = shift;
    %{$self->deleted_objects} = ();
}

##############################################################################


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   => 'expand_title',
        U   => 'expand_username',
        P   => 'expand_password',
        A   => 'expand_url',
        N   => 'expand_notes',
        I   => 'uuid',
        O   => 'other_strings',
    );
    $wanted     = $fields{$wanted} or return;
    $search_in  = $fields{$search_in} or return;

    my $query = $search_in eq 'uuid' ? query($search_in => uuid($text))
                                     : simple_expression_query($text, '=~', $search_in);

    my $entry = $self->entries->grep($query)->next;
    $entry or return;

    return $entry->$wanted;
}

our %PLACEHOLDERS = (
    # 'PLACEHOLDER'       => sub { my ($entry, $arg) = @_; ... };
    'TITLE'             => sub { $_[0]->expand_title },
    'USERNAME'          => sub { $_[0]->expand_username },
    'PASSWORD'          => sub { $_[0]->expand_password },
    'NOTES'             => sub { $_[0]->expand_notes },
    'S:'                => sub { $_[0]->string_value($_[1]) },
    'URL'               => sub { $_[0]->expand_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('IPC::Cmd'); IPC::Cmd::can_run('iexplore') },
    'FIREFOX'           => sub { load_optional('IPC::Cmd'); IPC::Cmd::can_run('firefox') },
    'GOOGLECHROME'      => sub { load_optional('IPC::Cmd'); IPC::Cmd::can_run('google-chrome') },
    'OPERA'             => sub { load_optional('IPC::Cmd'); IPC::Cmd::can_run('opera') },
    'SAFARI'            => sub { load_optional('IPC::Cmd'); IPC::Cmd::can_run('safari') },
    'APPDIR'            => sub { load_optional('FindBin'); $FindBin::Bin },
    'GROUP'             => sub { my $p = $_[0]->group; $p ? $p->name : undef },
    'GROUP_PATH'        => sub { $_[0]->path },
    'GROUP_NOTES'       => sub { my $p = $_[0]->group; $p ? $p->notes : undef },
    # '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:'
);

##############################################################################


sub _safe {
    my $self = shift;
    $SAFE{$self} = shift if @_;
    $SAFE{$self};
}

sub _remove_safe { delete $SAFE{$_[0]} }

sub lock {
    my $self = shift;

    # Find things to lock:
    my @strings;
    $self->entries(history => 1)->each(sub {
        my $strings = $_->strings;
        for my $string_key (keys %$strings) {
            my $string = $strings->{$string_key};
            push @strings, $string if $string->{protect} // $self->memory_protection($string_key);
        }
        push @strings, grep { $_->{protect} } values %{$_->binaries};
    });
    return $self if !@strings;  # nothing to do

    if (my $safe = $self->_safe) {
        $safe->add(\@strings);
    }
    else {
        $self->_safe(File::KDBX::Safe->new(\@strings));
    }
    return $self;
}


sub unlock {
    my $self = shift;
    my $safe = $self->_safe or return $self;

    $safe->unlock;
    $self->_remove_safe;

    return $self;
}


sub unlock_scoped {
    throw 'Programmer error: Cannot call unlock_scoped in void context' if !defined wantarray;
    my $self = shift;
    return if !$self->is_locked;
    require Scope::Guard;
    my $guard = Scope::Guard->new(sub { $self->lock });
    $self->unlock;
    return $guard;
}


sub peek {
    my $self = shift;
    my $string = shift;
    my $safe = $self->_safe or return;
    return $safe->peek($string);
}


sub is_locked { !!$_[0]->_safe }

##############################################################################

# 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)
#   - Header UUIDs match known ciphers/KDFs?
# }


sub remove_empty_groups {
    my $self = shift;
    my @removed;
    $self->groups(algorithm => 'dfs')
    ->where(-true => 'is_empty')
    ->each(sub { push @removed, $_->remove });
    return @removed;
}


sub remove_unused_icons {
    my $self = shift;
    my %icons = map { $_->{uuid} => 0 } @{$self->custom_icons};

    $self->objects->each(sub { ++$icons{$_->custom_icon_uuid // ''} });

    my @removed;
    push @removed, $self->remove_custom_icon($_) for grep { $icons{$_} == 0 } keys %icons;
    return @removed;
}


sub remove_duplicate_icons {
    my $self = shift;

    my %seen;
    my %dup;
    for my $icon (@{$self->custom_icons}) {
        my $digest = digest_data('SHA256', $icon->{data});
        if (my $other = $seen{$digest}) {
            $dup{$icon->{uuid}} = $other->{uuid};
        }
        else {
            $seen{$digest} = $icon;
        }
    }

    my @removed;
    while (my ($old_uuid, $new_uuid) = each %dup) {
        $self->objects
        ->where(custom_icon_uuid => $old_uuid)
        ->each(sub { $_->custom_icon_uuid($new_uuid) });
        push @removed, $self->remove_custom_icon($old_uuid);
    }
    return @removed;
}


sub prune_history {
    my $self = shift;
    my %args = @_;

    my $max_items = $args{max_items} // $self->history_max_items // HISTORY_DEFAULT_MAX_ITEMS;
    my $max_size  = $args{max_size}  // $self->history_max_size  // HISTORY_DEFAULT_MAX_SIZE;
    my $max_age   = $args{max_age}   // $self->maintenance_history_days // HISTORY_DEFAULT_MAX_AGE;

    my @removed;
    $self->entries->each(sub {
        push @removed, $_->prune_history(
            max_items   => $max_items,
            max_size    => $max_size,
            max_age     => $max_age,
        );
    });
    return @removed;
}


sub randomize_seeds {
    my $self = shift;
    my $iv_size = 16;
    $iv_size = $self->cipher(key => "\0" x 32)->iv_size if KDBX_VERSION_4_0 <= $self->version;
    $self->encryption_iv(random_bytes($iv_size));
    $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));
}

##############################################################################


sub key {
    my $self = shift;
    $KEYS{$self} = File::KDBX::Key->new(@_) if @_;
    $KEYS{$self};
}


sub composite_key {
    my $self = shift;
    require File::KDBX::Key::Composite;
    return File::KDBX::Key::Composite->new(@_);
}


sub kdf {
    my $self = shift;
    my %args = @_ % 2 == 1 ? (params => shift, @_) : @_;

    my $params = $args{params};

    $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;
    my $param = KDF_PARAM_AES_SEED;     # Short cut: Argon2 uses the same parameter name ("S")
    $self->headers->{+HEADER_TRANSFORM_SEED} =
        $self->headers->{+HEADER_KDF_PARAMETERS}{$param} = shift if @_;
    $self->headers->{+HEADER_TRANSFORM_SEED} =
        $self->headers->{+HEADER_KDF_PARAMETERS}{$param} //= random_bytes(32);
}

sub transform_rounds {
    my $self = shift;
    require File::KDBX::KDF;
    my $info = $File::KDBX::KDF::ROUNDS_INFO{$self->kdf_parameters->{+KDF_PARAM_UUID} // ''} //
        $File::KDBX::KDF::DEFAULT_ROUNDS_INFO;
    $self->headers->{+HEADER_TRANSFORM_ROUNDS} =
        $self->headers->{+HEADER_KDF_PARAMETERS}{$info->{p}} = shift if @_;
    $self->headers->{+HEADER_TRANSFORM_ROUNDS} =
        $self->headers->{+HEADER_KDF_PARAMETERS}{$info->{p}} //= $info->{d};
}


sub cipher {
    my $self = shift;
    my %args = @_;

    $args{uuid} //= $self->cipher_id;
    $args{iv}   //= $self->encryption_iv;

    require File::KDBX::Cipher;
    return File::KDBX::Cipher->new(%args);
}


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 _handle_signal {
    my $self    = shift;
    my $object  = shift;
    my $type    = shift;

    my %handlers = (
        'entry.added'           => \&_handle_object_added,
        'group.added'           => \&_handle_object_added,
        'entry.removed'         => \&_handle_object_removed,
        'group.removed'         => \&_handle_object_removed,
        'entry.uuid.changed'    => \&_handle_entry_uuid_changed,
        'group.uuid.changed'    => \&_handle_group_uuid_changed,
    );
    my $handler = $handlers{$type} or return;
    $self->$handler($object, @_);
}

sub _handle_object_added {
    my $self    = shift;
    my $object  = shift;
    $self->remove_deleted_object($object->uuid);
}

sub _handle_object_removed {
    my $self        = shift;
    my $object      = shift;
    my $old_uuid    = $object->{uuid} // return;

    my $meta = $self->meta;
    $self->recycle_bin_uuid(UUID_NULL)          if $old_uuid eq ($meta->{recycle_bin_uuid} // '');
    $self->entry_templates_group(UUID_NULL)     if $old_uuid eq ($meta->{entry_templates_group} // '');
    $self->last_selected_group(UUID_NULL)       if $old_uuid eq ($meta->{last_selected_group} // '');
    $self->last_top_visible_group(UUID_NULL)    if $old_uuid eq ($meta->{last_top_visible_group} // '');

    $self->add_deleted_object($old_uuid);
}

sub _handle_entry_uuid_changed {
    my $self        = shift;
    my $object      = shift;
    my $new_uuid    = shift;
    my $old_uuid    = shift // return;

    my $old_pretty = format_uuid($old_uuid);
    my $new_pretty = format_uuid($new_uuid);
    my $fieldref_match = qr/\{REF:([TUPANI])\@I:\Q$old_pretty\E\}/is;

    $self->entries->each(sub {
        $_->previous_parent_group($new_uuid) if $old_uuid eq ($_->{previous_parent_group} // '');

        for my $string (values %{$_->strings}) {
            next if !defined $string->{value} || $string->{value} !~ $fieldref_match;
            my $txn = $_->begin_work;
            $string->{value} =~ s/$fieldref_match/{REF:$1\@I:$new_pretty}/g;
            $txn->commit;
        }
    });
}

sub _handle_group_uuid_changed {
    my $self        = shift;
    my $object      = shift;
    my $new_uuid    = shift;
    my $old_uuid    = shift // return;

    my $meta = $self->meta;
    $self->recycle_bin_uuid($new_uuid)          if $old_uuid eq ($meta->{recycle_bin_uuid} // '');
    $self->entry_templates_group($new_uuid)     if $old_uuid eq ($meta->{entry_templates_group} // '');
    $self->last_selected_group($new_uuid)       if $old_uuid eq ($meta->{last_selected_group} // '');
    $self->last_top_visible_group($new_uuid)    if $old_uuid eq ($meta->{last_top_visible_group} // '');

    $self->groups->each(sub {
        $_->last_top_visible_entry($new_uuid)   if $old_uuid eq ($_->{last_top_visible_entry} // '');
        $_->previous_parent_group($new_uuid)    if $old_uuid eq ($_->{previous_parent_group} // '');
    });
    $self->entries->each(sub {
        $_->previous_parent_group($new_uuid)    if $old_uuid eq ($_->{previous_parent_group} // '');
    });
}

#########################################################################################


#########################################################################################

sub TO_JSON { +{%{$_[0]}} }

1;

__END__