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