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 stmt bran cond sub pod time code
1             #line 1
2 55     55   346 package Test::SharedFork;
  55         121  
  55         2138  
3 55     55   324 use strict;
  55         122  
  55         2092  
4 55     55   311 use warnings;
  55         110  
  55         22236  
5             use base 'Test::Builder::Module';
6 55     55   343 our $VERSION = '0.16';
  55         1734  
  55         1666  
7 55     55   33170 use Test::Builder 0.32; # 0.32 or later is needed
  55         185  
  55         1511  
8 55     55   36148 use Test::SharedFork::Scalar;
  55         200  
  55         2106  
9 55     55   33154 use Test::SharedFork::Array;
  55         246  
  55         1818  
10 55     55   358 use Test::SharedFork::Store;
  55         117  
  55         2619  
11 55     55   1434 use Config;
  55         247  
  55         39832  
12             use 5.008000;
13              
14             {
15             package #
16             Test::SharedFork::Contextual;
17              
18 0     0     sub call {
19 0           my $code = shift;
20 0 0         my $wantarray = [caller(1)]->[5];
    0          
21 0           if ($wantarray) {
22 0           my @result = $code->();
23             bless {result => \@result, wantarray => $wantarray}, __PACKAGE__;
24 0           } elsif (defined $wantarray) {
25 0           my $result = $code->();
26             bless {result => $result, wantarray => $wantarray}, __PACKAGE__;
27 0           } else {
  0            
28 0           { ; $code->(); } # void context
29             bless {wantarray => $wantarray}, __PACKAGE__;
30             }
31             }
32              
33 0     0     sub result {
34 0 0         my $self = shift;
    0          
35 0           if ($self->{wantarray}) {
  0            
36             return @{ $self->{result} };
37 0           } elsif (defined $self->{wantarray}) {
38             return $self->{result};
39 0           } else {
40             return;
41             }
42             }
43             }
44              
45             my $STORE;
46              
47 55     55   823 BEGIN {
48             my $builder = __PACKAGE__->builder;
49 55 50 33     1341  
      33        
50 0         0 if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) {
51             die "# Current version of Test::SharedFork does not supports ithreads.";
52             }
53 55 50       1280  
54             if (Test::Builder->VERSION > 2.00) {
55 0         0 # new Test::Builder
56             $STORE = Test::SharedFork::Store->new();
57 0         0  
58 0         0 our $level = 0;
59 0         0 for my $class (qw/Test::Builder2::History Test::Builder2::Counter/) {
60 0         0 my $meta = $class->meta;
61 0 0       0 my @methods = $meta->get_method_list;
62             my $orig =
63             $class eq 'Test::Builder2::History'
64             ? $builder->{History}
65 0         0 : $builder->{History}->counter;
66 0         0 $orig->{test_sharedfork_hacked}++;
67 0         0 $STORE->set($class => $orig);
68 0 0       0 for my $method (@methods) {
69 0 0       0 next if $method =~ /^_/;
70 0 0       0 next if $method eq 'meta';
71 0 0       0 next if $method eq 'create';
72             next if $method eq 'singleton';
73             $meta->add_around_method_modifier(
74 0         0 $method => sub {
75 0 0 0     0 my ($code, $orig_self, @args) = @_;
76             return $orig_self->$code(@args) if (! ref $orig_self) || ! $orig_self->{test_sharedfork_hacked};
77 0         0  
78 0         0 my $lock = $STORE->get_lock();
79 0 0       0 local $level = $level + 1;
80             my $self =
81             $level == 1 ? $STORE->get($class) : $orig_self;
82 0         0  
  0         0  
83 0         0 my $ret = Test::SharedFork::Contextual::call(sub { $self->$code(@args) });
84 0         0 $STORE->set($class => $self);
85             return $ret->result;
86 0         0 },
87             );
88             }
89             }
90             } else {
91             # older Test::Builder
92             $STORE = Test::SharedFork::Store->new(
93 55         125 cb => sub {
94 55         853 my $store = shift;
95             tie $builder->{Curr_Test}, 'Test::SharedFork::Scalar',
96 55         134 $store, 'Curr_Test';
  55         651  
97             tie @{ $builder->{Test_Results} },
98             'Test::SharedFork::Array', $store, 'Test_Results';
99 55         1015 },
100             init => +{
101             Test_Results => $builder->{Test_Results},
102             Curr_Test => $builder->{Curr_Test},
103             },
104             );
105             }
106              
107 55     55   384 # make methods atomic.
  55         118  
  55         2355  
108 55     55   321 no strict 'refs';
  55         121  
  55         9937  
109 55         321 no warnings 'redefine';
110 220         371 for my $name (qw/ok skip todo_skip current_test/) {
  220         935  
111 220         5163 my $orig = *{"Test::Builder::${name}"}{CODE};
112 606     606   1414 *{"Test::Builder::${name}"} = sub {
113 606         3841 local $Test::Builder::Level += 3;
114 606         3690 my $lock = $STORE->get_lock(); # RAII
115 220         836 $orig->(@_);
116             };
117             };
118              
119             }
120              
121             {
122 0     0 0   # backward compatibility method
123 0     0 0   sub parent { }
124 0     0 0   sub child { }
125             sub fork { fork() }
126             }
127              
128             1;
129             __END__