src/check.pl

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