mirror of
https://git.savannah.gnu.org/git/make.git
synced 2024-10-23 20:59:55 +00:00
43d81ff866
Allows the user to reset the prefix character for introducing recipe lines from the default (tab) to any other single character, and back again. Also, reworked the manual to consistently use the word "recipe" to describe the set of commands we use to update a target, instead of the various phrases used in the past: "commands", "command lines", "command scripts", etc.
1218 lines
30 KiB
Perl
1218 lines
30 KiB
Perl
#!/usr/bin/perl
|
|
# -*-perl-*-
|
|
#
|
|
# Modification history:
|
|
# Written 91-12-02 through 92-01-01 by Stephen McGee.
|
|
# Modified 92-02-11 through 92-02-22 by Chris Arthur to further generalize.
|
|
#
|
|
# Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
|
|
# 2001, 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
|
|
# This file is part of GNU Make.
|
|
#
|
|
# GNU Make is free software; you can redistribute it and/or modify it under
|
|
# the terms of the GNU General Public License as published by the Free Software
|
|
# Foundation; either version 3 of the License, or (at your option) any later
|
|
# version.
|
|
#
|
|
# GNU Make is distributed in the hope that it will be useful, but WITHOUT ANY
|
|
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
|
|
# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
|
|
# details.
|
|
#
|
|
# You should have received a copy of the GNU General Public License along with
|
|
# this program. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
|
|
# Test driver routines used by a number of test suites, including
|
|
# those for SCS, make, roll_dir, and scan_deps (?).
|
|
#
|
|
# this routine controls the whole mess; each test suite sets up a few
|
|
# variables and then calls &toplevel, which does all the real work.
|
|
|
|
# $Id$
|
|
|
|
|
|
# The number of test categories we've run
|
|
$categories_run = 0;
|
|
# The number of test categroies that have passed
|
|
$categories_passed = 0;
|
|
# The total number of individual tests that have been run
|
|
$total_tests_run = 0;
|
|
# The total number of individual tests that have passed
|
|
$total_tests_passed = 0;
|
|
# The number of tests in this category that have been run
|
|
$tests_run = 0;
|
|
# The number of tests in this category that have passed
|
|
$tests_passed = 0;
|
|
|
|
|
|
# Yeesh. This whole test environment is such a hack!
|
|
$test_passed = 1;
|
|
|
|
|
|
# Timeout in seconds. If the test takes longer than this we'll fail it.
|
|
$test_timeout = 5;
|
|
|
|
|
|
# %makeENV is the cleaned-out environment.
|
|
%makeENV = ();
|
|
|
|
# %extraENV are any extra environment variables the tests might want to set.
|
|
# These are RESET AFTER EVERY TEST!
|
|
%extraENV = ();
|
|
|
|
# %origENV is the caller's original environment
|
|
%origENV = %ENV;
|
|
|
|
sub resetENV
|
|
{
|
|
# We used to say "%ENV = ();" but this doesn't work in Perl 5.000
|
|
# through Perl 5.004. It was fixed in Perl 5.004_01, but we don't
|
|
# want to require that here, so just delete each one individually.
|
|
foreach $v (keys %ENV) {
|
|
delete $ENV{$v};
|
|
}
|
|
|
|
%ENV = %makeENV;
|
|
foreach $v (keys %extraENV) {
|
|
$ENV{$v} = $extraENV{$v};
|
|
delete $extraENV{$v};
|
|
}
|
|
}
|
|
|
|
sub toplevel
|
|
{
|
|
# Pull in benign variables from the user's environment
|
|
|
|
foreach (# UNIX-specific things
|
|
'TZ', 'TMPDIR', 'HOME', 'USER', 'LOGNAME', 'PATH',
|
|
# Purify things
|
|
'PURIFYOPTIONS',
|
|
# Windows NT-specific stuff
|
|
'Path', 'SystemRoot',
|
|
# DJGPP-specific stuff
|
|
'DJDIR', 'DJGPP', 'SHELL', 'COMSPEC', 'HOSTNAME', 'LFN',
|
|
'FNCASE', '387', 'EMU387', 'GROUP'
|
|
) {
|
|
$makeENV{$_} = $ENV{$_} if $ENV{$_};
|
|
}
|
|
|
|
# Make sure our compares are not foiled by locale differences
|
|
|
|
$makeENV{LC_ALL} = 'C';
|
|
|
|
# Replace the environment with the new one
|
|
#
|
|
%origENV = %ENV;
|
|
|
|
resetENV();
|
|
|
|
$| = 1; # unbuffered output
|
|
|
|
$debug = 0; # debug flag
|
|
$profile = 0; # profiling flag
|
|
$verbose = 0; # verbose mode flag
|
|
$detail = 0; # detailed verbosity
|
|
$keep = 0; # keep temp files around
|
|
$workdir = "work"; # The directory where the test will start running
|
|
$scriptdir = "scripts"; # The directory where we find the test scripts
|
|
$tmpfilesuffix = "t"; # the suffix used on tmpfiles
|
|
$default_output_stack_level = 0; # used by attach_default_output, etc.
|
|
$default_input_stack_level = 0; # used by attach_default_input, etc.
|
|
$cwd = "."; # don't we wish we knew
|
|
$cwdslash = ""; # $cwd . $pathsep, but "" rather than "./"
|
|
|
|
&get_osname; # sets $osname, $vos, $pathsep, and $short_filenames
|
|
|
|
&set_defaults; # suite-defined
|
|
|
|
&parse_command_line (@ARGV);
|
|
|
|
print "OS name = `$osname'\n" if $debug;
|
|
|
|
$workpath = "$cwdslash$workdir";
|
|
$scriptpath = "$cwdslash$scriptdir";
|
|
|
|
&set_more_defaults; # suite-defined
|
|
|
|
&print_banner;
|
|
|
|
if (-d $workpath)
|
|
{
|
|
print "Clearing $workpath...\n";
|
|
&remove_directory_tree("$workpath/")
|
|
|| &error ("Couldn't wipe out $workpath\n");
|
|
}
|
|
else
|
|
{
|
|
mkdir ($workpath, 0777) || &error ("Couldn't mkdir $workpath: $!\n");
|
|
}
|
|
|
|
if (!-d $scriptpath)
|
|
{
|
|
&error ("Failed to find $scriptpath containing perl test scripts.\n");
|
|
}
|
|
|
|
if (@TESTS)
|
|
{
|
|
print "Making work dirs...\n";
|
|
foreach $test (@TESTS)
|
|
{
|
|
if ($test =~ /^([^\/]+)\//)
|
|
{
|
|
$dir = $1;
|
|
push (@rmdirs, $dir);
|
|
-d "$workpath/$dir"
|
|
|| mkdir ("$workpath/$dir", 0777)
|
|
|| &error ("Couldn't mkdir $workpath/$dir: $!\n");
|
|
}
|
|
}
|
|
}
|
|
else
|
|
{
|
|
print "Finding tests...\n";
|
|
opendir (SCRIPTDIR, $scriptpath)
|
|
|| &error ("Couldn't opendir $scriptpath: $!\n");
|
|
@dirs = grep (!/^(\..*|CVS|RCS)$/, readdir (SCRIPTDIR) );
|
|
closedir (SCRIPTDIR);
|
|
foreach $dir (@dirs)
|
|
{
|
|
next if ($dir =~ /^(\..*|CVS|RCS)$/ || ! -d "$scriptpath/$dir");
|
|
push (@rmdirs, $dir);
|
|
mkdir ("$workpath/$dir", 0777)
|
|
|| &error ("Couldn't mkdir $workpath/$dir: $!\n");
|
|
opendir (SCRIPTDIR, "$scriptpath/$dir")
|
|
|| &error ("Couldn't opendir $scriptpath/$dir: $!\n");
|
|
@files = grep (!/^(\..*|CVS|RCS|.*~)$/, readdir (SCRIPTDIR) );
|
|
closedir (SCRIPTDIR);
|
|
foreach $test (@files)
|
|
{
|
|
-d $test and next;
|
|
push (@TESTS, "$dir/$test");
|
|
}
|
|
}
|
|
}
|
|
|
|
if (@TESTS == 0)
|
|
{
|
|
&error ("\nNo tests in $scriptpath, and none were specified.\n");
|
|
}
|
|
|
|
print "\n";
|
|
|
|
&run_each_test;
|
|
|
|
foreach $dir (@rmdirs)
|
|
{
|
|
rmdir ("$workpath/$dir");
|
|
}
|
|
|
|
$| = 1;
|
|
|
|
$categories_failed = $categories_run - $categories_passed;
|
|
$total_tests_failed = $total_tests_run - $total_tests_passed;
|
|
|
|
if ($total_tests_failed)
|
|
{
|
|
print "\n$total_tests_failed Test";
|
|
print "s" unless $total_tests_failed == 1;
|
|
print " in $categories_failed Categor";
|
|
print ($categories_failed == 1 ? "y" : "ies");
|
|
print " Failed (See .$diffext files in $workdir dir for details) :-(\n\n";
|
|
return 0;
|
|
}
|
|
else
|
|
{
|
|
print "\n$total_tests_passed Test";
|
|
print "s" unless $total_tests_passed == 1;
|
|
print " in $categories_passed Categor";
|
|
print ($categories_passed == 1 ? "y" : "ies");
|
|
print " Complete ... No Failures :-)\n\n";
|
|
return 1;
|
|
}
|
|
}
|
|
|
|
sub get_osname
|
|
{
|
|
# Set up an initial value. In perl5 we can do it the easy way.
|
|
#
|
|
$osname = defined($^O) ? $^O : '';
|
|
|
|
# See if the filesystem supports long file names with multiple
|
|
# dots. DOS doesn't.
|
|
$short_filenames = 0;
|
|
(open (TOUCHFD, "> fancy.file.name") && close (TOUCHFD))
|
|
|| ($short_filenames = 1);
|
|
unlink ("fancy.file.name") || ($short_filenames = 1);
|
|
|
|
if (! $short_filenames) {
|
|
# Thanks go to meyering@cs.utexas.edu (Jim Meyering) for suggesting a
|
|
# better way of doing this. (We used to test for existence of a /mnt
|
|
# dir, but that apparently fails on an SGI Indigo (whatever that is).)
|
|
# Because perl on VOS translates /'s to >'s, we need to test for
|
|
# VOSness rather than testing for Unixness (ie, try > instead of /).
|
|
|
|
mkdir (".ostest", 0777) || &error ("Couldn't create .ostest: $!\n", 1);
|
|
open (TOUCHFD, "> .ostest>ick") && close (TOUCHFD);
|
|
chdir (".ostest") || &error ("Couldn't chdir to .ostest: $!\n", 1);
|
|
}
|
|
|
|
if (! $short_filenames && -f "ick")
|
|
{
|
|
$osname = "vos";
|
|
$vos = 1;
|
|
$pathsep = ">";
|
|
}
|
|
else
|
|
{
|
|
# the following is regrettably knarly, but it seems to be the only way
|
|
# to not get ugly error messages if uname can't be found.
|
|
# Hmmm, BSD/OS 2.0's uname -a is excessively verbose. Let's try it
|
|
# with switches first.
|
|
eval "chop (\$osname = `sh -c 'uname -nmsr 2>&1'`)";
|
|
if ($osname =~ /not found/i)
|
|
{
|
|
$osname = "(something unixy with no uname)";
|
|
}
|
|
elsif ($@ ne "" || $?)
|
|
{
|
|
eval "chop (\$osname = `sh -c 'uname -a 2>&1'`)";
|
|
if ($@ ne "" || $?)
|
|
{
|
|
$osname = "(something unixy)";
|
|
}
|
|
}
|
|
$vos = 0;
|
|
$pathsep = "/";
|
|
}
|
|
|
|
if (! $short_filenames) {
|
|
chdir ("..") || &error ("Couldn't chdir to ..: $!\n", 1);
|
|
unlink (".ostest>ick");
|
|
rmdir (".ostest") || &error ("Couldn't rmdir .ostest: $!\n", 1);
|
|
}
|
|
}
|
|
|
|
sub parse_command_line
|
|
{
|
|
@argv = @_;
|
|
|
|
# use @ARGV if no args were passed in
|
|
|
|
if (@argv == 0)
|
|
{
|
|
@argv = @ARGV;
|
|
}
|
|
|
|
# look at each option; if we don't recognize it, maybe the suite-specific
|
|
# command line parsing code will...
|
|
|
|
while (@argv)
|
|
{
|
|
$option = shift @argv;
|
|
if ($option =~ /^-debug$/i)
|
|
{
|
|
print "\nDEBUG ON\n";
|
|
$debug = 1;
|
|
}
|
|
elsif ($option =~ /^-usage$/i)
|
|
{
|
|
&print_usage;
|
|
exit 0;
|
|
}
|
|
elsif ($option =~ /^-(h|help)$/i)
|
|
{
|
|
&print_help;
|
|
exit 0;
|
|
}
|
|
elsif ($option =~ /^-profile$/i)
|
|
{
|
|
$profile = 1;
|
|
}
|
|
elsif ($option =~ /^-verbose$/i)
|
|
{
|
|
$verbose = 1;
|
|
}
|
|
elsif ($option =~ /^-detail$/i)
|
|
{
|
|
$detail = 1;
|
|
$verbose = 1;
|
|
}
|
|
elsif ($option =~ /^-keep$/i)
|
|
{
|
|
$keep = 1;
|
|
}
|
|
elsif (&valid_option($option))
|
|
{
|
|
# The suite-defined subroutine takes care of the option
|
|
}
|
|
elsif ($option =~ /^-/)
|
|
{
|
|
print "Invalid option: $option\n";
|
|
&print_usage;
|
|
exit 0;
|
|
}
|
|
else # must be the name of a test
|
|
{
|
|
$option =~ s/\.pl$//;
|
|
push(@TESTS,$option);
|
|
}
|
|
}
|
|
}
|
|
|
|
sub max
|
|
{
|
|
local($num) = shift @_;
|
|
local($newnum);
|
|
|
|
while (@_)
|
|
{
|
|
$newnum = shift @_;
|
|
if ($newnum > $num)
|
|
{
|
|
$num = $newnum;
|
|
}
|
|
}
|
|
|
|
return $num;
|
|
}
|
|
|
|
sub print_centered
|
|
{
|
|
local($width, $string) = @_;
|
|
local($pad);
|
|
|
|
if (length ($string))
|
|
{
|
|
$pad = " " x ( ($width - length ($string) + 1) / 2);
|
|
print "$pad$string";
|
|
}
|
|
}
|
|
|
|
sub print_banner
|
|
{
|
|
local($info);
|
|
local($line);
|
|
local($len);
|
|
|
|
$info = "Running tests for $testee on $osname\n"; # $testee is suite-defined
|
|
$len = &max (length ($line), length ($testee_version),
|
|
length ($banner_info), 73) + 5;
|
|
$line = ("-" x $len) . "\n";
|
|
if ($len < 78)
|
|
{
|
|
$len = 78;
|
|
}
|
|
|
|
&print_centered ($len, $line);
|
|
&print_centered ($len, $info);
|
|
&print_centered ($len, $testee_version); # suite-defined
|
|
&print_centered ($len, $banner_info); # suite-defined
|
|
&print_centered ($len, $line);
|
|
print "\n";
|
|
}
|
|
|
|
sub run_each_test
|
|
{
|
|
$categories_run = 0;
|
|
|
|
foreach $testname (sort @TESTS)
|
|
{
|
|
++$categories_run;
|
|
$suite_passed = 1; # reset by test on failure
|
|
$num_of_logfiles = 0;
|
|
$num_of_tmpfiles = 0;
|
|
$description = "";
|
|
$details = "";
|
|
$old_makefile = undef;
|
|
$testname =~ s/^$scriptpath$pathsep//;
|
|
$perl_testname = "$scriptpath$pathsep$testname";
|
|
$testname =~ s/(\.pl|\.perl)$//;
|
|
$testpath = "$workpath$pathsep$testname";
|
|
# Leave enough space in the extensions to append a number, even
|
|
# though it needs to fit into 8+3 limits.
|
|
if ($short_filenames) {
|
|
$logext = 'l';
|
|
$diffext = 'd';
|
|
$baseext = 'b';
|
|
$extext = '';
|
|
} else {
|
|
$logext = 'log';
|
|
$diffext = 'diff';
|
|
$baseext = 'base';
|
|
$extext = '.';
|
|
}
|
|
$log_filename = "$testpath.$logext";
|
|
$diff_filename = "$testpath.$diffext";
|
|
$base_filename = "$testpath.$baseext";
|
|
$tmp_filename = "$testpath.$tmpfilesuffix";
|
|
|
|
&setup_for_test; # suite-defined
|
|
|
|
$output = "........................................................ ";
|
|
|
|
substr($output,0,length($testname)) = "$testname ";
|
|
|
|
print $output;
|
|
|
|
# Run the actual test!
|
|
$tests_run = 0;
|
|
$tests_passed = 0;
|
|
$code = do $perl_testname;
|
|
|
|
$total_tests_run += $tests_run;
|
|
$total_tests_passed += $tests_passed;
|
|
|
|
# How did it go?
|
|
if (!defined($code))
|
|
{
|
|
$suite_passed = 0;
|
|
if (length ($@)) {
|
|
warn "\n*** Test died ($testname): $@\n";
|
|
} else {
|
|
warn "\n*** Couldn't run $perl_testname\n";
|
|
}
|
|
}
|
|
elsif ($code == -1) {
|
|
$suite_passed = 0;
|
|
}
|
|
elsif ($code != 1 && $code != -1) {
|
|
$suite_passed = 0;
|
|
warn "\n*** Test returned $code\n";
|
|
}
|
|
|
|
if ($suite_passed) {
|
|
++$categories_passed;
|
|
$status = "ok ($tests_passed passed)";
|
|
for ($i = $num_of_tmpfiles; $i; $i--)
|
|
{
|
|
&rmfiles ($tmp_filename . &num_suffix ($i) );
|
|
}
|
|
|
|
for ($i = $num_of_logfiles ? $num_of_logfiles : 1; $i; $i--)
|
|
{
|
|
&rmfiles ($log_filename . &num_suffix ($i) );
|
|
&rmfiles ($base_filename . &num_suffix ($i) );
|
|
}
|
|
}
|
|
elsif (!defined $code || $code > 0) {
|
|
$status = "FAILED ($tests_passed/$tests_run passed)";
|
|
}
|
|
elsif ($code < 0) {
|
|
$status = "N/A";
|
|
--$categories_run;
|
|
}
|
|
|
|
# If the verbose option has been specified, then a short description
|
|
# of each test is printed before displaying the results of each test
|
|
# describing WHAT is being tested.
|
|
|
|
if ($verbose)
|
|
{
|
|
if ($detail)
|
|
{
|
|
print "\nWHAT IS BEING TESTED\n";
|
|
print "--------------------";
|
|
}
|
|
print "\n\n$description\n\n";
|
|
}
|
|
|
|
# If the detail option has been specified, then the details of HOW
|
|
# the test is testing what it says it is testing in the verbose output
|
|
# will be displayed here before the results of the test are displayed.
|
|
|
|
if ($detail)
|
|
{
|
|
print "\nHOW IT IS TESTED\n";
|
|
print "----------------";
|
|
print "\n\n$details\n\n";
|
|
}
|
|
|
|
print "$status\n";
|
|
}
|
|
}
|
|
|
|
# If the keep flag is not set, this subroutine deletes all filenames that
|
|
# are sent to it.
|
|
|
|
sub rmfiles
|
|
{
|
|
local(@files) = @_;
|
|
|
|
if (!$keep)
|
|
{
|
|
return (unlink @files);
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
sub print_standard_usage
|
|
{
|
|
local($plname,@moreusage) = @_;
|
|
local($line);
|
|
|
|
print "usage:\t$plname [testname] [-verbose] [-detail] [-keep]\n";
|
|
print "\t\t\t[-profile] [-usage] [-help] [-debug]\n";
|
|
foreach (@moreusage) {
|
|
print "\t\t\t$_\n";
|
|
}
|
|
}
|
|
|
|
sub print_standard_help
|
|
{
|
|
local(@morehelp) = @_;
|
|
local($line);
|
|
local($tline);
|
|
local($t) = " ";
|
|
|
|
$line = "Test Driver For $testee";
|
|
print "$line\n";
|
|
$line = "=" x length ($line);
|
|
print "$line\n";
|
|
|
|
&print_usage;
|
|
|
|
print "\ntestname\n"
|
|
. "${t}You may, if you wish, run only ONE test if you know the name\n"
|
|
. "${t}of that test and specify this name anywhere on the command\n"
|
|
. "${t}line. Otherwise ALL existing tests in the scripts directory\n"
|
|
. "${t}will be run.\n"
|
|
. "-verbose\n"
|
|
. "${t}If this option is given, a description of every test is\n"
|
|
. "${t}displayed before the test is run. (Not all tests may have\n"
|
|
. "${t}descriptions at this time)\n"
|
|
. "-detail\n"
|
|
. "${t}If this option is given, a detailed description of every\n"
|
|
. "${t}test is displayed before the test is run. (Not all tests\n"
|
|
. "${t}have descriptions at this time)\n"
|
|
. "-profile\n"
|
|
. "${t}If this option is given, then the profile file\n"
|
|
. "${t}is added to other profiles every time $testee is run.\n"
|
|
. "${t}This option only works on VOS at this time.\n"
|
|
. "-keep\n"
|
|
. "${t}You may give this option if you DO NOT want ANY\n"
|
|
. "${t}of the files generated by the tests to be deleted. \n"
|
|
. "${t}Without this option, all files generated by the test will\n"
|
|
. "${t}be deleted IF THE TEST PASSES.\n"
|
|
. "-debug\n"
|
|
. "${t}Use this option if you would like to see all of the system\n"
|
|
. "${t}calls issued and their return status while running the tests\n"
|
|
. "${t}This can be helpful if you're having a problem adding a test\n"
|
|
. "${t}to the suite, or if the test fails!\n";
|
|
|
|
foreach $line (@morehelp)
|
|
{
|
|
$tline = $line;
|
|
if (substr ($tline, 0, 1) eq "\t")
|
|
{
|
|
substr ($tline, 0, 1) = $t;
|
|
}
|
|
print "$tline\n";
|
|
}
|
|
}
|
|
|
|
#######################################################################
|
|
########### Generic Test Driver Subroutines ###########
|
|
#######################################################################
|
|
|
|
sub get_caller
|
|
{
|
|
local($depth);
|
|
local($package);
|
|
local($filename);
|
|
local($linenum);
|
|
|
|
$depth = defined ($_[0]) ? $_[0] : 1;
|
|
($package, $filename, $linenum) = caller ($depth + 1);
|
|
return "$filename: $linenum";
|
|
}
|
|
|
|
sub error
|
|
{
|
|
local($message) = $_[0];
|
|
local($caller) = &get_caller (1);
|
|
|
|
if (defined ($_[1]))
|
|
{
|
|
$caller = &get_caller ($_[1] + 1) . " -> $caller";
|
|
}
|
|
|
|
die "$caller: $message";
|
|
}
|
|
|
|
sub compare_output
|
|
{
|
|
local($answer,$logfile) = @_;
|
|
local($slurp, $answer_matched) = ('', 0);
|
|
|
|
print "Comparing Output ........ " if $debug;
|
|
|
|
$slurp = &read_file_into_string ($logfile);
|
|
|
|
# For make, get rid of any time skew error before comparing--too bad this
|
|
# has to go into the "generic" driver code :-/
|
|
$slurp =~ s/^.*modification time .*in the future.*\n//gm;
|
|
$slurp =~ s/^.*Clock skew detected.*\n//gm;
|
|
|
|
++$tests_run;
|
|
|
|
if ($slurp eq $answer) {
|
|
$answer_matched = 1;
|
|
} else {
|
|
# See if it is a slash or CRLF problem
|
|
local ($answer_mod, $slurp_mod) = ($answer, $slurp);
|
|
|
|
$answer_mod =~ tr,\\,/,;
|
|
$answer_mod =~ s,\r\n,\n,gs;
|
|
|
|
$slurp_mod =~ tr,\\,/,;
|
|
$slurp_mod =~ s,\r\n,\n,gs;
|
|
|
|
$answer_matched = ($slurp_mod eq $answer_mod);
|
|
|
|
# If it still doesn't match, see if the answer might be a regex.
|
|
if (!$answer_matched && $answer =~ m,^/(.+)/$,) {
|
|
$answer_matched = ($slurp =~ /$1/);
|
|
if (!$answer_matched && $answer_mod =~ m,^/(.+)/$,) {
|
|
$answer_matched = ($slurp_mod =~ /$1/);
|
|
}
|
|
}
|
|
}
|
|
|
|
if ($answer_matched && $test_passed)
|
|
{
|
|
print "ok\n" if $debug;
|
|
++$tests_passed;
|
|
return 1;
|
|
}
|
|
|
|
if (! $answer_matched) {
|
|
print "DIFFERENT OUTPUT\n" if $debug;
|
|
|
|
&create_file (&get_basefile, $answer);
|
|
|
|
print "\nCreating Difference File ...\n" if $debug;
|
|
|
|
# Create the difference file
|
|
|
|
local($command) = "diff -c " . &get_basefile . " " . $logfile;
|
|
&run_command_with_output(&get_difffile,$command);
|
|
}
|
|
|
|
$suite_passed = 0;
|
|
return 0;
|
|
}
|
|
|
|
sub read_file_into_string
|
|
{
|
|
local($filename) = @_;
|
|
local($oldslash) = $/;
|
|
|
|
undef $/;
|
|
|
|
open (RFISFILE, $filename) || return "";
|
|
local ($slurp) = <RFISFILE>;
|
|
close (RFISFILE);
|
|
|
|
$/ = $oldslash;
|
|
|
|
return $slurp;
|
|
}
|
|
|
|
sub attach_default_output
|
|
{
|
|
local ($filename) = @_;
|
|
local ($code);
|
|
|
|
if ($vos)
|
|
{
|
|
$code = system "++attach_default_output_hack $filename";
|
|
$code == -2 || &error ("adoh death\n", 1);
|
|
return 1;
|
|
}
|
|
|
|
open ("SAVEDOS" . $default_output_stack_level . "out", ">&STDOUT")
|
|
|| &error ("ado: $! duping STDOUT\n", 1);
|
|
open ("SAVEDOS" . $default_output_stack_level . "err", ">&STDERR")
|
|
|| &error ("ado: $! duping STDERR\n", 1);
|
|
|
|
open (STDOUT, "> " . $filename)
|
|
|| &error ("ado: $filename: $!\n", 1);
|
|
open (STDERR, ">&STDOUT")
|
|
|| &error ("ado: $filename: $!\n", 1);
|
|
|
|
$default_output_stack_level++;
|
|
}
|
|
|
|
# close the current stdout/stderr, and restore the previous ones from
|
|
# the "stack."
|
|
|
|
sub detach_default_output
|
|
{
|
|
local ($code);
|
|
|
|
if ($vos)
|
|
{
|
|
$code = system "++detach_default_output_hack";
|
|
$code == -2 || &error ("ddoh death\n", 1);
|
|
return 1;
|
|
}
|
|
|
|
if (--$default_output_stack_level < 0)
|
|
{
|
|
&error ("default output stack has flown under!\n", 1);
|
|
}
|
|
|
|
close (STDOUT);
|
|
close (STDERR);
|
|
|
|
open (STDOUT, ">&SAVEDOS" . $default_output_stack_level . "out")
|
|
|| &error ("ddo: $! duping STDOUT\n", 1);
|
|
open (STDERR, ">&SAVEDOS" . $default_output_stack_level . "err")
|
|
|| &error ("ddo: $! duping STDERR\n", 1);
|
|
|
|
close ("SAVEDOS" . $default_output_stack_level . "out")
|
|
|| &error ("ddo: $! closing SCSDOSout\n", 1);
|
|
close ("SAVEDOS" . $default_output_stack_level . "err")
|
|
|| &error ("ddo: $! closing SAVEDOSerr\n", 1);
|
|
}
|
|
|
|
# This runs a command without any debugging info.
|
|
sub _run_command
|
|
{
|
|
my $code;
|
|
|
|
# We reset this before every invocation. On Windows I think there is only
|
|
# one environment, not one per process, so I think that variables set in
|
|
# test scripts might leak into subsequent tests if this isn't reset--???
|
|
resetENV();
|
|
|
|
eval {
|
|
local $SIG{ALRM} = sub { die "timeout\n"; };
|
|
alarm $test_timeout;
|
|
$code = system @_;
|
|
alarm 0;
|
|
};
|
|
if ($@) {
|
|
# The eval failed. If it wasn't SIGALRM then die.
|
|
$@ eq "timeout\n" or die;
|
|
|
|
# Timed out. Resend the alarm to our process group to kill the children.
|
|
$SIG{ALRM} = 'IGNORE';
|
|
kill -14, $$;
|
|
$code = 14;
|
|
}
|
|
|
|
return $code;
|
|
}
|
|
|
|
# run one command (passed as a list of arg 0 - n), returning 0 on success
|
|
# and nonzero on failure.
|
|
|
|
sub run_command
|
|
{
|
|
print "\nrun_command: @_\n" if $debug;
|
|
my $code = _run_command(@_);
|
|
print "run_command returned $code.\n" if $debug;
|
|
|
|
return $code;
|
|
}
|
|
|
|
# run one command (passed as a list of arg 0 - n, with arg 0 being the
|
|
# second arg to this routine), returning 0 on success and non-zero on failure.
|
|
# The first arg to this routine is a filename to connect to the stdout
|
|
# & stderr of the child process.
|
|
|
|
sub run_command_with_output
|
|
{
|
|
my $filename = shift;
|
|
|
|
print "\nrun_command_with_output($filename): @_\n" if $debug;
|
|
&attach_default_output ($filename);
|
|
my $code = _run_command(@_);
|
|
&detach_default_output;
|
|
print "run_command_with_output returned $code.\n" if $debug;
|
|
|
|
return $code;
|
|
}
|
|
|
|
# performs the equivalent of an "rm -rf" on the first argument. Like
|
|
# rm, if the path ends in /, leaves the (now empty) directory; otherwise
|
|
# deletes it, too.
|
|
|
|
sub remove_directory_tree
|
|
{
|
|
local ($targetdir) = @_;
|
|
local ($nuketop) = 1;
|
|
local ($ch);
|
|
|
|
$ch = substr ($targetdir, length ($targetdir) - 1);
|
|
if ($ch eq "/" || $ch eq $pathsep)
|
|
{
|
|
$targetdir = substr ($targetdir, 0, length ($targetdir) - 1);
|
|
$nuketop = 0;
|
|
}
|
|
|
|
if (! -e $targetdir)
|
|
{
|
|
return 1;
|
|
}
|
|
|
|
&remove_directory_tree_inner ("RDT00", $targetdir) || return 0;
|
|
if ($nuketop)
|
|
{
|
|
rmdir $targetdir || return 0;
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
sub remove_directory_tree_inner
|
|
{
|
|
local ($dirhandle, $targetdir) = @_;
|
|
local ($object);
|
|
local ($subdirhandle);
|
|
|
|
opendir ($dirhandle, $targetdir) || return 0;
|
|
$subdirhandle = $dirhandle;
|
|
$subdirhandle++;
|
|
while ($object = readdir ($dirhandle))
|
|
{
|
|
if ($object =~ /^(\.\.?|CVS|RCS)$/)
|
|
{
|
|
next;
|
|
}
|
|
|
|
$object = "$targetdir$pathsep$object";
|
|
lstat ($object);
|
|
|
|
if (-d _ && &remove_directory_tree_inner ($subdirhandle, $object))
|
|
{
|
|
rmdir $object || return 0;
|
|
}
|
|
else
|
|
{
|
|
unlink $object || return 0;
|
|
}
|
|
}
|
|
closedir ($dirhandle);
|
|
return 1;
|
|
}
|
|
|
|
# We used to use this behavior for this function:
|
|
#
|
|
#sub touch
|
|
#{
|
|
# local (@filenames) = @_;
|
|
# local ($now) = time;
|
|
# local ($file);
|
|
#
|
|
# foreach $file (@filenames)
|
|
# {
|
|
# utime ($now, $now, $file)
|
|
# || (open (TOUCHFD, ">> $file") && close (TOUCHFD))
|
|
# || &error ("Couldn't touch $file: $!\n", 1);
|
|
# }
|
|
# return 1;
|
|
#}
|
|
#
|
|
# But this behaves badly on networked filesystems where the time is
|
|
# skewed, because it sets the time of the file based on the _local_
|
|
# host. Normally when you modify a file, it's the _remote_ host that
|
|
# determines the modtime, based on _its_ clock. So, instead, now we open
|
|
# the file and write something into it to force the remote host to set
|
|
# the modtime correctly according to its clock.
|
|
#
|
|
|
|
sub touch
|
|
{
|
|
local ($file);
|
|
|
|
foreach $file (@_) {
|
|
(open(T, ">> $file") && print(T "\n") && close(T))
|
|
|| &error("Couldn't touch $file: $!\n", 1);
|
|
}
|
|
}
|
|
|
|
# Touch with a time offset. To DTRT, call touch() then use stat() to get the
|
|
# access/mod time for each file and apply the offset.
|
|
|
|
sub utouch
|
|
{
|
|
local ($off) = shift;
|
|
local ($file);
|
|
|
|
&touch(@_);
|
|
|
|
local (@s) = stat($_[0]);
|
|
|
|
utime($s[8]+$off, $s[9]+$off, @_);
|
|
}
|
|
|
|
# open a file, write some stuff to it, and close it.
|
|
|
|
sub create_file
|
|
{
|
|
local ($filename, @lines) = @_;
|
|
|
|
open (CF, "> $filename") || &error ("Couldn't open $filename: $!\n", 1);
|
|
foreach $line (@lines)
|
|
{
|
|
print CF $line;
|
|
}
|
|
close (CF);
|
|
}
|
|
|
|
# create a directory tree described by an associative array, wherein each
|
|
# key is a relative pathname (using slashes) and its associated value is
|
|
# one of:
|
|
# DIR indicates a directory
|
|
# FILE:contents indicates a file, which should contain contents +\n
|
|
# LINK:target indicates a symlink, pointing to $basedir/target
|
|
# The first argument is the dir under which the structure will be created
|
|
# (the dir will be made and/or cleaned if necessary); the second argument
|
|
# is the associative array.
|
|
|
|
sub create_dir_tree
|
|
{
|
|
local ($basedir, %dirtree) = @_;
|
|
local ($path);
|
|
|
|
&remove_directory_tree ("$basedir");
|
|
mkdir ($basedir, 0777) || &error ("Couldn't mkdir $basedir: $!\n", 1);
|
|
|
|
foreach $path (sort keys (%dirtree))
|
|
{
|
|
if ($dirtree {$path} =~ /^DIR$/)
|
|
{
|
|
mkdir ("$basedir/$path", 0777)
|
|
|| &error ("Couldn't mkdir $basedir/$path: $!\n", 1);
|
|
}
|
|
elsif ($dirtree {$path} =~ /^FILE:(.*)$/)
|
|
{
|
|
&create_file ("$basedir/$path", $1 . "\n");
|
|
}
|
|
elsif ($dirtree {$path} =~ /^LINK:(.*)$/)
|
|
{
|
|
symlink ("$basedir/$1", "$basedir/$path")
|
|
|| &error ("Couldn't symlink $basedir/$path -> $basedir/$1: $!\n", 1);
|
|
}
|
|
else
|
|
{
|
|
&error ("Bogus dirtree type: \"$dirtree{$path}\"\n", 1);
|
|
}
|
|
}
|
|
if ($just_setup_tree)
|
|
{
|
|
die "Tree is setup...\n";
|
|
}
|
|
}
|
|
|
|
# compare a directory tree with an associative array in the format used
|
|
# by create_dir_tree, above.
|
|
# The first argument is the dir under which the structure should be found;
|
|
# the second argument is the associative array.
|
|
|
|
sub compare_dir_tree
|
|
{
|
|
local ($basedir, %dirtree) = @_;
|
|
local ($path);
|
|
local ($i);
|
|
local ($bogus) = 0;
|
|
local ($contents);
|
|
local ($target);
|
|
local ($fulltarget);
|
|
local ($found);
|
|
local (@files);
|
|
local (@allfiles);
|
|
|
|
opendir (DIR, $basedir) || &error ("Couldn't open $basedir: $!\n", 1);
|
|
@allfiles = grep (!/^(\.\.?|CVS|RCS)$/, readdir (DIR) );
|
|
closedir (DIR);
|
|
if ($debug)
|
|
{
|
|
print "dirtree: (%dirtree)\n$basedir: (@allfiles)\n";
|
|
}
|
|
|
|
foreach $path (sort keys (%dirtree))
|
|
{
|
|
if ($debug)
|
|
{
|
|
print "Checking $path ($dirtree{$path}).\n";
|
|
}
|
|
|
|
$found = 0;
|
|
foreach $i (0 .. $#allfiles)
|
|
{
|
|
if ($allfiles[$i] eq $path)
|
|
{
|
|
splice (@allfiles, $i, 1); # delete it
|
|
if ($debug)
|
|
{
|
|
print " Zapped $path; files now (@allfiles).\n";
|
|
}
|
|
lstat ("$basedir/$path");
|
|
$found = 1;
|
|
last;
|
|
}
|
|
}
|
|
|
|
if (!$found)
|
|
{
|
|
print "compare_dir_tree: $path does not exist.\n";
|
|
$bogus = 1;
|
|
next;
|
|
}
|
|
|
|
if ($dirtree {$path} =~ /^DIR$/)
|
|
{
|
|
if (-d _ && opendir (DIR, "$basedir/$path") )
|
|
{
|
|
@files = readdir (DIR);
|
|
closedir (DIR);
|
|
@files = grep (!/^(\.\.?|CVS|RCS)$/ && ($_ = "$path/$_"), @files);
|
|
push (@allfiles, @files);
|
|
if ($debug)
|
|
{
|
|
print " Read in $path; new files (@files).\n";
|
|
}
|
|
}
|
|
else
|
|
{
|
|
print "compare_dir_tree: $path is not a dir.\n";
|
|
$bogus = 1;
|
|
}
|
|
}
|
|
elsif ($dirtree {$path} =~ /^FILE:(.*)$/)
|
|
{
|
|
if (-l _ || !-f _)
|
|
{
|
|
print "compare_dir_tree: $path is not a file.\n";
|
|
$bogus = 1;
|
|
next;
|
|
}
|
|
|
|
if ($1 ne "*")
|
|
{
|
|
$contents = &read_file_into_string ("$basedir/$path");
|
|
if ($contents ne "$1\n")
|
|
{
|
|
print "compare_dir_tree: $path contains wrong stuff."
|
|
. " Is:\n$contentsShould be:\n$1\n";
|
|
$bogus = 1;
|
|
}
|
|
}
|
|
}
|
|
elsif ($dirtree {$path} =~ /^LINK:(.*)$/)
|
|
{
|
|
$target = $1;
|
|
if (!-l _)
|
|
{
|
|
print "compare_dir_tree: $path is not a link.\n";
|
|
$bogus = 1;
|
|
next;
|
|
}
|
|
|
|
$contents = readlink ("$basedir/$path");
|
|
$contents =~ tr/>/\//;
|
|
$fulltarget = "$basedir/$target";
|
|
$fulltarget =~ tr/>/\//;
|
|
if (!($contents =~ /$fulltarget$/))
|
|
{
|
|
if ($debug)
|
|
{
|
|
$target = $fulltarget;
|
|
}
|
|
print "compare_dir_tree: $path should be link to $target, "
|
|
. "not $contents.\n";
|
|
$bogus = 1;
|
|
}
|
|
}
|
|
else
|
|
{
|
|
&error ("Bogus dirtree type: \"$dirtree{$path}\"\n", 1);
|
|
}
|
|
}
|
|
|
|
if ($debug)
|
|
{
|
|
print "leftovers: (@allfiles).\n";
|
|
}
|
|
|
|
foreach $file (@allfiles)
|
|
{
|
|
print "compare_dir_tree: $file should not exist.\n";
|
|
$bogus = 1;
|
|
}
|
|
|
|
return !$bogus;
|
|
}
|
|
|
|
# this subroutine generates the numeric suffix used to keep tmp filenames,
|
|
# log filenames, etc., unique. If the number passed in is 1, then a null
|
|
# string is returned; otherwise, we return ".n", where n + 1 is the number
|
|
# we were given.
|
|
|
|
sub num_suffix
|
|
{
|
|
local($num) = @_;
|
|
|
|
if (--$num > 0) {
|
|
return "$extext$num";
|
|
}
|
|
|
|
return "";
|
|
}
|
|
|
|
# This subroutine returns a log filename with a number appended to
|
|
# the end corresponding to how many logfiles have been created in the
|
|
# current running test. An optional parameter may be passed (0 or 1).
|
|
# If a 1 is passed, then it does NOT increment the logfile counter
|
|
# and returns the name of the latest logfile. If either no parameter
|
|
# is passed at all or a 0 is passed, then the logfile counter is
|
|
# incremented and the new name is returned.
|
|
|
|
sub get_logfile
|
|
{
|
|
local($no_increment) = @_;
|
|
|
|
$num_of_logfiles += !$no_increment;
|
|
|
|
return ($log_filename . &num_suffix ($num_of_logfiles));
|
|
}
|
|
|
|
# This subroutine returns a base (answer) filename with a number
|
|
# appended to the end corresponding to how many logfiles (and thus
|
|
# base files) have been created in the current running test.
|
|
# NO PARAMETERS ARE PASSED TO THIS SUBROUTINE.
|
|
|
|
sub get_basefile
|
|
{
|
|
return ($base_filename . &num_suffix ($num_of_logfiles));
|
|
}
|
|
|
|
# This subroutine returns a difference filename with a number appended
|
|
# to the end corresponding to how many logfiles (and thus diff files)
|
|
# have been created in the current running test.
|
|
|
|
sub get_difffile
|
|
{
|
|
return ($diff_filename . &num_suffix ($num_of_logfiles));
|
|
}
|
|
|
|
# just like logfile, only a generic tmp filename for use by the test.
|
|
# they are automatically cleaned up unless -keep was used, or the test fails.
|
|
# Pass an argument of 1 to return the same filename as the previous call.
|
|
|
|
sub get_tmpfile
|
|
{
|
|
local($no_increment) = @_;
|
|
|
|
$num_of_tmpfiles += !$no_increment;
|
|
|
|
return ($tmp_filename . &num_suffix ($num_of_tmpfiles));
|
|
}
|
|
|
|
1;
|