Commit 3135c195 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Resolve the naming conflicts in a :tree

Use the same algorithm as Quicklisp uses for its local-projects:
prefer a .asd with a path of shorter depth; and for equal depth,
prefer the path with namestring that is least for string<.
parent 81e4f08d
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
# your normal CL source registry. Otherwise, it will use local copies of # your normal CL source registry. Otherwise, it will use local copies of
# everything. # everything.
system := "asdf" system := "asdf"
webhome_private := common-lisp.net:/project/asdf/public_html/ webhome_private := common-lisp.net:/project/asdf/public_html/
webhome_public := "http://common-lisp.net/project/asdf/" webhome_public := "http://common-lisp.net/project/asdf/"
clnet_home := "/project/asdf/public_html/" clnet_home := "/project/asdf/public_html/"
......
...@@ -3642,8 +3642,13 @@ When looking in a tree, if one system is found, the search succeeds. ...@@ -3642,8 +3642,13 @@ When looking in a tree, if one system is found, the search succeeds.
If multiple systems are found, the consequences are unspecified: If multiple systems are found, the consequences are unspecified:
the search may succeed with any of the found systems, the search may succeed with any of the found systems,
or an error may be raised. or an error may be raised.
ASDF currently returns the first system found, ASDF 3.2.1 or later returns the pathname whose normalized directory component
XCVB currently raised an error. has the shortest length (as a list), and breaks ties by choosing the system
with the smallest @code{unix-namestring} when compared with @code{string<}.
Earlier versions of ASDF return ASDF return the first system found,
which is implementation-dependent, and may or may not be the pathname
with the smallest @code{unix-namestring} when compared with @code{string<}.
XCVB raises an error.
If none is found, the search continues. If none is found, the search continues.
Exclude statements specify patterns of subdirectories Exclude statements specify patterns of subdirectories
......
...@@ -302,6 +302,19 @@ after having found a .asd file? True by default.") ...@@ -302,6 +302,19 @@ after having found a .asd file? True by default.")
(collect (list directory :recurse recurse :exclude exclude)))))) (collect (list directory :recurse recurse :exclude exclude))))))
:test 'equal :from-end t)) :test 'equal :from-end t))
;; MAYBE: move this utility function to uiop/pathname and export it?
(defun pathname-directory-depth (p)
(length (normalize-pathname-directory-component (pathname-directory p))))
(defun preferred-source-path-p (x y)
"Return T iff X is to be preferred over Y as a source path"
(let ((lx (pathname-directory-depth x))
(ly (pathname-directory-depth y)))
(or (< lx ly)
(and (= lx ly)
(string< (namestring x)
(namestring y))))))
;; Will read the configuration and initialize all internal variables. ;; Will read the configuration and initialize all internal variables.
(defun compute-source-registry (&optional (parameter *source-registry-parameter*) (defun compute-source-registry (&optional (parameter *source-registry-parameter*)
(registry *source-registry*)) (registry *source-registry*))
...@@ -320,18 +333,21 @@ after having found a .asd file? True by default.") ...@@ -320,18 +333,21 @@ after having found a .asd file? True by default.")
;; instead of (load-system 'foo) ;; instead of (load-system 'foo)
(string-downcase name) (string-downcase name)
name))) name)))
(cond (unless (gethash name registry) ; already shadowed by something else
((gethash name registry) ; already shadowed by something else (if-let (old (gethash name h))
nil) ;; If the name appears multiple times,
((gethash name h) ; conflict at current level ;; prefer the one with the shallowest directory,
(when *verbose-out* ;; or if they have same depth, compare unix-namestring with string<
(warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~ (multiple-value-bind (better worse)
found several entries for ~A - picking ~S over ~S~:>") (if (preferred-source-path-p asd old)
directory recurse name (gethash name h) asd))) (progn (setf (gethash name h) asd) (values asd old))
(t (values old asd))
(setf (gethash name registry) asd) (when *verbose-out*
(setf (gethash name h) asd)))))) (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~
h))) found several entries for ~A - picking ~S over ~S~:>")
directory recurse name better worse)))
(setf (gethash name h) asd))))))
(maphash #'(lambda (k v) (setf (gethash k registry) v)) h))))
(values)) (values))
(defun initialize-source-registry (&optional (parameter *source-registry-parameter*)) (defun initialize-source-registry (&optional (parameter *source-registry-parameter*))
......
;; Used by test-source-registry. Should shadow other definitions.
(defsystem "which-asd2" :version "1")
;; Used by test-source-registry. Should be shadowed
(defsystem "which-asd2" :version "2")
;; Used by test-source-registry. Should be shadowed.
(defsystem "which-asd" :version "2")
;; Used by test-source-registry. Should shadow other definitions.
(defsystem "which-asd" :version "1")
;;; -*- Lisp -*-
(DBG "Testing that the source-registry prefers the path that is shorter and/or asciibetically earlier")
(setf *verbose-out* t)
(initialize-source-registry
`(:source-registry (:tree ,*test-directory*) :ignore-inherited-configuration))
(assert-pathname-equal
(system-source-directory "which-asd")
(subpathname *test-directory* "sources/"))
(assert-pathname-equal
(system-source-directory "which-asd2")
(subpathname *test-directory* "sources/a/"))
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