git.oblomov.eu Git - wine/blob - tools/testrun

   1 #!/usr/bin/perl
   2 # Copyright 1996-1998 Marcus Meissner
   3 # IPC remove code Copyright 1995 Michael Veksler
   4 #
   5 # This library is free software; you can redistribute it and/or
   6 # modify it under the terms of the GNU Lesser General Public
   7 # License as published by the Free Software Foundation; either
   8 # version 2.1 of the License, or (at your option) any later version.
   9 #
  10 # This library is distributed in the hope that it will be useful,
  11 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 # Lesser General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU Lesser General Public
  16 # License along with this library; if not, write to the Free Software
  17 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  18 #
  19 # NOTES:
  20 #
  21 # This perl script automatically test runs ALL windows .exe and .scr binaries
  22 # it finds (and can access) on your computer. It creates a subdirectory called
  23 # runs/ and stores the output there. It also does (unique) diffs between runs.
  24 #
  25 # It only reruns the test if ChangeLog or the executeable is NEWER than the
  26 # run file. (If you want to rerun everything inbetween releases, touch
  27 # ChangeLog.)
  28
  29 #
  30 # BEGIN OF USER CONFIGURATION
  31 #
  32 # Path to WINE executeable. If not specified, 'wine' is searched in the path.
  33 #
  34 $wine = 'wine';
  35 #
  36 # WINE options. -managed when using a windowmanager is probably not good in
  37 # automatic testruns.
  38 #
  39 $wineoptions='';
  40 #
  41 # Path to WINE ChangeLog. Used as timestamp for new releases...
  42 #
  43 $changelog = '/home/marcus/wine/ChangeLog';
  44 #
  45 # How long before automatically killing all subprocesses
  46 # 30 is good for automatic testing, 300 or more for interactive testing.
  47 #
  48 $waittime = 50;
  49 #
  50 #diff command
  51 #
  52 $diff='diff -u';
  53 #
  54 # truncate at how-much-lines
  55 #
  56 $trunclines=200;
  57 #
  58 $<||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";
  59 #
  60 # END OF USER CONFIGURATION
  61 #
  62
  63 if (! -d "runs") { die "no subdirectory runs/ found in $cwd. Please create one first!\n";}
  64
  65 # look for the exact path to wine executeable in case we need it for a
  66 # replacement changelog.
  67 if (! ($wine =~ /\//)) { # no path specified. Look it up.
  68         @paths = split(/:/,$ENV{'PATH'});
  69         foreach $path (@paths) {
  70                 if (-e "$path/$wine" && -x "$path/$wine") {
  71                         $wine = "$path/$wine";
  72                         last;
  73                 }
  74         }
  75 }
  76
  77 # if we don't have a changelog use the modification date of the WINE executeable
  78 if (! -e $changelog) {
  79         $changelog = $wine;
  80 }
  81
  82 # sanity check so we just fill runs/ with errors.
  83 (-x $wine)  || die "no $wine executable found!\n";
  84 # dito. will print usage
  85 system("$wine -h >/dev/null")||die "wine call failed:$!\n";
  86
  87 print "Using $wine as WINE executeable.\n";
  88 print "Using $changelog as testrun timereference.\n";
  89
  90 chomp($cwd = `pwd`);
  91
  92 # Find out all present semaphores so we don't remove them later.
  93 $IPC_RMID=0;
  94 $USER=$ENV{'USER'};
  95 open(IPCS,"ipcs|");
  96 while(<IPCS>) {
  97     split;
  98     # try to find out the IPC-ID, assume it is the first number.
  99     foreach (@_) {
 100         $_ ne int($_) && next;  # not a decimal number
 101         $num=$_;
 102         last;
 103     }
 104     if (/sem/i .. /^\s*$/ ) {
 105         index($_,$USER)>=0 || next;
 106         $sem_used{$num}=1;
 107         print "found $num\n";
 108     }
 109 }
 110 close(IPCS);
 111
 112 sub kill_subprocesses {
 113         local($killedalready,%parentof,%kids,$changed,%cmdline);
 114
 115         # FIXME: substitute ps command that shows PID,PPID and COMMAND
 116         # On Linux' latest procps this is "ps aulc"
 117         #
 118         open(PSAUX,"ps aulc|");
 119         # lookup all processes, remember their parents and cmdlines.
 120         %parentof=();
 121         $xline = <PSAUX>; # fmtline
 122         @psformat = split(/\s\s*/,$xline);
 123
 124         psline: while (<PSAUX>) {
 125                 chop;
 126                 @psline = split(/\s\s*/);
 127                 $pid=0;
 128                 for ($i=0;$i<=$#psformat;$i++) {
 129                         if ($psformat[$i] =~ /COMMAND/) {
 130                                 die unless $pid;
 131                                 $cmdline{$pid}=$psline[$i];
 132                                 break;
 133                         }
 134                         if ($psformat[$i] =~ /PPID/ ) {
 135                                 $parentof{$pid} = $psline[$i];
 136                                 next;
 137                         }
 138                         if ($psformat[$i] =~ /PID/ ) {
 139                                 $pid = $psline[$i];
 140                                 next;
 141                         }
 142                 }
 143         }
 144         close(PSAUX);
 145
 146         # find out all kids of this perlscript
 147         %kids = ();
 148         $kids{$$} = 1;
 149         $changed = 1;
 150         while ($changed) {
 151                 $changed = 0;
 152                 foreach (keys %parentof) {
 153                         next if ($kids{$_});
 154                         if ($kids{$parentof{$_}}) {
 155                                 $changed = 1;
 156                                 $kids{$_}=1;
 157                         }
 158                 }
 159         }
 160         # .. but do not consider us for killing
 161         delete $kids{$$};
 162         # remove all processes killed in the meantime from %killedalready.
 163         foreach $pid (keys %killedalready) {
 164                 delete $killedalready{$pid} if (!$kids{$pid} );
 165         }
 166         # kill all subprocesses called 'wine'. Do not kill find, diff, sh
 167         # and friends, which are also subprocesses of us.
 168         foreach (keys %kids) {
 169                 next unless ($cmdline{$_} =~ /((.|)wine|dosmod)/);
 170                 # if we have already killed it using -TERM, use -KILL
 171                 if ($killedalready{$_}) {
 172                         kill(9,$_);     # FIXME: use correct number?
 173                 } else {
 174                         kill(15,$_);    # FIXME: use correct number?
 175                 }
 176                 $killedalready{$_}=1;
 177         }
 178         alarm($waittime);               # wait again...
 179 };
 180
 181 # borrowed from tools/ipcl. See comments there.
 182 # killing wine subprocesses unluckily leaves all of their IPC stuff lying
 183 # around. We have to wipe it or we run out of it.
 184 sub cleanup_wine_ipc {
 185         open(IPCS,"ipcs|");
 186         while(<IPCS>) {
 187             split;
 188             # try to find out the IPC-ID, assume it is the first number.
 189             foreach (@_) {
 190                 $_ ne int($_) && next;  # not a decimal number
 191                 $num=$_;
 192                 last;
 193             }
 194             # was there before start of this script, skip it.
 195             #
 196             # FIXME: this doesn't work for programs started during the testrun.
 197             #
 198             if (/sem/i .. /^\s*$/ ) {
 199                 index($_,$USER)>=0 || next;
 200                 push(@sem,$num);
 201             }
 202         }
 203         foreach (@sem) {
 204             $sem_used{$_} && next;
 205             semctl($_, 0, $IPC_RMID,0);
 206         }
 207         close(IPCS);
 208 }
 209
 210 # kill all subwineprocesses for automatic runs.
 211 sub alarmhandler {
 212         print "timer triggered.\n";
 213         &kill_subprocesses;
 214 }
 215
 216 $SIG{'ALRM'} = "alarmhandler";
 217
 218 # NOTE: following find will also cross NFS mounts, so be sure to have nothing
 219 # mounted that's not on campus or add relevant ! -fstype nfs or similar.
 220 #
 221
 222 $startdir = '/';
 223
 224 $startdir = $ARGV[0] if ($ARGV[0] && (-d $ARGV[0]));
 225
 226 open(FIND,"find $startdir -type f  \\( -name \"*.EXE\" -o -name \"*.exe\" -o -name \"*.scr\" -o -name \"*.SCR\" \\) -print|");
 227 while ($exe=<FIND>) {
 228         chop($exe);
 229
 230         # This could change during a testrun (by doing 'make' for instance)
 231         # FIXME: doesn't handle missing libwine.so during compile...
 232         (-x $wine)  || die "no $wine executable found!\n";
 233
 234         # Skip all mssetup, acmsetup , installshield whatever exes.
 235         # they seem to work, mostly and starting them is just annoying.
 236         next if ($exe =~ /acmsetup|unwise|testexit|_msset|isun|st4u|st5u|_mstest|_isdel|ms-setup|~ms|unin/io);
 237
 238         $runfile = $exe;
 239         $runfile =~ s/[\/ ]/_/g;
 240         $runfile =~ s/\.exe$//g;
 241         $runfile =~ s/\.scr$//ig;
 242         $flag=0;
 243         #
 244         # Check if changelog is newer, if not, continue
 245         #
 246         if (    -e "runs/${runfile}.out" &&
 247                 (-M $changelog > -M "runs/${runfile}.out") &&
 248                 (-M $exe > -M "runs/${runfile}.out")
 249         ) {
 250                 #print "skipping $exe, already done.\n";
 251                 next;
 252         }
 253         # now testrun...
 254         print "$exe:\n";
 255         $dir = $exe;
 256         $dir =~ s/^(.*)\/[^\/]*$/$1/; #cut of the basename.
 257
 258         alarm($waittime);
 259
 260         chdir($dir)||die "$dir:$!";
 261         if ($exe =~ /\.scr/i) {
 262                 system("echo quit|$wine $wineoptions \"$exe /s\" >$cwd/${runfile}.out 2>&1");
 263         } else {
 264                 system("echo quit|$wine $wineoptions \"$exe\" >$cwd/${runfile}.out 2>&1");
 265         }
 266         alarm(1000);# so it doesn't trigger in the diff, kill or find.
 267
 268         system("touch $cwd/runs/${runfile}.out");
 269         system("$diff $cwd/runs/${runfile}.out $cwd/${runfile}.out|head -$trunclines");
 270         system("head -$trunclines $cwd/${runfile}.out >$cwd/runs/${runfile}.out");
 271         unlink("$cwd/${runfile}.out");
 272         &kill_subprocesses;
 273         &cleanup_wine_ipc;
 274         chdir($cwd);
 275 }
 276 close(FIND);