"Robustifying" the ASDF test suite somewhat

The following bits are meant to make the ASDF test suite more robust  
in the face of errors and failures. The suite takes more trouble to  
setup an environment where errors will be caught; prints somewhat  
nicer error messages and tries to make it easier to add more Lisps  
(sbcl, clisp and allegro alisp are the only supported ones right now)  
(and I haven't tested clisp).

Please let me know what you think and how you feel. If the consensus  
is that this is a good step, I'll commit sometime next week.


;;;;; New file
;;;;; test/compile-asdf.lisp
(in-package #:common-lisp-user)

(load "test/script-support.lisp")

(cond ((probe-file "asdf.lisp")
        (multiple-value-bind (result warnings-p errors-p)
	   (compile-file "asdf.lisp")
	 (declare (ignore result))
	 (cond (warnings-p
		(leave-lisp "Testuite failed: ASDF compiled with warnings" 1))
	       (errors-p
		(leave-lisp "Testuite failed: ASDF compiled with ERRORS" 2))
	       (t
		(leave-lisp "ASDF compiled cleanly" 0)))))
       (t
        (leave-lisp "Testsuite failed: unable to find ASDF source" 3)))

		

		
;;;;; New file
;;;;; test/script-support.lisp
(in-package #:common-lisp-user)

;;; Code adapted from cl-launch (any errors in transcription are mine!)
;; http://www.cliki.net/cl-launch
(defun leave-lisp (message return)
   (when message
     (format *error-output* message))
   #+allegro
   (excl:exit return)
   #+clisp
   (ext:quit return)
   #+(or cmu scl)
   (unix:unix-exit code)
   #+ecl
   (si:quit return)
   #+gcl
   (lisp:quit code)
   #+lispworks
   (lispworks:quit :status code :confirm nil :return nil :ignore- 
errors-p t)
   #+(or openmcl mcl)
   (ccl::quit return)
   #+sbcl
   (sb-ext:quit :unix-status return)

   (error "Don't know how to quit Lisp; wanting to use exit code ~a"  
return))

(defmacro exit-on-error (&body body)
   `(handler-case
       (progn ,@body
	     (leave-lisp "Script succeeded" 0))
     (error (c)
       (format *error-output* "~a" c)
       (leave-lisp "Script failed" 1))))


;;;;;;; Changes

        Index: test/run-tests.sh
===================================================================
RCS file: /cvsroot/cclan/asdf/test/run-tests.sh,v
retrieving revision 1.9
diff -u -w -u -r1.9 run-tests.sh
--- test/run-tests.sh	21 Mar 2007 22:08:34 -0000	1.9
+++ test/run-tests.sh	2 Jun 2007 02:39:06 -0000
@@ -4,19 +4,38 @@
do_tests() {
rm *.$2 || true
-( cd .. && echo '(compile-file "asdf")' |$1  )
+( cd .. && echo '(load "test/compile-asdf.lisp")' | $1  )
+if [ $? -eq 0 ] ; then
+    test_count=0
+    test_pass=0
+    test_fail=0
+    failed_list=""
for i in *.script;
do
+      echo "Testing: $i" >&2
+      test_count=`expr "$test_count" + 1`
    rm *.$2 || true
    if $1 < $i ;then
      echo "Using $1, $i passed" >&2
+	test_pass=`expr "$test_pass" + 1`
    else
      echo "Using $1, $i failed" >&2
+	test_fail=`expr "$test_fail" + 1`
+	failed_list="$failed_list $i"
      sok=0
-    exit 1
    fi
done
-echo "Using $1, all tests apparently successful ($sok)" >&2
+    echo >&2
+    echo "Using $1" >&2
+    echo "Ran $test_count tests: " >&2
+    echo "  $test_pass passing and $test_fail failing" >&2
+    if [ $test_fail -eq 0 ] ; then
+	echo "all tests apparently successful" >&2
+    else
+	echo "failing test(s): $failed_list" >&2
+    fi
+    echo >&2
+fi
}
# do_tests {lisp invocation} {fasl extension}
@@ -24,19 +43,43 @@
# - quit with exit status 0 on getting eof
# - quit with exit status >0 if an unhandled error occurs
+# terminate on error
set -e
-if type sbcl
-then
-  do_tests "sbcl --userinit /dev/null --sysinit /dev/null -- 
noprogrammer" fasl
+lisp=$1
+if [ -z $1 ] ; then
+    lisp="sbcl"
fi
-if [ -x /usr/bin/lisp ]
-then
-  do_tests "/usr/bin/lisp -batch -noinit" x86f
+if [ "$lisp" = "sbcl" ] ; then
+    if type sbcl ; then
+      fasl_ext="fasl"
+      command="sbcl --userinit /dev/null --sysinit /dev/null -- 
noprogrammer"
+    fi
+elif [ "$lisp" = "clisp" ] ; then
+    if type clisp ; then
+	fasl_ext="fas"
+	command=`where clisp`
+	command="$command -norc -ansi -I - "
+    fi
+elif [ "$lisp" = "allegro" ] ; then
+    if type alisp ; then
+	fasl_ext="fasl"
+	command="alisp -q --batch "
+    fi
fi
-if [ -x /usr/bin/clisp ]
-then
-  do_tests "/usr/bin/clisp -norc -ansi -I - " fas
+
+#if [ -x /usr/bin/lisp ]
+#then
+#  do_tests "/usr/bin/lisp -batch -noinit" x86f
+#fi
+
+
+if [ -z "$command" ] ; then
+    echo "Error: don't know how to run Lisp named $lisp"
+else
+    echo $command
+    do_tests "$command" $fasl_ext
fi
+
Index: test/test-force.script
===================================================================
RCS file: /cvsroot/cclan/asdf/test/test-force.script,v
retrieving revision 1.1
diff -u -w -u -r1.1 test-force.script
--- test/test-force.script	30 May 2006 18:14:40 -0000	1.1
+++ test/test-force.script	2 Jun 2007 02:39:06 -0000
@@ -1,5 +1,7 @@
;;; -*- Lisp -*-
+(load "script-support")
(load "../asdf")
+(exit-on-error
(setf asdf:*central-registry* '(*default-pathname-defaults*))
(asdf:operate 'asdf:load-op 'test-force)
@@ -14,3 +16,4 @@
(sleep 1)
(asdf:operate 'asdf:load-op 'test-force :force t)
(assert (> (file-write-date (compile-file-pathname "file1")) file1- 
date))
+ )
\ No newline at end of file
Index: test/test-package.script
===================================================================
RCS file: /cvsroot/cclan/asdf/test/test-package.script,v
retrieving revision 1.1
diff -u -w -u -r1.1 test-package.script
--- test/test-package.script	21 Aug 2006 10:52:34 -0000	1.1
+++ test/test-package.script	2 Jun 2007 02:39:06 -0000
@@ -1,5 +1,8 @@
(in-package :cl-user)
+;;; -*- Lisp -*-
+(load "script-support")
(load "../asdf")
+(exit-on-error
(defun module () 1)
@@ -8,3 +11,4 @@
(defclass module () ())
(load "test-package.asd")
+)
Index: test/test-preferences-1.script
===================================================================
RCS file: /cvsroot/cclan/asdf/test/test-preferences-1.script,v
retrieving revision 1.1
diff -u -w -u -r1.1 test-preferences-1.script
--- test/test-preferences-1.script	6 Jul 2006 02:26:00 -0000	1.1
+++ test/test-preferences-1.script	2 Jun 2007 02:39:06 -0000
@@ -1,9 +1,11 @@
;;; -*- Lisp -*-
-
+(load "script-support")
(load "../asdf")
+(exit-on-error
(setf asdf:*central-registry* '(*default-pathname-defaults*))
(in-package :asdf)
(asdf:oos 'asdf:load-op 'test-preferences-system-1)
(assert (eq common-lisp-user::*test-preferences-variable-1* :load))
(asdf:oos 'asdf:test-op 'test-preferences-system-1)
(assert (eq common-lisp-user::*test-preferences-variable-1* :test))
+ )
\ No newline at end of file
Index: test/test-version.script
===================================================================
RCS file: /cvsroot/cclan/asdf/test/test-version.script,v
retrieving revision 1.1
diff -u -w -u -r1.1 test-version.script
--- test/test-version.script	14 May 2006 16:03:16 -0000	1.1
+++ test/test-version.script	2 Jun 2007 02:39:06 -0000
@@ -1,5 +1,5 @@
-;; -*- lisp -*-
-
+;;; -*- Lisp -*-
+(load "script-support")
(load "../asdf")
(setf asdf:*central-registry* '(*default-pathname-defaults*))
@@ -8,6 +8,7 @@
(in-package :test-version-system)
+(cl-user::exit-on-error
(defsystem :versioned-system-1
    :pathname #.*default-pathname-defaults*
    :version "1.0")
@@ -27,4 +28,4 @@
    (test :versioned-system-2 "1.0")
    (test :versioned-system-3 "2.0" nil))
-
\ No newline at end of file
+ )
\ No newline at end of file
Index: test/test1.script
===================================================================
RCS file: /cvsroot/cclan/asdf/test/test1.script,v
retrieving revision 1.3
diff -u -w -u -r1.3 test1.script
--- test/test1.script	4 Feb 2003 17:01:27 -0000	1.3
+++ test/test1.script	2 Jun 2007 02:39:06 -0000
@@ -1,15 +1,18 @@
;;; -*- Lisp -*-
+(load "script-support")
(load "../asdf")
+(exit-on-error
(setf asdf:*central-registry* '(*default-pathname-defaults*))
(asdf:operate 'asdf:load-op 'test1)
;; test that it compiled
(defvar file1-date (file-write-date (compile-file-pathname "file1")))
-(assert (and file1-date (file-write-date (compile-file-pathname  
"file2"))))
+ (assert (and file1-date (file-write-date (compile-file-pathname  
"file2")))))
;; and loaded
(assert test-package::*file1*)
+(exit-on-error
;; now remove one output file and check that the other is _not_
;; recompiled
(sleep 1) ; mtime has 1-second granularity, so pause here for fast  
machines
@@ -30,3 +33,4 @@
    (sleep 1)
    (asdf:operate 'asdf:load-op 'test1)
    (assert (>  (file-write-date (compile-file-pathname "file2"))  
before)))
+ )
\ No newline at end of file
Index: test/test2.script
===================================================================
RCS file: /cvsroot/cclan/asdf/test/test2.script,v
retrieving revision 1.3
diff -u -w -u -r1.3 test2.script
--- test/test2.script	20 Sep 2002 12:41:42 -0000	1.3
+++ test/test2.script	2 Jun 2007 02:39:06 -0000
@@ -1,5 +1,7 @@
;;; -*- Lisp -*-
+(load "script-support")
(load "../asdf")
+(exit-on-error
(setf asdf:*central-registry* '(*default-pathname-defaults*))
;(trace asdf::perform)
;(trace asdf::find-component)
@@ -17,3 +19,4 @@
    (asdf:missing-dependency (c)
      (format t "load failed as expected: - ~%~A~%" c))
    (:no-error (c) (error "should have failed, oops")))
+ )
\ No newline at end of file
Index: test/test3.script
===================================================================
RCS file: /cvsroot/cclan/asdf/test/test3.script,v
retrieving revision 1.3
diff -u -w -u -r1.3 test3.script
--- test/test3.script	20 Sep 2002 12:41:42 -0000	1.3
+++ test/test3.script	2 Jun 2007 02:39:06 -0000
@@ -1,12 +1,14 @@
;;; -*- Lisp -*-
#+(or f1 f2)
      (error "This test cannot run if :f1 or :f2 are on *features*")
+(load "script-support")
(load "../asdf")
+(in-package :asdf)
+(cl-user::exit-on-error
(asdf:run-shell-command "rm ~A ~A"
			(namestring (compile-file-pathname "file1"))
			(namestring (compile-file-pathname "file2")))
(setf asdf:*central-registry* '(*default-pathname-defaults*))
-(in-package :asdf)
(handler-case
      (asdf:oos 'asdf:load-op 'test3)
    (asdf:missing-dependency (c)
@@ -21,3 +23,4 @@
(asdf:oos 'asdf:load-op 'test3)
(assert (probe-file (compile-file-pathname "file2")))
(assert (not (probe-file (compile-file-pathname "file1"))))
+ )
Index: test/test4.script
===================================================================
RCS file: /cvsroot/cclan/asdf/test/test4.script,v
retrieving revision 1.1
diff -u -w -u -r1.1 test4.script
--- test/test4.script	20 May 2002 14:16:46 -0000	1.1
+++ test/test4.script	2 Jun 2007 02:39:06 -0000
@@ -1,8 +1,12 @@
;;; -*- Lisp -*-
+;;; -*- Lisp -*-
+(load "script-support")
(load "../asdf")
-(setf asdf:*central-registry* '(*default-pathname-defaults*))
(in-package :asdf)
+(cl-user::exit-on-error
+ (setf asdf:*central-registry* '(*default-pathname-defaults*))
(assert (not (component-property (find-system 'test3) :foo)))
(assert (equal (component-property (find-system 'test3) :prop1)  
"value"))
(setf (component-property (find-system 'test3) :foo) "bar")
(assert (equal (component-property (find-system 'test3) :foo) "bar"))
+ )
\ No newline at end of file
Index: test/wild-module.script
===================================================================
RCS file: /cvsroot/cclan/asdf/test/wild-module.script,v
retrieving revision 1.2
diff -u -w -u -r1.2 wild-module.script
--- test/wild-module.script	8 Feb 2003 15:31:17 -0000	1.2
+++ test/wild-module.script	2 Jun 2007 02:39:06 -0000
@@ -1,7 +1,11 @@
;;; -*- Lisp -*-
+(load "script-support")
+(load "../asdf")
+(exit-on-error
(load "../asdf")
(load "../wild-modules")
(setf asdf:*central-registry* '(*default-pathname-defaults*))
(asdf:operate 'asdf:load-op 'wild-module)
+ )
\ No newline at end of file
		


--
Gary Warren King, metabang.com
Cell: (413) 885 9127
Fax: (206) 338-4052
gwkkwg on Skype * garethsan on AIM





-------------------------------------------------------------------------
This SF.net email is sponsored by DB2 Express
Download DB2 Express C - the FREE version of DB2 express and take
control of your XML. No limits. Just data. Click to get it now.
http://sourceforge.net/powerbar/db2/