Dogcows Code - chaz/p5-HTTP-AnyUA/blob - t/lib/Server.pm

   1 package Server;
   2 # ABSTRACT: A runner for test HTTP servers
   3
   4 =head1 SYNOPSIS
   5
   6     use Server;
   7     my $server = Server->new('app.psgi');
   8
   9 =head1 DESCRIPTION
  10
  11 Throws up an HTTP server on a random port, suitable for testing. Server logs will be printed to
  12 C<STDERR> as test notes.
  13
  14 =cut
  15
  16 use warnings;
  17 use strict;
  18
  19 use IO::Handle;
  20 use Plack::Runner;
  21 use Util qw(recv_env);
  22
  23 =method new
  24
  25     $server = Server->new($path);
  26     $server = Server->new(\&app);
  27     $server = Server->new(\&app, type => 'Starman');
  28
  29 Construct and L</start> a new test HTTP server.
  30
  31 =cut
  32
  33 sub new {
  34     my $class   = shift;
  35     my $app     = shift or die 'PSGI app required';
  36     my %args    = @_;
  37
  38     $args{type} ||= 'HTTP::Server::PSGI';
  39
  40     my $self = bless {app => $app, %args}, $class;
  41     return $self->start;
  42 }
  43
  44 =attr app
  45
  46 Get the app that was passed to L</new>.
  47
  48 =attr in
  49
  50 Get a filehandle for reading the server's STDOUT.
  51
  52 =attr pid
  53
  54 Get the process identifier of the server.
  55
  56 =attr port
  57
  58 Get the port number the server is listening on.
  59
  60 =attr url
  61
  62 Get the URL for the server.
  63
  64 =attr type
  65
  66 Get the type of server that was passed to L</new>.
  67
  68 =cut
  69
  70 sub app  { shift->{app}  }
  71 sub in   { shift->{in}   }
  72 sub pid  { shift->{pid}  }
  73 sub port { shift->{port} }
  74 sub url  { 'http://localhost:' . shift->port }
  75 sub type { shift->{type} }
  76
  77 =method start
  78
  79     $server->start;
  80
  81 Start the server.
  82
  83 =cut
  84
  85 sub start {
  86     my $self = shift;
  87
  88     # do not start on top of an already-started server
  89     return $self if $self->{pid};
  90
  91     my $type = $self->type;
  92
  93     my $pid = open(my $pipe, '-|');
  94     defined $pid or die "fork failed: $!";
  95
  96     $pipe->autoflush(1);
  97
  98     if ($pid) {
  99         my $port = <$pipe>;
 100         die 'Could not start test server' if !$port;
 101         chomp $port;
 102
 103         $self->{in}     = $pipe;
 104         $self->{pid}    = $pid;
 105         $self->{port}   = $port;
 106     }
 107     else {
 108         tie *STDERR, 'Server::RedirectToTestHarness';
 109
 110         autoflush STDOUT 1;
 111
 112         for my $try (1..10) {
 113             my $port_num = $ENV{PERL_HTTP_ANYUA_TEST_PORT} || int(rand(32768)) + 32768;
 114             print STDERR sprintf('Try %02d - Attempting to start a server on port %d for testing...', $try, $port_num);
 115
 116             local $SIG{ALRM} = sub { print "$port_num\n" };
 117             alarm 1;
 118
 119             eval {
 120                 my $runner = Plack::Runner->new;
 121                 $runner->parse_options('-s', $type, '-p', $port_num);
 122                 $runner->run($self->app);
 123             };
 124             warn $@ if $@;
 125
 126             alarm 0;
 127         }
 128
 129         print STDERR "Giving up...";
 130         exit;
 131     }
 132
 133     return $self;
 134 }
 135
 136 =method stop
 137
 138     $server->stop;
 139
 140 Stop the server. Called implicitly by C<DESTROY>.
 141
 142 =cut
 143
 144 sub stop {
 145     my $self = shift;
 146
 147     if (my $pid = $self->pid) {
 148         kill 'TERM', $pid;
 149         waitpid $pid, 0;
 150         $? = 0;             # don't let child exit status affect parent
 151     }
 152     %$self = (app => $self->app);
 153 }
 154
 155 sub DESTROY {
 156     my $self = shift;
 157     $self->stop;
 158 }
 159
 160
 161 =method read_env
 162
 163     $env = $server->read_env;
 164
 165 Read a L<PSGI> environment from the server, sent by L<Util/send_env>.
 166
 167 =cut
 168
 169 sub read_env {
 170     my $self = shift;
 171     return recv_env($self->in or die 'Not connected');
 172 }
 173
 174
 175 {
 176     package Server::RedirectToTestHarness;
 177
 178     use Test::More ();
 179
 180     sub TIEHANDLE   { bless {} }
 181     sub PRINT       { shift; Test::More::note('Server: ', @_) }
 182     sub PRINTF      { shift; Test::More::note('Server: ', sprintf(@_)) }
 183 }
 184
 185 1;