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