| Subject: | Strawberry does not always resolve 'localhost' correctly (may be in LWP) |
I recently got a bug report for my RPC-XML module, in which the user was trying to build/install on Windows with Strawberry Perl 5.20.2. After much poking and prodding, I finally realized that when I created a daemon with HTTP::Daemon, it was taking 'localhost' and resolving it to 127.0.0.1. That is, I would create the object as:
$server = HTTP::Daemon->new(LocalHost => 'localhost', LocalPort => 9000);
and then printing $server->url would give me:
http://127.0.0.1:9000/
The problem I was having came when creating a client to connect to that server. The client did NOT resolve localhost to 127.0.0.1, and instead failed to connect. I created the client with:
$client = LWP::UserAgent->new(POST => 'http://localhost:9000');
If, instead, I created the client as:
$client = LWP::UserAgent->new(POST => $server->url);
it would work fine.
The attached file shows this. It is stripped down from what it would be if I were using RPC::XML classes instead, but it shows the problem. The series of lines from 28-30, and again from 38-40, create request objects. As configured in this file, you will see the failure. If you comment-out lines 30 and 40, and uncomment 28 and 38, the script will run without error.
(If you instead uncomment lines 29 and 39, you'll see a different bug that I'll be reporting in a different RT ticket.)
I cannot tell if this problem is due to something in the HTTP::Request library vs. HTTP::Daemon, or if it traces back to different networking syscalls being made in the different cases. I have not tried this on the 5.22.0.1 build yet.
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);
my $req = HTTP::Request->new(HEAD => 'http://localhost:9000');
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);
$req = HTTP::Request->new(POST => 'http://localhost:9000');
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;