src/check.pl

   1 # $MirOS: src/bin/mksh/check.pl,v 1.42 2015/11/29 17:05:00 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
   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 #                                       PATHSEP is set to either : or ;.
  82 #                                       __progname is set to the -p argument.
  83 #                                       __perlname is set to $^X (perlexe).
  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 # pull EINTR from POSIX.pm or Errno.pm if they exist
 157 # otherwise just skip it
 158 BEGIN {
 159         $EINTR = 0;
 160         eval {
 161                 require POSIX;
 162                 $EINTR = POSIX::EINTR();
 163         };
 164         if ($@) {
 165                 eval {
 166                         require Errno;
 167                         $EINTR = Errno::EINTR();
 168                 } or do {
 169                         $EINTR = 0;
 170                 };
 171         }
 172 };
 173
 174 use Getopt::Std;
 175 use Config;
 176
 177 $os = defined $^O ? $^O : 'unknown';
 178
 179 ($prog = $0) =~ s#.*/##;
 180
 181 $Usage = <<EOF ;
 182 Usage: $prog [-Pv] [-C cat] [-e e=v] [-p prog] [-s fn] [-T dir] \
 183        [-t tmo] name ...
 184         -C c    Specify the comma separated list of categories the program
 185                 belongs to (see category field).
 186         -e e=v  Set the environment variable e to v for all tests
 187                 (if no =v is given, the current value is used)
 188                 Only one -e option can be given at the moment, sadly.
 189         -P      program (-p) string has multiple words, and the program is in
 190                 the path (kludge option)
 191         -p p    Use p as the program to test
 192         -s s    Read tests from file s; if s is a directory, it is recursively
 193                 scaned for test files (which end in .t).
 194         -T dir  Use dir instead of /tmp to hold temporary files
 195         -t t    Use t as default time limit for tests (default is unlimited)
 196         -v      Verbose mode: print reason test failed.
 197         name    specifies the name of the test(s) to run; if none are
 198                 specified, all tests are run.
 199 EOF
 200
 201 # See comment above for flag meanings
 202 %test_fields = (
 203         'name',                         'r',
 204         'description',                  'm',
 205         'arguments',                    'M',
 206         'script',                       'm',
 207         'stdin',                        'm',
 208         'perl-setup',                   'm',
 209         'perl-cleanup',                 'm',
 210         'env-setup',                    'M',
 211         'file-setup',                   'mps',
 212         'file-result',                  'mps',
 213         'time-limit',                   '',
 214         'expected-fail',                '',
 215         'expected-exit',                '',
 216         'expected-stdout',              'm',
 217         'expected-stdout-pattern',      'm',
 218         'expected-stderr',              'm',
 219         'expected-stderr-pattern',      'm',
 220         'category',                     'm',
 221         'need-ctty',                    '',
 222         'need-pass',                    '',
 223         );
 224 # Filled in by read_test()
 225 %internal_test_fields = (
 226         ':full-name', 1,                # file:name
 227         ':long-name', 1,                # dir/file:lineno:name
 228         );
 229
 230 # Categories of the program under test. Provide the current
 231 # os by default.
 232 %categories = (
 233         "os:$os", '1'
 234         );
 235
 236 $nfailed = 0;
 237 $nifailed = 0;
 238 $nxfailed = 0;
 239 $npassed = 0;
 240 $nxpassed = 0;
 241
 242 %known_tests = ();
 243
 244 if (!getopts('C:e:Pp:s:T:t:v')) {
 245     print STDERR $Usage;
 246     exit 1;
 247 }
 248
 249 die "$prog: no program specified (use -p)\n" if !defined $opt_p;
 250 die "$prog: no test set specified (use -s)\n" if !defined $opt_s;
 251 $test_prog = $opt_p;
 252 $verbose = defined $opt_v && $opt_v;
 253 $test_set = $opt_s;
 254 $temp_base = $opt_T || "/tmp";
 255 if (defined $opt_t) {
 256     die "$prog: bad -t argument (should be number > 0): $opt_t\n"
 257         if $opt_t !~ /^\d+$/ || $opt_t <= 0;
 258     $default_time_limit = $opt_t;
 259 }
 260 $program_kludge = defined $opt_P ? $opt_P : 0;
 261
 262 if (defined $opt_C) {
 263     foreach $c (split(',', $opt_C)) {
 264         $c =~ s/\s+//;
 265         die "$prog: categories can't be negated on the command line\n"
 266             if ($c =~ /^!/);
 267         $categories{$c} = 1;
 268     }
 269 }
 270
 271 # Note which tests are to be run.
 272 %do_test = ();
 273 grep($do_test{$_} = 1, @ARGV);
 274 $all_tests = @ARGV == 0;
 275
 276 # Set up a very minimal environment
 277 %new_env = ();
 278 foreach $env (('HOME', 'LD_LIBRARY_PATH', 'LOCPATH', 'LOGNAME',
 279   'PATH', 'SHELL', 'UNIXMODE', 'UNIXROOT', 'USER')) {
 280     $new_env{$env} = $ENV{$env} if defined $ENV{$env};
 281 }
 282 $new_env{'CYGWIN'} = 'nodosfilewarning';
 283 $new_env{'ENV'} = '/nonexistant';
 284 $new_env{'PATHSEP'} = $os eq 'os2' ? ';' : ':';
 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 chop($pwd = `pwd 2>/dev/null`);
 301 die "$prog: couldn't get current working directory\n" if $pwd eq '';
 302 die "$prog: couldn't cd to $pwd - $!\n" if !chdir($pwd);
 303
 304 die "$prog: couldn't cd to $temp_base - $!\n" if !chdir($temp_base);
 305 die "$prog: couldn't get temporary directory base\n" unless -d '.';
 306 $temps = sprintf("chk%d-%d.", $$, time());
 307 $tempi = 0;
 308 until (mkdir(($tempdir = sprintf("%s%03d", $temps, $tempi)), 0700)) {
 309     die "$prog: couldn't get temporary directory\n" if $tempi++ >= 999;
 310 }
 311 die "$prog: couldn't cd to $tempdir - $!\n" if !chdir($tempdir);
 312 chop($temp_dir = `pwd 2>/dev/null`);
 313 die "$prog: couldn't get temporary directory\n" if $temp_dir eq '';
 314 die "$prog: couldn't cd to $pwd - $!\n" if !chdir($pwd);
 315
 316 if (!$program_kludge) {
 317     $test_prog = "$pwd/$test_prog" if (substr($test_prog, 0, 1) ne '/') &&
 318       ($os ne 'os2' || substr($test_prog, 1, 1) ne ':');
 319     die "$prog: $test_prog is not executable - bye\n"
 320       if (! -x $test_prog && $os ne 'os2');
 321 }
 322
 323 @trap_sigs = ('TERM', 'QUIT', 'INT', 'PIPE', 'HUP');
 324 @SIG{@trap_sigs} = ('cleanup_exit') x @trap_sigs;
 325 $child_kill_ok = 0;
 326 $SIG{'ALRM'} = 'catch_sigalrm';
 327
 328 $| = 1;
 329
 330 # Create temp files
 331 $temps = "${temp_dir}/rts";
 332 $tempi = "${temp_dir}/rti";
 333 $tempo = "${temp_dir}/rto";
 334 $tempe = "${temp_dir}/rte";
 335 $tempdir = "${temp_dir}/rtd";
 336 mkdir($tempdir, 0700) or die "$prog: couldn't mkdir $tempdir - $!\n";
 337
 338 if (-d $test_set) {
 339     $file_prefix_skip = length($test_set) + 1;
 340     $ret = &process_test_dir($test_set);
 341 } else {
 342     $file_prefix_skip = 0;
 343     $ret = &process_test_file($test_set);
 344 }
 345 &cleanup_exit() if !defined $ret;
 346
 347 $tot_failed = $nfailed + $nifailed + $nxfailed;
 348 $tot_passed = $npassed + $nxpassed;
 349 if ($tot_failed || $tot_passed) {
 350     print "Total failed: $tot_failed";
 351     print " ($nifailed ignored)" if $nifailed;
 352     print " ($nxfailed unexpected)" if $nxfailed;
 353     print " (as expected)" if $nfailed && !$nxfailed && !$nifailed;
 354     print " ($nfailed expected)" if $nfailed && ($nxfailed || $nifailed);
 355     print "\nTotal passed: $tot_passed";
 356     print " ($nxpassed unexpected)" if $nxpassed;
 357     print "\n";
 358 }
 359
 360 &cleanup_exit('ok');
 361
 362 sub
 363 cleanup_exit
 364 {
 365     local($sig, $exitcode) = ('', 1);
 366
 367     if ($_[0] eq 'ok') {
 368         unless ($nxfailed) {
 369                 $exitcode = 0;
 370         } else {
 371                 $exitcode = 1;
 372         }
 373     } elsif ($_[0] ne '') {
 374         $sig = $_[0];
 375     }
 376
 377     unlink($tempi, $tempo, $tempe, $temps);
 378     &scrub_dir($tempdir) if defined $tempdir;
 379     rmdir($tempdir) if defined $tempdir;
 380     rmdir($temp_dir) if defined $temp_dir;
 381
 382     if ($sig) {
 383         $SIG{$sig} = 'DEFAULT';
 384         kill $sig, $$;
 385         return;
 386     }
 387     exit $exitcode;
 388 }
 389
 390 sub
 391 catch_sigalrm
 392 {
 393     $SIG{'ALRM'} = 'catch_sigalrm';
 394     kill(9, $child_pid) if $child_kill_ok;
 395     $child_killed = 1;
 396 }
 397
 398 sub
 399 process_test_dir
 400 {
 401     local($dir) = @_;
 402     local($ret, $file);
 403     local(@todo) = ();
 404
 405     if (!opendir(DIR, $dir)) {
 406         print STDERR "$prog: can't open directory $dir - $!\n";
 407         return undef;
 408     }
 409     while (defined ($file = readdir(DIR))) {
 410         push(@todo, $file) if $file =~ /^[^.].*\.t$/;
 411     }
 412     closedir(DIR);
 413
 414     foreach $file (@todo) {
 415         $file = "$dir/$file";
 416         if (-d $file) {
 417             $ret = &process_test_dir($file);
 418         } elsif (-f _) {
 419             $ret = &process_test_file($file);
 420         }
 421         last if !defined $ret;
 422     }
 423
 424     return $ret;
 425 }
 426
 427 sub
 428 process_test_file
 429 {
 430     local($file) = @_;
 431     local($ret);
 432
 433     if (!open(IN, $file)) {
 434         print STDERR "$prog: can't open $file - $!\n";
 435         return undef;
 436     }
 437     binmode(IN);
 438     while (1) {
 439         $ret = &read_test($file, IN, *test);
 440         last if !defined $ret || !$ret;
 441         next if !$all_tests && !$do_test{$test{'name'}};
 442         next if !&category_check(*test);
 443         $ret = &run_test(*test);
 444         last if !defined $ret;
 445     }
 446     close(IN);
 447
 448     return $ret;
 449 }
 450
 451 sub
 452 run_test
 453 {
 454     local(*test) = @_;
 455     local($name) = $test{':full-name'};
 456
 457     return undef if !&scrub_dir($tempdir);
 458
 459     if (defined $test{'stdin'}) {
 460         return undef if !&write_file($tempi, $test{'stdin'});
 461         $ifile = $tempi;
 462     } else {
 463         $ifile = '/dev/null';
 464     }
 465
 466     if (defined $test{'script'}) {
 467         return undef if !&write_file($temps, $test{'script'});
 468     }
 469
 470     if (!chdir($tempdir)) {
 471         print STDERR "$prog: couldn't cd to $tempdir - $!\n";
 472         return undef;
 473     }
 474
 475     if (defined $test{'file-setup'}) {
 476         local($i);
 477         local($type, $perm, $rest, $c, $len, $name);
 478
 479         for ($i = 0; $i < $test{'file-setup'}; $i++) {
 480             $val = $test{"file-setup:$i"};
 481
 482             # format is: type perm "name"
 483             ($type, $perm, $rest) =
 484                 split(' ', $val, 3);
 485             $c = substr($rest, 0, 1);
 486             $len = index($rest, $c, 1) - 1;
 487             $name = substr($rest, 1, $len);
 488             $rest = substr($rest, 2 + $len);
 489             $perm = oct($perm) if $perm =~ /^\d+$/;
 490             if ($type eq 'file') {
 491                 return undef if !&write_file($name, $rest);
 492                 if (!chmod($perm, $name)) {
 493                     print STDERR
 494                   "$prog:$test{':long-name'}: can't chmod $perm $name - $!\n";
 495                     return undef;
 496                 }
 497             } elsif ($type eq 'dir') {
 498                 if (!mkdir($name, $perm)) {
 499                     print STDERR
 500                   "$prog:$test{':long-name'}: can't mkdir $perm $name - $!\n";
 501                     return undef;
 502                 }
 503             } elsif ($type eq 'symlink') {
 504                 local($oumask) = umask($perm);
 505                 local($ret) = symlink($rest, $name);
 506                 umask($oumask);
 507                 if (!$ret) {
 508                     print STDERR
 509             "$prog:$test{':long-name'}: couldn't create symlink $name - $!\n";
 510                     return undef;
 511                 }
 512             }
 513         }
 514     }
 515
 516     if (defined $test{'perl-setup'}) {
 517         eval $test{'perl-setup'};
 518         if ($@ ne '') {
 519             print STDERR "$prog:$test{':long-name'}: error running perl-setup - $@\n";
 520             return undef;
 521         }
 522     }
 523
 524     $pid = fork;
 525     if (!defined $pid) {
 526         print STDERR "$prog: can't fork - $!\n";
 527         return undef;
 528     }
 529     if (!$pid) {
 530         @SIG{@trap_sigs} = ('DEFAULT') x @trap_sigs;
 531         $SIG{'ALRM'} = 'DEFAULT';
 532         if (defined $test{'env-setup'}) {
 533             local($var, $val, $i);
 534
 535             foreach $var (split(substr($test{'env-setup'}, 0, 1),
 536                 $test{'env-setup'}))
 537             {
 538                 $i = index($var, '=');
 539                 next if $i == 0 || $var eq '';
 540                 if ($i < 0) {
 541                     delete $new_env{$var};
 542                 } else {
 543                     $new_env{substr($var, 0, $i)} = substr($var, $i + 1);
 544                 }
 545             }
 546         }
 547         if (!open(STDIN, "< $ifile")) {
 548                 print STDERR "$prog: couldn't open $ifile in child - $!\n";
 549                 kill('TERM', $$);
 550         }
 551         binmode(STDIN);
 552         if (!open(STDOUT, "> $tempo")) {
 553                 print STDERR "$prog: couldn't open $tempo in child - $!\n";
 554                 kill('TERM', $$);
 555         }
 556         binmode(STDOUT);
 557         if (!open(STDERR, "> $tempe")) {
 558                 print STDOUT "$prog: couldn't open $tempe in child - $!\n";
 559                 kill('TERM', $$);
 560         }
 561         binmode(STDERR);
 562         if ($program_kludge) {
 563             @argv = split(' ', $test_prog);
 564         } else {
 565             @argv = ($test_prog);
 566         }
 567         if (defined $test{'arguments'}) {
 568                 push(@argv,
 569                      split(substr($test{'arguments'}, 0, 1),
 570                            substr($test{'arguments'}, 1)));
 571         }
 572         push(@argv, $temps) if defined $test{'script'};
 573
 574         #XXX realpathise, use command -v/whence -p/which, or sth. like that
 575         #XXX if !$program_kludge, we get by with not doing it for now tho
 576         $new_env{'__progname'} = $argv[0];
 577
 578         # The following doesn't work with perl5...  Need to do it explicitly - yuck.
 579         #%ENV = %new_env;
 580         foreach $k (keys(%ENV)) {
 581             delete $ENV{$k};
 582         }
 583         $ENV{$k} = $v while ($k,$v) = each %new_env;
 584
 585         exec { $argv[0] } @argv;
 586         print STDERR "$prog: couldn't execute $test_prog - $!\n";
 587         kill('TERM', $$);
 588         exit(95);
 589     }
 590     $child_pid = $pid;
 591     $child_killed = 0;
 592     $child_kill_ok = 1;
 593     alarm($test{'time-limit'}) if defined $test{'time-limit'};
 594     while (1) {
 595         $xpid = waitpid($pid, 0);
 596         $child_kill_ok = 0;
 597         if ($xpid < 0) {
 598             if ($EINTR) {
 599                 next if $! == $EINTR;
 600             }
 601             print STDERR "$prog: error waiting for child - $!\n";
 602             return undef;
 603         }
 604         last;
 605     }
 606     $status = $?;
 607     alarm(0) if defined $test{'time-limit'};
 608
 609     $failed = 0;
 610     $why = '';
 611
 612     if ($child_killed) {
 613         $failed = 1;
 614         $why .= "\ttest timed out (limit of $test{'time-limit'} seconds)\n";
 615     }
 616
 617     $ret = &eval_exit($test{'long-name'}, $status, $test{'expected-exit'});
 618     return undef if !defined $ret;
 619     if (!$ret) {
 620         local($expl);
 621
 622         $failed = 1;
 623         if (($status & 0xff) == 0x7f) {
 624             $expl = "stopped";
 625         } elsif (($status & 0xff)) {
 626             $expl = "signal " . ($status & 0x7f);
 627         } else {
 628             $expl = "exit-code " . (($status >> 8) & 0xff);
 629         }
 630         $why .=
 631         "\tunexpected exit status $status ($expl), expected $test{'expected-exit'}\n";
 632     }
 633
 634     $tmp = &check_output($test{'long-name'}, $tempo, 'stdout',
 635                 $test{'expected-stdout'}, $test{'expected-stdout-pattern'});
 636     return undef if !defined $tmp;
 637     if ($tmp ne '') {
 638         $failed = 1;
 639         $why .= $tmp;
 640     }
 641
 642     $tmp = &check_output($test{'long-name'}, $tempe, 'stderr',
 643                 $test{'expected-stderr'}, $test{'expected-stderr-pattern'});
 644     return undef if !defined $tmp;
 645     if ($tmp ne '') {
 646         $failed = 1;
 647         $why .= $tmp;
 648     }
 649
 650     $tmp = &check_file_result(*test);
 651     return undef if !defined $tmp;
 652     if ($tmp ne '') {
 653         $failed = 1;
 654         $why .= $tmp;
 655     }
 656
 657     if (defined $test{'perl-cleanup'}) {
 658         eval $test{'perl-cleanup'};
 659         if ($@ ne '') {
 660             print STDERR "$prog:$test{':long-name'}: error running perl-cleanup - $@\n";
 661             return undef;
 662         }
 663     }
 664
 665     if (!chdir($pwd)) {
 666         print STDERR "$prog: couldn't cd to $pwd - $!\n";
 667         return undef;
 668     }
 669
 670     if ($failed) {
 671         if (!$test{'expected-fail'}) {
 672             if ($test{'need-pass'}) {
 673                 print "FAIL $name\n";
 674                 $nxfailed++;
 675             } else {
 676                 print "FAIL $name (ignored)\n";
 677                 $nifailed++;
 678             }
 679         } else {
 680             print "fail $name (as expected)\n";
 681             $nfailed++;
 682         }
 683         $why = "\tDescription"
 684                 . &wrap_lines($test{'description'}, " (missing)\n")
 685                 . $why;
 686     } elsif ($test{'expected-fail'}) {
 687         print "PASS $name (unexpectedly)\n";
 688         $nxpassed++;
 689     } else {
 690         print "pass $name\n";
 691         $npassed++;
 692     }
 693     print $why if $verbose;
 694     return 0;
 695 }
 696
 697 sub
 698 category_check
 699 {
 700     local(*test) = @_;
 701     local($c);
 702
 703     return 0 if ($test{'need-ctty'} && defined $categories{'regress:no-ctty'});
 704     return 1 if (!defined $test{'category'});
 705     local($ok) = 0;
 706     foreach $c (split(',', $test{'category'})) {
 707         $c =~ s/\s+//;
 708         if ($c =~ /^!/) {
 709             $c = $';
 710             return 0 if (defined $categories{$c});
 711             $ok = 1;
 712         } else {
 713             $ok = 1 if (defined $categories{$c});
 714         }
 715     }
 716     return $ok;
 717 }
 718
 719 sub
 720 scrub_dir
 721 {
 722     local($dir) = @_;
 723     local(@todo) = ();
 724     local($file);
 725
 726     if (!opendir(DIR, $dir)) {
 727         print STDERR "$prog: couldn't open directory $dir - $!\n";
 728         return undef;
 729     }
 730     while (defined ($file = readdir(DIR))) {
 731         push(@todo, $file) if $file ne '.' && $file ne '..';
 732     }
 733     closedir(DIR);
 734     foreach $file (@todo) {
 735         $file = "$dir/$file";
 736         if (-d $file) {
 737             return undef if !&scrub_dir($file);
 738             if (!rmdir($file)) {
 739                 print STDERR "$prog: couldn't rmdir $file - $!\n";
 740                 return undef;
 741             }
 742         } else {
 743             if (!unlink($file)) {
 744                 print STDERR "$prog: couldn't unlink $file - $!\n";
 745                 return undef;
 746             }
 747         }
 748     }
 749     return 1;
 750 }
 751
 752 sub
 753 write_file
 754 {
 755     local($file, $str) = @_;
 756
 757     if (!open(TEMP, "> $file")) {
 758         print STDERR "$prog: can't open $file - $!\n";
 759         return undef;
 760     }
 761     binmode(TEMP);
 762     print TEMP $str;
 763     if (!close(TEMP)) {
 764         print STDERR "$prog: error writing $file - $!\n";
 765         return undef;
 766     }
 767     return 1;
 768 }
 769
 770 sub
 771 check_output
 772 {
 773     local($name, $file, $what, $expect, $expect_pat) = @_;
 774     local($got) = '';
 775     local($why) = '';
 776     local($ret);
 777
 778     if (!open(TEMP, "< $file")) {
 779         print STDERR "$prog:$name($what): couldn't open $file after running program - $!\n";
 780         return undef;
 781     }
 782     binmode(TEMP);
 783     while (<TEMP>) {
 784         $got .= $_;
 785     }
 786     close(TEMP);
 787     return compare_output($name, $what, $expect, $expect_pat, $got);
 788 }
 789
 790 sub
 791 compare_output
 792 {
 793     local($name, $what, $expect, $expect_pat, $got) = @_;
 794     local($why) = '';
 795
 796     if (defined $expect_pat) {
 797         $_ = $got;
 798         $ret = eval "$expect_pat";
 799         if ($@ ne '') {
 800             print STDERR "$prog:$name($what): error evaluating $what pattern: $expect_pat - $@\n";
 801             return undef;
 802         }
 803         if (!$ret) {
 804             $why = "\tunexpected $what - wanted pattern";
 805             $why .= &wrap_lines($expect_pat);
 806             $why .= "\tgot";
 807             $why .= &wrap_lines($got);
 808         }
 809     } else {
 810         $expect = '' if !defined $expect;
 811         if ($got ne $expect) {
 812             $why .= "\tunexpected $what - " . &first_diff($expect, $got) . "\n";
 813             $why .= "\twanted";
 814             $why .= &wrap_lines($expect);
 815             $why .= "\tgot";
 816             $why .= &wrap_lines($got);
 817         }
 818     }
 819     return $why;
 820 }
 821
 822 sub
 823 wrap_lines
 824 {
 825     local($str, $empty) = @_;
 826     local($nonl) = substr($str, -1, 1) ne "\n";
 827
 828     return (defined $empty ? $empty : " nothing\n") if $str eq '';
 829     substr($str, 0, 0) = ":\n";
 830     $str =~ s/\n/\n\t\t/g;
 831     if ($nonl) {
 832         $str .= "\n\t[incomplete last line]\n";
 833     } else {
 834         chop($str);
 835         chop($str);
 836     }
 837     return $str;
 838 }
 839
 840 sub
 841 first_diff
 842 {
 843     local($exp, $got) = @_;
 844     local($lineno, $char) = (1, 1);
 845     local($i, $exp_len, $got_len);
 846     local($ce, $cg);
 847
 848     $exp_len = length($exp);
 849     $got_len = length($got);
 850     if ($exp_len != $got_len) {
 851         if ($exp_len < $got_len) {
 852             if (substr($got, 0, $exp_len) eq $exp) {
 853                 return "got too much output";
 854             }
 855         } elsif (substr($exp, 0, $got_len) eq $got) {
 856             return "got too little output";
 857         }
 858     }
 859     for ($i = 0; $i < $exp_len; $i++) {
 860         $ce = substr($exp, $i, 1);
 861         $cg = substr($got, $i, 1);
 862         last if $ce ne $cg;
 863         $char++;
 864         if ($ce eq "\n") {
 865             $lineno++;
 866             $char = 1;
 867         }
 868     }
 869     return "first difference: line $lineno, char $char (wanted '"
 870         . &format_char($ce) . "', got '"
 871         . &format_char($cg) . "'";
 872 }
 873
 874 sub
 875 format_char
 876 {
 877     local($ch, $s);
 878
 879     $ch = ord($_[0]);
 880     if ($ch == 10) {
 881         return '\n';
 882     } elsif ($ch == 13) {
 883         return '\r';
 884     } elsif ($ch == 8) {
 885         return '\b';
 886     } elsif ($ch == 9) {
 887         return '\t';
 888     } elsif ($ch > 127) {
 889         $ch -= 127;
 890         $s = "M-";
 891     } else {
 892         $s = '';
 893     }
 894     if ($ch < 32) {
 895         $s .= '^';
 896         $ch += ord('@');
 897     } elsif ($ch == 127) {
 898         return $s . "^?";
 899     }
 900     return $s . sprintf("%c", $ch);
 901 }
 902
 903 sub
 904 eval_exit
 905 {
 906     local($name, $status, $expect) = @_;
 907     local($expr);
 908     local($w, $e, $s) = ($status, ($status >> 8) & 0xff, $status & 0x7f);
 909
 910     $e = -1000 if $status & 0xff;
 911     $s = -1000 if $s == 0x7f;
 912     if (!defined $expect) {
 913         $expr = '$w == 0';
 914     } elsif ($expect =~ /^(|-)\d+$/) {
 915         $expr = "\$e == $expect";
 916     } else {
 917         $expr = $expect;
 918         $expr =~ s/\b([wse])\b/\$$1/g;
 919         $expr =~ s/\b(SIG[A-Z][A-Z0-9]*)\b/&$1/g;
 920     }
 921     $w = eval $expr;
 922     if ($@ ne '') {
 923         print STDERR "$prog:$test{':long-name'}: bad expected-exit expression: $expect ($@)\n";
 924         return undef;
 925     }
 926     return $w;
 927 }
 928
 929 sub
 930 read_test
 931 {
 932     local($file, $in, *test) = @_;
 933     local($field, $val, $flags, $do_chop, $need_redo, $start_lineno);
 934     local(%cnt, $sfield);
 935
 936     %test = ();
 937     %cnt = ();
 938     while (<$in>) {
 939         chop;
 940         next if /^\s*$/;
 941         next if /^ *#/;
 942         last if /^\s*---\s*$/;
 943         $start_lineno = $. if !defined $start_lineno;
 944         if (!/^([-\w]+):\s*(|\S|\S.*\S)\s*$/) {
 945             print STDERR "$prog:$file:$.: unrecognised line \"$_\"\n";
 946             return undef;
 947         }
 948         ($field, $val) = ($1, $2);
 949         $sfield = $field;
 950         $flags = $test_fields{$field};
 951         if (!defined $flags) {
 952             print STDERR "$prog:$file:$.: unrecognised field \"$field\"\n";
 953             return undef;
 954         }
 955         if ($flags =~ /s/) {
 956             local($cnt) = $cnt{$field}++;
 957             $test{$field} = $cnt{$field};
 958             $cnt = 0 if $cnt eq '';
 959             $sfield .= ":$cnt";
 960         } elsif (defined $test{$field}) {
 961             print STDERR "$prog:$file:$.: multiple \"$field\" fields\n";
 962             return undef;
 963         }
 964         $do_chop = $flags !~ /m/;
 965         $need_redo = 0;
 966         if ($val eq '' || $val eq '!' || $flags =~ /p/) {
 967             if ($flags =~ /[Mm]/) {
 968                 if ($flags =~ /p/) {
 969                     if ($val =~ /^!/) {
 970                         $do_chop = 1;
 971                         $val = $';
 972                     } else {
 973                         $do_chop = 0;
 974                     }
 975                     if ($val eq '') {
 976                         print STDERR
 977                 "$prog:$file:$.: no parameters given for field \"$field\"\n";
 978                         return undef;
 979                     }
 980                 } else {
 981                     if ($val eq '!') {
 982                         $do_chop = 1;
 983                     }
 984                     $val = '';
 985                 }
 986                 while (<$in>) {
 987                     last if !/^\t/;
 988                     $val .= $';
 989                 }
 990                 chop $val if $do_chop;
 991                 $do_chop = 1;
 992                 $need_redo = 1;
 993
 994                 # Syntax check on fields that can several instances
 995                 # (can give useful line numbers this way)
 996
 997                 if ($field eq 'file-setup') {
 998                     local($type, $perm, $rest, $c, $len, $name);
 999
1000                     # format is: type perm "name"
1001                     if ($val !~ /^[ \t]*(\S+)[ \t]+(\S+)[ \t]+([^ \t].*)/) {
1002                         print STDERR
1003                     "$prog:$file:$.: bad parameter line for file-setup field\n";
1004                         return undef;
1005                     }
1006                     ($type, $perm, $rest) = ($1, $2, $3);
1007                     if ($type !~ /^(file|dir|symlink)$/) {
1008                         print STDERR
1009                     "$prog:$file:$.: bad file type for file-setup: $type\n";
1010                         return undef;
1011                     }
1012                     if ($perm !~ /^\d+$/) {
1013                         print STDERR
1014                     "$prog:$file:$.: bad permissions for file-setup: $type\n";
1015                         return undef;
1016                     }
1017                     $c = substr($rest, 0, 1);
1018                     if (($len = index($rest, $c, 1) - 1) <= 0) {
1019                         print STDERR
1020     "$prog:$file:$.: missing end quote for file name in file-setup: $rest\n";
1021                         return undef;
1022                     }
1023                     $name = substr($rest, 1, $len);
1024                     if ($name =~ /^\// || $name =~ /(^|\/)\.\.(\/|$)/) {
1025                         # Note: this is not a security thing - just a sanity
1026                         # check - a test can still use symlinks to get at files
1027                         # outside the test directory.
1028                         print STDERR
1029 "$prog:$file:$.: file name in file-setup is absolute or contains ..: $name\n";
1030                         return undef;
1031                     }
1032                 }
1033                 if ($field eq 'file-result') {
1034                     local($type, $perm, $uid, $gid, $matchType,
1035                           $rest, $c, $len, $name);
1036
1037                     # format is: type perm uid gid matchType "name"
1038                     if ($val !~ /^\s*(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S.*)/) {
1039                         print STDERR
1040                     "$prog:$file:$.: bad parameter line for file-result field\n";
1041                         return undef;
1042                     }
1043                     ($type, $perm, $uid, $gid, $matchType, $rest)
1044                         = ($1, $2, $3, $4, $5, $6);
1045                     if ($type !~ /^(file|dir|symlink)$/) {
1046                         print STDERR
1047                     "$prog:$file:$.: bad file type for file-result: $type\n";
1048                         return undef;
1049                     }
1050                     if ($perm !~ /^\d+$/ && $perm ne '*') {
1051                         print STDERR
1052                     "$prog:$file:$.: bad permissions for file-result: $perm\n";
1053                         return undef;
1054                     }
1055                     if ($uid !~ /^\d+$/ && $uid ne '*') {
1056                         print STDERR
1057                     "$prog:$file:$.: bad user-id for file-result: $uid\n";
1058                         return undef;
1059                     }
1060                     if ($gid !~ /^\d+$/ && $gid ne '*') {
1061                         print STDERR
1062                     "$prog:$file:$.: bad group-id for file-result: $gid\n";
1063                         return undef;
1064                     }
1065                     if ($matchType !~ /^(exact|pattern)$/) {
1066                         print STDERR
1067                 "$prog:$file:$.: bad match type for file-result: $matchType\n";
1068                         return undef;
1069                     }
1070                     $c = substr($rest, 0, 1);
1071                     if (($len = index($rest, $c, 1) - 1) <= 0) {
1072                         print STDERR
1073     "$prog:$file:$.: missing end quote for file name in file-result: $rest\n";
1074                         return undef;
1075                     }
1076                     $name = substr($rest, 1, $len);
1077                     if ($name =~ /^\// || $name =~ /(^|\/)\.\.(\/|$)/) {
1078                         # Note: this is not a security thing - just a sanity
1079                         # check - a test can still use symlinks to get at files
1080                         # outside the test directory.
1081                         print STDERR
1082 "$prog:$file:$.: file name in file-result is absolute or contains ..: $name\n";
1083                         return undef;
1084                     }
1085                 }
1086             } elsif ($val eq '') {
1087                 print STDERR
1088                     "$prog:$file:$.: no value given for field \"$field\"\n";
1089                 return undef;
1090             }
1091         }
1092         $val .= "\n" if !$do_chop;
1093         $test{$sfield} = $val;
1094         redo if $need_redo;
1095     }
1096     if ($_ eq '') {
1097         if (%test) {
1098             print STDERR
1099               "$prog:$file:$start_lineno: end-of-file while reading test\n";
1100             return undef;
1101         }
1102         return 0;
1103     }
1104
1105     while (($field, $val) = each %test_fields) {
1106         if ($val =~ /r/ && !defined $test{$field}) {
1107             print STDERR
1108               "$prog:$file:$start_lineno: required field \"$field\" missing\n";
1109             return undef;
1110         }
1111     }
1112
1113     $test{':full-name'} = substr($file, $file_prefix_skip) . ":$test{'name'}";
1114     $test{':long-name'} = "$file:$start_lineno:$test{'name'}";
1115
1116     # Syntax check on specific fields
1117     if (defined $test{'expected-fail'}) {
1118         if ($test{'expected-fail'} !~ /^(yes|no)$/) {
1119             print STDERR
1120               "$prog:$test{':long-name'}: bad value for expected-fail field\n";
1121             return undef;
1122         }
1123         $test{'expected-fail'} = $1 eq 'yes';
1124     } else {
1125         $test{'expected-fail'} = 0;
1126     }
1127     if (defined $test{'need-ctty'}) {
1128         if ($test{'need-ctty'} !~ /^(yes|no)$/) {
1129             print STDERR
1130               "$prog:$test{':long-name'}: bad value for need-ctty field\n";
1131             return undef;
1132         }
1133         $test{'need-ctty'} = $1 eq 'yes';
1134     } else {
1135         $test{'need-ctty'} = 0;
1136     }
1137     if (defined $test{'need-pass'}) {
1138         if ($test{'need-pass'} !~ /^(yes|no)$/) {
1139             print STDERR
1140               "$prog:$test{':long-name'}: bad value for need-pass field\n";
1141             return undef;
1142         }
1143         $test{'need-pass'} = $1 eq 'yes';
1144     } else {
1145         $test{'need-pass'} = 1;
1146     }
1147     if (defined $test{'arguments'}) {
1148         local($firstc) = substr($test{'arguments'}, 0, 1);
1149
1150         if (substr($test{'arguments'}, -1, 1) ne $firstc) {
1151             print STDERR "$prog:$test{':long-name'}: arguments field doesn't start and end with the same character\n";
1152             return undef;
1153         }
1154     }
1155     if (defined $test{'env-setup'}) {
1156         local($firstc) = substr($test{'env-setup'}, 0, 1);
1157
1158         if (substr($test{'env-setup'}, -1, 1) ne $firstc) {
1159             print STDERR "$prog:$test{':long-name'}: env-setup field doesn't start and end with the same character\n";
1160             return undef;
1161         }
1162     }
1163     if (defined $test{'expected-exit'}) {
1164         local($val) = $test{'expected-exit'};
1165
1166         if ($val =~ /^(|-)\d+$/) {
1167             if ($val < 0 || $val > 255) {
1168                 print STDERR "$prog:$test{':long-name'}: expected-exit value $val not in 0..255\n";
1169                 return undef;
1170             }
1171         } elsif ($val !~ /^([\s\d<>+=*%\/&|!()-]|\b[wse]\b|\bSIG[A-Z][A-Z0-9]*\b)+$/) {
1172             print STDERR "$prog:$test{':long-name'}: bad expected-exit expression: $val\n";
1173             return undef;
1174         }
1175     } else {
1176         $test{'expected-exit'} = 0;
1177     }
1178     if (defined $test{'expected-stdout'}
1179         && defined $test{'expected-stdout-pattern'})
1180     {
1181         print STDERR "$prog:$test{':long-name'}: can't use both expected-stdout and expected-stdout-pattern\n";
1182         return undef;
1183     }
1184     if (defined $test{'expected-stderr'}
1185         && defined $test{'expected-stderr-pattern'})
1186     {
1187         print STDERR "$prog:$test{':long-name'}: can't use both expected-stderr and expected-stderr-pattern\n";
1188         return undef;
1189     }
1190     if (defined $test{'time-limit'}) {
1191         if ($test{'time-limit'} !~ /^\d+$/ || $test{'time-limit'} == 0) {
1192             print STDERR
1193               "$prog:$test{':long-name'}: bad value for time-limit field\n";
1194             return undef;
1195         }
1196     } elsif (defined $default_time_limit) {
1197         $test{'time-limit'} = $default_time_limit;
1198     }
1199
1200     if (defined $known_tests{$test{'name'}}) {
1201         print STDERR "$prog:$test{':long-name'}: warning: duplicate test name ${test{'name'}}\n";
1202     }
1203     $known_tests{$test{'name'}} = 1;
1204
1205     return 1;
1206 }
1207
1208 sub
1209 tty_msg
1210 {
1211     local($msg) = @_;
1212
1213     open(TTY, "> /dev/tty") || return 0;
1214     print TTY $msg;
1215     close(TTY);
1216     return 1;
1217 }
1218
1219 sub
1220 never_called_funcs
1221 {
1222         return 0;
1223         &tty_msg("hi\n");
1224         &never_called_funcs();
1225         &catch_sigalrm();
1226         $old_env{'foo'} = 'bar';
1227         $internal_test_fields{'foo'} = 'bar';
1228 }
1229
1230 sub
1231 check_file_result
1232 {
1233     local(*test) = @_;
1234
1235     return '' if (!defined $test{'file-result'});
1236
1237     local($why) = '';
1238     local($i);
1239     local($type, $perm, $uid, $gid, $rest, $c, $len, $name);
1240     local(@stbuf);
1241
1242     for ($i = 0; $i < $test{'file-result'}; $i++) {
1243         $val = $test{"file-result:$i"};
1244
1245         # format is: type perm "name"
1246         ($type, $perm, $uid, $gid, $matchType, $rest) =
1247             split(' ', $val, 6);
1248         $c = substr($rest, 0, 1);
1249         $len = index($rest, $c, 1) - 1;
1250         $name = substr($rest, 1, $len);
1251         $rest = substr($rest, 2 + $len);
1252         $perm = oct($perm) if $perm =~ /^\d+$/;
1253
1254         @stbuf = lstat($name);
1255         if (!@stbuf) {
1256             $why .= "\texpected $type \"$name\" not created\n";
1257             next;
1258         }
1259         if ($perm ne '*' && ($stbuf[2] & 07777) != $perm) {
1260             $why .= "\t$type \"$name\" has unexpected permissions\n";
1261             $why .= sprintf("\t\texpected 0%o, found 0%o\n",
1262                     $perm, $stbuf[2] & 07777);
1263         }
1264         if ($uid ne '*' && $stbuf[4] != $uid) {
1265             $why .= "\t$type \"$name\" has unexpected user-id\n";
1266             $why .= sprintf("\t\texpected %d, found %d\n",
1267                     $uid, $stbuf[4]);
1268         }
1269         if ($gid ne '*' && $stbuf[5] != $gid) {
1270             $why .= "\t$type \"$name\" has unexpected group-id\n";
1271             $why .= sprintf("\t\texpected %d, found %d\n",
1272                     $gid, $stbuf[5]);
1273         }
1274
1275         if ($type eq 'file') {
1276             if (-l _ || ! -f _) {
1277                 $why .= "\t$type \"$name\" is not a regular file\n";
1278             } else {
1279                 local $tmp = &check_output($test{'long-name'}, $name,
1280                             "$type contents in \"$name\"",
1281                             $matchType eq 'exact' ? $rest : undef
1282                             $matchType eq 'pattern' ? $rest : undef);
1283                 return undef if (!defined $tmp);
1284                 $why .= $tmp;
1285             }
1286         } elsif ($type eq 'dir') {
1287             if ($rest !~ /^\s*$/) {
1288                 print STDERR "$prog:$test{':long-name'}: file-result test for directory $name should not have content specified\n";
1289                 return undef;
1290             }
1291             if (-l _ || ! -d _) {
1292                 $why .= "\t$type \"$name\" is not a directory\n";
1293             }
1294         } elsif ($type eq 'symlink') {
1295             if (!-l _) {
1296                 $why .= "\t$type \"$name\" is not a symlink\n";
1297             } else {
1298                 local $content = readlink($name);
1299                 if (!defined $content) {
1300                     print STDERR "$prog:$test{':long-name'}: file-result test for $type $name failed - could not readlink - $!\n";
1301                     return undef;
1302                 }
1303                 local $tmp = &compare_output($test{'long-name'},
1304                             "$type contents in \"$name\"",
1305                             $matchType eq 'exact' ? $rest : undef
1306                             $matchType eq 'pattern' ? $rest : undef);
1307                 return undef if (!defined $tmp);
1308                 $why .= $tmp;
1309             }
1310         }
1311     }
1312
1313     return $why;
1314 }
1315
1316 sub
1317 HELP_MESSAGE
1318 {
1319     print STDERR $Usage;
1320     exit 0;
1321 }