Bug #67292 for Test-TCP: Tests are blocking in Windows 7. With a prposed patch.

Thu Apr 07 01:38:55 2011 bo.johansson [...] lsn.se - Ticket created

Subject:

Tests are blocking in Windows 7. With a prposed patch.

Problem: The tests in Test::TCP are blocking. Sometimes get the system in state, that it must be restarted. I am using: * Strawberry-perl-5.12.2.0 * Perl 5, version 12, subversion 2 (v5.12.2) built for MSWin32-x86-multi-thread * Windows 7 Home Premium with Service Pack 1 Proposal of change to Test-TCP. =============================== Attached is a patch. The purpose of the patch is to: 1) Reduce the frequency of problems when using kill on a pseudo-proccess in Windows. 2) To avoid to use kill on a pseudo-process in the test of Test-TCP. See also "A safer way to kill pseudo-forked processes on Windows?" in http://www.gossamer-threads.com/lists/perl/porters/261805. This is to reduce the frequency when sub stop or "sub DESTROY" is used: + # 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 + 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 + Other things that perhaps all should be changed. ================================================= In t/01_simple.t What is the purpose of "for 1..10" in this: ok $port, "test case for sharedfork" for 1..10; Can the test for "leaks" be removed? An example is: if ($?) { # It's maybe ActivePerl's bug. # http://ppm4.activestate.com/MSWin32-x86/5.12/1200/T/TO/TOKUHIROM/Test-TCP-1.11.d/log-20101221T221845.txt diag "test_tcp() leaks \$?. Maybe it's Perl bug?: $?"; $? = 0; } Tests made 1. ============= Batchfile used: @echo off set count=0 :loop set /a count=%count%+1 echo Count %count% @echo on perl -Ilib -Iinc t/00_compile.t perl -Ilib -Iinc t/01_simple.t perl -Ilib -Iinc t/02_abrt.t perl -Ilib -Iinc t/03_return_when_sigterm.t perl -Ilib -Iinc t/04_die.t perl -Ilib -Iinc t/05_sigint.t perl -Ilib -Iinc t/06_nest.t perl -Ilib -Iinc t/07_optional.t perl -Ilib -Iinc t/08_exit.t perl -Ilib -Iinc t/09_fork.t perl -Ilib -Iinc t/10_oo.t @echo off goto loop See example of output in attached file log1.txt. Run more than 1000 loops without blocking. Tests made 2. ============= Batchfile used: @echo off set count=0 :loop set /a count=%count%+1 echo Count %count% @echo on perl "-MExtUtils::Command::MM" "-e" "test_harness(0, 'inc', 'lib')" t/00_compile.t t/01_simple.t t/02_abrt.t t/03_return_when_sigterm.t t/04_die.t t/05_sigint.t t/06_nest.t t/07_optional.t t/08_exit.t t/09_fork.t t/10_oo.t @echo off goto loop See example of output in attached file log2.txt. Run more than 1000 loops without blocking.

Subject:

log1.txt

Count 1090 s:\wp\wpPerl\wpTestTcp>perl -Ilib -Iinc t/00_compile.t 1..1 ok 1 - use Test::TCP; # Test::More: 0.98 s:\wp\wpPerl\wpTestTcp>perl -Ilib -Iinc t/01_simple.t 1..22 ok 1 - test case for sharedfork ok 2 - test case for sharedfork ok 3 - test case for sharedfork ok 4 - test case for sharedfork ok 5 - test case for sharedfork ok 6 - test case for sharedfork ok 7 - test case for sharedfork ok 8 - test case for sharedfork ok 9 - test case for sharedfork ok 10 - test case for sharedfork ok 11 - test case for sharedfork ok 12 - test case for sharedfork ok 13 - test case for sharedfork ok 14 - test case for sharedfork ok 15 - test case for sharedfork ok 16 - test case for sharedfork ok 17 - test case for sharedfork ok 18 - test case for sharedfork ok 19 - test case for sharedfork ok 20 - test case for sharedfork # send 1 # new request ok 21 # send 2 # new request ok 22 # finalize # new request # server exit s:\wp\wpPerl\wpTestTcp>perl -Ilib -Iinc t/02_abrt.t 1..0 # SKIP win32 doesn't support embedded function named dump() s:\wp\wpPerl\wpTestTcp>perl -Ilib -Iinc t/03_return_when_sigterm.t 1..2 ok 1 ok 2 - test finished. s:\wp\wpPerl\wpTestTcp>perl -Ilib -Iinc t/04_die.t 1..3 ok 1 ok 2 ok 3 - already killed by test_tcp s:\wp\wpPerl\wpTestTcp>perl -Ilib -Iinc t/05_sigint.t 1..0 # SKIP this test requires SIGUSR1 s:\wp\wpPerl\wpTestTcp>perl -Ilib -Iinc t/06_nest.t 1..1 ok 1 - 10375, 10635 s:\wp\wpPerl\wpTestTcp>perl -Ilib -Iinc t/07_optional.t 1..2 ok 1 - One ok 2 - Two s:\wp\wpPerl\wpTestTcp>perl -Ilib -Iinc t/08_exit.t 1..5 # SEVER: -1120 # CLIENT: -3376 ok 1 # skip not implemented on Win32 ok 2 # skip not implemented on Win32 ok 3 # skip not implemented on Win32 ok 4 # skip not implemented on Win32 ok 5 s:\wp\wpPerl\wpTestTcp>perl -Ilib -Iinc t/09_fork.t 1..6 ok 1 - Successfully forked child -3120 ok 2 - Successfully forked child 0 ok 3 - Successfully executed child -3120 ok 4 - child exited normally ok 5 - socket is connected # new request ok 6 - got expected reply # finalize # new request # server exit # exit s:\wp\wpPerl\wpTestTcp>perl -Ilib -Iinc t/10_oo.t 1..22 ok 1 - test case for sharedfork ok 2 - test case for sharedfork ok 3 - test case for sharedfork ok 4 - test case for sharedfork ok 5 - test case for sharedfork ok 6 - test case for sharedfork ok 7 - test case for sharedfork ok 8 - test case for sharedfork ok 9 - test case for sharedfork ok 10 - test case for sharedfork ok 11 - test case for sharedfork ok 12 - test case for sharedfork ok 13 - test case for sharedfork ok 14 - test case for sharedfork ok 15 - test case for sharedfork ok 16 - test case for sharedfork ok 17 - test case for sharedfork ok 18 - test case for sharedfork ok 19 - test case for sharedfork ok 20 - test case for sharedfork # send 1 # new request ok 21 # send 2 # new request ok 22 # finalize # new request # server exit # exit Count 1091

Subject:

log2.txt

Count 1056 s:\wp\wpPerl\wpTestTcp>perl "-MExtUtils::Command::MM" "-e" "test_harness(0, 'inc', 'lib')" t/00_compile.t t/01_simple.t t/02_abrt.t t/03_return_when_sigterm.t t/04_die.t t/05_sigint.t t/06_nest.t t/07_optional.t t/08_exit.t t/09_fork.t t/10_oo.t t/00_compile.t .............. ok t/01_simple.t ............... ok t/02_abrt.t ................. skipped: win32 doesn't support embedded function named dump() t/03_return_when_sigterm.t .. ok t/04_die.t .................. ok t/05_sigint.t ............... skipped: this test requires SIGUSR1 t/06_nest.t ................. ok t/07_optional.t ............. ok t/08_exit.t ................. ok t/09_fork.t ................. ok t/10_oo.t ................... ok All tests successful. Files=11, Tests=64, 25 wallclock secs ( 0.19 usr + 0.08 sys = 0.27 CPU) Result: PASS Count 1057

Subject:

patch.txt

diff -ur dist/lib/Test/TCP.pm modified/lib/Test/TCP.pm --- dist/lib/Test/TCP.pm 2011-03-03 08:14:40.000000000 +0100 +++ modified/lib/Test/TCP.pm 2011-04-06 09:50:38.979000000 +0200 @@ -52,7 +52,7 @@ port => $args{port} || empty_port(), ); $args{client}->($server->port, $server->pid); - undef $server; # make sure + return $server; } sub _check_port { @@ -130,7 +130,15 @@ return unless defined $self->{pid}; return unless $self->{_my_pid} == $$; + # 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 + 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 ); diff -ur dist/t/01_simple.t modified/t/01_simple.t --- dist/t/01_simple.t 2010-08-15 15:21:39.000000000 +0200 +++ modified/t/01_simple.t 2011-04-06 23:21:19.257000000 +0200 @@ -27,6 +27,7 @@ note "finalize"; print {$sock} "quit\n"; + sleep(1); }, server => sub { my $port = shift; @@ -34,8 +35,11 @@ t::Server->new($port)->run(sub { note "new request"; my ($remote, $line, $sock) = @_; + if ($line eq "quit\n"){ + note "server exit"; + exit 0; + }; print {$remote} $line; }); }, ); - diff -ur dist/t/08_exit.t modified/t/08_exit.t --- dist/t/08_exit.t 2010-08-24 06:08:16.000000000 +0200 +++ modified/t/08_exit.t 2011-04-06 23:29:18.714200000 +0200 @@ -36,6 +36,7 @@ test_tcp( client => sub { my $port = shift; + Win32::Sleep(100) if $^O eq "MSWin32"; # will relinquish the remainder of its time slice note "CLIENT: $$"; exit 1; }, diff -ur dist/t/09_fork.t modified/t/09_fork.t --- dist/t/09_fork.t 2011-03-03 08:13:54.000000000 +0100 +++ modified/t/09_fork.t 2011-04-06 23:27:41.947400000 +0200 @@ -3,7 +3,7 @@ use Test::TCP; use t::Server; -test_tcp +my $server = test_tcp client => sub { my $port = shift; @@ -39,20 +39,32 @@ print {$sock} "Hello server\n"; my $res = <$sock>; is $res, "Hello server\n", "got expected reply"; + + note "finalize"; + print {$sock} "quit\n"; + sleep(1); }, server => sub { my $port = shift; t::Server->new($port)->run(sub { note "new request"; my ($remote, $line, $sock) = @_; + if ($line eq "quit\n"){ + note "server exit"; + exit 0; + }; print {$remote} $line; }); } ; +$server->stop; + if ($?) { # It's maybe ActivePerl's bug. # http://ppm4.activestate.com/MSWin32-x86/5.12/1200/T/TO/TOKUHIROM/Test-TCP-1.11.d/log-20101221T221845.txt diag "test_tcp() leaks \$?. Maybe it's Perl bug?: $?"; $? = 0; } + +note "exit"; \ Ingen nyrad vid filslut diff -ur dist/t/10_oo.t modified/t/10_oo.t --- dist/t/10_oo.t 2011-03-03 08:13:56.000000000 +0100 +++ modified/t/10_oo.t 2011-04-06 23:29:04.393400000 +0200 @@ -12,6 +12,10 @@ t::Server->new($port)->run(sub { note "new request"; my ($remote, $line, $sock) = @_; + if ($line eq "quit\n"){ # shut down server + note "server exit"; + exit 0; + }; print {$remote} $line; }); } @@ -35,7 +39,8 @@ is $res2, "bar\n"; note "finalize"; -print {$sock} "quit\n"; +print {$sock} "quit\n"; # Shut down the server +sleep(1); if ($?) { # It's maybe ActivePerl's bug. @@ -43,6 +48,6 @@ diag "test_tcp() leaks \$?. Maybe it's Perl bug?: $?"; $? = 0; } - +note "exit"; done_testing;

Fri Mar 01 18:53:09 2013 tokuhirom+cpan [...] gmail.com - Correspondence added

This patch was applied at 1.13. (Note, but it's still failing.)

Fri Mar 01 18:53:09 2013 The RT System itself - Status changed from 'new' to 'open'

Thu Mar 14 05:53:48 2013 bo.johansson [...] lsn.se - Correspondence added

From:

bo.johansson [...] lsn.se

Vid Fre, 01 Mar 2013 kl. 18.53.09, skrev TOKUHIROM: Show quoted text

> This patch was applied at 1.13. > (Note, but it's still failing.)

!!!Only parts of the patch was applied!!! The part to shut down the server without using kill 9 was omitted. In Windows kill 9 on a process (block in an I/O-operation) must not be used. From http://perldoc.perl.org/perlfork.html: “The outcome of kill on a pseudo-process is unpredictable and it should not be used except under dire circumstances, because the operating system may not guarantee integrity of the process resources when a running thread is terminated.” I have done some analysis and ask for help. Posted http://www.perlmonks.org/?node_id=1021771, but didn't get much help. One of my conclusions is that there is still a probability that Windows returns 9 instead of the correct zero. One failing subtest in about 140 test runs is a little bit to high!? New types of errors seems also to have emerged. One example is: [Test::TCP] Child process does not block(PID: -xxxx, PPID: xxxx) at .. +. \lib/Test/TCP.pm line 121. t/xxxx.t ................. ok Made a second try to get help with http://www.perlmonks.org/?node_id=1022364. Got there a proposal how to improve “kill -9 style un-graceful exit” in win32/win32.c. However the proposed change has limitations: “This code has a race condition: if the hProcess thread exits with a different exitcode before the TerminteThread() manages to kill it. I don't know if TerminateThread will still change the exit code of a thread that has already terminated. I would suspect not, and in that case the following loop will never terminate.” If Test::TCP must use fork, at least in windows the server MUST be shut down without using kill 9. I have made a rough rewrite of Test::TCP to see if threads could be used. See the attached files. I do not understand all the applications so there are probably many mistakes! Here follows some comments to my changes. Test-TCP-1.21/lib/Net/EmptyPort.pm: “`$^X -MNet::EmptyPort -echeck_port $port” does not work if perl is started with “-I” switches. Net::EmptyPort::check_port($port) seem to work without starting a new process. Test-TCP-1.21/lib/Test/TCP.pm: Do not to know what to do with server pid! Is the pid need? In Test-TCP-1.21/t/xxx.t “use Test::TCP;” must come before “use Test::More tests => 99;” The test files: 03_return_when_sigterm.t, 04_die.t, t: 08_exit.t and 09_fork.t are coupled to the usage of fork and should be replaced by tests of the thread based solution.

Thu Mar 14 06:09:38 2013 bo.johansson [...] lsn.se - Correspondence added

From:

bo.johansson [...] lsn.se

The file wasn't uploaded!

Subject:

diff.txt

-*- mode: compilation; default-directory: "s:/wp/wpPerl/wpTestTcp4/" -*- Compilation started at Thu Mar 14 09:37:48 diff -ru dist/Test-TCP-1.21/ Test-TCP-1.21/ diff -ru dist/Test-TCP-1.21/lib/Net/EmptyPort.pm Test-TCP-1.21/lib/Net/EmptyPort.pm --- dist/Test-TCP-1.21/lib/Net/EmptyPort.pm 2013-03-03 04:07:54.000000000 +0100 +++ Test-TCP-1.21/lib/Net/EmptyPort.pm 2013-03-13 10:12:22.015757100 +0100 @@ -57,7 +57,7 @@ $sleep ||= 0.1; while ( $retry-- ) { - if ($^O eq 'MSWin32' ? `$^X -MNet::EmptyPort -echeck_port $port` : check_port( $port )) { + if ($^O eq 'MSWin32' ? `$^X -ITest-TCP-1.21/lib -MNet::EmptyPort -echeck_port $port` : check_port( $port )) { return 1; } Time::HiRes::sleep($sleep); Only in Test-TCP-1.21/lib/Test/TCP: CheckPort.pm~ diff -ru dist/Test-TCP-1.21/lib/Test/TCP.pm Test-TCP-1.21/lib/Test/TCP.pm --- dist/Test-TCP-1.21/lib/Test/TCP.pm 2013-03-03 04:34:52.000000000 +0100 +++ Test-TCP-1.21/lib/Test/TCP.pm 2013-03-14 09:24:35.315907700 +0100 @@ -3,21 +3,17 @@ use warnings; use 5.00800; our $VERSION = '1.21'; +use threads; use base qw/Exporter/; use IO::Socket::INET; -use Test::SharedFork 0.12; -use Test::More (); -use Config; -use POSIX; +#use Config; +#use POSIX; use Time::HiRes (); -use Carp (); +use Carp (); use Net::EmptyPort qw(empty_port check_port); 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'; - sub test_tcp { my %args = @_; for my $k (qw/client server/) { @@ -27,15 +23,21 @@ code => $args{server}, port => $args{port} || empty_port(), ); - $args{client}->($server->port, $server->pid); - undef $server; # make sure + $args{client}->( $server->port); + undef $server; # make sure } sub wait_port { my $port = shift; - Net::EmptyPort::wait_port($port, 0.1, 100) - or die "cannot open port: $port"; + my $retry = 100; + my $sleep = 0,1; + while ( $retry-- ){ + return 1 if Net::EmptyPort::check_port($port); + Time::HiRes::sleep($sleep); + }; + + die "cannot open port: $port"; } # ------------------------------------------------------------------------- @@ -43,7 +45,7 @@ sub new { my $class = shift; - my %args = @_==1 ? %{$_[0]} : @_; + my %args = @_ == 1 ? %{ $_[0] } : @_; Carp::croak("missing mandatory parameter 'code'") unless exists $args{code}; my $self = bless { auto_start => 1, @@ -56,67 +58,22 @@ return $self; } -sub pid { $_[0]->{pid} } +#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: $!"; - } + my $self = shift; + my $port = $self->port; + my $server = threads->create( $self->{code}, $self->port ); + $self->{server_thread} = $server; + Test::TCP::wait_port( $self->port ); + return $self; } 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}; + $self->{server_thread} && $self->{server_thread}->detach; + return $self; } sub DESTROY { diff -ru dist/Test-TCP-1.21/t/01_simple.t Test-TCP-1.21/t/01_simple.t --- dist/Test-TCP-1.21/t/01_simple.t 2012-04-09 05:25:32.000000000 +0200 +++ Test-TCP-1.21/t/01_simple.t 2013-03-14 07:45:37.162588500 +0100 @@ -1,7 +1,7 @@ use warnings; use strict; -use Test::More tests => 22; use Test::TCP; +use Test::More tests => 22; use IO::Socket::INET; use t::Server; Only in dist/Test-TCP-1.21/t: 03_return_when_sigterm.t Only in Test-TCP-1.21/t: 03_return_when_sigterm.t_not_used diff -ru dist/Test-TCP-1.21/t/04_die.t Test-TCP-1.21/t/04_die.t --- dist/Test-TCP-1.21/t/04_die.t 2012-04-09 05:25:32.000000000 +0200 +++ Test-TCP-1.21/t/04_die.t 2013-03-14 09:11:08.559776900 +0100 @@ -1,7 +1,7 @@ use warnings; use strict; -use Test::More tests => 3; use Test::TCP; +use Test::More tests => 2; use IO::Socket::INET; use t::Server; @@ -23,8 +23,8 @@ my $e = $@; ok $e; like $e, qr/sinamon/; -my $killed = kill 9, $child_pid; -is $killed, 0, "already killed by test_tcp"; +#my $killed = kill 9, $child_pid; +#is $killed, 0, "already killed by test_tcp"; if ($?) { # It's maybe ActivePerl's bug. Only in dist/Test-TCP-1.21/t: 08_exit.t Only in Test-TCP-1.21/t: 08_exit.t_not_used Only in dist/Test-TCP-1.21/t: 09_fork.t Only in Test-TCP-1.21/t: 09_fork.t_not_used diff -ru dist/Test-TCP-1.21/t/10_oo.t Test-TCP-1.21/t/10_oo.t --- dist/Test-TCP-1.21/t/10_oo.t 2012-04-09 05:25:32.000000000 +0200 +++ Test-TCP-1.21/t/10_oo.t 2013-03-14 07:50:13.310976700 +0100 @@ -1,7 +1,7 @@ use warnings; use strict; -use Test::More tests => 22; use Test::TCP; +use Test::More tests => 22; use IO::Socket::INET; use t::Server; Compilation exited abnormally with code 1 at Thu Mar 14 09:37:48

Subject:

TCP.pm

package Test::TCP; use strict; use warnings; use 5.00800; our $VERSION = '1.21'; use threads; use base qw/Exporter/; use IO::Socket::INET; #use Config; #use POSIX; use Time::HiRes (); use Carp (); use Net::EmptyPort qw(empty_port check_port); our @EXPORT = qw/ empty_port test_tcp wait_port /; 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); undef $server; # make sure } sub wait_port { my $port = shift; my $retry = 100; my $sleep = 0,1; while ( $retry-- ){ return 1 if Net::EmptyPort::check_port($port); Time::HiRes::sleep($sleep); }; 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} = 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; my $port = $self->port; my $server = threads->create( $self->{code}, $self->port ); $self->{server_thread} = $server; Test::TCP::wait_port( $self->port ); return $self; } sub stop { my $self = shift; $self->{server_thread} && $self->{server_thread}->detach; return $self; } sub DESTROY { my $self = shift; local $@; $self->stop(); } 1; __END__ =encoding utf8 =head1 NAME Test::TCP - testing TCP program =head1 SYNOPSIS use Test::TCP; my $server = Test::TCP->new( code => sub { my $port = shift; ... }, ); my $client = MyClient->new(host => '127.0.0.1', port => $server->port); undef $server; # kill child process on DESTROY Using memcached: use Test::TCP; my $memcached = Test::TCP->new( code => sub { my $port = shift; exec $bin, '-p' => $port; die "cannot execute $bin: $!"; }, ); my $memd = Cache::Memcached->new({servers => ['127.0.0.1:' . $memcached->port]}); ... And functional interface is available: use Test::TCP; test_tcp( client => sub { my ($port, $server_pid) = @_; # send request to the server }, server => sub { my $port = shift; # run server }, ); =head1 DESCRIPTION Test::TCP is test utilities for TCP/IP programs. =head1 METHODS =over 4 =item test_tcp Functional interface. test_tcp( client => sub { my $port = shift; # send request to the server }, server => sub { my $port = shift; # run server }, # optional port => 8080 ); =item wait_port wait_port(8080); Waits for a particular port is available for connect. =back =head1 OO-ish interface =over 4 =item my $server = Test::TCP->new(%args); Create new instance of Test::TCP. Arguments are following: =over 4 =item $args{auto_start}: Boolean Call C<< $server->start() >> after create instance. Default: true =item $args{code}: CodeRef The callback function. Argument for callback function is: C<< $code->($pid) >>. This parameter is required. =back =item $server->start() Start the server process. Normally, you don't need to call this method. =item $server->stop() Stop the server process. =item my $pid = $server->pid(); Get the pid of child process. =item my $port = $server->port(); Get the port number of child process. =back =head1 FAQ =over 4 =item How to invoke two servers? You can call test_tcp() twice! test_tcp( client => sub { my $port1 = shift; test_tcp( client => sub { my $port2 = shift; # some client code here }, server => sub { my $port2 = shift; # some server2 code here }, ); }, server => sub { my $port1 = shift; # some server1 code here }, ); Or use OO-ish interface instead. my $server1 = Test::TCP->new(code => sub { my $port1 = shift; ... }); my $server2 = Test::TCP->new(code => sub { my $port2 = shift; ... }); # your client code here. ... =item How do you test server program written in other languages like memcached? You can use C<exec()> in child process. use strict; use warnings; use utf8; use Test::More; use Test::TCP 1.08; use File::Which; my $bin = scalar which 'memcached'; plan skip_all => 'memcached binary is not found' unless defined $bin; my $memcached = Test::TCP->new( code => sub { my $port = shift; exec $bin, '-p' => $port; die "cannot execute $bin: $!"; }, ); use Cache::Memcached; my $memd = Cache::Memcached->new({servers => ['127.0.0.1:' . $memcached->port]}); $memd->set(foo => 'bar'); is $memd->get('foo'), 'bar'; done_testing; =back =head1 AUTHOR Tokuhiro Matsuno E<lt>tokuhirom@gmail.comE<gt> =head1 THANKS TO kazuhooku dragon3 charsbar Tatsuhiko Miyagawa lestrrat =head1 SEE ALSO =head1 LICENSE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut

Fri Mar 29 02:59:02 2013 tokuhirom+cpan [...] gmail.com - Correspondence added

I hope the issue was resolved by other ticket. Does the issue still happening?

Sun Apr 07 13:13:23 2013 bo.johansson [...] lsn.se - Correspondence added

From:

bo.johansson [...] lsn.se

Vid Fre, 29 Mar 2013 kl. 02.59.02, skrev TOKUHIROM: Show quoted text

> I hope the issue was resolved by other ticket. Does the issue still > happening?

The issue is still happening! As earlier stated: In Windows kill 9 on a process (blocked in an I/O-operation) must not be used. “The outcome of kill on a pseudo-process is unpredictable and it should not be used except under dire circumstances, because the operating system may not guarantee integrity of the process resources when a running thread is terminated.” If Test::TCP must use fork, at least in windows the server MUST be shut down without using kill 9. I have used this batch-file to run the tests: @echo off set count=0 :loop set /a count=%count%+1 echo Count %count% @echo on perl -ITest-TCP-1.26/lib -ITest-TCP-1.26 Test-TCP-1.26/t/00_compile.t ECHO.%ERRORLEVEL% perl -ITest-TCP-1.26/lib -ITest-TCP-1.26 Test-TCP-1.26/t/01_simple.t ECHO.%ERRORLEVEL% perl -ITest-TCP-1.26/lib -ITest-TCP-1.26 Test-TCP-1.26/t/02_abrt.t ECHO.%ERRORLEVEL% perl -ITest-TCP-1.26/lib -ITest-TCP-1.26 Test-TCP-1.26/t/03_return_when_sigterm.t ECHO.%ERRORLEVEL% perl -ITest-TCP-1.26/lib -ITest-TCP-1.26 Test-TCP-1.26/t/04_die.t ECHO.%ERRORLEVEL% perl -ITest-TCP-1.26/lib -ITest-TCP-1.26 Test-TCP-1.26/t/05_sigint.t ECHO.%ERRORLEVEL% perl -ITest-TCP-1.26/lib -ITest-TCP-1.26 Test-TCP-1.26/t/06_nest.t ECHO.%ERRORLEVEL% perl -ITest-TCP-1.26/lib -ITest-TCP-1.26 Test-TCP-1.26/t/07_optional.t ECHO.%ERRORLEVEL% perl -ITest-TCP-1.26/lib -ITest-TCP-1.26 Test-TCP-1.26/t/08_exit.t ECHO.%ERRORLEVEL% perl -ITest-TCP-1.26/lib -ITest-TCP-1.26 Test-TCP-1.26/t/09_fork.t ECHO.%ERRORLEVEL% perl -ITest-TCP-1.26/lib -ITest-TCP-1.26 Test-TCP-1.26/t/10_oo.t ECHO.%ERRORLEVEL% @echo off goto loop Running the loop in the batch-file 1000 times I typically results in: - 10 times: Faulty return value 9 from a test. - One time: Perl is stuck and must be killed. - One time: Operating system says “Perl has stopped working”. Running the test from a Perl program or using a more loaded system increases the error rate. The tests was done using Windows 7, perl 5, version 16, subversion 3 (v5.16.3) built for MSWin32-x64-multi-thread and Test-TCP-1.26. Note: Test-TCP-1.26/lib/Net/EmptyPort.pm: “`$^X -MNet::EmptyPort -echeck_port $port” does not work if perl is started with “-I” switches.

Bug #67292 for Test-TCP: Tests are blocking in Windows 7. With a prposed patch.

Preferred bug tracker