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