diff --git a/test/require-system.asd b/test/require-system.asd new file mode 100644 index 0000000000000000000000000000000000000000..638ef3d10668e2c56ddf72d7fb473be728f02cf5 --- /dev/null +++ b/test/require-system.asd @@ -0,0 +1,20 @@ +(defsystem "require-system" :version "2.0" + :depends-on ("require-system/immutable")) + +(defsystem "require-system/preloaded" :version "2.0") +(defsystem "require-system/immutable" :version "2.0") + +(defsystem "require-system/not-loaded" :version "2.0") + +(defsystem "require-system/ordinary" :version "2.0") + +(defsystem "require-system/require" + :version "2.0" + :depends-on ((:require "require-system/module1") + (:require "require-system/module2"))) + +(defsystem "require-system/depends" + :version "2.0" + :depends-on ("test-asdf/module1" + "require-system-module2")) + diff --git a/test/script-support.lisp b/test/script-support.lisp index 0f3289576226b1f59d28e3bb8bdec1fb748b7ca0..f47482433d5c8e9c2bf329f67f9cbbb7538df5fe 100644 --- a/test/script-support.lisp +++ b/test/script-support.lisp @@ -31,7 +31,8 @@ Some constraints: #:leave-test #:def-test-system #:action-name #:in-plan-p #:test-source #:test-fasl #:resolve-output #:output-location - #:quietly #:join-namestrings)) + #:quietly #:join-namestrings + #:clear-cache)) (in-package :asdf-test) @@ -729,6 +730,10 @@ is bound, write a message and exit on an error. If :for (n . morep) :on namestrings :do (format s "~A~@[~C~]" n (and morep separator))))) +(defun clear-cache () + ;; Or, should we preserve the timestamps? + (clrhash (asymval :*asdf-cache*))) + ;; These are shorthands for interactive debugging of test scripts: (!a common-lisp-user::debug-asdf debug-asdf diff --git a/test/test-require.script b/test/test-require.script new file mode 100644 index 0000000000000000000000000000000000000000..d0f3481a8cfac730ea53a5d7aefdf357044ae510 --- /dev/null +++ b/test/test-require.script @@ -0,0 +1,193 @@ +;; -*- 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") +(let ((system (registered-system "test-preloaded-dummy"))) + (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") +(clear-cache) +(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") +(clear-cache) +(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") +(clear-cache) +(load-system "require-system/ordinary") +(assert-equal (component-version (registered-system "require-system/ordinary")) "2.0") + + +;;; We can't actually test portably loading an implementation-dependent module, +;;; because we don't know what modules does implementations ship, so we'll only +;;; test the feature on implementations that support hooking ASDF into CL:REQUIRE +;;; Which is most of the interesting ones, anyway. + +(defparameter *mod* + (or + #+abcl :abcl-contrib + #+allegro :yacc + #+clisp "zlib" ;; Has to be lower case! + #+(or clozure cmucl) :defsystem + #+ecl :ecl-curl + #+lispworks "comm" + #+mkcl :walker + #+sbcl :sb-md5 + #+scl :http-library)) + +(unless *mod* + (leave-test "This implementation doesn't provide a known module" 0)) + +(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)) + +(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) +(assert (has-module-p *mod*))