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