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   73120 use strict;
  16         110  
  16         409  
3 16     16   352 use 5.008; # We use "fancy" opening of lexical filehandle, see below
  16         52  
4 16     16   7011 use FindBin;
  16         17968  
  16         750  
5 16     16   104 use File::Spec;
  16         34  
  16         268  
6 16     16   11753 use File::Temp;
  16         352887  
  16         1100  
7 16     16   6652 use URI::URL qw();
  16         120686  
  16         386  
8 16     16   97 use Carp qw(carp croak);
  16         36  
  16         787  
9 16     16   87 use Cwd;
  16         33  
  16         829  
10 16     16   93 use File::Basename;
  16         32  
  16         841  
11 16     16   8363 use Time::HiRes qw ( time sleep );
  16         21241  
  16         67  
12 16     16   13688 use HTTP::Tiny;
  16         634097  
  16         729  
13 16     16   8484 use HTTP::Daemon 6.05; # Our log server needs this, but we load it here to find its version
  16         773679  
  16         169  
14              
15             our $VERSION = '0.75';
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 318 my( $url ) = @_;
115 11         48 local *ENV;
116 11         62 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         198 my $response = HTTP::Tiny->new->get($url);
123             $response->{content}
124 11         34116 }
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 60 sub spawn_child_posix { my ( $self, @cmd ) = @_;
132 17         161 require POSIX;
133 17         183 POSIX->import("setsid");
134              
135             # daemonize
136 17 50       23947 defined(my $pid = fork()) || die "can't fork: $!";
137 17 100       1099 if( $pid ) { # non-zero now means I am the parent
138 9         841 return $pid;
139             };
140             #chdir("/") || die "can't chdir to /: $!";
141              
142             # We are the child, close about everything, then exec
143 8 50       931 (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 68 sub spawn_child { my ( $self, @cmd ) = @_;
151 17         30 my ($pid);
152 17 50       113 if( $^O =~ /mswin/i ) {
153 0         0 $pid = $self->spawn_child_win32(@cmd)
154             } else {
155 17         70 $pid = $self->spawn_child_posix(@cmd)
156             };
157              
158 9         291 return $pid
159             }
160              
161             sub spawn {
162 17     17 1 1292 my ($class,%args) = @_;
163              
164 17   50     164 $args{ request_pause } ||= 0;
165              
166 17         62 my $self = { %args };
167 17         51 bless $self,$class;
168              
169 17         80 local $ENV{TEST_HTTP_VERBOSE};
170             $ENV{TEST_HTTP_VERBOSE}= 1
171 17 50       68 if (delete $args{debug});
172              
173 17         101 $self->{delete} = [];
174 17 50       66 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         116 my ($tmpfh,$logfile) = File::Temp::tempfile();
185 17         9922 close $tmpfh;
186 17         56 push @{$self->{delete}},$logfile;
  17         70  
187 17         61 $self->{logfile} = $logfile;
188 17   50     131 my $web_page = delete $args{file} || "";
189              
190 17         44 my $file = __PACKAGE__;
191 17         125 $file =~ s!::!/!g;
192 17         44 $file .= '.pm';
193 17         1446 my $server_file = File::Spec->catfile( dirname( $INC{$file} ),'log-server' );
194 17         106 my ($fh,$url_file) = File::Temp::tempfile;
195 17         5038 close $fh; # race condition, but oh well
196 17         85 my @opts = ("-f", $url_file);
197             push @opts, "-e" => delete($args{ eval })
198 17 50       79 if $args{ eval };
199 17         55 push @opts, "-s" => $args{ request_pause };
200              
201 17         68 my @cmd=( $^X, $server_file, $web_page, $logfile, @opts );
202 17         113 my $pid = $self->spawn_child(@cmd);
203 9         302 my $timeout = time +2;
204 9   66     613 while( time < $timeout and (-s $url_file <= 15)) {
205 38         3807831 sleep( 0.1 ); # overkill, but good enough for the moment
206             }
207              
208 9         161 my $server;
209 9   33     1147 while( time < $timeout and !open $server, '<', $url_file ) {
210 0         0 sleep(0.1);
211             };
212 9 50       132 $server
213             or die "Couldn't read back URL from '$url_file': $!";
214              
215 9         489 my $url = <$server>;
216 9         168 close $server;
217 9         1134 unlink $url_file;
218 9         74 chomp $url;
219 9 50       96 die "Couldn't read back local server url"
220             unless $url;
221              
222 9         276 $self->{_pid} = $pid;
223 9         397 $self->{_server_url} = URI::URL->new($url);
224              
225 9         69831 $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 22030 $_[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 1393 };
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 25954 local $?; # so we don't override the exit code of a child here
280 9         52 get( $_[0]->server_url() . "quit_server" );
281 9         97 undef $_[0]->{_server_url};
282 9         88 my $pid = delete $_[0]->{_pid};
283 9         23357 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 13023 my ($self) = @_;
325 2         14 return get( $self->server_url() . "get_server_log" );
326             };
327              
328             sub DESTROY {
329 9 100   9   6309 $_[0]->stop if $_[0]->server_url;
330 9         115 for my $file (@{$_[0]->{delete}}) {
  9         173  
331 9 50       641 unlink $file or warn "Couldn't remove tempfile $file : $!\n";
332             };
333 9 50 33     1048 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   28502 use vars qw(%urls);
  16         60  
  16         1796  
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   119 no strict 'refs';
  16         45  
  16         3154  
449             my $name = $_;
450             *{ $name } = sub {
451 1     1   1779 my $self = shift;
452 1         7 $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-2023 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;