util/perl/OpenSSL/Test.pm

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