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 eval { +require threads; threads->import; 1 }
24  ) {
25    print "1..14\n";
26  } else {
27    print "1..0 # Skip -- threads aren't enabled in your perl";
28    exit 0;
29  }
30}
31
32use Tie::RefHash;
33
34$\ = "\n";
35sub ok ($$) {
36  print ( ( $_[0] ? "" : "not " ), "ok - $_[1]" );
37}
38
39sub is ($$$) {
40  print ( ( ( ($_[0]||'') eq ($_[1]||'') ) ? "" : "not "), "ok - $_[2]" );
41}
42
43tie my %hash, "Tie::RefHash";
44
45my $r1 = {};
46my $r2 = [];
47my $v1 = "foo";
48
49$hash{$r1} = "hash";
50$hash{$r2} = "array";
51$hash{$v1} = "string";
52
53is( $hash{$v1}, "string", "fetch by string before clone ($v1)" );
54is( $hash{$r1}, "hash", "fetch by ref before clone ($r1)" );
55is( $hash{$r2}, "array", "fetch by ref before clone ($r2)" );
56
57my $th = threads->create(sub {
58  is( scalar keys %hash, 3, "key count is OK" );
59
60  ok( exists $hash{$v1}, "string key exists ($v1)" );
61  is( $hash{$v1}, "string", "fetch by string" );
62
63  ok( exists $hash{$r1}, "ref key exists ($r1)" );
64  is( $hash{$r1}, "hash", "fetch by ref" );
65
66  ok( exists $hash{$r2}, "ref key exists ($r2)" );
67  is( $hash{$r2}, "array", "fetch by ref" );
68
69  is( join("\0",sort keys %hash), join("\0",sort $r1, $r2, $v1), "keys are ok" );
70});
71
72$th->join;
73
74is( $hash{$v1}, "string", "fetch by string after clone, orig thread ($v1)" );
75is( $hash{$r1}, "hash", "fetch by ref after clone ($r1)" );
76is( $hash{$r2}, "array", "fetch by ref after clone ($r2)" );
77