Change 30319 by [EMAIL PROTECTED] on 2007/02/15 16:15:16
Integrate:
[ 27628]
Subject: CLONE for Tie::RefHash
From: Yuval Kogman <[EMAIL PROTECTED]>
Date: Mon, 27 Mar 2006 15:34:07 +0200
Message-ID: <[EMAIL PROTECTED]>
(also rename old Tie::RefHash test, so several test files
are allowed.)
[ 28177]
Upgrade to Tie::RefHash 1.34, by Yuval Kogman
Affected files ...
... //depot/maint-5.8/perl/MANIFEST#339 integrate
... //depot/maint-5.8/perl/lib/Tie/RefHash.pm#6 integrate
... //depot/maint-5.8/perl/lib/Tie/RefHash.t#6 delete
... //depot/maint-5.8/perl/lib/Tie/RefHash/rebless.t#1 branch
... //depot/maint-5.8/perl/lib/Tie/RefHash/refhash.t#1 branch
... //depot/maint-5.8/perl/lib/Tie/RefHash/storable.t#1 branch
... //depot/maint-5.8/perl/lib/Tie/RefHash/threaded.t#1 branch
Differences ...
==== //depot/maint-5.8/perl/MANIFEST#339 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST#338~30318~ 2007-02-15 06:56:36.000000000 -0800
+++ perl/MANIFEST 2007-02-15 08:15:16.000000000 -0800
@@ -2113,7 +2113,10 @@
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/rebless.t Test for Tie::RefHash with rebless
+lib/Tie/RefHash/storable.t Test for Tie::RefHash with storable
+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
==== //depot/maint-5.8/perl/lib/Tie/RefHash.pm#6 (text) ====
Index: perl/lib/Tie/RefHash.pm
--- perl/lib/Tie/RefHash.pm#5~24180~ 2005-04-06 09:20:17.000000000 -0700
+++ perl/lib/Tie/RefHash.pm 2007-02-15 08:15:16.000000000 -0800
@@ -1,6 +1,8 @@
package Tie::RefHash;
-our $VERSION = 1.32;
+use vars qw/$VERSION/;
+
+$VERSION = "1.34";
=head1 NAME
@@ -53,16 +55,30 @@
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>[EMAIL PROTECTED]<gt>
+
=head1 AUTHOR
Gurusamy Sarathy [EMAIL PROTECTED]
'Nestable' by Ed Avis [EMAIL PROTECTED]
-=head1 VERSION
-
-Version 1.32
-
=head1 SEE ALSO
perl(1), perlfunc(1), perltie(1)
@@ -73,8 +89,35 @@
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()
+}
+
+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]);
+ }
+ };
+ }
+}
-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;
@@ -83,13 +126,58 @@
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;
}
+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 { $_->_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) {
- my $kstr = overload::StrVal($k);
+ my $kstr = refaddr($k);
if (defined $s->[0]{$kstr}) {
$s->[0]{$kstr}[1];
}
@@ -105,7 +193,7 @@
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;
@@ -116,19 +204,19 @@
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;
}
==== //depot/maint-5.8/perl/lib/Tie/RefHash/rebless.t#1 (text) ====
Index: perl/lib/Tie/RefHash/rebless.t
--- /dev/null 2007-01-16 11:55:45.526841103 -0800
+++ perl/lib/Tie/RefHash/rebless.t 2007-02-15 08:15:16.000000000 -0800
@@ -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");
==== //depot/maint-5.8/perl/lib/Tie/RefHash/refhash.t#1 (text) ====
Index: perl/lib/Tie/RefHash/refhash.t
--- /dev/null 2007-01-16 11:55:45.526841103 -0800
+++ perl/lib/Tie/RefHash/refhash.t 2007-02-15 08:15:16.000000000 -0800
@@ -0,0 +1,331 @@
+#!/usr/bin/perl -T -w
+#
+# Basic test suite for Tie::RefHash and Tie::RefHash::Nestable.
+#
+# The testing is in two parts: first, run lots of tests on both a tied
+# hash and an ordinary un-tied hash, and check they give the same
+# answer. Then there are tests for those cases where the tied hashes
+# should behave differently to normal hashes, that is, when using
+# references as keys.
+#
+
+BEGIN {
+ 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;
+use Tie::RefHash;
+use Data::Dumper;
+my $numtests = 39;
+my $currtest = 1;
+print "1..$numtests\n";
+
+my $ref = []; my $ref1 = [];
+
+package Boustrophedon; # A class with overloaded "".
+sub new { my ($c, $s) = @_; bless \$s, $c }
+use overload '""' => sub { ${$_[0]} . reverse ${$_[0]} };
+package main;
+my $ox = Boustrophedon->new("foobar");
+
+# Test standard hash functionality, by performing the same operations
+# on a tied hash and on a normal hash, and checking that the results
+# are the same. This does of course assume that Perl hashes are not
+# buggy :-)
+#
+my @tests = standard_hash_tests();
+
+my @ordinary_results = runtests([EMAIL PROTECTED], undef);
+foreach my $class ('Tie::RefHash', 'Tie::RefHash::Nestable') {
+ my @tied_results = runtests([EMAIL PROTECTED], $class);
+ my $all_ok = 1;
+
+ die if @ordinary_results != @tied_results;
+ foreach my $i (0 .. $#ordinary_results) {
+ my ($or, $ow, $oe) = @{$ordinary_results[$i]};
+ my ($tr, $tw, $te) = @{$tied_results[$i]};
+
+ my $ok = 1;
+ local $^W = 0;
+ $ok = 0 if (defined($or) != defined($tr)) or ($or ne $tr);
+ $ok = 0 if (defined($ow) != defined($tw)) or ($ow ne $tw);
+ $ok = 0 if (defined($oe) != defined($te)) or ($oe ne $te);
+
+ if (not $ok) {
+ print STDERR
+ "failed for $class: $tests[$i]\n",
+ "ordinary hash gave:\n",
+ defined $or ? "\tresult: $or\n" : "\tundef result\n",
+ defined $ow ? "\twarning: $ow\n" : "\tno warning\n",
+ defined $oe ? "\texception: $oe\n" : "\tno exception\n",
+ "tied $class hash gave:\n",
+ defined $tr ? "\tresult: $tr\n" : "\tundef result\n",
+ defined $tw ? "\twarning: $tw\n" : "\tno warning\n",
+ defined $te ? "\texception: $te\n" : "\tno exception\n",
+ "\n";
+ $all_ok = 0;
+ }
+ }
+ test($all_ok);
+}
+
+# Now test Tie::RefHash's special powers
+my (%h, $h);
+$h = eval { tie %h, 'Tie::RefHash' };
+warn $@ if $@;
+test(not $@);
+test(ref($h) eq 'Tie::RefHash');
+test(defined(tied(%h)) and tied(%h) =~ /^Tie::RefHash/);
+$h{$ref} = 'cholet';
+test($h{$ref} eq 'cholet');
+test(exists $h{$ref});
+test((keys %h) == 1);
+test(ref((keys %h)[0]) eq 'ARRAY');
+test((keys %h)[0] eq $ref);
+test((values %h) == 1);
+test((values %h)[0] eq 'cholet');
+my $count = 0;
+while (my ($k, $v) = each %h) {
+ if ($count++ == 0) {
+ test(ref($k) eq 'ARRAY');
+ test($k eq $ref);
+ }
+}
+test($count == 1);
+delete $h{$ref};
+test(not defined $h{$ref});
+test(not exists($h{$ref}));
+test((keys %h) == 0);
+test((values %h) == 0);
+$h{$ox} = "bellow"; # overloaded ""
+test(exists $h{$ox});
+test($h{$ox} eq "bellow");
+test(not exists $h{"foobarraboof"});
+undef $h;
+untie %h;
+
+# And now Tie::RefHash::Nestable's differences from Tie::RefHash.
+$h = eval { tie %h, 'Tie::RefHash::Nestable' };
+warn $@ if $@;
+test(not $@);
+test(ref($h) eq 'Tie::RefHash::Nestable');
+test(defined(tied(%h)) and tied(%h) =~ /^Tie::RefHash::Nestable/);
+$h{$ref}->{$ref1} = 'bungo';
+test($h{$ref}->{$ref1} eq 'bungo');
+
+# Test that the nested hash is also tied (for current implementation)
+test(defined(tied(%{$h{$ref}}))
+ and tied(%{$h{$ref}}) =~ /^Tie::RefHash::Nestable=/ );
+
+test((keys %h) == 1);
+test((keys %h)[0] eq $ref);
+test((keys %{$h{$ref}}) == 1);
+test((keys %{$h{$ref}})[0] eq $ref1);
+
+{
+ # Tests that delete returns the deleted element [perl #32193]
+ my $ref = \(my $var = "oink");
+ tie my %oink, 'Tie::RefHash';
+ $oink{$ref} = "ding";
+ test($oink{$ref} eq "ding");
+ test(delete($oink{$ref}) eq "ding");
+}
+
+die "expected to run $numtests tests, but ran ", $currtest - 1
+ if $currtest - 1 != $numtests;
+
[EMAIL PROTECTED] = ();
+undef $ref;
+undef $ref1;
+
+exit();
+
+
+# Print 'ok X' if true, 'not ok X' if false
+# Uses global $currtest.
+#
+sub test {
+ my $t = shift;
+ print 'not ' if not $t;
+ print 'ok ', $currtest++, "\n";
+}
+
+
+# Wrapper for Data::Dumper to 'dump' a scalar as an EXPR string.
+sub dumped {
+ my $s = shift;
+ my $d = Dumper($s);
+ $d =~ s/^\$VAR1 =\s*//;
+ $d =~ s/;$//;
+ chomp $d;
+ return $d;
+}
+
+# Crudely dump a hash into a canonical string representation (because
+# hash keys can appear in any order, Data::Dumper may give different
+# strings for the same hash).
+#
+sub dumph {
+ my $h = shift;
+ my $r = '';
+ foreach (sort keys %$h) {
+ $r = dumped($_) . ' => ' . dumped($h->{$_}) . "\n";
+ }
+ return $r;
+}
+
+# Run the tests and give results.
+#
+# Parameters: reference to list of tests to run
+# name of class to use for tied hash, or undef if not tied
+#
+# Returns: list of [R, W, E] tuples, one for each test.
+# R is the return value from running the test, W any warnings it gave,
+# and E any exception raised with 'die'. E and W will be tidied up a
+# little to remove irrelevant details like line numbers :-)
+#
+# Will also run a few of its own 'ok N' tests.
+#
+sub runtests {
+ my ($tests, $class) = @_;
+ my @r;
+
+ my (%h, $h);
+ if (defined $class) {
+ $h = eval { tie %h, $class };
+ warn $@ if $@;
+ test(not $@);
+ test(ref($h) eq $class);
+ test(defined(tied(%h)) and tied(%h) =~ /^\Q$class\E/);
+ }
+
+ foreach (@$tests) {
+ my ($result, $warning, $exception);
+ local $SIG{__WARN__} = sub { $warning .= $_[0] };
+ $result = scalar(eval $_);
+ if ($@)
+ {
+ die "$@:$_" unless defined $class;
+ $exception = $@;
+ }
+
+ foreach ($warning, $exception) {
+ next if not defined;
+ s/ at .+ line \d+\.$//mg;
+ s/ at .+ line \d+, at .*//mg;
+ s/ at .+ line \d+, near .*//mg;
+ s/(uninitialized value)( within)? [EMAIL PROTECTED] in /$1 in /g;
+ }
+
+ my (@warnings, %seen);
+ foreach (split /\n/, $warning) {
+ push @warnings, $_ unless $seen{$_}++;
+ }
+ $warning = join("\n", @warnings);
+
+ push @r, [ $result, $warning, $exception ];
+ }
+
+ return @r;
+}
+
+
+# Things that should work just the same for an ordinary hash and a
+# Tie::RefHash.
+#
+# Each test is a code string to be eval'd, it should do something with
+# %h and give a scalar return value. The global $ref and $ref1 may
+# also be used.
+#
+# One thing we don't test is that the ordering from 'keys', 'values'
+# and 'each' is the same. You can't reasonably expect that.
+#
+sub standard_hash_tests {
+ my @r;
+
+ # Library of standard tests on keys, values and each
+ my $STD_TESTS = <<'END'
+ join $;, sort keys %h;
+ join $;, sort values %h;
+ { my ($v, %tmp); $tmp{$v}++ while (defined($v = each %h)); dumph(\%tmp) }
+ { my ($k, $v, %tmp); $tmp{"$k$;$v"}++ while (($k, $v) = each %h);
dumph(\%tmp) }
+END
+ ;
+
+ # Tests on the existence of the element 'foo'
+ my $FOO_TESTS = <<'END'
+ defined $h{foo};
+ exists $h{foo};
+ $h{foo};
+END
+ ;
+
+ # Test storing and deleting 'foo'
+ push @r, split /\n/, <<"END"
+ $STD_TESTS;
+ $FOO_TESTS;
+ \$h{foo} = undef;
+ $STD_TESTS;
+ $FOO_TESTS;
+ \$h{foo} = 'hello';
+ $STD_TESTS;
+ $FOO_TESTS;
+ delete \$h{foo};
+ $STD_TESTS;
+ $FOO_TESTS;
+END
+ ;
+
+ # Test storing and removing under ordinary keys
+ my @things = ('boink', 0, 1, '', undef);
+ foreach my $key (map { dumped($_) } @things) {
+ foreach my $value ((map { dumped($_) } @things), '$ref') {
+ push @r, split /\n/, <<"END"
+ \$h{$key} = $value;
+ $STD_TESTS;
+ defined \$h{$key};
+ exists \$h{$key};
+ \$h{$key};
+ delete \$h{$key};
+ $STD_TESTS;
+ defined \$h{$key};
+ exists \$h{$key};
+ \$h{$key};
+END
+ ;
+ }
+ }
+
+ # Test hash slices
+ my @slicetests;
+ @slicetests = split /\n/, <<'END'
+ @h{'b'} = ();
+ @h{'c'} = ('d');
+ @h{'e'} = ('f', 'g');
+ @h{'h', 'i'} = ();
+ @h{'j', 'k'} = ('l');
+ @h{'m', 'n'} = ('o', 'p');
+ @h{'q', 'r'} = ('s', 't', 'u');
+END
+ ;
+ my @aaa = @slicetests;
+ foreach (@slicetests) {
+ push @r, $_;
+ push @r, split(/\n/, $STD_TESTS);
+ }
+
+ # Test CLEAR
+ push @r, '%h = ();', split(/\n/, $STD_TESTS);
+
+ return @r;
+}
==== //depot/maint-5.8/perl/lib/Tie/RefHash/storable.t#1 (text) ====
Index: perl/lib/Tie/RefHash/storable.t
--- /dev/null 2007-01-16 11:55:45.526841103 -0800
+++ perl/lib/Tie/RefHash/storable.t 2007-02-15 08:15:16.000000000 -0800
@@ -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" );
+}
+
+
==== //depot/maint-5.8/perl/lib/Tie/RefHash/threaded.t#1 (text) ====
Index: perl/lib/Tie/RefHash/threaded.t
--- /dev/null 2007-01-16 11:55:45.526841103 -0800
+++ perl/lib/Tie/RefHash/threaded.t 2007-02-15 08:15:16.000000000 -0800
@@ -0,0 +1,68 @@
+#!/usr/bin/perl -T -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
+}
+
+use strict;
+
+BEGIN {
+ # this is sucky because threads.pm has to be loaded before Test::Builder
+ 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 = {};
+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( join("\0",sort keys %hash), join("\0",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)" );
End of Patch.
