Commit 1ad4042c authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Only load-asd UIOP when strictly newer than ASDF

parent fdda4604
...@@ -142,20 +142,25 @@ Do NOT try to load a .asd file directly with CL:LOAD. Always use ASDF:LOAD-ASD." ...@@ -142,20 +142,25 @@ Do NOT try to load a .asd file directly with CL:LOAD. Always use ASDF:LOAD-ASD."
;; Returns T if everything went right, NIL if the system was an ASDF of the same or older version, ;; Returns T if everything went right, NIL if the system was an ASDF of the same or older version,
;; that shall not be loaded. Also issue a warning if it was a strictly older version of ASDF. ;; that shall not be loaded. Also issue a warning if it was a strictly older version of ASDF.
(defun check-not-old-asdf-system (name pathname) (defun check-not-old-asdf-system (name pathname)
(or (not (equal name "asdf")) (or (not (member name '("asdf" "uiop") :test 'equal))
(null pathname) (null pathname)
(let* ((version-pathname (subpathname pathname "version.lisp-expr")) (let* ((asdfp (equal name "asdf")) ;; otherwise, it's uiop
(version-pathname
(subpathname pathname "version" :type (if asdfp "lisp-expr" "lisp")))
(version (and (probe-file* version-pathname :truename nil) (version (and (probe-file* version-pathname :truename nil)
(read-file-form version-pathname))) (read-file-form version-pathname :at (if asdfp '(0) '(2 2 2)))))
(old-version (asdf-version))) (old-version (asdf-version)))
(cond (cond
((version<= old-version version) t) ;; newer or same version: good! ;; Don't load UIOP of the exact same version: we already loaded it as part of ASDF.
((and (equal old-version version) (equal name "uiop")) nil)
((version<= old-version version) t) ;; newer or same version: Good!
(t ;; old version: bad (t ;; old version: bad
(ensure-gethash (ensure-gethash
(list (namestring pathname) version) *old-asdf-systems* (list (namestring pathname) version) *old-asdf-systems*
#'(lambda () #'(lambda ()
(let ((old-pathname (system-source-file (registered-system "asdf")))) (let ((old-pathname (system-source-file (registered-system "asdf"))))
(warn "~@<~ (if asdfp
(warn "~@<~
You are using ASDF version ~A ~:[(probably from (require \"asdf\") ~ You are using ASDF version ~A ~:[(probably from (require \"asdf\") ~
or loaded by quicklisp)~;from ~:*~S~] and have an older version of ASDF ~ or loaded by quicklisp)~;from ~:*~S~] and have an older version of ASDF ~
~:[(and older than 2.27 at that)~;~:*~A~] registered at ~S. ~ ~:[(and older than 2.27 at that)~;~:*~A~] registered at ~S. ~
...@@ -177,7 +182,11 @@ Do NOT try to load a .asd file directly with CL:LOAD. Always use ASDF:LOAD-ASD." ...@@ -177,7 +182,11 @@ Do NOT try to load a .asd file directly with CL:LOAD. Always use ASDF:LOAD-ASD."
then you might indeed want to either install and register a more recent version, ~ then you might indeed want to either install and register a more recent version, ~
or use :ignore-inherited-configuration to avoid registering the old one. ~ or use :ignore-inherited-configuration to avoid registering the old one. ~
Please consult ASDF documentation and/or experts.~@:>~%" Please consult ASDF documentation and/or experts.~@:>~%"
old-version old-pathname version pathname)))) old-version old-pathname version pathname)
;; NB: for UIOP, don't warn, just ignore.
(warn "ASDF ~A (from ~A), UIOP ~A (from ~A)"
old-version old-pathname version pathname)
))))
nil))))) ;; only issue the warning the first time, but always return nil nil))))) ;; only issue the warning the first time, but always return nil
(defun locate-system (name) (defun locate-system (name)
......
...@@ -303,15 +303,14 @@ ...@@ -303,15 +303,14 @@
(ensure-directories-exist (subpathname *build-directory* "deleteme/a/b/d/")) (ensure-directories-exist (subpathname *build-directory* "deleteme/a/b/d/"))
(ensure-directories-exist (subpathname *build-directory* "deleteme/a/b/e/")) (ensure-directories-exist (subpathname *build-directory* "deleteme/a/b/e/"))
(register-directory *asdf-directory*) (register-directory *asdf-directory*)
(register-directory *uiop-directory*)
(let ((new-file (subpathname *build-directory* "deleteme/a/1.x"))) (let ((new-file (subpathname *build-directory* "deleteme/a/1.x")))
(when (probe-file new-file) (when (probe-file new-file)
(delete-file new-file)) (delete-file new-file))
(copy-file (system-source-file :uiop) new-file)) (copy-file (system-source-file :asdf) new-file))
(let ((new-file (subpathname *build-directory* "deleteme/a/b/2"))) (let ((new-file (subpathname *build-directory* "deleteme/a/b/2")))
(when (probe-file new-file) (when (probe-file new-file)
(delete-file new-file)) (delete-file new-file))
(copy-file (system-source-file :uiop) new-file)) (copy-file (system-source-file :asdf) new-file))
(assert (directory-exists-p (subpathname *build-directory* "deleteme/a/b/c/"))) (assert (directory-exists-p (subpathname *build-directory* "deleteme/a/b/c/")))
(assert (directory-exists-p (subpathname *build-directory* "deleteme/a/b/d/"))) (assert (directory-exists-p (subpathname *build-directory* "deleteme/a/b/d/")))
(assert (directory-exists-p (subpathname *build-directory* "deleteme/a/b/e/"))) (assert (directory-exists-p (subpathname *build-directory* "deleteme/a/b/e/")))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment