6 my ($module, $thread_safe_var);
8 $module = 'Scope::Upper';
9 $thread_safe_var = 'Scope::Upper::SU_THREADSAFE()';
16 if (defined &Scope::Upper::reap) {
17 &Scope::Upper::reap(sub { $var *= 2 });
31 # Keep the rest of the file untouched
34 use VPIT::TestHelpers threads => [ $module, $thread_safe_var ];
36 my $could_not_create_thread = 'Could not create thread';
39 tests => 1 + (2 + 2 * 2) + 6 + (2 * 4 + 1) * 2 + (4 + 1) + (6 + 1) + 1
43 my ($affirmative, $desc) = @_;
45 my $res = load_test();
50 $desc = "$desc: module loaded";
53 $desc = "$desc: module not loaded";
56 unless (is $res, $expected, $desc) {
57 $res = defined $res ? "'$res'" : 'undef';
58 $expected = "'$expected'";
59 diag("Test '$desc' failed: got $res, expected $expected");
67 my $code = eval "sub { require $module }";
72 is_loaded 0, 'main body, beginning';
74 # Test serial loadings
78 my $here = "first serial thread";
79 is_loaded 0, "$here, beginning";
82 is_loaded 1, "$here, after loading";
87 skip "$could_not_create_thread (serial 1)" => 2 unless defined $thr;
90 if (my $err = $thr->error) {
95 is_loaded 0, 'main body, in between serial loadings';
99 my $here = "second serial thread";
100 is_loaded 0, "$here, beginning";
103 is_loaded 1, "$here, after loading";
108 skip "$could_not_create_thread (serial 2)" => 2 unless defined $thr;
111 if (my $err = $thr->error) {
116 is_loaded 0, 'main body, after serial loadings';
118 # Test nested loadings
121 my $parent = spawn(sub {
122 my $here = 'parent thread';
123 is_loaded 0, "$here, beginning";
126 my $kid = spawn(sub {
127 my $here = 'child thread';
128 is_loaded 0, "$here, beginning";
131 is_loaded 1, "$here, after loading";
136 skip "$could_not_create_thread (nested child)" => 2 unless defined $kid;
139 if (my $err = $kid->error) {
140 die "in child thread: $err\n";
144 is_loaded 0, "$here, after child terminated";
147 is_loaded 1, "$here, after loading";
152 skip "$could_not_create_thread (nested parent)" => (3 + 2)
153 unless defined $parent;
156 if (my $err = $parent->error) {
161 is_loaded 0, 'main body, after nested loadings';
163 # Test parallel loadings
170 my @locks_down = (1) x $sync_points;
171 my @locks_up = (0) x $sync_points;
172 share($_) for @locks_down, @locks_up;
174 my $default_peers = 2;
177 my ($id, $peers) = @_;
179 $peers = $default_peers unless defined $peers;
182 lock $locks_down[$id];
183 $locks_down[$id] = 0;
184 cond_broadcast $locks_down[$id];
189 cond_wait $locks_up[$id] until $locks_up[$id] == $peers;
197 lock $locks_down[$id];
198 cond_wait $locks_down[$id] until $locks_down[$id] == 0;
204 cond_signal $locks_up[$id];
208 for my $first_thread_ends_first (0, 1) {
209 for my $id (0 .. $sync_points - 1) {
211 lock $locks_down[$id];
212 $locks_down[$id] = 1;
220 my $thr1_end = 'finishes first';
221 my $thr2_end = 'finishes last';
223 ($thr1_end, $thr2_end) = ($thr2_end, $thr1_end)
224 unless $first_thread_ends_first;
227 my $thr1 = spawn(sub {
228 my $here = "first simultaneous thread ($thr1_end)";
231 is_loaded 0, "$here, beginning";
235 is_loaded 1, "$here, after loading";
240 is_loaded 1, "$here, still loaded while also loaded in the other thread";
243 sync_slave 6 unless $first_thread_ends_first;
245 is_loaded 1, "$here, end";
250 skip "$could_not_create_thread (parallel 1)" => (4 * 2) unless defined $thr1;
252 my $thr2 = spawn(sub {
253 my $here = "second simultaneous thread ($thr2_end)";
256 is_loaded 0, "$here, beginning";
261 is_loaded 0, "$here, loaded in other thread but not here";
264 is_loaded 1, "$here, after loading";
268 sync_slave 6 if $first_thread_ends_first;
270 is_loaded 1, "$here, end";
275 sync_master($_) for 0 .. 5;
278 ($thr2, $thr1) = ($thr1, $thr2) unless $first_thread_ends_first;
281 if (my $err = $thr1->error) {
288 if (my $err = $thr1->error) {
292 sync_master(6, 1) unless $first_thread_ends_first;
295 if (my $err = $thr1->error) {
299 skip "$could_not_create_thread (parallel 2)" => (4 * 1);
303 is_loaded 0, 'main body, after simultaneous threads';
309 my $parent = spawn(sub {
310 my $here = 'simple clone, parent thread';
311 is_loaded 0, "$here, beginning";
314 is_loaded 1, "$here, after loading";
317 my $kid = spawn(sub {
318 my $here = 'simple clone, child thread';
320 is_loaded 1, "$here, beginning";
325 skip "$could_not_create_thread (simple clone child)" => 1
329 if (my $err = $kid->error) {
330 die "in child thread: $err\n";
334 is_loaded 1, "$here, after child terminated";
339 skip "$could_not_create_thread (simple clone parent)" => (3 + 1)
340 unless defined $parent;
343 if (my $err = $parent->error) {
348 is_loaded 0, 'main body, after simple clone';
350 # Test clone outliving its parent
359 my $parent = spawn(sub {
360 my $here = 'outliving clone, parent thread';
361 is_loaded 0, "$here, beginning";
366 is_loaded 1, "$here, after loading";
369 my $kid = spawn(sub {
370 my $here = 'outliving clone, child thread';
372 is_loaded 1, "$here, beginning";
376 $kid_tid = threads->tid();
377 cond_signal $kid_tid;
380 is_loaded 1, "$here, kid tid was communicated";
384 cond_wait $kid_done until $kid_done;
387 is_loaded 1, "$here, end";
392 unless (defined $kid) {
394 skip "$could_not_create_thread (outliving clone child)" => 3;
398 is_loaded 1, "$here, end";
403 skip "$could_not_create_thread (outliving clone parent)" => (3 + 3)
404 unless defined $parent;
406 my $no_kid = $parent->join;
407 if (my $err = $parent->error) {
414 cond_wait $kid_tid until defined $kid_tid;
418 my $kid = threads->object($tid);
423 cond_signal $kid_done;
431 is_loaded 0, 'main body, after outliving clone';
434 is_loaded 1, 'main body, loaded at end';