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