view release on metacpan or  search on metacpan

lib/Net/Respite/Server/Test.pm  view on Meta::CPAN

    my $tmpnam      = File::Temp->new;
    my $pid_file    = $args->{'pid_file'}    || "$tmpnam.$$.pid";
    my $access_file = $args->{'access_file'} || "$tmpnam.$$.access";
    my $error_file  = $args->{'error_file'}  || "$tmpnam.$$.error";
    undef $tmpnam;
    my $no_brand    = exists($args->{'no_brand'}) ? 1 : 0;
    my $no_ssl      = exists($args->{'no_ssl'})   ? 1 : 0;
    #$no_ssl = 1;
    my $flat        = exists($args->{'flat'})     ? 1 : 0;

    my $server = $args->{'server'} || do {
        my $pkg = $args->{'server_class'} || 'Net::Respite::Server';
        (my $file = "$pkg.pm") =~ s|::|/|g;
        eval { require $file } || throw "Could not require client library", {msg => $@};
        $pkg->new({
            no_brand        => $no_brand,
            ($args->{'service'}  ? (server_name => $args->{'service'})  : ()),
            ($args->{'api_meta'} ? (api_meta    => $args->{'api_meta'}) : ()),
            port            => $port,
            server_type     => $args->{'server_type'} || 'Fork',
            no_ssl          => $no_ssl,
            flat            => $flat,
            host            => $args->{'host'} || 'localhost',
            pass            => $args->{'pass'},
            pid_file        => $pid_file,
            access_log_file => $access_file,
            log_file        => $error_file,
            user            => defined($args->{'user'})  ? $args->{'user'} : $<,
            group           => defined($args->{'group'}) ? $args->{'group'} : $(,
        });
    };
    #debug $server;
    my $service = $server->server_name;
    $service =~ s/_server$//;

    my $encoded = exists($args->{'utf8_encoded'}) ? 1 : 0;
    my $client = $args->{'client'} || do {
        my $pkg = $args->{'client_class'} || 'Net::Respite::Client';
        (my $file = "$pkg.pm") =~ s|::|/|g;
        eval { require $file } || throw "Could not require client library", {msg => $@};
        $pkg->new({
            no_brand     => $no_brand,
            service      => $service,
            port         => $port,
            host         => $server->{'host'},
            pass         => $args->{'pass'},
            no_ssl       => $no_ssl,
            flat         => $flat,
            utf8_encoded => $encoded,
            ($args->{'brand'} ? (brand => $args->{'brand'}) : ()),
        });
    };
    #debug $client;

    ###----------------------------------------------------------------###
    # start the server in a child, block the parent until ready

    my $pid = fork;
    die "Could not fork during test\n" if ! defined $pid;
    if (!$pid) { # child
        local @ARGV;
        $server->run_server(setsid => 0, background => 0); # allow a kill term to close the server too
        exit;
    }

    my $client_pid = $$;
    $client->{'_test_ender'} = end {
        diag("Client object ending: pid=[$$] port=[$port]");

        if ($client_pid != $$) {
            diag("ORIGPID[$client_pid]!=CURRPID[$$] Refusing to stop server on port [$port]! Running setup_test_server() while an old client object still exists can trigger this phantom cleanup on the OLD client object when the child request from the...
            return;
        }

        diag("Process list") if $verbose;
        $server->__ps;

        diag("Stop server");
        $server->__stop;
        # get some info - then tear down

        diag("Tail of the error_log") if $verbose;
        $server->__tail_error(1000) if $verbose;

        diag("Tail of the access_log") if $verbose;
        $server->__tail_access($server->{'tail_access'} || 20) if $verbose;

        diag("Shut down server") if $verbose;
        unlink $_ for $pid_file, $access_file, $error_file; # double check
    };

    # block the parent (that will run client tests) until the child running the server is fully setup
    my $connected;
    for (1 .. 30) {
        sleep 0.1;
        my $class = 'IO::Socket::INET';
        if (!$no_ssl) {
            require IO::Socket::SSL;
            $class = 'IO::Socket::SSL';
        }
        my $sock = $class->new(PeerHost => "localhost", PeerPort => $port, SSL_verify_mode => 0) || next;
        print $sock "GET /waited_until_child HTTP/1.0\n\n";
        $connected = 1;
        last;
    }
    if (! $connected) {
        diag("Tail of the error_log");
        $server->__tail_error($server->{'tail_error'} || 20) if $verbose;
        die "Failed to connect to the server: $!";
    }

    return wantarray ? ($client, $server) : $client;
}

1;

__END__

=head1 SYNOPSIS

    use Test::More tests => 2;