util/perl/OpenSSL/Test.pm

   1 # Copyright 2016-2021 The OpenSSL Project Authors. All Rights Reserved.
   2 #
   3 # Licensed under the Apache License 2.0 (the "License").  You may not use
   4 # this file except in compliance with the License.  You can obtain a copy
   5 # in the file LICENSE in the source distribution or at
   6 # https://www.openssl.org/source/license.html
   7
   8 package OpenSSL::Test;
   9
  10 use strict;
  11 use warnings;
  12
  13 use Test::More 0.96;
  14
  15 use Exporter;
  16 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  17 $VERSION = "1.0";
  18 @ISA = qw(Exporter);
  19 @EXPORT = (@Test::More::EXPORT, qw(setup run indir cmd app fuzz test
  20                                    perlapp perltest subtest));
  21 @EXPORT_OK = (@Test::More::EXPORT_OK, qw(bldtop_dir bldtop_file
  22                                          srctop_dir srctop_file
  23                                          data_file data_dir
  24                                          result_file result_dir
  25                                          pipe with cmdstr quotify
  26                                          openssl_versions
  27                                          ok_nofips is_nofips isnt_nofips));
  28
  29 =head1 NAME
  30
  31 OpenSSL::Test - a private extension of Test::More
  32
  33 =head1 SYNOPSIS
  34
  35   use OpenSSL::Test;
  36
  37   setup("my_test_name");
  38
  39   plan tests => 2;
  40
  41   ok(run(app(["openssl", "version"])), "check for openssl presence");
  42
  43   indir "subdir" => sub {
  44     ok(run(test(["sometest", "arg1"], stdout => "foo.txt")),
  45        "run sometest with output to foo.txt");
  46   };
  47
  48 =head1 DESCRIPTION
  49
  50 This module is a private extension of L<Test::More> for testing OpenSSL.
  51 In addition to the Test::More functions, it also provides functions that
  52 easily find the diverse programs within a OpenSSL build tree, as well as
  53 some other useful functions.
  54
  55 This module I<depends> on the environment variables C<$TOP> or C<$SRCTOP>
  56 and C<$BLDTOP>.  Without one of the combinations it refuses to work.
  57 See L</ENVIRONMENT> below.
  58
  59 With each test recipe, a parallel data directory with (almost) the same name
  60 as the recipe is possible in the source directory tree.  For example, for a
  61 recipe C<$SRCTOP/test/recipes/99-foo.t>, there could be a directory
  62 C<$SRCTOP/test/recipes/99-foo_data/>.
  63
  64 =cut
  65
  66 use File::Copy;
  67 use File::Spec::Functions qw/file_name_is_absolute curdir canonpath splitdir
  68                              catdir catfile splitpath catpath devnull abs2rel/;
  69 use File::Path 2.00 qw/rmtree mkpath/;
  70 use File::Basename;
  71 use Cwd qw/getcwd abs_path/;
  72
  73 my $level = 0;
  74
  75 # The name of the test.  This is set by setup() and is used in the other
  76 # functions to verify that setup() has been used.
  77 my $test_name = undef;
  78
  79 # Directories we want to keep track of TOP, APPS, TEST and RESULTS are the
  80 # ones we're interested in, corresponding to the environment variables TOP
  81 # (mandatory), BIN_D, TEST_D, UTIL_D and RESULT_D.
  82 my %directories = ();
  83
  84 # The environment variables that gave us the contents in %directories.  These
  85 # get modified whenever we change directories, so that subprocesses can use
  86 # the values of those environment variables as well
  87 my @direnv = ();
  88
  89 # A bool saying if we shall stop all testing if the current recipe has failing
  90 # tests or not.  This is set by setup() if the environment variable STOPTEST
  91 # is defined with a non-empty value.
  92 my $end_with_bailout = 0;
  93
  94 # A set of hooks that is affected by with() and may be used in diverse places.
  95 # All hooks are expected to be CODE references.
  96 my %hooks = (
  97
  98     # exit_checker is used by run() directly after completion of a command.
  99     # it receives the exit code from that command and is expected to return
 100     # 1 (for success) or 0 (for failure).  This is the status value that run()
 101     # will give back (through the |statusvar| reference and as returned value
 102     # when capture => 1 doesn't apply).
 103     exit_checker => sub { return shift == 0 ? 1 : 0 },
 104
 105     );
 106
 107 # Debug flag, to be set manually when needed
 108 my $debug = 0;
 109
 110 =head2 Main functions
 111
 112 The following functions are exported by default when using C<OpenSSL::Test>.
 113
 114 =cut
 115
 116 =over 4
 117
 118 =item B<setup "NAME">
 119
 120 C<setup> is used for initial setup, and it is mandatory that it's used.
 121 If it's not used in a OpenSSL test recipe, the rest of the recipe will
 122 most likely refuse to run.
 123
 124 C<setup> checks for environment variables (see L</ENVIRONMENT> below),
 125 checks that C<$TOP/Configure> or C<$SRCTOP/Configure> exists, C<chdir>
 126 into the results directory (defined by the C<$RESULT_D> environment
 127 variable if defined, otherwise C<$BLDTOP/test-runs> or C<$TOP/test-runs>,
 128 whichever is defined).
 129
 130 =back
 131
 132 =cut
 133
 134 sub setup {
 135     my $old_test_name = $test_name;
 136     $test_name = shift;
 137     my %opts = @_;
 138
 139     BAIL_OUT("setup() must receive a name") unless $test_name;
 140     warn "setup() detected test name change.  Innocuous, so we continue...\n"
 141         if $old_test_name && $old_test_name ne $test_name;
 142
 143     return if $old_test_name;
 144
 145     BAIL_OUT("setup() needs \$TOP or \$SRCTOP and \$BLDTOP to be defined")
 146         unless $ENV{TOP} || ($ENV{SRCTOP} && $ENV{BLDTOP});
 147     BAIL_OUT("setup() found both \$TOP and \$SRCTOP or \$BLDTOP...")
 148         if $ENV{TOP} && ($ENV{SRCTOP} || $ENV{BLDTOP});
 149
 150     __env();
 151
 152     BAIL_OUT("setup() expects the file Configure in the source top directory")
 153         unless -f srctop_file("Configure");
 154
 155     note "The results of this test will end up in $directories{RESULTS}"
 156         unless $opts{quiet};
 157
 158     __cwd($directories{RESULTS});
 159 }
 160
 161 =over 4
 162
 163 =item B<indir "SUBDIR" =E<gt> sub BLOCK, OPTS>
 164
 165 C<indir> is used to run a part of the recipe in a different directory than
 166 the one C<setup> moved into, usually a subdirectory, given by SUBDIR.
 167 The part of the recipe that's run there is given by the codeblock BLOCK.
 168
 169 C<indir> takes some additional options OPTS that affect the subdirectory:
 170
 171 =over 4
 172
 173 =item B<create =E<gt> 0|1>
 174
 175 When set to 1 (or any value that perl perceives as true), the subdirectory
 176 will be created if it doesn't already exist.  This happens before BLOCK
 177 is executed.
 178
 179 =back
 180
 181 An example:
 182
 183   indir "foo" => sub {
 184       ok(run(app(["openssl", "version"]), stdout => "foo.txt"));
 185       if (ok(open(RESULT, "foo.txt"), "reading foo.txt")) {
 186           my $line = <RESULT>;
 187           close RESULT;
 188           is($line, qr/^OpenSSL 1\./,
 189              "check that we're using OpenSSL 1.x.x");
 190       }
 191   }, create => 1;
 192
 193 =back
 194
 195 =cut
 196
 197 sub indir {
 198     my $subdir = shift;
 199     my $codeblock = shift;
 200     my %opts = @_;
 201
 202     my $reverse = __cwd($subdir,%opts);
 203     BAIL_OUT("FAILURE: indir, \"$subdir\" wasn't possible to move into")
 204         unless $reverse;
 205
 206     $codeblock->();
 207
 208     __cwd($reverse);
 209 }
 210
 211 =over 4
 212
 213 =item B<cmd ARRAYREF, OPTS>
 214
 215 This functions build up a platform dependent command based on the
 216 input.  It takes a reference to a list that is the executable or
 217 script and its arguments, and some additional options (described
 218 further on).  Where necessary, the command will be wrapped in a
 219 suitable environment to make sure the correct shared libraries are
 220 used (currently only on Unix).
 221
 222 It returns a CODEREF to be used by C<run>, C<pipe> or C<cmdstr>.
 223
 224 The options that C<cmd> (as well as its derivatives described below) can take
 225 are in the form of hash values:
 226
 227 =over 4
 228
 229 =item B<stdin =E<gt> PATH>
 230
 231 =item B<stdout =E<gt> PATH>
 232
 233 =item B<stderr =E<gt> PATH>
 234
 235 In all three cases, the corresponding standard input, output or error is
 236 redirected from (for stdin) or to (for the others) a file given by the
 237 string PATH, I<or>, if the value is C<undef>, C</dev/null> or similar.
 238
 239 =back
 240
 241 =item B<app ARRAYREF, OPTS>
 242
 243 =item B<test ARRAYREF, OPTS>
 244
 245 Both of these are specific applications of C<cmd>, with just a couple
 246 of small difference:
 247
 248 C<app> expects to find the given command (the first item in the given list
 249 reference) as an executable in C<$BIN_D> (if defined, otherwise C<$TOP/apps>
 250 or C<$BLDTOP/apps>).
 251
 252 C<test> expects to find the given command (the first item in the given list
 253 reference) as an executable in C<$TEST_D> (if defined, otherwise C<$TOP/test>
 254 or C<$BLDTOP/test>).
 255
 256 Also, for both C<app> and C<test>, the command may be prefixed with
 257 the content of the environment variable C<$EXE_SHELL>, which is useful
 258 in case OpenSSL has been cross compiled.
 259
 260 =item B<perlapp ARRAYREF, OPTS>
 261
 262 =item B<perltest ARRAYREF, OPTS>
 263
 264 These are also specific applications of C<cmd>, where the interpreter
 265 is predefined to be C<perl>, and they expect the script to be
 266 interpreted to reside in the same location as C<app> and C<test>.
 267
 268 C<perlapp> and C<perltest> will also take the following option:
 269
 270 =over 4
 271
 272 =item B<interpreter_args =E<gt> ARRAYref>
 273
 274 The array reference is a set of arguments for the interpreter rather
 275 than the script.  Take care so that none of them can be seen as a
 276 script!  Flags and their eventual arguments only!
 277
 278 =back
 279
 280 An example:
 281
 282   ok(run(perlapp(["foo.pl", "arg1"],
 283                  interpreter_args => [ "-I", srctop_dir("test") ])));
 284
 285 =back
 286
 287 =begin comment
 288
 289 One might wonder over the complexity of C<apps>, C<fuzz>, C<test>, ...
 290 with all the lazy evaluations and all that.  The reason for this is that
 291 we want to make sure the directory in which those programs are found are
 292 correct at the time these commands are used.  Consider the following code
 293 snippet:
 294
 295   my $cmd = app(["openssl", ...]);
 296
 297   indir "foo", sub {
 298       ok(run($cmd), "Testing foo")
 299   };
 300
 301 If there wasn't this lazy evaluation, the directory where C<openssl> is
 302 found would be incorrect at the time C<run> is called, because it was
 303 calculated before we moved into the directory "foo".
 304
 305 =end comment
 306
 307 =cut
 308
 309 sub cmd {
 310     my $cmd = shift;
 311     my %opts = @_;
 312     return sub {
 313         my $num = shift;
 314         # Make a copy to not destroy the caller's array
 315         my @cmdargs = ( @$cmd );
 316         my @prog = __wrap_cmd(shift @cmdargs, $opts{exe_shell} // ());
 317
 318         return __decorate_cmd($num, [ @prog, quotify(@cmdargs) ],
 319                               %opts);
 320     }
 321 }
 322
 323 sub app {
 324     my $cmd = shift;
 325     my %opts = @_;
 326     return sub {
 327         my @cmdargs = ( @{$cmd} );
 328         my @prog = __fixup_prg(__apps_file(shift @cmdargs, __exeext()));
 329         return cmd([ @prog, @cmdargs ],
 330                    exe_shell => $ENV{EXE_SHELL}, %opts) -> (shift);
 331     }
 332 }
 333
 334 sub fuzz {
 335     my $cmd = shift;
 336     my %opts = @_;
 337     return sub {
 338         my @cmdargs = ( @{$cmd} );
 339         my @prog = __fixup_prg(__fuzz_file(shift @cmdargs, __exeext()));
 340         return cmd([ @prog, @cmdargs ],
 341                    exe_shell => $ENV{EXE_SHELL}, %opts) -> (shift);
 342     }
 343 }
 344
 345 sub test {
 346     my $cmd = shift;
 347     my %opts = @_;
 348     return sub {
 349         my @cmdargs = ( @{$cmd} );
 350         my @prog = __fixup_prg(__test_file(shift @cmdargs, __exeext()));
 351         return cmd([ @prog, @cmdargs ],
 352                    exe_shell => $ENV{EXE_SHELL}, %opts) -> (shift);
 353     }
 354 }
 355
 356 sub perlapp {
 357     my $cmd = shift;
 358     my %opts = @_;
 359     return sub {
 360         my @interpreter_args = defined $opts{interpreter_args} ?
 361             @{$opts{interpreter_args}} : ();
 362         my @interpreter = __fixup_prg($^X);
 363         my @cmdargs = ( @{$cmd} );
 364         my @prog = __apps_file(shift @cmdargs, undef);
 365         return cmd([ @interpreter, @interpreter_args,
 366                      @prog, @cmdargs ], %opts) -> (shift);
 367     }
 368 }
 369
 370 sub perltest {
 371     my $cmd = shift;
 372     my %opts = @_;
 373     return sub {
 374         my @interpreter_args = defined $opts{interpreter_args} ?
 375             @{$opts{interpreter_args}} : ();
 376         my @interpreter = __fixup_prg($^X);
 377         my @cmdargs = ( @{$cmd} );
 378         my @prog = __test_file(shift @cmdargs, undef);
 379         return cmd([ @interpreter, @interpreter_args,
 380                      @prog, @cmdargs ], %opts) -> (shift);
 381     }
 382 }
 383
 384 =over 4
 385
 386 =item B<run CODEREF, OPTS>
 387
 388 CODEREF is expected to be the value return by C<cmd> or any of its
 389 derivatives, anything else will most likely cause an error unless you
 390 know what you're doing.
 391
 392 C<run> executes the command returned by CODEREF and return either the
 393 resulting standard output (if the option C<capture> is set true) or a boolean
 394 indicating if the command succeeded or not.
 395
 396 The options that C<run> can take are in the form of hash values:
 397
 398 =over 4
 399
 400 =item B<capture =E<gt> 0|1>
 401
 402 If true, the command will be executed with a perl backtick,
 403 and C<run> will return the resulting standard output as an array of lines.
 404 If false or not given, the command will be executed with C<system()>,
 405 and C<run> will return 1 if the command was successful or 0 if it wasn't.
 406
 407 =item B<prefix =E<gt> EXPR>
 408
 409 If specified, EXPR will be used as a string to prefix the output from the
 410 command.  This is useful if the output contains lines starting with C<ok >
 411 or C<not ok > that can disturb Test::Harness.
 412
 413 =item B<statusvar =E<gt> VARREF>
 414
 415 If used, B<VARREF> must be a reference to a scalar variable.  It will be
 416 assigned a boolean indicating if the command succeeded or not.  This is
 417 particularly useful together with B<capture>.
 418
 419 =back
 420
 421 Usually 1 indicates that the command was successful and 0 indicates failure.
 422 For further discussion on what is considered a successful command or not, see
 423 the function C<with> further down.
 424
 425 =back
 426
 427 =cut
 428
 429 sub run {
 430     my ($cmd, $display_cmd) = shift->(0);
 431     my %opts = @_;
 432
 433     return () if !$cmd;
 434
 435     my $prefix = "";
 436     if ( $^O eq "VMS" ) {       # VMS
 437         $prefix = "pipe ";
 438     }
 439
 440     my @r = ();
 441     my $r = 0;
 442     my $e = 0;
 443
 444     die "OpenSSL::Test::run(): statusvar value not a scalar reference"
 445         if $opts{statusvar} && ref($opts{statusvar}) ne "SCALAR";
 446
 447     # For some reason, program output, or even output from this function
 448     # somehow isn't caught by TAP::Harness (TAP::Parser?) on VMS, so we're
 449     # silencing it specifically there until further notice.
 450     my $save_STDOUT;
 451     my $save_STDERR;
 452     if ($^O eq 'VMS') {
 453         # In non-verbose, we want to shut up the command interpreter, in case
 454         # it has something to complain about.  On VMS, it might complain both
 455         # on stdout and stderr
 456         if ($ENV{HARNESS_ACTIVE} && !$ENV{HARNESS_VERBOSE}) {
 457             open $save_STDOUT, '>&', \*STDOUT or die "Can't dup STDOUT: $!";
 458             open $save_STDERR, '>&', \*STDERR or die "Can't dup STDERR: $!";
 459             open STDOUT, ">", devnull();
 460             open STDERR, ">", devnull();
 461         }
 462     }
 463
 464     $ENV{HARNESS_OSSL_LEVEL} = $level + 1;
 465
 466     # The dance we do with $? is the same dance the Unix shells appear to
 467     # do.  For example, a program that gets aborted (and therefore signals
 468     # SIGABRT = 6) will appear to exit with the code 134.  We mimic this
 469     # to make it easier to compare with a manual run of the command.
 470     if ($opts{capture} || defined($opts{prefix})) {
 471         my $pipe;
 472         local $_;
 473
 474         open($pipe, '-|', "$prefix$cmd") or die "Can't start command: $!";
 475         while(<$pipe>) {
 476             my $l = ($opts{prefix} // "") . $_;
 477             if ($opts{capture}) {
 478                 push @r, $l;
 479             } else {
 480                 print STDOUT $l;
 481             }
 482         }
 483         close $pipe;
 484     } else {
 485         $ENV{HARNESS_OSSL_PREFIX} = "# ";
 486         system("$prefix$cmd");
 487         delete $ENV{HARNESS_OSSL_PREFIX};
 488     }
 489     $e = ($? & 0x7f) ? ($? & 0x7f)|0x80 : ($? >> 8);
 490     $r = $hooks{exit_checker}->($e);
 491     if ($opts{statusvar}) {
 492         ${$opts{statusvar}} = $r;
 493     }
 494
 495     # Restore STDOUT / STDERR on VMS
 496     if ($^O eq 'VMS') {
 497         if ($ENV{HARNESS_ACTIVE} && !$ENV{HARNESS_VERBOSE}) {
 498             close STDOUT;
 499             close STDERR;
 500             open STDOUT, '>&', $save_STDOUT or die "Can't restore STDOUT: $!";
 501             open STDERR, '>&', $save_STDERR or die "Can't restore STDERR: $!";
 502         }
 503
 504         print STDERR "$prefix$display_cmd => $e\n"
 505             if !$ENV{HARNESS_ACTIVE} || $ENV{HARNESS_VERBOSE};
 506     } else {
 507         print STDERR "$prefix$display_cmd => $e\n";
 508     }
 509
 510     # At this point, $? stops being interesting, and unfortunately,
 511     # there are Test::More versions that get picky if we leave it
 512     # non-zero.
 513     $? = 0;
 514
 515     if ($opts{capture}) {
 516         return @r;
 517     } else {
 518         return $r;
 519     }
 520 }
 521
 522 END {
 523     my $tb = Test::More->builder;
 524     my $failure = scalar(grep { $_ == 0; } $tb->summary);
 525     if ($failure && $end_with_bailout) {
 526         BAIL_OUT("Stoptest!");
 527     }
 528 }
 529
 530 =head2 Utility functions
 531
 532 The following functions are exported on request when using C<OpenSSL::Test>.
 533
 534   # To only get the bldtop_file and srctop_file functions.
 535   use OpenSSL::Test qw/bldtop_file srctop_file/;
 536
 537   # To only get the bldtop_file function in addition to the default ones.
 538   use OpenSSL::Test qw/:DEFAULT bldtop_file/;
 539
 540 =cut
 541
 542 # Utility functions, exported on request
 543
 544 =over 4
 545
 546 =item B<bldtop_dir LIST>
 547
 548 LIST is a list of directories that make up a path from the top of the OpenSSL
 549 build directory (as indicated by the environment variable C<$TOP> or
 550 C<$BLDTOP>).
 551 C<bldtop_dir> returns the resulting directory as a string, adapted to the local
 552 operating system.
 553
 554 =back
 555
 556 =cut
 557
 558 sub bldtop_dir {
 559     return __bldtop_dir(@_);    # This caters for operating systems that have
 560                                 # a very distinct syntax for directories.
 561 }
 562
 563 =over 4
 564
 565 =item B<bldtop_file LIST, FILENAME>
 566
 567 LIST is a list of directories that make up a path from the top of the OpenSSL
 568 build directory (as indicated by the environment variable C<$TOP> or
 569 C<$BLDTOP>) and FILENAME is the name of a file located in that directory path.
 570 C<bldtop_file> returns the resulting file path as a string, adapted to the local
 571 operating system.
 572
 573 =back
 574
 575 =cut
 576
 577 sub bldtop_file {
 578     return __bldtop_file(@_);
 579 }
 580
 581 =over 4
 582
 583 =item B<srctop_dir LIST>
 584
 585 LIST is a list of directories that make up a path from the top of the OpenSSL
 586 source directory (as indicated by the environment variable C<$TOP> or
 587 C<$SRCTOP>).
 588 C<srctop_dir> returns the resulting directory as a string, adapted to the local
 589 operating system.
 590
 591 =back
 592
 593 =cut
 594
 595 sub srctop_dir {
 596     return __srctop_dir(@_);    # This caters for operating systems that have
 597                                 # a very distinct syntax for directories.
 598 }
 599
 600 =over 4
 601
 602 =item B<srctop_file LIST, FILENAME>
 603
 604 LIST is a list of directories that make up a path from the top of the OpenSSL
 605 source directory (as indicated by the environment variable C<$TOP> or
 606 C<$SRCTOP>) and FILENAME is the name of a file located in that directory path.
 607 C<srctop_file> returns the resulting file path as a string, adapted to the local
 608 operating system.
 609
 610 =back
 611
 612 =cut
 613
 614 sub srctop_file {
 615     return __srctop_file(@_);
 616 }
 617
 618 =over 4
 619
 620 =item B<data_dir LIST>
 621
 622 LIST is a list of directories that make up a path from the data directory
 623 associated with the test (see L</DESCRIPTION> above).
 624 C<data_dir> returns the resulting directory as a string, adapted to the local
 625 operating system.
 626
 627 =back
 628
 629 =cut
 630
 631 sub data_dir {
 632     return __data_dir(@_);
 633 }
 634
 635 =over 4
 636
 637 =item B<data_file LIST, FILENAME>
 638
 639 LIST is a list of directories that make up a path from the data directory
 640 associated with the test (see L</DESCRIPTION> above) and FILENAME is the name
 641 of a file located in that directory path.  C<data_file> returns the resulting
 642 file path as a string, adapted to the local operating system.
 643
 644 =back
 645
 646 =cut
 647
 648 sub data_file {
 649     return __data_file(@_);
 650 }
 651
 652 =over 4
 653
 654 =item B<result_dir>
 655
 656 C<result_dir> returns the directory where test output files should be placed
 657 as a string, adapted to the local operating system.
 658
 659 =back
 660
 661 =cut
 662
 663 sub result_dir {
 664     BAIL_OUT("Must run setup() first") if (! $test_name);
 665
 666     return catfile($directories{RESULTS});
 667 }
 668
 669 =over 4
 670
 671 =item B<result_file FILENAME>
 672
 673 FILENAME is the name of a test output file.
 674 C<result_file> returns the path of the given file as a string,
 675 prepending to the file name the path to the directory where test output files
 676 should be placed, adapted to the local operating system.
 677
 678 =back
 679
 680 =cut
 681
 682 sub result_file {
 683     BAIL_OUT("Must run setup() first") if (! $test_name);
 684
 685     my $f = pop;
 686     return catfile(result_dir(),@_,$f);
 687 }
 688
 689 =over 4
 690
 691 =item B<pipe LIST>
 692
 693 LIST is a list of CODEREFs returned by C<app> or C<test>, from which C<pipe>
 694 creates a new command composed of all the given commands put together in a
 695 pipe.  C<pipe> returns a new CODEREF in the same manner as C<app> or C<test>,
 696 to be passed to C<run> for execution.
 697
 698 =back
 699
 700 =cut
 701
 702 sub pipe {
 703     my @cmds = @_;
 704     return
 705         sub {
 706             my @cs  = ();
 707             my @dcs = ();
 708             my @els = ();
 709             my $counter = 0;
 710             foreach (@cmds) {
 711                 my ($c, $dc, @el) = $_->(++$counter);
 712
 713                 return () if !$c;
 714
 715                 push @cs, $c;
 716                 push @dcs, $dc;
 717                 push @els, @el;
 718             }
 719             return (
 720                 join(" | ", @cs),
 721                 join(" | ", @dcs),
 722                 @els
 723                 );
 724     };
 725 }
 726
 727 =over 4
 728
 729 =item B<with HASHREF, CODEREF>
 730
 731 C<with> will temporarily install hooks given by the HASHREF and then execute
 732 the given CODEREF.  Hooks are usually expected to have a coderef as value.
 733
 734 The currently available hoosk are:
 735
 736 =over 4
 737
 738 =item B<exit_checker =E<gt> CODEREF>
 739
 740 This hook is executed after C<run> has performed its given command.  The
 741 CODEREF receives the exit code as only argument and is expected to return
 742 1 (if the exit code indicated success) or 0 (if the exit code indicated
 743 failure).
 744
 745 =back
 746
 747 =back
 748
 749 =cut
 750
 751 sub with {
 752     my $opts = shift;
 753     my %opts = %{$opts};
 754     my $codeblock = shift;
 755
 756     my %saved_hooks = ();
 757
 758     foreach (keys %opts) {
 759         $saved_hooks{$_} = $hooks{$_}   if exists($hooks{$_});
 760         $hooks{$_} = $opts{$_};
 761     }
 762
 763     $codeblock->();
 764
 765     foreach (keys %saved_hooks) {
 766         $hooks{$_} = $saved_hooks{$_};
 767     }
 768 }
 769
 770 =over 4
 771
 772 =item B<cmdstr CODEREF, OPTS>
 773
 774 C<cmdstr> takes a CODEREF from C<app> or C<test> and simply returns the
 775 command as a string.
 776
 777 C<cmdstr> takes some additional options OPTS that affect the string returned:
 778
 779 =over 4
 780
 781 =item B<display =E<gt> 0|1>
 782
 783 When set to 0, the returned string will be with all decorations, such as a
 784 possible redirect of stderr to the null device.  This is suitable if the
 785 string is to be used directly in a recipe.
 786
 787 When set to 1, the returned string will be without extra decorations.  This
 788 is suitable for display if that is desired (doesn't confuse people with all
 789 internal stuff), or if it's used to pass a command down to a subprocess.
 790
 791 Default: 0
 792
 793 =back
 794
 795 =back
 796
 797 =cut
 798
 799 sub cmdstr {
 800     my ($cmd, $display_cmd) = shift->(0);
 801     my %opts = @_;
 802
 803     if ($opts{display}) {
 804         return $display_cmd;
 805     } else {
 806         return $cmd;
 807     }
 808 }
 809
 810 =over 4
 811
 812 =item B<quotify LIST>
 813
 814 LIST is a list of strings that are going to be used as arguments for a
 815 command, and makes sure to inject quotes and escapes as necessary depending
 816 on the content of each string.
 817
 818 This can also be used to put quotes around the executable of a command.
 819 I<This must never ever be done on VMS.>
 820
 821 =back
 822
 823 =cut
 824
 825 sub quotify {
 826     # Unix setup (default if nothing else is mentioned)
 827     my $arg_formatter =
 828         sub { $_ = shift;
 829               ($_ eq '' || /\s|[\{\}\\\$\[\]\*\?\|\&:;<>]/) ? "'$_'" : $_ };
 830
 831     if ( $^O eq "VMS") {        # VMS setup
 832         $arg_formatter = sub {
 833             $_ = shift;
 834             if ($_ eq '' || /\s|["[:upper:]]/) {
 835                 s/"/""/g;
 836                 '"'.$_.'"';
 837             } else {
 838                 $_;
 839             }
 840         };
 841     } elsif ( $^O eq "MSWin32") { # MSWin setup
 842         $arg_formatter = sub {
 843             $_ = shift;
 844             if ($_ eq '' || /\s|["\|\&\*\;<>]/) {
 845                 s/(["\\])/\\$1/g;
 846                 '"'.$_.'"';
 847             } else {
 848                 $_;
 849             }
 850         };
 851     }
 852
 853     return map { $arg_formatter->($_) } @_;
 854 }
 855
 856 =over 4
 857
 858 =item B<openssl_versions>
 859
 860 Returns a list of two version numbers, the first representing the build
 861 version, the second representing the library version.  See opensslv.h for
 862 more information on those numbers.
 863
 864 =back
 865
 866 =cut
 867
 868 my @versions = ();
 869 sub openssl_versions {
 870     unless (@versions) {
 871         my %lines =
 872             map { s/\R$//;
 873                   /^(.*): (.*)$/;
 874                   $1 => $2 }
 875             run(test(['versions']), capture => 1);
 876         @versions = ( $lines{'Build version'}, $lines{'Library version'} );
 877     }
 878     return @versions;
 879 }
 880
 881 =over 4
 882
 883 =item B<ok_nofips EXPR, TEST_NAME>
 884
 885 C<ok_nofips> is equivalent to using C<ok> when the environment variable
 886 C<FIPS_MODE> is undefined, otherwise it is equivalent to C<not ok>. This can be
 887 used for C<ok> tests that must fail when testing a FIPS provider. The parameters
 888 are the same as used by C<ok> which is an expression EXPR followed by the test
 889 description TEST_NAME.
 890
 891 An example:
 892
 893   ok_nofips(run(app(["md5.pl"])), "md5 should fail in fips mode");
 894
 895 =item B<is_nofips EXPR1, EXPR2, TEST_NAME>
 896
 897 C<is_nofips> is equivalent to using C<is> when the environment variable
 898 C<FIPS_MODE> is undefined, otherwise it is equivalent to C<isnt>. This can be
 899 used for C<is> tests that must fail when testing a FIPS provider. The parameters
 900 are the same as used by C<is> which has 2 arguments EXPR1 and EXPR2 that can be
 901 compared using eq or ne, followed by a test description TEST_NAME.
 902
 903 An example:
 904
 905   is_nofips(ultimate_answer(), 42,  "Meaning of Life");
 906
 907 =item B<isnt_nofips EXPR1, EXPR2, TEST_NAME>
 908
 909 C<isnt_nofips> is equivalent to using C<isnt> when the environment variable
 910 C<FIPS_MODE> is undefined, otherwise it is equivalent to C<is>. This can be
 911 used for C<isnt> tests that must fail when testing a FIPS provider. The
 912 parameters are the same as used by C<isnt> which has 2 arguments EXPR1 and EXPR2
 913 that can be compared using ne or eq, followed by a test description TEST_NAME.
 914
 915 An example:
 916
 917   isnt_nofips($foo, '',  "Got some foo");
 918
 919 =back
 920
 921 =cut
 922
 923 sub ok_nofips {
 924     return ok(!$_[0], @_[1..$#_]) if defined $ENV{FIPS_MODE};
 925     return ok($_[0], @_[1..$#_]);
 926 }
 927
 928 sub is_nofips {
 929     return isnt($_[0], $_[1], @_[2..$#_]) if defined $ENV{FIPS_MODE};
 930     return is($_[0], $_[1], @_[2..$#_]);
 931 }
 932
 933 sub isnt_nofips {
 934     return is($_[0], $_[1], @_[2..$#_]) if defined $ENV{FIPS_MODE};
 935     return isnt($_[0], $_[1], @_[2..$#_]);
 936 }
 937
 938 ######################################################################
 939 # private functions.  These are never exported.
 940
 941 =head1 ENVIRONMENT
 942
 943 OpenSSL::Test depends on some environment variables.
 944
 945 =over 4
 946
 947 =item B<TOP>
 948
 949 This environment variable is mandatory.  C<setup> will check that it's
 950 defined and that it's a directory that contains the file C<Configure>.
 951 If this isn't so, C<setup> will C<BAIL_OUT>.
 952
 953 =item B<BIN_D>
 954
 955 If defined, its value should be the directory where the openssl application
 956 is located.  Defaults to C<$TOP/apps> (adapted to the operating system).
 957
 958 =item B<TEST_D>
 959
 960 If defined, its value should be the directory where the test applications
 961 are located.  Defaults to C<$TOP/test> (adapted to the operating system).
 962
 963 =item B<STOPTEST>
 964
 965 If defined, it puts testing in a different mode, where a recipe with
 966 failures will result in a C<BAIL_OUT> at the end of its run.
 967
 968 =item B<FIPS_MODE>
 969
 970 If defined it indicates that the FIPS provider is being tested. Tests may use
 971 B<ok_nofips>, B<is_nofips> and B<isnt_nofips> to invert test results
 972 i.e. Some tests may only work in non FIPS mode.
 973
 974 =back
 975
 976 =cut
 977
 978 sub __env {
 979     (my $recipe_datadir = basename($0)) =~ s/\.t$/_data/i;
 980
 981     $directories{SRCTOP}    = abs_path($ENV{SRCTOP} || $ENV{TOP});
 982     $directories{BLDTOP}    = abs_path($ENV{BLDTOP} || $ENV{TOP});
 983     $directories{BLDAPPS}   = $ENV{BIN_D}  || __bldtop_dir("apps");
 984     $directories{SRCAPPS}   =                 __srctop_dir("apps");
 985     $directories{BLDFUZZ}   =                 __bldtop_dir("fuzz");
 986     $directories{SRCFUZZ}   =                 __srctop_dir("fuzz");
 987     $directories{BLDTEST}   = $ENV{TEST_D} || __bldtop_dir("test");
 988     $directories{SRCTEST}   =                 __srctop_dir("test");
 989     $directories{SRCDATA}   =                 __srctop_dir("test", "recipes",
 990                                                            $recipe_datadir);
 991     $directories{RESULTTOP} = $ENV{RESULT_D} || __bldtop_dir("test-runs");
 992     $directories{RESULTS}   = catdir($directories{RESULTTOP}, $test_name);
 993
 994     # Create result directory dynamically
 995     rmtree($directories{RESULTS}, { safe => 0, keep_root => 1 });
 996     mkpath($directories{RESULTS});
 997
 998     # All directories are assumed to exist, except for SRCDATA.  If that one
 999     # doesn't exist, just drop it.
1000     delete $directories{SRCDATA} unless -d $directories{SRCDATA};
1001
1002     push @direnv, "TOP"       if $ENV{TOP};
1003     push @direnv, "SRCTOP"    if $ENV{SRCTOP};
1004     push @direnv, "BLDTOP"    if $ENV{BLDTOP};
1005     push @direnv, "BIN_D"     if $ENV{BIN_D};
1006     push @direnv, "TEST_D"    if $ENV{TEST_D};
1007     push @direnv, "RESULT_D"  if $ENV{RESULT_D};
1008
1009     $end_with_bailout = $ENV{STOPTEST} ? 1 : 0;
1010 };
1011
1012 # __srctop_file and __srctop_dir are helpers to build file and directory
1013 # names on top of the source directory.  They depend on $SRCTOP, and
1014 # therefore on the proper use of setup() and when needed, indir().
1015 # __bldtop_file and __bldtop_dir do the same thing but relative to $BLDTOP.
1016 # __srctop_file and __bldtop_file take the same kind of argument as
1017 # File::Spec::Functions::catfile.
1018 # Similarly, __srctop_dir and __bldtop_dir take the same kind of argument
1019 # as File::Spec::Functions::catdir
1020 sub __srctop_file {
1021     BAIL_OUT("Must run setup() first") if (! $test_name);
1022
1023     my $f = pop;
1024     return abs2rel(catfile($directories{SRCTOP},@_,$f),getcwd);
1025 }
1026
1027 sub __srctop_dir {
1028     BAIL_OUT("Must run setup() first") if (! $test_name);
1029
1030     return abs2rel(catdir($directories{SRCTOP},@_), getcwd);
1031 }
1032
1033 sub __bldtop_file {
1034     BAIL_OUT("Must run setup() first") if (! $test_name);
1035
1036     my $f = pop;
1037     return abs2rel(catfile($directories{BLDTOP},@_,$f), getcwd);
1038 }
1039
1040 sub __bldtop_dir {
1041     BAIL_OUT("Must run setup() first") if (! $test_name);
1042
1043     return abs2rel(catdir($directories{BLDTOP},@_), getcwd);
1044 }
1045
1046 # __exeext is a function that returns the platform dependent file extension
1047 # for executable binaries, or the value of the environment variable $EXE_EXT
1048 # if that one is defined.
1049 sub __exeext {
1050     my $ext = "";
1051     if ($^O eq "VMS" ) {        # VMS
1052         $ext = ".exe";
1053     } elsif ($^O eq "MSWin32") { # Windows
1054         $ext = ".exe";
1055     }
1056     return $ENV{"EXE_EXT"} || $ext;
1057 }
1058
1059 # __test_file, __apps_file and __fuzz_file return the full path to a file
1060 # relative to the test/, apps/ or fuzz/ directory in the build tree or the
1061 # source tree, depending on where the file is found.  Note that when looking
1062 # in the build tree, the file name with an added extension is looked for, if
1063 # an extension is given.  The intent is to look for executable binaries (in
1064 # the build tree) or possibly scripts (in the source tree).
1065 # These functions all take the same arguments as File::Spec::Functions::catfile,
1066 # *plus* a mandatory extension argument.  This extension argument can be undef,
1067 # and is ignored in such a case.
1068 sub __test_file {
1069     BAIL_OUT("Must run setup() first") if (! $test_name);
1070
1071     my $e = pop || "";
1072     my $f = pop;
1073     my $out = catfile($directories{BLDTEST},@_,$f . $e);
1074     $out = catfile($directories{SRCTEST},@_,$f) unless -f $out;
1075     return $out;
1076 }
1077
1078 sub __apps_file {
1079     BAIL_OUT("Must run setup() first") if (! $test_name);
1080
1081     my $e = pop || "";
1082     my $f = pop;
1083     my $out = catfile($directories{BLDAPPS},@_,$f . $e);
1084     $out = catfile($directories{SRCAPPS},@_,$f) unless -f $out;
1085     return $out;
1086 }
1087
1088 sub __fuzz_file {
1089     BAIL_OUT("Must run setup() first") if (! $test_name);
1090
1091     my $e = pop || "";
1092     my $f = pop;
1093     my $out = catfile($directories{BLDFUZZ},@_,$f . $e);
1094     $out = catfile($directories{SRCFUZZ},@_,$f) unless -f $out;
1095     return $out;
1096 }
1097
1098 sub __data_file {
1099     BAIL_OUT("Must run setup() first") if (! $test_name);
1100
1101     return undef unless exists $directories{SRCDATA};
1102
1103     my $f = pop;
1104     return catfile($directories{SRCDATA},@_,$f);
1105 }
1106
1107 sub __data_dir {
1108     BAIL_OUT("Must run setup() first") if (! $test_name);
1109
1110     return undef unless exists $directories{SRCDATA};
1111
1112     return catdir($directories{SRCDATA},@_);
1113 }
1114
1115 # __cwd DIR
1116 # __cwd DIR, OPTS
1117 #
1118 # __cwd changes directory to DIR (string) and changes all the relative
1119 # entries in %directories accordingly.  OPTS is an optional series of
1120 # hash style arguments to alter __cwd's behavior:
1121 #
1122 #    create = 0|1       The directory we move to is created if 1, not if 0.
1123
1124 sub __cwd {
1125     my $dir = catdir(shift);
1126     my %opts = @_;
1127
1128     # If the directory is to be created, we must do that before using
1129     # abs_path().
1130     $dir = canonpath($dir);
1131     if ($opts{create}) {
1132         mkpath($dir);
1133     }
1134
1135     my $abscurdir = abs_path(curdir());
1136     my $absdir = abs_path($dir);
1137     my $reverse = abs2rel($abscurdir, $absdir);
1138
1139     # PARANOIA: if we're not moving anywhere, we do nothing more
1140     if ($abscurdir eq $absdir) {
1141         return $reverse;
1142     }
1143
1144     # Do not support a move to a different volume for now.  Maybe later.
1145     BAIL_OUT("FAILURE: \"$dir\" moves to a different volume, not supported")
1146         if $reverse eq $abscurdir;
1147
1148     # If someone happened to give a directory that leads back to the current,
1149     # it's extremely silly to do anything more, so just simulate that we did
1150     # move.
1151     # In this case, we won't even clean it out, for safety's sake.
1152     return "." if $reverse eq "";
1153
1154     # We are recalculating the directories we keep track of, but need to save
1155     # away the result for after having moved into the new directory.
1156     my %tmp_directories = ();
1157     my %tmp_ENV = ();
1158
1159     # For each of these directory variables, figure out where they are relative
1160     # to the directory we want to move to if they aren't absolute (if they are,
1161     # they don't change!)
1162     my @dirtags = sort keys %directories;
1163     foreach (@dirtags) {
1164         if (!file_name_is_absolute($directories{$_})) {
1165             my $oldpath = abs_path($directories{$_});
1166             my $newpath = abs2rel($oldpath, $absdir);
1167             if ($debug) {
1168                 print STDERR "DEBUG: [dir $_] old path: $oldpath\n";
1169                 print STDERR "DEBUG: [dir $_] new base: $absdir\n";
1170                 print STDERR "DEBUG: [dir $_] resulting new path: $newpath\n";
1171             }
1172             $tmp_directories{$_} = $newpath;
1173         }
1174     }
1175
1176     # Treat each environment variable that was used to get us the values in
1177     # %directories the same was as the paths in %directories, so any sub
1178     # process can use their values properly as well
1179     foreach (@direnv) {
1180         if (!file_name_is_absolute($ENV{$_})) {
1181             my $oldpath = abs_path($ENV{$_});
1182             my $newpath = abs2rel($oldpath, $absdir);
1183             if ($debug) {
1184                 print STDERR "DEBUG: [env $_] old path: $oldpath\n";
1185                 print STDERR "DEBUG: [env $_] new base: $absdir\n";
1186                 print STDERR "DEBUG: [env $_] resulting new path: $newpath\n";
1187             }
1188             $tmp_ENV{$_} = $newpath;
1189         }
1190     }
1191
1192     # Should we just bail out here as well?  I'm unsure.
1193     return undef unless chdir($dir);
1194
1195     # We put back new values carefully.  Doing the obvious
1196     # %directories = ( %tmp_directories )
1197     # will clear out any value that happens to be an absolute path
1198     foreach (keys %tmp_directories) {
1199         $directories{$_} = $tmp_directories{$_};
1200     }
1201     foreach (keys %tmp_ENV) {
1202         $ENV{$_} = $tmp_ENV{$_};
1203     }
1204
1205     if ($debug) {
1206         print STDERR "DEBUG: __cwd(), directories and files:\n";
1207         print STDERR "  Moving from $abscurdir\n";
1208         print STDERR "  Moving to $absdir\n";
1209         print STDERR "\n";
1210         print STDERR "  \$directories{BLDTEST} = \"$directories{BLDTEST}\"\n";
1211         print STDERR "  \$directories{SRCTEST} = \"$directories{SRCTEST}\"\n";
1212         print STDERR "  \$directories{SRCDATA} = \"$directories{SRCDATA}\"\n"
1213             if exists $directories{SRCDATA};
1214         print STDERR "  \$directories{RESULTS} = \"$directories{RESULTS}\"\n";
1215         print STDERR "  \$directories{BLDAPPS} = \"$directories{BLDAPPS}\"\n";
1216         print STDERR "  \$directories{SRCAPPS} = \"$directories{SRCAPPS}\"\n";
1217         print STDERR "  \$directories{SRCTOP}  = \"$directories{SRCTOP}\"\n";
1218         print STDERR "  \$directories{BLDTOP}  = \"$directories{BLDTOP}\"\n";
1219         print STDERR "\n";
1220         print STDERR "  the way back is \"$reverse\"\n";
1221     }
1222
1223     return $reverse;
1224 }
1225
1226 # __wrap_cmd CMD
1227 # __wrap_cmd CMD, EXE_SHELL
1228 #
1229 # __wrap_cmd "wraps" CMD (string) with a beginning command that makes sure
1230 # the command gets executed with an appropriate environment.  If EXE_SHELL
1231 # is given, it is used as the beginning command.
1232 #
1233 # __wrap_cmd returns a list that should be used to build up a larger list
1234 # of command tokens, or be joined together like this:
1235 #
1236 #    join(" ", __wrap_cmd($cmd))
1237 sub __wrap_cmd {
1238     my $cmd = shift;
1239     my $exe_shell = shift;
1240
1241     my @prefix = ();
1242
1243     if (defined($exe_shell)) {
1244         # If $exe_shell is defined, trust it
1245         @prefix = ( $exe_shell );
1246     } else {
1247         # Otherwise, use the standard wrapper
1248         my $std_wrapper = __bldtop_file("util", "wrap.pl");
1249
1250         if ($^O eq "VMS") {
1251             # On VMS, running random executables without having a command
1252             # symbol means running them with the MCR command.  This is an
1253             # old PDP-11 command that stuck around.  So we get a command
1254             # running perl running the script.
1255             @prefix = ( "MCR", $^X, $std_wrapper );
1256         } elsif ($^O eq "MSWin32") {
1257             # In the Windows case, we run perl explicitly.  We might not
1258             # need it, but that depends on if the user has associated the
1259             # '.pl' extension with a perl interpreter, so better be safe.
1260             @prefix = ( __fixup_prg($^X), $std_wrapper );
1261         } else {
1262             # Otherwise, we assume Unix semantics, and trust that the #!
1263             # line activates perl for us.
1264             @prefix = ( $std_wrapper );
1265         }
1266     }
1267
1268     return (@prefix, $cmd);
1269 }
1270
1271 # __fixup_prg PROG
1272 #
1273 # __fixup_prg does whatever fixup is needed to execute an executable binary
1274 # given by PROG (string).
1275 #
1276 # __fixup_prg returns a string with the possibly prefixed program path spec.
1277 sub __fixup_prg {
1278     my $prog = shift;
1279
1280     my $prefix = "";
1281
1282     if ($^O eq "VMS" ) {
1283         $prefix = ($prog =~ /^(?:[\$a-z0-9_]+:)?[<\[]/i ? "mcr " : "mcr []");
1284     }
1285
1286     if (defined($prog)) {
1287         # Make sure to quotify the program file on platforms that may
1288         # have spaces or similar in their path name.
1289         # To our knowledge, VMS is the exception where quotifying should
1290         # never happen.
1291         ($prog) = quotify($prog) unless $^O eq "VMS";
1292         return $prefix.$prog;
1293     }
1294
1295     print STDERR "$prog not found\n";
1296     return undef;
1297 }
1298
1299 # __decorate_cmd NUM, CMDARRAYREF
1300 #
1301 # __decorate_cmd takes a command number NUM and a command token array
1302 # CMDARRAYREF, builds up a command string from them and decorates it
1303 # with necessary redirections.
1304 # __decorate_cmd returns a list of two strings, one with the command
1305 # string to actually be used, the other to be displayed for the user.
1306 # The reason these strings might differ is that we redirect stderr to
1307 # the null device unless we're verbose and unless the user has
1308 # explicitly specified a stderr redirection.
1309 sub __decorate_cmd {
1310     BAIL_OUT("Must run setup() first") if (! $test_name);
1311
1312     my $num = shift;
1313     my $cmd = shift;
1314     my %opts = @_;
1315
1316     my $cmdstr = join(" ", @$cmd);
1317     my $null = devnull();
1318     my $fileornull = sub { $_[0] ? $_[0] : $null; };
1319     my $stdin = "";
1320     my $stdout = "";
1321     my $stderr = "";
1322     my $saved_stderr = undef;
1323     $stdin = " < ".$fileornull->($opts{stdin})  if exists($opts{stdin});
1324     $stdout= " > ".$fileornull->($opts{stdout}) if exists($opts{stdout});
1325     $stderr=" 2> ".$fileornull->($opts{stderr}) if exists($opts{stderr});
1326
1327     my $display_cmd = "$cmdstr$stdin$stdout$stderr";
1328
1329     # VMS program output escapes TAP::Parser
1330     if ($^O eq 'VMS') {
1331         $stderr=" 2> ".$null
1332             unless $stderr || !$ENV{HARNESS_ACTIVE} || $ENV{HARNESS_VERBOSE};
1333     }
1334
1335     $cmdstr .= "$stdin$stdout$stderr";
1336
1337     if ($debug) {
1338         print STDERR "DEBUG[__decorate_cmd]: \$cmdstr = \"$cmdstr\"\n";
1339         print STDERR "DEBUG[__decorate_cmd]: \$display_cmd = \"$display_cmd\"\n";
1340     }
1341
1342     return ($cmdstr, $display_cmd);
1343 }
1344
1345 =head1 SEE ALSO
1346
1347 L<Test::More>, L<Test::Harness>
1348
1349 =head1 AUTHORS
1350
1351 Richard Levitte E<lt>levitte@openssl.orgE<gt> with assistance and
1352 inspiration from Andy Polyakov E<lt>appro@openssl.org<gt>.
1353
1354 =cut
1355
1356 no warnings 'redefine';
1357 sub subtest {
1358     $level++;
1359
1360     Test::More::subtest @_;
1361
1362     $level--;
1363 };
1364
1365 1;