1use strict; 2use warnings; 3 4use Test2::IPC; 5use Test2::Tools::Tiny; 6use Test2::Util qw/CAN_THREAD CAN_REALLY_FORK USE_THREADS get_tid/; 7 8ok(1, "Just to get things initialized."); 9 10# We need to control these env vars for this test 11$ENV{T2_NO_IPC} = 0; 12$ENV{T2_TRACE_STAMPS} = 0; 13# This test relies on TAP being the default formatter for non-canon instances 14$ENV{T2_FORMATTER} = 'TAP'; 15 16my $CLASS = 'Test2::API::Instance'; 17 18my $one = $CLASS->new; 19is_deeply( 20 $one, 21 { 22 contexts => {}, 23 24 finalized => undef, 25 ipc => undef, 26 formatter => undef, 27 28 add_uuid_via => undef, 29 30 ipc_polling => undef, 31 ipc_drivers => [], 32 ipc_timeout => 30, 33 ipc_disabled => 0, 34 35 formatters => [], 36 37 no_wait => 0, 38 loaded => 0, 39 40 exit_callbacks => [], 41 post_load_callbacks => [], 42 context_acquire_callbacks => [], 43 context_init_callbacks => [], 44 context_release_callbacks => [], 45 pre_subtest_callbacks => [], 46 47 trace_stamps => 0, 48 49 stack => [], 50 }, 51 "Got initial settings" 52); 53 54%$one = (); 55is_deeply($one, {}, "wiped object"); 56 57$one->reset; 58is_deeply( 59 $one, 60 { 61 contexts => {}, 62 63 ipc_polling => undef, 64 ipc_drivers => [], 65 ipc_timeout => 30, 66 ipc_disabled => 0, 67 68 add_uuid_via => undef, 69 70 formatters => [], 71 72 finalized => undef, 73 ipc => undef, 74 formatter => undef, 75 76 no_wait => 0, 77 loaded => 0, 78 79 exit_callbacks => [], 80 post_load_callbacks => [], 81 context_acquire_callbacks => [], 82 context_init_callbacks => [], 83 context_release_callbacks => [], 84 pre_subtest_callbacks => [], 85 86 trace_stamps => 0, 87 88 stack => [], 89 }, 90 "Reset Object" 91); 92 93ok(!$one->formatter_set, "no formatter set"); 94$one->set_formatter('Foo'); 95ok($one->formatter_set, "formatter set"); 96$one->reset; 97 98my $ran = 0; 99my $callback = sub { $ran++ }; 100$one->add_post_load_callback($callback); 101ok(!$ran, "did not run yet"); 102is_deeply($one->post_load_callbacks, [$callback], "stored callback for later"); 103 104ok(!$one->loaded, "not loaded"); 105$one->load; 106ok($one->loaded, "loaded"); 107is($ran, 1, "ran the callback"); 108 109$one->load; 110is($ran, 1, "Did not run the callback again"); 111 112$one->add_post_load_callback($callback); 113is($ran, 2, "ran the new callback"); 114is_deeply($one->post_load_callbacks, [$callback, $callback], "stored callback for the record"); 115 116like( 117 exception { $one->add_post_load_callback({}) }, 118 qr/Post-load callbacks must be coderefs/, 119 "Post-load callbacks must be coderefs" 120); 121 122$one->reset; 123ok($one->ipc, 'got ipc'); 124ok($one->finalized, "calling ipc finalized the object"); 125 126$one->reset; 127ok($one->stack, 'got stack'); 128ok(!$one->finalized, "calling stack did not finaliz the object"); 129 130$one->reset; 131ok($one->formatter, 'Got formatter'); 132ok($one->finalized, "calling format finalized the object"); 133 134$one->reset; 135$one->set_formatter('Foo'); 136is($one->formatter, 'Foo', "got specified formatter"); 137ok($one->finalized, "calling format finalized the object"); 138 139{ 140 local $ENV{T2_FORMATTER} = 'TAP'; 141 my $one = $CLASS->new; 142 is($one->formatter, 'Test2::Formatter::TAP', "got specified formatter"); 143 ok($one->finalized, "calling format finalized the object"); 144 145 local $ENV{T2_FORMATTER} = '+Test2::Formatter::TAP'; 146 $one->reset; 147 is($one->formatter, 'Test2::Formatter::TAP', "got specified formatter"); 148 ok($one->finalized, "calling format finalized the object"); 149 150 local $ENV{T2_FORMATTER} = '+A::Fake::Module::That::Should::Not::Exist'; 151 $one->reset; 152 like( 153 exception { $one->formatter }, 154 qr/COULD NOT LOAD FORMATTER 'A::Fake::Module::That::Should::Not::Exist' \(set by the 'T2_FORMATTER' environment variable\)/, 155 "Bad formatter" 156 ); 157} 158 159$ran = 0; 160$one->reset; 161$one->add_exit_callback($callback); 162is(@{$one->exit_callbacks}, 1, "added an exit callback"); 163$one->add_exit_callback($callback); 164is(@{$one->exit_callbacks}, 2, "added another exit callback"); 165 166like( 167 exception { $one->add_exit_callback({}) }, 168 qr/End callbacks must be coderefs/, 169 "Exit callbacks must be coderefs" 170); 171 172$one->reset; 173$one->add_pre_subtest_callback($callback); 174is(@{$one->pre_subtest_callbacks}, 1, "added a pre-subtest callback"); 175$one->add_pre_subtest_callback($callback); 176is(@{$one->pre_subtest_callbacks}, 2, "added another pre-subtest callback"); 177 178like( 179 exception { $one->add_pre_subtest_callback({}) }, 180 qr/Pre-subtest callbacks must be coderefs/, 181 "Pre-subtest callbacks must be coderefs" 182); 183 184if (CAN_REALLY_FORK) { 185 my $one = $CLASS->new; 186 my $pid = fork; 187 die "Failed to fork!" unless defined $pid; 188 unless($pid) { exit 0 } 189 190 is(Test2::API::Instance::_ipc_wait, 0, "No errors"); 191 192 $pid = fork; 193 die "Failed to fork!" unless defined $pid; 194 unless($pid) { exit 255 } 195 my @warnings; 196 { 197 local $SIG{__WARN__} = sub { push @warnings => @_ }; 198 is(Test2::API::Instance::_ipc_wait, 255, "Process exited badly"); 199 } 200 like($warnings[0], qr/Process .* did not exit cleanly \(wstat: \S+, exit: 255, sig: 0\)/, "Warn about exit"); 201 202 $pid = fork; 203 die "Failed to fork!" unless defined $pid; 204 unless($pid) { sleep 20; exit 0 } 205 kill('TERM', $pid) or die "Failed to send signal"; 206 @warnings = (); 207 { 208 local $SIG{__WARN__} = sub { push @warnings => @_ }; 209 is(Test2::API::Instance::_ipc_wait, 255, "Process exited badly"); 210 } 211 like($warnings[0], qr/Process .* did not exit cleanly \(wstat: \S+, exit: 0, sig: 15\)/, "Warn about exit"); 212} 213 214if (CAN_THREAD && $] ge '5.010') { 215 require threads; 216 my $one = $CLASS->new; 217 218 threads->new(sub { 1 }); 219 is(Test2::API::Instance::_ipc_wait, 0, "No errors"); 220 221 if (threads->can('error')) { 222 threads->new(sub { 223 close(STDERR); 224 close(STDOUT); 225 die "xxx" 226 }); 227 my @warnings; 228 { 229 local $SIG{__WARN__} = sub { push @warnings => @_ }; 230 is(Test2::API::Instance::_ipc_wait, 255, "Thread exited badly"); 231 } 232 like($warnings[0], qr/Thread .* did not end cleanly: xxx/, "Warn about exit"); 233 } 234} 235 236{ 237 my $one = $CLASS->new; 238 local $? = 0; 239 $one->set_exit; 240 is($?, 0, "no errors on exit"); 241} 242 243{ 244 my $one = $CLASS->new; 245 $one->set__tid(1); 246 local $? = 0; 247 $one->set_exit; 248 is($?, 0, "no errors on exit"); 249} 250 251{ 252 my $one = $CLASS->new; 253 $one->stack->top; 254 $one->set_no_wait(1); 255 local $? = 0; 256 $one->set_exit; 257 is($?, 0, "no errors on exit"); 258} 259 260{ 261 my $one = $CLASS->new; 262 $one->stack->top->set_no_ending(1); 263 local $? = 0; 264 $one->set_exit; 265 is($?, 0, "no errors on exit"); 266} 267 268{ 269 my $one = $CLASS->new; 270 $one->load(); 271 $one->stack->top->set_failed(2); 272 local $? = 0; 273 $one->set_exit; 274 is($?, 2, "number of failures"); 275} 276 277{ 278 my $one = $CLASS->new; 279 $one->load(); 280 local $? = 500; 281 $one->set_exit; 282 is($?, 255, "set exit code to a sane number"); 283} 284 285{ 286 local %INC = %INC; 287 delete $INC{'Test2/IPC.pm'}; 288 my $one = $CLASS->new; 289 $one->load(); 290 my @events; 291 $one->stack->top->filter(sub { push @events => $_[1]; undef}); 292 $one->stack->new_hub; 293 local $? = 0; 294 $one->set_exit; 295 is($?, 255, "errors on exit"); 296 like($events[0]->message, qr/Test ended with extra hubs on the stack!/, "got diag"); 297} 298 299SKIP: { 300 last SKIP if $] lt "5.008"; 301 my $one = $CLASS->new; 302 my $stderr = ""; 303 { 304 local $INC{'Test/Builder.pm'} = __FILE__; 305 local $Test2::API::VERSION = '0.002'; 306 local $Test::Builder::VERSION = '0.001'; 307 local *STDERR; 308 open(STDERR, '>', \$stderr) or print "Failed to open new STDERR"; 309 310 $one->set_exit; 311 } 312 313 is($stderr, <<' EOT', "Got warning about version mismatch"); 314 315******************************************************************************** 316* * 317* Test::Builder -- Test2::API version mismatch detected * 318* * 319******************************************************************************** 320 Test2::API Version: 0.002 321Test::Builder Version: 0.001 322 323This is not a supported configuration, you will have problems. 324 325 EOT 326} 327 328SKIP: { 329 last SKIP if $] lt "5.008"; 330 require Test2::API::Breakage; 331 no warnings qw/redefine once/; 332 my $ran = 0; 333 local *Test2::API::Breakage::report = sub { $ran++; return "foo" }; 334 use warnings qw/redefine once/; 335 my $one = $CLASS->new; 336 $one->load(); 337 338 my $stderr = ""; 339 { 340 local *STDERR; 341 open(STDERR, '>', \$stderr) or print "Failed to open new STDERR"; 342 local $? = 255; 343 $one->set_exit; 344 } 345 346 is($stderr, <<" EOT", "Reported bad modules"); 347 348You have loaded versions of test modules known to have problems with Test2. 349This could explain some test failures. 350foo 351 352 EOT 353} 354 355 356{ 357 my $one = $CLASS->new; 358 $one->load(); 359 my @events; 360 $one->stack->top->filter(sub { push @events => $_[1]; undef}); 361 $one->stack->new_hub; 362 ok($one->stack->top->ipc, "Have IPC"); 363 $one->stack->new_hub; 364 ok($one->stack->top->ipc, "Have IPC"); 365 $one->stack->top->set_ipc(undef); 366 ok(!$one->stack->top->ipc, "no IPC"); 367 $one->stack->new_hub; 368 local $? = 0; 369 $one->set_exit; 370 is($?, 255, "errors on exit"); 371 like($events[0]->message, qr/Test ended with extra hubs on the stack!/, "got diag"); 372} 373 374if (CAN_REALLY_FORK) { 375 local $SIG{__WARN__} = sub { }; 376 my $one = $CLASS->new; 377 my $pid = fork; 378 die "Failed to fork!" unless defined $pid; 379 unless ($pid) { exit 255 } 380 $one->_finalize; 381 $one->stack->top; 382 383 local $? = 0; 384 $one->set_exit; 385 is($?, 255, "errors on exit"); 386 387 $one->reset(); 388 $pid = fork; 389 die "Failed to fork!" unless defined $pid; 390 unless ($pid) { exit 255 } 391 $one->_finalize; 392 $one->stack->top; 393 394 local $? = 122; 395 $one->set_exit; 396 is($?, 122, "kept original exit"); 397} 398 399{ 400 my $one = $CLASS->new; 401 my $ctx = bless { 402 trace => Test2::EventFacet::Trace->new(frame => ['Foo::Bar', 'Foo/Bar.pm', 42, 'xxx']), 403 hub => Test2::Hub->new(), 404 }, 'Test2::API::Context'; 405 $one->contexts->{1234} = $ctx; 406 407 local $? = 500; 408 my $warnings = warnings { $one->set_exit }; 409 is($?, 255, "set exit code to a sane number"); 410 411 is_deeply( 412 $warnings, 413 [ 414 "context object was never released! This means a testing tool is behaving very badly at Foo/Bar.pm line 42.\n" 415 ], 416 "Warned about unfreed context" 417 ); 418 $one->set_no_wait(0); 419} 420 421{ 422 local %INC = %INC; 423 delete $INC{'Test2/IPC.pm'}; 424 delete $INC{'threads.pm'}; 425 ok(!USE_THREADS, "Sanity Check"); 426 427 my $one = $CLASS->new; 428 ok(!$one->ipc, 'IPC not loaded, no IPC object'); 429 ok($one->finalized, "calling ipc finalized the object"); 430 is($one->ipc_polling, undef, "no polling defined"); 431 ok(!@{$one->ipc_drivers}, "no driver"); 432 433 if (CAN_THREAD) { 434 local $INC{'threads.pm'} = 1; 435 no warnings 'once'; 436 local *threads::tid = sub { 0 } unless threads->can('tid'); 437 $one->reset; 438 ok($one->ipc, 'IPC loaded if threads are'); 439 ok($one->finalized, "calling ipc finalized the object"); 440 ok($one->ipc_polling, "polling on by default"); 441 is($one->ipc_drivers->[0], 'Test2::IPC::Driver::Files', "default driver"); 442 } 443 444 { 445 local $INC{'Test2/IPC.pm'} = 1; 446 $one->reset; 447 ok($one->ipc, 'IPC loaded if Test2::IPC is'); 448 ok($one->finalized, "calling ipc finalized the object"); 449 ok($one->ipc_polling, "polling on by default"); 450 is($one->ipc_drivers->[0], 'Test2::IPC::Driver::Files', "default driver"); 451 } 452 453 require Test2::IPC::Driver::Files; 454 $one->reset; 455 $one->add_ipc_driver('Test2::IPC::Driver::Files'); 456 ok($one->ipc, 'IPC loaded if drivers have been added'); 457 ok($one->finalized, "calling ipc finalized the object"); 458 ok($one->ipc_polling, "polling on by default"); 459 460 my $file = __FILE__; 461 my $line = __LINE__ + 1; 462 my $warnings = warnings { $one->add_ipc_driver('Test2::IPC::Driver::Files') }; 463 like( 464 $warnings->[0], 465 qr{^IPC driver Test2::IPC::Driver::Files loaded too late to be used as the global ipc driver at \Q$file\E line $line}, 466 "Got warning at correct frame" 467 ); 468 469 $one->reset; 470 $one->add_ipc_driver('Fake::Fake::XXX'); 471 is( 472 exception { $one->ipc }, 473 "IPC has been requested, but no viable drivers were found. Aborting...\n", 474 "Failed without viable IPC driver" 475 ); 476} 477 478{ 479 my $one = $CLASS->new; 480 $one->{ipc} = Test2::IPC::Driver::Files->new; 481 482 ok(!@{$one->context_init_callbacks}, "no callbacks"); 483 is($one->ipc_polling, undef, "no polling, undef"); 484 485 $one->disable_ipc_polling; 486 ok(!@{$one->context_init_callbacks}, "no callbacks"); 487 is($one->ipc_polling, undef, "no polling, still undef"); 488 489 my $cull = 0; 490 no warnings 'once'; 491 local *Fake::Hub::cull = sub { $cull++ }; 492 use warnings; 493 494 $one->enable_ipc_polling; 495 ok(defined($one->{_pid}), "pid is defined"); 496 ok(defined($one->{_tid}), "tid is defined"); 497 is(@{$one->context_init_callbacks}, 1, "added the callback"); 498 is($one->ipc_polling, 1, "polling on"); 499 $one->context_init_callbacks->[0]->({'hub' => 'Fake::Hub'}); 500 is($cull, 1, "called cull once"); 501 $cull = 0; 502 503 $one->disable_ipc_polling; 504 is(@{$one->context_init_callbacks}, 1, "kept the callback"); 505 is($one->ipc_polling, 0, "no polling, set to 0"); 506 $one->context_init_callbacks->[0]->({'hub' => 'Fake::Hub'}); 507 is($cull, 0, "did not call cull"); 508 $cull = 0; 509 510 $one->enable_ipc_polling; 511 is(@{$one->context_init_callbacks}, 1, "did not add the callback"); 512 is($one->ipc_polling, 1, "polling on"); 513 $one->context_init_callbacks->[0]->({'hub' => 'Fake::Hub'}); 514 is($cull, 1, "called cull once"); 515} 516 517{ 518 require Test2::IPC::Driver::Files; 519 520 local $ENV{T2_NO_IPC} = 1; 521 my $one = $CLASS->new; 522 $one->add_ipc_driver('Test2::IPC::Driver::Files'); 523 ok($one->ipc_disabled, "IPC is disabled by env var"); 524 ok(!$one->ipc, 'IPC not loaded'); 525 526 local $ENV{T2_NO_IPC} = 0; 527 $one->reset; 528 ok(!$one->ipc_disabled, "IPC is not disabled by env var"); 529 ok($one->ipc, 'IPC loaded'); 530 like( 531 exception { $one->ipc_disable }, 532 qr/Attempt to disable IPC after it has been initialized/, 533 "Cannot disable IPC once it is initialized" 534 ); 535 536 $one->reset; 537 ok(!$one->ipc_disabled, "IPC is not disabled by env var"); 538 $one->ipc_disable; 539 ok($one->ipc_disabled, "IPC is disabled directly"); 540} 541 542Test2::API::test2_ipc_wait_enable(); 543 544done_testing; 545