File Coverage

inc/Test/HTTP/LocalServer.pm

Criterion	Covered	Total	%
statement	31	82	37.8
branch	0	20	0.0
condition	0	5	0.0
subroutine	11	19	57.8
pod	6	6	100.0
total	48	132	36.3

package Test::HTTP::LocalServer;

# start a fake webserver, fork, and connect to ourselves
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 LWP::Simple;
use FindBin;
use File::Spec;
use File::Temp;
use URI::URL qw();
use Carp qw(carp croak);

use vars qw($VERSION);
$VERSION = '0.56';

=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
  $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

=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} || "";

  my $server_file = File::Spec->catfile( $FindBin::Bin,File::Spec->updir,'inc','Test','HTTP','log-server' );
  my @opts;
  push @opts, "-e" => qq{"} . delete($args{ eval }) . qq{"}
      if $args{ eval };

  my $cmd= qq'$^X "$server_file" "$web_page" "$logfile" @opts|';
  #warn "[$cmd]";
  my $pid = open my $server, $cmd
    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->{_fh} = $server;
  $self->{_pid} = $pid;
  $self->{_server_url} = URI::URL->new($url);

  $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
  $server->stop;

=cut

sub url {
  $_[0]->{_server_url}->abs
};

=head2 C<< $server->stop >>

This stops the server process by requesting a special
url.

=cut

sub stop {
  get( $_[0]->{_server_url} . "quit_server" );
  close $_[0]->{_fh};
  undef $_[0]->{_server_url}
};

=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 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) = @_;
  return get( $self->{_server_url} . "get_server_log" );
};

sub DESTROY {
  $_[0]->stop if $_[0]->{_server_url};
  for my $file (@{$_[0]->{delete}}) {
    unlink $file or warn "Couldn't remove tempfile $file : $!\n";
  };
  if( $_[0]->{_pid } and CORE::kill( 0 => $_[0]->{_pid })) {
      $_[0]->kill; # boom
  };
};

=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

use vars qw(%urls);
%urls = (
    '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, [e-mail]

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;