diff --git a/asdf.lisp b/asdf.lisp index 1518e38e8caa95a48b3a496ba36cac6453681775..7ce8537bd1ea32860c231f7db2e5241745f4e260 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.131" (1+ (length "VERSION")))) + (subseq "VERSION:2.132" (1+ (length "VERSION")))) (existing-asdf (fboundp 'find-system)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) @@ -178,7 +178,7 @@ (#:perform #:explain #:output-files #:operation-done-p #:perform-with-restarts #:component-relative-pathname #:system-source-file #:operate #:find-component #:find-system - #:apply-output-translations #:translate-pathname*) + #:apply-output-translations #:translate-pathname* #:resolve-location) :unintern (#:*asdf-revision* #:around #:asdf-method-combination #:split #:make-collector) @@ -323,12 +323,19 @@ (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p))))) (when (find-class 'module nil) (eval - '(defmethod update-instance-for-redefined-class :after - ((m module) added deleted plist &key) - (declare (ignorable deleted plist)) - (when *asdf-verbose* (format *trace-output* "Updating ~A~%" m)) - (when (member 'components-by-name added) - (compute-module-components-by-name m)))))) + '(progn + (defmethod update-instance-for-redefined-class :after + ((m module) added deleted plist &key) + (declare (ignorable deleted plist)) + (when *asdf-verbose* (format *trace-output* "Updating ~A~%" m)) + (when (member 'components-by-name added) + (compute-module-components-by-name m))) + (defmethod update-instance-for-redefined-class :after + ((s system) added deleted plist &key) + (declare (ignorable deleted plist)) + (when *asdf-verbose* (format *trace-output* "Updating ~A~%" s)) + (when (member 'source-file added) + (%set-system-source-file (probe-asd (component-name s) (component-pathname s)) s))))))) ;;;; ------------------------------------------------------------------------- ;;;; User-visible parameters @@ -2683,19 +2690,24 @@ with a different configuration, so the configuration would be re-read then." (make-pathname :directory '(:relative :wild-inferiors) :name :wild :type "asd" :version :newest)) -(declaim (ftype (function (t &optional boolean) (values (or null pathname) &optional)) +(declaim (ftype (function (t &key (:directory boolean) (:wilden boolean)) + (values (or null pathname) &optional)) resolve-location)) -(defun* resolve-relative-location-component (super x &optional wildenp) +(defun* resolve-relative-location-component (super x &key directory wilden) (let* ((r (etypecase x (pathname x) (string x) (cons - (let ((car (resolve-relative-location-component super (car x) nil))) + (return-from resolve-relative-location-component (if (null (cdr x)) - car - (let ((cdr (resolve-relative-location-component - (merge-pathnames* car super) (cdr x) wildenp))) + (resolve-relative-location-component + super (car x) :directory directory :wilden wilden) + (let* ((car (resolve-relative-location-component + super (car x) :directory t :wilden nil)) + (cdr (resolve-relative-location-component + (merge-pathnames* car super) (cdr x) + :directory directory :wilden wilden))) (merge-pathnames* cdr car))))) ((eql :default-directory) (relativize-pathname-directory (default-directory))) @@ -2703,49 +2715,55 @@ with a different configuration, so the configuration would be re-read then." ((eql :implementation-type) (string-downcase (implementation-type))) #-(and (or win32 windows mswindows mingw32) (not cygwin)) ((eql :uid) (princ-to-string (get-uid))))) - (d (if (pathnamep x) r (ensure-directory-pathname r))) - (s (if (and wildenp (not (pathnamep x))) - (wilden d) - d))) + (d (if (or (pathnamep x) (not directory)) r (ensure-directory-pathname r))) + (s (if (or (pathnamep x) (not wilden)) d (wilden d)))) (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super)))) (error "pathname ~S is not relative to ~S" s super)) (merge-pathnames* s super))) -(defun* resolve-absolute-location-component (x wildenp) +(defun* resolve-absolute-location-component (x &key directory wilden) (let* ((r (etypecase x (pathname x) - (string (ensure-directory-pathname x)) + (string (if directory (ensure-directory-pathname x) (parse-namestring x))) (cons - (let ((car (resolve-absolute-location-component (car x) nil))) + (return-from resolve-absolute-location-component (if (null (cdr x)) - car - (let ((cdr (resolve-relative-location-component - car (cdr x) wildenp))) - (merge-pathnames* cdr car))))) + (resolve-absolute-location-component + (car x) :directory directory :wilden wilden) + (let* ((car (resolve-absolute-location-component + (car x) :directory t :wilden nil)) + (cdr (resolve-relative-location-component + car (cdr x) :directory directory :wilden wilden))) + (merge-pathnames* cdr car))))) ; XXX why is this not just "cdr" ? ((eql :root) ;; special magic! we encode such paths as relative pathnames, ;; but it means "relative to the root of the source pathname's host and device". (return-from resolve-absolute-location-component - (make-pathname :directory '(:relative)))) + (let ((p (make-pathname :directory '(:relative)))) + (if wilden (wilden p) p)))) ((eql :home) (user-homedir)) - ((eql :user-cache) (resolve-location *user-cache* nil)) - ((eql :system-cache) (resolve-location *system-cache* nil)) + ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil)) + ((eql :system-cache) (resolve-location *system-cache* :directory t :wilden nil)) ((eql :default-directory) (default-directory)))) - (s (if (and wildenp (not (pathnamep x))) + (s (if (and wilden (not (pathnamep x))) (wilden r) r))) (unless (absolute-pathname-p s) (error "Not an absolute pathname ~S" s)) s)) -(defun* resolve-location (x &optional wildenp) +(defun* resolve-location (x &key directory wilden) (if (atom x) - (resolve-absolute-location-component x wildenp) - (loop :with path = (resolve-absolute-location-component (car x) nil) + (resolve-absolute-location-component x :directory directory :wilden wilden) + (loop :with path = (resolve-absolute-location-component + (car x) :directory (and (or directory (cdr x)) t) + :wilden (and wilden (null (cdr x)))) :for (component . morep) :on (cdr x) + :for dir = (and (or morep directory) t) + :for wild = (and wilden (not morep)) :do (setf path (resolve-relative-location-component - path component (and wildenp (not morep)))) + path component :directory dir :wilden wild)) :finally (return path)))) (defun* location-designator-p (x) @@ -2920,7 +2938,7 @@ with a different configuration, so the configuration would be re-read then." (process-output-translations (pathname dst) :inherit nil :collect collect)) (when src (let ((trusrc (or (eql src t) - (let ((loc (resolve-location src t))) + (let ((loc (resolve-location src :directory t :wilden t))) (if (absolute-pathname-p loc) (truenamize loc) loc))))) (cond ((location-function-p dst) @@ -2933,7 +2951,7 @@ with a different configuration, so the configuration would be re-read then." (funcall collect (list trusrc t))) (t (let* ((trudst (make-pathname - :defaults (if dst (resolve-location dst t) trusrc))) + :defaults (if dst (resolve-location dst :directory t :wilden t) trusrc))) (wilddst (make-pathname :name :wild :type :wild :version :wild :defaults trudst))) @@ -3218,7 +3236,7 @@ with a different configuration, so the configuration would be re-read then." (case kw ((:include :directory :tree) (and (length=n-p rest 1) - (typep (car rest) '(or pathname string null)))) + (location-designator-p (first rest)))) ((:exclude :also-exclude) (every #'stringp rest)) (null rest)))) @@ -3382,15 +3400,16 @@ with a different configuration, so the configuration would be re-read then." (ecase kw ((:include) (destructuring-bind (pathname) rest - (process-source-registry (pathname pathname) :inherit nil :register register))) + (process-source-registry (resolve-location pathname) :inherit nil :register register))) ((:directory) (destructuring-bind (pathname) rest (when pathname - (funcall register (ensure-directory-pathname pathname))))) + (funcall register (resolve-location pathname :directory t))))) ((:tree) (destructuring-bind (pathname) rest (when pathname - (funcall register (ensure-directory-pathname pathname) :recurse t :exclude *source-registry-exclusions*)))) + (funcall register (resolve-location pathname :directory t) + :recurse t :exclude *source-registry-exclusions*)))) ((:exclude) (setf *source-registry-exclusions* rest)) ((:also-exclude) diff --git a/doc/asdf.texinfo b/doc/asdf.texinfo index a6b1196e1e530dbbbf5dfc18ccc33553e4860868..8ee342b692fd1d7ae3fbddefb4e58685288a634c 100644 --- a/doc/asdf.texinfo +++ b/doc/asdf.texinfo @@ -1752,6 +1752,29 @@ DIRECTIVE := ;; This directive specifies that some default must be spliced. :default-registry +REGULAR-FILE-PATHNAME-DESIGNATOR := PATHNAME-DESIGNATOR ;; interpreted as a file +DIRECTORY-PATHNAME-DESIGNATOR := PATHNAME-DESIGNATOR ;; interpreted as a directory name + +PATHNAME-DESIGNATOR := + NULL | ;; Special: skip this entry. + ABSOLUTE-COMPONENT-DESIGNATOR | + (ABSOLUTE-COMPONENT-DESIGNATOR RELATIVE-COMPONENT-DESIGNATOR ...) + +ABSOLUTE-COMPONENT-DESIGNATOR := + STRING | ;; namestring (better be absolute or bust, directory assumed where applicable) + PATHNAME | ;; pathname (better be an absolute path, or bust) + :HOME | ;; designates the user-homedir-pathname ~/ + :USER-CACHE | ;; designates the default location for the user cache + :SYSTEM-CACHE ;; designates the default location for the system cache + +RELATIVE-COMPONENT-DESIGNATOR := + STRING | ;; namestring (directory assumed where applicable) + PATHNAME | ;; pathname + :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-1.0.32.30-linux-x86-64 + :IMPLEMENTATION-TYPE | ;; a directory based on lisp-implementation-type only, e.g. sbcl + :UID | ;; current UID -- not available on Windows + :USER ;; current USER name -- NOT IMPLEMENTED(!) + PATTERN := a string without wildcards, that will be matched exactly against the name of a any subdirectory in the directory component of a path. e.g. @code{"_darcs"} will match @file{#p"/foo/bar/_darcs/src/bar.asd"} @@ -1762,7 +1785,7 @@ which is the default place ASDF looks for this configuration, once contained: @example (:source-registry - (:tree "/home/fare/cl/") + (:tree (:home "cl")) ;; will expand to e.g. "/home/joeluser/cl/" :inherit-configuration) @end example diff --git a/test/asdf-pathname-test.script b/test/asdf-pathname-test.script index b6a5a2ef6708e13c79da2679cc77abadefa1cebc..77bf9ad3b822823011d5b123549678dea344284f 100644 --- a/test/asdf-pathname-test.script +++ b/test/asdf-pathname-test.script @@ -278,6 +278,15 @@ (asdf:initialize-output-translations) (format t "output translations: ~S~%" (asdf::output-translations)) + #-(or clisp ecl) ; clisp has problem with the first one having :version :newest + (progn ; 1- we're testing with unix, are we not? + (assert (equal (asdf::resolve-location '(:home)) (truename (user-homedir-pathname)))) + (assert (equal (asdf::resolve-location '("/foo" "bar" "baz")) #p"/foo/bar/baz")) + (assert (equal (asdf::resolve-location '("/foo" "bar" "baz") :directory t) #p"/foo/bar/baz/")) + (assert (equal (asdf::resolve-location '("/foo" "bar" "baz") :directory t :wilden t) (asdf::wilden #p"/foo/bar/baz/"))) + (assert (equal (asdf::resolve-location '("/foo" "bar" "baz") :directory nil :wilden t) (asdf::wilden #p"/foo/bar/"))) + (assert (equal (asdf::resolve-location '("/foo" "bar" #p"**/" "baz" #p"*.*") :directory nil :wilden t) #p"/foo/bar/**/baz/*.*"))) + (or (test-component-pathnames :delete-host t :support-string-pathnames nil) (leave-lisp "test failed" 1))) diff --git a/test/compile-asdf.lisp b/test/compile-asdf.lisp index f379dece5c8beafe9670fef320dbf6a53eb8869f..d753dda5c98a0be67ec0268cbb1534e9d6e2980e 100644 --- a/test/compile-asdf.lisp +++ b/test/compile-asdf.lisp @@ -21,6 +21,7 @@ (compile-file *asdf-lisp* :output-file tmp :print t :verbose t)) (declare (ignore result)) (cond + #-ecl ; 10.7.1 has spurious warnings. Sigh. (warnings-p (leave-lisp "Testsuite failed: ASDF compiled with warnings" 1)) (errors-p diff --git a/test/sources/level1/file1.lisp b/test/sources/level1/file1.lisp index 336ddb98d9b5702485292ce77947441f444f86e1..5e0d8a74b5f8b40a535500281a1b79cbd792a2ed 100644 --- a/test/sources/level1/file1.lisp +++ b/test/sources/level1/file1.lisp @@ -2,3 +2,7 @@ (in-package :test-package) (defvar *file-tmp* t) +(eval-when (:compile-toplevel :execute) + (format t "compiling level1/file1~%")) +(eval-when (:load-toplevel :execute) + (format t "loading level1/file1~%")) diff --git a/test/test-module-pathnames.asd b/test/test-module-pathnames.asd index c154c81b5a252ef04face5f33f5ab046d9808950..e4748620cdbe0f43b1e472139c1cfa6e10811f15 100644 --- a/test/test-module-pathnames.asd +++ b/test/test-module-pathnames.asd @@ -1,12 +1,11 @@ ;;; -*- Lisp -*- -(asdf:defsystem test-module-pathnames +(defsystem :test-module-pathnames :components ((:module "sources/level1" :serial t - :components - ((:file "file1") - (:file "level2/file2") - (:static-file "level2/static.file") - (:static-file "test-tmp.cl"))))) - + :components + ((:file "file1") + (:file "level2/file2") + (:static-file "level2/static.file") + (:static-file "test-tmp.cl"))))) diff --git a/test/test-module-pathnames.script b/test/test-module-pathnames.script index fee40aa9257afa82e383fdcb8c6f811d36c971ec..44ccabeb13ae5116a82dc12881583b281939e052 100644 --- a/test/test-module-pathnames.script +++ b/test/test-module-pathnames.script @@ -4,6 +4,7 @@ (quit-on-error (setf asdf:*central-registry* '(*default-pathname-defaults*)) + (trace asdf:perform) (asdf:load-system 'test-module-pathnames) (flet ((submodule (module name) (find name (asdf:module-components module) @@ -17,19 +18,17 @@ (assert (member (pathname-foo (asdf:component-relative-pathname test-tmp)) '(((:relative) "test-tmp" "cl") (nil "test-tmp" "cl")) :test 'equal) - nil - "Didn't get the name of test-tmp.cl right") + () "Didn't get the name of test-tmp.cl right") (assert (equal (pathname-foo (asdf:component-relative-pathname static)) '((:relative "level2") "static" "file")) - nil - "Didn't get the name of static.file right"))) - (assert (find-package :test-package) nil - "package test-package not found") - (assert (find-symbol (symbol-name '*file-tmp*) :test-package) nil - "symbol `*file-tmp*` not found") + () "Didn't get the name of static.file right"))) + (assert (find-package :test-package) + () "package test-package not found") + (assert (find-symbol (symbol-name '*file-tmp*) :test-package) + () "symbol `*file-tmp*` not found") (assert (symbol-value (find-symbol (symbol-name '*file-tmp*) :test-package)) - nil "symbol `*file-tmp*` has wrong value") + () "symbol `*file-tmp*` has wrong value") #| ; must be adapted to ABL (assert (probe-file (merge-pathnames diff --git a/test/test-tmp.cl b/test/test-tmp.cl index 0a21fc2e1d5c43148d8aa27720ece8467e1a6c9d..7e8dd8594e9a76189926b11d1fd2641ee0744aa9 100644 --- a/test/test-tmp.cl +++ b/test/test-tmp.cl @@ -1,3 +1,10 @@ ;; part of the test-module-pathnames test (in-package #:test-package) + +(defparameter *test-tmp-cl* t) + +(eval-when (:compile-toplevel :execute) + (format t "compiling test-tmp.cl~%")) +(eval-when (:load-toplevel :execute) + (format t "loading test-tmp.cl~%"))