package LocalServer; # start a fake webserver, fork, and connect to ourselves use warnings; use strict; # this has to happen here because LWP::Simple creates a $ua # on load so any time after this is too late. BEGIN { delete @ENV{ qw( HTTP_PROXY http_proxy CGI_HTTP_PROXY HTTPS_PROXY https_proxy HTTP_PROXY_ALL http_proxy_all ) }; } use Carp qw( carp croak ); use File::Temp (); use LWP::Simple qw( get ); use Path::Tiny qw( path ); use URI::URL (); =head1 SYNOPSIS use LWP::Simple qw(get); my $server = Test::HTTP::LocalServer->spawn; ok get $server->url, "Retrieve " . $server->url; $server->stop; =head1 METHODS =head2 Cspawn %ARGS> This spawns a new HTTP server. The server will stay running until C<< $server->stop >> is called. Valid arguments are: =over 4 =item * C<< html => >> scalar containing the page to be served =item * C<< file => >> filename containing the page to be served =item * C<< debug => 1 >> to make the spawned server output debug information =item * C<< eval => >> string that will get evaluated per request in the server Try to avoid characters that are special to the shell, especially quotes. A good idea for a slow server would be eval => sleep+10 =back All served HTML will have the first %s replaced by the current location. The following entries will be removed from C<%ENV>: HTTP_PROXY http_proxy CGI_HTTP_PROXY HTTPS_PROXY https_proxy HTTP_PROXY_ALL http_proxy_all =cut sub spawn { my ( $class, %args ) = @_; my $self = {%args}; bless $self, $class; local $ENV{TEST_HTTP_VERBOSE}; $ENV{TEST_HTTP_VERBOSE} = 1 if ( delete $args{debug} ); $self->{delete} = []; if ( my $html = delete $args{html} ) { # write the html to a temp file my ( $fh, $tempfile ) = File::Temp::tempfile(); binmode $fh; print $fh $html or die "Couldn't write tempfile $tempfile : $!"; close $fh; push @{ $self->{delete} }, $tempfile; $args{file} = $tempfile; } my ( $fh, $logfile ) = File::Temp::tempfile(); close $fh; push @{ $self->{delete} }, $logfile; $self->{logfile} = $logfile; my $web_page = delete $args{file} || q{}; my $server_file = path('t/local/log-server')->absolute; my @opts; push @opts, "-e" => qq{"} . delete( $args{eval} ) . qq{"} if $args{eval}; my $pid = open my $server, qq'$^X "$server_file" "$web_page" "$logfile" @opts|' or croak "Couldn't spawn local server $server_file : $!"; my $url = <$server>; chomp $url; die "Couldn't read back local server url" unless $url; $self->{_server_url} = URI::URL->new($url); $self->{_fh} = $server; $self->{_pid} = $pid; $self; } =head2 C<< $server->port >> This returns the port of the current server. As new instances will most likely run under a different port, this is convenient if you need to compare results from two runs. =cut sub port { carp __PACKAGE__ . '::port called without a server' unless $_[0]->{_server_url}; $_[0]->{_server_url}->port; } =head2 C<< $server->url >> This returns the url where you can contact the server. This url is valid until the C<$server> goes out of scope or you call C<< $server->stop >> or C<< $server->get_log >>. =cut sub url { $_[0]->{_server_url}->abs->as_string; } =head2 C<< $server->stop >> This stops the server process by requesting a special url. =cut sub stop { my ($self) = @_; get( $self->quit_server ); undef $self->{_server_url}; if ( $self->{_fh} ) { close $self->{_fh}; delete $self->{_fh}; } } =head2 C<< $server->kill >> This kills the server process via C. The log cannot be retrieved then. =cut sub kill { CORE::kill( 9 => $_[0]->{_pid} ); undef $_[0]->{_server_url}; undef $_[0]->{_pid}; } =head2 C<< $server->get_log >> This stops the server by calling C and then returns the output of the server process. This output will be a list of all requests made to the server concatenated together as a string. =cut sub get_log { my ($self) = @_; my $log = get( $self->get_server_log ); $self->stop; return $log; } sub DESTROY { $_[0]->stop if $_[0]->{_server_url}; for my $file ( @{ $_[0]->{delete} } ) { unlink $file or warn "Couldn't remove tempfile $file : $!\n"; } } =head1 URLs implemented by the server =head2 302 redirect C<< $server->redirect($target) >> This URL will issue a redirect to C<$target>. No special care is taken towards URL-decoding C<$target> as not to complicate the server code. You need to be wary about issuing requests with escaped URL parameters. =head2 404 error C<< $server->error_notfound($target) >> This URL will response with status code 404. =head2 Timeout C<< $server->error_timeout($seconds) >> This URL will send a 599 error after C<$seconds> seconds. =head2 Timeout+close C<< $server->error_close($seconds) >> This URL will send nothing and close the connection after C<$seconds> seconds. =head2 Error in response content C<< $server->error_after_headers >> This URL will send headers for a successfull response but will close the socket with an error after 2 blocks of 16 spaces have been sent. =head2 Chunked response C<< $server->chunked >> This URL will return 5 blocks of 16 spaces at a rate of one block per second in a chunked response. =head2 Other URLs All other URLs will echo back the cookies and query parameters. =cut my %urls = ( 'quit_server' => 'quit_server', 'get_server_log' => 'get_server_log', 'redirect' => 'redirect/%s', 'error_notfound' => 'error/notfound/%s', 'error_timeout' => 'error/timeout/%s', 'error_close' => 'error/close/%s', 'error_after_headers' => 'error/after_headers', 'chunked' => 'chunks', ); for ( keys %urls ) { no strict 'refs'; my $name = $_; *{$name} = sub { my $self = shift; $self->url . sprintf $urls{$name}, @_; }; } =head1 EXPORT None by default. =head1 COPYRIGHT AND LICENSE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Copyright (C) 2003-2011 Max Maischein =head1 AUTHOR Max Maischein, Ecorion@cpan.orgE Please contact me if you find bugs or otherwise improve the module. More tests are also very welcome ! =head1 SEE ALSO L,L,L =cut 1;