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