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