File Coverage

inc/Test/SharedFork.pm

Criterion	Covered	Total	%
statement	49	92	53.2
branch	2	26	7.6
condition	2	9	22.2
subroutine	13	18	72.2
pod	0	3	0.0
total	66	148	44.5

#line 1
package Test::SharedFork;
use strict;
use warnings;
use base 'Test::Builder::Module';
our $VERSION = '0.16';
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;

BEGIN {
    my $builder = __PACKAGE__->builder;

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

    if (Test::Builder->VERSION > 2.00) {
        # new Test::Builder
        $STORE = Test::SharedFork::Store->new();

        our $level = 0;
        for my $class (qw/Test::Builder2::History Test::Builder2::Counter/) {
            my $meta = $class->meta;
            my @methods = $meta->get_method_list;
            my $orig =
                $class eq 'Test::Builder2::History'
              ? $builder->{History}
              : $builder->{History}->counter;
            $orig->{test_sharedfork_hacked}++;
            $STORE->set($class => $orig);
            for my $method (@methods) {
                next if $method =~ /^_/;
                next if $method eq 'meta';
                next if $method eq 'create';
                next if $method eq 'singleton';
                $meta->add_around_method_modifier(
                    $method => sub {
                        my ($code, $orig_self, @args) = @_;
                        return $orig_self->$code(@args) if (! ref $orig_self) || ! $orig_self->{test_sharedfork_hacked};

                        my $lock = $STORE->get_lock();
                        local $level = $level + 1;
                        my $self =
                          $level == 1 ? $STORE->get($class) : $orig_self;

                        my $ret = Test::SharedFork::Contextual::call(sub { $self->$code(@args) });
                        $STORE->set($class => $self);
                        return $ret->result;
                    },
                );
            }
        }
    } 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->{Test_Results} },
                'Test::SharedFork::Array', $store, 'Test_Results';
            },
            init => +{
                Test_Results => $builder->{Test_Results},
                Curr_Test    => $builder->{Curr_Test},
            },
        );
    }

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

}

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

1;
__END__