Commit 19afd715 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Improve tests on Windows, again.

parent c69a7d2a
......@@ -27,7 +27,7 @@ Some constraints:
#:leave-test #:def-test-system
#:action-name #:in-plan-p
#:test-source #:test-fasl #:resolve-output #:output-location
#:quietly))
#:quietly #:join-namestrings))
(in-package :asdf-test)
......@@ -601,6 +601,12 @@ is bound, write a message and exit on an error. If
(assert (asymval '#:*file1* :test-package))
(assert (asymval '#:*file3* :test-package))))
(defun join-namestrings (namestrings)
(with-output-to-string (s)
(loop :with separator = (acall :inter-directory-separator)
:for (n . morep) :on namestrings
:do (format s "~A~@[~C~]" n (and morep separator)))))
;; These are shorthands for interactive debugging of test scripts:
(!a
common-lisp-user::debug-asdf debug-asdf
......
......@@ -50,12 +50,6 @@
"dir9/dirb/") ; foo9 should /not/ be found -- not under :here :tree
:collect (under-tmp-directory dir)))
(defparameter *separator* (inter-directory-separator))
(defun join-namestrings (namestrings)
(with-output-to-string (s)
(loop :for (n . morep) :on namestrings
:do (format s "~A~@[~C~]" n (and morep *separator*)))))
(defun create-asd-files ()
(loop
:for d :in *tmp-asd-directories*
......@@ -67,55 +61,54 @@
:if-does-not-exist :create)
(format s "(defsystem :foo~D)~%" i))))
(progn
(assert-equal (asdf::parse-output-translations-string
(join-namestrings '("/foo" "/bar" "" "/baz" "/quux")))
'(:output-translations ("/foo" "/bar") :inherit-configuration
("/baz" "/quux")))
(assert-equal (asdf::parse-output-translations-string
(join-namestrings '("/" "")))
'(:output-translations ("/" nil) :ignore-inherited-configuration))
(assert-equal (asdf::parse-output-translations-string
(join-namestrings '("/" "" "")))
'(:output-translations ("/" nil) :inherit-configuration))
(assert-equal (asdf::parse-output-translations-string
(join-namestrings '("/" "/")))
'(:output-translations ("/" "/") :ignore-inherited-configuration))
(assert-equal (asdf::parse-output-translations-string
"(:output-translations (\"/\" \"/\") :ignore-inherited-configuration)")
'(:output-translations ("/" "/") :ignore-inherited-configuration))
(assert-equal (asdf::parse-output-translations-string
(join-namestrings '("/foo" "/bar" "" "/baz" "/quux")))
'(:output-translations ("/foo" "/bar") :inherit-configuration
("/baz" "/quux")))
(assert-equal (asdf::parse-output-translations-string
(join-namestrings '("/" "")))
'(:output-translations ("/" nil) :ignore-inherited-configuration))
(assert-equal (asdf::parse-output-translations-string
(join-namestrings '("/" "" "")))
'(:output-translations ("/" nil) :inherit-configuration))
(assert-equal (asdf::parse-output-translations-string
(join-namestrings '("/" "/")))
'(:output-translations ("/" "/") :ignore-inherited-configuration))
(assert-equal (asdf::parse-output-translations-string
"(:output-translations (\"/\" \"/\") :ignore-inherited-configuration)")
'(:output-translations ("/" "/") :ignore-inherited-configuration))
(create-asd-files)
(create-conf-files)
(create-asd-files)
(create-conf-files)
(format t "~&subdirectories of dir2/: ~S~%" (subdirectories (under-tmp-directory "dir2/")))
(assert-equal 2 (length (subdirectories (under-tmp-directory "dir2/"))))
(format t "~&subdirectories of dir2/: ~S~%" (subdirectories (under-tmp-directory "dir2/")))
(assert-equal 2 (length (subdirectories (under-tmp-directory "dir2/"))))
(format t "~&subdirectories of dir5/: ~S~%" (subdirectories (under-tmp-directory "dir5/")))
(assert-equal 2 (length (subdirectories (under-tmp-directory "dir5/"))))
(format t "~&subdirectories of dir5/: ~S~%" (subdirectories (under-tmp-directory "dir5/")))
(assert-equal 2 (length (subdirectories (under-tmp-directory "dir5/"))))
(initialize-source-registry
`(:source-registry (:include ,(under-tmp-directory "conf.d/"))
(:include ,(under-tmp-directory "dir5/"))
(:include ,(under-tmp-directory "dir8/"))
(:include ,(under-tmp-directory "dir9/dira/"))
:ignore-inherited-configuration))
(initialize-source-registry
`(:source-registry (:include ,(under-tmp-directory "conf.d/"))
(:include ,(under-tmp-directory "dir5/"))
(:include ,(under-tmp-directory "dir8/"))
(:include ,(under-tmp-directory "dir9/dira/"))
:ignore-inherited-configuration))
(format t "~&Source Registry: ~S~%"
asdf::*source-registry*)
(assert (find-system :foo0 nil))
(assert (find-system :foo1 nil))
(assert (find-system :foo2 nil))
(assert (find-system :foo3 nil))
(assert (find-system :foo4 nil))
(assert (not (find-system :foo5 nil)))
(assert (find-system :foo6 nil))
(assert (find-system :foo7 nil))
(assert (find-system :foo8 nil))
(assert (not (find-system :foo9 nil)))
(format t "~&Source Registry: ~S~%"
asdf::*source-registry*)
(assert (find-system :foo0 nil))
(assert (find-system :foo1 nil))
(assert (find-system :foo2 nil))
(assert (find-system :foo3 nil))
(assert (find-system :foo4 nil))
(assert (not (find-system :foo5 nil)))
(assert (find-system :foo6 nil))
(assert (find-system :foo7 nil))
(assert (find-system :foo8 nil))
(assert (not (find-system :foo9 nil)))
(format t "~&A: ~S~%B: ~S~%"
(namestring (system-relative-pathname :foo3 "bar/baz.lisp"))
(under-tmp-directory "dir2/bar/baz.lisp"))
(assert-equal (namestring (system-relative-pathname :foo3 "bar/baz.lisp"))
(under-tmp-directory "dir2/bar/baz.lisp")))
(format t "~&A: ~S~%B: ~S~%"
(namestring (system-relative-pathname :foo3 "bar/baz.lisp"))
(under-tmp-directory "dir2/bar/baz.lisp"))
(assert-equal (namestring (system-relative-pathname :foo3 "bar/baz.lisp"))
(under-tmp-directory "dir2/bar/baz.lisp"))
......@@ -42,16 +42,16 @@
(assert
(not (version-satisfies (asdf-version) "666")))
(assert-pathnames-equal
(split-native-pathnames-string "foo:bar")
(split-native-pathnames-string (join-namestrings '("foo" "bar")))
'(#p"foo" #p"bar"))
(assert-pathnames-equal
(split-native-pathnames-string "foo:bar" :ensure-directory t)
(split-native-pathnames-string (join-namestrings '("foo" "bar")) :ensure-directory t)
'(#p"foo/" #p"bar/"))
(assert-pathnames-equal
(split-native-pathnames-string (strcat "/foo" (inter-directory-separator) "/bar") :want-absolute t)
(split-native-pathnames-string (join-namestrings '("/foo" "/bar")) :want-absolute t)
'(#p"/foo" #p"/bar"))
(assert-pathnames-equal
(split-native-pathnames-string (strcat "/foo" (inter-directory-separator) "/bar")
(split-native-pathnames-string (join-namestrings '("/foo" "/bar"))
:want-absolute t :ensure-directory t)
'(#p"/foo/" #p"/bar/"))
(assert-equal
......
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