1# Copyright 2016-2018 The OpenSSL Project Authors. All Rights Reserved. 2# 3# Licensed under the OpenSSL license (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 Test::More 0.96; 14 15use Exporter; 16use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); 17$VERSION = "0.8"; 18@ISA = qw(Exporter); 19@EXPORT = (@Test::More::EXPORT, qw(setup indir app fuzz perlapp test perltest 20 run)); 21@EXPORT_OK = (@Test::More::EXPORT_OK, qw(bldtop_dir bldtop_file 22 srctop_dir srctop_file 23 data_file 24 pipe with cmdstr quotify)); 25 26=head1 NAME 27 28OpenSSL::Test - a private extension of Test::More 29 30=head1 SYNOPSIS 31 32 use OpenSSL::Test; 33 34 setup("my_test_name"); 35 36 ok(run(app(["openssl", "version"])), "check for openssl presence"); 37 38 indir "subdir" => sub { 39 ok(run(test(["sometest", "arg1"], stdout => "foo.txt")), 40 "run sometest with output to foo.txt"); 41 }; 42 43=head1 DESCRIPTION 44 45This module is a private extension of L<Test::More> for testing OpenSSL. 46In addition to the Test::More functions, it also provides functions that 47easily find the diverse programs within a OpenSSL build tree, as well as 48some other useful functions. 49 50This module I<depends> on the environment variables C<$TOP> or C<$SRCTOP> 51and C<$BLDTOP>. Without one of the combinations it refuses to work. 52See L</ENVIRONMENT> below. 53 54With each test recipe, a parallel data directory with (almost) the same name 55as the recipe is possible in the source directory tree. For example, for a 56recipe C<$SRCTOP/test/recipes/99-foo.t>, there could be a directory 57C<$SRCTOP/test/recipes/99-foo_data/>. 58 59=cut 60 61use File::Copy; 62use File::Spec::Functions qw/file_name_is_absolute curdir canonpath splitdir 63 catdir catfile splitpath catpath devnull abs2rel 64 rel2abs/; 65use File::Path 2.00 qw/rmtree mkpath/; 66use File::Basename; 67 68 69# The name of the test. This is set by setup() and is used in the other 70# functions to verify that setup() has been used. 71my $test_name = undef; 72 73# Directories we want to keep track of TOP, APPS, TEST and RESULTS are the 74# ones we're interested in, corresponding to the environment variables TOP 75# (mandatory), BIN_D, TEST_D, UTIL_D and RESULT_D. 76my %directories = (); 77 78# The environment variables that gave us the contents in %directories. These 79# get modified whenever we change directories, so that subprocesses can use 80# the values of those environment variables as well 81my @direnv = (); 82 83# A bool saying if we shall stop all testing if the current recipe has failing 84# tests or not. This is set by setup() if the environment variable STOPTEST 85# is defined with a non-empty value. 86my $end_with_bailout = 0; 87 88# A set of hooks that is affected by with() and may be used in diverse places. 89# All hooks are expected to be CODE references. 90my %hooks = ( 91 92 # exit_checker is used by run() directly after completion of a command. 93 # it receives the exit code from that command and is expected to return 94 # 1 (for success) or 0 (for failure). This is the value that will be 95 # returned by run(). 96 # NOTE: When run() gets the option 'capture => 1', this hook is ignored. 97 exit_checker => sub { return shift == 0 ? 1 : 0 }, 98 99 ); 100 101# Debug flag, to be set manually when needed 102my $debug = 0; 103 104# Declare some utility functions that are defined at the end 105sub bldtop_file; 106sub bldtop_dir; 107sub srctop_file; 108sub srctop_dir; 109sub quotify; 110 111# Declare some private functions that are defined at the end 112sub __env; 113sub __cwd; 114sub __apps_file; 115sub __results_file; 116sub __fixup_cmd; 117sub __build_cmd; 118 119=head2 Main functions 120 121The following functions are exported by default when using C<OpenSSL::Test>. 122 123=cut 124 125=over 4 126 127=item B<setup "NAME"> 128 129C<setup> is used for initial setup, and it is mandatory that it's used. 130If it's not used in a OpenSSL test recipe, the rest of the recipe will 131most likely refuse to run. 132 133C<setup> checks for environment variables (see L</ENVIRONMENT> below), 134checks that C<$TOP/Configure> or C<$SRCTOP/Configure> exists, C<chdir> 135into the results directory (defined by the C<$RESULT_D> environment 136variable if defined, otherwise C<$BLDTOP/test> or C<$TOP/test>, whichever 137is defined). 138 139=back 140 141=cut 142 143sub setup { 144 my $old_test_name = $test_name; 145 $test_name = shift; 146 147 BAIL_OUT("setup() must receive a name") unless $test_name; 148 warn "setup() detected test name change. Innocuous, so we continue...\n" 149 if $old_test_name && $old_test_name ne $test_name; 150 151 return if $old_test_name; 152 153 BAIL_OUT("setup() needs \$TOP or \$SRCTOP and \$BLDTOP to be defined") 154 unless $ENV{TOP} || ($ENV{SRCTOP} && $ENV{BLDTOP}); 155 BAIL_OUT("setup() found both \$TOP and \$SRCTOP or \$BLDTOP...") 156 if $ENV{TOP} && ($ENV{SRCTOP} || $ENV{BLDTOP}); 157 158 __env(); 159 160 BAIL_OUT("setup() expects the file Configure in the source top directory") 161 unless -f srctop_file("Configure"); 162 163 __cwd($directories{RESULTS}); 164} 165 166=over 4 167 168=item B<indir "SUBDIR" =E<gt> sub BLOCK, OPTS> 169 170C<indir> is used to run a part of the recipe in a different directory than 171the one C<setup> moved into, usually a subdirectory, given by SUBDIR. 172The part of the recipe that's run there is given by the codeblock BLOCK. 173 174C<indir> takes some additional options OPTS that affect the subdirectory: 175 176=over 4 177 178=item B<create =E<gt> 0|1> 179 180When set to 1 (or any value that perl preceives as true), the subdirectory 181will be created if it doesn't already exist. This happens before BLOCK 182is executed. 183 184=item B<cleanup =E<gt> 0|1> 185 186When set to 1 (or any value that perl preceives as true), the subdirectory 187will be cleaned out and removed. This happens both before and after BLOCK 188is executed. 189 190=back 191 192An example: 193 194 indir "foo" => sub { 195 ok(run(app(["openssl", "version"]), stdout => "foo.txt")); 196 if (ok(open(RESULT, "foo.txt"), "reading foo.txt")) { 197 my $line = <RESULT>; 198 close RESULT; 199 is($line, qr/^OpenSSL 1\./, 200 "check that we're using OpenSSL 1.x.x"); 201 } 202 }, create => 1, cleanup => 1; 203 204=back 205 206=cut 207 208sub indir { 209 my $subdir = shift; 210 my $codeblock = shift; 211 my %opts = @_; 212 213 my $reverse = __cwd($subdir,%opts); 214 BAIL_OUT("FAILURE: indir, \"$subdir\" wasn't possible to move into") 215 unless $reverse; 216 217 $codeblock->(); 218 219 __cwd($reverse); 220 221 if ($opts{cleanup}) { 222 rmtree($subdir, { safe => 0 }); 223 } 224} 225 226=over 4 227 228=item B<app ARRAYREF, OPTS> 229 230=item B<test ARRAYREF, OPTS> 231 232Both of these functions take a reference to a list that is a command and 233its arguments, and some additional options (described further on). 234 235C<app> expects to find the given command (the first item in the given list 236reference) as an executable in C<$BIN_D> (if defined, otherwise C<$TOP/apps> 237or C<$BLDTOP/apps>). 238 239C<test> expects to find the given command (the first item in the given list 240reference) as an executable in C<$TEST_D> (if defined, otherwise C<$TOP/test> 241or C<$BLDTOP/test>). 242 243Both return a CODEREF to be used by C<run>, C<pipe> or C<cmdstr>. 244 245The options that both C<app> and C<test> can take are in the form of hash 246values: 247 248=over 4 249 250=item B<stdin =E<gt> PATH> 251 252=item B<stdout =E<gt> PATH> 253 254=item B<stderr =E<gt> PATH> 255 256In all three cases, the corresponding standard input, output or error is 257redirected from (for stdin) or to (for the others) a file given by the 258string PATH, I<or>, if the value is C<undef>, C</dev/null> or similar. 259 260=back 261 262=item B<perlapp ARRAYREF, OPTS> 263 264=item B<perltest ARRAYREF, OPTS> 265 266Both these functions function the same way as B<app> and B<test>, except 267that they expect the command to be a perl script. Also, they support one 268more option: 269 270=over 4 271 272=item B<interpreter_args =E<gt> ARRAYref> 273 274The array reference is a set of arguments for perl rather than the script. 275Take care so that none of them can be seen as a script! Flags and their 276eventual arguments only! 277 278=back 279 280An example: 281 282 ok(run(perlapp(["foo.pl", "arg1"], 283 interpreter_args => [ "-I", srctop_dir("test") ]))); 284 285=back 286 287=cut 288 289sub app { 290 my $cmd = shift; 291 my %opts = @_; 292 return sub { my $num = shift; 293 return __build_cmd($num, \&__apps_file, $cmd, %opts); } 294} 295 296sub fuzz { 297 my $cmd = shift; 298 my %opts = @_; 299 return sub { my $num = shift; 300 return __build_cmd($num, \&__fuzz_file, $cmd, %opts); } 301} 302 303sub test { 304 my $cmd = shift; 305 my %opts = @_; 306 return sub { my $num = shift; 307 return __build_cmd($num, \&__test_file, $cmd, %opts); } 308} 309 310sub perlapp { 311 my $cmd = shift; 312 my %opts = @_; 313 return sub { my $num = shift; 314 return __build_cmd($num, \&__perlapps_file, $cmd, %opts); } 315} 316 317sub perltest { 318 my $cmd = shift; 319 my %opts = @_; 320 return sub { my $num = shift; 321 return __build_cmd($num, \&__perltest_file, $cmd, %opts); } 322} 323 324=over 4 325 326=item B<run CODEREF, OPTS> 327 328This CODEREF is expected to be the value return by C<app> or C<test>, 329anything else will most likely cause an error unless you know what you're 330doing. 331 332C<run> executes the command returned by CODEREF and return either the 333resulting output (if the option C<capture> is set true) or a boolean indicating 334if the command succeeded or not. 335 336The options that C<run> can take are in the form of hash values: 337 338=over 4 339 340=item B<capture =E<gt> 0|1> 341 342If true, the command will be executed with a perl backtick, and C<run> will 343return the resulting output as an array of lines. If false or not given, 344the command will be executed with C<system()>, and C<run> will return 1 if 345the command was successful or 0 if it wasn't. 346 347=back 348 349For further discussion on what is considered a successful command or not, see 350the function C<with> further down. 351 352=back 353 354=cut 355 356sub run { 357 my ($cmd, $display_cmd) = shift->(0); 358 my %opts = @_; 359 360 return () if !$cmd; 361 362 my $prefix = ""; 363 if ( $^O eq "VMS" ) { # VMS 364 $prefix = "pipe "; 365 } 366 367 my @r = (); 368 my $r = 0; 369 my $e = 0; 370 371 # In non-verbose, we want to shut up the command interpreter, in case 372 # it has something to complain about. On VMS, it might complain both 373 # on stdout and stderr 374 my $save_STDOUT; 375 my $save_STDERR; 376 if ($ENV{HARNESS_ACTIVE} && !$ENV{HARNESS_VERBOSE}) { 377 open $save_STDOUT, '>&', \*STDOUT or die "Can't dup STDOUT: $!"; 378 open $save_STDERR, '>&', \*STDERR or die "Can't dup STDERR: $!"; 379 open STDOUT, ">", devnull(); 380 open STDERR, ">", devnull(); 381 } 382 383 # The dance we do with $? is the same dance the Unix shells appear to 384 # do. For example, a program that gets aborted (and therefore signals 385 # SIGABRT = 6) will appear to exit with the code 134. We mimic this 386 # to make it easier to compare with a manual run of the command. 387 if ($opts{capture}) { 388 @r = `$prefix$cmd`; 389 $e = ($? & 0x7f) ? ($? & 0x7f)|0x80 : ($? >> 8); 390 } else { 391 system("$prefix$cmd"); 392 $e = ($? & 0x7f) ? ($? & 0x7f)|0x80 : ($? >> 8); 393 $r = $hooks{exit_checker}->($e); 394 } 395 396 if ($ENV{HARNESS_ACTIVE} && !$ENV{HARNESS_VERBOSE}) { 397 close STDOUT; 398 close STDERR; 399 open STDOUT, '>&', $save_STDOUT or die "Can't restore STDOUT: $!"; 400 open STDERR, '>&', $save_STDERR or die "Can't restore STDERR: $!"; 401 } 402 403 print STDERR "$prefix$display_cmd => $e\n" 404 if !$ENV{HARNESS_ACTIVE} || $ENV{HARNESS_VERBOSE}; 405 406 # At this point, $? stops being interesting, and unfortunately, 407 # there are Test::More versions that get picky if we leave it 408 # non-zero. 409 $? = 0; 410 411 if ($opts{capture}) { 412 return @r; 413 } else { 414 return $r; 415 } 416} 417 418END { 419 my $tb = Test::More->builder; 420 my $failure = scalar(grep { $_ == 0; } $tb->summary); 421 if ($failure && $end_with_bailout) { 422 BAIL_OUT("Stoptest!"); 423 } 424} 425 426=head2 Utility functions 427 428The following functions are exported on request when using C<OpenSSL::Test>. 429 430 # To only get the bldtop_file and srctop_file functions. 431 use OpenSSL::Test qw/bldtop_file srctop_file/; 432 433 # To only get the bldtop_file function in addition to the default ones. 434 use OpenSSL::Test qw/:DEFAULT bldtop_file/; 435 436=cut 437 438# Utility functions, exported on request 439 440=over 4 441 442=item B<bldtop_dir LIST> 443 444LIST is a list of directories that make up a path from the top of the OpenSSL 445build directory (as indicated by the environment variable C<$TOP> or 446C<$BLDTOP>). 447C<bldtop_dir> returns the resulting directory as a string, adapted to the local 448operating system. 449 450=back 451 452=cut 453 454sub bldtop_dir { 455 return __bldtop_dir(@_); # This caters for operating systems that have 456 # a very distinct syntax for directories. 457} 458 459=over 4 460 461=item B<bldtop_file LIST, FILENAME> 462 463LIST is a list of directories that make up a path from the top of the OpenSSL 464build directory (as indicated by the environment variable C<$TOP> or 465C<$BLDTOP>) and FILENAME is the name of a file located in that directory path. 466C<bldtop_file> returns the resulting file path as a string, adapted to the local 467operating system. 468 469=back 470 471=cut 472 473sub bldtop_file { 474 return __bldtop_file(@_); 475} 476 477=over 4 478 479=item B<srctop_dir LIST> 480 481LIST is a list of directories that make up a path from the top of the OpenSSL 482source directory (as indicated by the environment variable C<$TOP> or 483C<$SRCTOP>). 484C<srctop_dir> returns the resulting directory as a string, adapted to the local 485operating system. 486 487=back 488 489=cut 490 491sub srctop_dir { 492 return __srctop_dir(@_); # This caters for operating systems that have 493 # a very distinct syntax for directories. 494} 495 496=over 4 497 498=item B<srctop_file LIST, FILENAME> 499 500LIST is a list of directories that make up a path from the top of the OpenSSL 501source directory (as indicated by the environment variable C<$TOP> or 502C<$SRCTOP>) and FILENAME is the name of a file located in that directory path. 503C<srctop_file> returns the resulting file path as a string, adapted to the local 504operating system. 505 506=back 507 508=cut 509 510sub srctop_file { 511 return __srctop_file(@_); 512} 513 514=over 4 515 516=item B<data_file LIST, FILENAME> 517 518LIST is a list of directories that make up a path from the data directory 519associated with the test (see L</DESCRIPTION> above) and FILENAME is the name 520of a file located in that directory path. C<data_file> returns the resulting 521file path as a string, adapted to the local operating system. 522 523=back 524 525=cut 526 527sub data_file { 528 return __data_file(@_); 529} 530 531=over 4 532 533=item B<pipe LIST> 534 535LIST is a list of CODEREFs returned by C<app> or C<test>, from which C<pipe> 536creates a new command composed of all the given commands put together in a 537pipe. C<pipe> returns a new CODEREF in the same manner as C<app> or C<test>, 538to be passed to C<run> for execution. 539 540=back 541 542=cut 543 544sub pipe { 545 my @cmds = @_; 546 return 547 sub { 548 my @cs = (); 549 my @dcs = (); 550 my @els = (); 551 my $counter = 0; 552 foreach (@cmds) { 553 my ($c, $dc, @el) = $_->(++$counter); 554 555 return () if !$c; 556 557 push @cs, $c; 558 push @dcs, $dc; 559 push @els, @el; 560 } 561 return ( 562 join(" | ", @cs), 563 join(" | ", @dcs), 564 @els 565 ); 566 }; 567} 568 569=over 4 570 571=item B<with HASHREF, CODEREF> 572 573C<with> will temporarly install hooks given by the HASHREF and then execute 574the given CODEREF. Hooks are usually expected to have a coderef as value. 575 576The currently available hoosk are: 577 578=over 4 579 580=item B<exit_checker =E<gt> CODEREF> 581 582This hook is executed after C<run> has performed its given command. The 583CODEREF receives the exit code as only argument and is expected to return 5841 (if the exit code indicated success) or 0 (if the exit code indicated 585failure). 586 587=back 588 589=back 590 591=cut 592 593sub with { 594 my $opts = shift; 595 my %opts = %{$opts}; 596 my $codeblock = shift; 597 598 my %saved_hooks = (); 599 600 foreach (keys %opts) { 601 $saved_hooks{$_} = $hooks{$_} if exists($hooks{$_}); 602 $hooks{$_} = $opts{$_}; 603 } 604 605 $codeblock->(); 606 607 foreach (keys %saved_hooks) { 608 $hooks{$_} = $saved_hooks{$_}; 609 } 610} 611 612=over 4 613 614=item B<cmdstr CODEREF, OPTS> 615 616C<cmdstr> takes a CODEREF from C<app> or C<test> and simply returns the 617command as a string. 618 619C<cmdstr> takes some additiona options OPTS that affect the string returned: 620 621=over 4 622 623=item B<display =E<gt> 0|1> 624 625When set to 0, the returned string will be with all decorations, such as a 626possible redirect of stderr to the null device. This is suitable if the 627string is to be used directly in a recipe. 628 629When set to 1, the returned string will be without extra decorations. This 630is suitable for display if that is desired (doesn't confuse people with all 631internal stuff), or if it's used to pass a command down to a subprocess. 632 633Default: 0 634 635=back 636 637=back 638 639=cut 640 641sub cmdstr { 642 my ($cmd, $display_cmd) = shift->(0); 643 my %opts = @_; 644 645 if ($opts{display}) { 646 return $display_cmd; 647 } else { 648 return $cmd; 649 } 650} 651 652=over 4 653 654=item B<quotify LIST> 655 656LIST is a list of strings that are going to be used as arguments for a 657command, and makes sure to inject quotes and escapes as necessary depending 658on the content of each string. 659 660This can also be used to put quotes around the executable of a command. 661I<This must never ever be done on VMS.> 662 663=back 664 665=cut 666 667sub quotify { 668 # Unix setup (default if nothing else is mentioned) 669 my $arg_formatter = 670 sub { $_ = shift; 671 ($_ eq '' || /\s|[\{\}\\\$\[\]\*\?\|\&:;<>]/) ? "'$_'" : $_ }; 672 673 if ( $^O eq "VMS") { # VMS setup 674 $arg_formatter = sub { 675 $_ = shift; 676 if ($_ eq '' || /\s|["[:upper:]]/) { 677 s/"/""/g; 678 '"'.$_.'"'; 679 } else { 680 $_; 681 } 682 }; 683 } elsif ( $^O eq "MSWin32") { # MSWin setup 684 $arg_formatter = sub { 685 $_ = shift; 686 if ($_ eq '' || /\s|["\|\&\*\;<>]/) { 687 s/(["\\])/\\$1/g; 688 '"'.$_.'"'; 689 } else { 690 $_; 691 } 692 }; 693 } 694 695 return map { $arg_formatter->($_) } @_; 696} 697 698###################################################################### 699# private functions. These are never exported. 700 701=head1 ENVIRONMENT 702 703OpenSSL::Test depends on some environment variables. 704 705=over 4 706 707=item B<TOP> 708 709This environment variable is mandatory. C<setup> will check that it's 710defined and that it's a directory that contains the file C<Configure>. 711If this isn't so, C<setup> will C<BAIL_OUT>. 712 713=item B<BIN_D> 714 715If defined, its value should be the directory where the openssl application 716is located. Defaults to C<$TOP/apps> (adapted to the operating system). 717 718=item B<TEST_D> 719 720If defined, its value should be the directory where the test applications 721are located. Defaults to C<$TOP/test> (adapted to the operating system). 722 723=item B<STOPTEST> 724 725If defined, it puts testing in a different mode, where a recipe with 726failures will result in a C<BAIL_OUT> at the end of its run. 727 728=back 729 730=cut 731 732sub __env { 733 (my $recipe_datadir = basename($0)) =~ s/\.t$/_data/i; 734 735 $directories{SRCTOP} = $ENV{SRCTOP} || $ENV{TOP}; 736 $directories{BLDTOP} = $ENV{BLDTOP} || $ENV{TOP}; 737 $directories{BLDAPPS} = $ENV{BIN_D} || __bldtop_dir("apps"); 738 $directories{SRCAPPS} = __srctop_dir("apps"); 739 $directories{BLDFUZZ} = __bldtop_dir("fuzz"); 740 $directories{SRCFUZZ} = __srctop_dir("fuzz"); 741 $directories{BLDTEST} = $ENV{TEST_D} || __bldtop_dir("test"); 742 $directories{SRCTEST} = __srctop_dir("test"); 743 $directories{SRCDATA} = __srctop_dir("test", "recipes", 744 $recipe_datadir); 745 $directories{RESULTS} = $ENV{RESULT_D} || $directories{BLDTEST}; 746 747 push @direnv, "TOP" if $ENV{TOP}; 748 push @direnv, "SRCTOP" if $ENV{SRCTOP}; 749 push @direnv, "BLDTOP" if $ENV{BLDTOP}; 750 push @direnv, "BIN_D" if $ENV{BIN_D}; 751 push @direnv, "TEST_D" if $ENV{TEST_D}; 752 push @direnv, "RESULT_D" if $ENV{RESULT_D}; 753 754 $end_with_bailout = $ENV{STOPTEST} ? 1 : 0; 755}; 756 757sub __srctop_file { 758 BAIL_OUT("Must run setup() first") if (! $test_name); 759 760 my $f = pop; 761 return catfile($directories{SRCTOP},@_,$f); 762} 763 764sub __srctop_dir { 765 BAIL_OUT("Must run setup() first") if (! $test_name); 766 767 return catdir($directories{SRCTOP},@_); 768} 769 770sub __bldtop_file { 771 BAIL_OUT("Must run setup() first") if (! $test_name); 772 773 my $f = pop; 774 return catfile($directories{BLDTOP},@_,$f); 775} 776 777sub __bldtop_dir { 778 BAIL_OUT("Must run setup() first") if (! $test_name); 779 780 return catdir($directories{BLDTOP},@_); 781} 782 783sub __exeext { 784 my $ext = ""; 785 if ($^O eq "VMS" ) { # VMS 786 $ext = ".exe"; 787 } elsif ($^O eq "MSWin32") { # Windows 788 $ext = ".exe"; 789 } 790 return $ENV{"EXE_EXT"} || $ext; 791} 792 793sub __test_file { 794 BAIL_OUT("Must run setup() first") if (! $test_name); 795 796 my $f = pop; 797 my $out = catfile($directories{BLDTEST},@_,$f . __exeext()); 798 $out = catfile($directories{SRCTEST},@_,$f) unless -x $out; 799 return $out; 800} 801 802sub __perltest_file { 803 BAIL_OUT("Must run setup() first") if (! $test_name); 804 805 my $f = pop; 806 my $out = catfile($directories{BLDTEST},@_,$f); 807 $out = catfile($directories{SRCTEST},@_,$f) unless -f $out; 808 return ($^X, $out); 809} 810 811sub __apps_file { 812 BAIL_OUT("Must run setup() first") if (! $test_name); 813 814 my $f = pop; 815 my $out = catfile($directories{BLDAPPS},@_,$f . __exeext()); 816 $out = catfile($directories{SRCAPPS},@_,$f) unless -x $out; 817 return $out; 818} 819 820sub __fuzz_file { 821 BAIL_OUT("Must run setup() first") if (! $test_name); 822 823 my $f = pop; 824 my $out = catfile($directories{BLDFUZZ},@_,$f . __exeext()); 825 $out = catfile($directories{SRCFUZZ},@_,$f) unless -x $out; 826 return $out; 827} 828 829sub __perlapps_file { 830 BAIL_OUT("Must run setup() first") if (! $test_name); 831 832 my $f = pop; 833 my $out = catfile($directories{BLDAPPS},@_,$f); 834 $out = catfile($directories{SRCAPPS},@_,$f) unless -f $out; 835 return ($^X, $out); 836} 837 838sub __data_file { 839 BAIL_OUT("Must run setup() first") if (! $test_name); 840 841 my $f = pop; 842 return catfile($directories{SRCDATA},@_,$f); 843} 844 845sub __results_file { 846 BAIL_OUT("Must run setup() first") if (! $test_name); 847 848 my $f = pop; 849 return catfile($directories{RESULTS},@_,$f); 850} 851 852sub __cwd { 853 my $dir = catdir(shift); 854 my %opts = @_; 855 my $abscurdir = rel2abs(curdir()); 856 my $absdir = rel2abs($dir); 857 my $reverse = abs2rel($abscurdir, $absdir); 858 859 # PARANOIA: if we're not moving anywhere, we do nothing more 860 if ($abscurdir eq $absdir) { 861 return $reverse; 862 } 863 864 # Do not support a move to a different volume for now. Maybe later. 865 BAIL_OUT("FAILURE: \"$dir\" moves to a different volume, not supported") 866 if $reverse eq $abscurdir; 867 868 # If someone happened to give a directory that leads back to the current, 869 # it's extremely silly to do anything more, so just simulate that we did 870 # move. 871 # In this case, we won't even clean it out, for safety's sake. 872 return "." if $reverse eq ""; 873 874 $dir = canonpath($dir); 875 if ($opts{create}) { 876 mkpath($dir); 877 } 878 879 # We are recalculating the directories we keep track of, but need to save 880 # away the result for after having moved into the new directory. 881 my %tmp_directories = (); 882 my %tmp_ENV = (); 883 884 # For each of these directory variables, figure out where they are relative 885 # to the directory we want to move to if they aren't absolute (if they are, 886 # they don't change!) 887 my @dirtags = sort keys %directories; 888 foreach (@dirtags) { 889 if (!file_name_is_absolute($directories{$_})) { 890 my $newpath = abs2rel(rel2abs($directories{$_}), rel2abs($dir)); 891 $tmp_directories{$_} = $newpath; 892 } 893 } 894 895 # Treat each environment variable that was used to get us the values in 896 # %directories the same was as the paths in %directories, so any sub 897 # process can use their values properly as well 898 foreach (@direnv) { 899 if (!file_name_is_absolute($ENV{$_})) { 900 my $newpath = abs2rel(rel2abs($ENV{$_}), rel2abs($dir)); 901 $tmp_ENV{$_} = $newpath; 902 } 903 } 904 905 # Should we just bail out here as well? I'm unsure. 906 return undef unless chdir($dir); 907 908 if ($opts{cleanup}) { 909 rmtree(".", { safe => 0, keep_root => 1 }); 910 } 911 912 # We put back new values carefully. Doing the obvious 913 # %directories = ( %tmp_irectories ) 914 # will clear out any value that happens to be an absolute path 915 foreach (keys %tmp_directories) { 916 $directories{$_} = $tmp_directories{$_}; 917 } 918 foreach (keys %tmp_ENV) { 919 $ENV{$_} = $tmp_ENV{$_}; 920 } 921 922 if ($debug) { 923 print STDERR "DEBUG: __cwd(), directories and files:\n"; 924 print STDERR " \$directories{BLDTEST} = \"$directories{BLDTEST}\"\n"; 925 print STDERR " \$directories{SRCTEST} = \"$directories{SRCTEST}\"\n"; 926 print STDERR " \$directories{SRCDATA} = \"$directories{SRCDATA}\"\n"; 927 print STDERR " \$directories{RESULTS} = \"$directories{RESULTS}\"\n"; 928 print STDERR " \$directories{BLDAPPS} = \"$directories{BLDAPPS}\"\n"; 929 print STDERR " \$directories{SRCAPPS} = \"$directories{SRCAPPS}\"\n"; 930 print STDERR " \$directories{SRCTOP} = \"$directories{SRCTOP}\"\n"; 931 print STDERR " \$directories{BLDTOP} = \"$directories{BLDTOP}\"\n"; 932 print STDERR "\n"; 933 print STDERR " current directory is \"",curdir(),"\"\n"; 934 print STDERR " the way back is \"$reverse\"\n"; 935 } 936 937 return $reverse; 938} 939 940sub __fixup_cmd { 941 my $prog = shift; 942 my $exe_shell = shift; 943 944 my $prefix = __bldtop_file("util", "shlib_wrap.sh")." "; 945 946 if (defined($exe_shell)) { 947 $prefix = "$exe_shell "; 948 } elsif ($^O eq "VMS" ) { # VMS 949 $prefix = ($prog =~ /^(?:[\$a-z0-9_]+:)?[<\[]/i ? "mcr " : "mcr []"); 950 } elsif ($^O eq "MSWin32") { # Windows 951 $prefix = ""; 952 } 953 954 # We test both with and without extension. The reason 955 # is that we might be passed a complete file spec, with 956 # extension. 957 if ( ! -x $prog ) { 958 my $prog = "$prog"; 959 if ( ! -x $prog ) { 960 $prog = undef; 961 } 962 } 963 964 if (defined($prog)) { 965 # Make sure to quotify the program file on platforms that may 966 # have spaces or similar in their path name. 967 # To our knowledge, VMS is the exception where quotifying should 968 # never happen. 969 ($prog) = quotify($prog) unless $^O eq "VMS"; 970 return $prefix.$prog; 971 } 972 973 print STDERR "$prog not found\n"; 974 return undef; 975} 976 977sub __build_cmd { 978 BAIL_OUT("Must run setup() first") if (! $test_name); 979 980 my $num = shift; 981 my $path_builder = shift; 982 # Make a copy to not destroy the caller's array 983 my @cmdarray = ( @{$_[0]} ); shift; 984 my %opts = @_; 985 986 # We do a little dance, as $path_builder might return a list of 987 # more than one. If so, only the first is to be considered a 988 # program to fix up, the rest is part of the arguments. This 989 # happens for perl scripts, where $path_builder will return 990 # a list of two, $^X and the script name. 991 # Also, if $path_builder returned more than one, we don't apply 992 # the EXE_SHELL environment variable. 993 my @prog = ($path_builder->(shift @cmdarray)); 994 my $first = shift @prog; 995 my $exe_shell = @prog ? undef : $ENV{EXE_SHELL}; 996 my $cmd = __fixup_cmd($first, $exe_shell); 997 if (@prog) { 998 if ( ! -f $prog[0] ) { 999 print STDERR "$prog[0] not found\n"; 1000 $cmd = undef; 1001 } 1002 } 1003 my @args = (@prog, @cmdarray); 1004 if (defined($opts{interpreter_args})) { 1005 unshift @args, @{$opts{interpreter_args}}; 1006 } 1007 1008 return () if !$cmd; 1009 1010 my $arg_str = ""; 1011 my $null = devnull(); 1012 1013 1014 $arg_str = " ".join(" ", quotify @args) if @args; 1015 1016 my $fileornull = sub { $_[0] ? $_[0] : $null; }; 1017 my $stdin = ""; 1018 my $stdout = ""; 1019 my $stderr = ""; 1020 my $saved_stderr = undef; 1021 $stdin = " < ".$fileornull->($opts{stdin}) if exists($opts{stdin}); 1022 $stdout= " > ".$fileornull->($opts{stdout}) if exists($opts{stdout}); 1023 $stderr=" 2> ".$fileornull->($opts{stderr}) if exists($opts{stderr}); 1024 1025 my $display_cmd = "$cmd$arg_str$stdin$stdout$stderr"; 1026 1027 $stderr=" 2> ".$null 1028 unless $stderr || !$ENV{HARNESS_ACTIVE} || $ENV{HARNESS_VERBOSE}; 1029 1030 $cmd .= "$arg_str$stdin$stdout$stderr"; 1031 1032 if ($debug) { 1033 print STDERR "DEBUG[__build_cmd]: \$cmd = \"$cmd\"\n"; 1034 print STDERR "DEBUG[__build_cmd]: \$display_cmd = \"$display_cmd\"\n"; 1035 } 1036 1037 return ($cmd, $display_cmd); 1038} 1039 1040=head1 SEE ALSO 1041 1042L<Test::More>, L<Test::Harness> 1043 1044=head1 AUTHORS 1045 1046Richard Levitte E<lt>levitte@openssl.orgE<gt> with assitance and 1047inspiration from Andy Polyakov E<lt>appro@openssl.org<gt>. 1048 1049=cut 1050 10511; 1052