Perl_hv_placeholders_get() actually takes a const HV *hv.

[perl5.git] / lib / Tie / RefHash.pm

diff --git a/lib/Tie/RefHash.pm b/lib/Tie/RefHash.pm
index b4485de..f95bf41 100644 (file)
--- a/lib/Tie/RefHash.pm
+++ b/lib/Tie/RefHash.pm
@@ -1,6 +1,10 @@
 package Tie::RefHash;
 
-our $VERSION = 1.30;
+use vars qw/$VERSION/;
+
+$VERSION = "1.38";
+
+use 5.005;
 
 =head1 NAME
 
@@ -53,16 +57,30 @@ store a reference to one of your own hashes in the tied hash.
        print ref($_), "\n";
     }
 
+=head1 THREAD SUPPORT
+
+L<Tie::RefHash> fully supports threading using the C<CLONE> method.
+
+=head1 STORABLE SUPPORT
+
+L<Storable> hooks are provided for semantically correct serialization and
+cloning of tied refhashes.
+
+=head1 RELIC SUPPORT
+
+This version of Tie::RefHash seems to no longer work with 5.004. This has not
+been throughly investigated. Patches welcome ;-)
+
+=head1 MAINTAINER
+
+Yuval Kogman E<lt>nothingmuch@woobling.orgE<gt>
+
 =head1 AUTHOR
 
 Gurusamy Sarathy        gsar@activestate.com
 
 'Nestable' by Ed Avis   ed@membled.com
 
-=head1 VERSION
-
-Version 1.30
-
 =head1 SEE ALSO
 
 perl(1), perlfunc(1), perltie(1)
@@ -73,6 +91,39 @@ use Tie::Hash;
 use vars '@ISA';
 @ISA = qw(Tie::Hash);
 use strict;
+use Carp qw/croak/;
+
+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 ) {
+    Scalar::Util->import("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 {
   my $c = shift;
@@ -81,14 +132,70 @@ sub TIEHASH {
   while (@_) {
     $s->STORE(shift, shift);
   }
+
+  if (_HAS_THREADS ) {
+
+    if ( _HAS_WEAKEN ) {
+      # 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;
+      }
+    } else {
+      $count++; # used in the warning
+    }
+  }
+
   return $s;
 }
 
+my $storable_format_version = join("/", __PACKAGE__, "0.01");
+
+sub STORABLE_freeze {
+  my ( $self, $is_cloning ) = @_;
+  my ( $refs, $reg ) = @$self;
+  return ( $storable_format_version, [ values %$refs ], $reg );
+}
+
+sub STORABLE_thaw {
+  my ( $self, $is_cloning, $version, $refs, $reg ) = @_;
+  croak "incompatible versions of Tie::RefHash between freeze and thaw"
+    unless $version eq $storable_format_version;
+
+  @$self = ( {}, $reg );
+  $self->_reindex_keys( $refs );
+}
+
+sub CLONE {
+  my $pkg = shift;
+
+  if ( $count and not _HAS_WEAKEN ) {
+    warn "Tie::RefHash is not threadsafe without Scalar::Util::weaken";
+  }
+
+  # 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;
+  $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 { refaddr($_->[0]) => $_ } (values(%{ $self->[0] }), @{ $extra_keys || [] });
+}
+
 sub FETCH {
   my($s, $k) = @_;
   if (ref $k) {
-      if (defined $s->[0]{"$k"}) {
-        $s->[0]{"$k"}[1];
+      my $kstr = refaddr($k);
+      if (defined $s->[0]{$kstr}) {
+        $s->[0]{$kstr}[1];
       }
       else {
         undef;
@@ -102,7 +209,7 @@ sub FETCH {
 sub STORE {
   my($s, $k, $v) = @_;
   if (ref $k) {
-    $s->[0]{"$k"} = [$k, $v];
+    $s->[0]{refaddr($k)} = [$k, $v];
   }
   else {
     $s->[1]{$k} = $v;
@@ -112,19 +219,21 @@ sub STORE {
 
 sub DELETE {
   my($s, $k) = @_;
-  (ref $k) ? delete($s->[0]{"$k"}) : delete($s->[1]{$k});
+  (ref $k)
+    ? (delete($s->[0]{refaddr($k)}) || [])->[1]
+    : delete($s->[1]{$k});
 }
 
 sub EXISTS {
   my($s, $k) = @_;
-  (ref $k) ? exists($s->[0]{"$k"}) : exists($s->[1]{$k});
+  (ref $k) ? exists($s->[0]{refaddr($k)}) : exists($s->[1]{$k});
 }
 
 sub FIRSTKEY {
   my $s = shift;
-  keys %{$s->[0]};     # reset iterator
-  keys %{$s->[1]};     # reset iterator
-  $s->[2] = 0;
+  keys %{$s->[0]};  # reset iterator
+  keys %{$s->[1]};  # reset iterator
+  $s->[2] = 0;      # flag for iteration, see NEXTKEY
   $s->NEXTKEY;
 }
 
@@ -133,7 +242,7 @@ sub NEXTKEY {
   my ($k, $v);
   if (!$s->[2]) {
     if (($k, $v) = each %{$s->[0]}) {
-      return $s->[0]{"$k"}[0];
+      return $v->[0];
     }
     else {
       $s->[2] = 1;