| Subject: | Calls to an object's method within a child thread hang |
While diagnosing my previous bug (105603), I found a different problem in Strawberry Perl, one that does not seem to exhibit in ActiveState Perl.
In my test code, I create a server object, then fork and have the server start in the child process. The parent then sends some requests to the server and kills the child when done. The server object is *not* shared between the parent and child; the child should have gotten a copy of the object (as I understand things, at least).
However, when I made multiple calls to the "url" method of the server object in the parent, I found that my second call would hang indefinitely. If I cached the value of the URL before the fork, and just used that value instead, I had no problems.
In the attached code, look at lines 28-29 and 37-38. Run as-is, the problem will manifest. You will see the results of the HEAD request, and the message "Creating POST request". But the child/server will never see a second request, and you'll never see the results of the request printed out by the parent. If you comment-out 29 and 38, then uncomment 28 and 37, the script will run correctly. You will see the results of both the HEAD and POST requests.
I know that fork() et al are implemented in terms of threads on Windows, but I expected that calling $server->url in the parent would work consistently even while a child-thread was waiting in an accept-loop. And it is odd that the *first* call to ->url returns fine, it is only the second call that hangs.
This is on 5.20.2. I have not yet tried it on 5.22.0.
Randy
--
Randy J. Ray
rjray@blackperl.com
randy.j.ray@gmail.com
| Subject: | socket-fail.pl |
#!/usr/bin/env perl
use strict;
use warnings;
use LWP::UserAgent;
use HTTP::Daemon;
use HTTP::Request;
use HTTP::Response;
use HTTP::Status;
my $server = HTTP::Daemon->new(
ReuseAddr => 1,
LocalHost => 'localhost',
LocalPort => 9000,
Listen => 5
);
my $url = $server->url;
die "Failed to create server object\n" if (! $server);
my $child = fork;
if (! defined $child) {
die "fork() failed: $!\n";
} elsif ($child) {
# Parent
my $UA = LWP::UserAgent->new;
#my $req = HTTP::Request->new(HEAD => $url);
my $req = HTTP::Request->new(HEAD => $server->url);
print ">>> Sending HEAD request\n";
my $res = $UA->request($req);
print ">>> Headers from HEAD request:\n\t";
printf "%d %s\n\t", $res->code, $res->message;
print $res->headers_as_string("\n\t"), "\n";
sleep 1;
printf ">>> Creating POST request to %s\n", $url;
#$req = HTTP::Request->new(POST => $url);
$req = HTTP::Request->new(POST => $server->url);
print ">>> Sending POST request\n";
$res = $UA->request($req);
print ">>> Full message from POST request:\n\t";
print $res->as_string("\n\t"), "\n";
} else {
# Child
$server->timeout(1);
while (1) {
my $conn = $server->accept;
printf "<<< Accept: %s\n", ($conn || '(none)');
next if (! $conn);
my $req;
while ($conn and $req = $conn->get_request('headers only')) {
my $res = HTTP::Response->new;
$res->code(RC_OK);
$res->message('OK');
$res->header(Accept => 'text/xml');
$res->content_type('text/xml');
if ($req->method eq 'HEAD') {
print "<<< Sending HEAD response\n";
$conn->send_response($res);
} elsif ($req->method eq 'POST') {
print "<<< Sending POST response\n";
$res->content('Success');
$conn->send_response($res);
}
}
my $eval_return = eval {
local $SIG{PIPE} = sub { die "<<< server_loop: Caught SIGPIPE\n"; };
$conn->close;
1;
};
if ((! $eval_return) && $@)
{
warn "<<< Cannot close connection: $@\n";
}
undef $conn;
}
}
kill 'KILL', $child;
exit;