Commit 8c10cdbc authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Include tests for require-system

Based on a contribution by Daniel Kochmanski in gitlab MR !13.
parent 0e27f08f
(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"))
......@@ -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
......
;; -*- 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*))
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