package LocalServer;
# start a fake webserver, fork, and connect to ourselves
use warnings;
use strict;
use Test::More;
use LWP::Simple;
use FindBin;
use File::Spec;
use File::Temp;
use URI::URL qw();
use Carp qw(carp croak);
=head2 C<< Test::HTTP::LocalServer->spawn %ARGS >>
This spawns a new HTTP server. The server will stay running until
C<< $server->stop >> is called.
Valid arguments are:
=over 4
=item * html
scalar containing the page to be served
=item * file
filename containing the page to be served
=item * debug
Set to true to make the spawned server output debug information
=back
All served HTML will have the first %s replaced by the current location.
=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};
if (defined $web_page) {
$web_page = qq{"$web_page"}
} else {
$web_page = "";
};
my $server_file = File::Spec->catfile( $FindBin::Bin,'log-server' );
open my $server, qq'$^X "$server_file" "$web_page" "$logfile" |'
or die "Couldn't spawn fake server $server_file : $!";
my $url = <$server>;
chomp $url;
die "Couldn't find fake server url" unless $url;
$self->{_fh} = $server;
my $lhurl = URI::URL->new( $url );
$lhurl->host( 'localhost' );
$self->{_server_url} = $lhurl;
diag "Started $lhurl";
$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 you call
C<< $server->stop >>
or
C<< $server->get_output >>
=cut
sub url {
my $url = $_[0]->{_server_url}->abs;
return $url->as_string;
};
=head2 C<< $server->creds_required >>
This returns a URL for a page that requires HTTP Basic-Auth. The
content returned is invariant and irrelevant; this method is for
testing credential-passing code. The username is 'luser' and the
password is 'fnord'. When these credentials are passed, the returned
status will be 200, otherwise it will be 401.
=cut
sub creds_required {
return $_[0]->{_server_url} . 'creds_required';
}
=head2 C<< $server->stop >>
This stops the server process by requesting a special
url.
=cut
sub stop {
get( $_[0]->{_server_url} . 'quit_server' );
undef $_[0]->{_server_url}
};
=head2 C<< $server->get_output >>
This stops the server by calling C<stop> 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_output {
my ($self) = @_;
$self->stop;
local $/;
local *LOG;
open LOG, '<', $self->{logfile}
or die "Couldn't retrieve logfile";
return join "", <LOG>;
}
sub DESTROY {
my $self = shift;
$self->stop if $self->{_server_url};
if ( $self->{_fh} ) {
close $self->{_fh};
delete $self->{_fh};
}
for my $file ( @{$self->{delete}} ) {
unlink $file or warn "Couldn't remove tempfile $file : $!\n";
}
}
=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 Max Maischein
=head1 AUTHOR
Max Maischein, E<lt>corion@cpan.orgE<gt>
Please contact me if you find bugs or otherwise improve the module. More tests are also very welcome !
=head1 SEE ALSO
L<WWW::Mechanize>,L<WWW::Mechanize::Shell>
=cut
1;