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