Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Fixes for test problems with Strawberry Perl.

  • Loading branch information...
commit 3270580b3538e108a2df16273e7513d197eee2d3 1 parent 0593e5b
@rjray authored
Showing with 22 additions and 13 deletions.
  1. +4 −5 t/40_server.t
  2. +2 −3 t/40_server_xmllibxml.t
  3. +16 −5 t/50_client.t
View
9 t/40_server.t
@@ -173,7 +173,7 @@ $port = $srv->port;
my @localhostinfo = gethostbyname 'localhost';
my $local_ip = join q{.} => unpack 'C4', $localhostinfo[4];
my @allhosts = ($local_ip, $localhostinfo[0], split q{ } => $localhostinfo[1]);
-for (@allhosts) { s/[.]/\\./g }
+for (@allhosts) { s/[.]/[.]/g }
# Per RT 27778: For some reason gethostbyname('localhost') does not return
# "localhost" on win32
if ($^O eq 'MSWin32' || $^O eq 'cygwin')
@@ -182,7 +182,7 @@ if ($^O eq 'MSWin32' || $^O eq 'cygwin')
}
if (none { /localdomain/ } @allhosts)
{
- push @allhosts, 'localhost\.localdomain';
+ push @allhosts, 'localhost[.]localdomain';
}
my $allhosts = join q{|} => @allhosts;
like($srv->url, qr{http://($allhosts):$port},
@@ -224,7 +224,7 @@ like($res, qr/Unknown type: bad/, 'add_method, bad type param');
# Here goes...
$parser = RPC::XML::ParserFactory->new;
$UA = LWP::UserAgent->new;
-$req = HTTP::Request->new(POST => "http://localhost:$port/");
+$req = HTTP::Request->new(POST => $srv->url);
$child = start_server $srv;
$req->header(Content_Type => 'text/xml');
@@ -448,12 +448,11 @@ if (! ref $srv)
{
croak "Server allocation failed, cannot continue. Message was: $srv";
}
-$port = $srv->port;
# Did it get all of them?
is($srv->list_methods(), scalar(@API_METHODS),
'Correct number of methods (defaults)');
-$req = HTTP::Request->new(POST => "http://localhost:$port/");
+$req = HTTP::Request->new(POST => $srv->url);
$child = start_server $srv;
View
5 t/40_server_xmllibxml.t
@@ -121,7 +121,7 @@ ok(! ref($res), 'get_method for non-existent method');
# Here goes...
$parser = RPC::XML::ParserFactory->new;
$UA = LWP::UserAgent->new;
-$req = HTTP::Request->new(POST => "http://localhost:$port/");
+$req = HTTP::Request->new(POST => $srv->url);
$child = start_server $srv;
$req->header(Content_Type => 'text/xml');
@@ -297,11 +297,10 @@ if (! ref $srv)
{
croak "Server allocation failed, cannot continue. Message was: $srv";
}
-$port = $srv->port;
# Did it get all of them?
is($srv->list_methods(), scalar(@API_METHODS),
'Correct number of methods (defaults)');
-$req = HTTP::Request->new(POST => "http://localhost:$port/");
+$req = HTTP::Request->new(POST => $srv->url);
$child = start_server $srv;
View
21 t/50_client.t
@@ -21,7 +21,7 @@ use File::Spec;
use RPC::XML::Server;
use RPC::XML::Client;
-my ($dir, $vol, $srv, $child, $port, $cli, $res, $flag);
+my ($dir, $vol, $srv, $child, $port, $cli, $res, $flag, $srv_url);
($vol, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0));
$dir = File::Spec->catpath($vol, $dir, q{});
@@ -46,7 +46,7 @@ if (($port = find_port) == -1)
croak 'No usable port found between 9000 and 11000, skipping';
}
$cli = RPC::XML::Client->new("http://localhost:$port");
-$cli->timeout(5); #to prevent long waiting for non-existing server
+$cli->timeout(5); # to prevent long waiting for non-existing server
isa_ok($cli, 'RPC::XML::Client', '$cli');
# With no server yet at that port, test the failure modes
@@ -95,6 +95,14 @@ if (! ref $srv)
{
croak "Failed to create server: $srv, stopped";
}
+# Due to issues with Strawberry Perl on Windows, have to explicitly set the
+# endpoint to what the server object thinks it is. Also, because of threading
+# issues with Strawberry, we need to save the URL value for later use while
+# the server is running.
+$srv_url = $srv->url;
+$cli->uri($srv_url);
+
+# Start the server...
$child = start_server $srv;
# NOW, this should work. Also, set $RPC::XML::ERROR to see if it clears
@@ -206,8 +214,8 @@ if (! ref $res)
}
# Last tests-- is the uri() method working?
-like($cli->uri, qr{http://localhost([.]localdomain)?:$port/?}x,
- 'RPC::XML::Client::uri method return value is correct');
+is($cli->uri, $srv_url,
+ 'RPC::XML::Client::uri method return value is correct');
# does calling it as an accesor change it at all?
$cli->uri('http://www.oreilly.com/RPC');
@@ -217,6 +225,10 @@ is($cli->uri, 'http://www.oreilly.com/RPC',
# Kill the server long enough to add a new method
stop_server $child;
+# Restore the server URL in the client. Due to some threading issues seen in
+# Strawberry Perl, must do this while $srv is not running.
+$cli->uri($srv->url);
+
SKIP: {
if ($LWP::VERSION <= 5.800)
{
@@ -253,7 +265,6 @@ SKIP: {
$cli->message_file_thresh(-s $fh1);
$cli->message_temp_dir($dir);
- $cli->uri("http://localhost:$port/");
$res = $cli->send_request(cmpImg =>
RPC::XML::base64->new($fh1),
RPC::XML::base64->new($fh2));

0 comments on commit 3270580

Please sign in to comment.
Something went wrong with that request. Please try again.