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