Add maintenance methods

[chaz/p5-File-KDBX] / lib / File / KDBX / Object.pm

diff --git a/lib/File/KDBX/Object.pm b/lib/File/KDBX/Object.pm
index bcbfd58c86451544c829abfbb6654b024a4eb4ad..3a56c37e82ce270ee26e4cf517326e5e25707f51 100644 (file)
--- a/lib/File/KDBX/Object.pm
+++ b/lib/File/KDBX/Object.pm
@@ -5,10 +5,11 @@ use warnings;
 use strict;
 
 use Devel::GlobalDestruction;
 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 File::KDBX::Error;
 use File::KDBX::Util qw(:uuid);
 use Hash::Util::FieldHash qw(fieldhashes);

-use List::Util qw(first);
+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;
 use Ref::Util qw(is_arrayref is_plain_arrayref is_plain_hashref is_ref);
 use Scalar::Util qw(blessed weaken);
 use namespace::clean;


@@ -130,12 +131,12 @@ sub label { die 'Not implemented' }
 
 =method clone
 
 
 =method clone
 

-    $object_copy = $object->clone;
+    $object_copy = $object->clone(%options);

     $object_copy = File::KDBX::Object->new($object);
 
     $object_copy = File::KDBX::Object->new($object);
 

-Make a clone of an object. 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). Some options are allowed to
-get different effects:
+Make a clone of an object. By default the clone is indeed an exact copy that is connected to the same database
+but not actually included in the object tree (i.e. it has no parent group). Some options are allowed to get
+different effects:

 
 =for :list
 * C<new_uuid> - If set, generate a new UUID for the copy (default: false)
 
 =for :list
 * C<new_uuid> - If set, generate a new UUID for the copy (default: false)


@@ -169,7 +170,7 @@ sub clone {
     if ($args{relabel} and my $label = $self->label) {
         $copy->label("$label - Copy");
     }
     if ($args{relabel} and my $label = $self->label) {
         $copy->label("$label - Copy");
     }

-    if ($args{parent} and my $parent = $self->parent) {
+    if ($args{parent} and my $parent = $self->group) {

         $parent->add_object($copy);
     }
 
         $parent->add_object($copy);
     }
 


@@ -235,7 +236,7 @@ sub STORABLE_thaw {
     $kdbx = $object->kdbx;
     $object->kdbx($kdbx);
 
     $kdbx = $object->kdbx;
     $object->kdbx($kdbx);
 

-Get or set the L<File::KDBX> instance associated with this object.
+Get or set the L<File::KDBX> instance connected with this object.

 
 =cut
 
 
 =cut
 


@@ -251,7 +252,20 @@ sub kdbx {
             delete $KDBX{$self};
         }
     }
             delete $KDBX{$self};
         }
     }

-    $KDBX{$self} or throw 'Object is disassociated from a KDBX database', object => $self;
+    $KDBX{$self} or throw 'Object is disconnected', object => $self;
+}
+
+=method is_connected
+
+    $bool = $object->is_connected;
+
+Determine whether or not an object is connected to a database.
+
+=cut
+
+sub is_connected {
+    my $self = shift;
+    return !!eval { $self->kdbx };

 }
 
 =method id
 }
 
 =method id


@@ -272,18 +286,25 @@ sub id { format_uuid(shift->uuid, @_) }
 
 =method group
 
 
 =method group
 

-=method parent
-
-    $group = $object->group;
-    # OR equivalently
-    $group = $object->parent;
+    $parent_group = $object->group;
+    $object->group($parent_group);

 
 

-Get the parent group to which an object belongs or C<undef> if it belongs to no group.
+Get or set the parent group to which an object belongs or C<undef> if it belongs to no group.

 
 =cut
 
 sub group {
     my $self = shift;
 
 =cut
 
 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;
     my $id   = Hash::Util::FieldHash::id($self);
     if (my $group = $PARENT{$self}) {
         my $method = $self->_parent_container;


@@ -297,8 +318,6 @@ sub group {
     return $group;
 }
 
     return $group;
 }
 

-sub parent { shift->group(@_) }
-

 sub _set_group {
     my $self = shift;
     if (my $parent = shift) {
 sub _set_group {
     my $self = shift;
     if (my $parent = shift) {


@@ -333,10 +352,10 @@ sub lineage {
 
     # try leaf to root
     my @path;
 
     # try leaf to root
     my @path;

-    my $o = $self;
-    while ($o = $o->parent) {
-        unshift @path, $o;
-        last if $base_addr == Hash::Util::FieldHash::id($o);
+    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);
 
     }
     return \@path if @path && ($base_addr == Hash::Util::FieldHash::id($path[0]) || $path[0]->is_root);
 


@@ -346,19 +365,73 @@ sub lineage {
 
 =method remove
 
 
 =method remove
 

-    $object = $object->remove;
+    $object = $object->remove(%options);
+
+Remove an object from its parent. If the object is a group, all contained objects stay with the object and so
+are removed as well. Options:

 
 

-Remove the object from the database. If the object is a group, all contained objects are removed as well.
+=for :list
+* C<signal> Whether or not to signal the removal to the connected database (default: true)

 
 =cut
 
 sub remove {
     my $self = shift;
 
 =cut
 
 sub remove {
     my $self = shift;

-    my $parent = $self->parent;
-    $parent->remove_object($self) if $parent;
+    my $parent = $self->group;
+    $parent->remove_object($self, @_) if $parent;
+    $self->_set_group(undef);

     return $self;
 }
 
     return $self;
 }
 

+=method recycle
+
+    $object = $object->recycle;
+
+Remove an object from its parent and add it to the connected database's recycle bin group.
+
+=cut
+
+sub recycle {
+    my $self = shift;
+    return $self->group($self->kdbx->recycle_bin);
+}
+
+=method recycle_or_remove
+
+    $object = $object->recycle_or_remove;
+
+Recycle or remove an object, depending on the connected database's L<File::KDBX/recycle_bin_enabled>. If the
+object is not connected to a database or is already in the recycle bin, remove it.
+
+=cut
+
+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;
+    }
+}
+
+=method is_recycled
+
+    $bool = $object->is_recycled;
+
+Get whether or not an object is in a recycle bin.
+
+=cut
+
+sub is_recycled {
+    my $self = shift;
+    eval { $self->kdbx } or return FALSE;
+    return !!($self->group && any { $_->is_recycle_bin } @{$self->lineage});
+}
+
+##############################################################################
+

 =method tag_list
 
     @tags = $entry->tag_list;
 =method tag_list
 
     @tags = $entry->tag_list;


@@ -724,10 +797,11 @@ but instead use its subclasses:
 
 There is some functionality shared by both types of objects, and that's what this class provides.
 
 
 There is some functionality shared by both types of objects, and that's what this class provides.
 

-Each object can be associated with a L<File::KDBX> database or be disassociated. A disassociated object will
-not be persisted when dumping a database. It is also possible for an object to be associated with a database
-but not be part of the object tree (i.e. is not the root group or any subroup or entry). A disassociated
-object or an object not part of the object tree of a database can be added to a database using one of:
+Each object can be connected with a L<File::KDBX> database or be disconnected. A disconnected object exists in
+memory but will not be persisted when dumping a database. It is also possible for an object to be connected
+with a database but not be part of the object tree (i.e. is not the root group or any subroup or entry).
+A disconnected object or an object not part of the object tree of a database can be added to a database using
+one of:

 
 =for :list
 * L<File::KDBX/add_entry>
 
 =for :list
 * L<File::KDBX/add_entry>


@@ -737,7 +811,7 @@ object or an object not part of the object tree of a database can be added to a
 * L<File::KDBX::Entry/add_historical_entry>
 
 It is possible to copy or move objects between databases, but B<DO NOT> include the same object in more
 * L<File::KDBX::Entry/add_historical_entry>
 
 It is possible to copy or move objects between databases, but B<DO NOT> include the same object in more

-than one database at once or there could some strange aliasing effects (i.e. changes in one database might
+than one database at once or there could be some strange aliasing effects (i.e. changes in one database might

 effect another in unexpected ways). This could lead to difficult-to-debug problems. It is similarly not safe
 or valid to add the same object multiple times to the same database. For example:
 
 effect another in unexpected ways). This could lead to difficult-to-debug problems. It is similarly not safe
 or valid to add the same object multiple times to the same database. For example:
 


@@ -758,6 +832,6 @@ Instead, do this:
     $another_kdbx->add_entry($entry->clone);
 
     # OR move an existing entry from one database to another:
     $another_kdbx->add_entry($entry->clone);
 
     # OR move an existing entry from one database to another:

-    $kdbx->add_entry($entry->remove);
+    $another_kdbx->add_entry($entry->remove);

 
 =cut
 
 =cut