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