X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=tests%2Ftest-init.lisp;h=da6063337677cdb49bb2cbce91b7bdacb0a721c5;hp=585df962cdb3a0dc443e03d9402b04082c40e629;hb=967266c94b00f91e5967b8330fe2b9134b0c0447;hpb=cc92d162f24648d65ad872098353305a5baf91d7

diff --git a/tests/test-init.lisp b/tests/test-init.lisp
index 585df96..da60633 100644
--- a/tests/test-init.lisp
+++ b/tests/test-init.lisp
@@ -16,7 +16,8 @@
 
 (in-package #:clsql-tests)
 
-(defvar *report-stream*)
+(defvar *report-stream* nil "Stream to send text report.")
+(defvar *sexp-report-stream* nil "Stream to send sexp report.")
 (defvar *rt-connection*)
 (defvar *rt-fddl*)
 (defvar *rt-fdml*)
@@ -136,6 +137,9 @@
 		 :make-default t
 		 :if-exists :old)
   
+  (unless (db-backend-has-create/destroy-db? db-type)
+    (truncate-database :database *default-database*))
+  
   (setf *test-database-underlying-type*
 	(clsql-sys:database-underlying-type *default-database*))
   
@@ -154,10 +158,6 @@
 (defparameter employee10 nil)
 
 (defun test-initialise-database ()
-  ;; Ensure that old objects are removed
-  (unless (db-backend-has-create/destroy-db? *test-database-type*)
-    (truncate-database *default-database*)) 
-  
   (test-basic-initialize)
   
   (clsql:create-view-from-class 'employee)
@@ -300,16 +300,28 @@
   (clsql:update-records-from-instance company1))
 
 (defvar *error-count* 0)
+(defvar *error-list* nil)
 
 (defun run-tests-append-report-file (report-file)
-  (with-open-file (out report-file :direction :output
-		       :if-exists :append
-		       :if-does-not-exist :create)
-    (run-tests out)))
+  (let* ((report-path (etypecase report-file
+			(pathname report-file)
+			(string (parse-namestring report-file))))
+	 (sexp-report-path (make-pathname :defaults report-path
+					  :type "sexp")))
+  (with-open-file (rs report-path :direction :output
+		      :if-exists :append
+		      :if-does-not-exist :create)
+    (with-open-file (srs sexp-report-path :direction :output
+			 :if-exists :append
+			 :if-does-not-exist :create)
+      (run-tests :report-stream rs :sexp-report-stream srs)))))
     
-(defun run-tests (&optional (*report-stream* *standard-output*))
+(defun run-tests (&key (report-stream *standard-output*) (sexp-report-stream nil))
   (let ((specs (read-specs))
-	(*error-count* 0))
+	(*report-stream* report-stream)
+	(*sexp-report-stream* sexp-report-stream)
+	(*error-count* 0)
+	(*error-list* nil))
     (unless specs
       (warn "Not running tests because test configuration file is missing")
       (return-from run-tests :skipped))
@@ -331,34 +343,50 @@
       (multiple-value-bind (test-forms skip-tests)
 	  (compute-tests-for-backend db-type *test-database-underlying-type*)
 	
-  (format *report-stream* 
-	  "~&
+	(format *report-stream* 
+		"~&
 ******************************************************************************
 ***     CLSQL Test Suite begun at ~A
 ***     ~A
-***     ~A
+***     ~A on ~A
 ***     Database ~A backend~A.
 ******************************************************************************
 " 
-(clsql-base:format-time nil (clsql-base:utime->time (get-universal-time)))
-(lisp-implementation-type)
-(lisp-implementation-version)
-db-type
-(if (not (eq db-type *test-database-underlying-type*))
-    (format nil " with underlying type ~A" *test-database-underlying-type*)
-    "")
-)
-  
+		(clsql-base:format-time 
+		 nil 
+		 (clsql-base:utime->time (get-universal-time)))
+		(lisp-implementation-type)
+		(lisp-implementation-version)
+		(machine-type)
+		db-type
+		(if (not (eq db-type *test-database-underlying-type*))
+		    (format nil " with underlying type ~A" 
+			    *test-database-underlying-type*)
+		  "")
+		)
+	
 	(test-initialise-database)
-
+	
 	(regression-test:rem-all-tests)
 	(dolist (test-form test-forms)
 	  (eval test-form))
 	
 	(let ((remaining (rtest:do-tests *report-stream*)))
-	  (when (consp remaining)
+	  (when (rt:pending-tests)
 	    (incf *error-count* (length remaining))))
 	
+	(let ((sexp-error (list db-type 
+				*test-database-underlying-type* 
+				(get-universal-time)
+				(length test-forms)
+				(rt:pending-tests)
+				(lisp-implementation-type) 
+				(lisp-implementation-version)
+				(machine-type))))
+	  (when *sexp-report-stream*
+	    (write sexp-error :stream *sexp-report-stream*)) 
+	  (push sexp-error *error-list*))
+	
 	(format *report-stream* "~&Tests skipped:")
 	(if skip-tests
 	    (dolist (skipped skip-tests)