Sweden-Number/tools/testrun

#!/usr/bin/perl
# Copyright 1996-1998 Marcus Meissner
# IPC remove code Copyright 1995 Michael Veksler
#
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Lesser General Public
# License as published by the Free Software Foundation; either
# version 2.1 of the License, or (at your option) any later version.
#
# This library is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# Lesser General Public License for more details.
#
# You should have received a copy of the GNU Lesser General Public
# License along with this library; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
# NOTES:
#
# This perl script automatically test runs ALL windows .exe and .scr binaries
# it finds (and can access) on your computer. It creates a subdirectory called
# runs/ and stores the output there. It also does (unique) diffs between runs.
#
# It only reruns the test if ChangeLog or the executeable is NEWER than the
# run file. (If you want to rerun everything inbetween releases, touch
# ChangeLog.)

#
# BEGIN OF USER CONFIGURATION
#
# Path to WINE executeable. If not specified, 'wine' is searched in the path.
#
$wine = 'wine';
#
# WINE options. -managed when using a windowmanager is probably not good in
# automatic testruns.
#
$wineoptions='';
#
# Path to WINE ChangeLog. Used as timestamp for new releases...
#
$changelog = '/home/marcus/wine/ChangeLog';
#
# How long before automatically killing all subprocesses
# 30 is good for automatic testing, 300 or more for interactive testing.
#
$waittime = 50;
#
#diff command
#
$diff='diff -u';
#
# truncate at how-much-lines
#
$trunclines=200;
#
$<||die "Running this script under UID 0 is a great security risk (and risk for existing windows installations on mounted DOS/W95 partitions). If you really want to, comment out this line.\n";
#
# END OF USER CONFIGURATION
#

if (! -d "runs") { die "no subdirectory runs/ found in $cwd. Please create one first!\n";}

# look for the exact path to wine executeable in case we need it for a
# replacement changelog.
if (! ($wine =~ /\//)) { # no path specified. Look it up.
	@paths = split(/:/,$ENV{'PATH'});
	foreach $path (@paths) {
		if (-e "$path/$wine" && -x "$path/$wine") {
			$wine = "$path/$wine";
			last;
		}
	}
}

# if we don't have a changelog use the modification date of the WINE executeable
if (! -e $changelog) {
	$changelog = $wine;
}

# sanity check so we just fill runs/ with errors.
(-x $wine)  || die "no $wine executable found!\n";
# dito. will print usage
system("$wine -h >/dev/null")||die "wine call failed:$!\n";

print "Using $wine as WINE executeable.\n";
print "Using $changelog as testrun timereference.\n";

chomp($cwd = `pwd`);

# Find out all present semaphores so we don't remove them later.
$IPC_RMID=0;
$USER=$ENV{'USER'};
open(IPCS,"ipcs|");
while(<IPCS>) {
    split;
    # try to find out the IPC-ID, assume it is the first number.
    foreach (@_) {
	$_ ne int($_) && next;	# not a decimal number
	$num=$_;
	last;
    }
    if (/sem/i .. /^\s*$/ ) {
	index($_,$USER)>=0 || next;
	$sem_used{$num}=1;
	print "found $num\n";
    }
}
close(IPCS);

sub kill_subprocesses {
	local($killedalready,%parentof,%kids,$changed,%cmdline);

	# FIXME: substitute ps command that shows PID,PPID and COMMAND
	# On Linux' latest procps this is "ps aulc"
	#
	open(PSAUX,"ps aulc|");
	# lookup all processes, remember their parents and cmdlines.
	%parentof=();
	$xline = <PSAUX>; # fmtline
	@psformat = split(/\s\s*/,$xline);

	psline: while (<PSAUX>) {
		chop;
		@psline = split(/\s\s*/);
		$pid=0;
		for ($i=0;$i<=$#psformat;$i++) {
			if ($psformat[$i] =~ /COMMAND/) {
				die unless $pid;
				$cmdline{$pid}=$psline[$i];
				break;
			}
			if ($psformat[$i] =~ /PPID/ ) {
				$parentof{$pid} = $psline[$i];
				next;
			}
			if ($psformat[$i] =~ /PID/ ) {
				$pid = $psline[$i];
				next;
			}
		}
	}
	close(PSAUX);

	# find out all kids of this perlscript
	%kids = ();
	$kids{$$} = 1;
	$changed = 1;
	while ($changed) {
		$changed = 0;
		foreach (keys %parentof) {
			next if ($kids{$_});
			if ($kids{$parentof{$_}}) {
				$changed = 1;
				$kids{$_}=1;
			}
		}
	}
	# .. but do not consider us for killing
	delete $kids{$$};
	# remove all processes killed in the meantime from %killedalready.
	foreach $pid (keys %killedalready) {
		delete $killedalready{$pid} if (!$kids{$pid} );
	}
	# kill all subprocesses called 'wine'. Do not kill find, diff, sh
	# and friends, which are also subprocesses of us.
	foreach (keys %kids) {
		next unless ($cmdline{$_} =~ /((.|)wine|dosmod)/);
		# if we have already killed it using -TERM, use -KILL
		if ($killedalready{$_}) {
			kill(9,$_);	# FIXME: use correct number?
		} else {
			kill(15,$_);	# FIXME: use correct number?
		}
		$killedalready{$_}=1;
	}
	alarm($waittime);		# wait again...
};

# borrowed from tools/ipcl. See comments there.
# killing wine subprocesses unluckily leaves all of their IPC stuff lying
# around. We have to wipe it or we run out of it.
sub cleanup_wine_ipc {
	open(IPCS,"ipcs|");
	while(<IPCS>) {
	    split;
	    # try to find out the IPC-ID, assume it is the first number.
	    foreach (@_) {
		$_ ne int($_) && next;	# not a decimal number
		$num=$_;
		last;
	    }
	    # was there before start of this script, skip it.
	    #
	    # FIXME: this doesn't work for programs started during the testrun.
	    #
	    if (/sem/i .. /^\s*$/ ) {
		index($_,$USER)>=0 || next;
		push(@sem,$num);
	    }
	}
	foreach (@sem) {
	    $sem_used{$_} && next;
	    semctl($_, 0, $IPC_RMID,0);
	}
	close(IPCS);
}

# kill all subwineprocesses for automatic runs.
sub alarmhandler {
	print "timer triggered.\n";
	&kill_subprocesses;
}

$SIG{'ALRM'} = "alarmhandler";

# NOTE: following find will also cross NFS mounts, so be sure to have nothing
# mounted that's not on campus or add relevant ! -fstype nfs or similar.
#

$startdir = '/';

$startdir = $ARGV[0] if ($ARGV[0] && (-d $ARGV[0]));

open(FIND,"find $startdir -type f  \\( -name \"*.EXE\" -o -name \"*.exe\" -o -name \"*.scr\" -o -name \"*.SCR\" \\) -print|");
while ($exe=<FIND>) {
	chop($exe);

	# This could change during a testrun (by doing 'make' for instance)
	# FIXME: doesn't handle missing libwine.so during compile...
	(-x $wine)  || die "no $wine executable found!\n";

	# Skip all mssetup, acmsetup , installshield whatever exes.
	# they seem to work, mostly and starting them is just annoying.
	next if ($exe =~ /acmsetup|unwise|testexit|_msset|isun|st4u|st5u|_mstest|_isdel|ms-setup|~ms|unin/io);

	$runfile = $exe;
	$runfile =~ s/[\/ ]/_/g;
	$runfile =~ s/\.exe$//g;
	$runfile =~ s/\.scr$//ig;
	$flag=0;
	#
	# Check if changelog is newer, if not, continue
	#
	if (	-e "runs/${runfile}.out" &&
		(-M $changelog > -M "runs/${runfile}.out") &&
		(-M $exe > -M "runs/${runfile}.out")
	) {
		#print "skipping $exe, already done.\n";
		next;
	}
	# now testrun...
	print "$exe:\n";
	$dir = $exe;
	$dir =~ s/^(.*)\/[^\/]*$/$1/; #cut of the basename.

	alarm($waittime);

	chdir($dir)||die "$dir:$!";
	if ($exe =~ /\.scr/i) {
		system("echo quit|$wine $wineoptions \"$exe /s\" >$cwd/${runfile}.out 2>&1");
	} else {
		system("echo quit|$wine $wineoptions \"$exe\" >$cwd/${runfile}.out 2>&1");
	}
	alarm(1000);# so it doesn't trigger in the diff, kill or find.

	system("touch $cwd/runs/${runfile}.out");
	system("$diff $cwd/runs/${runfile}.out $cwd/${runfile}.out|head -n $trunclines");
	system("head -n $trunclines $cwd/${runfile}.out >$cwd/runs/${runfile}.out");
	unlink("$cwd/${runfile}.out");
	&kill_subprocesses;
	&cleanup_wine_ipc;
	chdir($cwd);
}
close(FIND);