File Coverage

blib/lib/Test/Stream/IPC.pm
Criterion Covered Total %
statement 51 51 100.0
branch 10 10 100.0
condition 2 2 100.0
subroutine 16 16 100.0
pod 5 7 71.4
total 84 86 97.6


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__