1#!/usr/bin/perl -T -w
2
3BEGIN {
4    if( $ENV{PERL_CORE} ) {
5        chdir 't';
6        @INC = '../lib';
7    }
8}
9
10use strict;
11
12
13BEGIN {
14    # this is sucky because threads.pm has to be loaded before Test::Builder
15  use Config;
16  eval { require Scalar::Util };
17
18  if ( $^O eq 'MSWin32' ) {
19    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";
20    exit 0;
21  }
22  if ( $Config{usethreads} and !$Config{use5005threads}
23      and defined(&Scalar::Util::weaken)
24      and eval { require threads; threads->import; 1 }
25  ) {
26    print "1..14\n";
27  } else {
28    print "1..0 # Skip -- threads aren't enabled in your perl, or Scalar::Util::weaken is missing\n";
29    exit 0;
30  }
31}
32
33use Tie::RefHash;
34
35$\ = "\n";
36sub ok ($$) {
37  print ( ( $_[0] ? "" : "not " ), "ok - $_[1]" );
38}
39
40sub is ($$$) {
41  print ( ( ( ($_[0]||'') eq ($_[1]||'') ) ? "" : "not "), "ok - $_[2]" );
42}
43
44tie my %hash, "Tie::RefHash";
45
46my $r1 = {};
47my $r2 = [];
48my $v1 = "foo";
49
50$hash{$r1} = "hash";
51$hash{$r2} = "array";
52$hash{$v1} = "string";
53
54is( $hash{$v1}, "string", "fetch by string before clone ($v1)" );
55is( $hash{$r1}, "hash", "fetch by ref before clone ($r1)" );
56is( $hash{$r2}, "array", "fetch by ref before clone ($r2)" );
57
58my $th = threads->create(sub {
59  is( scalar keys %hash, 3, "key count is OK" );
60
61  ok( exists $hash{$v1}, "string key exists ($v1)" );
62  is( $hash{$v1}, "string", "fetch by string" );
63
64  ok( exists $hash{$r1}, "ref key exists ($r1)" );
65  is( $hash{$r1}, "hash", "fetch by ref" );
66
67  ok( exists $hash{$r2}, "ref key exists ($r2)" );
68  is( $hash{$r2}, "array", "fetch by ref" );
69
70  is( join("\0",sort keys %hash), join("\0",sort $r1, $r2, $v1), "keys are ok" );
71});
72
73$th->join;
74
75is( $hash{$v1}, "string", "fetch by string after clone, orig thread ($v1)" );
76is( $hash{$r1}, "hash", "fetch by ref after clone ($r1)" );
77is( $hash{$r2}, "array", "fetch by ref after clone ($r2)" );
78