Commit f5bfb0a6 authored by Robert Goldman's avatar Robert Goldman
Browse files

Merge branch 'master' of

parents 50caf4c3 61a7924d
......@@ -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))
(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)
......@@ -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.")
(split-native-pathnames-string (join-namestrings '("foo" "bar")))
'(#p"foo" #p"bar"))
(DBG "Second pathname test.")
(split-native-pathnames-string (join-namestrings '("foo" "bar")) :ensure-directory t)
'(#p"foo/" #p"bar/"))
(DBG "Third pathname test.")
(split-native-pathnames-string (join-namestrings '("/foo" "/bar")) :want-absolute t)
'(#p"/foo" #p"/bar"))
(DBG "Fourth pathname test.")
(split-native-pathnames-string (join-namestrings '("/foo" "/bar"))
:want-absolute t :ensure-directory t)
'(#p"/foo/" #p"/bar/"))
(DBG "Fifth pathname test.")
(mapcar 'location-function-p
'((:function f)
......@@ -213,8 +218,8 @@
(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/")
......@@ -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")
Supports Markdown
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