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;