Commit 98127ec8 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

2.26.107: make logical pathnames work. Gah.

parent 139af5a4
...@@ -15,7 +15,7 @@ ...@@ -15,7 +15,7 @@
:licence "MIT" :licence "MIT"
:description "Another System Definition Facility" :description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems." :long-description "ASDF builds Common Lisp software organized into defined systems."
:version "2.26.106" ;; to be automatically updated by bin/bump-revision :version "2.26.107" ;; to be automatically updated by bin/bump-revision
:depends-on () :depends-on ()
:components ((:module "build" :components ((:file "asdf")))) :components ((:module "build" :components ((:file "asdf"))))
:in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op generate-asdf)))) :in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op generate-asdf))))
......
...@@ -30,7 +30,7 @@ ...@@ -30,7 +30,7 @@
;; and merged into that DIRECTORY as per SUBPATHNAME. ;; and merged into that DIRECTORY as per SUBPATHNAME.
;; If no absolute pathname was found, we return NIL. ;; If no absolute pathname was found, we return NIL.
(check-type pathname (or null string pathname)) (check-type pathname (or null string pathname))
(or (and (pathnamep pathname) (absolute-pathname-p pathname)) (or (and (pathnamep pathname) (absolute-pathname-p pathname) (resolve-symlinks* pathname))
(let* ((lisp-file-pathname (resolve-symlinks* (current-lisp-file-pathname)))) (let* ((lisp-file-pathname (resolve-symlinks* (current-lisp-file-pathname))))
(when (absolute-pathname-p lisp-file-pathname) (when (absolute-pathname-p lisp-file-pathname)
(subpathname lisp-file-pathname pathname :type :directory))))) (subpathname lisp-file-pathname pathname :type :directory)))))
...@@ -169,7 +169,7 @@ ...@@ -169,7 +169,7 @@
;; we also need to remember it in a special variable *systems-being-defined*. ;; we also need to remember it in a special variable *systems-being-defined*.
(with-system-definitions () (with-system-definitions ()
(let* ((name (coerce-name name)) (let* ((name (coerce-name name))
(source-file (if sfp source-file (current-lisp-file-pathname))) (source-file (if sfp source-file (resolve-symlinks* (current-lisp-file-pathname))))
(registered (system-registered-p name)) (registered (system-registered-p name))
(registered! (if registered (registered! (if registered
(rplaca registered (safe-file-write-date source-file)) (rplaca registered (safe-file-write-date source-file))
......
...@@ -133,9 +133,10 @@ called with an object of type asdf:system." ...@@ -133,9 +133,10 @@ called with an object of type asdf:system."
(cleanup-system-definition-search-functions) (cleanup-system-definition-search-functions)
(defun* search-for-system-definition (system) (defun* search-for-system-definition (system)
(some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name))) (with-pathname-defaults ()
(cons 'find-system-if-being-defined (some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name)))
*system-definition-search-functions*))) (cons 'find-system-if-being-defined
*system-definition-search-functions*))))
(defvar *central-registry* nil (defvar *central-registry* nil
"A list of 'system directory designators' ASDF uses to find systems. "A list of 'system directory designators' ASDF uses to find systems.
...@@ -155,14 +156,14 @@ Going forward, we recommend new users should be using the source-registry. ...@@ -155,14 +156,14 @@ Going forward, we recommend new users should be using the source-registry.
(defun* probe-asd (name defaults) (defun* probe-asd (name defaults)
(block nil (block nil
(when (directory-pathname-p defaults) (when (directory-pathname-p defaults)
(let* ((file (probe-file* (subpathname defaults (strcat name ".asd"))))) (let* ((file (probe-file* (subpathname defaults name :type "asd"))))
(when file (when file
(return file))) (return file)))
#-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!) #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!)
(when (os-windows-p) (when (os-windows-p)
(let ((shortcut (let ((shortcut
(make-pathname (make-pathname
:defaults defaults :version :newest :case :local :defaults defaults :case :local
:name (strcat name ".asd") :name (strcat name ".asd")
:type "lnk"))) :type "lnk")))
(when (probe-file* shortcut) (when (probe-file* shortcut)
...@@ -279,16 +280,13 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. ...@@ -279,16 +280,13 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(pathname (or (and (typep found '(or pathname string)) (pathname found)) (pathname (or (and (typep found '(or pathname string)) (pathname found))
(and found-system (system-source-file found-system)) (and found-system (system-source-file found-system))
(and previous (system-source-file previous)))) (and previous (system-source-file previous))))
(pathname (ensure-pathname (resolve-symlinks* pathname) :want-absolute t))
(foundp (and (or found-system pathname previous) t))) (foundp (and (or found-system pathname previous) t)))
(check-type found (or null pathname system)) (check-type found (or null pathname system))
(when foundp (when foundp
(setf pathname (resolve-symlinks* pathname)) (when (and pathname found-system)
(when (and pathname (not (absolute-pathname-p pathname))) (setf (system-source-file found-system) pathname))
(setf pathname (ensure-pathname-absolute pathname)) (when (and previous (not (pathname-equal (system-source-file previous) pathname)))
(when found-system
(setf (system-source-file found-system) pathname)))
(when (and previous (not (#-cormanlisp equal #+cormanlisp equalp
(system-source-file previous) pathname)))
(setf (system-source-file previous) pathname) (setf (system-source-file previous) pathname)
(setf previous-time nil)) (setf previous-time nil))
(values foundp found-system pathname previous previous-time)))) (values foundp found-system pathname previous previous-time))))
...@@ -302,9 +300,11 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. ...@@ -302,9 +300,11 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(declare (ignore foundp)) (declare (ignore foundp))
(when (and found-system (not previous)) (when (and found-system (not previous))
(register-system found-system)) (register-system found-system))
(unless (and (equal pathname (and previous (system-source-file previous))) (when (and pathname
(stamp<= (safe-file-write-date pathname) previous-time)) (not (and previous
;; only load when it's a different pathname, or newer file content (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)) (load-sysdef name pathname))
(let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed
(return (return
......
;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*- ;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
;;; This is ASDF 2.26.106: Another System Definition Facility. ;;; This is ASDF 2.26.107: Another System Definition Facility.
;;; ;;;
;;; Feedback, bug reports, and patches are all welcome: ;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>. ;;; please mail to <asdf-devel@common-lisp.net>.
......
...@@ -9,6 +9,7 @@ ...@@ -9,6 +9,7 @@
#:*resolve-symlinks* #:*resolve-symlinks*
;; Making and merging pathnames, portably ;; Making and merging pathnames, portably
#:normalize-pathname-directory-component #:denormalize-pathname-directory-component #:normalize-pathname-directory-component #:denormalize-pathname-directory-component
#:pathname-equal
#:merge-pathname-directory-components #:make-pathname* #:*unspecific-pathname-type* #:merge-pathname-directory-components #:make-pathname* #:*unspecific-pathname-type*
#:make-pathname-component-logical #:make-pathname-logical #:make-pathname-component-logical #:make-pathname-logical
#:merge-pathnames* #:merge-pathnames*
...@@ -200,6 +201,27 @@ by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL." ...@@ -200,6 +201,27 @@ by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL."
;;; Some pathname predicates ;;; Some pathname predicates
(defun* pathname-equal (p1 p2)
(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)))
(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))
(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)))))))
(defun* absolute-pathname-p (pathspec) (defun* absolute-pathname-p (pathspec)
"If PATHSPEC is a pathname or namestring object that parses as a pathname "If PATHSPEC is a pathname or namestring object that parses as a pathname
possessing an :ABSOLUTE directory component, return the (parsed) pathname. possessing an :ABSOLUTE directory component, return the (parsed) pathname.
...@@ -853,8 +875,11 @@ For the latter case, we ought pick random suffix and atomically open it." ...@@ -853,8 +875,11 @@ For the latter case, we ought pick random suffix and atomically open it."
`(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body))) `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body)))
;;; Basic pathnames ;;; Basic pathnames
(defun* logical-pathname-p (x)
(typep x 'logical-pathname))
(defun* physical-pathname-p (x) (defun* physical-pathname-p (x)
(and (pathnamep x) (not (typep x 'logical-pathname)))) (and (pathnamep x) (not (logical-pathname-p x))))
(defun* sane-physical-pathname (&key defaults (keep t) fallback want-existing) (defun* sane-physical-pathname (&key defaults (keep t) fallback want-existing)
(flet ((sanitize (x) (flet ((sanitize (x)
...@@ -1049,7 +1074,7 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." ...@@ -1049,7 +1074,7 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
:ensure-directory ensure-directory :want-relative want-relative)))) :ensure-directory ensure-directory :want-relative want-relative))))
(check want-pathname (pathnamep p) "Expected a pathname, not NIL") (check want-pathname (pathnamep p) "Expected a pathname, not NIL")
(unless pathname (return NIL)) (unless pathname (return NIL))
(check want-logical (typep p 'logical-pathname) "Expected a logical pathname") (check want-logical (logical-pathname-p p) "Expected a logical pathname")
(check want-physical (physical-pathname-p p) "Expected a physical pathname") (check want-physical (physical-pathname-p p) "Expected a physical pathname")
(transform ensure-physical () (translate-logical-pathname p)) (transform ensure-physical () (translate-logical-pathname p))
(check ensure-physical (physical-pathname-p p) "Could not translate to a physical pathname") (check ensure-physical (physical-pathname-p p) "Could not translate to a physical pathname")
......
...@@ -51,7 +51,7 @@ system names to pathnames of .asd files") ...@@ -51,7 +51,7 @@ system names to pathnames of .asd files")
(register-clear-configuration-hook 'clear-source-registry) (register-clear-configuration-hook 'clear-source-registry)
(defparameter *wild-asd* (defparameter *wild-asd*
(make-pathname* :directory nil :name *wild* :type "asd" :version :newest)) (make-pathname* :directory nil :name *wild* :type "asd"))
(defun* directory-asd-files (directory) (defun* directory-asd-files (directory)
(directory-files directory *wild-asd*)) (directory-files directory *wild-asd*))
......
...@@ -50,6 +50,9 @@ ...@@ -50,6 +50,9 @@
;; and it tries to load ASDF from a logical-pathname. ;; and it tries to load ASDF from a logical-pathname.
'(:source-registry (:tree #p"ASDF:test;") '(:source-registry (:tree #p"ASDF:test;")
:ignore-inherited-configuration)) :ignore-inherited-configuration))
(load-system :test-logical-pathname :force t)) (load-system :test-logical-pathname :force t)
(let ((sys (find-system :test-logical-pathname)))
(assert (logical-pathname-p (component-pathname sys)))
(assert (logical-pathname-p (system-source-file sys)))))
(DBG "Done")) (DBG "Done"))
...@@ -45,7 +45,7 @@ ...@@ -45,7 +45,7 @@
;; "2.345.6" would be a development version in the official upstream ;; "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.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 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
(asdf-version "2.26.106") (asdf-version "2.26.107")
(existing-asdf (find-class (find-symbol* :component :asdf nil) nil)) (existing-asdf (find-class (find-symbol* :component :asdf nil) nil))
(existing-version *asdf-version*) (existing-version *asdf-version*)
(already-there (equal asdf-version existing-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