--- /dev/null
+# $MirOS: src/bin/mksh/check.pl,v 1.23 2009/06/10 18:12:43 tg Rel $
+# $OpenBSD: th,v 1.13 2006/05/18 21:27:23 miod Exp $
+#-
+# Copyright (c) 2003, 2004, 2005, 2006, 2007, 2008, 2009
+# Thorsten Glaser <tg@mirbsd.org>
+#
+# Provided that these terms and disclaimer and all copyright notices
+# are retained or reproduced in an accompanying document, permission
+# is granted to deal in this work without restriction, including un-
+# limited rights to use, publicly perform, distribute, sell, modify,
+# merge, give away, or sublicence.
+#
+# This work is provided "AS IS" and WITHOUT WARRANTY of any kind, to
+# the utmost extent permitted by applicable law, neither express nor
+# implied; without malicious intent or gross negligence. In no event
+# may a licensor, author or contributor be held liable for indirect,
+# direct, other damage, loss, or other issues arising in any way out
+# of dealing in the work, even if advised of the possibility of such
+# damage or existence of a defect, except proven that it results out
+# of said person's immediate fault when using the work as intended.
+#-
+# Example test:
+# name: a-test
+# description:
+# a test to show how tests are done
+# arguments: !-x!-f!
+# stdin:
+# echo -n *
+# false
+# expected-stdout: !
+# *
+# expected-stderr:
+# + echo -n *
+# + false
+# expected-exit: 1
+# ---
+# This runs the test-program (eg, mksh) with the arguments -x and -f,
+# standard input is a file containing "echo hi*\nfalse\n". The program
+# is expected to produce "hi*" (no trailing newline) on standard output,
+# "+ echo hi*\n+false\n" on standard error, and an exit code of 1.
+#
+#
+# Format of test files:
+# - blank lines and lines starting with # are ignored
+# - a test file contains a series of tests
+# - a test is a series of tag:value pairs ended with a "---" line
+# (leading/trailing spaces are stripped from the first line of value)
+# - test tags are:
+# Tag Flag Description
+# ----- ---- -----------
+# name r The name of the test; should be unique
+# description m What test does
+# arguments M Arguments to pass to the program;
+# default is no arguments.
+# script m Value is written to a file which
+# is passed as an argument to the program
+# (after the arguments arguments)
+# stdin m Value is written to a file which is
+# used as standard-input for the program;
+# default is to use /dev/null.
+# perl-setup m Value is a perl script which is executed
+# just before the test is run. Try to
+# avoid using this...
+# perl-cleanup m Value is a perl script which is executed
+# just after the test is run. Try to
+# avoid using this...
+# env-setup M Value is a list of NAME=VALUE elements
+# which are put in the environment before
+# the test is run. If the =VALUE is
+# missing, NAME is removed from the
+# environment. Programs are run with
+# the following minimal environment:
+# HOME, LD_LIBRARY_PATH, LOCPATH,
+# LOGNAME, PATH, SHELL, USER
+# (values taken from the environment of
+# the test harness).
+# ENV is set to /nonexistant.
+# __progname is set to the -p argument.
+# __perlname is set to $^X (perlexe).
+# file-setup mps Used to create files, directories
+# and symlinks. First word is either
+# file, dir or symlink; second word is
+# permissions; this is followed by a
+# quoted word that is the name of the
+# file; the end-quote should be followed
+# by a newline, then the file data
+# (if any). The first word may be
+# preceded by a ! to strip the trailing
+# newline in a symlink.
+# file-result mps Used to verify a file, symlink or
+# directory is created correctly.
+# The first word is either
+# file, dir or symlink; second word is
+# expected permissions; third word
+# is user-id; fourth is group-id;
+# fifth is "exact" or "pattern"
+# indicating whether the file contents
+# which follow is to be matched exactly
+# or if it is a regular expression.
+# The fifth argument is the quoted name
+# of the file that should be created.
+# The end-quote should be followed
+# by a newline, then the file data
+# (if any). The first word may be
+# preceded by a ! to strip the trailing
+# newline in the file contents.
+# The permissions, user and group fields
+# may be * meaning accept any value.
+# time-limit Time limit - the program is sent a
+# SIGKILL N seconds. Default is no
+# limit.
+# expected-fail 'yes' if the test is expected to fail.
+# expected-exit expected exit code. Can be a number,
+# or a C expression using the variables
+# e, s and w (exit code, termination
+# signal, and status code).
+# expected-stdout m What the test should generate on stdout;
+# default is to expect no output.
+# expected-stdout-pattern m A perl pattern which matches the
+# expected output.
+# expected-stderr m What the test should generate on stderr;
+# default is to expect no output.
+# expected-stderr-pattern m A perl pattern which matches the
+# expected standard error.
+# category m Specify a comma separated list of
+# 'categories' of program that the test
+# is to be run for. A category can be
+# negated by prefixing the name with a !.
+# The idea is that some tests in a
+# test suite may apply to a particular
+# program version and shouldn't be run
+# on other versions. The category(s) of
+# the program being tested can be
+# specified on the command line.
+# One category os:XXX is predefined
+# (XXX is the operating system name,
+# eg, linux, dec_osf).
+# Flag meanings:
+# r tag is required (eg, a test must have a name tag).
+# m value can be multiple lines. Lines must be prefixed with
+# a tab. If the value part of the initial tag:value line is
+# - empty: the initial blank line is stripped.
+# - a lone !: the last newline in the value is stripped;
+# M value can be multiple lines (prefixed by a tab) and consists
+# of multiple fields, delimited by a field separator character.
+# The value must start and end with the f-s-c.
+# p tag takes parameters (used with m).
+# s tag can be used several times.
+
+use POSIX qw(EINTR);
+use Getopt::Std;
+use Config;
+
+$os = defined $^O ? $^O : 'unknown';
+
+($prog = $0) =~ s#.*/##;
+
+$Usage = <<EOF ;
+Usage: $prog [-s test-set] [-C category] [-p prog] [-v] [-e e=v] name ...
+ -p p Use p as the program to test
+ -C c Specify the comma separated list of categories the program
+ belongs to (see category field).
+ -s s Read tests from file s; if s is a directory, it is recursively
+ scaned for test files (which end in .t).
+ -t t Use t as default time limit for tests (default is unlimited)
+ -P program (-p) string has multiple words, and the program is in
+ the path (kludge option)
+ -v Verbose mode: print reason test failed.
+ -e e=v Set the environment variable e to v for all tests
+ (if no =v is given, the current value is used)
+ Only one -e option can be given at the moment, sadly.
+ name specifies the name of the test(s) to run; if none are
+ specified, all tests are run.
+EOF
+
+# See comment above for flag meanings
+%test_fields = (
+ 'name', 'r',
+ 'description', 'm',
+ 'arguments', 'M',
+ 'script', 'm',
+ 'stdin', 'm',
+ 'perl-setup', 'm',
+ 'perl-cleanup', 'm',
+ 'env-setup', 'M',
+ 'file-setup', 'mps',
+ 'file-result', 'mps',
+ 'time-limit', '',
+ 'expected-fail', '',
+ 'expected-exit', '',
+ 'expected-stdout', 'm',
+ 'expected-stdout-pattern', 'm',
+ 'expected-stderr', 'm',
+ 'expected-stderr-pattern', 'm',
+ 'category', 'm',
+ );
+# Filled in by read_test()
+%internal_test_fields = (
+ ':full-name', 1, # file:name
+ ':long-name', 1, # dir/file:lineno:name
+ );
+
+# Categories of the program under test. Provide the current
+# os by default.
+%categories = (
+ "os:$os", '1'
+ );
+
+$temps = "/tmp/rts$$";
+$tempi = "/tmp/rti$$";
+$tempo = "/tmp/rto$$";
+$tempe = "/tmp/rte$$";
+$tempdir = "/tmp/rtd$$";
+
+$nfailed = 0;
+$nxfailed = 0;
+$npassed = 0;
+$nxpassed = 0;
+
+%known_tests = ();
+
+if (!getopts('C:p:Ps:t:ve:')) {
+ print STDERR $Usage;
+ exit 1;
+}
+
+die "$prog: no program specified (use -p)\n" if !defined $opt_p;
+die "$prog: no test set specified (use -s)\n" if !defined $opt_s;
+$test_prog = $opt_p;
+$verbose = defined $opt_v && $opt_v;
+$test_set = $opt_s;
+if (defined $opt_t) {
+ die "$prog: bad -t argument (should be number > 0): $opt_t\n"
+ if $opt_t !~ /^\d+$/ || $opt_t <= 0;
+ $default_time_limit = $opt_t;
+}
+$program_kludge = defined $opt_P ? $opt_P : 0;
+
+if (defined $opt_C) {
+ foreach $c (split(',', $opt_C)) {
+ $c =~ s/\s+//;
+ die "$prog: categories can't be negated on the command line\n"
+ if ($c =~ /^!/);
+ $categories{$c} = 1;
+ }
+}
+
+# Note which tests are to be run.
+%do_test = ();
+grep($do_test{$_} = 1, @ARGV);
+$all_tests = @ARGV == 0;
+
+# Set up a very minimal environment
+%new_env = ();
+foreach $env (('HOME', 'LD_LIBRARY_PATH', 'LOCPATH', 'LOGNAME',
+ 'PATH', 'SHELL', 'USER')) {
+ $new_env{$env} = $ENV{$env} if defined $ENV{$env};
+}
+$new_env{'ENV'} = '/nonexistant';
+if (($os eq 'VMS') || ($Config{perlpath} =~ m/$Config{_exe}$/i)) {
+ $new_env{'__perlname'} = $Config{perlpath};
+} else {
+ $new_env{'__perlname'} = $Config{perlpath} . $Config{_exe};
+}
+if (defined $opt_e) {
+ # XXX need a way to allow many -e arguments...
+ if ($opt_e =~ /^([a-zA-Z_]\w*)(|=(.*))$/) {
+ $new_env{$1} = $2 eq '' ? $ENV{$1} : $3;
+ } else {
+ die "$0: bad -e argument: $opt_e\n";
+ }
+}
+%old_env = %ENV;
+
+die "$prog: couldn't make directory $tempdir - $!\n" if !mkdir($tempdir, 0777);
+
+chop($pwd = `pwd 2>/dev/null`);
+die "$prog: couldn't get current working directory\n" if $pwd eq '';
+die "$prog: couldn't cd to $pwd - $!\n" if !chdir($pwd);
+
+if (!$program_kludge) {
+ $test_prog = "$pwd/$test_prog" if substr($test_prog, 0, 1) ne '/';
+ die "$prog: $test_prog is not executable - bye\n"
+ if (! -x $test_prog && $os ne 'os2');
+}
+
+@trap_sigs = ('TERM', 'QUIT', 'INT', 'PIPE', 'HUP');
+@SIG{@trap_sigs} = ('cleanup_exit') x @trap_sigs;
+$child_kill_ok = 0;
+$SIG{'ALRM'} = 'catch_sigalrm';
+
+$| = 1;
+
+if (-d $test_set) {
+ $file_prefix_skip = length($test_set) + 1;
+ $ret = &process_test_dir($test_set);
+} else {
+ $file_prefix_skip = 0;
+ $ret = &process_test_file($test_set);
+}
+&cleanup_exit() if !defined $ret;
+
+$tot_failed = $nfailed + $nxfailed;
+$tot_passed = $npassed + $nxpassed;
+if ($tot_failed || $tot_passed) {
+ print "Total failed: $tot_failed";
+ print " ($nxfailed unexpected)" if $nxfailed;
+ print " (as expected)" if $nfailed && !$nxfailed;
+ print "\nTotal passed: $tot_passed";
+ print " ($nxpassed unexpected)" if $nxpassed;
+ print "\n";
+}
+
+&cleanup_exit('ok');
+
+sub
+cleanup_exit
+{
+ local($sig, $exitcode) = ('', 1);
+
+ if ($_[0] eq 'ok') {
+ $exitcode = 0;
+ } elsif ($_[0] ne '') {
+ $sig = $_[0];
+ }
+
+ unlink($tempi, $tempo, $tempe, $temps);
+ &scrub_dir($tempdir) if defined $tempdir;
+ rmdir($tempdir) if defined $tempdir;
+
+ if ($sig) {
+ $SIG{$sig} = 'DEFAULT';
+ kill $sig, $$;
+ return;
+ }
+ exit $exitcode;
+}
+
+sub
+catch_sigalrm
+{
+ $SIG{'ALRM'} = 'catch_sigalrm';
+ kill(9, $child_pid) if $child_kill_ok;
+ $child_killed = 1;
+}
+
+sub
+process_test_dir
+{
+ local($dir) = @_;
+ local($ret, $file);
+ local(@todo) = ();
+
+ if (!opendir(DIR, $dir)) {
+ print STDERR "$prog: can't open directory $dir - $!\n";
+ return undef;
+ }
+ while (defined ($file = readdir(DIR))) {
+ push(@todo, $file) if $file =~ /^[^.].*\.t$/;
+ }
+ closedir(DIR);
+
+ foreach $file (@todo) {
+ $file = "$dir/$file";
+ if (-d $file) {
+ $ret = &process_test_dir($file);
+ } elsif (-f _) {
+ $ret = &process_test_file($file);
+ }
+ last if !defined $ret;
+ }
+
+ return $ret;
+}
+
+sub
+process_test_file
+{
+ local($file) = @_;
+ local($ret);
+
+ if (!open(IN, $file)) {
+ print STDERR "$prog: can't open $file - $!\n";
+ return undef;
+ }
+ binmode(IN);
+ while (1) {
+ $ret = &read_test($file, IN, *test);
+ last if !defined $ret || !$ret;
+ next if !$all_tests && !$do_test{$test{'name'}};
+ next if !&category_check(*test);
+ $ret = &run_test(*test);
+ last if !defined $ret;
+ }
+ close(IN);
+
+ return $ret;
+}
+
+sub
+run_test
+{
+ local(*test) = @_;
+ local($name) = $test{':full-name'};
+
+ if (defined $test{'stdin'}) {
+ return undef if !&write_file($tempi, $test{'stdin'});
+ $ifile = $tempi;
+ } else {
+ $ifile = '/dev/null';
+ }
+
+ if (defined $test{'script'}) {
+ return undef if !&write_file($temps, $test{'script'});
+ }
+
+ return undef if !&scrub_dir($tempdir);
+
+ if (!chdir($tempdir)) {
+ print STDERR "$prog: couldn't cd to $tempdir - $!\n";
+ return undef;
+ }
+
+ if (defined $test{'file-setup'}) {
+ local($i);
+ local($type, $perm, $rest, $c, $len, $name);
+
+ for ($i = 0; $i < $test{'file-setup'}; $i++) {
+ $val = $test{"file-setup:$i"};
+
+ # format is: type perm "name"
+ ($type, $perm, $rest) =
+ split(' ', $val, 3);
+ $c = substr($rest, 0, 1);
+ $len = index($rest, $c, 1) - 1;
+ $name = substr($rest, 1, $len);
+ $rest = substr($rest, 2 + $len);
+ $perm = oct($perm) if $perm =~ /^\d+$/;
+ if ($type eq 'file') {
+ return undef if !&write_file($name, $rest);
+ if (!chmod($perm, $name)) {
+ print STDERR
+ "$prog:$test{':long-name'}: can't chmod $perm $name - $!\n";
+ return undef;
+ }
+ } elsif ($type eq 'dir') {
+ if (!mkdir($name, $perm)) {
+ print STDERR
+ "$prog:$test{':long-name'}: can't mkdir $perm $name - $!\n";
+ return undef;
+ }
+ } elsif ($type eq 'symlink') {
+ local($oumask) = umask($perm);
+ local($ret) = symlink($rest, $name);
+ umask($oumask);
+ if (!$ret) {
+ print STDERR
+ "$prog:$test{':long-name'}: couldn't create symlink $name - $!\n";
+ return undef;
+ }
+ }
+ }
+ }
+
+ if (defined $test{'perl-setup'}) {
+ eval $test{'perl-setup'};
+ if ($@ ne '') {
+ print STDERR "$prog:$test{':long-name'}: error running perl-setup - $@\n";
+ return undef;
+ }
+ }
+
+ $pid = fork;
+ if (!defined $pid) {
+ print STDERR "$prog: can't fork - $!\n";
+ return undef;
+ }
+ if (!$pid) {
+ @SIG{@trap_sigs} = ('DEFAULT') x @trap_sigs;
+ $SIG{'ALRM'} = 'DEFAULT';
+ if (defined $test{'env-setup'}) {
+ local($var, $val, $i);
+
+ foreach $var (split(substr($test{'env-setup'}, 0, 1),
+ $test{'env-setup'}))
+ {
+ $i = index($var, '=');
+ next if $i == 0 || $var eq '';
+ if ($i < 0) {
+ delete $new_env{$var};
+ } else {
+ $new_env{substr($var, 0, $i)} = substr($var, $i + 1);
+ }
+ }
+ }
+ if (!open(STDIN, "< $ifile")) {
+ print STDERR "$prog: couldn't open $ifile in child - $!\n";
+ kill('TERM', $$);
+ }
+ binmode(STDIN);
+ if (!open(STDOUT, "> $tempo")) {
+ print STDERR "$prog: couldn't open $tempo in child - $!\n";
+ kill('TERM', $$);
+ }
+ binmode(STDOUT);
+ if (!open(STDERR, "> $tempe")) {
+ print STDOUT "$prog: couldn't open $tempe in child - $!\n";
+ kill('TERM', $$);
+ }
+ binmode(STDERR);
+ if ($program_kludge) {
+ @argv = split(' ', $test_prog);
+ } else {
+ @argv = ($test_prog);
+ }
+ if (defined $test{'arguments'}) {
+ push(@argv,
+ split(substr($test{'arguments'}, 0, 1),
+ substr($test{'arguments'}, 1)));
+ }
+ push(@argv, $temps) if defined $test{'script'};
+
+ #XXX realpathise, use which/whence -p, or sth. like that
+ #XXX if !$program_kludge, we get by with not doing it for now tho
+ $new_env{'__progname'} = $argv[0];
+
+ # The following doesn't work with perl5... Need to do it explicitly - yuck.
+ #%ENV = %new_env;
+ foreach $k (keys(%ENV)) {
+ delete $ENV{$k};
+ }
+ $ENV{$k} = $v while ($k,$v) = each %new_env;
+
+ exec { $argv[0] } @argv;
+ print STDERR "$prog: couldn't execute $test_prog - $!\n";
+ kill('TERM', $$);
+ exit(95);
+ }
+ $child_pid = $pid;
+ $child_killed = 0;
+ $child_kill_ok = 1;
+ alarm($test{'time-limit'}) if defined $test{'time-limit'};
+ while (1) {
+ $xpid = waitpid($pid, 0);
+ $child_kill_ok = 0;
+ if ($xpid < 0) {
+ next if $! == EINTR;
+ print STDERR "$prog: error waiting for child - $!\n";
+ return undef;
+ }
+ last;
+ }
+ $status = $?;
+ alarm(0) if defined $test{'time-limit'};
+
+ $failed = 0;
+ $why = '';
+
+ if ($child_killed) {
+ $failed = 1;
+ $why .= "\ttest timed out (limit of $test{'time-limit'} seconds)\n";
+ }
+
+ $ret = &eval_exit($test{'long-name'}, $status, $test{'expected-exit'});
+ return undef if !defined $ret;
+ if (!$ret) {
+ local($expl);
+
+ $failed = 1;
+ if (($status & 0xff) == 0x7f) {
+ $expl = "stopped";
+ } elsif (($status & 0xff)) {
+ $expl = "signal " . ($status & 0x7f);
+ } else {
+ $expl = "exit-code " . (($status >> 8) & 0xff);
+ }
+ $why .=
+ "\tunexpected exit status $status ($expl), expected $test{'expected-exit'}\n";
+ }
+
+ $tmp = &check_output($test{'long-name'}, $tempo, 'stdout',
+ $test{'expected-stdout'}, $test{'expected-stdout-pattern'});
+ return undef if !defined $tmp;
+ if ($tmp ne '') {
+ $failed = 1;
+ $why .= $tmp;
+ }
+
+ $tmp = &check_output($test{'long-name'}, $tempe, 'stderr',
+ $test{'expected-stderr'}, $test{'expected-stderr-pattern'});
+ return undef if !defined $tmp;
+ if ($tmp ne '') {
+ $failed = 1;
+ $why .= $tmp;
+ }
+
+ $tmp = &check_file_result(*test);
+ return undef if !defined $tmp;
+ if ($tmp ne '') {
+ $failed = 1;
+ $why .= $tmp;
+ }
+
+ if (defined $test{'perl-cleanup'}) {
+ eval $test{'perl-cleanup'};
+ if ($@ ne '') {
+ print STDERR "$prog:$test{':long-name'}: error running perl-cleanup - $@\n";
+ return undef;
+ }
+ }
+
+ if (!chdir($pwd)) {
+ print STDERR "$prog: couldn't cd to $pwd - $!\n";
+ return undef;
+ }
+
+ if ($failed) {
+ if (!$test{'expected-fail'}) {
+ print "FAIL $name\n";
+ $nxfailed++;
+ } else {
+ print "fail $name (as expected)\n";
+ $nfailed++;
+ }
+ $why = "\tDescription"
+ . &wrap_lines($test{'description'}, " (missing)\n")
+ . $why;
+ } elsif ($test{'expected-fail'}) {
+ print "PASS $name (unexpectedly)\n";
+ $nxpassed++;
+ } else {
+ print "pass $name\n";
+ $npassed++;
+ }
+ print $why if $verbose;
+ return 0;
+}
+
+sub
+category_check
+{
+ local(*test) = @_;
+ local($c);
+
+ return 1 if (!defined $test{'category'});
+ local($ok) = 0;
+ foreach $c (split(',', $test{'category'})) {
+ $c =~ s/\s+//;
+ if ($c =~ /^!/) {
+ $c = $';
+ return 0 if (defined $categories{$c});
+ $ok = 1;
+ } else {
+ $ok = 1 if (defined $categories{$c});
+ }
+ }
+ return $ok;
+}
+
+sub
+scrub_dir
+{
+ local($dir) = @_;
+ local(@todo) = ();
+ local($file);
+
+ if (!opendir(DIR, $dir)) {
+ print STDERR "$prog: couldn't open directory $dir - $!\n";
+ return undef;
+ }
+ while (defined ($file = readdir(DIR))) {
+ push(@todo, $file) if $file ne '.' && $file ne '..';
+ }
+ closedir(DIR);
+ foreach $file (@todo) {
+ $file = "$dir/$file";
+ if (-d $file) {
+ return undef if !&scrub_dir($file);
+ if (!rmdir($file)) {
+ print STDERR "$prog: couldn't rmdir $file - $!\n";
+ return undef;
+ }
+ } else {
+ if (!unlink($file)) {
+ print STDERR "$prog: couldn't unlink $file - $!\n";
+ return undef;
+ }
+ }
+ }
+ return 1;
+}
+
+sub
+write_file
+{
+ local($file, $str) = @_;
+
+ if (!open(TEMP, "> $file")) {
+ print STDERR "$prog: can't open $file - $!\n";
+ return undef;
+ }
+ binmode(TEMP);
+ print TEMP $str;
+ if (!close(TEMP)) {
+ print STDERR "$prog: error writing $file - $!\n";
+ return undef;
+ }
+ return 1;
+}
+
+sub
+check_output
+{
+ local($name, $file, $what, $expect, $expect_pat) = @_;
+ local($got) = '';
+ local($why) = '';
+ local($ret);
+
+ if (!open(TEMP, "< $file")) {
+ print STDERR "$prog:$name($what): couldn't open $file after running program - $!\n";
+ return undef;
+ }
+ binmode(TEMP);
+ while (<TEMP>) {
+ $got .= $_;
+ }
+ close(TEMP);
+ return compare_output($name, $what, $expect, $expect_pat, $got);
+}
+
+sub
+compare_output
+{
+ local($name, $what, $expect, $expect_pat, $got) = @_;
+ local($why) = '';
+
+ if (defined $expect_pat) {
+ $_ = $got;
+ $ret = eval "$expect_pat";
+ if ($@ ne '') {
+ print STDERR "$prog:$name($what): error evaluating $what pattern: $expect_pat - $@\n";
+ return undef;
+ }
+ if (!$ret) {
+ $why = "\tunexpected $what - wanted pattern";
+ $why .= &wrap_lines($expect_pat);
+ $why .= "\tgot";
+ $why .= &wrap_lines($got);
+ }
+ } else {
+ $expect = '' if !defined $expect;
+ if ($got ne $expect) {
+ $why .= "\tunexpected $what - " . &first_diff($expect, $got) . "\n";
+ $why .= "\twanted";
+ $why .= &wrap_lines($expect);
+ $why .= "\tgot";
+ $why .= &wrap_lines($got);
+ }
+ }
+ return $why;
+}
+
+sub
+wrap_lines
+{
+ local($str, $empty) = @_;
+ local($nonl) = substr($str, -1, 1) ne "\n";
+
+ return (defined $empty ? $empty : " nothing\n") if $str eq '';
+ substr($str, 0, 0) = ":\n";
+ $str =~ s/\n/\n\t\t/g;
+ if ($nonl) {
+ $str .= "\n\t[incomplete last line]\n";
+ } else {
+ chop($str);
+ chop($str);
+ }
+ return $str;
+}
+
+sub
+first_diff
+{
+ local($exp, $got) = @_;
+ local($lineno, $char) = (1, 1);
+ local($i, $exp_len, $got_len);
+ local($ce, $cg);
+
+ $exp_len = length($exp);
+ $got_len = length($got);
+ if ($exp_len != $got_len) {
+ if ($exp_len < $got_len) {
+ if (substr($got, 0, $exp_len) eq $exp) {
+ return "got too much output";
+ }
+ } elsif (substr($exp, 0, $got_len) eq $got) {
+ return "got too little output";
+ }
+ }
+ for ($i = 0; $i < $exp_len; $i++) {
+ $ce = substr($exp, $i, 1);
+ $cg = substr($got, $i, 1);
+ last if $ce ne $cg;
+ $char++;
+ if ($ce eq "\n") {
+ $lineno++;
+ $char = 1;
+ }
+ }
+ return "first difference: line $lineno, char $char (wanted '"
+ . &format_char($ce) . "', got '"
+ . &format_char($cg) . "'";
+}
+
+sub
+format_char
+{
+ local($ch, $s);
+
+ $ch = ord($_[0]);
+ if ($ch == 10) {
+ return '\n';
+ } elsif ($ch == 13) {
+ return '\r';
+ } elsif ($ch == 8) {
+ return '\b';
+ } elsif ($ch == 9) {
+ return '\t';
+ } elsif ($ch > 127) {
+ $ch -= 127;
+ $s = "M-";
+ } else {
+ $s = '';
+ }
+ if ($ch < 32) {
+ $s .= '^';
+ $ch += ord('@');
+ } elsif ($ch == 127) {
+ return $s . "^?";
+ }
+ return $s . sprintf("%c", $ch);
+}
+
+sub
+eval_exit
+{
+ local($name, $status, $expect) = @_;
+ local($expr);
+ local($w, $e, $s) = ($status, ($status >> 8) & 0xff, $status & 0x7f);
+
+ $e = -1000 if $status & 0xff;
+ $s = -1000 if $s == 0x7f;
+ if (!defined $expect) {
+ $expr = '$w == 0';
+ } elsif ($expect =~ /^(|-)\d+$/) {
+ $expr = "\$e == $expect";
+ } else {
+ $expr = $expect;
+ $expr =~ s/\b([wse])\b/\$$1/g;
+ $expr =~ s/\b(SIG[A-Z0-9]+)\b/&$1/g;
+ }
+ $w = eval $expr;
+ if ($@ ne '') {
+ print STDERR "$prog:$test{':long-name'}: bad expected-exit expression: $expect ($@)\n";
+ return undef;
+ }
+ return $w;
+}
+
+sub
+read_test
+{
+ local($file, $in, *test) = @_;
+ local($field, $val, $flags, $do_chop, $need_redo, $start_lineno);
+ local(%cnt, $sfield);
+
+ %test = ();
+ %cnt = ();
+ while (<$in>) {
+ next if /^\s*$/;
+ next if /^ *#/;
+ last if /^\s*---\s*$/;
+ $start_lineno = $. if !defined $start_lineno;
+ if (!/^([-\w]+):\s*(|\S|\S.*\S)\s*$/) {
+ print STDERR "$prog:$file:$.: unrecognised line\n";
+ return undef;
+ }
+ ($field, $val) = ($1, $2);
+ $sfield = $field;
+ $flags = $test_fields{$field};
+ if (!defined $flags) {
+ print STDERR "$prog:$file:$.: unrecognised field \"$field\"\n";
+ return undef;
+ }
+ if ($flags =~ /s/) {
+ local($cnt) = $cnt{$field}++;
+ $test{$field} = $cnt{$field};
+ $cnt = 0 if $cnt eq '';
+ $sfield .= ":$cnt";
+ } elsif (defined $test{$field}) {
+ print STDERR "$prog:$file:$.: multiple \"$field\" fields\n";
+ return undef;
+ }
+ $do_chop = $flags !~ /m/;
+ $need_redo = 0;
+ if ($val eq '' || $val eq '!' || $flags =~ /p/) {
+ if ($flags =~ /[Mm]/) {
+ if ($flags =~ /p/) {
+ if ($val =~ /^!/) {
+ $do_chop = 1;
+ $val = $';
+ } else {
+ $do_chop = 0;
+ }
+ if ($val eq '') {
+ print STDERR
+ "$prog:$file:$.: no parameters given for field \"$field\"\n";
+ return undef;
+ }
+ } else {
+ if ($val eq '!') {
+ $do_chop = 1;
+ }
+ $val = '';
+ }
+ while (<$in>) {
+ last if !/^\t/;
+ $val .= $';
+ }
+ chop $val if $do_chop;
+ $do_chop = 1;
+ $need_redo = 1;
+
+ # Syntax check on fields that can several instances
+ # (can give useful line numbers this way)
+
+ if ($field eq 'file-setup') {
+ local($type, $perm, $rest, $c, $len, $name);
+
+ # format is: type perm "name"
+ if ($val !~ /^[ \t]*(\S+)[ \t]+(\S+)[ \t]+([^ \t].*)/) {
+ print STDERR
+ "$prog:$file:$.: bad parameter line for file-setup field\n";
+ return undef;
+ }
+ ($type, $perm, $rest) = ($1, $2, $3);
+ if ($type !~ /^(file|dir|symlink)$/) {
+ print STDERR
+ "$prog:$file:$.: bad file type for file-setup: $type\n";
+ return undef;
+ }
+ if ($perm !~ /^\d+$/) {
+ print STDERR
+ "$prog:$file:$.: bad permissions for file-setup: $type\n";
+ return undef;
+ }
+ $c = substr($rest, 0, 1);
+ if (($len = index($rest, $c, 1) - 1) <= 0) {
+ print STDERR
+ "$prog:$file:$.: missing end quote for file name in file-setup: $rest\n";
+ return undef;
+ }
+ $name = substr($rest, 1, $len);
+ if ($name =~ /^\// || $name =~ /(^|\/)\.\.(\/|$)/) {
+ # Note: this is not a security thing - just a sanity
+ # check - a test can still use symlinks to get at files
+ # outside the test directory.
+ print STDERR
+"$prog:$file:$.: file name in file-setup is absolute or contains ..: $name\n";
+ return undef;
+ }
+ }
+ if ($field eq 'file-result') {
+ local($type, $perm, $uid, $gid, $matchType,
+ $rest, $c, $len, $name);
+
+ # format is: type perm uid gid matchType "name"
+ if ($val !~ /^\s*(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S.*)/) {
+ print STDERR
+ "$prog:$file:$.: bad parameter line for file-result field\n";
+ return undef;
+ }
+ ($type, $perm, $uid, $gid, $matchType, $rest)
+ = ($1, $2, $3, $4, $5, $6);
+ if ($type !~ /^(file|dir|symlink)$/) {
+ print STDERR
+ "$prog:$file:$.: bad file type for file-result: $type\n";
+ return undef;
+ }
+ if ($perm !~ /^\d+$/ && $perm ne '*') {
+ print STDERR
+ "$prog:$file:$.: bad permissions for file-result: $perm\n";
+ return undef;
+ }
+ if ($uid !~ /^\d+$/ && $uid ne '*') {
+ print STDERR
+ "$prog:$file:$.: bad user-id for file-result: $uid\n";
+ return undef;
+ }
+ if ($gid !~ /^\d+$/ && $gid ne '*') {
+ print STDERR
+ "$prog:$file:$.: bad group-id for file-result: $gid\n";
+ return undef;
+ }
+ if ($matchType !~ /^(exact|pattern)$/) {
+ print STDERR
+ "$prog:$file:$.: bad match type for file-result: $matchType\n";
+ return undef;
+ }
+ $c = substr($rest, 0, 1);
+ if (($len = index($rest, $c, 1) - 1) <= 0) {
+ print STDERR
+ "$prog:$file:$.: missing end quote for file name in file-result: $rest\n";
+ return undef;
+ }
+ $name = substr($rest, 1, $len);
+ if ($name =~ /^\// || $name =~ /(^|\/)\.\.(\/|$)/) {
+ # Note: this is not a security thing - just a sanity
+ # check - a test can still use symlinks to get at files
+ # outside the test directory.
+ print STDERR
+"$prog:$file:$.: file name in file-result is absolute or contains ..: $name\n";
+ return undef;
+ }
+ }
+ } elsif ($val eq '') {
+ print STDERR
+ "$prog:$file:$.: no value given for field \"$field\"\n";
+ return undef;
+ }
+ }
+ $val .= "\n" if !$do_chop;
+ $test{$sfield} = $val;
+ redo if $need_redo;
+ }
+ if ($_ eq '') {
+ if (%test) {
+ print STDERR
+ "$prog:$file:$start_lineno: end-of-file while reading test\n";
+ return undef;
+ }
+ return 0;
+ }
+
+ while (($field, $val) = each %test_fields) {
+ if ($val =~ /r/ && !defined $test{$field}) {
+ print STDERR
+ "$prog:$file:$start_lineno: required field \"$field\" missing\n";
+ return undef;
+ }
+ }
+
+ $test{':full-name'} = substr($file, $file_prefix_skip) . ":$test{'name'}";
+ $test{':long-name'} = "$file:$start_lineno:$test{'name'}";
+
+ # Syntax check on specific fields
+ if (defined $test{'expected-fail'}) {
+ if ($test{'expected-fail'} !~ /^(yes|no)$/) {
+ print STDERR
+ "$prog:$test{':long-name'}: bad value for expected-fail field\n";
+ return undef;
+ }
+ $test{'expected-fail'} = $1 eq 'yes';
+ } else {
+ $test{'expected-fail'} = 0;
+ }
+ if (defined $test{'arguments'}) {
+ local($firstc) = substr($test{'arguments'}, 0, 1);
+
+ if (substr($test{'arguments'}, -1, 1) ne $firstc) {
+ print STDERR "$prog:$test{':long-name'}: arguments field doesn't start and end with the same character\n";
+ return undef;
+ }
+ }
+ if (defined $test{'env-setup'}) {
+ local($firstc) = substr($test{'env-setup'}, 0, 1);
+
+ if (substr($test{'env-setup'}, -1, 1) ne $firstc) {
+ print STDERR "$prog:$test{':long-name'}: env-setup field doesn't start and end with the same character\n";
+ return undef;
+ }
+ }
+ if (defined $test{'expected-exit'}) {
+ local($val) = $test{'expected-exit'};
+
+ if ($val =~ /^(|-)\d+$/) {
+ if ($val < 0 || $val > 255) {
+ print STDERR "$prog:$test{':long-name'}: expected-exit value $val not in 0..255\n";
+ return undef;
+ }
+ } elsif ($val !~ /^([\s<>+-=*%\/&|!()]|\b[wse]\b|\bSIG[A-Z0-9]+\b)+$/) {
+ print STDERR "$prog:$test{':long-name'}: bad expected-exit expression: $val\n";
+ return undef;
+ }
+ } else {
+ $test{'expected-exit'} = 0;
+ }
+ if (defined $test{'expected-stdout'}
+ && defined $test{'expected-stdout-pattern'})
+ {
+ print STDERR "$prog:$test{':long-name'}: can't use both expected-stdout and expected-stdout-pattern\n";
+ return undef;
+ }
+ if (defined $test{'expected-stderr'}
+ && defined $test{'expected-stderr-pattern'})
+ {
+ print STDERR "$prog:$test{':long-name'}: can't use both expected-stderr and expected-stderr-pattern\n";
+ return undef;
+ }
+ if (defined $test{'time-limit'}) {
+ if ($test{'time-limit'} !~ /^\d+$/ || $test{'time-limit'} == 0) {
+ print STDERR
+ "$prog:$test{':long-name'}: bad value for time-limit field\n";
+ return undef;
+ }
+ } elsif (defined $default_time_limit) {
+ $test{'time-limit'} = $default_time_limit;
+ }
+
+ if (defined $known_tests{$test{'name'}}) {
+ print STDERR "$prog:$test{':long-name'}: warning: duplicate test name ${test{'name'}}\n";
+ }
+ $known_tests{$test{'name'}} = 1;
+
+ return 1;
+}
+
+sub
+tty_msg
+{
+ local($msg) = @_;
+
+ open(TTY, "> /dev/tty") || return 0;
+ print TTY $msg;
+ close(TTY);
+ return 1;
+}
+
+sub
+never_called_funcs
+{
+ return 0;
+ &tty_msg("hi\n");
+ &never_called_funcs();
+ &catch_sigalrm();
+ $old_env{'foo'} = 'bar';
+ $internal_test_fields{'foo'} = 'bar';
+}
+
+sub
+check_file_result
+{
+ local(*test) = @_;
+
+ return '' if (!defined $test{'file-result'});
+
+ local($why) = '';
+ local($i);
+ local($type, $perm, $uid, $gid, $rest, $c, $len, $name);
+ local(@stbuf);
+
+ for ($i = 0; $i < $test{'file-result'}; $i++) {
+ $val = $test{"file-result:$i"};
+
+ # format is: type perm "name"
+ ($type, $perm, $uid, $gid, $matchType, $rest) =
+ split(' ', $val, 6);
+ $c = substr($rest, 0, 1);
+ $len = index($rest, $c, 1) - 1;
+ $name = substr($rest, 1, $len);
+ $rest = substr($rest, 2 + $len);
+ $perm = oct($perm) if $perm =~ /^\d+$/;
+
+ @stbuf = lstat($name);
+ if (!@stbuf) {
+ $why .= "\texpected $type \"$name\" not created\n";
+ next;
+ }
+ if ($perm ne '*' && ($stbuf[2] & 07777) != $perm) {
+ $why .= "\t$type \"$name\" has unexpected permissions\n";
+ $why .= sprintf("\t\texpected 0%o, found 0%o\n",
+ $perm, $stbuf[2] & 07777);
+ }
+ if ($uid ne '*' && $stbuf[4] != $uid) {
+ $why .= "\t$type \"$name\" has unexpected user-id\n";
+ $why .= sprintf("\t\texpected %d, found %d\n",
+ $uid, $stbuf[4]);
+ }
+ if ($gid ne '*' && $stbuf[5] != $gid) {
+ $why .= "\t$type \"$name\" has unexpected group-id\n";
+ $why .= sprintf("\t\texpected %d, found %d\n",
+ $gid, $stbuf[5]);
+ }
+
+ if ($type eq 'file') {
+ if (-l _ || ! -f _) {
+ $why .= "\t$type \"$name\" is not a regular file\n";
+ } else {
+ local $tmp = &check_output($test{'long-name'}, $name,
+ "$type contents in \"$name\"",
+ $matchType eq 'exact' ? $rest : undef
+ $matchType eq 'pattern' ? $rest : undef);
+ return undef if (!defined $tmp);
+ $why .= $tmp;
+ }
+ } elsif ($type eq 'dir') {
+ if ($rest !~ /^\s*$/) {
+ print STDERR "$prog:$test{':long-name'}: file-result test for directory $name should not have content specified\n";
+ return undef;
+ }
+ if (-l _ || ! -d _) {
+ $why .= "\t$type \"$name\" is not a directory\n";
+ }
+ } elsif ($type eq 'symlink') {
+ if (!-l _) {
+ $why .= "\t$type \"$name\" is not a symlink\n";
+ } else {
+ local $content = readlink($name);
+ if (!defined $content) {
+ print STDERR "$prog:$test{':long-name'}: file-result test for $type $name failed - could not readlink - $!\n";
+ return undef;
+ }
+ local $tmp = &compare_output($test{'long-name'},
+ "$type contents in \"$name\"",
+ $matchType eq 'exact' ? $rest : undef
+ $matchType eq 'pattern' ? $rest : undef);
+ return undef if (!defined $tmp);
+ $why .= $tmp;
+ }
+ }
+ }
+
+ return $why;
+}
+
+sub
+HELP_MESSAGE
+{
+ print STDERR $Usage;
+ exit 0;
+}
OSDN Git Service
