From f3c8215dff31546bcdc260ce5d00b5ad671f7637 Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <fare@tunes.org> Date: Thu, 21 Oct 2010 13:42:36 -0700 Subject: [PATCH] 2.140: Make subdirectories actually work with ABCL, Allegro, CMUCL, CormanLisp, Scieneer Also, save defsystem-depends-on information for the sake of introspection by e.g. quicklisp. Some documentation clarifications. --- asdf.lisp | 55 +++++++++++++++++++++++----------- doc/asdf.texinfo | 6 +++- test/test-configuration.script | 9 ++++++ 3 files changed, 51 insertions(+), 19 deletions(-) diff --git a/asdf.lisp b/asdf.lisp index c319771c..51bb36f7 100644 --- a/asdf.lisp +++ b/asdf.lisp @@ -72,7 +72,7 @@ (defvar *asdf-version* nil) (defvar *upgraded-p* nil) (let* ((asdf-version ;; the 1+ helps the version bumping script discriminate - (subseq "VERSION:2.139" (1+ (length "VERSION")))) + (subseq "VERSION:2.140" (1+ (length "VERSION")))) (existing-asdf (fboundp 'find-system)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) @@ -305,6 +305,7 @@ #:split-string #:component-name-to-pathname-components #:split-name-type + #:subdirectories #:truenamize #:while-collecting))) (setf *asdf-version* asdf-version @@ -695,11 +696,14 @@ ways that the filename components can be missing are for it to be NIL, Note that this does _not_ check to see that PATHNAME points to an actually-existing directory." - (flet ((check-one (x) - (member x '(nil :unspecific "") :test 'equal))) - (and (check-one (pathname-name pathname)) - (check-one (pathname-type pathname)) - t))) + (when pathname + (let ((pathname (pathname pathname))) + (flet ((check-one (x) + (member x '(nil :unspecific "") :test 'equal))) + (and (not (wild-pathname-p pathname)) + (check-one (pathname-name pathname)) + (check-one (pathname-type pathname)) + t))))) (defun* ensure-directory-pathname (pathspec) "Converts the non-wild pathname designator PATHSPEC to directory form." @@ -1069,7 +1073,8 @@ with given pathname and if it exists return its truename." (licence :accessor system-licence :initarg :licence :accessor system-license :initarg :license) (source-file :reader system-source-file :initarg :source-file - :writer %set-system-source-file))) + :writer %set-system-source-file) + (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on))) ;;;; ------------------------------------------------------------------------- ;;;; version-satisfies @@ -2156,7 +2161,7 @@ details." (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system) defsystem-depends-on &allow-other-keys) options - (let ((component-options (remove-keys '(:defsystem-depends-on :class) options))) + (let ((component-options (remove-keys '(:class) options))) `(progn ;; system must be registered before we parse the body, otherwise ;; we recur when trying to find an existing system of the same name @@ -3247,17 +3252,31 @@ with a different configuration, so the configuration would be re-read then." #+clisp #+clisp :circle t)) t)) -(defparameter *wild-subdir* - (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil)) - (defun subdirectories (directory) - (ignore-errors - (directory (merge-pathnames* *wild-subdir* directory) - #+sbcl #+sbcl :resolve-symlinks nil - #+ccl #+ccl :follow-links nil - #+ccl #+ccl :directories t - #+ccl #+ccl :files nil - #+clisp #+clisp :circle t))) + (let* ((directory (ensure-directory-pathname directory)) + #-cormanlisp + (wild (merge-pathnames* + #-(or abcl allegro scl) + (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil) + #+(or abcl allegro scl) "*.*" + directory)) + (dirs + #-cormanlisp + (ignore-errors + (directory wild . + #.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil) + #+ccl '(:follow-links nil :directories t :files nil) + #+clisp '(:circle t :if-does-not-exist :ignore) + #+(or cmu scl) '(:follow-links nil :truenamep nil) + #+digitool '(:directories t) + #+sbcl '(:resolve-symlinks nil)))) + #+cormanlisp (cl::directory-subdirs directory)) + #+(or abcl allegro scl) + (dirs (remove-if-not #+abcl #'extensions:probe-directory + #+allegro #'excl:probe-directory + #+scl #'directory-pathname-p + dirs))) + dirs)) (defun collect-subdirs (directory collectp recursep collector) (when (funcall collectp directory) diff --git a/doc/asdf.texinfo b/doc/asdf.texinfo index 1dcf3ced..b054f075 100644 --- a/doc/asdf.texinfo +++ b/doc/asdf.texinfo @@ -1717,6 +1717,9 @@ to be found, for systems to be found the current directory (at the time that the configuration is initialized) as well as @code{:directory} entries for @file{$XDG_DATA_DIRS/common-lisp/systems/} and @code{:tree} entries for @file{$XDG_DATA_DIRS/common-lisp/source/}. +For instance, SBCL will include directories for its contribs +when it can find them; it will look for them where SBCL was installed, +or at the location specified by the @code{SBCL_HOME} environment variable. @end enumerate @@ -1796,6 +1799,8 @@ DIRECTIVE := (:exclude PATTERN ...) | ;; augment the defaults for exclusion patterns (:also-exclude PATTERN ...) | + ;; Note that the scope of a an exclude pattern specification is + ;; the rest of the current configuration expression or file. ;; splice the parsed contents of another config file (:include REGULAR-FILE-PATHNAME-DESIGNATOR) | @@ -1840,7 +1845,6 @@ once contained: :inherit-configuration) @end example - @section Configuration Directories Configuration directories consist in files each contains diff --git a/test/test-configuration.script b/test/test-configuration.script index ae3364bc..96477fa5 100644 --- a/test/test-configuration.script +++ b/test/test-configuration.script @@ -46,6 +46,8 @@ (cl-user::quit-on-error +(format t "~&subdirectories of dir2/: ~S~%" (subdirectories (under-test-directory "dir2/"))) +(assert (= 2 (length (subdirectories (under-test-directory "dir2/"))))) (assert (equal (parse-output-translations-string "/foo:/bar::/baz:/quux") '(:output-translations @@ -74,6 +76,13 @@ `(:source-registry (:include ,(under-test-directory "conf.d/")) :ignore-inherited-configuration)) +(format t "~&Source Registry: ~S~%" + asdf::*source-registry*) +(assert (find-system :foo0 nil)) +(assert (find-system :foo1 nil)) +(assert (find-system :foo2 nil)) +(assert (find-system :foo3 nil)) + (assert (equal (namestring (system-relative-pathname :foo3 "bar/baz.lisp")) (under-test-directory "dir2/bar/baz.lisp"))) -- GitLab