9 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
12 @EXPORT = (@Test::More::EXPORT, qw(setup indir app test run));
13 @EXPORT_OK = (@Test::More::EXPORT_OK, qw(top_dir top_file pipe with cmdstr
18 use File::Spec::Functions qw/file_name_is_absolute curdir canonpath splitdir
19 catdir catfile splitpath catpath devnull abs2rel
21 use File::Path 2.00 qw/remove_tree mkpath/;
24 my $test_name = undef;
26 my %directories = (); # Directories we want to keep track of
27 # TOP, APPS, TEST and RESULTS are the
28 # ones we're interested in, corresponding
29 # to the environment variables TOP (mandatory),
30 # BIN_D, TEST_D and RESULT_D.
32 my $end_with_bailout = 0;
37 BAIL_OUT("Must run setup() first") if (! $test_name);
40 return catfile($directories{TOP},@_,$f);
44 BAIL_OUT("Must run setup() first") if (! $test_name);
47 return catfile($directories{TEST},@_,$f);
51 BAIL_OUT("Must run setup() first") if (! $test_name);
54 return catfile($directories{APPS},@_,$f);
58 BAIL_OUT("Must run setup() first") if (! $test_name);
61 return catfile($directories{RESULTS},@_,$f);
65 return __results_file("$test_name.log");
69 return __top_file(@_, ""); # This caters for operating systems that have
70 # a very distinct syntax for directories.
73 return __top_file(@_);
79 my $abscurdir = rel2abs(curdir());
80 my $absdir = rel2abs($dir);
81 my $reverse = abs2rel($abscurdir, $absdir);
83 # PARANOIA: if we're not moving anywhere, we do nothing more
84 if ($abscurdir eq $absdir) {
88 # Do not support a move to a different volume for now. Maybe later.
89 BAIL_OUT("FAILURE: \"$dir\" moves to a different volume, not supported")
90 if $reverse eq $abscurdir;
92 # If someone happened to give a directory that leads back to the current,
93 # it's extremely silly to do anything more, so just simulate that we did
95 # In this case, we won't even clean it out, for safety's sake.
96 return "." if $reverse eq "";
98 $dir = canonpath($dir);
103 # Should we just bail out here as well? I'm unsure.
104 return undef unless chdir($dir);
106 if ($opts{cleanup}) {
107 remove_tree(".", { safe => 0, keep_root => 1 });
110 # For each of these directory variables, figure out where they are relative
111 # to the directory we want to move to if they aren't absolute (if they are,
112 # they don't change!)
113 my @dirtags = ("TOP", "TEST", "APPS", "RESULTS");
115 if (!file_name_is_absolute($directories{$_})) {
116 my $newpath = abs2rel(rel2abs($directories{$_}), rel2abs($dir));
117 $directories{$_} = $newpath;
122 print STDERR "DEBUG: __cwd(), directories and files:\n";
123 print STDERR " \$directories{TEST} = \"$directories{TEST}\"\n";
124 print STDERR " \$directories{RESULTS} = \"$directories{RESULTS}\"\n";
125 print STDERR " \$directories{APPS} = \"$directories{APPS}\"\n";
126 print STDERR " \$directories{TOP} = \"$directories{TOP}\"\n";
127 print STDERR " \$test_log = \"",__test_log(),"\"\n";
129 print STDERR " current directory is \"",curdir(),"\"\n";
130 print STDERR " the way back is \"$reverse\"\n";
139 BAIL_OUT("setup() must receive a name") unless $test_name;
140 BAIL_OUT("setup() needs \$TOP to be defined") unless $ENV{TOP};
142 $directories{TOP} = $ENV{TOP},
143 $directories{APPS} = $ENV{BIN_D} || catdir($directories{TOP},"apps");
144 $directories{TEST} = $ENV{TEST_D} || catdir($directories{TOP},"test");
145 $directories{RESULTS} = $ENV{RESULT_D} || $directories{TEST};
147 $end_with_bailout = $ENV{STOPTEST} ? 1 : 0;
149 BAIL_OUT("setup() expects the file Configure in the \$TOP directory")
150 unless -f top_file("Configure");
152 __cwd($directories{RESULTS});
154 # Loop in case we're on a platform with more than one file generation
155 1 while unlink(__test_log());
160 my $codeblock = shift;
163 my $reverse = __cwd($subdir,%opts);
164 BAIL_OUT("FAILURE: indir, \"$subdir\" wasn't possible to move into")
171 if ($opts{cleanup}) {
172 remove_tree($subdir, { safe => 0 });
177 exit_checker => sub { return shift == 0 ? 1 : 0 }
183 my $codeblock = shift;
185 my %saved_hooks = ();
187 foreach (keys %opts) {
188 $saved_hooks{$_} = $hooks{$_} if exists($hooks{$_});
189 $hooks{$_} = $opts{$_};
194 foreach (keys %saved_hooks) {
195 $hooks{$_} = $saved_hooks{$_};
202 my $prefix = __top_file("util", "shlib_wrap.sh")." ";
203 my $ext = $ENV{"EXE_EXT"} || "";
205 if ( $^O eq "VMS" ) { # VMS
208 } elsif ($^O eq "MSWin32") { # Windows
213 # We test both with and without extension. The reason
214 # is that we might, for example, be passed a Perl script
216 my $file = "$prog$ext";
218 return $prefix.$file;
219 } elsif ( -f $prog ) {
223 print STDERR "$prog not found\n";
228 BAIL_OUT("Must run setup() first") if (! $test_name);
231 my $path_builder = shift;
232 my $cmd = __fixup_cmd($path_builder->(shift @{$_[0]}));
233 my @args = @{$_[0]}; shift;
239 my $null = devnull();
242 $arg_str = " ".join(" ", quotify @args) if @args;
244 my $fileornull = sub { $_[0] ? $_[0] : $null; };
248 my $saved_stderr = undef;
249 $stdin = " < ".$fileornull->($opts{stdin}) if exists($opts{stdin});
250 $stdout= " > ".$fileornull->($opts{stdout}) if exists($opts{stdout});
251 $stderr=" 2> ".$fileornull->($opts{stderr}) if exists($opts{stderr});
253 $saved_stderr = $opts{stderr} if defined($opts{stderr});
255 my $errlog = $num ? "$test_name.$num.tmp_err" : "$test_name.tmp_err";
256 my $display_cmd = "$cmd$arg_str$stdin$stdout$stderr";
257 $cmd .= "$arg_str$stdin$stdout 2> $errlog";
259 return ($cmd, $display_cmd, $errlog => $saved_stderr);
265 return sub { my $num = shift;
266 return __build_cmd($num, \&__apps_file, $cmd, %opts); }
272 return sub { my $num = shift;
273 return __build_cmd($num, \&__test_file, $cmd, %opts); }
277 my ($cmd, $display_cmd, %errlogs) = shift->(0);
283 my $tb = Test::More->builder;
284 my $failure = scalar(grep { $_ == 0; } $tb->summary);
285 if ($failure && $end_with_bailout) {
286 BAIL_OUT("Stoptest!");
290 my ($cmd, $display_cmd, %errlogs) = shift->(0);
296 if ( $^O eq "VMS" ) { # VMS
298 } elsif ($^O eq "MSWin32") { # MSYS
305 if ($opts{capture}) {
309 system("$prefix$cmd");
311 $r = $hooks{exit_checker}->($e);
314 # At this point, $? stops being interesting, and unfortunately,
315 # there are Test::More versions that get picky if we leave it
319 open ERR, ">>", __test_log();
320 { local $| = 1; print ERR "$display_cmd => $e\n"; }
321 foreach (keys %errlogs) {
323 copy($_,$errlogs{$_}) if defined($errlogs{$_});
328 if ($opts{capture}) {
344 my ($c, $dc, @el) = $_->(++$counter);
360 # Utility functions, some of which are exported on request
363 # Unix setup (default if nothing else is mentioned)
365 sub { $_ = shift; /\s|[\{\}\\\$\[\]\*\?\|\&:;<>]/ ? "'$_'" : $_ };
367 if ( $^O eq "VMS") { # VMS setup
368 $arg_formatter = sub {
370 if (/\s|["[:upper:]]/) {
377 } elsif ( $^O eq "MSWin32") { # MSWin setup
378 $arg_formatter = sub {
380 if (/\s|["\|\&\*\;<>]/) {
389 return map { $arg_formatter->($_) } @_;