test/testlib/OpenSSL/Test.pm

   1 # Copyright 2016 The OpenSSL Project Authors. All Rights Reserved.
   2 #
   3 # Licensed under the OpenSSL license (the "License").  You may not use
   4 # this file except in compliance with the License.  You can obtain a copy
   5 # in the file LICENSE in the source distribution or at
   6 # https://www.openssl.org/source/license.html
   7
   8 package OpenSSL::Test;
   9
  10 use strict;
  11 use warnings;
  12
  13 use Test::More 0.96;
  14
  15 use Exporter;
  16 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  17 $VERSION = "0.8";
  18 @ISA = qw(Exporter);
  19 @EXPORT = (@Test::More::EXPORT, qw(setup run indir cmd app fuzz test
  20                                    perlapp perltest));
  21 @EXPORT_OK = (@Test::More::EXPORT_OK, qw(bldtop_dir bldtop_file
  22                                          srctop_dir srctop_file
  23                                          data_file
  24                                          pipe with cmdstr quotify));
  25
  26 =head1 NAME
  27
  28 OpenSSL::Test - a private extension of Test::More
  29
  30 =head1 SYNOPSIS
  31
  32   use OpenSSL::Test;
  33
  34   setup("my_test_name");
  35
  36   ok(run(app(["openssl", "version"])), "check for openssl presence");
  37
  38   indir "subdir" => sub {
  39     ok(run(test(["sometest", "arg1"], stdout => "foo.txt")),
  40        "run sometest with output to foo.txt");
  41   };
  42
  43 =head1 DESCRIPTION
  44
  45 This module is a private extension of L<Test::More> for testing OpenSSL.
  46 In addition to the Test::More functions, it also provides functions that
  47 easily find the diverse programs within a OpenSSL build tree, as well as
  48 some other useful functions.
  49
  50 This module I<depends> on the environment variables C<$TOP> or C<$SRCTOP>
  51 and C<$BLDTOP>.  Without one of the combinations it refuses to work.
  52 See L</ENVIRONMENT> below.
  53
  54 With each test recipe, a parallel data directory with (almost) the same name
  55 as the recipe is possible in the source directory tree.  For example, for a
  56 recipe C<$SRCTOP/test/recipes/99-foo.t>, there could be a directory
  57 C<$SRCTOP/test/recipes/99-foo_data/>.
  58
  59 =cut
  60
  61 use File::Copy;
  62 use File::Spec::Functions qw/file_name_is_absolute curdir canonpath splitdir
  63                              catdir catfile splitpath catpath devnull abs2rel
  64                              rel2abs/;
  65 use File::Path 2.00 qw/rmtree mkpath/;
  66 use File::Basename;
  67
  68
  69 # The name of the test.  This is set by setup() and is used in the other
  70 # functions to verify that setup() has been used.
  71 my $test_name = undef;
  72
  73 # Directories we want to keep track of TOP, APPS, TEST and RESULTS are the
  74 # ones we're interested in, corresponding to the environment variables TOP
  75 # (mandatory), BIN_D, TEST_D, UTIL_D and RESULT_D.
  76 my %directories = ();
  77
  78 # The environment variables that gave us the contents in %directories.  These
  79 # get modified whenever we change directories, so that subprocesses can use
  80 # the values of those environment variables as well
  81 my @direnv = ();
  82
  83 # A bool saying if we shall stop all testing if the current recipe has failing
  84 # tests or not.  This is set by setup() if the environment variable STOPTEST
  85 # is defined with a non-empty value.
  86 my $end_with_bailout = 0;
  87
  88 # A set of hooks that is affected by with() and may be used in diverse places.
  89 # All hooks are expected to be CODE references.
  90 my %hooks = (
  91
  92     # exit_checker is used by run() directly after completion of a command.
  93     # it receives the exit code from that command and is expected to return
  94     # 1 (for success) or 0 (for failure).  This is the status value that run()
  95     # will give back (through the |statusvar| referens and as returned value
  96     # when capture => 1 doesn't apply).
  97     exit_checker => sub { return shift == 0 ? 1 : 0 },
  98
  99     );
 100
 101 # Debug flag, to be set manually when needed
 102 my $debug = 0;
 103
 104 =head2 Main functions
 105
 106 The following functions are exported by default when using C<OpenSSL::Test>.
 107
 108 =cut
 109
 110 =over 4
 111
 112 =item B<setup "NAME">
 113
 114 C<setup> is used for initial setup, and it is mandatory that it's used.
 115 If it's not used in a OpenSSL test recipe, the rest of the recipe will
 116 most likely refuse to run.
 117
 118 C<setup> checks for environment variables (see L</ENVIRONMENT> below),
 119 checks that C<$TOP/Configure> or C<$SRCTOP/Configure> exists, C<chdir>
 120 into the results directory (defined by the C<$RESULT_D> environment
 121 variable if defined, otherwise C<$BLDTOP/test> or C<$TOP/test>, whichever
 122 is defined).
 123
 124 =back
 125
 126 =cut
 127
 128 sub setup {
 129     my $old_test_name = $test_name;
 130     $test_name = shift;
 131
 132     BAIL_OUT("setup() must receive a name") unless $test_name;
 133     warn "setup() detected test name change.  Innocuous, so we continue...\n"
 134         if $old_test_name && $old_test_name ne $test_name;
 135
 136     return if $old_test_name;
 137
 138     BAIL_OUT("setup() needs \$TOP or \$SRCTOP and \$BLDTOP to be defined")
 139         unless $ENV{TOP} || ($ENV{SRCTOP} && $ENV{BLDTOP});
 140     BAIL_OUT("setup() found both \$TOP and \$SRCTOP or \$BLDTOP...")
 141         if $ENV{TOP} && ($ENV{SRCTOP} || $ENV{BLDTOP});
 142
 143     __env();
 144
 145     BAIL_OUT("setup() expects the file Configure in the source top directory")
 146         unless -f srctop_file("Configure");
 147
 148     __cwd($directories{RESULTS});
 149 }
 150
 151 =over 4
 152
 153 =item B<indir "SUBDIR" =E<gt> sub BLOCK, OPTS>
 154
 155 C<indir> is used to run a part of the recipe in a different directory than
 156 the one C<setup> moved into, usually a subdirectory, given by SUBDIR.
 157 The part of the recipe that's run there is given by the codeblock BLOCK.
 158
 159 C<indir> takes some additional options OPTS that affect the subdirectory:
 160
 161 =over 4
 162
 163 =item B<create =E<gt> 0|1>
 164
 165 When set to 1 (or any value that perl preceives as true), the subdirectory
 166 will be created if it doesn't already exist.  This happens before BLOCK
 167 is executed.
 168
 169 =item B<cleanup =E<gt> 0|1>
 170
 171 When set to 1 (or any value that perl preceives as true), the subdirectory
 172 will be cleaned out and removed.  This happens both before and after BLOCK
 173 is executed.
 174
 175 =back
 176
 177 An example:
 178
 179   indir "foo" => sub {
 180       ok(run(app(["openssl", "version"]), stdout => "foo.txt"));
 181       if (ok(open(RESULT, "foo.txt"), "reading foo.txt")) {
 182           my $line = <RESULT>;
 183           close RESULT;
 184           is($line, qr/^OpenSSL 1\./,
 185              "check that we're using OpenSSL 1.x.x");
 186       }
 187   }, create => 1, cleanup => 1;
 188
 189 =back
 190
 191 =cut
 192
 193 sub indir {
 194     my $subdir = shift;
 195     my $codeblock = shift;
 196     my %opts = @_;
 197
 198     my $reverse = __cwd($subdir,%opts);
 199     BAIL_OUT("FAILURE: indir, \"$subdir\" wasn't possible to move into")
 200         unless $reverse;
 201
 202     $codeblock->();
 203
 204     __cwd($reverse);
 205
 206     if ($opts{cleanup}) {
 207         rmtree($subdir, { safe => 0 });
 208     }
 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<statusvar =E<gt> VARREF>
 407
 408 If used, B<VARREF> must be a reference to a scalar variable.  It will be
 409 assigned a boolean indicating if the command succeeded or not.  This is
 410 particularly useful together with B<capture>.
 411
 412 =back
 413
 414 For further discussion on what is considered a successful command or not, see
 415 the function C<with> further down.
 416
 417 =back
 418
 419 =cut
 420
 421 sub run {
 422     my ($cmd, $display_cmd) = shift->(0);
 423     my %opts = @_;
 424
 425     return () if !$cmd;
 426
 427     my $prefix = "";
 428     if ( $^O eq "VMS" ) {       # VMS
 429         $prefix = "pipe ";
 430     }
 431
 432     my @r = ();
 433     my $r = 0;
 434     my $e = 0;
 435
 436     die "OpenSSL::Test::run(): statusvar value not a scalar reference"
 437         if $opts{statusvar} && ref($opts{statusvar}) ne "SCALAR";
 438
 439     # In non-verbose, we want to shut up the command interpreter, in case
 440     # it has something to complain about.  On VMS, it might complain both
 441     # on stdout and stderr
 442     my $save_STDOUT;
 443     my $save_STDERR;
 444     if ($ENV{HARNESS_ACTIVE} && !$ENV{HARNESS_VERBOSE}) {
 445         open $save_STDOUT, '>&', \*STDOUT or die "Can't dup STDOUT: $!";
 446         open $save_STDERR, '>&', \*STDERR or die "Can't dup STDERR: $!";
 447         open STDOUT, ">", devnull();
 448         open STDERR, ">", devnull();
 449     }
 450
 451     # The dance we do with $? is the same dance the Unix shells appear to
 452     # do.  For example, a program that gets aborted (and therefore signals
 453     # SIGABRT = 6) will appear to exit with the code 134.  We mimic this
 454     # to make it easier to compare with a manual run of the command.
 455     if ($opts{capture}) {
 456         @r = `$prefix$cmd`;
 457     } else {
 458         system("$prefix$cmd");
 459     }
 460     $e = ($? & 0x7f) ? ($? & 0x7f)|0x80 : ($? >> 8);
 461     $r = $hooks{exit_checker}->($e);
 462     if ($opts{statusvar}) {
 463         ${$opts{statusvar}} = $r;
 464     }
 465
 466     if ($ENV{HARNESS_ACTIVE} && !$ENV{HARNESS_VERBOSE}) {
 467         close STDOUT;
 468         close STDERR;
 469         open STDOUT, '>&', $save_STDOUT or die "Can't restore STDOUT: $!";
 470         open STDERR, '>&', $save_STDERR or die "Can't restore STDERR: $!";
 471     }
 472
 473     print STDERR "$prefix$display_cmd => $e\n"
 474         if !$ENV{HARNESS_ACTIVE} || $ENV{HARNESS_VERBOSE};
 475
 476     # At this point, $? stops being interesting, and unfortunately,
 477     # there are Test::More versions that get picky if we leave it
 478     # non-zero.
 479     $? = 0;
 480
 481     if ($opts{capture}) {
 482         return @r;
 483     } else {
 484         return $r;
 485     }
 486 }
 487
 488 END {
 489     my $tb = Test::More->builder;
 490     my $failure = scalar(grep { $_ == 0; } $tb->summary);
 491     if ($failure && $end_with_bailout) {
 492         BAIL_OUT("Stoptest!");
 493     }
 494 }
 495
 496 =head2 Utility functions
 497
 498 The following functions are exported on request when using C<OpenSSL::Test>.
 499
 500   # To only get the bldtop_file and srctop_file functions.
 501   use OpenSSL::Test qw/bldtop_file srctop_file/;
 502
 503   # To only get the bldtop_file function in addition to the default ones.
 504   use OpenSSL::Test qw/:DEFAULT bldtop_file/;
 505
 506 =cut
 507
 508 # Utility functions, exported on request
 509
 510 =over 4
 511
 512 =item B<bldtop_dir LIST>
 513
 514 LIST is a list of directories that make up a path from the top of the OpenSSL
 515 build directory (as indicated by the environment variable C<$TOP> or
 516 C<$BLDTOP>).
 517 C<bldtop_dir> returns the resulting directory as a string, adapted to the local
 518 operating system.
 519
 520 =back
 521
 522 =cut
 523
 524 sub bldtop_dir {
 525     return __bldtop_dir(@_);    # This caters for operating systems that have
 526                                 # a very distinct syntax for directories.
 527 }
 528
 529 =over 4
 530
 531 =item B<bldtop_file LIST, FILENAME>
 532
 533 LIST is a list of directories that make up a path from the top of the OpenSSL
 534 build directory (as indicated by the environment variable C<$TOP> or
 535 C<$BLDTOP>) and FILENAME is the name of a file located in that directory path.
 536 C<bldtop_file> returns the resulting file path as a string, adapted to the local
 537 operating system.
 538
 539 =back
 540
 541 =cut
 542
 543 sub bldtop_file {
 544     return __bldtop_file(@_);
 545 }
 546
 547 =over 4
 548
 549 =item B<srctop_dir LIST>
 550
 551 LIST is a list of directories that make up a path from the top of the OpenSSL
 552 source directory (as indicated by the environment variable C<$TOP> or
 553 C<$SRCTOP>).
 554 C<srctop_dir> returns the resulting directory as a string, adapted to the local
 555 operating system.
 556
 557 =back
 558
 559 =cut
 560
 561 sub srctop_dir {
 562     return __srctop_dir(@_);    # This caters for operating systems that have
 563                                 # a very distinct syntax for directories.
 564 }
 565
 566 =over 4
 567
 568 =item B<srctop_file LIST, FILENAME>
 569
 570 LIST is a list of directories that make up a path from the top of the OpenSSL
 571 source directory (as indicated by the environment variable C<$TOP> or
 572 C<$SRCTOP>) and FILENAME is the name of a file located in that directory path.
 573 C<srctop_file> returns the resulting file path as a string, adapted to the local
 574 operating system.
 575
 576 =back
 577
 578 =cut
 579
 580 sub srctop_file {
 581     return __srctop_file(@_);
 582 }
 583
 584 =over 4
 585
 586 =item B<data_file LIST, FILENAME>
 587
 588 LIST is a list of directories that make up a path from the data directory
 589 associated with the test (see L</DESCRIPTION> above) and FILENAME is the name
 590 of a file located in that directory path.  C<data_file> returns the resulting
 591 file path as a string, adapted to the local operating system.
 592
 593 =back
 594
 595 =cut
 596
 597 sub data_file {
 598     return __data_file(@_);
 599 }
 600
 601 =over 4
 602
 603 =item B<pipe LIST>
 604
 605 LIST is a list of CODEREFs returned by C<app> or C<test>, from which C<pipe>
 606 creates a new command composed of all the given commands put together in a
 607 pipe.  C<pipe> returns a new CODEREF in the same manner as C<app> or C<test>,
 608 to be passed to C<run> for execution.
 609
 610 =back
 611
 612 =cut
 613
 614 sub pipe {
 615     my @cmds = @_;
 616     return
 617         sub {
 618             my @cs  = ();
 619             my @dcs = ();
 620             my @els = ();
 621             my $counter = 0;
 622             foreach (@cmds) {
 623                 my ($c, $dc, @el) = $_->(++$counter);
 624
 625                 return () if !$c;
 626
 627                 push @cs, $c;
 628                 push @dcs, $dc;
 629                 push @els, @el;
 630             }
 631             return (
 632                 join(" | ", @cs),
 633                 join(" | ", @dcs),
 634                 @els
 635                 );
 636     };
 637 }
 638
 639 =over 4
 640
 641 =item B<with HASHREF, CODEREF>
 642
 643 C<with> will temporarly install hooks given by the HASHREF and then execute
 644 the given CODEREF.  Hooks are usually expected to have a coderef as value.
 645
 646 The currently available hoosk are:
 647
 648 =over 4
 649
 650 =item B<exit_checker =E<gt> CODEREF>
 651
 652 This hook is executed after C<run> has performed its given command.  The
 653 CODEREF receives the exit code as only argument and is expected to return
 654 1 (if the exit code indicated success) or 0 (if the exit code indicated
 655 failure).
 656
 657 =back
 658
 659 =back
 660
 661 =cut
 662
 663 sub with {
 664     my $opts = shift;
 665     my %opts = %{$opts};
 666     my $codeblock = shift;
 667
 668     my %saved_hooks = ();
 669
 670     foreach (keys %opts) {
 671         $saved_hooks{$_} = $hooks{$_}   if exists($hooks{$_});
 672         $hooks{$_} = $opts{$_};
 673     }
 674
 675     $codeblock->();
 676
 677     foreach (keys %saved_hooks) {
 678         $hooks{$_} = $saved_hooks{$_};
 679     }
 680 }
 681
 682 =over 4
 683
 684 =item B<cmdstr CODEREF, OPTS>
 685
 686 C<cmdstr> takes a CODEREF from C<app> or C<test> and simply returns the
 687 command as a string.
 688
 689 C<cmdstr> takes some additiona options OPTS that affect the string returned:
 690
 691 =over 4
 692
 693 =item B<display =E<gt> 0|1>
 694
 695 When set to 0, the returned string will be with all decorations, such as a
 696 possible redirect of stderr to the null device.  This is suitable if the
 697 string is to be used directly in a recipe.
 698
 699 When set to 1, the returned string will be without extra decorations.  This
 700 is suitable for display if that is desired (doesn't confuse people with all
 701 internal stuff), or if it's used to pass a command down to a subprocess.
 702
 703 Default: 0
 704
 705 =back
 706
 707 =back
 708
 709 =cut
 710
 711 sub cmdstr {
 712     my ($cmd, $display_cmd) = shift->(0);
 713     my %opts = @_;
 714
 715     if ($opts{display}) {
 716         return $display_cmd;
 717     } else {
 718         return $cmd;
 719     }
 720 }
 721
 722 =over 4
 723
 724 =item B<quotify LIST>
 725
 726 LIST is a list of strings that are going to be used as arguments for a
 727 command, and makes sure to inject quotes and escapes as necessary depending
 728 on the content of each string.
 729
 730 This can also be used to put quotes around the executable of a command.
 731 I<This must never ever be done on VMS.>
 732
 733 =back
 734
 735 =cut
 736
 737 sub quotify {
 738     # Unix setup (default if nothing else is mentioned)
 739     my $arg_formatter =
 740         sub { $_ = shift; /\s|[\{\}\\\$\[\]\*\?\|\&:;<>]/ ? "'$_'" : $_ };
 741
 742     if ( $^O eq "VMS") {        # VMS setup
 743         $arg_formatter = sub {
 744             $_ = shift;
 745             if (/\s|["[:upper:]]/) {
 746                 s/"/""/g;
 747                 '"'.$_.'"';
 748             } else {
 749                 $_;
 750             }
 751         };
 752     } elsif ( $^O eq "MSWin32") { # MSWin setup
 753         $arg_formatter = sub {
 754             $_ = shift;
 755             if (/\s|["\|\&\*\;<>]/) {
 756                 s/(["\\])/\\$1/g;
 757                 '"'.$_.'"';
 758             } else {
 759                 $_;
 760             }
 761         };
 762     }
 763
 764     return map { $arg_formatter->($_) } @_;
 765 }
 766
 767 ######################################################################
 768 # private functions.  These are never exported.
 769
 770 =head1 ENVIRONMENT
 771
 772 OpenSSL::Test depends on some environment variables.
 773
 774 =over 4
 775
 776 =item B<TOP>
 777
 778 This environment variable is mandatory.  C<setup> will check that it's
 779 defined and that it's a directory that contains the file C<Configure>.
 780 If this isn't so, C<setup> will C<BAIL_OUT>.
 781
 782 =item B<BIN_D>
 783
 784 If defined, its value should be the directory where the openssl application
 785 is located.  Defaults to C<$TOP/apps> (adapted to the operating system).
 786
 787 =item B<TEST_D>
 788
 789 If defined, its value should be the directory where the test applications
 790 are located.  Defaults to C<$TOP/test> (adapted to the operating system).
 791
 792 =item B<STOPTEST>
 793
 794 If defined, it puts testing in a different mode, where a recipe with
 795 failures will result in a C<BAIL_OUT> at the end of its run.
 796
 797 =back
 798
 799 =cut
 800
 801 sub __env {
 802     (my $recipe_datadir = basename($0)) =~ s/\.t$/_data/i;
 803
 804     $directories{SRCTOP}  = $ENV{SRCTOP} || $ENV{TOP};
 805     $directories{BLDTOP}  = $ENV{BLDTOP} || $ENV{TOP};
 806     $directories{BLDAPPS} = $ENV{BIN_D}  || __bldtop_dir("apps");
 807     $directories{SRCAPPS} =                 __srctop_dir("apps");
 808     $directories{BLDFUZZ} =                 __bldtop_dir("fuzz");
 809     $directories{SRCFUZZ} =                 __srctop_dir("fuzz");
 810     $directories{BLDTEST} = $ENV{TEST_D} || __bldtop_dir("test");
 811     $directories{SRCTEST} =                 __srctop_dir("test");
 812     $directories{SRCDATA} =                 __srctop_dir("test", "recipes",
 813                                                          $recipe_datadir);
 814     $directories{RESULTS} = $ENV{RESULT_D} || $directories{BLDTEST};
 815
 816     push @direnv, "TOP"       if $ENV{TOP};
 817     push @direnv, "SRCTOP"    if $ENV{SRCTOP};
 818     push @direnv, "BLDTOP"    if $ENV{BLDTOP};
 819     push @direnv, "BIN_D"     if $ENV{BIN_D};
 820     push @direnv, "TEST_D"    if $ENV{TEST_D};
 821     push @direnv, "RESULT_D"  if $ENV{RESULT_D};
 822
 823     $end_with_bailout     = $ENV{STOPTEST} ? 1 : 0;
 824 };
 825
 826 # __srctop_file and __srctop_dir are helpers to build file and directory
 827 # names on top of the source directory.  They depend on $SRCTOP, and
 828 # therefore on the proper use of setup() and when needed, indir().
 829 # __bldtop_file and __bldtop_dir do the same thing but relative to $BLDTOP.
 830 # __srctop_file and __bldtop_file take the same kind of argument as
 831 # File::Spec::Functions::catfile.
 832 # Similarly, __srctop_dir and __bldtop_dir take the same kind of argument
 833 # as File::Spec::Functions::catdir
 834 sub __srctop_file {
 835     BAIL_OUT("Must run setup() first") if (! $test_name);
 836
 837     my $f = pop;
 838     return catfile($directories{SRCTOP},@_,$f);
 839 }
 840
 841 sub __srctop_dir {
 842     BAIL_OUT("Must run setup() first") if (! $test_name);
 843
 844     return catdir($directories{SRCTOP},@_);
 845 }
 846
 847 sub __bldtop_file {
 848     BAIL_OUT("Must run setup() first") if (! $test_name);
 849
 850     my $f = pop;
 851     return catfile($directories{BLDTOP},@_,$f);
 852 }
 853
 854 sub __bldtop_dir {
 855     BAIL_OUT("Must run setup() first") if (! $test_name);
 856
 857     return catdir($directories{BLDTOP},@_);
 858 }
 859
 860 # __exeext is a function that returns the platform dependent file extension
 861 # for executable binaries, or the value of the environment variable $EXE_EXT
 862 # if that one is defined.
 863 sub __exeext {
 864     my $ext = "";
 865     if ($^O eq "VMS" ) {        # VMS
 866         $ext = ".exe";
 867     } elsif ($^O eq "MSWin32") { # Windows
 868         $ext = ".exe";
 869     }
 870     return $ENV{"EXE_EXT"} || $ext;
 871 }
 872
 873 # __test_file, __apps_file and __fuzz_file return the full path to a file
 874 # relative to the test/, apps/ or fuzz/ directory in the build tree or the
 875 # source tree, depending on where the file is found.  Note that when looking
 876 # in the build tree, the file name with an added extension is looked for, if
 877 # an extension is given.  The intent is to look for executable binaries (in
 878 # the build tree) or possibly scripts (in the source tree).
 879 # These functions all take the same arguments as File::Spec::Functions::catfile,
 880 # *plus* a mandatory extension argument.  This extension argument can be undef,
 881 # and is ignored in such a case.
 882 sub __test_file {
 883     BAIL_OUT("Must run setup() first") if (! $test_name);
 884
 885     my $e = pop || "";
 886     my $f = pop;
 887     $f = catfile($directories{BLDTEST},@_,$f . $e);
 888     $f = catfile($directories{SRCTEST},@_,$f) unless -f $f;
 889     return $f;
 890 }
 891
 892 sub __apps_file {
 893     BAIL_OUT("Must run setup() first") if (! $test_name);
 894
 895     my $e = pop || "";
 896     my $f = pop;
 897     $f = catfile($directories{BLDAPPS},@_,$f . $e);
 898     $f = catfile($directories{SRCAPPS},@_,$f) unless -f $f;
 899     return $f;
 900 }
 901
 902 sub __fuzz_file {
 903     BAIL_OUT("Must run setup() first") if (! $test_name);
 904
 905     my $e = pop || "";
 906     my $f = pop;
 907     $f = catfile($directories{BLDFUZZ},@_,$f . $e);
 908     $f = catfile($directories{SRCFUZZ},@_,$f) unless -f $f;
 909     return $f;
 910 }
 911
 912 sub __data_file {
 913     BAIL_OUT("Must run setup() first") if (! $test_name);
 914
 915     my $f = pop;
 916     return catfile($directories{SRCDATA},@_,$f);
 917 }
 918
 919 sub __results_file {
 920     BAIL_OUT("Must run setup() first") if (! $test_name);
 921
 922     my $f = pop;
 923     return catfile($directories{RESULTS},@_,$f);
 924 }
 925
 926 # __cwd DIR
 927 # __cwd DIR, OPTS
 928 #
 929 # __cwd changes directory to DIR (string) and changes all the relative
 930 # entries in %directories accordingly.  OPTS is an optional series of
 931 # hash style arguments to alter __cwd's behavior:
 932 #
 933 #    create = 0|1       The directory we move to is created if 1, not if 0.
 934 #    cleanup = 0|1      The directory we move from is removed if 1, not if 0.
 935
 936 sub __cwd {
 937     my $dir = catdir(shift);
 938     my %opts = @_;
 939     my $abscurdir = rel2abs(curdir());
 940     my $absdir = rel2abs($dir);
 941     my $reverse = abs2rel($abscurdir, $absdir);
 942
 943     # PARANOIA: if we're not moving anywhere, we do nothing more
 944     if ($abscurdir eq $absdir) {
 945         return $reverse;
 946     }
 947
 948     # Do not support a move to a different volume for now.  Maybe later.
 949     BAIL_OUT("FAILURE: \"$dir\" moves to a different volume, not supported")
 950         if $reverse eq $abscurdir;
 951
 952     # If someone happened to give a directory that leads back to the current,
 953     # it's extremely silly to do anything more, so just simulate that we did
 954     # move.
 955     # In this case, we won't even clean it out, for safety's sake.
 956     return "." if $reverse eq "";
 957
 958     $dir = canonpath($dir);
 959     if ($opts{create}) {
 960         mkpath($dir);
 961     }
 962
 963     # We are recalculating the directories we keep track of, but need to save
 964     # away the result for after having moved into the new directory.
 965     my %tmp_directories = ();
 966     my %tmp_ENV = ();
 967
 968     # For each of these directory variables, figure out where they are relative
 969     # to the directory we want to move to if they aren't absolute (if they are,
 970     # they don't change!)
 971     my @dirtags = sort keys %directories;
 972     foreach (@dirtags) {
 973         if (!file_name_is_absolute($directories{$_})) {
 974             my $newpath = abs2rel(rel2abs($directories{$_}), rel2abs($dir));
 975             $tmp_directories{$_} = $newpath;
 976         }
 977     }
 978
 979     # Treat each environment variable that was used to get us the values in
 980     # %directories the same was as the paths in %directories, so any sub
 981     # process can use their values properly as well
 982     foreach (@direnv) {
 983         if (!file_name_is_absolute($ENV{$_})) {
 984             my $newpath = abs2rel(rel2abs($ENV{$_}), rel2abs($dir));
 985             $tmp_ENV{$_} = $newpath;
 986         }
 987     }
 988
 989     # Should we just bail out here as well?  I'm unsure.
 990     return undef unless chdir($dir);
 991
 992     if ($opts{cleanup}) {
 993         rmtree(".", { safe => 0, keep_root => 1 });
 994     }
 995
 996     # We put back new values carefully.  Doing the obvious
 997     # %directories = ( %tmp_irectories )
 998     # will clear out any value that happens to be an absolute path
 999     foreach (keys %tmp_directories) {
1000         $directories{$_} = $tmp_directories{$_};
1001     }
1002     foreach (keys %tmp_ENV) {
1003         $ENV{$_} = $tmp_ENV{$_};
1004     }
1005
1006     if ($debug) {
1007         print STDERR "DEBUG: __cwd(), directories and files:\n";
1008         print STDERR "  \$directories{BLDTEST} = \"$directories{BLDTEST}\"\n";
1009         print STDERR "  \$directories{SRCTEST} = \"$directories{SRCTEST}\"\n";
1010         print STDERR "  \$directories{SRCDATA} = \"$directories{SRCDATA}\"\n";
1011         print STDERR "  \$directories{RESULTS} = \"$directories{RESULTS}\"\n";
1012         print STDERR "  \$directories{BLDAPPS} = \"$directories{BLDAPPS}\"\n";
1013         print STDERR "  \$directories{SRCAPPS} = \"$directories{SRCAPPS}\"\n";
1014         print STDERR "  \$directories{SRCTOP}  = \"$directories{SRCTOP}\"\n";
1015         print STDERR "  \$directories{BLDTOP}  = \"$directories{BLDTOP}\"\n";
1016         print STDERR "\n";
1017         print STDERR "  current directory is \"",curdir(),"\"\n";
1018         print STDERR "  the way back is \"$reverse\"\n";
1019     }
1020
1021     return $reverse;
1022 }
1023
1024 # __wrap_cmd CMD
1025 # __wrap_cmd CMD, EXE_SHELL
1026 #
1027 # __wrap_cmd "wraps" CMD (string) with a beginning command that makes sure
1028 # the command gets executed with an appropriate environment.  If EXE_SHELL
1029 # is given, it is used as the beginning command.
1030 #
1031 # __wrap_cmd returns a list that should be used to build up a larger list
1032 # of command tokens, or be joined together like this:
1033 #
1034 #    join(" ", __wrap_cmd($cmd))
1035 sub __wrap_cmd {
1036     my $cmd = shift;
1037     my $exe_shell = shift;
1038
1039     my @prefix = ( __bldtop_file("util", "shlib_wrap.sh") );
1040
1041     if(defined($exe_shell)) {
1042         @prefix = ( $exe_shell );
1043     } elsif ($^O eq "VMS" || $^O eq "MSWin32") {
1044         # VMS and Windows don't use any wrapper script for the moment
1045         @prefix = ();
1046     }
1047
1048     return (@prefix, $cmd);
1049 }
1050
1051 # __fixup_prg PROG
1052 #
1053 # __fixup_prg does whatever fixup is needed to execute an executable binary
1054 # given by PROG (string).
1055 #
1056 # __fixup_prg returns a string with the possibly prefixed program path spec.
1057 sub __fixup_prg {
1058     my $prog = shift;
1059
1060     my $prefix = "";
1061
1062     if ($^O eq "VMS" ) {
1063         $prefix = ($prog =~ /^(?:[\$a-z0-9_]+:)?[<\[]/i ? "mcr " : "mcr []");
1064     }
1065
1066     # We test if the program to use exists.
1067     if ( ! -x $prog ) {
1068         $prog = undef;
1069     }
1070
1071     if (defined($prog)) {
1072         # Make sure to quotify the program file on platforms that may
1073         # have spaces or similar in their path name.
1074         # To our knowledge, VMS is the exception where quotifying should
1075         # never happem.
1076         ($prog) = quotify($prog) unless $^O eq "VMS";
1077         return $prefix.$prog;
1078     }
1079
1080     print STDERR "$prog not found\n";
1081     return undef;
1082 }
1083
1084 # __decorate_cmd NUM, CMDARRAYREF
1085 #
1086 # __decorate_cmd takes a command number NUM and a command token array
1087 # CMDARRAYREF, builds up a command string from them and decorates it
1088 # with necessary redirections.
1089 # __decorate_cmd returns a list of two strings, one with the command
1090 # string to actually be used, the other to be displayed for the user.
1091 # The reason these strings might differ is that we redirect stderr to
1092 # the null device unless we're verbose and unless the user has
1093 # explicitly specified a stderr redirection.
1094 sub __decorate_cmd {
1095     BAIL_OUT("Must run setup() first") if (! $test_name);
1096
1097     my $num = shift;
1098     my $cmd = shift;
1099     my %opts = @_;
1100
1101     my $cmdstr = join(" ", @$cmd);
1102     my $null = devnull();
1103     my $fileornull = sub { $_[0] ? $_[0] : $null; };
1104     my $stdin = "";
1105     my $stdout = "";
1106     my $stderr = "";
1107     my $saved_stderr = undef;
1108     $stdin = " < ".$fileornull->($opts{stdin})  if exists($opts{stdin});
1109     $stdout= " > ".$fileornull->($opts{stdout}) if exists($opts{stdout});
1110     $stderr=" 2> ".$fileornull->($opts{stderr}) if exists($opts{stderr});
1111
1112     my $display_cmd = "$cmdstr$stdin$stdout$stderr";
1113
1114     $stderr=" 2> ".$null
1115         unless $stderr || !$ENV{HARNESS_ACTIVE} || $ENV{HARNESS_VERBOSE};
1116
1117     $cmdstr .= "$stdin$stdout$stderr";
1118
1119     if ($debug) {
1120         print STDERR "DEBUG[__decorate_cmd]: \$cmdstr = \"$cmdstr\"\n";
1121         print STDERR "DEBUG[__decorate_cmd]: \$display_cmd = \"$display_cmd\"\n";
1122     }
1123
1124     return ($cmdstr, $display_cmd);
1125 }
1126
1127 =head1 SEE ALSO
1128
1129 L<Test::More>, L<Test::Harness>
1130
1131 =head1 AUTHORS
1132
1133 Richard Levitte E<lt>levitte@openssl.orgE<gt> with assitance and
1134 inspiration from Andy Polyakov E<lt>appro@openssl.org<gt>.
1135
1136 =cut
1137
1138 1;