initial commit
[chaz/p5-HTTP-AnyUA] / 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;
This page took 0.043107 seconds and 4 git commands to generate.