=head1 NAME
Froody::Server::Test
=head1 SYNOPSIS
=head1 DESCRIPTION
=cut
package Froody::Server::Test;
use warnings;
use strict;
use Froody::Dispatch;
use Froody::Server::Standalone;
=head1 METHODS
=over
=item client( 'Froody::Service', 'Froody::Service', .. )
Starts a standalone Froody server, implementing the passed service classes,
and returns a Froody::Client object that will talk to the server, for local
testing of implementations. The server will be stopped on script exit.
=cut
# This is our random port, which is an attempt to not tromp over other users who might
# be testing their own froody clients at the same time.
our $port = 30_000 + ( $> % 400 );
my $child;
=item start
Starts the Test server with a list of configuration details as specified
by the C<config> method of L<Froody::Dispatch>. Returns the pid of the
started process, or 0 if it happens to be the child process.
This will only start the server once, without calling C<stop> first.
=cut
sub start {
my ($class, @impl) = @_;
return $child if defined $child;
unless ($child = fork()) {
# loading Froody::Server::Standalone does some things
# to our enviroment (for example, it piddles with the SIG handlers
# so we only want to do that in the child.)
my $server = Froody::Server::Standalone->new();
$server->config({
modules => \@impl,
});
$server->port($port);
$server->run;
}
return $child;
}
=item endpoint
Returns the endpoint for the Test server
=cut
sub endpoint {
my $class = shift;
return "http://localhost:$port/";
}
# start the web server
=item client
Returns a C<Froody::Dispatch> based client that points to the test
server. As a side-effect, it will start up the test server if it has
not already been started.
=cut
sub client {
my ($class, @impl) = @_;
$class->start(@impl);
sleep 1;
my $client = Froody::Dispatch->new();
$client->repository( Froody::Repository->new() );
$client->add_endpoint("http://localhost:$port");
return $client;
}
# stop is documented
sub stop {
if ($child) {
# what the gosh-darn signals numbered on this box then?
use Config;
defined $Config{sig_name} || die "No sigs?";
my ($i, %signo);
foreach my $name (split(' ', $Config{sig_name})) {
$signo{$name} = $i;
$i++;
}
# die with more and more nastyness
for my $signal (qw(TERM KILL)) {
kill $signo{$signal}, $child;
exit unless kill 0, $child;
sleep 1;
}
$child = undef;
}
}
END { stop() }
=back
=head1 BUGS
None known.
Please report any bugs you find via the CPAN RT system.
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Froody>
=head1 AUTHOR
Copyright Fotango 2005. All rights reserved.
Please see the main L<Froody> documentation for details of who has worked
on this project.
This module is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.
=cut
1;