Commit fb3d1204 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

2.26.120: vanquishing the dragon of CL pathnames so you don't have to.

(equal #p"ccl:" #p"/") ==> T. Yikes.
parent 072692f1
......@@ -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))))
......
......@@ -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
......
......@@ -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
......
......@@ -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)))
(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 (system-source-file 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))
(load-sysdef name pathname)))
(let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed
(return
(cond
......
;; -*- 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>.
......
......@@ -54,6 +54,7 @@
#:parse-file-location-info #:parse-windows-shortcut
;; Checking constraints
#:ensure-pathname
#:absolutize-pathnames
;; Output translations
#:*output-translation-function*))
......@@ -165,16 +166,16 @@ 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)
(and (=? pathname-host)
(=? pathname-device)
(=? normalize-pathname-directory-component pathname-directory)
(=? pathname-name)
......@@ -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,13 +813,17 @@ 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"
((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)
......@@ -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)
......@@ -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))
......
......@@ -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)
......
......@@ -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)))))
......@@ -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)))
......
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