Upgrade to Tie::RefHash 1.34, by Yuval Kogman

p4raw-id: //depot/perl@28177

5 files changed, 208 insertions, 41 deletions

diff --git a/lib/Tie/RefHash.pm b/lib/Tie/RefHash.pm
index e2ce01d218..30a90d98af 100644
--- a/lib/Tie/RefHash.pm
+++ b/lib/Tie/RefHash.pm
@@ -1,6 +1,8 @@
 package Tie::RefHash;
 
-our $VERSION = 1.33;
+use vars qw/$VERSION/;
+
+$VERSION = "1.34";
 
 =head1 NAME
 
@@ -53,6 +55,24 @@ 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
@@ -69,15 +89,33 @@ use Tie::Hash;
 use vars '@ISA';
 @ISA = qw(Tie::Hash);
 use strict;
+use Carp qw/croak/;
 
 BEGIN {
+  # 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 };
   require Scalar::Util if $usethreads; # we need weaken()
 }
 
-require overload; # to support objects with overloaded ""
+BEGIN {
+  # create a refaddr function
+
+  if ( eval { require Scalar::Util; 1 } ) {
+    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
 
@@ -105,24 +143,41 @@ sub TIEHASH {
   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;
   # 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;
+  @thread_object_registry = grep { defined && do { $_->_reindex_keys; 1 } } @thread_object_registry;
   $count = 0; # we just cleaned up
 }
 
-sub CLONE_OBJ {
-  my $self = shift;
+sub _reindex_keys {
+  my ( $self, $extra_keys ) = @_;
   # rehash all the ref keys based on their new StrVal
-  %{ $self->[0] } = map { overload::StrVal($_->[0]) => $_ } values %{ $self->[0] };
+  %{ $self->[0] } = map { refaddr($_->[0]) => $_ } (values(%{ $self->[0] }), @{ $extra_keys || [] });
 }
 
 sub FETCH {
   my($s, $k) = @_;
   if (ref $k) {
-      my $kstr = overload::StrVal($k);
+      my $kstr = refaddr($k);
       if (defined $s->[0]{$kstr}) {
         $s->[0]{$kstr}[1];
       }
@@ -138,7 +193,7 @@ sub FETCH {
 sub STORE {
   my($s, $k, $v) = @_;
   if (ref $k) {
-    $s->[0]{overload::StrVal($k)} = [$k, $v];
+    $s->[0]{refaddr($k)} = [$k, $v];
   }
   else {
     $s->[1]{$k} = $v;
@@ -149,19 +204,19 @@ sub STORE {
 sub DELETE {
   my($s, $k) = @_;
   (ref $k)
-    ? (delete($s->[0]{overload::StrVal($k)}) || [])->[1]
+    ? (delete($s->[0]{refaddr($k)}) || [])->[1]
     : delete($s->[1]{$k});
 }
 
 sub EXISTS {
   my($s, $k) = @_;
-  (ref $k) ? exists($s->[0]{overload::StrVal($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
+  keys %{$s->[0]};  # reset iterator
+  keys %{$s->[1]};  # reset iterator
   $s->[2] = 0;      # flag for iteration, see NEXTKEY
   $s->NEXTKEY;
 }
diff --git a/lib/Tie/RefHash/rebless.t b/lib/Tie/RefHash/rebless.t
new file mode 100644
index 0000000000..4ae40f43fe
--- /dev/null
+++ b/lib/Tie/RefHash/rebless.t
@@ -0,0 +1,36 @@
+#!/usr/bin/perl -T -w
+
+BEGIN {
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = '../lib';
+    }
+}
+
+use strict;
+
+use Tie::RefHash;
+
+{
+  package Moose;
+  sub new { bless { }, shift };
+
+  package Elk;
+  use vars qw/@ISA/;
+  @ISA = "Moose";
+}
+
+$\ = "\n";
+print "1..2";
+
+my $obj = Moose->new;
+
+tie my %hash, "Tie::RefHash";
+
+$hash{$obj} = "magic";
+
+print ( ( $hash{$obj} eq "magic" ) ? "" : "not ", "ok - keyed before rebless" );
+
+bless $obj, "Elk";
+
+print ( ( $hash{$obj} eq "magic" ) ? "" : "not ", "ok - still the same");
diff --git a/lib/Tie/RefHash/refhash.t b/lib/Tie/RefHash/refhash.t
index 3415cecef1..d19f7d3593 100644
--- a/lib/Tie/RefHash/refhash.t
+++ b/lib/Tie/RefHash/refhash.t
@@ -1,4 +1,4 @@
-#!/usr/bin/perl -w
+#!/usr/bin/perl -T -w
 # 
 # Basic test suite for Tie::RefHash and Tie::RefHash::Nestable.
 # 
@@ -10,14 +10,17 @@
 # 
 
 BEGIN {
-    chdir 't' if -d 't';
-    @INC = '.'; 
-    push @INC, '../lib';
-    require Config;
-    if (($Config::Config{'extensions'} !~ m!\bData/Dumper\b!) ){
-	print "1..0 # Skip -- Perl configured without Data::Dumper module\n";
-	exit 0;
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = '../lib';
     }
+}
+
+BEGIN {
+  unless ( eval { require Data::Dumper; 1 } ) {
+    print "1..0 # Skip -- Data::Dumper is not available\n";
+    exit 0;
+  }
 }    
 
 use strict;
@@ -221,7 +224,7 @@ sub runtests {
             s/ at .+ line \d+\.$//mg;
             s/ at .+ line \d+, at .*//mg;
             s/ at .+ line \d+, near .*//mg;
-	    s/(uninitialized value)( within)? [\$@%].*? in /$1 in /g;
+      s/(uninitialized value)( within)? [\$@%].*? in /$1 in /g;
         }
 
         my (@warnings, %seen);
diff --git a/lib/Tie/RefHash/storable.t b/lib/Tie/RefHash/storable.t
new file mode 100644
index 0000000000..6c28b77a54
--- /dev/null
+++ b/lib/Tie/RefHash/storable.t
@@ -0,0 +1,63 @@
+#!/usr/bin/perl -T -w
+
+BEGIN {
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = '../lib';
+    }
+}
+
+BEGIN {
+  unless ( eval { require Storable; 1 } ){
+    print "1..0 # Skip -- Storable is not available\n";
+    exit 0;
+  }
+}
+
+use strict;
+
+use Tie::RefHash;
+
+use Storable qw/dclone nfreeze thaw/;
+
+$\ = "\n";
+print "1..24";
+
+sub ok ($$) {
+    print ( ( $_[0] ? "" : "not " ), "ok - $_[1]" );
+}
+
+sub is ($$$) {
+    print ( ( ( $_[0] eq $_[1] ) ? "" : "not "), "ok - $_[2]" );
+}
+
+sub isa_ok ($$) {
+    ok( eval { $_[0]->isa($_[1]) }, "the object isa $_[1]");
+}
+
+tie my %hash, "Tie::RefHash";
+
+my $key = { foo => 1 };
+$hash{$key} = "value";
+$hash{non_ref} = "other";
+
+foreach my $clone ( \%hash, dclone(\%hash), thaw(nfreeze(\%hash)) ){
+
+  ok( tied(%$clone), "copy is tied");
+  isa_ok( tied(%$clone), "Tie::RefHash" );
+
+  my @keys = keys %$clone;
+  is( scalar(@keys), 2, "one key in clone");
+  my $key = ref($keys[0]) ? shift @keys : pop @keys;
+  my $reg = $keys[0];
+
+  ok( ref($key), "key is a ref after clone" );
+  is( $key->{foo}, 1, "key serialized ok");
+
+  is( $clone->{$key}, "value", "and is still pointing at the same value" );
+
+  ok( !ref($reg), "regular key is non ref" );
+  is( $clone->{$reg}, "other", "and is also a valid key" );
+}
+
+
diff --git a/lib/Tie/RefHash/threaded.t b/lib/Tie/RefHash/threaded.t
index a2b63e9478..d6caed430f 100644
--- a/lib/Tie/RefHash/threaded.t
+++ b/lib/Tie/RefHash/threaded.t
@@ -1,27 +1,37 @@
-#!./perl
+#!/usr/bin/perl -T -w
 
 BEGIN {
-    chdir 't' if -d 't';
-    @INC = qw(../lib);
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = '../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 Config;
+  if ( $Config{usethreads} and !$Config{use5005threads} ) {
+    require threads; "threads"->import;
+    print "1..14\n";
+  } else {
+    print "1..0 # Skip -- threads aren't enabled in your perl\n";
+    exit 0;
+  }
 }
 
 use Tie::RefHash;
 
+$\ = "\n";
+sub ok ($$) {
+  print ( ( $_[0] ? "" : "not " ), "ok - $_[1]" );
+}
+
+sub is ($$$) {
+  print ( ( ( $_[0] eq $_[1] ) ? "" : "not "), "ok - $_[2]" );
+}
+
 tie my %hash, "Tie::RefHash";
 
 my $r1 = {};
@@ -37,18 +47,18 @@ 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" );
+  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{$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{$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" );
+  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" );
+  is( join("\0",sort keys %hash), join("\0",sort $r1, $r2, $v1), "keys are ok" );
 });
 
 $th->join;