[e90b2f]: src / tests / config.lsp.in Maximize Restore History

Download this file

config.lsp.in    412 lines (354 with data), 12.3 kB

;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;;
;;; (c) 2011, Juan Jose Garcia-Ripoll
;;;
;;; Set up the test environment.
;;;

(defpackage :ecl-tests
  (:use :cl))

(in-package :ecl-tests)

(setf *load-verbose* nil *load-print* nil)

(defvar *ecl-sources*
  (loop for *default-pathname-defaults* in
	'(#p"@true_srcdir@/" #p"../../" #p"../../src/")
	when (probe-file "CHANGELOG")
	return *default-pathname-defaults*))

(defvar *test-sources* (merge-pathnames "tests/" *ecl-sources*))

(defvar *here* (merge-pathnames "@builddir@/"))

(defvar *cache* (merge-pathnames "./cache/" *here*))

(defvar *test-image* (or (ext:getenv "TEST_IMAGE")
			 #+windows
			 (namestring (truename #+windows "sys:ecl.exe"))
			 #-windows
			 "ecl"))

(defvar *test-image-args*
  (cond ((search "ecl" *test-image*)
	 '("-norc" "-eval" "(print (ext:getenv \"ECLDIR\"))"
	   ;#+windows "-eval" #+windows "(require :cmp)"
	   ))
	((search "sbcl" *test-image*)
	 '("--no-userinit" "--no-sysinit"))
	(t
	 '())))

#+ecl
(ext:setenv "ECLDIR" (namestring (truename "SYS:")))

(defvar *test-name* (or (ext:getenv "TEST_NAME") "ecl"))

(defvar *output-directory*
  (merge-pathnames (concatenate 'string "output." *test-name* "/") *here*))

(defvar *quicklisp-sandbox* (merge-pathnames "quicklisp/" *here*))

(defvar *quicklisp-install-file* (merge-pathnames "quicklisp.lsp" *cache*))

(defvar *quicklisp-setup-file* (merge-pathnames "setup.lisp" *quicklisp-sandbox*))

(defvar *regressions-sources* (merge-pathnames "bugs/" *test-sources*))

(defvar *regressions-sandbox* (merge-pathnames "regressions/" *here*))

(defvar *ansi-tests-mirror* "http://ecls.sourceforge.net/ansi-tests.tar.gz")

(defvar *ansi-tests-sandbox* (merge-pathnames "ansi-tests/" *here*))

(defvar *ansi-tests-tarball* "ansi-tests.tar.gz")

(defvar *mop-tests-mirror* "http://ecls.sourceforge.net/mop-features.tar.gz")

(defvar *mop-tests-sandbox* (merge-pathnames "mop-features/" *here*))

(defvar *mop-tests-tarball* "mop-features.tar.gz")

(defvar *fricas-mirror* "http://ecls.sourceforge.net/fricas.tar.gz")

(defvar *fricas-sandbox* (merge-pathnames "fricas/" *here*))

(defvar *fricas-tarball* "fricas.tar.gz")

(defvar *wild-inferiors* (make-pathname :name :wild
					:type :wild
					:version :wild
					:directory '(:relative :wild-inferiors)))

(defvar *cleanup-extensions* '("fasl" "fasb" "c" "h" "obj" "o" "a" "lib" "dll" "dylib" "data"))

(defun lisp-system-directory ()
  (loop with root = (si::get-library-pathname)
	with lib-name = (format nil "../lib/ecl-~A/" (lisp-implementation-version))
	for base in (list root (merge-pathnames lib-name root))
	when (or (probe-file (merge-pathnames "./BUILD-STAMP" base))
		 (probe-file (merge-pathnames "./LGPL" base)))
	do (return base)))

(setf (logical-pathname-translations "SYS")
      (list (list #p"sys:**;*.*"
		  (merge-pathnames "**/*.*"
				   (lisp-system-directory)))))

(require :cmp)
(require :ecl-curl)
(require :deflate)
(require :ql-minitar)

;;;
;;; PREPARATION OF DIRECTORIES AND FILES
;;;

(defun setup-asdf ()
  (require :asdf)
  (ensure-directories-exist *cache*)
  (setf (symbol-value (read-from-string "asdf::*user-cache*"))
	(list *cache* :implementation)))
		      

(defun delete-everything (path)
  ;; Recursively run through children
  (labels ((recursive-deletion (path)
             (mapc #'delete-everything
                   (directory (merge-pathnames
                               (make-pathname :name nil
                                              :type nil
                                              :directory '(:relative :wild)
                                              :defaults path)
                               path)))
             ;; Delete files
             (loop for f in (directory (make-pathname :name :wild
                                                      :type :wild
                                                      :defaults path))
                do (delete-file f)
                finally (delete-file path))))
    (and (probe-file path)
         (recursive-deletion path))))

(defun safe-download (url filename)
  (ensure-directories-exist filename)
  (handler-case
      (ecl-curl:download-url-to-file url filename)
    (ecl-curl:download-error (c)
      (format t "~&;;;~%;;; Unable to download quicklisp. Aborting. ~%;;;")
      (ext:quit 1)))
  filename)

(defun download-quicklisp-install ()
  (safe-download "http://beta.quicklisp.org/quicklisp.lisp"
		 *quicklisp-install-file*))

(defun download-and-setup-quicklisp ()
  (when (probe-file *quicklisp-sandbox*)
    (delete-everything *quicklisp-sandbox*))
  (handler-case
      (progn
	(load (download-quicklisp-install))
	(let ((function (read-from-string "quicklisp-quickstart:install")))
	  (eval (list function :path *quicklisp-sandbox*))))
    (error (c)
      (format t "~&;;;~%;;; Unable to setup quicklisp. Aborting.~%;;;")
      (delete-everything *quicklisp-sandbox*))))

(defun ensure-quicklisp ()
  (unless (find-package "QL")
    (unless (probe-file *quicklisp-sandbox*)
      (setup-asdf)
      (download-and-setup-quicklisp))
    (load *quicklisp-setup-file*))
  t)

(defun copy-directory (orig dest)
  (setf orig (truename orig))
  (print dest)
  (loop for f in (directory (merge-pathnames *wild-inferiors* orig))
     for f2 = (enough-namestring f orig)
     for f3 = (merge-pathnames f2 dest)
     unless (probe-file f3)
     do (ensure-directories-exist f3)
     do (ext:copy-file f f3)))

(defun extract-tarball (filename)
  (format t "~&;;;~%;;; Extracting ~a~%;;;" filename)
  (if (string-equal (pathname-type filename) "gz")
      (let ((temp-filename (ext:mkstemp "fooXXXXXXX")))
	(unwind-protect
	     (progn
	       (deflate:gunzip filename temp-filename)
	       (extract-tarball temp-filename))
	  (delete-file temp-filename)))
      (ql-minitar:unpack-tarball filename)))

(defun extract-distribution (filename url)
  (let ((distribution (loop for base in (list *cache*
					      *here*
					      *test-sources*)
			 for file = (merge-pathnames filename base)
			 when (probe-file file)
			 do (return file)
			 finally (let ((tmp (merge-pathnames filename *cache*)))
				   (return (safe-download url tmp))))))
    (extract-tarball distribution)))

(defun ensure-regressions ()
  (unless (probe-file *regressions-sandbox*)
    (copy-directory *regressions-sources* *regressions-sandbox*)))

(defun ensure-ansi-tests ()
  (unless (probe-file *ansi-tests-sandbox*)
    (extract-distribution *ansi-tests-tarball* *ansi-tests-mirror*))
  t)

(defun ensure-mop-tests ()
  (unless (probe-file *mop-tests-sandbox*)
    (extract-distribution *mop-tests-tarball* *mop-tests-mirror*))
  t)

(defun ensure-fricas ()
  (unless (probe-file *fricas-sandbox*)
    (extract-distribution *fricas-tarball* *fricas-url*)))

(defun ensure-maxima ()
  (unless (probe-file *fricas-sandbox*)
    (extract-distribution *fricas-tarball* *fricas-url*)))

(defun cleanup-directory (path)
  (loop for i in (directory (merge-pathnames *wild-inferiors*
					     path))
     when (member (pathname-type i) *cleanup-extensions* :test #'string-equal)
     do (delete-file i)))

;;;
;;; RUNNING TESTS
;;;

(defun run-ansi-tests (&optional (output (merge-pathnames "ansi.log"
							  *output-directory*)))
  (ensure-ansi-tests)
  ;; Cleanup stray files
  (cleanup-directory *ansi-tests-sandbox*)
  (delete-everything (merge-pathnames "scratch/" *ansi-tests-sandbox*))
  ;; Run with given image
  (ensure-directories-exist output)
  (let* ((input (merge-pathnames "doit.lsp" *ansi-tests-sandbox*))
	 (tmp (merge-pathnames "ecl-tmp-doit.lsp" *ansi-tests-sandbox*)))
    (with-open-file (s tmp :direction :output
		       :if-exists :supersede
		       :if-does-not-exist :create)
      (format s "(require :cmp)(pprint (ext:getcwd))(load ~S)#+ecl(quit)"
	      (namestring input)))
    (unwind-protect
	(progn
	  (ext:chdir *ansi-tests-sandbox*)
	  (ext:run-program *test-image*
			   *test-image-args*
			   :input tmp
			   :output output
			   :error :output
			   :wait t))
      (when (probe-file tmp)
	(ignore-errors (delete-file tmp)))
      (ext:chdir *here*))))

(defun run-regressions-tests (&optional (output (merge-pathnames "regressions.log"
								 *output-directory*)))
  (ensure-regressions)
  ;; Cleanup stray files
  (cleanup-directory *regressions-sandbox*)
  ;; Run with given image
  (ensure-directories-exist output)
  (unwind-protect 
       (progn
	 (ext:chdir *regressions-sandbox*)
	 (ext:run-program *test-image*
			  *test-image-args*
			  :input (merge-pathnames "doit.lsp" *regressions-sandbox*)
			  :output output
			  :error :output))
    (ext:chdir *here*)))

(defun run-mop-tests (&optional (output (merge-pathnames "mop-features.log"
							 *output-directory*)))
  (ensure-mop-tests)
  ;; Cleanup stray files
  (cleanup-directory *mop-tests-sandbox*)
  ;; Create the script we are going to run
  (let ((mop-script (merge-pathnames "./run-mop-tests.lisp" *mop-tests-sandbox*)))
    (with-open-file (s mop-script :direction :output
		       :if-exists :supersede
		       :if-does-not-exist :create)
      (pprint '(progn
		(require :asdf)
		(load "lw-compat-package")
		(load "lw-compat")
		(load "mop-features-packages.lisp")
		(load "mop-feature-tests.lisp")
		(handler-case
		    (progn
		      (funcall (read-from-string "mop-feature-tests::run-feature-tests"))
		      (format t "~%~%~%MOP-FEATURE-TESTS: OK"))
		  (error (error)
		    (format t "~%~%~%MOP-FEATURE-TESTS: Failed"))))
	      s))
    ;; Run with given image
    (ensure-directories-exist output)
    (unwind-protect 
	 (progn
	   (ext:chdir *mop-tests-sandbox*)
	   (ext:run-program *test-image*
			    *test-image-args*
			    :input mop-script
			    :output output
			    :error :output))
      (ext:chdir *here*))))


(defvar *quicklisp-library-list*
  '(trivial-features
    alexandria
    babel
    cffi
    cl-ppcre
    cl-unicode
    iterate
    trivial-gray-streams
    trivial-garbage
    flexi-streams
    lift
    metabang-bind
    swank
    stefil
    sqlite
    chunga
    cl+ssl
    cl-base64
    cl-fad
    cl-python
    md5
    rfc2388
    trivial-backtrace
    trivial-gray-streams
    usocket
    hunchentoot))

(defconstant +quicklisp-build-template+ "
(require 'asdf)
(setf (symbol-value (read-from-string \"asdf::*user-cache*\"))
      (list ~s :implementation))
(load ~s)
(ql:use-only-quicklisp-systems)
(handler-case
  (progn
    (ql:quickload ~s)
    (princ \"ECL-BUILD-OK\"))
  (serious-condition (c) (princ c)))
#+ecl
(ext:quit)
#+sbcl
(sb-ext:quit)
")

(defconstant +quicklisp-test-template+ "
(require 'asdf)
(setf (symbol-value (read-from-string \"asdf::*user-cache*\"))
      (list ~s :implementation))
(load ~s)
(ql:use-only-quicklisp-systems)
(handler-case
  (progn
    (ql:quickload ~s)
    (princ \"ECL-BUILD-OK\")
    (asdf:oos 'asdf:test-op ~:*~s)
    (princ \"ECL-TEST-OK\"))
  (serious-condition (c) (princ c)))
#+ecl
(ext:quit)
#+sbcl
(sb-ext:quit)
")

(defun run-quicklisp-tests (&optional (output (merge-pathnames "quicklisp.log"
							       *output-directory*)))
  (mapcar #'delete-everything (directory (merge-pathnames "*/" *cache*)))
  (let ((quicklisp-logs (merge-pathnames "quicklisp.logs/" *output-directory*)))
    (labels ((build-or-test-job (name suffix template)
	       (let* ((name (string-downcase name))
		      (log-name (concatenate 'string name suffix))
		      (build-log (ensure-directories-exist
				  (merge-pathnames log-name quicklisp-logs))))
		 (multiple-value-bind (stream status process)
		     (ext:run-program *test-image*
				      *test-image-args*
				      :input :stream
				      :output build-log
				      :error :output
				      :wait nil)
		   (unwind-protect
			(progn
			  (format stream template
				  (namestring *cache*)
				  (namestring *quicklisp-setup-file*)
				  name)
			  (format t template
				  (namestring *cache*)
				  (namestring *quicklisp-setup-file*)
				  name)
			  (force-output stream))
		     (close stream)
		     (ext:external-process-wait process t)
		     ))))
	     (build-job (name)
	       (build-or-test-job name "-build.log" +quicklisp-build-template+))
	     (test-job (name)
	       (build-or-test-job name "-test.log" +quicklisp-test-template+)))
      (mapc #'build-job *quicklisp-library-list*)
      (mapc #'test-job *quicklisp-library-list*))))