Use a linked list instead of a DPA for the hook list.
[wine] / 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);