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   1539 use strict;
  99         175  
  99         2422  
3 99     99   449 use warnings;
  99         165  
  99         2367  
4              
5 99     99   457 use Config;
  99         168  
  99         4053  
6 99     99   601 use Carp qw/confess carp longmess/;
  99         187  
  99         6602  
7              
8             use Test::Stream::HashBase(
9 99         766 accessors => [qw/no_fatal/],
10 99     99   1034 );
  99         174  
11              
12             sub import {
13 106     106   268 my $class = shift;
14 106 100       2557 return if $class eq __PACKAGE__;
15 3         11 $class->register_drivers($class);
16             }
17              
18             my @DRIVERS;
19             *register_driver = \®ister_drivers;
20             sub register_drivers {
21 5     5 1 14 my $class = shift;
22 5         11 my %seen = map {($_ => 1)} @DRIVERS;
  5         24  
23 5         13 push @DRIVERS => grep { !$seen{$_} } @_;
  7         33  
24             }
25              
26             sub drivers {
27 301 100   301 1 1018 unless(@DRIVERS) {
28             # Fallback to files
29 99         57806 require Test::Stream::IPC::Files;
30 99         634 push @DRIVERS => 'Test::Stream::IPC::Files';
31             }
32              
33 301         1115 return @DRIVERS;
34             }
35              
36             sub init {
37 161     161 0 292 my $class = shift;
38              
39 161         542 for my $driver ($class->drivers) {
40 161 100       1227 next unless $driver->is_viable;
41 160   100     969 my $ipc = $driver->new || next;
42 159         816 return $ipc;
43             }
44              
45 2         26 die "Could not find a viable IPC driver! Aborting...\n";
46             }
47              
48             my $POLLING = 0;
49 4     4 0 40 sub polling_enabled { $POLLING }
50             sub enable_polling {
51 3 100   3 1 16 return if $POLLING++;
52 2         20 require Test::Stream::Context;
53 2     17   38 Test::Stream::Context->ON_INIT(sub { $_[0]->hub->cull });
  17         60  
54             }
55              
56             for my $meth (qw/send cull add_hub drop_hub waiting is_viable/) {
57 99     99   546 no strict 'refs';
  99         168  
  99         20611  
58             *$meth = sub {
59 6     6   35 my $thing = shift;
60 6         915 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 4981 my $self = shift;
71 14         61 chomp(my ($msg) = @_);
72 14         138 print STDERR "IPC Fatal Error: $msg\n";
73 14         55 print STDOUT "not ok - IPC Fatal Error\n";
74              
75 14 100       98 CORE::exit(255) unless $self->no_fatal;
76             }
77              
78             sub abort_trace {
79 4     4 1 29 my $self = shift;
80 4         9 my ($msg) = @_;
81 4         476 $self->abort(longmess($msg));
82             }
83              
84              
85             1;
86              
87             __END__