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