5 if ($ENV{'PERL_CORE'}){
7 unshift @INC, '../lib';
10 if (! $Config{'useithreads'}) {
11 print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
16 use ExtUtils::testlib;
19 my ($id, $ok, $name) = @_;
21 # You have to do it this way or VMS will get confused.
23 print("ok $id - $name\n");
25 print("not ok $id - $name\n");
26 printf("# Failed test at line %d\n", (caller)[2]);
34 print("1..20\n"); ### Number of tests that will be run ###
41 ### Start of Testing ###
48 ok(2, !defined ${$foo{foo}}, "Check deref");
50 ok(3, ${$foo{foo}} eq "test", "Check deref after assign");
51 threads->create(sub{${$foo{foo}} = "test2";})->join();
52 ok(4, $foo eq "test2", "Check after assign in another thread");
53 my $bar = delete($foo{foo});
54 ok(5, $$bar eq "test2", "check delete");
55 threads->create( sub {
61 ok(6, ${$foo{test}} eq "thread3", "Check reference created in another thread");
64 ok(7, ${$foo{test}} eq "test", "Check reference");
65 my $gg2 = delete($foo{test});
66 ok(8, threads::shared::_id($$gg) == threads::shared::_id($$gg2),
67 sprintf("Check we get the same thing (%x vs %x)",
68 threads::shared::_id($$gg),threads::shared::_id($$gg2)));
69 ok(9, $$gg eq $$gg2, "And check the values are the same");
70 ok(10, keys %foo == 0, "And make sure we realy have deleted the values");
75 $hash1{hash} = \%hash2;
76 $hash2{"bar"} = "foo";
77 ok(11, $hash1{hash}->{bar} eq "foo", "Check hash references work");
78 threads->create(sub { $hash2{"bar2"} = "foo2"})->join();
79 ok(12, $hash1{hash}->{bar2} eq "foo2", "Check hash references work");
80 threads->create(sub { my (%hash3); share(%hash3); $hash2{hash} = \%hash3; $hash3{"thread"} = "yes"})->join();
81 ok(13, $hash1{hash}->{hash}->{thread} eq "yes", "Check hash created in another thread");
90 ok(14, !$@, "lock on helems ref: $@");
91 eval { lock($h->{a}); };
92 ok(15, !$@, "lock on helems: $@");
94 ok(14, 1, "skipped. < 5.8");
95 ok(15, 1, "skipped. < 5.8");
99 my $object : shared = &share({});
100 threads->create(sub {
101 bless $object, 'test1';
103 ok(16, ref($object) eq 'test1', "blessing does work");
104 my %test = (object => $object);
105 ok(17, ref($test{object}) eq 'test1', "and some more work");
106 bless $object, 'test2';
107 ok(18, ref($test{object}) eq 'test2', "reblessing works!");
110 ok(19, is_shared($foo), "Check for sharing");
111 ok(20, is_shared(%foo), "Check for sharing");