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

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

find-system.lisp

+76 −58
Original line number Diff line number Diff line
@@ -18,8 +18,7 @@ 
   #:find-system-if-being-defined

   #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed

   #:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems*

   #:clear-defined-system #:clear-defined-systems #:*defined-systems*

   #:*immutable-systems*

   #:*defined-systems* #:clear-defined-systems #:*immutable-systems* #:register-immutable-system

   ;; defined in source-registry, but specially mentioned here:

   #:initialize-source-registry #:sysdef-source-registry-search))

(in-package :asdf/find-system)
@@ -89,29 +88,84 @@ of which is a system object.") 
                      (get-file-stamp file))

                    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)))

      (remhash name *defined-systems*)

      (unless (and *immutable-systems* (gethash name *immutable-systems*))

        (remhash (coerce-name name) *defined-systems*)

        (unset-asdf-cache-entry `(locate-system ,name))

        (unset-asdf-cache-entry `(find-system ,name))

      nil))

        t)))



  (defun clear-defined-systems ()

    ;; Invalidate all systems but ASDF itself, if registered.

    (loop :for name :being :the :hash-keys :of *defined-systems*

          :unless (equal name "asdf")

            :do (clear-defined-system name)))

          :unless (equal name "asdf") :do (clear-system name)))



  (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)

    "Apply FN to each defined system.
@@ -232,26 +286,6 @@ Going forward, we recommend new users should be using the source-registry. 
                            (list new)

                            (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))

    (when error-p

      (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. 
    ;; notable side effect: mark the system as being defined, to avoid infinite loops

    (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.

    (with-asdf-cache ()

      (with-standard-io-syntax
@@ -331,25 +367,6 @@ Going forward, we recommend new users should be using the source-registry. 
                         old-version old-pathname version pathname))))

             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)

    "Given a system NAME designator, try to locate where to load the system from.

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. 
        (unless (equal name primary-name)

          (find-system primary-name nil)))

      (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)

              (locate-system name)

            (assert (eq foundp (and (or found-system pathname previous) t)))

interface.lisp

+2 −0
Original line number Diff line number Diff line
@@ -58,6 +58,8 @@ 
   #:static-file #:doc-file #:html-file

   #:file-type #:source-file-type



   #:register-preloaded-system #:register-immutable-system



   #:package-inferred-system #:register-system-packages

   #:package-system ;; backward-compatibility during migration, to be removed in a further release.

test/test-cache.script

+1 −1
Original line number Diff line number Diff line
@@ -24,7 +24,7 @@ 


(defun clear-caches-and-search ()

  (setf asdf:*central-registry* nil)

  (mapc #'asdf/find-system:clear-defined-system *all-systems*))

  (mapc #'clear-system *all-systems*))



(clear-caches-and-search)

(assert (not (asdf:find-system "test-asdf/force1" nil)))

test/test-preloaded.script

0 → 100644
+33 −0
Original line number Diff line number Diff line 
;;; -*- 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

test/test-sysdef-asdf.script

+5 −5
Original line number Diff line number Diff line
@@ -15,7 +15,7 @@ 
  (declare (ignore system))

  (subpathname *test-directory* "always-error.lisp"))



(asdf::clear-defined-system "asdf")

(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")
@@ -25,7 +25,7 @@ 
	     (when (search "ASDF will ignore this configured system rather than downgrade itself."

			   (simple-condition-format-control c))

	       (setf state "Caught warning")))))

    (asdf::clear-defined-system "asdf")

    (clear-system "asdf")

    (upgrade-asdf))

  (assert-equal state "Caught warning")

  (DBG "2nd bogus attempt at loading same old ASDF: should ignore without a warning")
@@ -33,7 +33,7 @@ 
      ((simple-warning

	 #'(lambda (c)

	     (error "Should not have issued warning, but did issue:~%  ~A" c))))

    (asdf::clear-defined-system "asdf")

    (clear-system "asdf")

    (upgrade-asdf)))



(DBG "Load ASDF with proper configuration: should find asdf.asd from the source above")
@@ -42,14 +42,14 @@ 
   (:directory ,*asdf-directory*)

   (:directory ,*uiop-directory*)

   :ignore-inherited-configuration))

(asdf::clear-defined-system "asdf")

(clear-system "asdf")

(load-system :asdf)

;; This time we found it, but it was skipped because the version was the same

(assert-equal nil (system-source-file (find-system :asdf)))



;; But if we cheat on our version, that should work

(setf asdf::*asdf-version* "3.0")

(asdf::clear-defined-system "asdf")

(clear-system "asdf")

#-xcl ;; expected-failure: XCL has trouble with the ASDF upgrade

(load-system :asdf)

(assert-pathname-equal (subpathname *asdf-directory* "asdf.asd")