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';
35 my ($affirmative, $desc) = @_;
37 my $res = load_test();
42 $desc = "$desc: module loaded";
45 $desc = "$desc: module not loaded";
48 unless (is $res, $expected, $desc) {
49 $res = defined $res ? "'$res'" : 'undef';
50 $expected = "'$expected'";
51 diag("Test '$desc' failed: got $res, expected $expected");
59 my $code = eval "sub { require $module }";
64 is_loaded 0, 'main body, beginning';
66 # Test serial loadings
70 my $here = "first serial thread";
71 is_loaded 0, "$here, beginning";
74 is_loaded 1, "$here, after loading";
79 skip "$could_not_create_thread (serial 1)" => 2 unless defined $thr;
82 if (my $err = $thr->error) {
87 is_loaded 0, 'main body, in between serial loadings';
91 my $here = "second serial thread";
92 is_loaded 0, "$here, beginning";
95 is_loaded 1, "$here, after loading";
100 skip "$could_not_create_thread (serial 2)" => 2 unless defined $thr;
103 if (my $err = $thr->error) {
108 is_loaded 0, 'main body, after serial loadings';
110 # Test nested loadings
113 my $parent = spawn(sub {
114 my $here = 'parent thread';
115 is_loaded 0, "$here, beginning";
118 my $kid = spawn(sub {
119 my $here = 'child thread';
120 is_loaded 0, "$here, beginning";
123 is_loaded 1, "$here, after loading";
128 skip "$could_not_create_thread (nested child)" => 2 unless defined $kid;
131 if (my $err = $kid->error) {
132 die "in child thread: $err\n";
136 is_loaded 0, "$here, after child terminated";
139 is_loaded 1, "$here, after loading";
144 skip "$could_not_create_thread (nested parent)" => (3 + 2)
145 unless defined $parent;
148 if (my $err = $parent->error) {
153 is_loaded 0, 'main body, after nested loadings';
155 # Test parallel loadings
162 my @locks_down = (1) x $sync_points;
163 my @locks_up = (0) x $sync_points;
164 share($_) for @locks_down, @locks_up;
166 my $default_peers = 2;
169 my ($id, $peers) = @_;
171 $peers = $default_peers unless defined $peers;
174 lock $locks_down[$id];
175 $locks_down[$id] = 0;
176 cond_broadcast $locks_down[$id];
182 my $timeout = time() + 2;
183 until ($locks_up[$id] == $peers) {
184 if (cond_timedwait $locks_up[$id], $timeout) {
200 lock $locks_down[$id];
201 cond_wait $locks_down[$id] until $locks_down[$id] == 0;
207 cond_signal $locks_up[$id];
213 for my $first_thread_ends_first (0, 1) {
214 for my $id (0 .. $sync_points - 1) {
216 lock $locks_down[$id];
217 $locks_down[$id] = 1;
225 my $thr1_end = 'finishes first';
226 my $thr2_end = 'finishes last';
228 ($thr1_end, $thr2_end) = ($thr2_end, $thr1_end)
229 unless $first_thread_ends_first;
232 my $thr1 = spawn(sub {
233 my $here = "first simultaneous thread ($thr1_end)";
236 is_loaded 0, "$here, beginning";
240 is_loaded 1, "$here, after loading";
245 is_loaded 1, "$here, still loaded while also loaded in the other thread";
248 sync_slave 6 unless $first_thread_ends_first;
250 is_loaded 1, "$here, end";
255 skip "$could_not_create_thread (parallel 1)" => (4 * 2) unless defined $thr1;
257 my $thr2 = spawn(sub {
258 my $here = "second simultaneous thread ($thr2_end)";
261 is_loaded 0, "$here, beginning";
266 is_loaded 0, "$here, loaded in other thread but not here";
269 is_loaded 1, "$here, after loading";
273 sync_slave 6 if $first_thread_ends_first;
275 is_loaded 1, "$here, end";
280 sync_master($_) for 0 .. 5;
283 ($thr2, $thr1) = ($thr1, $thr2) unless $first_thread_ends_first;
286 if (my $err = $thr1->error) {
293 if (my $err = $thr1->error) {
297 sync_master(6, 1) unless $first_thread_ends_first;
300 if (my $err = $thr1->error) {
304 skip "$could_not_create_thread (parallel 2)" => (4 * 1);
308 is_loaded 0, 'main body, after simultaneous threads';
314 my $parent = spawn(sub {
315 my $here = 'simple clone, parent thread';
316 is_loaded 0, "$here, beginning";
319 is_loaded 1, "$here, after loading";
322 my $kid = spawn(sub {
323 my $here = 'simple clone, child thread';
325 is_loaded 1, "$here, beginning";
330 skip "$could_not_create_thread (simple clone child)" => 1
334 if (my $err = $kid->error) {
335 die "in child thread: $err\n";
339 is_loaded 1, "$here, after child terminated";
344 skip "$could_not_create_thread (simple clone parent)" => (3 + 1)
345 unless defined $parent;
348 if (my $err = $parent->error) {
353 is_loaded 0, 'main body, after simple clone';
355 # Test clone outliving its parent
361 my $parent = spawn(sub {
362 my $here = 'outliving clone, parent thread';
363 is_loaded 0, "$here, beginning";
366 is_loaded 1, "$here, after loading";
371 my $kid = spawn(sub {
372 my $here = 'outliving clone, child thread';
374 is_loaded 1, "$here, beginning";
378 cond_wait $kid_done until $kid_done;
381 is_loaded 1, "$here, end";
387 $kid_tid = $kid->tid;
390 skip "$could_not_create_thread (outliving clone child)" => 2;
394 is_loaded 1, "$here, end";
399 skip "$could_not_create_thread (outliving clone parent)" => (3 + 2)
400 unless defined $parent;
402 my $kid_tid = $parent->join;
403 if (my $err = $parent->error) {
408 my $kid = threads->object($kid_tid);
410 if ($kid->is_running) {
413 cond_signal $kid_done;
421 is_loaded 0, 'main body, after outliving clone';
424 is_loaded 1, 'main body, loaded at end';
426 # perl 5.13.4 comes a Test::More more recent than 0.88, so it must have
427 # done_testing() and Test::Leaner will not replace it by a croaking stub.