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