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