cpan/Test-Simple/lib/Test2/API/Instance.pm

   1 package Test2::API::Instance;
   2 use strict;
   3 use warnings;
   4
   5 our $VERSION = '1.302022';
   6
   7
   8 our @CARP_NOT = qw/Test2::API Test2::API::Instance Test2::IPC::Driver Test2::Formatter/;
   9 use Carp qw/confess carp/;
  10 use Scalar::Util qw/reftype/;
  11
  12 use Test2::Util qw/get_tid USE_THREADS CAN_FORK pkg_to_file try/;
  13
  14 use Test2::Util::Trace();
  15 use Test2::API::Stack();
  16
  17 use Test2::Util::HashBase qw{
  18     _pid _tid
  19     no_wait
  20     finalized loaded
  21     ipc stack formatter
  22     contexts
  23
  24     ipc_shm_size
  25     ipc_shm_last
  26     ipc_shm_id
  27     ipc_polling
  28     ipc_drivers
  29     formatters
  30
  31     exit_callbacks
  32     post_load_callbacks
  33     context_acquire_callbacks
  34     context_init_callbacks
  35     context_release_callbacks
  36 };
  37
  38 sub pid { $_[0]->{+_PID} ||= $$ }
  39 sub tid { $_[0]->{+_TID} ||= get_tid() }
  40
  41 # Wrap around the getters that should call _finalize.
  42 BEGIN {
  43     for my $finalizer (IPC, FORMATTER) {
  44         my $orig = __PACKAGE__->can($finalizer);
  45         my $new  = sub {
  46             my $self = shift;
  47             $self->_finalize unless $self->{+FINALIZED};
  48             $self->$orig;
  49         };
  50
  51         no strict 'refs';
  52         no warnings 'redefine';
  53         *{$finalizer} = $new;
  54     }
  55 }
  56
  57 sub import {
  58     my $class = shift;
  59     return unless @_;
  60     my ($ref) = @_;
  61     $$ref = $class->new;
  62 }
  63
  64 sub init { $_[0]->reset }
  65
  66 sub reset {
  67     my $self = shift;
  68
  69     delete $self->{+_PID};
  70     delete $self->{+_TID};
  71
  72     $self->{+CONTEXTS}    = {};
  73
  74     $self->{+IPC_DRIVERS} = [];
  75     $self->{+IPC_POLLING} = undef;
  76
  77     $self->{+FORMATTERS} = [];
  78     $self->{+FORMATTER}  = undef;
  79
  80     $self->{+FINALIZED} = undef;
  81     $self->{+IPC}       = undef;
  82
  83     $self->{+NO_WAIT} = 0;
  84     $self->{+LOADED}  = 0;
  85
  86     $self->{+EXIT_CALLBACKS}            = [];
  87     $self->{+POST_LOAD_CALLBACKS}       = [];
  88     $self->{+CONTEXT_ACQUIRE_CALLBACKS} = [];
  89     $self->{+CONTEXT_INIT_CALLBACKS}    = [];
  90     $self->{+CONTEXT_RELEASE_CALLBACKS} = [];
  91
  92     $self->{+STACK} = Test2::API::Stack->new;
  93 }
  94
  95 sub _finalize {
  96     my $self = shift;
  97     my ($caller) = @_;
  98     $caller ||= [caller(1)];
  99
 100     $self->{+FINALIZED} = $caller;
 101
 102     $self->{+_PID} = $$        unless defined $self->{+_PID};
 103     $self->{+_TID} = get_tid() unless defined $self->{+_TID};
 104
 105     unless ($self->{+FORMATTER}) {
 106         my ($formatter, $source);
 107         if ($ENV{T2_FORMATTER}) {
 108             $source = "set by the 'T2_FORMATTER' environment variable";
 109
 110             if ($ENV{T2_FORMATTER} =~ m/^(\+)?(.*)$/) {
 111                 $formatter = $1 ? $2 : "Test2::Formatter::$2"
 112             }
 113             else {
 114                 $formatter = '';
 115             }
 116         }
 117         elsif (@{$self->{+FORMATTERS}}) {
 118             ($formatter) = @{$self->{+FORMATTERS}};
 119             $source = "Most recently added";
 120         }
 121         else {
 122             $formatter = 'Test2::Formatter::TAP';
 123             $source    = 'default formatter';
 124         }
 125
 126         unless (ref($formatter) || $formatter->can('write')) {
 127             my $file = pkg_to_file($formatter);
 128             my ($ok, $err) = try { require $file };
 129             unless ($ok) {
 130                 my $line   = "* COULD NOT LOAD FORMATTER '$formatter' ($source) *";
 131                 my $border = '*' x length($line);
 132                 die "\n\n  $border\n  $line\n  $border\n\n$err";
 133             }
 134         }
 135
 136         $self->{+FORMATTER} = $formatter;
 137     }
 138
 139     # Turn on IPC if threads are on, drivers are registered, or the Test2::IPC
 140     # module is loaded.
 141     return unless USE_THREADS || $INC{'Test2/IPC.pm'} || @{$self->{+IPC_DRIVERS}};
 142
 143     # Turn on polling by default, people expect it.
 144     $self->enable_ipc_polling;
 145
 146     unless (@{$self->{+IPC_DRIVERS}}) {
 147         my ($ok, $error) = try { require Test2::IPC::Driver::Files };
 148         die $error unless $ok;
 149         push @{$self->{+IPC_DRIVERS}} => 'Test2::IPC::Driver::Files';
 150     }
 151
 152     for my $driver (@{$self->{+IPC_DRIVERS}}) {
 153         next unless $driver->can('is_viable') && $driver->is_viable;
 154         $self->{+IPC} = $driver->new or next;
 155         $self->ipc_enable_shm if $self->{+IPC}->use_shm;
 156         return;
 157     }
 158
 159     die "IPC has been requested, but no viable drivers were found. Aborting...\n";
 160 }
 161
 162 sub formatter_set { $_[0]->{+FORMATTER} ? 1 : 0 }
 163
 164 sub add_formatter {
 165     my $self = shift;
 166     my ($formatter) = @_;
 167     unshift @{$self->{+FORMATTERS}} => $formatter;
 168
 169     return unless $self->{+FINALIZED};
 170
 171     # Why is the @CARP_NOT entry not enough?
 172     local %Carp::Internal = %Carp::Internal;
 173     $Carp::Internal{'Test2::Formatter'} = 1;
 174
 175     carp "Formatter $formatter loaded too late to be used as the global formatter";
 176 }
 177
 178 sub add_context_acquire_callback {
 179     my $self =  shift;
 180     my ($code) = @_;
 181
 182     my $rtype = reftype($code) || "";
 183
 184     confess "Context-acquire callbacks must be coderefs"
 185         unless $code && $rtype eq 'CODE';
 186
 187     push @{$self->{+CONTEXT_ACQUIRE_CALLBACKS}} => $code;
 188 }
 189
 190 sub add_context_init_callback {
 191     my $self =  shift;
 192     my ($code) = @_;
 193
 194     my $rtype = reftype($code) || "";
 195
 196     confess "Context-init callbacks must be coderefs"
 197         unless $code && $rtype eq 'CODE';
 198
 199     push @{$self->{+CONTEXT_INIT_CALLBACKS}} => $code;
 200 }
 201
 202 sub add_context_release_callback {
 203     my $self =  shift;
 204     my ($code) = @_;
 205
 206     my $rtype = reftype($code) || "";
 207
 208     confess "Context-release callbacks must be coderefs"
 209         unless $code && $rtype eq 'CODE';
 210
 211     push @{$self->{+CONTEXT_RELEASE_CALLBACKS}} => $code;
 212 }
 213
 214 sub add_post_load_callback {
 215     my $self = shift;
 216     my ($code) = @_;
 217
 218     my $rtype = reftype($code) || "";
 219
 220     confess "Post-load callbacks must be coderefs"
 221         unless $code && $rtype eq 'CODE';
 222
 223     push @{$self->{+POST_LOAD_CALLBACKS}} => $code;
 224     $code->() if $self->{+LOADED};
 225 }
 226
 227 sub load {
 228     my $self = shift;
 229     unless ($self->{+LOADED}) {
 230         $self->{+_PID} = $$        unless defined $self->{+_PID};
 231         $self->{+_TID} = get_tid() unless defined $self->{+_TID};
 232
 233         # This is for https://github.com/Test-More/test-more/issues/16
 234         # and https://rt.perl.org/Public/Bug/Display.html?id=127774
 235         # END blocks run in reverse order. This insures the END block is loaded
 236         # as late as possible. It will not solve all cases, but it helps.
 237         eval "END { Test2::API::test2_set_is_end() }; 1" or die $@;
 238
 239         $self->{+LOADED} = 1;
 240         $_->() for @{$self->{+POST_LOAD_CALLBACKS}};
 241     }
 242     return $self->{+LOADED};
 243 }
 244
 245 sub add_exit_callback {
 246     my $self = shift;
 247     my ($code) = @_;
 248     my $rtype = reftype($code) || "";
 249
 250     confess "End callbacks must be coderefs"
 251         unless $code && $rtype eq 'CODE';
 252
 253     push @{$self->{+EXIT_CALLBACKS}} => $code;
 254 }
 255
 256 sub add_ipc_driver {
 257     my $self = shift;
 258     my ($driver) = @_;
 259     unshift @{$self->{+IPC_DRIVERS}} => $driver;
 260
 261     return unless $self->{+FINALIZED};
 262
 263     # Why is the @CARP_NOT entry not enough?
 264     local %Carp::Internal = %Carp::Internal;
 265     $Carp::Internal{'Test2::IPC::Driver'} = 1;
 266
 267     carp "IPC driver $driver loaded too late to be used as the global ipc driver";
 268 }
 269
 270 sub enable_ipc_polling {
 271     my $self = shift;
 272
 273     $self->add_context_init_callback(
 274         # This is called every time a context is created, it needs to be fast.
 275         # $_[0] is a context object
 276         sub {
 277             return unless $self->{+IPC_POLLING};
 278             return $_[0]->{hub}->cull unless $self->{+IPC_SHM_ID};
 279
 280             my $val;
 281             {
 282                 shmread($self->{+IPC_SHM_ID}, $val, 0, $self->{+IPC_SHM_SIZE}) or return;
 283
 284                 return if $val eq $self->{+IPC_SHM_LAST};
 285                 $self->{+IPC_SHM_LAST} = $val;
 286             }
 287
 288             $_[0]->{hub}->cull;
 289         }
 290     ) unless defined $self->ipc_polling;
 291
 292     $self->set_ipc_polling(1);
 293 }
 294
 295 sub ipc_enable_shm {
 296     my $self = shift;
 297
 298     return 1 if defined $self->{+IPC_SHM_ID};
 299
 300     my ($ok, $err) = try {
 301         require IPC::SysV;
 302
 303         my $ipc_key = IPC::SysV::IPC_PRIVATE();
 304         my $shm_size = $self->{+IPC}->can('shm_size') ? $self->{+IPC}->shm_size : 64;
 305         my $shm_id = shmget($ipc_key, $shm_size, 0666) or die;
 306
 307         my $initial = 'a' x $shm_size;
 308         shmwrite($shm_id, $initial, 0, $shm_size) or die;
 309
 310         $self->{+IPC_SHM_SIZE} = $shm_size;
 311         $self->{+IPC_SHM_ID}   = $shm_id;
 312         $self->{+IPC_SHM_LAST} = $initial;
 313     };
 314
 315     return $ok;
 316 }
 317
 318 sub ipc_free_shm {
 319     my $self = shift;
 320
 321     my $id = delete $self->{+IPC_SHM_ID};
 322     return unless defined $id;
 323
 324     shmctl($id, IPC::SysV::IPC_RMID(), 0);
 325 }
 326
 327 sub get_ipc_pending {
 328     my $self = shift;
 329     return -1 unless defined $self->{+IPC_SHM_ID};
 330     my $val;
 331     shmread($self->{+IPC_SHM_ID}, $val, 0, $self->{+IPC_SHM_SIZE}) or return -1;
 332     return 0 if $val eq $self->{+IPC_SHM_LAST};
 333     $self->{+IPC_SHM_LAST} = $val;
 334     return 1;
 335 }
 336
 337 sub set_ipc_pending {
 338     my $self = shift;
 339
 340     return undef unless defined $self->{+IPC_SHM_ID};
 341
 342     my ($val) = @_;
 343
 344     confess "value is required for set_ipc_pending"
 345         unless $val;
 346
 347     shmwrite($self->{+IPC_SHM_ID}, $val, 0, $self->{+IPC_SHM_SIZE});
 348 }
 349
 350 sub disable_ipc_polling {
 351     my $self = shift;
 352     return unless defined $self->{+IPC_POLLING};
 353     $self->{+IPC_POLLING} = 0;
 354 }
 355
 356 sub _ipc_wait {
 357     my $fail = 0;
 358
 359     if (CAN_FORK) {
 360         while (1) {
 361             my $pid = CORE::wait();
 362             my $err = $?;
 363             last if $pid == -1;
 364             next unless $err;
 365             $fail++;
 366             $err = $err >> 8;
 367             warn "Process $pid did not exit cleanly (status: $err)\n";
 368         }
 369     }
 370
 371     if (USE_THREADS) {
 372         for my $t (threads->list()) {
 373             $t->join;
 374             # In older threads we cannot check if a thread had an error unless
 375             # we control it and its return.
 376             my $err = $t->can('error') ? $t->error : undef;
 377             next unless $err;
 378             my $tid = $t->tid();
 379             $fail++;
 380             chomp($err);
 381             warn "Thread $tid did not end cleanly: $err\n";
 382         }
 383     }
 384
 385     return 0 unless $fail;
 386     return 255;
 387 }
 388
 389 sub DESTROY {
 390     my $self = shift;
 391
 392     return unless defined($self->{+_PID}) && $self->{+_PID} == $$;
 393     return unless defined($self->{+_TID}) && $self->{+_TID} == get_tid();
 394
 395     shmctl($self->{+IPC_SHM_ID}, IPC::SysV::IPC_RMID(), 0)
 396         if defined $self->{+IPC_SHM_ID};
 397 }
 398
 399 sub set_exit {
 400     my $self = shift;
 401
 402     my $exit     = $?;
 403     my $new_exit = $exit;
 404
 405     if ($INC{'Test/Builder.pm'} && $Test::Builder::VERSION ne $Test2::API::VERSION) {
 406         print STDERR <<"        EOT";
 407
 408 ********************************************************************************
 409 *                                                                              *
 410 *            Test::Builder -- Test2::API version mismatch detected             *
 411 *                                                                              *
 412 ********************************************************************************
 413    Test2::API Version: $Test2::API::VERSION
 414 Test::Builder Version: $Test::Builder::VERSION
 415
 416 This is not a supported configuration, you will have problems.
 417
 418         EOT
 419     }
 420
 421     for my $ctx (values %{$self->{+CONTEXTS}}) {
 422         next unless $ctx;
 423
 424         next if $ctx->_aborted && ${$ctx->_aborted};
 425
 426         # Only worry about contexts in this PID
 427         my $trace = $ctx->trace || next;
 428         next unless $trace->pid && $trace->pid == $$;
 429
 430         # Do not worry about contexts that have no hub
 431         my $hub = $ctx->hub  || next;
 432
 433         # Do not worry if the state came to a sudden end.
 434         next if $hub->bailed_out;
 435         next if defined $hub->skip_reason;
 436
 437         # now we worry
 438         $trace->alert("context object was never released! This means a testing tool is behaving very badly");
 439
 440         $exit     = 255;
 441         $new_exit = 255;
 442     }
 443
 444     if (!defined($self->{+_PID}) or !defined($self->{+_TID}) or $self->{+_PID} != $$ or $self->{+_TID} != get_tid()) {
 445         $? = $exit;
 446         return;
 447     }
 448
 449     my @hubs = $self->{+STACK} ? $self->{+STACK}->all : ();
 450
 451     if (@hubs and $self->{+IPC} and !$self->{+NO_WAIT}) {
 452         local $?;
 453         my %seen;
 454         for my $hub (reverse @hubs) {
 455             my $ipc = $hub->ipc or next;
 456             next if $seen{$ipc}++;
 457             $ipc->waiting();
 458         }
 459
 460         my $ipc_exit = _ipc_wait();
 461         $new_exit ||= $ipc_exit;
 462     }
 463
 464     # None of this is necessary if we never got a root hub
 465     if(my $root = shift @hubs) {
 466         my $trace = Test2::Util::Trace->new(
 467             frame  => [__PACKAGE__, __FILE__, 0, __PACKAGE__ . '::END'],
 468             detail => __PACKAGE__ . ' END Block finalization',
 469         );
 470         my $ctx = Test2::API::Context->new(
 471             trace => $trace,
 472             hub   => $root,
 473         );
 474
 475         if (@hubs) {
 476             $ctx->diag("Test ended with extra hubs on the stack!");
 477             $new_exit  = 255;
 478         }
 479
 480         unless ($root->no_ending) {
 481             local $?;
 482             $root->finalize($trace) unless $root->ended;
 483             $_->($ctx, $exit, \$new_exit) for @{$self->{+EXIT_CALLBACKS}};
 484             $new_exit ||= $root->failed;
 485         }
 486     }
 487
 488     $new_exit = 255 if $new_exit > 255;
 489
 490     if ($new_exit) {
 491         require Test2::API::Breakage;
 492         my @warn = Test2::API::Breakage->report();
 493
 494         if (@warn) {
 495             print STDERR "\nYou have loaded versions of test modules known to have problems with Test2.\nThis could explain some test failures.\n";
 496             print STDERR "$_\n" for @warn;
 497             print STDERR "\n";
 498         }
 499     }
 500
 501     $? = $new_exit;
 502 }
 503
 504 1;
 505
 506 __END__
 507
 508 =pod
 509
 510 =encoding UTF-8
 511
 512 =head1 NAME
 513
 514 Test2::API::Instance - Object used by Test2::API under the hood
 515
 516 =head1 DESCRIPTION
 517
 518 This object encapsulates the global shared state tracked by
 519 L<Test2>. A single global instance of this package is stored (and
 520 obscured) by the L<Test2::API> package.
 521
 522 There is no reason to directly use this package. This package is documented for
 523 completeness. This package can change, or go away completely at any time.
 524 Directly using, or monkeypatching this package is not supported in any way
 525 shape or form.
 526
 527 =head1 SYNOPSIS
 528
 529     use Test2::API::Instance;
 530
 531     my $obj = Test2::API::Instance->new;
 532
 533 =over 4
 534
 535 =item $pid = $obj->pid
 536
 537 PID of this instance.
 538
 539 =item $obj->tid
 540
 541 Thread ID of this instance.
 542
 543 =item $obj->reset()
 544
 545 Reset the object to defaults.
 546
 547 =item $obj->load()
 548
 549 Set the internal state to loaded, and run and stored post-load callbacks.
 550
 551 =item $bool = $obj->loaded
 552
 553 Check if the state is set to loaded.
 554
 555 =item $arrayref = $obj->post_load_callbacks
 556
 557 Get the post-load callbacks.
 558
 559 =item $obj->add_post_load_callback(sub { ... })
 560
 561 Add a post-load callback. If C<load()> has already been called then the callback will
 562 be immediately executed. If C<load()> has not been called then the callback will be
 563 stored and executed later when C<load()> is called.
 564
 565 =item $hashref = $obj->contexts()
 566
 567 Get a hashref of all active contexts keyed by hub id.
 568
 569 =item $arrayref = $obj->context_acquire_callbacks
 570
 571 Get all context acquire callbacks.
 572
 573 =item $arrayref = $obj->context_init_callbacks
 574
 575 Get all context init callbacks.
 576
 577 =item $arrayref = $obj->context_release_callbacks
 578
 579 Get all context release callbacks.
 580
 581 =item $obj->add_context_init_callback(sub { ... })
 582
 583 Add a context init callback. Subs are called every time a context is created. Subs
 584 get the newly created context as their only argument.
 585
 586 =item $obj->add_context_release_callback(sub { ... })
 587
 588 Add a context release callback. Subs are called every time a context is released. Subs
 589 get the released context as their only argument. These callbacks should not
 590 call release on the context.
 591
 592 =item $obj->set_exit()
 593
 594 This is intended to be called in an C<END { ... }> block. This will look at
 595 test state and set $?. This will also call any end callbacks, and wait on child
 596 processes/threads.
 597
 598 =item $obj->ipc_enable_shm()
 599
 600 Turn on SHM for IPC (if possible)
 601
 602 =item $shm_id = $obj->ipc_shm_id()
 603
 604 If SHM is enabled for IPC this will be the shm_id for it.
 605
 606 =item $shm_size = $obj->ipc_shm_size()
 607
 608 If SHM is enabled for IPC this will be the size of it.
 609
 610 =item $shm_last_val = $obj->ipc_shm_last()
 611
 612 If SHM is enabled for IPC this will return the last SHM value seen.
 613
 614 =item $obj->set_ipc_pending($val)
 615
 616 use the IPC SHM to tell other processes and threads there is a pending event.
 617 C<$val> should be a unique value no other thread/process will generate.
 618
 619 B<Note:> This will also make the current process see a pending event. It does
 620 not set C<ipc_shm_last()>, this is important because doing so could hide a
 621 previous change.
 622
 623 =item $pending = $obj->get_ipc_pending()
 624
 625 This returns -1 if SHM is not enabled for IPC.
 626
 627 This returns 0 if the SHM value matches the last known value, which means there
 628 are no pending events.
 629
 630 This returns 1 if the SHM value has changed, which means there are probably
 631 pending events.
 632
 633 When 1 is returned this will set C<< $obj->ipc_shm_last() >>.
 634
 635 =item $drivers = $obj->ipc_drivers
 636
 637 Get the list of IPC drivers.
 638
 639 =item $obj->add_ipc_driver($DRIVER_CLASS)
 640
 641 Add an IPC driver to the list. The most recently added IPC driver will become
 642 the global one during initialization. If a driver is added after initialization
 643 has occurred a warning will be generated:
 644
 645     "IPC driver $driver loaded too late to be used as the global ipc driver"
 646
 647 =item $bool = $obj->ipc_polling
 648
 649 Check if polling is enabled.
 650
 651 =item $obj->enable_ipc_polling
 652
 653 Turn on polling. This will cull events from other processes and threads every
 654 time a context is created.
 655
 656 =item $obj->disable_ipc_polling
 657
 658 Turn off IPC polling.
 659
 660 =item $bool = $obj->no_wait
 661
 662 =item $bool = $obj->set_no_wait($bool)
 663
 664 Get/Set no_wait. This option is used to turn off process/thread waiting at exit.
 665
 666 =item $arrayref = $obj->exit_callbacks
 667
 668 Get the exit callbacks.
 669
 670 =item $obj->add_exit_callback(sub { ... })
 671
 672 Add an exit callback. This callback will be called by C<set_exit()>.
 673
 674 =item $bool = $obj->finalized
 675
 676 Check if the object is finalized. Finalization happens when either C<ipc()>,
 677 C<stack()>, or C<format()> are called on the object. Once finalization happens
 678 these fields are considered unchangeable (not enforced here, enforced by
 679 L<Test2>).
 680
 681 =item $ipc = $obj->ipc
 682
 683 Get the one true IPC instance.
 684
 685 =item $stack = $obj->stack
 686
 687 Get the one true hub stack.
 688
 689 =item $formatter = $obj->formatter
 690
 691 Get the global formatter. By default this is the C<'Test2::Formatter::TAP'>
 692 package. This could be any package that implements the C<write()> method. This
 693 can also be an instantiated object.
 694
 695 =item $bool = $obj->formatter_set()
 696
 697 Check if a formatter has been set.
 698
 699 =item $obj->add_formatter($class)
 700
 701 =item $obj->add_formatter($obj)
 702
 703 Add a formatter. The most recently added formatter will become the global one
 704 during initialization. If a formatter is added after initialization has occurred
 705 a warning will be generated:
 706
 707     "Formatter $formatter loaded too late to be used as the global formatter"
 708
 709 =back
 710
 711 =head1 SOURCE
 712
 713 The source code repository for Test2 can be found at
 714 F<http://github.com/Test-More/test-more/>.
 715
 716 =head1 MAINTAINERS
 717
 718 =over 4
 719
 720 =item Chad Granum E<lt>exodist@cpan.orgE<gt>
 721
 722 =back
 723
 724 =head1 AUTHORS
 725
 726 =over 4
 727
 728 =item Chad Granum E<lt>exodist@cpan.orgE<gt>
 729
 730 =back
 731
 732 =head1 COPYRIGHT
 733
 734 Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
 735
 736 This program is free software; you can redistribute it and/or
 737 modify it under the same terms as Perl itself.
 738
 739 See F<http://dev.perl.org/licenses/>
 740
 741 =cut