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 __fixup_cmd;
  91 sub __build_cmd;
  92
  93 =head2 Main functions
  94
  95 The following functions are exported by default when using C<OpenSSL::Test>.
  96
  97 =cut
  98
  99 =over 4
 100
 101 =item B<setup "NAME">
 102
 103 C<setup> is used for initial setup, and it is mandatory that it's used.
 104 If it's not used in a OpenSSL test recipe, the rest of the recipe will
 105 most likely refuse to run.
 106
 107 C<setup> checks for environment variables (see L</ENVIRONMENT> below),
 108 check that C<$TOP/Configure> exists, C<chdir> into the results directory
 109 (defined by the C<$RESULT_D> environment variable if defined, otherwise
 110 C<$TEST_D> if defined, otherwise C<$TOP/test>).
 111
 112 =back
 113
 114 =cut
 115
 116 sub setup {
 117     $test_name = shift;
 118
 119     BAIL_OUT("setup() must receive a name") unless $test_name;
 120     BAIL_OUT("setup() needs \$TOP to be defined") unless $ENV{TOP};
 121
 122     __env();
 123
 124     BAIL_OUT("setup() expects the file Configure in the \$TOP directory")
 125         unless -f top_file("Configure");
 126
 127     __cwd($directories{RESULTS});
 128
 129     # Loop in case we're on a platform with more than one file generation
 130     1 while unlink(__test_log());
 131 }
 132
 133 =over 4
 134
 135 =item B<indir "SUBDIR" =E<gt> sub BLOCK, OPTS>
 136
 137 C<indir> is used to run a part of the recipe in a different directory than
 138 the one C<setup> moved into, usually a subdirectory, given by SUBDIR.
 139 The part of the recipe that's run there is given by the codeblock BLOCK.
 140
 141 C<indir> takes some additional options OPTS that affect the subdirectory:
 142
 143 =over 4
 144
 145 =item B<create =E<gt> 0|1>
 146
 147 When set to 1 (or any value that perl preceives as true), the subdirectory
 148 will be created if it doesn't already exist.  This happens before BLOCK
 149 is executed.
 150
 151 =item B<cleanup =E<gt> 0|1>
 152
 153 When set to 1 (or any value that perl preceives as true), the subdirectory
 154 will be cleaned out and removed.  This happens both before and after BLOCK
 155 is executed.
 156
 157 =back
 158
 159 An example:
 160
 161   indir "foo" => sub {
 162       ok(run(app(["openssl", "version"]), stdout => "foo.txt"));
 163       if (ok(open(RESULT, "foo.txt"), "reading foo.txt")) {
 164           my $line = <RESULT>;
 165           close RESULT;
 166           is($line, qr/^OpenSSL 1\./,
 167              "check that we're using OpenSSL 1.x.x");
 168       }
 169   }, create => 1, cleanup => 1;
 170
 171 =back
 172
 173 =cut
 174
 175 sub indir {
 176     my $subdir = shift;
 177     my $codeblock = shift;
 178     my %opts = @_;
 179
 180     my $reverse = __cwd($subdir,%opts);
 181     BAIL_OUT("FAILURE: indir, \"$subdir\" wasn't possible to move into")
 182         unless $reverse;
 183
 184     $codeblock->();
 185
 186     __cwd($reverse);
 187
 188     if ($opts{cleanup}) {
 189         remove_tree($subdir, { safe => 0 });
 190     }
 191 }
 192
 193 =over 4
 194
 195 =item B<app ARRAYREF, OPTS>
 196
 197 =item B<test ARRAYREF, OPTS>
 198
 199 Both of these functions take a reference to a list that is a command and
 200 its arguments, and some additional options (described further on).
 201
 202 C<app> expects to find the given command (the first item in the given list
 203 reference) as an executable in C<$BIN_D> (if defined, otherwise C<$TOP/apps>).
 204
 205 C<test> expects to find the given command (the first item in the given list
 206 reference) as an executable in C<$TEST_D> (if defined, otherwise C<$TOP/test>).
 207
 208 Both return a CODEREF to be used by C<run>, C<pipe> or C<cmdstr>.
 209
 210 The options that both C<app> and C<test> can take are in the form of hash
 211 values:
 212
 213 =over 4
 214
 215 =item B<stdin =E<gt> PATH>
 216
 217 =item B<stdout =E<gt> PATH>
 218
 219 =item B<stderr =E<gt> PATH>
 220
 221 In all three cases, the corresponding standard input, output or error is
 222 redirected from (for stdin) or to (for the others) a file given by the
 223 string PATH, I<or>, if the value is C<undef>, C</dev/null> or similar.
 224
 225 =back
 226
 227 =back
 228
 229 =cut
 230
 231 sub app {
 232     my $cmd = shift;
 233     my %opts = @_;
 234     return sub { my $num = shift;
 235                  return __build_cmd($num, \&__apps_file, $cmd, %opts); }
 236 }
 237
 238 sub test {
 239     my $cmd = shift;
 240     my %opts = @_;
 241     return sub { my $num = shift;
 242                  return __build_cmd($num, \&__test_file, $cmd, %opts); }
 243 }
 244
 245 =over 4
 246
 247 =item B<run CODEREF, OPTS>
 248
 249 This CODEREF is expected to be the value return by C<app> or C<test>,
 250 anything else will most likely cause an error unless you know what you're
 251 doing.
 252
 253 C<run> executes the command returned by CODEREF and return either the
 254 resulting output (if the option C<capture> is set true) or a boolean indicating
 255 if the command succeeded or not.
 256
 257 The options that C<run> can take are in the form of hash values:
 258
 259 =over 4
 260
 261 =item B<capture =E<gt> 0|1>
 262
 263 If true, the command will be executed with a perl backtick, and C<run> will
 264 return the resulting output as an array of lines.  If false or not given,
 265 the command will be executed with C<system()>, and C<run> will return 1 if
 266 the command was successful or 0 if it wasn't.
 267
 268 =back
 269
 270 For further discussion on what is considered a successful command or not, see
 271 the function C<with> further down.
 272
 273 =back
 274
 275 =cut
 276
 277 sub run {
 278     my ($cmd, $display_cmd, %errlogs) = shift->(0);
 279     my %opts = @_;
 280
 281     return () if !$cmd;
 282
 283     my $prefix = "";
 284     if ( $^O eq "VMS" ) {       # VMS
 285         $prefix = "pipe ";
 286     }
 287
 288     my @r = ();
 289     my $r = 0;
 290     my $e = 0;
 291     if ($opts{capture}) {
 292         @r = `$prefix$cmd`;
 293         $e = $? >> 8;
 294     } else {
 295         system("$prefix$cmd");
 296         $e = $? >> 8;
 297         $r = $hooks{exit_checker}->($e);
 298     }
 299
 300     # At this point, $? stops being interesting, and unfortunately,
 301     # there are Test::More versions that get picky if we leave it
 302     # non-zero.
 303     $? = 0;
 304
 305     open ERR, ">>", __test_log();
 306     { local $| = 1; print ERR "$display_cmd => $e\n"; }
 307     foreach (keys %errlogs) {
 308         copy($_,\*ERR);
 309         copy($_,$errlogs{$_}) if defined($errlogs{$_});
 310         unlink($_);
 311     }
 312     close ERR;
 313
 314     if ($opts{capture}) {
 315         return @r;
 316     } else {
 317         return $r;
 318     }
 319 }
 320
 321 END {
 322     my $tb = Test::More->builder;
 323     my $failure = scalar(grep { $_ == 0; } $tb->summary);
 324     if ($failure && $end_with_bailout) {
 325         BAIL_OUT("Stoptest!");
 326     }
 327 }
 328
 329 =head2 Utility functions
 330
 331 The following functions are exported on request when using C<OpenSSL::Test>.
 332
 333   # To only get the top_file function.
 334   use OpenSSL::Test qw/top_file/;
 335
 336   # To only get the top_file function in addition to the default ones.
 337   use OpenSSL::Test qw/:DEFAULT top_file/;
 338
 339 =cut
 340
 341 # Utility functions, exported on request
 342
 343 =over 4
 344
 345 =item B<top_dir LIST>
 346
 347 LIST is a list of directories that make up a path from the top of the OpenSSL
 348 source directory (as indicated by the environment variable C<$TOP>).
 349 C<top_dir> returns the resulting directory as a string, adapted to the local
 350 operating system.
 351
 352 =back
 353
 354 =cut
 355
 356 sub top_dir {
 357     return __top_dir(@_);       # This caters for operating systems that have
 358                                 # a very distinct syntax for directories.
 359 }
 360
 361 =over 4
 362
 363 =item B<top_file LIST, FILENAME>
 364
 365 LIST is a list of directories that make up a path from the top of the OpenSSL
 366 source directory (as indicated by the environment variable C<$TOP>) and
 367 FILENAME is the name of a file located in that directory path.
 368 C<top_file> returns the resulting file path as a string, adapted to the local
 369 operating system.
 370
 371 =back
 372
 373 =cut
 374
 375 sub top_file {
 376     return __top_file(@_);
 377 }
 378
 379 =over 4
 380
 381 =item B<pipe LIST>
 382
 383 LIST is a list of CODEREFs returned by C<app> or C<test>, from which C<pipe>
 384 creates a new command composed of all the given commands put together in a
 385 pipe.  C<pipe> returns a new CODEREF in the same manner as C<app> or C<test>,
 386 to be passed to C<run> for execution.
 387
 388 =back
 389
 390 =cut
 391
 392 sub pipe {
 393     my @cmds = @_;
 394     return
 395         sub {
 396             my @cs  = ();
 397             my @dcs = ();
 398             my @els = ();
 399             my $counter = 0;
 400             foreach (@cmds) {
 401                 my ($c, $dc, @el) = $_->(++$counter);
 402
 403                 return () if !$c;
 404
 405                 push @cs, $c;
 406                 push @dcs, $dc;
 407                 push @els, @el;
 408             }
 409             return (
 410                 join(" | ", @cs),
 411                 join(" | ", @dcs),
 412                 @els
 413                 );
 414     };
 415 }
 416
 417 =over 4
 418
 419 =item B<with HASHREF, CODEREF>
 420
 421 C<with> will temporarly install hooks given by the HASHREF and then execute
 422 the given CODEREF.  Hooks are usually expected to have a coderef as value.
 423
 424 The currently available hoosk are:
 425
 426 =over 4
 427
 428 =item B<exit_checker =E<gt> CODEREF>
 429
 430 This hook is executed after C<run> has performed its given command.  The
 431 CODEREF receives the exit code as only argument and is expected to return
 432 1 (if the exit code indicated success) or 0 (if the exit code indicated
 433 failure).
 434
 435 =back
 436
 437 =back
 438
 439 =cut
 440
 441 sub with {
 442     my $opts = shift;
 443     my %opts = %{$opts};
 444     my $codeblock = shift;
 445
 446     my %saved_hooks = ();
 447
 448     foreach (keys %opts) {
 449         $saved_hooks{$_} = $hooks{$_}   if exists($hooks{$_});
 450         $hooks{$_} = $opts{$_};
 451     }
 452
 453     $codeblock->();
 454
 455     foreach (keys %saved_hooks) {
 456         $hooks{$_} = $saved_hooks{$_};
 457     }
 458 }
 459
 460 =over 4
 461
 462 =item B<cmdstr CODEREF>
 463
 464 C<cmdstr> takes a CODEREF from C<app> or C<test> and simply returns the
 465 command as a string.
 466
 467 =back
 468
 469 =cut
 470
 471 sub cmdstr {
 472     my ($cmd, $display_cmd, %errlogs) = shift->(0);
 473
 474     return $display_cmd;
 475 }
 476
 477 =over 4
 478
 479 =item B<quotify LIST>
 480
 481 LIST is a list of strings that are going to be used as arguments for a
 482 command, and makes sure to inject quotes and escapes as necessary depending
 483 on the content of each string.
 484
 485 This can also be used to put quotes around the executable of a command.
 486 I<This must never ever be done on VMS.>
 487
 488 =back
 489
 490 =cut
 491
 492 sub quotify {
 493     # Unix setup (default if nothing else is mentioned)
 494     my $arg_formatter =
 495         sub { $_ = shift; /\s|[\{\}\\\$\[\]\*\?\|\&:;<>]/ ? "'$_'" : $_ };
 496
 497     if ( $^O eq "VMS") {        # VMS setup
 498         $arg_formatter = sub {
 499             $_ = shift;
 500             if (/\s|["[:upper:]]/) {
 501                 s/"/""/g;
 502                 '"'.$_.'"';
 503             } else {
 504                 $_;
 505             }
 506         };
 507     } elsif ( $^O eq "MSWin32") { # MSWin setup
 508         $arg_formatter = sub {
 509             $_ = shift;
 510             if (/\s|["\|\&\*\;<>]/) {
 511                 s/(["\\])/\\$1/g;
 512                 '"'.$_.'"';
 513             } else {
 514                 $_;
 515             }
 516         };
 517     }
 518
 519     return map { $arg_formatter->($_) } @_;
 520 }
 521
 522 ######################################################################
 523 # private functions.  These are never exported.
 524
 525 =head1 ENVIRONMENT
 526
 527 OpenSSL::Test depends on some environment variables.
 528
 529 =over 4
 530
 531 =item B<TOP>
 532
 533 This environment variable is mandatory.  C<setup> will check that it's
 534 defined and that it's a directory that contains the file C<Configure>.
 535 If this isn't so, C<setup> will C<BAIL_OUT>.
 536
 537 =item B<BIN_D>
 538
 539 If defined, its value should be the directory where the openssl application
 540 is located.  Defaults to C<$TOP/apps> (adapted to the operating system).
 541
 542 =item B<TEST_D>
 543
 544 If defined, its value should be the directory where the test applications
 545 are located.  Defaults to C<$TOP/test> (adapted to the operating system).
 546
 547 =item B<RESULT_D>
 548
 549 If defined, its value should be the directory where the log files are
 550 located.  Defaults to C<$TEST_D>.
 551
 552 =item B<STOPTEST>
 553
 554 If defined, it puts testing in a different mode, where a recipe with
 555 failures will result in a C<BAIL_OUT> at the end of its run.
 556
 557 =back
 558
 559 =cut
 560
 561 sub __env {
 562     $directories{TOP}     = $ENV{TOP},
 563     $directories{APPS}    = $ENV{BIN_D}    || catdir($directories{TOP},"apps");
 564     $directories{TEST}    = $ENV{TEST_D}   || catdir($directories{TOP},"test");
 565     $directories{RESULTS} = $ENV{RESULT_D} || $directories{TEST};
 566
 567     $end_with_bailout     = $ENV{STOPTEST} ? 1 : 0;
 568 };
 569
 570 sub __top_file {
 571     BAIL_OUT("Must run setup() first") if (! $test_name);
 572
 573     my $f = pop;
 574     return catfile($directories{TOP},@_,$f);
 575 }
 576
 577 sub __top_dir {
 578     BAIL_OUT("Must run setup() first") if (! $test_name);
 579
 580     return catdir($directories{TOP},@_);
 581 }
 582
 583 sub __test_file {
 584     BAIL_OUT("Must run setup() first") if (! $test_name);
 585
 586     my $f = pop;
 587     return catfile($directories{TEST},@_,$f);
 588 }
 589
 590 sub __apps_file {
 591     BAIL_OUT("Must run setup() first") if (! $test_name);
 592
 593     my $f = pop;
 594     return catfile($directories{APPS},@_,$f);
 595 }
 596
 597 sub __results_file {
 598     BAIL_OUT("Must run setup() first") if (! $test_name);
 599
 600     my $f = pop;
 601     return catfile($directories{RESULTS},@_,$f);
 602 }
 603
 604 sub __test_log {
 605     return __results_file("$test_name.log");
 606 }
 607
 608 sub __cwd {
 609     my $dir = catdir(shift);
 610     my %opts = @_;
 611     my $abscurdir = rel2abs(curdir());
 612     my $absdir = rel2abs($dir);
 613     my $reverse = abs2rel($abscurdir, $absdir);
 614
 615     # PARANOIA: if we're not moving anywhere, we do nothing more
 616     if ($abscurdir eq $absdir) {
 617         return $reverse;
 618     }
 619
 620     # Do not support a move to a different volume for now.  Maybe later.
 621     BAIL_OUT("FAILURE: \"$dir\" moves to a different volume, not supported")
 622         if $reverse eq $abscurdir;
 623
 624     # If someone happened to give a directory that leads back to the current,
 625     # it's extremely silly to do anything more, so just simulate that we did
 626     # move.
 627     # In this case, we won't even clean it out, for safety's sake.
 628     return "." if $reverse eq "";
 629
 630     $dir = canonpath($dir);
 631     if ($opts{create}) {
 632         mkpath($dir);
 633     }
 634
 635     # Should we just bail out here as well?  I'm unsure.
 636     return undef unless chdir($dir);
 637
 638     if ($opts{cleanup}) {
 639         remove_tree(".", { safe => 0, keep_root => 1 });
 640     }
 641
 642     # For each of these directory variables, figure out where they are relative
 643     # to the directory we want to move to if they aren't absolute (if they are,
 644     # they don't change!)
 645     my @dirtags = ("TOP", "TEST", "APPS", "RESULTS");
 646     foreach (@dirtags) {
 647         if (!file_name_is_absolute($directories{$_})) {
 648             my $newpath = abs2rel(rel2abs($directories{$_}), rel2abs($dir));
 649             $directories{$_} = $newpath;
 650         }
 651     }
 652
 653     if (0) {
 654         print STDERR "DEBUG: __cwd(), directories and files:\n";
 655         print STDERR "  \$directories{TEST}    = \"$directories{TEST}\"\n";
 656         print STDERR "  \$directories{RESULTS} = \"$directories{RESULTS}\"\n";
 657         print STDERR "  \$directories{APPS}    = \"$directories{APPS}\"\n";
 658         print STDERR "  \$directories{TOP}     = \"$directories{TOP}\"\n";
 659         print STDERR "  \$test_log             = \"",__test_log(),"\"\n";
 660         print STDERR "\n";
 661         print STDERR "  current directory is \"",curdir(),"\"\n";
 662         print STDERR "  the way back is \"$reverse\"\n";
 663     }
 664
 665     return $reverse;
 666 }
 667
 668 sub __fixup_cmd {
 669     my $prog = shift;
 670
 671     my $prefix = __top_file("util", "shlib_wrap.sh")." ";
 672     my $ext = $ENV{"EXE_EXT"} || "";
 673
 674     if (defined($ENV{EXE_SHELL})) {
 675         $prefix = "$ENV{EXE_SHELL} ";
 676     } elsif ($^O eq "VMS" ) {   # VMS
 677         $prefix = ($prog =~ /^[<\[]/ ? "mcr " : "mcr []");
 678         $ext = ".exe";
 679     } elsif ($^O eq "MSWin32") { # Windows
 680         $prefix = "";
 681         $ext = ".exe";
 682     }
 683
 684     # We test both with and without extension.  The reason
 685     # is that we might, for example, be passed a Perl script
 686     # ending with .pl...
 687     my $file = "$prog$ext";
 688     if ( -x $file ) {
 689         return $prefix.$file;
 690     } elsif ( -f $prog ) {
 691         return $prog;
 692     }
 693
 694     print STDERR "$prog not found\n";
 695     return undef;
 696 }
 697
 698 sub __build_cmd {
 699     BAIL_OUT("Must run setup() first") if (! $test_name);
 700
 701     my $num = shift;
 702     my $path_builder = shift;
 703     # Make a copy to not destroy the caller's array
 704     my @cmdarray = ( @{$_[0]} ); shift;
 705     my $cmd = __fixup_cmd($path_builder->(shift @cmdarray));
 706     my @args = @cmdarray;
 707     my %opts = @_;
 708
 709     return () if !$cmd;
 710
 711     my $arg_str = "";
 712     my $null = devnull();
 713
 714
 715     $arg_str = " ".join(" ", quotify @args) if @args;
 716
 717     my $fileornull = sub { $_[0] ? $_[0] : $null; };
 718     my $stdin = "";
 719     my $stdout = "";
 720     my $stderr = "";
 721     my $saved_stderr = undef;
 722     $stdin = " < ".$fileornull->($opts{stdin})  if exists($opts{stdin});
 723     $stdout= " > ".$fileornull->($opts{stdout}) if exists($opts{stdout});
 724     $stderr=" 2> ".$fileornull->($opts{stderr}) if exists($opts{stderr});
 725
 726     $saved_stderr = $opts{stderr}               if defined($opts{stderr});
 727
 728     my $errlog =
 729         __results_file($num ? "$test_name.$num.tmp_err" : "$test_name.tmp_err");
 730     my $display_cmd = "$cmd$arg_str$stdin$stdout$stderr";
 731     $cmd .= "$arg_str$stdin$stdout 2> $errlog";
 732
 733     return ($cmd, $display_cmd, $errlog => $saved_stderr);
 734 }
 735
 736 =head1 SEE ALSO
 737
 738 L<Test::More>, L<Test::Harness>
 739
 740 =head1 AUTHORS
 741
 742 Richard Levitte E<lt>levitte@openssl.orgE<gt> with assitance and
 743 inspiration from Andy Polyakov E<lt>appro@openssl.org<gt>.
 744
 745 =cut
 746
 747 1;