File Coverage

blib/lib/File/KeePass/KDBX.pm

Criterion	Covered	Total	%
statement	240	310	77.4
branch	109	174	62.6
condition	55	113	48.6
subroutine	52	67	77.6
pod	30	36	83.3
total	486	700	69.4

package File::KeePass::KDBX;
# ABSTRACT: Read and write KDBX files (using the File::KDBX backend)

use utf8;
use warnings;
use strict;

use Crypt::PRNG qw(irand);
use Crypt::Misc 0.029 qw(decode_b64 encode_b64);
use File::KDBX::Constants qw(:header :magic :version);
use File::KDBX::Loader::KDB;
use File::KDBX::Util qw(clone_nomagic generate_uuid load_optional);
use Hash::Util::FieldHash qw(fieldhashes);
use Module::Load;
use Scalar::Util qw(blessed looks_like_number weaken);
use boolean;
use namespace::clean;

our $VERSION = '0.900'; # VERSION

fieldhashes \my (%KDBX, %TIED);

BEGIN {
    our @ISA;
    @ISA = qw(File::KeePass) if $INC{'File/KeePass.pm'};
}


sub new {
    my $class = shift;

    # copy constructor
    return $_[0]->clone if @_ == 1 && (blessed $_[0] // '') eq __PACKAGE__;

    if (@_ == 1 && blessed $_[0] && $_[0]->isa('File::KeePass')) {
        return $class->from_fkp(@_);
    }

    if (@_ == 1 && blessed $_[0] && $_[0]->isa('File::KDBX')) {
        my $self = bless {}, $class;
        $self->kdbx($_[0]);
        return $self;
    }

    my $args = ref $_[0] ? {%{$_[0]}} : {@_};
    my $self = bless $args, $class;
    exists $args->{kdbx} and $self->kdbx(delete $args->{kdbx});
    return $self;
}

sub DESTROY { $_[0]->clear }


sub clone {
    my $self = shift;
    require Storable;
    return Storable::dclone($self);
}

sub STORABLE_freeze {
    my $self = shift;
    my $copy = {%$self};
    delete @$self{qw(header groups)};
    return '', $copy, $KDBX{$self};
}

sub STORABLE_thaw {
    my $self    = shift;
    my $cloning = shift;
    shift;  # empty
    my $copy    = shift;
    my $kdbx    = shift;

    @$self{keys %$copy} = values %$copy;
    $self->kdbx($kdbx) if $kdbx;
}


sub clear {
    my $self = shift;
    delete $KDBX{$self};
    delete $TIED{$self};
    delete @$self{qw(header groups)};
}


sub kdbx {
    my $self = shift;
    $self = $self->new if !ref $self;
    if (@_) {
        $self->clear;
        $KDBX{$self} = shift;
    }
    $KDBX{$self} //= do { require File::KDBX; File::KDBX->new };
}


sub to_fkp {
    my $self = shift;
    load_optional('File::KeePass');
    return File::KeePass->new(clone_nomagic({%$self, header => $self->header, groups => $self->groups}));
}


sub from_fkp {
    my $class = shift;
    my $k = shift;
    my $kdbx = File::KDBX::Loader::KDB::convert_keepass_to_kdbx($k);
    my $self = bless {}, $class;
    $self->kdbx($kdbx);
    return $self;
}


sub load_db {
    my $self = shift;
    my $file = shift or die "Missing file\n";
    my $pass = shift or die "Missing pass\n";
    my $args = shift || {};

    open(my $fh, '<:raw', $file) or die "Could not open $file: $!\n";
    $self->_load($fh, $pass, $args);
}


sub parse_db {
    my ($self, $buf, $pass, $args) = @_;

    my $ref = ref $buf ? $buf : \$buf;

    open(my $fh, '<:raw', $ref) or die "Could not open buffer: $!\n";
    $self->_load($fh, $pass, $args);
}

sub _load {
    my ($self, $fh, $pass, $args) = @_;

    $self = $self->new($args) if !ref $self;

    my $unlock = defined $args->{auto_lock} ? !$args->{auto_lock} : !$self->auto_lock;

    $self->kdbx->load_handle($fh, $pass);
    $self->kdbx->unlock if $unlock;
    return $self;
}


sub parse_header {
    my ($self, $buf) = @_;

    open(my $fh, '<:raw', \$buf) or die "Could not open buffer: $!\n";

    # detect filetype and version
    my $loader = File::KDBX::Loader->new;
    my ($sig1, $sig2, $version) = $loader->read_magic_numbers($fh);

    if ($sig2 == KDBX_SIG2_1 || $version < KDBX_VERSION_2_0) {
        close($fh);

        load_optional('File::KeePass');
        return File::KeePass->parse_header($buf);
    }

    my %header_transform = (
        HEADER_COMMENT()                    => ['comment'],
        HEADER_CIPHER_ID()                  => ['cipher', sub { $self->_cipher_name($_[0]) }],
        HEADER_COMPRESSION_FLAGS()          => ['compression'],
        HEADER_MASTER_SEED()                => ['seed_rand'],
        HEADER_TRANSFORM_SEED()             => ['seed_key'],
        HEADER_TRANSFORM_ROUNDS()           => ['rounds'],
        HEADER_ENCRYPTION_IV()              => ['enc_iv'],
        HEADER_INNER_RANDOM_STREAM_KEY()    => ['protected_stream_key'],
        HEADER_STREAM_START_BYTES()         => ['start_bytes'],
        HEADER_INNER_RANDOM_STREAM_ID()     => ['protected_stream', sub { $self->_inner_random_stream_name($_[0]) }],
        HEADER_KDF_PARAMETERS()             => ['kdf_parameters'],
        HEADER_PUBLIC_CUSTOM_DATA()         => ['public_custom_data'],
    );

    my %head;

    while (my ($type, $val) = $loader->_read_header($fh)) {
        last if $type == HEADER_END;
        my ($name, $filter) = @{$header_transform{$type} || ["$type"]};
        $head{$name} = $filter ? $filter->($val) : $val;
    }

    return \%head;
}


sub save_db {
    my ($self, $file, $pass, $head) = @_;
    die "Missing file\n" if !$file;
    die "Missing pass\n" if !$pass;

    shift if @_ % 2 == 1;
    my %args = @_;

    local $self->kdbx->{headers} = $self->_gen_headers($head);

    $args{randomize_seeds} = 0 if $head && $head->{reuse_header};

    $self->kdbx->dump_file($file, $pass, %args);
    return 1;
}


sub gen_db {
    my ($self, $pass, $head) = @_;
    die "Missing pass\n" if !$pass;

    shift if @_ % 2 == 1;
    my %args = @_;

    local $self->kdbx->{headers} = $self->_gen_headers($head);

    $args{randomize_seeds} = 0 if $head && $head->{reuse_header};

    my $dump = $self->kdbx->dump_string($pass, %args);
    return $$dump;
}

sub _gen_headers {
    my $self = shift;
    my $head = shift || {};

    my $v = $head->{'version'} || $self->header->{'version'};
    my $reuse = $head->{'reuse_header'}                        # explicit yes
                || (!exists($head->{'reuse_header'})           # not explicit no
                    && ($self->{'reuse_header'}                # explicit yes
                        || !exists($self->{'reuse_header'}))); # not explicit no
    if ($reuse) {
        ($head, my $args) = ($self->header || {}, $head);
        @$head{keys %$args} = values %$args;
    }
    $head->{'version'} = $v ||= $head->{'version'} || '1';
    delete @$head{qw(enc_iv seed_key seed_rand protected_stream_key start_bytes)} if $reuse && $reuse < 0;

    if ($head->{version} == 1) {
        $head->{enc_type} = 'rijndael';
        $head->{cipher} = 'aes';
    }

    my $temp_kdbx = File::KDBX::Loader::KDB::_convert_keepass_to_kdbx_headers($head, File::KDBX->new);
    return $temp_kdbx->headers;
}


sub header {
    my $self = shift;
    return if !exists $KDBX{$self};
    $self->{header} //= $self->_tie({}, 'Header', $self->kdbx);
}


sub groups {
    my $self = shift;
    return if !exists $KDBX{$self};
    $self->{groups} //= $self->_tie([], 'GroupList', $self->kdbx);
}


# Copied from File::KeePass - thanks paul
sub dump_groups {
    my ($self, $args, $groups) = @_;
    my $t = '';
    my %gargs; for (keys %$args) { $gargs{$2} = $args->{$1} if /^(group_(.+))$/ };
    foreach my $g ($self->find_groups(\%gargs, $groups)) {
        my $indent = '    ' x $g->{'level'};
        $t .= $indent.($g->{'expanded'} ? '-' : '+')."  $g->{'title'} ($g->{'id'}) $g->{'created'}\n";
        local $g->{'groups'}; # don't recurse while looking for entries since we are already flat
        $t .= "$indent    > $_->{'title'}\t($_->{'id'}) $_->{'created'}\n" for $self->find_entries($args, [$g]);
    }
    return $t;
}


sub add_group {
    my $self = shift;
    my $group = shift;

    my $parent = delete local $group->{group};
    $parent = $parent->{id} if ref $parent;

    $group->{expires} //= $self->default_exp;

    my $group_info = File::KDBX::Loader::KDB::_convert_keepass_to_kdbx_group($group);
    my $group_obj = $self->kdbx->add_group($group_info, parent => $parent);
    return $self->_tie({}, 'Group', $group_obj);
}


# Copied from File::KeePass - thanks paul
sub find_groups {
    my ($self, $args, $groups, $level) = @_;
    my @tests = $self->finder_tests($args);
    my @groups;
    my %uniq;
    my $container = $groups || $self->groups;
    for my $g (@$container) {
        $g->{'level'} = $level || 0;
        $g->{'title'} = '' if ! defined $g->{'title'};
        $g->{'icon'}  ||= 0;
        if ($self->{'force_v2_gid'}) {
            $g->{'id'} = $self->uuid($g->{'id'}, \%uniq);
        } else {
            $g->{'id'} = irand while !defined($g->{'id'}) || $uniq{$g->{'id'}}++; # the non-v2 gid is compatible with both v1 and our v2 implementation
        }

        if (!@tests || !grep{!$_->($g)} @tests) {
            push @groups, $g;
            push @{ $self->{'__group_groups'} }, $container if $self->{'__group_groups'};
        }
        push @groups, $self->find_groups($args, $g->{'groups'}, $g->{'level'} + 1) if $g->{'groups'};
    }
    return @groups;
}


# Copied from File::KeePass - thanks paul
sub find_group {
    my $self = shift;
    local $self->{'__group_groups'} = [] if wantarray;
    my @g = $self->find_groups(@_);
    die "Found too many groups (@g)\n" if @g > 1;
    return wantarray ? ($g[0], $self->{'__group_groups'}->[0]) : $g[0];
}


sub delete_group {
    my $self = shift;
    my $group_info = shift;

    my $group = $self->find_group($group_info) or return;
    $group->{__object}->remove;
    return $group;
}


sub add_entry {
    my $self = shift;
    my $entry = shift;

    my $parent = delete local $entry->{group};
    $parent = $parent->{id} if ref $parent;

    $entry->{expires} //= $self->default_exp;

    my $entry_info = File::KDBX::Loader::KDB::_convert_keepass_to_kdbx_entry($entry);
    $parent = $self->kdbx->root->groups->[0] if !$parent && $self->kdbx->_has_implicit_root;
    my $entry_obj = $self->kdbx->add_entry($entry_info, parent => $parent);
    return $self->_tie({}, 'Entry', $entry_obj);
}


# Copied from File::KeePass - thanks paul
sub find_entries {
    my ($self, $args, $groups) = @_;
    local @{ $args }{'expires gt', 'active'} = ($self->now, undef) if $args->{'active'};
    my @tests = $self->finder_tests($args);
    my @entries;
    foreach my $g ($self->find_groups({}, $groups)) {
        foreach my $e (@{ $g->{'entries'} || [] }) {
            local $e->{'group_id'}    = $g->{'id'};
            local $e->{'group_title'} = $g->{'title'};
            if (!@tests || !grep{!$_->($e)} @tests) {
                push @entries, $e;
                push @{ $self->{'__entry_groups'} }, $g if $self->{'__entry_groups'};
            }
        }
    }
    return @entries;
}


# Copied from File::KeePass - thanks paul
sub find_entry {
    my $self = shift;
    local $self->{'__entry_groups'} = [] if wantarray;
    my @e = $self->find_entries(@_);
    die "Found too many entries (@e)\n" if @e > 1;
    return wantarray ? ($e[0], $self->{'__entry_groups'}->[0]) : $e[0];
}


sub delete_entry {
    my $self = shift;
    my $entry_info = shift;

    my $entry = $self->find_entry($entry_info) or return;
    $entry->{__object}->remove;
    return $entry;
}

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


# Copied from File::KeePass - thanks paul
sub finder_tests {
    my ($self, $args) = @_;
    my @tests;
    foreach my $key (keys %{ $args || {} }) {
        next if ! defined $args->{$key};
        my ($field, $op) = ($key =~ m{ ^ (\w+) \s* (|!|=|!~|=~|gt|lt) $ }x) ? ($1, $2) : die "Invalid find match criteria \"$key\"\n";
        push @tests,  (!$op || $op eq '=') ? sub {  defined($_[0]->{$field}) && $_[0]->{$field} eq $args->{$key} }
                    : ($op eq '!')         ? sub { !defined($_[0]->{$field}) || $_[0]->{$field} ne $args->{$key} }
                    : ($op eq '=~')        ? sub {  defined($_[0]->{$field}) && $_[0]->{$field} =~ $args->{$key} }
                    : ($op eq '!~')        ? sub { !defined($_[0]->{$field}) || $_[0]->{$field} !~ $args->{$key} }
                    : ($op eq 'gt')        ? sub {  defined($_[0]->{$field}) && $_[0]->{$field} gt $args->{$key} }
                    : ($op eq 'lt')        ? sub {  defined($_[0]->{$field}) && $_[0]->{$field} lt $args->{$key} }
                    : die "Unknown op \"$op\"\n";
    }
    return @tests;
}


sub default_exp { $_[0]->{default_exp} || '2999-12-31 23:23:59' }


# Copied from File::KeePass - thanks paul
sub now {
    my ($self, $time) = @_;
    my ($sec, $min, $hour, $day, $mon, $year) = gmtime($time || time);
    return sprintf '%04d-%02d-%02d %02d:%02d:%02d', $year+1900, $mon+1, $day, $hour, $min, $sec;
}

sub encode_base64 { encode_b64($_[1]) }
sub decode_base64 { decode_b64($_[1]) }

sub gen_uuid { generate_uuid(printable => 1) }

# Copied from File::KeePass - thanks paul
sub uuid {
    my ($self, $id, $uniq) = @_;
    $id = $self->gen_uuid if !defined($id) || !length($id);
    return $uniq->{$id} ||= do {
        if (length($id) != 16) {
            $id = substr($self->encode_base64($id), 0, 16) if $id !~ /^\d+$/ || $id > 2**32-1;
            $id = sprintf '%016s', $id if $id ne '0';
        }
        $id = $self->gen_uuid while $uniq->{$id}++;
        $id;
    };
}

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


sub auto_lock {
    my $self = shift;
    $self->{auto_lock} = shift if @_;
    $self->{auto_lock} //= 1;
}


sub is_locked { $_[0]->kdbx->is_locked }


sub lock { $_[0]->kdbx->lock }


sub unlock { $_[0]->kdbx->unlock }


sub locked_entry_password {
    my $self = shift;
    my $entry = shift;

    $self->is_locked or die "Passwords are not locked\n";

    $entry = $self->find_entry({id => $entry}) if !ref $entry;
    return if !$entry;

    my $entry_obj = $entry->{__object} or return;
    return $entry_obj->string_peek('Password');
}

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

sub _tie {
    my $self    = shift;
    my $ref     = shift // \my %h;
    my $class   = shift;
    my $obj     = shift;

    my $cache = $TIED{$self} //= {};

    $class = __PACKAGE__."::Tie::$class" if $class !~ s/^\+//;
    my $key = "$class:" . Hash::Util::FieldHash::id($obj);
    my $hit = $cache->{$key};
    return $hit if defined $hit;

    load $class;
    tie((ref $ref eq 'ARRAY' ? @$ref : %$ref), $class, $obj, @_, $self);
    $hit = $cache->{$key} = $ref;
    weaken $cache->{$key};
    return $hit;
}

### convert datetime from KDBX to KeePass format
sub _decode_datetime {
    local $_ = shift or return;
    return $_->strftime('%Y-%m-%d %H:%M:%S');
}

### convert datetime from KeePass to KDBX format
sub _encode_datetime {
    local $_ = shift or return;
    return Time::Piece->strptime($_, '%Y-%m-%d %H:%M:%S');
}

### convert UUID from KeePass to KDBX format
sub _encode_uuid {
    local $_ = shift // return;
    # Group IDs in KDB files are 32-bit integers
    return sprintf('%016x', $_) if length($_) != 16 && looks_like_number($_);
    return $_;
}

### convert tristate from KDBX to KeePass format
sub _decode_tristate {
    local $_ = shift // return;
    return $_ ? 1 : 0;
}

### convert tristate from KeePass to KDBX format
sub _encode_tristate {
    local $_ = shift // return;
    return boolean($_);
}

1;

__END__