From 81604125cc023132207802b4ae0ab4cea12c17fd Mon Sep 17 00:00:00 2001 From: Charles McGarvey Date: Tue, 19 Apr 2022 11:00:04 -0600 Subject: [PATCH] Add better thread safety --- lib/File/KDBX.pm | 25 ++++++++-------- lib/File/KDBX/Entry.pm | 9 +++--- lib/File/KDBX/Group.pm | 7 +++-- lib/File/KDBX/IO.pm | 1 + lib/File/KDBX/Key.pm | 16 +++++++---- lib/File/KDBX/Object.pm | 63 +++++++++++++++++++---------------------- lib/File/KDBX/Util.pm | 4 +-- 7 files changed, 63 insertions(+), 62 deletions(-) diff --git a/lib/File/KDBX.pm b/lib/File/KDBX.pm index 3f52d6c..e5fcb27 100644 --- 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 c4c67b7..c124b94 100644 --- 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 3aa562a..652d3aa 100644 --- 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 5d18347..48c8e19 100644 --- 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 8fdb0ff..8a57965 100644 --- 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 e1c8c8e..9cc33ca 100644 --- 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 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 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 a074d3e..c970683 100644 --- 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 -- 2.43.0