util/perl/OpenSSL/Test.pm

   1 # Copyright 2016-2019 The OpenSSL Project Authors. All Rights Reserved.
   2 #
   3 # Licensed under the Apache License 2.0 (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 = "1.0";
  18 @ISA = qw(Exporter);
  19 @EXPORT = (@Test::More::EXPORT, qw(setup run indir cmd app fuzz test
  20                                    perlapp perltest subtest));
  21 @EXPORT_OK = (@Test::More::EXPORT_OK, qw(bldtop_dir bldtop_file
  22                                          srctop_dir srctop_file
  23                                          data_file data_dir
  24                                          pipe with cmdstr quotify
  25                                          openssl_versions
  26                                          ok_nofips is_nofips isnt_nofips));
  27
  28 =head1 NAME
  29
  30 OpenSSL::Test - a private extension of Test::More
  31
  32 =head1 SYNOPSIS
  33
  34   use OpenSSL::Test;
  35
  36   setup("my_test_name");
  37
  38   ok(run(app(["openssl", "version"])), "check for openssl presence");
  39
  40   indir "subdir" => sub {
  41     ok(run(test(["sometest", "arg1"], stdout => "foo.txt")),
  42        "run sometest with output to foo.txt");
  43   };
  44
  45 =head1 DESCRIPTION
  46
  47 This module is a private extension of L<Test::More> for testing OpenSSL.
  48 In addition to the Test::More functions, it also provides functions that
  49 easily find the diverse programs within a OpenSSL build tree, as well as
  50 some other useful functions.
  51
  52 This module I<depends> on the environment variables C<$TOP> or C<$SRCTOP>
  53 and C<$BLDTOP>.  Without one of the combinations it refuses to work.
  54 See L</ENVIRONMENT> below.
  55
  56 With each test recipe, a parallel data directory with (almost) the same name
  57 as the recipe is possible in the source directory tree.  For example, for a
  58 recipe C<$SRCTOP/test/recipes/99-foo.t>, there could be a directory
  59 C<$SRCTOP/test/recipes/99-foo_data/>.
  60
  61 =cut
  62
  63 use File::Copy;
  64 use File::Spec::Functions qw/file_name_is_absolute curdir canonpath splitdir
  65                              catdir catfile splitpath catpath devnull abs2rel
  66                              rel2abs/;
  67 use File::Path 2.00 qw/rmtree mkpath/;
  68 use File::Basename;
  69 use Cwd qw/getcwd abs_path/;
  70
  71 my $level = 0;
  72
  73 # The name of the test.  This is set by setup() and is used in the other
  74 # functions to verify that setup() has been used.
  75 my $test_name = undef;
  76
  77 # Directories we want to keep track of TOP, APPS, TEST and RESULTS are the
  78 # ones we're interested in, corresponding to the environment variables TOP
  79 # (mandatory), BIN_D, TEST_D, UTIL_D and RESULT_D.
  80 my %directories = ();
  81
  82 # The environment variables that gave us the contents in %directories.  These
  83 # get modified whenever we change directories, so that subprocesses can use
  84 # the values of those environment variables as well
  85 my @direnv = ();
  86
  87 # A bool saying if we shall stop all testing if the current recipe has failing
  88 # tests or not.  This is set by setup() if the environment variable STOPTEST
  89 # is defined with a non-empty value.
  90 my $end_with_bailout = 0;
  91
  92 # A set of hooks that is affected by with() and may be used in diverse places.
  93 # All hooks are expected to be CODE references.
  94 my %hooks = (
  95
  96     # exit_checker is used by run() directly after completion of a command.
  97     # it receives the exit code from that command and is expected to return
  98     # 1 (for success) or 0 (for failure).  This is the status value that run()
  99     # will give back (through the |statusvar| reference and as returned value
 100     # when capture => 1 doesn't apply).
 101     exit_checker => sub { return shift == 0 ? 1 : 0 },
 102
 103     );
 104
 105 # Debug flag, to be set manually when needed
 106 my $debug = 0;
 107
 108 =head2 Main functions
 109
 110 The following functions are exported by default when using C<OpenSSL::Test>.
 111
 112 =cut
 113
 114 =over 4
 115
 116 =item B<setup "NAME">
 117
 118 C<setup> is used for initial setup, and it is mandatory that it's used.
 119 If it's not used in a OpenSSL test recipe, the rest of the recipe will
 120 most likely refuse to run.
 121
 122 C<setup> checks for environment variables (see L</ENVIRONMENT> below),
 123 checks that C<$TOP/Configure> or C<$SRCTOP/Configure> exists, C<chdir>
 124 into the results directory (defined by the C<$RESULT_D> environment
 125 variable if defined, otherwise C<$BLDTOP/test> or C<$TOP/test>, whichever
 126 is defined).
 127
 128 =back
 129
 130 =cut
 131
 132 sub setup {
 133     my $old_test_name = $test_name;
 134     $test_name = shift;
 135
 136     BAIL_OUT("setup() must receive a name") unless $test_name;
 137     warn "setup() detected test name change.  Innocuous, so we continue...\n"
 138         if $old_test_name && $old_test_name ne $test_name;
 139
 140     return if $old_test_name;
 141
 142     BAIL_OUT("setup() needs \$TOP or \$SRCTOP and \$BLDTOP to be defined")
 143         unless $ENV{TOP} || ($ENV{SRCTOP} && $ENV{BLDTOP});
 144     BAIL_OUT("setup() found both \$TOP and \$SRCTOP or \$BLDTOP...")
 145         if $ENV{TOP} && ($ENV{SRCTOP} || $ENV{BLDTOP});
 146
 147     __env();
 148
 149     BAIL_OUT("setup() expects the file Configure in the source top directory")
 150         unless -f srctop_file("Configure");
 151
 152     note "The results of this test will end up in $directories{RESULTS}";
 153
 154     __cwd($directories{RESULTS});
 155 }
 156
 157 =over 4
 158
 159 =item B<indir "SUBDIR" =E<gt> sub BLOCK, OPTS>
 160
 161 C<indir> is used to run a part of the recipe in a different directory than
 162 the one C<setup> moved into, usually a subdirectory, given by SUBDIR.
 163 The part of the recipe that's run there is given by the codeblock BLOCK.
 164
 165 C<indir> takes some additional options OPTS that affect the subdirectory:
 166
 167 =over 4
 168
 169 =item B<create =E<gt> 0|1>
 170
 171 When set to 1 (or any value that perl perceives as true), the subdirectory
 172 will be created if it doesn't already exist.  This happens before BLOCK
 173 is executed.
 174
 175 =back
 176
 177 An example:
 178
 179   indir "foo" => sub {
 180       ok(run(app(["openssl", "version"]), stdout => "foo.txt"));
 181       if (ok(open(RESULT, "foo.txt"), "reading foo.txt")) {
 182           my $line = <RESULT>;
 183           close RESULT;
 184           is($line, qr/^OpenSSL 1\./,
 185              "check that we're using OpenSSL 1.x.x");
 186       }
 187   }, create => 1;
 188
 189 =back
 190
 191 =cut
 192
 193 sub indir {
 194     my $subdir = shift;
 195     my $codeblock = shift;
 196     my %opts = @_;
 197
 198     my $reverse = __cwd($subdir,%opts);
 199     BAIL_OUT("FAILURE: indir, \"$subdir\" wasn't possible to move into")
 200         unless $reverse;
 201
 202     $codeblock->();
 203
 204     __cwd($reverse);
 205 }
 206
 207 =over 4
 208
 209 =item B<cmd ARRAYREF, OPTS>
 210
 211 This functions build up a platform dependent command based on the
 212 input.  It takes a reference to a list that is the executable or
 213 script and its arguments, and some additional options (described
 214 further on).  Where necessary, the command will be wrapped in a
 215 suitable environment to make sure the correct shared libraries are
 216 used (currently only on Unix).
 217
 218 It returns a CODEREF to be used by C<run>, C<pipe> or C<cmdstr>.
 219
 220 The options that C<cmd> can take are in the form of hash values:
 221
 222 =over 4
 223
 224 =item B<stdin =E<gt> PATH>
 225
 226 =item B<stdout =E<gt> PATH>
 227
 228 =item B<stderr =E<gt> PATH>
 229
 230 In all three cases, the corresponding standard input, output or error is
 231 redirected from (for stdin) or to (for the others) a file given by the
 232 string PATH, I<or>, if the value is C<undef>, C</dev/null> or similar.
 233
 234 =back
 235
 236 =item B<app ARRAYREF, OPTS>
 237
 238 =item B<test ARRAYREF, OPTS>
 239
 240 Both of these are specific applications of C<cmd>, with just a couple
 241 of small difference:
 242
 243 C<app> expects to find the given command (the first item in the given list
 244 reference) as an executable in C<$BIN_D> (if defined, otherwise C<$TOP/apps>
 245 or C<$BLDTOP/apps>).
 246
 247 C<test> expects to find the given command (the first item in the given list
 248 reference) as an executable in C<$TEST_D> (if defined, otherwise C<$TOP/test>
 249 or C<$BLDTOP/test>).
 250
 251 Also, for both C<app> and C<test>, the command may be prefixed with
 252 the content of the environment variable C<$EXE_SHELL>, which is useful
 253 in case OpenSSL has been cross compiled.
 254
 255 =item B<perlapp ARRAYREF, OPTS>
 256
 257 =item B<perltest ARRAYREF, OPTS>
 258
 259 These are also specific applications of C<cmd>, where the interpreter
 260 is predefined to be C<perl>, and they expect the script to be
 261 interpreted to reside in the same location as C<app> and C<test>.
 262
 263 C<perlapp> and C<perltest> will also take the following option:
 264
 265 =over 4
 266
 267 =item B<interpreter_args =E<gt> ARRAYref>
 268
 269 The array reference is a set of arguments for the interpreter rather
 270 than the script.  Take care so that none of them can be seen as a
 271 script!  Flags and their eventual arguments only!
 272
 273 =back
 274
 275 An example:
 276
 277   ok(run(perlapp(["foo.pl", "arg1"],
 278                  interpreter_args => [ "-I", srctop_dir("test") ])));
 279
 280 =back
 281
 282 =begin comment
 283
 284 One might wonder over the complexity of C<apps>, C<fuzz>, C<test>, ...
 285 with all the lazy evaluations and all that.  The reason for this is that
 286 we want to make sure the directory in which those programs are found are
 287 correct at the time these commands are used.  Consider the following code
 288 snippet:
 289
 290   my $cmd = app(["openssl", ...]);
 291
 292   indir "foo", sub {
 293       ok(run($cmd), "Testing foo")
 294   };
 295
 296 If there wasn't this lazy evaluation, the directory where C<openssl> is
 297 found would be incorrect at the time C<run> is called, because it was
 298 calculated before we moved into the directory "foo".
 299
 300 =end comment
 301
 302 =cut
 303
 304 sub cmd {
 305     my $cmd = shift;
 306     my %opts = @_;
 307     return sub {
 308         my $num = shift;
 309         # Make a copy to not destroy the caller's array
 310         my @cmdargs = ( @$cmd );
 311         my @prog = __wrap_cmd(shift @cmdargs, $opts{exe_shell} // ());
 312
 313         return __decorate_cmd($num, [ @prog, quotify(@cmdargs) ],
 314                               %opts);
 315     }
 316 }
 317
 318 sub app {
 319     my $cmd = shift;
 320     my %opts = @_;
 321     return sub {
 322         my @cmdargs = ( @{$cmd} );
 323         my @prog = __fixup_prg(__apps_file(shift @cmdargs, __exeext()));
 324         return cmd([ @prog, @cmdargs ],
 325                    exe_shell => $ENV{EXE_SHELL}, %opts) -> (shift);
 326     }
 327 }
 328
 329 sub fuzz {
 330     my $cmd = shift;
 331     my %opts = @_;
 332     return sub {
 333         my @cmdargs = ( @{$cmd} );
 334         my @prog = __fixup_prg(__fuzz_file(shift @cmdargs, __exeext()));
 335         return cmd([ @prog, @cmdargs ],
 336                    exe_shell => $ENV{EXE_SHELL}, %opts) -> (shift);
 337     }
 338 }
 339
 340 sub test {
 341     my $cmd = shift;
 342     my %opts = @_;
 343     return sub {
 344         my @cmdargs = ( @{$cmd} );
 345         my @prog = __fixup_prg(__test_file(shift @cmdargs, __exeext()));
 346         return cmd([ @prog, @cmdargs ],
 347                    exe_shell => $ENV{EXE_SHELL}, %opts) -> (shift);
 348     }
 349 }
 350
 351 sub perlapp {
 352     my $cmd = shift;
 353     my %opts = @_;
 354     return sub {
 355         my @interpreter_args = defined $opts{interpreter_args} ?
 356             @{$opts{interpreter_args}} : ();
 357         my @interpreter = __fixup_prg($^X);
 358         my @cmdargs = ( @{$cmd} );
 359         my @prog = __apps_file(shift @cmdargs, undef);
 360         return cmd([ @interpreter, @interpreter_args,
 361                      @prog, @cmdargs ], %opts) -> (shift);
 362     }
 363 }
 364
 365 sub perltest {
 366     my $cmd = shift;
 367     my %opts = @_;
 368     return sub {
 369         my @interpreter_args = defined $opts{interpreter_args} ?
 370             @{$opts{interpreter_args}} : ();
 371         my @interpreter = __fixup_prg($^X);
 372         my @cmdargs = ( @{$cmd} );
 373         my @prog = __test_file(shift @cmdargs, undef);
 374         return cmd([ @interpreter, @interpreter_args,
 375                      @prog, @cmdargs ], %opts) -> (shift);
 376     }
 377 }
 378
 379 =over 4
 380
 381 =item B<run CODEREF, OPTS>
 382
 383 CODEREF is expected to be the value return by C<cmd> or any of its
 384 derivatives, anything else will most likely cause an error unless you
 385 know what you're doing.
 386
 387 C<run> executes the command returned by CODEREF and return either the
 388 resulting output (if the option C<capture> is set true) or a boolean
 389 indicating if the command succeeded or not.
 390
 391 The options that C<run> can take are in the form of hash values:
 392
 393 =over 4
 394
 395 =item B<capture =E<gt> 0|1>
 396
 397 If true, the command will be executed with a perl backtick, and C<run> will
 398 return the resulting output as an array of lines.  If false or not given,
 399 the command will be executed with C<system()>, and C<run> will return 1 if
 400 the command was successful or 0 if it wasn't.
 401
 402 =item B<prefix =E<gt> EXPR>
 403
 404 If specified, EXPR will be used as a string to prefix the output from the
 405 command.  This is useful if the output contains lines starting with C<ok >
 406 or C<not ok > that can disturb Test::Harness.
 407
 408 =item B<statusvar =E<gt> VARREF>
 409
 410 If used, B<VARREF> must be a reference to a scalar variable.  It will be
 411 assigned a boolean indicating if the command succeeded or not.  This is
 412 particularly useful together with B<capture>.
 413
 414 =back
 415
 416 For further discussion on what is considered a successful command or not, see
 417 the function C<with> further down.
 418
 419 =back
 420
 421 =cut
 422
 423 sub run {
 424     my ($cmd, $display_cmd) = shift->(0);
 425     my %opts = @_;
 426
 427     return () if !$cmd;
 428
 429     my $prefix = "";
 430     if ( $^O eq "VMS" ) {       # VMS
 431         $prefix = "pipe ";
 432     }
 433
 434     my @r = ();
 435     my $r = 0;
 436     my $e = 0;
 437
 438     die "OpenSSL::Test::run(): statusvar value not a scalar reference"
 439         if $opts{statusvar} && ref($opts{statusvar}) ne "SCALAR";
 440
 441     # For some reason, program output, or even output from this function
 442     # somehow isn't caught by TAP::Harness (TAP::Parser?) on VMS, so we're
 443     # silencing it specifically there until further notice.
 444     my $save_STDOUT;
 445     my $save_STDERR;
 446     if ($^O eq 'VMS') {
 447         # In non-verbose, we want to shut up the command interpreter, in case
 448         # it has something to complain about.  On VMS, it might complain both
 449         # on stdout and stderr
 450         if ($ENV{HARNESS_ACTIVE} && !$ENV{HARNESS_VERBOSE}) {
 451             open $save_STDOUT, '>&', \*STDOUT or die "Can't dup STDOUT: $!";
 452             open $save_STDERR, '>&', \*STDERR or die "Can't dup STDERR: $!";
 453             open STDOUT, ">", devnull();
 454             open STDERR, ">", devnull();
 455         }
 456     }
 457
 458     $ENV{HARNESS_OSSL_LEVEL} = $level + 1;
 459
 460     # The dance we do with $? is the same dance the Unix shells appear to
 461     # do.  For example, a program that gets aborted (and therefore signals
 462     # SIGABRT = 6) will appear to exit with the code 134.  We mimic this
 463     # to make it easier to compare with a manual run of the command.
 464     if ($opts{capture} || defined($opts{prefix})) {
 465         my $pipe;
 466         local $_;
 467
 468         open($pipe, '-|', "$prefix$cmd") or die "Can't start command: $!";
 469         while(<$pipe>) {
 470             my $l = ($opts{prefix} // "") . $_;
 471             if ($opts{capture}) {
 472                 push @r, $l;
 473             } else {
 474                 print STDOUT $l;
 475             }
 476         }
 477         close $pipe;
 478     } else {
 479         $ENV{HARNESS_OSSL_PREFIX} = "# ";
 480         system("$prefix$cmd");
 481         delete $ENV{HARNESS_OSSL_PREFIX};
 482     }
 483     $e = ($? & 0x7f) ? ($? & 0x7f)|0x80 : ($? >> 8);
 484     $r = $hooks{exit_checker}->($e);
 485     if ($opts{statusvar}) {
 486         ${$opts{statusvar}} = $r;
 487     }
 488
 489     # Restore STDOUT / STDERR on VMS
 490     if ($^O eq 'VMS') {
 491         if ($ENV{HARNESS_ACTIVE} && !$ENV{HARNESS_VERBOSE}) {
 492             close STDOUT;
 493             close STDERR;
 494             open STDOUT, '>&', $save_STDOUT or die "Can't restore STDOUT: $!";
 495             open STDERR, '>&', $save_STDERR or die "Can't restore STDERR: $!";
 496         }
 497
 498         print STDERR "$prefix$display_cmd => $e\n"
 499             if !$ENV{HARNESS_ACTIVE} || $ENV{HARNESS_VERBOSE};
 500     } else {
 501         print STDERR "$prefix$display_cmd => $e\n";
 502     }
 503
 504     # At this point, $? stops being interesting, and unfortunately,
 505     # there are Test::More versions that get picky if we leave it
 506     # non-zero.
 507     $? = 0;
 508
 509     if ($opts{capture}) {
 510         return @r;
 511     } else {
 512         return $r;
 513     }
 514 }
 515
 516 END {
 517     my $tb = Test::More->builder;
 518     my $failure = scalar(grep { $_ == 0; } $tb->summary);
 519     if ($failure && $end_with_bailout) {
 520         BAIL_OUT("Stoptest!");
 521     }
 522 }
 523
 524 =head2 Utility functions
 525
 526 The following functions are exported on request when using C<OpenSSL::Test>.
 527
 528   # To only get the bldtop_file and srctop_file functions.
 529   use OpenSSL::Test qw/bldtop_file srctop_file/;
 530
 531   # To only get the bldtop_file function in addition to the default ones.
 532   use OpenSSL::Test qw/:DEFAULT bldtop_file/;
 533
 534 =cut
 535
 536 # Utility functions, exported on request
 537
 538 =over 4
 539
 540 =item B<bldtop_dir LIST>
 541
 542 LIST is a list of directories that make up a path from the top of the OpenSSL
 543 build directory (as indicated by the environment variable C<$TOP> or
 544 C<$BLDTOP>).
 545 C<bldtop_dir> returns the resulting directory as a string, adapted to the local
 546 operating system.
 547
 548 =back
 549
 550 =cut
 551
 552 sub bldtop_dir {
 553     return __bldtop_dir(@_);    # This caters for operating systems that have
 554                                 # a very distinct syntax for directories.
 555 }
 556
 557 =over 4
 558
 559 =item B<bldtop_file LIST, FILENAME>
 560
 561 LIST is a list of directories that make up a path from the top of the OpenSSL
 562 build directory (as indicated by the environment variable C<$TOP> or
 563 C<$BLDTOP>) and FILENAME is the name of a file located in that directory path.
 564 C<bldtop_file> returns the resulting file path as a string, adapted to the local
 565 operating system.
 566
 567 =back
 568
 569 =cut
 570
 571 sub bldtop_file {
 572     return __bldtop_file(@_);
 573 }
 574
 575 =over 4
 576
 577 =item B<srctop_dir LIST>
 578
 579 LIST is a list of directories that make up a path from the top of the OpenSSL
 580 source directory (as indicated by the environment variable C<$TOP> or
 581 C<$SRCTOP>).
 582 C<srctop_dir> returns the resulting directory as a string, adapted to the local
 583 operating system.
 584
 585 =back
 586
 587 =cut
 588
 589 sub srctop_dir {
 590     return __srctop_dir(@_);    # This caters for operating systems that have
 591                                 # a very distinct syntax for directories.
 592 }
 593
 594 =over 4
 595
 596 =item B<srctop_file LIST, FILENAME>
 597
 598 LIST is a list of directories that make up a path from the top of the OpenSSL
 599 source directory (as indicated by the environment variable C<$TOP> or
 600 C<$SRCTOP>) and FILENAME is the name of a file located in that directory path.
 601 C<srctop_file> returns the resulting file path as a string, adapted to the local
 602 operating system.
 603
 604 =back
 605
 606 =cut
 607
 608 sub srctop_file {
 609     return __srctop_file(@_);
 610 }
 611
 612 =over 4
 613
 614 =item B<data_dir LIST>
 615
 616 LIST is a list of directories that make up a path from the data directory
 617 associated with the test (see L</DESCRIPTION> above).
 618 C<data_dir> returns the resulting directory as a string, adapted to the local
 619 operating system.
 620
 621 =back
 622
 623 =cut
 624
 625 sub data_dir {
 626     return __data_dir(@_);
 627 }
 628
 629 =over 4
 630
 631 =item B<data_file LIST, FILENAME>
 632
 633 LIST is a list of directories that make up a path from the data directory
 634 associated with the test (see L</DESCRIPTION> above) and FILENAME is the name
 635 of a file located in that directory path.  C<data_file> returns the resulting
 636 file path as a string, adapted to the local operating system.
 637
 638 =back
 639
 640 =cut
 641
 642 sub data_file {
 643     return __data_file(@_);
 644 }
 645
 646 =over 4
 647
 648 =item B<pipe LIST>
 649
 650 LIST is a list of CODEREFs returned by C<app> or C<test>, from which C<pipe>
 651 creates a new command composed of all the given commands put together in a
 652 pipe.  C<pipe> returns a new CODEREF in the same manner as C<app> or C<test>,
 653 to be passed to C<run> for execution.
 654
 655 =back
 656
 657 =cut
 658
 659 sub pipe {
 660     my @cmds = @_;
 661     return
 662         sub {
 663             my @cs  = ();
 664             my @dcs = ();
 665             my @els = ();
 666             my $counter = 0;
 667             foreach (@cmds) {
 668                 my ($c, $dc, @el) = $_->(++$counter);
 669
 670                 return () if !$c;
 671
 672                 push @cs, $c;
 673                 push @dcs, $dc;
 674                 push @els, @el;
 675             }
 676             return (
 677                 join(" | ", @cs),
 678                 join(" | ", @dcs),
 679                 @els
 680                 );
 681     };
 682 }
 683
 684 =over 4
 685
 686 =item B<with HASHREF, CODEREF>
 687
 688 C<with> will temporarily install hooks given by the HASHREF and then execute
 689 the given CODEREF.  Hooks are usually expected to have a coderef as value.
 690
 691 The currently available hoosk are:
 692
 693 =over 4
 694
 695 =item B<exit_checker =E<gt> CODEREF>
 696
 697 This hook is executed after C<run> has performed its given command.  The
 698 CODEREF receives the exit code as only argument and is expected to return
 699 1 (if the exit code indicated success) or 0 (if the exit code indicated
 700 failure).
 701
 702 =back
 703
 704 =back
 705
 706 =cut
 707
 708 sub with {
 709     my $opts = shift;
 710     my %opts = %{$opts};
 711     my $codeblock = shift;
 712
 713     my %saved_hooks = ();
 714
 715     foreach (keys %opts) {
 716         $saved_hooks{$_} = $hooks{$_}   if exists($hooks{$_});
 717         $hooks{$_} = $opts{$_};
 718     }
 719
 720     $codeblock->();
 721
 722     foreach (keys %saved_hooks) {
 723         $hooks{$_} = $saved_hooks{$_};
 724     }
 725 }
 726
 727 =over 4
 728
 729 =item B<cmdstr CODEREF, OPTS>
 730
 731 C<cmdstr> takes a CODEREF from C<app> or C<test> and simply returns the
 732 command as a string.
 733
 734 C<cmdstr> takes some additional options OPTS that affect the string returned:
 735
 736 =over 4
 737
 738 =item B<display =E<gt> 0|1>
 739
 740 When set to 0, the returned string will be with all decorations, such as a
 741 possible redirect of stderr to the null device.  This is suitable if the
 742 string is to be used directly in a recipe.
 743
 744 When set to 1, the returned string will be without extra decorations.  This
 745 is suitable for display if that is desired (doesn't confuse people with all
 746 internal stuff), or if it's used to pass a command down to a subprocess.
 747
 748 Default: 0
 749
 750 =back
 751
 752 =back
 753
 754 =cut
 755
 756 sub cmdstr {
 757     my ($cmd, $display_cmd) = shift->(0);
 758     my %opts = @_;
 759
 760     if ($opts{display}) {
 761         return $display_cmd;
 762     } else {
 763         return $cmd;
 764     }
 765 }
 766
 767 =over 4
 768
 769 =item B<quotify LIST>
 770
 771 LIST is a list of strings that are going to be used as arguments for a
 772 command, and makes sure to inject quotes and escapes as necessary depending
 773 on the content of each string.
 774
 775 This can also be used to put quotes around the executable of a command.
 776 I<This must never ever be done on VMS.>
 777
 778 =back
 779
 780 =cut
 781
 782 sub quotify {
 783     # Unix setup (default if nothing else is mentioned)
 784     my $arg_formatter =
 785         sub { $_ = shift;
 786               ($_ eq '' || /\s|[\{\}\\\$\[\]\*\?\|\&:;<>]/) ? "'$_'" : $_ };
 787
 788     if ( $^O eq "VMS") {        # VMS setup
 789         $arg_formatter = sub {
 790             $_ = shift;
 791             if ($_ eq '' || /\s|["[:upper:]]/) {
 792                 s/"/""/g;
 793                 '"'.$_.'"';
 794             } else {
 795                 $_;
 796             }
 797         };
 798     } elsif ( $^O eq "MSWin32") { # MSWin setup
 799         $arg_formatter = sub {
 800             $_ = shift;
 801             if ($_ eq '' || /\s|["\|\&\*\;<>]/) {
 802                 s/(["\\])/\\$1/g;
 803                 '"'.$_.'"';
 804             } else {
 805                 $_;
 806             }
 807         };
 808     }
 809
 810     return map { $arg_formatter->($_) } @_;
 811 }
 812
 813 =over 4
 814
 815 =item B<openssl_versions>
 816
 817 Returns a list of two version numbers, the first representing the build
 818 version, the second representing the library version.  See opensslv.h for
 819 more information on those numbers.
 820
 821 =back
 822
 823 =cut
 824
 825 my @versions = ();
 826 sub openssl_versions {
 827     unless (@versions) {
 828         my %lines =
 829             map { s/\R$//;
 830                   /^(.*): (.*)$/;
 831                   $1 => $2 }
 832             run(test(['versions']), capture => 1);
 833         @versions = ( $lines{'Build version'}, $lines{'Library version'} );
 834     }
 835     return @versions;
 836 }
 837
 838 =over 4
 839
 840 =item B<ok_nofips EXPR, TEST_NAME>
 841
 842 C<ok_nofips> is equivalent to using C<ok> when the environment variable
 843 C<FIPS_MODE> is undefined, otherwise it is equivalent to C<not ok>. This can be
 844 used for C<ok> tests that must fail when testing a FIPS provider. The parameters
 845 are the same as used by C<ok> which is an expression EXPR followed by the test
 846 description TEST_NAME.
 847
 848 An example:
 849
 850   ok_nofips(run(app(["md5.pl"])), "md5 should fail in fips mode");
 851
 852 =item B<is_nofips EXPR1, EXPR2, TEST_NAME>
 853
 854 C<is_nofips> is equivalent to using C<is> when the environment variable
 855 C<FIPS_MODE> is undefined, otherwise it is equivalent to C<isnt>. This can be
 856 used for C<is> tests that must fail when testing a FIPS provider. The parameters
 857 are the same as used by C<is> which has 2 arguments EXPR1 and EXPR2 that can be
 858 compared using eq or ne, followed by a test description TEST_NAME.
 859
 860 An example:
 861
 862   is_nofips(ultimate_answer(), 42,  "Meaning of Life");
 863
 864 =item B<isnt_nofips EXPR1, EXPR2, TEST_NAME>
 865
 866 C<isnt_nofips> is equivalent to using C<isnt> when the environment variable
 867 C<FIPS_MODE> is undefined, otherwise it is equivalent to C<is>. This can be
 868 used for C<isnt> tests that must fail when testing a FIPS provider. The
 869 parameters are the same as used by C<isnt> which has 2 arguments EXPR1 and EXPR2
 870 that can be compared using ne or eq, followed by a test description TEST_NAME.
 871
 872 An example:
 873
 874   isnt_nofips($foo, '',  "Got some foo");
 875
 876 =back
 877
 878 =cut
 879
 880 sub ok_nofips {
 881     return ok(!$_[0], @_[1..$#_]) if defined $ENV{FIPS_MODE};
 882     return ok($_[0], @_[1..$#_]);
 883 }
 884
 885 sub is_nofips {
 886     return isnt($_[0], $_[1], @_[2..$#_]) if defined $ENV{FIPS_MODE};
 887     return is($_[0], $_[1], @_[2..$#_]);
 888 }
 889
 890 sub isnt_nofips {
 891     return is($_[0], $_[1], @_[2..$#_]) if defined $ENV{FIPS_MODE};
 892     return isnt($_[0], $_[1], @_[2..$#_]);
 893 }
 894
 895 ######################################################################
 896 # private functions.  These are never exported.
 897
 898 =head1 ENVIRONMENT
 899
 900 OpenSSL::Test depends on some environment variables.
 901
 902 =over 4
 903
 904 =item B<TOP>
 905
 906 This environment variable is mandatory.  C<setup> will check that it's
 907 defined and that it's a directory that contains the file C<Configure>.
 908 If this isn't so, C<setup> will C<BAIL_OUT>.
 909
 910 =item B<BIN_D>
 911
 912 If defined, its value should be the directory where the openssl application
 913 is located.  Defaults to C<$TOP/apps> (adapted to the operating system).
 914
 915 =item B<TEST_D>
 916
 917 If defined, its value should be the directory where the test applications
 918 are located.  Defaults to C<$TOP/test> (adapted to the operating system).
 919
 920 =item B<STOPTEST>
 921
 922 If defined, it puts testing in a different mode, where a recipe with
 923 failures will result in a C<BAIL_OUT> at the end of its run.
 924
 925 =item B<FIPS_MODE>
 926
 927 If defined it indicates that the FIPS provider is being tested. Tests may use
 928 B<ok_nofips>, B<is_nofips> and B<isnt_nofips> to invert test results
 929 i.e. Some tests may only work in non FIPS mode.
 930
 931 =back
 932
 933 =cut
 934
 935 sub __env {
 936     (my $recipe_datadir = basename($0)) =~ s/\.t$/_data/i;
 937
 938     $directories{SRCTOP}    = abs_path($ENV{SRCTOP} || $ENV{TOP});
 939     $directories{BLDTOP}    = abs_path($ENV{BLDTOP} || $ENV{TOP});
 940     $directories{BLDAPPS}   = $ENV{BIN_D}  || __bldtop_dir("apps");
 941     $directories{SRCAPPS}   =                 __srctop_dir("apps");
 942     $directories{BLDFUZZ}   =                 __bldtop_dir("fuzz");
 943     $directories{SRCFUZZ}   =                 __srctop_dir("fuzz");
 944     $directories{BLDTEST}   = $ENV{TEST_D} || __bldtop_dir("test");
 945     $directories{SRCTEST}   =                 __srctop_dir("test");
 946     $directories{SRCDATA}   =                 __srctop_dir("test", "recipes",
 947                                                            $recipe_datadir);
 948     $directories{RESULTTOP} = $ENV{RESULT_D} || __bldtop_dir("test-runs");
 949     $directories{RESULTS}   = catdir($directories{RESULTTOP}, $test_name);
 950
 951     # Create result directory dynamically
 952     rmtree($directories{RESULTS}, { safe => 0, keep_root => 1 });
 953     mkpath($directories{RESULTS});
 954
 955     push @direnv, "TOP"       if $ENV{TOP};
 956     push @direnv, "SRCTOP"    if $ENV{SRCTOP};
 957     push @direnv, "BLDTOP"    if $ENV{BLDTOP};
 958     push @direnv, "BIN_D"     if $ENV{BIN_D};
 959     push @direnv, "TEST_D"    if $ENV{TEST_D};
 960     push @direnv, "RESULT_D"  if $ENV{RESULT_D};
 961
 962     $end_with_bailout = $ENV{STOPTEST} ? 1 : 0;
 963 };
 964
 965 # __srctop_file and __srctop_dir are helpers to build file and directory
 966 # names on top of the source directory.  They depend on $SRCTOP, and
 967 # therefore on the proper use of setup() and when needed, indir().
 968 # __bldtop_file and __bldtop_dir do the same thing but relative to $BLDTOP.
 969 # __srctop_file and __bldtop_file take the same kind of argument as
 970 # File::Spec::Functions::catfile.
 971 # Similarly, __srctop_dir and __bldtop_dir take the same kind of argument
 972 # as File::Spec::Functions::catdir
 973 sub __srctop_file {
 974     BAIL_OUT("Must run setup() first") if (! $test_name);
 975
 976     my $f = pop;
 977     return abs2rel(catfile($directories{SRCTOP},@_,$f),getcwd);
 978 }
 979
 980 sub __srctop_dir {
 981     BAIL_OUT("Must run setup() first") if (! $test_name);
 982
 983     return abs2rel(catdir($directories{SRCTOP},@_), getcwd);
 984 }
 985
 986 sub __bldtop_file {
 987     BAIL_OUT("Must run setup() first") if (! $test_name);
 988
 989     my $f = pop;
 990     return abs2rel(catfile($directories{BLDTOP},@_,$f), getcwd);
 991 }
 992
 993 sub __bldtop_dir {
 994     BAIL_OUT("Must run setup() first") if (! $test_name);
 995
 996     return abs2rel(catdir($directories{BLDTOP},@_), getcwd);
 997 }
 998
 999 # __exeext is a function that returns the platform dependent file extension
1000 # for executable binaries, or the value of the environment variable $EXE_EXT
1001 # if that one is defined.
1002 sub __exeext {
1003     my $ext = "";
1004     if ($^O eq "VMS" ) {        # VMS
1005         $ext = ".exe";
1006     } elsif ($^O eq "MSWin32") { # Windows
1007         $ext = ".exe";
1008     }
1009     return $ENV{"EXE_EXT"} || $ext;
1010 }
1011
1012 # __test_file, __apps_file and __fuzz_file return the full path to a file
1013 # relative to the test/, apps/ or fuzz/ directory in the build tree or the
1014 # source tree, depending on where the file is found.  Note that when looking
1015 # in the build tree, the file name with an added extension is looked for, if
1016 # an extension is given.  The intent is to look for executable binaries (in
1017 # the build tree) or possibly scripts (in the source tree).
1018 # These functions all take the same arguments as File::Spec::Functions::catfile,
1019 # *plus* a mandatory extension argument.  This extension argument can be undef,
1020 # and is ignored in such a case.
1021 sub __test_file {
1022     BAIL_OUT("Must run setup() first") if (! $test_name);
1023
1024     my $e = pop || "";
1025     my $f = pop;
1026     my $out = catfile($directories{BLDTEST},@_,$f . $e);
1027     $out = catfile($directories{SRCTEST},@_,$f) unless -f $out;
1028     return $out;
1029 }
1030
1031 sub __apps_file {
1032     BAIL_OUT("Must run setup() first") if (! $test_name);
1033
1034     my $e = pop || "";
1035     my $f = pop;
1036     my $out = catfile($directories{BLDAPPS},@_,$f . $e);
1037     $out = catfile($directories{SRCAPPS},@_,$f) unless -f $out;
1038     return $out;
1039 }
1040
1041 sub __fuzz_file {
1042     BAIL_OUT("Must run setup() first") if (! $test_name);
1043
1044     my $e = pop || "";
1045     my $f = pop;
1046     my $out = catfile($directories{BLDFUZZ},@_,$f . $e);
1047     $out = catfile($directories{SRCFUZZ},@_,$f) unless -f $out;
1048     return $out;
1049 }
1050
1051 sub __data_file {
1052     BAIL_OUT("Must run setup() first") if (! $test_name);
1053
1054     my $f = pop;
1055     return catfile($directories{SRCDATA},@_,$f);
1056 }
1057
1058 sub __data_dir {
1059     BAIL_OUT("Must run setup() first") if (! $test_name);
1060
1061     return catdir($directories{SRCDATA},@_);
1062 }
1063
1064 sub __results_file {
1065     BAIL_OUT("Must run setup() first") if (! $test_name);
1066
1067     my $f = pop;
1068     return catfile($directories{RESULTS},@_,$f);
1069 }
1070
1071 # __cwd DIR
1072 # __cwd DIR, OPTS
1073 #
1074 # __cwd changes directory to DIR (string) and changes all the relative
1075 # entries in %directories accordingly.  OPTS is an optional series of
1076 # hash style arguments to alter __cwd's behavior:
1077 #
1078 #    create = 0|1       The directory we move to is created if 1, not if 0.
1079
1080 sub __cwd {
1081     my $dir = catdir(shift);
1082     my %opts = @_;
1083     my $abscurdir = rel2abs(curdir());
1084     my $absdir = rel2abs($dir);
1085     my $reverse = abs2rel($abscurdir, $absdir);
1086
1087     # PARANOIA: if we're not moving anywhere, we do nothing more
1088     if ($abscurdir eq $absdir) {
1089         return $reverse;
1090     }
1091
1092     # Do not support a move to a different volume for now.  Maybe later.
1093     BAIL_OUT("FAILURE: \"$dir\" moves to a different volume, not supported")
1094         if $reverse eq $abscurdir;
1095
1096     # If someone happened to give a directory that leads back to the current,
1097     # it's extremely silly to do anything more, so just simulate that we did
1098     # move.
1099     # In this case, we won't even clean it out, for safety's sake.
1100     return "." if $reverse eq "";
1101
1102     $dir = canonpath($dir);
1103     if ($opts{create}) {
1104         mkpath($dir);
1105     }
1106
1107     # We are recalculating the directories we keep track of, but need to save
1108     # away the result for after having moved into the new directory.
1109     my %tmp_directories = ();
1110     my %tmp_ENV = ();
1111
1112     # For each of these directory variables, figure out where they are relative
1113     # to the directory we want to move to if they aren't absolute (if they are,
1114     # they don't change!)
1115     my @dirtags = sort keys %directories;
1116     foreach (@dirtags) {
1117         if (!file_name_is_absolute($directories{$_})) {
1118             my $newpath = abs2rel(rel2abs($directories{$_}), rel2abs($dir));
1119             $tmp_directories{$_} = $newpath;
1120         }
1121     }
1122
1123     # Treat each environment variable that was used to get us the values in
1124     # %directories the same was as the paths in %directories, so any sub
1125     # process can use their values properly as well
1126     foreach (@direnv) {
1127         if (!file_name_is_absolute($ENV{$_})) {
1128             my $newpath = abs2rel(rel2abs($ENV{$_}), rel2abs($dir));
1129             $tmp_ENV{$_} = $newpath;
1130         }
1131     }
1132
1133     # Should we just bail out here as well?  I'm unsure.
1134     return undef unless chdir($dir);
1135
1136     # We put back new values carefully.  Doing the obvious
1137     # %directories = ( %tmp_directories )
1138     # will clear out any value that happens to be an absolute path
1139     foreach (keys %tmp_directories) {
1140         $directories{$_} = $tmp_directories{$_};
1141     }
1142     foreach (keys %tmp_ENV) {
1143         $ENV{$_} = $tmp_ENV{$_};
1144     }
1145
1146     if ($debug) {
1147         print STDERR "DEBUG: __cwd(), directories and files:\n";
1148         print STDERR "  \$directories{BLDTEST} = \"$directories{BLDTEST}\"\n";
1149         print STDERR "  \$directories{SRCTEST} = \"$directories{SRCTEST}\"\n";
1150         print STDERR "  \$directories{SRCDATA} = \"$directories{SRCDATA}\"\n";
1151         print STDERR "  \$directories{RESULTS} = \"$directories{RESULTS}\"\n";
1152         print STDERR "  \$directories{BLDAPPS} = \"$directories{BLDAPPS}\"\n";
1153         print STDERR "  \$directories{SRCAPPS} = \"$directories{SRCAPPS}\"\n";
1154         print STDERR "  \$directories{SRCTOP}  = \"$directories{SRCTOP}\"\n";
1155         print STDERR "  \$directories{BLDTOP}  = \"$directories{BLDTOP}\"\n";
1156         print STDERR "\n";
1157         print STDERR "  current directory is \"",curdir(),"\"\n";
1158         print STDERR "  the way back is \"$reverse\"\n";
1159     }
1160
1161     return $reverse;
1162 }
1163
1164 # __wrap_cmd CMD
1165 # __wrap_cmd CMD, EXE_SHELL
1166 #
1167 # __wrap_cmd "wraps" CMD (string) with a beginning command that makes sure
1168 # the command gets executed with an appropriate environment.  If EXE_SHELL
1169 # is given, it is used as the beginning command.
1170 #
1171 # __wrap_cmd returns a list that should be used to build up a larger list
1172 # of command tokens, or be joined together like this:
1173 #
1174 #    join(" ", __wrap_cmd($cmd))
1175 sub __wrap_cmd {
1176     my $cmd = shift;
1177     my $exe_shell = shift;
1178
1179     my @prefix = ( __bldtop_file("util", "shlib_wrap.sh") );
1180
1181     if(defined($exe_shell)) {
1182         @prefix = ( $exe_shell );
1183     } elsif ($^O eq "VMS" || $^O eq "MSWin32") {
1184         # VMS and Windows don't use any wrapper script for the moment
1185         @prefix = ();
1186     }
1187
1188     return (@prefix, $cmd);
1189 }
1190
1191 # __fixup_prg PROG
1192 #
1193 # __fixup_prg does whatever fixup is needed to execute an executable binary
1194 # given by PROG (string).
1195 #
1196 # __fixup_prg returns a string with the possibly prefixed program path spec.
1197 sub __fixup_prg {
1198     my $prog = shift;
1199
1200     my $prefix = "";
1201
1202     if ($^O eq "VMS" ) {
1203         $prefix = ($prog =~ /^(?:[\$a-z0-9_]+:)?[<\[]/i ? "mcr " : "mcr []");
1204     }
1205
1206     if (defined($prog)) {
1207         # Make sure to quotify the program file on platforms that may
1208         # have spaces or similar in their path name.
1209         # To our knowledge, VMS is the exception where quotifying should
1210         # never happen.
1211         ($prog) = quotify($prog) unless $^O eq "VMS";
1212         return $prefix.$prog;
1213     }
1214
1215     print STDERR "$prog not found\n";
1216     return undef;
1217 }
1218
1219 # __decorate_cmd NUM, CMDARRAYREF
1220 #
1221 # __decorate_cmd takes a command number NUM and a command token array
1222 # CMDARRAYREF, builds up a command string from them and decorates it
1223 # with necessary redirections.
1224 # __decorate_cmd returns a list of two strings, one with the command
1225 # string to actually be used, the other to be displayed for the user.
1226 # The reason these strings might differ is that we redirect stderr to
1227 # the null device unless we're verbose and unless the user has
1228 # explicitly specified a stderr redirection.
1229 sub __decorate_cmd {
1230     BAIL_OUT("Must run setup() first") if (! $test_name);
1231
1232     my $num = shift;
1233     my $cmd = shift;
1234     my %opts = @_;
1235
1236     my $cmdstr = join(" ", @$cmd);
1237     my $null = devnull();
1238     my $fileornull = sub { $_[0] ? $_[0] : $null; };
1239     my $stdin = "";
1240     my $stdout = "";
1241     my $stderr = "";
1242     my $saved_stderr = undef;
1243     $stdin = " < ".$fileornull->($opts{stdin})  if exists($opts{stdin});
1244     $stdout= " > ".$fileornull->($opts{stdout}) if exists($opts{stdout});
1245     $stderr=" 2> ".$fileornull->($opts{stderr}) if exists($opts{stderr});
1246
1247     my $display_cmd = "$cmdstr$stdin$stdout$stderr";
1248
1249     # VMS program output escapes TAP::Parser
1250     if ($^O eq 'VMS') {
1251         $stderr=" 2> ".$null
1252             unless $stderr || !$ENV{HARNESS_ACTIVE} || $ENV{HARNESS_VERBOSE};
1253     }
1254
1255     $cmdstr .= "$stdin$stdout$stderr";
1256
1257     if ($debug) {
1258         print STDERR "DEBUG[__decorate_cmd]: \$cmdstr = \"$cmdstr\"\n";
1259         print STDERR "DEBUG[__decorate_cmd]: \$display_cmd = \"$display_cmd\"\n";
1260     }
1261
1262     return ($cmdstr, $display_cmd);
1263 }
1264
1265 =head1 SEE ALSO
1266
1267 L<Test::More>, L<Test::Harness>
1268
1269 =head1 AUTHORS
1270
1271 Richard Levitte E<lt>levitte@openssl.orgE<gt> with assistance and
1272 inspiration from Andy Polyakov E<lt>appro@openssl.org<gt>.
1273
1274 =cut
1275
1276 no warnings 'redefine';
1277 sub subtest {
1278     $level++;
1279
1280     Test::More::subtest @_;
1281
1282     $level--;
1283 };
1284
1285 1;