view release on metacpan or  search on metacpan

lib/File/KDBX/Object.pm  view on Meta::CPAN

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.906'; # 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;

lib/File/KDBX/Object.pm  view on Meta::CPAN

    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;