1# $MirOS: src/bin/mksh/check.pl,v 1.27 2011/05/29 02:18:47 tg Exp $
2# $OpenBSD: th,v 1.13 2006/05/18 21:27:23 miod Exp $
3#-
4# Copyright (c) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2011
5#	Thorsten Glaser <tg@mirbsd.org>
6#
7# Provided that these terms and disclaimer and all copyright notices
8# are retained or reproduced in an accompanying document, permission
9# is granted to deal in this work without restriction, including un-
10# limited rights to use, publicly perform, distribute, sell, modify,
11# merge, give away, or sublicence.
12#
13# This work is provided "AS IS" and WITHOUT WARRANTY of any kind, to
14# the utmost extent permitted by applicable law, neither express nor
15# implied; without malicious intent or gross negligence. In no event
16# may a licensor, author or contributor be held liable for indirect,
17# direct, other damage, loss, or other issues arising in any way out
18# of dealing in the work, even if advised of the possibility of such
19# damage or existence of a defect, except proven that it results out
20# of said person's immediate fault when using the work as intended.
21#-
22# Example test:
23#		name: a-test
24#		description:
25#			a test to show how tests are done
26#		arguments: !-x!-f!
27#		stdin:
28#			echo -n *
29#			false
30#		expected-stdout: !
31#			*
32#		expected-stderr:
33#			+ echo -n *
34#			+ false
35#		expected-exit: 1
36#		---
37#	This runs the test-program (eg, mksh) with the arguments -x and -f,
38#	standard input is a file containing "echo hi*\nfalse\n". The program
39#	is expected to produce "hi*" (no trailing newline) on standard output,
40#	"+ echo hi*\n+false\n" on standard error, and an exit code of 1.
41#
42#
43# Format of test files:
44# - blank lines and lines starting with # are ignored
45# - a test file contains a series of tests
46# - a test is a series of tag:value pairs ended with a "---" line
47#   (leading/trailing spaces are stripped from the first line of value)
48# - test tags are:
49#	Tag			Flag	Description
50#	-----			----	-----------
51#	name			r	The name of the test; should be unique
52#	description		m	What test does
53#	arguments		M	Arguments to pass to the program;
54#					default is no arguments.
55#	script			m	Value is written to a file which
56#					is passed as an argument to the program
57#					(after the arguments arguments)
58#	stdin			m	Value is written to a file which is
59#					used as standard-input for the program;
60#					default is to use /dev/null.
61#	perl-setup		m	Value is a perl script which is executed
62#					just before the test is run. Try to
63#					avoid using this...
64#	perl-cleanup		m	Value is a perl script which is executed
65#					just after the test is run. Try to
66#					avoid using this...
67#	env-setup		M	Value is a list of NAME=VALUE elements
68#					which are put in the environment before
69#					the test is run. If the =VALUE is
70#					missing, NAME is removed from the
71#					environment. Programs are run with
72#					the following minimal environment:
73#					    HOME, LD_LIBRARY_PATH, LOCPATH,
74#					    LOGNAME, PATH, SHELL, UNIXMODE,
75#					    USER
76#					(values taken from the environment of
77#					the test harness).
78#					ENV is set to /nonexistant.
79#					__progname is set to the -p argument.
80#					__perlname is set to $^X (perlexe).
81#	file-setup		mps	Used to create files, directories
82#					and symlinks. First word is either
83#					file, dir or symlink; second word is
84#					permissions; this is followed by a
85#					quoted word that is the name of the
86#					file; the end-quote should be followed
87#					by a newline, then the file data
88#					(if any). The first word may be
89#					preceded by a ! to strip the trailing
90#					newline in a symlink.
91#	file-result		mps	Used to verify a file, symlink or
92#					directory is created correctly.
93#					The first word is either
94#					file, dir or symlink; second word is
95#					expected permissions; third word
96#					is user-id; fourth is group-id;
97#					fifth is "exact" or "pattern"
98#					indicating whether the file contents
99#					which follow is to be matched exactly
100#					or if it is a regular expression.
101#					The fifth argument is the quoted name
102#					of the file that should be created.
103#					The end-quote should be followed
104#					by a newline, then the file data
105#					(if any). The first word may be
106#					preceded by a ! to strip the trailing
107#					newline in the file contents.
108#					The permissions, user and group fields
109#					may be * meaning accept any value.
110#	time-limit			Time limit - the program is sent a
111#					SIGKILL N seconds. Default is no
112#					limit.
113#	expected-fail			'yes' if the test is expected to fail.
114#	expected-exit			expected exit code. Can be a number,
115#					or a C expression using the variables
116#					e, s and w (exit code, termination
117#					signal, and status code).
118#	expected-stdout		m	What the test should generate on stdout;
119#					default is to expect no output.
120#	expected-stdout-pattern	m	A perl pattern which matches the
121#					expected output.
122#	expected-stderr		m	What the test should generate on stderr;
123#					default is to expect no output.
124#	expected-stderr-pattern	m	A perl pattern which matches the
125#					expected standard error.
126#	category		m	Specify a comma separated list of
127#					'categories' of program that the test
128#					is to be run for. A category can be
129#					negated by prefixing the name with a !.
130#					The idea is that some tests in a
131#					test suite may apply to a particular
132#					program version and shouldn't be run
133#					on other versions. The category(s) of
134#					the program being tested can be
135#					specified on the command line.
136#					One category os:XXX is predefined
137#					(XXX is the operating system name,
138#					eg, linux, dec_osf).
139#	need-ctty			'yes' if the test needs a ctty, run
140#					with -C regress:no-ctty to disable.
141# Flag meanings:
142#	r	tag is required (eg, a test must have a name tag).
143#	m	value can be multiple lines. Lines must be prefixed with
144#		a tab. If the value part of the initial tag:value line is
145#			- empty: the initial blank line is stripped.
146#			- a lone !: the last newline in the value is stripped;
147#	M	value can be multiple lines (prefixed by a tab) and consists
148#		of multiple fields, delimited by a field separator character.
149#		The value must start and end with the f-s-c.
150#	p	tag takes parameters (used with m).
151#	s	tag can be used several times.
152
153use POSIX qw(EINTR);
154use Getopt::Std;
155use Config;
156
157$os = defined $^O ? $^O : 'unknown';
158
159($prog = $0) =~ s#.*/##;
160
161$Usage = <<EOF ;
162Usage: $prog [-Pv] [-C cat] [-e e=v] [-p prog] [-s fn] [-t tmo] name ...
163	-C c	Specify the comma separated list of categories the program
164		belongs to (see category field).
165	-e e=v	Set the environment variable e to v for all tests
166		(if no =v is given, the current value is used)
167		Only one -e option can be given at the moment, sadly.
168	-P	program (-p) string has multiple words, and the program is in
169		the path (kludge option)
170	-p p	Use p as the program to test
171	-s s	Read tests from file s; if s is a directory, it is recursively
172		scaned for test files (which end in .t).
173	-t t	Use t as default time limit for tests (default is unlimited)
174	-v	Verbose mode: print reason test failed.
175	name	specifies the name of the test(s) to run; if none are
176		specified, all tests are run.
177EOF
178
179# See comment above for flag meanings
180%test_fields = (
181	'name',				'r',
182	'description',			'm',
183	'arguments',			'M',
184	'script',			'm',
185	'stdin',			'm',
186	'perl-setup',			'm',
187	'perl-cleanup',			'm',
188	'env-setup',			'M',
189	'file-setup',			'mps',
190	'file-result',			'mps',
191	'time-limit',			'',
192	'expected-fail',		'',
193	'expected-exit',		'',
194	'expected-stdout',		'm',
195	'expected-stdout-pattern',	'm',
196	'expected-stderr',		'm',
197	'expected-stderr-pattern',	'm',
198	'category',			'm',
199	'need-ctty',			'',
200	'need-pass',			'',
201	);
202# Filled in by read_test()
203%internal_test_fields = (
204	':full-name', 1,		# file:name
205	':long-name', 1,		# dir/file:lineno:name
206	);
207
208# Categories of the program under test. Provide the current
209# os by default.
210%categories = (
211	"os:$os", '1'
212	);
213
214$temps = "/tmp/rts$$";
215$tempi = "/tmp/rti$$";
216$tempo = "/tmp/rto$$";
217$tempe = "/tmp/rte$$";
218$tempdir = "/tmp/rtd$$";
219
220$nfailed = 0;
221$nifailed = 0;
222$nxfailed = 0;
223$npassed = 0;
224$nxpassed = 0;
225
226%known_tests = ();
227
228if (!getopts('C:e:Pp:s:t:v')) {
229    print STDERR $Usage;
230    exit 1;
231}
232
233die "$prog: no program specified (use -p)\n" if !defined $opt_p;
234die "$prog: no test set specified (use -s)\n" if !defined $opt_s;
235$test_prog = $opt_p;
236$verbose = defined $opt_v && $opt_v;
237$test_set = $opt_s;
238if (defined $opt_t) {
239    die "$prog: bad -t argument (should be number > 0): $opt_t\n"
240	if $opt_t !~ /^\d+$/ || $opt_t <= 0;
241    $default_time_limit = $opt_t;
242}
243$program_kludge = defined $opt_P ? $opt_P : 0;
244
245if (defined $opt_C) {
246    foreach $c (split(',', $opt_C)) {
247	$c =~ s/\s+//;
248	die "$prog: categories can't be negated on the command line\n"
249	    if ($c =~ /^!/);
250	$categories{$c} = 1;
251    }
252}
253
254# Note which tests are to be run.
255%do_test = ();
256grep($do_test{$_} = 1, @ARGV);
257$all_tests = @ARGV == 0;
258
259# Set up a very minimal environment
260%new_env = ();
261foreach $env (('HOME', 'LD_LIBRARY_PATH', 'LOCPATH', 'LOGNAME',
262  'PATH', 'SHELL', 'UNIXMODE', 'USER')) {
263    $new_env{$env} = $ENV{$env} if defined $ENV{$env};
264}
265$new_env{'ENV'} = '/nonexistant';
266if (($os eq 'VMS') || ($Config{perlpath} =~ m/$Config{_exe}$/i)) {
267	$new_env{'__perlname'} = $Config{perlpath};
268} else {
269	$new_env{'__perlname'} = $Config{perlpath} . $Config{_exe};
270}
271if (defined $opt_e) {
272    # XXX need a way to allow many -e arguments...
273    if ($opt_e =~ /^([a-zA-Z_]\w*)(|=(.*))$/) {
274	$new_env{$1} = $2 eq '' ? $ENV{$1} : $3;
275    } else {
276	die "$0: bad -e argument: $opt_e\n";
277    }
278}
279%old_env = %ENV;
280
281die "$prog: couldn't make directory $tempdir - $!\n" if !mkdir($tempdir, 0777);
282
283chop($pwd = `pwd 2>/dev/null`);
284die "$prog: couldn't get current working directory\n" if $pwd eq '';
285die "$prog: couldn't cd to $pwd - $!\n" if !chdir($pwd);
286
287if (!$program_kludge) {
288    $test_prog = "$pwd/$test_prog" if substr($test_prog, 0, 1) ne '/';
289    die "$prog: $test_prog is not executable - bye\n"
290	if (! -x $test_prog && $os ne 'os2');
291}
292
293@trap_sigs = ('TERM', 'QUIT', 'INT', 'PIPE', 'HUP');
294@SIG{@trap_sigs} = ('cleanup_exit') x @trap_sigs;
295$child_kill_ok = 0;
296$SIG{'ALRM'} = 'catch_sigalrm';
297
298$| = 1;
299
300if (-d $test_set) {
301    $file_prefix_skip = length($test_set) + 1;
302    $ret = &process_test_dir($test_set);
303} else {
304    $file_prefix_skip = 0;
305    $ret = &process_test_file($test_set);
306}
307&cleanup_exit() if !defined $ret;
308
309$tot_failed = $nfailed + $nifailed + $nxfailed;
310$tot_passed = $npassed + $nxpassed;
311if ($tot_failed || $tot_passed) {
312    print "Total failed: $tot_failed";
313    print " ($nifailed ignored)" if $nifailed;
314    print " ($nxfailed unexpected)" if $nxfailed;
315    print " (as expected)" if $nfailed && !$nxfailed && !$nifailed;
316    print "\nTotal passed: $tot_passed";
317    print " ($nxpassed unexpected)" if $nxpassed;
318    print "\n";
319}
320
321&cleanup_exit('ok');
322
323sub
324cleanup_exit
325{
326    local($sig, $exitcode) = ('', 1);
327
328    if ($_[0] eq 'ok') {
329	unless ($nxfailed) {
330		$exitcode = 0;
331	} else {
332		$exitcode = 1;
333	}
334    } elsif ($_[0] ne '') {
335	$sig = $_[0];
336    }
337
338    unlink($tempi, $tempo, $tempe, $temps);
339    &scrub_dir($tempdir) if defined $tempdir;
340    rmdir($tempdir) if defined $tempdir;
341
342    if ($sig) {
343	$SIG{$sig} = 'DEFAULT';
344	kill $sig, $$;
345	return;
346    }
347    exit $exitcode;
348}
349
350sub
351catch_sigalrm
352{
353    $SIG{'ALRM'} = 'catch_sigalrm';
354    kill(9, $child_pid) if $child_kill_ok;
355    $child_killed = 1;
356}
357
358sub
359process_test_dir
360{
361    local($dir) = @_;
362    local($ret, $file);
363    local(@todo) = ();
364
365    if (!opendir(DIR, $dir)) {
366	print STDERR "$prog: can't open directory $dir - $!\n";
367	return undef;
368    }
369    while (defined ($file = readdir(DIR))) {
370	push(@todo, $file) if $file =~ /^[^.].*\.t$/;
371    }
372    closedir(DIR);
373
374    foreach $file (@todo) {
375	$file = "$dir/$file";
376	if (-d $file) {
377	    $ret = &process_test_dir($file);
378	} elsif (-f _) {
379	    $ret = &process_test_file($file);
380	}
381	last if !defined $ret;
382    }
383
384    return $ret;
385}
386
387sub
388process_test_file
389{
390    local($file) = @_;
391    local($ret);
392
393    if (!open(IN, $file)) {
394	print STDERR "$prog: can't open $file - $!\n";
395	return undef;
396    }
397    binmode(IN);
398    while (1) {
399	$ret = &read_test($file, IN, *test);
400	last if !defined $ret || !$ret;
401	next if !$all_tests && !$do_test{$test{'name'}};
402	next if !&category_check(*test);
403	$ret = &run_test(*test);
404	last if !defined $ret;
405    }
406    close(IN);
407
408    return $ret;
409}
410
411sub
412run_test
413{
414    local(*test) = @_;
415    local($name) = $test{':full-name'};
416
417    if (defined $test{'stdin'}) {
418	return undef if !&write_file($tempi, $test{'stdin'});
419	$ifile = $tempi;
420    } else {
421	$ifile = '/dev/null';
422    }
423
424    if (defined $test{'script'}) {
425	return undef if !&write_file($temps, $test{'script'});
426    }
427
428    return undef if !&scrub_dir($tempdir);
429
430    if (!chdir($tempdir)) {
431	print STDERR "$prog: couldn't cd to $tempdir - $!\n";
432	return undef;
433    }
434
435    if (defined $test{'file-setup'}) {
436	local($i);
437	local($type, $perm, $rest, $c, $len, $name);
438
439	for ($i = 0; $i < $test{'file-setup'}; $i++) {
440	    $val = $test{"file-setup:$i"};
441
442	    # format is: type perm "name"
443	    ($type, $perm, $rest) =
444		split(' ', $val, 3);
445	    $c = substr($rest, 0, 1);
446	    $len = index($rest, $c, 1) - 1;
447	    $name = substr($rest, 1, $len);
448	    $rest = substr($rest, 2 + $len);
449	    $perm = oct($perm) if $perm =~ /^\d+$/;
450	    if ($type eq 'file') {
451		return undef if !&write_file($name, $rest);
452		if (!chmod($perm, $name)) {
453		    print STDERR
454		  "$prog:$test{':long-name'}: can't chmod $perm $name - $!\n";
455		    return undef;
456		}
457	    } elsif ($type eq 'dir') {
458		if (!mkdir($name, $perm)) {
459		    print STDERR
460		  "$prog:$test{':long-name'}: can't mkdir $perm $name - $!\n";
461		    return undef;
462		}
463	    } elsif ($type eq 'symlink') {
464		local($oumask) = umask($perm);
465		local($ret) = symlink($rest, $name);
466		umask($oumask);
467		if (!$ret) {
468		    print STDERR
469	    "$prog:$test{':long-name'}: couldn't create symlink $name - $!\n";
470		    return undef;
471		}
472	    }
473	}
474    }
475
476    if (defined $test{'perl-setup'}) {
477	eval $test{'perl-setup'};
478	if ($@ ne '') {
479	    print STDERR "$prog:$test{':long-name'}: error running perl-setup - $@\n";
480	    return undef;
481	}
482    }
483
484    $pid = fork;
485    if (!defined $pid) {
486	print STDERR "$prog: can't fork - $!\n";
487	return undef;
488    }
489    if (!$pid) {
490	@SIG{@trap_sigs} = ('DEFAULT') x @trap_sigs;
491	$SIG{'ALRM'} = 'DEFAULT';
492	if (defined $test{'env-setup'}) {
493	    local($var, $val, $i);
494
495	    foreach $var (split(substr($test{'env-setup'}, 0, 1),
496		$test{'env-setup'}))
497	    {
498		$i = index($var, '=');
499		next if $i == 0 || $var eq '';
500		if ($i < 0) {
501		    delete $new_env{$var};
502		} else {
503		    $new_env{substr($var, 0, $i)} = substr($var, $i + 1);
504		}
505	    }
506	}
507	if (!open(STDIN, "< $ifile")) {
508		print STDERR "$prog: couldn't open $ifile in child - $!\n";
509		kill('TERM', $$);
510	}
511	binmode(STDIN);
512	if (!open(STDOUT, "> $tempo")) {
513		print STDERR "$prog: couldn't open $tempo in child - $!\n";
514		kill('TERM', $$);
515	}
516	binmode(STDOUT);
517	if (!open(STDERR, "> $tempe")) {
518		print STDOUT "$prog: couldn't open $tempe in child - $!\n";
519		kill('TERM', $$);
520	}
521	binmode(STDERR);
522	if ($program_kludge) {
523	    @argv = split(' ', $test_prog);
524	} else {
525	    @argv = ($test_prog);
526	}
527	if (defined $test{'arguments'}) {
528		push(@argv,
529		     split(substr($test{'arguments'}, 0, 1),
530			   substr($test{'arguments'}, 1)));
531	}
532	push(@argv, $temps) if defined $test{'script'};
533
534	#XXX realpathise, use which/whence -p, or sth. like that
535	#XXX if !$program_kludge, we get by with not doing it for now tho
536	$new_env{'__progname'} = $argv[0];
537
538	# The following doesn't work with perl5...  Need to do it explicitly - yuck.
539	#%ENV = %new_env;
540	foreach $k (keys(%ENV)) {
541	    delete $ENV{$k};
542	}
543	$ENV{$k} = $v while ($k,$v) = each %new_env;
544
545	exec { $argv[0] } @argv;
546	print STDERR "$prog: couldn't execute $test_prog - $!\n";
547	kill('TERM', $$);
548	exit(95);
549    }
550    $child_pid = $pid;
551    $child_killed = 0;
552    $child_kill_ok = 1;
553    alarm($test{'time-limit'}) if defined $test{'time-limit'};
554    while (1) {
555	$xpid = waitpid($pid, 0);
556	$child_kill_ok = 0;
557	if ($xpid < 0) {
558	    next if $! == EINTR;
559	    print STDERR "$prog: error waiting for child - $!\n";
560	    return undef;
561	}
562	last;
563    }
564    $status = $?;
565    alarm(0) if defined $test{'time-limit'};
566
567    $failed = 0;
568    $why = '';
569
570    if ($child_killed) {
571	$failed = 1;
572	$why .= "\ttest timed out (limit of $test{'time-limit'} seconds)\n";
573    }
574
575    $ret = &eval_exit($test{'long-name'}, $status, $test{'expected-exit'});
576    return undef if !defined $ret;
577    if (!$ret) {
578	local($expl);
579
580	$failed = 1;
581	if (($status & 0xff) == 0x7f) {
582	    $expl = "stopped";
583	} elsif (($status & 0xff)) {
584	    $expl = "signal " . ($status & 0x7f);
585	} else {
586	    $expl = "exit-code " . (($status >> 8) & 0xff);
587	}
588	$why .=
589	"\tunexpected exit status $status ($expl), expected $test{'expected-exit'}\n";
590    }
591
592    $tmp = &check_output($test{'long-name'}, $tempo, 'stdout',
593		$test{'expected-stdout'}, $test{'expected-stdout-pattern'});
594    return undef if !defined $tmp;
595    if ($tmp ne '') {
596	$failed = 1;
597	$why .= $tmp;
598    }
599
600    $tmp = &check_output($test{'long-name'}, $tempe, 'stderr',
601		$test{'expected-stderr'}, $test{'expected-stderr-pattern'});
602    return undef if !defined $tmp;
603    if ($tmp ne '') {
604	$failed = 1;
605	$why .= $tmp;
606    }
607
608    $tmp = &check_file_result(*test);
609    return undef if !defined $tmp;
610    if ($tmp ne '') {
611	$failed = 1;
612	$why .= $tmp;
613    }
614
615    if (defined $test{'perl-cleanup'}) {
616	eval $test{'perl-cleanup'};
617	if ($@ ne '') {
618	    print STDERR "$prog:$test{':long-name'}: error running perl-cleanup - $@\n";
619	    return undef;
620	}
621    }
622
623    if (!chdir($pwd)) {
624	print STDERR "$prog: couldn't cd to $pwd - $!\n";
625	return undef;
626    }
627
628    if ($failed) {
629	if (!$test{'expected-fail'}) {
630	    if ($test{'need-pass'}) {
631		print "FAIL $name\n";
632		$nxfailed++;
633	    } else {
634		print "FAIL $name (ignored)\n";
635		$nifailed++;
636	    }
637	} else {
638	    print "fail $name (as expected)\n";
639	    $nfailed++;
640	}
641	$why = "\tDescription"
642		. &wrap_lines($test{'description'}, " (missing)\n")
643		. $why;
644    } elsif ($test{'expected-fail'}) {
645	print "PASS $name (unexpectedly)\n";
646	$nxpassed++;
647    } else {
648	print "pass $name\n";
649	$npassed++;
650    }
651    print $why if $verbose;
652    return 0;
653}
654
655sub
656category_check
657{
658    local(*test) = @_;
659    local($c);
660
661    return 0 if ($test{'need-ctty'} && defined $categories{'regress:no-ctty'});
662    return 1 if (!defined $test{'category'});
663    local($ok) = 0;
664    foreach $c (split(',', $test{'category'})) {
665	$c =~ s/\s+//;
666	if ($c =~ /^!/) {
667	    $c = $';
668	    return 0 if (defined $categories{$c});
669	    $ok = 1;
670	} else {
671	    $ok = 1 if (defined $categories{$c});
672	}
673    }
674    return $ok;
675}
676
677sub
678scrub_dir
679{
680    local($dir) = @_;
681    local(@todo) = ();
682    local($file);
683
684    if (!opendir(DIR, $dir)) {
685	print STDERR "$prog: couldn't open directory $dir - $!\n";
686	return undef;
687    }
688    while (defined ($file = readdir(DIR))) {
689	push(@todo, $file) if $file ne '.' && $file ne '..';
690    }
691    closedir(DIR);
692    foreach $file (@todo) {
693	$file = "$dir/$file";
694	if (-d $file) {
695	    return undef if !&scrub_dir($file);
696	    if (!rmdir($file)) {
697		print STDERR "$prog: couldn't rmdir $file - $!\n";
698		return undef;
699	    }
700	} else {
701	    if (!unlink($file)) {
702		print STDERR "$prog: couldn't unlink $file - $!\n";
703		return undef;
704	    }
705	}
706    }
707    return 1;
708}
709
710sub
711write_file
712{
713    local($file, $str) = @_;
714
715    if (!open(TEMP, "> $file")) {
716	print STDERR "$prog: can't open $file - $!\n";
717	return undef;
718    }
719    binmode(TEMP);
720    print TEMP $str;
721    if (!close(TEMP)) {
722	print STDERR "$prog: error writing $file - $!\n";
723	return undef;
724    }
725    return 1;
726}
727
728sub
729check_output
730{
731    local($name, $file, $what, $expect, $expect_pat) = @_;
732    local($got) = '';
733    local($why) = '';
734    local($ret);
735
736    if (!open(TEMP, "< $file")) {
737	print STDERR "$prog:$name($what): couldn't open $file after running program - $!\n";
738	return undef;
739    }
740    binmode(TEMP);
741    while (<TEMP>) {
742	$got .= $_;
743    }
744    close(TEMP);
745    return compare_output($name, $what, $expect, $expect_pat, $got);
746}
747
748sub
749compare_output
750{
751    local($name, $what, $expect, $expect_pat, $got) = @_;
752    local($why) = '';
753
754    if (defined $expect_pat) {
755	$_ = $got;
756	$ret = eval "$expect_pat";
757	if ($@ ne '') {
758	    print STDERR "$prog:$name($what): error evaluating $what pattern: $expect_pat - $@\n";
759	    return undef;
760	}
761	if (!$ret) {
762	    $why = "\tunexpected $what - wanted pattern";
763	    $why .= &wrap_lines($expect_pat);
764	    $why .= "\tgot";
765	    $why .= &wrap_lines($got);
766	}
767    } else {
768	$expect = '' if !defined $expect;
769	if ($got ne $expect) {
770	    $why .= "\tunexpected $what - " . &first_diff($expect, $got) . "\n";
771	    $why .= "\twanted";
772	    $why .= &wrap_lines($expect);
773	    $why .= "\tgot";
774	    $why .= &wrap_lines($got);
775	}
776    }
777    return $why;
778}
779
780sub
781wrap_lines
782{
783    local($str, $empty) = @_;
784    local($nonl) = substr($str, -1, 1) ne "\n";
785
786    return (defined $empty ? $empty : " nothing\n") if $str eq '';
787    substr($str, 0, 0) = ":\n";
788    $str =~ s/\n/\n\t\t/g;
789    if ($nonl) {
790	$str .= "\n\t[incomplete last line]\n";
791    } else {
792	chop($str);
793	chop($str);
794    }
795    return $str;
796}
797
798sub
799first_diff
800{
801    local($exp, $got) = @_;
802    local($lineno, $char) = (1, 1);
803    local($i, $exp_len, $got_len);
804    local($ce, $cg);
805
806    $exp_len = length($exp);
807    $got_len = length($got);
808    if ($exp_len != $got_len) {
809	if ($exp_len < $got_len) {
810	    if (substr($got, 0, $exp_len) eq $exp) {
811		return "got too much output";
812	    }
813	} elsif (substr($exp, 0, $got_len) eq $got) {
814	    return "got too little output";
815	}
816    }
817    for ($i = 0; $i < $exp_len; $i++) {
818	$ce = substr($exp, $i, 1);
819	$cg = substr($got, $i, 1);
820	last if $ce ne $cg;
821	$char++;
822	if ($ce eq "\n") {
823	    $lineno++;
824	    $char = 1;
825	}
826    }
827    return "first difference: line $lineno, char $char (wanted '"
828	. &format_char($ce) . "', got '"
829	. &format_char($cg) . "'";
830}
831
832sub
833format_char
834{
835    local($ch, $s);
836
837    $ch = ord($_[0]);
838    if ($ch == 10) {
839	return '\n';
840    } elsif ($ch == 13) {
841	return '\r';
842    } elsif ($ch == 8) {
843	return '\b';
844    } elsif ($ch == 9) {
845	return '\t';
846    } elsif ($ch > 127) {
847	$ch -= 127;
848	$s = "M-";
849    } else {
850	$s = '';
851    }
852    if ($ch < 32) {
853	$s .= '^';
854	$ch += ord('@');
855    } elsif ($ch == 127) {
856	return $s . "^?";
857    }
858    return $s . sprintf("%c", $ch);
859}
860
861sub
862eval_exit
863{
864    local($name, $status, $expect) = @_;
865    local($expr);
866    local($w, $e, $s) = ($status, ($status >> 8) & 0xff, $status & 0x7f);
867
868    $e = -1000 if $status & 0xff;
869    $s = -1000 if $s == 0x7f;
870    if (!defined $expect) {
871	$expr = '$w == 0';
872    } elsif ($expect =~ /^(|-)\d+$/) {
873	$expr = "\$e == $expect";
874    } else {
875	$expr = $expect;
876	$expr =~ s/\b([wse])\b/\$$1/g;
877	$expr =~ s/\b(SIG[A-Z0-9]+)\b/&$1/g;
878    }
879    $w = eval $expr;
880    if ($@ ne '') {
881	print STDERR "$prog:$test{':long-name'}: bad expected-exit expression: $expect ($@)\n";
882	return undef;
883    }
884    return $w;
885}
886
887sub
888read_test
889{
890    local($file, $in, *test) = @_;
891    local($field, $val, $flags, $do_chop, $need_redo, $start_lineno);
892    local(%cnt, $sfield);
893
894    %test = ();
895    %cnt = ();
896    while (<$in>) {
897	next if /^\s*$/;
898	next if /^ *#/;
899	last if /^\s*---\s*$/;
900	$start_lineno = $. if !defined $start_lineno;
901	if (!/^([-\w]+):\s*(|\S|\S.*\S)\s*$/) {
902	    print STDERR "$prog:$file:$.: unrecognised line\n";
903	    return undef;
904	}
905	($field, $val) = ($1, $2);
906	$sfield = $field;
907	$flags = $test_fields{$field};
908	if (!defined $flags) {
909	    print STDERR "$prog:$file:$.: unrecognised field \"$field\"\n";
910	    return undef;
911	}
912	if ($flags =~ /s/) {
913	    local($cnt) = $cnt{$field}++;
914	    $test{$field} = $cnt{$field};
915	    $cnt = 0 if $cnt eq '';
916	    $sfield .= ":$cnt";
917	} elsif (defined $test{$field}) {
918	    print STDERR "$prog:$file:$.: multiple \"$field\" fields\n";
919	    return undef;
920	}
921	$do_chop = $flags !~ /m/;
922	$need_redo = 0;
923	if ($val eq '' || $val eq '!' || $flags =~ /p/) {
924	    if ($flags =~ /[Mm]/) {
925		if ($flags =~ /p/) {
926		    if ($val =~ /^!/) {
927			$do_chop = 1;
928			$val = $';
929		    } else {
930			$do_chop = 0;
931		    }
932		    if ($val eq '') {
933			print STDERR
934		"$prog:$file:$.: no parameters given for field \"$field\"\n";
935			return undef;
936		    }
937		} else {
938		    if ($val eq '!') {
939			$do_chop = 1;
940		    }
941		    $val = '';
942		}
943		while (<$in>) {
944		    last if !/^\t/;
945		    $val .= $';
946		}
947		chop $val if $do_chop;
948		$do_chop = 1;
949		$need_redo = 1;
950
951		# Syntax check on fields that can several instances
952		# (can give useful line numbers this way)
953
954		if ($field eq 'file-setup') {
955		    local($type, $perm, $rest, $c, $len, $name);
956
957		    # format is: type perm "name"
958		    if ($val !~ /^[ \t]*(\S+)[ \t]+(\S+)[ \t]+([^ \t].*)/) {
959			print STDERR
960		    "$prog:$file:$.: bad parameter line for file-setup field\n";
961			return undef;
962		    }
963		    ($type, $perm, $rest) = ($1, $2, $3);
964		    if ($type !~ /^(file|dir|symlink)$/) {
965			print STDERR
966		    "$prog:$file:$.: bad file type for file-setup: $type\n";
967			return undef;
968		    }
969		    if ($perm !~ /^\d+$/) {
970			print STDERR
971		    "$prog:$file:$.: bad permissions for file-setup: $type\n";
972			return undef;
973		    }
974		    $c = substr($rest, 0, 1);
975		    if (($len = index($rest, $c, 1) - 1) <= 0) {
976			print STDERR
977    "$prog:$file:$.: missing end quote for file name in file-setup: $rest\n";
978			return undef;
979		    }
980		    $name = substr($rest, 1, $len);
981		    if ($name =~ /^\// || $name =~ /(^|\/)\.\.(\/|$)/) {
982			# Note: this is not a security thing - just a sanity
983			# check - a test can still use symlinks to get at files
984			# outside the test directory.
985			print STDERR
986"$prog:$file:$.: file name in file-setup is absolute or contains ..: $name\n";
987			return undef;
988		    }
989		}
990		if ($field eq 'file-result') {
991		    local($type, $perm, $uid, $gid, $matchType,
992			  $rest, $c, $len, $name);
993
994		    # format is: type perm uid gid matchType "name"
995		    if ($val !~ /^\s*(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S.*)/) {
996			print STDERR
997		    "$prog:$file:$.: bad parameter line for file-result field\n";
998			return undef;
999		    }
1000		    ($type, $perm, $uid, $gid, $matchType, $rest)
1001			= ($1, $2, $3, $4, $5, $6);
1002		    if ($type !~ /^(file|dir|symlink)$/) {
1003			print STDERR
1004		    "$prog:$file:$.: bad file type for file-result: $type\n";
1005			return undef;
1006		    }
1007		    if ($perm !~ /^\d+$/ && $perm ne '*') {
1008			print STDERR
1009		    "$prog:$file:$.: bad permissions for file-result: $perm\n";
1010			return undef;
1011		    }
1012		    if ($uid !~ /^\d+$/ && $uid ne '*') {
1013			print STDERR
1014		    "$prog:$file:$.: bad user-id for file-result: $uid\n";
1015			return undef;
1016		    }
1017		    if ($gid !~ /^\d+$/ && $gid ne '*') {
1018			print STDERR
1019		    "$prog:$file:$.: bad group-id for file-result: $gid\n";
1020			return undef;
1021		    }
1022		    if ($matchType !~ /^(exact|pattern)$/) {
1023			print STDERR
1024		"$prog:$file:$.: bad match type for file-result: $matchType\n";
1025			return undef;
1026		    }
1027		    $c = substr($rest, 0, 1);
1028		    if (($len = index($rest, $c, 1) - 1) <= 0) {
1029			print STDERR
1030    "$prog:$file:$.: missing end quote for file name in file-result: $rest\n";
1031			return undef;
1032		    }
1033		    $name = substr($rest, 1, $len);
1034		    if ($name =~ /^\// || $name =~ /(^|\/)\.\.(\/|$)/) {
1035			# Note: this is not a security thing - just a sanity
1036			# check - a test can still use symlinks to get at files
1037			# outside the test directory.
1038			print STDERR
1039"$prog:$file:$.: file name in file-result is absolute or contains ..: $name\n";
1040			return undef;
1041		    }
1042		}
1043	    } elsif ($val eq '') {
1044		print STDERR
1045		    "$prog:$file:$.: no value given for field \"$field\"\n";
1046		return undef;
1047	    }
1048	}
1049	$val .= "\n" if !$do_chop;
1050	$test{$sfield} = $val;
1051	redo if $need_redo;
1052    }
1053    if ($_ eq '') {
1054	if (%test) {
1055	    print STDERR
1056	      "$prog:$file:$start_lineno: end-of-file while reading test\n";
1057	    return undef;
1058	}
1059	return 0;
1060    }
1061
1062    while (($field, $val) = each %test_fields) {
1063	if ($val =~ /r/ && !defined $test{$field}) {
1064	    print STDERR
1065	      "$prog:$file:$start_lineno: required field \"$field\" missing\n";
1066	    return undef;
1067	}
1068    }
1069
1070    $test{':full-name'} = substr($file, $file_prefix_skip) . ":$test{'name'}";
1071    $test{':long-name'} = "$file:$start_lineno:$test{'name'}";
1072
1073    # Syntax check on specific fields
1074    if (defined $test{'expected-fail'}) {
1075	if ($test{'expected-fail'} !~ /^(yes|no)$/) {
1076	    print STDERR
1077	      "$prog:$test{':long-name'}: bad value for expected-fail field\n";
1078	    return undef;
1079	}
1080	$test{'expected-fail'} = $1 eq 'yes';
1081    } else {
1082	$test{'expected-fail'} = 0;
1083    }
1084    if (defined $test{'need-ctty'}) {
1085	if ($test{'need-ctty'} !~ /^(yes|no)$/) {
1086	    print STDERR
1087	      "$prog:$test{':long-name'}: bad value for need-ctty field\n";
1088	    return undef;
1089	}
1090	$test{'need-ctty'} = $1 eq 'yes';
1091    } else {
1092	$test{'need-ctty'} = 0;
1093    }
1094    if (defined $test{'need-pass'}) {
1095	if ($test{'need-pass'} !~ /^(yes|no)$/) {
1096	    print STDERR
1097	      "$prog:$test{':long-name'}: bad value for need-pass field\n";
1098	    return undef;
1099	}
1100	$test{'need-pass'} = $1 eq 'yes';
1101    } else {
1102	$test{'need-pass'} = 1;
1103    }
1104    if (defined $test{'arguments'}) {
1105	local($firstc) = substr($test{'arguments'}, 0, 1);
1106
1107	if (substr($test{'arguments'}, -1, 1) ne $firstc) {
1108	    print STDERR "$prog:$test{':long-name'}: arguments field doesn't start and end with the same character\n";
1109	    return undef;
1110	}
1111    }
1112    if (defined $test{'env-setup'}) {
1113	local($firstc) = substr($test{'env-setup'}, 0, 1);
1114
1115	if (substr($test{'env-setup'}, -1, 1) ne $firstc) {
1116	    print STDERR "$prog:$test{':long-name'}: env-setup field doesn't start and end with the same character\n";
1117	    return undef;
1118	}
1119    }
1120    if (defined $test{'expected-exit'}) {
1121	local($val) = $test{'expected-exit'};
1122
1123	if ($val =~ /^(|-)\d+$/) {
1124	    if ($val < 0 || $val > 255) {
1125		print STDERR "$prog:$test{':long-name'}: expected-exit value $val not in 0..255\n";
1126		return undef;
1127	    }
1128	} elsif ($val !~ /^([\s<>+-=*%\/&|!()]|\b[wse]\b|\bSIG[A-Z0-9]+\b)+$/) {
1129	    print STDERR "$prog:$test{':long-name'}: bad expected-exit expression: $val\n";
1130	    return undef;
1131	}
1132    } else {
1133	$test{'expected-exit'} = 0;
1134    }
1135    if (defined $test{'expected-stdout'}
1136	&& defined $test{'expected-stdout-pattern'})
1137    {
1138	print STDERR "$prog:$test{':long-name'}: can't use both expected-stdout and expected-stdout-pattern\n";
1139	return undef;
1140    }
1141    if (defined $test{'expected-stderr'}
1142	&& defined $test{'expected-stderr-pattern'})
1143    {
1144	print STDERR "$prog:$test{':long-name'}: can't use both expected-stderr and expected-stderr-pattern\n";
1145	return undef;
1146    }
1147    if (defined $test{'time-limit'}) {
1148	if ($test{'time-limit'} !~ /^\d+$/ || $test{'time-limit'} == 0) {
1149	    print STDERR
1150	      "$prog:$test{':long-name'}: bad value for time-limit field\n";
1151	    return undef;
1152	}
1153    } elsif (defined $default_time_limit) {
1154	$test{'time-limit'} = $default_time_limit;
1155    }
1156
1157    if (defined $known_tests{$test{'name'}}) {
1158	print STDERR "$prog:$test{':long-name'}: warning: duplicate test name ${test{'name'}}\n";
1159    }
1160    $known_tests{$test{'name'}} = 1;
1161
1162    return 1;
1163}
1164
1165sub
1166tty_msg
1167{
1168    local($msg) = @_;
1169
1170    open(TTY, "> /dev/tty") || return 0;
1171    print TTY $msg;
1172    close(TTY);
1173    return 1;
1174}
1175
1176sub
1177never_called_funcs
1178{
1179	return 0;
1180	&tty_msg("hi\n");
1181	&never_called_funcs();
1182	&catch_sigalrm();
1183	$old_env{'foo'} = 'bar';
1184	$internal_test_fields{'foo'} = 'bar';
1185}
1186
1187sub
1188check_file_result
1189{
1190    local(*test) = @_;
1191
1192    return '' if (!defined $test{'file-result'});
1193
1194    local($why) = '';
1195    local($i);
1196    local($type, $perm, $uid, $gid, $rest, $c, $len, $name);
1197    local(@stbuf);
1198
1199    for ($i = 0; $i < $test{'file-result'}; $i++) {
1200	$val = $test{"file-result:$i"};
1201
1202	# format is: type perm "name"
1203	($type, $perm, $uid, $gid, $matchType, $rest) =
1204	    split(' ', $val, 6);
1205	$c = substr($rest, 0, 1);
1206	$len = index($rest, $c, 1) - 1;
1207	$name = substr($rest, 1, $len);
1208	$rest = substr($rest, 2 + $len);
1209	$perm = oct($perm) if $perm =~ /^\d+$/;
1210
1211	@stbuf = lstat($name);
1212	if (!@stbuf) {
1213	    $why .= "\texpected $type \"$name\" not created\n";
1214	    next;
1215	}
1216	if ($perm ne '*' && ($stbuf[2] & 07777) != $perm) {
1217	    $why .= "\t$type \"$name\" has unexpected permissions\n";
1218	    $why .= sprintf("\t\texpected 0%o, found 0%o\n",
1219		    $perm, $stbuf[2] & 07777);
1220	}
1221	if ($uid ne '*' && $stbuf[4] != $uid) {
1222	    $why .= "\t$type \"$name\" has unexpected user-id\n";
1223	    $why .= sprintf("\t\texpected %d, found %d\n",
1224		    $uid, $stbuf[4]);
1225	}
1226	if ($gid ne '*' && $stbuf[5] != $gid) {
1227	    $why .= "\t$type \"$name\" has unexpected group-id\n";
1228	    $why .= sprintf("\t\texpected %d, found %d\n",
1229		    $gid, $stbuf[5]);
1230	}
1231
1232	if ($type eq 'file') {
1233	    if (-l _ || ! -f _) {
1234		$why .= "\t$type \"$name\" is not a regular file\n";
1235	    } else {
1236		local $tmp = &check_output($test{'long-name'}, $name,
1237			    "$type contents in \"$name\"",
1238			    $matchType eq 'exact' ? $rest : undef
1239			    $matchType eq 'pattern' ? $rest : undef);
1240		return undef if (!defined $tmp);
1241		$why .= $tmp;
1242	    }
1243	} elsif ($type eq 'dir') {
1244	    if ($rest !~ /^\s*$/) {
1245		print STDERR "$prog:$test{':long-name'}: file-result test for directory $name should not have content specified\n";
1246		return undef;
1247	    }
1248	    if (-l _ || ! -d _) {
1249		$why .= "\t$type \"$name\" is not a directory\n";
1250	    }
1251	} elsif ($type eq 'symlink') {
1252	    if (!-l _) {
1253		$why .= "\t$type \"$name\" is not a symlink\n";
1254	    } else {
1255		local $content = readlink($name);
1256		if (!defined $content) {
1257		    print STDERR "$prog:$test{':long-name'}: file-result test for $type $name failed - could not readlink - $!\n";
1258		    return undef;
1259		}
1260		local $tmp = &compare_output($test{'long-name'},
1261			    "$type contents in \"$name\"",
1262			    $matchType eq 'exact' ? $rest : undef
1263			    $matchType eq 'pattern' ? $rest : undef);
1264		return undef if (!defined $tmp);
1265		$why .= $tmp;
1266	    }
1267	}
1268    }
1269
1270    return $why;
1271}
1272
1273sub
1274HELP_MESSAGE
1275{
1276    print STDERR $Usage;
1277    exit 0;
1278}
1279