File Coverage

blib/lib/Test/TCP.pm
Criterion Covered Total %
statement 95 95 100.0
branch 38 44 86.3
condition 11 17 64.7
subroutine 19 19 100.0
pod 7 7 100.0
total 170 182 93.4


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             # process does not die when received SIGTERM, on win32.
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; # make sure
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             # backward compat
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             # OO-ish interface
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 ) { # parent process.
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 { # child process
100 3   33     216         $self->{code}->($self->{socket} || $self->port);
101             # should not reach here
102 2 100       6005712         if (kill 0, $self->{_my_pid}) { # warn only parent process still exists
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             # This is a workaround for win32 fork emulation's bug.
116             #
117             # kill is inherently unsafe for pseudo-processes in Windows
118             # and the process calling kill(9, $pid) may be destabilized
119             # The call to Sleep will decrease the frequency of this problems
120             #
121             # SEE ALSO:
122             # http://www.gossamer-threads.com/lists/perl/porters/261805
123             # https://rt.cpan.org/Ticket/Display.html?id=67292
124 14 50       99     Win32::Sleep(0) if $^O eq "MSWin32"; # will relinquish the remainder of its time slice
125              
126 14         2886         kill $TERMSIG => $self->{pid};
127              
128 14 50       96     Win32::Sleep(0) if $^O eq "MSWin32"; # will relinquish the remainder of its time slice
129              
130              
131 14         120     local $?; # waitpid modifies original $?.
132 14         39     LOOP: while (1) {
133 27         255535         my $kid = waitpid( $self->{pid}, 0 );
134 27 50       205         if ($^O ne 'MSWin32') { # i'm not in hell
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