# $Id: Cons.pm,v 1.14.2.1 2000/11/17 05:39:08 knight Exp $

# This module should be included in every Cons test.
# Run "perldoc Test::Cmd::Cons" to get at the documentation
# for using this module.

# 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.

package Test::Cmd::Cons;

use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $_exe $_o $_a $_is_win32);
use Exporter ();

$VERSION = '2.2.0';
@ISA = qw(Test::Cmd Exporter);

@EXPORT_OK = qw($_exe $_o $_a $_is_win32);

use Config;
use Cwd;
use File::Copy ();
use Test::Cmd;

use vars qw( $Cons $Cons_Env $Perl_Flags );



=head1 NAME

Test::Cmd::Cons - module for testing the Cons software construction utility

=head1 SYNOPSIS

  use Test::Cmd::Cons;

  $test = Test::Cmd::Cons->new(string => 'functionality being tested');

  $test->cons;

  $test->cons_env;
  $test->cons_env('CC => "gcc", AR => 'ar',
			ARFLAGS => 'r', RANLIB => 'ranlib'");

  $test->cons_env_val('VARIABLE');

  $test->run(chdir => 'subdir', fail => '$? != 0',
		flags => '-x', targets => '.',
		stdout => <<_EOF_, stderr => <<_EOF_);
  standard output
  _EOF_
  error output
  _EOF_

  $test->up_to_date(chdir => 'subdir', flags => '-x', targets => '.');

  $test->execute(prog => 'foo.pl', interpreter => $^X,
		args => '-f arg1 arg2', fail => '$? != 0',
		expect => <<_EOF_);
  expected output
  _EOF_

  $test->subdir('subdir', ...);

  $test->read(\$contents, 'file');
  $test->read(\@lines, 'file');

  $test->write('file', <<_EOF_);
  contents of the file
  _EOF_

  $test->file_matches();

  $test->must_exist('file', ['subdir', 'file'], ...);

  $test->must_not_exist('file', ['subdir', 'file'], ...);

  $test->copy('src_file', 'dst_file');

  $test->sleep($seconds);

  $test->touch('file', ...);

  $test->unlink('file', ...);

  use Test::Cmd::Cons qw($_exe $_o $_a $_is_win32);

=head1 DESCRIPTION

The C<Test::Cmd::Cons> module provides a simple, high-level interface for
writing tests of the Cons software construction utility.

All methods throw exceptions and exit on failure.  This makes it
unnecessary to add explicit checks for return values, making the test
scripts themselves simpler to write and easier to read.

The C<Test::Cmd::Cons> module provides some importable variables:
C<$_exe>, C<$_o>, C<$_a>, C<$_is_win32>.  The first three are respectively,
the values normally available from C<$Config{_exe}> (executable file
suffix), C<$Config{_o}> (object file suffix) and C<$Config{_a}> (library
suffix).  These C<$Config> values, however, are not available prior to
Perl 5.005, so the C<Test::Cmd::Cons> module figures out proper values
via other means, if necessary.  The C<$_is_win32> variable provides
a Perl-version-independent means of testing for whether the current
platform is a Win32 system.

=head1 METHODS

=over 4

=cut

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

    $Cons = $ENV{CONS} || 'cons';

    $Perl_Flags = $ENV{PERLFLAGS} || '';

    $Cons_Env = $ENV{CONSENV};
    if (! $Cons_Env) {
	if ($_is_win32) {
		# Ordinarily, we want to use the default
		# CC, LINK and PREFLIB values in Cons itself.
		# Unfortunately, some of the tests use the
		# cons_env_val method to fetch them for
		# examination, so we need to duplicate them here.
		$Cons_Env = "
			CC => 'cl',
			CCOUTPUT => ' > nul',
			# CCCOM redirects standard output to nul
			# because I can't find *any* way to get the
			# stupid MSVC compiler to *not* print the
			# file name it's compiling.  No command-line
			# option, no environment variable, nada.
			# The extra file name print messes up the
			# output we examine to see if Cons did the
			# right thing in certain circumstances.
			CCCOM	=> '%CC %CFLAGS %_IFLAGS /nologo /c %< /Fo%> %CCOUTPUT',
			LINK => 'link',
			# Use the magic, undocumented %_LIBS symbol
			# so specifying libraries via -lfoo works
			# on Win32 systems.
			LINKCOM => '%LINK %LDFLAGS /nologo /out:%> %< %_LDIRS %_LIBS',
			PREFLIB => '',
			ENV => {
				INCLUDE => 'C:\\program files\\devstudio\\vc\\include;C:\\program files\\devstudio\\vc\\atl\\include;C:\\program files\\devstudio\\vc\\mfc\\include',
				LIB => 'C:\\program files\\devstudio\\vc\\lib;C:\\program files\\devstudio\\vc\\mfc\\lib',
				MSDEVDIR => 'C:\\Program Files\\DevStudio\\SharedIDE',
				MSDEVINC => 'C:\\Program Files\\DevStudio\\vc\\include',
				PATH => 'C:\\Tools;C:\\WINNT\\system32;C:\\WINNT;C:\\program files\\devstudio\\sharedide\\bin\\ide;C:\\program files\\devstudio\\sharedide\\bin;C:\\program files\\devstudio\\vc\\bin'
			}
			";
	} else {
		# Use "ar cr" by default, as we know that the tests
		# always create libraries, and the 'c' option quiets
		# 'ar' if the library doesn't already exist.
		#
		# Use our current environment PATH in Cons
		# environments.  Some of the tests invoke Cons,
		# which in turn runs Perl.  This makes sure
		# Cons can execute the perl version being run.
		$Cons_Env = "ARFLAGS => 'cr',
			     ENV => {
				PATH => '$ENV{PATH}'
			     },\n";
		$Cons_Env .= "AR => '$ENV{AR}',\n" if $ENV{AR};
		$Cons_Env .= "ARFLAGS => '$ENV{ARFLAGS}',\n" if $ENV{ARFLAGS};
		$Cons_Env .= "CC => '$ENV{CC}',\n" if $ENV{CC};
		$Cons_Env .= "RANLIB => '$ENV{RANLIB}',\n" if $ENV{RANLIB};
	}
    }
    $_exe = $Config{_exe};
    $_exe = $Config{exe_ext} if ! defined $_exe;
    $_exe = $_is_win32 ? '.exe' : '' if ! defined $_exe;
    $_o = $Config{_o};
    $_o = $Config{obj_ext}  if ! defined $_o;
    $_o = $_is_win32 ? '.obj' : '.o' if ! defined $_o;
    $_a = $Config{_a};
    $_a = $Config{lib_ext} if ! defined $_a;
    $_a = $_is_win32 ? '.lib' : '.a' if ! defined $_a;
}



=item C<new>

Creates a new Cons test environment object.  Any arguments are
keyword-value pairs that are passed through to the construct method
for the base class from which we inherit our methods (typically the
C<Test::Cmd> class).  In the normal case, this need only be the string
describing the functionality being tested:

    $test = Test::Cmd::Cons->new(string => 'cool new feature');

Creates a temporary working directory for the test environment and
changes directory to it.

The Cons script under test will be passed to perl, with the directory
from which it was invoked appended with C<-I>, allowing Cons to use
modules installed in the current directory.

Exits NO RESULT if the object can not be created, the temporary working
directory can not be created, or the current directory cannot be changed
to the temporary working directory.

=cut

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $test = $class->SUPER::new('prog' => $Cons,
				'interpreter' => $^X,
				'workdir' => '',
				@_);
    $class->SUPER::no_result(! $test, undef, 1);
    my $cwd = Cwd::cwd();
    $test->interpreter($test->interpreter . " $Perl_Flags -I. -I$cwd");
    my $ret = chdir $test->workdir;
    $test->no_result(! $ret, undef, 1);
    bless($test, $class);
}



=item C<cons>

Returns the Cons program to be executed for the specified test
environment, optionally setting it to the specified argument.

=cut

sub cons {
    my $self = shift;
    my $cons = shift;
    $Cons = $cons if $cons;
    $Cons;
}



=item C<cons_env>

Returns the string representation of the Cons environment for the
specified test environment, optionally setting it to the specified
argument.  Typically used to interpolate the Cons environment
into a Construct or Conscript file:

    $test->write('Construct', <<_EOF_);
    \$Env = new cons ( ${\$test->cons_env} );
    _EOF_

=cut

sub cons_env {
    my $self = shift;
    my $cons_env = shift;
    $Cons_Env = $cons_env if $cons_env;
    $Cons_Env;
}



=item C<cons_env_val>

Fetches a specified value from the Cons environment for the specified
test environment.  Typically used to fetch the current compiler, linker,
flags, or some other variable:

    $CC = $test->cons_env_val('CC');

=cut

sub cons_env_val {
    my $self = shift;
    my $val = shift;
    my %env;
    eval "%env = ( ${\$self->cons_env} );";
    $env{$val};
}



sub _fail_match_show {
    my($self, $stream, $expected, $actual) = @_;
    $self->fail(! $self->match($actual, $expected)
		=> sub {print STDERR "Expected $stream =====\n",
					ref $expected ? @$expected : $expected,
					"Actual $stream =====\n",
					ref $actual ? @$actual : $actual},
		2);
}



=item C<run>

Runs a test on Cons, checking that the test succeeded.  Arguments are
keyword-value pairs that affect the manner in which Cons is executed or
the results are evaluated.

    chdir => 'subdir'
    fail => 'failure condition'	# default is '$? != 0'
    flags => 'Cons flags'
    stderr => 'expected error output'
    stdout => 'expected standard output'
    targets => 'targets to build'

The test fails if:

  --  The specified failure condition is met.  The default failure
      condition is '$? != 0', i.e. Cons exits unsuccesfully.  A
      not-uncommon alternative is:

	  $test->run(fail => '$? == 0');	# expect failure

      when testing how Cons handles errors.

  --  Actual standard output does not match expected standard output
      (if any).  The expected standard output is an array of lines or
      a scalar which will be split on newlines.  Each expected line
      is a regular expression to match against the corresponding line
      in the file:

	  $test->run(stdout => <<_EOF_);
	  Multiple (line|lines)?
	  containing \Q$^X\E regular expressions
	  _EOF_

  --  Actual error output does not match expected error output (if any).
      The expected error output is an array of lines or a scalar which
      will be split on newlines.  Each expected line is a regular
      expression to match against the corresponding line in the file:

	  $test->run(stderr => <<_EOF_);
	  Multiple (line|lines)?
	  containing \Q$^X\E regular expressions
	  _EOF_

      This method will test for NO error output by default if no expected
      error output is specified (unlike standard output).  The error
      output test may be explicitly suppressed by specifying undef as the
      "expected" error output:

	  $test->run(stderr => undef);

=cut

sub run {
    my $self = shift;
    my %args = @_;
    my $cmd = $args{'args'};
    if (! $cmd) {
	$cmd = $args{'targets'};
	$cmd = "$args{'flags'} $cmd" if $args{'flags'};
    }
    $self->SUPER::run(@_, args => $cmd);
    my $cond = $args{'fail'} || '$? != 0';
    $self->fail(eval $cond
		=> sub {print STDERR $self->stdout, $self->stderr},
		1);
    if (defined $args{'stdout'}) {
	my @stdout = $self->stdout;
	$self->_fail_match_show('STDOUT', $args{'stdout'}, \@stdout);
    }
    $args{'stderr'} = '' if ! grep($_ eq 'stderr', keys %args);
    if (defined $args{'stderr'}) {
	my @stderr = $self->stderr;
	$self->_fail_match_show('STDERR', $args{'stderr'}, \@stderr);
    }
}



=item C<up_to_date>

Runs Cons, specifically checking to make sure that the specified targets
are already up-to-date, and nothing was rebuilt.  Takes the following
keyword-value argument pairs:

    chdir => 'subdir'
    flags => 'Cons flags',
    targets => 'targets to build'

The test fails if:

    Cons exits with an error (non-zero) status
    Cons reports anything being rebuilt
    Cons generates any error output

=cut

sub up_to_date {
    my $self = shift;
    my %args = @_;
    my @expect;
    foreach (split(/\s+/, $args{'targets'})) {
	my $invoke = $self->SUPER::basename;
	push @expect, "$invoke: \"$_\" is up-to-date.\n"
    }

    my $cmd = $args{'targets'};
    $cmd = "$args{'flags'} $cmd" if $args{'flags'};
    $self->run(@_, args => $cmd);
    $self->fail($? != 0 => sub {print $self->stderr}, 1);
    my $expect = join('', @expect);
    $self->fail($expect ne $self->stdout
		=> sub {print STDERR "Expected STDOUT ====\n",
				$expect,
				"Actual STDOUT =====\n",
				$self->stdout},
		1);
    $self->fail($self->stderr ne ''
		=> sub {print STDERR "Unexpected STDERR =====\n",
				$self->stderr},
		1);
}



=item C<execute>

Executes a program or script other than the Cons under test (typically
an executable built by the Cons invocation we're testing).

    args => 'command line arguments'
    fail => 'failure condition'	# default is '$? != 0'
    interpreter => 'prog_interpreter'
    prog => 'progam_to_execute'
    stderr => 'expected error output'
    stdout => 'expected standard output'

The execution fails if:

  --  The specified failure condition is met.  The default failure
      condition is '$? != 0', i.e. the program exits unsuccesfully.

  --  Actual standard output does not match expected standard output
      (if any).  The expected output is an array of lines or a scalar
      which will be split on newlines.  Each expected line is a regular
      expression to match against the corresponding line in the file:

	  $test->run(stdout => <<_EOF_);
	  Multiple (line|lines)?
	  containing \Q$^X\E regular expressions
	  _EOF_

  --  Actual error output does not match expected error output (if any).
      The expected error output is an array of lines or a scalar which
      will be split on newlines.  Each expected line is a regular
      expression to match against the corresponding line in the file:

	  $test->run(stderr => <<_EOF_);
	  Multiple (line|lines)?
	  containing \Q$^X\E regular expressions
	  _EOF_

=cut

sub execute {
    my $self = shift;
    my %args = @_;
    if (! $self->file_name_is_absolute($args{'prog'})) {
	$args{'prog'} = $self->catfile($self->here, $args{'prog'});
    }
    $self->SUPER::run(@_, prog => $args{'prog'});
    my $cond = $args{'fail'} || '$? != 0';
    $self->fail(eval $cond
		=> sub {print STDERR $self->stdout, $self->stderr},
		1);
    if (defined $args{'stdout'}) {
	my @stdout = $self->stdout;
	$self->_fail_match_show('STDOUT', $args{'stdout'}, \@stdout);
    }
    if (defined $args{'stderr'}) {
	my @stderr = $self->stderr;
	$self->_fail_match_show('STDERR', $args{'stderr'}, \@stderr);
    }
}



=item C<subdir>

Creates one or more subdirectories in the temporary working directory.
Exits NO RESULT if the number of subdirectories actually created does
not match the number expected.  For compatibility with its superclass
method, returns the number of subdirectories actually created.

=cut

sub subdir {
    my $self = shift;
    my $expected = @_;
    my $ret = $self->SUPER::subdir(@_);
    $self->no_result($expected != $ret,
		=> sub {print STDERR "could not create subdirectories: $!\n"},
		1);
    return $ret;
}



=item C<read>

Reads the contents of a file, depositing the contents in the destination
referred to by the first argument (a scalar or array reference).  If the
file name is not an absolute path name, it is relative to the temporary
working directory.  Exits NO RESULT if the file could not be read for
any reason.  For compatibility with its superclass method, returns TRUE
on success.

=cut

sub read {
    my $self = shift;
    my $destref = shift;
    my $ret = $self->SUPER::read($destref, @_);
    $self->no_result(! $ret
		=> sub {print STDERR "could not read file contents: $!\n"},
		1);
    return 1;
}



=item C<write>

Writes a file with the specified contents.  If the file name is not an
absolute path name, it is relative to the temporary working directory.
Exits NO RESULT if there were any errors writing the file.
For compatibility with its superclass method, returns TRUE on success.

    $test->write('file', <<_EOF_);
    contents of the file
    _EOF_

=cut

sub write {
    my $self = shift;
    my $file = shift; # the file to write to
    my $ret = $self->SUPER::write($file, @_);
    $self->no_result(! $ret
		=> sub {print STDERR "could not write $file: $!\n"},
		1);
    return 1;
}



=item C<file_matches>

Matches the contents of the specified file (first argument) against the
expected contents.  The expected contents are an array of lines or a
scalar which will be split on newlines.  Each expected line is a regular
expression to match against the corresponding line in the file:

    $test->file_matches('file', <<_EOF_);
    The (1st|first) line\.
    The (2nd|second) line\.
    _EOF_

The expe

=cut

sub file_matches {
    my($self, $file, $regexes) = @_;
    my @lines;
    my $ret = $self->SUPER::read(\@lines, $file);
    $self->no_result(! $ret
		=> sub {print STDERR "could not read file contents: $!\n"},
		1);
    $self->fail(! $self->match(\@lines, $regexes)
		=> sub {print STDERR "Expected contents of $file =====\n",
					ref $regexes ? @$regexes : $regexes,
					"Actual contents of $file =====\n",
					@lines},
		1);
}



=item C<must_exist>

Ensures that the specified files must exist.  Files may be specified as
an array reference of directory components, in which case the pathname
will be constructed by concatenating them.  Exits FAILED if any of the
files does not exist.

=cut

sub must_exist {
    my $self = shift;
    map(ref $_ ? $self->catfile(@$_) : $_, @_);
    my @missing = grep(! -e $_, @_);
    $self->fail(0 + @missing => sub {print STDERR "Files are missing: @missing\n"}, 1);
}



=item C<must_not_exist>

Ensures that the specified files must not exist.  Files may be specified
as an array reference of directory components, in which case the pathname
will be constructed by concatenating them.  Exits FAILED if any of the
files exists.

=cut

sub must_not_exist {
    my $self = shift;
    map(ref $_ ? $self->catfile(@$_) : $_, @_);
    my @exist = grep(-e $_, @_);
    $self->fail(0 + @exist => sub {print STDERR "Unexpected files exist: @exist\n"}, 1);
}



=item C<copy>

Copies a file from the source (first argument) to the destination
(second argument).  Exits NO RESULT if the file could  not be copied
for any reason.

=cut

sub copy {
    my($self, $src, $dest) = @_;
    my $ret = File::Copy::copy($src, $dest);
    $self->no_result(! $ret
		=> sub {print STDERR "Could not copy $src to $dest: $!\n"},
		1);
}



=item C<sleep>

Sleeps at least the specified number of seconds.  Sleeping more seconds
is all right.  Exits NO RESULT if the time slept was less than specified.

=cut

sub sleep {
    my($self, $seconds) = @_;
    my $ret = CORE::sleep($seconds);
    $self->no_result($ret < $seconds,
		=> sub {print STDERR "Only slept $ret seconds\n"},
		1);
}



=item C<touch>

Updates the access and modification times of the specified files.
Exits NO RESULT if any file could not be modified for any reason.

=cut

sub touch {
    my $self = shift;
    my $time = shift;
    my $expected = @_;
    my $ret = CORE::utime($time, $time, @_);
    $self->no_result($expected != $ret,
		=> sub {print STDERR "could not touch files: $!\n"},
		1);
}



=item C<unlink>

Removes the specified files.  Exits NO RESULT if any file could not be
removed for any reason.

=cut

sub unlink {
    my $self = shift;
    my @not_removed;
    my $file;
    foreach $file (@_) {
	if (! CORE::unlink($file)) {
	    push @not_removed, $file;
	}
    }
    $self->no_result(@not_removed != 0,
		=> sub {print STDERR "Could not unlink: @not_removed: $!\n"},
		1);
}



1;
__END__

=back

=head1 ENVIRONMENT

The C<Test::Cmd::Cons> module uses the following environment variables:

=over 4

=item C<CONS>

The Cons script under test.  This may be an absolute or relative path.
The script will be fed to perl and need not have execute permissions set.

=item C<CONSENV>

The Cons environment to use for tests.  This should be a string that will
be interpreted as a hash specifying the values for the local compiler,
linker, flags, etc., to be used for the tests:

	$ export CONSENV="CC => 'gcc', AR => 'ar', ARFLAGS => 'r', LINK => 'ld'"
	$ perl cons-test.pl

=item C<PERLFLAGS>

Any flags to be passed to Perl when it executes the Cons script under
test.  This is intended to be a way to execute every test using the Perl
C<-w> flag.

=back

The Test::Cmd::Cons module also uses the
C<PRESERVE>,
C<PRESERVE_FAIL>,
C<PRESERVE_NO_RESULT>,
and C<PRESERVE_PASS>
environment variables from the C<Test::Cmd> module.
See the C<Test::Cmd> documentation for details.

=head1 SEE ALSO

perl(1), Test::Cmd(3).

=head1 AUTHOR

Steven Knight, knight@baldmt.com

=head1 ACKNOWLEDGEMENTS

Thanks to Greg Spencer for the inspiration to create this package and
to rewrite all of the cons-test scripts in Perl.

The general idea of testing Cons in this way, as well as the test
reporting of the C<pass>, C<fail> and C<no_result> methods, come from the
testing framework invented by Peter Miller for his Aegis project change
supervisor.  Aegis is an excellent bit of work which integrates creation
and execution of regression tests into the software development process.
Information about Aegis is available at:

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

=cut