Thoroughly test module loading in threads
[perl/modules/indirect.git] / t / 09-load-threads.t
1 #!perl
2
3 use strict;
4 use warnings;
5
6 use lib 't/lib';
7 use VPIT::TestHelpers;
8
9 BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} }
10
11 my ($module, $thread_safe_var);
12 BEGIN {
13  $module          = 'indirect';
14  $thread_safe_var = 'indirect::I_THREADSAFE()';
15 }
16
17 sub load_test {
18  my $res;
19  if (defined &indirect::msg) {
20   local $@;
21   eval 'BEGIN { indirect->unimport(":fatal") if defined &indirect::msg } return; my $x = new X;';
22   $res = $@;
23  }
24  if (defined $res and $res =~ /^Indirect call of method/) {
25   return 1;
26  } elsif (not defined $res or $res eq '') {
27   return 0;
28  } else {
29   return $res;
30  }
31 }
32
33 # Keep the rest of the file untouched
34
35 BEGIN {
36  my $is_threadsafe;
37
38  if (defined $thread_safe_var) {
39   my $stat = run_perl "require POSIX; require $module; exit($thread_safe_var ? POSIX::EXIT_SUCCESS() : POSIX::EXIT_FAILURE())";
40   if (defined $stat) {
41    require POSIX;
42    my $res  = $stat >> 8;
43    if ($res == POSIX::EXIT_SUCCESS()) {
44     $is_threadsafe = 1;
45    } elsif ($res == POSIX::EXIT_FAILURE()) {
46     $is_threadsafe = !1;
47    }
48   }
49   if (not defined $is_threadsafe) {
50    skip_all "Could not detect if $module is thread safe or not";
51   }
52  }
53
54  VPIT::TestHelpers->import(
55   threads => [ $module => $is_threadsafe ],
56  )
57 }
58
59 my $could_not_create_thread = 'Could not create thread';
60
61 use Test::Leaner tests => 1 + (2 + 2 * 2) + 6 + (2 * 4) + 2;
62
63 sub is_loaded {
64  my ($affirmative, $desc) = @_;
65
66  my $res = load_test();
67
68  if ($affirmative) {
69   is $res, 1, "$desc: module loaded";
70  } else {
71   is $res, 0, "$desc: module not loaded";
72  }
73 }
74
75 BEGIN {
76  local $@;
77  my $code = eval "sub { require $module }";
78  die $@ if $@;
79  *do_load = $code;
80 }
81
82 is_loaded 0, 'main body, beginning';
83
84 # Test serial loadings
85
86 SKIP: {
87  my $thr = spawn(sub {
88   my $here = "first serial thread";
89   is_loaded 0, "$here, beginning";
90
91   do_load;
92   is_loaded 1, "$here, after loading";
93
94   return;
95  });
96
97  skip "$could_not_create_thread (serial 1)" => 2 unless defined $thr;
98
99  $thr->join;
100  if (my $err = $thr->error) {
101   die $err;
102  }
103 }
104
105 is_loaded 0, 'main body, in between serial loadings';
106
107 SKIP: {
108  my $thr = spawn(sub {
109   my $here = "second serial thread";
110   is_loaded 0, "$here, beginning";
111
112   do_load;
113   is_loaded 1, "$here, after loading";
114
115   return;
116  });
117
118  skip "$could_not_create_thread (serial 2)" => 2 unless defined $thr;
119
120  $thr->join;
121  if (my $err = $thr->error) {
122   die $err;
123  }
124 }
125
126 is_loaded 0, 'main body, after serial loadings';
127
128 # Test nested loadings
129
130 SKIP: {
131  my $thr = spawn(sub {
132   my $here = 'parent thread';
133   is_loaded 0, "$here, beginning";
134
135   SKIP: {
136    my $kid = spawn(sub {
137     my $here = 'child thread';
138     is_loaded 0, "$here, beginning";
139
140     do_load;
141     is_loaded 1, "$here, after loading";
142
143     return;
144    });
145
146    skip "$could_not_create_thread (nested child)" => 2 unless defined $kid;
147
148    $kid->join;
149    if (my $err = $kid->error) {
150     die "in child thread: $err\n";
151    }
152   }
153
154   is_loaded 0, "$here, after child terminated";
155
156   do_load;
157   is_loaded 1, "$here, after loading";
158
159   return;
160  });
161
162  skip "$could_not_create_thread (nested parent)" => (3 + 2) unless defined $thr;
163
164  $thr->join;
165  if (my $err = $thr->error) {
166   die $err;
167  }
168 }
169
170 is_loaded 0, 'main body, after nested loadings';
171
172 # Test parallel loadings
173
174 use threads;
175 use threads::shared;
176
177 my @locks = (1) x 5;
178 share($_) for @locks;
179
180 sub sync_master {
181  my ($id) = @_;
182
183  {
184   lock $locks[$id];
185   $locks[$id] = 0;
186   cond_broadcast $locks[$id];
187  }
188 }
189
190 sub sync_slave {
191  my ($id) = @_;
192
193  {
194   lock $locks[$id];
195   cond_wait $locks[$id] until $locks[$id] == 0;
196  }
197 }
198
199 SKIP: {
200  my $thr1 = spawn(sub {
201   my $here = 'first simultaneous thread';
202   is_loaded 0, "$here, beginning";
203   sync_slave 0;
204
205   do_load;
206   is_loaded 1, "$here, after loading";
207   sync_slave 1;
208   sync_slave 2;
209
210   sync_slave 3;
211   is_loaded 1, "$here, still loaded while also loaded in the other thread";
212   sync_slave 4;
213
214   is_loaded 1, "$here, end";
215
216   return;
217  });
218
219  skip "$could_not_create_thread (parallel 1)" => (4 * 2) unless defined $thr1;
220
221  my $thr2 = spawn(sub {
222   my $here = 'second simultaneous thread';
223   is_loaded 0, "$here, beginning";
224   sync_slave 0;
225
226   sync_slave 1;
227   is_loaded 0, "$here, loaded in other thread but not here";
228   sync_slave 2;
229
230   do_load;
231   is_loaded 1, "$here, after loading";
232   sync_slave 3;
233   sync_slave 4;
234
235   is_loaded 1, "$here, end";
236
237   return;
238  });
239
240  sync_master($_) for 0 .. $#locks;
241
242  $thr1->join;
243  if (my $err = $thr1->error) {
244   die $err;
245  }
246
247  skip "$could_not_create_thread (parallel 2)" => (4 * 1) unless defined $thr2;
248
249  $thr2->join;
250  if (my $err = $thr2->error) {
251   die $err;
252  }
253 }
254
255 is_loaded 0, 'main body, after simultaneous threads';
256
257 do_load;
258 is_loaded 1, 'main body, loaded at end';