diff --git a/component.lisp b/component.lisp index ac1c206dc7c12588c7dd0f25b8229c36396fdb76..392607943f2745381e91a61b60ff96a646c0b202 100644 --- a/component.lisp +++ b/component.lisp @@ -272,11 +272,16 @@ children."))) ;;;; version-satisfies (with-upgradability () + ;; short-circuit testing of null version specifications. + ;; this is an all-pass + (defmethod version-satisfies :around ((c t) (version null)) + (declare (ignorable c version)) + t) (defmethod version-satisfies ((c component) version) (unless (and version (slot-boundp c 'version) (component-version c)) (when version (warn "Requested version ~S but ~S has no version" version c)) - (return-from version-satisfies t)) + (return-from version-satisfies nil)) (version-satisfies (component-version c) version)) (defmethod version-satisfies ((cver string) version) diff --git a/test/test-utilities.script b/test/test-utilities.script index 3c5677f17fbbea13987992287dc5fea288c90ee9..f469df4c44ef9faf5f7bf84937a0b74a21fc18fb 100644 --- a/test/test-utilities.script +++ b/test/test-utilities.script @@ -30,7 +30,7 @@ (assert (version-satisfies (asdf-version) (asdf-version))) (assert (version-satisfies (asdf-version) "3.0")) (assert (version-satisfies (asdf-version) "2.0")) -(assert (version-satisfies (find-system :test-asdf) "666")) +(assert (not (version-satisfies (find-system :test-asdf) "666"))) (handler-case (version-satisfies (find-system :test-asdf) "666") (simple-warning (c) (assert (search "Requested version ~S but ~S has no version" (simple-condition-format-control c)))) @@ -39,19 +39,24 @@ (error "version-satisfies must warn when given component without version"))) (assert (version<= "2.0" (asdf-version))) (assert (not (version-satisfies (asdf-version) "666"))) +(DBG "First pathname test.") (assert-pathnames-equal (split-native-pathnames-string (join-namestrings '("foo" "bar"))) '(#p"foo" #p"bar")) +(DBG "Second pathname test.") (assert-pathnames-equal (split-native-pathnames-string (join-namestrings '("foo" "bar")) :ensure-directory t) '(#p"foo/" #p"bar/")) +(DBG "Third pathname test.") (assert-pathnames-equal (split-native-pathnames-string (join-namestrings '("/foo" "/bar")) :want-absolute t) '(#p"/foo" #p"/bar")) +(DBG "Fourth pathname test.") (assert-pathnames-equal (split-native-pathnames-string (join-namestrings '("/foo" "/bar")) :want-absolute t :ensure-directory t) '(#p"/foo/" #p"/bar/")) +(DBG "Fifth pathname test.") (assert-equal (mapcar 'location-function-p '((:function f) @@ -213,8 +218,8 @@ (assert-pathnames-equal (sort directory-b #'string< :key #'(lambda (x) (car (last (pathname-directory x))))) (list (subpathname *build-directory* "deleteme/a/b/c/") - (subpathname *build-directory* "deleteme/a/b/d/") - (subpathname *build-directory* "deleteme/a/b/e/")))) + (subpathname *build-directory* "deleteme/a/b/d/") + (subpathname *build-directory* "deleteme/a/b/e/")))) (delete-empty-directory (subpathname *build-directory* "deleteme/a/b/e/")) (assert (not (directory-exists-p (subpathname *build-directory* "deleteme/a/b/e/")))) (delete-directory-tree (subpathname *build-directory* "deleteme/") diff --git a/test/test-version.script b/test/test-version.script index 6d2319178bc3e4ec80b13120cade0c363d0f3eb4..092387caf5f3c6f51c210b977254a8236f4d263e 100644 --- a/test/test-version.script +++ b/test/test-version.script @@ -13,6 +13,9 @@ (DBG "Check that the fallback system bears the current asdf version") (assert-equal (asdf-version) (component-version *asdf*)) +(def-test-system :unversioned-system + :pathname #.*test-directory*) + (def-test-system :versioned-system-1 :pathname #.*test-directory* :version "1.0") @@ -39,8 +42,19 @@ (defun vtest (name v &optional (true t)) (or (eq true (version-satisfies (find-system name) v)) (error "no satisfaction: ~S version ~A not ~A" name v true))) + (vtest :versioned-system-1 "1.0") (vtest :versioned-system-2 "1.0") (vtest :versioned-system-3 "2.0" nil) (vtest :versioned-system-file-form "1.0") (vtest :versioned-system-file-line "1.0") +;; version UNmatching +(vtest :unversioned-system "1" nil) +(vtest :versioned-system-1 "1.1" nil) +(vtest :versioned-system-2 "1.1" t) +(vtest :versioned-system-2 "1.1.1" nil) +(vtest :versioned-system-2 "1.2" nil) +(vtest :versioned-system-3 "1.2") +(vtest :versioned-system-3 "1.1") +(vtest :versioned-system-3 "1.1.1") +