| #!/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); |