tags/v1_29/t/TEST.win32

#AUTHOR: Peter Tillemans <pti@MAIL.NET4ALL.BE>

use strict;
use Cwd;
use File::Copy;
use File::Find;
use Win32::Process;
use Win32;
use Config;
use File::Basename 'dirname';
require File::Spec;
use ExtUtils::MakeMaker;

#
# Config part
#

my $apache = 'apache';
my $fullapache = find_apache();

my $ap_path = dirname $fullapache;
$ENV{PATH} = join ";", $ap_path, $ENV{PATH};

my $fullperl = $Config{perlpath};

print "Running tests with:\n";
print "  perl=$fullperl\n  apache=$fullapache\n";

my $port = 8529;

sub ErrorReport {
    print Win32::FormatMessage( Win32::GetLastError() );
}

#
# prepare config files
#

my $conf = 't/conf/httpd.conf';
my $win32_conf = $conf . '-win32';
my $bak = $conf . '.bak';
copy($win32_conf, $conf)
    or die "Copy of $win32_conf to $conf failed: $!";

#
#source or binary distribution
#

for (qw(src/modules/win32/Release
        src/modules/win32/Debug
	win32/modules)) {	
    my $dll = "$_/mod_perl.so";
    next unless -e $dll;
    copy $dll, "t/modules/mod_perl.so";
    last;
}

#
# create some bogus files and a place to dump the logfiles
#

mkdir("/tmp","755") unless -d "/tmp";
for my $d (qw(logs conf)) {
    mkdir("t/$d","755") unless -d "t/$d";
}
for my $f (qw(srm.conf access.conf mime.types)) {
    local *FH;
    open FH, ">t/conf/$f"; close FH;
}

# change the paths so everybody agrees on which files to use
# this is to make sure apache knows which files to take :
#   apparently apache uner Win32
#   change directories to the installation directory so "./t" 
#   references do not work

my $pwd = cwd();
unless (-e $bak) {
    copy($conf, $bak) or die "Copying $conf to $bak failed: $!";
}
open(BAK, $bak) or die "Open of $bak for reading failed: $!";
open(CONF, ">$conf") or die "Open of $conf for writing failed: $!";
while (<BAK>) {
    s#\./t#$pwd/t#;
    print CONF $_;
}
close BAK;
close CONF;

#
# start ourselves a server to pound on
#

my $HttpdObj;
Win32::Process::Create($HttpdObj,
                       $fullapache,
                       "$apache -X -d $pwd/t -f $pwd/t/conf/httpd.conf",
                       0,
                       NORMAL_PRIORITY_CLASS,
                       ".") || die ErrorReport();

print << "END";
httpd listening on port $port
will write error_log to: t/logs/mod_perl_error_log
letting apache warm up...
END

sleep 2;
print "done\n";

#
# Ok, start pounding
#
system "$fullperl t/TEST @ARGV";

#
# stop server again
#
$HttpdObj->Kill(0);

#
# remove traces
#

print "letting apache cool down...\n";
sleep 2;
find(\&cleanup, '/tmp/');
sub cleanup {/^(mod_perl|CGItemp)/ && unlink($_)}
unlink $bak;
unlink "$pwd/t/logs/mod_perl_httpd.pid";

sub find_apache {
    my $apache;
    my $exe = 'Apache.exe';
  SEARCH: {
        my $candidate;
        for (File::Spec->path) {
            $candidate = File::Spec->catfile($_, $exe);
            if (-e $candidate and check_win32_apache($candidate)) {
                $apache = $candidate;
                last SEARCH;
            }
        }
        my @drives = drives();
        last SEARCH unless (@drives > 0);
        for my $drive (@drives) {
            for ('Apache', 'Program Files/Apache', 
                 'Program Files/Apache Group/Apache') {
                $candidate = File::Spec->catfile($drive, $_, $exe);
                if (-e $candidate and check_win32_apache($candidate)) {
                    $apache = $candidate;
                    last SEARCH;
                }
            }
        }
    }
    unless (-e $apache) {
        $apache = prompt("Please supply the full path to Apache.exe:", 
                         $apache);
        if (-d $apache) {
            $apache = File::Spec->catfile($apache, $exe);
        }
    }
    die "Can't find $exe!" 
        unless (-e $apache and check_win32_apache($apache));
    
    $apache = Win32::GetShortPathName($apache);
    $apache =~ s!\\!/!g;
    return $apache;
}

sub check_win32_apache {
    my $apache = shift;
    my $vers = qx{"$apache" -v};
    return ($vers =~ m!Apache/1.3!) ? 1 : 0;
}

sub drives {
    my @drives = ();
    eval{require Win32API::File;};
    return map {"$_:\\"} ('C' .. 'Z') if $@;
    my @r = Win32API::File::getLogicalDrives();
    return unless @r > 0;
    for (@r) {
        my $t = Win32API::File::GetDriveType($_);
        push @drives, $_ if ($t == 3 or $t == 4);
    }
    return @drives > 0 ? @drives : undef;
}