File Coverage

blib/lib/File/KDBX/Object.pm

Criterion	Covered	Total	%
statement	284	300	94.6
branch	98	128	76.5
condition	77	106	72.6
subroutine	48	54	88.8
pod	21	24	87.5
total	528	612	86.2

package File::KDBX::Object;
# ABSTRACT: A KDBX database object

use warnings;
use strict;

use Devel::GlobalDestruction;
use File::KDBX::Constants qw(:bool);
use File::KDBX::Error;
use File::KDBX::Util qw(:uuid);
use Hash::Util::FieldHash qw(fieldhashes);
use List::Util qw(any first);
use Ref::Util qw(is_arrayref is_plain_arrayref is_plain_hashref is_ref);
use Scalar::Util qw(blessed weaken);
use namespace::clean;

our $VERSION = '0.905'; # VERSION

fieldhashes \my (%KDBX, %PARENT, %TXNS, %REFS, %SIGNALS);


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_nonlazy_attributes if !$data;
    return $self;
}

sub _set_nonlazy_attributes { die 'Not implemented' }


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 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, @_);
}


sub label { die 'Not implemented' }


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->group) {
        $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 ($cloning ? Hash::Util::FieldHash::id($self) : ''), $copy;
}

sub STORABLE_thaw {
    my $self    = shift;
    my $cloning = shift;
    my $addr    = shift;
    my $copy    = shift;

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

    if ($cloning) {
        my $kdbx = $KDBX{$addr};
        $self->kdbx($kdbx) if $kdbx;
    }

    if (defined $self->{uuid}) {
        if (($CLONE{reference_password} || $CLONE{reference_username}) && $self->can('strings')) {
            my $uuid = format_uuid($self->{uuid});
            my $clone_obj = do {
                local $CLONE{new_uuid}              = 0;
                local $CLONE{entries}               = 1;
                local $CLONE{groups}                = 1;
                local $CLONE{history}               = 1;
                local $CLONE{reference_password}    = 0;
                local $CLONE{reference_username}    = 0;
                # Clone only the entry's data and manually bless to avoid infinite recursion.
                bless Storable::dclone({%$copy}), 'File::KDBX::Entry';
            };
            my $txn = $self->begin_work(snapshot => $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};
    }

    # Dualvars aren't cloned as dualvars, so dualify the icon.
    $self->icon_id($self->{icon_id}) if defined $self->{icon_id};
}


sub kdbx {
    my $self = shift;
    $self = $self->new if !ref $self;
    if (@_) {
        if (my $kdbx = shift) {
            $KDBX{$self} = $kdbx;
            weaken $KDBX{$self};
        }
        else {
            delete $KDBX{$self};
        }
    }
    $KDBX{$self} or throw 'Object is disconnected', object => $self;
}


sub is_connected {
    my $self = shift;
    return !!eval { $self->kdbx };
}


sub id { format_uuid(shift->uuid, @_) }


sub group {
    my $self = shift;

    if (my $new_group = shift) {
        my $old_group = $self->group;
        return $new_group if Hash::Util::FieldHash::id($old_group) == Hash::Util::FieldHash::id($new_group);
        # move to a new parent
        $self->remove(signal => 0) if $old_group;
        $self->location_changed('now');
        $new_group->add_object($self);
    }

    my $id   = Hash::Util::FieldHash::id($self);
    if (my $group = $PARENT{$self}) {
        my $method = $self->_parent_container;
        return $group if first { $id == Hash::Util::FieldHash::id($_) } @{$group->$method};
        delete $PARENT{$self};
    }
    # always get lineage from root to leaf because the other way requires parent, so it would be recursive
    my $lineage = $self->kdbx->_trace_lineage($self) or return;
    my $group = pop @$lineage or return;
    $PARENT{$self} = $group; weaken $PARENT{$self};
    return $group;
}

sub _set_group {
    my $self = shift;
    if (my $parent = shift) {
        $PARENT{$self} = $parent;
        weaken $PARENT{$self};
    }
    else {
        delete $PARENT{$self};
    }
    return $self;
}

### Name of the parent attribute expected to contain the object
sub _parent_container { die 'Not implemented' }


sub lineage {
    my $self = shift;
    my $base = shift;

    my $base_addr = $base ? Hash::Util::FieldHash::id($base) : 0;

    # try leaf to root
    my @path;
    my $object = $self;
    while ($object = $object->group) {
        unshift @path, $object;
        last if $base_addr == Hash::Util::FieldHash::id($object);
    }
    return \@path if @path && ($base_addr == Hash::Util::FieldHash::id($path[0]) || $path[0]->is_root);

    # try root to leaf
    return $self->kdbx->_trace_lineage($self, $base);
}


sub remove {
    my $self = shift;
    my $parent = $self->group;
    $parent->remove_object($self, @_) if $parent;
    $self->_set_group(undef);
    return $self;
}


sub recycle {
    my $self = shift;
    return $self->group($self->kdbx->recycle_bin);
}


sub recycle_or_remove {
    my $self = shift;
    my $kdbx = eval { $self->kdbx };
    if ($kdbx && $kdbx->recycle_bin_enabled && !$self->is_recycled) {
        $self->recycle;
    }
    else {
        $self->remove;
    }
}


sub is_recycled {
    my $self = shift;
    eval { $self->kdbx } or return FALSE;
    return !!($self->group && any { $_->is_recycle_bin } @{$self->lineage});
}

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


sub tag_list {
    my $self = shift;
    return grep { $_ ne '' } split(/[,\.:;]|\s+/, trim($self->tags) // '');
}


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


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


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

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


sub begin_work {
    my $self = shift;

    if (defined wantarray) {
        require File::KDBX::Transaction;
        return File::KDBX::Transaction->new($self, @_);
    }

    my %args = @_;
    my $orig = $args{snapshot} // do {
        my $c = $self->clone(
            entries => $args{entries} // 0,
            groups  => $args{groups}  // 0,
            history => $args{history} // 0,
        );
        $c->{entries} = $self->{entries} if !$args{entries};
        $c->{groups}  = $self->{groups}  if !$args{groups};
        $c->{history} = $self->{history} if !$args{history};
        $c;
    };

    my $id = Hash::Util::FieldHash::id($orig);
    _save_references($id, $self, $orig);

    $self->_signal_begin_work;

    push @{$self->_txns}, $orig;
}


sub commit {
    my $self = shift;
    my $orig = pop @{$self->_txns} or return $self;
    $self->_commit($orig);
    my $signals = $self->_signal_commit;
    $self->_signal_send($signals) if !$self->_in_txn;
    return $self;
}


sub rollback {
    my $self = shift;

    my $orig = pop @{$self->_txns} or return $self;

    my $id = Hash::Util::FieldHash::id($orig);
    _restore_references($id, $orig);

    $self->_signal_rollback;

    return $self;
}

# Get whether or not there is at least one pending transaction.
sub _in_txn { scalar @{$_[0]->_txns} }

# Get an array ref of pending transactions.
sub _txns   { $TXNS{$_[0]} //= [] }

# The _commit hook notifies subclasses that a commit has occurred.
sub _commit { die 'Not implemented' }

# Get a reference to an object that represents an object's committed state. If there is no pending
# transaction, this is just $self. If there is a transaction, this is the snapshot take before the transaction
# began. This method is private because it provides direct access to the actual snapshot. It is important that
# the snapshot not be changed or a rollback would roll back to an altered state.
# This is used by File::KDBX::Dumper::XML so as to not dump uncommitted changes.
sub _committed {
    my $self = shift;
    my ($orig) = @{$self->_txns};
    return $orig // $self;
}

# In addition to cloning an object when beginning work, we also keep track its hashrefs and arrayrefs
# internally so that we can restore to the very same structures in the case of a rollback.
sub _save_references {
    my $id   = shift;
    my $self = shift;
    my $orig = shift;

    if (is_plain_arrayref($orig)) {
        for (my $i = 0; $i < @$orig; ++$i) {
            _save_references($id, $self->[$i], $orig->[$i]);
        }
        $REFS{$id}{Hash::Util::FieldHash::id($orig)} = $self;
    }
    elsif (is_plain_hashref($orig) || (blessed $orig && $orig->isa(__PACKAGE__))) {
        for my $key (keys %$orig) {
            _save_references($id, $self->{$key}, $orig->{$key});
        }
        $REFS{$id}{Hash::Util::FieldHash::id($orig)} = $self;
    }
}

# During a rollback, copy data from the snapshot back into the original internal structures.
sub _restore_references {
    my $id   = shift;
    my $orig = shift // return;
    my $self = delete $REFS{$id}{Hash::Util::FieldHash::id($orig) // ''} // return $orig;

    if (is_plain_arrayref($orig)) {
        @$self = map { _restore_references($id, $_) } @$orig;
    }
    elsif (is_plain_hashref($orig) || (blessed $orig && $orig->isa(__PACKAGE__))) {
        for my $key (keys %$orig) {
            # next if is_ref($orig->{$key}) &&
            #     (Hash::Util::FieldHash::id($self->{$key}) // 0) == Hash::Util::FieldHash::id($orig->{$key});
            $self->{$key} = _restore_references($id, $orig->{$key});
        }
    }

    return $self;
}

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

sub _signal {
    my $self = shift;
    my $type = shift;

    if ($self->_in_txn) {
        my $stack = $self->_signal_stack;
        my $queue = $stack->[-1];
        push @$queue, [$type, @_];
    }

    $self->_signal_send([[$type, @_]]);

    return $self;
}

sub _signal_stack { $SIGNALS{$_[0]} //= [] }

sub _signal_begin_work {
    my $self = shift;
    push @{$self->_signal_stack}, [];
}

sub _signal_commit {
    my $self = shift;
    my $signals = pop @{$self->_signal_stack};
    my $previous = $self->_signal_stack->[-1] // [];
    push @$previous, @$signals;
    return $previous;
}

sub _signal_rollback {
    my $self = shift;
    pop @{$self->_signal_stack};
}

sub _signal_send {
    my $self    = shift;
    my $signals = shift // [];

    my $kdbx = $KDBX{$self} or return;

    # de-duplicate, keeping the most recent signal for each type
    my %seen;
    my @signals = grep { !$seen{$_->[0]}++ } reverse @$signals;

    for my $sig (reverse @signals) {
        $kdbx->_handle_signal($self, @$sig);
    }
}

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

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

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

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

1;

__END__