Newer
Older
;;;;; Minimal life-support for testing ASDF from a blank Lisp image.
#|
Some constraints:
* We cannot rely on any test library that could be loaded by ASDF.
And we cannot even rely on ASDF being present until we load it.
But we *can* rely on ASDF being present *after* we load it.
* evaluating this file MUST NOT print anything,
because we use it in the forward-ref test to check that nothing is printed.
* We make sure that none of our symbols clash with asdf/driver or asdf,
so we may use-package them during testing.
(defpackage :asdf-test
(:use :common-lisp)
(:export
#:asym #:acall #:asymval
#:*test-directory* #:*asdf-directory* #:*build-directory* #:*implementation*
#:assert-compare #:assert-equal #:assert-pathname-equal #:assert-pathnames-equal
#:hash-table->alist
#:load-asdf #:maybe-compile-asdf
#:load-asdf-lisp #:compile-asdf #:load-asdf-fasl
#:compile-load-asdf #:load-asdf-system #:clean-load-asdf-system
#:register-directory #:load-test-system
#:with-test #:test-asdf #:debug-asdf
#:assert-compare
#:leave-test #:def-test-system
#:action-name #:in-plan-p
#:test-source #:test-fasl #:resolve-output #:output-location
Francois-Rene Rideau
committed
(in-package :asdf-test)
(declaim (optimize (speed 2) (safety 3) #-(or allegro gcl genera) (debug 3)
#+(or cmu scl) (c::brevity 2)))
(proclaim '(optimize (speed 2) (safety 3) #-(or allegro gcl genera) (debug 3)
#+(or cmu scl) (c::brevity 2)))
(defvar *trace-symbols*
`(;; If you want to trace some stuff while debugging ASDF,
;; here's a nice place to say what.
;; These string designators will be interned in ASDF after it is loaded.
;;#+ecl ,@'( :perform :input-files :output-files :compile-file* :compile-file-pathname* :load*)
))
(defvar *debug-asdf* nil)
(defvar *quit-when-done* t)
(defun verbose (&optional (verbose t) (print verbose))
(setf *load-verbose* verbose *compile-verbose* verbose)
(setf *load-print* print *compile-print* print))
;;; Minimal compatibility layer
(eval-when (:compile-toplevel :load-toplevel :execute)
#+allegro
(setf excl:*warn-on-nested-reader-conditionals* nil
excl::*autoload-package-name-alist*
(remove "asdf" excl::*autoload-package-name-alist*
:test 'equalp :key 'car)) ; We need that BEFORE any mention of package ASDF.
#+cmucl (setf ext:*gc-verbose* nil)
(when (and (= system::*gcl-major-version* 2)
(= system::*gcl-minor-version* 6))
(pushnew :gcl2.6 *features*)
(shadowing-import 'system:*load-pathname* :asdf-test))
#+lispworks
(setf system:*stack-overflow-behaviour* :warn))
#+(or gcl genera)
(unless (fboundp 'ensure-directories-exist)
(defun ensure-directories-exist (path)
#+genera (fs:create-directories-recursively (pathname path))
#+gcl (lisp:system (format nil "mkdir -p ~S"
(namestring (make-pathname :name nil :type nil :defaults path))))))
;;; Survival utilities
(defun asym (name &optional package errorp)
(let* ((pname (or package :asdf))
(package (find-package pname)))
(if package
(or (find-symbol (string name) package)
(when errorp (error "Can't find symbol ~A in ~A" name pname)))
(when errorp (error "Can't find package ~A" pname)))))
(defun acall (name &rest args)
(apply (apply 'asym (if (consp name) name (list name))) args))
(defun asymval (name &optional package)
(symbol-value (asym name package)))
(defsetf asymval (name &optional package) (new-value) ;; NB: defun setf won't work on GCL2.6
(let ((sym (gensym "SYM")))
`(let ((,sym (asym ,name ,package)))
(if ,sym
(setf (symbol-value ,sym) ,new-value)
(error "NIHIL EX NIHILO")))))
(defun finish-outputs* ()
(loop :for s :in (list *standard-output* *error-output* *trace-output* *debug-io*)
:do (finish-output s)))
(defun redirect-outputs ()
(setf *error-output* *standard-output*
*trace-output* *standard-output*))
Francois-Rene Rideau
committed
(redirect-outputs) ;; Put everything on standard output, for the sake of scripts
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
;;; Helpful for debugging
(defun pathname-components (p)
(when p
(let ((p (pathname p)))
(list :host (pathname-host p)
:device (pathname-device p)
:directory (pathname-directory p)
:name (pathname-name p)
:type (pathname-type p)
:version (pathname-version p)))))
(defun assert-pathname-equal-helper (qx x qy y)
(cond
((equal x y)
(format t "~S and ~S both evaluate to same path:~% ~S~%" qx qy x))
((acall :pathname-equal x y)
(format t "These two expressions yield pathname-equal yet not equal path~% ~S~%" x)
(format t "the first expression ~S yields this:~% ~S~%" qx (pathname-components x))
(format t "the other expression ~S yields that:~% ~S~%" qy (pathname-components y)))
(t
(format t "These two expressions yield paths that are not pathname-equal~%")
(format t "the first expression ~S yields this:~% ~S~% ~S~%" qx x (pathname-components x))
(format t "the other expression ~S yields that:~% ~S~% ~S~%" qy y (pathname-components y)))))
(defmacro assert-pathname-equal (x y)
`(assert-pathname-equal-helper ',x ,x ',y ,y))
(defun assert-length-equal-helper (qx qy x y)
(unless (= (length x) (length y))
(format t "These two expressions yield sequences of unequal length~%")
(format t "The first, ~S, has value ~S of length ~S~%" qx x (length x))
(format t "The other, ~S, has value ~S of length ~S~%" qy y (length y))))
(defun assert-pathnames-equal-helper (qx x qy y)
(assert-length-equal-helper qx x qy y)
(loop :for n :from 0
:for qpx = `(nth ,n ,qx)
:for qpy = `(nth ,n ,qy)
:for px :in x
:for py :in y :do
(assert-pathname-equal-helper qpx px qpy py)))
(defmacro assert-pathnames-equal (x y)
`(assert-pathnames-equal-helper ',x ,x ',y ,y))
;; More pathname madness.
;; We can't use goodies from asdf/pathnames because ASDF isn't loaded yet.
;; We still want to work despite and host/device funkiness,
;; so we do it the hard way.
(defparameter *test-directory*
Francois-Rene Rideau
committed
(truename
(make-pathname :name nil :type nil :version nil
:defaults (or *load-pathname* *compile-file-pathname* *default-pathname-defaults*))))
(defun make-sub-pathname (&rest keys &key defaults &allow-other-keys)
(merge-pathnames (apply 'make-pathname keys) defaults))
(defun relative-dir (&rest dir) #-gcl (cons ':relative dir) #+gcl dir)
(defun back-dir () #-gcl :back #+gcl :parent)
(defparameter *asdf-directory*
(truename (make-sub-pathname :directory (relative-dir (back-dir)) :defaults *test-directory*)))
(defparameter *uiop-directory*
(truename (make-sub-pathname :directory (relative-dir "uiop") :defaults *asdf-directory*)))
(defparameter *build-directory*
(make-sub-pathname :directory (relative-dir "build") :defaults *asdf-directory*))
(defparameter *implementation*
(or #+allegro
(ecase excl:*current-case-mode*
(:case-sensitive-lower :mlisp)
(:case-insensitive-upper :alisp))
#+armedbear :abcl
#+clisp :clisp
#+clozure :ccl
#+cmu :cmucl
#+corman :cormanlisp
#+digitool :mcl
#+ecl (or #+ecl-bytecmp :ecl_bytecodes :ecl)
#+gcl :gcl
#+lispworks :lispworks
#+mkcl :mkcl
#+sbcl :sbcl
#+scl :scl
#+xcl :xcl))
(defparameter *early-fasl-directory*
(make-sub-pathname :directory (relative-dir "fasls" (string-downcase *implementation*))
:defaults *build-directory*))
(defun asdf-name (&optional tag)
(format nil "asdf~@[-~A~]" tag))
(defun asdf-lisp (&optional tag)
(make-pathname :name (asdf-name tag) :type "lisp" :defaults *build-directory*))
(defun debug-lisp ()
(make-sub-pathname :directory (relative-dir "contrib") :name "debug" :type "lisp" :defaults *asdf-directory*))
(defun early-compile-file-pathname (file)
(compile-file-pathname
(make-pathname :name (pathname-name file) :type "lisp" :defaults *early-fasl-directory*)))
(defun asdf-fasl (&optional tag)
(early-compile-file-pathname (asdf-lisp tag)))
;;; Test helper functions
(load (debug-lisp))
(defmacro assert-compare (expr)
(destructuring-bind (op x y) expr
`(assert-compare-helper ',op ',x ',y ,x ,y)))
(defun assert-compare-helper (op qx qy x y)
(unless (funcall op x y)
(error "These two expressions fail comparison with ~S:~% ~
~S evaluates to ~S~% ~S evaluates to ~S~%"
op qx x qy y)))
(defmacro assert-equal (x y)
`(assert-compare (equal ,x ,y)))
Francois-Rene Rideau
committed
(defun touch-file (file &key offset timestamp in-filesystem)
(let* ((base (or timestamp (get-universal-time)))
(stamp (if offset (+ base offset) base)))
(if (and (asymval :*asdf-cache*) (not in-filesystem))
(acall :register-file-stamp file stamp)
(multiple-value-bind (sec min hr day month year)
(decode-universal-time stamp #+gcl2.6 -5) ;; -5 is for *my* localtime
(unless in-filesystem
(error "Y U NO use stamp cache?"))
(acall :run-program
`("touch" "-t" ,(format nil "~4,'0D~2,'0D~2,'0D~2,'0D~2,'0D.~2,'0D"
year month day hr min sec)
,(acall :native-namestring file)))
(assert-equal (file-write-date file) stamp)))))
(defun mark-file-deleted (file)
(unless (asymval :*asdf-cache*) (error "Y U NO use asdf cache?"))
(acall :register-file-stamp file nil))
Francois-Rene Rideau
committed
(defun hash-table->alist (table)
(loop :for key :being :the :hash-keys :of table :using (:hash-value value)
:collect (cons key value)))
(defun exit-lisp (&optional (code 0)) ;; Simplified from asdf/image:quit
#+(or abcl xcl) (ext:quit :status code)
#+allegro (excl:exit code :quiet t)
#+clisp (ext:quit code)
#+clozure (ccl:quit code)
#+cormanlisp (win32:exitprocess code)
#+(or cmu scl) (unix:unix-exit code)
#+ecl (si:quit code)
#+gcl (lisp:quit code)
#+genera (error "You probably don't want to Halt the Machine. (code: ~S)" code)
#+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t)
#+mcl (ccl:quit) ;; or should we use FFI to call libc's exit(3) ?
#+mkcl (mk-ext:quit :exit-code code)
#+sbcl #.(let ((exit (find-symbol "EXIT" :sb-ext))
(quit* (find-symbol "QUIT" :sb-ext)))
(cond
(exit `(,exit :code code :abort t))
(quit* `(,quit* :unix-status code :recklessly-p t))))
#-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
(error "~S called with exit code ~S but there's no quitting on this implementation" 'quit code))
(defun leave-test (message return)
(fresh-line *error-output*)
(when message
(format *error-output* message)
(fresh-line *error-output*))
(throw :asdf-test-done return))
Francois-Rene Rideau
committed
(defmacro with-test ((&optional) &body body)
`(call-with-test (lambda () ,@body)))
(defun call-with-test (thunk)
"Unless the environment variable DEBUG_ASDF_TEST
is bound, write a message and exit on an error. If
*asdf-test-debug* is true, enter the debugger."
(let ((result
(catch :asdf-test-done
(handler-bind
((error (lambda (c)
(ignore-errors
(format *error-output* "~&TEST ABORTED: ~A~&" c))
(*debug-asdf*
(format t "~&It's your baby, fix it!~%")
(break))
(ignore-errors
(acall :print-condition-backtrace
c :count 69 :stream *error-output*))
(leave-test "Script failed" 1))))))
(funcall (or (asym :call-with-asdf-cache) 'funcall) thunk)
(leave-test "Script succeeded" 0)))))
(when *quit-when-done*
(exit-lisp result))))
;;; These are used by the upgrade tests
(defmacro quietly (&body body)
`(call-quietly #'(lambda () ,@body)))
(defun call-quietly (thunk)
(handler-bind (#+sbcl (sb-kernel:redefinition-warning #'muffle-warning))
(funcall thunk)))
Francois-Rene Rideau
committed
(defun interactive-test (&optional files)
(verbose t nil)
(loop :for file :in files :do
(load (string-downcase file)))
(setf *package* (some 'find-package '(:asdf :asdf/driver :asdf/utility :asdf/package :asdf-test)))
(load "contrib/debug.lisp"))
(defun load-asdf-lisp (&optional tag)
(quietly (load (asdf-lisp tag) :verbose *load-verbose* :print *load-print*)))
Francois-Rene Rideau
committed
(defun load-asdf-fasl (&optional tag)
(quietly (load (asdf-fasl tag))))
(defun register-directory (dir)
(pushnew dir (symbol-value (asym :*central-registry*))))
(quietly
(register-directory *asdf-directory*)
(register-directory *uiop-directory*)
(apply (asym :oos) (asym :load-op) :asdf keys)))
(defun call-with-asdf-conditions (thunk &optional verbose)
(declare (ignorable verbose))
(handler-bind (#+sbcl
((or sb-c::simple-compiler-note sb-kernel:redefinition-warning)
#'muffle-warning)
#+(and ecl (not ecl-bytecmp))
((or c::compiler-note c::compiler-debug-note
c::compiler-warning) ;; ECL emits more serious warnings than it should.
#'muffle-warning)
#+mkcl
((or compiler:compiler-note) #'muffle-warning)
#-(or cmu scl)
;; style warnings shouldn't abort the compilation [2010/02/03:rpg]
(style-warning
#'(lambda (w)
;; escalate style-warnings to warnings - we don't want them.
(when verbose
(warn "Can you please fix ASDF to not emit style-warnings? Got a ~S:~%~A"
(type-of w) w))
(muffle-warning w))))
(funcall thunk)))
(defmacro with-asdf-conditions ((&optional verbose) &body body)
`(call-with-asdf-conditions #'(lambda () ,@body) ,verbose))
(defun compile-asdf (&optional tag verbose)
(let* ((alisp (asdf-lisp tag))
(afasl (asdf-fasl tag))
(tmp (make-pathname :name "asdf-tmp" :defaults afasl)))
(ensure-directories-exist afasl)
(multiple-value-bind (result warnings-p errors-p)
(compile-file alisp :output-file tmp #-gcl :verbose #-gcl verbose :print verbose)
(flet ((bad (key)
(when result (ignore-errors (delete-file result)))
key)
(good (key)
(when (probe-file afasl) (delete-file afasl))
(rename-file tmp afasl)
key))
(cond
(errors-p (bad :errors))
(warnings-p
(or
;; ECL 11.1.1 has spurious warnings, same with XCL 0.0.0.291.
;; SCL has no warning but still raises the warningp flag since 2.20.15 (?)
#+(or cmu ecl scl xcl) (good :expected-warnings)
(t (good :success)))))))
(defun maybe-compile-asdf (&optional tag)
(let ((alisp (asdf-lisp tag))
(afasl (asdf-fasl tag)))
(cond
((not (probe-file alisp))
:not-found)
((and (probe-file afasl)
(> (file-write-date afasl) (file-write-date alisp))
(ignore-errors (load-asdf-fasl tag)))
:previously-compiled)
(t
(compile-asdf tag)))))
(defun compile-asdf-script ()
(with-test ()
(ecase (with-asdf-conditions () (maybe-compile-asdf))
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
(:not-found
(leave-test "Testsuite failed: unable to find ASDF source" 3))
(:previously-compiled
(leave-test "Reusing previously-compiled ASDF" 0))
(:errors
(leave-test "Testsuite failed: ASDF compiled with ERRORS" 2))
(:unexpected-warnings
(leave-test "Testsuite failed: ASDF compiled with unexpected warnings" 1))
(:expected-warnings
(leave-test "ASDF compiled with warnings, ignored for your implementation" 0))
(:success
(leave-test "ASDF compiled cleanly" 0)))))
(defun compile-load-asdf (&optional tag)
;; emulate the way asdf upgrades itself: load source, compile, load fasl.
(load-asdf-lisp tag)
(ecase (compile-asdf tag)
((:errors :unexpected-warnings) (leave-test "failed to compile ASDF" 1))
((:expected-warnings :success)
(load-asdf-fasl tag))))
;;; Now, functions to compile and load ASDF.
(defun load-test-system (x &key verbose)
(let ((*load-print* verbose)
(*load-verbose* verbose))
(register-directory *test-directory*)
(acall :oos (asym :load-op) x :verbose verbose)))
(defun get-asdf-version ()
(when (find-package :asdf)
(or (symbol-value (find-symbol (string :*asdf-version*) :asdf))
(let ((ver (symbol-value (find-symbol (string :*asdf-revision*) :asdf))))
(etypecase ver
(string ver)
(cons (format nil "~{~D~^.~}" ver))
(null "1.0"))))))
(defun output-location (&rest sublocation)
(list* *asdf-directory* "build/fasls" :implementation sublocation))
(defun resolve-output (&rest sublocation)
(acall :resolve-location (apply 'output-location sublocation)))
(defun test-source (file)
(acall :subpathname *test-directory* file))
(defun test-output-dir ()
(resolve-output "asdf" "test"))
(defun test-output (file)
(acall :subpathname (test-output-dir) file))
(defun test-fasl (file)
(acall :compile-file-pathname* (test-source file)))
(defun clean-asdf-system ()
;; If compiled by an antique ASDFs without output translations:
Francois-Rene Rideau
committed
(flet ((d (x) (acall :delete-file-if-exists x)))
(let ((asdf-fasl (compile-file-pathname (asdf-lisp))))
(d asdf-fasl)
(d (acall :apply-output-translations asdf-fasl))
(d (asdf-fasl)))))
(defun load-asdf-lisp-clean ()
(load-asdf-lisp)
(clean-asdf-system))
(defun configure-asdf ()
(format t "Configuring ASDF~%")
(when (asym :getenvp)
(format t "Enabling debugging~%")
(setf *debug-asdf* (or *debug-asdf* (acall :getenvp "DEBUG_ASDF_TEST"))))
(when *trace-symbols*
(format t "Tracing~{ ~A~}~%" *trace-symbols*)
(eval `(trace ,@(loop :for s :in *trace-symbols* :collect (asym s)))))
(when (asym :initialize-source-registry)
(acall :initialize-source-registry
`(:source-registry :ignore-inherited-configuration)))
(when (asym :initialize-output-translations)
(acall :initialize-output-translations
`(:output-translations
Francois-Rene Rideau
committed
(,(acall :wilden *asdf-directory*) ,(acall :wilden (resolve-output "asdf/")))
(t ,(acall :wilden (resolve-output "root")))
:ignore-inherited-configuration)))
Francois-Rene Rideau
committed
(set (asym :*central-registry*) `(,*test-directory*)))
Francois-Rene Rideau
committed
(when (asym :*asdf-verbose*) (setf (asymval :*asdf-verbose*) t))
(when (asym :*verbose-out*) (setf (asymval :*verbose-out*) *standard-output*))
(when (and (asym :locate-system) (asym :pathname-directory-pathname)
(asym :pathname-equal))
(format t "Comparing directories~%")
(let ((x (acall :pathname-directory-pathname (nth-value 2 (acall :locate-system :test-asdf)))))
(assert-pathname-equal *test-directory* x) ;; not always EQUAL (!)
(unless (equal *test-directory* x)
(format t "Interestingly, while *test-directory* has components~% ~S~%~
ASDF finds the ASDs in~% ~S~%Using the latter.~%"
(pathname-components *test-directory*)
(pathname-components x)))
(setf *test-directory* x)))
Francois-Rene Rideau
committed
(format t "Frob packages~%")
(use-package :asdf :asdf-test)
(when (find-package :asdf/driver) (use-package :asdf/driver :asdf-test))
(when (find-package :asdf/cache) (use-package :asdf/cache :asdf-test))
Francois-Rene Rideau
committed
(setf *package* (find-package :asdf-test))
t)
(defun load-asdf (&optional tag)
#+gcl2.6 (load-asdf-lisp tag) #-gcl2.6
(load-asdf-fasl tag)
Francois-Rene Rideau
committed
(configure-asdf))
Francois-Rene Rideau
committed
(defun debug-asdf ()
(setf *debug-asdf* t)
(setf *quit-when-done* nil)
(setf *package* (find-package :asdf-test)))
Francois-Rene Rideau
committed
(defun just-load-asdf-fasl () (load-asdf-fasl))
;; Actual scripts rely on this function:
(defun common-lisp-user::load-asdf () (load-asdf))
(setf *package* (find-package :asdf-test))
(defmacro def-test-system (name &rest rest)
`(apply (asym :register-system-definition) ',name :pathname ,*test-directory*
:source-file nil ',rest))
(defun in-plan-p (plan x) (member x plan :key (asym :action-path) :test 'equal))
(defmacro test-load-systems (&rest x)
`(do-test-load-systems ',x))
Francois-Rene Rideau
committed
(defun do-test-load-systems (systems)
(load-asdf-lisp)
(dolist (sys systems)
(format t "~&Trying to load ~A~%" sys)
(acall :load-system sys))
(format t "~&Done!~%"))
(defun test-upgrade (old-method new-method tag) ;; called by run-test
(with-test ()
(verbose t nil)
(when old-method
(cond
((string-equal tag "REQUIRE")
(format t "Requiring some previous ASDF ~A~%" tag)
(ignore-errors (funcall 'require "asdf"))
(if (member "ASDF" *modules* :test 'equalp)
(format t "Your Lisp implementation provided ASDF ~A~%" (get-asdf-version))
(leave-test "Your Lisp implementation does not provide ASDF. Skipping test.~%" 0)))
(t
(format t "Loading old asdf ~A via ~A~%" tag old-method)
(funcall old-method tag))))
(when (find-package :asdf)
(configure-asdf))
(format t "Now loading new asdf via method ~A~%" new-method)
(funcall new-method)
(format t "Testing it~%")
(register-directory *test-directory*)
Francois-Rene Rideau
committed
(load-test-system :test-asdf/all)
(assert (asymval '#:*file1* :test-package))
(assert (asymval '#:*file3* :test-package))))
;; These are shorthands for interactive debugging of test scripts:
(!a
common-lisp-user::debug-asdf debug-asdf
da debug-asdf common-lisp-user::da debug-asdf
la load-asdf common-lisp-user::la load-asdf
ll load-asdf-lisp
v verbose)
#| For the record, the following form is sometimes useful to insert in
asdf/plan:compute-action-stamp to find out what's happening.
It depends on the DBG macro in contrib/debug.lisp,
that you should load in your asdf/plan by inserting an (asdf-debug) form in it.
(let ((action-path (action-path (cons o c)))) (DBG :cas action-path just-done plan stamp-lookup out-files in-files out-op op-time dep-stamp out-stamps in-stamps missing-in missing-out all-present earliest-out latest-in up-to-date-p done-stamp (operation-done-p o c)
;;; blah
))
|#