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