1
2BEGIN {
3    chdir 't' if -d 't';
4    push @INC, '../lib';
5    require Config; import Config;
6    unless ($Config{'useithreads'}) {
7	print "1..0 # Skip: no useithreads\n";
8 	exit 0;
9    }
10}
11
12use warnings;
13use strict;
14use threads;
15use threads::shared;
16use Hash::Util 'lock_keys';
17
18# Note that we can't use  Test::More here, as we would need to
19# call is() from within the DESTROY() function at global destruction time,
20# and parts of Test::* may have already been freed by then
21
22print "1..14\n";
23
24my $test : shared = 1;
25
26sub is($$$) {
27    my ($got, $want, $desc) = @_;
28    unless ($got eq $want) {
29	print "# EXPECTED: $want\n";
30	print "# GOT:      $got\n";
31	print "not ";
32    }
33    print "ok $test - $desc\n";
34    $test++;
35}
36
37
38#
39# This tests for too much destruction
40# which was caused by cloning stashes
41# on join which led to double the dataspace
42#
43#########################
44
45$|++;
46
47{
48    sub Foo::DESTROY {
49	my $self = shift;
50	my ($package, $file, $line) = caller;
51	is(threads->tid(),$self->{tid},
52		"In destroy[$self->{tid}] it should be correct too" )
53    }
54    my $foo;
55    $foo = bless {tid => 0}, 'Foo';
56    my $bar = threads->create(sub {
57	is(threads->tid(),1, "And tid be 1 here");
58	$foo->{tid} = 1;
59	return $foo;
60    })->join();
61    $bar->{tid} = 0;
62}
63
64#
65# This tests whether we can call Config::myconfig after threads have been
66# started (interpreter cloned).  5.8.1 and 5.8.2 contained a bug that would
67# disallow that too be done, because an attempt was made to change a variable
68# with the : unique attribute.
69#
70#########################
71
72threads->new( sub {1} )->join;
73my $not = eval { Config::myconfig() } ? '' : 'not ';
74print "${not}ok $test - Are we able to call Config::myconfig after clone\n";
75$test++;
76
77# bugid 24383 - :unique hashes weren't being made readonly on interpreter
78# clone; check that they are.
79
80our $unique_scalar : unique;
81our @unique_array : unique;
82our %unique_hash : unique;
83threads->new(
84    sub {
85	my $TODO = ":unique needs to be re-implemented in a non-broken way";
86	eval { $unique_scalar = 1 };
87	print $@ =~ /read-only/
88	  ? '' : 'not ', "ok $test # TODO $TODO unique_scalar\n";
89	$test++;
90	eval { $unique_array[0] = 1 };
91	print $@ =~ /read-only/
92	  ? '' : 'not ', "ok $test # TODO $TODO - unique_array\n";
93	$test++;
94	eval { $unique_hash{abc} = 1 };
95	print $@ =~ /disallowed/
96	  ? '' : 'not ', "ok $test # TODO $TODO - unique_hash\n";
97	$test++;
98    }
99)->join;
100
101# bugid #24940 :unique should fail on my and sub declarations
102
103for my $decl ('my $x : unique', 'sub foo : unique') {
104    eval $decl;
105    print $@ =~
106	/^The 'unique' attribute may only be applied to 'our' variables/
107	    ? '' : 'not ', "ok $test - $decl\n";
108    $test++;
109}
110
111
112# Returing a closure from a thread caused problems. If the last index in
113# the anon sub's pad wasn't for a lexical, then a core dump could occur.
114# Otherwise, there might be leaked scalars.
115
116# XXX DAPM 9-Jan-04 - backed this out for now - returning a closure from a
117# thread seems to crash win32
118
119# sub f {
120#     my $x = "foo";
121#     sub { $x."bar" };
122# }
123#
124# my $string = threads->new(\&f)->join->();
125# print $string eq 'foobar' ?  '' : 'not ', "ok $test - returning closure\n";
126# $test++;
127
128# Nothing is checking that total keys gets cloned correctly.
129
130my %h = (1,2,3,4);
131is (keys %h, 2, "keys correct in parent");
132
133my $child = threads->new(sub { return scalar keys %h })->join;
134is ($child, 2, "keys correct in child");
135
136lock_keys (%h);
137delete $h{1};
138
139is (keys %h, 1, "keys correct in parent with restricted hash");
140
141$child = threads->new(sub { return scalar keys %h })->join;
142is ($child, 1, "keys correct in child with restricted hash");
143
1441;
145