line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Test::Stream::IPC; |
2
|
99
|
|
|
99
|
|
1604
|
use strict; |
|
99
|
|
|
|
|
179
|
|
|
99
|
|
|
|
|
2379
|
|
3
|
99
|
|
|
99
|
|
452
|
use warnings; |
|
99
|
|
|
|
|
166
|
|
|
99
|
|
|
|
|
2373
|
|
4
|
|
|
|
|
|
|
|
5
|
99
|
|
|
99
|
|
460
|
use Config; |
|
99
|
|
|
|
|
191
|
|
|
99
|
|
|
|
|
4134
|
|
6
|
99
|
|
|
99
|
|
485
|
use Carp qw/confess carp longmess/; |
|
99
|
|
|
|
|
192
|
|
|
99
|
|
|
|
|
6434
|
|
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
use Test::Stream::HashBase( |
9
|
99
|
|
|
|
|
768
|
accessors => [qw/no_fatal/], |
10
|
99
|
|
|
99
|
|
1110
|
); |
|
99
|
|
|
|
|
168
|
|
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
sub import { |
13
|
106
|
|
|
106
|
|
260
|
my $class = shift; |
14
|
106
|
100
|
|
|
|
2562
|
return if $class eq __PACKAGE__; |
15
|
3
|
|
|
|
|
10
|
$class->register_drivers($class); |
16
|
|
|
|
|
|
|
} |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
my @DRIVERS; |
19
|
|
|
|
|
|
|
*register_driver = \®ister_drivers; |
20
|
|
|
|
|
|
|
sub register_drivers { |
21
|
5
|
|
|
5
|
1
|
13
|
my $class = shift; |
22
|
5
|
|
|
|
|
8
|
my %seen = map {($_ => 1)} @DRIVERS; |
|
5
|
|
|
|
|
19
|
|
23
|
5
|
|
|
|
|
10
|
push @DRIVERS => grep { !$seen{$_} } @_; |
|
7
|
|
|
|
|
26
|
|
24
|
|
|
|
|
|
|
} |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
sub drivers { |
27
|
301
|
100
|
|
301
|
1
|
977
|
unless(@DRIVERS) { |
28
|
|
|
|
|
|
|
# Fallback to files |
29
|
99
|
|
|
|
|
56560
|
require Test::Stream::IPC::Files; |
30
|
99
|
|
|
|
|
522
|
push @DRIVERS => 'Test::Stream::IPC::Files'; |
31
|
|
|
|
|
|
|
} |
32
|
|
|
|
|
|
|
|
33
|
301
|
|
|
|
|
1170
|
return @DRIVERS; |
34
|
|
|
|
|
|
|
} |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
sub init { |
37
|
161
|
|
|
161
|
0
|
310
|
my $class = shift; |
38
|
|
|
|
|
|
|
|
39
|
161
|
|
|
|
|
549
|
for my $driver ($class->drivers) { |
40
|
161
|
100
|
|
|
|
1261
|
next unless $driver->is_viable; |
41
|
160
|
|
100
|
|
|
939
|
my $ipc = $driver->new || next; |
42
|
159
|
|
|
|
|
859
|
return $ipc; |
43
|
|
|
|
|
|
|
} |
44
|
|
|
|
|
|
|
|
45
|
2
|
|
|
|
|
27
|
die "Could not find a viable IPC driver! Aborting...\n"; |
46
|
|
|
|
|
|
|
} |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
my $POLLING = 0; |
49
|
4
|
|
|
4
|
0
|
36
|
sub polling_enabled { $POLLING } |
50
|
|
|
|
|
|
|
sub enable_polling { |
51
|
3
|
100
|
|
3
|
1
|
27
|
return if $POLLING++; |
52
|
2
|
|
|
|
|
13
|
require Test::Stream::Context; |
53
|
2
|
|
|
17
|
|
15
|
Test::Stream::Context->ON_INIT(sub { $_[0]->hub->cull }); |
|
17
|
|
|
|
|
55
|
|
54
|
|
|
|
|
|
|
} |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
for my $meth (qw/send cull add_hub drop_hub waiting is_viable/) { |
57
|
99
|
|
|
99
|
|
548
|
no strict 'refs'; |
|
99
|
|
|
|
|
185
|
|
|
99
|
|
|
|
|
21287
|
|
58
|
|
|
|
|
|
|
*$meth = sub { |
59
|
6
|
|
|
6
|
|
38
|
my $thing = shift; |
60
|
6
|
|
|
|
|
824
|
confess "'$thing' did not define the required method '$meth'." |
61
|
|
|
|
|
|
|
}; |
62
|
|
|
|
|
|
|
} |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
# Print the error and call exit. We are not using 'die' cause this is a |
65
|
|
|
|
|
|
|
# catastophic error that should never be caught. If we get here it |
66
|
|
|
|
|
|
|
# means some serious shit has happened in a child process, the only way |
67
|
|
|
|
|
|
|
# to inform the parent may be to exit false. |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
sub abort { |
70
|
14
|
|
|
14
|
1
|
5153
|
my $self = shift; |
71
|
14
|
|
|
|
|
59
|
chomp(my ($msg) = @_); |
72
|
14
|
|
|
|
|
96
|
print STDERR "IPC Fatal Error: $msg\n"; |
73
|
14
|
|
|
|
|
44
|
print STDOUT "not ok - IPC Fatal Error\n"; |
74
|
|
|
|
|
|
|
|
75
|
14
|
100
|
|
|
|
88
|
CORE::exit(255) unless $self->no_fatal; |
76
|
|
|
|
|
|
|
} |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
sub abort_trace { |
79
|
4
|
|
|
4
|
1
|
30
|
my $self = shift; |
80
|
4
|
|
|
|
|
10
|
my ($msg) = @_; |
81
|
4
|
|
|
|
|
586
|
$self->abort(longmess($msg)); |
82
|
|
|
|
|
|
|
} |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
1; |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
__END__ |