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