cpan/Tie-RefHash - Update to version 1.41

1.41 2024-08-25 22:32:19Z - fix leaks in @thread_object_registry (RT#64025, tusooa, #1 and Lukas Mai, #2) - fix incompatibility with Scalar::Util 1.65 and remove old refaddr fallback (Lukas Mai, #3)
Perl · Aug 26, 2024 · f37395a · f37395a
1 parent 34d9693
commit f37395a
Show file tree

Hide file tree

Showing 3 changed files with 52 additions and 34 deletions.
diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl
@@ -1211,7 +1211,8 @@ package Maintainers;
     },
 
     'Tie::RefHash' => {
-        'DISTRIBUTION' => 'ETHER/Tie-RefHash-1.40.tar.gz',
+        'DISTRIBUTION' => 'ETHER/Tie-RefHash-1.41.tar.gz',
+        'SYNCINFO'     => 'mauke on Mon Aug 26 04:28:51 2024',
         'FILES'        => q[cpan/Tie-RefHash],
         'EXCLUDED'     => [
             qr{^t/00-},

diff --git a/cpan/Tie-RefHash/lib/Tie/RefHash.pm b/cpan/Tie-RefHash/lib/Tie/RefHash.pm
@@ -1,7 +1,7 @@
-package Tie::RefHash; # git description: Tie-RefHash-1.39-10-g2cfa4bd
+package Tie::RefHash; # git description: v1.40-9-g23812d9
 # ABSTRACT: Use references as hash keys
 
-our $VERSION = '1.40';
+our $VERSION = '1.41';
 
 #pod =head1 SYNOPSIS
 #pod
@@ -76,36 +76,18 @@ our @ISA = qw(Tie::Hash);
 use strict;
 use Carp ();
 
+# Tie::RefHash::Weak (until at least 0.09) assumes we define a refaddr()
+# function, so just import the one from Scalar::Util
+use Scalar::Util qw(refaddr);
+
 BEGIN {
-  local $@;
   # determine whether we need to take care of threads
   use Config ();
   my $usethreads = $Config::Config{usethreads}; # && exists $INC{"threads.pm"}
   *_HAS_THREADS = $usethreads ? sub () { 1 } : sub () { 0 };
-  *_HAS_SCALAR_UTIL = eval { require Scalar::Util; 1 } ? sub () { 1 } : sub () { 0 };
   *_HAS_WEAKEN = defined(&Scalar::Util::weaken) ? sub () { 1 } : sub () { 0 };
 }
 
-BEGIN {
-  # create a refaddr function
-
-  local $@;
-
-  if ( _HAS_SCALAR_UTIL ) {
-    *refaddr = sub { goto \&Scalar::Util::refaddr }
-  } else {
-    require overload;
-
-    *refaddr = sub {
-      if ( overload::StrVal($_[0]) =~ /\( 0x ([a-zA-Z0-9]+) \)$/x) {
-          return $1;
-      } else {
-        die "couldn't parse StrVal: " . overload::StrVal($_[0]);
-      }
-    };
-  }
-}
-
 my (@thread_object_registry, $count); # used by the CLONE method to rehash the keys after their refaddr changed
 
 sub TIEHASH {
@@ -127,6 +109,7 @@ sub TIEHASH {
       if ( ++$count > 1000 ) {
         # this ensures we don't fill up with a huge array dead weakrefs
         @thread_object_registry = grep defined, @thread_object_registry;
+        Scalar::Util::weaken( $_ ) for @thread_object_registry;
         $count = 0;
       }
     } else {
@@ -164,19 +147,20 @@ sub CLONE {
   # when the thread has been cloned all the objects need to be updated.
   # dead weakrefs are undefined, so we filter them out
   @thread_object_registry = grep defined && do { $_->_reindex_keys; 1 }, @thread_object_registry;
+  Scalar::Util::weaken( $_ ) for @thread_object_registry;
   $count = 0; # we just cleaned up
 }
 
 sub _reindex_keys {
   my ( $self, $extra_keys ) = @_;
   # rehash all the ref keys based on their new StrVal
-  %{ $self->[0] } = map +(Scalar::Util::refaddr($_->[0]) => $_), (values(%{ $self->[0] }), @{ $extra_keys || [] });
+  %{ $self->[0] } = map +(refaddr($_->[0]) => $_), (values(%{ $self->[0] }), @{ $extra_keys || [] });
 }
 
 sub FETCH {
   my($s, $k) = @_;
   if (ref $k) {
-      my $kstr = Scalar::Util::refaddr($k);
+      my $kstr = refaddr($k);
       if (defined $s->[0]{$kstr}) {
         $s->[0]{$kstr}[1];
       }
@@ -192,7 +176,7 @@ sub FETCH {
 sub STORE {
   my($s, $k, $v) = @_;
   if (ref $k) {
-    $s->[0]{Scalar::Util::refaddr($k)} = [$k, $v];
+    $s->[0]{refaddr($k)} = [$k, $v];
   }
   else {
     $s->[1]{$k} = $v;
@@ -203,13 +187,13 @@ sub STORE {
 sub DELETE {
   my($s, $k) = @_;
   (ref $k)
-    ? (delete($s->[0]{Scalar::Util::refaddr($k)}) || [])->[1]
+    ? (delete($s->[0]{refaddr($k)}) || [])->[1]
     : delete($s->[1]{$k});
 }
 
 sub EXISTS {
   my($s, $k) = @_;
-  (ref $k) ? exists($s->[0]{Scalar::Util::refaddr($k)}) : exists($s->[1]{$k});
+  (ref $k) ? exists($s->[0]{refaddr($k)}) : exists($s->[1]{$k});
 }
 
 sub FIRSTKEY {
@@ -268,7 +252,7 @@ Tie::RefHash - Use references as hash keys
 
 =head1 VERSION
 
-version 1.40
+version 1.41
 
 =head1 SYNOPSIS
 
@@ -343,7 +327,7 @@ Tie::RefHash::Nestable by Ed Avis <[email protected]>
 
 =head1 CONTRIBUTORS
 
-=for stopwords Yuval Kogman Karen Etheridge Florian Ragwitz Jerry D. Hedden
+=for stopwords Yuval Kogman Karen Etheridge Florian Ragwitz Lukas Mai Jerry D. Hedden tusooa
 
 =over 4
 
@@ -361,8 +345,16 @@ Florian Ragwitz <[email protected]>
 
 =item *
 
+Lukas Mai <[email protected]>
+
+=item *
+
 Jerry D. Hedden <[email protected]>
 
+=item *
+
+tusooa <[email protected]>
+
 =back
 
 =head1 COPYRIGHT AND LICENCE

diff --git a/cpan/Tie-RefHash/t/threaded.t b/cpan/Tie-RefHash/t/threaded.t
@@ -13,7 +13,6 @@ use strict;
 BEGIN {
     # this is sucky because threads.pm has to be loaded before Test::Builder
   use Config;
-  eval { require Scalar::Util };
 
   if ( $^O eq 'MSWin32' ) {
     print "1..0 # Skip -- this test is generally broken on windows for unknown reasons. If you can help debug this patches would be very welcome.\n";
@@ -22,13 +21,14 @@ BEGIN {
   if ( $Config{usethreads} and !$Config{use5005threads}
       and eval { +require threads; threads->import; 1 }
   ) {
-    print "1..14\n";
+    print "1..18\n";
   } else {
     print "1..0 # Skip -- threads aren't enabled in your perl";
     exit 0;
   }
 }
 
+use Scalar::Util qw(weaken);
 use Tie::RefHash;
 
 $\ = "\n";
@@ -74,3 +74,28 @@ $th->join;
 is( $hash{$v1}, "string", "fetch by string after clone, orig thread ($v1)" );
 is( $hash{$r1}, "hash", "fetch by ref after clone ($r1)" );
 is( $hash{$r2}, "array", "fetch by ref after clone ($r2)" );
+
+{
+    # RT 64025
+
+    my $ref;
+    {
+        tie my %local_hash, "Tie::RefHash";
+        $ref = tied %local_hash;
+        weaken $ref;
+        is( ref($ref), "Tie::RefHash", "[attempt 1] tie object exists" );
+    }
+    ok( !defined($ref), "[attempt 2] tie object is gone after hash goes out of scope" );
+
+    {
+        tie my %local_hash, "Tie::RefHash";
+        $ref = tied %local_hash;
+        weaken $ref;
+        is( ref($ref), "Tie::RefHash", "[attempt 2] tie object exists" );
+
+        for my $i (1 .. 1_000) {
+            tie my %tmp, "Tie::RefHash";  # churn
+        }
+    }
+    ok( !defined($ref), "[attempt 2] tie object is gone after hash goes out of scope" );
+}