Adjust some perl & tcl related things in various scripts & utilities.
[dragonfly.git] / lib / libc_r / test / verify
CommitLineData
52b73b16 1#!/usr/pkg/bin/perl -w
984263bc
MD
2#-*-mode:perl-*-
3#############################################################################
4#
5# Copyright (C) 1999-2001 Jason Evans <jasone@freebsd.org>.
6# All rights reserved.
7#
8# Redistribution and use in source and binary forms, with or without
9# modification, are permitted provided that the following conditions
10# are met:
11# 1. Redistributions of source code must retain the above copyright
12# notice(s), this list of conditions and the following disclaimer as
13# the first lines of this file unmodified other than the possible
14# addition of one or more copyright notices.
15# 2. Redistributions in binary form must reproduce the above copyright
16# notice(s), this list of conditions and the following disclaimer in
17# the documentation and/or other materials provided with the
18# distribution.
19#
20# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDER(S) ``AS IS'' AND ANY
21# EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
22# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
23# PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER(S) BE
24# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
25# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
26# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
27# BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
28# WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
29# OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
30# EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31#
32#############################################################################
33#
34# Test harness.
35#
36# $FreeBSD: src/lib/libc_r/test/verify,v 1.1.2.2 2001/06/22 21:44:27 jasone Exp $
1de703da 37# $DragonFly: src/lib/libc_r/test/verify,v 1.2 2003/06/17 04:26:48 dillon Exp $
984263bc
MD
38#
39#############################################################################
40
41# Shut off buffering.
42select(STDOUT);
43$| = 1;
44
45#
46# Parse command-line arguments.
47#
48use Getopt::Long;
49Getopt::Long::config("bundling"); # Allow -hv rather than forcing -h -v.
50
51# Set option defaults for optional arguments.
52$opt_help = 0;
53$opt_verbose = 0;
54$opt_quiet = 0;
55$opt_srcdir = ".";
56$opt_objdir = ".";
57$opt_ustats = 0;
58$opt_zero = 0;
59
60$opt_retval =
61&GetOptions("h|help" => \$opt_help,
62 "v|verbose" => \$opt_verbose,
63 "q|quiet" => \$opt_quiet,
64 "s|srcdir=s" => \$opt_srcdir,
65 "o|objdir=s" => \$opt_objdir,
66 "u|ustats" => \$opt_ustats,
67 "z|zero" => \$opt_zero
68 );
69
70if ($opt_help)
71{
72 &usage();
73 exit(0);
74}
75
76if ($opt_retval == 0)
77{
78 &usage();
79 exit 1;
80}
81
82if ($opt_verbose && $opt_quiet)
83{
84 print STDERR "-v and -q are incompatible\n";
85 &usage();
86 exit 1;
87}
88
89if ($#ARGV + 1 == 0)
90{
91 print STDERR "No tests specified\n";
92 &usage();
93 exit 1;
94}
95
96if ($opt_verbose)
97{
98 print STDERR "Option values: h:$opt_help, v:$opt_verbose, "
99 . "s:\"$opt_srcdir\", o:\"$opt_objdir\" "
100 . "q:$opt_quiet, u:$opt_ustats, z:$opt_zero\n";
101 printf STDERR "Tests (%d total): @ARGV\n", $#ARGV + 1;
102}
103
104#
105# Create and print header.
106#
107@TSTATS =
108(
109 "--------------------------------------------------------------------------\n",
110 "Test c_user c_system c_total chng\n",
111 " passed/FAILED h_user h_system h_total %% chng\n"
112 );
113
114if (!$opt_quiet)
115{
116 foreach $line (@TSTATS)
117 {
118 printf STDOUT "$line";
119 }
120}
121
122#
123# Run sequence test(s).
124#
125$total_utime = 0.0; # Total user time.
126$total_stime = 0.0; # Total system time.
127$total_hutime = 0.0; # Total historical user time.
128$total_hstime = 0.0; # Total historical system time.
129$total_ntime = 0.0; # Total time for tests that have historical data.
130
131foreach $test (@ARGV)
132{
133 # Strip out any whitespace in $test.
134 $test =~ s/^\s*(.*)\s*$/$1/;
135
136 $okay = 1;
137
138 if (-e "$opt_srcdir/$test.exp")
139 {
140 # Diff mode.
141
142 ($okay, $utime, $stime) = &run_test($test);
143
144 if (-e "$opt_objdir/$test.out")
145 {
146 `diff $opt_srcdir/$test.exp $opt_objdir/$test.out > $opt_objdir/$test.diff 2>&1`;
147 if ($?)
148 {
149 # diff returns non-zero if there is a difference.
150 $okay = 0;
151 }
152 }
153 else
154 {
155 $okay = 0;
156 if ($opt_verbose)
157 {
158 print STDERR
159 "Nonexistent output file \"$opt_objdir/$test.out\"\n";
160 }
161 }
162
163 ($hutime, $hstime) = &print_stats($test, $okay, 0, 0, $utime, $stime);
164 }
165 else
166 {
167 # Sequence mode.
168
169 ($okay, $utime, $stime) = &run_test($test);
170
171 if (open (STEST_OUT, "<$opt_objdir/$test.out"))
172 {
173 $num_subtests = 0;
174 $num_failed_subtests = 0;
175
176 while (defined($line = <STEST_OUT>))
177 {
178 if ($line =~ /1\.\.(\d+)/)
179 {
180 $num_subtests = $1;
181 last;
182 }
183 }
184 if ($num_subtests == 0)
185 {
186 $okay = 0;
187 if ($opt_verbose)
188 {
189 print STDERR "Malformed or missing 1..n line\n";
190 }
191 }
192 else
193 {
194 for ($subtest = 1; $subtest <= $num_subtests; $subtest++)
195 {
196 while (defined($line = <STEST_OUT>))
197 {
198 if ($line =~ /^not\s+ok\s+(\d+)?/)
199 {
200 $not = 1;
201 $test_num = $1;
202 last;
203 }
204 elsif ($line =~ /^ok\s+(\d+)?/)
205 {
206 $not = 0;
207 $test_num = $1;
208 last;
209 }
210 }
211 if (defined($line))
212 {
213 if (defined($test_num) && ($test_num != $subtest))
214 {
215 # There was no output printed for one or more tests.
216 for (; $subtest < $test_num; $subtest++)
217 {
218 $num_failed_subtests++;
219 }
220 }
221 if ($not)
222 {
223 $num_failed_subtests++;
224 }
225 }
226 else
227 {
228 for (; $subtest <= $num_subtests; $subtest++)
229 {
230 $num_failed_subtests++;
231 }
232 }
233 }
234
235 if (0 < $num_failed_subtests)
236 {
237 $okay = 0;
238 }
239 }
240 }
241 else
242 {
243 if (!$opt_quiet)
244 {
245 print STDERR "Cannot open output file \"$opt_objdir/$test.out\"\n";
246 }
247 exit 1;
248 }
249
250 ($hutime, $hstime) = &print_stats($test, $okay,
251 $num_failed_subtests, $num_subtests,
252 $utime, $stime);
253 }
254
255 $total_hutime += $hutime;
256 $total_hstime += $hstime;
257
258 if ($okay)
259 {
260 $total_utime += $utime;
261 $total_stime += $stime;
262 }
263 else
264 {
265 @FAILED_TESTS = (@FAILED_TESTS, $test);
266 }
267
268 # If there were historical data, add the run time to the total time to
269 # compare against the historical run time.
270 if (0 < ($hutime + $hstime))
271 {
272 $total_ntime += $utime + $stime;
273 }
274}
275
276# Print summary stats.
277$tt_str = sprintf ("%d / %d passed (%5.2f%%%%)",
278 ($#ARGV + 1) - ($#FAILED_TESTS + 1),
279 $#ARGV + 1,
280 (($#ARGV + 1) - ($#FAILED_TESTS + 1))
281 / ($#ARGV + 1) * 100);
282
283$t_str = sprintf ("Totals %7.2f %7.2f %7.2f"
284 . " %7.2f\n"
285 . " %s %7.2f %7.2f %7.2f %7.2f%%%%\n",
286 $total_utime, $total_stime, $total_utime + $total_stime,
287 ($total_ntime - ($total_hutime + $total_hstime)),
288 $tt_str . ' ' x (40 - length($tt_str)),
289 $total_hutime, $total_hstime, $total_hutime + $total_hstime,
290 ($total_hutime + $total_hstime == 0.0) ? 0.0 :
291 (($total_ntime
292 - ($total_hutime + $total_hstime))
293 / ($total_hutime + $total_hstime) * 100));
294
295@TSTATS = ("--------------------------------------------------------------------------\n",
296 $t_str,
297 "--------------------------------------------------------------------------\n"
298 );
299if (!$opt_quiet)
300{
301 foreach $line (@TSTATS)
302 {
303 printf STDOUT "$line";
304 }
305}
306
307if ($#FAILED_TESTS >= 0)
308{
309 # One or more tests failed, so return an error.
310 exit 1;
311}
312# End of main execution.
313
314sub run_test
315{
316 my ($test) = @_;
317 my ($okay) = 1;
318 my ($tutime, $tstime);
319 my ($utime, $stime, $cutime, $cstime);
320 my (@TSTATS, @TPATH);
321 my ($t_str);
322 my ($srcdir, $objdir);
323
324 # Get the path component of $test, if any.
325 @TPATH = split(/\//, $test);
326 pop(@TPATH);
327 $srcdir = join('/', ($opt_srcdir, @TPATH));
328 $objdir = join('/', ($opt_objdir, @TPATH));
329
330 @TSTATS = ("--------------------------------------------------------------------------\n");
331
332 $t_str = sprintf ("%s%s", $test, ' ' x (40 - length($test)));
333 @TSTATS = (@TSTATS, $t_str);
334 @STATS = (@STATS, @TSTATS);
335 if (!$opt_quiet)
336 {
337 foreach $line (@TSTATS)
338 {
339 printf STDOUT "$line";
340 }
341 }
342
343 ($utime, $stime, $cutime, $cstime) = times;
344 `$opt_objdir/$test $srcdir $objdir > $opt_objdir/$test.out 2>&1`;
345 ($utime, $stime, $tutime, $tstime) = times;
346
347 # Subtract the before time from the after time.
348 $tutime -= $cutime;
349 $tstime -= $cstime;
350
351 if ($opt_zero)
352 {
353 if ($?)
354 {
355 $okay = 0;
356 if ($opt_verbose)
357 {
358 print STDERR
359 "\"$opt_objdir/$test > $opt_objdir/$test.out 2>&1\" returned $?\n";
360 }
361 }
362 }
363
364 return ($okay, $tutime, $tstime);
365}
366
367sub print_stats
368{
369 my ($test, $okay, $failed_subtests, $subtests, $utime, $stime) = @_;
370 my ($hutime, $hstime);
371# my (TEST_PERF);
372 my (@TSTATS);
373 my ($t_str, $pass_str);
374
375 $pass_str = $okay ? "passed" : "*** FAILED ***";
376 if ((0 != $subtests) && (!$okay))
377 {
378 $pass_str = $pass_str . " ($failed_subtests/$subtests failed)";
379 }
380 $pass_str = $pass_str . ' ' x (39 - length($pass_str));
381
382 if (-r "$test.perf")
383 {
384 if (!open (TEST_PERF, "<$opt_objdir/$test.perf"))
385 {
386 print STDERR "Unable to open \"$opt_objdir/$test.perf\"\n";
387 exit 1;
388 }
389 $_ = <TEST_PERF>;
390
391 ($hutime, $hstime) = split;
392 close TEST_PERF;
393
394 $t_str = sprintf (" %7.2f %7.2f %7.2f %7.2f\n"
395 . " %s %7.2f %7.2f %7.2f %7.2f%%%%\n",
396 $utime, $stime, $utime + $stime,
397 ($utime + $stime) - ($hutime + $hstime),
398 $pass_str,
399 $hutime, $hstime, $hutime + $hstime,
400 (($hutime + $hstime) == 0.0) ? 0.0 :
401 ((($utime + $stime) - ($hutime + $hstime))
402 / ($hutime + $hstime) * 100));
403 }
404 else
405 {
406 $hutime = 0.0;
407 $hstime = 0.0;
408
409 $t_str = sprintf (" %7.2f %7.2f %7.2f \n"
410 . " %s\n",
411 $utime, $stime, $utime + $stime,
412 $pass_str);
413 }
414 @TSTATS = ($t_str);
415 if (!$opt_quiet)
416 {
417 foreach $line (@TSTATS)
418 {
419 printf STDOUT "$line";
420 }
421 }
422
423 if ($okay && $opt_ustats)
424 {
425 if (!open (TEST_PERF, ">$opt_objdir/$test.perf"))
426 {
427 if (!$opt_quiet)
428 {
429 print STDERR "Unable to update \"$opt_objdir/$test.perf\"\n";
430 }
431 }
432 else
433 {
434 print TEST_PERF "$utime $stime\n";
435 close TEST_PERF;
436 }
437 }
438
439 return ($hutime, $hstime);
440}
441
442sub usage
443{
444 print <<EOF;
445$0 usage:
446 $0 [<options>] <test>+
447
448 Option | Description
449 --------------+-------------------------------------------------------------
450 -h --help | Print usage and exit.
451 -v --verbose | Verbose (incompatible with quiet).
452 -q --quiet | Quiet (incompatible with verbose).
453 -s --srcdir | Path to source tree (default is ".").
454 -o --objdir | Path to object tree (default is ".").
455 -u --ustats | Update historical statistics (stored in "<test>.perf".
456 -z --zero | Consider non-zero exit code to be an error.
457 --------------+-------------------------------------------------------------
458
459 If <test>.exp exists, <test>'s output is diff'ed with <test>.exp. Any
460 difference is considered failure.
461
462 If <test>.exp does not exist, output to stdout of the following form is
463 expected:
464
465 1..<n>
466 {not }ok[ 1]
467 {not }ok[ 2]
468 ...
469 {not }ok[ n]
470
471 1 <= <n> < 2^31
472
473 Lines which do not match the patterns shown above are ignored.
474EOF
475}