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 (at] 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 } 1322
