6 BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} }
8 my ($module, $thread_safe_var);
11 $thread_safe_var = 'indirect::I_THREADSAFE()';
16 if (defined &indirect::msg) {
18 eval 'BEGIN { indirect->unimport(":fatal") if defined &indirect::msg } return; my $x = new X;';
21 if (defined $res and $res =~ /^Indirect call of method/) {
23 } elsif (not defined $res or $res eq '') {
30 # Keep the rest of the file untouched
33 use VPIT::TestHelpers threads => [ $module, $thread_safe_var ];
35 my $could_not_create_thread = 'Could not create thread';
40 my ($affirmative, $desc) = @_;
42 my $res = load_test();
47 $desc = "$desc: module loaded";
50 $desc = "$desc: module not loaded";
53 unless (is $res, $expected, $desc) {
54 $res = defined $res ? "'$res'" : 'undef';
55 $expected = "'$expected'";
56 diag("Test '$desc' failed: got $res, expected $expected");
64 my $code = eval "sub { require $module }";
69 is_loaded 0, 'main body, beginning';
71 # Test serial loadings
75 my $here = "first serial thread";
76 is_loaded 0, "$here, beginning";
79 is_loaded 1, "$here, after loading";
84 skip "$could_not_create_thread (serial 1)" => 2 unless defined $thr;
87 if (my $err = $thr->error) {
92 is_loaded 0, 'main body, in between serial loadings';
96 my $here = "second serial thread";
97 is_loaded 0, "$here, beginning";
100 is_loaded 1, "$here, after loading";
105 skip "$could_not_create_thread (serial 2)" => 2 unless defined $thr;
108 if (my $err = $thr->error) {
113 is_loaded 0, 'main body, after serial loadings';
115 # Test nested loadings
118 my $parent = spawn(sub {
119 my $here = 'parent thread';
120 is_loaded 0, "$here, beginning";
123 my $kid = spawn(sub {
124 my $here = 'child thread';
125 is_loaded 0, "$here, beginning";
128 is_loaded 1, "$here, after loading";
133 skip "$could_not_create_thread (nested child)" => 2 unless defined $kid;
136 if (my $err = $kid->error) {
137 die "in child thread: $err\n";
141 is_loaded 0, "$here, after child terminated";
144 is_loaded 1, "$here, after loading";
149 skip "$could_not_create_thread (nested parent)" => (3 + 2)
150 unless defined $parent;
153 if (my $err = $parent->error) {
158 is_loaded 0, 'main body, after nested loadings';
160 # Test parallel loadings
167 my @locks_down = (1) x $sync_points;
168 my @locks_up = (0) x $sync_points;
169 share($_) for @locks_down, @locks_up;
171 my $default_peers = 2;
174 my ($id, $peers) = @_;
176 $peers = $default_peers unless defined $peers;
179 lock $locks_down[$id];
180 $locks_down[$id] = 0;
181 cond_broadcast $locks_down[$id];
186 my $timeout = time() + 10;
187 until ($locks_up[$id] == $peers) {
188 if (cond_timedwait $locks_up[$id], $timeout) {
203 lock $locks_down[$id];
204 cond_wait $locks_down[$id] until $locks_down[$id] == 0;
210 cond_signal $locks_up[$id];
216 for my $first_thread_ends_first (0, 1) {
217 for my $id (0 .. $sync_points - 1) {
219 lock $locks_down[$id];
220 $locks_down[$id] = 1;
228 my $thr1_end = 'finishes first';
229 my $thr2_end = 'finishes last';
231 ($thr1_end, $thr2_end) = ($thr2_end, $thr1_end)
232 unless $first_thread_ends_first;
235 my $thr1 = spawn(sub {
236 my $here = "first simultaneous thread ($thr1_end)";
239 is_loaded 0, "$here, beginning";
243 is_loaded 1, "$here, after loading";
248 is_loaded 1, "$here, still loaded while also loaded in the other thread";
251 sync_slave 6 unless $first_thread_ends_first;
253 is_loaded 1, "$here, end";
258 skip "$could_not_create_thread (parallel 1)" => (4 * 2) unless defined $thr1;
260 my $thr2 = spawn(sub {
261 my $here = "second simultaneous thread ($thr2_end)";
264 is_loaded 0, "$here, beginning";
269 is_loaded 0, "$here, loaded in other thread but not here";
272 is_loaded 1, "$here, after loading";
276 sync_slave 6 if $first_thread_ends_first;
278 is_loaded 1, "$here, end";
283 sync_master($_) for 0 .. 5;
286 ($thr2, $thr1) = ($thr1, $thr2) unless $first_thread_ends_first;
289 if (my $err = $thr1->error) {
296 if (my $err = $thr1->error) {
300 sync_master(6, 1) unless $first_thread_ends_first;
303 if (my $err = $thr1->error) {
307 skip "$could_not_create_thread (parallel 2)" => (4 * 1);
311 is_loaded 0, 'main body, after simultaneous threads';
317 my $parent = spawn(sub {
318 my $here = 'simple clone, parent thread';
319 is_loaded 0, "$here, beginning";
322 is_loaded 1, "$here, after loading";
325 my $kid = spawn(sub {
326 my $here = 'simple clone, child thread';
328 is_loaded 1, "$here, beginning";
333 skip "$could_not_create_thread (simple clone child)" => 1
337 if (my $err = $kid->error) {
338 die "in child thread: $err\n";
342 is_loaded 1, "$here, after child terminated";
347 skip "$could_not_create_thread (simple clone parent)" => (3 + 1)
348 unless defined $parent;
351 if (my $err = $parent->error) {
356 is_loaded 0, 'main body, after simple clone';
358 # Test clone outliving its parent
364 my $parent = spawn(sub {
365 my $here = 'outliving clone, parent thread';
366 is_loaded 0, "$here, beginning";
369 is_loaded 1, "$here, after loading";
374 my $kid = spawn(sub {
375 my $here = 'outliving clone, child thread';
377 is_loaded 1, "$here, beginning";
381 cond_wait $kid_done until $kid_done;
384 is_loaded 1, "$here, end";
390 $kid_tid = $kid->tid;
393 skip "$could_not_create_thread (outliving clone child)" => 2;
397 is_loaded 1, "$here, end";
402 skip "$could_not_create_thread (outliving clone parent)" => (3 + 2)
403 unless defined $parent;
405 my $kid_tid = $parent->join;
406 if (my $err = $parent->error) {
411 my $kid = threads->object($kid_tid);
413 if ($kid->is_running) {
416 cond_signal $kid_done;
424 is_loaded 0, 'main body, after outliving clone';
427 is_loaded 1, 'main body, loaded at end';