File Coverage

blib/lib/Test/UNIXSock.pm
Criterion Covered Total %
statement 88 98 89.8
branch 18 32 56.2
condition 4 8 50.0
subroutine 21 21 100.0
pod 5 7 71.4
total 136 166 81.9


line stmt bran cond sub pod time code
1             package Test::UNIXSock;
2 3     3   143532 use strict;
  3         28  
  3         86  
3 3     3   14 use warnings;
  3         5  
  3         72  
4 3     3   64 use 5.00800;
  3         9  
5             our $VERSION = '0.4';
6 3     3   18 use base qw/Exporter/;
  3         5  
  3         294  
7 3     3   1317 use IO::Socket::UNIX;
  3         59053  
  3         19  
8 3     3   2539 use Test::SharedFork 0.12;
  3         117501  
  3         34  
9 3     3   366 use Test::More ();
  3         5  
  3         47  
10 3     3   15 use Config;
  3         5  
  3         80  
11 3     3   15 use POSIX;
  3         5  
  3         18  
12 3     3   10219 use Time::HiRes ();
  3         3727  
  3         81  
13 3     3   18 use Carp ();
  3         7  
  3         130  
14 3     3   17 use File::Temp qw/ tempdir /;
  3         5  
  3         215  
15 3     3   1445 use Net::EmptyPort ();
  3         26336  
  3         2517  
16              
17             our @EXPORT = qw/ test_unix_sock wait_unix_sock /;
18              
19             my $TERMSIG = 'TERM';
20              
21             sub test_unix_sock {
22 1     1 0 737 my %args = @_;
23 1         4 for my $k (qw/client server/) {
24 2 50       8 die "missing madatory parameter $k" unless exists $args{$k};
25             }
26 1         4 my $server_code = delete $args{server};
27 1         2 my $client_code = delete $args{client};
28              
29 1         8 my $server = Test::UNIXSock->new(
30             code => $server_code,
31             %args,
32             );
33 1         5 $client_code->($server->path, $server->pid);
34 1         17580 undef $server; # make sure
35             }
36              
37             sub wait_unix_sock {
38 2     2 1 19 my ($path, $max_wait);
39 2 50 33     76 if (@_ && ref $_[0] eq 'HASH') {
    0          
40 2         28 $path = $_[0]->{path};
41 2         31 $max_wait = $_[0]->{max_wait};
42             } elsif (@_ == 3) {
43             # backward compat
44 0         0 ($path, (my $sleep), (my $retry)) = @_;
45 0         0 $max_wait = $sleep * $retry;
46             } else {
47 0         0 ($path, $max_wait) = @_;
48             }
49 2   50     76 $max_wait ||= 10;
50 2         60 my $waiter = Net::EmptyPort::_make_waiter($max_wait);
51 2         154 while ( $waiter->() ) {
52 6 100       17332 IO::Socket::UNIX->new(
53             Type => SOCK_STREAM,
54             Peer => $path,
55             ) && return 1;
56             }
57 0         0 return 0;
58             }
59              
60             # -------------------------------------------------------------------------
61             # OO-ish interface
62              
63             sub new {
64 2     2 1 100 my $class = shift;
65 2 50       14 my %args = @_==1 ? %{$_[0]} : @_;
  0         0  
66 2 50       11 Carp::croak("missing mandatory parameter 'code'") unless exists $args{code};
67 2         17 my $self = bless {
68             auto_start => 1,
69             max_wait => 10,
70             _my_pid => $$,
71             %args,
72             }, $class;
73 2 50       17 unless (defined $self->{path}) {
74 2         15 $self->{tmpdir} = tempdir( CLEANUP => 1 );
75 2         1038 $self->{path} = $self->{tmpdir} . "/test.sock";
76             }
77             $self->start()
78 2 50       25 if $self->{auto_start};
79 2         38 return $self;
80             }
81              
82 1     1 1 7 sub pid { $_[0]->{pid} }
83 14     14 0 9326 sub path { $_[0]->{path} }
84              
85             sub start {
86 2     2 1 5 my $self = shift;
87 2         2019 my $pid = fork();
88 2 50       137 die "fork() failed: $!" unless defined $pid;
89              
90 2 50       95 if ( $pid ) { # parent process.
91 2         60 $self->{pid} = $pid;
92 2         84 Test::UNIXSock::wait_unix_sock({ path => $self->path, max_wait => $self->{max_wait} });
93 2         1879 return;
94             } else { # child process
95 0         0 $self->{code}->($self->path);
96             # should not reach here
97 0 0       0 if (kill 0, $self->{_my_pid}) { # warn only parent process still exists
98 0         0 warn("[Test::UNIXSocket] Child process does not block(PID: $$, PPID: $self->{_my_pid})");
99             }
100 0         0 exit 0;
101             }
102             }
103              
104             sub stop {
105 3     3 1 6519 my $self = shift;
106              
107 3 100       185 return unless defined $self->{pid};
108 2 50       13 return unless $self->{_my_pid} == $$;
109              
110 2         280 kill $TERMSIG => $self->{pid};
111              
112 2         29 local $?; # waitpid modifies original $?.
113 2         7 LOOP: while (1) {
114 4         2160 my $kid = waitpid( $self->{pid}, 0 );
115 4 100       61 if (POSIX::WIFSIGNALED($?)) {
116 2         367 my $signame = (split(' ', $Config{sig_name}))[POSIX::WTERMSIG($?)];
117 2 50       30 if ($signame =~ /^(ABRT|PIPE)$/) {
118 0         0 Test::More::diag("your server received SIG$signame");
119             }
120             }
121 4 100 66     37 if ($kid == 0 || $kid == -1) {
122 2         8 last LOOP;
123             }
124             }
125 2         40 undef $self->{pid};
126             }
127              
128             sub DESTROY {
129 2     2   1189 my $self = shift;
130 2         7 local $@;
131 2         14 $self->stop();
132             }
133              
134             1;
135             __END__