src/check.pl

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