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