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