;; -*- Lisp -*- ;;; This script verifies the invariants of both ;;; *function* REQUIRE-SYSTEM and *class* REQUIRE-SYSTEM. ;;; Based on work by Daniel KochmaƄski (import 'asdf::registered-system) (DBG "---- Tests related to the behavior of preloaded systems") (DBG "- Even dummy `preloaded-system' is listed in `already-loaded-systems'") (register-preloaded-system "test-preloaded-dummy" :version "1.0") (assert (registered-system "test-preloaded-dummy")) (assert-equal (component-version (registered-system "test-preloaded-dummy")) "1.0") (DBG "- Loaded `preloaded-system' is listed in `already-loaded-systems'") (assert (component-loaded-p (registered-system "test-preloaded-dummy"))) (assert (member "test-preloaded-dummy" (already-loaded-systems) :test #'equal)) (DBG "- Dummy `preloaded-system' doesn't get overwritten by `require-system'") (require-system "test-preloaded-dummy") (assert-equal (component-version (registered-system "test-preloaded-dummy")) "1.0") (DBG "- Dummy `preloaded-system' doesn't get overwritten by `load-system' because there is no alternative in the filesystem") (load-test-system "test-preloaded-dummy") (assert-equal (component-version (registered-system "test-preloaded-dummy")) "1.0") (DBG "- Function `clear-system' doesn't remove `preloaded-system'") (assert (not (clear-system "test-preloaded-dummy"))) (assert-equal (component-version (registered-system "test-preloaded-dummy")) "1.0") (DBG "-`preloaded-system' overridden by defsystem") (def-test-system "test-preloaded-dummy" :version "2.0") (assert-equal (component-version (registered-system "test-preloaded-dummy")) "2.0") (DBG "- Function `clear-system' restores `preloaded-system'") (assert (not (clear-system "test-preloaded-dummy"))) (assert-equal (component-version (registered-system "test-preloaded-dummy")) "1.0") (DBG "-`preloaded-system' overridden by find-system") (assert (not (registered-system "require-system/preloaded"))) (register-preloaded-system "require-system/preloaded" :version "1.0") (assert-equal (component-version (registered-system "require-system/preloaded")) "1.0") (assert (component-loaded-p (registered-system "require-system/preloaded"))) (find-system "require-system/preloaded") (assert-equal (component-version (registered-system "require-system/preloaded")) "2.0") (DBG "-`find-system' doesn't make the new system loaded") (assert (not (component-loaded-p (registered-system "require-system/preloaded")))) (DBG "-`load-system' does") (load-system "require-system/preloaded") (assert (component-loaded-p (registered-system "require-system/preloaded"))) (DBG "- Function `clear-system' restores registered, preloaded `preloaded-system'") (assert (not (clear-system "require-system/preloaded"))) (assert-equal (component-version (registered-system "require-system/preloaded")) "1.0") (assert (component-loaded-p (registered-system "require-system/preloaded"))) (assert (member "require-system/preloaded" (already-loaded-systems) :test #'equal)) (DBG "- Function `require-system' doesn't overwrite `preloaded-system'") (require-system "require-system/preloaded") (assert-equal (component-version (registered-system "require-system/preloaded")) "1.0") (DBG "- Function `require-system' doesn't trigger a side-effect reloading system") ;;; `require-system' called `load-system' regardless if the system was ;;; loaded or not. While the `:force' and `:force-not' flags were ;;; handled correctly, `load-system' had a nasty side-effect which ;;; were overwriting our system loaded in-memory, so the second ;;; `require-system' loaded the new `asd'-defined system. (require-system "require-system/preloaded") (assert-equal (component-version (registered-system "require-system/preloaded")) "1.0") (DBG "- System `preloaded-system' won't be reloaded on `require-system' when cache is empty") (reset-session) (assert-equal (component-version (registered-system "require-system/preloaded")) "1.0") (require-system "require-system/preloaded") (assert-equal (component-version (registered-system "require-system/preloaded")) "1.0") (DBG "- Function `load-system' overwrites `preloaded-system'") (load-system "require-system/preloaded") (assert-equal (component-version (registered-system "require-system/preloaded")) "2.0") (DBG "- Update the preloaded system version after loading from asd") (register-preloaded-system "require-system/preloaded") (assert-equal (component-version (registered-system "require-system/preloaded")) "2.0") (assert (not (clear-system "require-system/preloaded"))) (assert-equal (component-version (registered-system "require-system/preloaded")) "2.0") ;; Not implemented: #| (deregister-preloaded-system "require-system/preloaded") (assert-equal (component-version (registered-system "require-system/preloaded")) "2.0") (assert (clear-system "require-system/preloaded")) (assert (not (registered-system "require-system/preloaded"))) |# (DBG "---- Tests related to the behavior of immutable systems") (DBG "- Test function `register-immutable-system'") ;; Note: it's not immutable *yet*, but loaded from file. (assert-equal (component-version (registered-system "require-system/immutable")) "2.0") (clear-system "require-system/immutable") (def-test-system "require-system/immutable" :version "1.0" :depends-on ("require-system/not-loaded") :components ((:file "file1"))) (assert (not (component-loaded-p "require-system/immutable"))) (assert-equal (component-version (registered-system "require-system/immutable")) "1.0") (let ((system (registered-system "require-system/immutable"))) (register-immutable-system "require-system/immutable") (assert (eq system (registered-system "require-system/immutable")))) (assert (eq 'system (type-of (registered-system "require-system/immutable")))) (assert-equal 1 (length (component-children (registered-system "require-system/immutable")))) (assert (not (component-loaded-p "require-system/immutable"))) ;; *not* marked loaded (assert-equal (component-version (registered-system "require-system/immutable")) "1.0") (DBG "- Function `require-system' doesn't overwrite `immutable-system'") (require-system "require-system/immutable") (assert-equal (component-version (registered-system "require-system/immutable")) "1.0") (assert (not (component-loaded-p "require-system/immutable"))) ;; *not* marked loaded (DBG "- Function `load-system' doesn't overwrite `immutable-system'") (load-system "require-system/immutable") (assert-equal (component-version (registered-system "require-system/immutable")) "1.0") (assert (not (component-loaded-p "require-system/immutable"))) ;; *not* marked loaded (DBG "- Function `load-system' doesn't load an immutable system's dependencies") (assert (not (component-loaded-p "require-system/not-loaded"))) ;; *not* marked loaded (DBG "- Function `clear-system' leaves `immutable-system' loaded, but clears build information") (assert-equal 1 (length (component-children (registered-system "require-system/immutable")))) (assert (not (component-loaded-p "require-system/immutable"))) ;; still not marked loaded (clear-system "require-system/immutable") (assert-equal (component-version (registered-system "require-system/immutable")) "1.0") (assert-equal 0 (length (component-children (registered-system "require-system/immutable")))) (assert (component-loaded-p "require-system/immutable")) ;; *YES* marked loaded! (DBG "- System `immutable-system' won't be reloaded when cache is empty") (reset-session) (load-system "require-system/immutable") (assert-equal (component-version (registered-system "require-system/immutable")) "1.0") (DBG "---- Tests related to the behavior of ordinary systems") (DBG "- Require-system doesn't replace already loaded system") (def-test-system "require-system/ordinary" :version "1.0") (asdf::mark-component-preloaded "require-system/ordinary") (assert (component-loaded-p "require-system/ordinary")) (require-system "require-system/ordinary") (assert-equal (component-version (registered-system "require-system/ordinary")) "1.0") (DBG "- Load-system loads system from the disk") (reset-session) (load-system "require-system/ordinary") (assert-equal (component-version (registered-system "require-system/ordinary")) "2.0") ;;; ASDF assumes that if a same-named system can be found by find-system, then ;;; it overrides any same-named implementation-dependent module (after downcasing) ;;; specified via (:require ...), so as to avoid recursive calls to asdf:operate from ;;; within plan execution, and any double-loading or infinite loop that could result. ;;; ;;; That means that we can't "just" test the (:require ...) feature portably by ;;; relying on the ASDF hook into CL:REQUIRE that many implementations provide. #+clisp (defparameter *dynmod-list* (mapcar 'pathname-name (directory-files (subpathname (lisp-implementation-directory) "dynmod/") "*.lisp"))) (defparameter *mod* (or #+abcl :abcl-contrib #+allegro :sax #+clisp (first (remove "asdf" *dynmod-list* :test 'equal)) #+(or clozure cmucl) :defsystem #+ecl :sockets #+lispworks "comm" #+mkcl :walker #+sbcl :sb-md5 #+scl :http-library)) (unless *mod* (leave-test "This implementation doesn't provide a known module" 0)) ;; Prevent ASDF from finding the modules as ASDF systems on ECL, MKCL, SBCL (and maybe more). (setf asdf::*system-definition-search-functions* (remove 'asdf::sysdef-source-registry-search asdf::*system-definition-search-functions*)) (asdf::clear-registered-systems) (reset-session) (defun has-module-p (x) ;; note that the spec is case-sensitive, but we'll cast a wider net. (and (member x *modules* :test 'string-equal) t)) (DBG :before *modules*) (assert (not (find-system *mod* nil))) (assert (not (has-module-p *mod*))) (eval `(def-test-system :require-test :depends-on ((:require ,*mod*)))) (load-system :require-test) (DBG :after *modules*) (assert (has-module-p *mod*))