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).  Where necessary, the command will be wrapped in a
 227 suitable environment to make sure the correct shared libraries are
 228 used (currently only on Unix).
 229
 230 It returns a CODEREF to be used by C<run>, C<pipe> or C<cmdstr>.
 231
 232 The options that C<cmd> can take are in the form of hash values:
 233
 234 =over 4
 235
 236 =item B<stdin =E<gt> PATH>
 237
 238 =item B<stdout =E<gt> PATH>
 239
 240 =item B<stderr =E<gt> PATH>
 241
 242 In all three cases, the corresponding standard input, output or error is
 243 redirected from (for stdin) or to (for the others) a file given by the
 244 string PATH, I<or>, if the value is C<undef>, C</dev/null> or similar.
 245
 246 =back
 247
 248 =item B<app ARRAYREF, OPTS>
 249
 250 =item B<test ARRAYREF, OPTS>
 251
 252 Both of these are specific applications of C<cmd>, with just a couple
 253 of small difference:
 254
 255 C<app> expects to find the given command (the first item in the given list
 256 reference) as an executable in C<$BIN_D> (if defined, otherwise C<$TOP/apps>
 257 or C<$BLDTOP/apps>).
 258
 259 C<test> expects to find the given command (the first item in the given list
 260 reference) as an executable in C<$TEST_D> (if defined, otherwise C<$TOP/test>
 261 or C<$BLDTOP/test>).
 262
 263 Also, for both C<app> and C<test>, the command may be prefixed with
 264 the content of the environment variable C<$EXE_SHELL>, which is useful
 265 in case OpenSSL has been cross compiled.
 266
 267 =item B<perlapp ARRAYREF, OPTS>
 268
 269 =item B<perltest ARRAYREF, OPTS>
 270
 271 These are also specific applications of C<cmd>, where the interpreter
 272 is predefined to be C<perl>, and they expect the script to be
 273 interpreted to reside in the same location as C<app> and C<test>.
 274
 275 C<perlapp> and C<perltest> will also take the following option:
 276
 277 =over 4
 278
 279 =item B<interpreter_args =E<gt> ARRAYref>
 280
 281 The array reference is a set of arguments for the interpreter rather
 282 than the script.  Take care so that none of them can be seen as a
 283 script!  Flags and their eventual arguments only!
 284
 285 =back
 286
 287 An example:
 288
 289   ok(run(perlapp(["foo.pl", "arg1"],
 290                  interpreter_args => [ "-I", srctop_dir("test") ])));
 291
 292 =back
 293
 294 =begin comment
 295
 296 One might wonder over the complexity of C<apps>, C<fuzz>, C<test>, ...
 297 with all the lazy evaluations and all that.  The reason for this is that
 298 we want to make sure the directory in which those programs are found are
 299 correct at the time these commands are used.  Consider the following code
 300 snippet:
 301
 302   my $cmd = app(["openssl", ...]);
 303
 304   indir "foo", sub {
 305       ok(run($cmd), "Testing foo")
 306   };
 307
 308 If there wasn't this lazy evaluation, the directory where C<openssl> is
 309 found would be incorrect at the time C<run> is called, because it was
 310 calculated before we moved into the directory "foo".
 311
 312 =end comment
 313
 314 =cut
 315
 316 sub cmd {
 317     my $cmd = shift;
 318     my %opts = @_;
 319     return sub {
 320         my $num = shift;
 321         # Make a copy to not destroy the caller's array
 322         my @cmdargs = ( @$cmd );
 323         my @prog = __wrap_cmd(shift @cmdargs, $opts{exe_shell} // ());
 324
 325         return __decorate_cmd($num, [ @prog, quotify(@cmdargs) ],
 326                               %opts);
 327     }
 328 }
 329
 330 sub app {
 331     my $cmd = shift;
 332     my %opts = @_;
 333     return sub {
 334         my @cmdargs = ( @{$cmd} );
 335         my @prog = __fixup_prg(__apps_file(shift @cmdargs, __exeext()));
 336         return cmd([ @prog, @cmdargs ],
 337                    exe_shell => $ENV{EXE_SHELL}, %opts) -> (shift);
 338     }
 339 }
 340
 341 sub fuzz {
 342     my $cmd = shift;
 343     my %opts = @_;
 344     return sub {
 345         my @cmdargs = ( @{$cmd} );
 346         my @prog = __fixup_prg(__fuzz_file(shift @cmdargs, __exeext()));
 347         return cmd([ @prog, @cmdargs ],
 348                    exe_shell => $ENV{EXE_SHELL}, %opts) -> (shift);
 349     }
 350 }
 351
 352 sub test {
 353     my $cmd = shift;
 354     my %opts = @_;
 355     return sub {
 356         my @cmdargs = ( @{$cmd} );
 357         my @prog = __fixup_prg(__test_file(shift @cmdargs, __exeext()));
 358         return cmd([ @prog, @cmdargs ],
 359                    exe_shell => $ENV{EXE_SHELL}, %opts) -> (shift);
 360     }
 361 }
 362
 363 sub perlapp {
 364     my $cmd = shift;
 365     my %opts = @_;
 366     return sub {
 367         my @interpreter_args = defined $opts{interpreter_args} ?
 368             @{$opts{interpreter_args}} : ();
 369         my @interpreter = __fixup_prg($^X);
 370         my @cmdargs = ( @{$cmd} );
 371         my @prog = __apps_file(shift @cmdargs, undef);
 372         return cmd([ @interpreter, @interpreter_args,
 373                      @prog, @cmdargs ], %opts) -> (shift);
 374     }
 375 }
 376
 377 sub perltest {
 378     my $cmd = shift;
 379     my %opts = @_;
 380     return sub {
 381         my @interpreter_args = defined $opts{interpreter_args} ?
 382             @{$opts{interpreter_args}} : ();
 383         my @interpreter = __fixup_prg($^X);
 384         my @cmdargs = ( @{$cmd} );
 385         my @prog = __test_file(shift @cmdargs, undef);
 386         return cmd([ @interpreter, @interpreter_args,
 387                      @prog, @cmdargs ], %opts) -> (shift);
 388     }
 389 }
 390
 391 =over 4
 392
 393 =item B<run CODEREF, OPTS>
 394
 395 CODEREF is expected to be the value return by C<cmd> or any of its
 396 derivatives, anything else will most likely cause an error unless you
 397 know what you're doing.
 398
 399 C<run> executes the command returned by CODEREF and return either the
 400 resulting output (if the option C<capture> is set true) or a boolean
 401 indicating if the command succeeded or not.
 402
 403 The options that C<run> can take are in the form of hash values:
 404
 405 =over 4
 406
 407 =item B<capture =E<gt> 0|1>
 408
 409 If true, the command will be executed with a perl backtick, and C<run> will
 410 return the resulting output as an array of lines.  If false or not given,
 411 the command will be executed with C<system()>, and C<run> will return 1 if
 412 the command was successful or 0 if it wasn't.
 413
 414 =back
 415
 416 For further discussion on what is considered a successful command or not, see
 417 the function C<with> further down.
 418
 419 =back
 420
 421 =cut
 422
 423 sub run {
 424     my ($cmd, $display_cmd) = shift->(0);
 425     my %opts = @_;
 426
 427     return () if !$cmd;
 428
 429     my $prefix = "";
 430     if ( $^O eq "VMS" ) {       # VMS
 431         $prefix = "pipe ";
 432     }
 433
 434     my @r = ();
 435     my $r = 0;
 436     my $e = 0;
 437
 438     # In non-verbose, we want to shut up the command interpreter, in case
 439     # it has something to complain about.  On VMS, it might complain both
 440     # on stdout and stderr
 441     my $save_STDOUT;
 442     my $save_STDERR;
 443     if ($ENV{HARNESS_ACTIVE} && !$ENV{HARNESS_VERBOSE}) {
 444         open $save_STDOUT, '>&', \*STDOUT or die "Can't dup STDOUT: $!";
 445         open $save_STDERR, '>&', \*STDERR or die "Can't dup STDERR: $!";
 446         open STDOUT, ">", devnull();
 447         open STDERR, ">", devnull();
 448     }
 449
 450     # The dance we do with $? is the same dance the Unix shells appear to
 451     # do.  For example, a program that gets aborted (and therefore signals
 452     # SIGABRT = 6) will appear to exit with the code 134.  We mimic this
 453     # to make it easier to compare with a manual run of the command.
 454     if ($opts{capture}) {
 455         @r = `$prefix$cmd`;
 456         $e = ($? & 0x7f) ? ($? & 0x7f)|0x80 : ($? >> 8);
 457     } else {
 458         system("$prefix$cmd");
 459         $e = ($? & 0x7f) ? ($? & 0x7f)|0x80 : ($? >> 8);
 460         $r = $hooks{exit_checker}->($e);
 461     }
 462
 463     if ($ENV{HARNESS_ACTIVE} && !$ENV{HARNESS_VERBOSE}) {
 464         close STDOUT;
 465         close STDERR;
 466         open STDOUT, '>&', $save_STDOUT or die "Can't restore STDOUT: $!";
 467         open STDERR, '>&', $save_STDERR or die "Can't restore STDERR: $!";
 468     }
 469
 470     print STDERR "$prefix$display_cmd => $e\n"
 471         if !$ENV{HARNESS_ACTIVE} || $ENV{HARNESS_VERBOSE};
 472
 473     # At this point, $? stops being interesting, and unfortunately,
 474     # there are Test::More versions that get picky if we leave it
 475     # non-zero.
 476     $? = 0;
 477
 478     if ($opts{capture}) {
 479         return @r;
 480     } else {
 481         return $r;
 482     }
 483 }
 484
 485 END {
 486     my $tb = Test::More->builder;
 487     my $failure = scalar(grep { $_ == 0; } $tb->summary);
 488     if ($failure && $end_with_bailout) {
 489         BAIL_OUT("Stoptest!");
 490     }
 491 }
 492
 493 =head2 Utility functions
 494
 495 The following functions are exported on request when using C<OpenSSL::Test>.
 496
 497   # To only get the bldtop_file and srctop_file functions.
 498   use OpenSSL::Test qw/bldtop_file srctop_file/;
 499
 500   # To only get the bldtop_file function in addition to the default ones.
 501   use OpenSSL::Test qw/:DEFAULT bldtop_file/;
 502
 503 =cut
 504
 505 # Utility functions, exported on request
 506
 507 =over 4
 508
 509 =item B<bldtop_dir LIST>
 510
 511 LIST is a list of directories that make up a path from the top of the OpenSSL
 512 build directory (as indicated by the environment variable C<$TOP> or
 513 C<$BLDTOP>).
 514 C<bldtop_dir> returns the resulting directory as a string, adapted to the local
 515 operating system.
 516
 517 =back
 518
 519 =cut
 520
 521 sub bldtop_dir {
 522     return __bldtop_dir(@_);    # This caters for operating systems that have
 523                                 # a very distinct syntax for directories.
 524 }
 525
 526 =over 4
 527
 528 =item B<bldtop_file LIST, FILENAME>
 529
 530 LIST is a list of directories that make up a path from the top of the OpenSSL
 531 build directory (as indicated by the environment variable C<$TOP> or
 532 C<$BLDTOP>) and FILENAME is the name of a file located in that directory path.
 533 C<bldtop_file> returns the resulting file path as a string, adapted to the local
 534 operating system.
 535
 536 =back
 537
 538 =cut
 539
 540 sub bldtop_file {
 541     return __bldtop_file(@_);
 542 }
 543
 544 =over 4
 545
 546 =item B<srctop_dir LIST>
 547
 548 LIST is a list of directories that make up a path from the top of the OpenSSL
 549 source directory (as indicated by the environment variable C<$TOP> or
 550 C<$SRCTOP>).
 551 C<srctop_dir> returns the resulting directory as a string, adapted to the local
 552 operating system.
 553
 554 =back
 555
 556 =cut
 557
 558 sub srctop_dir {
 559     return __srctop_dir(@_);    # This caters for operating systems that have
 560                                 # a very distinct syntax for directories.
 561 }
 562
 563 =over 4
 564
 565 =item B<srctop_file LIST, FILENAME>
 566
 567 LIST is a list of directories that make up a path from the top of the OpenSSL
 568 source directory (as indicated by the environment variable C<$TOP> or
 569 C<$SRCTOP>) and FILENAME is the name of a file located in that directory path.
 570 C<srctop_file> returns the resulting file path as a string, adapted to the local
 571 operating system.
 572
 573 =back
 574
 575 =cut
 576
 577 sub srctop_file {
 578     return __srctop_file(@_);
 579 }
 580
 581 =over 4
 582
 583 =item B<pipe LIST>
 584
 585 LIST is a list of CODEREFs returned by C<app> or C<test>, from which C<pipe>
 586 creates a new command composed of all the given commands put together in a
 587 pipe.  C<pipe> returns a new CODEREF in the same manner as C<app> or C<test>,
 588 to be passed to C<run> for execution.
 589
 590 =back
 591
 592 =cut
 593
 594 sub pipe {
 595     my @cmds = @_;
 596     return
 597         sub {
 598             my @cs  = ();
 599             my @dcs = ();
 600             my @els = ();
 601             my $counter = 0;
 602             foreach (@cmds) {
 603                 my ($c, $dc, @el) = $_->(++$counter);
 604
 605                 return () if !$c;
 606
 607                 push @cs, $c;
 608                 push @dcs, $dc;
 609                 push @els, @el;
 610             }
 611             return (
 612                 join(" | ", @cs),
 613                 join(" | ", @dcs),
 614                 @els
 615                 );
 616     };
 617 }
 618
 619 =over 4
 620
 621 =item B<with HASHREF, CODEREF>
 622
 623 C<with> will temporarly install hooks given by the HASHREF and then execute
 624 the given CODEREF.  Hooks are usually expected to have a coderef as value.
 625
 626 The currently available hoosk are:
 627
 628 =over 4
 629
 630 =item B<exit_checker =E<gt> CODEREF>
 631
 632 This hook is executed after C<run> has performed its given command.  The
 633 CODEREF receives the exit code as only argument and is expected to return
 634 1 (if the exit code indicated success) or 0 (if the exit code indicated
 635 failure).
 636
 637 =back
 638
 639 =back
 640
 641 =cut
 642
 643 sub with {
 644     my $opts = shift;
 645     my %opts = %{$opts};
 646     my $codeblock = shift;
 647
 648     my %saved_hooks = ();
 649
 650     foreach (keys %opts) {
 651         $saved_hooks{$_} = $hooks{$_}   if exists($hooks{$_});
 652         $hooks{$_} = $opts{$_};
 653     }
 654
 655     $codeblock->();
 656
 657     foreach (keys %saved_hooks) {
 658         $hooks{$_} = $saved_hooks{$_};
 659     }
 660 }
 661
 662 =over 4
 663
 664 =item B<cmdstr CODEREF, OPTS>
 665
 666 C<cmdstr> takes a CODEREF from C<app> or C<test> and simply returns the
 667 command as a string.
 668
 669 C<cmdstr> takes some additiona options OPTS that affect the string returned:
 670
 671 =over 4
 672
 673 =item B<display =E<gt> 0|1>
 674
 675 When set to 0, the returned string will be with all decorations, such as a
 676 possible redirect of stderr to the null device.  This is suitable if the
 677 string is to be used directly in a recipe.
 678
 679 When set to 1, the returned string will be without extra decorations.  This
 680 is suitable for display if that is desired (doesn't confuse people with all
 681 internal stuff), or if it's used to pass a command down to a subprocess.
 682
 683 Default: 0
 684
 685 =back
 686
 687 =back
 688
 689 =cut
 690
 691 sub cmdstr {
 692     my ($cmd, $display_cmd) = shift->(0);
 693     my %opts = @_;
 694
 695     if ($opts{display}) {
 696         return $display_cmd;
 697     } else {
 698         return $cmd;
 699     }
 700 }
 701
 702 =over 4
 703
 704 =item B<quotify LIST>
 705
 706 LIST is a list of strings that are going to be used as arguments for a
 707 command, and makes sure to inject quotes and escapes as necessary depending
 708 on the content of each string.
 709
 710 This can also be used to put quotes around the executable of a command.
 711 I<This must never ever be done on VMS.>
 712
 713 =back
 714
 715 =cut
 716
 717 sub quotify {
 718     # Unix setup (default if nothing else is mentioned)
 719     my $arg_formatter =
 720         sub { $_ = shift; /\s|[\{\}\\\$\[\]\*\?\|\&:;<>]/ ? "'$_'" : $_ };
 721
 722     if ( $^O eq "VMS") {        # VMS setup
 723         $arg_formatter = sub {
 724             $_ = shift;
 725             if (/\s|["[:upper:]]/) {
 726                 s/"/""/g;
 727                 '"'.$_.'"';
 728             } else {
 729                 $_;
 730             }
 731         };
 732     } elsif ( $^O eq "MSWin32") { # MSWin setup
 733         $arg_formatter = sub {
 734             $_ = shift;
 735             if (/\s|["\|\&\*\;<>]/) {
 736                 s/(["\\])/\\$1/g;
 737                 '"'.$_.'"';
 738             } else {
 739                 $_;
 740             }
 741         };
 742     }
 743
 744     return map { $arg_formatter->($_) } @_;
 745 }
 746
 747 ######################################################################
 748 # private functions.  These are never exported.
 749
 750 =head1 ENVIRONMENT
 751
 752 OpenSSL::Test depends on some environment variables.
 753
 754 =over 4
 755
 756 =item B<TOP>
 757
 758 This environment variable is mandatory.  C<setup> will check that it's
 759 defined and that it's a directory that contains the file C<Configure>.
 760 If this isn't so, C<setup> will C<BAIL_OUT>.
 761
 762 =item B<BIN_D>
 763
 764 If defined, its value should be the directory where the openssl application
 765 is located.  Defaults to C<$TOP/apps> (adapted to the operating system).
 766
 767 =item B<TEST_D>
 768
 769 If defined, its value should be the directory where the test applications
 770 are located.  Defaults to C<$TOP/test> (adapted to the operating system).
 771
 772 =item B<STOPTEST>
 773
 774 If defined, it puts testing in a different mode, where a recipe with
 775 failures will result in a C<BAIL_OUT> at the end of its run.
 776
 777 =back
 778
 779 =cut
 780
 781 sub __env {
 782     $directories{SRCTOP}  = $ENV{SRCTOP} || $ENV{TOP};
 783     $directories{BLDTOP}  = $ENV{BLDTOP} || $ENV{TOP};
 784     $directories{BLDAPPS} = $ENV{BIN_D}  || __bldtop_dir("apps");
 785     $directories{SRCAPPS} =                 __srctop_dir("apps");
 786     $directories{BLDFUZZ} =                 __bldtop_dir("fuzz");
 787     $directories{SRCFUZZ} =                 __srctop_dir("fuzz");
 788     $directories{BLDTEST} = $ENV{TEST_D} || __bldtop_dir("test");
 789     $directories{SRCTEST} =                 __srctop_dir("test");
 790     $directories{RESULTS} = $ENV{RESULT_D} || $directories{BLDTEST};
 791
 792     push @direnv, "TOP"       if $ENV{TOP};
 793     push @direnv, "SRCTOP"    if $ENV{SRCTOP};
 794     push @direnv, "BLDTOP"    if $ENV{BLDTOP};
 795     push @direnv, "BIN_D"     if $ENV{BIN_D};
 796     push @direnv, "TEST_D"    if $ENV{TEST_D};
 797     push @direnv, "RESULT_D"  if $ENV{RESULT_D};
 798
 799     $end_with_bailout     = $ENV{STOPTEST} ? 1 : 0;
 800 };
 801
 802 # __srctop_file and __srctop_dir are helpers to build file and directory
 803 # names on top of the source directory.  They depend on $SRCTOP, and
 804 # therefore on the proper use of setup() and when needed, indir().
 805 # __bldtop_file and __bldtop_dir do the same thing but relative to $BLDTOP.
 806 # __srctop_file and __bldtop_file take the same kind of argument as
 807 # File::Spec::Functions::catfile.
 808 # Similarly, __srctop_dir and __bldtop_dir take the same kind of argument
 809 # as File::Spec::Functions::catdir
 810 sub __srctop_file {
 811     BAIL_OUT("Must run setup() first") if (! $test_name);
 812
 813     my $f = pop;
 814     return catfile($directories{SRCTOP},@_,$f);
 815 }
 816
 817 sub __srctop_dir {
 818     BAIL_OUT("Must run setup() first") if (! $test_name);
 819
 820     return catdir($directories{SRCTOP},@_);
 821 }
 822
 823 sub __bldtop_file {
 824     BAIL_OUT("Must run setup() first") if (! $test_name);
 825
 826     my $f = pop;
 827     return catfile($directories{BLDTOP},@_,$f);
 828 }
 829
 830 sub __bldtop_dir {
 831     BAIL_OUT("Must run setup() first") if (! $test_name);
 832
 833     return catdir($directories{BLDTOP},@_);
 834 }
 835
 836 # __exeext is a function that returns the platform dependent file extension
 837 # for executable binaries, or the value of the environment variable $EXE_EXT
 838 # if that one is defined.
 839 sub __exeext {
 840     my $ext = "";
 841     if ($^O eq "VMS" ) {        # VMS
 842         $ext = ".exe";
 843     } elsif ($^O eq "MSWin32") { # Windows
 844         $ext = ".exe";
 845     }
 846     return $ENV{"EXE_EXT"} || $ext;
 847 }
 848
 849 # __test_file, __apps_file and __fuzz_file return the full path to a file
 850 # relative to the test/, apps/ or fuzz/ directory in the build tree or the
 851 # source tree, depending on where the file is found.  Note that when looking
 852 # in the build tree, the file name with an added extension is looked for, if
 853 # an extension is given.  The intent is to look for executable binaries (in
 854 # the build tree) or possibly scripts (in the source tree).
 855 # These functions all take the same arguments as File::Spec::Functions::catfile,
 856 # *plus* a mandatory extension argument.  This extension argument can be undef,
 857 # and is ignored in such a case.
 858 sub __test_file {
 859     BAIL_OUT("Must run setup() first") if (! $test_name);
 860
 861     my $e = pop || "";
 862     my $f = pop;
 863     $f = catfile($directories{BLDTEST},@_,$f . $e);
 864     $f = catfile($directories{SRCTEST},@_,$f) unless -f $f;
 865     return $f;
 866 }
 867
 868 sub __apps_file {
 869     BAIL_OUT("Must run setup() first") if (! $test_name);
 870
 871     my $e = pop || "";
 872     my $f = pop;
 873     $f = catfile($directories{BLDAPPS},@_,$f . $e);
 874     $f = catfile($directories{SRCAPPS},@_,$f) unless -f $f;
 875     return $f;
 876 }
 877
 878 sub __fuzz_file {
 879     BAIL_OUT("Must run setup() first") if (! $test_name);
 880
 881     my $e = pop || "";
 882     my $f = pop;
 883     $f = catfile($directories{BLDFUZZ},@_,$f . $e);
 884     $f = catfile($directories{SRCFUZZ},@_,$f) unless -f $f;
 885     return $f;
 886 }
 887
 888 sub __results_file {
 889     BAIL_OUT("Must run setup() first") if (! $test_name);
 890
 891     my $f = pop;
 892     return catfile($directories{RESULTS},@_,$f);
 893 }
 894
 895 # __cwd DIR
 896 # __cwd DIR, OPTS
 897 #
 898 # __cwd changes directory to DIR (string) and changes all the relative
 899 # entries in %directories accordingly.  OPTS is an optional series of
 900 # hash style arguments to alter __cwd's behavior:
 901 #
 902 #    create = 0|1       The directory we move to is created if 1, not if 0.
 903 #    cleanup = 0|1      The directory we move from is removed if 1, not if 0.
 904
 905 sub __cwd {
 906     my $dir = catdir(shift);
 907     my %opts = @_;
 908     my $abscurdir = rel2abs(curdir());
 909     my $absdir = rel2abs($dir);
 910     my $reverse = abs2rel($abscurdir, $absdir);
 911
 912     # PARANOIA: if we're not moving anywhere, we do nothing more
 913     if ($abscurdir eq $absdir) {
 914         return $reverse;
 915     }
 916
 917     # Do not support a move to a different volume for now.  Maybe later.
 918     BAIL_OUT("FAILURE: \"$dir\" moves to a different volume, not supported")
 919         if $reverse eq $abscurdir;
 920
 921     # If someone happened to give a directory that leads back to the current,
 922     # it's extremely silly to do anything more, so just simulate that we did
 923     # move.
 924     # In this case, we won't even clean it out, for safety's sake.
 925     return "." if $reverse eq "";
 926
 927     $dir = canonpath($dir);
 928     if ($opts{create}) {
 929         mkpath($dir);
 930     }
 931
 932     # We are recalculating the directories we keep track of, but need to save
 933     # away the result for after having moved into the new directory.
 934     my %tmp_directories = ();
 935     my %tmp_ENV = ();
 936
 937     # For each of these directory variables, figure out where they are relative
 938     # to the directory we want to move to if they aren't absolute (if they are,
 939     # they don't change!)
 940     my @dirtags = sort keys %directories;
 941     foreach (@dirtags) {
 942         if (!file_name_is_absolute($directories{$_})) {
 943             my $newpath = abs2rel(rel2abs($directories{$_}), rel2abs($dir));
 944             $tmp_directories{$_} = $newpath;
 945         }
 946     }
 947
 948     # Treat each environment variable that was used to get us the values in
 949     # %directories the same was as the paths in %directories, so any sub
 950     # process can use their values properly as well
 951     foreach (@direnv) {
 952         if (!file_name_is_absolute($ENV{$_})) {
 953             my $newpath = abs2rel(rel2abs($ENV{$_}), rel2abs($dir));
 954             $tmp_ENV{$_} = $newpath;
 955         }
 956     }
 957
 958     # Should we just bail out here as well?  I'm unsure.
 959     return undef unless chdir($dir);
 960
 961     if ($opts{cleanup}) {
 962         rmtree(".", { safe => 0, keep_root => 1 });
 963     }
 964
 965     # We put back new values carefully.  Doing the obvious
 966     # %directories = ( %tmp_irectories )
 967     # will clear out any value that happens to be an absolute path
 968     foreach (keys %tmp_directories) {
 969         $directories{$_} = $tmp_directories{$_};
 970     }
 971     foreach (keys %tmp_ENV) {
 972         $ENV{$_} = $tmp_ENV{$_};
 973     }
 974
 975     if ($debug) {
 976         print STDERR "DEBUG: __cwd(), directories and files:\n";
 977         print STDERR "  \$directories{BLDTEST} = \"$directories{BLDTEST}\"\n";
 978         print STDERR "  \$directories{SRCTEST} = \"$directories{SRCTEST}\"\n";
 979         print STDERR "  \$directories{RESULTS} = \"$directories{RESULTS}\"\n";
 980         print STDERR "  \$directories{BLDAPPS} = \"$directories{BLDAPPS}\"\n";
 981         print STDERR "  \$directories{SRCAPPS} = \"$directories{SRCAPPS}\"\n";
 982         print STDERR "  \$directories{SRCTOP}  = \"$directories{SRCTOP}\"\n";
 983         print STDERR "  \$directories{BLDTOP}  = \"$directories{BLDTOP}\"\n";
 984         print STDERR "\n";
 985         print STDERR "  current directory is \"",curdir(),"\"\n";
 986         print STDERR "  the way back is \"$reverse\"\n";
 987     }
 988
 989     return $reverse;
 990 }
 991
 992 # __wrap_cmd CMD
 993 # __wrap_cmd CMD, EXE_SHELL
 994 #
 995 # __wrap_cmd "wraps" CMD (string) with a beginning command that makes sure
 996 # the command gets executed with an appropriate environment.  If EXE_SHELL
 997 # is given, it is used as the beginning command.
 998 #
 999 # __wrap_cmd returns a list that should be used to build up a larger list
1000 # of command tokens, or be joined together like this:
1001 #
1002 #    join(" ", __wrap_cmd($cmd))
1003 sub __wrap_cmd {
1004     my $cmd = shift;
1005     my $exe_shell = shift;
1006
1007     my @prefix = ( __bldtop_file("util", "shlib_wrap.sh") );
1008
1009     if(defined($exe_shell)) {
1010         @prefix = ( $exe_shell );
1011     } elsif ($^O eq "VMS" || $^O eq "MSWin32") {
1012         # VMS and Windows don't use any wrapper script for the moment
1013         @prefix = ();
1014     }
1015
1016     return (@prefix, $cmd);
1017 }
1018
1019 # __fixup_prg PROG
1020 #
1021 # __fixup_prg does whatever fixup is needed to execute an executable binary
1022 # given by PROG (string).
1023 #
1024 # __fixup_prg returns a string with the possibly prefixed program path spec.
1025 sub __fixup_prg {
1026     my $prog = shift;
1027
1028     my $prefix = "";
1029
1030     if ($^O eq "VMS" ) {
1031         $prefix = ($prog =~ /^(?:[\$a-z0-9_]+:)?[<\[]/i ? "mcr " : "mcr []");
1032     }
1033
1034     # We test both with and without extension.  The reason
1035     # is that we might be passed a complete file spec, with
1036     # extension.
1037     if ( ! -x $prog ) {
1038         my $prog = "$prog";
1039         if ( ! -x $prog ) {
1040             $prog = undef;
1041         }
1042     }
1043
1044     if (defined($prog)) {
1045         # Make sure to quotify the program file on platforms that may
1046         # have spaces or similar in their path name.
1047         # To our knowledge, VMS is the exception where quotifying should
1048         # never happem.
1049         ($prog) = quotify($prog) unless $^O eq "VMS";
1050         return $prefix.$prog;
1051     }
1052
1053     print STDERR "$prog not found\n";
1054     return undef;
1055 }
1056
1057 # __decorate_cmd NUM, CMDARRAYREF
1058 #
1059 # __decorate_cmd takes a command number NUM and a command token array
1060 # CMDARRAYREF, builds up a command string from them and decorates it
1061 # with necessary redirections.
1062 # __decorate_cmd returns a list of two strings, one with the command
1063 # string to actually be used, the other to be displayed for the user.
1064 # The reason these strings might differ is that we redirect stderr to
1065 # the null device unless we're verbose and unless the user has
1066 # explicitly specified a stderr redirection.
1067 sub __decorate_cmd {
1068     BAIL_OUT("Must run setup() first") if (! $test_name);
1069
1070     my $num = shift;
1071     my $cmd = shift;
1072     my %opts = @_;
1073
1074     my $cmdstr = join(" ", @$cmd);
1075     my $null = devnull();
1076     my $fileornull = sub { $_[0] ? $_[0] : $null; };
1077     my $stdin = "";
1078     my $stdout = "";
1079     my $stderr = "";
1080     my $saved_stderr = undef;
1081     $stdin = " < ".$fileornull->($opts{stdin})  if exists($opts{stdin});
1082     $stdout= " > ".$fileornull->($opts{stdout}) if exists($opts{stdout});
1083     $stderr=" 2> ".$fileornull->($opts{stderr}) if exists($opts{stderr});
1084
1085     my $display_cmd = "$cmdstr$stdin$stdout$stderr";
1086
1087     $stderr=" 2> ".$null
1088         unless $stderr || !$ENV{HARNESS_ACTIVE} || $ENV{HARNESS_VERBOSE};
1089
1090     $cmdstr .= "$stdin$stdout$stderr";
1091
1092     if ($debug) {
1093         print STDERR "DEBUG[__decorate_cmd]: \$cmdstr = \"$cmdstr\"\n";
1094         print STDERR "DEBUG[__decorate_cmd]: \$display_cmd = \"$display_cmd\"\n";
1095     }
1096
1097     return ($cmdstr, $display_cmd);
1098 }
1099
1100 =head1 SEE ALSO
1101
1102 L<Test::More>, L<Test::Harness>
1103
1104 =head1 AUTHORS
1105
1106 Richard Levitte E<lt>levitte@openssl.orgE<gt> with assitance and
1107 inspiration from Andy Polyakov E<lt>appro@openssl.org<gt>.
1108
1109 =cut
1110
1111 1;