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