Moved Tie-RefHash from lib/ to ext/

6 files changed, 1 insertions, 781 deletions

diff --git a/lib/.gitignore b/lib/.gitignore
index 58ac8be5e4..f00a192b66 100644
--- a/lib/.gitignore
+++ b/lib/.gitignore
@@ -314,6 +314,7 @@
 /Thread
 /Tie/File.pm
 /Tie/Memoize.pm
+/Tie/RefHash.pm
 /Time/HiRes.pm
 /Time/Piece.pm
 /Time/Seconds.pm
diff --git a/lib/Tie/RefHash.pm b/lib/Tie/RefHash.pm
deleted file mode 100644
index f95bf41efd..0000000000
--- a/lib/Tie/RefHash.pm
+++ /dev/null
@@ -1,274 +0,0 @@
-package Tie::RefHash;
-
-use vars qw/$VERSION/;
-
-$VERSION = "1.38";
-
-use 5.005;
-
-=head1 NAME
-
-Tie::RefHash - use references as hash keys
-
-=head1 SYNOPSIS
-
-    require 5.004;
-    use Tie::RefHash;
-    tie HASHVARIABLE, 'Tie::RefHash', LIST;
-    tie HASHVARIABLE, 'Tie::RefHash::Nestable', LIST;
-
-    untie HASHVARIABLE;
-
-=head1 DESCRIPTION
-
-This module provides the ability to use references as hash keys if you
-first C<tie> the hash variable to this module.  Normally, only the
-keys of the tied hash itself are preserved as references; to use
-references as keys in hashes-of-hashes, use Tie::RefHash::Nestable,
-included as part of Tie::RefHash.
-
-It is implemented using the standard perl TIEHASH interface.  Please
-see the C<tie> entry in perlfunc(1) and perltie(1) for more information.
-
-The Nestable version works by looking for hash references being stored
-and converting them to tied hashes so that they too can have
-references as keys.  This will happen without warning whenever you
-store a reference to one of your own hashes in the tied hash.
-
-=head1 EXAMPLE
-
-    use Tie::RefHash;
-    tie %h, 'Tie::RefHash';
-    $a = [];
-    $b = {};
-    $c = \*main;
-    $d = \"gunk";
-    $e = sub { 'foo' };
-    %h = ($a => 1, $b => 2, $c => 3, $d => 4, $e => 5);
-    $a->[0] = 'foo';
-    $b->{foo} = 'bar';
-    for (keys %h) {
-       print ref($_), "\n";
-    }
-
-    tie %h, 'Tie::RefHash::Nestable';
-    $h{$a}->{$b} = 1;
-    for (keys %h, keys %{$h{$a}}) {
-       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 SEE ALSO
-
-perl(1), perlfunc(1), perltie(1)
-
-=cut
-
-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;
-  my $s = [];
-  bless $s, $c;
-  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) {
-      my $kstr = refaddr($k);
-      if (defined $s->[0]{$kstr}) {
-        $s->[0]{$kstr}[1];
-      }
-      else {
-        undef;
-      }
-  }
-  else {
-      $s->[1]{$k};
-  }
-}
-
-sub STORE {
-  my($s, $k, $v) = @_;
-  if (ref $k) {
-    $s->[0]{refaddr($k)} = [$k, $v];
-  }
-  else {
-    $s->[1]{$k} = $v;
-  }
-  $v;
-}
-
-sub DELETE {
-  my($s, $k) = @_;
-  (ref $k)
-    ? (delete($s->[0]{refaddr($k)}) || [])->[1]
-    : delete($s->[1]{$k});
-}
-
-sub EXISTS {
-  my($s, $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;      # flag for iteration, see NEXTKEY
-  $s->NEXTKEY;
-}
-
-sub NEXTKEY {
-  my $s = shift;
-  my ($k, $v);
-  if (!$s->[2]) {
-    if (($k, $v) = each %{$s->[0]}) {
-      return $v->[0];
-    }
-    else {
-      $s->[2] = 1;
-    }
-  }
-  return each %{$s->[1]};
-}
-
-sub CLEAR {
-  my $s = shift;
-  $s->[2] = 0;
-  %{$s->[0]} = ();
-  %{$s->[1]} = ();
-}
-
-package Tie::RefHash::Nestable;
-use vars '@ISA';
-@ISA = 'Tie::RefHash';
-
-sub STORE {
-  my($s, $k, $v) = @_;
-  if (ref($v) eq 'HASH' and not tied %$v) {
-      my @elems = %$v;
-      tie %$v, ref($s), @elems;
-  }
-  $s->SUPER::STORE($k, $v);
-}
-
-1;
diff --git a/lib/Tie/RefHash/rebless.t b/lib/Tie/RefHash/rebless.t
deleted file mode 100644
index 4ae40f43fe..0000000000
--- a/lib/Tie/RefHash/rebless.t
+++ /dev/null
@@ -1,36 +0,0 @@
-#!/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
deleted file mode 100644
index d19f7d3593..0000000000
--- a/lib/Tie/RefHash/refhash.t
+++ /dev/null
@@ -1,331 +0,0 @@
-#!/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(\@tests, undef);
-foreach my $class ('Tie::RefHash', 'Tie::RefHash::Nestable') {
-    my @tied_results = runtests(\@tests, $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;
-
-@tests = ();
-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)? [\$@%].*? 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;
-}
diff --git a/lib/Tie/RefHash/storable.t b/lib/Tie/RefHash/storable.t
deleted file mode 100644
index 6c28b77a54..0000000000
--- a/lib/Tie/RefHash/storable.t
+++ /dev/null
@@ -1,63 +0,0 @@
-#!/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
deleted file mode 100644
index 7e4fa1a7f0..0000000000
--- a/lib/Tie/RefHash/threaded.t
+++ /dev/null
@@ -1,77 +0,0 @@
-#!/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;
-  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";
-    exit 0;
-  }
-  if ( $Config{usethreads} and !$Config{use5005threads}
-      and defined(&Scalar::Util::weaken)
-      and eval { require threads; "threads"->import }
-  ) {
-    print "1..14\n";
-  } else {
-    print "1..0 # Skip -- threads aren't enabled in your perl, or Scalar::Util::weaken is missing\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)" );