1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
|
#line 1
package Test::TCP;
use strict;
use warnings;
use 5.00800;
our $VERSION = '1.13';
use base qw/Exporter/;
use IO::Socket::INET;
use Test::SharedFork 0.12;
use Test::More ();
use Config;
use POSIX;
use Time::HiRes ();
use Carp ();
our @EXPORT = qw/ empty_port test_tcp wait_port /;
# process does not die when received SIGTERM, on win32.
my $TERMSIG = $^O eq 'MSWin32' ? 'KILL' : 'TERM';
# get a empty port on 49152 .. 65535
# http://www.iana.org/assignments/port-numbers
sub empty_port {
my $port = do {
if (@_) {
my $p = $_[0];
$p = 49152 unless $p =~ /^[0-9]+$/ && $p < 49152;
$p;
} else {
50000 + int(rand()*1000);
}
};
while ( $port++ < 60000 ) {
next if _check_port($port);
my $sock = IO::Socket::INET->new(
Listen => 5,
LocalAddr => '127.0.0.1',
LocalPort => $port,
Proto => 'tcp',
(($^O eq 'MSWin32') ? () : (ReuseAddr => 1)),
);
return $port if $sock;
}
die "empty port not found";
}
sub test_tcp {
my %args = @_;
for my $k (qw/client server/) {
die "missing madatory parameter $k" unless exists $args{$k};
}
my $server = Test::TCP->new(
code => $args{server},
port => $args{port} || empty_port(),
);
$args{client}->($server->port, $server->pid);
undef $server; # make sure
}
sub _check_port {
my ($port) = @_;
my $remote = IO::Socket::INET->new(
Proto => 'tcp',
PeerAddr => '127.0.0.1',
PeerPort => $port,
);
if ($remote) {
close $remote;
return 1;
}
else {
return 0;
}
}
sub wait_port {
my $port = shift;
my $retry = 100;
while ( $retry-- ) {
return if _check_port($port);
Time::HiRes::sleep(0.1);
}
die "cannot open port: $port";
}
# -------------------------------------------------------------------------
# OO-ish interface
sub new {
my $class = shift;
my %args = @_==1 ? %{$_[0]} : @_;
Carp::croak("missing mandatory parameter 'code'") unless exists $args{code};
my $self = bless {
auto_start => 1,
_my_pid => $$,
%args,
}, $class;
$self->{port} = Test::TCP::empty_port() unless exists $self->{port};
$self->start()
if $self->{auto_start};
return $self;
}
sub pid { $_[0]->{pid} }
sub port { $_[0]->{port} }
sub start {
my $self = shift;
if ( my $pid = fork() ) {
# parent.
$self->{pid} = $pid;
Test::TCP::wait_port($self->port);
return;
} elsif ($pid == 0) {
# child process
$self->{code}->($self->port);
# should not reach here
if (kill 0, $self->{_my_pid}) { # warn only parent process still exists
warn("[Test::TCP] Child process does not block(PID: $$, PPID: $self->{_my_pid})");
}
exit 0;
} else {
die "fork failed: $!";
}
}
sub stop {
my $self = shift;
return unless defined $self->{pid};
return unless $self->{_my_pid} == $$;
# This is a workaround for win32 fork emulation's bug.
#
# kill is inherently unsafe for pseudo-processes in Windows
# and the process calling kill(9, $pid) may be destabilized
# The call to Sleep will decrease the frequency of this problems
#
# SEE ALSO:
# http://www.gossamer-threads.com/lists/perl/porters/261805
# https://rt.cpan.org/Ticket/Display.html?id=67292
Win32::Sleep(0) if $^O eq "MSWin32"; # will relinquish the remainder of its time slice
kill $TERMSIG => $self->{pid};
Win32::Sleep(0) if $^O eq "MSWin32"; # will relinquish the remainder of its time slice
local $?; # waitpid modifies original $?.
LOOP: while (1) {
my $kid = waitpid( $self->{pid}, 0 );
if ($^O ne 'MSWin32') { # i'm not in hell
if (POSIX::WIFSIGNALED($?)) {
my $signame = (split(' ', $Config{sig_name}))[POSIX::WTERMSIG($?)];
if ($signame =~ /^(ABRT|PIPE)$/) {
Test::More::diag("your server received SIG$signame");
}
}
}
if ($kid == 0 || $kid == -1) {
last LOOP;
}
}
undef $self->{pid};
}
sub DESTROY {
my $self = shift;
local $@;
$self->stop();
}
1;
__END__
=encoding utf8
#line 406
|
