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