t/author/http-server.t

   1 use strict;
   2 use warnings;
   3
   4 use Test::More tests => 1;
   5
   6 use File::Path;
   7 use FindBin;
   8 use IPC::Open3;
   9 use IO::Socket;
  10
  11 use Catalyst::Devel 1.0;
  12 use File::Copy::Recursive;
  13
  14 # Run a single test by providing it as the first arg
  15 my $single_test = shift;
  16
  17 my $tmpdir = "$FindBin::Bin/../../t/tmp";
  18
  19 # clean up
  20 rmtree $tmpdir if -d $tmpdir;
  21
  22 # create a TestApp and copy the test libs into it
  23 mkdir $tmpdir;
  24 chdir $tmpdir;
  25 system( $^X, "-I$FindBin::Bin/../../lib", "$FindBin::Bin/../../script/catalyst.pl", 'TestApp' );
  26 chdir "$FindBin::Bin/..";
  27 File::Copy::Recursive::dircopy( '../t/lib', '../t/tmp/TestApp/lib' ) or die;
  28
  29 # remove TestApp's tests
  30 rmtree '../t/tmp/TestApp/t' or die;
  31
  32 # spawn the standalone HTTP server
  33 my $port = 30000 + int rand(1 + 10000);
  34 my @cmd = ($^X, "-I$FindBin::Bin/../../lib",
  35   "$FindBin::Bin/../../t/tmp/TestApp/script/testapp_server.pl", '--port', $port );
  36 my $pid = open3( undef, my $server, undef, @cmd)
  37     or die "Unable to spawn standalone HTTP server: $!";
  38
  39 # wait for it to start
  40 print "Waiting for server to start...\n";
  41 my $timeout = 30;
  42 my $count = 0;
  43 while ( check_port( 'localhost', $port ) != 1 ) {
  44     sleep 1;
  45     die("Server did not start within $timeout seconds: " . join(' ', @cmd))
  46         if $count++ > $timeout;
  47 }
  48
  49 # run the testsuite against the HTTP server
  50 $ENV{CATALYST_SERVER} = "http://localhost:$port";
  51
  52 chdir '..';
  53
  54 my $return;
  55 if ( $single_test ) {
  56     $return = system( "$^X -Ilib/ $single_test" );
  57 }
  58 else {
  59     $return = prove( ['lib/'], [grep { $_ ne '..' } glob('t/aggregate/live_*.t')] );
  60 }
  61
  62 # shut it down
  63 kill 'INT', $pid;
  64 close $server;
  65
  66 # clean up
  67 rmtree "$FindBin::Bin/../../t/tmp" if -d "$FindBin::Bin/../../t/tmp";
  68
  69 is( $return, 0, 'live tests' );
  70
  71 sub check_port {
  72     my ( $host, $port ) = @_;
  73
  74     my $remote = IO::Socket::INET->new(
  75         Proto    => "tcp",
  76         PeerAddr => $host,
  77         PeerPort => $port
  78     );
  79     if ($remote) {
  80         close $remote;
  81         return 1;
  82     }
  83     else {
  84         return 0;
  85     }
  86 }
  87
  88 sub prove {
  89     my ($inc, $tests) = @_;
  90     if (!(my $pid = fork)) {
  91         unshift @INC, @{ $inc };
  92
  93         require TAP::Harness;
  94
  95         my $aggr = -e '.aggregating';
  96         my $harness = TAP::Harness->new({
  97             ($aggr ? (test_args => $tests) : ())
  98         });
  99
 100         my $aggregator = $aggr
 101             ? $harness->runtests('t/aggregate.t')
 102             : $harness->runtests(@{ $tests });
 103
 104         exit $aggregator->has_errors ? 1 : 0;
 105     } else {
 106         waitpid $pid, 0;
 107         return $?;
 108     }
 109 }