line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Test::HTTP::LocalServer; |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
# start a fake webserver, fork, and connect to ourselves |
4
|
11
|
|
|
11
|
|
49859
|
use strict; |
|
11
|
|
|
|
|
18
|
|
|
11
|
|
|
|
|
458
|
|
5
|
|
|
|
|
|
|
# this has to happen here because LWP::Simple creates a $ua |
6
|
|
|
|
|
|
|
# on load so any time after this is too late. |
7
|
|
|
|
|
|
|
BEGIN { |
8
|
11
|
|
|
11
|
|
312
|
delete @ENV{qw( |
9
|
|
|
|
|
|
|
HTTP_PROXY http_proxy CGI_HTTP_PROXY |
10
|
|
|
|
|
|
|
HTTPS_PROXY https_proxy HTTP_PROXY_ALL http_proxy_all |
11
|
|
|
|
|
|
|
)}; |
12
|
|
|
|
|
|
|
} |
13
|
11
|
|
|
11
|
|
4493
|
use LWP::Simple; |
|
11
|
|
|
|
|
169621
|
|
|
11
|
|
|
|
|
85
|
|
14
|
11
|
|
|
11
|
|
8648
|
use FindBin; |
|
11
|
|
|
|
|
9248
|
|
|
11
|
|
|
|
|
519
|
|
15
|
11
|
|
|
11
|
|
56
|
use File::Spec; |
|
11
|
|
|
|
|
17
|
|
|
11
|
|
|
|
|
153
|
|
16
|
11
|
|
|
11
|
|
7923
|
use File::Temp; |
|
11
|
|
|
|
|
164930
|
|
|
11
|
|
|
|
|
919
|
|
17
|
11
|
|
|
11
|
|
4435
|
use URI::URL qw(); |
|
11
|
|
|
|
|
23899
|
|
|
11
|
|
|
|
|
230
|
|
18
|
11
|
|
|
11
|
|
53
|
use Carp qw(carp croak); |
|
11
|
|
|
|
|
19
|
|
|
11
|
|
|
|
|
512
|
|
19
|
|
|
|
|
|
|
|
20
|
11
|
|
|
11
|
|
42
|
use vars qw($VERSION); |
|
11
|
|
|
|
|
11
|
|
|
11
|
|
|
|
|
5929
|
|
21
|
|
|
|
|
|
|
$VERSION = '0.56'; |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
=head1 SYNOPSIS |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
use LWP::Simple qw(get); |
26
|
|
|
|
|
|
|
my $server = Test::HTTP::LocalServer->spawn; |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
ok get $server->url, "Retrieve " . $server->url; |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
$server->stop; |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
=head1 METHODS |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
=head2 Cspawn %ARGS> |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
This spawns a new HTTP server. The server will stay running until |
37
|
|
|
|
|
|
|
$server->stop |
38
|
|
|
|
|
|
|
is called. |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
Valid arguments are : |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
=over 4 |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
=item * |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
C<< html => >> scalar containing the page to be served |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
=item * |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
C<< file => >> filename containing the page to be served |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
=item * |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
C<< debug => 1 >> to make the spawned server output debug information |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
=item * |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
C<< eval => >> string that will get evaluated per request in the server |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
Try to avoid characters that are special to the shell, especially quotes. |
61
|
|
|
|
|
|
|
A good idea for a slow server would be |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
eval => sleep+10 |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
=back |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
All served HTML will have the first %s replaced by the current location. |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
The following entries will be removed from C<%ENV>: |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
HTTP_PROXY |
72
|
|
|
|
|
|
|
http_proxy |
73
|
|
|
|
|
|
|
CGI_HTTP_PROXY |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
=cut |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
sub spawn { |
78
|
0
|
|
|
0
|
1
|
|
my ($class,%args) = @_; |
79
|
0
|
|
|
|
|
|
my $self = { %args }; |
80
|
0
|
|
|
|
|
|
bless $self,$class; |
81
|
|
|
|
|
|
|
|
82
|
0
|
0
|
|
|
|
|
local $ENV{TEST_HTTP_VERBOSE} = 1 |
83
|
|
|
|
|
|
|
if (delete $args{debug}); |
84
|
|
|
|
|
|
|
|
85
|
0
|
|
|
|
|
|
$self->{delete} = []; |
86
|
0
|
0
|
|
|
|
|
if (my $html = delete $args{html}) { |
87
|
|
|
|
|
|
|
# write the html to a temp file |
88
|
0
|
|
|
|
|
|
my ($fh,$tempfile) = File::Temp::tempfile(); |
89
|
0
|
|
|
|
|
|
binmode $fh; |
90
|
0
|
0
|
|
|
|
|
print $fh $html |
91
|
|
|
|
|
|
|
or die "Couldn't write tempfile $tempfile : $!"; |
92
|
0
|
|
|
|
|
|
close $fh; |
93
|
0
|
|
|
|
|
|
push @{$self->{delete}},$tempfile; |
|
0
|
|
|
|
|
|
|
94
|
0
|
|
|
|
|
|
$args{file} = $tempfile; |
95
|
|
|
|
|
|
|
}; |
96
|
0
|
|
|
|
|
|
my ($fh,$logfile) = File::Temp::tempfile(); |
97
|
0
|
|
|
|
|
|
close $fh; |
98
|
0
|
|
|
|
|
|
push @{$self->{delete}},$logfile; |
|
0
|
|
|
|
|
|
|
99
|
0
|
|
|
|
|
|
$self->{logfile} = $logfile; |
100
|
0
|
|
0
|
|
|
|
my $web_page = delete $args{file} || ""; |
101
|
|
|
|
|
|
|
|
102
|
0
|
|
|
|
|
|
my $server_file = File::Spec->catfile( $FindBin::Bin,File::Spec->updir,'inc','Test','HTTP','log-server' ); |
103
|
0
|
|
|
|
|
|
my @opts; |
104
|
|
|
|
|
|
|
push @opts, "-e" => qq{"} . delete($args{ eval }) . qq{"} |
105
|
0
|
0
|
|
|
|
|
if $args{ eval }; |
106
|
|
|
|
|
|
|
|
107
|
0
|
0
|
|
|
|
|
my $pid = open my $server, qq'$^X "$server_file" "$web_page" "$logfile" @opts|' |
108
|
|
|
|
|
|
|
or croak "Couldn't spawn local server $server_file : $!"; |
109
|
0
|
|
|
|
|
|
my $url = <$server>; |
110
|
0
|
|
|
|
|
|
chomp $url; |
111
|
0
|
0
|
|
|
|
|
die "Couldn't read back local server url" |
112
|
|
|
|
|
|
|
unless $url; |
113
|
|
|
|
|
|
|
|
114
|
0
|
|
|
|
|
|
$self->{_fh} = $server; |
115
|
0
|
|
|
|
|
|
$self->{_pid} = $pid; |
116
|
0
|
|
|
|
|
|
$self->{_server_url} = URI::URL->new($url); |
117
|
|
|
|
|
|
|
|
118
|
0
|
|
|
|
|
|
$self; |
119
|
|
|
|
|
|
|
}; |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
=head2 C<< $server->port >> |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
This returns the port of the current server. As new instances |
124
|
|
|
|
|
|
|
will most likely run under a different port, this is convenient |
125
|
|
|
|
|
|
|
if you need to compare results from two runs. |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
=cut |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
sub port { |
130
|
0
|
0
|
|
0
|
1
|
|
carp __PACKAGE__ . "::port called without a server" unless $_[0]->{_server_url}; |
131
|
0
|
|
|
|
|
|
$_[0]->{_server_url}->port |
132
|
|
|
|
|
|
|
}; |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
=head2 C<< $server->url >> |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
This returns the url where you can contact the server. This url |
137
|
|
|
|
|
|
|
is valid until the C<$server> goes out of scope or you call |
138
|
|
|
|
|
|
|
$server->stop; |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
=cut |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
sub url { |
143
|
0
|
|
|
0
|
1
|
|
$_[0]->{_server_url}->abs |
144
|
|
|
|
|
|
|
}; |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
=head2 C<< $server->stop >> |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
This stops the server process by requesting a special |
149
|
|
|
|
|
|
|
url. |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
=cut |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
sub stop { |
154
|
0
|
|
|
0
|
1
|
|
get( $_[0]->{_server_url} . "quit_server" ); |
155
|
0
|
|
|
|
|
|
undef $_[0]->{_server_url} |
156
|
|
|
|
|
|
|
}; |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
=head2 C<< $server->kill >> |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
This kills the server process via C. The log |
161
|
|
|
|
|
|
|
cannot be retrieved then. |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
=cut |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
sub kill { |
166
|
0
|
|
|
0
|
1
|
|
CORE::kill( 9 => $_[0]->{ _pid } ); |
167
|
0
|
|
|
|
|
|
undef $_[0]->{_server_url}; |
168
|
0
|
|
|
|
|
|
undef $_[0]->{_pid}; |
169
|
|
|
|
|
|
|
}; |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
=head2 C<< $server->get_log >> |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
This returns the |
174
|
|
|
|
|
|
|
output of the server process. This output will be a list of |
175
|
|
|
|
|
|
|
all requests made to the server concatenated together |
176
|
|
|
|
|
|
|
as a string. |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
=cut |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
sub get_log { |
181
|
0
|
|
|
0
|
1
|
|
my ($self) = @_; |
182
|
0
|
|
|
|
|
|
return get( $self->{_server_url} . "get_server_log" ); |
183
|
|
|
|
|
|
|
}; |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
sub DESTROY { |
186
|
0
|
0
|
|
0
|
|
|
$_[0]->stop if $_[0]->{_server_url}; |
187
|
0
|
|
|
|
|
|
for my $file (@{$_[0]->{delete}}) { |
|
0
|
|
|
|
|
|
|
188
|
0
|
0
|
|
|
|
|
unlink $file or warn "Couldn't remove tempfile $file : $!\n"; |
189
|
|
|
|
|
|
|
}; |
190
|
|
|
|
|
|
|
}; |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
=head1 URLs implemented by the server |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
=head2 302 redirect C<< $server->redirect($target) >> |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
This URL will issue a redirect to C<$target>. No special care is taken |
197
|
|
|
|
|
|
|
towards URL-decoding C<$target> as not to complicate the server code. |
198
|
|
|
|
|
|
|
You need to be wary about issuing requests with escaped URL parameters. |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
=head2 404 error C<< $server->error_notfound($target) >> |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
This URL will response with status code 404. |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
=head2 Timeout C<< $server->error_timeout($seconds) >> |
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
This URL will send a 599 error after C<$seconds> seconds. |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
=head2 Timeout+close C<< $server->error_close($seconds) >> |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
This URL will send nothing and close the connection after C<$seconds> seconds. |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
=head2 Error in response content C<< $server->error_after_headers >> |
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
This URL will send headers for a successfull response but will close the |
215
|
|
|
|
|
|
|
socket with an error after 2 blocks of 16 spaces have been sent. |
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
=head2 Chunked response C<< $server->chunked >> |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
This URL will return 5 blocks of 16 spaces at a rate of one block per second |
220
|
|
|
|
|
|
|
in a chunked response. |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
=head2 Other URLs |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
All other URLs will echo back the cookies and query parameters. |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
=cut |
227
|
|
|
|
|
|
|
|
228
|
11
|
|
|
11
|
|
54
|
use vars qw(%urls); |
|
11
|
|
|
|
|
22
|
|
|
11
|
|
|
|
|
701
|
|
229
|
|
|
|
|
|
|
%urls = ( |
230
|
|
|
|
|
|
|
'redirect' => 'redirect/%s', |
231
|
|
|
|
|
|
|
'error_notfound' => 'error/notfound/%s', |
232
|
|
|
|
|
|
|
'error_timeout' => 'error/timeout/%s', |
233
|
|
|
|
|
|
|
'error_close' => 'error/close/%s', |
234
|
|
|
|
|
|
|
'error_after_headers' => 'error/after_headers', |
235
|
|
|
|
|
|
|
'chunked' => 'chunks', |
236
|
|
|
|
|
|
|
); |
237
|
|
|
|
|
|
|
for (keys %urls) { |
238
|
11
|
|
|
11
|
|
46
|
no strict 'refs'; |
|
11
|
|
|
|
|
22
|
|
|
11
|
|
|
|
|
939
|
|
239
|
|
|
|
|
|
|
my $name = $_; |
240
|
|
|
|
|
|
|
*{ $name } = sub { |
241
|
0
|
|
|
0
|
|
|
my $self = shift; |
242
|
0
|
|
|
|
|
|
$self->url . sprintf $urls{ $name }, @_; |
243
|
|
|
|
|
|
|
}; |
244
|
|
|
|
|
|
|
}; |
245
|
|
|
|
|
|
|
|
246
|
|
|
|
|
|
|
=head1 EXPORT |
247
|
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
None by default. |
249
|
|
|
|
|
|
|
|
250
|
|
|
|
|
|
|
=head1 COPYRIGHT AND LICENSE |
251
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
Copyright (C) 2003-2011 Max Maischein |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
=head1 AUTHOR |
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
Max Maischein, Ecorion@cpan.orgE |
259
|
|
|
|
|
|
|
|
260
|
|
|
|
|
|
|
Please contact me if you find bugs or otherwise improve the module. More tests are also very welcome ! |
261
|
|
|
|
|
|
|
|
262
|
|
|
|
|
|
|
=head1 SEE ALSO |
263
|
|
|
|
|
|
|
|
264
|
|
|
|
|
|
|
L,L,L |
265
|
|
|
|
|
|
|
|
266
|
|
|
|
|
|
|
=cut |
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
1; |