# Copyright 1999-2001 Steven Knight. All rights reserved. This program
# is free software; you can redistribute it and/or modify it under the
# same terms as Perl itself.
######################### We start with some black magic to print on failure.
use Config;
use Test;
my $iswin32;
BEGIN {
$| = 1;
if ($] < 5.003) {
eval("require Win32");
$iswin32 = ! $@;
} else {
$iswin32 = $^O eq "MSWin32";
}
plan tests => 53, onfail => sub { $? = 1 if $ENV{AEGIS_TEST} }
}
END {print "not ok 1\n" unless $loaded;}
use Test::Cmd;
$loaded = 1;
ok(1);
######################### End of black magic.
my($run_env, $ret, $testx, $test, $subdir);
#
# The following complicated dance attempts to ensure we can create
# an executable Perl script named "scriptx" on both UNIX and Win32
# systems. We want it to be Perl since it's about the only thing
# that we can rely on in common between the systems.
#
# The UNIX side is easy; we just put our desired Perl script in
# the file name with $Config{startperl} at the top, chmod it
# executable, and away we go.
#
# For Win32, we go the route of creating a "scriptx.bat" file with
# the magic header that reads as both an NT and a Perl script.
# The hassle is that we want this .bat file to be executable
# regardless of where we are at the moment, and the only way I
# could figure out how to do this was to put the absolute path
# name to the file in the .bat file as the first argument to
# the perl.exe invocation. This means that we have to create our
# initial running environments up front, so we know where the
# "scriptx.bat" file will end up and can put its path name in
# itself.
#
# If anyone cares to suggest an easier way to do this, I'd be
# thrilled to hear about it.
#
$My_Config{_bat} = $iswin32 ? '.bat' : '';
$run_env = Test::Cmd->new(workdir => '');
ok($run_env);
$wdir = $run_env->workdir;
ok($wdir);
$ret = chdir($wdir);
ok($ret);
my $script = "script";
my $scriptx = "scriptx$My_Config{_bat}";
if ($iswin32) {
my $workpath_scriptx = $run_env->workpath($scriptx);
$My_Config{startperl} = <<EOF;
\@rem = '--*-PERL-*--';
\@rem = '
\@echo off
rem setlocal
set ARGS=
:loop
if .%1==. goto endloop
set ARGS=%ARGS% %1
shift
goto loop
:endloop
rem ***** This assumes PERL is in the PATH *****
perl.exe $workpath_scriptx %ARGS%
goto endofperl
\@rem ';
EOF
$My_Config{endperl} = <<'EOF';
#:endofperl
EOF
$My_Config{cwd_pkg} = 'Win32';
$My_Config{cwd_sub} = 'Win32::GetCwd';
} else {
$My_Config{startperl} = $Config{startperl};
$My_Config{endperl} = '';
$My_Config{cwd_pkg} = 'Cwd';
$My_Config{cwd_sub} = 'cwd';
}
#
$ret = $run_env->write($script, <<EOF);
use $My_Config{cwd_pkg};
my \$cwd = $My_Config{cwd_sub}();
print STDOUT "$script: \$string: STDOUT: \$cwd: '\@ARGV'\\n";
print STDERR "$script: \$string: STDERR: \$cwd: '\@ARGV'\\n";
exit 0;
EOF
ok($ret);
$ret = $run_env->write('xxx.pm', <<EOF);
\$string = 'xxx';
EOF
ok($ret);
$ret = $run_env->write('yyy.pm', <<EOF);
\$string = 'yyy';
EOF
ok($ret);
$ret = $run_env->write($scriptx, <<EOF);
$My_Config{startperl}
use $My_Config{cwd_pkg};
my \$cwd = $My_Config{cwd_sub}();
print STDOUT "$scriptx: \$string: STDOUT: \$cwd: '\@ARGV'\\n";
print STDERR "$scriptx: \$string: STDERR: \$cwd: '\@ARGV'\\n";
exit 0;
$My_Config{endperl};
EOF
ok($ret);
$ret = chmod(0755, $scriptx) if ! $iswin32;
skip($iswin32, $ret == 1);
ok(! -x $script);
ok(-x $scriptx);
# Everything before this was merely preparation of our "source
# directory." Now we do some real tests.
#
$test = Test::Cmd->new(prog => 'script', interpreter => "$^X -I$wdir -Mxxx", workdir => '', subdir => 'script_subdir');
ok($test);
$ret = $test->run();
ok($ret == 0);
ok($test->stdout eq "script: xxx: STDOUT: $wdir: ''\n");
ok($test->stderr eq "script: xxx: STDERR: $wdir: ''\n");
$ret = $test->run(args => 'arg1 arg2 arg3');
ok($ret == 0);
ok($test->stdout eq "script: xxx: STDOUT: $wdir: 'arg1 arg2 arg3'\n");
# Execute "scriptx" in the middle of the run here,
# so we know it doesn't affect the $test->prog value.
# Note that it should not pick up the test environment's
# interpreter value with "-Mxxx" in it.
$ret = $test->run(prog => 'scriptx', args => 'foo');
ok($ret == 0);
ok($test->stdout eq "$scriptx: : STDOUT: $wdir: 'foo'\n");
ok($test->stderr eq "$scriptx: : STDERR: $wdir: 'foo'\n");
$ret = $test->run(chdir => $test->curdir, args => 'x y z');
ok($ret == 0);
ok($test->stdout eq "script: xxx: STDOUT: ${\$test->workdir}: 'x y z'\n");
ok($test->stderr eq "script: xxx: STDERR: ${\$test->workdir}: 'x y z'\n");
$subdir = $test->workpath('script_subdir');
$ret = $test->run(chdir => 'script_subdir');
ok($ret == 0);
ok($test->stdout eq "script: xxx: STDOUT: $subdir: ''\n");
ok($test->stderr eq "script: xxx: STDERR: $subdir: ''\n");
$ret = $test->run(chdir => 'no_subdir');
ok(! defined $ret);
$ret = $test->run(prog => 'no_script', interpreter => $^X);
ok($ret != 0);
$ret = $test->run(prog => 'script');
ok($ret != 0);
$ret = $test->run(prog => 'script', interpreter => 'no_interpreter');
ok($ret != 0);
$ret = $test->run(prog => 'no_script', interpreter => 'no_interpreter');
ok($ret != 0);
$ret = $test->run(interpreter => 'no_interpreter');
ok($ret != 0);
$ret = $test->run(interpreter => "$^X -I$wdir -Myyy", args => 'zzz');
ok($ret == 0);
ok($test->stdout eq "script: yyy: STDOUT: $wdir: 'zzz'\n");
ok($test->stderr eq "script: yyy: STDERR: $wdir: 'zzz'\n");
#
$testx = Test::Cmd->new(prog => 'scriptx', workdir => '', subdir => 'scriptx_subdir');
ok($testx);
$ret = $testx->run();
ok($ret == 0);
ok($testx->stdout eq "$scriptx: : STDOUT: $wdir: ''\n");
ok($testx->stderr eq "$scriptx: : STDERR: $wdir: ''\n");
$ret = $testx->run(args => 'foo bar');
ok($ret == 0);
ok($testx->stdout eq "$scriptx: : STDOUT: $wdir: 'foo bar'\n");
ok($testx->stderr eq "$scriptx: : STDERR: $wdir: 'foo bar'\n");
# Execute "script" in the middle of the run here,
# so we know it doesn't affect the $test->prog value.
$ret = $testx->run(prog => 'script', interpreter => "$^X -I$wdir -Mxxx", args => 'bar');
ok($ret == 0);
ok($testx->stdout eq "script: xxx: STDOUT: $wdir: 'bar'\n");
ok($testx->stderr eq "script: xxx: STDERR: $wdir: 'bar'\n");
$ret = $testx->run(chdir => $testx->curdir, args => 'baz');
ok($ret == 0);
ok($testx->stdout eq "$scriptx: : STDOUT: ${\$testx->workdir}: 'baz'\n");
ok($testx->stderr eq "$scriptx: : STDERR: ${\$testx->workdir}: 'baz'\n");
$subdir = $testx->workpath('scriptx_subdir');
$ret = $testx->run(chdir => 'scriptx_subdir');
ok($ret == 0);
ok($testx->stdout eq "$scriptx: : STDOUT: $subdir: ''\n");
ok($testx->stderr eq "$scriptx: : STDERR: $subdir: ''\n");
$ret = $testx->run(chdir => 'no_subdir');
ok(! defined $ret);
$ret = $testx->run(prog => 'no_prog');
ok($ret != 0);