#!/usr/bin/perl -w
# $Id: //info.ravenbrook.com/project/mps/master/test/test/script/clib#9 $
#
# subroutines to compile test libraries, and check whether they
# need to be compiled
#
1;
use Cwd;
use File::Path qw(rmtree);
sub clib {
my $success = 1;
my $tlfile;
my $tlobj;
&objpurge();
&mpslibbuild();
&scrutinize();
&logcomment("Compiling test libraries.");
open(MANIFEST, "$testlib_dir/manifest");
while (defined($tlfile = <MANIFEST>)) {
unless ($tlfile =~ /^%/) {
chomp($tlfile);
$tlfile = $testlib_dir."/".$tlfile;
$tlobj = $tlfile;
$tlobj =~ s/\.c/$obj_suffix/;
$tlobj =~ s/$testlib_dir/$obj_dir/;
if (&compile($tlfile, $tlobj)) {
} else {
$success = 0;
&logcomment(" failed on $tlfile.");
}
}
}
close(MANIFEST);
&record_clib($success);
return $success;
}
#
# delete everything in the object directory
#
sub objpurge {
unless (opendir(DIR, $obj_dir)) {
die "Failed to open object directory $obj_dir.\n";
}
&logcomment("Cleaning out old object files.");
foreach (readdir(DIR)) {
unless ($_ eq "." || $_ eq ".." || rmtree $obj_dir."/".$_) {
&logcomment(" ... but failed to delete $_.");
}
}
closedir(DIR);
}
#
# Build the MPS object file.
#
sub mpslibbuild {
&logcomment("Building MPS library.");
local $dir = cwd();
chdir($MPS_INCLUDE_DIR);
&mysystem($make_command);
chdir($dir);
}
#
# record information about environment so that when running tests
# we can check the libraries are still applicable
#
# specifically:
# - MMQA_harness version
# - values of MPS_INCLUDE_DIR and MPS_LINK_OBJ
# - latest modification time of a mpsXXX.h files in MPS_INCLUDE_DIR,
# - or an object in MPS_LINK_OBJ
# - C-compiler version??
sub record_clib {
my ($success) = @_;
unless (open(REC, ">$obj_dir/record")) {
die "Unable to write clib record.";
}
print REC "HARNESS_VERSION $HARNESS_VERSION\n";
print REC "INCLUDE_DIR $MPS_INCLUDE_DIR\n";
print REC "LINK_OBJ $MPS_LINK_OBJ\n";
print REC "SUCCESS $success\n";
# &headertimes and &linkobjtimes have already been called, by &scrutinize
foreach (sort keys %mps_headers) {
print REC "HEADER $_ $mps_headers{$_}\n";
}
foreach (sort keys %mps_linkobjs) {
print REC "LINK $_ $mps_linkobjs{$_}\n";
}
close(REC);
}
#
# check whether the test libraries correspond to the current
# settings
#
sub test_clib {
my $err = 0;
if (!open(REC, "$obj_dir/record")) {
$err = "no test library description found";
} elsif (<REC> ne "HARNESS_VERSION $HARNESS_VERSION\n") {
$err = "libraries were compiled with a different harness version";
} elsif (<REC> ne "INCLUDE_DIR $MPS_INCLUDE_DIR\n") {
$err = "MPS_INCLUDE_DIR has changed";
} elsif (<REC> ne "LINK_OBJ $MPS_LINK_OBJ\n") {
$err = "MPS_LINK_OBJ has changed";
} elsif (<REC> ne "SUCCESS 1\n") {
$err = "previous attempt to compile test libraries failed";
} else {
&headertimes();
&linkobjtimes();
while (<REC>) {
if (/^HEADER\s+(\S+)\s+(\S+)/) {
if (!exists $mps_headers{$1}) {
$err = "header file $1 disappeared";
} elsif ($mps_headers{$1} != $2) {
$err = "I think $1 may have changed";
} else {
delete $mps_headers{$1};
}
} elsif (/^LINK\s+(\S+)\s+(\S+)/) {
if (!exists $mps_linkobjs{$1}) {
$err = "link object $1 disappeared";
} elsif ($mps_linkobjs{$1} != $2) {
$err = "I think $1 may have changed";
} else {
delete $mps_linkobjs{$1};
}
} else {
$err = "test library description not understood";
}
if ($err) {
last;
}
}
unless ($err) {
if (scalar (keys %mps_headers)) {
($err) = keys %mps_headers;
$err = "new header file $err";
} elsif (scalar (keys %mps_linkobjs)) {
($err) = keys %mps_linkobjs;
$err = "new link object $err";
}
}
}
return $err;
}
sub headertimes {
%mps_headers = ();
unless (opendir(DIR, $MPS_INCLUDE_DIR)) {
die "Failed to open directory $MPS_INCLUDE_DIR.\n";
}
foreach (readdir(DIR)) {
if (/^mps.*\.h$/ && ! $ignored_headers{$_}) {
$mps_headers{$_} = &mod_time("$MPS_INCLUDE_DIR/$_");
}
}
closedir(DIR);
}
sub linkobjtimes {
%mps_linkobjs = ();
$_ = $MPS_LINK_OBJ;
foreach (split) {
$mps_linkobjs{$_} = &mod_time($_);
}
}
sub mod_time {
my ($file, $modtime) = @_;
unless (open(STAT, $file)) {
die "Couldn't find $file.\n";
}
(undef,undef,undef,undef,undef,
undef,undef,undef,undef,$modtime) = stat STAT;
close(STAT);
return $modtime;
}
#
# root around in MPS_INCLUDE_DIR and find useful-looking header files
#
sub scrutinize {
my $command;
my $comobj;
%mps_symbols = ();
%mps_linkable = ();
&logcomment("Checking settings.");
&headertimes();
&linkobjtimes();
&logcomment("Scrutinizing MPS header files.");
foreach (keys %mps_headers) {
&scrutfile($_);
}
# add a dummy symbol to allow us to check that non-defined
# symbols are correctly filtered out
$mps_symbols{"MPS_MMQA_DUMMY_SYMBOL"} = 1;
unless (open(SYM, ">$obj_dir/symtest.c")) {
die "Failed to write symbol test file.\n";
}
print SYM "/* THIS FILE IS AUTOMATICALLY GENERATED */\n\n";
foreach (sort keys %mps_symbols) {
print SYM "void $_(void);\n";
}
print SYM "\n\nint main(void) {\n";
foreach (sort keys %mps_symbols) {
print SYM " $_();\n";
}
print SYM "\n return 1;\n}\n\n";
close(SYM);
$command = "$obj_dir/symtest.c";
if ($cc_objandexe) {
$comobj = "$cc_obj$obj_dir/symtest$obj_suffix";
} else {
$comobj = "";
}
$comout = "$obj_dir/symtest.out";
if (&mysystem("$cc_command $cc_opts $comobj $cc_exe$obj_dir/symtest"
. " $obj_dir/symtest.c $MPS_LINK_OBJ $cc_link_opts "
. sprintf($stdboth_red, $comout))
== 127) {
die "Failed link test";
}
%mps_linkable = %mps_symbols;
open(LINKTEST, $comout);
while (<LINKTEST>) {
# Clang helpfully annotates its "Undefined symbols" error messages
# with lines of the form "(maybe you meant: _mps_ap_trip)". To avoid
# false positives, we must ignore these lines.
if (!/maybe you meant:/) {
while (s/((mps|MPS)_\w+)/ /) {
delete $mps_linkable{$1};
&debug("Filtering out $1.");
}
}
}
close(LINKTEST);
if (exists $mps_linkable{"MPS_MMQA_DUMMY_SYMBOL"}) {
print "Failed to determine symbols defined in MPS libraries -- exiting.\n";
die "[Complain to mm-qa about this.]\n";
} elsif ((scalar(keys %mps_symbols)) == 0) {
print "Couldn't determine which symbols are defined in MPS libraries -- exiting.\n";
die "[Complain to mm-qa about this.]\n";
}
delete $mps_symbols{"MPS_MMQA_DUMMY_SYMBOL"};
unless (open(SYM, ">$obj_dir/mmqasym.h")) {
die "Failed to write mmqa symbol file.\n";
}
print SYM "/* THIS FILE IS AUTOMATICALLY GENERATED */\n\n";
print SYM "/* mps header files */\n\n";
foreach (sort keys %mps_headers) {
s/\.h$//;
print SYM "#define MMQA_HEADER_$_\n";
}
print SYM "\n\n/* symbols in header files */\n\n";
foreach (sort keys %mps_symbols) {
print SYM "#define MMQA_SYMBOL_$_\n";
}
print SYM "\n\n/* symbols defined in library */\n\n";
foreach (sort keys %mps_linkable) {
print SYM "#define MMQA_DEFINED_$_\n";
}
print SYM "\n/* end */\n";
close(SYM);
}
sub scrutfile {
my ($infile) = @_;
my $cmd;
unless(open(IN, "$MPS_INCLUDE_DIR/$infile")) {
die "Whoops! Failed to read $infile.\n";
}
while (<IN>) {
chomp;
while (s/\$//) { $_ = $_.<IN>; chomp; }
if (/^\s*#\s*define\s*((mps|MPS)_\w+)/) {
$mps_symbols{$1} = 1;
}
}
close(IN);
$cmd = &convdirseps("$preprocommand $MPS_INCLUDE_DIR/$infile |");
&debug("OPEN >>$cmd<<");
unless(open(IN, $cmd)) {
die "Failed to preprocess $infile.\n";
}
while (<IN>) {
while (s/((mps|MPS)_\w+)/ /) {
$mps_symbols{$1} = 1;
}
}
close(IN);
}
sub readSymbols {
%mps_symbols = ();
%mps_linkable = ();
%mps_assumed = ();
unless (open(SYM, "$obj_dir/mmqasym.h")) {
die "Couldn't read symbol list -- recompile test libraries (\"qa clib\").\n";
}
while (<SYM>) {
chomp;
if (/#define MMQA_SYMBOL_(.*)$/) {
$mps_symbols{$1} = 1;
} elsif (/#define MMQA_DEFINED_(.*)$/) {
$mps_linkable{$1} = 1;
}
}
close(SYM);
unless (open(SYM, "$testlib_dir/assumed")) {
die "Couldn't read assumed symbol list. Complain to mm-qa.\n";
}
while (<SYM>) {
chomp;
unless (/^%/) {
$mps_assumed{$_} = 1;
}
}
}
#
# make a list of all the things which look like mps symbols
# mentioned in a file
#
sub listFileSymbols {
my ($infile) = @_;
my @symbols = ();
unless (open(IN, $infile)) {
die "Failed to open $infile.\n";
}
while (<IN>) {
unless (/^\/\*/ .. /\*\/$/) {
while (/\b((mps|MPS)_\w+\b)/g) {
push @symbols, $1;
}
}
}
close(IN);
return \@symbols;
}
#
# find which symbols in a list are not defined mps symbols
# Return a reference to a list of them
#
sub missingSymbols {
my ($checklist) = @_;
my @missing = ();
foreach (@$checklist) {
unless (exists $mps_symbols{$_} || exists $mps_assumed{$_}) {
push @missing, $_;
}
}
return \@missing;
}