1#!perl
2
3use strict;
4use warnings;
5
6my ($module, $thread_safe_var);
7BEGIN {
8 $module          = 'autovivification';
9 $thread_safe_var = 'autovivification::A_THREADSAFE()';
10}
11
12sub load_test {
13 my $x;
14 if (defined &autovivification::unimport) {
15  local $@;
16  eval 'BEGIN { autovivification->unimport } my $y = $x->[0]';
17  $x = $@ if $@;
18 } else {
19  $x = '';
20 }
21 if (not defined $x) {
22  return 1;
23 } elsif (   (not ref $x        and not length $x)
24          or (ref $x eq 'ARRAY' and not @$x      )) {
25  return 0;
26 } else {
27  return "$x";
28 }
29}
30
31# Keep the rest of the file untouched
32
33use lib 't/lib';
34use VPIT::TestHelpers threads => [ $module, $thread_safe_var ];
35
36my $could_not_create_thread = 'Could not create thread';
37
38use Test::Leaner;
39
40sub is_loaded {
41 my ($affirmative, $desc) = @_;
42
43 my $res = load_test();
44
45 my $expected;
46 if ($affirmative) {
47  $expected = 1;
48  $desc     = "$desc: module loaded";
49 } else {
50  $expected = 0;
51  $desc     = "$desc: module not loaded";
52 }
53
54 unless (is $res, $expected, $desc) {
55  $res      = defined $res ? "'$res'" : 'undef';
56  $expected = "'$expected'";
57  diag("Test '$desc' failed: got $res, expected $expected");
58 }
59
60 return;
61}
62
63BEGIN {
64 local $@;
65 my $code = eval "sub { require $module }";
66 die $@ if $@;
67 *do_load = $code;
68}
69
70is_loaded 0, 'main body, beginning';
71
72# Test serial loadings
73
74SKIP: {
75 my $thr = spawn(sub {
76  my $here = "first serial thread";
77  is_loaded 0, "$here, beginning";
78
79  do_load;
80  is_loaded 1, "$here, after loading";
81
82  return;
83 });
84
85 skip "$could_not_create_thread (serial 1)" => 2 unless defined $thr;
86
87 $thr->join;
88 if (my $err = $thr->error) {
89  die $err;
90 }
91}
92
93is_loaded 0, 'main body, in between serial loadings';
94
95SKIP: {
96 my $thr = spawn(sub {
97  my $here = "second serial thread";
98  is_loaded 0, "$here, beginning";
99
100  do_load;
101  is_loaded 1, "$here, after loading";
102
103  return;
104 });
105
106 skip "$could_not_create_thread (serial 2)" => 2 unless defined $thr;
107
108 $thr->join;
109 if (my $err = $thr->error) {
110  die $err;
111 }
112}
113
114is_loaded 0, 'main body, after serial loadings';
115
116# Test nested loadings
117
118SKIP: {
119 my $parent = spawn(sub {
120  my $here = 'parent thread';
121  is_loaded 0, "$here, beginning";
122
123  SKIP: {
124   my $kid = spawn(sub {
125    my $here = 'child thread';
126    is_loaded 0, "$here, beginning";
127
128    do_load;
129    is_loaded 1, "$here, after loading";
130
131    return;
132   });
133
134   skip "$could_not_create_thread (nested child)" => 2 unless defined $kid;
135
136   $kid->join;
137   if (my $err = $kid->error) {
138    die "in child thread: $err\n";
139   }
140  }
141
142  is_loaded 0, "$here, after child terminated";
143
144  do_load;
145  is_loaded 1, "$here, after loading";
146
147  return;
148 });
149
150 skip "$could_not_create_thread (nested parent)" => (3 + 2)
151                                                         unless defined $parent;
152
153 $parent->join;
154 if (my $err = $parent->error) {
155  die $err;
156 }
157}
158
159is_loaded 0, 'main body, after nested loadings';
160
161# Test parallel loadings
162
163use threads;
164use threads::shared;
165
166my $sync_points = 7;
167
168my @locks_down = (1) x $sync_points;
169my @locks_up   = (0) x $sync_points;
170share($_) for @locks_down, @locks_up;
171
172my $default_peers = 2;
173
174sub sync_master {
175 my ($id, $peers) = @_;
176
177 $peers = $default_peers unless defined $peers;
178
179 {
180  lock $locks_down[$id];
181  $locks_down[$id] = 0;
182  cond_broadcast $locks_down[$id];
183 }
184
185 LOCK: {
186  lock $locks_up[$id];
187  my $timeout = time() + 10;
188  until ($locks_up[$id] == $peers) {
189   if (cond_timedwait $locks_up[$id], $timeout) {
190    last LOCK;
191   } else {
192    return 0;
193   }
194  }
195 }
196
197 return 1;
198}
199
200sub sync_slave {
201 my ($id) = @_;
202
203 {
204  lock $locks_down[$id];
205  cond_wait $locks_down[$id] until $locks_down[$id] == 0;
206 }
207
208 {
209  lock $locks_up[$id];
210  $locks_up[$id]++;
211  cond_signal $locks_up[$id];
212 }
213
214 return 1;
215}
216
217for my $first_thread_ends_first (0, 1) {
218 for my $id (0 .. $sync_points - 1) {
219  {
220   lock $locks_down[$id];
221   $locks_down[$id] = 1;
222  }
223  {
224   lock $locks_up[$id];
225   $locks_up[$id] = 0;
226  }
227 }
228
229 my $thr1_end = 'finishes first';
230 my $thr2_end = 'finishes last';
231
232 ($thr1_end, $thr2_end) = ($thr2_end, $thr1_end)
233                                                unless $first_thread_ends_first;
234
235 SKIP: {
236  my $thr1 = spawn(sub {
237   my $here = "first simultaneous thread ($thr1_end)";
238   sync_slave 0;
239
240   is_loaded 0, "$here, beginning";
241   sync_slave 1;
242
243   do_load;
244   is_loaded 1, "$here, after loading";
245   sync_slave 2;
246   sync_slave 3;
247
248   sync_slave 4;
249   is_loaded 1, "$here, still loaded while also loaded in the other thread";
250   sync_slave 5;
251
252   sync_slave 6 unless $first_thread_ends_first;
253
254   is_loaded 1, "$here, end";
255
256   return 1;
257  });
258
259  skip "$could_not_create_thread (parallel 1)" => (4 * 2) unless defined $thr1;
260
261  my $thr2 = spawn(sub {
262   my $here = "second simultaneous thread ($thr2_end)";
263   sync_slave 0;
264
265   is_loaded 0, "$here, beginning";
266   sync_slave 1;
267
268   sync_slave 2;
269   sync_slave 3;
270   is_loaded 0, "$here, loaded in other thread but not here";
271
272   do_load;
273   is_loaded 1, "$here, after loading";
274   sync_slave 4;
275   sync_slave 5;
276
277   sync_slave 6 if $first_thread_ends_first;
278
279   is_loaded 1, "$here, end";
280
281   return 1;
282  });
283
284  sync_master($_) for 0 .. 5;
285
286  if (defined $thr2) {
287   ($thr2, $thr1) = ($thr1, $thr2) unless $first_thread_ends_first;
288
289   $thr1->join;
290   if (my $err = $thr1->error) {
291    die $err;
292   }
293
294   sync_master(6, 1);
295
296   $thr2->join;
297   if (my $err = $thr1->error) {
298    die $err;
299   }
300  } else {
301   sync_master(6, 1) unless $first_thread_ends_first;
302
303   $thr1->join;
304   if (my $err = $thr1->error) {
305    die $err;
306   }
307
308   skip "$could_not_create_thread (parallel 2)" => (4 * 1);
309  }
310 }
311
312 is_loaded 0, 'main body, after simultaneous threads';
313}
314
315# Test simple clone
316
317SKIP: {
318 my $parent = spawn(sub {
319  my $here = 'simple clone, parent thread';
320  is_loaded 0, "$here, beginning";
321
322  do_load;
323  is_loaded 1, "$here, after loading";
324
325  SKIP: {
326   my $kid = spawn(sub {
327    my $here = 'simple clone, child thread';
328
329    is_loaded 1, "$here, beginning";
330
331    return;
332   });
333
334   skip "$could_not_create_thread (simple clone child)" => 1
335                                                            unless defined $kid;
336
337   $kid->join;
338   if (my $err = $kid->error) {
339    die "in child thread: $err\n";
340   }
341  }
342
343  is_loaded 1, "$here, after child terminated";
344
345  return;
346 });
347
348 skip "$could_not_create_thread (simple clone parent)" => (3 + 1)
349                                                         unless defined $parent;
350
351 $parent->join;
352 if (my $err = $parent->error) {
353  die $err;
354 }
355}
356
357is_loaded 0, 'main body, after simple clone';
358
359# Test clone outliving its parent
360
361SKIP: {
362 my $kid_done;
363 share($kid_done);
364
365 my $parent = spawn(sub {
366  my $here = 'outliving clone, parent thread';
367  is_loaded 0, "$here, beginning";
368
369  do_load;
370  is_loaded 1, "$here, after loading";
371
372  my $kid_tid;
373
374  SKIP: {
375   my $kid = spawn(sub {
376    my $here = 'outliving clone, child thread';
377
378    is_loaded 1, "$here, beginning";
379
380    {
381     lock $kid_done;
382     cond_wait $kid_done until $kid_done;
383    }
384
385    is_loaded 1, "$here, end";
386
387    return 1;
388   });
389
390   if (defined $kid) {
391    $kid_tid = $kid->tid;
392   } else {
393    $kid_tid = 0;
394    skip "$could_not_create_thread (outliving clone child)" => 2;
395   }
396  }
397
398  is_loaded 1, "$here, end";
399
400  return $kid_tid;
401 });
402
403 skip "$could_not_create_thread (outliving clone parent)" => (3 + 2)
404                                                         unless defined $parent;
405
406 my $kid_tid = $parent->join;
407 if (my $err = $parent->error) {
408  die $err;
409 }
410
411 if ($kid_tid) {
412  my $kid = threads->object($kid_tid);
413  if (defined $kid) {
414   if ($kid->is_running) {
415    lock $kid_done;
416    $kid_done = 1;
417    cond_signal $kid_done;
418   }
419
420   $kid->join;
421  }
422 }
423}
424
425is_loaded 0, 'main body, after outliving clone';
426
427do_load;
428is_loaded 1, 'main body, loaded at end';
429
430done_testing();
431