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