#! /usr/bin/env perl
#
# cons-test
#
#	Run the cons regression test suite.
#

# $Id: cons-test.pl,v 1.6.2.1 2000/09/13 21:52:06 knight Exp $

# Copyright (c) 1996-2000 Free Software Foundation, Inc.
#
# This program 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 2 of the License, or
# (at your option) any later version.
#
# This program 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; see the file COPYING.  If not, write to
# the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
# Boston, MA 02111-1307, USA.

use strict;
use File::Basename;
use Getopt::Long;

use vars qw(
		$Cons @Dirs $First $Help @IDirs $My_Name $Quiet
		$Script $Usage $Win32 $w_flag
	);

use Text::Tabs;
#use Pod::Usage;	# not in all Perl versions, roll our own
# DO NOT REUSE THIS ROUTINE
sub pod2usage {
	my $arg = shift;
	my @lines;
	while (<DATA>) {
		$_ = <DATA>, last if /SYNOPSIS/;
	}
	while (<DATA>) {
		last if /^=head1/;
		push @lines, $_;
	}
	@lines = map { $_ !~ /^$/ ? "    $_" : $_ } expand @lines;
	unshift(@lines, "Usage:\n");
	if ($arg == 1) {
		print STDOUT @lines;
	} elsif ($arg == 2) {
		print STDERR @lines;
	}
	exit ($arg);
}

$My_Name = basename($0);

@Dirs = ();
$Help = 0;
@IDirs = ();
$Quiet = 0;
$Script = undef;
$w_flag = '';

# eval in case Configue is not in this version of Getopt::Long.
eval 'Getopt::Long::Configure("bundling")';

GetOptions(
		'd|dir=s' => \@Dirs,
		'h|help' => \$Help,
		'I=s' => \@IDirs,
		'q|quiet' => \$Quiet,
		'x|exec=s' => \$Script,
		'w' => sub { $w_flag = '-w' },
	) or pod2usage(2);

pod2usage(1) if $Help;

if (@Dirs) {
    @Dirs = split(/,/, join(',', @Dirs));
} else {
    @Dirs = qw(
	.
	t
	/usr/lib/cons-2.0.2/test/t
	/usr/lib/cons/test/t
    );
}
@Dirs = grep(-d, @Dirs);

if (@IDirs) {
    @IDirs = split(/,/, join(',', @Dirs));
} else {
    @IDirs = qw(
	.
	/usr/lib/cons-2.0.2/test
	/usr/lib/cons/test
    );
}
@IDirs = grep(-d, @IDirs);

sub env_warn {
    #
    # Make sure that platforms that don't have cc in the regular path
    # can define it. Otherwise, define it as standard 'cc'.
    #
    if (! defined($ENV{'CC'})) {
	warn "$My_Name:  CC not defined! using 'cc'\n" unless $Quiet;
	$ENV{'CC'} = 'cc';
    }

    if (! defined($ENV{'AR'})) {
	warn "$My_Name:  AR not defined! using 'ar'\n" unless $Quiet;
	$ENV{'AR'} = 'ar';
    }

    if (! defined($ENV{'RANLIB'})) {
	warn "$My_Name:  RANLIB not defined! using 'ranlib'\n" unless $Quiet;
	$ENV{'RANLIB'} = 'ranlib';
    }
}

if (defined($Script)) {
    $Cons = $Script;
    if (! -f $Cons) {
	print STDERR <<_EOF_;
$My_Name:
    The specified '$Cons' script does not exist.
    Create it, or use -x to specify some other script.
_EOF_
	pod2usage(2);
    }
} else {
    foreach ('cons', 'cons.pl') {
	$Cons = $_, last if -f;
    }
    if (! $Cons) {
	print STDERR <<_EOF_;
$My_Name:
    There is no 'cons' or 'cons.pl' script in the current directory.
    Create one, or use -x to specify some other script.
_EOF_
	pod2usage(2);
    }
    print "Using the '$Cons' script.\n" unless $Quiet;
}

if ($] <  5.003) {
    eval("require Win32");
    $Win32 = ! $@;
} else {
    $Win32 = $^O eq "MSWin32";
}

$ENV{CONS} = $Cons;
$ENV{PERLFLAGS} = $w_flag;
$ENV{PERL5OPT} .= " -I " . join(" -I ", @IDirs) if @IDirs;

my $pass = 0;
my @fail = ();

sub report {
    my ($sofar) = @_;
    $sofar ||= '';
    if (@fail == 0) {
	print "$My_Name:  '$Cons' passed all $pass tests$sofar.\n";
    } else {
	printf "$My_Name:  '$Cons' passed $pass tests, failed %d$sofar:\n", scalar @fail;
	print "\t\t", join("\n\t\t", @fail), "\n";
    }
}

my $child_pid;

sub handler {
    my($sig) = @_;
    waitpid($child_pid, 0) if ! $Win32;
    print "$My_Name:  Caught SIG$sig; exiting.\n";
    print "\n";
    &report(' so far');
    exit (1);
}

$SIG{'HUP'} = \&handler if ! $Win32;
$SIG{'INT'} = \&handler;
$SIG{'QUIT'} = \&handler;
$SIG{'TERM'} = \&handler;

my $perl = $^X . ($w_flag ? " $w_flag" : "");

my %command = (
	'.t'	=> $perl,
	'.pl'	=> $perl,
	'.sh'	=> 'sh',
);

sub fetch_tests {
    my %test;
    my $dir;
    foreach $dir (@_) {
	opendir(DIR, $dir) || die "$My_Name: cannot open '$dir': $!\n";
	my $prefix = $dir eq '.' ? '' : "$dir/";
	foreach (grep /\.t$/, readdir(DIR)) {
	    $test{$_} = "$prefix$_" if ! $test{$_};
	}
	closedir(DIR);
    }
    return map { $test{$_} } sort keys %test;
}

sub find_test {
    my $name = shift;
    my $dir;
    foreach $dir (@_) {
	my $t = ($dir eq '.' ? '' : "$dir/") . $name;
	return $t if -f $t;
    }
    return undef
}

if (! @ARGV) {
    @ARGV = &fetch_tests(@Dirs);
    @Dirs = ();
}

$| = 1;	# flush print

$First = 1;

while (@ARGV) {
    my $test = shift @ARGV;
    if ($test =~ m/([^=]*)=(.*)/o) {
	$ENV{$1} = $2;
	if (! @ARGV && @fail == 0 && $pass == 0) {
	    @ARGV = &fetch_tests(@Dirs);
	    @Dirs = ();
	}
	next;
    }
    if ($First) {
	&env_warn;
	$First = undef;
    }
    $test = &find_test($test, @Dirs) if @Dirs;
    my ($name, $path, $suffix) = fileparse($test, keys %command);
    my $cmd = "$command{$suffix} $test";
    print "$My_Name:  $cmd\n";
    my $exit;
    if ($Win32) {
	system($cmd);
	$exit = $?
    } else {
	$child_pid = open(PIPE, "|$cmd");
	if (! defined($child_pid)) {
	    print "Unable to start '$cmd': $!\n";
	    &report(' so far');
	    exit (1);
	}
	waitpid($child_pid, 0);
	$exit = $?;
    }
    if ($exit) {
	push(@fail, $test);
    } else {
	$pass++;
    }
    if (! $Win32) {
	close(PIPE);
    }
}

print "\n";
&report('');

exit @fail;

__END__

=head1 NAME

cons-test - Run Cons tests

=head1 SYNOPSIS

  cons-test [-qw] [-d dir] [-I dir] [-x cons] [test_script ...]

	-d dir		search for tests in specified dir
	-I dir		add dir to Perl search path
	-q		quiet, supress warnings about undefined variables
	-w		execute the cons script with perl -w flag
	-x cons		test specified cons script

=head1 DESCRIPTION

By default, the C<cons-test> script will test the script C<cons> or
C<cons.pl> in the current directory.

An alternate C<cons> script name may be specified via the C<-x> flag:

  $ cons-test -x cons.NEW

  $ cons-test -x /usr/foo/cons.experiment/cons

The C<cons-test> script will arrange for each test to use the specified
C<cons> script.  The C<cons> script under test need not have execute
permission set.

The C<cons> script under test may be executed with the Perl C<-w> flag,
which warns about conditions such as uninitialized variables:

  $ cons-test -w

By default, the C<cons-test> script executes all the tests it finds in
the following directories:

  .
  t
  /usr/lib/cons-2.0.2/test/t
  /usr/lib/cons/test/t

Any file with a C<.t> extension is assumed to be a test.  The C<cons-test>
script can also execute tests with C<.pl> or C<.sh> extensions, although
they must be explicitly listed on the command line.

By default, the executed tests use the supporting C<Test::Cmd> and
C<Test::Cmd::Cons> perl modules found under the current directory or
F</usr/lib/cons-2.0.2>.  Additional directories to be
searched for these modules may be specified with C<-I> flag.

Each test is executed with the specified C<cons> script
passed in via the C<CONS> environment variable.  The C<cons> script
will be executed with any Perl flags specified via the C<PERLFLAGS>
environment variable.

After all the tests have been executed, the C<cons-test> script reports
a summary of the pass/fail score:

  cons-test:  'cons' passed all 118 tests.

  cons-test:  'cons' passed 116 tests, failed 2:
		/usr/lib/cons-2.0.2/test/t/t0003.t
		/usr/lib/cons-2.0.2/test/t/t0026.t

The C<cons-test> script can be given one or more tests as arguments,
in which case it will only execute the specified tests:

  $ perl cons-test t0007.t t0023.t
  cons-test:  perl -w /usr/lib/cons-2.0.2/test/t/t0007.t
  PASSED
  cons-test:  perl -w /usr/lib/cons-2.0.2/test/t/t0023.t
  PASSED

  cons-test:  'cons' passed all 2 tests.
  $

The C<cons-test> script may also be given environment variable assignments
as arguments.  These will be evaluated in order with the test arguments.
This allows, for example, executing the same test(s) with different
compilers in the same C<cons-test> invocation:

  $ perl cons-test CC=gcc t/t0001.t CC=no_compiler t/t0001.t
  cons-test:  perl -w /usr/lib/cons-2.0.2/test/t/t0001.t
  PASSED
  cons-test:  perl -w /usr/lib/cons-2.0.2/test/t/t0001.t
  FAILED test #1 of cons [single-module Program]:
  no_compiler -c foo.c -o foo.o
  cons: failed to execute "no_compiler" (No such file or directory). Is this an executable on path "/bin:/usr/bin"?
  cons: *** [foo.o] Error 2
  cons: errors constructing foo.o
  FAILED test #1 of cons [single-module Program]

  cons-test:  'cons' passed 1 tests, failed 1:
		/usr/lib/cons-2.0.2/test/t/t0001.t
  $

By default, the C<cons-test> script expects that the environment variables
C<CC>, C<AR>, and C<RANLIB> are set, and will generate warnings if they
are not.  A C<-q> option may be used to suppress these warnings.

=head1 TESTS

Tests conform to requirements of the Aegis project change supervisor,
which integrates creation and execution of regression tests into the
software development process.  Information about Aegis can be found at:

  http://www.tip.net.au/~millerp/aegis.html

Each test is a completely self-contained Perl script, and may be directly
executed by explicitly passing it to perl (C<-w> flag preferred):

  $ perl -w t/t0001.t

The cryptic names are by Aegis convention only, and could have been
named to reflect the functionality being tested.  The numbering has
been preserved to try to give order to the tests:  Simpler, underlying
functionality is tested before more complicated features that rely on
functionality tested by prior tests.

Each test creates a temporary work directory under C<$TMPDIR> (under
F</tmp> by default) and populates it with files from in-line here
documents.

Each test checks the return value from every subroutine it calls and ever
command it executes, expecting a successful return value or exit code
from each.  When it's important, each test compares actual command output
against expected output.  Note that, in the usual case, this is actually
output of the executables generated by Cons, not the "cc" command lines
reported as the actions Cons executes to build the test executables.
There are some exceptions, tests which do examine the build actions;
these are noted in the C<Tests.txt> file and in the commentary at the
top of each test.

By default, the tests rely on having normal C compilation, linking and
archiving tools available through the environment's C<PATH>, and expect
that C<printf()> is available through whatever library is linked into
a program via the default Cons build environment.  These tests use the
following environment variables for specification of alternate paths to
various utilities:

  AR	(default:  'ar')	library archiver
  CC	(default:  'cc')	C compiler
  RANLIB	(default:  'ranlib')	ranlib

As described previously, the C<cons-test> script accepts environment
variable assignments in its command-line arguments.  This may be
used, for example, to specify different C compilers for different
test invocations:

  $ perl cons-test CC=gcc t/t0001.t CC=cc t/t0001.t

Each test reports one of three results:

=over 4

=item PASSED

The Cons script being tested passed this test.

=item FAILED test of [functionality]

The Cons script being tested failed this test.

=item NO RESULT for test of [functionality]

The Cons script could not be tested due to some non-Cons problem (e.g.,
unable to create temporary directory or file).

=back

Each test removes its temporary work directory upon completion.

=head1 ENVIRONMENT VARIABLES

For post facto debugging, the work directory can be preserved (and its
name reported) by setting environment variables:

=over 4

=item PRESERVE

Don't remove the work directory.

=item PRESERVE_PASS

Don't remove the work directory if the test passes.

=item PRESERVE_FAIL

Don't remove the work directory if the test fails.

=item PRESERVE_NO_RESULT

Don't remove the work directory if there is no valid test result.

=back

=head1 FILES

=over 4

=item /usr/lib/cons-2.0.2/test/Test/Cmd/Cons.pm

Perl module for testing Cons.

=item /usr/lib/cons-2.0.2/test/Tests.txt

Summary descriptions of all tests.

=item /usr/lib/cons-2.0.2/test/t/

Subdirectory containing the default set of tests.

=back

=head1 AUTHOR

Steven Knight <knight@baldmt.com>

=head1 REPORTING BUGS

Report bugs to <bug-cons@gnu.org>.

=head1 COPYRIGHT

Copyright 2000 Free Software Foundation, Inc.
This is free software; see the source for copying conditions.
There is NO warranty; not even for MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE.

=head1 SEE ALSO

L<cons>
