util/perl/OpenSSL/Test.pm

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