line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Test::TCP; |
2
|
18
|
|
|
18
|
|
211210
|
use strict; |
|
18
|
|
|
|
|
43
|
|
|
18
|
|
|
|
|
454
|
|
3
|
18
|
|
|
18
|
|
81
|
use warnings; |
|
18
|
|
|
|
|
35
|
|
|
18
|
|
|
|
|
387
|
|
4
|
18
|
|
|
18
|
|
298
|
use 5.00800; |
|
18
|
|
|
|
|
62
|
|
5
|
|
|
|
|
|
|
our $VERSION = '2.19'; |
6
|
18
|
|
|
18
|
|
91
|
use base qw/Exporter/; |
|
18
|
|
|
|
|
35
|
|
|
18
|
|
|
|
|
1769
|
|
7
|
18
|
|
|
18
|
|
7214
|
use Test::SharedFork 0.12; |
|
18
|
|
|
|
|
550270
|
|
|
18
|
|
|
|
|
169
|
|
8
|
18
|
|
|
18
|
|
4523
|
use Test::More (); |
|
18
|
|
|
|
|
14856
|
|
|
18
|
|
|
|
|
311
|
|
9
|
18
|
|
|
18
|
|
135
|
use Config; |
|
18
|
|
|
|
|
38
|
|
|
18
|
|
|
|
|
502
|
|
10
|
18
|
|
|
18
|
|
7329
|
use POSIX; |
|
18
|
|
|
|
|
84846
|
|
|
18
|
|
|
|
|
102
|
|
11
|
18
|
|
|
18
|
|
46892
|
use Time::HiRes (); |
|
18
|
|
|
|
|
18557
|
|
|
18
|
|
|
|
|
470
|
|
12
|
18
|
|
|
18
|
|
162
|
use Carp (); |
|
18
|
|
|
|
|
35
|
|
|
18
|
|
|
|
|
311
|
|
13
|
18
|
|
|
18
|
|
6552
|
use Net::EmptyPort qw(empty_port check_port); |
|
18
|
|
|
|
|
55
|
|
|
18
|
|
|
|
|
13364
|
|
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
our @EXPORT = qw/ empty_port test_tcp wait_port /; |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
my $TERMSIG = $^O eq 'MSWin32' ? 'KILL' : 'TERM'; |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
sub test_tcp { |
21
|
17
|
|
|
17
|
1
|
18444
|
my %args = @_; |
22
|
17
|
|
|
|
|
98
|
for my $k (qw/client server/) { |
23
|
33
|
100
|
|
|
|
234
|
die "missing mandatory parameter $k" unless exists $args{$k}; |
24
|
|
|
|
|
|
|
} |
25
|
15
|
|
|
|
|
490
|
my $server_code = delete $args{server}; |
26
|
15
|
|
|
|
|
50
|
my $client_code = delete $args{client}; |
27
|
|
|
|
|
|
|
|
28
|
15
|
|
|
|
|
212
|
my $server = Test::TCP->new( |
29
|
|
|
|
|
|
|
code => $server_code, |
30
|
|
|
|
|
|
|
%args, |
31
|
|
|
|
|
|
|
); |
32
|
13
|
|
|
|
|
105
|
$client_code->($server->port, $server->pid); |
33
|
10
|
|
|
|
|
329822
|
undef $server; |
34
|
|
|
|
|
|
|
} |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
sub wait_port { |
37
|
17
|
|
|
17
|
1
|
4198
|
my ($host, $port, $max_wait); |
38
|
17
|
100
|
100
|
|
|
443
|
if (@_ && ref $_[0] eq 'HASH') { |
|
|
100
|
|
|
|
|
|
39
|
14
|
|
|
|
|
78
|
$host = $_[0]->{host}; |
40
|
14
|
|
|
|
|
79
|
$port = $_[0]->{port}; |
41
|
14
|
|
|
|
|
42
|
$max_wait = $_[0]->{max_wait}; |
42
|
|
|
|
|
|
|
} elsif (@_ == 3) { |
43
|
|
|
|
|
|
|
|
44
|
1
|
|
|
|
|
4
|
($port, (my $sleep), (my $retry)) = @_; |
45
|
1
|
|
|
|
|
3
|
$max_wait = $sleep * $retry; |
46
|
|
|
|
|
|
|
} else { |
47
|
2
|
|
|
|
|
7
|
($port, $max_wait) = @_; |
48
|
|
|
|
|
|
|
} |
49
|
17
|
100
|
|
|
|
117
|
$host = '127.0.0.1' |
50
|
|
|
|
|
|
|
unless defined $host; |
51
|
17
|
|
100
|
|
|
70
|
$max_wait ||= 10; |
52
|
|
|
|
|
|
|
|
53
|
17
|
50
|
|
|
|
349
|
Net::EmptyPort::wait_port({ host => $host, port => $port, max_wait => $max_wait }) |
54
|
|
|
|
|
|
|
or die "cannot open port: $host:$port"; |
55
|
|
|
|
|
|
|
} |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
sub new { |
61
|
21
|
|
|
21
|
1
|
9956
|
my $class = shift; |
62
|
21
|
100
|
|
|
|
176
|
my %args = @_==1 ? %{$_[0]} : @_; |
|
1
|
|
|
|
|
6
|
|
63
|
21
|
100
|
|
|
|
355
|
Carp::croak("missing mandatory parameter 'code'") unless exists $args{code}; |
64
|
20
|
|
|
|
|
345
|
my $self = bless { |
65
|
|
|
|
|
|
|
auto_start => 1, |
66
|
|
|
|
|
|
|
max_wait => 10, |
67
|
|
|
|
|
|
|
host => '127.0.0.1', |
68
|
|
|
|
|
|
|
_my_pid => $$, |
69
|
|
|
|
|
|
|
%args, |
70
|
|
|
|
|
|
|
}, $class; |
71
|
20
|
100
|
|
|
|
213
|
if ($self->{listen}) { |
72
|
|
|
|
|
|
|
$self->{socket} ||= Net::EmptyPort::listen_socket({ |
73
|
|
|
|
|
|
|
host => $self->{host}, |
74
|
|
|
|
|
|
|
proto => $self->{proto}, |
75
|
1
|
50
|
33
|
|
|
10
|
}) or die "Cannot listen: $!"; |
76
|
1
|
|
|
|
|
922
|
$self->{port} = $self->{socket}->sockport; |
77
|
|
|
|
|
|
|
} |
78
|
|
|
|
|
|
|
else { |
79
|
19
|
|
66
|
|
|
294
|
$self->{port} ||= empty_port({ host => $self->{host} }); |
80
|
|
|
|
|
|
|
} |
81
|
|
|
|
|
|
|
$self->start() |
82
|
20
|
100
|
|
|
|
209
|
if $self->{auto_start}; |
83
|
17
|
|
|
|
|
236
|
return $self; |
84
|
|
|
|
|
|
|
} |
85
|
|
|
|
|
|
|
|
86
|
14
|
|
|
14
|
1
|
256043
|
sub pid { $_[0]->{pid} } |
87
|
44
|
|
|
44
|
1
|
15795
|
sub port { $_[0]->{port} } |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
sub start { |
90
|
18
|
|
|
18
|
1
|
49
|
my $self = shift; |
91
|
18
|
|
|
|
|
13394
|
my $pid = fork(); |
92
|
18
|
50
|
|
|
|
740
|
die "fork() failed: $!" unless defined $pid; |
93
|
|
|
|
|
|
|
|
94
|
18
|
100
|
|
|
|
471
|
if ( $pid ) { |
95
|
15
|
|
|
|
|
288
|
$self->{pid} = $pid; |
96
|
|
|
|
|
|
|
Test::TCP::wait_port({ host => $self->{host}, port => $self->port, max_wait => $self->{max_wait} }) |
97
|
15
|
100
|
|
|
|
478
|
unless $self->{socket}; |
98
|
15
|
|
|
|
|
115
|
return; |
99
|
|
|
|
|
|
|
} else { |
100
|
3
|
|
33
|
|
|
216
|
$self->{code}->($self->{socket} || $self->port); |
101
|
|
|
|
|
|
|
|
102
|
2
|
100
|
|
|
|
6005712
|
if (kill 0, $self->{_my_pid}) { |
103
|
1
|
|
|
|
|
65
|
warn("[Test::TCP] Child process does not block(PID: $$, PPID: $self->{_my_pid})"); |
104
|
|
|
|
|
|
|
} |
105
|
2
|
|
|
|
|
44
|
exit 0; |
106
|
|
|
|
|
|
|
} |
107
|
|
|
|
|
|
|
} |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
sub stop { |
110
|
20
|
|
|
20
|
1
|
80
|
my $self = shift; |
111
|
|
|
|
|
|
|
|
112
|
20
|
100
|
|
|
|
703
|
return unless defined $self->{pid}; |
113
|
15
|
100
|
|
|
|
334
|
return unless $self->{_my_pid} == $$; |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
|
124
|
14
|
50
|
|
|
|
99
|
Win32::Sleep(0) if $^O eq "MSWin32"; |
125
|
|
|
|
|
|
|
|
126
|
14
|
|
|
|
|
2886
|
kill $TERMSIG => $self->{pid}; |
127
|
|
|
|
|
|
|
|
128
|
14
|
50
|
|
|
|
96
|
Win32::Sleep(0) if $^O eq "MSWin32"; |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
|
131
|
14
|
|
|
|
|
120
|
local $?; |
132
|
14
|
|
|
|
|
39
|
LOOP: while (1) { |
133
|
27
|
|
|
|
|
255535
|
my $kid = waitpid( $self->{pid}, 0 ); |
134
|
27
|
50
|
|
|
|
205
|
if ($^O ne 'MSWin32') { |
135
|
27
|
100
|
|
|
|
373
|
if (POSIX::WIFSIGNALED($?)) { |
136
|
12
|
|
|
|
|
1343
|
my $signame = (split(' ', $Config{sig_name}))[POSIX::WTERMSIG($?)]; |
137
|
12
|
100
|
|
|
|
210
|
if ($signame =~ /^(ABRT|PIPE)$/) { |
138
|
1
|
|
|
|
|
8
|
Test::More::diag("your server received SIG$signame"); |
139
|
|
|
|
|
|
|
} |
140
|
|
|
|
|
|
|
} |
141
|
|
|
|
|
|
|
} |
142
|
27
|
100
|
66
|
|
|
486
|
if ($kid == 0 || $kid == -1) { |
143
|
14
|
|
|
|
|
80
|
last LOOP; |
144
|
|
|
|
|
|
|
} |
145
|
|
|
|
|
|
|
} |
146
|
14
|
|
|
|
|
468
|
undef $self->{pid}; |
147
|
|
|
|
|
|
|
} |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
sub DESTROY { |
150
|
20
|
|
|
20
|
|
3069669
|
my $self = shift; |
151
|
20
|
|
|
|
|
77
|
local $@; |
152
|
20
|
|
|
|
|
192
|
$self->stop(); |
153
|
|
|
|
|
|
|
} |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
1; |
156
|
|
|
|
|
|
|
__END__ |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
=for stopwords OO |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
=encoding utf8 |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
=head1 NAME |
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
Test::TCP - testing TCP program |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
=head1 SYNOPSIS |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
use Test::TCP; |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
my $server = Test::TCP->new( |
171
|
|
|
|
|
|
|
listen => 1, |
172
|
|
|
|
|
|
|
code => sub { |
173
|
|
|
|
|
|
|
my $socket = shift; |
174
|
|
|
|
|
|
|
... |
175
|
|
|
|
|
|
|
}, |
176
|
|
|
|
|
|
|
); |
177
|
|
|
|
|
|
|
my $client = MyClient->new(host => '127.0.0.1', port => $server->port); |
178
|
|
|
|
|
|
|
undef $server; # kill child process on DESTROY |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
If using a server that can only accept a port number, e.g. memcached: |
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
use Test::TCP; |
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
my $memcached = Test::TCP->new( |
185
|
|
|
|
|
|
|
code => sub { |
186
|
|
|
|
|
|
|
my $port = shift; |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
exec $bin, '-p' => $port; |
189
|
|
|
|
|
|
|
die "cannot execute $bin: $!"; |
190
|
|
|
|
|
|
|
}, |
191
|
|
|
|
|
|
|
); |
192
|
|
|
|
|
|
|
my $memd = Cache::Memcached->new({servers => ['127.0.0.1:' . $memcached->port]}); |
193
|
|
|
|
|
|
|
... |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
B<N.B.>: This is vulnerable to race conditions, if another process binds |
196
|
|
|
|
|
|
|
to the same port after L<Net::EmptyPort> found it available. |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
And functional interface is available: |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
use Test::TCP; |
201
|
|
|
|
|
|
|
test_tcp( |
202
|
|
|
|
|
|
|
listen => 1, |
203
|
|
|
|
|
|
|
client => sub { |
204
|
|
|
|
|
|
|
my ($port, $server_pid) = @_; |
205
|
|
|
|
|
|
|
# send request to the server |
206
|
|
|
|
|
|
|
}, |
207
|
|
|
|
|
|
|
server => sub { |
208
|
|
|
|
|
|
|
my $socket = shift; |
209
|
|
|
|
|
|
|
# run server, calling $socket->accept |
210
|
|
|
|
|
|
|
}, |
211
|
|
|
|
|
|
|
); |
212
|
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
test_tcp( |
214
|
|
|
|
|
|
|
client => sub { |
215
|
|
|
|
|
|
|
my ($port, $server_pid) = @_; |
216
|
|
|
|
|
|
|
# send request to the server |
217
|
|
|
|
|
|
|
}, |
218
|
|
|
|
|
|
|
server => sub { |
219
|
|
|
|
|
|
|
my $port = shift; |
220
|
|
|
|
|
|
|
# run server, binding to $port |
221
|
|
|
|
|
|
|
}, |
222
|
|
|
|
|
|
|
); |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
=head1 DESCRIPTION |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
Test::TCP is a test utility to test TCP/IP-based server programs. |
227
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
=head1 METHODS |
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
=over 4 |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
=item test_tcp |
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
Functional interface. |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
test_tcp( |
237
|
|
|
|
|
|
|
listen => 1, |
238
|
|
|
|
|
|
|
client => sub { |
239
|
|
|
|
|
|
|
my $port = shift; |
240
|
|
|
|
|
|
|
# send request to the server |
241
|
|
|
|
|
|
|
}, |
242
|
|
|
|
|
|
|
server => sub { |
243
|
|
|
|
|
|
|
my $socket = shift; |
244
|
|
|
|
|
|
|
# run server |
245
|
|
|
|
|
|
|
}, |
246
|
|
|
|
|
|
|
# optional |
247
|
|
|
|
|
|
|
host => '127.0.0.1', # specify '::1' to test using IPv6 |
248
|
|
|
|
|
|
|
port => 8080, |
249
|
|
|
|
|
|
|
max_wait => 3, # seconds |
250
|
|
|
|
|
|
|
); |
251
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
If C<listen> is false, C<server> is instead passed a port number that |
253
|
|
|
|
|
|
|
was free before it was called. |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
=item wait_port |
256
|
|
|
|
|
|
|
|
257
|
|
|
|
|
|
|
wait_port(8080); |
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
Waits for a particular port is available for connect. |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
=back |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
=head1 Object Oriented interface |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
=over 4 |
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
=item my $server = Test::TCP->new(%args); |
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
Create new instance of Test::TCP. |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
Arguments are following: |
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
=over 4 |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
=item $args{auto_start}: Boolean |
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
Call C<< $server->start() >> after create instance. |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
Default: true |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
=item $args{code}: CodeRef |
282
|
|
|
|
|
|
|
|
283
|
|
|
|
|
|
|
The callback function. Argument for callback function is: |
284
|
|
|
|
|
|
|
C<< $code->($socket) >> or C<< $code->($port) >>, |
285
|
|
|
|
|
|
|
depending on the value of C<listen>. |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
This parameter is required. |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
=item $args{max_wait} : Number |
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
Will wait for at most C<$max_wait> seconds before checking port. |
292
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
See also L<Net::EmptyPort>. |
294
|
|
|
|
|
|
|
|
295
|
|
|
|
|
|
|
I<Default: 10> |
296
|
|
|
|
|
|
|
|
297
|
|
|
|
|
|
|
=item $args{listen} : Boolean |
298
|
|
|
|
|
|
|
|
299
|
|
|
|
|
|
|
If true, open a listening socket and pass this to the callback. |
300
|
|
|
|
|
|
|
Otherwise find a free port and pass the number of it to the callback. |
301
|
|
|
|
|
|
|
|
302
|
|
|
|
|
|
|
=back |
303
|
|
|
|
|
|
|
|
304
|
|
|
|
|
|
|
=item $server->start() |
305
|
|
|
|
|
|
|
|
306
|
|
|
|
|
|
|
Start the server process. Normally, you don't need to call this method. |
307
|
|
|
|
|
|
|
|
308
|
|
|
|
|
|
|
=item $server->stop() |
309
|
|
|
|
|
|
|
|
310
|
|
|
|
|
|
|
Stop the server process. |
311
|
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
=item my $pid = $server->pid(); |
313
|
|
|
|
|
|
|
|
314
|
|
|
|
|
|
|
Get the pid of child process. |
315
|
|
|
|
|
|
|
|
316
|
|
|
|
|
|
|
=item my $port = $server->port(); |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
Get the port number of child process. |
319
|
|
|
|
|
|
|
|
320
|
|
|
|
|
|
|
=back |
321
|
|
|
|
|
|
|
|
322
|
|
|
|
|
|
|
=head1 FAQ |
323
|
|
|
|
|
|
|
|
324
|
|
|
|
|
|
|
=over 4 |
325
|
|
|
|
|
|
|
|
326
|
|
|
|
|
|
|
=item How to invoke two servers? |
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
You can call test_tcp() twice! |
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
test_tcp( |
331
|
|
|
|
|
|
|
client => sub { |
332
|
|
|
|
|
|
|
my $port1 = shift; |
333
|
|
|
|
|
|
|
test_tcp( |
334
|
|
|
|
|
|
|
client => sub { |
335
|
|
|
|
|
|
|
my $port2 = shift; |
336
|
|
|
|
|
|
|
# some client code here |
337
|
|
|
|
|
|
|
}, |
338
|
|
|
|
|
|
|
server => sub { |
339
|
|
|
|
|
|
|
my $port2 = shift; |
340
|
|
|
|
|
|
|
# some server2 code here |
341
|
|
|
|
|
|
|
}, |
342
|
|
|
|
|
|
|
); |
343
|
|
|
|
|
|
|
}, |
344
|
|
|
|
|
|
|
server => sub { |
345
|
|
|
|
|
|
|
my $port1 = shift; |
346
|
|
|
|
|
|
|
# some server1 code here |
347
|
|
|
|
|
|
|
}, |
348
|
|
|
|
|
|
|
); |
349
|
|
|
|
|
|
|
|
350
|
|
|
|
|
|
|
Or use the OO interface instead. |
351
|
|
|
|
|
|
|
|
352
|
|
|
|
|
|
|
my $server1 = Test::TCP->new(code => sub { |
353
|
|
|
|
|
|
|
my $port1 = shift; |
354
|
|
|
|
|
|
|
... |
355
|
|
|
|
|
|
|
}); |
356
|
|
|
|
|
|
|
my $server2 = Test::TCP->new(code => sub { |
357
|
|
|
|
|
|
|
my $port2 = shift; |
358
|
|
|
|
|
|
|
... |
359
|
|
|
|
|
|
|
}); |
360
|
|
|
|
|
|
|
|
361
|
|
|
|
|
|
|
# your client code here. |
362
|
|
|
|
|
|
|
... |
363
|
|
|
|
|
|
|
|
364
|
|
|
|
|
|
|
=item How do you test server program written in other languages like memcached? |
365
|
|
|
|
|
|
|
|
366
|
|
|
|
|
|
|
You can use C<exec()> in child process. |
367
|
|
|
|
|
|
|
|
368
|
|
|
|
|
|
|
use strict; |
369
|
|
|
|
|
|
|
use warnings; |
370
|
|
|
|
|
|
|
use utf8; |
371
|
|
|
|
|
|
|
use Test::More; |
372
|
|
|
|
|
|
|
use Test::TCP 1.08; |
373
|
|
|
|
|
|
|
use File::Which; |
374
|
|
|
|
|
|
|
|
375
|
|
|
|
|
|
|
my $bin = scalar which 'memcached'; |
376
|
|
|
|
|
|
|
plan skip_all => 'memcached binary is not found' unless defined $bin; |
377
|
|
|
|
|
|
|
|
378
|
|
|
|
|
|
|
my $memcached = Test::TCP->new( |
379
|
|
|
|
|
|
|
code => sub { |
380
|
|
|
|
|
|
|
my $port = shift; |
381
|
|
|
|
|
|
|
|
382
|
|
|
|
|
|
|
exec $bin, '-p' => $port; |
383
|
|
|
|
|
|
|
die "cannot execute $bin: $!"; |
384
|
|
|
|
|
|
|
}, |
385
|
|
|
|
|
|
|
); |
386
|
|
|
|
|
|
|
|
387
|
|
|
|
|
|
|
use Cache::Memcached; |
388
|
|
|
|
|
|
|
my $memd = Cache::Memcached->new({servers => ['127.0.0.1:' . $memcached->port]}); |
389
|
|
|
|
|
|
|
$memd->set(foo => 'bar'); |
390
|
|
|
|
|
|
|
is $memd->get('foo'), 'bar'; |
391
|
|
|
|
|
|
|
|
392
|
|
|
|
|
|
|
done_testing; |
393
|
|
|
|
|
|
|
|
394
|
|
|
|
|
|
|
=item How do I use address other than "127.0.0.1" for testing? |
395
|
|
|
|
|
|
|
|
396
|
|
|
|
|
|
|
You can use the C<< host >> parameter to specify the bind address. |
397
|
|
|
|
|
|
|
|
398
|
|
|
|
|
|
|
# let the server bind to "0.0.0.0" for testing |
399
|
|
|
|
|
|
|
test_tcp( |
400
|
|
|
|
|
|
|
client => sub { |
401
|
|
|
|
|
|
|
... |
402
|
|
|
|
|
|
|
}, |
403
|
|
|
|
|
|
|
server => sub { |
404
|
|
|
|
|
|
|
... |
405
|
|
|
|
|
|
|
}, |
406
|
|
|
|
|
|
|
host => '0.0.0.0', |
407
|
|
|
|
|
|
|
); |
408
|
|
|
|
|
|
|
|
409
|
|
|
|
|
|
|
=item How should I write IPv6 tests? |
410
|
|
|
|
|
|
|
|
411
|
|
|
|
|
|
|
You should use the `Net::EmptyPort::can_bind` function to check if the program can bind to the loopback address of IPv6, as well as the `host` parameter of the `test_tcp` function to specify the same address as the bind address. |
412
|
|
|
|
|
|
|
|
413
|
|
|
|
|
|
|
use Net::EmptyPort qw(can_bind); |
414
|
|
|
|
|
|
|
|
415
|
|
|
|
|
|
|
plan skip_all => "IPv6 not available" |
416
|
|
|
|
|
|
|
unless can_bind('::1'); |
417
|
|
|
|
|
|
|
|
418
|
|
|
|
|
|
|
test_tcp( |
419
|
|
|
|
|
|
|
client => sub { |
420
|
|
|
|
|
|
|
... |
421
|
|
|
|
|
|
|
}, |
422
|
|
|
|
|
|
|
server => sub { |
423
|
|
|
|
|
|
|
... |
424
|
|
|
|
|
|
|
}, |
425
|
|
|
|
|
|
|
host => '::1', |
426
|
|
|
|
|
|
|
); |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
=back |
429
|
|
|
|
|
|
|
|
430
|
|
|
|
|
|
|
=head1 AUTHOR |
431
|
|
|
|
|
|
|
|
432
|
|
|
|
|
|
|
Tokuhiro Matsuno E<lt>tokuhirom@gmail.comE<gt> |
433
|
|
|
|
|
|
|
|
434
|
|
|
|
|
|
|
=head1 THANKS TO |
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
kazuhooku |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
dragon3 |
439
|
|
|
|
|
|
|
|
440
|
|
|
|
|
|
|
charsbar |
441
|
|
|
|
|
|
|
|
442
|
|
|
|
|
|
|
Tatsuhiko Miyagawa |
443
|
|
|
|
|
|
|
|
444
|
|
|
|
|
|
|
lestrrat |
445
|
|
|
|
|
|
|
|
446
|
|
|
|
|
|
|
=head1 SEE ALSO |
447
|
|
|
|
|
|
|
|
448
|
|
|
|
|
|
|
=head1 LICENSE |
449
|
|
|
|
|
|
|
|
450
|
|
|
|
|
|
|
This library is free software; you can redistribute it and/or modify |
451
|
|
|
|
|
|
|
it under the same terms as Perl itself. |
452
|
|
|
|
|
|
|
|
453
|
|
|
|
|
|
|
=cut |
454
|
|
|
|
|
|
|
|