7330970bfa
calls in Build.sh, we need HOSTCC for that… which we should do, using BER or something encoded for integers, and pregenerated hashtables as planned) also, bump to R50 beta, due to today’s language changes
1318 lines
34 KiB
Perl
1318 lines
34 KiB
Perl
# $MirOS: src/bin/mksh/check.pl,v 1.36 2014/06/09 13:25:50 tg Exp $
|
|
# $OpenBSD: th,v 1.1 2013/12/02 20:39:44 millert Exp $
|
|
#-
|
|
# Copyright (c) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2011,
|
|
# 2012, 2013, 2014
|
|
# 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, UNIXMODE,
|
|
# USER
|
|
# (values taken from the environment of
|
|
# the test harness).
|
|
# CYGWIN is set to nodosfilewarning.
|
|
# 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).
|
|
# need-ctty 'yes' if the test needs a ctty, run
|
|
# with -C regress:no-ctty to disable.
|
|
# 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.
|
|
|
|
# pull EINTR from POSIX.pm or Errno.pm if they exist
|
|
# otherwise just skip it
|
|
BEGIN {
|
|
$EINTR = 0;
|
|
eval {
|
|
require POSIX;
|
|
$EINTR = POSIX::EINTR();
|
|
};
|
|
if ($@) {
|
|
eval {
|
|
require Errno;
|
|
$EINTR = Errno::EINTR();
|
|
} or do {
|
|
$EINTR = 0;
|
|
};
|
|
}
|
|
};
|
|
|
|
use Getopt::Std;
|
|
use Config;
|
|
|
|
$os = defined $^O ? $^O : 'unknown';
|
|
|
|
($prog = $0) =~ s#.*/##;
|
|
|
|
$Usage = <<EOF ;
|
|
Usage: $prog [-Pv] [-C cat] [-e e=v] [-p prog] [-s fn] [-T dir] \
|
|
[-t tmo] name ...
|
|
-C c Specify the comma separated list of categories the program
|
|
belongs to (see category field).
|
|
-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.
|
|
-P program (-p) string has multiple words, and the program is in
|
|
the path (kludge option)
|
|
-p p Use p as the program to test
|
|
-s s Read tests from file s; if s is a directory, it is recursively
|
|
scaned for test files (which end in .t).
|
|
-T dir Use dir instead of /tmp to hold temporary files
|
|
-t t Use t as default time limit for tests (default is unlimited)
|
|
-v Verbose mode: print reason test failed.
|
|
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',
|
|
'need-ctty', '',
|
|
'need-pass', '',
|
|
);
|
|
# 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'
|
|
);
|
|
|
|
$nfailed = 0;
|
|
$nifailed = 0;
|
|
$nxfailed = 0;
|
|
$npassed = 0;
|
|
$nxpassed = 0;
|
|
|
|
%known_tests = ();
|
|
|
|
if (!getopts('C:e:Pp:s:T:t:v')) {
|
|
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;
|
|
$temp_base = $opt_T || "/tmp";
|
|
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', 'UNIXMODE', 'USER')) {
|
|
$new_env{$env} = $ENV{$env} if defined $ENV{$env};
|
|
}
|
|
$new_env{'CYGWIN'} = 'nodosfilewarning';
|
|
$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;
|
|
|
|
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);
|
|
|
|
die "$prog: couldn't cd to $temp_base - $!\n" if !chdir($temp_base);
|
|
die "$prog: couldn't get temporary directory base\n" unless -d '.';
|
|
$temps = sprintf("chk%d-%d.", $$, time());
|
|
$tempi = 0;
|
|
until (mkdir(($tempdir = sprintf("%s%03d", $temps, $tempi)), 0700)) {
|
|
die "$prog: couldn't get temporary directory\n" if $tempi++ >= 999;
|
|
}
|
|
die "$prog: couldn't cd to $tempdir - $!\n" if !chdir($tempdir);
|
|
chop($temp_dir = `pwd 2>/dev/null`);
|
|
die "$prog: couldn't get temporary directory\n" if $temp_dir 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;
|
|
|
|
# Create temp files
|
|
$temps = "${temp_dir}/rts";
|
|
$tempi = "${temp_dir}/rti";
|
|
$tempo = "${temp_dir}/rto";
|
|
$tempe = "${temp_dir}/rte";
|
|
$tempdir = "${temp_dir}/rtd";
|
|
mkdir($tempdir, 0700) or die "$prog: couldn't mkdir $tempdir - $!\n";
|
|
|
|
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 + $nifailed + $nxfailed;
|
|
$tot_passed = $npassed + $nxpassed;
|
|
if ($tot_failed || $tot_passed) {
|
|
print "Total failed: $tot_failed";
|
|
print " ($nifailed ignored)" if $nifailed;
|
|
print " ($nxfailed unexpected)" if $nxfailed;
|
|
print " (as expected)" if $nfailed && !$nxfailed && !$nifailed;
|
|
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') {
|
|
unless ($nxfailed) {
|
|
$exitcode = 0;
|
|
} else {
|
|
$exitcode = 1;
|
|
}
|
|
} elsif ($_[0] ne '') {
|
|
$sig = $_[0];
|
|
}
|
|
|
|
unlink($tempi, $tempo, $tempe, $temps);
|
|
&scrub_dir($tempdir) if defined $tempdir;
|
|
rmdir($tempdir) if defined $tempdir;
|
|
rmdir($temp_dir) if defined $temp_dir;
|
|
|
|
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'};
|
|
|
|
return undef if !&scrub_dir($tempdir);
|
|
|
|
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'});
|
|
}
|
|
|
|
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) {
|
|
if ($EINTR) {
|
|
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'}) {
|
|
if ($test{'need-pass'}) {
|
|
print "FAIL $name\n";
|
|
$nxfailed++;
|
|
} else {
|
|
print "FAIL $name (ignored)\n";
|
|
$nifailed++;
|
|
}
|
|
} 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 0 if ($test{'need-ctty'} && defined $categories{'regress:no-ctty'});
|
|
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-Z][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>) {
|
|
chop;
|
|
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{'need-ctty'}) {
|
|
if ($test{'need-ctty'} !~ /^(yes|no)$/) {
|
|
print STDERR
|
|
"$prog:$test{':long-name'}: bad value for need-ctty field\n";
|
|
return undef;
|
|
}
|
|
$test{'need-ctty'} = $1 eq 'yes';
|
|
} else {
|
|
$test{'need-ctty'} = 0;
|
|
}
|
|
if (defined $test{'need-pass'}) {
|
|
if ($test{'need-pass'} !~ /^(yes|no)$/) {
|
|
print STDERR
|
|
"$prog:$test{':long-name'}: bad value for need-pass field\n";
|
|
return undef;
|
|
}
|
|
$test{'need-pass'} = $1 eq 'yes';
|
|
} else {
|
|
$test{'need-pass'} = 1;
|
|
}
|
|
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-Z][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;
|
|
}
|