test/testlib/OpenSSL/Test.pm

   1 package OpenSSL::Test;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More 0.96;
   7
   8 use Exporter;
   9 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  10 $VERSION = "0.8";
  11 @ISA = qw(Exporter);
  12 @EXPORT = (@Test::More::EXPORT, qw(setup indir app perlapp test perltest run));
  13 @EXPORT_OK = (@Test::More::EXPORT_OK, qw(bldtop_dir bldtop_file
  14                                          srctop_dir srctop_file
  15                                          pipe with cmdstr quotify));
  16
  17 =head1 NAME
  18
  19 OpenSSL::Test - a private extension of Test::More
  20
  21 =head1 SYNOPSIS
  22
  23   use OpenSSL::Test;
  24
  25   setup("my_test_name");
  26
  27   ok(run(app(["openssl", "version"])), "check for openssl presence");
  28
  29   indir "subdir" => sub {
  30     ok(run(test(["sometest", "arg1"], stdout => "foo.txt")),
  31        "run sometest with output to foo.txt");
  32   };
  33
  34 =head1 DESCRIPTION
  35
  36 This module is a private extension of L<Test::More> for testing OpenSSL.
  37 In addition to the Test::More functions, it also provides functions that
  38 easily find the diverse programs within a OpenSSL build tree, as well as
  39 some other useful functions.
  40
  41 This module I<depends> on the environment variables C<$TOP> or C<$SRCTOP>
  42 and C<$BLDTOP>.  Without one of the combinations it refuses to work.
  43 See L</ENVIRONMENT> below.
  44
  45 =cut
  46
  47 use File::Copy;
  48 use File::Spec::Functions qw/file_name_is_absolute curdir canonpath splitdir
  49                              catdir catfile splitpath catpath devnull abs2rel
  50                              rel2abs/;
  51 use File::Path 2.00 qw/rmtree mkpath/;
  52
  53
  54 # The name of the test.  This is set by setup() and is used in the other
  55 # functions to verify that setup() has been used.
  56 my $test_name = undef;
  57
  58 # Directories we want to keep track of TOP, APPS, TEST and RESULTS are the
  59 # ones we're interested in, corresponding to the environment variables TOP
  60 # (mandatory), BIN_D, TEST_D, UTIL_D and RESULT_D.
  61 my %directories = ();
  62
  63 # A bool saying if we shall stop all testing if the current recipe has failing
  64 # tests or not.  This is set by setup() if the environment variable STOPTEST
  65 # is defined with a non-empty value.
  66 my $end_with_bailout = 0;
  67
  68 # A set of hooks that is affected by with() and may be used in diverse places.
  69 # All hooks are expected to be CODE references.
  70 my %hooks = (
  71
  72     # exit_checker is used by run() directly after completion of a command.
  73     # it receives the exit code from that command and is expected to return
  74     # 1 (for success) or 0 (for failure).  This is the value that will be
  75     # returned by run().
  76     # NOTE: When run() gets the option 'capture => 1', this hook is ignored.
  77     exit_checker => sub { return shift == 0 ? 1 : 0 },
  78
  79     );
  80
  81 # Debug flag, to be set manually when needed
  82 my $debug = 0;
  83
  84 # Declare some utility functions that are defined at the end
  85 sub bldtop_file;
  86 sub bldtop_dir;
  87 sub srctop_file;
  88 sub srctop_dir;
  89 sub quotify;
  90
  91 # Declare some private functions that are defined at the end
  92 sub __env;
  93 sub __cwd;
  94 sub __apps_file;
  95 sub __results_file;
  96 sub __test_log;
  97 sub __fixup_cmd;
  98 sub __build_cmd;
  99
 100 =head2 Main functions
 101
 102 The following functions are exported by default when using C<OpenSSL::Test>.
 103
 104 =cut
 105
 106 =over 4
 107
 108 =item B<setup "NAME">
 109
 110 C<setup> is used for initial setup, and it is mandatory that it's used.
 111 If it's not used in a OpenSSL test recipe, the rest of the recipe will
 112 most likely refuse to run.
 113
 114 C<setup> checks for environment variables (see L</ENVIRONMENT> below),
 115 checks that C<$TOP/Configure> or C<$SRCTOP/Configure> exists, C<chdir>
 116 into the results directory (defined by the C<$RESULT_D> environment
 117 variable if defined, otherwise C<$BLDTOP/test> or C<$TOP/test>, whichever
 118 is defined).
 119
 120 =back
 121
 122 =cut
 123
 124 sub setup {
 125     $test_name = shift;
 126
 127     BAIL_OUT("setup() must receive a name") unless $test_name;
 128     BAIL_OUT("setup() needs \$TOP or \$SRCTOP and \$BLDTOP to be defined")
 129         unless $ENV{TOP} || ($ENV{SRCTOP} && $ENV{BLDTOP});
 130     BAIL_OUT("setup() found both \$TOP and \$SRCTOP or \$BLDTOP...")
 131         if $ENV{TOP} && ($ENV{SRCTOP} || $ENV{BLDTOP});
 132
 133     __env();
 134
 135     BAIL_OUT("setup() expects the file Configure in the \$TOP directory")
 136         unless -f srctop_file("Configure");
 137
 138     __cwd($directories{RESULTS});
 139
 140     # Loop in case we're on a platform with more than one file generation
 141     1 while unlink(__test_log());
 142 }
 143
 144 =over 4
 145
 146 =item B<indir "SUBDIR" =E<gt> sub BLOCK, OPTS>
 147
 148 C<indir> is used to run a part of the recipe in a different directory than
 149 the one C<setup> moved into, usually a subdirectory, given by SUBDIR.
 150 The part of the recipe that's run there is given by the codeblock BLOCK.
 151
 152 C<indir> takes some additional options OPTS that affect the subdirectory:
 153
 154 =over 4
 155
 156 =item B<create =E<gt> 0|1>
 157
 158 When set to 1 (or any value that perl preceives as true), the subdirectory
 159 will be created if it doesn't already exist.  This happens before BLOCK
 160 is executed.
 161
 162 =item B<cleanup =E<gt> 0|1>
 163
 164 When set to 1 (or any value that perl preceives as true), the subdirectory
 165 will be cleaned out and removed.  This happens both before and after BLOCK
 166 is executed.
 167
 168 =back
 169
 170 An example:
 171
 172   indir "foo" => sub {
 173       ok(run(app(["openssl", "version"]), stdout => "foo.txt"));
 174       if (ok(open(RESULT, "foo.txt"), "reading foo.txt")) {
 175           my $line = <RESULT>;
 176           close RESULT;
 177           is($line, qr/^OpenSSL 1\./,
 178              "check that we're using OpenSSL 1.x.x");
 179       }
 180   }, create => 1, cleanup => 1;
 181
 182 =back
 183
 184 =cut
 185
 186 sub indir {
 187     my $subdir = shift;
 188     my $codeblock = shift;
 189     my %opts = @_;
 190
 191     my $reverse = __cwd($subdir,%opts);
 192     BAIL_OUT("FAILURE: indir, \"$subdir\" wasn't possible to move into")
 193         unless $reverse;
 194
 195     $codeblock->();
 196
 197     __cwd($reverse);
 198
 199     if ($opts{cleanup}) {
 200         rmtree($subdir, { safe => 0 });
 201     }
 202 }
 203
 204 =over 4
 205
 206 =item B<app ARRAYREF, OPTS>
 207
 208 =item B<test ARRAYREF, OPTS>
 209
 210 Both of these functions take a reference to a list that is a command and
 211 its arguments, and some additional options (described further on).
 212
 213 C<app> expects to find the given command (the first item in the given list
 214 reference) as an executable in C<$BIN_D> (if defined, otherwise C<$TOP/apps>
 215 or C<$BLDTOP/apps>).
 216
 217 C<test> expects to find the given command (the first item in the given list
 218 reference) as an executable in C<$TEST_D> (if defined, otherwise C<$TOP/test>
 219 or C<$BLDTOP/test>).
 220
 221 Both return a CODEREF to be used by C<run>, C<pipe> or C<cmdstr>.
 222
 223 The options that both C<app> and C<test> can take are in the form of hash
 224 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<perlapp ARRAYREF, OPTS>
 241
 242 =item B<perltest ARRAYREF, OPTS>
 243
 244 Both these functions function the same way as B<app> and B<test>, except
 245 that they expect the command to be a perl script.
 246
 247 =back
 248
 249 =cut
 250
 251 sub app {
 252     my $cmd = shift;
 253     my %opts = @_;
 254     return sub { my $num = shift;
 255                  return __build_cmd($num, \&__apps_file, $cmd, %opts); }
 256 }
 257
 258 sub test {
 259     my $cmd = shift;
 260     my %opts = @_;
 261     return sub { my $num = shift;
 262                  return __build_cmd($num, \&__test_file, $cmd, %opts); }
 263 }
 264
 265 sub perlapp {
 266     my $cmd = shift;
 267     my %opts = @_;
 268     return sub { my $num = shift;
 269                  return __build_cmd($num, \&__perlapps_file, $cmd, %opts); }
 270 }
 271
 272 sub perltest {
 273     my $cmd = shift;
 274     my %opts = @_;
 275     return sub { my $num = shift;
 276                  return __build_cmd($num, \&__perltest_file, $cmd, %opts); }
 277 }
 278
 279 =over 4
 280
 281 =item B<run CODEREF, OPTS>
 282
 283 This CODEREF is expected to be the value return by C<app> or C<test>,
 284 anything else will most likely cause an error unless you know what you're
 285 doing.
 286
 287 C<run> executes the command returned by CODEREF and return either the
 288 resulting output (if the option C<capture> is set true) or a boolean indicating
 289 if the command succeeded or not.
 290
 291 The options that C<run> can take are in the form of hash values:
 292
 293 =over 4
 294
 295 =item B<capture =E<gt> 0|1>
 296
 297 If true, the command will be executed with a perl backtick, and C<run> will
 298 return the resulting output as an array of lines.  If false or not given,
 299 the command will be executed with C<system()>, and C<run> will return 1 if
 300 the command was successful or 0 if it wasn't.
 301
 302 =back
 303
 304 For further discussion on what is considered a successful command or not, see
 305 the function C<with> further down.
 306
 307 =back
 308
 309 =cut
 310
 311 sub run {
 312     my ($cmd, $display_cmd, %errlogs) = shift->(0);
 313     my %opts = @_;
 314
 315     return () if !$cmd;
 316
 317     my $prefix = "";
 318     if ( $^O eq "VMS" ) {       # VMS
 319         $prefix = "pipe ";
 320     }
 321
 322     my @r = ();
 323     my $r = 0;
 324     my $e = 0;
 325     if ($opts{capture}) {
 326         @r = `$prefix$cmd`;
 327         $e = $? >> 8;
 328     } else {
 329         system("$prefix$cmd");
 330         $e = $? >> 8;
 331         $r = $hooks{exit_checker}->($e);
 332     }
 333
 334     # At this point, $? stops being interesting, and unfortunately,
 335     # there are Test::More versions that get picky if we leave it
 336     # non-zero.
 337     $? = 0;
 338
 339     open ERR, ">>", __test_log();
 340     { local $| = 1; print ERR "$display_cmd => $e\n"; }
 341     foreach (keys %errlogs) {
 342         copy($_,\*ERR);
 343         copy($_,$errlogs{$_}) if defined($errlogs{$_});
 344         unlink($_);
 345     }
 346     close ERR;
 347
 348     if ($opts{capture}) {
 349         return @r;
 350     } else {
 351         return $r;
 352     }
 353 }
 354
 355 END {
 356     my $tb = Test::More->builder;
 357     my $failure = scalar(grep { $_ == 0; } $tb->summary);
 358     if ($failure && $end_with_bailout) {
 359         BAIL_OUT("Stoptest!");
 360     }
 361 }
 362
 363 =head2 Utility functions
 364
 365 The following functions are exported on request when using C<OpenSSL::Test>.
 366
 367   # To only get the bldtop_file and srctop_file functions.
 368   use OpenSSL::Test qw/bldtop_file srctop_file/;
 369
 370   # To only get the bldtop_file function in addition to the default ones.
 371   use OpenSSL::Test qw/:DEFAULT bldtop_file/;
 372
 373 =cut
 374
 375 # Utility functions, exported on request
 376
 377 =over 4
 378
 379 =item B<bldtop_dir LIST>
 380
 381 LIST is a list of directories that make up a path from the top of the OpenSSL
 382 build directory (as indicated by the environment variable C<$TOP> or
 383 C<$BLDTOP>).
 384 C<bldtop_dir> returns the resulting directory as a string, adapted to the local
 385 operating system.
 386
 387 =back
 388
 389 =cut
 390
 391 sub bldtop_dir {
 392     return __bldtop_dir(@_);    # This caters for operating systems that have
 393                                 # a very distinct syntax for directories.
 394 }
 395
 396 =over 4
 397
 398 =item B<bldtop_file LIST, FILENAME>
 399
 400 LIST is a list of directories that make up a path from the top of the OpenSSL
 401 build directory (as indicated by the environment variable C<$TOP> or
 402 C<$BLDTOP>) and FILENAME is the name of a file located in that directory path.
 403 C<bldtop_file> returns the resulting file path as a string, adapted to the local
 404 operating system.
 405
 406 =back
 407
 408 =cut
 409
 410 sub bldtop_file {
 411     return __bldtop_file(@_);
 412 }
 413
 414 =over 4
 415
 416 =item B<srctop_dir LIST>
 417
 418 LIST is a list of directories that make up a path from the top of the OpenSSL
 419 source directory (as indicated by the environment variable C<$TOP> or
 420 C<$SRCTOP>).
 421 C<srctop_dir> returns the resulting directory as a string, adapted to the local
 422 operating system.
 423
 424 =back
 425
 426 =cut
 427
 428 sub srctop_dir {
 429     return __srctop_dir(@_);    # This caters for operating systems that have
 430                                 # a very distinct syntax for directories.
 431 }
 432
 433 =over 4
 434
 435 =item B<srctop_file LIST, FILENAME>
 436
 437 LIST is a list of directories that make up a path from the top of the OpenSSL
 438 source directory (as indicated by the environment variable C<$TOP> or
 439 C<$SRCTOP>) and FILENAME is the name of a file located in that directory path.
 440 C<srctop_file> returns the resulting file path as a string, adapted to the local
 441 operating system.
 442
 443 =back
 444
 445 =cut
 446
 447 sub srctop_file {
 448     return __srctop_file(@_);
 449 }
 450
 451 =over 4
 452
 453 =item B<pipe LIST>
 454
 455 LIST is a list of CODEREFs returned by C<app> or C<test>, from which C<pipe>
 456 creates a new command composed of all the given commands put together in a
 457 pipe.  C<pipe> returns a new CODEREF in the same manner as C<app> or C<test>,
 458 to be passed to C<run> for execution.
 459
 460 =back
 461
 462 =cut
 463
 464 sub pipe {
 465     my @cmds = @_;
 466     return
 467         sub {
 468             my @cs  = ();
 469             my @dcs = ();
 470             my @els = ();
 471             my $counter = 0;
 472             foreach (@cmds) {
 473                 my ($c, $dc, @el) = $_->(++$counter);
 474
 475                 return () if !$c;
 476
 477                 push @cs, $c;
 478                 push @dcs, $dc;
 479                 push @els, @el;
 480             }
 481             return (
 482                 join(" | ", @cs),
 483                 join(" | ", @dcs),
 484                 @els
 485                 );
 486     };
 487 }
 488
 489 =over 4
 490
 491 =item B<with HASHREF, CODEREF>
 492
 493 C<with> will temporarly install hooks given by the HASHREF and then execute
 494 the given CODEREF.  Hooks are usually expected to have a coderef as value.
 495
 496 The currently available hoosk are:
 497
 498 =over 4
 499
 500 =item B<exit_checker =E<gt> CODEREF>
 501
 502 This hook is executed after C<run> has performed its given command.  The
 503 CODEREF receives the exit code as only argument and is expected to return
 504 1 (if the exit code indicated success) or 0 (if the exit code indicated
 505 failure).
 506
 507 =back
 508
 509 =back
 510
 511 =cut
 512
 513 sub with {
 514     my $opts = shift;
 515     my %opts = %{$opts};
 516     my $codeblock = shift;
 517
 518     my %saved_hooks = ();
 519
 520     foreach (keys %opts) {
 521         $saved_hooks{$_} = $hooks{$_}   if exists($hooks{$_});
 522         $hooks{$_} = $opts{$_};
 523     }
 524
 525     $codeblock->();
 526
 527     foreach (keys %saved_hooks) {
 528         $hooks{$_} = $saved_hooks{$_};
 529     }
 530 }
 531
 532 =over 4
 533
 534 =item B<cmdstr CODEREF>
 535
 536 C<cmdstr> takes a CODEREF from C<app> or C<test> and simply returns the
 537 command as a string.
 538
 539 =back
 540
 541 =cut
 542
 543 sub cmdstr {
 544     my ($cmd, $display_cmd, %errlogs) = shift->(0);
 545
 546     return $display_cmd;
 547 }
 548
 549 =over 4
 550
 551 =item B<quotify LIST>
 552
 553 LIST is a list of strings that are going to be used as arguments for a
 554 command, and makes sure to inject quotes and escapes as necessary depending
 555 on the content of each string.
 556
 557 This can also be used to put quotes around the executable of a command.
 558 I<This must never ever be done on VMS.>
 559
 560 =back
 561
 562 =cut
 563
 564 sub quotify {
 565     # Unix setup (default if nothing else is mentioned)
 566     my $arg_formatter =
 567         sub { $_ = shift; /\s|[\{\}\\\$\[\]\*\?\|\&:;<>]/ ? "'$_'" : $_ };
 568
 569     if ( $^O eq "VMS") {        # VMS setup
 570         $arg_formatter = sub {
 571             $_ = shift;
 572             if (/\s|["[:upper:]]/) {
 573                 s/"/""/g;
 574                 '"'.$_.'"';
 575             } else {
 576                 $_;
 577             }
 578         };
 579     } elsif ( $^O eq "MSWin32") { # MSWin setup
 580         $arg_formatter = sub {
 581             $_ = shift;
 582             if (/\s|["\|\&\*\;<>]/) {
 583                 s/(["\\])/\\$1/g;
 584                 '"'.$_.'"';
 585             } else {
 586                 $_;
 587             }
 588         };
 589     }
 590
 591     return map { $arg_formatter->($_) } @_;
 592 }
 593
 594 ######################################################################
 595 # private functions.  These are never exported.
 596
 597 =head1 ENVIRONMENT
 598
 599 OpenSSL::Test depends on some environment variables.
 600
 601 =over 4
 602
 603 =item B<TOP>
 604
 605 This environment variable is mandatory.  C<setup> will check that it's
 606 defined and that it's a directory that contains the file C<Configure>.
 607 If this isn't so, C<setup> will C<BAIL_OUT>.
 608
 609 =item B<BIN_D>
 610
 611 If defined, its value should be the directory where the openssl application
 612 is located.  Defaults to C<$TOP/apps> (adapted to the operating system).
 613
 614 =item B<TEST_D>
 615
 616 If defined, its value should be the directory where the test applications
 617 are located.  Defaults to C<$TOP/test> (adapted to the operating system).
 618
 619 =item B<RESULT_D>
 620
 621 If defined, its value should be the directory where the log files are
 622 located.  Defaults to C<$TEST_D>.
 623
 624 =item B<STOPTEST>
 625
 626 If defined, it puts testing in a different mode, where a recipe with
 627 failures will result in a C<BAIL_OUT> at the end of its run.
 628
 629 =back
 630
 631 =cut
 632
 633 sub __env {
 634     $directories{SRCTOP}  = $ENV{SRCTOP} || $ENV{TOP};
 635     $directories{BLDTOP}  = $ENV{BLDTOP} || $ENV{TOP};
 636     $directories{APPS}    = $ENV{BIN_D}  || __bldtop_dir("apps");
 637     $directories{TEST}    = $ENV{TEST_D} || __bldtop_dir("test");
 638     $directories{RESULTS} = $ENV{RESULT_D} || $directories{TEST};
 639
 640     $end_with_bailout     = $ENV{STOPTEST} ? 1 : 0;
 641 };
 642
 643 sub __srctop_file {
 644     BAIL_OUT("Must run setup() first") if (! $test_name);
 645
 646     my $f = pop;
 647     return catfile($directories{SRCTOP},@_,$f);
 648 }
 649
 650 sub __srctop_dir {
 651     BAIL_OUT("Must run setup() first") if (! $test_name);
 652
 653     return catdir($directories{SRCTOP},@_);
 654 }
 655
 656 sub __bldtop_file {
 657     BAIL_OUT("Must run setup() first") if (! $test_name);
 658
 659     my $f = pop;
 660     return catfile($directories{BLDTOP},@_,$f);
 661 }
 662
 663 sub __bldtop_dir {
 664     BAIL_OUT("Must run setup() first") if (! $test_name);
 665
 666     return catdir($directories{BLDTOP},@_);
 667 }
 668
 669 sub __test_file {
 670     BAIL_OUT("Must run setup() first") if (! $test_name);
 671
 672     my $f = pop;
 673     return catfile($directories{TEST},@_,$f);
 674 }
 675
 676 sub __perltest_file {
 677     BAIL_OUT("Must run setup() first") if (! $test_name);
 678
 679     my $f = pop;
 680     return ($^X, catfile($directories{TEST},@_,$f));
 681 }
 682
 683 sub __apps_file {
 684     BAIL_OUT("Must run setup() first") if (! $test_name);
 685
 686     my $f = pop;
 687     return catfile($directories{APPS},@_,$f);
 688 }
 689
 690 sub __perlapps_file {
 691     BAIL_OUT("Must run setup() first") if (! $test_name);
 692
 693     my $f = pop;
 694     return ($^X, catfile($directories{APPS},@_,$f));
 695 }
 696
 697 sub __results_file {
 698     BAIL_OUT("Must run setup() first") if (! $test_name);
 699
 700     my $f = pop;
 701     return catfile($directories{RESULTS},@_,$f);
 702 }
 703
 704 sub __test_log {
 705     return __results_file("$test_name.log");
 706 }
 707
 708 sub __cwd {
 709     my $dir = catdir(shift);
 710     my %opts = @_;
 711     my $abscurdir = rel2abs(curdir());
 712     my $absdir = rel2abs($dir);
 713     my $reverse = abs2rel($abscurdir, $absdir);
 714
 715     # PARANOIA: if we're not moving anywhere, we do nothing more
 716     if ($abscurdir eq $absdir) {
 717         return $reverse;
 718     }
 719
 720     # Do not support a move to a different volume for now.  Maybe later.
 721     BAIL_OUT("FAILURE: \"$dir\" moves to a different volume, not supported")
 722         if $reverse eq $abscurdir;
 723
 724     # If someone happened to give a directory that leads back to the current,
 725     # it's extremely silly to do anything more, so just simulate that we did
 726     # move.
 727     # In this case, we won't even clean it out, for safety's sake.
 728     return "." if $reverse eq "";
 729
 730     $dir = canonpath($dir);
 731     if ($opts{create}) {
 732         mkpath($dir);
 733     }
 734
 735     # Should we just bail out here as well?  I'm unsure.
 736     return undef unless chdir($dir);
 737
 738     if ($opts{cleanup}) {
 739         rmtree(".", { safe => 0, keep_root => 1 });
 740     }
 741
 742     # For each of these directory variables, figure out where they are relative
 743     # to the directory we want to move to if they aren't absolute (if they are,
 744     # they don't change!)
 745     my @dirtags = sort keys %directories;
 746     foreach (@dirtags) {
 747         if (!file_name_is_absolute($directories{$_})) {
 748             my $newpath = abs2rel(rel2abs($directories{$_}), rel2abs($dir));
 749             $directories{$_} = $newpath;
 750         }
 751     }
 752
 753     if ($debug) {
 754         print STDERR "DEBUG: __cwd(), directories and files:\n";
 755         print STDERR "  \$directories{TEST}    = \"$directories{TEST}\"\n";
 756         print STDERR "  \$directories{RESULTS} = \"$directories{RESULTS}\"\n";
 757         print STDERR "  \$directories{APPS}    = \"$directories{APPS}\"\n";
 758         print STDERR "  \$directories{SRCTOP}  = \"$directories{SRCTOP}\"\n";
 759         print STDERR "  \$directories{BLDTOP}  = \"$directories{BLDTOP}\"\n";
 760         print STDERR "  \$test_log             = \"",__test_log(),"\"\n";
 761         print STDERR "\n";
 762         print STDERR "  current directory is \"",curdir(),"\"\n";
 763         print STDERR "  the way back is \"$reverse\"\n";
 764     }
 765
 766     return $reverse;
 767 }
 768
 769 sub __fixup_cmd {
 770     my $prog = shift;
 771     my $exe_shell = shift;
 772
 773     my $prefix = __bldtop_file("util", "shlib_wrap.sh")." ";
 774     my $ext = $ENV{"EXE_EXT"} || "";
 775
 776     if (defined($exe_shell)) {
 777         $prefix = "$exe_shell ";
 778     } elsif ($^O eq "VMS" ) {   # VMS
 779         $prefix = ($prog =~ /^(?:[\$a-z0-9_]+:)?[<\[]/i ? "mcr " : "mcr []");
 780         $ext = ".exe";
 781     } elsif ($^O eq "MSWin32") { # Windows
 782         $prefix = "";
 783         $ext = ".exe";
 784     }
 785
 786     # We test both with and without extension.  The reason
 787     # is that we might be passed a complete file spec, with
 788     # extension.
 789     if ( ! -x $prog ) {
 790         my $prog = "$prog$ext";
 791         if ( ! -x $prog ) {
 792             $prog = undef;
 793         }
 794     }
 795
 796     if (defined($prog)) {
 797         # Make sure to quotify the program file on platforms that may
 798         # have spaces or similar in their path name.
 799         # To our knowledge, VMS is the exception where quotifying should
 800         # never happem.
 801         ($prog) = quotify($prog) unless $^O eq "VMS";
 802         return $prefix.$prog;
 803     }
 804
 805     print STDERR "$prog not found\n";
 806     return undef;
 807 }
 808
 809 sub __build_cmd {
 810     BAIL_OUT("Must run setup() first") if (! $test_name);
 811
 812     my $num = shift;
 813     my $path_builder = shift;
 814     # Make a copy to not destroy the caller's array
 815     my @cmdarray = ( @{$_[0]} ); shift;
 816
 817     # We do a little dance, as $path_builder might return a list of
 818     # more than one.  If so, only the first is to be considered a
 819     # program to fix up, the rest is part of the arguments.  This
 820     # happens for perl scripts, where $path_builder will return
 821     # a list of two, $^X and the script name.
 822     # Also, if $path_builder returned more than one, we don't apply
 823     # the EXE_SHELL environment variable.
 824     my @prog = ($path_builder->(shift @cmdarray));
 825     my $first = shift @prog;
 826     my $exe_shell = @prog ? undef : $ENV{EXE_SHELL};
 827     my $cmd = __fixup_cmd($first, $exe_shell);
 828     if (@prog) {
 829         if ( ! -f $prog[0] ) {
 830             print STDERR "$prog[0] not found\n";
 831             $cmd = undef;
 832         }
 833     }
 834     my @args = (@prog, @cmdarray);
 835
 836     my %opts = @_;
 837
 838     return () if !$cmd;
 839
 840     my $arg_str = "";
 841     my $null = devnull();
 842
 843
 844     $arg_str = " ".join(" ", quotify @args) if @args;
 845
 846     my $fileornull = sub { $_[0] ? $_[0] : $null; };
 847     my $stdin = "";
 848     my $stdout = "";
 849     my $stderr = "";
 850     my $saved_stderr = undef;
 851     $stdin = " < ".$fileornull->($opts{stdin})  if exists($opts{stdin});
 852     $stdout= " > ".$fileornull->($opts{stdout}) if exists($opts{stdout});
 853     $stderr=" 2> ".$fileornull->($opts{stderr}) if exists($opts{stderr});
 854
 855     $saved_stderr = $opts{stderr}               if defined($opts{stderr});
 856
 857     my $errlog =
 858         __results_file($num ? "$test_name.$num.tmp_err" : "$test_name.tmp_err");
 859     my $display_cmd = "$cmd$arg_str$stdin$stdout$stderr";
 860     $cmd .= "$arg_str$stdin$stdout 2> $errlog";
 861
 862     if ($debug) {
 863         print STDERR "DEBUG[__build_cmd]: \$cmd = \"$cmd\"\n";
 864         print STDERR "DEBUG[__build_cmd]: \$display_cmd = \"$display_cmd\"\n";
 865     }
 866
 867     return ($cmd, $display_cmd, $errlog => $saved_stderr);
 868 }
 869
 870 =head1 SEE ALSO
 871
 872 L<Test::More>, L<Test::Harness>
 873
 874 =head1 AUTHORS
 875
 876 Richard Levitte E<lt>levitte@openssl.orgE<gt> with assitance and
 877 inspiration from Andy Polyakov E<lt>appro@openssl.org<gt>.
 878
 879 =cut
 880
 881 1;