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