Change OpenSSL::Test to be an extension of Test::More
[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.5";
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
17 use File::Copy;
18 use File::Spec::Functions qw/file_name_is_absolute curdir canonpath splitdir
19                              catdir catfile splitpath catpath devnull abs2rel
20                              rel2abs/;
21 use File::Path 2.00 qw/remove_tree mkpath/;
22
23
24 my $test_name = undef;
25
26 my %directories = ();           # Directories we want to keep track of
27                                 # TOP, APPS, TEST and RESULTS are the
28                                 # ones we're interested in, corresponding
29                                 # to the environment variables TOP (mandatory),
30                                 # BIN_D, TEST_D and RESULT_D.
31
32 my $end_with_bailout = 0;
33
34 sub quotify;
35
36 sub __top_file {
37     BAIL_OUT("Must run setup() first") if (! $test_name);
38
39     my $f = pop;
40     return catfile($directories{TOP},@_,$f);
41 }
42
43 sub __test_file {
44     BAIL_OUT("Must run setup() first") if (! $test_name);
45
46     my $f = pop;
47     return catfile($directories{TEST},@_,$f);
48 }
49
50 sub __apps_file {
51     BAIL_OUT("Must run setup() first") if (! $test_name);
52
53     my $f = pop;
54     return catfile($directories{APPS},@_,$f);
55 }
56
57 sub __results_file {
58     BAIL_OUT("Must run setup() first") if (! $test_name);
59
60     my $f = pop;
61     return catfile($directories{RESULTS},@_,$f);
62 }
63
64 sub __test_log {
65     return __results_file("$test_name.log");
66 }
67
68 sub top_dir {
69     return __top_file(@_, "");  # This caters for operating systems that have
70                                 # a very distinct syntax for directories.
71 }
72 sub top_file {
73     return __top_file(@_);
74 }
75
76 sub __cwd {
77     my $dir = shift;
78     my %opts = @_;
79     my $abscurdir = rel2abs(curdir());
80     my $absdir = rel2abs($dir);
81     my $reverse = abs2rel($abscurdir, $absdir);
82
83     # PARANOIA: if we're not moving anywhere, we do nothing more
84     if ($abscurdir eq $absdir) {
85         return $reverse;
86     }
87
88     # Do not support a move to a different volume for now.  Maybe later.
89     BAIL_OUT("FAILURE: \"$dir\" moves to a different volume, not supported")
90         if $reverse eq $abscurdir;
91
92     # If someone happened to give a directory that leads back to the current,
93     # it's extremely silly to do anything more, so just simulate that we did
94     # move.
95     # In this case, we won't even clean it out, for safety's sake.
96     return "." if $reverse eq "";
97
98     $dir = canonpath($dir);
99     if ($opts{create}) {
100         mkpath($dir);
101     }
102
103     # Should we just bail out here as well?  I'm unsure.
104     return undef unless chdir($dir);
105
106     if ($opts{cleanup}) {
107         remove_tree(".", { safe => 0, keep_root => 1 });
108     }
109
110     # For each of these directory variables, figure out where they are relative
111     # to the directory we want to move to if they aren't absolute (if they are,
112     # they don't change!)
113     my @dirtags = ("TOP", "TEST", "APPS", "RESULTS");
114     foreach (@dirtags) {
115         if (!file_name_is_absolute($directories{$_})) {
116             my $newpath = abs2rel(rel2abs($directories{$_}), rel2abs($dir));
117             $directories{$_} = $newpath;
118         }
119     }
120
121     if (0) {
122         print STDERR "DEBUG: __cwd(), directories and files:\n";
123         print STDERR "  \$directories{TEST}    = \"$directories{TEST}\"\n";
124         print STDERR "  \$directories{RESULTS} = \"$directories{RESULTS}\"\n";
125         print STDERR "  \$directories{APPS}    = \"$directories{APPS}\"\n";
126         print STDERR "  \$directories{TOP}     = \"$directories{TOP}\"\n";
127         print STDERR "  \$test_log             = \"",__test_log(),"\"\n";
128         print STDERR "\n";
129         print STDERR "  current directory is \"",curdir(),"\"\n";
130         print STDERR "  the way back is \"$reverse\"\n";
131     }
132
133     return $reverse;
134 }
135
136 sub setup {
137     $test_name = shift;
138
139     BAIL_OUT("setup() must receive a name") unless $test_name;
140     BAIL_OUT("setup() needs \$TOP to be defined") unless $ENV{TOP};
141
142     $directories{TOP}     = $ENV{TOP},
143     $directories{APPS}    = $ENV{BIN_D}    || catdir($directories{TOP},"apps");
144     $directories{TEST}    = $ENV{TEST_D}   || catdir($directories{TOP},"test");
145     $directories{RESULTS} = $ENV{RESULT_D} || $directories{TEST};
146
147     $end_with_bailout     = $ENV{STOPTEST} ? 1 : 0;
148
149     BAIL_OUT("setup() expects the file Configure in the \$TOP directory")
150         unless -f top_file("Configure");
151
152     __cwd($directories{RESULTS});
153
154     # Loop in case we're on a platform with more than one file generation
155     1 while unlink(__test_log());
156 }
157
158 sub indir {
159     my $subdir = shift;
160     my $codeblock = shift;
161     my %opts = @_;
162
163     my $reverse = __cwd($subdir,%opts);
164     BAIL_OUT("FAILURE: indir, \"$subdir\" wasn't possible to move into")
165         unless $reverse;
166
167     $codeblock->();
168
169     __cwd($reverse);
170
171     if ($opts{cleanup}) {
172         remove_tree($subdir, { safe => 0 });
173     }
174 }
175
176 my %hooks = (
177     exit_checker => sub { return shift == 0 ? 1 : 0 }
178     );
179
180 sub with {
181     my $opts = shift;
182     my %opts = %{$opts};
183     my $codeblock = shift;
184
185     my %saved_hooks = ();
186
187     foreach (keys %opts) {
188         $saved_hooks{$_} = $hooks{$_}   if exists($hooks{$_});
189         $hooks{$_} = $opts{$_};
190     }
191
192     $codeblock->();
193
194     foreach (keys %saved_hooks) {
195         $hooks{$_} = $saved_hooks{$_};
196     }
197 }
198
199 sub __fixup_cmd {
200     my $prog = shift;
201
202     my $prefix = __top_file("util", "shlib_wrap.sh")." ";
203     my $ext = $ENV{"EXE_EXT"} || "";
204
205     if ( $^O eq "VMS" ) {       # VMS
206         $prefix = "mcr ";
207         $ext = ".exe";
208     } elsif ($^O eq "MSWin32") { # Windows
209         $prefix = "";
210         $ext = ".exe";
211     }
212
213     # We test both with and without extension.  The reason
214     # is that we might, for example, be passed a Perl script
215     # ending with .pl...
216     my $file = "$prog$ext";
217     if ( -x $file ) {
218         return $prefix.$file;
219     } elsif ( -f $prog ) {
220         return $prog;
221     }
222
223     print STDERR "$prog not found\n";
224     return undef;
225 }
226
227 sub __build_cmd {
228     BAIL_OUT("Must run setup() first") if (! $test_name);
229
230     my $num = shift;
231     my $path_builder = shift;
232     my $cmd = __fixup_cmd($path_builder->(shift @{$_[0]}));
233     my @args = @{$_[0]}; shift;
234     my %opts = @_;
235
236     return () if !$cmd;
237
238     my $arg_str = "";
239     my $null = devnull();
240
241
242     $arg_str = " ".join(" ", quotify @args) if @args;
243
244     my $fileornull = sub { $_[0] ? $_[0] : $null; };
245     my $stdin = "";
246     my $stdout = "";
247     my $stderr = "";
248     my $saved_stderr = undef;
249     $stdin = " < ".$fileornull->($opts{stdin})  if exists($opts{stdin});
250     $stdout= " > ".$fileornull->($opts{stdout}) if exists($opts{stdout});
251     $stderr=" 2> ".$fileornull->($opts{stderr}) if exists($opts{stderr});
252
253     $saved_stderr = $opts{stderr}               if defined($opts{stderr});
254
255     my $errlog = $num ? "$test_name.$num.tmp_err" : "$test_name.tmp_err";
256     my $display_cmd = "$cmd$arg_str$stdin$stdout$stderr";
257     $cmd .= "$arg_str$stdin$stdout 2> $errlog";
258
259     return ($cmd, $display_cmd, $errlog => $saved_stderr);
260 }
261
262 sub app {
263     my $cmd = shift;
264     my %opts = @_;
265     return sub { my $num = shift;
266                  return __build_cmd($num, \&__apps_file, $cmd, %opts); }
267 }
268
269 sub test {
270     my $cmd = shift;
271     my %opts = @_;
272     return sub { my $num = shift;
273                  return __build_cmd($num, \&__test_file, $cmd, %opts); }
274 }
275
276 sub cmdstr {
277     my ($cmd, $display_cmd, %errlogs) = shift->(0);
278
279     return $display_cmd;
280 }
281
282 END {
283     my $tb = Test::More->builder;
284     my $failure = scalar(grep { $_ == 0; } $tb->summary);
285     if ($failure && $end_with_bailout) {
286         BAIL_OUT("Stoptest!");
287     }
288 }
289 sub run {
290     my ($cmd, $display_cmd, %errlogs) = shift->(0);
291     my %opts = @_;
292
293     return () if !$cmd;
294
295     my $prefix = "";
296     if ( $^O eq "VMS" ) {       # VMS
297         $prefix = "pipe ";
298     } elsif ($^O eq "MSWin32") { # MSYS
299         $prefix = "cmd /c ";
300     }
301
302     my @r = ();
303     my $r = 0;
304     my $e = 0;
305     if ($opts{capture}) {
306         @r = `$prefix$cmd`;
307         $e = $? >> 8;
308     } else {
309         system("$prefix$cmd");
310         $e = $? >> 8;
311         $r = $hooks{exit_checker}->($e);
312     }
313
314     # At this point, $? stops being interesting, and unfortunately,
315     # there are Test::More versions that get picky if we leave it
316     # non-zero.
317     $? = 0;
318
319     open ERR, ">>", __test_log();
320     { local $| = 1; print ERR "$display_cmd => $e\n"; }
321     foreach (keys %errlogs) {
322         copy($_,\*ERR);
323         copy($_,$errlogs{$_}) if defined($errlogs{$_});
324         unlink($_);
325     }
326     close ERR;
327
328     if ($opts{capture}) {
329         return @r;
330     } else {
331         return $r;
332     }
333 }
334
335 sub pipe {
336     my @cmds = @_;
337     return
338         sub {
339             my @cs  = ();
340             my @dcs = ();
341             my @els = ();
342             my $counter = 0;
343             foreach (@cmds) {
344                 my ($c, $dc, @el) = $_->(++$counter);
345
346                 return () if !$c;
347
348                 push @cs, $c;
349                 push @dcs, $dc;
350                 push @els, @el;
351             }
352             return (
353                 join(" | ", @cs),
354                 join(" | ", @dcs),
355                 @els
356                 );
357     };
358 }
359
360 # Utility functions, some of which are exported on request
361
362 sub quotify {
363     # Unix setup (default if nothing else is mentioned)
364     my $arg_formatter =
365         sub { $_ = shift; /\s|[\{\}\\\$\[\]\*\?\|\&:;<>]/ ? "'$_'" : $_ };
366
367     if ( $^O eq "VMS") {        # VMS setup
368         $arg_formatter = sub {
369             $_ = shift;
370             if (/\s|["[:upper:]]/) {
371                 s/"/""/g;
372                 '"'.$_.'"';
373             } else {
374                 $_;
375             }
376         };
377     } elsif ( $^O eq "MSWin32") { # MSWin setup
378         $arg_formatter = sub {
379             $_ = shift;
380             if (/\s|["\|\&\*\;<>]/) {
381                 s/(["\\])/\\$1/g;
382                 '"'.$_.'"';
383             } else {
384                 $_;
385             }
386         };
387     }
388
389     return map { $arg_formatter->($_) } @_;
390 }
391
392 1;