test/performtest.pl

   1 #!/usr/bin/perl
   2 #Perform tests on nasm
   3 use strict;
   4 use warnings;
   5
   6 use File::Basename qw(fileparse);
   7 use File::Compare qw(compare compare_text);
   8 use File::Copy qw(move);
   9 use File::Path qw(mkpath rmtree);
  10
  11 sub usage {
  12     print
  13 'Perform tests on nasm.
  14
  15 Usage: performtest.pl ["quiet"] ["clean"] ["golden"] nasm_executable test_files...
  16 ';
  17     exit;
  18 }
  19
  20 # sub debugprint { print (pop() . "\n"); }
  21 sub debugprint { }
  22
  23 #Get one command line argument
  24 sub get_arg { shift @ARGV; }
  25
  26 #Process one testfile
  27 sub perform {
  28     my ($clean, $golden, $nasm, $quiet, $testpath) = @_;
  29     my ($stdoutfile, $stderrfile) = (".stdout", ".stderr");
  30
  31     my ($testname, $ignoredpath, $ignoredsuffix) = fileparse($testpath, ".asm");
  32     debugprint $testname;
  33
  34     my $outputdir = $golden ? "golden" : "testresults";
  35
  36     mkdir "$outputdir" unless -d "$outputdir";
  37
  38     if ($clean) {
  39         rmtree "$outputdir/$testname";
  40         return;
  41     }
  42
  43     if(-d "$outputdir/$testname") {
  44         rmtree "$outputdir/$testname";
  45     }
  46
  47     open(TESTFILE, '<', $testpath) or (warn "Can't open $testpath\n", return);
  48     TEST:
  49     while(<TESTFILE>) {
  50         #See if there is a test case
  51         last unless /Testname=(.*);\s*Arguments=(.*);\s*Files=(.*)/;
  52         my ($subname, $arguments, $files) = ($1, $2, $3);
  53         debugprint("$subname | $arguments | $files");
  54
  55         #Call nasm with this test case
  56         system("$nasm $arguments $testpath > $stdoutfile 2> $stderrfile");
  57         debugprint("$nasm $arguments $testpath > $stdoutfile 2> $stderrfile ----> $?");
  58
  59         #Move the output to the test dir
  60         mkpath("$outputdir/$testname/$subname");
  61         foreach(split / /,$files) {
  62             if (-f $_) {
  63                 move($_, "$outputdir/$testname/$subname/$_") or die $!
  64             }
  65         }
  66         unlink ("$stdoutfile", "$stderrfile"); #Just to be sure
  67
  68         if(! $golden) {
  69             #Compare them with the golden files
  70             my $result = 0;
  71             my @failedfiles = ();
  72             foreach(split / /, $files) {
  73                 if(-f "$outputdir/$testname/$subname/$_") {
  74                     my $temp;
  75                     if($_ eq $stdoutfile or $_ eq $stderrfile) {
  76                         #Compare stdout and stderr in text mode so line ending changes won't matter
  77                         $temp = compare_text("$outputdir/$testname/$subname/$_", "golden/$testname/$subname/$_");
  78                     } else {
  79                         $temp = compare("$outputdir/$testname/$subname/$_", "golden/$testname/$subname/$_");
  80                     }
  81
  82                     if($temp == 1) {
  83                         #different
  84                         $result = 1;
  85                         push @failedfiles, $_;
  86                     } elsif($temp == -1) {
  87                         #error
  88                         print "Error in $testname/$subname with file $_\n";
  89                         next TEST;
  90                     }
  91                 } elsif (-f "golden/$testname/$subname/$_") {
  92                     #File exists in golden but not in output
  93                     $result = 1;
  94                     push @failedfiles, $_;
  95                 }
  96             }
  97
  98
  99             if($result == 0) {
 100                 print "Test $testname/$subname succeeded.\n" unless $quiet;
 101             } elsif ($result == 1) {
 102                 print "Test $testname/$subname failed on @failedfiles.\n";
 103             } else {
 104                 die "Impossible result";
 105             }
 106         }
 107     }
 108     close(TESTFILE);
 109 }
 110
 111
 112 my $arg;
 113 my $nasm;
 114 my $clean = 0;
 115 my $golden = 0;
 116 my $quiet = 0;
 117
 118 $arg = get_arg() or usage();
 119
 120
 121 if($arg eq "quiet") {
 122     $quiet = 1;
 123     $arg = get_arg() or usage();
 124 }
 125 if($arg eq "clean") {
 126     $clean = 1;
 127     $arg = get_arg() or usage();
 128 }
 129 if ($arg eq "golden") {
 130     $golden = 1;
 131     $arg = get_arg() or usage();
 132 }
 133
 134 $nasm = $arg;
 135
 136 perform($clean, $golden, $nasm, $quiet, $_) foreach @ARGV;