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