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     }
 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 END {
 323     my $tb = Test::More->builder;
 324     my $failure = scalar(grep { $_ == 0; } $tb->summary);
 325     if ($failure && $end_with_bailout) {
 326         BAIL_OUT("Stoptest!");
 327     }
 328 }
 329
 330 =head2 Utility functions
 331
 332 The following functions are exported on request when using C<OpenSSL::Test>.
 333
 334   # To only get the top_file function.
 335   use OpenSSL::Test qw/top_file/;
 336
 337   # To only get the top_file function in addition to the default ones.
 338   use OpenSSL::Test qw/:DEFAULT top_file/;
 339
 340 =cut
 341
 342 # Utility functions, exported on request
 343
 344 =over 4
 345
 346 =item B<top_dir LIST>
 347
 348 LIST is a list of directories that make up a path from the top of the OpenSSL
 349 source directory (as indicated by the environment variable C<$TOP>).
 350 C<top_dir> returns the resulting directory as a string, adapted to the local
 351 operating system.
 352
 353 =back
 354
 355 =cut
 356
 357 sub top_dir {
 358     return __top_dir(@_);       # This caters for operating systems that have
 359                                 # a very distinct syntax for directories.
 360 }
 361
 362 =over 4
 363
 364 =item B<top_file LIST, FILENAME>
 365
 366 LIST is a list of directories that make up a path from the top of the OpenSSL
 367 source directory (as indicated by the environment variable C<$TOP>) and
 368 FILENAME is the name of a file located in that directory path.
 369 C<top_file> returns the resulting file path as a string, adapted to the local
 370 operating system.
 371
 372 =back
 373
 374 =cut
 375
 376 sub top_file {
 377     return __top_file(@_);
 378 }
 379
 380 =over 4
 381
 382 =item B<pipe LIST>
 383
 384 LIST is a list of CODEREFs returned by C<app> or C<test>, from which C<pipe>
 385 creates a new command composed of all the given commands put together in a
 386 pipe.  C<pipe> returns a new CODEREF in the same manner as C<app> or C<test>,
 387 to be passed to C<run> for execution.
 388
 389 =back
 390
 391 =cut
 392
 393 sub pipe {
 394     my @cmds = @_;
 395     return
 396         sub {
 397             my @cs  = ();
 398             my @dcs = ();
 399             my @els = ();
 400             my $counter = 0;
 401             foreach (@cmds) {
 402                 my ($c, $dc, @el) = $_->(++$counter);
 403
 404                 return () if !$c;
 405
 406                 push @cs, $c;
 407                 push @dcs, $dc;
 408                 push @els, @el;
 409             }
 410             return (
 411                 join(" | ", @cs),
 412                 join(" | ", @dcs),
 413                 @els
 414                 );
 415     };
 416 }
 417
 418 =over 4
 419
 420 =item B<with HASHREF, CODEREF>
 421
 422 C<with> will temporarly install hooks given by the HASHREF and then execute
 423 the given CODEREF.  Hooks are usually expected to have a coderef as value.
 424
 425 The currently available hoosk are:
 426
 427 =over 4
 428
 429 =item B<exit_checker =E<gt> CODEREF>
 430
 431 This hook is executed after C<run> has performed its given command.  The
 432 CODEREF receives the exit code as only argument and is expected to return
 433 1 (if the exit code indicated success) or 0 (if the exit code indicated
 434 failure).
 435
 436 =back
 437
 438 =back
 439
 440 =cut
 441
 442 sub with {
 443     my $opts = shift;
 444     my %opts = %{$opts};
 445     my $codeblock = shift;
 446
 447     my %saved_hooks = ();
 448
 449     foreach (keys %opts) {
 450         $saved_hooks{$_} = $hooks{$_}   if exists($hooks{$_});
 451         $hooks{$_} = $opts{$_};
 452     }
 453
 454     $codeblock->();
 455
 456     foreach (keys %saved_hooks) {
 457         $hooks{$_} = $saved_hooks{$_};
 458     }
 459 }
 460
 461 =over 4
 462
 463 =item B<cmdstr CODEREF>
 464
 465 C<cmdstr> takes a CODEREF from C<app> or C<test> and simply returns the
 466 command as a string.
 467
 468 =back
 469
 470 =cut
 471
 472 sub cmdstr {
 473     my ($cmd, $display_cmd, %errlogs) = shift->(0);
 474
 475     return $display_cmd;
 476 }
 477
 478 =over 4
 479
 480 =item B<quotify LIST>
 481
 482 LIST is a list of strings that are going to be used as arguments for a
 483 command, and makes sure to inject quotes and escapes as necessary depending
 484 on the content of each string.
 485
 486 This can also be used to put quotes around the executable of a command.
 487 I<This must never ever be done on VMS.>
 488
 489 =back
 490
 491 =cut
 492
 493 sub quotify {
 494     # Unix setup (default if nothing else is mentioned)
 495     my $arg_formatter =
 496         sub { $_ = shift; /\s|[\{\}\\\$\[\]\*\?\|\&:;<>]/ ? "'$_'" : $_ };
 497
 498     if ( $^O eq "VMS") {        # VMS setup
 499         $arg_formatter = sub {
 500             $_ = shift;
 501             if (/\s|["[:upper:]]/) {
 502                 s/"/""/g;
 503                 '"'.$_.'"';
 504             } else {
 505                 $_;
 506             }
 507         };
 508     } elsif ( $^O eq "MSWin32") { # MSWin setup
 509         $arg_formatter = sub {
 510             $_ = shift;
 511             if (/\s|["\|\&\*\;<>]/) {
 512                 s/(["\\])/\\$1/g;
 513                 '"'.$_.'"';
 514             } else {
 515                 $_;
 516             }
 517         };
 518     }
 519
 520     return map { $arg_formatter->($_) } @_;
 521 }
 522
 523 ######################################################################
 524 # private functions.  These are never exported.
 525
 526 =head1 ENVIRONMENT
 527
 528 OpenSSL::Test depends on some environment variables.
 529
 530 =over 4
 531
 532 =item B<TOP>
 533
 534 This environment variable is mandatory.  C<setup> will check that it's
 535 defined and that it's a directory that contains the file C<Configure>.
 536 If this isn't so, C<setup> will C<BAIL_OUT>.
 537
 538 =item B<BIN_D>
 539
 540 If defined, its value should be the directory where the openssl application
 541 is located.  Defaults to C<$TOP/apps> (adapted to the operating system).
 542
 543 =item B<TEST_D>
 544
 545 If defined, its value should be the directory where the test applications
 546 are located.  Defaults to C<$TOP/test> (adapted to the operating system).
 547
 548 =item B<RESULT_D>
 549
 550 If defined, its value should be the directory where the log files are
 551 located.  Defaults to C<$TEST_D>.
 552
 553 =item B<STOPTEST>
 554
 555 If defined, it puts testing in a different mode, where a recipe with
 556 failures will result in a C<BAIL_OUT> at the end of its run.
 557
 558 =back
 559
 560 =cut
 561
 562 sub __env {
 563     $directories{TOP}     = $ENV{TOP},
 564     $directories{APPS}    = $ENV{BIN_D}    || catdir($directories{TOP},"apps");
 565     $directories{TEST}    = $ENV{TEST_D}   || catdir($directories{TOP},"test");
 566     $directories{RESULTS} = $ENV{RESULT_D} || $directories{TEST};
 567
 568     $end_with_bailout     = $ENV{STOPTEST} ? 1 : 0;
 569 };
 570
 571 sub __top_file {
 572     BAIL_OUT("Must run setup() first") if (! $test_name);
 573
 574     my $f = pop;
 575     return catfile($directories{TOP},@_,$f);
 576 }
 577
 578 sub __top_dir {
 579     BAIL_OUT("Must run setup() first") if (! $test_name);
 580
 581     return catdir($directories{TOP},@_);
 582 }
 583
 584 sub __test_file {
 585     BAIL_OUT("Must run setup() first") if (! $test_name);
 586
 587     my $f = pop;
 588     return catfile($directories{TEST},@_,$f);
 589 }
 590
 591 sub __apps_file {
 592     BAIL_OUT("Must run setup() first") if (! $test_name);
 593
 594     my $f = pop;
 595     return catfile($directories{APPS},@_,$f);
 596 }
 597
 598 sub __results_file {
 599     BAIL_OUT("Must run setup() first") if (! $test_name);
 600
 601     my $f = pop;
 602     return catfile($directories{RESULTS},@_,$f);
 603 }
 604
 605 sub __test_log {
 606     return __results_file("$test_name.log");
 607 }
 608
 609 sub __cwd {
 610     my $dir = shift;
 611     my %opts = @_;
 612     my $abscurdir = rel2abs(curdir());
 613     my $absdir = rel2abs($dir);
 614     my $reverse = abs2rel($abscurdir, $absdir);
 615
 616     # PARANOIA: if we're not moving anywhere, we do nothing more
 617     if ($abscurdir eq $absdir) {
 618         return $reverse;
 619     }
 620
 621     # Do not support a move to a different volume for now.  Maybe later.
 622     BAIL_OUT("FAILURE: \"$dir\" moves to a different volume, not supported")
 623         if $reverse eq $abscurdir;
 624
 625     # If someone happened to give a directory that leads back to the current,
 626     # it's extremely silly to do anything more, so just simulate that we did
 627     # move.
 628     # In this case, we won't even clean it out, for safety's sake.
 629     return "." if $reverse eq "";
 630
 631     $dir = canonpath($dir);
 632     if ($opts{create}) {
 633         mkpath($dir);
 634     }
 635
 636     # Should we just bail out here as well?  I'm unsure.
 637     return undef unless chdir($dir);
 638
 639     if ($opts{cleanup}) {
 640         remove_tree(".", { safe => 0, keep_root => 1 });
 641     }
 642
 643     # For each of these directory variables, figure out where they are relative
 644     # to the directory we want to move to if they aren't absolute (if they are,
 645     # they don't change!)
 646     my @dirtags = ("TOP", "TEST", "APPS", "RESULTS");
 647     foreach (@dirtags) {
 648         if (!file_name_is_absolute($directories{$_})) {
 649             my $newpath = abs2rel(rel2abs($directories{$_}), rel2abs($dir));
 650             $directories{$_} = $newpath;
 651         }
 652     }
 653
 654     if (0) {
 655         print STDERR "DEBUG: __cwd(), directories and files:\n";
 656         print STDERR "  \$directories{TEST}    = \"$directories{TEST}\"\n";
 657         print STDERR "  \$directories{RESULTS} = \"$directories{RESULTS}\"\n";
 658         print STDERR "  \$directories{APPS}    = \"$directories{APPS}\"\n";
 659         print STDERR "  \$directories{TOP}     = \"$directories{TOP}\"\n";
 660         print STDERR "  \$test_log             = \"",__test_log(),"\"\n";
 661         print STDERR "\n";
 662         print STDERR "  current directory is \"",curdir(),"\"\n";
 663         print STDERR "  the way back is \"$reverse\"\n";
 664     }
 665
 666     return $reverse;
 667 }
 668
 669 sub __fixup_cmd {
 670     my $prog = shift;
 671
 672     my $prefix = __top_file("util", "shlib_wrap.sh")." ";
 673     my $ext = $ENV{"EXE_EXT"} || "";
 674
 675     if (defined($ENV{EXE_SHELL})) {
 676         $prefix = "$ENV{EXE_SHELL} ";
 677     } elsif ($^O eq "VMS" ) {   # VMS
 678         $prefix = "mcr ";
 679         $ext = ".exe";
 680     } elsif ($^O eq "MSWin32") { # Windows
 681         $prefix = "";
 682         $ext = ".exe";
 683     }
 684
 685     # We test both with and without extension.  The reason
 686     # is that we might, for example, be passed a Perl script
 687     # ending with .pl...
 688     my $file = "$prog$ext";
 689     if ( -x $file ) {
 690         return $prefix.$file;
 691     } elsif ( -f $prog ) {
 692         return $prog;
 693     }
 694
 695     print STDERR "$prog not found\n";
 696     return undef;
 697 }
 698
 699 sub __build_cmd {
 700     BAIL_OUT("Must run setup() first") if (! $test_name);
 701
 702     my $num = shift;
 703     my $path_builder = shift;
 704     # Make a copy to not destroy the caller's array
 705     my @cmdarray = ( @{$_[0]} ); shift;
 706     my $cmd = __fixup_cmd($path_builder->(shift @cmdarray));
 707     my @args = @cmdarray;
 708     my %opts = @_;
 709
 710     return () if !$cmd;
 711
 712     my $arg_str = "";
 713     my $null = devnull();
 714
 715
 716     $arg_str = " ".join(" ", quotify @args) if @args;
 717
 718     my $fileornull = sub { $_[0] ? $_[0] : $null; };
 719     my $stdin = "";
 720     my $stdout = "";
 721     my $stderr = "";
 722     my $saved_stderr = undef;
 723     $stdin = " < ".$fileornull->($opts{stdin})  if exists($opts{stdin});
 724     $stdout= " > ".$fileornull->($opts{stdout}) if exists($opts{stdout});
 725     $stderr=" 2> ".$fileornull->($opts{stderr}) if exists($opts{stderr});
 726
 727     $saved_stderr = $opts{stderr}               if defined($opts{stderr});
 728
 729     my $errlog =
 730         __results_file($num ? "$test_name.$num.tmp_err" : "$test_name.tmp_err");
 731     my $display_cmd = "$cmd$arg_str$stdin$stdout$stderr";
 732     $cmd .= "$arg_str$stdin$stdout 2> $errlog";
 733
 734     return ($cmd, $display_cmd, $errlog => $saved_stderr);
 735 }
 736
 737 =head1 SEE ALSO
 738
 739 L<Test::More>, L<Test::Harness>
 740
 741 =head1 AUTHORS
 742
 743 Richard Levitte E<lt>levitte@openssl.orgE<gt> with assitance and
 744 inspiration from Andy Polyakov E<lt>appro@openssl.org<gt>.
 745
 746 =cut
 747
 748 1;