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

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 @@
# your normal CL source registry. Otherwise, it will use local copies of
# everything.
system := "asdf"
system := "asdf"
webhome_private := common-lisp.net:/project/asdf/public_html/
webhome_public := "http://common-lisp.net/project/asdf/"
clnet_home := "/project/asdf/public_html/"
......
......@@ -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:
the search may succeed with any of the found systems,
or an error may be raised.
ASDF currently returns the first system found,
XCVB currently raised an error.
ASDF 3.2.1 or later returns the pathname whose normalized directory component
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.
Exclude statements specify patterns of subdirectories
......
......@@ -302,6 +302,19 @@ after having found a .asd file? True by default.")
(collect (list directory :recurse recurse :exclude exclude))))))
: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.
(defun compute-source-registry (&optional (parameter *source-registry-parameter*)
(registry *source-registry*))
......@@ -320,18 +333,21 @@ after having found a .asd file? True by default.")
;; instead of (load-system 'foo)
(string-downcase name)
name)))
(cond
((gethash name registry) ; already shadowed by something else
nil)
((gethash name h) ; conflict at current level
(when *verbose-out*
(warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~
found several entries for ~A - picking ~S over ~S~:>")
directory recurse name (gethash name h) asd)))
(t
(setf (gethash name registry) asd)
(setf (gethash name h) asd))))))
h)))
(unless (gethash name registry) ; already shadowed by something else
(if-let (old (gethash name h))
;; If the name appears multiple times,
;; prefer the one with the shallowest directory,
;; or if they have same depth, compare unix-namestring with string<
(multiple-value-bind (better worse)
(if (preferred-source-path-p asd old)
(progn (setf (gethash name h) asd) (values asd old))
(values old asd))
(when *verbose-out*
(warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~
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))
(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