Add better thread safety

diff --git a/lib/File/KDBX.pm b/lib/File/KDBX.pm
index 3f52d6cfdf2855461a8b7519e7343822cd061605..e5fcb27c91919ace7eff6f38ae4294acfefd0d74 100644 (file)
--- a/lib/File/KDBX.pm
+++ b/lib/File/KDBX.pm
@@ -10,9 +10,10 @@ use File::KDBX::Constants qw(:all);
 use File::KDBX::Error;
 use File::KDBX::Safe;
 use File::KDBX::Util qw(:empty erase generate_uuid search simple_expression_query snakify);
+use Hash::Util::FieldHash qw(fieldhashes);
 use List::Util qw(any);
 use Ref::Util qw(is_ref is_arrayref is_plain_hashref);
-use Scalar::Util qw(blessed refaddr);
+use Scalar::Util qw(blessed);
 use Time::Piece;
 use boolean;
 use namespace::clean;
@@ -20,8 +21,7 @@ use namespace::clean;
 our $VERSION = '999.999'; # VERSION
 our $WARNINGS = 1;
 
-my %SAFE;
-my %KEYS;
+fieldhashes \my (%SAFE, %KEYS);
 
 =method new
 
@@ -44,7 +44,7 @@ sub new {
     return $self;
 }
 
-sub DESTROY { !in_global_destruction and $_[0]->reset }
+sub DESTROY { local ($., $@, $!, $^E, $?); !in_global_destruction and $_[0]->reset }
 
 =method init
 
@@ -80,7 +80,6 @@ sub reset {
     erase $self->inner_headers->{+INNER_HEADER_INNER_RANDOM_STREAM_KEY};
     erase $self->{raw};
     %$self = ();
-    delete $SAFE{refaddr($self)};
     $self->_remove_safe;
     return $self;
 }
@@ -106,7 +105,7 @@ sub STORABLE_freeze {
 
     my $copy = {%$self};
 
-    return '', $copy, $KEYS{refaddr($self)} // (), $SAFE{refaddr($self)} // ();
+    return '', $copy, $KEYS{$self} // (), $SAFE{$self} // ();
 }
 
 sub STORABLE_thaw {
@@ -118,8 +117,8 @@ sub STORABLE_thaw {
     my $safe    = shift;
 
     @$self{keys %$clone} = values %$clone;
-    $KEYS{refaddr($self)} = $key;
-    $SAFE{refaddr($self)} = $safe;
+    $KEYS{$self} = $key;
+    $SAFE{$self} = $safe;
 
     for my $object (@{$self->all_groups}, @{$self->all_entries(history => 1)}) {
         $object->kdbx($self);
@@ -1159,11 +1158,11 @@ state. Returns itself to allow method chaining.
 
 sub _safe {
     my $self = shift;
-    $SAFE{refaddr($self)} = shift if @_;
-    $SAFE{refaddr($self)};
+    $SAFE{$self} = shift if @_;
+    $SAFE{$self};
 }
 
-sub _remove_safe { delete $SAFE{refaddr($_[0])} }
+sub _remove_safe { delete $SAFE{$_[0]} }
 
 sub lock {
     my $self = shift;
@@ -1277,8 +1276,8 @@ dumper when loading or saving a KDBX file.
 
 sub key {
     my $self = shift;
-    $KEYS{refaddr($self)} = File::KDBX::Key->new(@_) if @_;
-    $KEYS{refaddr($self)};
+    $KEYS{$self} = File::KDBX::Key->new(@_) if @_;
+    $KEYS{$self};
 }
 
 =method composite_key

diff --git a/lib/File/KDBX/Entry.pm b/lib/File/KDBX/Entry.pm
index c4c67b7f73dc335d0449e15a667a332e4ea5f9f3..c124b94203adf169a84aeec91374b2a6ad4e6324 100644 (file)
--- a/lib/File/KDBX/Entry.pm
+++ b/lib/File/KDBX/Entry.pm
@@ -10,9 +10,10 @@ use Encode qw(encode);
 use File::KDBX::Constants qw(:history :icon);
 use File::KDBX::Error;
 use File::KDBX::Util qw(:function :uri generate_uuid load_optional);
+use Hash::Util::FieldHash;
 use List::Util qw(sum0);
-use Ref::Util qw(is_plain_hashref is_ref);
-use Scalar::Util qw(looks_like_number refaddr);
+use Ref::Util qw(is_plain_hashref);
+use Scalar::Util qw(looks_like_number);
 use Storable qw(dclone);
 use Time::Piece;
 use boolean;
@@ -169,7 +170,7 @@ sub uuid {
         for my $entry (@{$self->history}) {
             $entry->{uuid} = $uuid;
         }
-        # if (defined $old_uuid and my $kdbx = $KDBX{refaddr($self)}) {
+        # if (defined $old_uuid and my $kdbx = $KDBX{$self}) {
         #     $kdbx->_update_entry_uuid($old_uuid, $uuid, $self);
         # }
     }
@@ -363,7 +364,7 @@ sub _expand_placeholder {
     }
     return if !defined $File::KDBX::PLACEHOLDERS{$placeholder_key};
 
-    my $local_key = join('/', refaddr($self), $placeholder_key);
+    my $local_key = join('/', Hash::Util::FieldHash::id($self), $placeholder_key);
     local $PLACEHOLDERS{$local_key} = my $handler = $PLACEHOLDERS{$local_key} // do {
         my $handler = $File::KDBX::PLACEHOLDERS{$placeholder_key} or next;
         memoize recurse_limit($handler, $PLACEHOLDER_MAX_DEPTH, sub {

diff --git a/lib/File/KDBX/Group.pm b/lib/File/KDBX/Group.pm
index 3aa562ac7631bf0d85a169b2520fec68c0b4c6ac..652d3aae3a7b05334971929ecf70482a46b2d46b 100644 (file)
--- a/lib/File/KDBX/Group.pm
+++ b/lib/File/KDBX/Group.pm
@@ -8,9 +8,10 @@ use Devel::GlobalDestruction;
 use File::KDBX::Constants qw(:icon);
 use File::KDBX::Error;
 use File::KDBX::Util qw(generate_uuid);
+use Hash::Util::FieldHash;
 use List::Util qw(sum0);
 use Ref::Util qw(is_ref);
-use Scalar::Util qw(blessed refaddr);
+use Scalar::Util qw(blessed);
 use Time::Piece;
 use boolean;
 use namespace::clean;
@@ -77,7 +78,7 @@ sub uuid {
         my %args = @_ % 2 == 1 ? (uuid => shift, @_) : @_;
         my $old_uuid = $self->{uuid};
         my $uuid = $self->{uuid} = delete $args{uuid} // generate_uuid;
-        # if (defined $old_uuid and my $kdbx = $KDBX{refaddr($self)}) {
+        # if (defined $old_uuid and my $kdbx = $KDBX{$self}) {
         #     $kdbx->_update_group_uuid($old_uuid, $uuid, $self);
         # }
     }
@@ -248,7 +249,7 @@ Determine if a group is the root group of its associated database.
 sub is_root {
     my $self = shift;
     my $kdbx = eval { $self->kdbx } or return;
-    return refaddr($kdbx->root) == refaddr($self);
+    return Hash::Util::FieldHash::id($kdbx->root) == Hash::Util::FieldHash::id($self);
 }
 
 =method path

diff --git a/lib/File/KDBX/IO.pm b/lib/File/KDBX/IO.pm
index 5d183473b656199a011202782721db69f1f6f98e..48c8e1908a842be7c8c82ac23b55ad7a8d5de4f8 100644 (file)
--- a/lib/File/KDBX/IO.pm
+++ b/lib/File/KDBX/IO.pm
@@ -43,6 +43,7 @@ sub new {
 
 sub DESTROY {
     return if in_global_destruction;
+    local ($., $@, $!, $^E, $?);
     my $self = shift;
     $self->close;
 }

diff --git a/lib/File/KDBX/Key.pm b/lib/File/KDBX/Key.pm
index 8fdb0ff9a88b7a43b483ff3f5ba50b1e48b585a1..8a5796568bd9c2c2d03a6d97723826a5245e4c02 100644 (file)
--- a/lib/File/KDBX/Key.pm
+++ b/lib/File/KDBX/Key.pm
@@ -8,14 +8,15 @@ use Devel::GlobalDestruction;
 use File::KDBX::Error;
 use File::KDBX::Safe;
 use File::KDBX::Util qw(erase);
+use Hash::Util::FieldHash qw(fieldhashes);
 use Module::Load;
 use Ref::Util qw(is_arrayref is_coderef is_hashref is_ref is_scalarref);
-use Scalar::Util qw(blessed openhandle refaddr);
+use Scalar::Util qw(blessed openhandle);
 use namespace::clean;
 
 our $VERSION = '999.999'; # VERSION
 
-my %SAFE;
+fieldhashes \my %SAFE;
 
 =method new
 
@@ -55,7 +56,10 @@ sub new {
     return $self;
 }
 
-sub DESTROY { !in_global_destruction and do { $_[0]->_clear_raw_key; erase \$_[0]->{primitive} } }
+sub DESTROY {
+    local ($., $@, $!, $^E, $?);
+    !in_global_destruction and do { $_[0]->_clear_raw_key; eval { erase \$_[0]->{primitive} } }
+}
 
 =method init
 
@@ -191,10 +195,10 @@ Get whether or not the key's raw secret is currently in memory protection.
 
 =cut
 
-sub is_hidden { !!$SAFE{refaddr($_[0])} }
+sub is_hidden { !!$SAFE{$_[0]} }
 
-sub _safe     { $SAFE{refaddr($_[0])} }
-sub _new_safe { $SAFE{refaddr($_[0])} = File::KDBX::Safe->new }
+sub _safe     { $SAFE{$_[0]} }
+sub _new_safe { $SAFE{$_[0]} = File::KDBX::Safe->new }
 
 1;
 __END__

diff --git a/lib/File/KDBX/Object.pm b/lib/File/KDBX/Object.pm
index e1c8c8e1b2e9f8d841f8ab41b66f77254d664632..9cc33ca79cae07f1923611cb5571c6d39300dbaa 100644 (file)
--- a/lib/File/KDBX/Object.pm
+++ b/lib/File/KDBX/Object.pm
@@ -7,14 +7,14 @@ use strict;
 use Devel::GlobalDestruction;
 use File::KDBX::Error;
 use File::KDBX::Util qw(:uuid);
+use Hash::Util::FieldHash qw(fieldhashes);
 use Ref::Util qw(is_arrayref is_plain_hashref is_ref);
-use Scalar::Util qw(blessed refaddr weaken);
+use Scalar::Util qw(blessed weaken);
 use namespace::clean;
 
 our $VERSION = '999.999'; # VERSION
 
-my %KDBX;
-my %PARENT;
+fieldhashes \my (%KDBX, %PARENT);
 
 =method new
 
@@ -99,13 +99,6 @@ sub init {
     return $self;
 }
 
-sub DESTROY {
-    return if in_global_destruction;
-    my $self = shift;
-    delete $KDBX{refaddr($self)};
-    delete $PARENT{refaddr($self)};
-}
-
 =method wrap
 
     $object = File::KDBX::Object->wrap($object);
@@ -191,19 +184,21 @@ sub STORABLE_freeze {
     delete $copy->{groups}  if !$CLONE{groups};
     delete $copy->{history} if !$CLONE{history};
 
-    return refaddr($self) || '', $copy;
+    return ($cloning ? Hash::Util::FieldHash::id($self) : ''), $copy;
 }
 
 sub STORABLE_thaw {
     my $self    = shift;
     my $cloning = shift;
     my $addr    = shift;
-    my $clone   = shift;
+    my $copy    = shift;
 
-    @$self{keys %$clone} = values %$clone;
+    @$self{keys %$copy} = values %$copy;
 
-    my $kdbx = $KDBX{$addr};
-    $self->kdbx($kdbx) if $kdbx;
+    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')) {
@@ -215,7 +210,7 @@ sub STORABLE_thaw {
                 local $CLONE{history}               = 1;
                 local $CLONE{reference_password}    = 0;
                 local $CLONE{reference_username}    = 0;
-                bless Storable::dclone({%$clone}), 'File::KDBX::Entry';
+                bless Storable::dclone({%$copy}), 'File::KDBX::Entry';
             };
             my $txn = $self->begin_work($clone_obj);
             if ($CLONE{reference_password}) {
@@ -242,17 +237,16 @@ Get or set the L<File::KDBX> instance associated with this object.
 sub kdbx {
     my $self = shift;
     $self = $self->new if !ref $self;
-    my $addr = refaddr($self);
     if (@_) {
-        $KDBX{$addr} = shift;
-        if (defined $KDBX{$addr}) {
-            weaken $KDBX{$addr};
+        if (my $kdbx = shift) {
+            $KDBX{$self} = $kdbx;
+            weaken $KDBX{$self};
         }
         else {
-            delete $KDBX{$addr};
+            delete $KDBX{$self};
         }
     }
-    $KDBX{$addr} or throw 'Object is disassociated from a KDBX database', object => $self;
+    $KDBX{$self} or throw 'Object is disassociated from a KDBX database', object => $self;
 }
 
 =method id
@@ -285,18 +279,18 @@ Get the parent group to which an object belongs or C<undef> if it belongs to no
 
 sub group {
     my $self = shift;
-    my $addr = refaddr($self);
-    if (my $group = $PARENT{$addr}) {
+    my $addr = Hash::Util::FieldHash::id($self);
+    if (my $group = $PARENT{$self}) {
         my $method = $self->_parent_container;
         for my $object (@{$group->$method}) {
-            return $group if $addr == refaddr($object);
+            return $group if $addr == Hash::Util::FieldHash::id($object);
         }
-        delete $PARENT{$addr};
+        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{$addr} = $group; weaken $PARENT{$addr};
+    $PARENT{$self} = $group; weaken $PARENT{$self};
     return $group;
 }
 
@@ -305,10 +299,11 @@ sub parent { shift->group(@_) }
 sub _set_group {
     my $self = shift;
     if (my $parent = shift) {
-        $PARENT{refaddr($self)} = $parent;
+        $PARENT{$self} = $parent;
+        weaken $PARENT{$self};
     }
     else {
-        delete $PARENT{refaddr($self)};
+        delete $PARENT{$self};
     }
     return $self;
 }
@@ -331,16 +326,16 @@ sub lineage {
     my $self = shift;
     my $base = shift;
 
-    my $base_addr = $base ? refaddr($base) : 0;
+    my $base_addr = $base ? Hash::Util::FieldHash::id($base) : 0;
 
     # try leaf to root
     my @path;
     my $o = $self;
     while ($o = $o->parent) {
         unshift @path, $o;
-        last if $base_addr == refaddr($o);
+        last if $base_addr == Hash::Util::FieldHash::id($o);
     }
-    return \@path if @path && ($base_addr == refaddr($path[0]) || $path[0]->is_root);
+    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);
@@ -473,14 +468,14 @@ sub _wrap_group {
     my $self  = shift;
     my $group = shift;
     require File::KDBX::Group;
-    return File::KDBX::Group->wrap($group, $KDBX{refaddr($self)});
+    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{refaddr($self)});
+    return File::KDBX::Entry->wrap($entry, $KDBX{$self});
 }
 
 sub TO_JSON { +{%{$_[0]}} }

diff --git a/lib/File/KDBX/Util.pm b/lib/File/KDBX/Util.pm
index a074d3e163f2641b5d1936d442a6f7efedefdcc0..c970683694fcef37ff0086c2c5a7acc5d54f3efa 100644 (file)
--- a/lib/File/KDBX/Util.pm
+++ b/lib/File/KDBX/Util.pm
@@ -10,8 +10,8 @@ use Exporter qw(import);
 use File::KDBX::Error;
 use List::Util 1.33 qw(any all);
 use Module::Load;
-use Ref::Util qw(is_arrayref is_coderef is_hashref is_ref is_refref is_scalarref is_ref);
-use Scalar::Util qw(blessed isdual looks_like_number readonly refaddr);
+use Ref::Util qw(is_arrayref is_coderef is_hashref is_ref is_refref is_scalarref);
+use Scalar::Util qw(blessed readonly);
 use namespace::clean -except => 'import';
 
 our $VERSION = '999.999'; # VERSION