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