diff --git a/asdf.asd b/asdf.asd index bea38902dfee590a9e9f2c078c6d89e8fcfb1cf7..d48e73ad5660872bd9955a5d7f8a25178944d49a 100644 --- a/asdf.asd +++ b/asdf.asd @@ -15,7 +15,7 @@ :licence "MIT" :description "Another System Definition Facility" :long-description "ASDF builds Common Lisp software organized into defined systems." - :version "2.26.119" ;; to be automatically updated by bin/bump-revision + :version "2.26.120" ;; to be automatically updated by bin/bump-revision :depends-on () :components ((:module "build" :components ((:file "asdf")))) :in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op generate-asdf)))) diff --git a/bundle.lisp b/bundle.lisp index 5fee75c1bc1eb8a8225479c5c6d0feccc4deb595..e4c0ae733126ee13730838a3bb809b97b577a2a5 100644 --- a/bundle.lisp +++ b/bundle.lisp @@ -16,7 +16,7 @@ #:operation-monolithic-p #:user-system-p #:user-system #:trivial-system-p #:gather-actions #:operated-components - #+ecl #:make-build #+mkcl #:bundle-system + #+ecl #:make-build #:register-pre-built-system #:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library #:component-translate-output-p #:translate-output-p diff --git a/defsystem.lisp b/defsystem.lisp index 630b496510893c9df9baf181d3f842dd909cc693..4064947b7e19e381c38d586bf942a15c1646ce7a 100644 --- a/defsystem.lisp +++ b/defsystem.lisp @@ -32,16 +32,9 @@ ;; and may be from within the EVAL-WHEN of a file compilation. ;; If no absolute pathname was found, we return NIL. (check-type pathname (or null string pathname)) - (or (and (absolute-pathname-p pathname) (resolve-symlinks* pathname)) - (let* ((load-pathname (load-pathname)) - (load-absolute - (or (absolute-pathname-p load-pathname) - (let ((defaults (resolve-symlinks* *default-pathname-defaults*))) - (and (absolute-pathname-p defaults) - (merge-pathnames* load-pathname defaults)))))) - (when (absolute-pathname-p load-absolute) - (resolve-symlinks* - (subpathname load-absolute pathname :type :directory)))))) + (absolutize-pathnames + (list pathname (load-pathname) *default-pathname-defaults* (getcwd)) + :resolve-symlinks *resolve-symlinks*)) ;;; Component class diff --git a/find-system.lisp b/find-system.lisp index 4e38e37894f7c338ab2aeff53740f4b68f0883a7..7bb7728c63a23ac0e53320bd8bc1df68e55735eb 100644 --- a/find-system.lisp +++ b/find-system.lisp @@ -155,7 +155,12 @@ Going forward, we recommend new users should be using the source-registry. (defun* probe-asd (name defaults &key truename) (block nil (when (directory-pathname-p defaults) - (let* ((file (probe-file* (subpathname defaults name :type "asd") :truename truename))) + (let* ((file (probe-file* + (absolutize-pathnames + (list (make-pathname :name name :type "asd") + defaults *default-pathname-defaults* (getcwd)) + :resolve-symlinks truename) + :truename truename))) (when file (return file))) #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!) @@ -177,11 +182,10 @@ Going forward, we recommend new users should be using the source-registry. (block nil (unwind-protect (dolist (dir *central-registry*) - (let ((defaults (resolve-symlinks* (eval dir))) - directorized truenamized) + (let ((defaults (eval dir)) + directorized) (when defaults - (cond ((and (directory-pathname-p defaults) - (absolute-pathname-p defaults)) + (cond ((directory-pathname-p defaults) (let* ((file (probe-asd name defaults :truename *resolve-symlinks*))) (when file (return file)))) @@ -196,13 +200,6 @@ Going forward, we recommend new users should be using the source-registry. (remove-entry-from-registry () :report "Remove entry from *central-registry* and continue" (push dir to-remove)) - (coerce-to-truename () - :test (lambda (c) (declare (ignore c)) - (setf truenamized (truename* defaults))) - :report (lambda (s) - (format s (compatfmt "~@<Coerce entry to truename ~S and continue.~@:>") - truenamized)) - (push dir to-remove)) (coerce-entry-to-directory () :test (lambda (c) (declare (ignore c)) (and (not (directory-pathname-p defaults)) @@ -305,14 +302,18 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (multiple-value-bind (foundp found-system pathname previous previous-time) (locate-system name) (assert (eq foundp (and (or found-system pathname previous) t))) - (when (and found-system (not previous)) - (register-system found-system)) - (when (and pathname - (not (and previous - (pathname-equal pathname (system-source-file previous)) - (stamp<= (safe-file-write-date pathname) previous-time)))) - ;; only load when it's a pathname that is different or has newer content - (load-sysdef name pathname)) + (let ((previous-pathname (and previous (system-source-file previous))) + (system (or previous found-system))) + (when (and found-system (not previous)) + (register-system found-system)) + (when (and system pathname) + (setf (system-source-file system) pathname)) + (when (and pathname + (not (and previous + (pathname-equal pathname previous-pathname) + (stamp<= (safe-file-write-date pathname) previous-time)))) + ;; only load when it's a pathname that is different or has newer content + (load-sysdef name pathname))) (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed (return (cond diff --git a/header.lisp b/header.lisp index 1d83da9f3615b6fc28a4d5821fec738764899129..9072107259420998a3c755c6883dbf7b5ae0020d 100644 --- a/header.lisp +++ b/header.lisp @@ -1,5 +1,5 @@ ;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*- -;;; This is ASDF 2.26.119: Another System Definition Facility. +;;; This is ASDF 2.26.120: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel@common-lisp.net>. diff --git a/pathname.lisp b/pathname.lisp index a20285650cff812af0c03bbdbcbafbe1e579b155..7fa73390d38ab46cce72898213f637223b47a28e 100644 --- a/pathname.lisp +++ b/pathname.lisp @@ -54,6 +54,7 @@ #:parse-file-location-info #:parse-windows-shortcut ;; Checking constraints #:ensure-pathname + #:absolutize-pathnames ;; Output translations #:*output-translation-function*)) @@ -165,21 +166,21 @@ and make a new pathname with corresponding components and specified logical HOST (when (stringp p1) (setf p1 (pathname p1))) (when (stringp p2) (setf p2 (pathname p2))) (flet ((normalize-component (x) - (and (not (member x '(nil :unspecific :newest (:relative)) :test 'equal)) x))) + (unless (member x '(nil :unspecific :newest (:relative)) :test 'equal) + x))) (macrolet ((=? (&rest accessors) (flet ((frob (x) (reduce 'list (cons 'normalize-component accessors) :initial-value x :from-end t))) `(equal ,(frob 'p1) ,(frob 'p2))))) - (or (and (null p1) (null 2)) + (or (and (null p1) (null p2)) (and (pathnamep p1) (pathnamep p2) - (or (equal p1 p2) - (=? pathname-host) - (=? pathname-device) - (=? normalize-pathname-directory-component pathname-directory) - (=? pathname-name) - (=? pathname-type) - (=? pathname-version))))))) + (and (=? pathname-host) + (=? pathname-device) + (=? normalize-pathname-directory-component pathname-directory) + (=? pathname-name) + (=? pathname-type) + (=? pathname-version))))))) (defun* logical-pathname-p (x) (typep x 'logical-pathname)) @@ -401,7 +402,7 @@ or the original (parsed) pathname if it is false (the default)." ;; and we can survive and we will continue the planning ;; as if the file were very old. ;; (or should we treat the case in a different, special way?) - (and pathname (probe-file* pathname) (ignore-errors (file-write-date pathname)))) + (and (probe-file* pathname) (ignore-errors (file-write-date pathname)))) (defun* directory* (pathname-spec &rest keys &key &allow-other-keys) (apply 'directory pathname-spec @@ -413,7 +414,7 @@ or the original (parsed) pathname if it is false (the default)." '(:resolve-symlinks nil)))))) (defun* filter-logical-directory-results (directory entries merger) - (if (typep directory 'logical-pathname) + (if (logical-pathname-p directory) ;; Try hard to not resolve logical-pathname into physical pathnames; ;; otherwise logical-pathname users/lovers will be disappointed. ;; If directory* could use some implementation-dependent magic, @@ -421,7 +422,7 @@ or the original (parsed) pathname if it is false (the default)." ;; we only keep pathnames for which specifying the name and ;; translating the LPN commute. (loop :for f :in entries - :for p = (or (and (typep f 'logical-pathname) f) + :for p = (or (and (logical-pathname-p f) f) (let* ((u (ignore-errors (funcall merger f)))) ;; The first u avoids a cumbersome (truename u) error. ;; At this point f should already be a truename, @@ -432,7 +433,7 @@ or the original (parsed) pathname if it is false (the default)." (defun* directory-files (directory &optional (pattern *wild-file*)) (let ((dir (pathname directory))) - (when (typep dir 'logical-pathname) + (when (logical-pathname-p dir) ;; Because of the filtering we do below, ;; logical pathnames have restrictions on wild patterns. ;; Not that the results are very portable when you use these patterns on physical pathnames. @@ -688,14 +689,6 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME." (and pathname (subpathname (ensure-directory-pathname pathname) subpath :type type))) -(defun* subpathp (maybe-subpath base-pathname) - (and (pathnamep maybe-subpath) (pathnamep base-pathname) - (absolute-pathname-p maybe-subpath) (absolute-pathname-p base-pathname) - (directory-pathname-p base-pathname) (not (wild-pathname-p base-pathname)) - (with-pathname-defaults () - (let ((enough (enough-namestring maybe-subpath base-pathname))) - (and (relative-pathname-p enough) (pathname enough)))))) - ;;; Pathname host and its root (defun* pathname-root (pathname) (make-pathname* :directory '(:absolute) @@ -758,6 +751,15 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME." :defaults pathname))) pathname))) +(defun* subpathp (maybe-subpath base-pathname) + (and (pathnamep maybe-subpath) (pathnamep base-pathname) + (absolute-pathname-p maybe-subpath) (absolute-pathname-p base-pathname) + (directory-pathname-p base-pathname) (not (wild-pathname-p base-pathname)) + (pathname-equal (pathname-root maybe-subpath) (pathname-root base-pathname)) + (with-pathname-defaults () + (let ((enough (enough-namestring maybe-subpath base-pathname))) + (and (relative-pathname-p enough) (pathname enough)))))) + ;;; Resolving symlinks somewhat (defun* truenamize (pathname &optional (defaults *default-pathname-defaults*)) @@ -765,15 +767,15 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME." (block nil (when (typep pathname '(or null logical-pathname)) (return pathname)) (let ((p (merge-pathnames* pathname defaults))) - (when (typep p 'logical-pathname) (return p)) - (let ((found (probe-file* p))) + (when (logical-pathname-p p) (return p)) + (let ((found (probe-file* p :truename t))) (when found (return found))) (unless (absolute-pathname-p p) (let ((true-defaults (truename* defaults))) (when true-defaults (setf p (merge-pathnames pathname true-defaults))))) (unless (absolute-pathname-p p) (return p)) - (let ((sofar (probe-file* (pathname-root p)))) + (let ((sofar (probe-file* (pathname-root p) :truename t))) (unless sofar (return p)) (flet ((solution (directories) (merge-pathnames* @@ -790,7 +792,7 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME." :for more = (probe-file* (merge-pathnames* (make-pathname* :directory `(:relative ,dir)) - sofar)) :do + sofar) :truename t) :do (if more (setf sofar more) (return (solution rest))) @@ -811,14 +813,18 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME." ;;; absolute vs relative -(defun* ensure-pathname-absolute (path &optional defaults) +(defun* ensure-pathname-absolute (path &optional defaults (on-error 'error)) (cond - ((absolute-pathname-p path) path) + ((absolute-pathname-p path)) ((stringp path) (ensure-pathname-absolute (pathname path) defaults)) - ((not (pathnamep path)) (error "not a valid pathname designator ~S" path)) - ((absolute-pathname-p defaults) (merge-pathnames* path defaults)) - (t (error "Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S" - path defaults)))) + ((not (pathnamep path)) (call-function on-error "not a valid pathname designator ~S" path)) + ((absolute-pathname-p defaults) + (or (absolute-pathname-p (merge-pathnames* path defaults)) + (call-function on-error "Failed to merge ~S with ~S into an absolute pathname" + path defaults))) + (t (call-function on-error + "Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S" + path defaults)))) (defun relativize-directory-component (directory-component) (let ((directory (normalize-pathname-directory-component directory-component))) @@ -850,7 +856,7 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME." #+clozure :if-exists #+clozure :rename-and-delete)) (defun* delete-file-if-exists (x) - (when (and x (probe-file* x)) + (when (probe-file* x) (delete-file x))) ;;; Translate a pathname @@ -891,8 +897,7 @@ For the latter case, we ought pick random suffix and atomically open it." (multiple-value-prog1 (funcall fun staging) (rename-file-overwriting-target staging pathname)) - (when (probe-file* staging) - (delete-file staging))))) + (delete-file-if-exists staging)))) (defmacro with-staging-pathname ((pathname-var &optional (pathname-value pathname-var)) &body body) `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body))) @@ -910,7 +915,7 @@ For the latter case, we ought pick random suffix and atomically open it." ((:host) (pathname-host-pathname x)) ((nil) (nil-pathname x)))) (when want-existing ;; CCL's probe-file will choke if d-p-d is logical - (setf x (and (probe-file* x) x))) + (setf x (probe-file* x))) (and (physical-pathname-p x) x)))) (or (sanitize defaults) (when fallback @@ -1123,5 +1128,30 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." p)))) +(defun absolutize-pathnames + (pathnames &key type (resolve-symlinks *resolve-symlinks*) truename) + "Given a list of PATHNAMES where each is in the context of the next ones, +try to resolve these pathnames into an absolute pathname; first gently, then harder." + (block nil + (labels ((resolve (x) + (or (when truename + (absolute-pathname-p (truename* x))) + (when resolve-symlinks + (absolute-pathname-p (resolve-symlinks x))) + (absolute-pathname-p x) + (unless resolve-symlinks + (absolute-pathname-p (resolve-symlinks x))) + (unless truename + (absolute-pathname-p (truename* x))) + (return nil))) + (tryone (x type rest) + (resolve (or (absolute-pathname-p x) + (subpathname (recurse rest :directory) x :type type)))) + (recurse (pathnames type) + (if (null pathnames) (return nil) + (tryone (first pathnames) type (rest pathnames))))) + (recurse pathnames type)))) + + ;;; Hook for output translations (defvar *output-translation-function* 'identity) diff --git a/system.lisp b/system.lisp index 14135d626be6aa9031180891c2fc9aad4a495ea6..400b70b278b9f785a3250b7c6f3cdcd8c9fc8147 100644 --- a/system.lisp +++ b/system.lisp @@ -65,7 +65,6 @@ in which the system specification (.asd file) is located." (defun* system-relative-pathname (system name &key type) (subpathname (system-source-directory system) name :type type)) - ;;;; Beware of builtin systems (defgeneric* builtin-system-p (system)) (defmethod builtin-system-p ((s system)) diff --git a/test/script-support.lisp b/test/script-support.lisp index 32db7b1a07279d67cbc9daf9b55f9a4e535ee6ac..2bd21538493e3f54b6e0da8daf9c4e15309aeb3c 100644 --- a/test/script-support.lisp +++ b/test/script-support.lisp @@ -36,6 +36,7 @@ Some constraints: `(;; If you want to trace some stuff while debugging ASDF, ;; here's a nice place to say what. ;; These string designators will be interned in ASDF after it is loaded. + :absolutize-pathnames )) (defvar *debug-asdf* nil) diff --git a/test/test-bundle.script b/test/test-bundle.script index 4622a5bbb6a44ef06aa514f41e5c39ba43100aec..db0d352a89bb755c657c0e46abef91d5e044b446 100644 --- a/test/test-bundle.script +++ b/test/test-bundle.script @@ -22,12 +22,14 @@ (bundle-1 (asdf:output-file op (find-system :test-bundle-1))) (bundle-2 (asdf:output-file op (find-system :test-bundle-2)))) (DBG :test-bundle bundle-1 bundle-2) + (assert-equal (list bundle-2) + (input-files (make-operation 'load-fasl-op) (find-system :test-bundle-2))) (delete-file-if-exists bundle-1) (delete-file-if-exists bundle-2) (operate 'load-fasl-op :test-bundle-2) ;; Check that the bundles were indeed created. - (assert (probe-file bundle-1)) (assert (probe-file bundle-2)) + (assert (probe-file bundle-1)) ;; Check that the files were indeed loaded. (assert (symbol-value (find-symbol* :*file1* :test-package))) (assert (symbol-value (find-symbol* :*file3* :test-package))))) diff --git a/upgrade.lisp b/upgrade.lisp index 4a5ebdf110411222e13a5db7a6235defc7828579..c6a41e0ad392258d6ca37fe572960c67d1f60576 100644 --- a/upgrade.lisp +++ b/upgrade.lisp @@ -45,7 +45,7 @@ ;; "2.345.6" would be a development version in the official upstream ;; "2.345.0.7" would be your seventh local modification of official release 2.345 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 - (asdf-version "2.26.119") + (asdf-version "2.26.120") (existing-asdf (find-class (find-symbol* :component :asdf nil) nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) diff --git a/version.lisp-expr b/version.lisp-expr index 35cc57af53f848b7750f6854c2f91e5467992741..a14d62c5856db1161c0594b9e8d4666ea6a118c3 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -1 +1 @@ -"2.26.119" +"2.26.120"