From 8c10cdbc6a08b4d35ca2272d7864a4d912de2b60 Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <fare@tunes.org>
Date: Thu, 15 Sep 2016 20:50:45 -0400
Subject: [PATCH] Include tests for require-system

Based on a contribution by Daniel Kochmanski in gitlab MR !13.
---
 test/require-system.asd  |  20 ++++
 test/script-support.lisp |   7 +-
 test/test-require.script | 193 +++++++++++++++++++++++++++++++++++++++
 3 files changed, 219 insertions(+), 1 deletion(-)
 create mode 100644 test/require-system.asd
 create mode 100644 test/test-require.script

diff --git a/test/require-system.asd b/test/require-system.asd
new file mode 100644
index 000000000..638ef3d10
--- /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 0f3289576..f47482433 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 000000000..d0f3481a8
--- /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*))
-- 
GitLab