diff --git a/asdf.lisp b/asdf.lisp index 51efdb82aeb561a7182060ed27f2f99dd92ecb8f..6a8453ba966fa242b57f48e237882ddec1379a47 100644 --- a/asdf.lisp +++ b/asdf.lisp @@ -112,6 +112,8 @@ #:try-recompiling #:retry #:accept ; restarts + #:coerce-entry-to-directory + #:remove-entry-from-registry #:standard-asdf-method-combination #:around ; protocol assistants @@ -430,17 +432,68 @@ which evaluates to a pathname. For example: #p\"/usr/share/common-lisp/systems/\")) ") +(defun directory-pathname-p (pathname) + (and (member (pathname-name pathname) (list nil :unspecific)) + (member (pathname-type pathname) (list nil :unspecific)))) + +(defun pathname-name+type (pathname) + "Returns a new pathname consisting of only the name and type from +a non-wild pathname." + (make-pathname :name (pathname-name pathname) + :type (pathname-type pathname))) + +(defun ensure-directory-pathname (pathname) + (if (directory-pathname-p pathname) + pathname + (make-pathname :defaults pathname + :directory (append + (pathname-directory pathname) + (list (file-namestring pathname))) + :name nil :type nil :version nil))) + (defun sysdef-central-registry-search (system) - (let ((name (coerce-name system))) + (let ((name (coerce-name system)) + (to-remove nil) + (to-replace nil)) (block nil - (dolist (dir *central-registry*) - (let* ((defaults (eval dir)) - (file (and defaults - (make-pathname - :defaults defaults :version :newest - :name name :type "asd" :case :local)))) - (if (and file (probe-file file)) - (return file))))))) + (unwind-protect + (dolist (dir *central-registry*) + (let ((defaults (eval dir))) + (cond ((directory-pathname-p defaults) + (let ((file (and defaults + (make-pathname + :defaults defaults :version :newest + :name name :type "asd" :case :local)))) + (if (and file (probe-file file)) + (return file)))) + (t + (restart-case + (let* ((*print-circle* nil) + (message + (format nil + "~@<While searching for system `~a`: `~a` evaluated ~ +to `~a` which is not a directory.~@:>" + system dir defaults))) + (error message)) + (remove-entry-from-registry () + :report "Remove entry from *central-registry* and continue" + (push dir to-remove)) + (coerce-entry-to-directory () + :report (lambda (s) + (format s "Coerce entry to ~a, replace ~a and continue." + (ensure-directory-pathname defaults) dir)) + (push (cons dir (ensure-directory-pathname defaults)) to-replace))))))) + ;; cleanup + (dolist (dir to-remove) + (setf *central-registry* (remove dir *central-registry*))) + (dolist (pair to-replace) + (let* ((current (car pair)) + (new (cdr pair)) + (position (position current *central-registry*))) + (setf *central-registry* + (append (subseq *central-registry* 0 position) + (list new) + (subseq *central-registry* (1+ position)))))))))) (defun make-temporary-package () (flet ((try (counter) diff --git a/test/dweinreb-tests.lisp b/test/dweinreb-tests.lisp new file mode 100644 index 0000000000000000000000000000000000000000..034a0e6eacd0ccee58053889d1ec2a6195b080bc --- /dev/null +++ b/test/dweinreb-tests.lisp @@ -0,0 +1,270 @@ +;;; -*- Lisp -*- +;;; By Dan Weinreb, Oct 1, 2006. Public domain, entirely free, etc. +#| +Daniel Weinreb +dlw@alum.mit.edu +http://danweinreb.org/blog/ +http://ilc2009.scheming.org/ +|# + +(defparameter *all-tests* nil) + +(defclass test () + ((system-name :initarg :system-name :reader test-system-name) + (operation-name :initarg :operation-name :reader test-operation-name) + (already-compiled :initarg :already-compiled :reader test-already-compiled) + (expected :initarg :expected :reader test-expected))) + +(defmacro define-test (test-name system-name + &key operation-name already-compiled expected) + `(progn + (push ',test-name *all-tests*) + (setf (get ',test-name 'test) + (make-instance 'test + :system-name ',system-name + :operation-name ',operation-name + :already-compiled ',already-compiled + :expected ',expected)))) + +(defclass test-file (asdf:component) ()) + +(defvar *test* nil) + +(defvar *steps* nil) + +(defmethod asdf:operation-done-p ((o asdf:compile-op) (c test-file)) + (declare (ignorable o)) + (member (asdf:component-name c) (test-already-compiled *test*) + :test #'string=)) + +(defmethod asdf:operation-done-p ((o asdf:operation) (c test-file)) + (declare (ignorable o c)) + nil) + +(defmethod asdf:perform ((o asdf:compile-op) (c test-file)) + (declare (ignorable o)) + (push (cons :compiled (asdf:component-name c)) *steps*)) + +(defmethod asdf:perform ((o asdf:load-op) (c test-file)) + (declare (ignorable o)) + (push (cons :loaded (asdf:component-name c)) *steps*)) + +(defun run-unit-test (test-name) + (let ((*test* (get test-name 'test)) + (*steps* nil) + (succeeded t)) + (flet ((fail (format-string &rest format-args) + (setq succeeded nil) + (format t "Error in test ~S: " test-name) + (apply #'format t format-string format-args) + (terpri))) + (let ((system-name (test-system-name *test*)) + (operation-name (test-operation-name *test*))) + (check-type system-name symbol) + (check-type operation-name symbol) + (asdf:operate operation-name system-name)) + (setq *steps* (nreverse *steps*)) + (loop for steps on *steps* do + (when (member (first steps) (rest steps) :test #'equal) + (fail "The step ~S happened more than once: ~S" + (first steps) *steps*))) + ;(format t "~2%STEPS: ~S~3%" *steps*) + (dolist (expectation (test-expected *test*)) + (destructuring-bind (op file &rest at) + expectation + ;(format t "~2%Expectation: ~S~3%" expectation) + (check-type file string) + (ecase op + ((:compiled :loaded) + (let ((pos (position (cons op file) *steps* :test #'equal))) + (if (null pos) + (fail "~S was not ~A" file op) + (loop for (relationship file2) on at by #'cddr do + (check-type file2 string) + (let* ((op2 (ecase relationship + (:after-loading :loaded) + (:after-compiling :compiled))) + (pos2 (position (cons op2 file2) *steps* + :test #'equal))) + (cond ((null pos2) + (fail "~S was not ~A at all, after ~A was ~A" + file2 op2 file op)) + ((< pos pos2) + (fail "Wrong order between ~A of ~S and ~A of ~S" + op file op2 file2)))))))) + (:did-not-compile + (when (member (cons :compiled file) *steps*) + (fail "~A compiled but should not have" file))) + (:did-not-load + (when (member (cons :loaded file) *steps*) + (fail "~A loaded but should not have" file))))))) + succeeded)) + +(defun run-all-unit-tests () + (let ((n-tests 0) + (n-succeeded 0)) + (dolist (test-name *all-tests*) + (incf n-tests) + (when (run-unit-test test-name) + (incf n-succeeded))) + (format t "Summary: ~D of ~D tests succeeded." n-succeeded n-tests))) + + +(asdf:defsystem system-1 + :components ((:test-file "a") + (:test-file "b") + (:test-file "c" :depends-on ("b")) + (:test-file "d"))) + + +(define-test test-1 system-1 + :operation-name asdf:load-op + :already-compiled ("b") + :expected ((:compiled "a") + (:loaded "a" :after-compiling "a") + (:did-not-compile "b") + (:loaded "b") + (:compiled "c" :after-loading "b") + (:loaded "c" :after-loading "b" :after-compiling "c") + (:compiled "d") + (:loaded "d" :after-compiling "d"))) + +(asdf:defsystem system-2 + :components ((:test-file "a" :depends-on ("g" "k")) + (:test-file "b") + (:test-file "c" :depends-on ("b")) + (:test-file "d" :depends-on ("e")) + (:test-file "e") + (:test-file "f" :depends-on ("c")) + (:test-file "g" :depends-on ("h")) + (:test-file "h") + (:test-file "i" :depends-on ("f" "b")) + (:test-file "j" :depends-on ("f" "c")) + (:test-file "k") + (:test-file "l" :depends-on ("d")))) + +(define-test test-2 system-2 + :operation-name asdf:load-op + :already-compiled () + :expected ((:compiled "a" :after-compiling "g" :after-compiling "k" + :after-compiling "h" :after-loading "g" + :after-loading "k" :after-loading "h") + (:loaded "a" :after-compiling "a") + (:compiled "b") + (:loaded "b" :after-compiling "b") + (:compiled "c" :after-compiling "b" :after-loading "b") + (:loaded "c" :after-compiling "b" :after-loading "b" + :after-compiling "c") + (:compiled "d" :after-compiling "e") + (:compiled "e") + (:compiled "f" :after-compiling "c" :after-compiling "b") + (:compiled "g" :after-compiling "h") + (:compiled "h") + (:compiled "i" :after-compiling "f" :after-compiling "b") + (:compiled "j" :after-compiling "f" :after-compiling "b" + :after-compiling "c") + (:compiled "i" :after-compiling "f" :after-compiling "b" + :after-compiling "c") + (:compiled "j" :after-compiling "f" :after-compiling "b" + :after-compiling "c") + (:compiled "k") + (:compiled "l" :after-compiling "d" :after-compiling "e"))) + +(asdf:defsystem system-3 + :components ((:test-file "a") + (:test-file "b" :depends-on ("a")))) + +(define-test test-3 system-3 + :operation-name asdf:compile-op + :already-compiled ("b") + :expected ((:compiled "a") + (:loaded "a" :after-compiling "a") + (:compiled "b" :after-compiling "a" :after-loading "a") + (:did-not-load "b"))) + +(define-test test-3-a system-3 + :operation-name asdf:compile-op + :already-compiled ("a" "b") + :expected ((:did-not-compile "a") + (:did-not-load "a") + (:did-not-compile "b") + (:did-not-load "b"))) + +(define-test test-3-b system-3 + :operation-name asdf:compile-op + :already-compiled () + :expected ((:compiled "a") + (:loaded "a" :after-compiling "a") + (:compiled "b" :after-compiling "a" :after-loading "a") + (:did-not-load "b"))) + +(asdf:defsystem system-4 + :components ((:test-file "a") + (:test-file "b" :depends-on ("a")))) + +(define-test test-4 system-4 + :operation-name asdf:compile-op + :already-compiled ("a" "b") + :expected ((:did-not-compile "a") + (:did-not-load "a") + (:did-not-compile "b") + (:did-not-load "b"))) + +(asdf:defsystem system-5 + :components ((:test-file "a") + (:test-file "b" :depends-on ("a") + :in-order-to ((asdf:compile-op + (asdf:load-op "a")))))) + +(define-test test-5 system-5 + :operation-name asdf:compile-op + :already-compiled ("a" "b") + :expected ((:did-not-compile "a") + (:loaded "a") + (:did-not-compile "b") + (:did-not-load "b"))) + + +(asdf:defsystem system-6 + :components ((:test-file "a") + (:test-file "b" + :in-order-to ((asdf:compile-op (asdf:compile-op "a")) + (asdf:load-op (asdf:load-op "a"))) + :do-first ((asdf:compile-op (asdf:load-op "a")))))) + +(define-test test-6 system-6 + :operation-name asdf:compile-op + :already-compiled ("a" "b") + :expected ((:did-not-compile "a") + (:did-not-load "a") + (:did-not-compile "b") + (:did-not-load "b"))) + +;; Should be just like test-3-b, but a does not get loaded. Why not? +;; Because you can't really specify :do-first because it clobbers +;; the :do-first that you provide! +(define-test test-6-a system-6 + :operation-name asdf:compile-op + :already-compiled () + :expected ((:compiled "a") + (:loaded "a" :after-compiling "a") + (:compiled "b" :after-compiling "a" :after-loading "a") + (:did-not-load "b"))) + + + + +(asdf:defsystem system-7 + :components ((:test-file "a") + (:test-file "b" + :in-order-to ((asdf:compile-op (asdf:compile-op "a")) + (asdf:load-op (asdf:load-op "a")) + (asdf:compile-op (asdf:load-op "a")))))) + +(define-test test-7 system-7 + :operation-name asdf:compile-op + :already-compiled ("a" "b") + :expected ((:did-not-compile "a") + (:loaded "a") + (:did-not-compile "b") + (:did-not-load "b"))) diff --git a/test/in-progress.lisp b/test/in-progress.lisp new file mode 100644 index 0000000000000000000000000000000000000000..85837cd79322454fa0dd554cedbd4386fce2b9cb --- /dev/null +++ b/test/in-progress.lisp @@ -0,0 +1,30 @@ +(in-package asdf) + +(assert +(equalp + (let ((*system-definition-search-functions* + '(sysdef-central-registry-search)) + (*central-registry* (list "/tmp/ok-1/" "/tmp/bad" "/tmp/ok-2/"))) + (handler-bind + ((error (lambda (c) + (when (find-restart 'remove-entry-from-registry) + (invoke-restart 'remove-entry-from-registry))))) + (find-system "a" nil)) + *central-registry*) + (list "/tmp/ok-1/" "/tmp/ok-2/")) +) + +(assert +(equalp + (let ((*system-definition-search-functions* + '(sysdef-central-registry-search)) + (*central-registry* (list "/tmp/ok-1/" "/tmp/bad" "/tmp/ok-2/"))) + (handler-bind + ((error (lambda (c) + (when (find-restart 'coerce-entry-to-directory) + (invoke-restart 'coerce-entry-to-directory))))) + (find-system "a" nil)) + *central-registry*) + (list "/tmp/ok-1/" #p"/tmp/bad/" "/tmp/ok-2/")) +) +