
# Useful routines used by the test scripts

package ModTest;

use strict;
use Socket;
use Cwd;

my $version	= `httpd -v` =~ /Apache.2/ ? 2 : 1;
my $srvroot	= "/tmp/mod_persistentperl${version}_test";
my $srvport	= 8528 + $version;
my $tcp_proto	= getprotobyname('tcp');
my $lo_addr	= inet_aton('localhost');

sub mod_dir {
    &Cwd::cwd;
}

sub docroot {
    &mod_dir . '/t/docroot';
}

sub get_httpd_pid {
    my $pid = `cat $srvroot/httpd.pid 2>/dev/null`;
    chop $pid;
    return ($pid && kill(0, $pid)) ? $pid : 0;
}

sub write_conf { my $extracfg = shift; 
    my($mod_dir, $docroot, $grp) = (&mod_dir, &docroot, $));
    $grp =~ s/\s.*//;
    my $module = $ENV{PERPERL_MODULE}
	|| ($version == 1
	    ? "$mod_dir/mod_persistentperl.so" : "$mod_dir/.libs/mod_persistentperl.so");
    my $backend = $ENV{PERPERL_BACKENDPROG}
	|| "$mod_dir/../perperl_backend/perperl_backend";

    foreach my $f ($module, $backend) {
	die "Cannot locate ${f}: $!\n" unless -f $f;
    }

    # Can't run apache as user 0 (root)
    my $user = $> ? "#$>" : 'nobody';

    my $cfg = "
	ServerRoot		$srvroot
	User			$user
	Group			#$grp
	ServerName		localhost
	DocumentRoot		$docroot
	ErrorLog		error_log
	PidFile			httpd.pid
	LockFile		lock_file
	Options			+ExecCGI
	LoadModule		persistentperl_module $module
	PersistentBackendProg	$backend
	<Directory $docroot/perperl>  
	DefaultType		 persistentperl-script
	</Directory>		 
	<IfModule mod_mime.c>
	TypesConfig /dev/null
	</IfModule>
    ";
    if ($version > 1) {
	$cfg .= "
	Listen			$srvport
	";
    } else {
	$cfg .= "
	Port			$srvport
	AddModule		mod_persistentperl.c
	AccessConfig		/dev/null
	ResourceConfig		/dev/null
	ScoreBoardFile		/dev/null
	";
    }
    $cfg .= $extracfg if (defined($extracfg));
    $cfg =~ s/\n\s+/\n/g;

    mkdir($srvroot, 0777);
    open(F, ">$srvroot/httpd.conf") || die;
    print F $cfg;
    close(F);
}

sub find_httpd {
    my $x = `apxs -q SBINDIR` . '/httpd';
    return -x $x ? $x : 'httpd';
}

sub abort_test {
    my $reason = 'Cannot start httpd, skipping test';
    $| = 1;
    print "1..1\nok # skip $reason\n";
    print STDERR "$reason\n";
    exit;
};

sub start_httpd {
    &write_conf(@_);
    my $pid = &get_httpd_pid;
    if ($pid && kill(0, $pid)) {
	kill(9, $pid);
	sleep 1;
    }
    my $x = $|; $| = 1; print ""; $| = $x; # Avoid double-flush on stdout.
    if (fork == 0) {
	close(STDOUT);
	close(STDERR);
	if (fork == 0) {
	    open(STDOUT, ">>$srvroot/httpd.stdout");
	    open(STDERR, ">&STDOUT");
	    $| = 1;
	    print 'Startup ', scalar localtime, "\n";
	    my $httpd = &find_httpd;
	    eval {exec(split(/ /, "$httpd -X -d $srvroot -f httpd.conf"))};
	    print STDERR "cannot exec httpd: $!\n";
	    die;
	}
	exit 0;
    }
    wait;
    for (my $tries = 4; $tries; --$tries) {
	my $test = html_get('/htmltest');
	# print STDERR "debug=$test\n";
	return if $test =~ /html test/i;
	sleep(1);
    }
    &abort_test;
}

sub http_get { my $relurl = shift;
    my $paddr = sockaddr_in($srvport, $lo_addr);
    socket(SOCK, PF_INET, SOCK_STREAM, $tcp_proto);
    return '' unless connect(SOCK, $paddr);
    my $oldfh = select SOCK;
    $| = 1;
    print "GET $relurl HTTP/1.0\n\n";
    select $oldfh;
    my @ret;
    eval {
	local $SIG{ALRM} = sub {die "alarm clock"};
	alarm 2;
	@ret = <SOCK>;
	alarm 0;
    };
    close(SOCK);
    return wantarray ? @ret : join('', @ret);
}

sub html_get { 
    my @lines = &http_get(@_);
    if (@lines) {
	while ($lines[0] =~ /\S/) { shift @lines }
	shift @lines;
	return wantarray ? @lines : join('', @lines);
    }
    return '';
}

sub touchem { my $scripts = shift;
    my $docroot = &docroot;
    foreach my $scr (@{$scripts || []}) {
	$scr = "$docroot/$scr";
	die "$scr: $!\n" unless -f $scr;
	utime time, time, $scr;
    }
}

sub set_alarm { my $secs = shift;
    $SIG{ALRM} = sub { print "failed\n"; exit };
    alarm($secs);
}

sub test_init { my($timeout, $scripts, $extracfg) = @_;
    &set_alarm($timeout);
    &touchem($scripts);
    &start_httpd($extracfg);
}

END {
    my $pid = &get_httpd_pid;
    kill(9, $pid) if ($pid);
}

1;
