Added varargs support for 16-bit entry points.
[wine] / 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);