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