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_file(@_, "");  # 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 __test_file {
 581     BAIL_OUT("Must run setup() first") if (! $test_name);
 582
 583     my $f = pop;
 584     return catfile($directories{TEST},@_,$f);
 585 }
 586
 587 sub __apps_file {
 588     BAIL_OUT("Must run setup() first") if (! $test_name);
 589
 590     my $f = pop;
 591     return catfile($directories{APPS},@_,$f);
 592 }
 593
 594 sub __results_file {
 595     BAIL_OUT("Must run setup() first") if (! $test_name);
 596
 597     my $f = pop;
 598     return catfile($directories{RESULTS},@_,$f);
 599 }
 600
 601 sub __test_log {
 602     return __results_file("$test_name.log");
 603 }
 604
 605 sub __cwd {
 606     my $dir = shift;
 607     my %opts = @_;
 608     my $abscurdir = rel2abs(curdir());
 609     my $absdir = rel2abs($dir);
 610     my $reverse = abs2rel($abscurdir, $absdir);
 611
 612     # PARANOIA: if we're not moving anywhere, we do nothing more
 613     if ($abscurdir eq $absdir) {
 614         return $reverse;
 615     }
 616
 617     # Do not support a move to a different volume for now.  Maybe later.
 618     BAIL_OUT("FAILURE: \"$dir\" moves to a different volume, not supported")
 619         if $reverse eq $abscurdir;
 620
 621     # If someone happened to give a directory that leads back to the current,
 622     # it's extremely silly to do anything more, so just simulate that we did
 623     # move.
 624     # In this case, we won't even clean it out, for safety's sake.
 625     return "." if $reverse eq "";
 626
 627     $dir = canonpath($dir);
 628     if ($opts{create}) {
 629         mkpath($dir);
 630     }
 631
 632     # Should we just bail out here as well?  I'm unsure.
 633     return undef unless chdir($dir);
 634
 635     if ($opts{cleanup}) {
 636         remove_tree(".", { safe => 0, keep_root => 1 });
 637     }
 638
 639     # For each of these directory variables, figure out where they are relative
 640     # to the directory we want to move to if they aren't absolute (if they are,
 641     # they don't change!)
 642     my @dirtags = ("TOP", "TEST", "APPS", "RESULTS");
 643     foreach (@dirtags) {
 644         if (!file_name_is_absolute($directories{$_})) {
 645             my $newpath = abs2rel(rel2abs($directories{$_}), rel2abs($dir));
 646             $directories{$_} = $newpath;
 647         }
 648     }
 649
 650     if (0) {
 651         print STDERR "DEBUG: __cwd(), directories and files:\n";
 652         print STDERR "  \$directories{TEST}    = \"$directories{TEST}\"\n";
 653         print STDERR "  \$directories{RESULTS} = \"$directories{RESULTS}\"\n";
 654         print STDERR "  \$directories{APPS}    = \"$directories{APPS}\"\n";
 655         print STDERR "  \$directories{TOP}     = \"$directories{TOP}\"\n";
 656         print STDERR "  \$test_log             = \"",__test_log(),"\"\n";
 657         print STDERR "\n";
 658         print STDERR "  current directory is \"",curdir(),"\"\n";
 659         print STDERR "  the way back is \"$reverse\"\n";
 660     }
 661
 662     return $reverse;
 663 }
 664
 665 sub __fixup_cmd {
 666     my $prog = shift;
 667
 668     my $prefix = __top_file("util", "shlib_wrap.sh")." ";
 669     my $ext = $ENV{"EXE_EXT"} || "";
 670
 671     if ( $^O eq "VMS" ) {       # VMS
 672         $prefix = "mcr ";
 673         $ext = ".exe";
 674     } elsif ($^O eq "MSWin32") { # Windows
 675         $prefix = "";
 676         $ext = ".exe";
 677     }
 678
 679     # We test both with and without extension.  The reason
 680     # is that we might, for example, be passed a Perl script
 681     # ending with .pl...
 682     my $file = "$prog$ext";
 683     if ( -x $file ) {
 684         return $prefix.$file;
 685     } elsif ( -f $prog ) {
 686         return $prog;
 687     }
 688
 689     print STDERR "$prog not found\n";
 690     return undef;
 691 }
 692
 693 sub __build_cmd {
 694     BAIL_OUT("Must run setup() first") if (! $test_name);
 695
 696     my $num = shift;
 697     my $path_builder = shift;
 698     # Make a copy to not destroy the caller's array
 699     my @cmdarray = ( @{$_[0]} ); shift;
 700     my $cmd = __fixup_cmd($path_builder->(shift @cmdarray));
 701     my @args = @cmdarray;
 702     my %opts = @_;
 703
 704     return () if !$cmd;
 705
 706     my $arg_str = "";
 707     my $null = devnull();
 708
 709
 710     $arg_str = " ".join(" ", quotify @args) if @args;
 711
 712     my $fileornull = sub { $_[0] ? $_[0] : $null; };
 713     my $stdin = "";
 714     my $stdout = "";
 715     my $stderr = "";
 716     my $saved_stderr = undef;
 717     $stdin = " < ".$fileornull->($opts{stdin})  if exists($opts{stdin});
 718     $stdout= " > ".$fileornull->($opts{stdout}) if exists($opts{stdout});
 719     $stderr=" 2> ".$fileornull->($opts{stderr}) if exists($opts{stderr});
 720
 721     $saved_stderr = $opts{stderr}               if defined($opts{stderr});
 722
 723     my $errlog =
 724         __results_file($num ? "$test_name.$num.tmp_err" : "$test_name.tmp_err");
 725     my $display_cmd = "$cmd$arg_str$stdin$stdout$stderr";
 726     $cmd .= "$arg_str$stdin$stdout 2> $errlog";
 727
 728     return ($cmd, $display_cmd, $errlog => $saved_stderr);
 729 }
 730
 731 =head1 SEE ALSO
 732
 733 L<Test::More>, L<Test::Harness>
 734
 735 =head1 AUTHORS
 736
 737 Richard Levitte E<lt>levitte@openssl.orgE<gt> with assitance and
 738 inspiration from Andy Polyakov E<lt>appro@openssl.org<gt>.
 739
 740 =cut
 741
 742 1;