6 my ($module, $thread_safe_var);
8 $module = 'Variable::Magic';
9 $thread_safe_var = 'Variable::Magic::VMG_THREADSAFE()';
14 if (defined &Variable::Magic::wizard) {
15 my $wiz = Variable::Magic::wizard(
16 free => sub { $res = 1; return },
19 &Variable::Magic::cast(\$var, $wiz);
25 # Keep the rest of the file untouched
28 use VPIT::TestHelpers threads => [ $module, $thread_safe_var ];
30 my $could_not_create_thread = 'Could not create thread';
33 tests => 1 + (2 + 2 * 2) + 6 + (2 * 4 + 1) * 2 + (4 + 1) + (6 + 1) + 1
37 my ($affirmative, $desc) = @_;
39 my $res = load_test();
44 $desc = "$desc: module loaded";
47 $desc = "$desc: module not loaded";
50 unless (is $res, $expected, $desc) {
51 $res = defined $res ? "'$res'" : 'undef';
52 $expected = "'$expected'";
53 diag("Test '$desc' failed: got $res, expected $expected");
61 my $code = eval "sub { require $module }";
66 is_loaded 0, 'main body, beginning';
68 # Test serial loadings
72 my $here = "first serial thread";
73 is_loaded 0, "$here, beginning";
76 is_loaded 1, "$here, after loading";
81 skip "$could_not_create_thread (serial 1)" => 2 unless defined $thr;
84 if (my $err = $thr->error) {
89 is_loaded 0, 'main body, in between serial loadings';
93 my $here = "second serial thread";
94 is_loaded 0, "$here, beginning";
97 is_loaded 1, "$here, after loading";
102 skip "$could_not_create_thread (serial 2)" => 2 unless defined $thr;
105 if (my $err = $thr->error) {
110 is_loaded 0, 'main body, after serial loadings';
112 # Test nested loadings
115 my $parent = spawn(sub {
116 my $here = 'parent thread';
117 is_loaded 0, "$here, beginning";
120 my $kid = spawn(sub {
121 my $here = 'child thread';
122 is_loaded 0, "$here, beginning";
125 is_loaded 1, "$here, after loading";
130 skip "$could_not_create_thread (nested child)" => 2 unless defined $kid;
133 if (my $err = $kid->error) {
134 die "in child thread: $err\n";
138 is_loaded 0, "$here, after child terminated";
141 is_loaded 1, "$here, after loading";
146 skip "$could_not_create_thread (nested parent)" => (3 + 2)
147 unless defined $parent;
150 if (my $err = $parent->error) {
155 is_loaded 0, 'main body, after nested loadings';
157 # Test parallel loadings
164 my @locks_down = (1) x $sync_points;
165 my @locks_up = (0) x $sync_points;
166 share($_) for @locks_down, @locks_up;
168 my $default_peers = 2;
171 my ($id, $peers) = @_;
173 $peers = $default_peers unless defined $peers;
176 lock $locks_down[$id];
177 $locks_down[$id] = 0;
178 cond_broadcast $locks_down[$id];
183 cond_wait $locks_up[$id] until $locks_up[$id] == $peers;
191 lock $locks_down[$id];
192 cond_wait $locks_down[$id] until $locks_down[$id] == 0;
198 cond_signal $locks_up[$id];
202 for my $first_thread_ends_first (0, 1) {
203 for my $id (0 .. $sync_points - 1) {
205 lock $locks_down[$id];
206 $locks_down[$id] = 1;
214 my $thr1_end = 'finishes first';
215 my $thr2_end = 'finishes last';
217 ($thr1_end, $thr2_end) = ($thr2_end, $thr1_end)
218 unless $first_thread_ends_first;
221 my $thr1 = spawn(sub {
222 my $here = "first simultaneous thread ($thr1_end)";
225 is_loaded 0, "$here, beginning";
229 is_loaded 1, "$here, after loading";
234 is_loaded 1, "$here, still loaded while also loaded in the other thread";
237 sync_slave 6 unless $first_thread_ends_first;
239 is_loaded 1, "$here, end";
244 skip "$could_not_create_thread (parallel 1)" => (4 * 2) unless defined $thr1;
246 my $thr2 = spawn(sub {
247 my $here = "second simultaneous thread ($thr2_end)";
250 is_loaded 0, "$here, beginning";
255 is_loaded 0, "$here, loaded in other thread but not here";
258 is_loaded 1, "$here, after loading";
262 sync_slave 6 if $first_thread_ends_first;
264 is_loaded 1, "$here, end";
269 sync_master($_) for 0 .. 5;
272 ($thr2, $thr1) = ($thr1, $thr2) unless $first_thread_ends_first;
275 if (my $err = $thr1->error) {
282 if (my $err = $thr1->error) {
286 sync_master(6, 1) unless $first_thread_ends_first;
289 if (my $err = $thr1->error) {
293 skip "$could_not_create_thread (parallel 2)" => (4 * 1);
297 is_loaded 0, 'main body, after simultaneous threads';
303 my $parent = spawn(sub {
304 my $here = 'simple clone, parent thread';
305 is_loaded 0, "$here, beginning";
308 is_loaded 1, "$here, after loading";
311 my $kid = spawn(sub {
312 my $here = 'simple clone, child thread';
314 is_loaded 1, "$here, beginning";
319 skip "$could_not_create_thread (simple clone child)" => 1
323 if (my $err = $kid->error) {
324 die "in child thread: $err\n";
328 is_loaded 1, "$here, after child terminated";
333 skip "$could_not_create_thread (simple clone parent)" => (3 + 1)
334 unless defined $parent;
337 if (my $err = $parent->error) {
342 is_loaded 0, 'main body, after simple clone';
344 # Test clone outliving its parent
353 my $parent = spawn(sub {
354 my $here = 'outliving clone, parent thread';
355 is_loaded 0, "$here, beginning";
360 is_loaded 1, "$here, after loading";
363 my $kid = spawn(sub {
364 my $here = 'outliving clone, child thread';
366 is_loaded 1, "$here, beginning";
370 $kid_tid = threads->tid();
371 cond_signal $kid_tid;
374 is_loaded 1, "$here, kid tid was communicated";
378 cond_wait $kid_done until $kid_done;
381 is_loaded 1, "$here, end";
386 unless (defined $kid) {
388 skip "$could_not_create_thread (outliving clone child)" => 3;
392 is_loaded 1, "$here, end";
397 skip "$could_not_create_thread (outliving clone parent)" => (3 + 3)
398 unless defined $parent;
400 my $no_kid = $parent->join;
401 if (my $err = $parent->error) {
408 cond_wait $kid_tid until defined $kid_tid;
412 my $kid = threads->object($tid);
417 cond_signal $kid_done;
425 is_loaded 0, 'main body, after outliving clone';
428 is_loaded 1, 'main body, loaded at end';