# $Id: apache.t,v 1.28 1999/08/26 23:39:52 john Exp $

use 5.010;
use strict;
use warnings;

use Cwd;
use IO::Socket;
use Net::Ident;

# GET uri from server
sub GET {
    my ( $server, $uri ) = @_;
    my ( $header, $content );

    print "# GET http://$server$uri\n";
    eval {
        my $sock = new IO::Socket::INET PeerAddr => $server, Timeout => 10;
        $sock or die "cannot connect to $server: $!\n";
        $sock->autoflush(1);
        local $SIG{ALRM} = sub { die "Timeout in GET\n" };
        alarm(10);
        print $sock <<HTTP;
GET $uri HTTP/1.0\r
User-Agent: t/apache.t\r
Host: $server\r
Connection: close\r
\r
HTTP

        my $resp = join( "", <$sock> );
        alarm(0);
        ( $header, $content ) = $resp =~ /\A((?:.*\n)+)\r?\n([\s\S]*)\Z/;
        $header or die "server returned garbage: $resp\n";
        wantarray ? ( $content, $header ) : $content;
    };
}

my ($apache_bin, $apache_addr, $apache_root, $username, $ourpid);

END {
    # make sure apache dies when we exit, but only if we exit ourselves
    return if !$ourpid || $ourpid != $$;
    if (   defined $apache_root
        && -r "$apache_root/logs/httpd.pid"
        && open( PID, "$apache_root/logs/httpd.pid" ) ) {
        my $pid = <PID>;
        chomp $pid;
        close PID;
        kill TERM => $pid
          and print "# stopped apache\n";
        sleep 2;
        kill KILL => $pid;
    }
}

# Initialise apache test. If the below dies at any point, it means the
# apache setup failed. This does NOT fail the test, however...
eval {
    # get current directory
    my $cwd = cwd();

    # set our PID, for the END{} routine
    $ourpid = $$;

    # verify the apache test is configured
    -f "$cwd/t/apache/conf/apache_config.pl"
      or die "Apache test not configured\n";

    # read configuration data
    require "$cwd/t/apache/conf/apache_config.pl";

    # write file containing current @INC, to be used by the apache
    # mod_perl programs.
    open( INC, ">$apache_root/perl/inc" )
      or die "cannot write $apache_root/perl/inc: $!\n";
    print INC '@INC = ("', join(
        '","',
        map {
            s/^\./$cwd/;
            $_ = "$cwd/$_" unless m-^/-;
            s/\\/\\\\/g;
            s/"/\\"/g;
            $_
        } @INC
      ),
      "\");\n";
    close INC;

    # OK! Let's have fun!
    print "# Starting apache...\n";
    system( $apache_bin, "-f", "$apache_root/conf/httpd.conf" )
      and die "Apache returned non-zero exit status: $?\n";
    my $startuptime = 3 + time;

    # do a really silly loopback connection and ident lookup on this
    # to find out what identd returns. We assume previous tests
    # already established the proper functioning of Net::Ident in
    # "normal" circumstances!
    my $listen = new IO::Socket::INET Listen => 5, LocalAddr => 'localhost', Timeout => 10;
    $listen or die "SLEEP: Cannot create listening socket: $!\n";
    my $listenport = $listen->sockport;
    my $pid        = fork;
    defined $pid or die "SLEEP: cannot fork: $!\n";
    if ( $pid == 0 ) {

        # child. connect from here to prevent deadlocks
        my $connect = new IO::Socket::INET PeerAddr => "localhost:$listenport";
        $connect or exit 0;    # can't generate error.
        my $dummy = <$connect>;
        exit 0;
    }

    # parent. wait for an incoming connection, or possibly time out
    my $accept = $listen->accept;
    $accept or die "SLEEP: Error in accept: $!\n";

    # phew. we have an incoming connection from ourselves. let's do the
    # actual ident lookup.
    my ( $os, $error );
    ( $username, $os, $error ) = Net::Ident::lookup( $accept, 10 );
    defined $username
      or die "SLEEP: Couldn't perform ident lookup: $error\n";
    print "# identd tells us we're $username\n";
    print $accept "you are $username\n";
    close $accept;
    close $listen;

    # if you think the above is an extremely silly way to do getpwuid($<),
    # think again. Just for fun, let's compare the ID we got with getpwuid
    # and co... sometimes it IS different (for privacy-enhanced identd)
    if (   ( getpwuid($<) && $username ne getpwuid($<) )
        && ( getlogin() && $username ne getlogin() )
        && ( $ENV{USER} && $username ne $ENV{USER} ) ) {
        print "# Hmm... that doesn't look like getpwuid(\$<) = \"", getpwuid($<) || "(undef)", "\"\n";
        print "# nor like getlogin() = \"",                         getlogin()   || "(undef)", "\"\n";
        print "# nor like $ENV{USER} = \"",                         $ENV{USER}   || "(undef)", "\"\n";
    }

    # let apache warm up some more, if necessary
    sleep $startuptime - time if $startuptime > time;

    # test apache itself
    my $result = GET( $apache_addr, "/testapache.txt" );
    defined $result and $result =~ /^Apache OK/
      or die "Apache not ready\n";
    print "# standard Apache OK\n";
    GET( $apache_addr, "/perl/testmodperl" ) =~ /^mod_perl OK/
      or die "mod_perl not ready\n";
    print "# mod_perl OK\n";
};

if ($@) {
    my $reason = $@;
    if ( $reason =~ /^SLEEP: (.*)$/s ) {

        # we died too soon, apache is still starting up.
        $reason = $1;

        # make sure apache starts properly, else we can't kill it
        sleep 5;
    }
    print "# $reason";
    print "\n" unless $reason =~ /\n$/;
    print "1..0\n";
    exit 0;
}

# when we get here, identd is responding, apache is running, and mod_perl
# is functioning. Let's finally do some testing of Net::Ident

print "1..4\n";
my $i = 1;
my ( $reply, $header ) = GET( $apache_addr, "/perl/testident" );
if ( !defined $reply ) {
    print "not ok $i\n";
    $i++;
    exit 0;
}
print "ok $i\n";
$i++;
if ( $header !~ m{\AHTTP/[\d.]+\s+(\d+)\s} || $1 ne "200" ) {
    print "# apache barfed\n";
    print "not ok $i\n";
    $i++;
    print STDERR "$header\n\n$reply\n";
    exit 0;
}
print "ok $i\n";
$i++;
my ( $func, $meth ) = $reply =~ m{
    ^function\slookupFromInAddr\ssays\syou\sare:\s(.*)\n
    ident_lookup\smethod\ssays\syou\sare:\s(.*)\n
}xm;
if ( !defined $meth ) {
    print "not ok $i\n";
    $i++;
    exit 0;
}
print "# ident lookup via apache returned: \"$func\" and \"$meth\"\n";
print( ( $func eq $username ) ? "ok $i\n" : "not ok $i\n" );
$i++;
print( ( $meth eq $username ) ? "ok $i\n" : "not ok $i\n" );
$i++;
