-
Notifications
You must be signed in to change notification settings - Fork 35
/
test-configuration.script
161 lines (138 loc) · 6.1 KB
/
test-configuration.script
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
;;; -*- Lisp -*-
(in-package :asdf)
(use-package :asdf-test)
(import '(asdf-test::DBG))
(defparameter *tmp-directory* (subpathname *asdf-directory* "build/"))
(setf *central-registry* nil)
(defun under-tmp-directory (designator &optional (defaults *tmp-directory*))
(namestring (subpathname defaults designator)))
(defun create-conf-files (&optional (path *tmp-directory*))
(let ((v `(("conf.d/conf1.conf"
((:directory ,(under-tmp-directory "dir1/"))))
("conf.d/conf2.conf"
((:tree ,(under-tmp-directory "dir2/"))))
;; this is for testing the :here directive
("dir5/conf.conf"
((:directory (:here "dir6"))))
("dir8/conf.conf"
((:directory (:here))))
("dir9/dira/conf.conf"
((:tree (:here)))))))
(loop
:for (file contents) :in v
:for name = (under-tmp-directory file path)
:do
(ensure-directories-exist name)
(with-open-file (out name
:direction :output
:if-exists :supersede)
(with-standard-io-syntax
(format out "~{~S~%~}" contents))))))
(defparameter *tmp-asd-directories*
(loop
:for dir
:in '("dir1/" ; foo0
"dir2/dir3/" ; foo1
"dir2/dir4/" ; foo2
"dir2/" ; foo3
;; system here should be found because of :here directive
"dir5/dir6/" ; foo4
;; system here should /not/ be found because of :here directive
"dir5/dir7/" ; foo5
"dir8/" ; foo6
"dir9/dira/" ; foo7 should be found because of :here :tree
"dir9/dira/dirc/" ; foo8 ditto
"dir9/dirb/") ; foo9 should /not/ be found -- not under :here :tree
:collect (under-tmp-directory dir)))
(defun create-asd-files ()
(loop
:for d :in *tmp-asd-directories*
:for i :from 0 :do
(ensure-directories-exist d)
(with-open-file (s (merge-pathnames* (format nil "foo~D.asd" i) d)
:direction :output
:if-exists :supersede
:if-does-not-exist :create)
(format s "(defsystem :foo~D)~%" i))))
(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)
(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/"))))
(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))
(defun dump-source-registry ()
(format t "~&Source Registry:~%")
(loop :for k :being :each hash-key :of *source-registry*
:using (hash-value v)
:do (format t "~a --> ~a~%" k v)))
(dump-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"))
(DBG "Testing link farm found through source registry.")
(defparameter *link-farm-directory* (under-tmp-directory "link-farm/"))
(defun link-asd-files ()
(loop
:for d :in *tmp-asd-directories*
:for i :from 0
:as asd-file = (merge-pathnames* (format nil "foo~D.asd" i) d)
:do (assert (probe-file asd-file))
(run-program (format nil "ln -s ~a ~a" (namestring asd-file) (namestring *link-farm-directory*)))))
;;; prepare for link farm test
;; clean up first
(describe *link-farm-directory*)
(when (uiop:directory-exists-p *link-farm-directory*)
(uiop:delete-directory-tree *link-farm-directory*
:validate (lambda (x) (subpathp x *tmp-directory*))))
;; create the link farm
(ensure-directories-exist *link-farm-directory*)
(link-asd-files)
;;; test following symlinks
(initialize-source-registry
`(:source-registry (:include ,(namestring *link-farm-directory*))
:ignore-inherited-configuration))
(dump-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)))