From 51accff10a14f634285a33f2fd72a48f551c3340 Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <fare@tunes.org> Date: Sat, 19 Nov 2016 11:56:12 -0500 Subject: [PATCH] Add out-of-date detection for system definition --- action.lisp | 89 ++++++++------- find-system.lisp | 109 ++++++++++++------- interface.lisp | 2 +- plan.lisp | 45 +++++--- system.lisp | 14 ++- test/package-inferred-system-test.script | 5 +- test/test-defsystem-depends-on-change.asd | 1 + test/test-defsystem-depends-on-change.script | 5 + test/test-defsystem-depends-on.script | 9 +- test/test-sysdef-asdf.script | 47 ++++---- uiop/utility.lisp | 5 +- 11 files changed, 192 insertions(+), 139 deletions(-) diff --git a/action.lisp b/action.lisp index 4f76099dc..bb95fc088 100644 --- a/action.lisp +++ b/action.lisp @@ -16,7 +16,7 @@ #:input-files #:output-files #:output-file #:operation-done-p #:action-operation #:action-component #:make-action #:component-operation-time #:mark-operation-done #:compute-action-stamp - #:perform #:perform-with-restarts #:retry #:accept #:*action* + #:perform #:perform-with-restarts #:retry #:accept #:action-path #:find-action #:stamp #:done-p #:operation-definition-warning #:operation-definition-error ;; condition #:action-valid-p @@ -50,9 +50,10 @@ and a class-name or class designates the canonical instance of the designated cl (with-upgradability () (defun action-path (action) "A readable data structure that identifies the action." - (let ((o (action-operation action)) - (c (action-component action))) - (cons (type-of o) (component-find-path c)))) + (when action + (let ((o (action-operation action)) + (c (action-component action))) + (cons (type-of o) (component-find-path c))))) (defun find-action (path) "Reconstitute an action from its action-path" (destructuring-bind (o . c) path (make-action (make-operation o) (find-component () c))))) @@ -110,7 +111,7 @@ and a class-name or class designates the canonical instance of the designated cl ,if-no-component)))))))) -;;;; self-description +;;;; Self-description (with-upgradability () (defgeneric action-description (operation component) (:documentation "returns a phrase that describes performing this operation @@ -128,6 +129,42 @@ Use it in FORMAT control strings as ~/asdf-action:format-action/" (princ (action-description operation component) stream)))) +;;;; Detection of circular dependencies +(with-upgradability () + (defun (action-valid-p) (operation component) + "Is this action valid to include amongst dependencies?" + ;; If either the operation or component was resolved to nil, the action is invalid. + ;; :if-feature will invalidate actions on components for which the features don't apply. + (and operation component + (if-let (it (component-if-feature component)) (featurep it) t))) + + (define-condition circular-dependency (system-definition-error) + ((actions :initarg :actions :reader circular-dependency-actions)) + (:report (lambda (c s) + (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>") + (circular-dependency-actions c))))) + + (defun call-while-visiting-action (operation component fun) + "Detect circular dependencies" + (with-asdf-session () + (with-accessors ((action-set visiting-action-set) + (action-list visiting-action-list)) *asdf-session* + (let ((action (cons operation component))) + (when (gethash action action-set) + (error 'circular-dependency :actions + (member action (reverse action-list) :test 'equal))) + (setf (gethash action action-set) t) + (push action action-list) + (unwind-protect + (funcall fun) + (pop action-list) + (setf (gethash action action-set) nil)))))) + + ;; Syntactic sugar for call-while-visiting-action + (defmacro while-visiting-action ((o c) &body body) + `(call-while-visiting-action ,o ,c #'(lambda () ,@body)))) + + ;;;; Dependencies (with-upgradability () (defgeneric component-depends-on (operation component) ;; ASDF4: rename to component-dependencies @@ -410,11 +447,8 @@ Returns two values: (:documentation "PERFORM an action, consuming its input-files and building its output-files")) (define-convenience-action-methods perform (operation component)) - (defvar *action* nil - "Action being performed") (defmethod perform :around ((o operation) (c component)) - (let ((*action* (cons o c))) - (call-next-method))) + (while-visiting-action (o c) (call-next-method))) (defmethod perform :before ((o operation) (c component)) (ensure-all-directories-exist (output-files o c))) (defmethod perform :after ((o operation) (c component)) @@ -452,40 +486,3 @@ Returns two values: (action-description operation component))) (mark-operation-done operation component) (return)))))) - - -;;;; Detection of circular dependencies -(with-upgradability () - (defun (action-valid-p) (operation component) - "Is this action valid to include amongst dependencies?" - ;; If either the operation or component was resolved to nil, the action is invalid. - ;; :if-feature will invalidate actions on components for which the features don't apply. - (and operation component - (if-let (it (component-if-feature component)) (featurep it) t))) - - (define-condition circular-dependency (system-definition-error) - ((actions :initarg :actions :reader circular-dependency-actions)) - (:report (lambda (c s) - (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>") - (circular-dependency-actions c))))) - - (defun call-while-visiting-action (operation component fun) - "Detect circular dependencies" - (when (action-valid-p operation component) - (with-accessors ((action-set visiting-action-set) - (action-list visiting-action-list)) *asdf-session* - (let ((action (cons operation component))) - (when (gethash action action-set) - (error 'circular-dependency :actions - (member action (reverse action-list) :test 'equal))) - (setf (gethash action action-set) t) - (push action action-list) - (unwind-protect - (funcall fun) - (pop action-list) - (setf (gethash action action-set) nil)))))) - - ;; Syntactic sugar for call-while-visiting-action - (defmacro while-visiting-action ((o c) &body body) - `(call-while-visiting-action ,o ,c #'(lambda () ,@body)))) - diff --git a/find-system.lisp b/find-system.lisp index bf711eade..22114504b 100644 --- a/find-system.lisp +++ b/find-system.lisp @@ -8,7 +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 #:system-out-of-date)) (in-package :asdf/find-system) (with-upgradability () @@ -20,6 +20,13 @@ (format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>") (error-name c) (error-pathname c) (error-condition c))))) + (define-condition system-out-of-date (condition) + ;; NB: not an error, not a warning, but a normal expected condition + ((name :initarg :name :reader component-name)) + (:documentation "condition signaled when a system is detected as being out of date") + (:report (lambda (c s) + (format s "system ~A is out of date" (component-name c))))) + ;;; Methods for find-system @@ -50,13 +57,13 @@ (and (typep operation 'load-op) (typep component 'system) (equal "asdf" (coerce-name component)))) - (when *action* - (let ((parent-operation (car *action*)) - (parent-component (cdr *action*))) + (if-let ((action (first (visiting-action-list *asdf-session*)))) + (let ((parent-operation (action-operation action)) + (parent-component (action-component action))) (unless (and (typep parent-operation 'define-op) (typep parent-component 'system)) (error "Invalid recursive use of (OPERATE ~S ~S) while visiting ~S ~ - please use proper dependencies instead." - operation component *action*)) + operation component action)) (let ((action (cons operation component))) (unless (gethash action (definition-dependency-set parent-component)) (push (cons operation component) (definition-dependency-list parent-component)) @@ -106,8 +113,8 @@ (asdf-message (compatfmt "~&~@<; ~@;Loading system definition~@[ for ~A~] from ~A~@:>~%") (coerce-name s) pathname) ;; dependencies will depend on what's loaded via definition-dependency-list - (unset-asdf-cache-entry `(component-depends-on ,o ,s)) - (load* pathname :external-format (encoding-external-format (detect-encoding pathname)))))) + (unset-asdf-cache-entry `(component-depends-on ,o ,s))) + (load* pathname :external-format (encoding-external-format (detect-encoding pathname))))) (defun load-asd (pathname &key name) "Load system definitions from PATHNAME. @@ -123,7 +130,9 @@ Do NOT try to load a .asd file directly with CL:LOAD. Always use ASDF:LOAD-ASD." (progn ;; We already determine this to be obsolete --- ;; or should we move some tests from find-system to check for up-to-date-ness here? - (setf (component-operation-time operation system) nil) + (setf (component-operation-time operation system) nil + (definition-dependency-list system) nil + (definition-dependency-set system) (list-to-hash-set nil)) (do-it operation system)) (let ((system (make-instance 'undefined-system :name primary-name :source-file pathname))) @@ -214,38 +223,58 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. ;; preloaded, with a previous configuration, or before filesystem changes), and ;; load a found .asd if appropriate. Finally, update registration table and return results. (defmethod find-system ((name string) &optional (error-p t)) - (with-asdf-session (:key `(find-system ,name)) - (let ((primary-name (primary-system-name name))) - (unless (equal name primary-name) - (find-system primary-name nil))) - (or (and *immutable-systems* (gethash name *immutable-systems*) (registered-system name)) - (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 (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)) - (if-let ((stamp (get-file-stamp pathname))) - (let ((up-to-date-p - (and previous - (or (pathname-equal pathname previous-pathname) - (and pathname previous-pathname - (pathname-equal - (physicalize-pathname pathname) - (physicalize-pathname previous-pathname)))) - (stamp<= stamp previous-time) - ;; TODO: check that all dependencies are up-to-date. - ;; This necessitates traversing them without triggering - ;; the adding of nodes to the plan. - ))) - (unless up-to-date-p - (load-asd pathname :name name))))) - ;; Try again after having loaded from disk if needed - (or (registered-system name) - (when error-p (error 'missing-component :requires name))))))) + (nest + (with-asdf-session (:key `(find-system ,name))) + (let* ((name-primary-p (primary-system-p name)) + (primary-system (unless name-primary-p (find-system (primary-system-name name) nil))))) + (or (and *immutable-systems* (gethash name *immutable-systems*) (registered-system name))) + (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 (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)) + (if-let ((stamp (get-file-stamp pathname))) + (let ((up-to-date-p + (and previous + (or (pathname-equal pathname previous-pathname) + (and pathname previous-pathname + (pathname-equal + (physicalize-pathname pathname) + (physicalize-pathname previous-pathname)))) + (stamp<= stamp previous-time) + ;; TODO: check that all dependencies are up-to-date. + ;; This necessitates traversing them without triggering + ;; the adding of nodes to the plan. + (loop :with plan = (or (and *asdf-session* + (session-plan *asdf-session*)) + (make-instance *plan-class*)) + :for action :in (definition-dependency-list previous) + :always (handler-bind + ((system-out-of-date + (lambda (c) (declare (ignore c)) (return nil)))) + (action-up-to-date-p plan + (action-operation action) + (action-component action))) + :finally + (let ((o (make-operation 'define-op)) + (s (if name-primary-p previous primary-system))) + (when s + (multiple-value-bind (stamp done-p) + (compute-action-stamp plan o s) + (return (and (stamp<= stamp (component-operation-time o s)) + done-p))))))))) + (unless up-to-date-p + (restart-case + (signal 'system-out-of-date :name name) + (continue () :report "continue")) + (load-asd pathname :name name))))) + ;; Try again after having loaded from disk if needed + (or (registered-system name) + (when error-p (error 'missing-component :requires name))))) ;; Resolved forward reference for asdf/system-registry. (defun mark-component-preloaded (component) diff --git a/interface.lisp b/interface.lisp index d6e6ec7f0..f8a45374e 100644 --- a/interface.lisp +++ b/interface.lisp @@ -123,7 +123,7 @@ #:missing-dependency #:missing-dependency-of-version #:circular-dependency ; errors - #:duplicate-names #:non-toplevel-system #:non-system-system #:bad-system-name + #:duplicate-names #:non-toplevel-system #:non-system-system #:bad-system-name #:system-out-of-date #:package-inferred-system-missing-package-error #:operation-definition-warning #:operation-definition-error diff --git a/plan.lisp b/plan.lisp index edadac948..f3c3d2b88 100644 --- a/plan.lisp +++ b/plan.lisp @@ -18,7 +18,7 @@ #:record-dependency #:normalize-forced-systems #:action-forced-p #:action-forced-not-p #:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies - #:compute-action-stamp #:traverse-action + #:compute-action-stamp #:traverse-action #:action-up-to-date-p #:make-plan #:plan-actions #:perform-plan #:plan-operates-on-p #:planned-p #:index #:forced #:forced-not #:plan-actions-r @@ -73,6 +73,9 @@ in some previous image, or T if it needs to be done.") +action-status-out-of-date+ (make-instance 'action-status :stamp stamp :done-p done-p :planned-p planned-p :index index))) + (defun action-status-out-of-date-p (status) + (eq (action-stamp status) t)) + (defmethod print-object ((status action-status) stream) (print-unreadable-object (status stream :type t) (with-slots (stamp done-p planned-p index) status @@ -104,6 +107,7 @@ the action of OPERATION on COMPONENT in the PLAN")) (setf (gethash o times) (action-stamp new-status)))) new-status)) + ;;;; forcing (with-upgradability () (defgeneric action-forced-p (plan operation component) @@ -346,8 +350,9 @@ initialized with SEED." (defun action-up-to-date-p (plan operation component) "Check whether a node is up-to-date, and mark it so if such. But don't add anything to the plan." - (while-visiting-action (operation component) ; maintain context, handle circularity. - (block nil + (block nil + (unless (action-valid-p operation component) (return nil)) + (while-visiting-action (operation component) ; maintain context, handle circularity. ;; Do NOT record the dependency: it might be out of date. (let ((status (action-status plan operation component))) (when status @@ -369,12 +374,13 @@ initialized with SEED." (not (eq (action-stamp status) t)))))) (defmethod traverse-action (plan operation component needed-in-image-p) - (while-visiting-action (operation component) ; maintain context, handle circularity. - (block nil - ;; Record the dependency. This hook is needed by POIU, which tracks a full dependency graph, - ;; instead of just a dependency order as in vanilla ASDF. - ;; TODO: It is also needed to detect OPERATE-in-PERFORM. - (record-dependency plan operation component) + (block nil + (unless (action-valid-p operation component) (return nil)) + ;; Record the dependency. This hook is needed by POIU, which tracks a full dependency graph, + ;; instead of just a dependency order as in vanilla ASDF. + ;; TODO: It is also needed to detect OPERATE-in-PERFORM. + (record-dependency plan operation component) + (while-visiting-action (operation component) ; maintain context, handle circularity. ;; needed-in-image distinguishes b/w things that must happen in the ;; current image and those things that simply need to have been done in a previous one. (let* ((aniip (needed-in-image-p operation component)) ; action-specific needed-in-image @@ -451,6 +457,8 @@ initialized with SEED." (with-asdf-session () (let ((plan (apply 'make-instance (or plan-class *plan-class*) :system (component-system c) keys))) + (when (and (null (session-plan *asdf-session*)) (plan-performable-p plan)) + (setf (session-plan *asdf-session*) plan)) (traverse-action plan o c t) plan))) @@ -506,15 +514,16 @@ initialized with SEED." :collect (cons o c)))) (defun collect-action-dependencies (plan operation component) - (while-visiting-action (operation component) ; maintain context, handle circularity. - (let ((action (make-action operation component))) - (unless (gethash action (visited-actions *asdf-session*)) - (setf (gethash action (visited-actions *asdf-session*)) t) - (when (and (typep component (plan-component-type plan)) - (not (action-forced-not-p plan operation component))) - (map-direct-dependencies operation component - #'(lambda (o c) (collect-action-dependencies plan o c))) - (push action (plan-actions-r plan))))))) + (when (action-valid-p operation component) + (while-visiting-action (operation component) ; maintain context, handle circularity. + (let ((action (make-action operation component))) + (unless (gethash action (visited-actions *asdf-session*)) + (setf (gethash action (visited-actions *asdf-session*)) t) + (when (and (typep component (plan-component-type plan)) + (not (action-forced-not-p plan operation component))) + (map-direct-dependencies operation component + #'(lambda (o c) (collect-action-dependencies plan o c))) + (push action (plan-actions-r plan)))))))) (defgeneric collect-dependencies (operation component &key &allow-other-keys) (:documentation "Given an action, build a plan for all of its dependencies.")) diff --git a/system.lisp b/system.lisp index 94f71a05c..d2e93514f 100644 --- a/system.lisp +++ b/system.lisp @@ -60,7 +60,14 @@ NB: This interface is subject to change. Please contact ASDF maintainers if you (defclass proto-system () ; slots to keep when resetting a system ;; To preserve identity for all objects, we'd need keep the components slots ;; but also to modify parse-component-form to reset the recycled objects. - ((name) (source-file)) + ((name) + (source-file) + ;; These two slots contains the *inferred* dependencies of define-op, + ;; from loading the .asd file, as list and as set. + (definition-dependency-list + :initform nil :accessor definition-dependency-list) + (definition-dependency-set + :initform (list-to-hash-set nil) :accessor definition-dependency-set)) (:documentation "PROTO-SYSTEM defines the elements of identity that are preserved when a SYSTEM is redefined and its class is modified.")) @@ -89,11 +96,6 @@ a SYSTEM is redefined and its class is modified.")) ;; This slot contains the *declared* defsystem-depends-on dependencies (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on :initform nil) - ;; These slots contains the *inferred* dependencies of define-op, as list and as set - (definition-dependency-list - :initform nil :accessor definition-dependency-list) - (definition-dependency-set - :initform (list-to-hash-set nil) :accessor definition-dependency-set) ;; these two are specially set in parse-component-form, so have no :INITARGs. (depends-on :reader system-depends-on :initform nil) (weakly-depends-on :reader system-weakly-depends-on :initform nil)) diff --git a/test/package-inferred-system-test.script b/test/package-inferred-system-test.script index 6ff089171..cedbb612f 100644 --- a/test/package-inferred-system-test.script +++ b/test/package-inferred-system-test.script @@ -1,3 +1,5 @@ +;;-*- Lisp -*- + (register-directory (subpathname *test-directory* "package-inferred-system-test/")) (load-system :package-inferred-system-test/a/x) (load-system :package-inferred-system-test/d) @@ -5,7 +7,8 @@ (signals package-inferred-system-missing-package-error (load-system :package-inferred-system-test/e)) ;; No such file. -(signals missing-component (load-system :package-inferred-system-test/f)) +(signals missing-component + (handler-bind ((system-out-of-date 'continue)) (load-system :package-inferred-system-test/f))) ;; Test that around-compile is inherited by inferred systems. (assert-equal 3 (symbol-call :package-inferred-system-test/a :add10 1)) ;; add10 must have been compiled in base 2 diff --git a/test/test-defsystem-depends-on-change.asd b/test/test-defsystem-depends-on-change.asd index 3c17719c0..7d5e46074 100644 --- a/test/test-defsystem-depends-on-change.asd +++ b/test/test-defsystem-depends-on-change.asd @@ -1,5 +1,6 @@ (defvar *tddoc* 0) (incf *tddoc*) +(format t "tddoc loaded ~D times.~%" *tddoc*) (if (= *tddoc* 1) (defsystem "test-defsystem-depends-on-change" diff --git a/test/test-defsystem-depends-on-change.script b/test/test-defsystem-depends-on-change.script index 1cd72686d..923974b6d 100644 --- a/test/test-defsystem-depends-on-change.script +++ b/test/test-defsystem-depends-on-change.script @@ -8,10 +8,12 @@ (defparameter tddoc "test-defsystem-depends-on-change") (defparameter talc "test-asdf-location-change") +(defparameter asdf-user::*tddoc* 0) (DBG "Load the system, using xach-foo-1") (push (subpathname *test-directory* "xach-foo-1/") *central-registry*) +(clear-system tddoc) (load-system tddoc) (assert-equal asdf-user::*tddoc* 1) (assert-equal test-asdf-system::*times-loaded* 1) @@ -39,9 +41,12 @@ (subpathname *test-directory* "xach-foo-1/test-asdf-location-change.asd") (system-source-file talc)) + (DBG "Now, change a defsystem-depends-on dependency and try again") (setf (first *central-registry*) (subpathname *test-directory* "xach-foo-2/")) +(DBG :before asdf-user::*tddoc* test-asdf-system::*times-loaded* test-asdf-system::*ta/dcc* test-asdf-system::*ta/dcd* test-asdf-system::*ta/dca*) (load-system "test-defsystem-depends-on-change") +(DBG :after asdf-user::*tddoc* test-asdf-system::*times-loaded* test-asdf-system::*ta/dcc* test-asdf-system::*ta/dcd* test-asdf-system::*ta/dca*) (assert-equal asdf-user::*tddoc* 2) (assert-equal test-asdf-system::*times-loaded* 1) ;; from test-asdf.asd (assert-equal test-asdf-system::*ta/dcc* 2) diff --git a/test/test-defsystem-depends-on.script b/test/test-defsystem-depends-on.script index 2d64319a1..c18880cc1 100644 --- a/test/test-defsystem-depends-on.script +++ b/test/test-defsystem-depends-on.script @@ -31,7 +31,8 @@ :components ((:file "file3"))) (reset-session) -(signals asdf::formatted-system-definition-error (make :test-defsystem-depends-on-3)) +(signals asdf::formatted-system-definition-error + (handler-bind ((system-out-of-date 'continue)) (make :test-defsystem-depends-on-3))) (defparameter *newsym* (gentemp (symbol-name 'feature) :keyword)) @@ -49,9 +50,11 @@ (assert (not (system-registered-p "unloadable-system")))) (progn - (signals missing-dependency (find-system "test-defsystem-depends-on-missing-system")) + (signals missing-dependency + (handler-bind ((system-out-of-date 'continue)) (find-system "test-defsystem-depends-on-missing-system"))) (assert (not (asdf::registered-system "test-defsystem-depends-on-missing-system")))) (progn - (signals asdf::system-definition-error (find-system "test-defsystem-depends-on-circular")) + (signals asdf::system-definition-error + (handler-bind ((system-out-of-date 'continue)) (find-system "test-defsystem-depends-on-circular"))) (assert (not (asdf::registered-system "test-defsystem-depends-on-circular")))) diff --git a/test/test-sysdef-asdf.script b/test/test-sysdef-asdf.script index 07d7931e4..e611d2f78 100644 --- a/test/test-sysdef-asdf.script +++ b/test/test-sysdef-asdf.script @@ -2,16 +2,17 @@ (format! t "~%Using ASDF ~A~%" (asdf-version)) (assert (version< "3.0" (asdf-version))) ;; check that we have a recent enough ASDF - (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)) + (def-test-system "foo") + (defmethod input-files :after ((o load-op) (c system)) + (tick)) (assert-equal *ticks* 0) (input-files 'load-op "foo") (assert-equal *ticks* 1) @@ -19,6 +20,7 @@ (assert-equal *ticks* 1) ;; It was cached. (assert (find-system "fooey" nil))) + (DBG "Try load ASDF with an empty configuration") (initialize-source-registry '(:source-registry :ignore-inherited-configuration)) @@ -26,15 +28,15 @@ ;; We haven't found it, and got the fallback (assert-equal nil (system-source-file (find-system :asdf))) + +(DBG "Bogus attempt at loading an old ASDF: should issue a warning and ignore") +(clear-system "asdf") ;; Bogus sysdef finding function, for the sake of testing no-load-old-version. (defun sysdef-bogus-test-search (system) (declare (ignore system)) (subpathname *test-directory* "always-error.lisp")) - -(clear-system "asdf") (let ((*system-definition-search-functions* '(sysdef-bogus-test-search)) (state "Didn't catch warning")) - (DBG "Bogus attempt at loading an old ASDF: should issue a warning and ignore") (handler-bind ((simple-warning #'(lambda (c) @@ -43,8 +45,11 @@ (setf state "Caught warning"))))) (clear-system "asdf") (upgrade-asdf)) - (assert-equal state "Caught warning") - (DBG "2nd bogus attempt at loading same old ASDF: should ignore without a warning") + (assert-equal state "Caught warning")) + + +(DBG "2nd bogus attempt at loading same old ASDF: should ignore without a warning") +(let ((*system-definition-search-functions* '(sysdef-bogus-test-search))) (handler-bind ((simple-warning #'(lambda (c) @@ -53,6 +58,7 @@ (upgrade-asdf))) (assert-equal nil (system-source-file (find-system :asdf))) + (DBG "Load ASDF with proper configuration: should find asdf.asd from the source above") (initialize-source-registry `(:source-registry @@ -60,18 +66,17 @@ (:directory ,*uiop-directory*) :ignore-inherited-configuration)) (clear-system "asdf") - (with-asdf-session (:override t) (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)))) - (DBG "Loading from the same version shouldn't have reset methods") (setf *ticks* 2) (input-files 'load-op "foo") (assert-equal *ticks* 3)) + (DBG "Loading from an ancient version WILL reset methods") (assert (find-system "fooey" nil)) (defparameter *current-version* (asdf-version)) @@ -79,7 +84,6 @@ (assert (asdf/upgrade::upgrading-p)) (clear-system "asdf") (reset-session) - (with-expected-failure (#+xcl t) ;; expected-failure: XCL has trouble with the ASDF upgrade (load-system :asdf) @@ -88,7 +92,7 @@ (system-source-file (find-system :asdf)))) -;; Upgrading from an old-enough version redefined away the input-files method! +(DBG "Upgrading from an old-enough version should have redefined away the input-files method!") (setf *ticks* 4) (input-files 'load-op "asdf") (assert-equal *ticks* 4) @@ -96,38 +100,37 @@ (assert (not (find-system "fooey" nil))) +(DBG "Actually upgrade, from a different but forward-compatible version") ;; The data-punting upgrade will mess up component identity, so clear the cache (reset-session) - (setf asdf::*asdf-version* asdf/upgrade::*oldest-forward-compatible-asdf-version*) (clear-system "asdf") (def-test-system "fooey") -(setf *ticks* 5) -(defmethod input-files :after ((load-op operation) (c system)) +(setf *ticks* 10) +(defmethod input-files :after ((o load-op) (c system)) + (DBG :input-files o c) (incf *ticks*)) (input-files 'load-op "uiop") -(assert-equal *ticks* 8) +(assert-equal *ticks* 11) (with-expected-failure (#+xcl t) ;; expected-failure: XCL has trouble with the ASDF upgrade (load-system :asdf)) ;; Upgrading from a recent-enough version, the input-files method was preserved! ;; But we need to clear the cache for it not to be short-circuited. (reset-session) - (assert (find-system "fooey" nil)) - -(setf *ticks* 9) +(setf *ticks* 20) (eval '(input-files 'load-op "uiop")) -(assert-equal *ticks* 12) +(assert-equal *ticks* 21) + +(DBG "Checking that the bootstrap script and asdf.asd are in synch") (defun bootstrap-lisp-files (file line-prefix) (with-input-file (input (subpathname *asdf-directory* file)) (loop :for line = (read-line input) :when (string-prefix-p line-prefix line) :return (subseq line (length line-prefix)) :finally (error "Didn't find ~a in ~a" line-prefix file)))) - -(DBG "Checking that the bootstrap script and asdf.asd are in synch") (defun system-lisp-files (system) (loop :for f :in (input-files 'concatenate-source-op system) :collect (unix-namestring (enough-pathname f *asdf-directory*)))) diff --git a/uiop/utility.lisp b/uiop/utility.lisp index eb9ebf54f..7869e5acc 100644 --- a/uiop/utility.lisp +++ b/uiop/utility.lisp @@ -82,8 +82,9 @@ to supersede any previous definition." (with-upgradability () (defvar *uiop-debug-utility* '(or (ignore-errors - (symbol-call :asdf :system-relative-pathname :uiop "contrib/debug.lisp")) - (symbol-call :uiop/pathname :subpathname (user-homedir-pathname) "common-lisp/asdf/uiop/contrib/debug.lisp")) + (probe-file (symbol-call :asdf :system-relative-pathname :uiop "contrib/debug.lisp"))) + (probe-file (symbol-call :uiop/pathname :subpathname + (user-homedir-pathname) "common-lisp/asdf/uiop/contrib/debug.lisp"))) "form that evaluates to the pathname to your favorite debugging utilities") (defmacro uiop-debug (&rest keys) -- GitLab