Commit 0796586f authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Move flag for asdf upgrade from operate to session.

This should notably prevent recording of a circular dependency of asdf on asdf.
parent 6688d26b
......@@ -8,8 +8,7 @@
:asdf/find-component :asdf/system-registry :asdf/plan :asdf/operate)
(:export
#:find-system #:locate-system #:load-asd #:define-op
#:load-system-definition-error #:error-name #:error-pathname #:error-condition
))
#:load-system-definition-error #:error-name #:error-pathname #:error-condition))
(in-package :asdf/find-system)
(with-upgradability ()
......
......@@ -44,9 +44,6 @@ But do NOT depend on it, for this is deprecated behavior."))
(define-convenience-action-methods operate (operation component &key)
:if-no-component (error 'missing-component :requires component))
(defvar *in-operate* nil
"Are we in operate?")
;; This method ensures that an ASDF upgrade is attempted as the very first thing,
;; with suitable state preservation in case in case it actually happens,
;; and that a few suitable dynamic bindings are established.
......@@ -56,9 +53,7 @@ But do NOT depend on it, for this is deprecated behavior."))
(on-failure *compile-file-failure-behaviour*) &allow-other-keys)
(nest
(with-asdf-session ())
(let ((in-operate *in-operate*)
(*in-operate* t)
(operation-remaker ;; how to remake the operation after ASDF was upgraded (if it was)
(let ((operation-remaker ;; how to remake the operation after ASDF was upgraded (if it was)
(etypecase operation
(operation (let ((name (type-of operation)))
#'(lambda () (make-operation name))))
......@@ -69,12 +64,14 @@ But do NOT depend on it, for this is deprecated behavior."))
;; Before we operate on any system, make sure ASDF is up-to-date,
;; for if an upgrade is ever attempted at any later time, there may be BIG trouble.
(progn
(unless in-operate
(unless (asdf-upgraded-p (toplevel-asdf-session))
(setf (asdf-upgraded-p (toplevel-asdf-session)) t)
(when (upgrade-asdf)
;; If we were upgraded, restart OPERATE the hardest of ways, for
;; its function may have been redefined.
(return-from operate
(apply 'operate (funcall operation-remaker) component-path keys)))))
(with-asdf-session (:override t)
(apply 'operate (funcall operation-remaker) component-path keys))))))
;; Setup proper bindings around any operate call.
(let* ((*verbose-out* (and verbose *standard-output*))
(*compile-file-warnings-behaviour* on-warnings)
......
......@@ -530,12 +530,10 @@ initialized with SEED."
(defun* (required-components) (system &rest keys &key (goal-operation 'load-op) &allow-other-keys)
"Given a SYSTEM and a GOAL-OPERATION (default LOAD-OP), traverse the dependencies and
return a list of the components involved in building the desired action."
(let ((cache (and *asdf-session* (session-cache *asdf-session*))))
(with-asdf-session (:override t)
(when cache (setf (session-cache *asdf-session*) cache))
(remove-duplicates
(mapcar 'action-component
(apply 'collect-dependencies goal-operation system
(remove-plist-key :goal-operation keys)))
:from-end t)))))
(with-asdf-session (:override t)
(remove-duplicates
(mapcar 'action-component
(apply 'collect-dependencies goal-operation system
(remove-plist-key :goal-operation keys)))
:from-end t))))
......@@ -10,7 +10,8 @@
#:asdf-cache #:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache
#:do-asdf-cache #:normalize-namestring
#:call-with-asdf-session #:with-asdf-session
#:*asdf-session* #:*asdf-session-class* #:session #:session-cache #:session-plan
#:*asdf-session* #:*asdf-session-class* #:session #:toplevel-asdf-session
#:session-cache #:session-plan #:asdf-upgraded-p
#:visited-actions #:visiting-action-set #:visiting-action-list
#:total-action-count #:planned-action-count #:planned-output-action-count
#:clear-configuration-and-retry #:retry
......@@ -36,9 +37,15 @@
;; * Speed and reliability of ASDF, with fewer side-effects from access to the filesystem, and
;; no expensive recomputations of transitive dependencies for input-files or output-files.
;; * Testability of ASDF with the ability to fake timestamps without actually touching files.
(ancestor
:initform nil :initarg :ancestor :reader session-ancestor
:documentation "Top level session that this is part of")
(session-cache
:initform (make-hash-table :test 'equal) :accessor session-cache
:initform (make-hash-table :test 'equal) :initarg :session-cache :reader session-cache
:documentation "Memoize expensive computations")
(asdf-upgraded-p
:initform nil :initarg :asdf-upgraded-p :accessor asdf-upgraded-p
:documentation "Was ASDF already upgraded in this session - only valid for toplevel-asdf-session.")
(plan
:initform nil :accessor session-plan
:documentation "Dependency graph of actions")
......@@ -56,6 +63,9 @@
(planned-output-action-count :initform 0 :accessor planned-output-action-count))
(:documentation "An ASDF session with a cache to memoize some computations"))
(defun toplevel-asdf-session ()
(when *asdf-session* (or (session-ancestor *asdf-session*) *asdf-session*)))
(defun asdf-cache ()
(session-cache *asdf-session*))
......@@ -93,13 +103,18 @@
;; Second, if a new session was started, establish restarts for retrying the overall computation.
;; Finally, consult the cache if a KEY was specified with the THUNK as a fallback when the cache
;; entry isn't found, or just call the THUNK if no KEY was specified.
(defun call-with-asdf-session (thunk &key override key)
(defun call-with-asdf-session (thunk &key override key override-cache)
(let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk)))
(if (and *asdf-session* (not override))
(if (and (not override) *asdf-session*)
(funcall fun)
(loop
(restart-case
(let ((*asdf-session* (make-instance *asdf-session-class*)))
(let ((*asdf-session*
(apply 'make-instance *asdf-session-class*
(when *asdf-session*
`(:ancestor ,(toplevel-asdf-session)
,@(unless override-cache
`(:session-cache ,(session-cache *asdf-session*))))))))
(return (funcall fun)))
(retry ()
:report (lambda (s)
......@@ -107,11 +122,13 @@
(clear-configuration-and-retry ()
:report (lambda (s)
(format s (compatfmt "~@<Retry ASDF operation after resetting the configuration.~@:>")))
(clrhash (session-cache *asdf-session*))
(clear-configuration)))))))
;; Syntactic sugar for call-with-asdf-session
(defmacro with-asdf-session ((&key key override) &body body)
`(call-with-asdf-session #'(lambda () ,@body) :override ,override :key ,key))
(defmacro with-asdf-session ((&key key override override-cache) &body body)
`(call-with-asdf-session
#'(lambda () ,@body) :override ,override :key ,key :override-cache ,override-cache))
;;; Define specific accessor for file (date) stamp.
......
;;-*- Lisp -*-
(setf *asdf-session* nil)
(defun current-system-source-file (x)
(system-source-file (asdf::registered-system x)))
(with-asdf-session (:override t)
(terpri)
(DBG "loading test-mutual-redefinition-1")
(let ((warned-p nil))
(handler-bind ((bad-system-name (lambda (c)
......@@ -19,7 +22,8 @@
(test-source "test-mutual-redefinition-1.asd")
(current-system-source-file "test-mutual-redefinition-2"))
(DBG "loading test-mutual-redefinition-2 in the same cache session")
(terpri)
(DBG "loading test-mutual-redefinition-2 in the same cache session. It shouldn't affect asd paths")
(load-system 'test-mutual-redefinition-2)
(assert-pathname-equal
(test-source "test-mutual-redefinition-1.asd")
......@@ -29,6 +33,7 @@
(current-system-source-file "test-mutual-redefinition-2")))
(with-asdf-session (:override t)
(terpri)
(DBG "loading test-mutual-redefinition-2 in a different cache session")
(load-system 'test-mutual-redefinition-2)
(assert-pathname-equal
......
......@@ -3,19 +3,21 @@
(format! t "~%Using ASDF ~A~%" (asdf-version))
(assert (version< "3.0" (asdf-version))) ;; check that we have a recent enough ASDF
(DBG "Let's define some methods on input-files, to later check what an upgrade does to them.")
(def-test-system "fooey")
(defparameter *ticks* 0)
(defun tick () (incf *ticks*))
(defsystem "foo")
(defmethod input-files :after ((o load-op) (c system)) (tick))
(assert-equal *ticks* 0)
(input-files 'load-op "foo")
(assert-equal *ticks* 1)
(input-files 'load-op "foo")
(assert-equal *ticks* 1) ;; It was cached.
(assert (find-system "fooey" nil))
(setf *asdf-session* nil)
(DBG "Let's define some methods on input-files, to later check what an upgrade does to them.")
(with-asdf-session (:override t)
(def-test-system "fooey")
(defparameter *ticks* 0)
(defun tick () (incf *ticks*))
(defsystem "foo")
(defmethod input-files :after ((o load-op) (c system)) (tick))
(assert-equal *ticks* 0)
(input-files 'load-op "foo")
(assert-equal *ticks* 1)
(input-files 'load-op "foo")
(assert-equal *ticks* 1) ;; It was cached.
(assert (find-system "fooey" nil)))
(DBG "Try load ASDF with an empty configuration")
(initialize-source-registry
......@@ -60,8 +62,7 @@
(clear-system "asdf")
(with-asdf-session (:override t)
(with-expected-failure (#+xcl t)
;; expected-failure: XCL has trouble with the ASDF upgrade
(with-expected-failure (#+xcl t) ;; expected-failure: XCL has trouble with the ASDF upgrade
(load-system :asdf)
(assert-pathname-equal (subpathname *asdf-directory* "asdf.asd")
(system-source-file (find-system :asdf))))
......
......@@ -4,6 +4,7 @@
;;; system that can be found using *system-definition-search-functions*
(defun system-registered-time (name)
(car (asdf::system-registered-p name)))
(setf (asdf-upgraded-p *asdf-session*) t)
(defparameter test1.asd (nth-value 2 (locate-system :test1)))
(assert-pathname-equal test1.asd (test-source "test1.asd"))
......
......@@ -2,6 +2,7 @@
;;; test retrying finding location of an ASDF system.
(setf *asdf-session* nil)
(in-package asdf-test)
(defparameter *old-registry* asdf:*central-registry*)
......@@ -62,7 +63,7 @@
(DBG "After invoking restart, CENTRAL-REGISTRY is:"
asdf:*central-registry*))
;; avoid infinite looping
(leave-test 11 "Infinite loop while catching MISSING-COMPONENT"))))
(leave-test "Infinite loop while catching MISSING-COMPONENT" 11))))
(handler-bind
((asdf:missing-dependency-of-version
#'(lambda (c)
......
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