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