Test.pm 25.2 KB
Newer Older
1 2 3 4 5 6 7
# Copyright 2016 The OpenSSL Project Authors. All Rights Reserved.
#
# Licensed under the OpenSSL license (the "License").  You may not use
# this file except in compliance with the License.  You can obtain a copy
# in the file LICENSE in the source distribution or at
# https://www.openssl.org/source/license.html

8 9 10 11 12
package OpenSSL::Test;

use strict;
use warnings;

13 14
use Test::More 0.96;

15 16
use Exporter;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
17
$VERSION = "0.8";
18
@ISA = qw(Exporter);
19
@EXPORT = (@Test::More::EXPORT, qw(setup indir app perlapp test perltest run));
20 21 22
@EXPORT_OK = (@Test::More::EXPORT_OK, qw(bldtop_dir bldtop_file
                                         srctop_dir srctop_file
                                         pipe with cmdstr quotify));
23

24
=head1 NAME
25

26
OpenSSL::Test - a private extension of Test::More
27

28
=head1 SYNOPSIS
29

30
  use OpenSSL::Test;
31

32
  setup("my_test_name");
33

34
  ok(run(app(["openssl", "version"])), "check for openssl presence");
R
Richard Levitte 已提交
35

36 37 38 39
  indir "subdir" => sub {
    ok(run(test(["sometest", "arg1"], stdout => "foo.txt")),
       "run sometest with output to foo.txt");
  };
40

41
=head1 DESCRIPTION
42

43 44 45 46
This module is a private extension of L<Test::More> for testing OpenSSL.
In addition to the Test::More functions, it also provides functions that
easily find the diverse programs within a OpenSSL build tree, as well as
some other useful functions.
47

48 49 50
This module I<depends> on the environment variables C<$TOP> or C<$SRCTOP>
and C<$BLDTOP>.  Without one of the combinations it refuses to work.
See L</ENVIRONMENT> below.
51

52
=cut
53

54 55 56 57
use File::Copy;
use File::Spec::Functions qw/file_name_is_absolute curdir canonpath splitdir
                             catdir catfile splitpath catpath devnull abs2rel
                             rel2abs/;
58
use File::Path 2.00 qw/rmtree mkpath/;
59 60


61 62 63
# The name of the test.  This is set by setup() and is used in the other
# functions to verify that setup() has been used.
my $test_name = undef;
64

65 66
# Directories we want to keep track of TOP, APPS, TEST and RESULTS are the
# ones we're interested in, corresponding to the environment variables TOP
67
# (mandatory), BIN_D, TEST_D, UTIL_D and RESULT_D.
68
my %directories = ();
69

70 71 72 73 74
# The environment variables that gave us the contents in %directories.  These
# get modified whenever we change directories, so that subprocesses can use
# the values of those environment variables as well
my @direnv = ();

75 76 77 78
# A bool saying if we shall stop all testing if the current recipe has failing
# tests or not.  This is set by setup() if the environment variable STOPTEST
# is defined with a non-empty value.
my $end_with_bailout = 0;
79

80 81 82
# A set of hooks that is affected by with() and may be used in diverse places.
# All hooks are expected to be CODE references.
my %hooks = (
83

84 85 86 87 88 89
    # exit_checker is used by run() directly after completion of a command.
    # it receives the exit code from that command and is expected to return
    # 1 (for success) or 0 (for failure).  This is the value that will be
    # returned by run().
    # NOTE: When run() gets the option 'capture => 1', this hook is ignored.
    exit_checker => sub { return shift == 0 ? 1 : 0 },
90

91
    );
92

93 94 95
# Debug flag, to be set manually when needed
my $debug = 0;

96
# Declare some utility functions that are defined at the end
97 98 99 100
sub bldtop_file;
sub bldtop_dir;
sub srctop_file;
sub srctop_dir;
101
sub quotify;
102

103 104 105 106 107 108 109
# Declare some private functions that are defined at the end
sub __env;
sub __cwd;
sub __apps_file;
sub __results_file;
sub __fixup_cmd;
sub __build_cmd;
110

111
=head2 Main functions
112

113
The following functions are exported by default when using C<OpenSSL::Test>.
114

115
=cut
116

117
=over 4
118

119
=item B<setup "NAME">
120

121 122 123 124 125
C<setup> is used for initial setup, and it is mandatory that it's used.
If it's not used in a OpenSSL test recipe, the rest of the recipe will
most likely refuse to run.

C<setup> checks for environment variables (see L</ENVIRONMENT> below),
126 127 128 129
checks that C<$TOP/Configure> or C<$SRCTOP/Configure> exists, C<chdir>
into the results directory (defined by the C<$RESULT_D> environment
variable if defined, otherwise C<$BLDTOP/test> or C<$TOP/test>, whichever
is defined).
130 131 132 133

=back

=cut
134 135

sub setup {
136
    my $old_test_name = $test_name;
137 138 139
    $test_name = shift;

    BAIL_OUT("setup() must receive a name") unless $test_name;
140 141 142 143 144
    warn "setup() detected test name change.  Innocuous, so we continue...\n"
        if $old_test_name && $old_test_name ne $test_name;

    return if $old_test_name;

145 146 147 148
    BAIL_OUT("setup() needs \$TOP or \$SRCTOP and \$BLDTOP to be defined")
        unless $ENV{TOP} || ($ENV{SRCTOP} && $ENV{BLDTOP});
    BAIL_OUT("setup() found both \$TOP and \$SRCTOP or \$BLDTOP...")
        if $ENV{TOP} && ($ENV{SRCTOP} || $ENV{BLDTOP});
149

150
    __env();
R
Richard Levitte 已提交
151

152 153
    BAIL_OUT("setup() expects the file Configure in the source top directory")
        unless -f srctop_file("Configure");
154 155 156 157

    __cwd($directories{RESULTS});
}

158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199
=over 4

=item B<indir "SUBDIR" =E<gt> sub BLOCK, OPTS>

C<indir> is used to run a part of the recipe in a different directory than
the one C<setup> moved into, usually a subdirectory, given by SUBDIR.
The part of the recipe that's run there is given by the codeblock BLOCK.

C<indir> takes some additional options OPTS that affect the subdirectory:

=over 4

=item B<create =E<gt> 0|1>

When set to 1 (or any value that perl preceives as true), the subdirectory
will be created if it doesn't already exist.  This happens before BLOCK
is executed.

=item B<cleanup =E<gt> 0|1>

When set to 1 (or any value that perl preceives as true), the subdirectory
will be cleaned out and removed.  This happens both before and after BLOCK
is executed.

=back

An example:

  indir "foo" => sub {
      ok(run(app(["openssl", "version"]), stdout => "foo.txt"));
      if (ok(open(RESULT, "foo.txt"), "reading foo.txt")) {
          my $line = <RESULT>;
          close RESULT;
          is($line, qr/^OpenSSL 1\./,
             "check that we're using OpenSSL 1.x.x");
      }
  }, create => 1, cleanup => 1;

=back

=cut

200 201 202 203 204 205 206 207 208 209 210 211 212 213
sub indir {
    my $subdir = shift;
    my $codeblock = shift;
    my %opts = @_;

    my $reverse = __cwd($subdir,%opts);
    BAIL_OUT("FAILURE: indir, \"$subdir\" wasn't possible to move into")
	unless $reverse;

    $codeblock->();

    __cwd($reverse);

    if ($opts{cleanup}) {
214
	rmtree($subdir, { safe => 0 });
215 216 217
    }
}

218
=over 4
219

220
=item B<app ARRAYREF, OPTS>
221

222
=item B<test ARRAYREF, OPTS>
223

224 225
Both of these functions take a reference to a list that is a command and
its arguments, and some additional options (described further on).
226

227
C<app> expects to find the given command (the first item in the given list
228 229
reference) as an executable in C<$BIN_D> (if defined, otherwise C<$TOP/apps>
or C<$BLDTOP/apps>).
230

231
C<test> expects to find the given command (the first item in the given list
232 233
reference) as an executable in C<$TEST_D> (if defined, otherwise C<$TOP/test>
or C<$BLDTOP/test>).
234

235
Both return a CODEREF to be used by C<run>, C<pipe> or C<cmdstr>.
236

237 238
The options that both C<app> and C<test> can take are in the form of hash
values:
239

240
=over 4
241

242
=item B<stdin =E<gt> PATH>
243

244
=item B<stdout =E<gt> PATH>
245

246
=item B<stderr =E<gt> PATH>
247

248 249 250
In all three cases, the corresponding standard input, output or error is
redirected from (for stdin) or to (for the others) a file given by the
string PATH, I<or>, if the value is C<undef>, C</dev/null> or similar.
251

252
=back
253

254 255 256 257 258
=item B<perlapp ARRAYREF, OPTS>

=item B<perltest ARRAYREF, OPTS>

Both these functions function the same way as B<app> and B<test>, except
259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275
that they expect the command to be a perl script.  Also, they support one
more option:

=over 4

=item B<interpreter_args =E<gt> ARRAYref>

The array reference is a set of arguments for perl rather than the script.
Take care so that none of them can be seen as a script!  Flags and their
eventual arguments only!

=back

An example:

  ok(run(perlapp(["foo.pl", "arg1"],
                 interpreter_args => [ "-I", srctop_dir("test") ])));
276

277
=back
278

279
=cut
280 281 282 283 284 285 286 287 288 289 290 291 292 293 294

sub app {
    my $cmd = shift;
    my %opts = @_;
    return sub { my $num = shift;
		 return __build_cmd($num, \&__apps_file, $cmd, %opts); }
}

sub test {
    my $cmd = shift;
    my %opts = @_;
    return sub { my $num = shift;
		 return __build_cmd($num, \&__test_file, $cmd, %opts); }
}

295 296 297 298 299 300 301 302 303 304 305 306 307 308
sub perlapp {
    my $cmd = shift;
    my %opts = @_;
    return sub { my $num = shift;
		 return __build_cmd($num, \&__perlapps_file, $cmd, %opts); }
}

sub perltest {
    my $cmd = shift;
    my %opts = @_;
    return sub { my $num = shift;
		 return __build_cmd($num, \&__perltest_file, $cmd, %opts); }
}

309
=over 4
310

311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339
=item B<run CODEREF, OPTS>

This CODEREF is expected to be the value return by C<app> or C<test>,
anything else will most likely cause an error unless you know what you're
doing.

C<run> executes the command returned by CODEREF and return either the
resulting output (if the option C<capture> is set true) or a boolean indicating
if the command succeeded or not.

The options that C<run> can take are in the form of hash values:

=over 4

=item B<capture =E<gt> 0|1>

If true, the command will be executed with a perl backtick, and C<run> will
return the resulting output as an array of lines.  If false or not given,
the command will be executed with C<system()>, and C<run> will return 1 if
the command was successful or 0 if it wasn't.

=back

For further discussion on what is considered a successful command or not, see
the function C<with> further down.

=back

=cut
340 341

sub run {
342
    my ($cmd, $display_cmd) = shift->(0);
343 344 345 346 347 348 349 350 351 352 353 354
    my %opts = @_;

    return () if !$cmd;

    my $prefix = "";
    if ( $^O eq "VMS" ) {	# VMS
	$prefix = "pipe ";
    }

    my @r = ();
    my $r = 0;
    my $e = 0;
355

356 357 358 359 360 361 362 363 364 365
    # In non-verbose, we want to shut up the command interpreter, in case
    # it has something to complain about.  On VMS, it might complain both
    # on stdout and stderr
    *save_STDOUT = *STDOUT;
    *save_STDERR = *STDERR;
    if ($ENV{HARNESS_ACTIVE} && !$ENV{HARNESS_VERBOSE}) {
        open STDOUT, ">", devnull();
        open STDERR, ">", devnull();
    }

366 367 368 369
    # The dance we do with $? is the same dance the Unix shells appear to
    # do.  For example, a program that gets aborted (and therefore signals
    # SIGABRT = 6) will appear to exit with the code 134.  We mimic this
    # to make it easier to compare with a manual run of the command.
370 371
    if ($opts{capture}) {
	@r = `$prefix$cmd`;
372
	$e = ($? & 0x7f) ? ($? & 0x7f)|0x80 : ($? >> 8);
373 374
    } else {
	system("$prefix$cmd");
375
	$e = ($? & 0x7f) ? ($? & 0x7f)|0x80 : ($? >> 8);
376 377 378
	$r = $hooks{exit_checker}->($e);
    }

379 380 381 382 383 384 385
    if ($ENV{HARNESS_ACTIVE} && !$ENV{HARNESS_VERBOSE}) {
        close STDOUT;
        close STDERR;
    }
    *STDOUT = *save_STDOUT;
    *STDERR = *save_STDERR;

386
    print STDERR "$prefix$display_cmd => $e\n"
387 388
        if !$ENV{HARNESS_ACTIVE} || $ENV{HARNESS_VERBOSE};

389 390 391 392 393 394 395 396 397 398 399 400
    # At this point, $? stops being interesting, and unfortunately,
    # there are Test::More versions that get picky if we leave it
    # non-zero.
    $? = 0;

    if ($opts{capture}) {
	return @r;
    } else {
	return $r;
    }
}

401 402 403 404 405 406 407 408 409 410 411 412
END {
    my $tb = Test::More->builder;
    my $failure = scalar(grep { $_ == 0; } $tb->summary);
    if ($failure && $end_with_bailout) {
	BAIL_OUT("Stoptest!");
    }
}

=head2 Utility functions

The following functions are exported on request when using C<OpenSSL::Test>.

413 414
  # To only get the bldtop_file and srctop_file functions.
  use OpenSSL::Test qw/bldtop_file srctop_file/;
415

416 417
  # To only get the bldtop_file function in addition to the default ones.
  use OpenSSL::Test qw/:DEFAULT bldtop_file/;
418 419 420 421 422 423 424

=cut

# Utility functions, exported on request

=over 4

425
=item B<bldtop_dir LIST>
426 427

LIST is a list of directories that make up a path from the top of the OpenSSL
428 429 430
build directory (as indicated by the environment variable C<$TOP> or
C<$BLDTOP>).
C<bldtop_dir> returns the resulting directory as a string, adapted to the local
431 432 433 434 435 436
operating system.

=back

=cut

437 438
sub bldtop_dir {
    return __bldtop_dir(@_);	# This caters for operating systems that have
439 440 441 442 443
				# a very distinct syntax for directories.
}

=over 4

444
=item B<bldtop_file LIST, FILENAME>
445 446

LIST is a list of directories that make up a path from the top of the OpenSSL
447 448 449
build directory (as indicated by the environment variable C<$TOP> or
C<$BLDTOP>) and FILENAME is the name of a file located in that directory path.
C<bldtop_file> returns the resulting file path as a string, adapted to the local
450 451 452 453 454 455
operating system.

=back

=cut

456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494
sub bldtop_file {
    return __bldtop_file(@_);
}

=over 4

=item B<srctop_dir LIST>

LIST is a list of directories that make up a path from the top of the OpenSSL
source directory (as indicated by the environment variable C<$TOP> or
C<$SRCTOP>).
C<srctop_dir> returns the resulting directory as a string, adapted to the local
operating system.

=back

=cut

sub srctop_dir {
    return __srctop_dir(@_);	# This caters for operating systems that have
				# a very distinct syntax for directories.
}

=over 4

=item B<srctop_file LIST, FILENAME>

LIST is a list of directories that make up a path from the top of the OpenSSL
source directory (as indicated by the environment variable C<$TOP> or
C<$SRCTOP>) and FILENAME is the name of a file located in that directory path.
C<srctop_file> returns the resulting file path as a string, adapted to the local
operating system.

=back

=cut

sub srctop_file {
    return __srctop_file(@_);
495 496 497 498 499 500 501 502 503 504 505 506 507 508 509
}

=over 4

=item B<pipe LIST>

LIST is a list of CODEREFs returned by C<app> or C<test>, from which C<pipe>
creates a new command composed of all the given commands put together in a
pipe.  C<pipe> returns a new CODEREF in the same manner as C<app> or C<test>,
to be passed to C<run> for execution.

=back

=cut

510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534
sub pipe {
    my @cmds = @_;
    return
	sub {
	    my @cs  = ();
	    my @dcs = ();
	    my @els = ();
	    my $counter = 0;
	    foreach (@cmds) {
		my ($c, $dc, @el) = $_->(++$counter);

		return () if !$c;

		push @cs, $c;
		push @dcs, $dc;
		push @els, @el;
	    }
	    return (
		join(" | ", @cs),
		join(" | ", @dcs),
		@els
		);
    };
}

535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579
=over 4

=item B<with HASHREF, CODEREF>

C<with> will temporarly install hooks given by the HASHREF and then execute
the given CODEREF.  Hooks are usually expected to have a coderef as value.

The currently available hoosk are:

=over 4

=item B<exit_checker =E<gt> CODEREF>

This hook is executed after C<run> has performed its given command.  The
CODEREF receives the exit code as only argument and is expected to return
1 (if the exit code indicated success) or 0 (if the exit code indicated
failure).

=back

=back

=cut

sub with {
    my $opts = shift;
    my %opts = %{$opts};
    my $codeblock = shift;

    my %saved_hooks = ();

    foreach (keys %opts) {
	$saved_hooks{$_} = $hooks{$_}	if exists($hooks{$_});
	$hooks{$_} = $opts{$_};
    }

    $codeblock->();

    foreach (keys %saved_hooks) {
	$hooks{$_} = $saved_hooks{$_};
    }
}

=over 4

580
=item B<cmdstr CODEREF, OPTS>
581 582 583 584

C<cmdstr> takes a CODEREF from C<app> or C<test> and simply returns the
command as a string.

585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602
C<cmdstr> takes some additiona options OPTS that affect the string returned:

=over 4

=item B<display =E<gt> 0|1>

When set to 0, the returned string will be with all decorations, such as a
possible redirect of stderr to the null device.  This is suitable if the
string is to be used directly in a recipe.

When set to 1, the returned string will be without extra decorations.  This
is suitable for display if that is desired (doesn't confuse people with all
internal stuff), or if it's used to pass a command down to a subprocess.

Default: 0

=back

603 604 605 606 607
=back

=cut

sub cmdstr {
608
    my ($cmd, $display_cmd) = shift->(0);
609
    my %opts = @_;
610

611 612 613 614 615
    if ($opts{display}) {
        return $display_cmd;
    } else {
        return $cmd;
    }
616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631
}

=over 4

=item B<quotify LIST>

LIST is a list of strings that are going to be used as arguments for a
command, and makes sure to inject quotes and escapes as necessary depending
on the content of each string.

This can also be used to put quotes around the executable of a command.
I<This must never ever be done on VMS.>

=back

=cut
632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662

sub quotify {
    # Unix setup (default if nothing else is mentioned)
    my $arg_formatter =
	sub { $_ = shift; /\s|[\{\}\\\$\[\]\*\?\|\&:;<>]/ ? "'$_'" : $_ };

    if ( $^O eq "VMS") {	# VMS setup
	$arg_formatter = sub {
	    $_ = shift;
	    if (/\s|["[:upper:]]/) {
		s/"/""/g;
		'"'.$_.'"';
	    } else {
		$_;
	    }
	};
    } elsif ( $^O eq "MSWin32") { # MSWin setup
	$arg_formatter = sub {
	    $_ = shift;
	    if (/\s|["\|\&\*\;<>]/) {
		s/(["\\])/\\$1/g;
		'"'.$_.'"';
	    } else {
		$_;
	    }
	};
    }

    return map { $arg_formatter->($_) } @_;
}

663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697
######################################################################
# private functions.  These are never exported.

=head1 ENVIRONMENT

OpenSSL::Test depends on some environment variables.

=over 4

=item B<TOP>

This environment variable is mandatory.  C<setup> will check that it's
defined and that it's a directory that contains the file C<Configure>.
If this isn't so, C<setup> will C<BAIL_OUT>.

=item B<BIN_D>

If defined, its value should be the directory where the openssl application
is located.  Defaults to C<$TOP/apps> (adapted to the operating system).

=item B<TEST_D>

If defined, its value should be the directory where the test applications
are located.  Defaults to C<$TOP/test> (adapted to the operating system).

=item B<STOPTEST>

If defined, it puts testing in a different mode, where a recipe with
failures will result in a C<BAIL_OUT> at the end of its run.

=back

=cut

sub __env {
698 699
    $directories{SRCTOP}  = $ENV{SRCTOP} || $ENV{TOP};
    $directories{BLDTOP}  = $ENV{BLDTOP} || $ENV{TOP};
700 701 702 703 704
    $directories{BLDAPPS} = $ENV{BIN_D}  || __bldtop_dir("apps");
    $directories{SRCAPPS} =                 __srctop_dir("apps");
    $directories{BLDTEST} = $ENV{TEST_D} || __bldtop_dir("test");
    $directories{SRCTEST} =                 __srctop_dir("test");
    $directories{RESULTS} = $ENV{RESULT_D} || $directories{BLDTEST};
705

706 707 708 709 710 711 712
    push @direnv, "TOP"       if $ENV{TOP};
    push @direnv, "SRCTOP"    if $ENV{SRCTOP};
    push @direnv, "BLDTOP"    if $ENV{BLDTOP};
    push @direnv, "BIN_D"     if $ENV{BIN_D};
    push @direnv, "TEST_D"    if $ENV{TEST_D};
    push @direnv, "RESULT_D"  if $ENV{RESULT_D};

713 714 715
    $end_with_bailout	  = $ENV{STOPTEST} ? 1 : 0;
};

716 717 718 719 720 721 722 723 724 725 726 727 728 729
sub __srctop_file {
    BAIL_OUT("Must run setup() first") if (! $test_name);

    my $f = pop;
    return catfile($directories{SRCTOP},@_,$f);
}

sub __srctop_dir {
    BAIL_OUT("Must run setup() first") if (! $test_name);

    return catdir($directories{SRCTOP},@_);
}

sub __bldtop_file {
730 731 732
    BAIL_OUT("Must run setup() first") if (! $test_name);

    my $f = pop;
733
    return catfile($directories{BLDTOP},@_,$f);
734 735
}

736
sub __bldtop_dir {
737 738
    BAIL_OUT("Must run setup() first") if (! $test_name);

739
    return catdir($directories{BLDTOP},@_);
740 741
}

742 743 744 745 746 747 748 749 750 751
sub __exeext {
    my $ext = "";
    if ($^O eq "VMS" ) {	# VMS
	$ext = ".exe";
    } elsif ($^O eq "MSWin32") { # Windows
	$ext = ".exe";
    }
    return $ENV{"EXE_EXT"} || $ext;
}

752 753 754
sub __test_file {
    BAIL_OUT("Must run setup() first") if (! $test_name);

755 756
    my $f = pop;
    $f = catfile($directories{BLDTEST},@_,$f . __exeext());
757 758
    $f = catfile($directories{SRCTEST},@_,$f) unless -x $f;
    return $f;
759 760
}

761 762 763 764
sub __perltest_file {
    BAIL_OUT("Must run setup() first") if (! $test_name);

    my $f = pop;
765 766 767
    $f = catfile($directories{BLDTEST},@_,$f);
    $f = catfile($directories{SRCTEST},@_,$f) unless -f $f;
    return ($^X, $f);
768 769
}

770 771 772
sub __apps_file {
    BAIL_OUT("Must run setup() first") if (! $test_name);

773 774
    my $f = pop;
    $f = catfile($directories{BLDAPPS},@_,$f . __exeext());
775 776
    $f = catfile($directories{SRCAPPS},@_,$f) unless -x $f;
    return $f;
777 778
}

779 780 781 782
sub __perlapps_file {
    BAIL_OUT("Must run setup() first") if (! $test_name);

    my $f = pop;
783 784 785
    $f = catfile($directories{BLDAPPS},@_,$f);
    $f = catfile($directories{SRCAPPS},@_,$f) unless -f $f;
    return ($^X, $f);
786 787
}

788 789 790 791 792 793 794 795
sub __results_file {
    BAIL_OUT("Must run setup() first") if (! $test_name);

    my $f = pop;
    return catfile($directories{RESULTS},@_,$f);
}

sub __cwd {
796
    my $dir = catdir(shift);
797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825
    my %opts = @_;
    my $abscurdir = rel2abs(curdir());
    my $absdir = rel2abs($dir);
    my $reverse = abs2rel($abscurdir, $absdir);

    # PARANOIA: if we're not moving anywhere, we do nothing more
    if ($abscurdir eq $absdir) {
	return $reverse;
    }

    # Do not support a move to a different volume for now.  Maybe later.
    BAIL_OUT("FAILURE: \"$dir\" moves to a different volume, not supported")
	if $reverse eq $abscurdir;

    # If someone happened to give a directory that leads back to the current,
    # it's extremely silly to do anything more, so just simulate that we did
    # move.
    # In this case, we won't even clean it out, for safety's sake.
    return "." if $reverse eq "";

    $dir = canonpath($dir);
    if ($opts{create}) {
	mkpath($dir);
    }

    # Should we just bail out here as well?  I'm unsure.
    return undef unless chdir($dir);

    if ($opts{cleanup}) {
826
	rmtree(".", { safe => 0, keep_root => 1 });
827 828 829 830 831
    }

    # For each of these directory variables, figure out where they are relative
    # to the directory we want to move to if they aren't absolute (if they are,
    # they don't change!)
832
    my @dirtags = sort keys %directories;
833 834 835 836 837 838 839
    foreach (@dirtags) {
	if (!file_name_is_absolute($directories{$_})) {
	    my $newpath = abs2rel(rel2abs($directories{$_}), rel2abs($dir));
	    $directories{$_} = $newpath;
	}
    }

840 841 842 843 844 845 846 847 848 849
    # Treat each environment variable that was used to get us the values in
    # %directories the same was as the paths in %directories, so any sub
    # process can use their values properly as well
    foreach (@direnv) {
	if (!file_name_is_absolute($ENV{$_})) {
	    my $newpath = abs2rel(rel2abs($ENV{$_}), rel2abs($dir));
	    $ENV{$_} = $newpath;
	}
    }

850
    if ($debug) {
851
	print STDERR "DEBUG: __cwd(), directories and files:\n";
852 853
	print STDERR "  \$directories{BLDTEST} = \"$directories{BLDTEST}\"\n";
	print STDERR "  \$directories{SRCTEST} = \"$directories{SRCTEST}\"\n";
854
	print STDERR "  \$directories{RESULTS} = \"$directories{RESULTS}\"\n";
855 856
	print STDERR "  \$directories{BLDAPPS} = \"$directories{BLDAPPS}\"\n";
	print STDERR "  \$directories{SRCAPPS} = \"$directories{SRCAPPS}\"\n";
857 858
	print STDERR "  \$directories{SRCTOP}  = \"$directories{SRCTOP}\"\n";
	print STDERR "  \$directories{BLDTOP}  = \"$directories{BLDTOP}\"\n";
859 860 861 862 863 864 865 866 867 868
	print STDERR "\n";
	print STDERR "  current directory is \"",curdir(),"\"\n";
	print STDERR "  the way back is \"$reverse\"\n";
    }

    return $reverse;
}

sub __fixup_cmd {
    my $prog = shift;
869
    my $exe_shell = shift;
870

871
    my $prefix = __bldtop_file("util", "shlib_wrap.sh")." ";
872

873 874
    if (defined($exe_shell)) {
	$prefix = "$exe_shell ";
875
    } elsif ($^O eq "VMS" ) {	# VMS
876
	$prefix = ($prog =~ /^(?:[\$a-z0-9_]+:)?[<\[]/i ? "mcr " : "mcr []");
877 878 879 880 881
    } elsif ($^O eq "MSWin32") { # Windows
	$prefix = "";
    }

    # We test both with and without extension.  The reason
882 883 884
    # is that we might be passed a complete file spec, with
    # extension.
    if ( ! -x $prog ) {
885
	my $prog = "$prog";
886 887 888 889 890 891 892 893 894 895 896 897
	if ( ! -x $prog ) {
	    $prog = undef;
	}
    }

    if (defined($prog)) {
	# Make sure to quotify the program file on platforms that may
	# have spaces or similar in their path name.
	# To our knowledge, VMS is the exception where quotifying should
	# never happem.
	($prog) = quotify($prog) unless $^O eq "VMS";
	return $prefix.$prog;
898 899 900 901 902 903 904 905 906 907 908
    }

    print STDERR "$prog not found\n";
    return undef;
}

sub __build_cmd {
    BAIL_OUT("Must run setup() first") if (! $test_name);

    my $num = shift;
    my $path_builder = shift;
R
Richard Levitte 已提交
909 910
    # Make a copy to not destroy the caller's array
    my @cmdarray = ( @{$_[0]} ); shift;
911
    my %opts = @_;
912 913 914 915 916

    # We do a little dance, as $path_builder might return a list of
    # more than one.  If so, only the first is to be considered a
    # program to fix up, the rest is part of the arguments.  This
    # happens for perl scripts, where $path_builder will return
917 918 919
    # a list of two, $^X and the script name.
    # Also, if $path_builder returned more than one, we don't apply
    # the EXE_SHELL environment variable.
920
    my @prog = ($path_builder->(shift @cmdarray));
921 922 923
    my $first = shift @prog;
    my $exe_shell = @prog ? undef : $ENV{EXE_SHELL};
    my $cmd = __fixup_cmd($first, $exe_shell);
924 925 926 927 928 929 930
    if (@prog) {
	if ( ! -f $prog[0] ) {
	    print STDERR "$prog[0] not found\n";
	    $cmd = undef;
	}
    }
    my @args = (@prog, @cmdarray);
931 932 933
    if (defined($opts{interpreter_args})) {
        unshift @args, @{$opts{interpreter_args}};
    }
934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952

    return () if !$cmd;

    my $arg_str = "";
    my $null = devnull();


    $arg_str = " ".join(" ", quotify @args) if @args;

    my $fileornull = sub { $_[0] ? $_[0] : $null; };
    my $stdin = "";
    my $stdout = "";
    my $stderr = "";
    my $saved_stderr = undef;
    $stdin = " < ".$fileornull->($opts{stdin})  if exists($opts{stdin});
    $stdout= " > ".$fileornull->($opts{stdout}) if exists($opts{stdout});
    $stderr=" 2> ".$fileornull->($opts{stderr}) if exists($opts{stderr});

    my $display_cmd = "$cmd$arg_str$stdin$stdout$stderr";
953 954 955 956 957

    $stderr=" 2> ".$null
        unless $stderr || !$ENV{HARNESS_ACTIVE} || $ENV{HARNESS_VERBOSE};

    $cmd .= "$arg_str$stdin$stdout$stderr";
958

959 960 961 962 963
    if ($debug) {
	print STDERR "DEBUG[__build_cmd]: \$cmd = \"$cmd\"\n";
	print STDERR "DEBUG[__build_cmd]: \$display_cmd = \"$display_cmd\"\n";
    }

964
    return ($cmd, $display_cmd);
965 966 967 968 969 970 971 972 973 974 975 976 977
}

=head1 SEE ALSO

L<Test::More>, L<Test::Harness>

=head1 AUTHORS

Richard Levitte E<lt>levitte@openssl.orgE<gt> with assitance and
inspiration from Andy Polyakov E<lt>appro@openssl.org<gt>.

=cut

978
1;