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