261 lines
6.8 KiB
Perl
Executable File
261 lines
6.8 KiB
Perl
Executable File
#!/usr/bin/perl
|
|
# Copyright 1996-1998 Marcus Meissner
|
|
# IPC remove code Copyright 1995 Michael Veksler
|
|
#
|
|
# 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");
|
|
system("head -$trunclines $cwd/${runfile}.out >$cwd/runs/${runfile}.out");
|
|
unlink("$cwd/${runfile}.out");
|
|
&kill_subprocesses;
|
|
&cleanup_wine_ipc;
|
|
chdir($cwd);
|
|
}
|
|
close(FIND);
|