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