[r2003-11-29 11:38:04 by szach] added support for print and better test on error conditions

Original author: szach
Date: 2003-11-29 11:38:04+00:00

tests/schema/test.pl

 #!/usr/bin/perl -w
 use strict;
+my $testfile = shift || die "testfile?";
+my $logfile = shift || die "logfile?";
+my $cduce = "../../cduce";
+my $failed_tests = "";
+unlink $logfile if (-f $logfile);
 sub get_root($) {
   my ($f) = @_;
   open (F, "< $f");
@@ -9,26 +14,49 @@ sub get_root($) {
       return($1);
     }
   }
-  die "Can't find root element in schema $f\n";
+  print "W: can't find root element in schema $f\n";
+  return(0);
 }
 foreach my $s (@ARGV) {
   if ($s =~ /(.*)\.xsd$/) {
-    print "Testing $s ...\n";
-    open(CD, "> test.cd");
+    my $msg = "Testing $s ...\n";
+    print $msg;
+    open (LOG, ">> $logfile");
+    print LOG "\n", "*" x 80, "\n", $msg, "*" x 80, "\n";
+    close LOG;
+    open(CD, "> $testfile");
     my $root = get_root($s);
     print CD <<EOF;
       schema X = \"$s\";;
-      #print_type X # $root;;
 EOF
+    if ($root) {
+      print CD <<EOF;
+	#print_type X # $root;;
+EOF
+    }
     if (-f "$1.xml") {
       print CD <<EOF;
 	let x = load_xml "$1.xml";;
-	validate x with X # $root;;
+	let y = validate x with X # $root;;
+	print_xml y;;
 EOF
     }
     close CD;
-    system "`which cduce` < test.cd";
+    my $retval = system "$cduce $testfile >> $logfile 2>&1";
+    if ($? == -1) {
+      die "Can't execute CDuce (tried $cduce)\n";
+    } elsif ($? != 0) {
+      print "E: test failed on $s\n";
+      $failed_tests .= " $s";
+    }
   } else {
-    print "Ignoring $s ...\n"
+    print "W: ignoring $s ...\n"
   };
 }
+if ($failed_tests) {
+  print STDERR "One or more tests failed :-(\nFailed tests:$failed_tests\n";
+  print STDERR "See $logfile for details\n";
+  exit 1;
+} else {
+  exit 0;
+}