Commit 1b38225b authored by Dave Cooper's avatar Dave Cooper Committed by Francois-Rene Rideau

Add and export a register-immutable-system function.

Make *immutable-systems* also respect preloaded-systems.
Don't clear immutable-systems as part of clear-system and clear-defined-system.
Export register-preloaded-system.
Add a test, ensure bugs are fixed.

This code was written by Dave Cooper then tweaked by Francois-Rene Rideau.
parent 9d867929
...@@ -18,8 +18,7 @@ ...@@ -18,8 +18,7 @@
#:find-system-if-being-defined #:find-system-if-being-defined
#:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed
#:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems* #:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems*
#:clear-defined-system #:clear-defined-systems #:*defined-systems* #:*defined-systems* #:clear-defined-systems #:*immutable-systems* #:register-immutable-system
#:*immutable-systems*
;; defined in source-registry, but specially mentioned here: ;; defined in source-registry, but specially mentioned here:
#:initialize-source-registry #:sysdef-source-registry-search)) #:initialize-source-registry #:sysdef-source-registry-search))
(in-package :asdf/find-system) (in-package :asdf/find-system)
...@@ -89,29 +88,84 @@ of which is a system object.") ...@@ -89,29 +88,84 @@ of which is a system object.")
(get-file-stamp file)) (get-file-stamp file))
system))))) system)))))
(defun clear-defined-system (system) (defvar *preloaded-systems* (make-hash-table :test 'equal))
(defun make-preloaded-system (name keys)
(apply 'make-instance (getf keys :class 'system)
:name name :source-file (getf keys :source-file)
(remove-plist-keys '(:class :name :source-file) keys)))
(defun sysdef-preloaded-system-search (requested)
(let ((name (coerce-name requested)))
(multiple-value-bind (keys foundp) (gethash name *preloaded-systems*)
(when foundp
(make-preloaded-system name keys)))))
(defun register-preloaded-system (system-name &rest keys)
(setf (gethash (coerce-name system-name) *preloaded-systems*) keys))
(dolist (s '("asdf" "uiop" "asdf-driver" "asdf-defsystem" "asdf-package-system"))
;; don't bother with these, no one relies on them: "asdf-utils" "asdf-bundle"
(register-preloaded-system s :version *asdf-version*))
(defvar *immutable-systems* nil
"An hash-set (equal hash-table mapping keys to T) of systems that are immutable,
i.e. already loaded in memory and not to be refreshed from the filesystem.
They will be treated specially by find-system, and passed as :force-not argument to make-plan.
If you deliver an image with many systems precompiled, *and* do not want to check the filesystem
for them every time a user loads an extension, what more risk a problematic upgrade or catastrophic
downgrade, before you dump an image, use:
(setf asdf::*immutable-systems* (uiop:list-to-hash-set (asdf:already-loaded-systems)))")
(defun sysdef-immutable-system-search (requested)
(let ((name (coerce-name requested)))
(when (and *immutable-systems* (gethash name *immutable-systems*))
(or (cdr (system-registered-p requested))
(sysdef-preloaded-system-search name)
(error 'formatted-system-definition-error
:format-control "Requested system ~A is in the *immutable-systems* set, ~
but not loaded in memory"
:format-arguments (list name))))))
(defun register-immutable-system (system-name &key (version t))
(let* ((system-name (coerce-name system-name))
(registered-system (cdr (system-registered-p system-name)))
(default-version? (eql version t))
(version (cond ((and default-version? registered-system)
(component-version registered-system))
(default-version? nil)
(t version))))
(unless registered-system
(register-system (make-preloaded-system system-name (list :version version))))
(register-preloaded-system system-name :version version)
(unless *immutable-systems*
(setf *immutable-systems* (list-to-hash-set nil)))
(setf (gethash (coerce-name system-name) *immutable-systems*) t)))
(defun clear-system (system)
"Clear the entry for a SYSTEM in the database of systems previously loaded,
unless the system appears in the table of *IMMUTABLE-SYSTEMS*.
Note that this does NOT in any way cause the code of the system to be unloaded.
Returns T if cleared or already cleared,
NIL if not cleared because the system was found to be immutable."
;; There is no "unload" operation in Common Lisp, and
;; a general such operation cannot be portably written,
;; considering how much CL relies on side-effects to global data structures.
(let ((name (coerce-name system))) (let ((name (coerce-name system)))
(remhash name *defined-systems*) (unless (and *immutable-systems* (gethash name *immutable-systems*))
(unset-asdf-cache-entry `(locate-system ,name)) (remhash (coerce-name name) *defined-systems*)
(unset-asdf-cache-entry `(find-system ,name)) (unset-asdf-cache-entry `(locate-system ,name))
nil)) (unset-asdf-cache-entry `(find-system ,name))
t)))
(defun clear-defined-systems () (defun clear-defined-systems ()
;; Invalidate all systems but ASDF itself, if registered. ;; Invalidate all systems but ASDF itself, if registered.
(loop :for name :being :the :hash-keys :of *defined-systems* (loop :for name :being :the :hash-keys :of *defined-systems*
:unless (equal name "asdf") :unless (equal name "asdf") :do (clear-system name)))
:do (clear-defined-system name)))
(register-hook-function '*post-upgrade-cleanup-hook* 'clear-defined-systems nil) (register-hook-function '*post-upgrade-cleanup-hook* 'clear-defined-systems nil)
(defun clear-system (name)
"Clear the entry for a system in the database of systems previously loaded.
Note that this does NOT in any way cause the code of the system to be unloaded."
;; There is no "unload" operation in Common Lisp, and
;; a general such operation cannot be portably written,
;; considering how much CL relies on side-effects to global data structures.
(remhash (coerce-name name) *defined-systems*))
(defun map-systems (fn) (defun map-systems (fn)
"Apply FN to each defined system. "Apply FN to each defined system.
...@@ -232,26 +286,6 @@ Going forward, we recommend new users should be using the source-registry. ...@@ -232,26 +286,6 @@ Going forward, we recommend new users should be using the source-registry.
(list new) (list new)
(subseq *central-registry* (1+ position)))))))))) (subseq *central-registry* (1+ position))))))))))
(defvar *preloaded-systems* (make-hash-table :test 'equal))
(defun make-preloaded-system (name keys)
(apply 'make-instance (getf keys :class 'system)
:name name :source-file (getf keys :source-file)
(remove-plist-keys '(:class :name :source-file) keys)))
(defun sysdef-preloaded-system-search (requested)
(let ((name (coerce-name requested)))
(multiple-value-bind (keys foundp) (gethash name *preloaded-systems*)
(when foundp
(make-preloaded-system name keys)))))
(defun register-preloaded-system (system-name &rest keys)
(setf (gethash (coerce-name system-name) *preloaded-systems*) keys))
(dolist (s '("asdf" "uiop" "asdf-driver" "asdf-defsystem" "asdf-package-system"))
;; don't bother with these, no one relies on them: "asdf-utils" "asdf-bundle"
(register-preloaded-system s :version *asdf-version*))
(defmethod find-system ((name null) &optional (error-p t)) (defmethod find-system ((name null) &optional (error-p t))
(when error-p (when error-p
(sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>")))) (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>"))))
...@@ -263,7 +297,9 @@ Going forward, we recommend new users should be using the source-registry. ...@@ -263,7 +297,9 @@ Going forward, we recommend new users should be using the source-registry.
;; notable side effect: mark the system as being defined, to avoid infinite loops ;; notable side effect: mark the system as being defined, to avoid infinite loops
(first (gethash `(find-system ,(coerce-name name)) *asdf-cache*))) (first (gethash `(find-system ,(coerce-name name)) *asdf-cache*)))
(defun load-asd (pathname &key name (external-format (encoding-external-format (detect-encoding pathname))) &aux (readtable *readtable*) (print-pprint-dispatch *print-pprint-dispatch*)) (defun load-asd (pathname
&key name (external-format (encoding-external-format (detect-encoding pathname)))
&aux (readtable *readtable*) (print-pprint-dispatch *print-pprint-dispatch*))
;; Tries to load system definition with canonical NAME from PATHNAME. ;; Tries to load system definition with canonical NAME from PATHNAME.
(with-asdf-cache () (with-asdf-cache ()
(with-standard-io-syntax (with-standard-io-syntax
...@@ -331,25 +367,6 @@ Going forward, we recommend new users should be using the source-registry. ...@@ -331,25 +367,6 @@ Going forward, we recommend new users should be using the source-registry.
old-version old-pathname version pathname)))) old-version old-pathname version pathname))))
nil))))) ;; only issue the warning the first time, but always return nil nil))))) ;; only issue the warning the first time, but always return nil
(defvar *immutable-systems* nil
"An hash-set (equal hash-table mapping keys to T) of systems that are immutable,
i.e. already loaded in memory and not to be refreshed from the filesystem.
They will be treated specially by find-system, and passed as :force-not argument to make-plan.
If you deliver an image with many systems precompiled, *and* do not want to check the filesystem
for them every time a user loads an extension, what more risk a problematic upgrade or catastrophic
downgrade, before you dump an image, use:
(setf asdf::*immutable-systems* (uiop:list-to-hash-set (asdf:already-loaded-systems)))")
(defun sysdef-immutable-system-search (requested)
(let ((name (coerce-name requested)))
(when (and *immutable-systems* (gethash name *immutable-systems*))
(or (cdr (system-registered-p requested))
(error 'formatted-system-definition-error
:format-control "Requested system ~A is in the *immutable-systems* set, ~
but not loaded in memory"
:format-arguments (list name))))))
(defun locate-system (name) (defun locate-system (name)
"Given a system NAME designator, try to locate where to load the system from. "Given a system NAME designator, try to locate where to load the system from.
Returns five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME Returns five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME
...@@ -389,7 +406,8 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. ...@@ -389,7 +406,8 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(unless (equal name primary-name) (unless (equal name primary-name)
(find-system primary-name nil))) (find-system primary-name nil)))
(or (and *immutable-systems* (gethash name *immutable-systems*) (or (and *immutable-systems* (gethash name *immutable-systems*)
(cdr (system-registered-p name))) (or (cdr (system-registered-p name))
(sysdef-preloaded-system-search name)))
(multiple-value-bind (foundp found-system pathname previous previous-time) (multiple-value-bind (foundp found-system pathname previous previous-time)
(locate-system name) (locate-system name)
(assert (eq foundp (and (or found-system pathname previous) t))) (assert (eq foundp (and (or found-system pathname previous) t)))
......
...@@ -58,6 +58,8 @@ ...@@ -58,6 +58,8 @@
#:static-file #:doc-file #:html-file #:static-file #:doc-file #:html-file
#:file-type #:source-file-type #:file-type #:source-file-type
#:register-preloaded-system #:register-immutable-system
#:package-inferred-system #:register-system-packages #:package-inferred-system #:register-system-packages
#:package-system ;; backward-compatibility during migration, to be removed in a further release. #:package-system ;; backward-compatibility during migration, to be removed in a further release.
......
...@@ -24,7 +24,7 @@ ...@@ -24,7 +24,7 @@
(defun clear-caches-and-search () (defun clear-caches-and-search ()
(setf asdf:*central-registry* nil) (setf asdf:*central-registry* nil)
(mapc #'asdf/find-system:clear-defined-system *all-systems*)) (mapc #'clear-system *all-systems*))
(clear-caches-and-search) (clear-caches-and-search)
(assert (not (asdf:find-system "test-asdf/force1" nil))) (assert (not (asdf:find-system "test-asdf/force1" nil)))
......
;;; -*- Lisp -*-
(in-package :asdf-test)
(DBG "Consider a system that does not exist. Loading it fails.")
(assert (null (find-system :this-system-does-not-exist nil)))
(errors missing-component (load-system :this-system-does-not-exist))
(DBG "Now let's register it as preloaded. Loading it will work!")
(register-preloaded-system :this-system-does-not-exist :version "3.14")
(assert (null (system-registered-p :this-system-does-not-exist))) ;; not yet registered as loaded
(load-system :this-system-does-not-exist) ;; but now we can load it
(assert (system-registered-p :this-system-does-not-exist)) ;; and it is loaded indeed!
(DBG "Now let's load a simple system. It should create a package.")
(load-system :test-asdf/1)
(assert (find-package :test-package))
(DBG "Destroy the package, clear the system and load it again. The package should be back.")
(delete-package :test-package) (clear-system :test-asdf/1)
(load-system :test-asdf/1)
(assert (find-package :test-package))
(DBG "Destroy the package, clear the system, and register it as immutable. Try loading it again.")
(DBG "The package should NOT be back, because it's immutable thus it's NOT going to be loaded.")
(delete-package :test-package) (clear-system :test-asdf/1)
(assert (null (system-registered-p :test-asdf/1))) ;; not registered as loaded
(register-immutable-system :test-asdf/1)
(assert (system-registered-p :test-asdf/1)) ;; now it's registered as loaded
(load-system :test-asdf/1)
(assert (system-registered-p :test-asdf/1)) ;; and it is "loaded" indeed!
(assert (null (find-package :test-package))) ;; but the source code wasn't loaded
...@@ -15,7 +15,7 @@ ...@@ -15,7 +15,7 @@
(declare (ignore system)) (declare (ignore system))
(subpathname *test-directory* "always-error.lisp")) (subpathname *test-directory* "always-error.lisp"))
(asdf::clear-defined-system "asdf") (clear-system "asdf")
(let ((*system-definition-search-functions* '(sysdef-bogus-test-search)) (let ((*system-definition-search-functions* '(sysdef-bogus-test-search))
(state "Didn't catch warning")) (state "Didn't catch warning"))
(DBG "Bogus attempt at loading an old ASDF: should issue a warning and ignore") (DBG "Bogus attempt at loading an old ASDF: should issue a warning and ignore")
...@@ -25,7 +25,7 @@ ...@@ -25,7 +25,7 @@
(when (search "ASDF will ignore this configured system rather than downgrade itself." (when (search "ASDF will ignore this configured system rather than downgrade itself."
(simple-condition-format-control c)) (simple-condition-format-control c))
(setf state "Caught warning"))))) (setf state "Caught warning")))))
(asdf::clear-defined-system "asdf") (clear-system "asdf")
(upgrade-asdf)) (upgrade-asdf))
(assert-equal state "Caught warning") (assert-equal state "Caught warning")
(DBG "2nd bogus attempt at loading same old ASDF: should ignore without a warning") (DBG "2nd bogus attempt at loading same old ASDF: should ignore without a warning")
...@@ -33,7 +33,7 @@ ...@@ -33,7 +33,7 @@
((simple-warning ((simple-warning
#'(lambda (c) #'(lambda (c)
(error "Should not have issued warning, but did issue:~% ~A" c)))) (error "Should not have issued warning, but did issue:~% ~A" c))))
(asdf::clear-defined-system "asdf") (clear-system "asdf")
(upgrade-asdf))) (upgrade-asdf)))
(DBG "Load ASDF with proper configuration: should find asdf.asd from the source above") (DBG "Load ASDF with proper configuration: should find asdf.asd from the source above")
...@@ -42,14 +42,14 @@ ...@@ -42,14 +42,14 @@
(:directory ,*asdf-directory*) (:directory ,*asdf-directory*)
(:directory ,*uiop-directory*) (:directory ,*uiop-directory*)
:ignore-inherited-configuration)) :ignore-inherited-configuration))
(asdf::clear-defined-system "asdf") (clear-system "asdf")
(load-system :asdf) (load-system :asdf)
;; This time we found it, but it was skipped because the version was the same ;; This time we found it, but it was skipped because the version was the same
(assert-equal nil (system-source-file (find-system :asdf))) (assert-equal nil (system-source-file (find-system :asdf)))
;; But if we cheat on our version, that should work ;; But if we cheat on our version, that should work
(setf asdf::*asdf-version* "3.0") (setf asdf::*asdf-version* "3.0")
(asdf::clear-defined-system "asdf") (clear-system "asdf")
#-xcl ;; expected-failure: XCL has trouble with the ASDF upgrade #-xcl ;; expected-failure: XCL has trouble with the ASDF upgrade
(load-system :asdf) (load-system :asdf)
(assert-pathname-equal (subpathname *asdf-directory* "asdf.asd") (assert-pathname-equal (subpathname *asdf-directory* "asdf.asd")
......
...@@ -15,7 +15,7 @@ ...@@ -15,7 +15,7 @@
(defparameter date2 (- date1 600)) (defparameter date2 (- date1 600))
(defparameter date3 (- date1 300)) (defparameter date3 (- date1 300))
(asdf::clear-defined-system :test1) (clear-system :test1)
(touch-file test1.asd :timestamp date2) (touch-file test1.asd :timestamp date2)
(touch-file file1.lisp :timestamp date3) (touch-file file1.lisp :timestamp date3)
(touch-file file2.lisp :timestamp date3) (touch-file file2.lisp :timestamp date3)
...@@ -29,7 +29,7 @@ ...@@ -29,7 +29,7 @@
(assert-compare (>= date4 date3)) (assert-compare (>= date4 date3))
(sleep 1) (sleep 1)
(asdf::clear-defined-system :test1) (clear-system :test1)
(touch-file test1.asd) (touch-file test1.asd)
(find-system :test1) (find-system :test1)
(defparameter date6 (system-registered-time :test1)) (defparameter date6 (system-registered-time :test1))
......
...@@ -12,8 +12,8 @@ ...@@ -12,8 +12,8 @@
(defun clear-caches-and-search () (defun clear-caches-and-search ()
(setf asdf:*central-registry* nil) (setf asdf:*central-registry* nil)
(asdf/find-system:clear-defined-system "test-asdf") (clear-system "test-asdf")
(asdf/find-system:clear-defined-system "test-asdf/force1")) (clear-system "test-asdf/force1"))
(DBG "Clearing the caches and finding.") (DBG "Clearing the caches and finding.")
(clear-caches-and-search) (clear-caches-and-search)
......
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