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 Test::TCP;
   9 use Try::Tiny;
  10 use Plack::Builder;
  11
  12 eval { require Catalyst::Devel; Catalyst::Devel->VERSION(1.0); 1; } || do {
  13     fail("Could not load Catalyst::Devel: $@");
  14     exit 1;
  15 };
  16
  17 eval { require File::Copy::Recursive; 1 } || do {
  18     fail("Could not load File::Copy::Recursive: $@");
  19     exit 1;
  20 };
  21
  22 # Run a single test by providing it as the first arg
  23 my $single_test = shift;
  24
  25 my $tmpdir = "$FindBin::Bin/../../t/tmp";
  26
  27 # clean up
  28 rmtree $tmpdir if -d $tmpdir;
  29
  30 # create a TestApp and copy the test libs into it
  31 mkdir $tmpdir;
  32 chdir $tmpdir;
  33 system( $^X, "-I$FindBin::Bin/../../lib", "$FindBin::Bin/../../script/catalyst.pl", 'TestApp' );
  34 chdir "$FindBin::Bin/..";
  35 File::Copy::Recursive::dircopy( '../t/lib', '../t/tmp/TestApp/lib' ) or die;
  36
  37 # remove TestApp's tests
  38 rmtree '../t/tmp/TestApp/t' or die;
  39
  40 # spawn the standalone HTTP server
  41 my $port = empty_port;
  42
  43 my $pid = fork;
  44 if ($pid) {
  45     # parent.
  46     print "Waiting for server to start...\n";
  47     wait_port_timeout($port, 30);
  48 } elsif ($pid == 0) {
  49     # child process
  50     unshift @INC, "$tmpdir/TestApp/lib", "$FindBin::Bin/../../lib";
  51     require TestApp;
  52
  53     my $psgi_app = TestApp->apply_default_middlewares(TestApp->psgi_app);
  54     Plack::Loader->auto(port => $port)->run(builder {
  55         mount '/test_prefix' => $psgi_app;
  56         mount '/' => sub {
  57             return [501, ['Content-Type' => 'text/plain'], ['broken tests']];
  58         };
  59     });
  60
  61     exit 0;
  62 } else {
  63     die "fork failed: $!";
  64 }
  65
  66 # run the testsuite against the HTTP server
  67 $ENV{CATALYST_SERVER} = "http://localhost:$port/test_prefix";
  68
  69 chdir '..';
  70
  71 my $return;
  72 if ( $single_test ) {
  73     $return = system( "$^X -Ilib/ $single_test" );
  74 }
  75 else {
  76     $return = prove(grep { $_ ne '..' } glob('t/aggregate/live_*.t'));
  77 }
  78
  79 # shut it down
  80 kill 'INT', $pid;
  81
  82 # clean up
  83 rmtree "$FindBin::Bin/../../t/tmp" if -d "$FindBin::Bin/../../t/tmp";
  84
  85 is( $return, 0, 'live tests' );
  86
  87 # kill 'INT' doesn't exist in Windows, so to prevent child hanging,
  88 # this process will need to commit seppuku to clean up the children.
  89 if ($^O eq 'MSWin32') {
  90     # Furthermore, it needs to do it 'politely' so that TAP doesn't
  91     # smell anything 'dubious'.
  92     require Win32::Process;  # core in all versions of Win32 Perl
  93     Win32::Process::KillProcess($$, $return);
  94 }
  95
  96 sub wait_port_timeout {
  97     my ($port, $timeout) = @_;
  98
  99     # wait_port waits for 10 seconds
 100     for (1 .. int($timeout / 10)) { # meh, good enough.
 101         try { wait_port $port; 1 } and return;
 102     }
 103
 104     die "Server did not start within $timeout seconds";
 105 }
 106
 107 sub prove {
 108     my (@tests) = @_;
 109     if (!(my $pid = fork)) {
 110         require TAP::Harness;
 111
 112         my $aggr = -e '.aggregating';
 113         my $harness = TAP::Harness->new({
 114             ($aggr ? (test_args => \@tests) : ()),
 115             lib => ['lib'],
 116         });
 117
 118         my $aggregator = $aggr
 119             ? $harness->runtests('t/aggregate.t')
 120             : $harness->runtests(@tests);
 121
 122         exit $aggregator->has_errors ? 1 : 0;
 123     } else {
 124         waitpid $pid, 0;
 125         return $?;
 126     }
 127 }