X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Fauthor%2Fhttp-server.t;h=2861c275ce9d12ae06c3ccc0830fa61005bf676f;hb=f6ddb2f242a1635b4a5ba848f61d87c1093422dc;hp=9754857724122d16a43d4db62cebfa45d1292d21;hpb=d93d402c16035129944e4948a00309a5cd78a1c7;p=catagits%2FCatalyst-Runtime.git

diff --git a/t/author/http-server.t b/t/author/http-server.t
index 9754857..2861c27 100644
--- a/t/author/http-server.t
+++ b/t/author/http-server.t
@@ -2,13 +2,23 @@ use strict;
 use warnings;
 
 use Test::More tests => 1;
+use Test::TCP;
 
 use File::Path;
 use FindBin;
-use IO::Socket;
+use Net::EmptyPort qw(wait_port empty_port);
+use Try::Tiny;
+use Plack::Builder;
 
-use Catalyst::Devel 1.0;
-use File::Copy::Recursive;
+eval { require Catalyst::Devel; Catalyst::Devel->VERSION(1.0); 1; } || do {
+    fail("Could not load Catalyst::Devel: $@");
+    exit 1;
+};
+
+eval { require File::Copy::Recursive; 1 } || do {
+    fail("Could not load File::Copy::Recursive: $@");
+    exit 1;
+};
 
 # Run a single test by providing it as the first arg
 my $single_test = shift;
@@ -29,26 +39,25 @@ File::Copy::Recursive::dircopy( '../t/lib', '../t/tmp/TestApp/lib' ) or die;
 rmtree '../t/tmp/TestApp/t' or die;
 
 # spawn the standalone HTTP server
-my $port = 30000 + int rand(1 + 10000);
+my $port = empty_port;
 
 my $pid = fork;
 if ($pid) {
     # parent.
     print "Waiting for server to start...\n";
-    my $timeout = 30;
-    my $count = 0;
-    while ( check_port( 'localhost', $port ) != 1 ) {
-        sleep 1;
-        die "Server did not start within $timeout seconds:"
-            if $count++ > $timeout;
-    }
+    wait_port_timeout($port, 30);
 } elsif ($pid == 0) {
     # child process
     unshift @INC, "$tmpdir/TestApp/lib", "$FindBin::Bin/../../lib";
     require TestApp;
 
-    my $psgi_app = TestApp->_wrapped_legacy_psgi_app(TestApp->psgi_app);
-    Plack::Loader->auto(port => $port)->run($psgi_app);
+    my $psgi_app = TestApp->apply_default_middlewares(TestApp->psgi_app);
+    Plack::Loader->auto(port => $port)->run(builder {
+        mount '/test_prefix' => $psgi_app;
+        mount '/' => sub {
+            return [501, ['Content-Type' => 'text/plain'], ['broken tests']];
+        };
+    });
 
     exit 0;
 } else {
@@ -56,7 +65,7 @@ if ($pid) {
 }
 
 # run the testsuite against the HTTP server
-$ENV{CATALYST_SERVER} = "http://localhost:$port";
+$ENV{CATALYST_SERVER} = "http://localhost:$port/test_prefix";
 
 chdir '..';
 
@@ -76,21 +85,21 @@ rmtree "$FindBin::Bin/../../t/tmp" if -d "$FindBin::Bin/../../t/tmp";
 
 is( $return, 0, 'live tests' );
 
-sub check_port {
-    my ( $host, $port ) = @_;
-
-    my $remote = IO::Socket::INET->new(
-        Proto    => "tcp",
-        PeerAddr => $host,
-        PeerPort => $port
-    );
-    if ($remote) {
-        close $remote;
-        return 1;
-    }
-    else {
-        return 0;
-    }
+# kill 'INT' doesn't exist in Windows, so to prevent child hanging,
+# this process will need to commit seppuku to clean up the children.
+if ($^O eq 'MSWin32') {
+    # Furthermore, it needs to do it 'politely' so that TAP doesn't 
+    # smell anything 'dubious'.
+    require Win32::Process;  # core in all versions of Win32 Perl
+    Win32::Process::KillProcess($$, $return);
+}
+
+sub wait_port_timeout {
+    my ($port, $timeout) = @_;
+
+    wait_port($port, $timeout * 10) and return;
+
+    die "Server did not start within $timeout seconds";
 }
 
 sub prove {