| Subject: | Tests are blocking in Windows 7 |
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
I have used version 1.11 and 1.12 of Test::TCP
Problem:
The test in Test::TCP is blocking. Get the system in state, that it
must be restarted.
It is sometimes not possible to kill the blocked processes.
I even get errors like “Can't spawn "cmd.exe"” when using the system
call. It indicates a degeneration of the perl interpreter.
Tries and errors:
I have tried a lot of changes and also tried to find out what the real
problem is. But i have not succeeded.
Probably there is a problem in the emulation of fork in Windows.
I have found by adding "sleep 1;" in some places there is an
improvement. I think that it is not the delay, but that it cause a
"context change" in the fork emulation that is important.
I have also tried to add a "sleep 1;" in the destructor. It gives some
improvements but is not enough.
sub DESTROY {
my $self = shift;
local $@;
sleep 1; #added gives some improvement
$self->stop();
}
In several tests it is necessary to add an explicit shutdown of the server
t::Server->new($port)->run(sub {
note "new request";
my ($remote, $line, $sock) = @_;
+ if ($line eq "quit\n"){
+ exit 0;
+ };
print {$remote} $line;
});
},
An alternative is to make test_tcp to return the $server.
sub test_tcp {
.....
$args{client}->($server->port, $server->pid);
#undef $server; # make sure REMOVED
return $server; # ADDED
}
This makes it possible to do the shout down in the tests in this way
my $object = test_tcp ....
$object->stop;
Using the object oriented way of calling this technique can be used
In t/10_oo.t I have done the changes:
-print {$sock} "quit\n";
+$server->stop;
Patch with proposed changes:
diff -u -r t.orig/01_simple.t t/01_simple.t
--- t.orig/01_simple.t 2010-08-15 16:21:39.000000000 +0200
+++ t/01_simple.t 2011-03-06 20:04:45.875400000 +0100
@@ -27,6 +27,7 @@
note "finalize";
print {$sock} "quit\n";
+ sleep 1;
},
server => sub {
my $port = shift;
@@ -34,8 +35,13 @@
t::Server->new($port)->run(sub {
note "new request";
my ($remote, $line, $sock) = @_;
+ if ($line eq "quit\n"){
+ exit 0;
+ };
print {$remote} $line;
});
},
);
+warn $$;
+
diff -u -r t.orig/08_exit.t t/08_exit.t
--- t.orig/08_exit.t 2010-08-24 07:08:16.000000000 +0200
+++ t/08_exit.t 2011-03-06 20:06:41.907000000 +0100
@@ -37,6 +37,7 @@
client => sub {
my $port = shift;
note "CLIENT: $$";
+ sleep 1;
exit 1;
},
server => sub {
@@ -53,3 +54,4 @@
);
}
+
diff -u -r t.orig/09_fork.t t/09_fork.t
--- t.orig/09_fork.t 2011-03-03 09:13:54.000000000 +0100
+++ t/09_fork.t 2011-03-06 22:31:39.035000000 +0100
@@ -39,12 +39,20 @@
print {$sock} "Hello server\n";
my $res = <$sock>;
is $res, "Hello server\n", "got expected reply";
+
+ note "finalize";
+ print {$sock} "quit\n";
+ sleep 1;
+ warn "Client exit after sleep $$";
},
server => sub {
my $port = shift;
t::Server->new($port)->run(sub {
note "new request";
my ($remote, $line, $sock) = @_;
+ if ($line eq "quit\n"){
+ exit 0;
+ };
print {$remote} $line;
});
}
@@ -56,3 +64,5 @@
diag "test_tcp() leaks \$?. Maybe it's Perl bug?: $?";
$? = 0;
}
+
+
diff -u -r t.orig/10_oo.t t/10_oo.t
--- t.orig/10_oo.t 2011-03-03 09:13:56.000000000 +0100
+++ t/10_oo.t 2011-03-07 07:37:18.063200000 +0100
@@ -35,7 +35,7 @@
is $res2, "bar\n";
note "finalize";
-print {$sock} "quit\n";
+$server->stop;
if ($?) {
# It's maybe ActivePerl's bug.