cpan/Test-Simple/t/Test2/modules/API/Instance.t

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