File Coverage

blib/lib/Test/HTTP/LocalServer.pm
Criterion Covered Total %
statement 114 144 79.1
branch 14 36 38.8
condition 6 16 37.5
subroutine 24 29 82.7
pod 9 13 69.2
total 167 238 70.1


line stmt bran cond sub pod time code
1             package Test::HTTP::LocalServer;
2 16     16   75304 use strict;
  16         121  
  16         465  
3 16     16   313 use 5.008; # We use "fancy" opening of lexical filehandle, see below
  16         57  
4 16     16   7439 use FindBin;
  16         19243  
  16         703  
5 16     16   106 use File::Spec;
  16         92  
  16         302  
6 16     16   12030 use File::Temp;
  16         380146  
  16         1117  
7 16     16   7110 use URI::URL qw();
  16         133152  
  16         400  
8 16     16   110 use Carp qw(carp croak);
  16         31  
  16         866  
9 16     16   105 use Cwd;
  16         30  
  16         817  
10 16     16   95 use File::Basename;
  16         36  
  16         811  
11 16     16   9641 use Time::HiRes qw ( time sleep );
  16         22872  
  16         68  
12 16     16   15087 use HTTP::Tiny;
  16         679003  
  16         711  
13 16     16   8947 use HTTP::Daemon 6.05; # Our log server needs this, but we load it here to find its version
  16         768075  
  16         155  
14              
15             our $VERSION = '0.74';
16              
17             =head1 NAME
18              
19             Test::HTTP::LocalServer - spawn a local HTTP server for testing
20              
21             =head1 SYNOPSIS
22              
23             use HTTP::Tiny;
24             my $server = Test::HTTP::LocalServer->spawn(
25             request_pause => 1, # wait one second before accepting the next request
26             );
27              
28             my $res = HTTP::Tiny->new->get( $server->url );
29             print $res->{content};
30              
31             $server->stop;
32              
33             =head1 DESCRIPTION
34              
35             This module implements a tiny web server suitable for running "live" tests
36             of HTTP clients against it. It also takes care of cleaning C<%ENV> from settings
37             that influence the use of a local proxy etc.
38              
39             Use this web server if you write an HTTP client and want to exercise its
40             behaviour in your test suite without talking to the outside world.
41              
42             =head1 METHODS
43              
44             =head2 Cspawn %ARGS>
45              
46             my $server = Test::HTTP::LocalServer->spawn;
47              
48             This spawns a new HTTP server. The server will stay running until
49              
50             $server->stop
51              
52             is called. Ideally, you explicitly call C<< ->stop >> or use
53              
54             undef $server
55              
56             before the main program ends so that the program exit code reflects the
57             real exit code and not the chlid exit code.
58              
59             Valid arguments are :
60              
61             =over 4
62              
63             =item *
64              
65             C<< html => >> scalar containing the page to be served
66              
67             If this is not specified, an informative default page will be used.
68              
69             =item *
70              
71             C<< request_pause => >> number of seconds to sleep before accepting the next
72             request
73              
74             If your system is slow or needs to wait some time before a socket connection
75             is ready again, use this parameter to make the server wait a bit before
76             handling the next connection.
77              
78             =item *
79              
80             C<< file => >> filename containing the page to be served
81              
82             =item *
83              
84             C<< debug => 1 >> to make the spawned server output debug information
85              
86             =item *
87              
88             C<< eval => >> string that will get evaluated per request in the server
89              
90             Try to avoid characters that are special to the shell, especially quotes.
91             A good idea for a slow server would be
92              
93             eval => sleep+10
94              
95             =back
96              
97             All served HTML will have the first %s replaced by the current location.
98              
99             The following entries will be removed from C<%ENV> when making a request:
100              
101             HTTP_PROXY
102             http_proxy
103             HTTP_PROXY_ALL
104             http_proxy_all
105             HTTPS_PROXY
106             https_proxy
107             CGI_HTTP_PROXY
108             ALL_PROXY
109             all_proxy
110              
111             =cut
112              
113             sub get {
114 11     11 0 402 my( $url ) = @_;
115 11         72 local *ENV;
116 11         107 delete @ENV{qw(
117             HTTP_PROXY http_proxy CGI_HTTP_PROXY
118             HTTPS_PROXY https_proxy HTTP_PROXY_ALL http_proxy_all
119             ALL_PROXY
120             all_proxy
121             )};
122 11         227 my $response = HTTP::Tiny->new->get($url);
123             $response->{content}
124 11         45370 }
125              
126 0     0 0 0 sub spawn_child_win32 { my ( $self, @cmd ) = @_;
127 0         0 local $?;
128 0         0 system(1, @cmd)
129             }
130              
131 17     17 0 70 sub spawn_child_posix { my ( $self, @cmd ) = @_;
132 17         145 require POSIX;
133 17         185 POSIX->import("setsid");
134              
135             # daemonize
136 17 50       34804 defined(my $pid = fork()) || die "can't fork: $!";
137 17 100       1348 if( $pid ) { # non-zero now means I am the parent
138 9         993 return $pid;
139             };
140             #chdir("/") || die "can't chdir to /: $!";
141              
142             # We are the child, close about everything, then exec
143 8 50       1167 (setsid() != -1) || die "Can't start a new session: $!";
144             #open(STDERR, ">&STDOUT") || die "can't dup stdout: $!";
145             #open(STDIN, "< /dev/null") || die "can't read /dev/null: $!";
146             #open(STDOUT, "> /dev/null") || die "can't write to /dev/null: $!";
147 8 0       0 exec @cmd or warn $!;
148             }
149              
150 17     17 0 70 sub spawn_child { my ( $self, @cmd ) = @_;
151 17         32 my ($pid);
152 17 50       123 if( $^O =~ /mswin/i ) {
153 0         0 $pid = $self->spawn_child_win32(@cmd)
154             } else {
155 17         72 $pid = $self->spawn_child_posix(@cmd)
156             };
157              
158 9         288 return $pid
159             }
160              
161             sub spawn {
162 17     17 1 1399 my ($class,%args) = @_;
163              
164 17   50     178 $args{ request_pause } ||= 0;
165              
166 17         74 my $self = { %args };
167 17         57 bless $self,$class;
168              
169 17         97 local $ENV{TEST_HTTP_VERBOSE};
170             $ENV{TEST_HTTP_VERBOSE}= 1
171 17 50       72 if (delete $args{debug});
172              
173 17         93 $self->{delete} = [];
174 17 50       78 if (my $html = delete $args{html}) {
175             # write the html to a temp file
176 0         0 my ($fh,$tempfile) = File::Temp::tempfile();
177 0         0 binmode $fh;
178 0 0       0 print $fh $html
179             or die "Couldn't write tempfile $tempfile : $!";
180 0         0 close $fh;
181 0         0 push @{$self->{delete}},$tempfile;
  0         0  
182 0         0 $args{file} = $tempfile;
183             };
184 17         105 my ($tmpfh,$logfile) = File::Temp::tempfile();
185 17         11482 close $tmpfh;
186 17         71 push @{$self->{delete}},$logfile;
  17         85  
187 17         67 $self->{logfile} = $logfile;
188 17   50     128 my $web_page = delete $args{file} || "";
189              
190 17         40 my $file = __PACKAGE__;
191 17         133 $file =~ s!::!/!g;
192 17         59 $file .= '.pm';
193 17         1640 my $server_file = File::Spec->catfile( dirname( $INC{$file} ),'log-server' );
194 17         119 my ($fh,$url_file) = File::Temp::tempfile;
195 17         9229 close $fh; # race condition, but oh well
196 17         129 my @opts = ("-f", $url_file);
197             push @opts, "-e" => delete($args{ eval })
198 17 50       121 if $args{ eval };
199 17         59 push @opts, "-s" => $args{ request_pause };
200              
201 17         74 my @cmd=( $^X, $server_file, $web_page, $logfile, @opts );
202 17         78 my $pid = $self->spawn_child(@cmd);
203 9         348 my $timeout = time +2;
204 9   66     720 while( time < $timeout and (-s $url_file <= 15)) {
205 45         4510729 sleep( 0.1 ); # overkill, but good enough for the moment
206             }
207              
208 9         202 my $server;
209 9   33     1703 while( time < $timeout and !open $server, '<', $url_file ) {
210 0         0 sleep(0.1);
211             };
212 9 50       155 $server
213             or die "Couldn't read back URL from '$url_file': $!";
214              
215 9         836 my $url = <$server>;
216 9         277 close $server;
217 9         1729 unlink $url_file;
218 9         144 chomp $url;
219 9 50       119 die "Couldn't read back local server url"
220             unless $url;
221              
222 9         452 $self->{_pid} = $pid;
223 9         576 $self->{_server_url} = URI::URL->new($url);
224              
225 9         96495 $self;
226             };
227              
228             =head2 C<< $server->port >>
229              
230             This returns the port of the current server. As new instances
231             will most likely run under a different port, this is convenient
232             if you need to compare results from two runs.
233              
234             =cut
235              
236             sub port {
237 0 0   0 1 0 carp __PACKAGE__ . "::port called without a server" unless $_[0]->server_url;
238 0         0 $_[0]->server_url->port
239             };
240              
241             =head2 C<< $server->url >>
242              
243             This returns the L where you can contact the server. This url
244             is valid until the C<$server> goes out of scope or you call
245              
246             $server->stop;
247              
248             The returned object is a copy that you can modify at your leisure.
249              
250             =cut
251              
252             sub url {
253 9     9 1 32551 $_[0]->server_url->abs
254             };
255              
256             =head2 C<< $server->server_url >>
257              
258             This returns the L object of the server URL. Use Lurl> instead.
259             Use this object if you want to modify the hostname or other properties of the
260             server object.
261              
262             Consider this basically an emergency accessor. In about every case,
263             using C<< ->url() >> does what you want.
264              
265             =cut
266              
267             sub server_url {
268             $_[0]->{_server_url}
269 31     31 1 1375 };
270              
271             =head2 C<< $server->stop >>
272              
273             This stops the server process by requesting a special
274             url.
275              
276             =cut
277              
278             sub stop {
279 9     9 1 31728 local $?; # so we don't override the exit code of a child here
280 9         74 get( $_[0]->server_url() . "quit_server" );
281 9         128 undef $_[0]->{_server_url};
282 9         150 my $pid = delete $_[0]->{_pid};
283 9         31325 waitpid $pid, 0;
284             #my $retries = 10;
285             #while(--$retries and CORE::kill( 0 => $_[0]->{ _pid } )) {
286             #warn "Waiting for '$_[0]->{ _pid }'";
287             #sleep 1; # to give the child a chance to go away
288             #};
289             #if( ! $retries ) {
290             #$_[0]->kill;
291             #};
292             };
293              
294             =head2 C<< $server->kill >>
295              
296             This kills the server process via C. The log
297             cannot be retrieved then.
298              
299             =cut
300              
301             sub kill {
302 0     0 1 0 my $pid = delete $_[0]->{_pid};
303 0 0 0     0 if( $pid and CORE::kill( 0 => $pid )) {
304 0         0 local $?; # so we don't override the exit code of a child here
305              
306             # The kid is still alive
307 0 0       0 CORE::kill( 'KILL' => $pid )
308             or warn "Couldn't kill pid '$pid': $!";
309 0         0 waitpid $pid, 0;
310             };
311 0         0 undef $_[0]->{_server_url};
312             };
313              
314             =head2 C<< $server->get_log >>
315              
316             This returns the
317             output of the server process. This output will be a list of
318             all requests made to the server concatenated together
319             as a string.
320              
321             =cut
322              
323             sub get_log {
324 2     2 1 20002 my ($self) = @_;
325 2         22 return get( $self->server_url() . "get_server_log" );
326             };
327              
328             sub DESTROY {
329 9 100   9   8735 $_[0]->stop if $_[0]->server_url;
330 9         136 for my $file (@{$_[0]->{delete}}) {
  9         234  
331 9 50       805 unlink $file or warn "Couldn't remove tempfile $file : $!\n";
332             };
333 9 50 33     1445 if( $_[0]->{_pid } and CORE::kill( 0 => $_[0]->{_pid })) {
334 0         0 $_[0]->kill; # boom
335             };
336             };
337              
338             =head2 C<< $server->local >>
339              
340             my $url = $server->local('foo.html');
341             # file:///.../foo.html
342              
343             Returns an URL for a local file which will be read and served
344             by the webserver. The filename must
345             be a relative filename relative to the location of the current
346             program.
347              
348             =cut
349              
350             sub local {
351 0     0 1 0 my ($self, $htmlfile) = @_;
352 0         0 require File::Spec;
353 0 0       0 my $fn= File::Spec->file_name_is_absolute( $htmlfile )
354             ? $htmlfile
355             : File::Spec->rel2abs(
356             File::Spec->catfile(dirname($0),$htmlfile),
357             Cwd::getcwd(),
358             );
359 0         0 $fn =~ s!\\!/!g; # fakey "make file:// URL"
360              
361 0         0 $self->local_abs($fn)
362             }
363              
364             =head1 URLs implemented by the server
365              
366             =head2 arbitrary content C<< $server->content($html) >>
367              
368             $server->content(<<'HTML');
369            
370             HTML
371              
372             The URL will contain the HTML as supplied. This is convenient for supplying
373             Javascript or special URL to your user agent.
374              
375             =head2 download C<< $server->download($name) >>
376              
377             This URL will send a file with a C header and indicate
378             the suggested filename as passed in.
379              
380             =head2 302 redirect C<< $server->redirect($target) >>
381              
382             This URL will issue a redirect to C<$target>. No special care is taken
383             towards URL-decoding C<$target> as not to complicate the server code.
384             You need to be wary about issuing requests with escaped URL parameters.
385              
386             =head2 401 basic authentication challenge C<< $server->basic_auth($user, $pass) >>
387              
388             This URL will issue a 401 basic authentication challenge. The expected user
389             and password are encoded in the URL.
390              
391             my $challenge_url = $server->basic_auth('foo','secret');
392             my $wrong_pw = URI->new( $challenge_url );
393             $wrong_pw->userinfo('foo:hunter2');
394             $res = HTTP::Tiny->new->get($wrong_pw);
395             is $res->{status}, 401, "We get the challenge with a wrong user/password";
396              
397             =head2 404 error C<< $server->error_notfound($target) >>
398              
399             This URL will response with status code 404.
400              
401             =head2 Timeout C<< $server->error_timeout($seconds) >>
402              
403             This URL will send a 599 error after C<$seconds> seconds.
404              
405             =head2 Timeout+close C<< $server->error_close($seconds) >>
406              
407             This URL will send nothing and close the connection after C<$seconds> seconds.
408              
409             =head2 Error in response content C<< $server->error_after_headers >>
410              
411             This URL will send headers for a successful response but will close the
412             socket with an error after 2 blocks of 16 spaces have been sent.
413              
414             =head2 Chunked response C<< $server->chunked >>
415              
416             This URL will return 5 blocks of 16 spaces at a rate of one block per second
417             in a chunked response.
418              
419             =head2 Surprisingly large bzip2 encoded response C<< $server->bzip2 >>
420              
421             This URL will return a short HTTP response that expands to 16M body.
422              
423             =head2 Surprisingly large gzip encoded response C<< $server->gzip >>
424              
425             This URL will return a short HTTP response that expands to 16M body.
426              
427             =head2 Other URLs
428              
429             All other URLs will echo back the cookies and query parameters.
430              
431             =cut
432              
433 16     16   30205 use vars qw(%urls);
  16         42  
  16         1882  
434             %urls = (
435             'local_abs' => 'local/%s',
436             'redirect' => 'redirect/%s',
437             'error_notfound' => 'error/notfound/%s',
438             'error_timeout' => 'error/timeout/%s',
439             'error_close' => 'error/close/%s',
440             'error_after_headers' => 'error/after_headers',
441             'gzip' => 'large/gzip/16M',
442             'bzip2' => 'large/bzip/16M',
443             'chunked' => 'chunks',
444             'download' => 'download/%s',
445             'basic_auth' => 'basic_auth/%s/%s',
446             );
447             for (keys %urls) {
448 16     16   139 no strict 'refs';
  16         51  
  16         3385  
449             my $name = $_;
450             *{ $name } = sub {
451 1     1   2096 my $self = shift;
452 1         19 $self->url . sprintf $urls{ $name }, @_;
453             };
454             };
455              
456             sub content {
457 0     0 1   my( $self, $html ) = @_;
458 0           (my $encoded = $html) =~ s!([^\w])!sprintf '%%%02x',$1!ge;
  0            
459 0           $self->url . $encoded;
460             }
461              
462             =head1 EXPORT
463              
464             None by default.
465              
466             =head1 COPYRIGHT AND LICENSE
467              
468             This library is free software; you can redistribute it and/or modify it under
469             the same terms as Perl itself.
470              
471             Copyright (C) 2003-2021 Max Maischein
472              
473             =head1 AUTHOR
474              
475             Max Maischein, Ecorion@cpan.orgE
476              
477             Please contact me if you find bugs or otherwise improve the module. More tests
478             are also very welcome !
479              
480             =head1 SEE ALSO
481              
482             L,L,L
483              
484             =cut
485              
486             1;