File Coverage

blib/lib/Test/SharedFork.pm

Criterion	Covered	Total	%
statement	56	84	66.6
branch	2	18	11.1
condition	2	6	33.3
subroutine	19	21	90.4
pod	0	3	0.0
total	79	132	59.8

package Test::SharedFork;
use strict;
use warnings;
use base 'Test::Builder::Module';
our $VERSION = '0.34';
use Test::Builder 0.32; # 0.32 or later is needed
use Test::SharedFork::Scalar;
use Test::SharedFork::Array;
use Test::SharedFork::Store;
use Config;
use 5.008000;

{
    package #
        Test::SharedFork::Contextual;

    sub call {
        my $code = shift;
        my $wantarray = [caller(1)]->[5];
        if ($wantarray) {
            my @result = $code->();
            bless {result => \@result, wantarray => $wantarray}, __PACKAGE__;
        } elsif (defined $wantarray) {
            my $result = $code->();
            bless {result => $result, wantarray => $wantarray}, __PACKAGE__;
        } else {
            { ; $code->(); } # void context
            bless {wantarray => $wantarray}, __PACKAGE__;
        }
    }

    sub result {
        my $self = shift;
        if ($self->{wantarray}) {
            return @{ $self->{result} };
        } elsif (defined $self->{wantarray}) {
            return $self->{result};
        } else {
            return;
        }
    }
}

my $STORE;

sub _mangle_builder {
    my $builder = shift;

    if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) {
        die "# Current version of Test::SharedFork does not supports ithreads.";
    }

    if ($builder->can("coordinate_forks")) {
        # Use Test::Builder's implementation.
        $builder->new->coordinate_forks(1);
    } elsif($INC{'Test/Stream/Sync.pm'}) {
        require Test::Stream::IPC;
        Test::Stream::IPC->import('poll');
        Test::Stream::IPC->enable_polling if Test::Stream::IPC->can('enable_polling');
        my $stack = $builder->{Stack};
        return if $stack->top->ipc;
        my ($driver) = Test::Stream::IPC->drivers;
        my $ipc = $driver->new();
        for my $hub (@$stack) {
            $hub->set_ipc($ipc);
            $ipc->add_hub($hub->hid);
        }
    } else {
        # older Test::Builder
        $STORE = Test::SharedFork::Store->new(
            cb => sub {
                my $store = shift;
                tie $builder->{Curr_Test}, 'Test::SharedFork::Scalar',
                    $store, 'Curr_Test';
                tie $builder->{Is_Passing}, 'Test::SharedFork::Scalar',
                    $store, 'Is_Passing';
                tie @{ $builder->{Test_Results} },
                    'Test::SharedFork::Array', $store, 'Test_Results';
            },
            init => +{
                Test_Results => $builder->{Test_Results},
                Curr_Test    => $builder->{Curr_Test},
                Is_Passing   => 1,
            },
        );

        # make methods atomic.
        no strict 'refs';
        no warnings 'redefine';
        no warnings 'uninitialized';
        for my $name (qw/ok skip todo_skip current_test is_passing/) {
            my $orig = *{"Test::Builder::${name}"}{CODE};
            *{"Test::Builder::${name}"} = sub {
                local $Test::Builder::Level = $Test::Builder::Level + 1;
                local $Test::Builder::BLevel = $Test::Builder::BLevel + 1;
                my $lock = $STORE->get_lock(); # RAII
                $orig->(@_);
            };
        };
    }
}

BEGIN {
    my $builder = __PACKAGE__->builder;
    _mangle_builder($builder);
}

{
    # backward compatibility method
    sub parent { }
    sub child  { }
    sub fork   { fork() }
}

1;
__END__