Commit fa8cf3e6 authored by Gary King's avatar Gary King
Browse files

handle bad *central-registry* itmes; xcvb compat

* Add two restarts (coerce-entry-to-directory and
  remove-entry-from-registry) and use them to guard
  against *central-registry* entries that are not
  directories.

* add some XCVB goodness to aid in compatibility.
parent 1e25da8a
Loading
Loading
Loading
Loading
+62 −9
Original line number Original line Diff line number Diff line
@@ -112,6 +112,8 @@
	   #:try-recompiling
	   #:try-recompiling
           #:retry
           #:retry
           #:accept                     ; restarts
           #:accept                     ; restarts
	   #:coerce-entry-to-directory
	   #:remove-entry-from-registry


           #:standard-asdf-method-combination
           #:standard-asdf-method-combination
           #:around                     ; protocol assistants
           #:around                     ; protocol assistants
@@ -430,17 +432,68 @@ which evaluates to a pathname. For example:
                #p\"/usr/share/common-lisp/systems/\"))
                #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)
(defun sysdef-central-registry-search (system)
  (let ((name (coerce-name system)))
  (let ((name (coerce-name system))
	(to-remove nil)
	(to-replace nil))
    (block nil
    (block nil
      (unwind-protect
	   (dolist (dir *central-registry*)
	   (dolist (dir *central-registry*)
        (let* ((defaults (eval dir))
	     (let ((defaults (eval dir)))
               (file (and defaults
	       (cond ((directory-pathname-p defaults)
		      (let ((file (and defaults
				       (make-pathname
				       (make-pathname
					:defaults defaults :version :newest
					:defaults defaults :version :newest
					:name name :type "asd" :case :local))))
					:name name :type "asd" :case :local))))
			(if (and file (probe-file file))
			(if (and file (probe-file file))
              (return 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 ()
(defun make-temporary-package ()
  (flet ((try (counter)
  (flet ((try (counter)
+270 −0
Original line number Original line Diff line number Diff line
;;; -*- 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")))

test/in-progress.lisp

0 → 100644
+30 −0
Original line number Original line Diff line number Diff line
(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/"))
)