emacs/mps/qa/test/script/clib

#!/usr/local/perl
# $HopeName: MMQA_harness!script:clib(trunk.6) $
#
# subroutines to compile test libraries, and check whether they
# need to be compiled
#

1;

sub clib {
 my $success = 1;
 my $tlfile;
 my $tlobj;

 &objpurge();
 &scrutinize();
 &logcomment("Compiling test libraries.");

 open(MANIFEST, "$testlib_dir/manifest");

 while (defined($tlfile = <MANIFEST>)) {
  unless ($tlfile =~ /^%/) {
   chop($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 ".." || unlink $obj_dir."/".$_) {
   &logcomment("  ... but failed to delete $_.");
  }
 }
 closedir(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$/) {
   $mps_headers{$_} = &mod_time("$MPS_INCLUDE_DIR/$_");
  }
 }
 closedir(DIR);
}

sub linkobjtimes {
 %mps_linkobjs = ();
 $_ = $MPS_LINK_OBJ;

 foreach (split) {
  $mps_linkobjs{$_} = &mod_time($_);
 }
 closedir(DIR);
}

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>) {
  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>) {
  chop;
  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>) {
  chop;
  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>) {
  while (s/((mps|MPS)_\w+)/ /) {
   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;
}