CLONE for Tie::RefHash

Message-ID: <20060327133407.GA16901@woobling.org>

(also rename old Tie::RefHash test, so several test files
are allowed.)

p4raw-id: //depot/perl@27628

4 files changed, 98 insertions, 6 deletions

diff --git a/MANIFEST b/MANIFEST
index e614095a3a..26d0054d59 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -2539,7 +2539,8 @@ lib/Tie/Hash.pm			Base class for tied hashes
 lib/Tie/Memoize.pm		Base class for memoized tied hashes
 lib/Tie/Memoize.t		Test for Memoize.t
 lib/Tie/RefHash.pm		Base class for tied hashes with references as keys
-lib/Tie/RefHash.t		Test for Tie::RefHash and Tie::RefHash::Nestable
+lib/Tie/RefHash/refhash.t	Test for Tie::RefHash and Tie::RefHash::Nestable
+lib/Tie/RefHash/threaded.t	Test for Tie::RefHash with threads
 lib/Tie/Scalar.pm		Base class for tied scalars
 lib/Tie/Scalar.t		See if Tie::Scalar works
 lib/Tie/SubstrHash.pm		Compact hash for known key, value and table size
diff --git a/lib/Tie/RefHash.pm b/lib/Tie/RefHash.pm
index cfcdd5b5a1..e2ce01d218 100644
--- a/lib/Tie/RefHash.pm
+++ b/lib/Tie/RefHash.pm
@@ -1,6 +1,6 @@
 package Tie::RefHash;
 
-our $VERSION = 1.32;
+our $VERSION = 1.33;
 
 =head1 NAME
 
@@ -59,10 +59,6 @@ Gurusamy Sarathy        gsar@activestate.com
 
 'Nestable' by Ed Avis   ed@membled.com
 
-=head1 VERSION
-
-Version 1.32
-
 =head1 SEE ALSO
 
 perl(1), perlfunc(1), perltie(1)
@@ -74,8 +70,17 @@ use vars '@ISA';
 @ISA = qw(Tie::Hash);
 use strict;
 
+BEGIN {
+  use Config ();
+  my $usethreads = $Config::Config{usethreads}; # && exists $INC{"threads.pm"}
+  *_HAS_THREADS = $usethreads ? sub () { 1 } : sub () { 0 };
+  require Scalar::Util if $usethreads; # we need weaken()
+}
+
 require overload; # to support objects with overloaded ""
 
+my (@thread_object_registry, $count); # used by the CLONE method to rehash the keys after their refaddr changed
+
 sub TIEHASH {
   my $c = shift;
   my $s = [];
@@ -83,9 +88,37 @@ sub TIEHASH {
   while (@_) {
     $s->STORE(shift, shift);
   }
+
+  if (_HAS_THREADS) {
+    # remember the object so that we can rekey it on CLONE
+    push @thread_object_registry, $s;
+    # but make this a weak reference, so that there are no leaks
+    Scalar::Util::weaken( $thread_object_registry[-1] );
+
+    if ( ++$count > 1000 ) {
+      # this ensures we don't fill up with a huge array dead weakrefs
+      @thread_object_registry = grep { defined } @thread_object_registry;
+      $count = 0;
+    }
+  }
+
   return $s;
 }
 
+sub CLONE {
+  my $pkg = shift;
+  # 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 { $_->CLONE_OBJ; 1 } } @thread_object_registry;
+  $count = 0; # we just cleaned up
+}
+
+sub CLONE_OBJ {
+  my $self = shift;
+  # rehash all the ref keys based on their new StrVal
+  %{ $self->[0] } = map { overload::StrVal($_->[0]) => $_ } values %{ $self->[0] };
+}
+
 sub FETCH {
   my($s, $k) = @_;
   if (ref $k) {
diff --git a/lib/Tie/RefHash.t b/lib/Tie/RefHash/refhash.t
index 3415cecef1..3415cecef1 100644
--- a/lib/Tie/RefHash.t
+++ b/lib/Tie/RefHash/refhash.t
diff --git a/lib/Tie/RefHash/threaded.t b/lib/Tie/RefHash/threaded.t
new file mode 100644
index 0000000000..a2b63e9478
--- /dev/null
+++ b/lib/Tie/RefHash/threaded.t
@@ -0,0 +1,58 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = qw(../lib);
+}
+
+use strict;
+use warnings;
+
+BEGIN {
+    # this is sucky because threads.pm has to be loaded before Test::Builder
+    use Config;
+    if ( $Config{usethreads} ) {
+	require threads; threads->import;
+	require Test::More; Test::More->import( tests => 14 );
+    } else {
+	require Test::More;
+	Test::More->import( skip_all => "threads aren't enabled in your perl" )
+    }
+}
+
+use Tie::RefHash;
+
+tie my %hash, "Tie::RefHash";
+
+my $r1 = {};
+my $r2 = [];
+my $v1 = "foo";
+
+$hash{$r1} = "hash";
+$hash{$r2} = "array";
+$hash{$v1} = "string";
+
+is( $hash{$v1}, "string", "fetch by string before clone ($v1)" );
+is( $hash{$r1}, "hash", "fetch by ref before clone ($r1)" );
+is( $hash{$r2}, "array", "fetch by ref before clone ($r2)" );
+
+my $th = threads->create(sub {
+    is( scalar keys %hash, 3, "key count is OK" );
+
+    ok( exists $hash{$v1}, "string key exists ($v1)" );
+    is( $hash{$v1}, "string", "fetch by string" );
+
+    ok( exists $hash{$r1}, "ref key exists ($r1)" );
+    is( $hash{$r1}, "hash", "fetch by ref" );
+
+    ok( exists $hash{$r2}, "ref key exists ($r2)" );
+    is( $hash{$r2}, "array", "fetch by ref" );
+
+    is_deeply( [ sort keys %hash ], [ sort $r1, $r2, $v1 ], "keys are ok" );
+});
+
+$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)" );