Commit aec27d4d authored by Richard Levitte's avatar Richard Levitte
Browse files

Groundwork for a perl based testing framework 



The idea with this perl based testing framework is to make use of
what's delivered with perl and exists on all sorts of platforms.

The choice came to using Test::More and Test::Harness, as that seems
to be the most widely spread foundation, even if perl is aged.

The main runner of the show is run_tests.pl.  As it currently stands,
it's designed to run from inside Makefile, but it's absolutely
possible to run it from the command line as well, like so:

	cd test
	OPENSSL_SRCDIR=.. perl run_tests.pl

The tester scripts themselves are stored in the subdirectory recipes/,
and initially, we have two such scripts, recipes/00-check_testalltests.t
and recipes/00-check_testexes.t.  recipes/00-check_testalltests.t will
pick out the dependencies of "alltests" in test/Makefile, and check if
it can find recipes with corresponding names.  recipes/00-check_testexes.t
does something similar, but bases it on existing compiled test binaries.
They make it easy to figure out what's to be added, and will be
removed when this effort is finished.

Individual recipes can be run as well, of course, as they are perl
scripts in themselves.  For example, you can run only
recipes/00-check_testexes.t like so:

	cd test
	OPENSSL_SRCDIR=.. perl recipes/00-check_testexes.t

To make coding easier, there's a routine library OpenSSL::Test, which
is reachable in a perl script like so:

	use lib 'testlib';
	use OpenSSL::Test;

Reviewed-by: default avatarRich Salz <rsalz@openssl.org>
parent 8098fc56

test/recipes/00-check_testalltests.t

0 → 100644
+63 −0
Original line number Diff line number Diff line 
#! /usr/bin/perl



use strict;



use File::Spec::Functions;

use Test::More;



use lib 'testlib';

use OpenSSL::Test;



setup("check_testalltests");



my $Makefile = top_file("test","Makefile");



plan tests => 2;

if (ok(open(FH,$Makefile), "test/Makefile exists")) {

    subtest 'Finding test scripts for the alltests target' => sub {

	find_tests(\*FH); close FH;

    };

} else {

    diag("Expected to find $Makefile");

}



#-------------

# test script finder

sub find_tests {

    my $fh = shift;

    my $line;

    while(<$fh>) {

	chomp;

	$line = $_;

	last if /^alltests:/;

    }

    while(<$fh>) {

	chomp;

	my $l = $_;

	$line =~ s/\\\s*$/$l/;

	last if $line !~ /\\\s*$/;

    }

    close $fh;

    $line =~ s/^alltests:\s*//;



    # It's part of the test_ssl recipe

    $line =~ s/\s+test_ss\s+/ /;



    # It's split into sha1, sha256 and sha512

    $line =~ s/\s+test_sha\s+/ test_sha1 test_sha256 test_sha512 /;



    my %foundfiles =

	map {

	    s/^test_//;

	    $_ => top_file("test",

			   "recipes/[0-9][0-9]-test_$_.t"); } split(/\s+/,

								    $line);



    plan tests => scalar (keys %foundfiles);



    foreach (sort keys %foundfiles) {

	my @check = glob($foundfiles{$_});

	ok(scalar @check, "check that a test for $_ exists")

	    || diag("Expected to find something matching $foundfiles{$_}");

    }

}

test/recipes/00-check_testexes.t

0 → 100644
+53 −0
Original line number Diff line number Diff line 
#! /usr/bin/perl



use strict;



use File::Spec::Functions;

use Test::More;



use OpenSSL::Test qw/:DEFAULT top_file/;



setup("check_testexes");



my $MINFO = top_file("MINFO");



plan tests => 2;

if (ok(open(FH,$MINFO), "MINFO exists")) {

    subtest 'Finding test scripts for the compiled test binaries' => sub {

	find_tests(\*FH); close FH;

    };

} else {

    diag("Expected to find $MINFO, please run 'make files' in the top directory");

}



#-------------

# test script finder

sub find_tests {

    my $fh = shift;

    while(<$fh>) {

	chomp;

	last if /^RELATIVE_DIRECTORY=test$/;

    }

    while(<$fh>) {

	chomp;

	last if /^EXE=/;

    }



    s/^EXE=\s*//;

    s/\s*$//;

    my %foundfiles =

	map {

	    my $key = $_;

	    s/_?test$//;

	    s/(sha\d+)t/$1/;

	    $key => top_file("test",

			     "recipes/[0-9][0-9]-test_$_.t"); } split(/\s+/, $_);



    plan tests => scalar (keys %foundfiles);



    foreach (sort keys %foundfiles) {

	my @check = glob($foundfiles{$_});

	ok(scalar @check, "check that a test for $_ exists")

	    || diag("Expected to find something matching $foundfiles{$_}");

    }

}

test/run_tests.pl

0 → 100644
+43 −0
Original line number Diff line number Diff line 
#! /usr/bin/perl



use strict;

use warnings;



use File::Spec::Functions qw/catdir catfile curdir abs2rel rel2abs/;

use File::Basename;

use Test::Harness qw/runtests $switches/;



my $top = $ENV{TOP};

my $recipesdir = catdir($top, "test", "recipes");

my $testlib = catdir($top, "test", "testlib");



# It seems that $switches is getting interpretted with 'eval' or something

# like that, and that we need to take care of backslashes or they will

# disappear along the way.

$testlib =~ s|\\|\\\\|g if $^O eq "MSWin32";



# Test::Harness provides the variable $switches to give it

# switches to be used when it calls our recipes.

$switches = "-w \"-I$testlib\"";



my @tests = ( "alltests" );

if (@ARGV) {

    @tests = @ARGV;

}

if (grep /^alltests$/, @tests) {

    @tests = grep {

	basename($_) =~ /^[0-9][0-9]-[^\.]*\.t$/

    } glob(catfile($recipesdir,"*.t"));

} else {

    my @t = ();

    foreach (@tests) {

	push @t, grep {

	    basename($_) =~ /^[0-9][0-9]-[^\.]*\.t$/

	} glob(catfile($recipesdir,"*-$_.t"));

    }

    @tests = @t;

}



@tests = map { abs2rel($_, rel2abs(curdir())); } @tests;



runtests(sort @tests);

test/testlib/OpenSSL/Test.pm

0 → 100644
+379 −0
Original line number Diff line number Diff line 
package OpenSSL::Test;



use strict;

use warnings;



use Exporter;

use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);

$VERSION = "0.5";

@ISA = qw(Exporter);

@EXPORT = qw(setup indir app test run);

@EXPORT_OK = qw(top_dir top_file pipe with cmdstr quotify));





use File::Copy;

use File::Spec::Functions qw/file_name_is_absolute curdir canonpath splitdir

                             catdir catfile splitpath catpath devnull abs2rel

                             rel2abs/;

use File::Path qw/remove_tree mkpath/;

use Test::More;





my $test_name = undef;



my %directories = ();		# Directories we want to keep track of

				# TOP, APPS, TEST and RESULTS are the

				# ones we're interested in, corresponding

				# to the environment variables TOP (mandatory),

				# BIN_D, TEST_D and RESULT_D.



sub quotify;



sub __top_file {

    BAIL_OUT("Must run setup() first") if (! $test_name);



    my $f = pop;

    return catfile($directories{TOP},@_,$f);

}



sub __test_file {

    BAIL_OUT("Must run setup() first") if (! $test_name);



    my $f = pop;

    return catfile($directories{TEST},@_,$f);

}



sub __apps_file {

    BAIL_OUT("Must run setup() first") if (! $test_name);



    my $f = pop;

    return catfile($directories{APPS},@_,$f);

}



sub __results_file {

    BAIL_OUT("Must run setup() first") if (! $test_name);



    my $f = pop;

    return catfile($directories{RESULTS},@_,$f);

}



sub __test_log {

    return __results_file("$test_name.log");

}



sub top_dir {

    return __top_file(@_, "");	# This caters for operating systems that have

				# a very distinct syntax for directories.

}

sub top_file {

    return __top_file(@_);

}



sub __cwd {

    my $dir = shift;

    my %opts = @_;

    my $abscurdir = rel2abs(curdir());

    my $absdir = rel2abs($dir);

    my $reverse = abs2rel($abscurdir, $absdir);



    # PARANOIA: if we're not moving anywhere, we do nothing more

    if ($abscurdir eq $absdir) {

	return $reverse;

    }



    # Do not support a move to a different volume for now.  Maybe later.

    BAIL_OUT("FAILURE: \"$dir\" moves to a different volume, not supported")

	if $reverse eq $abscurdir;



    # If someone happened to give a directory that leads back to the current,

    # it's extremely silly to do anything more, so just simulate that we did

    # move.

    # In this case, we won't even clean it out, for safety's sake.

    return "." if $reverse eq "";



    $dir = canonpath($dir);

    if ($opts{create}) {

	mkpath($dir);

    }



    # Should we just bail out here as well?  I'm unsure.

    return undef unless chdir($dir);



    if ($opts{cleanup}) {

	remove_tree(".", { safe => 0, keep_root => 1 });

    }



    # For each of these directory variables, figure out where they are relative

    # to the directory we want to move to if they aren't absolute (if they are,

    # they don't change!)

    my @dirtags = ("TOP", "TEST", "APPS", "RESULTS");

    foreach (@dirtags) {

	if (!file_name_is_absolute($directories{$_})) {

	    my $newpath = abs2rel(rel2abs($directories{$_}), rel2abs($dir));

	    $directories{$_} = $newpath;

	}

    }



    if (0) {

	print STDERR "DEBUG: __cwd(), directories and files:\n";

	print STDERR "  \$directories{TEST}    = \"$directories{TEST}\"\n";

	print STDERR "  \$directories{RESULTS} = \"$directories{RESULTS}\"\n";

	print STDERR "  \$directories{APPS}    = \"$directories{APPS}\"\n";

	print STDERR "  \$directories{TOP}     = \"$directories{TOP}\"\n";

	print STDERR "  \$test_log             = \"",__test_log(),"\"\n";

	print STDERR "\n";

	print STDERR "  current directory is \"",curdir(),"\"\n";

	print STDERR "  the way back is \"$reverse\"\n";

    }



    return $reverse;

}



sub setup {

    $test_name = shift;



    BAIL_OUT("setup() must receive a name") unless $test_name;

    BAIL_OUT("setup() needs \$TOP to be defined") unless $ENV{TOP};



    $directories{TOP}     = $ENV{TOP},

    $directories{APPS}    = $ENV{BIN_D}    || catdir($directories{TOP},"apps");

    $directories{TEST}    = $ENV{TEST_D}   || catdir($directories{TOP},"test");

    $directories{RESULTS} = $ENV{RESULT_D} || $directories{TEST};



    BAIL_OUT("setup() expects the file Configure in the \$TOP directory")

	unless -f top_file("Configure");



    __cwd($directories{RESULTS});



    # Loop in case we're on a platform with more than one file generation

    1 while unlink(__test_log());

}



sub indir {

    my $subdir = shift;

    my $codeblock = shift;

    my %opts = @_;



    my $reverse = __cwd($subdir,%opts);

    BAIL_OUT("FAILURE: indir, \"$subdir\" wasn't possible to move into")

	unless $reverse;



    $codeblock->();



    __cwd($reverse);



    if ($opts{cleanup}) {

	remove_tree($subdir, { safe => 0 });

    }

}



my %hooks = (

    exit_checker => sub { return shift == 0 ? 1 : 0 }

    );



sub with {

    my $opts = shift;

    my %opts = %{$opts};

    my $codeblock = shift;



    my %saved_hooks = ();



    foreach (keys %opts) {

	$saved_hooks{$_} = $hooks{$_}	if exists($hooks{$_});

	$hooks{$_} = $opts{$_};

    }



    $codeblock->();



    foreach (keys %saved_hooks) {

	$hooks{$_} = $saved_hooks{$_};

    }

}



sub __fixup_cmd {

    my $prog = shift;



    my $prefix = __top_file("util", "shlib_wrap.sh")." ";

    my $ext = $ENV{"EXE_EXT"} || "";



    if ( $^O eq "VMS" ) {	# VMS

	$prefix = "mcr ";

	$ext = ".exe";

    } elsif ($^O eq "MSWin32") { # Windows

	$prefix = "";

	$ext = ".exe";

    }



    # We test both with and without extension.  The reason

    # is that we might, for example, be passed a Perl script

    # ending with .pl...

    my $file = "$prog$ext";

    if ( -x $file ) {

	return $prefix.$file;

    } elsif ( -f $prog ) {

	return $prog;

    }



    print STDERR "$prog not found\n";

    return undef;

}



sub __build_cmd {

    BAIL_OUT("Must run setup() first") if (! $test_name);



    my $num = shift;

    my $path_builder = shift;

    my $cmd = __fixup_cmd($path_builder->(shift @{$_[0]}));

    my @args = @{$_[0]}; shift;

    my %opts = @_;



    return () if !$cmd;



    my $arg_str = "";

    my $null = devnull();





    $arg_str = " ".join(" ", quotify @args) if @args;



    my $fileornull = sub { $_[0] ? $_[0] : $null; };

    my $stdin = "";

    my $stdout = "";

    my $stderr = "";

    my $saved_stderr = undef;

    $stdin = " < ".$fileornull->($opts{stdin})  if exists($opts{stdin});

    $stdout= " > ".$fileornull->($opts{stdout}) if exists($opts{stdout});

    $stderr=" 2> ".$fileornull->($opts{stderr}) if exists($opts{stderr});



    $saved_stderr = $opts{stderr}		if defined($opts{stderr});



    my $errlog = $num ? "$test_name.$num.tmp_err" : "$test_name.tmp_err";

    my $display_cmd = "$cmd$arg_str$stdin$stdout$stderr";

    $cmd .= "$arg_str$stdin$stdout 2> $errlog";



    return ($cmd, $display_cmd, $errlog => $saved_stderr);

}



sub app {

    my $cmd = shift;

    my %opts = @_;

    return sub { my $num = shift;

		 return __build_cmd($num, \&__apps_file, $cmd, %opts); }

}



sub test {

    my $cmd = shift;

    my %opts = @_;

    return sub { my $num = shift;

		 return __build_cmd($num, \&__test_file, $cmd, %opts); }

}



sub cmdstr {

    my ($cmd, $display_cmd, %errlogs) = shift->(0);



    return $display_cmd;

}



sub run {

    my ($cmd, $display_cmd, %errlogs) = shift->(0);

    my %opts = @_;



    return () if !$cmd;



    my $prefix = "";

    if ( $^O eq "VMS" ) {	# VMS

	$prefix = "pipe ";

    } elsif ($^O eq "MSWin32") { # MSYS

	$prefix = "cmd /c ";

    }



    my @r = ();

    my $r = 0;

    my $e = 0;

    if ($opts{capture}) {

	@r = `$prefix$cmd`;

	$e = $? >> 8;

    } else {

	system("$prefix$cmd");

	$e = $? >> 8;

	$r = $hooks{exit_checker}->($e);

    }



    # At this point, $? stops being interesting, and unfortunately,

    # there are Test::More versions that get picky if we leave it

    # non-zero.

    $? = 0;



    open ERR, ">>", __test_log();

    { local $| = 1; print ERR "$display_cmd => $e\n"; }

    foreach (keys %errlogs) {

	copy($_,\*ERR);

	copy($_,$errlogs{$_}) if defined($errlogs{$_});

	unlink($_);

    }

    close ERR;



    if ($opts{capture}) {

	return @r;

    } else {

	return $r;

    }

}



sub pipe {

    my @cmds = @_;

    return

	sub {

	    my @cs  = ();

	    my @dcs = ();

	    my @els = ();

	    my $counter = 0;

	    foreach (@cmds) {

		my ($c, $dc, @el) = $_->(++$counter);



		return () if !$c;



		push @cs, $c;

		push @dcs, $dc;

		push @els, @el;

	    }

	    return (

		join(" | ", @cs),

		join(" | ", @dcs),

		@els

		);

    };

}



# Utility functions, some of which are exported on request



sub quotify {

    # Unix setup (default if nothing else is mentioned)

    my $arg_formatter =

	sub { $_ = shift; /\s|[\{\}\\\$\[\]\*\?\|\&:;<>]/ ? "'$_'" : $_ };



    if ( $^O eq "VMS") {	# VMS setup

	$arg_formatter = sub {

	    $_ = shift;

	    if (/\s|["[:upper:]]/) {

		s/"/""/g;

		'"'.$_.'"';

	    } else {

		$_;

	    }

	};

    } elsif ( $^O eq "MSWin32") { # MSWin setup

	$arg_formatter = sub {

	    $_ = shift;

	    if (/\s|["\|\&\*\;<>]/) {

		s/(["\\])/\\$1/g;

		'"'.$_.'"';

	    } else {

		$_;

	    }

	};

    }



    return map { $arg_formatter->($_) } @_;

}



1;