test/testlib/OpenSSL/Test.pm

   1 # Copyright 2016 The OpenSSL Project Authors. All Rights Reserved.
   2 #
   3 # Licensed under the OpenSSL license (the "License").  You may not use
   4 # this file except in compliance with the License.  You can obtain a copy
   5 # in the file LICENSE in the source distribution or at
   6 # https://www.openssl.org/source/license.html
   7
   8 package OpenSSL::Test;
   9
  10 use strict;
  11 use warnings;
  12
  13 use Test::More 0.96;
  14
  15 use Exporter;
  16 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 fuzz  perlapp test perltest
  20                                    run));
  21 @EXPORT_OK = (@Test::More::EXPORT_OK, qw(bldtop_dir bldtop_file
  22                                          srctop_dir srctop_file
  23                                          pipe with cmdstr quotify));
  24
  25 =head1 NAME
  26
  27 OpenSSL::Test - a private extension of Test::More
  28
  29 =head1 SYNOPSIS
  30
  31   use OpenSSL::Test;
  32
  33   setup("my_test_name");
  34
  35   ok(run(app(["openssl", "version"])), "check for openssl presence");
  36
  37   indir "subdir" => sub {
  38     ok(run(test(["sometest", "arg1"], stdout => "foo.txt")),
  39        "run sometest with output to foo.txt");
  40   };
  41
  42 =head1 DESCRIPTION
  43
  44 This module is a private extension of L<Test::More> for testing OpenSSL.
  45 In addition to the Test::More functions, it also provides functions that
  46 easily find the diverse programs within a OpenSSL build tree, as well as
  47 some other useful functions.
  48
  49 This module I<depends> on the environment variables C<$TOP> or C<$SRCTOP>
  50 and C<$BLDTOP>.  Without one of the combinations it refuses to work.
  51 See L</ENVIRONMENT> below.
  52
  53 =cut
  54
  55 use File::Copy;
  56 use File::Spec::Functions qw/file_name_is_absolute curdir canonpath splitdir
  57                              catdir catfile splitpath catpath devnull abs2rel
  58                              rel2abs/;
  59 use File::Path 2.00 qw/rmtree mkpath/;
  60
  61
  62 # The name of the test.  This is set by setup() and is used in the other
  63 # functions to verify that setup() has been used.
  64 my $test_name = undef;
  65
  66 # Directories we want to keep track of TOP, APPS, TEST and RESULTS are the
  67 # ones we're interested in, corresponding to the environment variables TOP
  68 # (mandatory), BIN_D, TEST_D, UTIL_D and RESULT_D.
  69 my %directories = ();
  70
  71 # The environment variables that gave us the contents in %directories.  These
  72 # get modified whenever we change directories, so that subprocesses can use
  73 # the values of those environment variables as well
  74 my @direnv = ();
  75
  76 # A bool saying if we shall stop all testing if the current recipe has failing
  77 # tests or not.  This is set by setup() if the environment variable STOPTEST
  78 # is defined with a non-empty value.
  79 my $end_with_bailout = 0;
  80
  81 # A set of hooks that is affected by with() and may be used in diverse places.
  82 # All hooks are expected to be CODE references.
  83 my %hooks = (
  84
  85     # exit_checker is used by run() directly after completion of a command.
  86     # it receives the exit code from that command and is expected to return
  87     # 1 (for success) or 0 (for failure).  This is the value that will be
  88     # returned by run().
  89     # NOTE: When run() gets the option 'capture => 1', this hook is ignored.
  90     exit_checker => sub { return shift == 0 ? 1 : 0 },
  91
  92     );
  93
  94 # Debug flag, to be set manually when needed
  95 my $debug = 0;
  96
  97 # Declare some utility functions that are defined at the end
  98 sub bldtop_file;
  99 sub bldtop_dir;
 100 sub srctop_file;
 101 sub srctop_dir;
 102 sub quotify;
 103
 104 # Declare some private functions that are defined at the end
 105 sub __env;
 106 sub __cwd;
 107 sub __apps_file;
 108 sub __results_file;
 109 sub __fixup_cmd;
 110 sub __build_cmd;
 111
 112 =head2 Main functions
 113
 114 The following functions are exported by default when using C<OpenSSL::Test>.
 115
 116 =cut
 117
 118 =over 4
 119
 120 =item B<setup "NAME">
 121
 122 C<setup> is used for initial setup, and it is mandatory that it's used.
 123 If it's not used in a OpenSSL test recipe, the rest of the recipe will
 124 most likely refuse to run.
 125
 126 C<setup> checks for environment variables (see L</ENVIRONMENT> below),
 127 checks that C<$TOP/Configure> or C<$SRCTOP/Configure> exists, C<chdir>
 128 into the results directory (defined by the C<$RESULT_D> environment
 129 variable if defined, otherwise C<$BLDTOP/test> or C<$TOP/test>, whichever
 130 is defined).
 131
 132 =back
 133
 134 =cut
 135
 136 sub setup {
 137     my $old_test_name = $test_name;
 138     $test_name = shift;
 139
 140     BAIL_OUT("setup() must receive a name") unless $test_name;
 141     warn "setup() detected test name change.  Innocuous, so we continue...\n"
 142         if $old_test_name && $old_test_name ne $test_name;
 143
 144     return if $old_test_name;
 145
 146     BAIL_OUT("setup() needs \$TOP or \$SRCTOP and \$BLDTOP to be defined")
 147         unless $ENV{TOP} || ($ENV{SRCTOP} && $ENV{BLDTOP});
 148     BAIL_OUT("setup() found both \$TOP and \$SRCTOP or \$BLDTOP...")
 149         if $ENV{TOP} && ($ENV{SRCTOP} || $ENV{BLDTOP});
 150
 151     __env();
 152
 153     BAIL_OUT("setup() expects the file Configure in the source top directory")
 154         unless -f srctop_file("Configure");
 155
 156     __cwd($directories{RESULTS});
 157 }
 158
 159 =over 4
 160
 161 =item B<indir "SUBDIR" =E<gt> sub BLOCK, OPTS>
 162
 163 C<indir> is used to run a part of the recipe in a different directory than
 164 the one C<setup> moved into, usually a subdirectory, given by SUBDIR.
 165 The part of the recipe that's run there is given by the codeblock BLOCK.
 166
 167 C<indir> takes some additional options OPTS that affect the subdirectory:
 168
 169 =over 4
 170
 171 =item B<create =E<gt> 0|1>
 172
 173 When set to 1 (or any value that perl preceives as true), the subdirectory
 174 will be created if it doesn't already exist.  This happens before BLOCK
 175 is executed.
 176
 177 =item B<cleanup =E<gt> 0|1>
 178
 179 When set to 1 (or any value that perl preceives as true), the subdirectory
 180 will be cleaned out and removed.  This happens both before and after BLOCK
 181 is executed.
 182
 183 =back
 184
 185 An example:
 186
 187   indir "foo" => sub {
 188       ok(run(app(["openssl", "version"]), stdout => "foo.txt"));
 189       if (ok(open(RESULT, "foo.txt"), "reading foo.txt")) {
 190           my $line = <RESULT>;
 191           close RESULT;
 192           is($line, qr/^OpenSSL 1\./,
 193              "check that we're using OpenSSL 1.x.x");
 194       }
 195   }, create => 1, cleanup => 1;
 196
 197 =back
 198
 199 =cut
 200
 201 sub indir {
 202     my $subdir = shift;
 203     my $codeblock = shift;
 204     my %opts = @_;
 205
 206     my $reverse = __cwd($subdir,%opts);
 207     BAIL_OUT("FAILURE: indir, \"$subdir\" wasn't possible to move into")
 208         unless $reverse;
 209
 210     $codeblock->();
 211
 212     __cwd($reverse);
 213
 214     if ($opts{cleanup}) {
 215         rmtree($subdir, { safe => 0 });
 216     }
 217 }
 218
 219 =over 4
 220
 221 =item B<app ARRAYREF, OPTS>
 222
 223 =item B<test ARRAYREF, OPTS>
 224
 225 Both of these functions take a reference to a list that is a command and
 226 its arguments, and some additional options (described further on).
 227
 228 C<app> expects to find the given command (the first item in the given list
 229 reference) as an executable in C<$BIN_D> (if defined, otherwise C<$TOP/apps>
 230 or C<$BLDTOP/apps>).
 231
 232 C<test> expects to find the given command (the first item in the given list
 233 reference) as an executable in C<$TEST_D> (if defined, otherwise C<$TOP/test>
 234 or C<$BLDTOP/test>).
 235
 236 Both return a CODEREF to be used by C<run>, C<pipe> or C<cmdstr>.
 237
 238 The options that both C<app> and C<test> can take are in the form of hash
 239 values:
 240
 241 =over 4
 242
 243 =item B<stdin =E<gt> PATH>
 244
 245 =item B<stdout =E<gt> PATH>
 246
 247 =item B<stderr =E<gt> PATH>
 248
 249 In all three cases, the corresponding standard input, output or error is
 250 redirected from (for stdin) or to (for the others) a file given by the
 251 string PATH, I<or>, if the value is C<undef>, C</dev/null> or similar.
 252
 253 =back
 254
 255 =item B<perlapp ARRAYREF, OPTS>
 256
 257 =item B<perltest ARRAYREF, OPTS>
 258
 259 Both these functions function the same way as B<app> and B<test>, except
 260 that they expect the command to be a perl script.  Also, they support one
 261 more option:
 262
 263 =over 4
 264
 265 =item B<interpreter_args =E<gt> ARRAYref>
 266
 267 The array reference is a set of arguments for perl rather than the script.
 268 Take care so that none of them can be seen as a script!  Flags and their
 269 eventual arguments only!
 270
 271 =back
 272
 273 An example:
 274
 275   ok(run(perlapp(["foo.pl", "arg1"],
 276                  interpreter_args => [ "-I", srctop_dir("test") ])));
 277
 278 =back
 279
 280 =cut
 281
 282 sub app {
 283     my $cmd = shift;
 284     my %opts = @_;
 285     return sub { my $num = shift;
 286                  return __build_cmd($num, \&__apps_file, $cmd, %opts); }
 287 }
 288
 289 sub fuzz {
 290     my $cmd = shift;
 291     my %opts = @_;
 292     return sub { my $num = shift;
 293                  return __build_cmd($num, \&__fuzz_file, $cmd, %opts); }
 294 }
 295
 296 sub test {
 297     my $cmd = shift;
 298     my %opts = @_;
 299     return sub { my $num = shift;
 300                  return __build_cmd($num, \&__test_file, $cmd, %opts); }
 301 }
 302
 303 sub perlapp {
 304     my $cmd = shift;
 305     my %opts = @_;
 306     return sub { my $num = shift;
 307                  return __build_cmd($num, \&__perlapps_file, $cmd, %opts); }
 308 }
 309
 310 sub perltest {
 311     my $cmd = shift;
 312     my %opts = @_;
 313     return sub { my $num = shift;
 314                  return __build_cmd($num, \&__perltest_file, $cmd, %opts); }
 315 }
 316
 317 =over 4
 318
 319 =item B<run CODEREF, OPTS>
 320
 321 This CODEREF is expected to be the value return by C<app> or C<test>,
 322 anything else will most likely cause an error unless you know what you're
 323 doing.
 324
 325 C<run> executes the command returned by CODEREF and return either the
 326 resulting output (if the option C<capture> is set true) or a boolean indicating
 327 if the command succeeded or not.
 328
 329 The options that C<run> can take are in the form of hash values:
 330
 331 =over 4
 332
 333 =item B<capture =E<gt> 0|1>
 334
 335 If true, the command will be executed with a perl backtick, and C<run> will
 336 return the resulting output as an array of lines.  If false or not given,
 337 the command will be executed with C<system()>, and C<run> will return 1 if
 338 the command was successful or 0 if it wasn't.
 339
 340 =back
 341
 342 For further discussion on what is considered a successful command or not, see
 343 the function C<with> further down.
 344
 345 =back
 346
 347 =cut
 348
 349 sub run {
 350     my ($cmd, $display_cmd) = shift->(0);
 351     my %opts = @_;
 352
 353     return () if !$cmd;
 354
 355     my $prefix = "";
 356     if ( $^O eq "VMS" ) {       # VMS
 357         $prefix = "pipe ";
 358     }
 359
 360     my @r = ();
 361     my $r = 0;
 362     my $e = 0;
 363
 364     # In non-verbose, we want to shut up the command interpreter, in case
 365     # it has something to complain about.  On VMS, it might complain both
 366     # on stdout and stderr
 367     my $save_STDOUT;
 368     my $save_STDERR;
 369     if ($ENV{HARNESS_ACTIVE} && !$ENV{HARNESS_VERBOSE}) {
 370         open $save_STDOUT, '>&', \*STDOUT or die "Can't dup STDOUT: $!";
 371         open $save_STDERR, '>&', \*STDERR or die "Can't dup STDERR: $!";
 372         open STDOUT, ">", devnull();
 373         open STDERR, ">", devnull();
 374     }
 375
 376     # The dance we do with $? is the same dance the Unix shells appear to
 377     # do.  For example, a program that gets aborted (and therefore signals
 378     # SIGABRT = 6) will appear to exit with the code 134.  We mimic this
 379     # to make it easier to compare with a manual run of the command.
 380     if ($opts{capture}) {
 381         @r = `$prefix$cmd`;
 382         $e = ($? & 0x7f) ? ($? & 0x7f)|0x80 : ($? >> 8);
 383     } else {
 384         system("$prefix$cmd");
 385         $e = ($? & 0x7f) ? ($? & 0x7f)|0x80 : ($? >> 8);
 386         $r = $hooks{exit_checker}->($e);
 387     }
 388
 389     if ($ENV{HARNESS_ACTIVE} && !$ENV{HARNESS_VERBOSE}) {
 390         close STDOUT;
 391         close STDERR;
 392         open STDOUT, '>&', $save_STDOUT or die "Can't restore STDOUT: $!";
 393         open STDERR, '>&', $save_STDERR or die "Can't restore STDERR: $!";
 394     }
 395
 396     print STDERR "$prefix$display_cmd => $e\n"
 397         if !$ENV{HARNESS_ACTIVE} || $ENV{HARNESS_VERBOSE};
 398
 399     # At this point, $? stops being interesting, and unfortunately,
 400     # there are Test::More versions that get picky if we leave it
 401     # non-zero.
 402     $? = 0;
 403
 404     if ($opts{capture}) {
 405         return @r;
 406     } else {
 407         return $r;
 408     }
 409 }
 410
 411 END {
 412     my $tb = Test::More->builder;
 413     my $failure = scalar(grep { $_ == 0; } $tb->summary);
 414     if ($failure && $end_with_bailout) {
 415         BAIL_OUT("Stoptest!");
 416     }
 417 }
 418
 419 =head2 Utility functions
 420
 421 The following functions are exported on request when using C<OpenSSL::Test>.
 422
 423   # To only get the bldtop_file and srctop_file functions.
 424   use OpenSSL::Test qw/bldtop_file srctop_file/;
 425
 426   # To only get the bldtop_file function in addition to the default ones.
 427   use OpenSSL::Test qw/:DEFAULT bldtop_file/;
 428
 429 =cut
 430
 431 # Utility functions, exported on request
 432
 433 =over 4
 434
 435 =item B<bldtop_dir LIST>
 436
 437 LIST is a list of directories that make up a path from the top of the OpenSSL
 438 build directory (as indicated by the environment variable C<$TOP> or
 439 C<$BLDTOP>).
 440 C<bldtop_dir> returns the resulting directory as a string, adapted to the local
 441 operating system.
 442
 443 =back
 444
 445 =cut
 446
 447 sub bldtop_dir {
 448     return __bldtop_dir(@_);    # This caters for operating systems that have
 449                                 # a very distinct syntax for directories.
 450 }
 451
 452 =over 4
 453
 454 =item B<bldtop_file LIST, FILENAME>
 455
 456 LIST is a list of directories that make up a path from the top of the OpenSSL
 457 build directory (as indicated by the environment variable C<$TOP> or
 458 C<$BLDTOP>) and FILENAME is the name of a file located in that directory path.
 459 C<bldtop_file> returns the resulting file path as a string, adapted to the local
 460 operating system.
 461
 462 =back
 463
 464 =cut
 465
 466 sub bldtop_file {
 467     return __bldtop_file(@_);
 468 }
 469
 470 =over 4
 471
 472 =item B<srctop_dir LIST>
 473
 474 LIST is a list of directories that make up a path from the top of the OpenSSL
 475 source directory (as indicated by the environment variable C<$TOP> or
 476 C<$SRCTOP>).
 477 C<srctop_dir> returns the resulting directory as a string, adapted to the local
 478 operating system.
 479
 480 =back
 481
 482 =cut
 483
 484 sub srctop_dir {
 485     return __srctop_dir(@_);    # This caters for operating systems that have
 486                                 # a very distinct syntax for directories.
 487 }
 488
 489 =over 4
 490
 491 =item B<srctop_file LIST, FILENAME>
 492
 493 LIST is a list of directories that make up a path from the top of the OpenSSL
 494 source directory (as indicated by the environment variable C<$TOP> or
 495 C<$SRCTOP>) and FILENAME is the name of a file located in that directory path.
 496 C<srctop_file> returns the resulting file path as a string, adapted to the local
 497 operating system.
 498
 499 =back
 500
 501 =cut
 502
 503 sub srctop_file {
 504     return __srctop_file(@_);
 505 }
 506
 507 =over 4
 508
 509 =item B<pipe LIST>
 510
 511 LIST is a list of CODEREFs returned by C<app> or C<test>, from which C<pipe>
 512 creates a new command composed of all the given commands put together in a
 513 pipe.  C<pipe> returns a new CODEREF in the same manner as C<app> or C<test>,
 514 to be passed to C<run> for execution.
 515
 516 =back
 517
 518 =cut
 519
 520 sub pipe {
 521     my @cmds = @_;
 522     return
 523         sub {
 524             my @cs  = ();
 525             my @dcs = ();
 526             my @els = ();
 527             my $counter = 0;
 528             foreach (@cmds) {
 529                 my ($c, $dc, @el) = $_->(++$counter);
 530
 531                 return () if !$c;
 532
 533                 push @cs, $c;
 534                 push @dcs, $dc;
 535                 push @els, @el;
 536             }
 537             return (
 538                 join(" | ", @cs),
 539                 join(" | ", @dcs),
 540                 @els
 541                 );
 542     };
 543 }
 544
 545 =over 4
 546
 547 =item B<with HASHREF, CODEREF>
 548
 549 C<with> will temporarly install hooks given by the HASHREF and then execute
 550 the given CODEREF.  Hooks are usually expected to have a coderef as value.
 551
 552 The currently available hoosk are:
 553
 554 =over 4
 555
 556 =item B<exit_checker =E<gt> CODEREF>
 557
 558 This hook is executed after C<run> has performed its given command.  The
 559 CODEREF receives the exit code as only argument and is expected to return
 560 1 (if the exit code indicated success) or 0 (if the exit code indicated
 561 failure).
 562
 563 =back
 564
 565 =back
 566
 567 =cut
 568
 569 sub with {
 570     my $opts = shift;
 571     my %opts = %{$opts};
 572     my $codeblock = shift;
 573
 574     my %saved_hooks = ();
 575
 576     foreach (keys %opts) {
 577         $saved_hooks{$_} = $hooks{$_}   if exists($hooks{$_});
 578         $hooks{$_} = $opts{$_};
 579     }
 580
 581     $codeblock->();
 582
 583     foreach (keys %saved_hooks) {
 584         $hooks{$_} = $saved_hooks{$_};
 585     }
 586 }
 587
 588 =over 4
 589
 590 =item B<cmdstr CODEREF, OPTS>
 591
 592 C<cmdstr> takes a CODEREF from C<app> or C<test> and simply returns the
 593 command as a string.
 594
 595 C<cmdstr> takes some additiona options OPTS that affect the string returned:
 596
 597 =over 4
 598
 599 =item B<display =E<gt> 0|1>
 600
 601 When set to 0, the returned string will be with all decorations, such as a
 602 possible redirect of stderr to the null device.  This is suitable if the
 603 string is to be used directly in a recipe.
 604
 605 When set to 1, the returned string will be without extra decorations.  This
 606 is suitable for display if that is desired (doesn't confuse people with all
 607 internal stuff), or if it's used to pass a command down to a subprocess.
 608
 609 Default: 0
 610
 611 =back
 612
 613 =back
 614
 615 =cut
 616
 617 sub cmdstr {
 618     my ($cmd, $display_cmd) = shift->(0);
 619     my %opts = @_;
 620
 621     if ($opts{display}) {
 622         return $display_cmd;
 623     } else {
 624         return $cmd;
 625     }
 626 }
 627
 628 =over 4
 629
 630 =item B<quotify LIST>
 631
 632 LIST is a list of strings that are going to be used as arguments for a
 633 command, and makes sure to inject quotes and escapes as necessary depending
 634 on the content of each string.
 635
 636 This can also be used to put quotes around the executable of a command.
 637 I<This must never ever be done on VMS.>
 638
 639 =back
 640
 641 =cut
 642
 643 sub quotify {
 644     # Unix setup (default if nothing else is mentioned)
 645     my $arg_formatter =
 646         sub { $_ = shift; /\s|[\{\}\\\$\[\]\*\?\|\&:;<>]/ ? "'$_'" : $_ };
 647
 648     if ( $^O eq "VMS") {        # VMS setup
 649         $arg_formatter = sub {
 650             $_ = shift;
 651             if (/\s|["[:upper:]]/) {
 652                 s/"/""/g;
 653                 '"'.$_.'"';
 654             } else {
 655                 $_;
 656             }
 657         };
 658     } elsif ( $^O eq "MSWin32") { # MSWin setup
 659         $arg_formatter = sub {
 660             $_ = shift;
 661             if (/\s|["\|\&\*\;<>]/) {
 662                 s/(["\\])/\\$1/g;
 663                 '"'.$_.'"';
 664             } else {
 665                 $_;
 666             }
 667         };
 668     }
 669
 670     return map { $arg_formatter->($_) } @_;
 671 }
 672
 673 ######################################################################
 674 # private functions.  These are never exported.
 675
 676 =head1 ENVIRONMENT
 677
 678 OpenSSL::Test depends on some environment variables.
 679
 680 =over 4
 681
 682 =item B<TOP>
 683
 684 This environment variable is mandatory.  C<setup> will check that it's
 685 defined and that it's a directory that contains the file C<Configure>.
 686 If this isn't so, C<setup> will C<BAIL_OUT>.
 687
 688 =item B<BIN_D>
 689
 690 If defined, its value should be the directory where the openssl application
 691 is located.  Defaults to C<$TOP/apps> (adapted to the operating system).
 692
 693 =item B<TEST_D>
 694
 695 If defined, its value should be the directory where the test applications
 696 are located.  Defaults to C<$TOP/test> (adapted to the operating system).
 697
 698 =item B<STOPTEST>
 699
 700 If defined, it puts testing in a different mode, where a recipe with
 701 failures will result in a C<BAIL_OUT> at the end of its run.
 702
 703 =back
 704
 705 =cut
 706
 707 sub __env {
 708     $directories{SRCTOP}  = $ENV{SRCTOP} || $ENV{TOP};
 709     $directories{BLDTOP}  = $ENV{BLDTOP} || $ENV{TOP};
 710     $directories{BLDAPPS} = $ENV{BIN_D}  || __bldtop_dir("apps");
 711     $directories{SRCAPPS} =                 __srctop_dir("apps");
 712     $directories{BLDFUZZ} =                 __bldtop_dir("fuzz");
 713     $directories{SRCFUZZ} =                 __srctop_dir("fuzz");
 714     $directories{BLDTEST} = $ENV{TEST_D} || __bldtop_dir("test");
 715     $directories{SRCTEST} =                 __srctop_dir("test");
 716     $directories{RESULTS} = $ENV{RESULT_D} || $directories{BLDTEST};
 717
 718     push @direnv, "TOP"       if $ENV{TOP};
 719     push @direnv, "SRCTOP"    if $ENV{SRCTOP};
 720     push @direnv, "BLDTOP"    if $ENV{BLDTOP};
 721     push @direnv, "BIN_D"     if $ENV{BIN_D};
 722     push @direnv, "TEST_D"    if $ENV{TEST_D};
 723     push @direnv, "RESULT_D"  if $ENV{RESULT_D};
 724
 725     $end_with_bailout     = $ENV{STOPTEST} ? 1 : 0;
 726 };
 727
 728 sub __srctop_file {
 729     BAIL_OUT("Must run setup() first") if (! $test_name);
 730
 731     my $f = pop;
 732     return catfile($directories{SRCTOP},@_,$f);
 733 }
 734
 735 sub __srctop_dir {
 736     BAIL_OUT("Must run setup() first") if (! $test_name);
 737
 738     return catdir($directories{SRCTOP},@_);
 739 }
 740
 741 sub __bldtop_file {
 742     BAIL_OUT("Must run setup() first") if (! $test_name);
 743
 744     my $f = pop;
 745     return catfile($directories{BLDTOP},@_,$f);
 746 }
 747
 748 sub __bldtop_dir {
 749     BAIL_OUT("Must run setup() first") if (! $test_name);
 750
 751     return catdir($directories{BLDTOP},@_);
 752 }
 753
 754 sub __exeext {
 755     my $ext = "";
 756     if ($^O eq "VMS" ) {        # VMS
 757         $ext = ".exe";
 758     } elsif ($^O eq "MSWin32") { # Windows
 759         $ext = ".exe";
 760     }
 761     return $ENV{"EXE_EXT"} || $ext;
 762 }
 763
 764 sub __test_file {
 765     BAIL_OUT("Must run setup() first") if (! $test_name);
 766
 767     my $f = pop;
 768     $f = catfile($directories{BLDTEST},@_,$f . __exeext());
 769     $f = catfile($directories{SRCTEST},@_,$f) unless -x $f;
 770     return $f;
 771 }
 772
 773 sub __perltest_file {
 774     BAIL_OUT("Must run setup() first") if (! $test_name);
 775
 776     my $f = pop;
 777     $f = catfile($directories{BLDTEST},@_,$f);
 778     $f = catfile($directories{SRCTEST},@_,$f) unless -f $f;
 779     return ($^X, $f);
 780 }
 781
 782 sub __apps_file {
 783     BAIL_OUT("Must run setup() first") if (! $test_name);
 784
 785     my $f = pop;
 786     $f = catfile($directories{BLDAPPS},@_,$f . __exeext());
 787     $f = catfile($directories{SRCAPPS},@_,$f) unless -x $f;
 788     return $f;
 789 }
 790
 791 sub __fuzz_file {
 792     BAIL_OUT("Must run setup() first") if (! $test_name);
 793
 794     my $f = pop;
 795     $f = catfile($directories{BLDFUZZ},@_,$f . __exeext());
 796     $f = catfile($directories{SRCFUZZ},@_,$f) unless -x $f;
 797     return $f;
 798 }
 799
 800 sub __perlapps_file {
 801     BAIL_OUT("Must run setup() first") if (! $test_name);
 802
 803     my $f = pop;
 804     $f = catfile($directories{BLDAPPS},@_,$f);
 805     $f = catfile($directories{SRCAPPS},@_,$f) unless -f $f;
 806     return ($^X, $f);
 807 }
 808
 809 sub __results_file {
 810     BAIL_OUT("Must run setup() first") if (! $test_name);
 811
 812     my $f = pop;
 813     return catfile($directories{RESULTS},@_,$f);
 814 }
 815
 816 sub __cwd {
 817     my $dir = catdir(shift);
 818     my %opts = @_;
 819     my $abscurdir = rel2abs(curdir());
 820     my $absdir = rel2abs($dir);
 821     my $reverse = abs2rel($abscurdir, $absdir);
 822
 823     # PARANOIA: if we're not moving anywhere, we do nothing more
 824     if ($abscurdir eq $absdir) {
 825         return $reverse;
 826     }
 827
 828     # Do not support a move to a different volume for now.  Maybe later.
 829     BAIL_OUT("FAILURE: \"$dir\" moves to a different volume, not supported")
 830         if $reverse eq $abscurdir;
 831
 832     # If someone happened to give a directory that leads back to the current,
 833     # it's extremely silly to do anything more, so just simulate that we did
 834     # move.
 835     # In this case, we won't even clean it out, for safety's sake.
 836     return "." if $reverse eq "";
 837
 838     $dir = canonpath($dir);
 839     if ($opts{create}) {
 840         mkpath($dir);
 841     }
 842
 843     # We are recalculating the directories we keep track of, but need to save
 844     # away the result for after having moved into the new directory.
 845     my %tmp_directories = ();
 846     my %tmp_ENV = ();
 847
 848     # For each of these directory variables, figure out where they are relative
 849     # to the directory we want to move to if they aren't absolute (if they are,
 850     # they don't change!)
 851     my @dirtags = sort keys %directories;
 852     foreach (@dirtags) {
 853         if (!file_name_is_absolute($directories{$_})) {
 854             my $newpath = abs2rel(rel2abs($directories{$_}), rel2abs($dir));
 855             $tmp_directories{$_} = $newpath;
 856         }
 857     }
 858
 859     # Treat each environment variable that was used to get us the values in
 860     # %directories the same was as the paths in %directories, so any sub
 861     # process can use their values properly as well
 862     foreach (@direnv) {
 863         if (!file_name_is_absolute($ENV{$_})) {
 864             my $newpath = abs2rel(rel2abs($ENV{$_}), rel2abs($dir));
 865             $tmp_ENV{$_} = $newpath;
 866         }
 867     }
 868
 869     # Should we just bail out here as well?  I'm unsure.
 870     return undef unless chdir($dir);
 871
 872     if ($opts{cleanup}) {
 873         rmtree(".", { safe => 0, keep_root => 1 });
 874     }
 875
 876     # We put back new values carefully.  Doing the obvious
 877     # %directories = ( %tmp_irectories )
 878     # will clear out any value that happens to be an absolute path
 879     foreach (keys %tmp_directories) {
 880         $directories{$_} = $tmp_directories{$_};
 881     }
 882     foreach (keys %tmp_ENV) {
 883         $ENV{$_} = $tmp_ENV{$_};
 884     }
 885
 886     if ($debug) {
 887         print STDERR "DEBUG: __cwd(), directories and files:\n";
 888         print STDERR "  \$directories{BLDTEST} = \"$directories{BLDTEST}\"\n";
 889         print STDERR "  \$directories{SRCTEST} = \"$directories{SRCTEST}\"\n";
 890         print STDERR "  \$directories{RESULTS} = \"$directories{RESULTS}\"\n";
 891         print STDERR "  \$directories{BLDAPPS} = \"$directories{BLDAPPS}\"\n";
 892         print STDERR "  \$directories{SRCAPPS} = \"$directories{SRCAPPS}\"\n";
 893         print STDERR "  \$directories{SRCTOP}  = \"$directories{SRCTOP}\"\n";
 894         print STDERR "  \$directories{BLDTOP}  = \"$directories{BLDTOP}\"\n";
 895         print STDERR "\n";
 896         print STDERR "  current directory is \"",curdir(),"\"\n";
 897         print STDERR "  the way back is \"$reverse\"\n";
 898     }
 899
 900     return $reverse;
 901 }
 902
 903 sub __fixup_cmd {
 904     my $prog = shift;
 905     my $exe_shell = shift;
 906
 907     my $prefix = __bldtop_file("util", "shlib_wrap.sh")." ";
 908
 909     if (defined($exe_shell)) {
 910         $prefix = "$exe_shell ";
 911     } elsif ($^O eq "VMS" ) {   # VMS
 912         $prefix = ($prog =~ /^(?:[\$a-z0-9_]+:)?[<\[]/i ? "mcr " : "mcr []");
 913     } elsif ($^O eq "MSWin32") { # Windows
 914         $prefix = "";
 915     }
 916
 917     # We test both with and without extension.  The reason
 918     # is that we might be passed a complete file spec, with
 919     # extension.
 920     if ( ! -x $prog ) {
 921         my $prog = "$prog";
 922         if ( ! -x $prog ) {
 923             $prog = undef;
 924         }
 925     }
 926
 927     if (defined($prog)) {
 928         # Make sure to quotify the program file on platforms that may
 929         # have spaces or similar in their path name.
 930         # To our knowledge, VMS is the exception where quotifying should
 931         # never happem.
 932         ($prog) = quotify($prog) unless $^O eq "VMS";
 933         return $prefix.$prog;
 934     }
 935
 936     print STDERR "$prog not found\n";
 937     return undef;
 938 }
 939
 940 sub __build_cmd {
 941     BAIL_OUT("Must run setup() first") if (! $test_name);
 942
 943     my $num = shift;
 944     my $path_builder = shift;
 945     # Make a copy to not destroy the caller's array
 946     my @cmdarray = ( @{$_[0]} ); shift;
 947     my %opts = @_;
 948
 949     # We do a little dance, as $path_builder might return a list of
 950     # more than one.  If so, only the first is to be considered a
 951     # program to fix up, the rest is part of the arguments.  This
 952     # happens for perl scripts, where $path_builder will return
 953     # a list of two, $^X and the script name.
 954     # Also, if $path_builder returned more than one, we don't apply
 955     # the EXE_SHELL environment variable.
 956     my @prog = ($path_builder->(shift @cmdarray));
 957     my $first = shift @prog;
 958     my $exe_shell = @prog ? undef : $ENV{EXE_SHELL};
 959     my $cmd = __fixup_cmd($first, $exe_shell);
 960     if (@prog) {
 961         if ( ! -f $prog[0] ) {
 962             print STDERR "$prog[0] not found\n";
 963             $cmd = undef;
 964         }
 965     }
 966     my @args = (@prog, @cmdarray);
 967     if (defined($opts{interpreter_args})) {
 968         unshift @args, @{$opts{interpreter_args}};
 969     }
 970
 971     return () if !$cmd;
 972
 973     my $arg_str = "";
 974     my $null = devnull();
 975
 976
 977     $arg_str = " ".join(" ", quotify @args) if @args;
 978
 979     my $fileornull = sub { $_[0] ? $_[0] : $null; };
 980     my $stdin = "";
 981     my $stdout = "";
 982     my $stderr = "";
 983     my $saved_stderr = undef;
 984     $stdin = " < ".$fileornull->($opts{stdin})  if exists($opts{stdin});
 985     $stdout= " > ".$fileornull->($opts{stdout}) if exists($opts{stdout});
 986     $stderr=" 2> ".$fileornull->($opts{stderr}) if exists($opts{stderr});
 987
 988     my $display_cmd = "$cmd$arg_str$stdin$stdout$stderr";
 989
 990     $stderr=" 2> ".$null
 991         unless $stderr || !$ENV{HARNESS_ACTIVE} || $ENV{HARNESS_VERBOSE};
 992
 993     $cmd .= "$arg_str$stdin$stdout$stderr";
 994
 995     if ($debug) {
 996         print STDERR "DEBUG[__build_cmd]: \$cmd = \"$cmd\"\n";
 997         print STDERR "DEBUG[__build_cmd]: \$display_cmd = \"$display_cmd\"\n";
 998     }
 999
1000     return ($cmd, $display_cmd);
1001 }
1002
1003 =head1 SEE ALSO
1004
1005 L<Test::More>, L<Test::Harness>
1006
1007 =head1 AUTHORS
1008
1009 Richard Levitte E<lt>levitte@openssl.orgE<gt> with assitance and
1010 inspiration from Andy Polyakov E<lt>appro@openssl.org<gt>.
1011
1012 =cut
1013
1014 1;