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